ghc 9.0.2 → 9.2.1

raw patch · 588 files changed

+134220/−106864 lines, 588 filesdep +parsecdep +unbuildabledep −ghc-boot-thdep ~basedep ~bytestringdep ~ghc-bootnew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: parsec, unbuildable

Dependencies removed: ghc-boot-th

Dependency ranges changed: base, bytestring, ghc-boot, ghc-heap, ghci, template-haskell, time

API changes (from Hackage documentation)

- GHC: AnnBlockComment :: String -> AnnotationComment

- GHC: AnnDocCommentNamed :: String -> AnnotationComment

- GHC: AnnDocCommentNext :: String -> AnnotationComment

- GHC: AnnDocCommentPrev :: String -> AnnotationComment

- GHC: AnnDocOptions :: String -> AnnotationComment

- GHC: AnnDocSection :: Int -> String -> AnnotationComment

- GHC: AnnLineComment :: String -> AnnotationComment

- GHC: ApiAnns :: Map ApiAnnKey [RealSrcSpan] -> Maybe RealSrcSpan -> Map RealSrcSpan [RealLocated AnnotationComment] -> [RealLocated AnnotationComment] -> ApiAnns

- GHC: HscAsm :: HscTarget

- GHC: HscC :: HscTarget

- GHC: HscInterpreted :: HscTarget

- GHC: HscLlvm :: HscTarget

- GHC: HscNothing :: HscTarget

- GHC: Opt_ByteCodeIfUnboxed :: GeneralFlag

- GHC: Opt_FlatCache :: GeneralFlag

- GHC: TM_NoInst :: TcRnExprMode

- GHC: [apiAnnComments] :: ApiAnns -> Map RealSrcSpan [RealLocated AnnotationComment]

- GHC: [apiAnnEofPos] :: ApiAnns -> Maybe RealSrcSpan

- GHC: [apiAnnItems] :: ApiAnns -> Map ApiAnnKey [RealSrcSpan]

- GHC: [apiAnnRogueComments] :: ApiAnns -> [RealLocated AnnotationComment]

- GHC: [cachedPlugins] :: DynFlags -> [LoadedPlugin]

- GHC: [canGenerateDynamicToo] :: DynFlags -> IORef Bool

- GHC: [cfgWeightInfo] :: DynFlags -> CfgWeights

- GHC: [dirsToClean] :: DynFlags -> IORef (Map FilePath FilePath)

- GHC: [dump_action] :: DynFlags -> DumpAction

- GHC: [dynHiSuf] :: DynFlags -> String

- GHC: [dynObjectSuf] :: DynFlags -> String

- GHC: [dynOutputFile] :: DynFlags -> Maybe String

- GHC: [filesToClean] :: DynFlags -> IORef FilesToClean

- GHC: [generatedDumps] :: DynFlags -> IORef (Set FilePath)

- GHC: [hiSuf] :: DynFlags -> String

- GHC: [homeUnitId] :: DynFlags -> UnitId

- GHC: [homeUnitInstanceOfId] :: DynFlags -> Maybe IndefUnitId

- GHC: [homeUnitInstantiations] :: DynFlags -> [(ModuleName, Module)]

- GHC: [hooks] :: DynFlags -> Hooks

- GHC: [hscTarget] :: DynFlags -> HscTarget

- GHC: [log_action] :: DynFlags -> LogAction

- GHC: [mainModIs] :: DynFlags -> Module

- GHC: [mi_complete_sigs] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceCompleteMatch]

- GHC: [nextTempSuffix] :: DynFlags -> IORef Int

- GHC: [objectSuf] :: DynFlags -> String

- GHC: [outputFile] :: DynFlags -> Maybe String

- GHC: [platformConstants] :: DynFlags -> PlatformConstants

- GHC: [pm_annotations] :: ParsedModule -> ApiAnns

- GHC: [staticPlugins] :: DynFlags -> [StaticPlugin]

- GHC: [trace_action] :: DynFlags -> TraceAction

- GHC: [ufCreationThreshold] :: DynFlags -> Int

- GHC: [ufDearOp] :: DynFlags -> Int

- GHC: [ufDictDiscount] :: DynFlags -> Int

- GHC: [ufFunAppDiscount] :: DynFlags -> Int

- GHC: [ufUseThreshold] :: DynFlags -> Int

- GHC: [ufVeryAggressive] :: DynFlags -> Bool

- GHC: [unitDatabases] :: DynFlags -> Maybe [UnitDatabase UnitId]

- GHC: [unitState] :: DynFlags -> UnitState

- GHC: [ways] :: DynFlags -> Set Way

- GHC: data AnnotationComment

- GHC: data ApiAnns

- GHC: data HscTarget

- GHC: defaultObjectTarget :: DynFlags -> HscTarget

- GHC: getAndRemoveAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> ([RealSrcSpan], ApiAnns)

- GHC: getAndRemoveAnnotationComments :: ApiAnns -> RealSrcSpan -> ([RealLocated AnnotationComment], ApiAnns)

- GHC: getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]

- GHC: getAnnotationComments :: ApiAnns -> RealSrcSpan -> [RealLocated AnnotationComment]

- GHC: setLogAction :: GhcMonad m => LogAction -> m ()

- GHC: splitForAllTys :: Type -> ([TyCoVar], Type)

- GHC: type ApiAnnKey = (RealSrcSpan, AnnKeywordId)

- GHC: unicodeAnn :: AnnKeywordId -> AnnKeywordId

- GHC.Builtin.Names: isLabelClassName :: Name

- GHC.Builtin.Names: isLabelClassNameKey :: Unique

- GHC.Builtin.Names: liftedConKey :: Unique

- GHC.Builtin.Names: liftedRepDataConKey :: Unique

- GHC.Builtin.Names: mAIN :: Module

- GHC.Builtin.Names: ntTyConKey :: Unique

- GHC.Builtin.Names: typeNatKindConNameKey :: Unique

- GHC.Builtin.Names: typeNatLeqTyFamNameKey :: Unique

- GHC.Builtin.Names: unliftedConKey :: Unique

- GHC.Builtin.Names: unliftedRepDataConKeys :: [Unique]

- GHC.Builtin.Names: unliftedSimpleRepDataConKeys :: [Unique]

- GHC.Builtin.Names: voidPrimTyConKey :: Unique

- GHC.Builtin.PrimOps: Addr2IntOp :: PrimOp

- GHC.Builtin.PrimOps: AndIOp :: PrimOp

- GHC.Builtin.PrimOps: AndOp :: PrimOp

- GHC.Builtin.PrimOps: Double2FloatOp :: PrimOp

- GHC.Builtin.PrimOps: Double2IntOp :: PrimOp

- GHC.Builtin.PrimOps: Float2DoubleOp :: PrimOp

- GHC.Builtin.PrimOps: Float2IntOp :: PrimOp

- GHC.Builtin.PrimOps: ISllOp :: PrimOp

- GHC.Builtin.PrimOps: ISraOp :: PrimOp

- GHC.Builtin.PrimOps: ISrlOp :: PrimOp

- GHC.Builtin.PrimOps: Int16Extend :: PrimOp

- GHC.Builtin.PrimOps: Int16Narrow :: PrimOp

- GHC.Builtin.PrimOps: Int2AddrOp :: PrimOp

- GHC.Builtin.PrimOps: Int2DoubleOp :: PrimOp

- GHC.Builtin.PrimOps: Int2FloatOp :: PrimOp

- GHC.Builtin.PrimOps: Int2WordOp :: PrimOp

- GHC.Builtin.PrimOps: Int8Extend :: PrimOp

- GHC.Builtin.PrimOps: Int8Narrow :: PrimOp

- GHC.Builtin.PrimOps: NotIOp :: PrimOp

- GHC.Builtin.PrimOps: NotOp :: PrimOp

- GHC.Builtin.PrimOps: OrIOp :: PrimOp

- GHC.Builtin.PrimOps: OrOp :: PrimOp

- GHC.Builtin.PrimOps: SllOp :: PrimOp

- GHC.Builtin.PrimOps: SrlOp :: PrimOp

- GHC.Builtin.PrimOps: Word16Extend :: PrimOp

- GHC.Builtin.PrimOps: Word16Narrow :: PrimOp

- GHC.Builtin.PrimOps: Word2DoubleOp :: PrimOp

- GHC.Builtin.PrimOps: Word2FloatOp :: PrimOp

- GHC.Builtin.PrimOps: Word2IntOp :: PrimOp

- GHC.Builtin.PrimOps: Word8Extend :: PrimOp

- GHC.Builtin.PrimOps: Word8Narrow :: PrimOp

- GHC.Builtin.PrimOps: XorIOp :: PrimOp

- GHC.Builtin.PrimOps: XorOp :: PrimOp

- GHC.Builtin.RebindableNames: reboundIfSymbol :: FastString

- GHC.Builtin.Types: liftedRepDataCon :: DataCon

- GHC.Builtin.Types: liftedRepDataConTy :: Type

- GHC.Builtin.Types: liftedRepDataConTyCon :: TyCon

- GHC.Builtin.Types: typeNatKind :: Kind

- GHC.Builtin.Types: typeNatKindCon :: TyCon

- GHC.Builtin.Types: unliftedRepDataConTy :: Type

- GHC.Builtin.Types: word8TyConName :: Name

- GHC.Builtin.Types.Literals: typeNatLeqTyCon :: TyCon

- GHC.Builtin.Types.Prim: multiplicityTyVar :: TyVar

- GHC.Builtin.Types.Prim: voidPrimTy :: Type

- GHC.Builtin.Types.Prim: voidPrimTyCon :: TyCon

- GHC.ByteCode.Instr: RETURN_UBX :: ArgRep -> BCInstr

- GHC.Cmm.CLabel: instance GHC.Show.Show GHC.Cmm.CLabel.IdLabelInfo

- GHC.Cmm.Dataflow.Collections: type family KeyOf map;

- GHC.Cmm.DebugBlock: instance GHC.Utils.Outputable.Outputable GHC.Cmm.DebugBlock.DebugBlock

- GHC.Cmm.DebugBlock: instance GHC.Utils.Outputable.Outputable GHC.Cmm.DebugBlock.UnwindExpr

- GHC.Cmm.DebugBlock: instance GHC.Utils.Outputable.Outputable GHC.Cmm.DebugBlock.UnwindPoint

- GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Info.Build.CAFLabel

- GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Info.Build.ModuleSRTInfo

- GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Info.Build.SRTEntry

- GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Info.Build.SomeLabel

- GHC.Cmm.Lint: instance GHC.Driver.Session.HasDynFlags GHC.Cmm.Lint.CmmLint

- GHC.Cmm.Monad: PD :: (DynFlags -> PState -> ParseResult a) -> PD a

- GHC.Cmm.Monad: [unPD] :: PD a -> DynFlags -> PState -> ParseResult a

- GHC.Cmm.Monad: failMsgPD :: String -> PD a

- GHC.Cmm.Monad: instance GHC.Base.Applicative GHC.Cmm.Monad.PD

- GHC.Cmm.Monad: instance GHC.Base.Functor GHC.Cmm.Monad.PD

- GHC.Cmm.Monad: instance GHC.Base.Monad GHC.Cmm.Monad.PD

- GHC.Cmm.Monad: instance GHC.Driver.Session.HasDynFlags GHC.Cmm.Monad.PD

- GHC.Cmm.Monad: liftP :: P a -> PD a

- GHC.Cmm.Monad: newtype PD a

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.C GHC.Cmm.Dataflow.Block.C)

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.C GHC.Cmm.Dataflow.Block.O)

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.O GHC.Cmm.Dataflow.Block.C)

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.O GHC.Cmm.Dataflow.Block.O)

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.Dataflow.Graph.Graph GHC.Cmm.Node.CmmNode e x)

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.Node.CmmNode e x)

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CmmGraph

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CmmTopInfo

- GHC.Cmm.Ppr: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Node.ForeignTarget

- GHC.Cmm.Ppr.Decl: instance (GHC.Utils.Outputable.Outputable d, GHC.Utils.Outputable.Outputable info, GHC.Utils.Outputable.Outputable i) => GHC.Utils.Outputable.Outputable (GHC.Cmm.GenCmmDecl d info i)

- GHC.Cmm.Ppr.Decl: instance GHC.Utils.Outputable.Outputable (GHC.Cmm.GenCmmStatics a)

- GHC.Cmm.Ppr.Decl: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CmmInfoTable

- GHC.Cmm.Ppr.Decl: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CmmStatic

- GHC.Cmm.Ppr.Decl: writeCmms :: (Outputable info, Outputable g) => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()

- GHC.Cmm.Ppr.Expr: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Expr.CmmExpr

- GHC.Cmm.Ppr.Expr: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Expr.CmmLit

- GHC.Cmm.Switch: targetSupportsSwitch :: HscTarget -> Bool

- GHC.Cmm.Utils: slotForeignHint :: SlotTy -> ForeignHint

- GHC.CmmToAsm: x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest

- GHC.CmmToAsm.Config: [ncgDebugLevel] :: NCGConfig -> !Int

- GHC.CmmToAsm.Config: [ncgSpillPreallocSize] :: NCGConfig -> !Int

- GHC.CmmToAsm.Dwarf.Constants: dW_AT_MIPS_linkage_name :: Word

- GHC.CmmToAsm.Dwarf.Types: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.Dwarf.Types.DwarfFrameBlock

- GHC.CmmToAsm.Instr: BasicBlock :: BlockId -> [i] -> GenBasicBlock i

- GHC.CmmToAsm.Instr: ListGraph :: [GenBasicBlock i] -> ListGraph i

- GHC.CmmToAsm.Instr: blockId :: GenBasicBlock i -> BlockId

- GHC.CmmToAsm.Instr: data GenBasicBlock i

- GHC.CmmToAsm.Instr: entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]

- GHC.CmmToAsm.Instr: newtype ListGraph i

- GHC.CmmToAsm.Instr: topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i

- GHC.CmmToAsm.Instr: type NatBasicBlock instr = GenBasicBlock instr

- GHC.CmmToAsm.Instr: type NatCmm instr = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) (ListGraph instr)

- GHC.CmmToAsm.Instr: type NatCmmDecl statics instr = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)

- GHC.CmmToAsm.Monad: [natm_dflags] :: NatM_State -> DynFlags

- GHC.CmmToAsm.Monad: [natm_this_module] :: NatM_State -> Module

- GHC.CmmToAsm.Monad: getDynFlags :: HasDynFlags m => m DynFlags

- GHC.CmmToAsm.Monad: initConfig :: DynFlags -> NCGConfig

- GHC.CmmToAsm.Monad: instance GHC.Driver.Session.HasDynFlags GHC.CmmToAsm.Monad.NatM

- GHC.CmmToAsm.PIC: getThisModule :: CmmMakeDynamicReferenceM m => m Module

- GHC.CmmToAsm.PPC.Instr: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.PPC.Instr.Instr

- GHC.CmmToAsm.PPC.Ppr: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.PPC.Instr.Instr

- GHC.CmmToAsm.Ppr: castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8)

- GHC.CmmToAsm.Ppr: castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)

- GHC.CmmToAsm.Ppr: floatToBytes :: Float -> [Int]

- GHC.CmmToAsm.Reg.Graph.Stats: instance (GHC.Utils.Outputable.Outputable statics, GHC.Utils.Outputable.Outputable instr) => GHC.Utils.Outputable.Outputable (GHC.CmmToAsm.Reg.Graph.Stats.RegAllocStats statics instr)

- GHC.CmmToAsm.Reg.Liveness: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.Reg.Liveness.LiveInfo

- GHC.CmmToAsm.SPARC.Instr: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.SPARC.Instr.Instr

- GHC.CmmToAsm.SPARC.Ppr: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.SPARC.Instr.Instr

- GHC.CmmToAsm.X86.Instr: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.X86.Instr.Instr

- GHC.CmmToAsm.X86.Ppr: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.X86.Instr.Instr

- GHC.CmmToC: writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()

- GHC.CmmToLlvm.Base: liftStream :: Stream IO a x -> Stream LlvmM a x

- GHC.Core: Breakpoint :: !Int -> [id] -> Tickish id

- GHC.Core: CostCentreScope :: TickishScoping

- GHC.Core: HpcTick :: Module -> !Int -> Tickish id

- GHC.Core: NoScope :: TickishScoping

- GHC.Core: PlaceCostCentre :: TickishPlacement

- GHC.Core: PlaceNonLam :: TickishPlacement

- GHC.Core: PlaceRuntime :: TickishPlacement

- GHC.Core: ProfNote :: CostCentre -> !Bool -> !Bool -> Tickish id

- GHC.Core: SoftScope :: TickishScoping

- GHC.Core: SourceNote :: RealSrcSpan -> String -> Tickish id

- GHC.Core: [breakpointFVs] :: Tickish id -> [id]

- GHC.Core: [breakpointId] :: Tickish id -> !Int

- GHC.Core: [profNoteCC] :: Tickish id -> CostCentre

- GHC.Core: [profNoteCount] :: Tickish id -> !Bool

- GHC.Core: [profNoteScope] :: Tickish id -> !Bool

- GHC.Core: [sourceName] :: Tickish id -> String

- GHC.Core: [sourceSpan] :: Tickish id -> RealSrcSpan

- GHC.Core: [tickId] :: Tickish id -> !Int

- GHC.Core: [tickModule] :: Tickish id -> Module

- GHC.Core: data Tickish id

- GHC.Core: data TickishPlacement

- GHC.Core: data TickishScoping

- GHC.Core: instance Data.Data.Data id => Data.Data.Data (GHC.Core.Tickish id)

- GHC.Core: instance GHC.Classes.Eq GHC.Core.TickishPlacement

- GHC.Core: instance GHC.Classes.Eq GHC.Core.TickishScoping

- GHC.Core: instance GHC.Classes.Eq id => GHC.Classes.Eq (GHC.Core.Tickish id)

- GHC.Core: instance GHC.Classes.Ord id => GHC.Classes.Ord (GHC.Core.Tickish id)

- GHC.Core: mkNoCount :: Tickish id -> Tickish id

- GHC.Core: mkNoScope :: Tickish id -> Tickish id

- GHC.Core: tickishCanSplit :: Tickish id -> Bool

- GHC.Core: tickishContains :: Eq b => Tickish b -> Tickish b -> Bool

- GHC.Core: tickishCounts :: Tickish id -> Bool

- GHC.Core: tickishFloatable :: Tickish id -> Bool

- GHC.Core: tickishIsCode :: Tickish id -> Bool

- GHC.Core: tickishPlace :: Tickish id -> TickishPlacement

- GHC.Core: tickishScoped :: Tickish id -> TickishScoping

- GHC.Core: tickishScopesLike :: Tickish id -> TickishScoping -> Bool

- GHC.Core: type Alt b = (AltCon, [b], Expr b)

- GHC.Core: type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)

- GHC.Core.Coercion: NoBlockSubst :: BlockSubstFlag

- GHC.Core.Coercion: YesBlockSubst :: BlockSubstFlag

- GHC.Core.Coercion: [ch_blocker] :: CoercionHole -> BlockSubstFlag

- GHC.Core.Coercion: badCoercionHole :: Type -> Bool

- GHC.Core.Coercion: badCoercionHoleCo :: Coercion -> Bool

- GHC.Core.Coercion: data BlockSubstFlag

- GHC.Core.ConLike: conLikeWrapId_maybe :: ConLike -> Maybe Id

- GHC.Core.DataCon: [flIsOverloaded] :: FieldLbl a -> Bool

- GHC.Core.DataCon: data FieldLbl a

- GHC.Core.DataCon: isUnboxedSumCon :: DataCon -> Bool

- GHC.Core.DataCon: isUnboxedTupleCon :: DataCon -> Bool

- GHC.Core.DataCon: type FieldLabel = FieldLbl Name

- GHC.Core.FVs: idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet

- GHC.Core.FVs: ruleRhsFreeIds :: CoreRule -> VarSet

- GHC.Core.FamInstEnv: flattenTys :: InScopeSet -> [Type] -> [Type]

- GHC.Core.Map: (>.>) :: (a -> b) -> (b -> c) -> a -> c

- GHC.Core.Map: (|>) :: a -> (a -> b) -> b

- GHC.Core.Map: (|>>) :: TrieMap m2 => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) -> (m2 a -> m2 a) -> m1 (m2 a) -> m1 (m2 a)

- GHC.Core.Map: alterTM :: forall b. TrieMap m => Key m -> XT b -> m b -> m b

- GHC.Core.Map: class TrieMap m where {

- GHC.Core.Map: data CmEnv

- GHC.Core.Map: data CoreMap a

- GHC.Core.Map: data GenMap m a

- GHC.Core.Map: data ListMap m a

- GHC.Core.Map: data LooseTypeMap a

- GHC.Core.Map: data MaybeMap m a

- GHC.Core.Map: data TypeMap a

- GHC.Core.Map: deleteTM :: TrieMap m => Key m -> m a -> m a

- GHC.Core.Map: emptyCoreMap :: CoreMap a

- GHC.Core.Map: emptyTM :: TrieMap m => m a

- GHC.Core.Map: emptyTypeMap :: TypeMap a

- GHC.Core.Map: extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a

- GHC.Core.Map: extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a

- GHC.Core.Map: extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a

- GHC.Core.Map: foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b

- GHC.Core.Map: foldTM :: TrieMap m => (a -> b -> b) -> m a -> b -> b

- GHC.Core.Map: foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b

- GHC.Core.Map: infixr 1 |>>

- GHC.Core.Map: insertTM :: TrieMap m => Key m -> a -> m a -> m a

- GHC.Core.Map: instance GHC.Classes.Eq (GHC.Core.Map.DeBruijn GHC.Core.CoreAlt)

- GHC.Core.Map: instance GHC.Classes.Eq (GHC.Core.Map.DeBruijn GHC.Core.CoreExpr)

- GHC.Core.Map: instance GHC.Classes.Eq (GHC.Core.Map.DeBruijn GHC.Core.TyCo.Rep.Coercion)

- GHC.Core.Map: instance GHC.Classes.Eq (GHC.Core.Map.DeBruijn GHC.Core.TyCo.Rep.Type)

- GHC.Core.Map: instance GHC.Classes.Eq (GHC.Core.Map.DeBruijn a) => GHC.Classes.Eq (GHC.Core.Map.DeBruijn (GHC.Maybe.Maybe a))

- GHC.Core.Map: instance GHC.Classes.Eq (GHC.Core.Map.DeBruijn a) => GHC.Classes.Eq (GHC.Core.Map.DeBruijn [a])

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.AltMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.BndrMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.CoercionMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.CoercionMapX

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.CoreMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.CoreMapX

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.LooseTypeMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.TyLitMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.TypeMap

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.TypeMapX

- GHC.Core.Map: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.VarMap

- GHC.Core.Map: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Core.Map.CoreMap a)

- GHC.Core.Map: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Core.Map.TypeMapG a)

- GHC.Core.Map: lkDFreeVar :: Var -> DVarEnv a -> Maybe a

- GHC.Core.Map: lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a

- GHC.Core.Map: lookupCME :: CmEnv -> Var -> Maybe BoundVar

- GHC.Core.Map: lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a

- GHC.Core.Map: lookupTM :: forall b. TrieMap m => Key m -> m b -> Maybe b

- GHC.Core.Map: lookupTypeMap :: TypeMap a -> Type -> Maybe a

- GHC.Core.Map: lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a

- GHC.Core.Map: mapTM :: TrieMap m => (a -> b) -> m a -> m b

- GHC.Core.Map: mkDeBruijnContext :: [Var] -> CmEnv

- GHC.Core.Map: type LiteralMap a = Map Literal a

- GHC.Core.Map: type XT a = Maybe a -> Maybe a

- GHC.Core.Map: type family Key m :: Type;

- GHC.Core.Map: xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a

- GHC.Core.Map: xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a

- GHC.Core.Map: }

- GHC.Core.Opt.Arity: ABot :: Arity -> ArityType

- GHC.Core.Opt.Arity: ATop :: [OneShotInfo] -> ArityType

- GHC.Core.Opt.Arity: isBotArityType :: ArityType -> Bool

- GHC.Core.Opt.ConstantFold: EnableBignumRules :: Bool -> EnableBignumRules

- GHC.Core.Opt.ConstantFold: newtype EnableBignumRules

- GHC.Core.Opt.Specialise: instance Control.Monad.Fail.MonadFail GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.Specialise: instance GHC.Base.Applicative GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.Specialise: instance GHC.Base.Functor GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.Specialise: instance GHC.Base.Monad GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.Specialise: instance GHC.Driver.Session.HasDynFlags GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.Specialise: instance GHC.Types.Unique.Supply.MonadUnique GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.Specialise: instance GHC.Unit.Module.HasModule GHC.Core.Opt.Specialise.SpecM

- GHC.Core.Opt.WorkWrap.Utils: DataConAppContext :: !DataCon -> ![Type] -> ![(Scaled Type, StrictnessMark)] -> !Coercion -> DataConAppContext

- GHC.Core.Opt.WorkWrap.Utils: [dcac_arg_tys] :: DataConAppContext -> ![(Scaled Type, StrictnessMark)]

- GHC.Core.Opt.WorkWrap.Utils: [dcac_co] :: DataConAppContext -> !Coercion

- GHC.Core.Opt.WorkWrap.Utils: [dcac_dc] :: DataConAppContext -> !DataCon

- GHC.Core.Opt.WorkWrap.Utils: [dcac_tys] :: DataConAppContext -> ![Type]

- GHC.Core.Opt.WorkWrap.Utils: data DataConAppContext

- GHC.Core.Opt.WorkWrap.Utils: deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext

- GHC.Core.PatSyn: updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn

- GHC.Core.Ppr: instance GHC.Utils.Outputable.Outputable id => GHC.Utils.Outputable.Outputable (GHC.Core.Tickish id)

- GHC.Core.Ppr.TyThing: pprFamInst :: FamInst -> SDoc

- GHC.Core.Ppr.TyThing: pprTyThing :: ShowSub -> TyThing -> SDoc

- GHC.Core.Ppr.TyThing: pprTyThingHdr :: TyThing -> SDoc

- GHC.Core.Ppr.TyThing: pprTyThingInContext :: ShowSub -> TyThing -> SDoc

- GHC.Core.Ppr.TyThing: pprTyThingInContextLoc :: TyThing -> SDoc

- GHC.Core.Ppr.TyThing: pprTyThingLoc :: TyThing -> SDoc

- GHC.Core.Ppr.TyThing: pprTypeForUser :: Type -> SDoc

- GHC.Core.SimpleOpt: collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)

- GHC.Core.SimpleOpt: pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)

- GHC.Core.SimpleOpt: pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)

- GHC.Core.SimpleOpt: pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion)

- GHC.Core.Subst: substSpec :: Subst -> Id -> RuleInfo -> RuleInfo

- GHC.Core.TyCo.Ppr: pprShortTyThing :: TyThing -> SDoc

- GHC.Core.TyCo.Ppr: pprTyThingCategory :: TyThing -> SDoc

- GHC.Core.TyCo.Rep: ACoAxiom :: CoAxiom Branched -> TyThing

- GHC.Core.TyCo.Rep: AConLike :: ConLike -> TyThing

- GHC.Core.TyCo.Rep: ATyCon :: TyCon -> TyThing

- GHC.Core.TyCo.Rep: AnId :: Id -> TyThing

- GHC.Core.TyCo.Rep: NoBlockSubst :: BlockSubstFlag

- GHC.Core.TyCo.Rep: YesBlockSubst :: BlockSubstFlag

- GHC.Core.TyCo.Rep: [ch_blocker] :: CoercionHole -> BlockSubstFlag

- GHC.Core.TyCo.Rep: data BlockSubstFlag

- GHC.Core.TyCo.Rep: data TyThing

- GHC.Core.TyCo.Rep: instance GHC.Classes.Ord GHC.Core.TyCo.Rep.TyLit

- GHC.Core.TyCo.Rep: instance GHC.Types.Name.NamedThing GHC.Core.TyCo.Rep.TyThing

- GHC.Core.TyCo.Rep: instance GHC.Utils.Outputable.Outputable GHC.Core.TyCo.Rep.BlockSubstFlag

- GHC.Core.TyCo.Rep: instance GHC.Utils.Outputable.Outputable GHC.Core.TyCo.Rep.TyThing

- GHC.Core.TyCo.Rep: mkTyConApp :: TyCon -> [Type] -> Type

- GHC.Core.TyCo.Rep: mkTyConTy :: TyCon -> Type

- GHC.Core.TyCo.Rep: pprShortTyThing :: TyThing -> SDoc

- GHC.Core.TyCo.Rep: pprTyThingCategory :: TyThing -> SDoc

- GHC.Core.TyCo.Rep: tyThingCategory :: TyThing -> String

- GHC.Core.TyCon: checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker

- GHC.Core.TyCon: data RecTcChecker

- GHC.Core.TyCon: defaultRecTcMaxBound :: Int

- GHC.Core.TyCon: initRecTc :: RecTcChecker

- GHC.Core.TyCon: isDataProductTyCon_maybe :: TyCon -> Maybe DataCon

- GHC.Core.TyCon: isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]

- GHC.Core.TyCon: isProductTyCon :: TyCon -> Bool

- GHC.Core.TyCon: setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker

- GHC.Core.Type: ACoAxiom :: CoAxiom Branched -> TyThing

- GHC.Core.Type: AConLike :: ConLike -> TyThing

- GHC.Core.Type: ATyCon :: TyCon -> TyThing

- GHC.Core.Type: AnId :: Id -> TyThing

- GHC.Core.Type: data TyThing

- GHC.Core.Type: splitForAllTy :: Type -> (TyCoVar, Type)

- GHC.Core.Type: splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)

- GHC.Core.Type: splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)

- GHC.Core.Type: splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)

- GHC.Core.Type: splitForAllTys :: Type -> ([TyCoVar], Type)

- GHC.Core.Type: splitForAllTysInvis :: Type -> ([InvisTVBinder], Type)

- GHC.Core.Type: splitForAllTysReq :: Type -> ([ReqTVBinder], Type)

- GHC.Core.Type: splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)

- GHC.Core.Type: splitPiTysInvisible :: Type -> ([TyCoBinder], Type)

- GHC.Core.Type: splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)

- GHC.Core.Type: synTyConResKind :: TyCon -> Kind

- GHC.Core.Unfold: exprIsConApp_maybe :: HasDebugCallStack => InScopeEnv -> CoreExpr -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])

- GHC.Core.Unfold: exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal

- GHC.Core.Unfold: mkCompulsoryUnfolding :: CoreExpr -> Unfolding

- GHC.Core.Unfold: mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding

- GHC.Core.Unfold: mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding

- GHC.Core.Unfold: mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding

- GHC.Core.Unfold: mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding

- GHC.Core.Unfold: mkInlineUnfolding :: CoreExpr -> Unfolding

- GHC.Core.Unfold: mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding

- GHC.Core.Unfold: mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding

- GHC.Core.Unfold: mkUnfolding :: DynFlags -> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding

- GHC.Core.Unfold: mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding

- GHC.Core.Unfold: mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding

- GHC.Core.Unfold: noUnfolding :: Unfolding

- GHC.Core.Unfold: specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> [CoreArg] -> Unfolding -> Unfolding

- GHC.Core.Unify: Skolem :: BindFlag

- GHC.Core.Unify: instance GHC.Base.Alternative GHC.Core.Unify.UM

- GHC.Core.Unify: instance GHC.Base.Alternative GHC.Core.Unify.UnifyResultM

- GHC.Core.Unify: instance GHC.Base.MonadPlus GHC.Core.Unify.UM

- GHC.Core.Unify: instance GHC.Base.MonadPlus GHC.Core.Unify.UnifyResultM

- GHC.CoreToByteCode: byteCodeGen :: HscEnv -> Module -> CoreProgram -> [TyCon] -> Maybe ModBreaks -> IO CompiledByteCode

- GHC.CoreToByteCode: coreExprToBCOs :: HscEnv -> Module -> CoreExpr -> IO UnlinkedBCO

- GHC.CoreToByteCode: data UnlinkedBCO

- GHC.CoreToByteCode: instance GHC.Base.Applicative GHC.CoreToByteCode.BcM

- GHC.CoreToByteCode: instance GHC.Base.Functor GHC.CoreToByteCode.BcM

- GHC.CoreToByteCode: instance GHC.Base.Monad GHC.CoreToByteCode.BcM

- GHC.CoreToByteCode: instance GHC.Classes.Eq GHC.CoreToByteCode.ByteOff

- GHC.CoreToByteCode: instance GHC.Classes.Eq GHC.CoreToByteCode.Discr

- GHC.CoreToByteCode: instance GHC.Classes.Eq GHC.CoreToByteCode.WordOff

- GHC.CoreToByteCode: instance GHC.Classes.Ord GHC.CoreToByteCode.ByteOff

- GHC.CoreToByteCode: instance GHC.Classes.Ord GHC.CoreToByteCode.Discr

- GHC.CoreToByteCode: instance GHC.Classes.Ord GHC.CoreToByteCode.WordOff

- GHC.CoreToByteCode: instance GHC.Driver.Session.HasDynFlags GHC.CoreToByteCode.BcM

- GHC.CoreToByteCode: instance GHC.Enum.Enum GHC.CoreToByteCode.ByteOff

- GHC.CoreToByteCode: instance GHC.Enum.Enum GHC.CoreToByteCode.WordOff

- GHC.CoreToByteCode: instance GHC.Num.Num GHC.CoreToByteCode.ByteOff

- GHC.CoreToByteCode: instance GHC.Num.Num GHC.CoreToByteCode.WordOff

- GHC.CoreToByteCode: instance GHC.Real.Integral GHC.CoreToByteCode.ByteOff

- GHC.CoreToByteCode: instance GHC.Real.Integral GHC.CoreToByteCode.WordOff

- GHC.CoreToByteCode: instance GHC.Real.Real GHC.CoreToByteCode.ByteOff

- GHC.CoreToByteCode: instance GHC.Real.Real GHC.CoreToByteCode.WordOff

- GHC.CoreToByteCode: instance GHC.Utils.Outputable.Outputable GHC.CoreToByteCode.Discr

- GHC.Data.FastMutInt: data FastMutPtr

- GHC.Data.FastMutInt: newFastMutPtr :: IO FastMutPtr

- GHC.Data.FastMutInt: readFastMutPtr :: FastMutPtr -> IO (Ptr a)

- GHC.Data.FastMutInt: writeFastMutPtr :: FastMutPtr -> Ptr a -> IO ()

- GHC.Data.FastString: instance GHC.Classes.Ord GHC.Data.FastString.FastString

- GHC.Data.Graph.UnVar: instance GHC.Utils.Outputable.Outputable GHC.Data.Graph.UnVar.Gen

- GHC.Data.Stream: [runStream] :: Stream m a b -> m (Either b (a, Stream m a b))

- GHC.Data.Stream: collect_ :: Monad m => Stream m a r -> m ([a], r)

- GHC.Data.Stream: instance GHC.Base.Monad f => GHC.Base.Functor (GHC.Data.Stream.Stream f a)

- GHC.Data.Stream: instance GHC.Base.Monad m => GHC.Base.Applicative (GHC.Data.Stream.Stream m a)

- GHC.Data.Stream: instance GHC.Base.Monad m => GHC.Base.Monad (GHC.Data.Stream.Stream m a)

- GHC.Data.Stream: mapAccumL :: Monad m => (c -> a -> m (c, b)) -> c -> Stream m a () -> Stream m b c

- GHC.Data.StringBuffer: bidirectionalFormatChars :: [(Char, String)]

- GHC.Data.StringBuffer: containsBidirectionalFormatChar :: StringBuffer -> Bool

- GHC.Data.TrieMap: type family Key m :: Type;

- GHC.Driver.Finder: Found :: ModLocation -> Module -> FindResult

- GHC.Driver.Finder: FoundMultiple :: [(Module, ModuleOrigin)] -> FindResult

- GHC.Driver.Finder: NoPackage :: Unit -> FindResult

- GHC.Driver.Finder: NotFound :: [FilePath] -> Maybe Unit -> [Unit] -> [Unit] -> [(Unit, UnusableUnitReason)] -> [ModuleSuggestion] -> FindResult

- GHC.Driver.Finder: [fr_mods_hidden] :: FindResult -> [Unit]

- GHC.Driver.Finder: [fr_paths] :: FindResult -> [FilePath]

- GHC.Driver.Finder: [fr_pkg] :: FindResult -> Maybe Unit

- GHC.Driver.Finder: [fr_pkgs_hidden] :: FindResult -> [Unit]

- GHC.Driver.Finder: [fr_suggestions] :: FindResult -> [ModuleSuggestion]

- GHC.Driver.Finder: [fr_unusables] :: FindResult -> [(Unit, UnusableUnitReason)]

- GHC.Driver.Finder: addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module

- GHC.Driver.Finder: cannotFindInterface :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc

- GHC.Driver.Finder: cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc

- GHC.Driver.Finder: data FindResult

- GHC.Driver.Finder: findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult

- GHC.Driver.Finder: findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult

- GHC.Driver.Finder: findHomeModule :: HscEnv -> ModuleName -> IO FindResult

- GHC.Driver.Finder: findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult

- GHC.Driver.Finder: findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable

- GHC.Driver.Finder: findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)

- GHC.Driver.Finder: findPluginModule :: HscEnv -> ModuleName -> IO FindResult

- GHC.Driver.Finder: flushFinderCaches :: HscEnv -> IO ()

- GHC.Driver.Finder: mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String -> IO ModLocation

- GHC.Driver.Finder: mkHiPath :: DynFlags -> FilePath -> String -> FilePath

- GHC.Driver.Finder: mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation

- GHC.Driver.Finder: mkHomeModLocation2 :: DynFlags -> ModuleName -> FilePath -> String -> IO ModLocation

- GHC.Driver.Finder: mkObjPath :: DynFlags -> FilePath -> String -> FilePath

- GHC.Driver.Finder: mkStubPaths :: DynFlags -> ModuleName -> ModLocation -> FilePath

- GHC.Driver.Finder: uncacheModule :: HscEnv -> ModuleName -> IO ()

- GHC.Driver.Flags: Opt_ByteCodeIfUnboxed :: GeneralFlag

- GHC.Driver.Flags: Opt_D_dump_stg :: DumpFlag

- GHC.Driver.Flags: Opt_D_dump_verbose_inlinings :: DumpFlag

- GHC.Driver.Flags: Opt_FlatCache :: GeneralFlag

- GHC.Driver.Flags: Opt_WarnUnicodeBidirectionalFormatCharacters :: WarningFlag

- GHC.Driver.Hooks: getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a

- GHC.Driver.Hooks: lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a

- GHC.Driver.Main: TM_NoInst :: TcRnExprMode

- GHC.Driver.Main: [hscs_iface_dflags] :: HscStatus -> !DynFlags

- GHC.Driver.Main: initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails

- GHC.Driver.Make: implicitRequirements :: HscEnv -> [(Maybe FastString, Located ModuleName)] -> IO [(Maybe FastString, Located ModuleName)]

- GHC.Driver.Phases: HsBootFile :: HscSource

- GHC.Driver.Phases: HsSrcFile :: HscSource

- GHC.Driver.Phases: HsigFile :: HscSource

- GHC.Driver.Phases: data HscSource

- GHC.Driver.Phases: hscSourceString :: HscSource -> String

- GHC.Driver.Phases: instance GHC.Classes.Eq GHC.Driver.Phases.HscSource

- GHC.Driver.Phases: instance GHC.Classes.Ord GHC.Driver.Phases.HscSource

- GHC.Driver.Phases: instance GHC.Show.Show GHC.Driver.Phases.HscSource

- GHC.Driver.Phases: instance GHC.Utils.Binary.Binary GHC.Driver.Phases.HscSource

- GHC.Driver.Phases: isHsBootOrSig :: HscSource -> Bool

- GHC.Driver.Phases: isHsigFile :: HscSource -> Bool

- GHC.Driver.Pipeline: exeFileName :: Bool -> DynFlags -> FilePath

- GHC.Driver.Pipeline: linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()

- GHC.Driver.Pipeline: maybeCreateManifest :: DynFlags -> FilePath -> IO [FilePath]

- GHC.Driver.Plugins: [dynflagsPlugin] :: Plugin -> [CommandLineOption] -> DynFlags -> IO DynFlags

- GHC.Driver.Session: CFGWeights :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> CfgWeights

- GHC.Driver.Session: FilesToClean :: !Set FilePath -> !Set FilePath -> FilesToClean

- GHC.Driver.Session: HscAsm :: HscTarget

- GHC.Driver.Session: HscC :: HscTarget

- GHC.Driver.Session: HscInterpreted :: HscTarget

- GHC.Driver.Session: HscLlvm :: HscTarget

- GHC.Driver.Session: HscNothing :: HscTarget

- GHC.Driver.Session: Opt_ByteCodeIfUnboxed :: GeneralFlag

- GHC.Driver.Session: Opt_D_dump_stg :: DumpFlag

- GHC.Driver.Session: Opt_D_dump_verbose_inlinings :: DumpFlag

- GHC.Driver.Session: Opt_FlatCache :: GeneralFlag

- GHC.Driver.Session: Opt_WarnUnicodeBidirectionalFormatCharacters :: WarningFlag

- GHC.Driver.Session: Sf_Ignore :: SafeHaskellMode

- GHC.Driver.Session: Sf_None :: SafeHaskellMode

- GHC.Driver.Session: Sf_Safe :: SafeHaskellMode

- GHC.Driver.Session: Sf_SafeInferred :: SafeHaskellMode

- GHC.Driver.Session: Sf_Trustworthy :: SafeHaskellMode

- GHC.Driver.Session: Sf_Unsafe :: SafeHaskellMode

- GHC.Driver.Session: [backEdgeBonus] :: CfgWeights -> Int

- GHC.Driver.Session: [cachedPlugins] :: DynFlags -> [LoadedPlugin]

- GHC.Driver.Session: [callWeight] :: CfgWeights -> Int

- GHC.Driver.Session: [canGenerateDynamicToo] :: DynFlags -> IORef Bool

- GHC.Driver.Session: [cfgWeightInfo] :: DynFlags -> CfgWeights

- GHC.Driver.Session: [condBranchWeight] :: CfgWeights -> Int

- GHC.Driver.Session: [dirsToClean] :: DynFlags -> IORef (Map FilePath FilePath)

- GHC.Driver.Session: [dump_action] :: DynFlags -> DumpAction

- GHC.Driver.Session: [dynHiSuf] :: DynFlags -> String

- GHC.Driver.Session: [dynObjectSuf] :: DynFlags -> String

- GHC.Driver.Session: [dynOutputFile] :: DynFlags -> Maybe String

- GHC.Driver.Session: [filesToClean] :: DynFlags -> IORef FilesToClean

- GHC.Driver.Session: [ftcCurrentModule] :: FilesToClean -> !Set FilePath

- GHC.Driver.Session: [ftcGhcSession] :: FilesToClean -> !Set FilePath

- GHC.Driver.Session: [generatedDumps] :: DynFlags -> IORef (Set FilePath)

- GHC.Driver.Session: [hiSuf] :: DynFlags -> String

- GHC.Driver.Session: [homeUnitId] :: DynFlags -> UnitId

- GHC.Driver.Session: [homeUnitInstanceOfId] :: DynFlags -> Maybe IndefUnitId

- GHC.Driver.Session: [homeUnitInstantiations] :: DynFlags -> [(ModuleName, Module)]

- GHC.Driver.Session: [hooks] :: DynFlags -> Hooks

- GHC.Driver.Session: [hscTarget] :: DynFlags -> HscTarget

- GHC.Driver.Session: [infoTablePenalty] :: CfgWeights -> Int

- GHC.Driver.Session: [likelyCondWeight] :: CfgWeights -> Int

- GHC.Driver.Session: [log_action] :: DynFlags -> LogAction

- GHC.Driver.Session: [mainModIs] :: DynFlags -> Module

- GHC.Driver.Session: [nextTempSuffix] :: DynFlags -> IORef Int

- GHC.Driver.Session: [objectSuf] :: DynFlags -> String

- GHC.Driver.Session: [outputFile] :: DynFlags -> Maybe String

- GHC.Driver.Session: [pc_DYNAMIC_BY_DEFAULT] :: PlatformConstants -> Bool

- GHC.Driver.Session: [platformConstants] :: DynFlags -> PlatformConstants

- GHC.Driver.Session: [platformMisc_ghcDebugged] :: PlatformMisc -> Bool

- GHC.Driver.Session: [platformMisc_ghcThreaded] :: PlatformMisc -> Bool

- GHC.Driver.Session: [sPlatformConstants] :: Settings -> PlatformConstants

- GHC.Driver.Session: [staticPlugins] :: DynFlags -> [StaticPlugin]

- GHC.Driver.Session: [switchWeight] :: CfgWeights -> Int

- GHC.Driver.Session: [trace_action] :: DynFlags -> TraceAction

- GHC.Driver.Session: [ufCreationThreshold] :: DynFlags -> Int

- GHC.Driver.Session: [ufDearOp] :: DynFlags -> Int

- GHC.Driver.Session: [ufDictDiscount] :: DynFlags -> Int

- GHC.Driver.Session: [ufFunAppDiscount] :: DynFlags -> Int

- GHC.Driver.Session: [ufUseThreshold] :: DynFlags -> Int

- GHC.Driver.Session: [ufVeryAggressive] :: DynFlags -> Bool

- GHC.Driver.Session: [uncondWeight] :: CfgWeights -> Int

- GHC.Driver.Session: [unitDatabases] :: DynFlags -> Maybe [UnitDatabase UnitId]

- GHC.Driver.Session: [unitState] :: DynFlags -> UnitState

- GHC.Driver.Session: [unlikelyCondWeight] :: CfgWeights -> Int

- GHC.Driver.Session: [ways] :: DynFlags -> Set Way

- GHC.Driver.Session: aP_STACK_SPLIM :: DynFlags -> Int

- GHC.Driver.Session: addWay' :: Way -> DynFlags -> DynFlags

- GHC.Driver.Session: bITMAP_BITS_SHIFT :: DynFlags -> Int

- GHC.Driver.Session: bLOCKS_PER_MBLOCK :: DynFlags -> Int

- GHC.Driver.Session: bLOCK_SIZE :: DynFlags -> Int

- GHC.Driver.Session: bLOCK_SIZE_W :: DynFlags -> Int

- GHC.Driver.Session: cINT_SIZE :: DynFlags -> Int

- GHC.Driver.Session: cLONG_LONG_SIZE :: DynFlags -> Int

- GHC.Driver.Session: cLONG_SIZE :: DynFlags -> Int

- GHC.Driver.Session: cONTROL_GROUP_CONST_291 :: DynFlags -> Int

- GHC.Driver.Session: canonicalizeHomeModule :: DynFlags -> ModuleName -> Module

- GHC.Driver.Session: canonicalizeModuleIfHome :: DynFlags -> Module -> Module

- GHC.Driver.Session: dYNAMIC_BY_DEFAULT :: DynFlags -> Bool

- GHC.Driver.Session: data CfgWeights

- GHC.Driver.Session: data FilesToClean

- GHC.Driver.Session: data HscTarget

- GHC.Driver.Session: data SafeHaskellMode

- GHC.Driver.Session: defaultLogAction :: LogAction

- GHC.Driver.Session: defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO ()

- GHC.Driver.Session: defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO ()

- GHC.Driver.Session: defaultObjectTarget :: DynFlags -> HscTarget

- GHC.Driver.Session: defaultWays :: Settings -> Set Way

- GHC.Driver.Session: dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags

- GHC.Driver.Session: emptyFilesToClean :: FilesToClean

- GHC.Driver.Session: homeUnit :: DynFlags -> Unit

- GHC.Driver.Session: iLDV_CREATE_MASK :: DynFlags -> Integer

- GHC.Driver.Session: iLDV_STATE_CREATE :: DynFlags -> Integer

- GHC.Driver.Session: iLDV_STATE_USE :: DynFlags -> Integer

- GHC.Driver.Session: ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a

- GHC.Driver.Session: instance GHC.Classes.Eq GHC.Driver.Session.HscTarget

- GHC.Driver.Session: instance GHC.Classes.Eq GHC.Driver.Session.SafeHaskellMode

- GHC.Driver.Session: instance GHC.Show.Show GHC.Driver.Session.HscTarget

- GHC.Driver.Session: instance GHC.Show.Show GHC.Driver.Session.SafeHaskellMode

- GHC.Driver.Session: instance GHC.Utils.Outputable.Outputable GHC.Driver.Session.SafeHaskellMode

- GHC.Driver.Session: isHomeModule :: DynFlags -> Module -> Bool

- GHC.Driver.Session: isObjectTarget :: HscTarget -> Bool

- GHC.Driver.Session: lDV_SHIFT :: DynFlags -> Int

- GHC.Driver.Session: mAX_CHARLIKE :: DynFlags -> Int

- GHC.Driver.Session: mAX_Double_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_Float_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_INTLIKE :: DynFlags -> Int

- GHC.Driver.Session: mAX_Long_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_PTR_TAG :: DynFlags -> Int

- GHC.Driver.Session: mAX_Real_Double_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_Real_Float_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_Real_Long_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_Real_Vanilla_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_Real_XMM_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_SPEC_AP_SIZE :: DynFlags -> Int

- GHC.Driver.Session: mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int

- GHC.Driver.Session: mAX_Vanilla_REG :: DynFlags -> Int

- GHC.Driver.Session: mAX_XMM_REG :: DynFlags -> Int

- GHC.Driver.Session: mIN_CHARLIKE :: DynFlags -> Int

- GHC.Driver.Session: mIN_INTLIKE :: DynFlags -> Int

- GHC.Driver.Session: mIN_PAYLOAD_SIZE :: DynFlags -> Int

- GHC.Driver.Session: mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int

- GHC.Driver.Session: mkHomeModule :: DynFlags -> ModuleName -> Module

- GHC.Driver.Session: oFFSET_Capability_r :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_CostCentreStack_scc_count :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgArrBytes_bytes :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgEntCounter_allocd :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgEntCounter_allocs :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgEntCounter_entry_count :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgEntCounter_link :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgEntCounter_registeredp :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgHeader_ccs :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgHeader_ldvw :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgMutArrPtrs_size :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rCCCS :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rD1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rD2 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rD3 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rD4 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rD5 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rD6 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rF1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rF2 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rF3 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rF4 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rF5 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rF6 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rHp :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rHpLim :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rL1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR10 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR2 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR3 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR4 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR5 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR6 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR7 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR8 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rR9 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rSp :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rSpLim :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgStack_sp :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgStack_stack :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgTSO_alloc_limit :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgTSO_cccs :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgTSO_stackobj :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_bdescr_blocks :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_bdescr_flags :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_bdescr_free :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_bdescr_start :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_stgGCEnter1 :: DynFlags -> Int

- GHC.Driver.Session: oFFSET_stgGCFun :: DynFlags -> Int

- GHC.Driver.Session: pROF_HDR_SIZE :: DynFlags -> Int

- GHC.Driver.Session: putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()

- GHC.Driver.Session: rESERVED_C_STACK_BYTES :: DynFlags -> Int

- GHC.Driver.Session: rESERVED_STACK_WORDS :: DynFlags -> Int

- GHC.Driver.Session: sGhcDebugged :: Settings -> Bool

- GHC.Driver.Session: sGhcThreaded :: Settings -> Bool

- GHC.Driver.Session: sIZEOF_CostCentreStack :: DynFlags -> Int

- GHC.Driver.Session: sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int

- GHC.Driver.Session: sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int

- GHC.Driver.Session: sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int

- GHC.Driver.Session: sIZEOF_StgSMPThunkHeader :: DynFlags -> Int

- GHC.Driver.Session: sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int

- GHC.Driver.Session: sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int

- GHC.Driver.Session: sTD_HDR_SIZE :: DynFlags -> Int

- GHC.Driver.Session: tAG_BITS :: DynFlags -> Int

- GHC.Driver.Session: tAG_MASK :: DynFlags -> Int

- GHC.Driver.Session: tICKY_BIN_COUNT :: DynFlags -> Int

- GHC.Driver.Session: targetRetainsAllBindings :: HscTarget -> Bool

- GHC.Driver.Session: type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()

- GHC.Driver.Session: unsafeGlobalDynFlags :: DynFlags

- GHC.Driver.Session: wORD_SIZE :: DynFlags -> Int

- GHC.Driver.Session: whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m ()

- GHC.Driver.Session: whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()

- GHC.Driver.Types: ACoAxiom :: CoAxiom Branched -> TyThing

- GHC.Driver.Types: AConLike :: ConLike -> TyThing

- GHC.Driver.Types: ATyCon :: TyCon -> TyThing

- GHC.Driver.Types: AnId :: Id -> TyThing

- GHC.Driver.Types: BCOs :: CompiledByteCode -> [SptEntry] -> Unlinked

- GHC.Driver.Types: CgGuts :: !Module -> [TyCon] -> CoreProgram -> !ForeignStubs -> ![(ForeignSrcLang, FilePath)] -> ![UnitId] -> !HpcInfo -> !Maybe ModBreaks -> [SptEntry] -> CgGuts

- GHC.Driver.Types: CompleteMatch :: [Name] -> Name -> CompleteMatch

- GHC.Driver.Types: DeprecatedTxt :: Located SourceText -> [Located StringLiteral] -> WarningTxt

- GHC.Driver.Types: Deps :: [ModuleNameWithIsBoot] -> [(UnitId, Bool)] -> [Module] -> [Module] -> [ModuleName] -> Dependencies

- GHC.Driver.Types: DotA :: FilePath -> Unlinked

- GHC.Driver.Types: DotDLL :: FilePath -> Unlinked

- GHC.Driver.Types: DotO :: FilePath -> Unlinked

- GHC.Driver.Types: EPS :: !ModuleNameEnv ModuleNameWithIsBoot -> !PackageIfaceTable -> InstalledModuleEnv (UniqDSet ModuleName) -> !PackageTypeEnv -> !PackageInstEnv -> !PackageFamInstEnv -> !PackageRuleBase -> !PackageAnnEnv -> !PackageCompleteMatchMap -> !ModuleEnv FamInstEnv -> !EpsStats -> ExternalPackageState

- GHC.Driver.Types: EpsStats :: !Int -> EpsStats

- GHC.Driver.Types: ExtensibleFields :: Map FieldName BinData -> ExtensibleFields

- GHC.Driver.Types: FixItem :: OccName -> Fixity -> FixItem

- GHC.Driver.Types: ForeignStubs :: SDoc -> SDoc -> ForeignStubs

- GHC.Driver.Types: Found :: ModLocation -> Module -> FindResult

- GHC.Driver.Types: FoundMultiple :: [(Module, ModuleOrigin)] -> FindResult

- GHC.Driver.Types: HomeModInfo :: !ModIface -> !ModDetails -> !Maybe Linkable -> HomeModInfo

- GHC.Driver.Types: HpcInfo :: Int -> Int -> HpcInfo

- GHC.Driver.Types: HsBootFile :: HscSource

- GHC.Driver.Types: HsParsedModule :: Located HsModule -> [FilePath] -> ApiAnns -> HsParsedModule

- GHC.Driver.Types: HsSrcFile :: HscSource

- GHC.Driver.Types: Hsc :: (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a

- GHC.Driver.Types: HscEnv :: DynFlags -> [Target] -> ModuleGraph -> InteractiveContext -> HomePackageTable -> {-# UNPACK #-} !IORef ExternalPackageState -> {-# UNPACK #-} !IORef NameCache -> {-# UNPACK #-} !IORef FinderCache -> Maybe (Module, IORef TypeEnv) -> Maybe Interp -> DynLinker -> HscEnv

- GHC.Driver.Types: HscNotGeneratingCode :: ModIface -> ModDetails -> HscStatus

- GHC.Driver.Types: HscRecomp :: CgGuts -> !ModLocation -> !PartialModIface -> !Maybe Fingerprint -> !DynFlags -> HscStatus

- GHC.Driver.Types: HscUpToDate :: ModIface -> ModDetails -> HscStatus

- GHC.Driver.Types: HscUpdateBoot :: ModIface -> ModDetails -> HscStatus

- GHC.Driver.Types: HscUpdateSig :: ModIface -> ModDetails -> HscStatus

- GHC.Driver.Types: HsigFile :: HscSource

- GHC.Driver.Types: IIDecl :: ImportDecl GhcPs -> InteractiveImport

- GHC.Driver.Types: IIModule :: ModuleName -> InteractiveImport

- GHC.Driver.Types: ImportedBySystem :: ImportedBy

- GHC.Driver.Types: ImportedByUser :: ImportedModsVal -> ImportedBy

- GHC.Driver.Types: ImportedModsVal :: ModuleName -> SrcSpan -> IsSafeImport -> Bool -> !GlobalRdrEnv -> Bool -> ImportedModsVal

- GHC.Driver.Types: InstalledFound :: ModLocation -> InstalledModule -> InstalledFindResult

- GHC.Driver.Types: InstalledNoPackage :: UnitId -> InstalledFindResult

- GHC.Driver.Types: InstalledNotFound :: [FilePath] -> Maybe UnitId -> InstalledFindResult

- GHC.Driver.Types: InteractiveContext :: DynFlags -> Int -> [InteractiveImport] -> [TyThing] -> GlobalRdrEnv -> ([ClsInst], [FamInst]) -> FixityEnv -> Maybe [Type] -> [Resume] -> Name -> Name -> Maybe FilePath -> InteractiveContext

- GHC.Driver.Types: IsBoot :: IsBootInterface

- GHC.Driver.Types: LM :: UTCTime -> Module -> [Unlinked] -> Linkable

- GHC.Driver.Types: LangAsm :: ForeignSrcLang

- GHC.Driver.Types: LangC :: ForeignSrcLang

- GHC.Driver.Types: LangCxx :: ForeignSrcLang

- GHC.Driver.Types: LangObjc :: ForeignSrcLang

- GHC.Driver.Types: LangObjcxx :: ForeignSrcLang

- GHC.Driver.Types: MetaAW :: (Serialized -> MetaResult) -> MetaRequest

- GHC.Driver.Types: MetaD :: ([LHsDecl GhcPs] -> MetaResult) -> MetaRequest

- GHC.Driver.Types: MetaE :: (LHsExpr GhcPs -> MetaResult) -> MetaRequest

- GHC.Driver.Types: MetaP :: (LPat GhcPs -> MetaResult) -> MetaRequest

- GHC.Driver.Types: MetaT :: (LHsType GhcPs -> MetaResult) -> MetaRequest

- GHC.Driver.Types: ModBreaks :: ForeignRef BreakArray -> !Array BreakIndex SrcSpan -> !Array BreakIndex [OccName] -> !Array BreakIndex [String] -> !Array BreakIndex (RemotePtr CostCentre) -> IntMap CgBreakInfo -> ModBreaks

- GHC.Driver.Types: ModDetails :: [AvailInfo] -> !TypeEnv -> ![ClsInst] -> ![FamInst] -> ![CoreRule] -> ![Annotation] -> [CompleteMatch] -> ModDetails

- GHC.Driver.Types: ModGuts :: !Module -> HscSource -> SrcSpan -> ![AvailInfo] -> !Dependencies -> ![Usage] -> !Bool -> !GlobalRdrEnv -> !FixityEnv -> ![TyCon] -> ![ClsInst] -> ![FamInst] -> ![PatSyn] -> ![CoreRule] -> !CoreProgram -> !ForeignStubs -> ![(ForeignSrcLang, FilePath)] -> !Warnings -> [Annotation] -> [CompleteMatch] -> !HpcInfo -> !Maybe ModBreaks -> InstEnv -> FamInstEnv -> SafeHaskellMode -> Bool -> !Maybe HsDocString -> !DeclDocMap -> !ArgDocMap -> ModGuts

- GHC.Driver.Types: ModIface :: !Module -> !Maybe Module -> !HscSource -> Dependencies -> [Usage] -> ![IfaceExport] -> !Bool -> [(OccName, Fixity)] -> Warnings -> [IfaceAnnotation] -> [IfaceDeclExts phase] -> !Maybe GlobalRdrEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] -> !AnyHpcUsage -> !IfaceTrustInfo -> !Bool -> [IfaceCompleteMatch] -> Maybe HsDocString -> DeclDocMap -> ArgDocMap -> !IfaceBackendExts phase -> ExtensibleFields -> ModIface_ (phase :: ModIfacePhase)

- GHC.Driver.Types: ModIfaceBackend :: !Fingerprint -> !Fingerprint -> !Fingerprint -> !Fingerprint -> !Fingerprint -> !Fingerprint -> !WhetherHasOrphans -> !WhetherHasFamInst -> !Fingerprint -> !Fingerprint -> !OccName -> Maybe WarningTxt -> !OccName -> Maybe Fixity -> !OccName -> Maybe (OccName, Fingerprint) -> ModIfaceBackend

- GHC.Driver.Types: ModSummary :: Module -> HscSource -> ModLocation -> UTCTime -> Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime -> [(Maybe FastString, Located ModuleName)] -> [(Maybe FastString, Located ModuleName)] -> Maybe HsParsedModule -> FilePath -> DynFlags -> Maybe StringBuffer -> ModSummary

- GHC.Driver.Types: NoHpcInfo :: AnyHpcUsage -> HpcInfo

- GHC.Driver.Types: NoPackage :: Unit -> FindResult

- GHC.Driver.Types: NoStubs :: ForeignStubs

- GHC.Driver.Types: NoWarnings :: Warnings

- GHC.Driver.Types: NotBoot :: IsBootInterface

- GHC.Driver.Types: NotFound :: [FilePath] -> Maybe Unit -> [Unit] -> [Unit] -> [(Unit, UnusableUnitReason)] -> [ModuleSuggestion] -> FindResult

- GHC.Driver.Types: RawObject :: ForeignSrcLang

- GHC.Driver.Types: SourceModified :: SourceModified

- GHC.Driver.Types: SourceUnmodified :: SourceModified

- GHC.Driver.Types: SourceUnmodifiedAndStable :: SourceModified

- GHC.Driver.Types: SptEntry :: Id -> Fingerprint -> SptEntry

- GHC.Driver.Types: Target :: !TargetId -> !Bool -> !Maybe (InputFileBuffer, UTCTime) -> Target

- GHC.Driver.Types: TargetFile :: FilePath -> Maybe Phase -> TargetId

- GHC.Driver.Types: TargetModule :: ModuleName -> TargetId

- GHC.Driver.Types: UsageFile :: FilePath -> Fingerprint -> Usage

- GHC.Driver.Types: UsageHomeModule :: ModuleName -> Fingerprint -> [(OccName, Fingerprint)] -> Maybe Fingerprint -> IsSafeImport -> Usage

- GHC.Driver.Types: UsageMergedRequirement :: Module -> Fingerprint -> Usage

- GHC.Driver.Types: UsagePackageModule :: Module -> Fingerprint -> IsSafeImport -> Usage

- GHC.Driver.Types: WarnAll :: WarningTxt -> Warnings

- GHC.Driver.Types: WarnSome :: [(OccName, WarningTxt)] -> Warnings

- GHC.Driver.Types: WarningTxt :: Located SourceText -> [Located StringLiteral] -> WarningTxt

- GHC.Driver.Types: [cg_binds] :: CgGuts -> CoreProgram

- GHC.Driver.Types: [cg_dep_pkgs] :: CgGuts -> ![UnitId]

- GHC.Driver.Types: [cg_foreign] :: CgGuts -> !ForeignStubs

- GHC.Driver.Types: [cg_foreign_files] :: CgGuts -> ![(ForeignSrcLang, FilePath)]

- GHC.Driver.Types: [cg_hpc_info] :: CgGuts -> !HpcInfo

- GHC.Driver.Types: [cg_modBreaks] :: CgGuts -> !Maybe ModBreaks

- GHC.Driver.Types: [cg_module] :: CgGuts -> !Module

- GHC.Driver.Types: [cg_spt_entries] :: CgGuts -> [SptEntry]

- GHC.Driver.Types: [cg_tycons] :: CgGuts -> [TyCon]

- GHC.Driver.Types: [completeMatchConLikes] :: CompleteMatch -> [Name]

- GHC.Driver.Types: [completeMatchTyCon] :: CompleteMatch -> Name

- GHC.Driver.Types: [dep_finsts] :: Dependencies -> [Module]

- GHC.Driver.Types: [dep_mods] :: Dependencies -> [ModuleNameWithIsBoot]

- GHC.Driver.Types: [dep_orphs] :: Dependencies -> [Module]

- GHC.Driver.Types: [dep_pkgs] :: Dependencies -> [(UnitId, Bool)]

- GHC.Driver.Types: [dep_plgins] :: Dependencies -> [ModuleName]

- GHC.Driver.Types: [eps_PIT] :: ExternalPackageState -> !PackageIfaceTable

- GHC.Driver.Types: [eps_PTE] :: ExternalPackageState -> !PackageTypeEnv

- GHC.Driver.Types: [eps_ann_env] :: ExternalPackageState -> !PackageAnnEnv

- GHC.Driver.Types: [eps_complete_matches] :: ExternalPackageState -> !PackageCompleteMatchMap

- GHC.Driver.Types: [eps_fam_inst_env] :: ExternalPackageState -> !PackageFamInstEnv

- GHC.Driver.Types: [eps_free_holes] :: ExternalPackageState -> InstalledModuleEnv (UniqDSet ModuleName)

- GHC.Driver.Types: [eps_inst_env] :: ExternalPackageState -> !PackageInstEnv

- GHC.Driver.Types: [eps_is_boot] :: ExternalPackageState -> !ModuleNameEnv ModuleNameWithIsBoot

- GHC.Driver.Types: [eps_mod_fam_inst_env] :: ExternalPackageState -> !ModuleEnv FamInstEnv

- GHC.Driver.Types: [eps_rule_base] :: ExternalPackageState -> !PackageRuleBase

- GHC.Driver.Types: [eps_stats] :: ExternalPackageState -> !EpsStats

- GHC.Driver.Types: [fr_mods_hidden] :: FindResult -> [Unit]

- GHC.Driver.Types: [fr_paths] :: FindResult -> [FilePath]

- GHC.Driver.Types: [fr_pkg] :: FindResult -> Maybe Unit

- GHC.Driver.Types: [fr_pkgs_hidden] :: FindResult -> [Unit]

- GHC.Driver.Types: [fr_suggestions] :: FindResult -> [ModuleSuggestion]

- GHC.Driver.Types: [fr_unusables] :: FindResult -> [(Unit, UnusableUnitReason)]

- GHC.Driver.Types: [getExtensibleFields] :: ExtensibleFields -> Map FieldName BinData

- GHC.Driver.Types: [hm_details] :: HomeModInfo -> !ModDetails

- GHC.Driver.Types: [hm_iface] :: HomeModInfo -> !ModIface

- GHC.Driver.Types: [hm_linkable] :: HomeModInfo -> !Maybe Linkable

- GHC.Driver.Types: [hpcInfoHash] :: HpcInfo -> Int

- GHC.Driver.Types: [hpcInfoTickCount] :: HpcInfo -> Int

- GHC.Driver.Types: [hpcUsed] :: HpcInfo -> AnyHpcUsage

- GHC.Driver.Types: [hpm_annotations] :: HsParsedModule -> ApiAnns

- GHC.Driver.Types: [hpm_module] :: HsParsedModule -> Located HsModule

- GHC.Driver.Types: [hpm_src_files] :: HsParsedModule -> [FilePath]

- GHC.Driver.Types: [hsc_EPS] :: HscEnv -> {-# UNPACK #-} !IORef ExternalPackageState

- GHC.Driver.Types: [hsc_FC] :: HscEnv -> {-# UNPACK #-} !IORef FinderCache

- GHC.Driver.Types: [hsc_HPT] :: HscEnv -> HomePackageTable

- GHC.Driver.Types: [hsc_IC] :: HscEnv -> InteractiveContext

- GHC.Driver.Types: [hsc_NC] :: HscEnv -> {-# UNPACK #-} !IORef NameCache

- GHC.Driver.Types: [hsc_dflags] :: HscEnv -> DynFlags

- GHC.Driver.Types: [hsc_dynLinker] :: HscEnv -> DynLinker

- GHC.Driver.Types: [hsc_interp] :: HscEnv -> Maybe Interp

- GHC.Driver.Types: [hsc_mod_graph] :: HscEnv -> ModuleGraph

- GHC.Driver.Types: [hsc_targets] :: HscEnv -> [Target]

- GHC.Driver.Types: [hsc_type_env_var] :: HscEnv -> Maybe (Module, IORef TypeEnv)

- GHC.Driver.Types: [hscs_guts] :: HscStatus -> CgGuts

- GHC.Driver.Types: [hscs_iface_dflags] :: HscStatus -> !DynFlags

- GHC.Driver.Types: [hscs_mod_location] :: HscStatus -> !ModLocation

- GHC.Driver.Types: [hscs_old_iface_hash] :: HscStatus -> !Maybe Fingerprint

- GHC.Driver.Types: [hscs_partial_iface] :: HscStatus -> !PartialModIface

- GHC.Driver.Types: [ic_cwd] :: InteractiveContext -> Maybe FilePath

- GHC.Driver.Types: [ic_default] :: InteractiveContext -> Maybe [Type]

- GHC.Driver.Types: [ic_dflags] :: InteractiveContext -> DynFlags

- GHC.Driver.Types: [ic_fix_env] :: InteractiveContext -> FixityEnv

- GHC.Driver.Types: [ic_imports] :: InteractiveContext -> [InteractiveImport]

- GHC.Driver.Types: [ic_instances] :: InteractiveContext -> ([ClsInst], [FamInst])

- GHC.Driver.Types: [ic_int_print] :: InteractiveContext -> Name

- GHC.Driver.Types: [ic_mod_index] :: InteractiveContext -> Int

- GHC.Driver.Types: [ic_monad] :: InteractiveContext -> Name

- GHC.Driver.Types: [ic_resume] :: InteractiveContext -> [Resume]

- GHC.Driver.Types: [ic_rn_gbl_env] :: InteractiveContext -> GlobalRdrEnv

- GHC.Driver.Types: [ic_tythings] :: InteractiveContext -> [TyThing]

- GHC.Driver.Types: [imv_all_exports] :: ImportedModsVal -> !GlobalRdrEnv

- GHC.Driver.Types: [imv_is_hiding] :: ImportedModsVal -> Bool

- GHC.Driver.Types: [imv_is_safe] :: ImportedModsVal -> IsSafeImport

- GHC.Driver.Types: [imv_name] :: ImportedModsVal -> ModuleName

- GHC.Driver.Types: [imv_qualified] :: ImportedModsVal -> Bool

- GHC.Driver.Types: [imv_span] :: ImportedModsVal -> SrcSpan

- GHC.Driver.Types: [linkableModule] :: Linkable -> Module

- GHC.Driver.Types: [linkableTime] :: Linkable -> UTCTime

- GHC.Driver.Types: [linkableUnlinked] :: Linkable -> [Unlinked]

- GHC.Driver.Types: [md_anns] :: ModDetails -> ![Annotation]

- GHC.Driver.Types: [md_complete_sigs] :: ModDetails -> [CompleteMatch]

- GHC.Driver.Types: [md_exports] :: ModDetails -> [AvailInfo]

- GHC.Driver.Types: [md_fam_insts] :: ModDetails -> ![FamInst]

- GHC.Driver.Types: [md_insts] :: ModDetails -> ![ClsInst]

- GHC.Driver.Types: [md_rules] :: ModDetails -> ![CoreRule]

- GHC.Driver.Types: [md_types] :: ModDetails -> !TypeEnv

- GHC.Driver.Types: [mg_anns] :: ModGuts -> [Annotation]

- GHC.Driver.Types: [mg_arg_docs] :: ModGuts -> !ArgDocMap

- GHC.Driver.Types: [mg_binds] :: ModGuts -> !CoreProgram

- GHC.Driver.Types: [mg_complete_sigs] :: ModGuts -> [CompleteMatch]

- GHC.Driver.Types: [mg_decl_docs] :: ModGuts -> !DeclDocMap

- GHC.Driver.Types: [mg_deps] :: ModGuts -> !Dependencies

- GHC.Driver.Types: [mg_doc_hdr] :: ModGuts -> !Maybe HsDocString

- GHC.Driver.Types: [mg_exports] :: ModGuts -> ![AvailInfo]

- GHC.Driver.Types: [mg_fam_inst_env] :: ModGuts -> FamInstEnv

- GHC.Driver.Types: [mg_fam_insts] :: ModGuts -> ![FamInst]

- GHC.Driver.Types: [mg_fix_env] :: ModGuts -> !FixityEnv

- GHC.Driver.Types: [mg_foreign] :: ModGuts -> !ForeignStubs

- GHC.Driver.Types: [mg_foreign_files] :: ModGuts -> ![(ForeignSrcLang, FilePath)]

- GHC.Driver.Types: [mg_hpc_info] :: ModGuts -> !HpcInfo

- GHC.Driver.Types: [mg_hsc_src] :: ModGuts -> HscSource

- GHC.Driver.Types: [mg_inst_env] :: ModGuts -> InstEnv

- GHC.Driver.Types: [mg_insts] :: ModGuts -> ![ClsInst]

- GHC.Driver.Types: [mg_loc] :: ModGuts -> SrcSpan

- GHC.Driver.Types: [mg_modBreaks] :: ModGuts -> !Maybe ModBreaks

- GHC.Driver.Types: [mg_module] :: ModGuts -> !Module

- GHC.Driver.Types: [mg_patsyns] :: ModGuts -> ![PatSyn]

- GHC.Driver.Types: [mg_rdr_env] :: ModGuts -> !GlobalRdrEnv

- GHC.Driver.Types: [mg_rules] :: ModGuts -> ![CoreRule]

- GHC.Driver.Types: [mg_safe_haskell] :: ModGuts -> SafeHaskellMode

- GHC.Driver.Types: [mg_tcs] :: ModGuts -> ![TyCon]

- GHC.Driver.Types: [mg_trust_pkg] :: ModGuts -> Bool

- GHC.Driver.Types: [mg_usages] :: ModGuts -> ![Usage]

- GHC.Driver.Types: [mg_used_th] :: ModGuts -> !Bool

- GHC.Driver.Types: [mg_warns] :: ModGuts -> !Warnings

- GHC.Driver.Types: [mi_anns] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceAnnotation]

- GHC.Driver.Types: [mi_arg_docs] :: ModIface_ (phase :: ModIfacePhase) -> ArgDocMap

- GHC.Driver.Types: [mi_complete_sigs] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceCompleteMatch]

- GHC.Driver.Types: [mi_decl_docs] :: ModIface_ (phase :: ModIfacePhase) -> DeclDocMap

- GHC.Driver.Types: [mi_decls] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceDeclExts phase]

- GHC.Driver.Types: [mi_deps] :: ModIface_ (phase :: ModIfacePhase) -> Dependencies

- GHC.Driver.Types: [mi_doc_hdr] :: ModIface_ (phase :: ModIfacePhase) -> Maybe HsDocString

- GHC.Driver.Types: [mi_exp_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_exports] :: ModIface_ (phase :: ModIfacePhase) -> ![IfaceExport]

- GHC.Driver.Types: [mi_ext_fields] :: ModIface_ (phase :: ModIfacePhase) -> ExtensibleFields

- GHC.Driver.Types: [mi_fam_insts] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceFamInst]

- GHC.Driver.Types: [mi_final_exts] :: ModIface_ (phase :: ModIfacePhase) -> !IfaceBackendExts phase

- GHC.Driver.Types: [mi_finsts] :: ModIfaceBackend -> !WhetherHasFamInst

- GHC.Driver.Types: [mi_fix_fn] :: ModIfaceBackend -> !OccName -> Maybe Fixity

- GHC.Driver.Types: [mi_fixities] :: ModIface_ (phase :: ModIfacePhase) -> [(OccName, Fixity)]

- GHC.Driver.Types: [mi_flag_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_globals] :: ModIface_ (phase :: ModIfacePhase) -> !Maybe GlobalRdrEnv

- GHC.Driver.Types: [mi_hash_fn] :: ModIfaceBackend -> !OccName -> Maybe (OccName, Fingerprint)

- GHC.Driver.Types: [mi_hpc] :: ModIface_ (phase :: ModIfacePhase) -> !AnyHpcUsage

- GHC.Driver.Types: [mi_hpc_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_hsc_src] :: ModIface_ (phase :: ModIfacePhase) -> !HscSource

- GHC.Driver.Types: [mi_iface_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_insts] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceClsInst]

- GHC.Driver.Types: [mi_mod_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_module] :: ModIface_ (phase :: ModIfacePhase) -> !Module

- GHC.Driver.Types: [mi_opt_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_orphan] :: ModIfaceBackend -> !WhetherHasOrphans

- GHC.Driver.Types: [mi_orphan_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_plugin_hash] :: ModIfaceBackend -> !Fingerprint

- GHC.Driver.Types: [mi_rules] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceRule]

- GHC.Driver.Types: [mi_sig_of] :: ModIface_ (phase :: ModIfacePhase) -> !Maybe Module

- GHC.Driver.Types: [mi_trust] :: ModIface_ (phase :: ModIfacePhase) -> !IfaceTrustInfo

- GHC.Driver.Types: [mi_trust_pkg] :: ModIface_ (phase :: ModIfacePhase) -> !Bool

- GHC.Driver.Types: [mi_usages] :: ModIface_ (phase :: ModIfacePhase) -> [Usage]

- GHC.Driver.Types: [mi_used_th] :: ModIface_ (phase :: ModIfacePhase) -> !Bool

- GHC.Driver.Types: [mi_warn_fn] :: ModIfaceBackend -> !OccName -> Maybe WarningTxt

- GHC.Driver.Types: [mi_warns] :: ModIface_ (phase :: ModIfacePhase) -> Warnings

- GHC.Driver.Types: [modBreaks_breakInfo] :: ModBreaks -> IntMap CgBreakInfo

- GHC.Driver.Types: [modBreaks_ccs] :: ModBreaks -> !Array BreakIndex (RemotePtr CostCentre)

- GHC.Driver.Types: [modBreaks_decls] :: ModBreaks -> !Array BreakIndex [String]

- GHC.Driver.Types: [modBreaks_flags] :: ModBreaks -> ForeignRef BreakArray

- GHC.Driver.Types: [modBreaks_locs] :: ModBreaks -> !Array BreakIndex SrcSpan

- GHC.Driver.Types: [modBreaks_vars] :: ModBreaks -> !Array BreakIndex [OccName]

- GHC.Driver.Types: [ms_hie_date] :: ModSummary -> Maybe UTCTime

- GHC.Driver.Types: [ms_hs_date] :: ModSummary -> UTCTime

- GHC.Driver.Types: [ms_hsc_src] :: ModSummary -> HscSource

- GHC.Driver.Types: [ms_hspp_buf] :: ModSummary -> Maybe StringBuffer

- GHC.Driver.Types: [ms_hspp_file] :: ModSummary -> FilePath

- GHC.Driver.Types: [ms_hspp_opts] :: ModSummary -> DynFlags

- GHC.Driver.Types: [ms_iface_date] :: ModSummary -> Maybe UTCTime

- GHC.Driver.Types: [ms_location] :: ModSummary -> ModLocation

- GHC.Driver.Types: [ms_mod] :: ModSummary -> Module

- GHC.Driver.Types: [ms_obj_date] :: ModSummary -> Maybe UTCTime

- GHC.Driver.Types: [ms_parsed_mod] :: ModSummary -> Maybe HsParsedModule

- GHC.Driver.Types: [ms_srcimps] :: ModSummary -> [(Maybe FastString, Located ModuleName)]

- GHC.Driver.Types: [ms_textual_imps] :: ModSummary -> [(Maybe FastString, Located ModuleName)]

- GHC.Driver.Types: [n_ifaces_in, n_decls_in, n_decls_out, n_rules_in, n_rules_out, n_insts_in, n_insts_out] :: EpsStats -> !Int

- GHC.Driver.Types: [targetAllowObjCode] :: Target -> !Bool

- GHC.Driver.Types: [targetContents] :: Target -> !Maybe (InputFileBuffer, UTCTime)

- GHC.Driver.Types: [targetId] :: Target -> !TargetId

- GHC.Driver.Types: [usg_entities] :: Usage -> [(OccName, Fingerprint)]

- GHC.Driver.Types: [usg_exports] :: Usage -> Maybe Fingerprint

- GHC.Driver.Types: [usg_file_hash] :: Usage -> Fingerprint

- GHC.Driver.Types: [usg_file_path] :: Usage -> FilePath

- GHC.Driver.Types: [usg_mod] :: Usage -> Module

- GHC.Driver.Types: [usg_mod_hash] :: Usage -> Fingerprint

- GHC.Driver.Types: [usg_mod_name] :: Usage -> ModuleName

- GHC.Driver.Types: [usg_safe] :: Usage -> IsSafeImport

- GHC.Driver.Types: addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats

- GHC.Driver.Types: addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable

- GHC.Driver.Types: addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable

- GHC.Driver.Types: allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool

- GHC.Driver.Types: anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool

- GHC.Driver.Types: appendStubC :: ForeignStubs -> SDoc -> ForeignStubs

- GHC.Driver.Types: byteCodeOfObject :: Unlinked -> CompiledByteCode

- GHC.Driver.Types: class Monad m => MonadThings m

- GHC.Driver.Types: data CgGuts

- GHC.Driver.Types: data CompiledByteCode

- GHC.Driver.Types: data CompleteMatch

- GHC.Driver.Types: data Dependencies

- GHC.Driver.Types: data EpsStats

- GHC.Driver.Types: data ExternalPackageState

- GHC.Driver.Types: data FindResult

- GHC.Driver.Types: data FixItem

- GHC.Driver.Types: data ForeignSrcLang

- GHC.Driver.Types: data ForeignStubs

- GHC.Driver.Types: data GhcApiError

- GHC.Driver.Types: data HomeModInfo

- GHC.Driver.Types: data HpcInfo

- GHC.Driver.Types: data HsParsedModule

- GHC.Driver.Types: data HscEnv

- GHC.Driver.Types: data HscSource

- GHC.Driver.Types: data HscStatus

- GHC.Driver.Types: data IfaceTrustInfo

- GHC.Driver.Types: data ImportedBy

- GHC.Driver.Types: data ImportedModsVal

- GHC.Driver.Types: data InstalledFindResult

- GHC.Driver.Types: data InteractiveContext

- GHC.Driver.Types: data InteractiveImport

- GHC.Driver.Types: data IsBootInterface

- GHC.Driver.Types: data Linkable

- GHC.Driver.Types: data MetaRequest

- GHC.Driver.Types: data MetaResult

- GHC.Driver.Types: data ModBreaks

- GHC.Driver.Types: data ModDetails

- GHC.Driver.Types: data ModGuts

- GHC.Driver.Types: data ModIfaceBackend

- GHC.Driver.Types: data ModIface_ (phase :: ModIfacePhase)

- GHC.Driver.Types: data ModSummary

- GHC.Driver.Types: data ModuleGraph

- GHC.Driver.Types: data SourceError

- GHC.Driver.Types: data SourceModified

- GHC.Driver.Types: data SptEntry

- GHC.Driver.Types: data Target

- GHC.Driver.Types: data TargetId

- GHC.Driver.Types: data TyThing

- GHC.Driver.Types: data Unlinked

- GHC.Driver.Types: data Usage

- GHC.Driver.Types: data WarningTxt

- GHC.Driver.Types: data Warnings

- GHC.Driver.Types: delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable

- GHC.Driver.Types: deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields

- GHC.Driver.Types: deleteIfaceField :: FieldName -> ModIface -> ModIface

- GHC.Driver.Types: eltsHpt :: HomePackageTable -> [HomeModInfo]

- GHC.Driver.Types: emptyExtensibleFields :: ExtensibleFields

- GHC.Driver.Types: emptyFixityEnv :: FixityEnv

- GHC.Driver.Types: emptyFullModIface :: Module -> ModIface

- GHC.Driver.Types: emptyHomePackageTable :: HomePackageTable

- GHC.Driver.Types: emptyHpcInfo :: AnyHpcUsage -> HpcInfo

- GHC.Driver.Types: emptyIfaceWarnCache :: OccName -> Maybe WarningTxt

- GHC.Driver.Types: emptyInteractiveContext :: DynFlags -> InteractiveContext

- GHC.Driver.Types: emptyMG :: ModuleGraph

- GHC.Driver.Types: emptyModBreaks :: ModBreaks

- GHC.Driver.Types: emptyModDetails :: ModDetails

- GHC.Driver.Types: emptyPackageIfaceTable :: PackageIfaceTable

- GHC.Driver.Types: emptyPartialModIface :: Module -> PartialModIface

- GHC.Driver.Types: emptyTypeEnv :: TypeEnv

- GHC.Driver.Types: extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] -> CompleteMatchMap

- GHC.Driver.Types: extendInteractiveContext :: InteractiveContext -> [TyThing] -> [ClsInst] -> [FamInst] -> Maybe [Type] -> FixityEnv -> InteractiveContext

- GHC.Driver.Types: extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext

- GHC.Driver.Types: extendMG :: ModuleGraph -> ModSummary -> ModuleGraph

- GHC.Driver.Types: extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv

- GHC.Driver.Types: extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv

- GHC.Driver.Types: extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv

- GHC.Driver.Types: filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable

- GHC.Driver.Types: getSafeMode :: IfaceTrustInfo -> SafeHaskellMode

- GHC.Driver.Types: handleFlagWarnings :: DynFlags -> [Warn] -> IO ()

- GHC.Driver.Types: handleSourceError :: MonadCatch m => (SourceError -> m a) -> m a -> m a

- GHC.Driver.Types: home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]

- GHC.Driver.Types: hptCompleteSigs :: HscEnv -> [CompleteMatch]

- GHC.Driver.Types: hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])

- GHC.Driver.Types: hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]

- GHC.Driver.Types: hscEPS :: HscEnv -> IO ExternalPackageState

- GHC.Driver.Types: hscSourceString :: HscSource -> String

- GHC.Driver.Types: icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv

- GHC.Driver.Types: icInScopeTTs :: InteractiveContext -> [TyThing]

- GHC.Driver.Types: icInteractiveModule :: InteractiveContext -> Module

- GHC.Driver.Types: icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified

- GHC.Driver.Types: implicitClassThings :: Class -> [TyThing]

- GHC.Driver.Types: implicitTyConThings :: TyCon -> [TyThing]

- GHC.Driver.Types: implicitTyThings :: TyThing -> [TyThing]

- GHC.Driver.Types: importedByUser :: [ImportedBy] -> [ImportedModsVal]

- GHC.Driver.Types: instance (Control.DeepSeq.NFData (GHC.Driver.Types.IfaceBackendExts phase), Control.DeepSeq.NFData (GHC.Driver.Types.IfaceDeclExts phase)) => Control.DeepSeq.NFData (GHC.Driver.Types.ModIface_ phase)

- GHC.Driver.Types: instance Control.DeepSeq.NFData GHC.Driver.Types.ExtensibleFields

- GHC.Driver.Types: instance Control.Monad.IO.Class.MonadIO GHC.Driver.Types.Hsc

- GHC.Driver.Types: instance GHC.Base.Applicative GHC.Driver.Types.Hsc

- GHC.Driver.Types: instance GHC.Base.Functor GHC.Driver.Types.Hsc

- GHC.Driver.Types: instance GHC.Base.Monad GHC.Driver.Types.Hsc

- GHC.Driver.Types: instance GHC.Classes.Eq GHC.Driver.Types.Dependencies

- GHC.Driver.Types: instance GHC.Classes.Eq GHC.Driver.Types.TargetId

- GHC.Driver.Types: instance GHC.Classes.Eq GHC.Driver.Types.Usage

- GHC.Driver.Types: instance GHC.Classes.Eq GHC.Driver.Types.Warnings

- GHC.Driver.Types: instance GHC.Driver.Session.HasDynFlags GHC.Driver.Types.Hsc

- GHC.Driver.Types: instance GHC.Driver.Types.MonadThings m => GHC.Driver.Types.MonadThings (Control.Monad.Trans.Reader.ReaderT s m)

- GHC.Driver.Types: instance GHC.Exception.Type.Exception GHC.Driver.Types.GhcApiError

- GHC.Driver.Types: instance GHC.Exception.Type.Exception GHC.Driver.Types.SourceError

- GHC.Driver.Types: instance GHC.Show.Show GHC.Driver.Types.GhcApiError

- GHC.Driver.Types: instance GHC.Show.Show GHC.Driver.Types.SourceError

- GHC.Driver.Types: instance GHC.Utils.Binary.Binary GHC.Driver.Types.Dependencies

- GHC.Driver.Types: instance GHC.Utils.Binary.Binary GHC.Driver.Types.ExtensibleFields

- GHC.Driver.Types: instance GHC.Utils.Binary.Binary GHC.Driver.Types.IfaceTrustInfo

- GHC.Driver.Types: instance GHC.Utils.Binary.Binary GHC.Driver.Types.ModIface

- GHC.Driver.Types: instance GHC.Utils.Binary.Binary GHC.Driver.Types.Usage

- GHC.Driver.Types: instance GHC.Utils.Binary.Binary GHC.Driver.Types.Warnings

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.CompleteMatch

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.FixItem

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.IfaceTrustInfo

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.InteractiveImport

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.ModSummary

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.Target

- GHC.Driver.Types: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.TargetId

- GHC.Driver.Types: isBootSummary :: ModSummary -> IsBootInterface

- GHC.Driver.Types: isHpcUsed :: HpcInfo -> AnyHpcUsage

- GHC.Driver.Types: isHsBootOrSig :: HscSource -> Bool

- GHC.Driver.Types: isHsigFile :: HscSource -> Bool

- GHC.Driver.Types: isImplicitTyThing :: TyThing -> Bool

- GHC.Driver.Types: isInterpretable :: Unlinked -> Bool

- GHC.Driver.Types: isObject :: Unlinked -> Bool

- GHC.Driver.Types: isObjectLinkable :: Linkable -> Bool

- GHC.Driver.Types: isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool

- GHC.Driver.Types: linkableObjs :: Linkable -> [FilePath]

- GHC.Driver.Types: listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable

- GHC.Driver.Types: lookupDataCon :: MonadThings m => Name -> m DataCon

- GHC.Driver.Types: lookupFixity :: FixityEnv -> Name -> Fixity

- GHC.Driver.Types: lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo

- GHC.Driver.Types: lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo

- GHC.Driver.Types: lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo

- GHC.Driver.Types: lookupId :: MonadThings m => Name -> m Id

- GHC.Driver.Types: lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface

- GHC.Driver.Types: lookupThing :: MonadThings m => Name -> m TyThing

- GHC.Driver.Types: lookupTyCon :: MonadThings m => Name -> m TyCon

- GHC.Driver.Types: lookupType :: DynFlags -> HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing

- GHC.Driver.Types: lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing

- GHC.Driver.Types: lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)

- GHC.Driver.Types: mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable

- GHC.Driver.Types: mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph

- GHC.Driver.Types: metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized

- GHC.Driver.Types: metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]

- GHC.Driver.Types: metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)

- GHC.Driver.Types: metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)

- GHC.Driver.Types: metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)

- GHC.Driver.Types: mgBootModules :: ModuleGraph -> ModuleSet

- GHC.Driver.Types: mgElemModule :: ModuleGraph -> Module -> Bool

- GHC.Driver.Types: mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary

- GHC.Driver.Types: mgModSummaries :: ModuleGraph -> [ModSummary]

- GHC.Driver.Types: mi_boot :: ModIface -> IsBootInterface

- GHC.Driver.Types: mi_fix :: ModIface -> OccName -> Fixity

- GHC.Driver.Types: mi_free_holes :: ModIface -> UniqDSet ModuleName

- GHC.Driver.Types: mi_semantic_module :: ModIface_ a -> Module

- GHC.Driver.Types: mkApiErr :: DynFlags -> SDoc -> GhcApiError

- GHC.Driver.Types: mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap

- GHC.Driver.Types: mkHsSOName :: Platform -> FilePath -> FilePath

- GHC.Driver.Types: mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity

- GHC.Driver.Types: mkIfaceHashCache :: [(Fingerprint, IfaceDecl)] -> OccName -> Maybe (OccName, Fingerprint)

- GHC.Driver.Types: mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt

- GHC.Driver.Types: mkInteractiveHscEnv :: HscEnv -> HscEnv

- GHC.Driver.Types: mkModuleGraph :: [ModSummary] -> ModuleGraph

- GHC.Driver.Types: mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified

- GHC.Driver.Types: mkQualModule :: DynFlags -> QueryQualifyModule

- GHC.Driver.Types: mkQualPackage :: UnitState -> QueryQualifyPackage

- GHC.Driver.Types: mkSOName :: Platform -> FilePath -> FilePath

- GHC.Driver.Types: mkSrcErr :: ErrorMessages -> SourceError

- GHC.Driver.Types: mkTypeEnv :: [TyThing] -> TypeEnv

- GHC.Driver.Types: mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv

- GHC.Driver.Types: msHiFilePath :: ModSummary -> FilePath

- GHC.Driver.Types: msHsFilePath :: ModSummary -> FilePath

- GHC.Driver.Types: msObjFilePath :: ModSummary -> FilePath

- GHC.Driver.Types: ms_home_allimps :: ModSummary -> [ModuleName]

- GHC.Driver.Types: ms_home_imps :: ModSummary -> [Located ModuleName]

- GHC.Driver.Types: ms_home_srcimps :: ModSummary -> [Located ModuleName]

- GHC.Driver.Types: ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]

- GHC.Driver.Types: ms_installed_mod :: ModSummary -> InstalledModule

- GHC.Driver.Types: ms_mod_name :: ModSummary -> ModuleName

- GHC.Driver.Types: nameOfObject :: Unlinked -> FilePath

- GHC.Driver.Types: needsTemplateHaskellOrQQ :: ModuleGraph -> Bool

- GHC.Driver.Types: newtype ExtensibleFields

- GHC.Driver.Types: newtype Hsc a

- GHC.Driver.Types: noDependencies :: Dependencies

- GHC.Driver.Types: noIfaceTrustInfo :: IfaceTrustInfo

- GHC.Driver.Types: numToTrustInfo :: Word8 -> IfaceTrustInfo

- GHC.Driver.Types: phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang

- GHC.Driver.Types: pkgQual :: UnitState -> PrintUnqualified

- GHC.Driver.Types: plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv

- GHC.Driver.Types: plusWarns :: Warnings -> Warnings -> Warnings

- GHC.Driver.Types: pprHPT :: HomePackageTable -> SDoc

- GHC.Driver.Types: pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc

- GHC.Driver.Types: pprTarget :: Target -> SDoc

- GHC.Driver.Types: pprTargetId :: TargetId -> SDoc

- GHC.Driver.Types: prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv

- GHC.Driver.Types: printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()

- GHC.Driver.Types: readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)

- GHC.Driver.Types: readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)

- GHC.Driver.Types: readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)

- GHC.Driver.Types: renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName

- GHC.Driver.Types: runHsc :: HscEnv -> Hsc a -> IO a

- GHC.Driver.Types: runInteractiveHsc :: HscEnv -> Hsc a -> IO a

- GHC.Driver.Types: setInteractivePackage :: HscEnv -> HscEnv

- GHC.Driver.Types: setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext

- GHC.Driver.Types: setSafeMode :: SafeHaskellMode -> IfaceTrustInfo

- GHC.Driver.Types: showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String

- GHC.Driver.Types: soExt :: Platform -> FilePath

- GHC.Driver.Types: srcErrorMessages :: SourceError -> ErrorMessages

- GHC.Driver.Types: substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext

- GHC.Driver.Types: throwErrors :: MonadIO io => ErrorMessages -> io a

- GHC.Driver.Types: throwOneError :: MonadIO io => ErrMsg -> io a

- GHC.Driver.Types: trustInfoToNum :: IfaceTrustInfo -> Word8

- GHC.Driver.Types: tyThingAvailInfo :: TyThing -> [AvailInfo]

- GHC.Driver.Types: tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched

- GHC.Driver.Types: tyThingConLike :: HasDebugCallStack => TyThing -> ConLike

- GHC.Driver.Types: tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon

- GHC.Driver.Types: tyThingId :: HasDebugCallStack => TyThing -> Id

- GHC.Driver.Types: tyThingParent_maybe :: TyThing -> Maybe TyThing

- GHC.Driver.Types: tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon

- GHC.Driver.Types: tyThingsTyCoVars :: [TyThing] -> TyCoVarSet

- GHC.Driver.Types: type AnyHpcUsage = Bool

- GHC.Driver.Types: type CompleteMatchMap = UniqFM Name [CompleteMatch]

- GHC.Driver.Types: type FieldName = String

- GHC.Driver.Types: type FinderCache = InstalledModuleEnv InstalledFindResult

- GHC.Driver.Types: type FixityEnv = NameEnv FixItem

- GHC.Driver.Types: type HomePackageTable = DModuleNameEnv HomeModInfo

- GHC.Driver.Types: type IfaceExport = AvailInfo

- GHC.Driver.Types: type ImportedMods = ModuleEnv [ImportedBy]

- GHC.Driver.Types: type InputFileBuffer = StringBuffer

- GHC.Driver.Types: type IsSafeImport = Bool

- GHC.Driver.Types: type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult

- GHC.Driver.Types: type ModIface = ModIface_ 'ModIfaceFinal

- GHC.Driver.Types: type PackageCompleteMatchMap = CompleteMatchMap

- GHC.Driver.Types: type PackageFamInstEnv = FamInstEnv

- GHC.Driver.Types: type PackageIfaceTable = ModuleEnv ModIface

- GHC.Driver.Types: type PackageInstEnv = InstEnv

- GHC.Driver.Types: type PackageRuleBase = RuleBase

- GHC.Driver.Types: type PackageTypeEnv = TypeEnv

- GHC.Driver.Types: type PartialModIface = ModIface_ 'ModIfaceCore

- GHC.Driver.Types: type TypeEnv = NameEnv TyThing

- GHC.Driver.Types: type WhetherHasOrphans = Bool

- GHC.Driver.Types: typeEnvClasses :: TypeEnv -> [Class]

- GHC.Driver.Types: typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]

- GHC.Driver.Types: typeEnvDataCons :: TypeEnv -> [DataCon]

- GHC.Driver.Types: typeEnvElts :: TypeEnv -> [TyThing]

- GHC.Driver.Types: typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv

- GHC.Driver.Types: typeEnvIds :: TypeEnv -> [Id]

- GHC.Driver.Types: typeEnvPatSyns :: TypeEnv -> [PatSyn]

- GHC.Driver.Types: typeEnvTyCons :: TypeEnv -> [TyCon]

- GHC.Driver.Types: updNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c

- GHC.Driver.Types: writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields

- GHC.Driver.Types: writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface

- GHC.Driver.Types: writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface

- GHC.Driver.Ways: WayCustom :: String -> Way

- GHC.Driver.Ways: WayDebug :: Way

- GHC.Driver.Ways: WayDyn :: Way

- GHC.Driver.Ways: WayEventLog :: Way

- GHC.Driver.Ways: WayProf :: Way

- GHC.Driver.Ways: WayThreaded :: Way

- GHC.Driver.Ways: allowed_combination :: Set Way -> Bool

- GHC.Driver.Ways: data Way

- GHC.Driver.Ways: hasWay :: Set Way -> Way -> Bool

- GHC.Driver.Ways: hostFullWays :: Set Way

- GHC.Driver.Ways: hostIsDynamic :: Bool

- GHC.Driver.Ways: hostIsProfiled :: Bool

- GHC.Driver.Ways: instance GHC.Classes.Eq GHC.Driver.Ways.Way

- GHC.Driver.Ways: instance GHC.Classes.Ord GHC.Driver.Ways.Way

- GHC.Driver.Ways: instance GHC.Show.Show GHC.Driver.Ways.Way

- GHC.Driver.Ways: wayDesc :: Way -> String

- GHC.Driver.Ways: wayGeneralFlags :: Platform -> Way -> [GeneralFlag]

- GHC.Driver.Ways: wayOptP :: Platform -> Way -> [String]

- GHC.Driver.Ways: wayOptc :: Platform -> Way -> [String]

- GHC.Driver.Ways: wayOptl :: Platform -> Way -> [String]

- GHC.Driver.Ways: wayRTSOnly :: Way -> Bool

- GHC.Driver.Ways: wayTag :: Way -> String

- GHC.Driver.Ways: wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]

- GHC.Driver.Ways: waysBuildTag :: Set Way -> String

- GHC.Driver.Ways: waysTag :: Set Way -> String

- GHC.Hs.Binds: ABE :: XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p

- GHC.Hs.Binds: AbsBinds :: XAbsBinds idL idR -> [TyVar] -> [EvVar] -> [ABExport idL] -> [TcEvBinds] -> LHsBinds idL -> Bool -> HsBindLR idL idR

- GHC.Hs.Binds: ClassOpSig :: XClassOpSig pass -> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass

- GHC.Hs.Binds: CompleteMatchSig :: XCompleteMatchSig pass -> SourceText -> Located [Located (IdP pass)] -> Maybe (Located (IdP pass)) -> Sig pass

- GHC.Hs.Binds: EmptyLocalBinds :: XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR

- GHC.Hs.Binds: ExplicitBidirectional :: MatchGroup id (LHsExpr id) -> HsPatSynDir id

- GHC.Hs.Binds: FixSig :: XFixSig pass -> FixitySig pass -> Sig pass

- GHC.Hs.Binds: FixitySig :: XFixitySig pass -> [Located (IdP pass)] -> Fixity -> FixitySig pass

- GHC.Hs.Binds: FunBind :: XFunBind idL idR -> Located (IdP idL) -> MatchGroup idR (LHsExpr idR) -> [Tickish Id] -> HsBindLR idL idR

- GHC.Hs.Binds: HsIPBinds :: XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR

- GHC.Hs.Binds: HsValBinds :: XHsValBinds idL idR -> HsValBindsLR idL idR -> HsLocalBindsLR idL idR

- GHC.Hs.Binds: IPBind :: XCIPBind id -> Either (Located HsIPName) (IdP id) -> LHsExpr id -> IPBind id

- GHC.Hs.Binds: IPBinds :: XIPBinds id -> [LIPBind id] -> HsIPBinds id

- GHC.Hs.Binds: IdSig :: XIdSig pass -> Id -> Sig pass

- GHC.Hs.Binds: ImplicitBidirectional :: HsPatSynDir id

- GHC.Hs.Binds: InlineSig :: XInlineSig pass -> Located (IdP pass) -> InlinePragma -> Sig pass

- GHC.Hs.Binds: IsDefaultMethod :: TcSpecPrags

- GHC.Hs.Binds: MinimalSig :: XMinimalSig pass -> SourceText -> LBooleanFormula (Located (IdP pass)) -> Sig pass

- GHC.Hs.Binds: NPatBindTc :: NameSet -> Type -> NPatBindTc

- GHC.Hs.Binds: PSB :: XPSB idL idR -> Located (IdP idL) -> HsPatSynDetails (Located (IdP idR)) -> LPat idR -> HsPatSynDir idR -> PatSynBind idL idR

- GHC.Hs.Binds: PatBind :: XPatBind idL idR -> LPat idL -> GRHSs idR (LHsExpr idR) -> ([Tickish Id], [[Tickish Id]]) -> HsBindLR idL idR

- GHC.Hs.Binds: PatSynBind :: XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR

- GHC.Hs.Binds: PatSynSig :: XPatSynSig pass -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass

- GHC.Hs.Binds: RecordPatSynField :: a -> a -> RecordPatSynField a

- GHC.Hs.Binds: SCCFunSig :: XSCCFunSig pass -> SourceText -> Located (IdP pass) -> Maybe (Located StringLiteral) -> Sig pass

- GHC.Hs.Binds: SpecInstSig :: XSpecInstSig pass -> SourceText -> LHsSigType pass -> Sig pass

- GHC.Hs.Binds: SpecPrag :: Id -> HsWrapper -> InlinePragma -> TcSpecPrag

- GHC.Hs.Binds: SpecPrags :: [LTcSpecPrag] -> TcSpecPrags

- GHC.Hs.Binds: SpecSig :: XSpecSig pass -> Located (IdP pass) -> [LHsSigType pass] -> InlinePragma -> Sig pass

- GHC.Hs.Binds: TypeSig :: XTypeSig pass -> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass

- GHC.Hs.Binds: Unidirectional :: HsPatSynDir id

- GHC.Hs.Binds: ValBinds :: XValBinds idL idR -> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR

- GHC.Hs.Binds: VarBind :: XVarBind idL idR -> IdP idL -> LHsExpr idR -> HsBindLR idL idR

- GHC.Hs.Binds: XABExport :: !XXABExport p -> ABExport p

- GHC.Hs.Binds: XFixitySig :: !XXFixitySig pass -> FixitySig pass

- GHC.Hs.Binds: XHsBindsLR :: !XXHsBindsLR idL idR -> HsBindLR idL idR

- GHC.Hs.Binds: XHsIPBinds :: !XXHsIPBinds id -> HsIPBinds id

- GHC.Hs.Binds: XHsLocalBindsLR :: !XXHsLocalBindsLR idL idR -> HsLocalBindsLR idL idR

- GHC.Hs.Binds: XIPBind :: !XXIPBind id -> IPBind id

- GHC.Hs.Binds: XPatSynBind :: !XXPatSynBind idL idR -> PatSynBind idL idR

- GHC.Hs.Binds: XSig :: !XXSig pass -> Sig pass

- GHC.Hs.Binds: XValBindsLR :: !XXValBindsLR idL idR -> HsValBindsLR idL idR

- GHC.Hs.Binds: [abe_ext] :: ABExport p -> XABE p

- GHC.Hs.Binds: [abe_mono] :: ABExport p -> IdP p

- GHC.Hs.Binds: [abe_poly] :: ABExport p -> IdP p

- GHC.Hs.Binds: [abe_prags] :: ABExport p -> TcSpecPrags

- GHC.Hs.Binds: [abe_wrap] :: ABExport p -> HsWrapper

- GHC.Hs.Binds: [abs_binds] :: HsBindLR idL idR -> LHsBinds idL

- GHC.Hs.Binds: [abs_ev_binds] :: HsBindLR idL idR -> [TcEvBinds]

- GHC.Hs.Binds: [abs_ev_vars] :: HsBindLR idL idR -> [EvVar]

- GHC.Hs.Binds: [abs_exports] :: HsBindLR idL idR -> [ABExport idL]

- GHC.Hs.Binds: [abs_ext] :: HsBindLR idL idR -> XAbsBinds idL idR

- GHC.Hs.Binds: [abs_sig] :: HsBindLR idL idR -> Bool

- GHC.Hs.Binds: [abs_tvs] :: HsBindLR idL idR -> [TyVar]

- GHC.Hs.Binds: [fun_ext] :: HsBindLR idL idR -> XFunBind idL idR

- GHC.Hs.Binds: [fun_id] :: HsBindLR idL idR -> Located (IdP idL)

- GHC.Hs.Binds: [fun_matches] :: HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)

- GHC.Hs.Binds: [fun_tick] :: HsBindLR idL idR -> [Tickish Id]

- GHC.Hs.Binds: [pat_ext] :: HsBindLR idL idR -> XPatBind idL idR

- GHC.Hs.Binds: [pat_fvs] :: NPatBindTc -> NameSet

- GHC.Hs.Binds: [pat_lhs] :: HsBindLR idL idR -> LPat idL

- GHC.Hs.Binds: [pat_rhs] :: HsBindLR idL idR -> GRHSs idR (LHsExpr idR)

- GHC.Hs.Binds: [pat_rhs_ty] :: NPatBindTc -> Type

- GHC.Hs.Binds: [pat_ticks] :: HsBindLR idL idR -> ([Tickish Id], [[Tickish Id]])

- GHC.Hs.Binds: [psb_args] :: PatSynBind idL idR -> HsPatSynDetails (Located (IdP idR))

- GHC.Hs.Binds: [psb_def] :: PatSynBind idL idR -> LPat idR

- GHC.Hs.Binds: [psb_dir] :: PatSynBind idL idR -> HsPatSynDir idR

- GHC.Hs.Binds: [psb_ext] :: PatSynBind idL idR -> XPSB idL idR

- GHC.Hs.Binds: [psb_id] :: PatSynBind idL idR -> Located (IdP idL)

- GHC.Hs.Binds: [recordPatSynPatVar] :: RecordPatSynField a -> a

- GHC.Hs.Binds: [recordPatSynSelectorId] :: RecordPatSynField a -> a

- GHC.Hs.Binds: [var_ext] :: HsBindLR idL idR -> XVarBind idL idR

- GHC.Hs.Binds: [var_id] :: HsBindLR idL idR -> IdP idL

- GHC.Hs.Binds: [var_rhs] :: HsBindLR idL idR -> LHsExpr idR

- GHC.Hs.Binds: data ABExport p

- GHC.Hs.Binds: data FixitySig pass

- GHC.Hs.Binds: data HsBindLR idL idR

- GHC.Hs.Binds: data HsIPBinds id

- GHC.Hs.Binds: data HsLocalBindsLR idL idR

- GHC.Hs.Binds: data HsPatSynDir id

- GHC.Hs.Binds: data HsValBindsLR idL idR

- GHC.Hs.Binds: data IPBind id

- GHC.Hs.Binds: data NPatBindTc

- GHC.Hs.Binds: data PatSynBind idL idR

- GHC.Hs.Binds: data RecordPatSynField a

- GHC.Hs.Binds: data Sig pass

- GHC.Hs.Binds: data TcSpecPrag

- GHC.Hs.Binds: data TcSpecPrags

- GHC.Hs.Binds: hasSpecPrags :: TcSpecPrags -> Bool

- GHC.Hs.Binds: hsSigDoc :: Sig name -> SDoc

- GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId l, GHC.Hs.Extension.OutputableBndrId r, GHC.Utils.Outputable.Outputable (GHC.Hs.Extension.XXPatSynBind (GHC.Hs.Extension.GhcPass l) (GHC.Hs.Extension.GhcPass r))) => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.PatSynBind (GHC.Hs.Extension.GhcPass l) (GHC.Hs.Extension.GhcPass r))

- GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr) => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.HsBindLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr))

- GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr) => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.HsLocalBindsLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr))

- GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr) => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.HsValBindsLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr))

- GHC.Hs.Binds: instance Data.Data.Data GHC.Hs.Binds.NPatBindTc

- GHC.Hs.Binds: instance Data.Data.Data GHC.Hs.Binds.TcSpecPrag

- GHC.Hs.Binds: instance Data.Data.Data GHC.Hs.Binds.TcSpecPrags

- GHC.Hs.Binds: instance Data.Data.Data a => Data.Data.Data (GHC.Hs.Binds.RecordPatSynField a)

- GHC.Hs.Binds: instance Data.Foldable.Foldable GHC.Hs.Binds.RecordPatSynField

- GHC.Hs.Binds: instance Data.Traversable.Traversable GHC.Hs.Binds.RecordPatSynField

- GHC.Hs.Binds: instance GHC.Base.Functor GHC.Hs.Binds.RecordPatSynField

- GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.ABExport (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.FixitySig (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.HsIPBinds (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.IPBind (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.Sig (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Binds: instance GHC.Utils.Outputable.Outputable GHC.Hs.Binds.TcSpecPrag

- GHC.Hs.Binds: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Hs.Binds.RecordPatSynField a)

- GHC.Hs.Binds: isCompleteMatchSig :: LSig name -> Bool

- GHC.Hs.Binds: isDefaultMethod :: TcSpecPrags -> Bool

- GHC.Hs.Binds: isFixityLSig :: LSig name -> Bool

- GHC.Hs.Binds: isInlineLSig :: LSig name -> Bool

- GHC.Hs.Binds: isMinimalLSig :: LSig name -> Bool

- GHC.Hs.Binds: isPragLSig :: LSig name -> Bool

- GHC.Hs.Binds: isSCCFunSig :: LSig name -> Bool

- GHC.Hs.Binds: isSpecInstLSig :: LSig name -> Bool

- GHC.Hs.Binds: isSpecLSig :: LSig name -> Bool

- GHC.Hs.Binds: isTypeLSig :: LSig name -> Bool

- GHC.Hs.Binds: noSpecPrags :: TcSpecPrags

- GHC.Hs.Binds: type HsBind id = HsBindLR id id

- GHC.Hs.Binds: type HsLocalBinds id = HsLocalBindsLR id id

- GHC.Hs.Binds: type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]

- GHC.Hs.Binds: type HsValBinds id = HsValBindsLR id id

- GHC.Hs.Binds: type LFixitySig pass = Located (FixitySig pass)

- GHC.Hs.Binds: type LHsBind id = LHsBindLR id id

- GHC.Hs.Binds: type LHsBindLR idL idR = Located (HsBindLR idL idR)

- GHC.Hs.Binds: type LHsBinds id = LHsBindsLR id id

- GHC.Hs.Binds: type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)

- GHC.Hs.Binds: type LHsLocalBinds id = Located (HsLocalBinds id)

- GHC.Hs.Binds: type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)

- GHC.Hs.Binds: type LIPBind id = Located (IPBind id)

- GHC.Hs.Binds: type LSig pass = Located (Sig pass)

- GHC.Hs.Binds: type LTcSpecPrag = Located TcSpecPrag

- GHC.Hs.Decls: [con_qvars] :: ConDecl pass -> [LHsTyVarBndr Specificity pass]

- GHC.Hs.Decls: getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn

- GHC.Hs.Decls: hsConDeclArgTys :: HsConDeclDetails pass -> [HsScaled pass (LBangType pass)]

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.CImportSpec

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.DataDeclRn

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.DocDecl

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.ForeignExport

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.ForeignImport

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.HsRuleRn

- GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.NewOrData

- GHC.Hs.Decls: instance Data.Data.Data pass => Data.Data.Data (GHC.Hs.Decls.AnnProvenance pass)

- GHC.Hs.Decls: instance Data.Foldable.Foldable GHC.Hs.Decls.AnnProvenance

- GHC.Hs.Decls: instance Data.Traversable.Traversable GHC.Hs.Decls.AnnProvenance

- GHC.Hs.Decls: instance GHC.Base.Functor GHC.Hs.Decls.AnnProvenance

- GHC.Hs.Decls: instance GHC.Classes.Eq GHC.Hs.Decls.NewOrData

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.AnnDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.ClsInstDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.ConDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.DataFamInstDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.DefaultDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.DerivDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.DerivStrategy (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.FamilyDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.ForeignDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.HsDataDefn (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.HsDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.HsDerivingClause (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.HsGroup (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.InstDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.RuleBndr (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.RuleDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.RuleDecls (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.SpliceDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.StandaloneKindSig (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.TyClDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.TyClGroup (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.TyFamInstDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: instance GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.FamilyInfo pass)

- GHC.Hs.Decls: instance GHC.Utils.Outputable.Outputable GHC.Hs.Decls.DocDecl

- GHC.Hs.Decls: instance GHC.Utils.Outputable.Outputable GHC.Hs.Decls.ForeignExport

- GHC.Hs.Decls: instance GHC.Utils.Outputable.Outputable GHC.Hs.Decls.ForeignImport

- GHC.Hs.Decls: instance GHC.Utils.Outputable.Outputable GHC.Hs.Decls.NewOrData

- GHC.Hs.Decls: instance GHC.Utils.Outputable.OutputableBndr (GHC.Hs.Extension.IdP (GHC.Hs.Extension.GhcPass p)) => GHC.Utils.Outputable.Outputable (GHC.Hs.Decls.RoleAnnotDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Decls: newtype TyFamInstDecl pass

- GHC.Hs.Decls: type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs) " Here, the @pats@ are type patterns (with kind and type bndrs). See Note [Family instance declaration binders]"

- GHC.Hs.Decls: type HsConDeclDetails pass = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass])

- GHC.Hs.Decls: type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)

- GHC.Hs.Expr: ApplicativeArgMany :: XApplicativeArgMany idL -> [ExprLStmt idL] -> HsExpr idL -> LPat idL -> HsStmtContext GhcRn -> ApplicativeArg idL

- GHC.Hs.Expr: ApplicativeArgOne :: XApplicativeArgOne idL -> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL

- GHC.Hs.Expr: ApplicativeStmt :: XApplicativeStmt idL idR body -> [(SyntaxExpr idR, ApplicativeArg idL)] -> Maybe (SyntaxExpr idR) -> StmtLR idL idR body

- GHC.Hs.Expr: ArithSeq :: XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p

- GHC.Hs.Expr: ArrowExpr :: HsStmtContext p

- GHC.Hs.Expr: BareSplice :: SpliceDecoration

- GHC.Hs.Expr: BindStmt :: XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body

- GHC.Hs.Expr: BodyStmt :: XBodyStmt idL idR body -> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body

- GHC.Hs.Expr: CaseAlt :: HsMatchContext p

- GHC.Hs.Expr: DecBrG :: XDecBrG p -> HsGroup p -> HsBracket p

- GHC.Hs.Expr: DecBrL :: XDecBrL p -> [LHsDecl p] -> HsBracket p

- GHC.Hs.Expr: DoExpr :: Maybe ModuleName -> HsStmtContext p

- GHC.Hs.Expr: DollarSplice :: SpliceDecoration

- GHC.Hs.Expr: ExpBr :: XExpBr p -> LHsExpr p -> HsBracket p

- GHC.Hs.Expr: ExplicitList :: XExplicitList p -> Maybe (SyntaxExpr p) -> [LHsExpr p] -> HsExpr p

- GHC.Hs.Expr: ExplicitSum :: XExplicitSum p -> ConTag -> Arity -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: ExplicitTuple :: XExplicitTuple p -> [LHsTupArg p] -> Boxity -> HsExpr p

- GHC.Hs.Expr: ExprWithTySig :: XExprWithTySig p -> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p

- GHC.Hs.Expr: From :: LHsExpr id -> ArithSeqInfo id

- GHC.Hs.Expr: FromThen :: LHsExpr id -> LHsExpr id -> ArithSeqInfo id

- GHC.Hs.Expr: FromThenTo :: LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id

- GHC.Hs.Expr: FromTo :: LHsExpr id -> LHsExpr id -> ArithSeqInfo id

- GHC.Hs.Expr: FunRhs :: LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p

- GHC.Hs.Expr: GRHS :: XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body

- GHC.Hs.Expr: GRHSs :: XCGRHSs p body -> [LGRHS p body] -> LHsLocalBinds p -> GRHSs p body

- GHC.Hs.Expr: GhciStmtCtxt :: HsStmtContext p

- GHC.Hs.Expr: GroupForm :: TransForm

- GHC.Hs.Expr: HsApp :: XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsAppType :: XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p

- GHC.Hs.Expr: HsBinTick :: XBinTick p -> Int -> Int -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsBracket :: XBracket p -> HsBracket p -> HsExpr p

- GHC.Hs.Expr: HsCase :: XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p

- GHC.Hs.Expr: HsCmdApp :: XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id

- GHC.Hs.Expr: HsCmdArrApp :: XCmdArrApp id -> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id

- GHC.Hs.Expr: HsCmdArrForm :: XCmdArrForm id -> LHsExpr id -> LexicalFixity -> Maybe Fixity -> [LHsCmdTop id] -> HsCmd id

- GHC.Hs.Expr: HsCmdCase :: XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id

- GHC.Hs.Expr: HsCmdDo :: XCmdDo id -> Located [CmdLStmt id] -> HsCmd id

- GHC.Hs.Expr: HsCmdIf :: XCmdIf id -> SyntaxExpr id -> LHsExpr id -> LHsCmd id -> LHsCmd id -> HsCmd id

- GHC.Hs.Expr: HsCmdLam :: XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id

- GHC.Hs.Expr: HsCmdLamCase :: XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id

- GHC.Hs.Expr: HsCmdLet :: XCmdLet id -> LHsLocalBinds id -> LHsCmd id -> HsCmd id

- GHC.Hs.Expr: HsCmdPar :: XCmdPar id -> LHsCmd id -> HsCmd id

- GHC.Hs.Expr: HsCmdTop :: XCmdTop p -> LHsCmd p -> HsCmdTop p

- GHC.Hs.Expr: HsConLikeOut :: XConLikeOut p -> ConLike -> HsExpr p

- GHC.Hs.Expr: HsDo :: XDo p -> HsStmtContext GhcRn -> Located [ExprLStmt p] -> HsExpr p

- GHC.Hs.Expr: HsFirstOrderApp :: HsArrAppType

- GHC.Hs.Expr: HsHigherOrderApp :: HsArrAppType

- GHC.Hs.Expr: HsIPVar :: XIPVar p -> HsIPName -> HsExpr p

- GHC.Hs.Expr: HsIf :: XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsLam :: XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p

- GHC.Hs.Expr: HsLamCase :: XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p

- GHC.Hs.Expr: HsLet :: XLet p -> LHsLocalBinds p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsLit :: XLitE p -> HsLit p -> HsExpr p

- GHC.Hs.Expr: HsMultiIf :: XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p

- GHC.Hs.Expr: HsOverLabel :: XOverLabel p -> Maybe (IdP p) -> FastString -> HsExpr p

- GHC.Hs.Expr: HsOverLit :: XOverLitE p -> HsOverLit p -> HsExpr p

- GHC.Hs.Expr: HsPar :: XPar p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsPragE :: XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsPragSCC :: XSCC p -> SourceText -> StringLiteral -> HsPragE p

- GHC.Hs.Expr: HsPragTick :: XTickPragma p -> SourceText -> (StringLiteral, (Int, Int), (Int, Int)) -> ((SourceText, SourceText), (SourceText, SourceText)) -> HsPragE p

- GHC.Hs.Expr: HsProc :: XProc p -> LPat p -> LHsCmdTop p -> HsExpr p

- GHC.Hs.Expr: HsQuasiQuote :: XQuasiQuote id -> IdP id -> IdP id -> SrcSpan -> FastString -> HsSplice id

- GHC.Hs.Expr: HsRecFld :: XRecFld p -> AmbiguousFieldOcc p -> HsExpr p

- GHC.Hs.Expr: HsRnBracketOut :: XRnBracketOut p -> HsBracket GhcRn -> [PendingRnSplice] -> HsExpr p

- GHC.Hs.Expr: HsSpliceE :: XSpliceE p -> HsSplice p -> HsExpr p

- GHC.Hs.Expr: HsSpliced :: XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id

- GHC.Hs.Expr: HsSplicedExpr :: HsExpr id -> HsSplicedThing id

- GHC.Hs.Expr: HsSplicedPat :: Pat id -> HsSplicedThing id

- GHC.Hs.Expr: HsSplicedTy :: HsType id -> HsSplicedThing id

- GHC.Hs.Expr: HsStatic :: XStatic p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsTcBracketOut :: XTcBracketOut p -> Maybe QuoteWrapper -> HsBracket GhcRn -> [PendingTcSplice] -> HsExpr p

- GHC.Hs.Expr: HsTick :: XTick p -> Tickish (IdP p) -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: HsTypedSplice :: XTypedSplice id -> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id

- GHC.Hs.Expr: HsUnboundVar :: XUnboundVar p -> OccName -> HsExpr p

- GHC.Hs.Expr: HsUntypedSplice :: XUntypedSplice id -> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id

- GHC.Hs.Expr: HsVar :: XVar p -> Located (IdP p) -> HsExpr p

- GHC.Hs.Expr: IfAlt :: HsMatchContext p

- GHC.Hs.Expr: LambdaExpr :: HsMatchContext p

- GHC.Hs.Expr: LastStmt :: XLastStmt idL idR body -> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body

- GHC.Hs.Expr: LetStmt :: XLetStmt idL idR body -> LHsLocalBindsLR idL idR -> StmtLR idL idR body

- GHC.Hs.Expr: ListComp :: HsStmtContext p

- GHC.Hs.Expr: MDoExpr :: Maybe ModuleName -> HsStmtContext p

- GHC.Hs.Expr: MG :: XMG p body -> Located [LMatch p body] -> Origin -> MatchGroup p body

- GHC.Hs.Expr: Match :: XCMatch p body -> HsMatchContext (NoGhcTc p) -> [LPat p] -> GRHSs p body -> Match p body

- GHC.Hs.Expr: MatchGroupTc :: [Scaled Type] -> Type -> MatchGroupTc

- GHC.Hs.Expr: Missing :: XMissing id -> HsTupArg id

- GHC.Hs.Expr: MonadComp :: HsStmtContext p

- GHC.Hs.Expr: NegApp :: XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p

- GHC.Hs.Expr: OpApp :: XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: ParStmt :: XParStmt idL idR body -> [ParStmtBlock idL idR] -> HsExpr idR -> SyntaxExpr idR -> StmtLR idL idR body

- GHC.Hs.Expr: ParStmtBlock :: XParStmtBlock idL idR -> [ExprLStmt idL] -> [IdP idR] -> SyntaxExpr idR -> ParStmtBlock idL idR

- GHC.Hs.Expr: ParStmtCtxt :: HsStmtContext p -> HsStmtContext p

- GHC.Hs.Expr: PatBindGuards :: HsMatchContext p

- GHC.Hs.Expr: PatBindRhs :: HsMatchContext p

- GHC.Hs.Expr: PatBr :: XPatBr p -> LPat p -> HsBracket p

- GHC.Hs.Expr: PatGuard :: HsMatchContext p -> HsStmtContext p

- GHC.Hs.Expr: PatSyn :: HsMatchContext p

- GHC.Hs.Expr: Present :: XPresent id -> LHsExpr id -> HsTupArg id

- GHC.Hs.Expr: ProcExpr :: HsMatchContext p

- GHC.Hs.Expr: RecStmt :: XRecStmt idL idR body -> [LStmtLR idL idR body] -> [IdP idR] -> [IdP idR] -> SyntaxExpr idR -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body

- GHC.Hs.Expr: RecUpd :: HsMatchContext p

- GHC.Hs.Expr: RecordCon :: XRecordCon p -> Located (IdP p) -> HsRecordBinds p -> HsExpr p

- GHC.Hs.Expr: RecordConTc :: ConLike -> PostTcExpr -> RecordConTc

- GHC.Hs.Expr: RecordUpd :: XRecordUpd p -> LHsExpr p -> [LHsRecUpdField p] -> HsExpr p

- GHC.Hs.Expr: SectionL :: XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: SectionR :: XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p

- GHC.Hs.Expr: StmtCtxt :: HsStmtContext p -> HsMatchContext p

- GHC.Hs.Expr: TExpBr :: XTExpBr p -> LHsExpr p -> HsBracket p

- GHC.Hs.Expr: ThModFinalizers :: [ForeignRef (Q ())] -> ThModFinalizers

- GHC.Hs.Expr: ThPatQuote :: HsMatchContext p

- GHC.Hs.Expr: ThPatSplice :: HsMatchContext p

- GHC.Hs.Expr: ThenForm :: TransForm

- GHC.Hs.Expr: TransStmt :: XTransStmt idL idR body -> TransForm -> [ExprLStmt idL] -> [(IdP idR, IdP idR)] -> LHsExpr idR -> Maybe (LHsExpr idR) -> SyntaxExpr idR -> SyntaxExpr idR -> HsExpr idR -> StmtLR idL idR body

- GHC.Hs.Expr: TransStmtCtxt :: HsStmtContext p -> HsStmtContext p

- GHC.Hs.Expr: TypBr :: XTypBr p -> LHsType p -> HsBracket p

- GHC.Hs.Expr: UntypedDeclSplice :: UntypedSpliceFlavour

- GHC.Hs.Expr: UntypedExpSplice :: UntypedSpliceFlavour

- GHC.Hs.Expr: UntypedPatSplice :: UntypedSpliceFlavour

- GHC.Hs.Expr: UntypedTypeSplice :: UntypedSpliceFlavour

- GHC.Hs.Expr: VarBr :: XVarBr p -> Bool -> IdP p -> HsBracket p

- GHC.Hs.Expr: XApplicativeArg :: !XXApplicativeArg idL -> ApplicativeArg idL

- GHC.Hs.Expr: XBracket :: !XXBracket p -> HsBracket p

- GHC.Hs.Expr: XCmd :: !XXCmd id -> HsCmd id

- GHC.Hs.Expr: XCmdTop :: !XXCmdTop p -> HsCmdTop p

- GHC.Hs.Expr: XExpr :: !XXExpr p -> HsExpr p

- GHC.Hs.Expr: XGRHS :: !XXGRHS p body -> GRHS p body

- GHC.Hs.Expr: XGRHSs :: !XXGRHSs p body -> GRHSs p body

- GHC.Hs.Expr: XHsPragE :: !XXPragE p -> HsPragE p

- GHC.Hs.Expr: XMatch :: !XXMatch p body -> Match p body

- GHC.Hs.Expr: XMatchGroup :: !XXMatchGroup p body -> MatchGroup p body

- GHC.Hs.Expr: XParStmtBlock :: !XXParStmtBlock idL idR -> ParStmtBlock idL idR

- GHC.Hs.Expr: XSplice :: !XXSplice id -> HsSplice id

- GHC.Hs.Expr: XStmtLR :: !XXStmtLR idL idR body -> StmtLR idL idR body

- GHC.Hs.Expr: XTupArg :: !XXTupArg id -> HsTupArg id

- GHC.Hs.Expr: [app_arg_pattern] :: ApplicativeArg idL -> LPat idL

- GHC.Hs.Expr: [app_stmts] :: ApplicativeArg idL -> [ExprLStmt idL]

- GHC.Hs.Expr: [arg_expr] :: ApplicativeArg idL -> LHsExpr idL

- GHC.Hs.Expr: [bv_pattern] :: ApplicativeArg idL -> LPat idL

- GHC.Hs.Expr: [final_expr] :: ApplicativeArg idL -> HsExpr idL

- GHC.Hs.Expr: [grhssExt] :: GRHSs p body -> XCGRHSs p body

- GHC.Hs.Expr: [grhssGRHSs] :: GRHSs p body -> [LGRHS p body]

- GHC.Hs.Expr: [grhssLocalBinds] :: GRHSs p body -> LHsLocalBinds p

- GHC.Hs.Expr: [is_body_stmt] :: ApplicativeArg idL -> Bool

- GHC.Hs.Expr: [m_ctxt] :: Match p body -> HsMatchContext (NoGhcTc p)

- GHC.Hs.Expr: [m_ext] :: Match p body -> XCMatch p body

- GHC.Hs.Expr: [m_grhss] :: Match p body -> GRHSs p body

- GHC.Hs.Expr: [m_pats] :: Match p body -> [LPat p]

- GHC.Hs.Expr: [mc_fixity] :: HsMatchContext p -> LexicalFixity

- GHC.Hs.Expr: [mc_fun] :: HsMatchContext p -> LIdP p

- GHC.Hs.Expr: [mc_strictness] :: HsMatchContext p -> SrcStrictness

- GHC.Hs.Expr: [mg_alts] :: MatchGroup p body -> Located [LMatch p body]

- GHC.Hs.Expr: [mg_arg_tys] :: MatchGroupTc -> [Scaled Type]

- GHC.Hs.Expr: [mg_ext] :: MatchGroup p body -> XMG p body

- GHC.Hs.Expr: [mg_origin] :: MatchGroup p body -> Origin

- GHC.Hs.Expr: [mg_res_ty] :: MatchGroupTc -> Type

- GHC.Hs.Expr: [rcon_con_expr] :: RecordConTc -> PostTcExpr

- GHC.Hs.Expr: [rcon_con_like] :: RecordConTc -> ConLike

- GHC.Hs.Expr: [rcon_con_name] :: HsExpr p -> Located (IdP p)

- GHC.Hs.Expr: [rcon_ext] :: HsExpr p -> XRecordCon p

- GHC.Hs.Expr: [rcon_flds] :: HsExpr p -> HsRecordBinds p

- GHC.Hs.Expr: [recS_bind_fn] :: StmtLR idL idR body -> SyntaxExpr idR

- GHC.Hs.Expr: [recS_ext] :: StmtLR idL idR body -> XRecStmt idL idR body

- GHC.Hs.Expr: [recS_later_ids] :: StmtLR idL idR body -> [IdP idR]

- GHC.Hs.Expr: [recS_mfix_fn] :: StmtLR idL idR body -> SyntaxExpr idR

- GHC.Hs.Expr: [recS_rec_ids] :: StmtLR idL idR body -> [IdP idR]

- GHC.Hs.Expr: [recS_ret_fn] :: StmtLR idL idR body -> SyntaxExpr idR

- GHC.Hs.Expr: [recS_stmts] :: StmtLR idL idR body -> [LStmtLR idL idR body]

- GHC.Hs.Expr: [rupd_expr] :: HsExpr p -> LHsExpr p

- GHC.Hs.Expr: [rupd_ext] :: HsExpr p -> XRecordUpd p

- GHC.Hs.Expr: [rupd_flds] :: HsExpr p -> [LHsRecUpdField p]

- GHC.Hs.Expr: [stmt_context] :: ApplicativeArg idL -> HsStmtContext GhcRn

- GHC.Hs.Expr: [trS_bind] :: StmtLR idL idR body -> SyntaxExpr idR

- GHC.Hs.Expr: [trS_bndrs] :: StmtLR idL idR body -> [(IdP idR, IdP idR)]

- GHC.Hs.Expr: [trS_by] :: StmtLR idL idR body -> Maybe (LHsExpr idR)

- GHC.Hs.Expr: [trS_ext] :: StmtLR idL idR body -> XTransStmt idL idR body

- GHC.Hs.Expr: [trS_fmap] :: StmtLR idL idR body -> HsExpr idR

- GHC.Hs.Expr: [trS_form] :: StmtLR idL idR body -> TransForm

- GHC.Hs.Expr: [trS_ret] :: StmtLR idL idR body -> SyntaxExpr idR

- GHC.Hs.Expr: [trS_stmts] :: StmtLR idL idR body -> [ExprLStmt idL]

- GHC.Hs.Expr: [trS_using] :: StmtLR idL idR body -> LHsExpr idR

- GHC.Hs.Expr: [xarg_app_arg_many] :: ApplicativeArg idL -> XApplicativeArgMany idL

- GHC.Hs.Expr: [xarg_app_arg_one] :: ApplicativeArg idL -> XApplicativeArgOne idL

- GHC.Hs.Expr: data ApplicativeArg idL

- GHC.Hs.Expr: data ArithSeqInfo id

- GHC.Hs.Expr: data GRHS p body

- GHC.Hs.Expr: data GRHSs p body

- GHC.Hs.Expr: data HsArrAppType

- GHC.Hs.Expr: data HsBracket p

- GHC.Hs.Expr: data HsCmd id

- GHC.Hs.Expr: data HsCmdTop p

- GHC.Hs.Expr: data HsExpr p

- GHC.Hs.Expr: data HsMatchContext p

- GHC.Hs.Expr: data HsPragE p

- GHC.Hs.Expr: data HsSplice id

- GHC.Hs.Expr: data HsSplicedThing id

- GHC.Hs.Expr: data HsStmtContext p

- GHC.Hs.Expr: data HsTupArg id

- GHC.Hs.Expr: data Match p body

- GHC.Hs.Expr: data MatchGroup p body

- GHC.Hs.Expr: data MatchGroupTc

- GHC.Hs.Expr: data ParStmtBlock idL idR

- GHC.Hs.Expr: data RecordConTc

- GHC.Hs.Expr: data SpliceDecoration

- GHC.Hs.Expr: data StmtLR idL idR body

- GHC.Hs.Expr: data TransForm

- GHC.Hs.Expr: data UntypedSpliceFlavour

- GHC.Hs.Expr: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr, GHC.Utils.Outputable.Outputable body) => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.StmtLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr) body)

- GHC.Hs.Expr: instance (GHC.Hs.Extension.OutputableBndrId pr, GHC.Utils.Outputable.Outputable body) => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.Match (GHC.Hs.Extension.GhcPass pr) body)

- GHC.Hs.Expr: instance (GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.StmtLR idL idL (GHC.Hs.Expr.LHsExpr idL)), GHC.Utils.Outputable.Outputable (GHC.Hs.Extension.XXParStmtBlock idL idR)) => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.ParStmtBlock idL idR)

- GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.HsArrAppType

- GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.MatchGroupTc

- GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.SpliceDecoration

- GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.ThModFinalizers

- GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.TransForm

- GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.UntypedSpliceFlavour

- GHC.Hs.Expr: instance GHC.Classes.Eq GHC.Hs.Expr.SpliceDecoration

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId idL => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.ApplicativeArg (GHC.Hs.Extension.GhcPass idL))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.ArithSeqInfo (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsBracket (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsCmd (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsCmdTop (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsExpr (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsMatchContext (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsSplice (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsSplicedThing (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsStmtContext (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Show.Show GHC.Hs.Expr.SpliceDecoration

- GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsPragE (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable GHC.Hs.Expr.SpliceDecoration

- GHC.Hs.Expr: isComprehensionContext :: HsStmtContext id -> Bool

- GHC.Hs.Expr: isInfixMatch :: Match id body -> Bool

- GHC.Hs.Expr: isMonadCompContext :: HsStmtContext id -> Bool

- GHC.Hs.Expr: isMonadStmtContext :: HsStmtContext id -> Bool

- GHC.Hs.Expr: isPatSynCtxt :: HsMatchContext p -> Bool

- GHC.Hs.Expr: isTypedBracket :: HsBracket id -> Bool

- GHC.Hs.Expr: isTypedSplice :: HsSplice id -> Bool

- GHC.Hs.Expr: matchSeparator :: HsMatchContext p -> SDoc

- GHC.Hs.Expr: mkExpanded :: (HsExpansion a b -> b) -> a -> b -> b

- GHC.Hs.Expr: newtype ThModFinalizers

- GHC.Hs.Expr: pprAStmtContext :: Outputable (IdP id) => HsStmtContext id -> SDoc

- GHC.Hs.Expr: pprExternalSrcLoc :: (StringLiteral, (Int, Int), (Int, Int)) -> SDoc

- GHC.Hs.Expr: pprMatchContext :: Outputable (IdP p) => HsMatchContext p -> SDoc

- GHC.Hs.Expr: pprMatchContextNoun :: Outputable (IdP id) => HsMatchContext id -> SDoc

- GHC.Hs.Expr: pprStmtContext :: Outputable (IdP id) => HsStmtContext id -> SDoc

- GHC.Hs.Expr: prependQualified :: Maybe ModuleName -> SDoc -> SDoc

- GHC.Hs.Expr: qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName

- GHC.Hs.Expr: type CmdLStmt id = LStmt id (LHsCmd id)

- GHC.Hs.Expr: type CmdStmt id = Stmt id (LHsCmd id)

- GHC.Hs.Expr: type CmdSyntaxTable p = [(Name, HsExpr p)]

- GHC.Hs.Expr: type ExprLStmt id = LStmt id (LHsExpr id)

- GHC.Hs.Expr: type ExprStmt id = Stmt id (LHsExpr id)

- GHC.Hs.Expr: type FailOperator id = Maybe (SyntaxExpr id)

- GHC.Hs.Expr: type GhciLStmt id = LStmt id (LHsExpr id)

- GHC.Hs.Expr: type GhciStmt id = Stmt id (LHsExpr id)

- GHC.Hs.Expr: type GuardLStmt id = LStmt id (LHsExpr id)

- GHC.Hs.Expr: type GuardStmt id = Stmt id (LHsExpr id)

- GHC.Hs.Expr: type HsRecordBinds p = HsRecFields p (LHsExpr p)

- GHC.Hs.Expr: type LGRHS id body = Located (GRHS id body)

- GHC.Hs.Expr: type LHsCmd id = Located (HsCmd id)

- GHC.Hs.Expr: type LHsCmdTop p = Located (HsCmdTop p)

- GHC.Hs.Expr: type LHsExpr p = Located (HsExpr p) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

- GHC.Hs.Expr: type LHsTupArg id = Located (HsTupArg id)

- GHC.Hs.Expr: type LMatch id body = Located (Match id body)

- GHC.Hs.Expr: type LStmt id body = Located (StmtLR id id body)

- GHC.Hs.Expr: type LStmtLR idL idR body = Located (StmtLR idL idR body)

- GHC.Hs.Expr: type SplicePointName = Name

- GHC.Hs.Expr: type Stmt id body = StmtLR id id body

- GHC.Hs.Extension: NoExtField :: NoExtField

- GHC.Hs.Extension: data NoExtCon

- GHC.Hs.Extension: data NoExtField

- GHC.Hs.Extension: instance Data.Data.Data GHC.Hs.Extension.NoExtCon

- GHC.Hs.Extension: instance Data.Data.Data GHC.Hs.Extension.NoExtField

- GHC.Hs.Extension: instance GHC.Classes.Eq GHC.Hs.Extension.NoExtCon

- GHC.Hs.Extension: instance GHC.Classes.Eq GHC.Hs.Extension.NoExtField

- GHC.Hs.Extension: instance GHC.Classes.Ord GHC.Hs.Extension.NoExtCon

- GHC.Hs.Extension: instance GHC.Classes.Ord GHC.Hs.Extension.NoExtField

- GHC.Hs.Extension: instance GHC.Utils.Outputable.Outputable GHC.Hs.Extension.NoExtCon

- GHC.Hs.Extension: instance GHC.Utils.Outputable.Outputable GHC.Hs.Extension.NoExtField

- GHC.Hs.Extension: noExtCon :: NoExtCon -> a

- GHC.Hs.Extension: noExtField :: NoExtField

- GHC.Hs.Extension: type LIdP p = Located (IdP p)

- GHC.Hs.ImpExp: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.ImpExp.ImportDecl (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.ABExport GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.ABExport GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.ABExport GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.FixitySig GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.FixitySig GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.FixitySig GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsBindLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsBindLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsBindLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsBindLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsIPBinds GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsIPBinds GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsIPBinds GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsPatSynDir GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsPatSynDir GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsPatSynDir GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsValBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsValBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsValBindsLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.HsValBindsLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.IPBind GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.IPBind GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.IPBind GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.PatSynBind GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.PatSynBind GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.PatSynBind GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.PatSynBind GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.Sig GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.Sig GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Binds.Sig GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.AnnDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.AnnDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.AnnDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ClsInstDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ClsInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ClsInstDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ConDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ConDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ConDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DataFamInstDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DataFamInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DataFamInstDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DefaultDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DefaultDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DefaultDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DerivDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DerivDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DerivDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DerivStrategy GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DerivStrategy GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.DerivStrategy GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyInfo GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyInfo GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyInfo GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyResultSig GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyResultSig GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.FamilyResultSig GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ForeignDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ForeignDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.ForeignDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDataDefn GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDataDefn GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDerivingClause GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDerivingClause GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsDerivingClause GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsGroup GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsGroup GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.HsGroup GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.InjectivityAnn GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.InjectivityAnn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.InjectivityAnn GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.InstDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.InstDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.InstDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleBndr GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleBndr GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleBndr GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleDecls GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleDecls GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.RuleDecls GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.SpliceDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.SpliceDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.SpliceDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.StandaloneKindSig GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.StandaloneKindSig GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.StandaloneKindSig GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyClDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyClDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyClDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyClGroup GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyClGroup GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyClGroup GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyFamInstDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyFamInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.TyFamInstDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.WarnDecl GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.WarnDecl GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.WarnDecl GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.WarnDecls GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.WarnDecls GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Decls.WarnDecls GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ApplicativeArg GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ApplicativeArg GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ApplicativeArg GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ArithSeqInfo GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ArithSeqInfo GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ArithSeqInfo GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsBracket GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsBracket GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsBracket GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsCmd GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsCmd GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsCmd GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsCmdTop GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsCmdTop GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsCmdTop GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsExpr GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsExpr GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsExpr GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsMatchContext GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsMatchContext GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsMatchContext GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsPragE GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsPragE GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsPragE GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsSplice GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsSplice GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsSplice GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsSplicedThing GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsSplicedThing GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsSplicedThing GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsStmtContext GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsStmtContext GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsStmtContext GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsTupArg GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsTupArg GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.HsTupArg GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ParStmtBlock GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ParStmtBlock GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ParStmtBlock GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Expr.ParStmtBlock GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Lit.HsLit GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Lit.HsLit GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Lit.HsLit GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Lit.HsOverLit GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Lit.HsOverLit GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Lit.HsOverLit GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Pat.Pat GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Pat.Pat GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Pat.Pat GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.ConDeclField GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.ConDeclField GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.ConDeclField GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.FieldOcc GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.FieldOcc GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.FieldOcc GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsArrow GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsArrow GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsArrow GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsForAllTelescope GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsForAllTelescope GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsForAllTelescope GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsPatSigType GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsPatSigType GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsPatSigType GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsType GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsType GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.HsType GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.LHsQTyVars GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.LHsQTyVars GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.LHsQTyVars GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.LHsTypeArg GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.LHsTypeArg GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data (GHC.Hs.Type.LHsTypeArg GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data GHC.Hs.Expr.RecordConTc

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.GRHS GHC.Hs.Extension.GhcPs body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.GRHS GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.GRHS GHC.Hs.Extension.GhcTc body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.GRHSs GHC.Hs.Extension.GhcPs body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.GRHSs GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.GRHSs GHC.Hs.Extension.GhcTc body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.Match GHC.Hs.Extension.GhcPs body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.Match GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.Match GHC.Hs.Extension.GhcTc body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.MatchGroup GHC.Hs.Extension.GhcPs body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.MatchGroup GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.MatchGroup GHC.Hs.Extension.GhcTc body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.StmtLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.StmtLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.StmtLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Expr.StmtLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Pat.HsRecFields GHC.Hs.Extension.GhcPs body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Pat.HsRecFields GHC.Hs.Extension.GhcRn body)

- GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (GHC.Hs.Pat.HsRecFields GHC.Hs.Extension.GhcTc body)

- GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (GHC.Hs.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcPs)

- GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (GHC.Hs.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcRn)

- GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (GHC.Hs.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcTc)

- GHC.Hs.Instances: instance Data.Data.Data rhs => Data.Data.Data (GHC.Hs.Decls.FamEqn GHC.Hs.Extension.GhcPs rhs)

- GHC.Hs.Instances: instance Data.Data.Data rhs => Data.Data.Data (GHC.Hs.Decls.FamEqn GHC.Hs.Extension.GhcRn rhs)

- GHC.Hs.Instances: instance Data.Data.Data rhs => Data.Data.Data (GHC.Hs.Decls.FamEqn GHC.Hs.Extension.GhcTc rhs)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsImplicitBndrs GHC.Hs.Extension.GhcPs thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsImplicitBndrs GHC.Hs.Extension.GhcRn thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsImplicitBndrs GHC.Hs.Extension.GhcTc thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsScaled GHC.Hs.Extension.GhcPs thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsScaled GHC.Hs.Extension.GhcRn thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsScaled GHC.Hs.Extension.GhcTc thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsWildCardBndrs GHC.Hs.Extension.GhcPs thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsWildCardBndrs GHC.Hs.Extension.GhcRn thing)

- GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (GHC.Hs.Type.HsWildCardBndrs GHC.Hs.Extension.GhcTc thing)

- GHC.Hs.Lit: HsChar :: XHsChar x -> Char -> HsLit x

- GHC.Hs.Lit: HsCharPrim :: XHsCharPrim x -> Char -> HsLit x

- GHC.Hs.Lit: HsDoublePrim :: XHsDoublePrim x -> FractionalLit -> HsLit x

- GHC.Hs.Lit: HsFloatPrim :: XHsFloatPrim x -> FractionalLit -> HsLit x

- GHC.Hs.Lit: HsFractional :: !FractionalLit -> OverLitVal

- GHC.Hs.Lit: HsInt :: XHsInt x -> IntegralLit -> HsLit x

- GHC.Hs.Lit: HsInt64Prim :: XHsInt64Prim x -> Integer -> HsLit x

- GHC.Hs.Lit: HsIntPrim :: XHsIntPrim x -> Integer -> HsLit x

- GHC.Hs.Lit: HsInteger :: XHsInteger x -> Integer -> Type -> HsLit x

- GHC.Hs.Lit: HsIntegral :: !IntegralLit -> OverLitVal

- GHC.Hs.Lit: HsIsString :: !SourceText -> !FastString -> OverLitVal

- GHC.Hs.Lit: HsRat :: XHsRat x -> FractionalLit -> Type -> HsLit x

- GHC.Hs.Lit: HsString :: XHsString x -> FastString -> HsLit x

- GHC.Hs.Lit: HsStringPrim :: XHsStringPrim x -> !ByteString -> HsLit x

- GHC.Hs.Lit: HsWord64Prim :: XHsWord64Prim x -> Integer -> HsLit x

- GHC.Hs.Lit: HsWordPrim :: XHsWordPrim x -> Integer -> HsLit x

- GHC.Hs.Lit: OverLit :: XOverLit p -> OverLitVal -> HsExpr p -> HsOverLit p

- GHC.Hs.Lit: XLit :: !XXLit x -> HsLit x

- GHC.Hs.Lit: XOverLit :: !XXOverLit p -> HsOverLit p

- GHC.Hs.Lit: [ol_ext] :: HsOverLit p -> XOverLit p

- GHC.Hs.Lit: [ol_val] :: HsOverLit p -> OverLitVal

- GHC.Hs.Lit: [ol_witness] :: HsOverLit p -> HsExpr p

- GHC.Hs.Lit: data HsLit x

- GHC.Hs.Lit: data HsOverLit p

- GHC.Hs.Lit: data OverLitVal

- GHC.Hs.Lit: hsLitNeedsParens :: PprPrec -> HsLit x -> Bool

- GHC.Hs.Lit: hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool

- GHC.Hs.Lit: instance Data.Data.Data GHC.Hs.Lit.OverLitVal

- GHC.Hs.Lit: instance GHC.Classes.Eq (GHC.Hs.Extension.XXOverLit p) => GHC.Classes.Eq (GHC.Hs.Lit.HsOverLit p)

- GHC.Hs.Lit: instance GHC.Classes.Eq (GHC.Hs.Lit.HsLit x)

- GHC.Hs.Lit: instance GHC.Classes.Eq GHC.Hs.Lit.OverLitVal

- GHC.Hs.Lit: instance GHC.Classes.Ord (GHC.Hs.Extension.XXOverLit p) => GHC.Classes.Ord (GHC.Hs.Lit.HsOverLit p)

- GHC.Hs.Lit: instance GHC.Classes.Ord GHC.Hs.Lit.OverLitVal

- GHC.Hs.Lit: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Lit.HsOverLit (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Lit: instance GHC.Utils.Outputable.Outputable (GHC.Hs.Lit.HsLit (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Lit: instance GHC.Utils.Outputable.Outputable GHC.Hs.Lit.OverLitVal

- GHC.Hs.Lit: negateOverLitVal :: OverLitVal -> OverLitVal

- GHC.Hs.Pat: instance (Data.Data.Data id, Data.Data.Data arg) => Data.Data.Data (GHC.Hs.Pat.HsRecField' id arg)

- GHC.Hs.Pat: instance (GHC.Utils.Outputable.Outputable p, GHC.Utils.Outputable.Outputable arg) => GHC.Utils.Outputable.Outputable (GHC.Hs.Pat.HsRecField' p arg)

- GHC.Hs.Pat: instance Data.Foldable.Foldable (GHC.Hs.Pat.HsRecField' id)

- GHC.Hs.Pat: instance Data.Foldable.Foldable (GHC.Hs.Pat.HsRecFields p)

- GHC.Hs.Pat: instance Data.Traversable.Traversable (GHC.Hs.Pat.HsRecField' id)

- GHC.Hs.Pat: instance Data.Traversable.Traversable (GHC.Hs.Pat.HsRecFields p)

- GHC.Hs.Pat: instance GHC.Base.Functor (GHC.Hs.Pat.HsRecField' id)

- GHC.Hs.Pat: instance GHC.Base.Functor (GHC.Hs.Pat.HsRecFields p)

- GHC.Hs.Pat: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Pat.Pat (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Pat: instance GHC.Utils.Outputable.Outputable arg => GHC.Utils.Outputable.Outputable (GHC.Hs.Pat.HsRecFields p arg)

- GHC.Hs.Type: HsBoxedTuple :: HsTupleSort

- GHC.Hs.Type: HsConstraintTuple :: HsTupleSort

- GHC.Hs.Type: HsIB :: XHsIB pass thing -> thing -> HsImplicitBndrs pass thing

- GHC.Hs.Type: NHsCoreTy :: Type -> NewHsTypeX

- GHC.Hs.Type: XHsImplicitBndrs :: !XXHsImplicitBndrs pass thing -> HsImplicitBndrs pass thing

- GHC.Hs.Type: [hsib_body] :: HsImplicitBndrs pass thing -> thing

- GHC.Hs.Type: [hsib_ext] :: HsImplicitBndrs pass thing -> XHsIB pass thing

- GHC.Hs.Type: data HsImplicitBndrs pass thing

- GHC.Hs.Type: data NewHsTypeX

- GHC.Hs.Type: hsConDetailsArgs :: HsConDetails (LHsType a) (Located [LConDeclField a]) -> [LHsType a]

- GHC.Hs.Type: hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing

- GHC.Hs.Type: hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)

- GHC.Hs.Type: instance (Data.Data.Data arg, Data.Data.Data rec) => Data.Data.Data (GHC.Hs.Type.HsConDetails arg rec)

- GHC.Hs.Type: instance (GHC.Hs.Extension.OutputableBndrId p, GHC.Hs.Type.OutputableBndrFlag flag) => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsTyVarBndr flag (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance (GHC.Utils.Outputable.Outputable arg, GHC.Utils.Outputable.Outputable rec) => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsConDetails arg rec)

- GHC.Hs.Type: instance (GHC.Utils.Outputable.Outputable tm, GHC.Utils.Outputable.Outputable ty) => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsArg tm ty)

- GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.HsIPName

- GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.HsPSRn

- GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.HsTupleSort

- GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.HsTyLit

- GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.NewHsTypeX

- GHC.Hs.Type: instance GHC.Classes.Eq (GHC.Hs.Extension.XCFieldOcc (GHC.Hs.Extension.GhcPass p)) => GHC.Classes.Eq (GHC.Hs.Type.FieldOcc (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Classes.Eq GHC.Hs.Type.HsIPName

- GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.ConDeclField (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsForAllTelescope (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsPatSigType (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsType (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.LHsQTyVars (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId pass => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsArrow (GHC.Hs.Extension.GhcPass pass))

- GHC.Hs.Type: instance GHC.Hs.Type.OutputableBndrFlag ()

- GHC.Hs.Type: instance GHC.Hs.Type.OutputableBndrFlag GHC.Types.Var.Specificity

- GHC.Hs.Type: instance GHC.Types.Name.NamedThing (GHC.Hs.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcRn)

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable (GHC.Hs.Type.AmbiguousFieldOcc (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable (GHC.Hs.Type.FieldOcc pass)

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable GHC.Hs.Type.HsIPName

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable GHC.Hs.Type.HsTyLit

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable GHC.Hs.Type.NewHsTypeX

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsScaled pass a)

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable thing => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsImplicitBndrs (GHC.Hs.Extension.GhcPass p) thing)

- GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable thing => GHC.Utils.Outputable.Outputable (GHC.Hs.Type.HsWildCardBndrs (GHC.Hs.Extension.GhcPass p) thing)

- GHC.Hs.Type: instance GHC.Utils.Outputable.OutputableBndr (GHC.Hs.Type.AmbiguousFieldOcc (GHC.Hs.Extension.GhcPass p))

- GHC.Hs.Type: instance GHC.Utils.Outputable.OutputableBndr GHC.Hs.Type.HsIPName

- GHC.Hs.Type: isLHsForAllTy :: LHsType p -> Bool

- GHC.Hs.Type: mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing

- GHC.Hs.Type: mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing

- GHC.Hs.Type: noLHsContext :: LHsContext pass

- GHC.Hs.Type: pprHsExplicitForAll :: OutputableBndrId p => Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc

- GHC.Hs.Utils: instance GHC.Hs.Utils.CollectPass (GHC.Hs.Extension.GhcPass 'GHC.Hs.Extension.Parsed)

- GHC.Hs.Utils: instance GHC.Hs.Utils.CollectPass (GHC.Hs.Extension.GhcPass 'GHC.Hs.Extension.Renamed)

- GHC.Hs.Utils: instance GHC.Hs.Utils.CollectPass (GHC.Hs.Extension.GhcPass 'GHC.Hs.Extension.Typechecked)

- GHC.Hs.Utils: mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs

- GHC.Hs.Utils: mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs

- GHC.HsToCore.Expr: dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr

- GHC.HsToCore.Monad: getPmDeltas :: DsM Deltas

- GHC.HsToCore.Monad: instance GHC.Driver.Types.MonadThings (GHC.Data.IOEnv.IOEnv (GHC.Tc.Types.Env GHC.Tc.Types.DsGblEnv GHC.Tc.Types.DsLclEnv))

- GHC.HsToCore.Monad: updPmDeltas :: Deltas -> DsM a -> DsM a

- GHC.HsToCore.PmCheck: addScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a

- GHC.HsToCore.PmCheck: addTyCsDs :: Origin -> Bag EvVar -> DsM a -> DsM a

- GHC.HsToCore.PmCheck: checkGuardMatches :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM [Deltas]

- GHC.HsToCore.PmCheck: checkMatches :: DsMatchContext -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM [Deltas]

- GHC.HsToCore.PmCheck: checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()

- GHC.HsToCore.PmCheck: instance GHC.Base.Monoid GHC.HsToCore.PmCheck.Precision

- GHC.HsToCore.PmCheck: instance GHC.Base.Semigroup GHC.HsToCore.PmCheck.Precision

- GHC.HsToCore.PmCheck: instance GHC.Classes.Eq GHC.HsToCore.PmCheck.Precision

- GHC.HsToCore.PmCheck: instance GHC.Show.Show GHC.HsToCore.PmCheck.Precision

- GHC.HsToCore.PmCheck: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.AnnotatedTree

- GHC.HsToCore.PmCheck: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.CheckResult

- GHC.HsToCore.PmCheck: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.GrdTree

- GHC.HsToCore.PmCheck: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.PmGrd

- GHC.HsToCore.PmCheck: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Precision

- GHC.HsToCore.PmCheck: isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool

- GHC.HsToCore.PmCheck.Oracle: PmTyCt :: !TyCt -> PmCt

- GHC.HsToCore.PmCheck.Oracle: addPmCts :: Delta -> PmCts -> DsM (Maybe Delta)

- GHC.HsToCore.PmCheck.Oracle: canDiverge :: Delta -> Id -> Bool

- GHC.HsToCore.PmCheck.Oracle: data Delta

- GHC.HsToCore.PmCheck.Oracle: data PmCt

- GHC.HsToCore.PmCheck.Oracle: initDeltas :: Deltas

- GHC.HsToCore.PmCheck.Oracle: instance GHC.Base.Monoid GHC.HsToCore.PmCheck.Oracle.SatisfiabilityCheck

- GHC.HsToCore.PmCheck.Oracle: instance GHC.Base.Semigroup GHC.HsToCore.PmCheck.Oracle.SatisfiabilityCheck

- GHC.HsToCore.PmCheck.Oracle: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Oracle.InhabitationCandidate

- GHC.HsToCore.PmCheck.Oracle: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Oracle.PmCt

- GHC.HsToCore.PmCheck.Oracle: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Oracle.TmCt

- GHC.HsToCore.PmCheck.Oracle: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Oracle.TopNormaliseTypeResult

- GHC.HsToCore.PmCheck.Oracle: lookupRefuts :: Uniquable k => Delta -> k -> [PmAltCon]

- GHC.HsToCore.PmCheck.Oracle: lookupSolution :: Delta -> Id -> Maybe (PmAltCon, [TyVar], [Id])

- GHC.HsToCore.PmCheck.Oracle: mkPmId :: Type -> DsM Id

- GHC.HsToCore.PmCheck.Oracle: pattern PmBotCt :: Id -> PmCt

- GHC.HsToCore.PmCheck.Oracle: pattern PmConCt :: Id -> PmAltCon -> [TyVar] -> [Id] -> PmCt

- GHC.HsToCore.PmCheck.Oracle: pattern PmCoreCt :: Id -> CoreExpr -> PmCt

- GHC.HsToCore.PmCheck.Oracle: pattern PmNotBotCt :: Id -> PmCt

- GHC.HsToCore.PmCheck.Oracle: pattern PmNotConCt :: Id -> PmAltCon -> PmCt

- GHC.HsToCore.PmCheck.Oracle: pattern PmVarCt :: Id -> Id -> PmCt

- GHC.HsToCore.PmCheck.Oracle: provideEvidence :: [Id] -> Int -> Delta -> DsM [Delta]

- GHC.HsToCore.PmCheck.Oracle: tracePm :: String -> SDoc -> DsM ()

- GHC.HsToCore.PmCheck.Oracle: type DsM = TcRnIf DsGblEnv DsLclEnv

- GHC.HsToCore.PmCheck.Oracle: type PmCts = Bag PmCt

- GHC.HsToCore.PmCheck.Ppr: pprUncovered :: Delta -> [Id] -> SDoc

- GHC.HsToCore.PmCheck.Types: Disjoint :: PmEquality

- GHC.HsToCore.PmCheck.Types: Entry :: a -> Shared a

- GHC.HsToCore.PmCheck.Types: Equal :: PmEquality

- GHC.HsToCore.PmCheck.Types: Indirect :: Id -> Shared a

- GHC.HsToCore.PmCheck.Types: MkDelta :: TyState -> TmState -> Delta

- GHC.HsToCore.PmCheck.Types: MkDeltas :: Bag Delta -> Deltas

- GHC.HsToCore.PmCheck.Types: NoPM :: PossibleMatches

- GHC.HsToCore.PmCheck.Types: PM :: NonEmpty ConLikeSet -> PossibleMatches

- GHC.HsToCore.PmCheck.Types: PmAltConLike :: ConLike -> PmAltCon

- GHC.HsToCore.PmCheck.Types: PmAltLit :: PmLit -> PmAltCon

- GHC.HsToCore.PmCheck.Types: PmLit :: Type -> PmLitValue -> PmLit

- GHC.HsToCore.PmCheck.Types: PmLitChar :: Char -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PmLitInt :: Integer -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PmLitOverInt :: Int -> Integer -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PmLitOverRat :: Int -> Rational -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PmLitOverString :: FastString -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PmLitRat :: Rational -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PmLitString :: FastString -> PmLitValue

- GHC.HsToCore.PmCheck.Types: PossiblyOverlap :: PmEquality

- GHC.HsToCore.PmCheck.Types: SDIE :: DIdEnv (Shared a) -> SharedDIdEnv a

- GHC.HsToCore.PmCheck.Types: TmSt :: !SharedDIdEnv VarInfo -> !CoreMap Id -> TmState

- GHC.HsToCore.PmCheck.Types: TySt :: Bag EvVar -> TyState

- GHC.HsToCore.PmCheck.Types: VI :: !Type -> ![(PmAltCon, [TyVar], [Id])] -> !PmAltConSet -> !PossibleMatches -> VarInfo

- GHC.HsToCore.PmCheck.Types: [delta_tm_st] :: Delta -> TmState

- GHC.HsToCore.PmCheck.Types: [delta_ty_st] :: Delta -> TyState

- GHC.HsToCore.PmCheck.Types: [pm_lit_ty] :: PmLit -> Type

- GHC.HsToCore.PmCheck.Types: [pm_lit_val] :: PmLit -> PmLitValue

- GHC.HsToCore.PmCheck.Types: [ts_facts] :: TmState -> !SharedDIdEnv VarInfo

- GHC.HsToCore.PmCheck.Types: [ts_reps] :: TmState -> !CoreMap Id

- GHC.HsToCore.PmCheck.Types: [unSDIE] :: SharedDIdEnv a -> DIdEnv (Shared a)

- GHC.HsToCore.PmCheck.Types: [vi_cache] :: VarInfo -> !PossibleMatches

- GHC.HsToCore.PmCheck.Types: [vi_neg] :: VarInfo -> !PmAltConSet

- GHC.HsToCore.PmCheck.Types: [vi_pos] :: VarInfo -> ![(PmAltCon, [TyVar], [Id])]

- GHC.HsToCore.PmCheck.Types: [vi_ty] :: VarInfo -> !Type

- GHC.HsToCore.PmCheck.Types: coreExprAsPmLit :: CoreExpr -> Maybe PmLit

- GHC.HsToCore.PmCheck.Types: data Delta

- GHC.HsToCore.PmCheck.Types: data PmAltCon

- GHC.HsToCore.PmCheck.Types: data PmAltConSet

- GHC.HsToCore.PmCheck.Types: data PmEquality

- GHC.HsToCore.PmCheck.Types: data PmLit

- GHC.HsToCore.PmCheck.Types: data PmLitValue

- GHC.HsToCore.PmCheck.Types: data PossibleMatches

- GHC.HsToCore.PmCheck.Types: data Shared a

- GHC.HsToCore.PmCheck.Types: data TmState

- GHC.HsToCore.PmCheck.Types: data VarInfo

- GHC.HsToCore.PmCheck.Types: elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool

- GHC.HsToCore.PmCheck.Types: emptyPmAltConSet :: PmAltConSet

- GHC.HsToCore.PmCheck.Types: emptySDIE :: SharedDIdEnv a

- GHC.HsToCore.PmCheck.Types: eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality

- GHC.HsToCore.PmCheck.Types: extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet

- GHC.HsToCore.PmCheck.Types: initDeltas :: Deltas

- GHC.HsToCore.PmCheck.Types: instance GHC.Base.Semigroup GHC.HsToCore.PmCheck.Types.Deltas

- GHC.HsToCore.PmCheck.Types: instance GHC.Classes.Eq GHC.HsToCore.PmCheck.Types.PmAltCon

- GHC.HsToCore.PmCheck.Types: instance GHC.Classes.Eq GHC.HsToCore.PmCheck.Types.PmEquality

- GHC.HsToCore.PmCheck.Types: instance GHC.Classes.Eq GHC.HsToCore.PmCheck.Types.PmLit

- GHC.HsToCore.PmCheck.Types: instance GHC.Show.Show GHC.HsToCore.PmCheck.Types.PmEquality

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.Delta

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.Deltas

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.PmAltCon

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.PmAltConSet

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.PmEquality

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.PmLit

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.PmLitValue

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.PossibleMatches

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.TmState

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.TyState

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.PmCheck.Types.VarInfo

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.HsToCore.PmCheck.Types.Shared a)

- GHC.HsToCore.PmCheck.Types: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.HsToCore.PmCheck.Types.SharedDIdEnv a)

- GHC.HsToCore.PmCheck.Types: isEmptyPmAltConSet :: PmAltConSet -> Bool

- GHC.HsToCore.PmCheck.Types: liftDeltasM :: Monad m => (Delta -> m (Maybe Delta)) -> Deltas -> m Deltas

- GHC.HsToCore.PmCheck.Types: literalToPmLit :: Type -> Literal -> Maybe PmLit

- GHC.HsToCore.PmCheck.Types: lookupSDIE :: SharedDIdEnv a -> Id -> Maybe a

- GHC.HsToCore.PmCheck.Types: negatePmLit :: PmLit -> Maybe PmLit

- GHC.HsToCore.PmCheck.Types: newtype Deltas

- GHC.HsToCore.PmCheck.Types: newtype SharedDIdEnv a

- GHC.HsToCore.PmCheck.Types: newtype TyState

- GHC.HsToCore.PmCheck.Types: overloadPmLit :: Type -> PmLit -> Maybe PmLit

- GHC.HsToCore.PmCheck.Types: pmAltConSetElems :: PmAltConSet -> [PmAltCon]

- GHC.HsToCore.PmCheck.Types: pmAltConType :: PmAltCon -> [Type] -> Type

- GHC.HsToCore.PmCheck.Types: pmLitAsStringLit :: PmLit -> Maybe FastString

- GHC.HsToCore.PmCheck.Types: pmLitType :: PmLit -> Type

- GHC.HsToCore.PmCheck.Types: sameRepresentativeSDIE :: SharedDIdEnv a -> Id -> Id -> Bool

- GHC.HsToCore.PmCheck.Types: setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a

- GHC.HsToCore.PmCheck.Types: setIndirectSDIE :: SharedDIdEnv a -> Id -> Id -> SharedDIdEnv a

- GHC.HsToCore.PmCheck.Types: traverseSDIE :: forall a b f. Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)

- GHC.HsToCore.PmCheck.Types: type ConLikeSet = UniqDSet ConLike

- GHC.Iface.Binary: QuietBinIFaceReading :: TraceBinIFaceReading

- GHC.Iface.Binary: TraceBinIFaceReading :: TraceBinIFaceReading

- GHC.Iface.Binary: data TraceBinIFaceReading

- GHC.Iface.Binary: instance GHC.Classes.Eq GHC.Iface.Binary.TraceBinIFaceReading

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HasLoc thing, GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped thing)) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (GHC.Hs.Type.HsImplicitBndrs GHC.Hs.Extension.GhcRn thing))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HasLoc tm, GHC.Iface.Ext.Ast.HasLoc ty) => GHC.Iface.Ext.Ast.HasLoc (GHC.Hs.Type.HsArg tm ty)

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HiePass p, Data.Data.Data body, GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located body)) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LMatch (GHC.Hs.Extension.GhcPass p) (GHC.Types.SrcLoc.Located body))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HiePass p, GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located body), Data.Data.Data body) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.MatchGroup (GHC.Hs.Extension.GhcPass p) (GHC.Types.SrcLoc.Located body))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located label)), GHC.Iface.Ext.Ast.ToHie arg, GHC.Iface.Ext.Ast.HasLoc arg, Data.Data.Data arg, Data.Data.Data label) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RContext (GHC.Hs.Pat.LHsRecField' label arg))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located body), Data.Data.Data body, GHC.Iface.Ext.Ast.HiePass p) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Expr.LStmt (GHC.Hs.Extension.GhcPass p) (GHC.Types.SrcLoc.Located body)))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located body), GHC.Iface.Ext.Ast.HiePass a, Data.Data.Data body) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LGRHS (GHC.Hs.Extension.GhcPass a) (GHC.Types.SrcLoc.Located body))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located body), GHC.Iface.Ext.Ast.HiePass p, Data.Data.Data body) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.GRHSs (GHC.Hs.Extension.GhcPass p) (GHC.Types.SrcLoc.Located body))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie arg, GHC.Iface.Ext.Ast.HasLoc arg, Data.Data.Data arg, GHC.Iface.Ext.Ast.HiePass p) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RContext (GHC.Hs.Pat.HsRecFields (GHC.Hs.Extension.GhcPass p) arg))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie arg, GHC.Iface.Ext.Ast.ToHie rec) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Type.HsConDetails arg rec)

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie rhs, GHC.Iface.Ext.Ast.HasLoc rhs) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.FamEqn GHC.Hs.Extension.GhcRn rhs)

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie rhs, GHC.Iface.Ext.Ast.HasLoc rhs) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (GHC.Hs.Decls.FamEqn GHC.Hs.Extension.GhcRn rhs))

- GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie tm, GHC.Iface.Ext.Ast.ToHie ty) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Type.HsArg tm ty)

- GHC.Iface.Ext.Ast: instance Data.Data.Data flag => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TVScoped (GHC.Hs.Type.LHsTyVarBndr flag GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc (GHC.Hs.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc (GHC.Hs.Type.LHsQTyVars GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc a => GHC.Iface.Ext.Ast.HasLoc (GHC.Hs.Decls.FamEqn s a)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc thing => GHC.Iface.Ext.Ast.HasLoc (GHC.Hs.Type.HsImplicitBndrs a thing)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc thing => GHC.Iface.Ext.Ast.HasLoc (GHC.Hs.Type.HsWildCardBndrs a thing)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc thing => GHC.Iface.Ext.Ast.HasLoc (GHC.Iface.Ext.Ast.TScoped thing)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasRealDataConName GHC.Hs.Extension.GhcRn

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasRealDataConName GHC.Hs.Extension.GhcTc

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.HasType (GHC.Hs.Binds.LHsBind (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.HasType (GHC.Hs.Expr.LHsExpr (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.HasType (GHC.Types.SrcLoc.Located (GHC.Hs.Pat.Pat (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Binds.HsPatSynDir (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.HsMatchContext (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.HsStmtContext (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LHsCmd (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LHsCmdTop (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LHsExpr (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LHsTupArg (GHC.Hs.Extension.GhcPass p))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.BindContext (GHC.Hs.Binds.LHsBind (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.PScoped (GHC.Types.SrcLoc.Located (GHC.Hs.Pat.Pat (GHC.Hs.Extension.GhcPass p))))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Binds.HsValBindsLR (GHC.Hs.Extension.GhcPass p) (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Binds.LHsLocalBinds (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Binds.LIPBind (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Expr.ApplicativeArg (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.SigContext (GHC.Hs.Binds.LSig (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (GHC.Hs.Binds.PatSynBind (GHC.Hs.Extension.GhcPass p) (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (GHC.Hs.Expr.HsSplice (GHC.Hs.Extension.GhcPass p)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Data.BooleanFormula.LBooleanFormula (GHC.Types.SrcLoc.Located GHC.Types.Name.Name))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Binds.LFixitySig GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.FamilyInfo GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.HsDeriving GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LAnnDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LClsInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LConDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LDataFamInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LDefaultDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LDerivDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LFamilyDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LForeignDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LHsDerivingClause GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LInjectivityAnn GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LRoleAnnotDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LRuleDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LRuleDecls GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LSpliceDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LStandaloneKindSig GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LTyClDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LTyFamInstDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LWarnDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.LWarnDecls GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.StandaloneKindSig GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.TyClGroup GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.HsBracket a)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.LHsExpr a) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Expr.ArithSeqInfo a)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.ImpExp.LImportDecl GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Type.LConDeclField GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Type.LHsContext GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Type.LHsType GHC.Hs.Extension.GhcRn)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.Context (GHC.Types.SrcLoc.Located a)) => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Decls.AnnProvenance a)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.Context a) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.PatSynFieldContext (GHC.Hs.Binds.RecordPatSynField a))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.EvBindContext (GHC.Types.SrcLoc.Located GHC.Tc.Types.Evidence.TcEvBinds))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.IEContext (GHC.Hs.ImpExp.LIE GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.IEContext (GHC.Types.SrcLoc.Located (GHC.Types.FieldLabel.FieldLbl GHC.Types.Name.Name)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.IEContext (GHC.Types.SrcLoc.Located GHC.Unit.Module.Name.ModuleName))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Hs.Type.LFieldOcc GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Hs.Type.LFieldOcc GHC.Hs.Extension.GhcTc))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located (GHC.Hs.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcRn)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located (GHC.Hs.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcTc)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Decls.LFamilyResultSig GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Hs.Decls.LRuleBndr GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (GHC.Hs.Type.HsPatSigType GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (GHC.Hs.Type.LHsQTyVars GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (GHC.Hs.Type.LHsType GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (GHC.Core.Class.FunDep (GHC.Types.SrcLoc.Located GHC.Types.Name.Name)))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (GHC.Hs.Decls.DerivStrategy GHC.Hs.Extension.GhcRn))

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located GHC.Hs.Type.HsIPName)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located GHC.Tc.Types.Evidence.HsWrapper)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located GHC.Types.Basic.OverlapMode)

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located [GHC.Hs.Type.LConDeclField GHC.Hs.Extension.GhcRn])

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie GHC.Hs.Decls.ForeignExport

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie GHC.Hs.Decls.ForeignImport

- GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie a => GHC.Iface.Ext.Ast.ToHie (GHC.Hs.Type.HsScaled GHC.Hs.Extension.GhcRn a)

- GHC.Iface.Load: instance GHC.Utils.Outputable.Outputable GHC.Driver.Types.Warnings

- GHC.Iface.Load: loadDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name, TyThing)]

- GHC.Iface.Syntax: type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)

- GHC.IfaceToCore: tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]

- GHC.Parser.Annotation: AddAnn :: AnnKeywordId -> SrcSpan -> AddAnn

- GHC.Parser.Annotation: AnnBlockComment :: String -> AnnotationComment

- GHC.Parser.Annotation: AnnDocCommentNamed :: String -> AnnotationComment

- GHC.Parser.Annotation: AnnDocCommentNext :: String -> AnnotationComment

- GHC.Parser.Annotation: AnnDocCommentPrev :: String -> AnnotationComment

- GHC.Parser.Annotation: AnnDocOptions :: String -> AnnotationComment

- GHC.Parser.Annotation: AnnDocSection :: Int -> String -> AnnotationComment

- GHC.Parser.Annotation: AnnLineComment :: String -> AnnotationComment

- GHC.Parser.Annotation: ApiAnns :: Map ApiAnnKey [RealSrcSpan] -> Maybe RealSrcSpan -> Map RealSrcSpan [RealLocated AnnotationComment] -> [RealLocated AnnotationComment] -> ApiAnns

- GHC.Parser.Annotation: [apiAnnComments] :: ApiAnns -> Map RealSrcSpan [RealLocated AnnotationComment]

- GHC.Parser.Annotation: [apiAnnEofPos] :: ApiAnns -> Maybe RealSrcSpan

- GHC.Parser.Annotation: [apiAnnItems] :: ApiAnns -> Map ApiAnnKey [RealSrcSpan]

- GHC.Parser.Annotation: [apiAnnRogueComments] :: ApiAnns -> [RealLocated AnnotationComment]

- GHC.Parser.Annotation: data AddAnn

- GHC.Parser.Annotation: data AnnotationComment

- GHC.Parser.Annotation: data ApiAnns

- GHC.Parser.Annotation: getAndRemoveAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> ([RealSrcSpan], ApiAnns)

- GHC.Parser.Annotation: getAndRemoveAnnotationComments :: ApiAnns -> RealSrcSpan -> ([RealLocated AnnotationComment], ApiAnns)

- GHC.Parser.Annotation: getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]

- GHC.Parser.Annotation: getAnnotationComments :: ApiAnns -> RealSrcSpan -> [RealLocated AnnotationComment]

- GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnotationComment

- GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnnotationComment

- GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.AnnotationComment

- GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.AnnotationComment

- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnotationComment

- GHC.Parser.Annotation: mkParensApiAnn :: SrcSpan -> [AddAnn]

- GHC.Parser.Annotation: type ApiAnnKey = (RealSrcSpan, AnnKeywordId)

- GHC.Parser.Annotation: type LRdrName = Located RdrName

- GHC.Parser.Lexer: ITgenerated_prag :: SourceText -> Token

- GHC.Parser.Lexer: ParserFlags :: EnumSet WarningFlag -> UnitId -> !ExtsBitmap -> ParserFlags

- GHC.Parser.Lexer: [annotations] :: PState -> [(ApiAnnKey, [RealSrcSpan])]

- GHC.Parser.Lexer: [annotations_comments] :: PState -> [(RealSrcSpan, [RealLocated AnnotationComment])]

- GHC.Parser.Lexer: [messages] :: PState -> DynFlags -> Messages

- GHC.Parser.Lexer: [pHomeUnitId] :: ParserFlags -> UnitId

- GHC.Parser.Lexer: addAnnotation :: MonadP m => SrcSpan -> AnnKeywordId -> SrcSpan -> m ()

- GHC.Parser.Lexer: addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m ()

- GHC.Parser.Lexer: appendError :: SrcSpan -> SDoc -> (DynFlags -> Messages) -> DynFlags -> Messages

- GHC.Parser.Lexer: appendWarning :: ParserFlags -> WarningFlag -> SrcSpan -> SDoc -> (DynFlags -> Messages) -> DynFlags -> Messages

- GHC.Parser.Lexer: data ParserFlags

- GHC.Parser.Lexer: mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState

- GHC.Parser.Lexer: mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState

- GHC.Parser.Lexer: mkParserFlags :: DynFlags -> ParserFlags

- GHC.Parser.Lexer: mkParserFlags' :: EnumSet WarningFlag -> EnumSet Extension -> UnitId -> Bool -> Bool -> Bool -> Bool -> ParserFlags

- GHC.Parser.Lexer: pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState

- GHC.Parser.Lexer: withHomeUnitId :: (UnitId -> a) -> P a

- GHC.Parser.PostProcess: TyElKindApp :: SrcSpan -> LHsType GhcPs -> TyEl

- GHC.Parser.PostProcess: TyElOpd :: HsType GhcPs -> TyEl

- GHC.Parser.PostProcess: TyElOpr :: RdrName -> TyEl

- GHC.Parser.PostProcess: TyElUnpackedness :: ([AddAnn], SourceText, SrcUnpackedness) -> TyEl

- GHC.Parser.PostProcess: [runECP_PV] :: ECP -> forall b. DisambECP b => PV (Located b)

- GHC.Parser.PostProcess: checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)

- GHC.Parser.PostProcess: data TyEl

- GHC.Parser.PostProcess: filterCTuple :: RdrName -> RdrName

- GHC.Parser.PostProcess: forallSym :: Bool -> String

- GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambECP (GHC.Hs.Expr.HsCmd GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambECP (GHC.Hs.Expr.HsExpr GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambECP (GHC.Parser.PostProcess.PatBuilder GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambInfixOp (GHC.Hs.Expr.HsExpr GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess: instance GHC.Utils.Outputable.Outputable (GHC.Parser.PostProcess.PatBuilder GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess: instance GHC.Utils.Outputable.Outputable GHC.Parser.PostProcess.TyEl

- GHC.Parser.PostProcess: mergeDataCon :: [Located TyEl] -> P (Located RdrName, HsConDeclDetails GhcPs)

- GHC.Parser.PostProcess: mergeOps :: [Located TyEl] -> P (LHsType GhcPs)

- GHC.Parser.PostProcess: mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs

- GHC.Parser.PostProcess: runECP_P :: DisambECP b => ECP -> P (Located b)

- GHC.Parser.PostProcess: type family FunArg b;

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Decls.HsDataDefn GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Decls.HsDecl GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Decls.HsDeriving GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Decls.LConDecl GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Decls.LHsDecl GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Decls.LHsDerivingClause GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.ImpExp.LIE GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Type.LHsSigType GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Type.LHsSigWcType GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Type.LHsType GHC.Hs.Extension.GhcPs)

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Types.SrcLoc.Located [GHC.Hs.ImpExp.LIE GHC.Hs.Extension.GhcPs])

- GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock a => GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Hs.Type.HsScaled GHC.Hs.Extension.GhcPs a)

- GHC.Plugins: ACoAxiom :: CoAxiom Branched -> TyThing

- GHC.Plugins: AConLike :: ConLike -> TyThing

- GHC.Plugins: ATyCon :: TyCon -> TyThing

- GHC.Plugins: AnId :: Id -> TyThing

- GHC.Plugins: NoBlockSubst :: BlockSubstFlag

- GHC.Plugins: YesBlockSubst :: BlockSubstFlag

- GHC.Plugins: [ch_blocker] :: CoercionHole -> BlockSubstFlag

- GHC.Plugins: badCoercionHole :: Type -> Bool

- GHC.Plugins: badCoercionHoleCo :: Coercion -> Bool

- GHC.Plugins: data BlockSubstFlag

- GHC.Plugins: data TyThing

- GHC.Plugins: instance GHC.Driver.Types.MonadThings GHC.Core.Opt.Monad.CoreM

- GHC.Plugins: splitForAllTy :: Type -> (TyCoVar, Type)

- GHC.Plugins: splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)

- GHC.Plugins: splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)

- GHC.Plugins: splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)

- GHC.Plugins: splitForAllTys :: Type -> ([TyCoVar], Type)

- GHC.Plugins: splitForAllTysInvis :: Type -> ([InvisTVBinder], Type)

- GHC.Plugins: splitForAllTysReq :: Type -> ([ReqTVBinder], Type)

- GHC.Plugins: splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)

- GHC.Plugins: splitPiTysInvisible :: Type -> ([TyCoBinder], Type)

- GHC.Plugins: splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)

- GHC.Plugins: substSpec :: Subst -> Id -> RuleInfo -> RuleInfo

- GHC.Plugins: synTyConResKind :: TyCon -> Kind

- GHC.Rename.Doc: rnHsDoc :: HsDocString -> RnM HsDocString

- GHC.Rename.Doc: rnLHsDoc :: LHsDocString -> RnM LHsDocString

- GHC.Rename.Doc: rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)

- GHC.Rename.Env: FoundFL :: FieldLabel -> ChildLookupResult

- GHC.Rename.Env: FoundName :: Parent -> Name -> ChildLookupResult

- GHC.Rename.Env: lookupGlobalOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name]))

- GHC.Rename.Env: lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name]))

- GHC.Rename.Env: lookupReboundIf :: RnM (Maybe (Located Name))

- GHC.Rename.HsType: BindUnlessForall :: HsSigWcTypeScoping

- GHC.Rename.HsType: data HsSigWcTypeScoping

- GHC.Rename.HsType: extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars

- GHC.Rename.HsType: extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs] -> FreeKiTyVars -> FreeKiTyVars

- GHC.Rename.HsType: forAllOrNothing :: Bool -> FreeKiTyVars -> RnM FreeKiTyVars

- GHC.Rename.HsType: rnImplicitBndrs :: Maybe assoc -> FreeKiTyVars -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)

- GHC.Rename.Pat: checkTupSize :: Int -> RnM ()

- GHC.Rename.Utils: extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)

- GHC.Runtime.Eval: availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv

- GHC.Runtime.Eval: hasImport :: ParserFlags -> String -> Bool

- GHC.Runtime.Eval: isDecl :: ParserFlags -> String -> Bool

- GHC.Runtime.Eval: isImport :: ParserFlags -> String -> Bool

- GHC.Runtime.Eval: isStmt :: ParserFlags -> String -> Bool

- GHC.Runtime.Heap.Layout: instance Data.Bits.Bits GHC.Runtime.Heap.Layout.StgWord

- GHC.Runtime.Interpreter: [EnableBreakpoint] :: RemoteRef BreakArray -> Int -> Bool -> Message ()

- GHC.Runtime.Interpreter: enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()

- GHC.Runtime.Interpreter: iservCmd :: Binary a => HscEnv -> Message a -> IO a

- GHC.Runtime.Interpreter: withInterp :: HscEnv -> (Interp -> IO a) -> IO a

- GHC.Runtime.Linker: deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()

- GHC.Runtime.Linker: extendLinkEnv :: DynLinker -> [(Name, ForeignHValue)] -> IO ()

- GHC.Runtime.Linker: extendLoadedPkgs :: DynLinker -> [UnitId] -> IO ()

- GHC.Runtime.Linker: getHValue :: HscEnv -> Name -> IO ForeignHValue

- GHC.Runtime.Linker: initDynLinker :: HscEnv -> IO ()

- GHC.Runtime.Linker: instance GHC.Utils.Outputable.Outputable GHC.Runtime.Linker.LibrarySpec

- GHC.Runtime.Linker: linkCmdLineLibs :: HscEnv -> IO ()

- GHC.Runtime.Linker: linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()

- GHC.Runtime.Linker: linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue

- GHC.Runtime.Linker: linkModule :: HscEnv -> Module -> IO ()

- GHC.Runtime.Linker: linkPackages :: HscEnv -> [UnitId] -> IO ()

- GHC.Runtime.Linker: showLinkerState :: DynLinker -> IO SDoc

- GHC.Runtime.Linker: uninitializedLinker :: IO DynLinker

- GHC.Runtime.Linker: unload :: HscEnv -> [Linkable] -> IO ()

- GHC.Runtime.Linker: withExtendedLinkEnv :: ExceptionMonad m => DynLinker -> [(Name, ForeignHValue)] -> m a -> m a

- GHC.Runtime.Linker.Types: BCOs :: CompiledByteCode -> [SptEntry] -> Unlinked

- GHC.Runtime.Linker.Types: DotA :: FilePath -> Unlinked

- GHC.Runtime.Linker.Types: DotDLL :: FilePath -> Unlinked

- GHC.Runtime.Linker.Types: DotO :: FilePath -> Unlinked

- GHC.Runtime.Linker.Types: DynLinker :: MVar (Maybe PersistentLinkerState) -> DynLinker

- GHC.Runtime.Linker.Types: LM :: UTCTime -> Module -> [Unlinked] -> Linkable

- GHC.Runtime.Linker.Types: PersistentLinkerState :: ClosureEnv -> !ItblEnv -> ![Linkable] -> ![Linkable] -> ![UnitId] -> ![(FilePath, String)] -> PersistentLinkerState

- GHC.Runtime.Linker.Types: SptEntry :: Id -> Fingerprint -> SptEntry

- GHC.Runtime.Linker.Types: [bcos_loaded] :: PersistentLinkerState -> ![Linkable]

- GHC.Runtime.Linker.Types: [closure_env] :: PersistentLinkerState -> ClosureEnv

- GHC.Runtime.Linker.Types: [dl_mpls] :: DynLinker -> MVar (Maybe PersistentLinkerState)

- GHC.Runtime.Linker.Types: [itbl_env] :: PersistentLinkerState -> !ItblEnv

- GHC.Runtime.Linker.Types: [linkableModule] :: Linkable -> Module

- GHC.Runtime.Linker.Types: [linkableTime] :: Linkable -> UTCTime

- GHC.Runtime.Linker.Types: [linkableUnlinked] :: Linkable -> [Unlinked]

- GHC.Runtime.Linker.Types: [objs_loaded] :: PersistentLinkerState -> ![Linkable]

- GHC.Runtime.Linker.Types: [pkgs_loaded] :: PersistentLinkerState -> ![UnitId]

- GHC.Runtime.Linker.Types: [temp_sos] :: PersistentLinkerState -> ![(FilePath, String)]

- GHC.Runtime.Linker.Types: data Linkable

- GHC.Runtime.Linker.Types: data PersistentLinkerState

- GHC.Runtime.Linker.Types: data SptEntry

- GHC.Runtime.Linker.Types: data Unlinked

- GHC.Runtime.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.Runtime.Linker.Types.Linkable

- GHC.Runtime.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.Runtime.Linker.Types.SptEntry

- GHC.Runtime.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.Runtime.Linker.Types.Unlinked

- GHC.Runtime.Linker.Types: newtype DynLinker

- GHC.Settings: PlatformConstants :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool -> Int -> Integer -> Integer -> Integer -> PlatformConstants

- GHC.Settings: PlatformMini :: Arch -> OS -> PlatformMini

- GHC.Settings: [pc_AP_STACK_SPLIM] :: PlatformConstants -> Int

- GHC.Settings: [pc_BITMAP_BITS_SHIFT] :: PlatformConstants -> Int

- GHC.Settings: [pc_BLOCKS_PER_MBLOCK] :: PlatformConstants -> Int

- GHC.Settings: [pc_BLOCK_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_CINT_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_CLONG_LONG_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_CLONG_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_CONTROL_GROUP_CONST_291] :: PlatformConstants -> Int

- GHC.Settings: [pc_DYNAMIC_BY_DEFAULT] :: PlatformConstants -> Bool

- GHC.Settings: [pc_ILDV_CREATE_MASK] :: PlatformConstants -> Integer

- GHC.Settings: [pc_ILDV_STATE_CREATE] :: PlatformConstants -> Integer

- GHC.Settings: [pc_ILDV_STATE_USE] :: PlatformConstants -> Integer

- GHC.Settings: [pc_LDV_SHIFT] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_CHARLIKE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Double_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Float_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_INTLIKE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Long_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Real_Double_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Real_Float_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Real_Long_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Real_Vanilla_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Real_XMM_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_SPEC_AP_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_SPEC_SELECTEE_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_Vanilla_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MAX_XMM_REG] :: PlatformConstants -> Int

- GHC.Settings: [pc_MIN_CHARLIKE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MIN_INTLIKE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MIN_PAYLOAD_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_MUT_ARR_PTRS_CARD_BITS] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_Capability_r] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_CostCentreStack_mem_alloc] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_CostCentreStack_scc_count] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgArrBytes_bytes] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgEntCounter_allocd] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgEntCounter_allocs] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgEntCounter_entry_count] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgEntCounter_link] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgEntCounter_registeredp] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgFunInfoExtraFwd_arity] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgFunInfoExtraRev_arity] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgHeader_ccs] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgHeader_ldvw] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgMutArrPtrs_ptrs] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgMutArrPtrs_size] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rCCCS] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rCurrentNursery] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rCurrentTSO] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rD1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rD2] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rD3] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rD4] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rD5] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rD6] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rF1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rF2] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rF3] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rF4] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rF5] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rF6] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rHpAlloc] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rHpLim] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rHp] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rL1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR10] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR2] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR3] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR4] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR5] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR6] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR7] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR8] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rR9] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rSpLim] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rSp] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rXMM1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rXMM2] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rXMM3] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rXMM4] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rXMM5] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rXMM6] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rYMM1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rYMM2] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rYMM3] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rYMM4] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rYMM5] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rYMM6] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rZMM1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rZMM2] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rZMM3] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rZMM4] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rZMM5] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgRegTable_rZMM6] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgSmallMutArrPtrs_ptrs] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgStack_sp] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgStack_stack] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgTSO_alloc_limit] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgTSO_cccs] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgTSO_stackobj] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_StgUpdateFrame_updatee] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_bdescr_blocks] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_bdescr_flags] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_bdescr_free] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_bdescr_start] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_stgEagerBlackholeInfo] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_stgGCEnter1] :: PlatformConstants -> Int

- GHC.Settings: [pc_OFFSET_stgGCFun] :: PlatformConstants -> Int

- GHC.Settings: [pc_PROF_HDR_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_REP_CostCentreStack_mem_alloc] :: PlatformConstants -> Int

- GHC.Settings: [pc_REP_CostCentreStack_scc_count] :: PlatformConstants -> Int

- GHC.Settings: [pc_REP_StgEntCounter_allocd] :: PlatformConstants -> Int

- GHC.Settings: [pc_REP_StgEntCounter_allocs] :: PlatformConstants -> Int

- GHC.Settings: [pc_REP_StgFunInfoExtraFwd_arity] :: PlatformConstants -> Int

- GHC.Settings: [pc_REP_StgFunInfoExtraRev_arity] :: PlatformConstants -> Int

- GHC.Settings: [pc_RESERVED_C_STACK_BYTES] :: PlatformConstants -> Int

- GHC.Settings: [pc_RESERVED_STACK_WORDS] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_CostCentreStack] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_StgArrBytes_NoHdr] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_StgFunInfoExtraRev] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_StgMutArrPtrs_NoHdr] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_StgSMPThunkHeader] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_StgSmallMutArrPtrs_NoHdr] :: PlatformConstants -> Int

- GHC.Settings: [pc_SIZEOF_StgUpdateFrame_NoHdr] :: PlatformConstants -> Int

- GHC.Settings: [pc_STD_HDR_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [pc_TAG_BITS] :: PlatformConstants -> Int

- GHC.Settings: [pc_TICKY_BIN_COUNT] :: PlatformConstants -> Int

- GHC.Settings: [pc_WORD_SIZE] :: PlatformConstants -> Int

- GHC.Settings: [platformMini] :: Platform -> !PlatformMini

- GHC.Settings: [platformMini_arch] :: PlatformMini -> Arch

- GHC.Settings: [platformMini_os] :: PlatformMini -> OS

- GHC.Settings: [platformMisc_ghcDebugged] :: PlatformMisc -> Bool

- GHC.Settings: [platformMisc_ghcThreaded] :: PlatformMisc -> Bool

- GHC.Settings: [sPlatformConstants] :: Settings -> PlatformConstants

- GHC.Settings: data PlatformConstants

- GHC.Settings: data PlatformMini

- GHC.Settings: instance GHC.Read.Read GHC.Settings.PlatformConstants

- GHC.Settings: sGhcDebugged :: Settings -> Bool

- GHC.Settings: sGhcThreaded :: Settings -> Bool

- GHC.Stg.Syntax: StgLam :: NonEmpty (BinderP pass) -> StgExpr -> GenStgExpr pass

- GHC.StgToCmm.Closure: instance GHC.Utils.Outputable.Outputable GHC.StgToCmm.Closure.CgLoc

- GHC.StgToCmm.Monad: instance GHC.Utils.Outputable.Outputable GHC.StgToCmm.Monad.CgIdInfo

- GHC.SysTools: getFrameworkOpts :: DynFlags -> Platform -> [String]

- GHC.SysTools: getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]

- GHC.SysTools: libmLinkOpts :: [Option]

- GHC.SysTools: linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()

- GHC.SysTools.ExtraObj: checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool

- GHC.SysTools.ExtraObj: getCompilerInfo :: DynFlags -> IO CompilerInfo

- GHC.SysTools.ExtraObj: getLinkInfo :: DynFlags -> [UnitId] -> IO String

- GHC.SysTools.ExtraObj: ghcLinkInfoNoteName :: String

- GHC.SysTools.ExtraObj: ghcLinkInfoSectionName :: String

- GHC.SysTools.ExtraObj: haveRtsOptsFlags :: DynFlags -> Bool

- GHC.SysTools.ExtraObj: mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath

- GHC.SysTools.ExtraObj: mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath

- GHC.SysTools.ExtraObj: mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]

- GHC.SysTools.ExtraObj: platformSupportsSavingLinkOpts :: OS -> Bool

- GHC.SysTools.FileCleanup: TFL_CurrentModule :: TempFileLifetime

- GHC.SysTools.FileCleanup: TFL_GhcSession :: TempFileLifetime

- GHC.SysTools.FileCleanup: addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()

- GHC.SysTools.FileCleanup: changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()

- GHC.SysTools.FileCleanup: cleanCurrentModuleTempFiles :: DynFlags -> IO ()

- GHC.SysTools.FileCleanup: cleanTempDirs :: DynFlags -> IO ()

- GHC.SysTools.FileCleanup: cleanTempFiles :: DynFlags -> IO ()

- GHC.SysTools.FileCleanup: data TempFileLifetime

- GHC.SysTools.FileCleanup: instance GHC.Show.Show GHC.SysTools.FileCleanup.TempFileLifetime

- GHC.SysTools.FileCleanup: newTempDir :: DynFlags -> IO FilePath

- GHC.SysTools.FileCleanup: newTempLibName :: DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String)

- GHC.SysTools.FileCleanup: newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath

- GHC.SysTools.FileCleanup: withSystemTempDirectory :: String -> (FilePath -> IO a) -> IO a

- GHC.SysTools.FileCleanup: withTempDirectory :: FilePath -> String -> (FilePath -> IO a) -> IO a

- GHC.SysTools.Tasks: get_rpath :: String -> Maybe FilePath

- GHC.SysTools.Tasks: rpath_parser :: ReadP FilePath

- GHC.SysTools.Tasks: runInjectRPaths :: DynFlags -> [FilePath] -> FilePath -> IO ()

- GHC.Tc.Gen.Expr: instance GHC.Hs.Extension.OutputableBndrId id => GHC.Utils.Outputable.Outputable (GHC.Tc.Gen.Expr.HsExprArg id)

- GHC.Tc.Gen.Expr: tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)

- GHC.Tc.Gen.HsType: ResSigCtxt :: UserTypeCtxt

- GHC.Tc.Gen.HsType: ThBrackCtxt :: UserTypeCtxt

- GHC.Tc.Gen.HsType: failIfEmitsConstraints :: TcM a -> TcM a

- GHC.Tc.Gen.HsType: solveEqualities :: TcM a -> TcM a

- GHC.Tc.Gen.HsType: tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]

- GHC.Tc.Gen.HsType: tcNamedWildCardBinders :: [Name] -> ([(Name, TcTyVar)] -> TcM a) -> TcM a

- GHC.Tc.Module: TM_NoInst :: TcRnExprMode

- GHC.Tc.Solver: emitFlatConstraints :: WantedConstraints -> TcM ()

- GHC.Tc.Solver: simpl_top :: WantedConstraints -> TcS WantedConstraints

- GHC.Tc.Solver: solveLocalEqualities :: String -> TcM a -> TcM a

- GHC.Tc.Solver: solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)

- GHC.Tc.Solver: tcCheckSatisfiability :: Bag EvVar -> TcM Bool

- GHC.Tc.Solver.Canonical: maybeSym :: SwapFlag -> TcCoercion -> TcCoercion

- GHC.Tc.Solver.Flatten: FM_FlattenAll :: FlattenMode

- GHC.Tc.Solver.Flatten: FM_SubstOnly :: FlattenMode

- GHC.Tc.Solver.Flatten: data FlattenMode

- GHC.Tc.Solver.Flatten: flatten :: FlattenMode -> CtEvidence -> TcType -> TcS (Xi, TcCoercion)

- GHC.Tc.Solver.Flatten: flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)

- GHC.Tc.Solver.Flatten: flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)

- GHC.Tc.Solver.Flatten: flattenType :: CtLoc -> TcType -> TcS TcType

- GHC.Tc.Solver.Flatten: instance GHC.Base.Applicative GHC.Tc.Solver.Flatten.FlatM

- GHC.Tc.Solver.Flatten: instance GHC.Base.Functor GHC.Tc.Solver.Flatten.FlatM

- GHC.Tc.Solver.Flatten: instance GHC.Base.Monad GHC.Tc.Solver.Flatten.FlatM

- GHC.Tc.Solver.Flatten: instance GHC.Utils.Outputable.Outputable GHC.Tc.Solver.Flatten.FlattenMode

- GHC.Tc.Solver.Flatten: rewriteTyVar :: TcTyVar -> TcS TcType

- GHC.Tc.Solver.Flatten: unflattenWanteds :: Cts -> Cts -> TcS Cts

- GHC.Tc.Solver.Monad: [inert_count] :: InertCans -> Int

- GHC.Tc.Solver.Monad: [inert_flat_cache] :: InertSet -> ExactFunEqMap (TcCoercion, TcType, CtFlavour)

- GHC.Tc.Solver.Monad: [inert_fsks] :: InertSet -> [(TcTyVar, TcType)]

- GHC.Tc.Solver.Monad: [wl_funeqs] :: WorkList -> [Ct]

- GHC.Tc.Solver.Monad: demoteUnfilledFmv :: TcTyVar -> TcS ()

- GHC.Tc.Solver.Monad: dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()

- GHC.Tc.Solver.Monad: extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()

- GHC.Tc.Solver.Monad: extendWorkListFunEq :: Ct -> WorkList -> WorkList

- GHC.Tc.Solver.Monad: getNoGivenEqs :: TcLevel -> [TcTyVar] -> TcS (Bool, Cts)

- GHC.Tc.Solver.Monad: instance GHC.Driver.Types.MonadThings GHC.Tc.Solver.Monad.TcS

- GHC.Tc.Solver.Monad: isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool

- GHC.Tc.Solver.Monad: lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))

- GHC.Tc.Solver.Monad: lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType

- GHC.Tc.Solver.Monad: mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool

- GHC.Tc.Solver.Monad: newFlattenSkolem :: CtFlavour -> CtLoc -> TyCon -> [TcType] -> TcS (CtEvidence, Coercion, TcTyVar)

- GHC.Tc.Solver.Monad: type EqualCtList = [Ct]

- GHC.Tc.Solver.Monad: unflattenFmv :: TcTyVar -> TcType -> TcS ()

- GHC.Tc.Solver.Monad: updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()

- GHC.Tc.Solver.Monad: workListWantedCount :: WorkList -> Int

- GHC.Tc.TyCl.PatSyn: nonBidirectionalErr :: Outputable name => name -> TcM a

- GHC.Tc.TyCl.PatSyn: tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)

- GHC.Tc.Types: CompleteMatch :: [Name] -> Name -> CompleteMatch

- GHC.Tc.Types: DsBound :: Id -> DsMetaVal

- GHC.Tc.Types: DsGblEnv :: Module -> FamInstEnv -> PrintUnqualified -> IORef Messages -> (IfGblEnv, IfLclEnv) -> CompleteMatchMap -> IORef CostCentreState -> DsGblEnv

- GHC.Tc.Types: DsLclEnv :: DsMetaEnv -> RealSrcSpan -> Deltas -> DsLclEnv

- GHC.Tc.Types: DsSplice :: HsExpr GhcTc -> DsMetaVal

- GHC.Tc.Types: [completeMatchConLikes] :: CompleteMatch -> [Name]

- GHC.Tc.Types: [completeMatchTyCon] :: CompleteMatch -> Name

- GHC.Tc.Types: [ds_cc_st] :: DsGblEnv -> IORef CostCentreState

- GHC.Tc.Types: [ds_complete_matches] :: DsGblEnv -> CompleteMatchMap

- GHC.Tc.Types: [ds_fam_inst_env] :: DsGblEnv -> FamInstEnv

- GHC.Tc.Types: [ds_if_env] :: DsGblEnv -> (IfGblEnv, IfLclEnv)

- GHC.Tc.Types: [ds_mod] :: DsGblEnv -> Module

- GHC.Tc.Types: [ds_msgs] :: DsGblEnv -> IORef Messages

- GHC.Tc.Types: [ds_unqual] :: DsGblEnv -> PrintUnqualified

- GHC.Tc.Types: [dsl_deltas] :: DsLclEnv -> Deltas

- GHC.Tc.Types: [dsl_loc] :: DsLclEnv -> RealSrcSpan

- GHC.Tc.Types: [dsl_meta] :: DsLclEnv -> DsMetaEnv

- GHC.Tc.Types: data DsGblEnv

- GHC.Tc.Types: data DsLclEnv

- GHC.Tc.Types: data DsMetaVal

- GHC.Tc.Types: extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch] -> CompleteMatchMap

- GHC.Tc.Types: instance GHC.Unit.Module.ContainsModule GHC.Tc.Types.DsGblEnv

- GHC.Tc.Types: mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap

- GHC.Tc.Types: type CompleteMatchMap = UniqFM Name [CompleteMatch]

- GHC.Tc.Types: type DsM = TcRnIf DsGblEnv DsLclEnv

- GHC.Tc.Types: type DsMetaEnv = NameEnv DsMetaVal

- GHC.Tc.Types.Constraint: BlockedCIS :: CtIrredStatus

- GHC.Tc.Types.Constraint: CFunEqCan :: CtEvidence -> TyCon -> [Xi] -> TcTyVar -> Ct

- GHC.Tc.Types.Constraint: CTyEqCan :: CtEvidence -> TcTyVar -> TcType -> EqRel -> Ct

- GHC.Tc.Types.Constraint: InsolubleCIS :: CtIrredStatus

- GHC.Tc.Types.Constraint: OtherCIS :: CtIrredStatus

- GHC.Tc.Types.Constraint: [cc_fsk] :: Ct -> TcTyVar

- GHC.Tc.Types.Constraint: [cc_fun] :: Ct -> TyCon

- GHC.Tc.Types.Constraint: [cc_status] :: Ct -> CtIrredStatus

- GHC.Tc.Types.Constraint: [cc_tyvar] :: Ct -> TcTyVar

- GHC.Tc.Types.Constraint: [ic_no_eqs] :: Implication -> Bool

- GHC.Tc.Types.Constraint: data CtIrredStatus

- GHC.Tc.Types.Constraint: funEqCanDischarge :: CtEvidence -> CtEvidence -> (SwapFlag, Bool)

- GHC.Tc.Types.Constraint: funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool)

- GHC.Tc.Types.Constraint: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Constraint.CtIrredStatus

- GHC.Tc.Types.Constraint: isCDictCan_Maybe :: Ct -> Maybe Class

- GHC.Tc.Types.Constraint: isCFunEqCan :: Ct -> Bool

- GHC.Tc.Types.Constraint: isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])

- GHC.Tc.Types.Constraint: isCNonCanonical :: Ct -> Bool

- GHC.Tc.Types.Constraint: isCTyEqCan :: Ct -> Bool

- GHC.Tc.Types.Constraint: isGivenOrWDeriv :: CtFlavour -> Bool

- GHC.Tc.Types.Origin: ResSigCtxt :: UserTypeCtxt

- GHC.Tc.Types.Origin: ThBrackCtxt :: UserTypeCtxt

- GHC.Tc.Types.Origin: UnboundOccurrenceOf :: OccName -> CtOrigin

- GHC.Tc.Utils.Env: instance GHC.Driver.Types.MonadThings (GHC.Data.IOEnv.IOEnv (GHC.Tc.Types.Env GHC.Tc.Types.TcGblEnv GHC.Tc.Types.TcLclEnv))

- GHC.Tc.Utils.Instantiate: topInstantiateInferred :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcSigmaType)

- GHC.Tc.Utils.Monad: class ContainsCostCentreState e

- GHC.Tc.Utils.Monad: extractCostCentreState :: ContainsCostCentreState e => e -> TcRef CostCentreState

- GHC.Tc.Utils.Monad: instance GHC.Tc.Utils.Monad.ContainsCostCentreState GHC.Tc.Types.DsGblEnv

- GHC.Tc.Utils.Monad: instance GHC.Tc.Utils.Monad.ContainsCostCentreState GHC.Tc.Types.TcGblEnv

- GHC.Tc.Utils.Monad: mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg

- GHC.Tc.Utils.Monad: withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a

- GHC.Tc.Utils.TcMType: newFmvTyVar :: TcType -> TcM TcTyVar

- GHC.Tc.Utils.TcMType: newFskTyVar :: TcType -> TcM TcTyVar

- GHC.Tc.Utils.TcMType: promoteTyVar :: TcTyVar -> TcM Bool

- GHC.Tc.Utils.TcType: FlatMetaTv :: MetaInfo

- GHC.Tc.Utils.TcType: FlatSkolTv :: MetaInfo

- GHC.Tc.Utils.TcType: isAlmostFunctionFree :: TcType -> Bool

- GHC.Tc.Utils.TcType: isFlattenTyVar :: TcTyVar -> Bool

- GHC.Tc.Utils.TcType: isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool

- GHC.Tc.Utils.TcType: isFmvTyVar :: TcTyVar -> Bool

- GHC.Tc.Utils.TcType: isFskTyVar :: TcTyVar -> Bool

- GHC.Tc.Utils.TcType: isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool

- GHC.Tc.Utils.TcType: isTyVarHead :: TcTyVar -> TcType -> Bool

- GHC.Tc.Utils.TcType: pprTyThingCategory :: TyThing -> SDoc

- GHC.Tc.Utils.TcType: tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)

- GHC.Tc.Utils.TcType: tcSplitForAllTys :: Type -> ([TyVar], Type)

- GHC.Tc.Utils.TcType: tcSplitForAllTysInvis :: Type -> ([TcInvisTVBinder], Type)

- GHC.Tc.Utils.TcType: tcSplitForAllTysReq :: Type -> ([TcReqTVBinder], Type)

- GHC.Tc.Utils.TcType: tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type)

- GHC.Tc.Utils.TcType: tyThingCategory :: TyThing -> String

- GHC.Tc.Utils.Unify: MTVU_Bad :: MetaTyVarUpdateResult a

- GHC.Tc.Utils.Unify: MTVU_HoleBlocker :: MetaTyVarUpdateResult a

- GHC.Tc.Utils.Unify: MTVU_OK :: a -> MetaTyVarUpdateResult a

- GHC.Tc.Utils.Unify: MTVU_Occurs :: MetaTyVarUpdateResult a

- GHC.Tc.Utils.Unify: data MetaTyVarUpdateResult a

- GHC.Tc.Utils.Unify: instance GHC.Base.Applicative GHC.Tc.Utils.Unify.MetaTyVarUpdateResult

- GHC.Tc.Utils.Unify: instance GHC.Base.Functor GHC.Tc.Utils.Unify.MetaTyVarUpdateResult

- GHC.Tc.Utils.Unify: instance GHC.Base.Monad GHC.Tc.Utils.Unify.MetaTyVarUpdateResult

- GHC.Tc.Utils.Unify: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Tc.Utils.Unify.MetaTyVarUpdateResult a)

- GHC.Tc.Utils.Unify: metaTyVarUpdateOK :: DynFlags -> TcTyVar -> TcType -> MetaTyVarUpdateResult TcType

- GHC.Tc.Utils.Unify: occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()

- GHC.Tc.Utils.Zonk: zonkTcTypesToTypes :: [TcType] -> TcM [Type]

- GHC.Tc.Utils.Zonk: zonkTyVarBinders :: [VarBndr TcTyVar vis] -> TcM (ZonkEnv, [VarBndr TyVar vis])

- GHC.Tc.Validity: ResSigCtxt :: UserTypeCtxt

- GHC.Tc.Validity: ThBrackCtxt :: UserTypeCtxt

- GHC.Types.Avail: availNamesWithOccs :: AvailInfo -> [(Name, OccName)]

- GHC.Types.Avail: availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]

- GHC.Types.Basic: DeprecatedTxt :: Located SourceText -> [Located StringLiteral] -> WarningTxt

- GHC.Types.Basic: FL :: SourceText -> Bool -> Rational -> FractionalLit

- GHC.Types.Basic: Fixity :: SourceText -> Int -> FixityDirection -> Fixity

- GHC.Types.Basic: IL :: SourceText -> Bool -> Integer -> IntegralLit

- GHC.Types.Basic: Infix :: LexicalFixity

- GHC.Types.Basic: InfixL :: FixityDirection

- GHC.Types.Basic: InfixN :: FixityDirection

- GHC.Types.Basic: InfixR :: FixityDirection

- GHC.Types.Basic: NoSourceText :: SourceText

- GHC.Types.Basic: NoUserInline :: InlineSpec

- GHC.Types.Basic: Prefix :: LexicalFixity

- GHC.Types.Basic: SourceText :: String -> SourceText

- GHC.Types.Basic: StringLiteral :: SourceText -> FastString -> StringLiteral

- GHC.Types.Basic: WarningTxt :: Located SourceText -> [Located StringLiteral] -> WarningTxt

- GHC.Types.Basic: [fl_neg] :: FractionalLit -> Bool

- GHC.Types.Basic: [fl_text] :: FractionalLit -> SourceText

- GHC.Types.Basic: [fl_value] :: FractionalLit -> Rational

- GHC.Types.Basic: [il_neg] :: IntegralLit -> Bool

- GHC.Types.Basic: [il_text] :: IntegralLit -> SourceText

- GHC.Types.Basic: [il_value] :: IntegralLit -> Integer

- GHC.Types.Basic: [sl_fs] :: StringLiteral -> FastString

- GHC.Types.Basic: [sl_st] :: StringLiteral -> SourceText

- GHC.Types.Basic: compareFixity :: Fixity -> Fixity -> (Bool, Bool)

- GHC.Types.Basic: data Fixity

- GHC.Types.Basic: data FixityDirection

- GHC.Types.Basic: data FractionalLit

- GHC.Types.Basic: data IntegralLit

- GHC.Types.Basic: data LexicalFixity

- GHC.Types.Basic: data SourceText

- GHC.Types.Basic: data StringLiteral

- GHC.Types.Basic: data WarningTxt

- GHC.Types.Basic: defaultFixity :: Fixity

- GHC.Types.Basic: funTyFixity :: Fixity

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.Fixity

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.FixityDirection

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.FractionalLit

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.IntegralLit

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.LexicalFixity

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.SourceText

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.StringLiteral

- GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.WarningTxt

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.Fixity

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.FixityDirection

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.FractionalLit

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.IntegralLit

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.LexicalFixity

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.SourceText

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.StringLiteral

- GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.WarningTxt

- GHC.Types.Basic: instance GHC.Classes.Ord GHC.Types.Basic.FractionalLit

- GHC.Types.Basic: instance GHC.Classes.Ord GHC.Types.Basic.IntegralLit

- GHC.Types.Basic: instance GHC.Show.Show GHC.Types.Basic.FractionalLit

- GHC.Types.Basic: instance GHC.Show.Show GHC.Types.Basic.IntegralLit

- GHC.Types.Basic: instance GHC.Show.Show GHC.Types.Basic.SourceText

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.Fixity

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.FixityDirection

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.FractionalLit

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.IntegralLit

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.LexicalFixity

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.SourceText

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.StringLiteral

- GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.WarningTxt

- GHC.Types.Basic: integralFractionalLit :: Bool -> Integer -> FractionalLit

- GHC.Types.Basic: maxPrecedence :: Int

- GHC.Types.Basic: minPrecedence :: Int

- GHC.Types.Basic: mkFractionalLit :: Real a => a -> FractionalLit

- GHC.Types.Basic: mkIntegralLit :: Integral a => a -> IntegralLit

- GHC.Types.Basic: negateFixity :: Fixity

- GHC.Types.Basic: negateFractionalLit :: FractionalLit -> FractionalLit

- GHC.Types.Basic: negateIntegralLit :: IntegralLit -> IntegralLit

- GHC.Types.Basic: pprWarningTxtForMsg :: WarningTxt -> SDoc

- GHC.Types.Basic: pprWithSourceText :: SourceText -> SDoc -> SDoc

- GHC.Types.Cpr: conCpr :: ConTag -> CprResult

- GHC.Types.Cpr: conCprType :: ConTag -> CprType

- GHC.Types.Cpr: data CprResult

- GHC.Types.Cpr: ensureCprTyArity :: Arity -> CprType -> CprType

- GHC.Types.Cpr: instance GHC.Classes.Eq GHC.Types.Cpr.CprResult

- GHC.Types.Cpr: instance GHC.Show.Show GHC.Types.Cpr.CprResult

- GHC.Types.Cpr: instance GHC.Utils.Binary.Binary GHC.Types.Cpr.CprResult

- GHC.Types.Cpr: instance GHC.Utils.Outputable.Outputable GHC.Types.Cpr.CprResult

- GHC.Types.Demand: UCall :: Count -> UseDmd -> UseDmd

- GHC.Types.Demand: UHead :: UseDmd

- GHC.Types.Demand: UProd :: [ArgUse] -> UseDmd

- GHC.Types.Demand: Used :: UseDmd

- GHC.Types.Demand: bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand

- GHC.Types.Demand: bothDmd :: Demand -> Demand -> Demand

- GHC.Types.Demand: bothDmdType :: DmdType -> BothDmdArg -> DmdType

- GHC.Types.Demand: cleanEvalDmd :: CleanDemand

- GHC.Types.Demand: cleanEvalProdDmd :: Arity -> CleanDemand

- GHC.Types.Demand: cleanUseDmd_maybe :: Demand -> Maybe UseDmd

- GHC.Types.Demand: data Count

- GHC.Types.Demand: data StrDmd

- GHC.Types.Demand: data UseDmd

- GHC.Types.Demand: getStrDmd :: JointDmd s u -> s

- GHC.Types.Demand: getUseDmd :: JointDmd s u -> u

- GHC.Types.Demand: instance (GHC.Classes.Eq s, GHC.Classes.Eq u) => GHC.Classes.Eq (GHC.Types.Demand.JointDmd s u)

- GHC.Types.Demand: instance (GHC.Show.Show s, GHC.Show.Show u) => GHC.Show.Show (GHC.Types.Demand.JointDmd s u)

- GHC.Types.Demand: instance (GHC.Utils.Binary.Binary s, GHC.Utils.Binary.Binary u) => GHC.Utils.Binary.Binary (GHC.Types.Demand.JointDmd s u)

- GHC.Types.Demand: instance (GHC.Utils.Outputable.Outputable s, GHC.Utils.Outputable.Outputable u) => GHC.Utils.Outputable.Outputable (GHC.Types.Demand.JointDmd s u)

- GHC.Types.Demand: instance GHC.Classes.Eq GHC.Types.Demand.Count

- GHC.Types.Demand: instance GHC.Classes.Eq GHC.Types.Demand.StrDmd

- GHC.Types.Demand: instance GHC.Classes.Eq GHC.Types.Demand.UseDmd

- GHC.Types.Demand: instance GHC.Classes.Eq s => GHC.Classes.Eq (GHC.Types.Demand.Str s)

- GHC.Types.Demand: instance GHC.Classes.Eq u => GHC.Classes.Eq (GHC.Types.Demand.Use u)

- GHC.Types.Demand: instance GHC.Show.Show GHC.Types.Demand.Count

- GHC.Types.Demand: instance GHC.Show.Show GHC.Types.Demand.Divergence

- GHC.Types.Demand: instance GHC.Show.Show GHC.Types.Demand.StrDmd

- GHC.Types.Demand: instance GHC.Show.Show GHC.Types.Demand.UseDmd

- GHC.Types.Demand: instance GHC.Show.Show s => GHC.Show.Show (GHC.Types.Demand.Str s)

- GHC.Types.Demand: instance GHC.Show.Show u => GHC.Show.Show (GHC.Types.Demand.Use u)

- GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.ArgStr

- GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.ArgUse

- GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.Count

- GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.StrDmd

- GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.UseDmd

- GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.ArgStr

- GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.ArgUse

- GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.Count

- GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.StrDmd

- GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.UseDmd

- GHC.Types.Demand: mkBothDmdArg :: DmdEnv -> BothDmdArg

- GHC.Types.Demand: mkCallDmd :: CleanDemand -> CleanDemand

- GHC.Types.Demand: mkCallDmds :: Arity -> CleanDemand -> CleanDemand

- GHC.Types.Demand: mkHeadStrict :: CleanDemand -> CleanDemand

- GHC.Types.Demand: mkManyUsedDmd :: CleanDemand -> Demand

- GHC.Types.Demand: mkOnceUsedDmd :: CleanDemand -> Demand

- GHC.Types.Demand: mkProdDmd :: [Demand] -> CleanDemand

- GHC.Types.Demand: peelUseCall :: UseDmd -> Maybe (Count, UseDmd)

- GHC.Types.Demand: postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg

- GHC.Types.Demand: postProcessUnsat :: DmdShell -> DmdType -> DmdType

- GHC.Types.Demand: pprIfaceStrictSig :: StrictSig -> SDoc

- GHC.Types.Demand: splitFVs :: Bool -> DmdEnv -> (DmdEnv, DmdEnv)

- GHC.Types.Demand: splitProdDmd_maybe :: Demand -> Maybe [Demand]

- GHC.Types.Demand: strictApply1Dmd :: Demand

- GHC.Types.Demand: strictenDmd :: Demand -> Demand

- GHC.Types.Demand: toBothDmdArg :: DmdType -> BothDmdArg

- GHC.Types.Demand: toCleanDmd :: Demand -> (DmdShell, CleanDemand)

- GHC.Types.Demand: type BothDmdArg = (DmdEnv, Divergence)

- GHC.Types.Demand: type CleanDemand = JointDmd StrDmd UseDmd

- GHC.Types.Demand: type Demand = JointDmd ArgStr ArgUse

- GHC.Types.Demand: type DmdShell = JointDmd (Str ()) (Use ())

- GHC.Types.Demand: useCount :: Use u -> Count

- GHC.Types.Demand: zapUsageEnvSig :: StrictSig -> StrictSig

- GHC.Types.FieldLabel: [flIsOverloaded] :: FieldLbl a -> Bool

- GHC.Types.FieldLabel: data FieldLbl a

- GHC.Types.FieldLabel: instance Data.Data.Data a => Data.Data.Data (GHC.Types.FieldLabel.FieldLbl a)

- GHC.Types.FieldLabel: instance Data.Foldable.Foldable GHC.Types.FieldLabel.FieldLbl

- GHC.Types.FieldLabel: instance Data.Traversable.Traversable GHC.Types.FieldLabel.FieldLbl

- GHC.Types.FieldLabel: instance GHC.Base.Functor GHC.Types.FieldLabel.FieldLbl

- GHC.Types.FieldLabel: instance GHC.Classes.Eq a => GHC.Classes.Eq (GHC.Types.FieldLabel.FieldLbl a)

- GHC.Types.FieldLabel: instance GHC.Utils.Binary.Binary a => GHC.Utils.Binary.Binary (GHC.Types.FieldLabel.FieldLbl a)

- GHC.Types.FieldLabel: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.FieldLabel.FieldLbl a)

- GHC.Types.FieldLabel: mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName

- GHC.Types.FieldLabel: type FieldLabel = FieldLbl Name

- GHC.Types.Literal: char2IntLit :: Literal -> Literal

- GHC.Types.Literal: double2FloatLit :: Literal -> Literal

- GHC.Types.Literal: double2IntLit :: Literal -> Literal

- GHC.Types.Literal: float2DoubleLit :: Literal -> Literal

- GHC.Types.Literal: float2IntLit :: Literal -> Literal

- GHC.Types.Literal: int2CharLit :: Literal -> Literal

- GHC.Types.Literal: int2DoubleLit :: Literal -> Literal

- GHC.Types.Literal: int2FloatLit :: Literal -> Literal

- GHC.Types.Literal: int2WordLit :: Platform -> Literal -> Literal

- GHC.Types.Literal: isLitValue :: Literal -> Bool

- GHC.Types.Literal: narrow16IntLit :: Literal -> Literal

- GHC.Types.Literal: narrow16WordLit :: Literal -> Literal

- GHC.Types.Literal: narrow32IntLit :: Literal -> Literal

- GHC.Types.Literal: narrow32WordLit :: Literal -> Literal

- GHC.Types.Literal: narrow8IntLit :: Literal -> Literal

- GHC.Types.Literal: narrow8WordLit :: Literal -> Literal

- GHC.Types.Literal: narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal

- GHC.Types.Literal: word2IntLit :: Platform -> Literal -> Literal

- GHC.Types.Name.Reader: FldParent :: Name -> Maybe FieldLabelString -> Parent

- GHC.Types.Name.Reader: [par_lbl] :: Parent -> Maybe FieldLabelString

- GHC.Types.Name.Reader: greLabel :: GlobalRdrElt -> Maybe FieldLabelString

- GHC.Types.Name.Reader: isOverloadedRecFldGRE :: GlobalRdrElt -> Bool

- GHC.Types.SrcLoc: instance (GHC.Utils.Outputable.Outputable l, GHC.Utils.Outputable.Outputable e) => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated l e)

- GHC.Types.Unique: dataConTyRepNameUnique :: Unique -> Unique

- GHC.Types.Unique: dataConWorkerUnique :: Unique -> Unique

- GHC.Types.Unique: initExitJoinUnique :: Unique

- GHC.Types.Unique: initTyVarUnique :: Unique

- GHC.Types.Unique: mkAlphaTyVarUnique :: Int -> Unique

- GHC.Types.Unique: mkBuiltinUnique :: Int -> Unique

- GHC.Types.Unique: mkCoVarUnique :: Int -> Unique

- GHC.Types.Unique: mkCostCentreUnique :: Int -> Unique

- GHC.Types.Unique: mkDataOccUnique :: FastString -> Unique

- GHC.Types.Unique: mkPreludeClassUnique :: Int -> Unique

- GHC.Types.Unique: mkPreludeDataConUnique :: Arity -> Unique

- GHC.Types.Unique: mkPreludeMiscIdUnique :: Int -> Unique

- GHC.Types.Unique: mkPreludeTyConUnique :: Int -> Unique

- GHC.Types.Unique: mkPrimOpIdUnique :: Int -> Unique

- GHC.Types.Unique: mkPrimOpWrapperUnique :: Int -> Unique

- GHC.Types.Unique: mkPseudoUniqueD :: Int -> Unique

- GHC.Types.Unique: mkPseudoUniqueE :: Int -> Unique

- GHC.Types.Unique: mkPseudoUniqueH :: Int -> Unique

- GHC.Types.Unique: mkRegClassUnique :: Int -> Unique

- GHC.Types.Unique: mkRegPairUnique :: Int -> Unique

- GHC.Types.Unique: mkRegSingleUnique :: Int -> Unique

- GHC.Types.Unique: mkRegSubUnique :: Int -> Unique

- GHC.Types.Unique: mkTcOccUnique :: FastString -> Unique

- GHC.Types.Unique: mkTvOccUnique :: FastString -> Unique

- GHC.Types.Unique: mkVarOccUnique :: FastString -> Unique

- GHC.Types.Unique: tyConRepNameUnique :: Unique -> Unique

- GHC.Unit.Info: instance GHC.Classes.Ord GHC.Unit.Info.PackageId

- GHC.Unit.Info: instance GHC.Classes.Ord GHC.Unit.Info.PackageName

- GHC.Unit.Module: unitIdEq :: UnitId -> Unit -> Bool

- GHC.Unit.State: collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]

- GHC.Unit.State: collectIncludeDirs :: [UnitInfo] -> [FilePath]

- GHC.Unit.State: collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath]

- GHC.Unit.State: collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])

- GHC.Unit.State: displayUnitId :: UnitState -> UnitId -> Maybe String

- GHC.Unit.State: getLibs :: DynFlags -> [UnitId] -> IO [(String, String)]

- GHC.Unit.State: getPreloadUnitsAnd :: DynFlags -> [UnitId] -> IO [UnitInfo]

- GHC.Unit.State: getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]

- GHC.Unit.State: getUnitFrameworkPath :: DynFlags -> [UnitId] -> IO [String]

- GHC.Unit.State: getUnitFrameworks :: DynFlags -> [UnitId] -> IO [String]

- GHC.Unit.State: getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String]

- GHC.Unit.State: getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String]

- GHC.Unit.State: getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])

- GHC.Unit.State: homeUnitIsDefinite :: DynFlags -> Bool

- GHC.Unit.State: homeUnitIsIndefinite :: DynFlags -> Bool

- GHC.Unit.State: mkIndefUnitId :: UnitState -> FastString -> IndefUnitId

- GHC.Unit.State: packageHsLibs :: DynFlags -> UnitInfo -> [String]

- GHC.Unit.State: updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId

- GHC.Unit.Types: [indefUnitPprInfo] :: Indefinite unit -> Maybe UnitPprInfo

- GHC.Unit.Types: data Indefinite unit

- GHC.Unit.Types: instance GHC.Classes.Eq GHC.Unit.Types.Unit

- GHC.Unit.Types: instance GHC.Types.Unique.Uniquable GHC.Unit.Types.Unit

- GHC.Unit.Types: mkGenInstantiatedUnit :: (unit -> FastString) -> Indefinite unit -> GenInstantiations unit -> GenInstantiatedUnit unit

- GHC.Unit.Types: mkGenVirtUnit :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> GenUnit unit

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary Data.Typeable.Internal.SomeTypeRep

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Serialized.Serialized

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.Activation

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.Fixity

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.FixityDirection

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.FunctionOrData

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.InlinePragma

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.InlineSpec

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.LeftOrRight

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.OverlapFlag

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.OverlapMode

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.PromotionFlag

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.RecFlag

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.RuleMatchInfo

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.SourceText

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.StringLiteral

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.TupleSort

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.Basic.WarningTxt

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.KindRep

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.RuntimeRep

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.TyCon

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.TypeLitSort

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.VecCount

- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Types.VecElem

- GHC.Utils.Binary: instance forall k (a :: k). Data.Typeable.Internal.Typeable a => GHC.Utils.Binary.Binary (Data.Typeable.Internal.TypeRep a)

- GHC.Utils.Encoding: countUTF8Chars :: ShortByteString -> IO Int

- GHC.Utils.Encoding: toBase62 :: Word64 -> String

- GHC.Utils.Encoding: toBase62Padded :: Word64 -> String

- GHC.Utils.Encoding: utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)

- GHC.Utils.Encoding: utf8DecodeByteString :: ByteString -> [Char]

- GHC.Utils.Encoding: utf8DecodeChar :: Ptr Word8 -> (Char, Int)

- GHC.Utils.Encoding: utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)

- GHC.Utils.Encoding: utf8DecodeShortByteString :: ShortByteString -> [Char]

- GHC.Utils.Encoding: utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]

- GHC.Utils.Encoding: utf8EncodeChar :: (Int# -> Word# -> State# s -> State# s) -> Char -> ST s Int

- GHC.Utils.Encoding: utf8EncodeShortByteString :: String -> IO ShortByteString

- GHC.Utils.Encoding: utf8EncodeString :: Ptr Word8 -> String -> IO ()

- GHC.Utils.Encoding: utf8EncodedLength :: String -> Int

- GHC.Utils.Encoding: utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)

- GHC.Utils.Encoding: utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)

- GHC.Utils.Encoding: zDecodeString :: EncodedString -> UserString

- GHC.Utils.Encoding: zEncodeString :: UserString -> EncodedString

- GHC.Utils.Error: DumpOptions :: Bool -> String -> DumpOptions

- GHC.Utils.Error: FormatASM :: DumpFormat

- GHC.Utils.Error: FormatByteCode :: DumpFormat

- GHC.Utils.Error: FormatC :: DumpFormat

- GHC.Utils.Error: FormatCMM :: DumpFormat

- GHC.Utils.Error: FormatCore :: DumpFormat

- GHC.Utils.Error: FormatHaskell :: DumpFormat

- GHC.Utils.Error: FormatLLVM :: DumpFormat

- GHC.Utils.Error: FormatSTG :: DumpFormat

- GHC.Utils.Error: FormatText :: DumpFormat

- GHC.Utils.Error: [dumpForcedToFile] :: DumpOptions -> Bool

- GHC.Utils.Error: [dumpSuffix] :: DumpOptions -> String

- GHC.Utils.Error: data DumpFormat

- GHC.Utils.Error: data DumpOptions

- GHC.Utils.Error: data ErrDoc

- GHC.Utils.Error: data ErrMsg

- GHC.Utils.Error: defaultDumpAction :: DumpAction

- GHC.Utils.Error: defaultTraceAction :: TraceAction

- GHC.Utils.Error: dumpAction :: DumpAction

- GHC.Utils.Error: dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()

- GHC.Utils.Error: dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

- GHC.Utils.Error: dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

- GHC.Utils.Error: dumpOptionsFromFlag :: DumpFlag -> DumpOptions

- GHC.Utils.Error: errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc

- GHC.Utils.Error: errDocContext :: ErrDoc -> [MsgDoc]

- GHC.Utils.Error: errDocImportant :: ErrDoc -> [MsgDoc]

- GHC.Utils.Error: errDocSupplementary :: ErrDoc -> [MsgDoc]

- GHC.Utils.Error: errMsgContext :: ErrMsg -> PrintUnqualified

- GHC.Utils.Error: errMsgDoc :: ErrMsg -> ErrDoc

- GHC.Utils.Error: errMsgReason :: ErrMsg -> WarnReason

- GHC.Utils.Error: errMsgSeverity :: ErrMsg -> Severity

- GHC.Utils.Error: errMsgSpan :: ErrMsg -> SrcSpan

- GHC.Utils.Error: formatErrDoc :: SDocContext -> ErrDoc -> SDoc

- GHC.Utils.Error: instance GHC.Classes.Eq GHC.Utils.Error.DumpFormat

- GHC.Utils.Error: instance GHC.Show.Show GHC.Utils.Error.DumpFormat

- GHC.Utils.Error: instance GHC.Show.Show GHC.Utils.Error.ErrMsg

- GHC.Utils.Error: instance GHC.Show.Show GHC.Utils.Error.Severity

- GHC.Utils.Error: instance GHC.Utils.Json.ToJson GHC.Utils.Error.Severity

- GHC.Utils.Error: isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)

- GHC.Utils.Error: mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg

- GHC.Utils.Error: mkErrMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg

- GHC.Utils.Error: mkLongErrMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg

- GHC.Utils.Error: mkPlainErrMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg

- GHC.Utils.Error: pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]

- GHC.Utils.Error: pprLocErrMsg :: ErrMsg -> SDoc

- GHC.Utils.Error: printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()

- GHC.Utils.Error: touchDumpFile :: DynFlags -> DumpOptions -> IO ()

- GHC.Utils.Error: traceAction :: TraceAction

- GHC.Utils.Error: type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String -> DumpFormat -> SDoc -> IO ()

- GHC.Utils.Error: type Messages = (WarningMessages, ErrorMessages)

- GHC.Utils.Error: type MsgDoc = SDoc

- GHC.Utils.Error: type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a

- GHC.Utils.Error: warningsToMessages :: DynFlags -> WarningMessages -> Messages

- GHC.Utils.Error: withTimingD :: (MonadIO m, HasDynFlags m) => SDoc -> (a -> ()) -> m a -> m a

- GHC.Utils.Error: withTimingSilentD :: (MonadIO m, HasDynFlags m) => SDoc -> (a -> ()) -> m a -> m a

- GHC.Utils.Misc: consIORef :: IORef [a] -> a -> IO ()

- GHC.Utils.Misc: global :: a -> IORef a

- GHC.Utils.Misc: globalM :: IO a -> IORef a

- GHC.Utils.Misc: sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a

- GHC.Utils.Misc: sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a

- GHC.Utils.Outputable: [sdocDynFlags] :: SDocContext -> DynFlags

- GHC.Utils.Outputable: assertPanic :: String -> Int -> a

- GHC.Utils.Outputable: assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a

- GHC.Utils.Outputable: callStackDoc :: HasCallStack => SDoc

- GHC.Utils.Outputable: data CodeStyle

- GHC.Utils.Outputable: initSDocContext :: DynFlags -> PprStyle -> SDocContext

- GHC.Utils.Outputable: mkCodeStyle :: CodeStyle -> PprStyle

- GHC.Utils.Outputable: panic :: String -> a

- GHC.Utils.Outputable: pgmError :: String -> a

- GHC.Utils.Outputable: pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a

- GHC.Utils.Outputable: pprPanic :: HasCallStack => String -> SDoc -> a

- GHC.Utils.Outputable: pprPgmError :: String -> SDoc -> a

- GHC.Utils.Outputable: pprPrec :: Outputable a => Rational -> a -> SDoc

- GHC.Utils.Outputable: pprSTrace :: HasCallStack => SDoc -> a -> a

- GHC.Utils.Outputable: pprSorry :: String -> SDoc -> a

- GHC.Utils.Outputable: pprTrace :: String -> SDoc -> a -> a

- GHC.Utils.Outputable: pprTraceDebug :: String -> SDoc -> a -> a

- GHC.Utils.Outputable: pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a

- GHC.Utils.Outputable: pprTraceIt :: Outputable a => String -> a -> a

- GHC.Utils.Outputable: pprTraceM :: Applicative f => String -> SDoc -> f ()

- GHC.Utils.Outputable: pprTraceWith :: String -> (a -> SDoc) -> a -> a

- GHC.Utils.Outputable: pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a

- GHC.Utils.Outputable: printForC :: DynFlags -> Handle -> SDoc -> IO ()

- GHC.Utils.Outputable: printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()

- GHC.Utils.Outputable: renderWithStyle :: SDocContext -> SDoc -> String

- GHC.Utils.Outputable: sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc

- GHC.Utils.Outputable: showPpr :: Outputable a => DynFlags -> a -> String

- GHC.Utils.Outputable: showSDoc :: DynFlags -> SDoc -> String

- GHC.Utils.Outputable: showSDocDebug :: DynFlags -> SDoc -> String

- GHC.Utils.Outputable: showSDocDump :: DynFlags -> SDoc -> String

- GHC.Utils.Outputable: showSDocDumpOneLine :: DynFlags -> SDoc -> String

- GHC.Utils.Outputable: showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String

- GHC.Utils.Outputable: showSDocUnqual :: DynFlags -> SDoc -> String

- GHC.Utils.Outputable: sorry :: String -> a

- GHC.Utils.Outputable: trace :: String -> a -> a

- GHC.Utils.Outputable: warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a

+ GHC: AnnClosePH :: AnnKeywordId

+ GHC: AnnOpenPH :: AnnKeywordId

+ GHC: BreakInfo :: Module -> Int -> BreakInfo

+ GHC: EpaComment :: EpaCommentTok -> RealSrcSpan -> EpaComment

+ GHC: GhcApiError :: String -> GhcApiError

+ GHC: Interpreter :: Backend

+ GHC: LLVM :: Backend

+ GHC: NCG :: Backend

+ GHC: NoBackend :: Backend

+ GHC: Opt_ByteCode :: GeneralFlag

+ GHC: Opt_DistinctConstructorTables :: GeneralFlag

+ GHC: Opt_ExposeInternalSymbols :: GeneralFlag

+ GHC: Opt_FamAppCache :: GeneralFlag

+ GHC: Opt_InfoTableMap :: GeneralFlag

+ GHC: Opt_InlineGenerics :: GeneralFlag

+ GHC: Opt_InlineGenericsAggressively :: GeneralFlag

+ GHC: ViaC :: Backend

+ GHC: [ac_prior_tok] :: EpaComment -> RealSrcSpan

+ GHC: [ac_tok] :: EpaComment -> EpaCommentTok

+ GHC: [backend] :: DynFlags -> !Backend

+ GHC: [breakInfo_module] :: BreakInfo -> Module

+ GHC: [breakInfo_number] :: BreakInfo -> Int

+ GHC: [callerCcFilters] :: DynFlags -> [CallerCcFilter]

+ GHC: [cfgWeights] :: DynFlags -> Weights

+ GHC: [dynHiSuf_] :: DynFlags -> String

+ GHC: [dynObjectSuf_] :: DynFlags -> String

+ GHC: [dynOutputFile_] :: DynFlags -> Maybe String

+ GHC: [dynOutputHi] :: DynFlags -> Maybe String

+ GHC: [dynamicNow] :: DynFlags -> !Bool

+ GHC: [dynamicTooFailed] :: DynFlags -> IORef Bool

+ GHC: [hiSuf_] :: DynFlags -> String

+ GHC: [homeUnitId_] :: DynFlags -> UnitId

+ GHC: [homeUnitInstanceOf_] :: DynFlags -> Maybe UnitId

+ GHC: [homeUnitInstantiations_] :: DynFlags -> [(ModuleName, Module)]

+ GHC: [mainModuleNameIs] :: DynFlags -> ModuleName

+ GHC: [mi_complete_matches] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceCompleteMatch]

+ GHC: [objectSuf_] :: DynFlags -> String

+ GHC: [outputFile_] :: DynFlags -> Maybe String

+ GHC: [targetWays_] :: DynFlags -> Ways

+ GHC: [unfoldingOpts] :: DynFlags -> !UnfoldingOpts

+ GHC: data Backend

+ GHC: data EpaComment

+ GHC: data Logger

+ GHC: getLogger :: HasLogger m => m Logger

+ GHC: instance GHC.Exception.Type.Exception GHC.GhcApiError

+ GHC: instance GHC.Show.Show GHC.GhcApiError

+ GHC: modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()

+ GHC: newtype GhcApiError

+ GHC: parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])

+ GHC: popLogHook :: Logger -> Logger

+ GHC: popLogHookM :: GhcMonad m => m ()

+ GHC: pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger

+ GHC: pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()

+ GHC: putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()

+ GHC: putMsgM :: GhcMonad m => SDoc -> m ()

+ GHC: setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m ()

+ GHC: splitForAllTyCoVars :: Type -> ([TyCoVar], Type)

+ GHC.Builtin.Names: boxedRepDataConKey :: Unique

+ GHC.Builtin.Names: considerAccessibleIdKey :: Unique

+ GHC.Builtin.Names: considerAccessibleName :: Name

+ GHC.Builtin.Names: dataToTag_RDR :: RdrName

+ GHC.Builtin.Names: fromLabelClassOpKey :: Unique

+ GHC.Builtin.Names: fromLabelClassOpName :: Name

+ GHC.Builtin.Names: gHC_TYPELITS_INTERNAL :: Module

+ GHC.Builtin.Names: gHC_TYPENATS_INTERNAL :: Module

+ GHC.Builtin.Names: getFieldClassOpKey :: Unique

+ GHC.Builtin.Names: getFieldName :: Name

+ GHC.Builtin.Names: knownCharClassName :: Name

+ GHC.Builtin.Names: knownCharClassNameKey :: Unique

+ GHC.Builtin.Names: leftSectionKey :: Unique

+ GHC.Builtin.Names: levityTyConKey :: Unique

+ GHC.Builtin.Names: liftedDataConKey :: Unique

+ GHC.Builtin.Names: liftedRepTyConKey :: Unique

+ GHC.Builtin.Names: mkRationalBase10IdKey :: Unique

+ GHC.Builtin.Names: mkRationalBase10Name :: Name

+ GHC.Builtin.Names: mkRationalBase2IdKey :: Unique

+ GHC.Builtin.Names: mkRationalBase2Name :: Name

+ GHC.Builtin.Names: naturalToDoubleIdKey :: Unique

+ GHC.Builtin.Names: naturalToDoubleName :: Name

+ GHC.Builtin.Names: naturalToFloatIdKey :: Unique

+ GHC.Builtin.Names: naturalToFloatName :: Name

+ GHC.Builtin.Names: nonEmptyDataConKey :: Unique

+ GHC.Builtin.Names: nonEmptyTyConKey :: Unique

+ GHC.Builtin.Names: rightSectionKey :: Unique

+ GHC.Builtin.Names: setFieldClassOpKey :: Unique

+ GHC.Builtin.Names: setFieldName :: Name

+ GHC.Builtin.Names: trLiftedRepKey :: Unique

+ GHC.Builtin.Names: typeCharCmpTyFamNameKey :: Unique

+ GHC.Builtin.Names: typeCharKindConNameKey :: Unique

+ GHC.Builtin.Names: typeCharToNatTyFamNameKey :: Unique

+ GHC.Builtin.Names: typeCharTypeRepKey :: Unique

+ GHC.Builtin.Names: typeCharTypeRepName :: Name

+ GHC.Builtin.Names: typeConsSymbolTyFamNameKey :: Unique

+ GHC.Builtin.Names: typeLeqCharTyFamNameKey :: Unique

+ GHC.Builtin.Names: typeLitCharDataConKey :: Unique

+ GHC.Builtin.Names: typeLitCharDataConName :: Name

+ GHC.Builtin.Names: typeNatToCharTyFamNameKey :: Unique

+ GHC.Builtin.Names: typeUnconsSymbolTyFamNameKey :: Unique

+ GHC.Builtin.Names: unliftedDataConKey :: Unique

+ GHC.Builtin.Names: unliftedRepTyConKey :: Unique

+ GHC.Builtin.Names: unliftedTypeKindTyConKey :: Unique

+ GHC.Builtin.Names: word8TyConName :: Name

+ GHC.Builtin.Names.TH: charTyLitIdKey :: Unique

+ GHC.Builtin.Names.TH: charTyLitName :: Name

+ GHC.Builtin.Names.TH: getFieldEIdKey :: Unique

+ GHC.Builtin.Names.TH: getFieldEName :: Name

+ GHC.Builtin.Names.TH: projectionEIdKey :: Unique

+ GHC.Builtin.Names.TH: projectionEName :: Name

+ GHC.Builtin.PrimOps: AddrToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: AtomicReadAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: AtomicWriteAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: DoubleToFloatOp :: PrimOp

+ GHC.Builtin.PrimOps: DoubleToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: FetchAddAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: FetchAndAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: FetchNandAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: FetchOrAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: FetchSubAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: FetchXorAddrOp_Word :: PrimOp

+ GHC.Builtin.PrimOps: FloatToDoubleOp :: PrimOp

+ GHC.Builtin.PrimOps: FloatToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: Int16SllOp :: PrimOp

+ GHC.Builtin.PrimOps: Int16SraOp :: PrimOp

+ GHC.Builtin.PrimOps: Int16SrlOp :: PrimOp

+ GHC.Builtin.PrimOps: Int16ToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: Int16ToWord16Op :: PrimOp

+ GHC.Builtin.PrimOps: Int32AddOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32EqOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32GeOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32GtOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32LeOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32LtOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32MulOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32NeOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32NegOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32QuotOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32QuotRemOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32RemOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32SllOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32SraOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32SrlOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32SubOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32ToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: Int32ToWord32Op :: PrimOp

+ GHC.Builtin.PrimOps: Int8SllOp :: PrimOp

+ GHC.Builtin.PrimOps: Int8SraOp :: PrimOp

+ GHC.Builtin.PrimOps: Int8SrlOp :: PrimOp

+ GHC.Builtin.PrimOps: Int8ToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: Int8ToWord8Op :: PrimOp

+ GHC.Builtin.PrimOps: IntAndOp :: PrimOp

+ GHC.Builtin.PrimOps: IntNotOp :: PrimOp

+ GHC.Builtin.PrimOps: IntOrOp :: PrimOp

+ GHC.Builtin.PrimOps: IntSllOp :: PrimOp

+ GHC.Builtin.PrimOps: IntSraOp :: PrimOp

+ GHC.Builtin.PrimOps: IntSrlOp :: PrimOp

+ GHC.Builtin.PrimOps: IntToAddrOp :: PrimOp

+ GHC.Builtin.PrimOps: IntToDoubleOp :: PrimOp

+ GHC.Builtin.PrimOps: IntToFloatOp :: PrimOp

+ GHC.Builtin.PrimOps: IntToInt16Op :: PrimOp

+ GHC.Builtin.PrimOps: IntToInt32Op :: PrimOp

+ GHC.Builtin.PrimOps: IntToInt8Op :: PrimOp

+ GHC.Builtin.PrimOps: IntToWordOp :: PrimOp

+ GHC.Builtin.PrimOps: IntXorOp :: PrimOp

+ GHC.Builtin.PrimOps: MutableByteArrayContents_Char :: PrimOp

+ GHC.Builtin.PrimOps: WhereFromOp :: PrimOp

+ GHC.Builtin.PrimOps: Word16AndOp :: PrimOp

+ GHC.Builtin.PrimOps: Word16OrOp :: PrimOp

+ GHC.Builtin.PrimOps: Word16SllOp :: PrimOp

+ GHC.Builtin.PrimOps: Word16SrlOp :: PrimOp

+ GHC.Builtin.PrimOps: Word16ToInt16Op :: PrimOp

+ GHC.Builtin.PrimOps: Word16ToWordOp :: PrimOp

+ GHC.Builtin.PrimOps: Word16XorOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32AddOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32AndOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32EqOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32GeOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32GtOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32LeOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32LtOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32MulOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32NeOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32NotOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32OrOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32QuotOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32QuotRemOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32RemOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32SllOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32SrlOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32SubOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32ToInt32Op :: PrimOp

+ GHC.Builtin.PrimOps: Word32ToWordOp :: PrimOp

+ GHC.Builtin.PrimOps: Word32XorOp :: PrimOp

+ GHC.Builtin.PrimOps: Word8AndOp :: PrimOp

+ GHC.Builtin.PrimOps: Word8OrOp :: PrimOp

+ GHC.Builtin.PrimOps: Word8SllOp :: PrimOp

+ GHC.Builtin.PrimOps: Word8SrlOp :: PrimOp

+ GHC.Builtin.PrimOps: Word8ToInt8Op :: PrimOp

+ GHC.Builtin.PrimOps: Word8ToWordOp :: PrimOp

+ GHC.Builtin.PrimOps: Word8XorOp :: PrimOp

+ GHC.Builtin.PrimOps: WordAndOp :: PrimOp

+ GHC.Builtin.PrimOps: WordNotOp :: PrimOp

+ GHC.Builtin.PrimOps: WordOrOp :: PrimOp

+ GHC.Builtin.PrimOps: WordSllOp :: PrimOp

+ GHC.Builtin.PrimOps: WordSrlOp :: PrimOp

+ GHC.Builtin.PrimOps: WordToDoubleOp :: PrimOp

+ GHC.Builtin.PrimOps: WordToFloatOp :: PrimOp

+ GHC.Builtin.PrimOps: WordToIntOp :: PrimOp

+ GHC.Builtin.PrimOps: WordToWord16Op :: PrimOp

+ GHC.Builtin.PrimOps: WordToWord32Op :: PrimOp

+ GHC.Builtin.PrimOps: WordToWord8Op :: PrimOp

+ GHC.Builtin.PrimOps: WordXorOp :: PrimOp

+ GHC.Builtin.PrimOps: primOpIsDiv :: PrimOp -> Bool

+ GHC.Builtin.Types: boxedRepDataConTyCon :: TyCon

+ GHC.Builtin.Types: cTupleDataCon :: Arity -> DataCon

+ GHC.Builtin.Types: cTupleSelId :: ConTag -> Arity -> Id

+ GHC.Builtin.Types: cTupleSelIdName :: ConTag -> Arity -> Name

+ GHC.Builtin.Types: cTupleTyCon :: Arity -> TyCon

+ GHC.Builtin.Types: filterCTuple :: RdrName -> RdrName

+ GHC.Builtin.Types: isPromotedMaybeTy :: Type -> Maybe (Maybe Type)

+ GHC.Builtin.Types: isPromotedPairType :: Type -> Maybe (Type, Type)

+ GHC.Builtin.Types: levityTyCon :: TyCon

+ GHC.Builtin.Types: liftedDataConTy :: Type

+ GHC.Builtin.Types: liftedDataConTyCon :: TyCon

+ GHC.Builtin.Types: liftedRepTyCon :: TyCon

+ GHC.Builtin.Types: liftedRepTyConName :: Name

+ GHC.Builtin.Types: mkMaybeTy :: Type -> Kind

+ GHC.Builtin.Types: mkPromotedMaybeTy :: Kind -> Maybe Type -> Type

+ GHC.Builtin.Types: mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type

+ GHC.Builtin.Types: nonEmptyDataCon :: DataCon

+ GHC.Builtin.Types: nonEmptyDataConName :: Name

+ GHC.Builtin.Types: nonEmptyTyCon :: TyCon

+ GHC.Builtin.Types: nonEmptyTyConName :: Name

+ GHC.Builtin.Types: soloTyCon :: TyCon

+ GHC.Builtin.Types: unboxedUnitTy :: Type

+ GHC.Builtin.Types: unliftedDataConTy :: Type

+ GHC.Builtin.Types: unliftedDataConTyCon :: TyCon

+ GHC.Builtin.Types: unliftedRepTy :: Type

+ GHC.Builtin.Types: unliftedRepTyCon :: TyCon

+ GHC.Builtin.Types: unliftedRepTyConName :: Name

+ GHC.Builtin.Types: unliftedTypeKind :: Kind

+ GHC.Builtin.Types: unliftedTypeKindTyCon :: TyCon

+ GHC.Builtin.Types: unliftedTypeKindTyConName :: Name

+ GHC.Builtin.Types.Literals: typeCharCmpTyCon :: TyCon

+ GHC.Builtin.Types.Literals: typeCharToNatTyCon :: TyCon

+ GHC.Builtin.Types.Literals: typeConsSymbolTyCon :: TyCon

+ GHC.Builtin.Types.Literals: typeNatToCharTyCon :: TyCon

+ GHC.Builtin.Types.Literals: typeUnconsSymbolTyCon :: TyCon

+ GHC.Builtin.Types.Prim: multiplicityTyVar1 :: TyVar

+ GHC.Builtin.Types.Prim: multiplicityTyVar2 :: TyVar

+ GHC.Builtin.Types.Prim: openGammaTy :: Type

+ GHC.Builtin.Types.Prim: openGammaTyVar :: TyVar

+ GHC.Builtin.Types.Prim: runtimeRep3Ty :: Type

+ GHC.Builtin.Types.Prim: runtimeRep3TyVar :: TyVar

+ GHC.Builtin.Uniques: dataConTyRepNameUnique :: Unique -> Unique

+ GHC.Builtin.Uniques: dataConWorkerUnique :: Unique -> Unique

+ GHC.Builtin.Uniques: initExitJoinUnique :: Unique

+ GHC.Builtin.Uniques: initTyVarUnique :: Unique

+ GHC.Builtin.Uniques: mkAlphaTyVarUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkBuiltinUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique

+ GHC.Builtin.Uniques: mkCoVarUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkCostCentreUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkDataOccUnique :: FastString -> Unique

+ GHC.Builtin.Uniques: mkPreludeClassUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkPreludeDataConUnique :: Arity -> Unique

+ GHC.Builtin.Uniques: mkPreludeMiscIdUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkPreludeTyConUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkPrimOpIdUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkPrimOpWrapperUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkPseudoUniqueD :: Int -> Unique

+ GHC.Builtin.Uniques: mkPseudoUniqueE :: Int -> Unique

+ GHC.Builtin.Uniques: mkPseudoUniqueH :: Int -> Unique

+ GHC.Builtin.Uniques: mkRegClassUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkRegPairUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkRegSingleUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkRegSubUnique :: Int -> Unique

+ GHC.Builtin.Uniques: mkTcOccUnique :: FastString -> Unique

+ GHC.Builtin.Uniques: mkTvOccUnique :: FastString -> Unique

+ GHC.Builtin.Uniques: mkVarOccUnique :: FastString -> Unique

+ GHC.Builtin.Uniques: tyConRepNameUnique :: Unique -> Unique

+ GHC.ByteCode.Asm: mkTupleInfoLit :: Platform -> TupleInfo -> Literal

+ GHC.ByteCode.Instr: LocalLabel :: Word32 -> LocalLabel

+ GHC.ByteCode.Instr: PUSH_ALTS_TUPLE :: ProtoBCO Name -> !TupleInfo -> ProtoBCO Name -> BCInstr

+ GHC.ByteCode.Instr: RETURN_TUPLE :: BCInstr

+ GHC.ByteCode.Instr: RETURN_UNLIFTED :: ArgRep -> BCInstr

+ GHC.ByteCode.Instr: [getLocalLabel] :: LocalLabel -> Word32

+ GHC.ByteCode.Instr: instance GHC.Classes.Eq GHC.ByteCode.Instr.LocalLabel

+ GHC.ByteCode.Instr: instance GHC.Classes.Ord GHC.ByteCode.Instr.LocalLabel

+ GHC.ByteCode.Instr: instance GHC.Utils.Outputable.Outputable GHC.ByteCode.Instr.LocalLabel

+ GHC.ByteCode.Instr: newtype LocalLabel

+ GHC.ByteCode.Types: ByteOff :: Int -> ByteOff

+ GHC.ByteCode.Types: RegBitmap :: Word32 -> RegBitmap

+ GHC.ByteCode.Types: TupleInfo :: !WordOff -> !GlobalRegSet -> !WordOff -> TupleInfo

+ GHC.ByteCode.Types: WordOff :: Int -> WordOff

+ GHC.ByteCode.Types: [tupleNativeStackSize] :: TupleInfo -> !WordOff

+ GHC.ByteCode.Types: [tupleRegs] :: TupleInfo -> !GlobalRegSet

+ GHC.ByteCode.Types: [tupleSize] :: TupleInfo -> !WordOff

+ GHC.ByteCode.Types: [unRegBitmap] :: RegBitmap -> Word32

+ GHC.ByteCode.Types: data TupleInfo

+ GHC.ByteCode.Types: instance GHC.Bits.Bits GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Bits.FiniteBits GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Classes.Eq GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Classes.Eq GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Classes.Eq GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Classes.Ord GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Classes.Ord GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Classes.Ord GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Enum.Enum GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Enum.Enum GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Enum.Enum GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Num.Num GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Num.Num GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Num.Num GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Real.Integral GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Real.Integral GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Real.Integral GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Real.Real GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Real.Real GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Real.Real GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Show.Show GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Show.Show GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Show.Show GHC.ByteCode.Types.TupleInfo

+ GHC.ByteCode.Types: instance GHC.Show.Show GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: instance GHC.Utils.Outputable.Outputable GHC.ByteCode.Types.ByteOff

+ GHC.ByteCode.Types: instance GHC.Utils.Outputable.Outputable GHC.ByteCode.Types.RegBitmap

+ GHC.ByteCode.Types: instance GHC.Utils.Outputable.Outputable GHC.ByteCode.Types.TupleInfo

+ GHC.ByteCode.Types: instance GHC.Utils.Outputable.Outputable GHC.ByteCode.Types.WordOff

+ GHC.ByteCode.Types: newtype ByteOff

+ GHC.ByteCode.Types: newtype RegBitmap

+ GHC.ByteCode.Types: newtype WordOff

+ GHC.ByteCode.Types: voidTupleInfo :: TupleInfo

+ GHC.Cmm: instance GHC.Base.Functor (GHC.Cmm.GenCmmDecl d h)

+ GHC.Cmm: instance GHC.Base.Functor GHC.Cmm.GenBasicBlock

+ GHC.Cmm: instance GHC.Base.Functor GHC.Cmm.ListGraph

+ GHC.Cmm: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CmmStatic

+ GHC.Cmm: instance GHC.Utils.Outputable.OutputableP env instr => GHC.Utils.Outputable.OutputableP env (GHC.Cmm.GenBasicBlock instr)

+ GHC.Cmm: instance GHC.Utils.Outputable.OutputableP env instr => GHC.Utils.Outputable.OutputableP env (GHC.Cmm.ListGraph instr)

+ GHC.Cmm.CLabel: AsmStyle :: LabelStyle

+ GHC.Cmm.CLabel: CStyle :: LabelStyle

+ GHC.Cmm.CLabel: DefinitionSite :: ConInfoTableLocation

+ GHC.Cmm.CLabel: InfoProvEnt :: !CLabel -> !Int -> !String -> !Module -> !Maybe (RealSrcSpan, String) -> InfoProvEnt

+ GHC.Cmm.CLabel: UsageSite :: Module -> Int -> ConInfoTableLocation

+ GHC.Cmm.CLabel: [infoProvEntClosureType] :: InfoProvEnt -> !Int

+ GHC.Cmm.CLabel: [infoProvModule] :: InfoProvEnt -> !Module

+ GHC.Cmm.CLabel: [infoTableProv] :: InfoProvEnt -> !Maybe (RealSrcSpan, String)

+ GHC.Cmm.CLabel: [infoTablePtr] :: InfoProvEnt -> !CLabel

+ GHC.Cmm.CLabel: [infoTableType] :: InfoProvEnt -> !String

+ GHC.Cmm.CLabel: data ConInfoTableLocation

+ GHC.Cmm.CLabel: data InfoProvEnt

+ GHC.Cmm.CLabel: data LabelStyle

+ GHC.Cmm.CLabel: getConInfoTableLocation :: IdLabelInfo -> Maybe ConInfoTableLocation

+ GHC.Cmm.CLabel: hasIdLabelInfo :: CLabel -> Maybe IdLabelInfo

+ GHC.Cmm.CLabel: instance GHC.Classes.Eq GHC.Cmm.CLabel.ConInfoTableLocation

+ GHC.Cmm.CLabel: instance GHC.Classes.Eq GHC.Cmm.CLabel.InfoProvEnt

+ GHC.Cmm.CLabel: instance GHC.Classes.Ord GHC.Cmm.CLabel.ConInfoTableLocation

+ GHC.Cmm.CLabel: instance GHC.Classes.Ord GHC.Cmm.CLabel.InfoProvEnt

+ GHC.Cmm.CLabel: instance GHC.Show.Show GHC.Cmm.CLabel.CLabel

+ GHC.Cmm.CLabel: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CLabel.ConInfoTableLocation

+ GHC.Cmm.CLabel: instance GHC.Utils.Outputable.Outputable GHC.Cmm.CLabel.IdLabelInfo

+ GHC.Cmm.CLabel: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.CLabel.CLabel

+ GHC.Cmm.CLabel: mkAsmTempProcEndLabel :: CLabel -> CLabel

+ GHC.Cmm.CLabel: mkIPELabel :: InfoProvEnt -> CLabel

+ GHC.Cmm.CLabel: ppInternalProcLabel :: Module -> CLabel -> Maybe SDoc

+ GHC.Cmm.CallConv: tupleRegsCover :: Platform -> [GlobalReg]

+ GHC.Cmm.Dataflow.Collections: type ElemOf set;

+ GHC.Cmm.Dataflow.Collections: type KeyOf map;

+ GHC.Cmm.Dataflow.Label: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.Dataflow.Label.Label

+ GHC.Cmm.Dataflow.Label: instance GHC.Utils.Outputable.OutputableP env a => GHC.Utils.Outputable.OutputableP env (GHC.Cmm.Dataflow.Label.LabelMap a)

+ GHC.Cmm.DebugBlock: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.DebugBlock.DebugBlock

+ GHC.Cmm.DebugBlock: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.DebugBlock.UnwindExpr

+ GHC.Cmm.DebugBlock: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.DebugBlock.UnwindPoint

+ GHC.Cmm.Expr: instance GHC.Show.Show GHC.Cmm.Expr.Area

+ GHC.Cmm.Expr: instance GHC.Show.Show GHC.Cmm.Expr.CmmExpr

+ GHC.Cmm.Expr: instance GHC.Show.Show GHC.Cmm.Expr.CmmLit

+ GHC.Cmm.Expr: instance GHC.Show.Show GHC.Cmm.Expr.CmmReg

+ GHC.Cmm.Expr: instance GHC.Show.Show GHC.Cmm.Expr.LocalReg

+ GHC.Cmm.Expr: instance GHC.Utils.Outputable.Outputable GHC.Cmm.Expr.CmmLit

+ GHC.Cmm.Info: PtrOpts :: !Profile -> !Bool -> PtrOpts

+ GHC.Cmm.Info: [po_align_check] :: PtrOpts -> !Bool

+ GHC.Cmm.Info: [po_profile] :: PtrOpts -> !Profile

+ GHC.Cmm.Info: data PtrOpts

+ GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.Info.Build.CAFLabel

+ GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.Info.Build.ModuleSRTInfo

+ GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.Info.Build.SRTEntry

+ GHC.Cmm.Info.Build: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.Cmm.Info.Build.SomeLabel

+ GHC.Cmm.LRegSet: deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet

+ GHC.Cmm.LRegSet: elemLRegSet :: LocalReg -> LRegSet -> Bool

+ GHC.Cmm.LRegSet: elemsLRegSet :: IntSet -> [Int]

+ GHC.Cmm.LRegSet: emptyLRegSet :: LRegSet

+ GHC.Cmm.LRegSet: insertLRegSet :: LocalReg -> LRegSet -> LRegSet

+ GHC.Cmm.LRegSet: nullLRegSet :: LRegSet -> Bool

+ GHC.Cmm.LRegSet: plusLRegSet :: IntSet -> IntSet -> IntSet

+ GHC.Cmm.LRegSet: sizeLRegSet :: IntSet -> Int

+ GHC.Cmm.LRegSet: type LRegKey = Int

+ GHC.Cmm.LRegSet: type LRegSet = IntSet

+ GHC.Cmm.Liveness: cmmLocalLivenessL :: Platform -> CmmGraph -> BlockEntryLivenessL

+ GHC.Cmm.Liveness: gen_killL :: (DefinerOfRegs LocalReg n, UserOfRegs LocalReg n) => Platform -> n -> LRegSet -> LRegSet

+ GHC.Cmm.Liveness: liveLatticeL :: DataflowLattice LRegSet

+ GHC.Cmm.MachOp: MO_I64_FromI :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Ge :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Gt :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Le :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Lt :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Quot :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Rem :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_Shr :: CallishMachOp

+ GHC.Cmm.MachOp: MO_I64_ToI :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_FromW :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Ge :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Gt :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Le :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Lt :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Quot :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Rem :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_Shr :: CallishMachOp

+ GHC.Cmm.MachOp: MO_W64_ToW :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Add :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_And :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Eq :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Mul :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Ne :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Neg :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Not :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Or :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Shl :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Sub :: CallishMachOp

+ GHC.Cmm.MachOp: MO_x64_Xor :: CallishMachOp

+ GHC.Cmm.Parser.Monad: PD :: (DynFlags -> HomeUnit -> PState -> ParseResult a) -> PD a

+ GHC.Cmm.Parser.Monad: [unPD] :: PD a -> DynFlags -> HomeUnit -> PState -> ParseResult a

+ GHC.Cmm.Parser.Monad: failMsgPD :: (SrcSpan -> PsError) -> PD a

+ GHC.Cmm.Parser.Monad: getHomeUnitId :: PD UnitId

+ GHC.Cmm.Parser.Monad: getPlatform :: PD Platform

+ GHC.Cmm.Parser.Monad: getProfile :: PD Profile

+ GHC.Cmm.Parser.Monad: getPtrOpts :: PD PtrOpts

+ GHC.Cmm.Parser.Monad: instance GHC.Base.Applicative GHC.Cmm.Parser.Monad.PD

+ GHC.Cmm.Parser.Monad: instance GHC.Base.Functor GHC.Cmm.Parser.Monad.PD

+ GHC.Cmm.Parser.Monad: instance GHC.Base.Monad GHC.Cmm.Parser.Monad.PD

+ GHC.Cmm.Parser.Monad: instance GHC.Driver.Session.HasDynFlags GHC.Cmm.Parser.Monad.PD

+ GHC.Cmm.Parser.Monad: liftP :: P a -> PD a

+ GHC.Cmm.Parser.Monad: newtype PD a

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.C GHC.Cmm.Dataflow.Block.C)

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.C GHC.Cmm.Dataflow.Block.O)

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.O GHC.Cmm.Dataflow.Block.C)

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.Dataflow.Block.Block GHC.Cmm.Node.CmmNode GHC.Cmm.Dataflow.Block.O GHC.Cmm.Dataflow.Block.O)

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.Dataflow.Graph.Graph GHC.Cmm.Node.CmmNode e x)

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.Node.CmmNode e x)

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.CmmGraph

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.CmmTopInfo

+ GHC.Cmm.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.Node.ForeignTarget

+ GHC.Cmm.Ppr.Decl: instance (GHC.Utils.Outputable.OutputableP GHC.Platform.Platform d, GHC.Utils.Outputable.OutputableP GHC.Platform.Platform info, GHC.Utils.Outputable.OutputableP GHC.Platform.Platform i) => GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.GenCmmDecl d info i)

+ GHC.Cmm.Ppr.Decl: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform (GHC.Cmm.GenCmmStatics a)

+ GHC.Cmm.Ppr.Decl: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.CmmInfoTable

+ GHC.Cmm.Ppr.Decl: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.CmmStatic

+ GHC.Cmm.Ppr.Expr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.Expr.CmmExpr

+ GHC.Cmm.Ppr.Expr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.Cmm.Expr.CmmLit

+ GHC.Cmm.Ppr.Expr: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.Expr.GlobalReg

+ GHC.Cmm.Switch: backendSupportsSwitch :: Backend -> Bool

+ GHC.Cmm.Type: instance GHC.Show.Show GHC.Cmm.Type.CmmCat

+ GHC.Cmm.Type: instance GHC.Show.Show GHC.Cmm.Type.CmmType

+ GHC.Cmm.Utils: mAX_PTR_TAG :: Platform -> Int

+ GHC.Cmm.Utils: tAG_MASK :: Platform -> Int

+ GHC.CmmToAsm: initNCGConfig :: DynFlags -> Module -> NCGConfig

+ GHC.CmmToAsm.AArch64: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.AArch64.Instr.Instr

+ GHC.CmmToAsm.AArch64: ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest

+ GHC.CmmToAsm.AArch64.CodeGen: cmmTopCodeGen :: RawCmmDecl -> NatM [NatCmmDecl RawCmmStatics Instr]

+ GHC.CmmToAsm.AArch64.CodeGen: generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl RawCmmStatics Instr)

+ GHC.CmmToAsm.AArch64.Cond: ALWAYS :: Cond

+ GHC.CmmToAsm.AArch64.Cond: EQ :: Cond

+ GHC.CmmToAsm.AArch64.Cond: NE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: NEVER :: Cond

+ GHC.CmmToAsm.AArch64.Cond: OGE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: OGT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: OLE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: OLT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: SGE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: SGT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: SLE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: SLT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: UGE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: UGT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: ULE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: ULT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: UOGE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: UOGT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: UOLE :: Cond

+ GHC.CmmToAsm.AArch64.Cond: UOLT :: Cond

+ GHC.CmmToAsm.AArch64.Cond: VC :: Cond

+ GHC.CmmToAsm.AArch64.Cond: VS :: Cond

+ GHC.CmmToAsm.AArch64.Cond: data Cond

+ GHC.CmmToAsm.AArch64.Cond: instance GHC.Classes.Eq GHC.CmmToAsm.AArch64.Cond.Cond

+ GHC.CmmToAsm.AArch64.Instr: ADD :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: AND :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: ANDS :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: ANN :: SDoc -> Instr -> Instr

+ GHC.CmmToAsm.AArch64.Instr: ASR :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: B :: Target -> Instr

+ GHC.CmmToAsm.AArch64.Instr: BCOND :: Cond -> Target -> Instr

+ GHC.CmmToAsm.AArch64.Instr: BIC :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: BICS :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: BL :: Target -> [Reg] -> [Reg] -> Instr

+ GHC.CmmToAsm.AArch64.Instr: CBNZ :: Operand -> Target -> Instr

+ GHC.CmmToAsm.AArch64.Instr: CBZ :: Operand -> Target -> Instr

+ GHC.CmmToAsm.AArch64.Instr: CMN :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: CMP :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: COMMENT :: SDoc -> Instr

+ GHC.CmmToAsm.AArch64.Instr: CSET :: Operand -> Cond -> Instr

+ GHC.CmmToAsm.AArch64.Instr: DELTA :: Int -> Instr

+ GHC.CmmToAsm.AArch64.Instr: DMBSY :: Instr

+ GHC.CmmToAsm.AArch64.Instr: EON :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: EOR :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: ESXTB :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: ESXTH :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: ESXTW :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: ESXTX :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: EUXTB :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: EUXTH :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: EUXTW :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: EUXTX :: ExtMode

+ GHC.CmmToAsm.AArch64.Instr: FABS :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: FCVT :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: FCVTZS :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: J :: Target -> Instr

+ GHC.CmmToAsm.AArch64.Instr: LDATA :: Section -> RawCmmStatics -> Instr

+ GHC.CmmToAsm.AArch64.Instr: LDP :: Format -> Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: LDR :: Format -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: LOCATION :: Int -> Int -> Int -> String -> Instr

+ GHC.CmmToAsm.AArch64.Instr: LSL :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: LSR :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: MOV :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: MOVK :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: MSUB :: Operand -> Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: MUL :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: MULTILINE_COMMENT :: SDoc -> Instr

+ GHC.CmmToAsm.AArch64.Instr: MVN :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: NEG :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: NEWBLOCK :: BlockId -> Instr

+ GHC.CmmToAsm.AArch64.Instr: ORN :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: ORR :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: OpAddr :: AddrMode -> Operand

+ GHC.CmmToAsm.AArch64.Instr: OpImm :: Imm -> Operand

+ GHC.CmmToAsm.AArch64.Instr: OpImmShift :: Imm -> ShiftMode -> RegShift -> Operand

+ GHC.CmmToAsm.AArch64.Instr: OpReg :: Width -> Reg -> Operand

+ GHC.CmmToAsm.AArch64.Instr: OpRegExt :: Width -> Reg -> ExtMode -> ExtShift -> Operand

+ GHC.CmmToAsm.AArch64.Instr: OpRegShift :: Width -> Reg -> ShiftMode -> RegShift -> Operand

+ GHC.CmmToAsm.AArch64.Instr: POP_STACK_FRAME :: Instr

+ GHC.CmmToAsm.AArch64.Instr: PUSH_STACK_FRAME :: Instr

+ GHC.CmmToAsm.AArch64.Instr: ROR :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: SASR :: ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: SBFM :: Operand -> Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: SCVTF :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: SDIV :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: SLSL :: ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: SLSR :: ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: SROR :: ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: STP :: Format -> Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: STR :: Format -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: SUB :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: TBlock :: BlockId -> Target

+ GHC.CmmToAsm.AArch64.Instr: TLabel :: CLabel -> Target

+ GHC.CmmToAsm.AArch64.Instr: TReg :: Reg -> Target

+ GHC.CmmToAsm.AArch64.Instr: TST :: Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: UBFM :: Operand -> Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: UDIV :: Operand -> Operand -> Operand -> Instr

+ GHC.CmmToAsm.AArch64.Instr: _d :: Int -> Operand

+ GHC.CmmToAsm.AArch64.Instr: _x :: Int -> Operand

+ GHC.CmmToAsm.AArch64.Instr: allocMoreStack :: Platform -> Int -> NatCmmDecl statics Instr -> UniqSM (NatCmmDecl statics Instr, [(BlockId, BlockId)])

+ GHC.CmmToAsm.AArch64.Instr: callerSavedRegisters :: [Reg]

+ GHC.CmmToAsm.AArch64.Instr: d0 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d1 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d10 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d11 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d12 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d13 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d14 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d15 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d16 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d17 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d18 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d19 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d2 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d20 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d21 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d22 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d23 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d24 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d25 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d26 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d27 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d28 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d29 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d3 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d30 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d31 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d4 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d5 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d6 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d7 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d8 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: d9 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: data ExtMode

+ GHC.CmmToAsm.AArch64.Instr: data Instr

+ GHC.CmmToAsm.AArch64.Instr: data Operand

+ GHC.CmmToAsm.AArch64.Instr: data ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: data Target

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Classes.Eq GHC.CmmToAsm.AArch64.Instr.ExtMode

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Classes.Eq GHC.CmmToAsm.AArch64.Instr.Operand

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Classes.Eq GHC.CmmToAsm.AArch64.Instr.ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.ExtMode

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.Instr

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.Operand

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.ShiftMode

+ GHC.CmmToAsm.AArch64.Instr: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.Instr.RegUsage

+ GHC.CmmToAsm.AArch64.Instr: ip0 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: isJumpishInstr :: Instr -> Bool

+ GHC.CmmToAsm.AArch64.Instr: isMetaInstr :: Instr -> Bool

+ GHC.CmmToAsm.AArch64.Instr: jumpDestsOfInstr :: Instr -> [BlockId]

+ GHC.CmmToAsm.AArch64.Instr: maxSpillSlots :: NCGConfig -> Int

+ GHC.CmmToAsm.AArch64.Instr: mkJumpInstr :: BlockId -> [Instr]

+ GHC.CmmToAsm.AArch64.Instr: mkLoadInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.AArch64.Instr: mkRegRegMoveInstr :: Reg -> Reg -> Instr

+ GHC.CmmToAsm.AArch64.Instr: mkSpillInstr :: HasCallStack => NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.AArch64.Instr: mkStackAllocInstr :: Platform -> Int -> [Instr]

+ GHC.CmmToAsm.AArch64.Instr: mkStackDeallocInstr :: Platform -> Int -> [Instr]

+ GHC.CmmToAsm.AArch64.Instr: opReg :: Width -> Reg -> Operand

+ GHC.CmmToAsm.AArch64.Instr: opRegSExt :: Width -> Reg -> Operand

+ GHC.CmmToAsm.AArch64.Instr: opRegUExt :: Width -> Reg -> Operand

+ GHC.CmmToAsm.AArch64.Instr: patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr

+ GHC.CmmToAsm.AArch64.Instr: patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr

+ GHC.CmmToAsm.AArch64.Instr: regUsageOfInstr :: Platform -> Instr -> RegUsage

+ GHC.CmmToAsm.AArch64.Instr: sp :: Operand

+ GHC.CmmToAsm.AArch64.Instr: spillSlotSize :: Int

+ GHC.CmmToAsm.AArch64.Instr: spillSlotToOffset :: NCGConfig -> Int -> Int

+ GHC.CmmToAsm.AArch64.Instr: stackAlign :: Int

+ GHC.CmmToAsm.AArch64.Instr: stackFrameHeaderSize :: Platform -> Int

+ GHC.CmmToAsm.AArch64.Instr: takeDeltaInstr :: Instr -> Maybe Int

+ GHC.CmmToAsm.AArch64.Instr: takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)

+ GHC.CmmToAsm.AArch64.Instr: type ExtShift = Int

+ GHC.CmmToAsm.AArch64.Instr: type RegShift = Int

+ GHC.CmmToAsm.AArch64.Instr: wzr :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x0 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x1 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x10 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x11 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x12 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x13 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x14 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x15 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x16 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x17 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x18 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x19 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x2 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x20 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x21 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x22 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x23 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x24 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x25 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x26 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x27 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x28 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x29 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x3 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x30 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x31 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x4 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x5 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x6 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x7 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x8 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: x9 :: Operand

+ GHC.CmmToAsm.AArch64.Instr: xzr :: Operand

+ GHC.CmmToAsm.AArch64.Ppr: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.AArch64.Instr.Instr

+ GHC.CmmToAsm.AArch64.Ppr: pprInstr :: Platform -> Instr -> SDoc

+ GHC.CmmToAsm.AArch64.Ppr: pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc

+ GHC.CmmToAsm.AArch64.RegInfo: DestBlockId :: BlockId -> JumpDest

+ GHC.CmmToAsm.AArch64.RegInfo: canShortcut :: Instr -> Maybe JumpDest

+ GHC.CmmToAsm.AArch64.RegInfo: data JumpDest

+ GHC.CmmToAsm.AArch64.RegInfo: getJumpDestBlockId :: JumpDest -> Maybe BlockId

+ GHC.CmmToAsm.AArch64.RegInfo: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.AArch64.RegInfo.JumpDest

+ GHC.CmmToAsm.AArch64.RegInfo: shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr

+ GHC.CmmToAsm.AArch64.RegInfo: shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics

+ GHC.CmmToAsm.AArch64.Regs: AddrReg :: Reg -> AddrMode

+ GHC.CmmToAsm.AArch64.Regs: AddrRegImm :: Reg -> Imm -> AddrMode

+ GHC.CmmToAsm.AArch64.Regs: AddrRegReg :: Reg -> Reg -> AddrMode

+ GHC.CmmToAsm.AArch64.Regs: ImmCLbl :: CLabel -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmConstantDiff :: Imm -> Imm -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmConstantSum :: Imm -> Imm -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmDouble :: Rational -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmFloat :: Rational -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmIndex :: CLabel -> Int -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmInt :: Int -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmInteger :: Integer -> Imm

+ GHC.CmmToAsm.AArch64.Regs: ImmLit :: SDoc -> Imm

+ GHC.CmmToAsm.AArch64.Regs: allFpArgRegs :: [Reg]

+ GHC.CmmToAsm.AArch64.Regs: allGpArgRegs :: [Reg]

+ GHC.CmmToAsm.AArch64.Regs: allMachRegNos :: [RegNo]

+ GHC.CmmToAsm.AArch64.Regs: allocatableRegs :: Platform -> [RealReg]

+ GHC.CmmToAsm.AArch64.Regs: classOfRealReg :: RealReg -> RegClass

+ GHC.CmmToAsm.AArch64.Regs: data AddrMode

+ GHC.CmmToAsm.AArch64.Regs: data Imm

+ GHC.CmmToAsm.AArch64.Regs: instance GHC.Classes.Eq GHC.CmmToAsm.AArch64.Regs.AddrMode

+ GHC.CmmToAsm.AArch64.Regs: instance GHC.Classes.Eq GHC.CmmToAsm.AArch64.Regs.Imm

+ GHC.CmmToAsm.AArch64.Regs: instance GHC.Classes.Eq GHC.Utils.Outputable.SDoc

+ GHC.CmmToAsm.AArch64.Regs: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Regs.AddrMode

+ GHC.CmmToAsm.AArch64.Regs: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Regs.Imm

+ GHC.CmmToAsm.AArch64.Regs: instance GHC.Show.Show GHC.Utils.Outputable.SDoc

+ GHC.CmmToAsm.AArch64.Regs: litToImm :: CmmLit -> Imm

+ GHC.CmmToAsm.AArch64.Regs: mkVirtualReg :: Unique -> Format -> VirtualReg

+ GHC.CmmToAsm.AArch64.Regs: realRegSqueeze :: RegClass -> RealReg -> Int

+ GHC.CmmToAsm.AArch64.Regs: regDotColor :: RealReg -> SDoc

+ GHC.CmmToAsm.AArch64.Regs: strImmLit :: String -> Imm

+ GHC.CmmToAsm.AArch64.Regs: virtualRegSqueeze :: RegClass -> VirtualReg -> Int

+ GHC.CmmToAsm.CFG.Weight: Weights :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Weights

+ GHC.CmmToAsm.CFG.Weight: [backEdgeBonus] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [callWeight] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [condBranchWeight] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [infoTablePenalty] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [likelyCondWeight] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [switchWeight] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [uncondWeight] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: [unlikelyCondWeight] :: Weights -> Int

+ GHC.CmmToAsm.CFG.Weight: data Weights

+ GHC.CmmToAsm.CFG.Weight: defaultWeights :: Weights

+ GHC.CmmToAsm.CFG.Weight: parseWeights :: String -> Weights -> Weights

+ GHC.CmmToAsm.Config: [ncgAsmContext] :: NCGConfig -> !SDocContext

+ GHC.CmmToAsm.Config: [ncgCfgBlockLayout] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgCfgWeightlessLayout] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgCfgWeights] :: NCGConfig -> !Weights

+ GHC.CmmToAsm.Config: [ncgDwarfEnabled] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgDwarfSourceNotes] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgDwarfStripBlockInfo] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgDwarfUnwindings] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgExposeInternalSymbols] :: NCGConfig -> !Bool

+ GHC.CmmToAsm.Config: [ncgThisModule] :: NCGConfig -> !Module

+ GHC.CmmToAsm.Config: ncgSpillPreallocSize :: NCGConfig -> Int

+ GHC.CmmToAsm.Dwarf.Constants: dW_AT_linkage_name :: Word

+ GHC.CmmToAsm.Dwarf.Types: instance GHC.Utils.Outputable.OutputableP env GHC.Cmm.CLabel.CLabel => GHC.Utils.Outputable.OutputableP env GHC.CmmToAsm.Dwarf.Types.DwarfFrameBlock

+ GHC.CmmToAsm.Format: isIntFormat :: Format -> Bool

+ GHC.CmmToAsm.Instr: instance GHC.Show.Show GHC.CmmToAsm.Instr.RegUsage

+ GHC.CmmToAsm.Instr: mkComment :: Instruction instr => SDoc -> [instr]

+ GHC.CmmToAsm.Instr: pprInstr :: Instruction instr => Platform -> instr -> SDoc

+ GHC.CmmToAsm.Monad: getCfgWeights :: NatM Weights

+ GHC.CmmToAsm.Monad: instance GHC.Unit.Module.HasModule GHC.CmmToAsm.Monad.NatM

+ GHC.CmmToAsm.PPC: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.PPC.Instr.Instr

+ GHC.CmmToAsm.PPC: ncgPPC :: NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest

+ GHC.CmmToAsm.PPC.Instr: isJumpishInstr :: Instr -> Bool

+ GHC.CmmToAsm.PPC.Instr: isMetaInstr :: Instr -> Bool

+ GHC.CmmToAsm.PPC.Instr: jumpDestsOfInstr :: Instr -> [BlockId]

+ GHC.CmmToAsm.PPC.Instr: mkJumpInstr :: BlockId -> [Instr]

+ GHC.CmmToAsm.PPC.Instr: mkLoadInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.PPC.Instr: mkRegRegMoveInstr :: Reg -> Reg -> Instr

+ GHC.CmmToAsm.PPC.Instr: mkSpillInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.PPC.Instr: mkStackAllocInstr :: Platform -> Int -> [Instr]

+ GHC.CmmToAsm.PPC.Instr: mkStackDeallocInstr :: Platform -> Int -> [Instr]

+ GHC.CmmToAsm.PPC.Instr: patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr

+ GHC.CmmToAsm.PPC.Instr: patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr

+ GHC.CmmToAsm.PPC.Instr: regUsageOfInstr :: Platform -> Instr -> RegUsage

+ GHC.CmmToAsm.PPC.Instr: takeDeltaInstr :: Instr -> Maybe Int

+ GHC.CmmToAsm.PPC.Instr: takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)

+ GHC.CmmToAsm.PPC.Ppr: pprInstr :: Platform -> Instr -> SDoc

+ GHC.CmmToAsm.Reg.Graph.Stats: instance (GHC.Utils.Outputable.OutputableP GHC.Platform.Platform statics, GHC.Utils.Outputable.OutputableP GHC.Platform.Platform instr) => GHC.Utils.Outputable.Outputable (GHC.CmmToAsm.Reg.Graph.Stats.RegAllocStats statics instr)

+ GHC.CmmToAsm.Reg.Graph.Stats: instance GHC.Base.Functor (GHC.CmmToAsm.Reg.Graph.Stats.RegAllocStats statics)

+ GHC.CmmToAsm.Reg.Linear.AArch64: FreeRegs :: !Word32 -> !Word32 -> FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: data FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: getFreeRegs :: RegClass -> FreeRegs -> [RealReg]

+ GHC.CmmToAsm.Reg.Linear.AArch64: initFreeRegs :: Platform -> FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: instance GHC.Show.Show GHC.CmmToAsm.Reg.Linear.AArch64.FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: instance GHC.Utils.Outputable.Outputable GHC.CmmToAsm.Reg.Linear.AArch64.FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: noFreeRegs :: FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs

+ GHC.CmmToAsm.Reg.Linear.AArch64: showBits :: Word32 -> String

+ GHC.CmmToAsm.Reg.Linear.FreeRegs: instance GHC.CmmToAsm.Reg.Linear.FreeRegs.FR GHC.CmmToAsm.Reg.Linear.AArch64.FreeRegs

+ GHC.CmmToAsm.Reg.Liveness: instance GHC.Base.Functor GHC.CmmToAsm.Reg.Liveness.InstrSR

+ GHC.CmmToAsm.Reg.Liveness: instance GHC.Base.Functor GHC.CmmToAsm.Reg.Liveness.LiveInstr

+ GHC.CmmToAsm.Reg.Liveness: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.CmmToAsm.Reg.Liveness.LiveInfo

+ GHC.CmmToAsm.Reg.Liveness: instance GHC.Utils.Outputable.OutputableP env instr => GHC.Utils.Outputable.OutputableP env (GHC.CmmToAsm.Reg.Liveness.LiveInstr instr)

+ GHC.CmmToAsm.Reg.Liveness: mapLiveCmmDecl :: (instr -> b) -> LiveCmmDecl statics instr -> LiveCmmDecl statics b

+ GHC.CmmToAsm.Reg.Liveness: pprLiveCmmDecl :: (OutputableP Platform statics, Instruction instr) => Platform -> LiveCmmDecl statics instr -> SDoc

+ GHC.CmmToAsm.SPARC: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.SPARC.Instr.Instr

+ GHC.CmmToAsm.SPARC: ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics Instr JumpDest

+ GHC.CmmToAsm.SPARC.Instr: isJumpishInstr :: Instr -> Bool

+ GHC.CmmToAsm.SPARC.Instr: isMetaInstr :: Instr -> Bool

+ GHC.CmmToAsm.SPARC.Instr: jumpDestsOfInstr :: Instr -> [BlockId]

+ GHC.CmmToAsm.SPARC.Instr: mkJumpInstr :: BlockId -> [Instr]

+ GHC.CmmToAsm.SPARC.Instr: mkLoadInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.SPARC.Instr: mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr

+ GHC.CmmToAsm.SPARC.Instr: mkSpillInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.SPARC.Instr: patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr

+ GHC.CmmToAsm.SPARC.Instr: patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr

+ GHC.CmmToAsm.SPARC.Instr: regUsageOfInstr :: Platform -> Instr -> RegUsage

+ GHC.CmmToAsm.SPARC.Instr: takeDeltaInstr :: Instr -> Maybe Int

+ GHC.CmmToAsm.SPARC.Instr: takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)

+ GHC.CmmToAsm.SPARC.Ppr: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.CmmToAsm.SPARC.Instr.Instr

+ GHC.CmmToAsm.Types: BasicBlock :: BlockId -> [i] -> GenBasicBlock i

+ GHC.CmmToAsm.Types: ListGraph :: [GenBasicBlock i] -> ListGraph i

+ GHC.CmmToAsm.Types: blockId :: GenBasicBlock i -> BlockId

+ GHC.CmmToAsm.Types: data GenBasicBlock i

+ GHC.CmmToAsm.Types: newtype ListGraph i

+ GHC.CmmToAsm.Types: type NatBasicBlock instr = GenBasicBlock instr

+ GHC.CmmToAsm.Types: type NatCmm instr = GenCmmGroup RawCmmStatics (LabelMap RawCmmStatics) (ListGraph instr)

+ GHC.CmmToAsm.Types: type NatCmmDecl statics instr = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)

+ GHC.CmmToAsm.Types: type RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph

+ GHC.CmmToAsm.Types: type RawCmmStatics = GenCmmStatics 'True

+ GHC.CmmToAsm.Utils: entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]

+ GHC.CmmToAsm.Utils: topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i

+ GHC.CmmToAsm.X86: instance GHC.CmmToAsm.Instr.Instruction GHC.CmmToAsm.X86.Instr.Instr

+ GHC.CmmToAsm.X86: ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest

+ GHC.CmmToAsm.X86: ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) Instr JumpDest

+ GHC.CmmToAsm.X86.Instr: isJumpishInstr :: Instr -> Bool

+ GHC.CmmToAsm.X86.Instr: isMetaInstr :: Instr -> Bool

+ GHC.CmmToAsm.X86.Instr: jumpDestsOfInstr :: Instr -> [BlockId]

+ GHC.CmmToAsm.X86.Instr: mkJumpInstr :: BlockId -> [Instr]

+ GHC.CmmToAsm.X86.Instr: mkLoadInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.X86.Instr: mkRegRegMoveInstr :: Platform -> Reg -> Reg -> Instr

+ GHC.CmmToAsm.X86.Instr: mkSpillInstr :: NCGConfig -> Reg -> Int -> Int -> [Instr]

+ GHC.CmmToAsm.X86.Instr: mkStackAllocInstr :: Platform -> Int -> [Instr]

+ GHC.CmmToAsm.X86.Instr: mkStackDeallocInstr :: Platform -> Int -> [Instr]

+ GHC.CmmToAsm.X86.Instr: patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr

+ GHC.CmmToAsm.X86.Instr: patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr

+ GHC.CmmToAsm.X86.Instr: regUsageOfInstr :: Platform -> Instr -> RegUsage

+ GHC.CmmToAsm.X86.Instr: takeDeltaInstr :: Instr -> Maybe Int

+ GHC.CmmToAsm.X86.Instr: takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)

+ GHC.CmmToC: cmmToC :: Platform -> RawCmmGroup -> SDoc

+ GHC.CmmToLlvm.Base: instance GHC.Utils.Logger.HasLogger GHC.CmmToLlvm.Base.LlvmM

+ GHC.CmmToLlvm.Base: liftIO :: IO a -> LlvmM a

+ GHC.Core: Alt :: AltCon -> [b] -> Expr b -> Alt b

+ GHC.Core: AnnAlt :: AltCon -> [bndr] -> AnnExpr bndr annot -> AnnAlt bndr annot

+ GHC.Core: [roBignumRules] :: RuleOpts -> !Bool

+ GHC.Core: data Alt b

+ GHC.Core: data AnnAlt bndr annot

+ GHC.Core: instance Data.Data.Data b => Data.Data.Data (GHC.Core.Alt b)

+ GHC.Core: mkWord8Lit :: Integer -> Expr b

+ GHC.Core.Coercion: anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool

+ GHC.Core.Coercion: coercionHolesOfCo :: Coercion -> UniqSet CoercionHole

+ GHC.Core.Coercion: coercionHolesOfType :: Type -> UniqSet CoercionHole

+ GHC.Core.Coercion: hasCoercionHoleCo :: Coercion -> Bool

+ GHC.Core.Coercion: hasCoercionHoleTy :: Type -> Bool

+ GHC.Core.Coercion: instance GHC.Utils.Outputable.Outputable ev => GHC.Utils.Outputable.Outputable (GHC.Core.Coercion.NormaliseStepResult ev)

+ GHC.Core.Coercion: isReflMCo :: MCoercion -> Bool

+ GHC.Core.Coercion: mkCastTyMCo :: Type -> MCoercion -> Type

+ GHC.Core.Coercion: mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion

+ GHC.Core.Coercion: mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion

+ GHC.Core.Coercion: mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion

+ GHC.Core.Coercion: mkNthCoFunCo :: Int -> CoercionN -> Coercion -> Coercion -> Coercion

+ GHC.Core.Coercion: mkSymMCo :: MCoercion -> MCoercion

+ GHC.Core.Coercion: mkTransMCoL :: MCoercion -> Coercion -> MCoercion

+ GHC.Core.Coercion: type HoleSet = UniqSet CoercionHole

+ GHC.Core.Coercion: type MCoercionN = MCoercion

+ GHC.Core.Coercion.Opt: OptCoercionOpts :: Bool -> OptCoercionOpts

+ GHC.Core.Coercion.Opt: [optCoercionEnabled] :: OptCoercionOpts -> Bool

+ GHC.Core.Coercion.Opt: newtype OptCoercionOpts

+ GHC.Core.ConLike: conLikeHasBuilder :: ConLike -> Bool

+ GHC.Core.ConLike: isVanillaConLike :: ConLike -> Bool

+ GHC.Core.DataCon: [flHasDuplicateRecordFields] :: FieldLabel -> DuplicateRecordFields

+ GHC.Core.DataCon: [flHasFieldSelector] :: FieldLabel -> FieldSelectors

+ GHC.Core.DataCon: data FieldLabel

+ GHC.Core.DataCon: isBoxedTupleDataCon :: DataCon -> Bool

+ GHC.Core.DataCon: isNewDataCon :: DataCon -> Bool

+ GHC.Core.DataCon: isUnboxedSumDataCon :: DataCon -> Bool

+ GHC.Core.DataCon: isUnboxedTupleDataCon :: DataCon -> Bool

+ GHC.Core.FVs: bndrRuleAndUnfoldingIds :: Id -> IdSet

+ GHC.Core.FVs: exprsFreeIds :: [CoreExpr] -> IdSet

+ GHC.Core.FVs: rulesRhsFreeIds :: [CoreRule] -> VarSet

+ GHC.Core.Lint: displayLintResults :: Logger -> DynFlags -> Bool -> SDoc -> SDoc -> WarnsAndErrs -> IO ()

+ GHC.Core.Lint: interactiveInScope :: InteractiveContext -> [Var]

+ GHC.Core.Make: mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr

+ GHC.Core.Map.Expr: (>.>) :: (a -> b) -> (b -> c) -> a -> c

+ GHC.Core.Map.Expr: (|>) :: a -> (a -> b) -> b

+ GHC.Core.Map.Expr: (|>>) :: TrieMap m2 => (XT (m2 a) -> m1 (m2 a) -> m1 (m2 a)) -> (m2 a -> m2 a) -> m1 (m2 a) -> m1 (m2 a)

+ GHC.Core.Map.Expr: alterTM :: forall b. TrieMap m => Key m -> XT b -> m b -> m b

+ GHC.Core.Map.Expr: class TrieMap m where {

+ GHC.Core.Map.Expr: data CoreMap a

+ GHC.Core.Map.Expr: deleteTM :: TrieMap m => Key m -> m a -> m a

+ GHC.Core.Map.Expr: emptyCoreMap :: CoreMap a

+ GHC.Core.Map.Expr: emptyTM :: TrieMap m => m a

+ GHC.Core.Map.Expr: extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a

+ GHC.Core.Map.Expr: filterTM :: TrieMap m => (a -> Bool) -> m a -> m a

+ GHC.Core.Map.Expr: foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b

+ GHC.Core.Map.Expr: foldTM :: TrieMap m => (a -> b -> b) -> m a -> b -> b

+ GHC.Core.Map.Expr: infixr 1 |>>

+ GHC.Core.Map.Expr: insertTM :: TrieMap m => Key m -> a -> m a -> m a

+ GHC.Core.Map.Expr: instance GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn GHC.Core.CoreAlt)

+ GHC.Core.Map.Expr: instance GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn GHC.Core.CoreExpr)

+ GHC.Core.Map.Expr: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Expr.AltMap

+ GHC.Core.Map.Expr: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Expr.CoreMap

+ GHC.Core.Map.Expr: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Expr.CoreMapX

+ GHC.Core.Map.Expr: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Core.Map.Expr.CoreMap a)

+ GHC.Core.Map.Expr: lkDFreeVar :: Var -> DVarEnv a -> Maybe a

+ GHC.Core.Map.Expr: lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a

+ GHC.Core.Map.Expr: lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a

+ GHC.Core.Map.Expr: lookupTM :: forall b. TrieMap m => Key m -> m b -> Maybe b

+ GHC.Core.Map.Expr: mapTM :: TrieMap m => (a -> b) -> m a -> m b

+ GHC.Core.Map.Expr: type Key m :: Type;

+ GHC.Core.Map.Expr: xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a

+ GHC.Core.Map.Expr: xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a

+ GHC.Core.Map.Expr: }

+ GHC.Core.Map.Type: D :: CmEnv -> a -> DeBruijn a

+ GHC.Core.Map.Type: alterTM :: forall b. TrieMap m => Key m -> XT b -> m b -> m b

+ GHC.Core.Map.Type: class TrieMap m where {

+ GHC.Core.Map.Type: data BndrMap a

+ GHC.Core.Map.Type: data CmEnv

+ GHC.Core.Map.Type: data DeBruijn a

+ GHC.Core.Map.Type: data LooseTypeMap a

+ GHC.Core.Map.Type: data TypeMap a

+ GHC.Core.Map.Type: data VarMap a

+ GHC.Core.Map.Type: deBruijnize :: a -> DeBruijn a

+ GHC.Core.Map.Type: emptyCME :: CmEnv

+ GHC.Core.Map.Type: emptyTM :: TrieMap m => m a

+ GHC.Core.Map.Type: emptyTypeMap :: TypeMap a

+ GHC.Core.Map.Type: extendCME :: CmEnv -> Var -> CmEnv

+ GHC.Core.Map.Type: extendCMEs :: CmEnv -> [Var] -> CmEnv

+ GHC.Core.Map.Type: extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a

+ GHC.Core.Map.Type: extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a

+ GHC.Core.Map.Type: filterTM :: TrieMap m => (a -> Bool) -> m a -> m a

+ GHC.Core.Map.Type: foldTM :: TrieMap m => (a -> b -> b) -> m a -> b -> b

+ GHC.Core.Map.Type: foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b

+ GHC.Core.Map.Type: instance GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn GHC.Core.TyCo.Rep.Coercion)

+ GHC.Core.Map.Type: instance GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn GHC.Core.TyCo.Rep.Type)

+ GHC.Core.Map.Type: instance GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn a) => GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn (GHC.Maybe.Maybe a))

+ GHC.Core.Map.Type: instance GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn a) => GHC.Classes.Eq (GHC.Core.Map.Type.DeBruijn [a])

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.BndrMap

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.CoercionMap

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.CoercionMapX

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.LooseTypeMap

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.TyLitMap

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.TypeMap

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.TypeMapX

+ GHC.Core.Map.Type: instance GHC.Data.TrieMap.TrieMap GHC.Core.Map.Type.VarMap

+ GHC.Core.Map.Type: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Core.Map.Type.TypeMapG a)

+ GHC.Core.Map.Type: lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a

+ GHC.Core.Map.Type: lkDFreeVar :: Var -> DVarEnv a -> Maybe a

+ GHC.Core.Map.Type: lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a

+ GHC.Core.Map.Type: lkVar :: CmEnv -> Var -> VarMap a -> Maybe a

+ GHC.Core.Map.Type: lookupCME :: CmEnv -> Var -> Maybe BoundVar

+ GHC.Core.Map.Type: lookupTM :: forall b. TrieMap m => Key m -> m b -> Maybe b

+ GHC.Core.Map.Type: lookupTypeMap :: TypeMap a -> Type -> Maybe a

+ GHC.Core.Map.Type: lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a

+ GHC.Core.Map.Type: mapTM :: TrieMap m => (a -> b) -> m a -> m b

+ GHC.Core.Map.Type: mkDeBruijnContext :: [Var] -> CmEnv

+ GHC.Core.Map.Type: type CoercionMapG = GenMap CoercionMapX

+ GHC.Core.Map.Type: type Key m :: Type;

+ GHC.Core.Map.Type: type TypeMapG = GenMap TypeMapX

+ GHC.Core.Map.Type: type XT a = Maybe a -> Maybe a

+ GHC.Core.Map.Type: xtBndr :: forall a. CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a

+ GHC.Core.Map.Type: xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a

+ GHC.Core.Map.Type: xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a

+ GHC.Core.Map.Type: xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a

+ GHC.Core.Map.Type: }

+ GHC.Core.Opt.Arity: AT :: ![OneShotInfo] -> !Divergence -> ArityType

+ GHC.Core.Opt.Arity: collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)

+ GHC.Core.Opt.Arity: mkBotArityType :: [OneShotInfo] -> ArityType

+ GHC.Core.Opt.Arity: mkTopArityType :: [OneShotInfo] -> ArityType

+ GHC.Core.Opt.Arity: pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)

+ GHC.Core.Opt.Arity: pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)

+ GHC.Core.Opt.Arity: pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion -> Maybe (DataCon, [Type], [CoreExpr])

+ GHC.Core.Opt.Arity: pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)

+ GHC.Core.Opt.Arity: pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)

+ GHC.Core.Opt.Arity: pushCoercionIntoLambda :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)

+ GHC.Core.Opt.CallerCC: addCallerCostCentres :: ModGuts -> CoreM ModGuts

+ GHC.Core.Opt.CallerCC: data CallerCcFilter

+ GHC.Core.Opt.CallerCC: instance GHC.Utils.Binary.Binary GHC.Core.Opt.CallerCC.CallerCcFilter

+ GHC.Core.Opt.CallerCC: instance GHC.Utils.Binary.Binary GHC.Core.Opt.CallerCC.NamePattern

+ GHC.Core.Opt.CallerCC: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.CallerCC.CallerCcFilter

+ GHC.Core.Opt.CallerCC: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.CallerCC.NamePattern

+ GHC.Core.Opt.CallerCC: parseCallerCcFilter :: String -> Either String CallerCcFilter

+ GHC.Core.Opt.CprAnal: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.CprAnal.SigEnv

+ GHC.Core.Opt.DmdAnal: DmdAnalOpts :: Bool -> DmdAnalOpts

+ GHC.Core.Opt.DmdAnal: [dmd_strict_dicts] :: DmdAnalOpts -> Bool

+ GHC.Core.Opt.DmdAnal: newtype DmdAnalOpts

+ GHC.Core.Opt.Monad: CoreAddCallerCcs :: CoreToDo

+ GHC.Core.Opt.Monad: [sm_logger] :: SimplMode -> !Logger

+ GHC.Core.Opt.Monad: [sm_pre_inline] :: SimplMode -> !Bool

+ GHC.Core.Opt.Monad: [sm_uf_opts] :: SimplMode -> !UnfoldingOpts

+ GHC.Core.Opt.Monad: instance GHC.Utils.Logger.HasLogger GHC.Core.Opt.Monad.CoreM

+ GHC.Core.Opt.Simplify.Env: [seCaseDepth] :: SimplEnv -> !Int

+ GHC.Core.Opt.Simplify.Env: bumpCaseDepth :: SimplEnv -> SimplEnv

+ GHC.Core.Opt.Simplify.Env: seLogger :: SimplEnv -> Logger

+ GHC.Core.Opt.Simplify.Env: seUnfoldingOpts :: SimplEnv -> UnfoldingOpts

+ GHC.Core.Opt.Simplify.Monad: getOptCoercionOpts :: SimplM OptCoercionOpts

+ GHC.Core.Opt.Simplify.Monad: instance GHC.Utils.Logger.HasLogger GHC.Core.Opt.Simplify.Monad.SimplM

+ GHC.Core.Opt.WorkWrap.Utils: DataConPatContext :: !DataCon -> ![Type] -> !Coercion -> DataConPatContext

+ GHC.Core.Opt.WorkWrap.Utils: StopUnboxing :: UnboxingDecision s

+ GHC.Core.Opt.WorkWrap.Utils: Unbox :: !DataConPatContext -> [s] -> UnboxingDecision s

+ GHC.Core.Opt.WorkWrap.Utils: [dcpc_co] :: DataConPatContext -> !Coercion

+ GHC.Core.Opt.WorkWrap.Utils: [dcpc_dc] :: DataConPatContext -> !DataCon

+ GHC.Core.Opt.WorkWrap.Utils: [dcpc_tc_args] :: DataConPatContext -> ![Type]

+ GHC.Core.Opt.WorkWrap.Utils: data DataConPatContext

+ GHC.Core.Opt.WorkWrap.Utils: data UnboxingDecision s

+ GHC.Core.Opt.WorkWrap.Utils: splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext

+ GHC.Core.PatSyn: isVanillaPatSyn :: PatSyn -> Bool

+ GHC.Core.PatSyn: patSynResultType :: PatSyn -> Type

+ GHC.Core.PatSyn: type PatSynBuilder = Maybe (Name, Type, Bool)

+ GHC.Core.PatSyn: type PatSynMatcher = (Name, Type, Bool)

+ GHC.Core.Ppr: instance GHC.Utils.Outputable.Outputable (GHC.Types.Tickish.XTickishId pass) => GHC.Utils.Outputable.Outputable (GHC.Types.Tickish.GenTickish pass)

+ GHC.Core.Ppr: instance GHC.Utils.Outputable.OutputableBndr b => GHC.Utils.Outputable.Outputable (GHC.Core.Alt b)

+ GHC.Core.SimpleOpt: SimpleOpts :: !UnfoldingOpts -> !OptCoercionOpts -> SimpleOpts

+ GHC.Core.SimpleOpt: [so_co_opts] :: SimpleOpts -> !OptCoercionOpts

+ GHC.Core.SimpleOpt: [so_uf_opts] :: SimpleOpts -> !UnfoldingOpts

+ GHC.Core.SimpleOpt: data SimpleOpts

+ GHC.Core.SimpleOpt: defaultSimpleOpts :: SimpleOpts

+ GHC.Core.Subst: substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo

+ GHC.Core.TyCo.FVs: anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool

+ GHC.Core.TyCo.FVs: anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool

+ GHC.Core.TyCo.FVs: anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool

+ GHC.Core.TyCo.Rep: CharTyLit :: Char -> TyLit

+ GHC.Core.TyCo.Rep: cmpTyLit :: TyLit -> TyLit -> Ordering

+ GHC.Core.TyCo.Rep: instance GHC.Types.Unique.Uniquable GHC.Core.TyCo.Rep.CoercionHole

+ GHC.Core.TyCo.Rep: mkTyConTy_ :: TyCon -> Type

+ GHC.Core.TyCo.Rep: nonDetCmpTyLit :: TyLit -> TyLit -> Ordering

+ GHC.Core.TyCo.Subst: elemTCvSubst :: Var -> TCvSubst -> Bool

+ GHC.Core.TyCo.Subst: substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder)

+ GHC.Core.TyCon: LiftedInfo :: RuntimeRepInfo

+ GHC.Core.TyCon: UnliftedInfo :: RuntimeRepInfo

+ GHC.Core.TyCon: instance GHC.Classes.Eq GHC.Core.TyCon.PrimRep

+ GHC.Core.TyCon: isForgetfulSynTyCon :: TyCon -> Bool

+ GHC.Core.TyCon: tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon]

+ GHC.Core.TyCon: tyConNullaryTy :: TyCon -> Type

+ GHC.Core.TyCon.Env: adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a

+ GHC.Core.TyCon.Env: alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a

+ GHC.Core.TyCon.Env: alterTyConEnv :: (Maybe a -> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a

+ GHC.Core.TyCon.Env: anyTyConEnv :: (elt -> Bool) -> TyConEnv elt -> Bool

+ GHC.Core.TyCon.Env: delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a

+ GHC.Core.TyCon.Env: delFromTyConEnv :: TyConEnv a -> TyCon -> TyConEnv a

+ GHC.Core.TyCon.Env: delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a

+ GHC.Core.TyCon.Env: disjointTyConEnv :: TyConEnv a -> TyConEnv a -> Bool

+ GHC.Core.TyCon.Env: elemTyConEnv :: TyCon -> TyConEnv a -> Bool

+ GHC.Core.TyCon.Env: emptyDTyConEnv :: DTyConEnv a

+ GHC.Core.TyCon.Env: emptyTyConEnv :: TyConEnv a

+ GHC.Core.TyCon.Env: extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a

+ GHC.Core.TyCon.Env: extendTyConEnv :: TyConEnv a -> TyCon -> a -> TyConEnv a

+ GHC.Core.TyCon.Env: extendTyConEnvList :: TyConEnv a -> [(TyCon, a)] -> TyConEnv a

+ GHC.Core.TyCon.Env: extendTyConEnvList_C :: (a -> a -> a) -> TyConEnv a -> [(TyCon, a)] -> TyConEnv a

+ GHC.Core.TyCon.Env: extendTyConEnv_Acc :: (a -> b -> b) -> (a -> b) -> TyConEnv b -> TyCon -> a -> TyConEnv b

+ GHC.Core.TyCon.Env: extendTyConEnv_C :: (a -> a -> a) -> TyConEnv a -> TyCon -> a -> TyConEnv a

+ GHC.Core.TyCon.Env: filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a

+ GHC.Core.TyCon.Env: filterTyConEnv :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt

+ GHC.Core.TyCon.Env: foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a

+ GHC.Core.TyCon.Env: isEmptyDTyConEnv :: DTyConEnv a -> Bool

+ GHC.Core.TyCon.Env: isEmptyTyConEnv :: TyConEnv a -> Bool

+ GHC.Core.TyCon.Env: lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a

+ GHC.Core.TyCon.Env: lookupTyConEnv :: TyConEnv a -> TyCon -> Maybe a

+ GHC.Core.TyCon.Env: lookupTyConEnv_NF :: TyConEnv a -> TyCon -> a

+ GHC.Core.TyCon.Env: mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b

+ GHC.Core.TyCon.Env: mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b

+ GHC.Core.TyCon.Env: mapTyConEnv :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2

+ GHC.Core.TyCon.Env: mkTyConEnv :: [(TyCon, a)] -> TyConEnv a

+ GHC.Core.TyCon.Env: mkTyConEnvWith :: (a -> TyCon) -> [a] -> TyConEnv a

+ GHC.Core.TyCon.Env: nameEnvElts :: TyConEnv a -> [a]

+ GHC.Core.TyCon.Env: plusTyConEnv :: TyConEnv a -> TyConEnv a -> TyConEnv a

+ GHC.Core.TyCon.Env: plusTyConEnv_C :: (a -> a -> a) -> TyConEnv a -> TyConEnv a -> TyConEnv a

+ GHC.Core.TyCon.Env: plusTyConEnv_CD :: (a -> a -> a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a

+ GHC.Core.TyCon.Env: plusTyConEnv_CD2 :: (Maybe a -> Maybe a -> a) -> TyConEnv a -> TyConEnv a -> TyConEnv a

+ GHC.Core.TyCon.Env: type DTyConEnv a = UniqDFM TyCon a

+ GHC.Core.TyCon.Env: type TyConEnv a = UniqFM TyCon a

+ GHC.Core.TyCon.Env: unitTyConEnv :: TyCon -> a -> TyConEnv a

+ GHC.Core.TyCon.RecWalk: checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker

+ GHC.Core.TyCon.RecWalk: data RecTcChecker

+ GHC.Core.TyCon.RecWalk: defaultRecTcMaxBound :: Int

+ GHC.Core.TyCon.RecWalk: initRecTc :: RecTcChecker

+ GHC.Core.TyCon.RecWalk: setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker

+ GHC.Core.TyCon.Set: delFromTyConSet :: TyConSet -> TyCon -> TyConSet

+ GHC.Core.TyCon.Set: delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet

+ GHC.Core.TyCon.Set: disjointTyConSet :: TyConSet -> TyConSet -> Bool

+ GHC.Core.TyCon.Set: elemTyConSet :: TyCon -> TyConSet -> Bool

+ GHC.Core.TyCon.Set: emptyTyConSet :: TyConSet

+ GHC.Core.TyCon.Set: extendTyConSet :: TyConSet -> TyCon -> TyConSet

+ GHC.Core.TyCon.Set: extendTyConSetList :: TyConSet -> [TyCon] -> TyConSet

+ GHC.Core.TyCon.Set: filterTyConSet :: (TyCon -> Bool) -> TyConSet -> TyConSet

+ GHC.Core.TyCon.Set: intersectTyConSet :: TyConSet -> TyConSet -> TyConSet

+ GHC.Core.TyCon.Set: intersectsTyConSet :: TyConSet -> TyConSet -> Bool

+ GHC.Core.TyCon.Set: isEmptyTyConSet :: TyConSet -> Bool

+ GHC.Core.TyCon.Set: minusTyConSet :: TyConSet -> TyConSet -> TyConSet

+ GHC.Core.TyCon.Set: mkTyConSet :: [TyCon] -> TyConSet

+ GHC.Core.TyCon.Set: nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool

+ GHC.Core.TyCon.Set: nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool

+ GHC.Core.TyCon.Set: type TyConSet = UniqSet TyCon

+ GHC.Core.TyCon.Set: unionTyConSet :: TyConSet -> TyConSet -> TyConSet

+ GHC.Core.TyCon.Set: unionTyConSets :: [TyConSet] -> TyConSet

+ GHC.Core.TyCon.Set: unitTyConSet :: TyCon -> TyConSet

+ GHC.Core.Type: anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool

+ GHC.Core.Type: anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool

+ GHC.Core.Type: isBoxedRuntimeRep :: Type -> Bool

+ GHC.Core.Type: isBoxedType :: Type -> Bool

+ GHC.Core.Type: isBoxedTypeKind :: Kind -> Bool

+ GHC.Core.Type: isCharLitTy :: Type -> Maybe Char

+ GHC.Core.Type: isLevityTy :: Type -> Bool

+ GHC.Core.Type: isLevityVar :: TyVar -> Bool

+ GHC.Core.Type: isLiftedLevity :: Type -> Bool

+ GHC.Core.Type: isUnliftedLevity :: Type -> Bool

+ GHC.Core.Type: mkCharLitTy :: Char -> Type

+ GHC.Core.Type: mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type

+ GHC.Core.Type: pickyIsLiftedTypeKind :: Kind -> Bool

+ GHC.Core.Type: splitForAllCoVar_maybe :: Type -> Maybe (TyCoVar, Type)

+ GHC.Core.Type: splitForAllInvisTVBinders :: Type -> ([InvisTVBinder], Type)

+ GHC.Core.Type: splitForAllReqTVBinders :: Type -> ([ReqTVBinder], Type)

+ GHC.Core.Type: splitForAllTyCoVar :: Type -> (TyCoVar, Type)

+ GHC.Core.Type: splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type)

+ GHC.Core.Type: splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)

+ GHC.Core.Type: splitForAllTyCoVars :: Type -> ([TyCoVar], Type)

+ GHC.Core.Type: splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, Type)

+ GHC.Core.Type: splitInvisPiTys :: Type -> ([TyCoBinder], Type)

+ GHC.Core.Type: splitInvisPiTysN :: Int -> Type -> ([TyCoBinder], Type)

+ GHC.Core.Type: substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder)

+ GHC.Core.Type: tYPE :: Type -> Type

+ GHC.Core.Type: tcIsBoxedTypeKind :: Kind -> Bool

+ GHC.Core.Type: unliftedTypeKind :: Kind

+ GHC.Core.Unfold: UnfoldingOpts :: !Int -> !Int -> !Int -> !Int -> !Bool -> !Int -> !Int -> UnfoldingOpts

+ GHC.Core.Unfold: [unfoldingCaseScaling] :: UnfoldingOpts -> !Int

+ GHC.Core.Unfold: [unfoldingCaseThreshold] :: UnfoldingOpts -> !Int

+ GHC.Core.Unfold: [unfoldingCreationThreshold] :: UnfoldingOpts -> !Int

+ GHC.Core.Unfold: [unfoldingDictDiscount] :: UnfoldingOpts -> !Int

+ GHC.Core.Unfold: [unfoldingFunAppDiscount] :: UnfoldingOpts -> !Int

+ GHC.Core.Unfold: [unfoldingUseThreshold] :: UnfoldingOpts -> !Int

+ GHC.Core.Unfold: [unfoldingVeryAggressive] :: UnfoldingOpts -> !Bool

+ GHC.Core.Unfold: calcUnfoldingGuidance :: UnfoldingOpts -> Bool -> CoreExpr -> UnfoldingGuidance

+ GHC.Core.Unfold: data UnfoldingOpts

+ GHC.Core.Unfold: defaultUnfoldingOpts :: UnfoldingOpts

+ GHC.Core.Unfold: updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold: updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold: updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold: updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold: updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold: updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold: updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts

+ GHC.Core.Unfold.Make: mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkCompulsoryUnfolding' :: CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr -> UnfoldingGuidance -> Unfolding

+ GHC.Core.Unfold.Make: mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding

+ GHC.Core.Unfold.Make: mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkUnfolding :: UnfoldingOpts -> UnfoldingSource -> Bool -> Bool -> CoreExpr -> Unfolding

+ GHC.Core.Unfold.Make: mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding

+ GHC.Core.Unfold.Make: mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding

+ GHC.Core.Unfold.Make: noUnfolding :: Unfolding

+ GHC.Core.Unfold.Make: specUnfolding :: SimpleOpts -> [Var] -> (CoreExpr -> CoreExpr) -> [CoreArg] -> Unfolding -> Unfolding

+ GHC.Core.Unify: Apart :: BindFlag

+ GHC.Core.Unify: KnownTc :: Name -> RoughMatchTc

+ GHC.Core.Unify: MARInfinite :: MaybeApartReason

+ GHC.Core.Unify: MARTypeFamily :: MaybeApartReason

+ GHC.Core.Unify: OtherTc :: RoughMatchTc

+ GHC.Core.Unify: alwaysBindFun :: BindFun

+ GHC.Core.Unify: data MaybeApartReason

+ GHC.Core.Unify: data RoughMatchTc

+ GHC.Core.Unify: flattenTys :: InScopeSet -> [Type] -> [Type]

+ GHC.Core.Unify: flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))

+ GHC.Core.Unify: instance Data.Data.Data GHC.Core.Unify.RoughMatchTc

+ GHC.Core.Unify: instance GHC.Base.Semigroup GHC.Core.Unify.MaybeApartReason

+ GHC.Core.Unify: instance GHC.Utils.Outputable.Outputable GHC.Core.Unify.MaybeApartReason

+ GHC.Core.Unify: isRoughOtherTc :: RoughMatchTc -> Bool

+ GHC.Core.Unify: matchBindFun :: TyCoVarSet -> BindFun

+ GHC.Core.Unify: type BindFun = TyCoVar -> Type -> BindFlag

+ GHC.Core.Utils: zapLamBndrs :: FullArgCount -> [Var] -> [Var]

+ GHC.Data.Bag: instance GHC.Exts.IsList (GHC.Data.Bag.Bag a)

+ GHC.Data.Bag: nonEmptyToBag :: NonEmpty a -> Bag a

+ GHC.Data.EnumSet: difference :: EnumSet a -> EnumSet a -> EnumSet a

+ GHC.Data.FastMutInt: atomicFetchAddFastMut :: FastMutInt -> Int -> IO Int

+ GHC.Data.FastString: LexicalFastString :: FastString -> LexicalFastString

+ GHC.Data.FastString: NonDetFastString :: FastString -> NonDetFastString

+ GHC.Data.FastString: instance Data.Data.Data GHC.Data.FastString.LexicalFastString

+ GHC.Data.FastString: instance Data.Data.Data GHC.Data.FastString.NonDetFastString

+ GHC.Data.FastString: instance GHC.Classes.Eq GHC.Data.FastString.LexicalFastString

+ GHC.Data.FastString: instance GHC.Classes.Eq GHC.Data.FastString.NonDetFastString

+ GHC.Data.FastString: instance GHC.Classes.Ord GHC.Data.FastString.LexicalFastString

+ GHC.Data.FastString: instance GHC.Classes.Ord GHC.Data.FastString.NonDetFastString

+ GHC.Data.FastString: instance GHC.Show.Show GHC.Data.FastString.LexicalFastString

+ GHC.Data.FastString: instance GHC.Show.Show GHC.Data.FastString.NonDetFastString

+ GHC.Data.FastString: lexicalCompareFS :: FastString -> FastString -> Ordering

+ GHC.Data.FastString: newtype LexicalFastString

+ GHC.Data.FastString: newtype NonDetFastString

+ GHC.Data.FastString: unconsFS :: FastString -> Maybe (Char, FastString)

+ GHC.Data.FastString: uniqCompareFS :: FastString -> FastString -> Ordering

+ GHC.Data.Graph.UnVar: extendUnVarSet :: Var -> UnVarSet -> UnVarSet

+ GHC.Data.IOEnv: instance GHC.Driver.Hooks.ContainsHooks env => GHC.Driver.Hooks.HasHooks (GHC.Data.IOEnv.IOEnv env)

+ GHC.Data.IOEnv: instance GHC.Utils.Logger.ContainsLogger env => GHC.Utils.Logger.HasLogger (GHC.Data.IOEnv.IOEnv env)

+ GHC.Data.IOEnv: updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env ()

+ GHC.Data.Maybe: firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)

+ GHC.Data.OrdList: mapOL' :: (a -> b) -> OrdList a -> OrdList b

+ GHC.Data.OrdList: pattern ConsOL :: a -> OrdList a -> OrdList a

+ GHC.Data.OrdList: pattern NilOL :: OrdList a

+ GHC.Data.OrdList: pattern SnocOL :: OrdList a -> a -> OrdList a

+ GHC.Data.Stream: Done :: b -> StreamS m a b

+ GHC.Data.Stream: Effect :: m (StreamS m a b) -> StreamS m a b

+ GHC.Data.Stream: Yield :: a -> StreamS m a b -> StreamS m a b

+ GHC.Data.Stream: [runStreamInternal] :: Stream m a b -> forall r' r. (a -> m r') -> (b -> StreamS m r' r) -> StreamS m r' r

+ GHC.Data.Stream: data StreamS m a b

+ GHC.Data.Stream: instance Control.Monad.IO.Class.MonadIO m => Control.Monad.IO.Class.MonadIO (GHC.Data.Stream.Stream m b)

+ GHC.Data.Stream: instance GHC.Base.Applicative (GHC.Data.Stream.Stream m a)

+ GHC.Data.Stream: instance GHC.Base.Functor (GHC.Data.Stream.Stream f a)

+ GHC.Data.Stream: instance GHC.Base.Monad (GHC.Data.Stream.Stream m a)

+ GHC.Data.Stream: instance GHC.Base.Monad m => GHC.Base.Applicative (GHC.Data.Stream.StreamS m a)

+ GHC.Data.Stream: instance GHC.Base.Monad m => GHC.Base.Functor (GHC.Data.Stream.StreamS m a)

+ GHC.Data.Stream: instance GHC.Base.Monad m => GHC.Base.Monad (GHC.Data.Stream.StreamS m a)

+ GHC.Data.Stream: runStream :: Applicative m => Stream m r' r -> StreamS m r' r

+ GHC.Data.TrieMap: filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a

+ GHC.Data.TrieMap: filterTM :: TrieMap m => (a -> Bool) -> m a -> m a

+ GHC.Data.TrieMap: foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r

+ GHC.Data.TrieMap: instance (GHC.Classes.Eq (GHC.Data.TrieMap.Key m), GHC.Data.TrieMap.TrieMap m) => Data.Foldable.Foldable (GHC.Data.TrieMap.GenMap m)

+ GHC.Data.TrieMap: instance GHC.Data.TrieMap.TrieMap m => Data.Foldable.Foldable (GHC.Data.TrieMap.ListMap m)

+ GHC.Data.TrieMap: instance GHC.Data.TrieMap.TrieMap m => Data.Foldable.Foldable (GHC.Data.TrieMap.MaybeMap m)

+ GHC.Data.TrieMap: isEmptyTM :: TrieMap m => m a -> Bool

+ GHC.Data.TrieMap: type Key m :: Type;

+ GHC.Driver.Backend: NoBackend :: Backend

+ GHC.Driver.Backend: backendProducesObject :: Backend -> Bool

+ GHC.Driver.Backend: backendRetainsAllBindings :: Backend -> Bool

+ GHC.Driver.Backpack: instance GHC.Utils.Logger.HasLogger GHC.Driver.Backpack.BkpM

+ GHC.Driver.CmdLine: WordSuffix :: (Word -> EwM m ()) -> OptKind m

+ GHC.Driver.CodeOutput: ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub

+ GHC.Driver.Config: initOptCoercionOpts :: DynFlags -> OptCoercionOpts

+ GHC.Driver.Config: initParserOpts :: DynFlags -> ParserOpts

+ GHC.Driver.Config: initSimpleOpts :: DynFlags -> SimpleOpts

+ GHC.Driver.Env: Hsc :: (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a

+ GHC.Driver.Env: HscEnv :: DynFlags -> [Target] -> ModuleGraph -> InteractiveContext -> HomePackageTable -> {-# UNPACK #-} !IORef ExternalPackageState -> {-# UNPACK #-} !IORef NameCache -> {-# UNPACK #-} !IORef FinderCache -> Maybe (Module, IORef TypeEnv) -> Maybe Interp -> ![LoadedPlugin] -> ![StaticPlugin] -> !Maybe [UnitDatabase UnitId] -> UnitEnv -> !Logger -> !Hooks -> !TmpFs -> HscEnv

+ GHC.Driver.Env: [hsc_EPS] :: HscEnv -> {-# UNPACK #-} !IORef ExternalPackageState

+ GHC.Driver.Env: [hsc_FC] :: HscEnv -> {-# UNPACK #-} !IORef FinderCache

+ GHC.Driver.Env: [hsc_HPT] :: HscEnv -> HomePackageTable

+ GHC.Driver.Env: [hsc_IC] :: HscEnv -> InteractiveContext

+ GHC.Driver.Env: [hsc_NC] :: HscEnv -> {-# UNPACK #-} !IORef NameCache

+ GHC.Driver.Env: [hsc_dflags] :: HscEnv -> DynFlags

+ GHC.Driver.Env: [hsc_hooks] :: HscEnv -> !Hooks

+ GHC.Driver.Env: [hsc_interp] :: HscEnv -> Maybe Interp

+ GHC.Driver.Env: [hsc_logger] :: HscEnv -> !Logger

+ GHC.Driver.Env: [hsc_mod_graph] :: HscEnv -> ModuleGraph

+ GHC.Driver.Env: [hsc_plugins] :: HscEnv -> ![LoadedPlugin]

+ GHC.Driver.Env: [hsc_static_plugins] :: HscEnv -> ![StaticPlugin]

+ GHC.Driver.Env: [hsc_targets] :: HscEnv -> [Target]

+ GHC.Driver.Env: [hsc_tmpfs] :: HscEnv -> !TmpFs

+ GHC.Driver.Env: [hsc_type_env_var] :: HscEnv -> Maybe (Module, IORef TypeEnv)

+ GHC.Driver.Env: [hsc_unit_dbs] :: HscEnv -> !Maybe [UnitDatabase UnitId]

+ GHC.Driver.Env: [hsc_unit_env] :: HscEnv -> UnitEnv

+ GHC.Driver.Env: data HscEnv

+ GHC.Driver.Env: hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]

+ GHC.Driver.Env: hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]

+ GHC.Driver.Env: hptCompleteSigs :: HscEnv -> [CompleteMatch]

+ GHC.Driver.Env: hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])

+ GHC.Driver.Env: hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]

+ GHC.Driver.Env: hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]

+ GHC.Driver.Env: hscEPS :: HscEnv -> IO ExternalPackageState

+ GHC.Driver.Env: hsc_home_unit :: HscEnv -> HomeUnit

+ GHC.Driver.Env: hsc_units :: HscEnv -> UnitState

+ GHC.Driver.Env: lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface

+ GHC.Driver.Env: lookupType :: HscEnv -> Name -> IO (Maybe TyThing)

+ GHC.Driver.Env: mainModIs :: HscEnv -> Module

+ GHC.Driver.Env: mkInteractiveHscEnv :: HscEnv -> HscEnv

+ GHC.Driver.Env: newtype Hsc a

+ GHC.Driver.Env: prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv

+ GHC.Driver.Env: runHsc :: HscEnv -> Hsc a -> IO a

+ GHC.Driver.Env: runInteractiveHsc :: HscEnv -> Hsc a -> IO a

+ GHC.Driver.Env.Types: Hsc :: (HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a

+ GHC.Driver.Env.Types: HscEnv :: DynFlags -> [Target] -> ModuleGraph -> InteractiveContext -> HomePackageTable -> {-# UNPACK #-} !IORef ExternalPackageState -> {-# UNPACK #-} !IORef NameCache -> {-# UNPACK #-} !IORef FinderCache -> Maybe (Module, IORef TypeEnv) -> Maybe Interp -> ![LoadedPlugin] -> ![StaticPlugin] -> !Maybe [UnitDatabase UnitId] -> UnitEnv -> !Logger -> !Hooks -> !TmpFs -> HscEnv

+ GHC.Driver.Env.Types: [hsc_EPS] :: HscEnv -> {-# UNPACK #-} !IORef ExternalPackageState

+ GHC.Driver.Env.Types: [hsc_FC] :: HscEnv -> {-# UNPACK #-} !IORef FinderCache

+ GHC.Driver.Env.Types: [hsc_HPT] :: HscEnv -> HomePackageTable

+ GHC.Driver.Env.Types: [hsc_IC] :: HscEnv -> InteractiveContext

+ GHC.Driver.Env.Types: [hsc_NC] :: HscEnv -> {-# UNPACK #-} !IORef NameCache

+ GHC.Driver.Env.Types: [hsc_dflags] :: HscEnv -> DynFlags

+ GHC.Driver.Env.Types: [hsc_hooks] :: HscEnv -> !Hooks

+ GHC.Driver.Env.Types: [hsc_interp] :: HscEnv -> Maybe Interp

+ GHC.Driver.Env.Types: [hsc_logger] :: HscEnv -> !Logger

+ GHC.Driver.Env.Types: [hsc_mod_graph] :: HscEnv -> ModuleGraph

+ GHC.Driver.Env.Types: [hsc_plugins] :: HscEnv -> ![LoadedPlugin]

+ GHC.Driver.Env.Types: [hsc_static_plugins] :: HscEnv -> ![StaticPlugin]

+ GHC.Driver.Env.Types: [hsc_targets] :: HscEnv -> [Target]

+ GHC.Driver.Env.Types: [hsc_tmpfs] :: HscEnv -> !TmpFs

+ GHC.Driver.Env.Types: [hsc_type_env_var] :: HscEnv -> Maybe (Module, IORef TypeEnv)

+ GHC.Driver.Env.Types: [hsc_unit_dbs] :: HscEnv -> !Maybe [UnitDatabase UnitId]

+ GHC.Driver.Env.Types: [hsc_unit_env] :: HscEnv -> UnitEnv

+ GHC.Driver.Env.Types: data HscEnv

+ GHC.Driver.Env.Types: instance Control.Monad.IO.Class.MonadIO GHC.Driver.Env.Types.Hsc

+ GHC.Driver.Env.Types: instance GHC.Base.Applicative GHC.Driver.Env.Types.Hsc

+ GHC.Driver.Env.Types: instance GHC.Base.Functor GHC.Driver.Env.Types.Hsc

+ GHC.Driver.Env.Types: instance GHC.Base.Monad GHC.Driver.Env.Types.Hsc

+ GHC.Driver.Env.Types: instance GHC.Driver.Session.HasDynFlags GHC.Driver.Env.Types.Hsc

+ GHC.Driver.Env.Types: instance GHC.Utils.Logger.HasLogger GHC.Driver.Env.Types.Hsc

+ GHC.Driver.Env.Types: newtype Hsc a

+ GHC.Driver.Errors: handleFlagWarnings :: Logger -> DynFlags -> [Warn] -> IO ()

+ GHC.Driver.Errors: isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)

+ GHC.Driver.Errors: printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()

+ GHC.Driver.Errors: printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()

+ GHC.Driver.Errors: warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages)

+ GHC.Driver.Flags: GHC2021 :: Language

+ GHC.Driver.Flags: Opt_ByteCode :: GeneralFlag

+ GHC.Driver.Flags: Opt_D_dump_c_backend :: DumpFlag

+ GHC.Driver.Flags: Opt_D_dump_faststrings :: DumpFlag

+ GHC.Driver.Flags: Opt_D_dump_stg_from_core :: DumpFlag

+ GHC.Driver.Flags: Opt_DistinctConstructorTables :: GeneralFlag

+ GHC.Driver.Flags: Opt_ExposeInternalSymbols :: GeneralFlag

+ GHC.Driver.Flags: Opt_FamAppCache :: GeneralFlag

+ GHC.Driver.Flags: Opt_InfoTableMap :: GeneralFlag

+ GHC.Driver.Flags: Opt_InlineGenerics :: GeneralFlag

+ GHC.Driver.Flags: Opt_InlineGenericsAggressively :: GeneralFlag

+ GHC.Driver.Flags: Opt_WarnAmbiguousFields :: WarningFlag

+ GHC.Driver.Flags: Opt_WarnImplicitLift :: WarningFlag

+ GHC.Driver.Flags: Opt_WarnMissingKindSignatures :: WarningFlag

+ GHC.Driver.Flags: Opt_WarnOperatorWhitespace :: WarningFlag

+ GHC.Driver.Flags: Opt_WarnOperatorWhitespaceExtConflict :: WarningFlag

+ GHC.Driver.Flags: Opt_WarnRedundantBangPatterns :: WarningFlag

+ GHC.Driver.Flags: instance GHC.Classes.Ord GHC.Driver.Flags.WarningFlag

+ GHC.Driver.Hooks: class ContainsHooks a

+ GHC.Driver.Hooks: class HasHooks m

+ GHC.Driver.Hooks: extractHooks :: ContainsHooks a => a -> Hooks

+ GHC.Driver.Hooks: getHooks :: HasHooks m => m Hooks

+ GHC.Driver.Hooks: type family DsForeignsHook :: Type

+ GHC.Driver.Main: [hscs_mod_details] :: HscStatus -> !ModDetails

+ GHC.Driver.Make: ModNodeMap :: Map ModNodeKey a -> ModNodeMap a

+ GHC.Driver.Make: [unModNodeMap] :: ModNodeMap a -> Map ModNodeKey a

+ GHC.Driver.Make: emptyModNodeMap :: ModNodeMap a

+ GHC.Driver.Make: implicitRequirementsShallow :: HscEnv -> [(Maybe FastString, Located ModuleName)] -> IO ([ModuleName], [InstantiatedUnit])

+ GHC.Driver.Make: instance Data.Foldable.Foldable GHC.Driver.Make.ModNodeMap

+ GHC.Driver.Make: instance Data.Foldable.Foldable GHC.Driver.Make.NodeMap

+ GHC.Driver.Make: instance Data.Traversable.Traversable GHC.Driver.Make.ModNodeMap

+ GHC.Driver.Make: instance Data.Traversable.Traversable GHC.Driver.Make.NodeMap

+ GHC.Driver.Make: instance GHC.Base.Functor GHC.Driver.Make.ModNodeMap

+ GHC.Driver.Make: instance GHC.Base.Functor GHC.Driver.Make.NodeMap

+ GHC.Driver.Make: instance GHC.Classes.Eq GHC.Driver.Make.BuildModule

+ GHC.Driver.Make: instance GHC.Classes.Eq GHC.Driver.Make.NodeKey

+ GHC.Driver.Make: instance GHC.Classes.Ord GHC.Driver.Make.BuildModule

+ GHC.Driver.Make: instance GHC.Classes.Ord GHC.Driver.Make.NodeKey

+ GHC.Driver.Make: instantiationNodes :: UnitState -> [ModuleGraphNode]

+ GHC.Driver.Make: modNodeMapElems :: ModNodeMap a -> [a]

+ GHC.Driver.Make: modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a

+ GHC.Driver.Make: modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a

+ GHC.Driver.Make: newtype ModNodeMap a

+ GHC.Driver.Monad: instance Control.Monad.IO.Class.MonadIO m => GHC.Utils.Logger.HasLogger (GHC.Driver.Monad.GhcT m)

+ GHC.Driver.Monad: instance GHC.Utils.Logger.HasLogger GHC.Driver.Monad.Ghc

+ GHC.Driver.Monad: modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()

+ GHC.Driver.Monad: modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m ()

+ GHC.Driver.Monad: popLogHookM :: GhcMonad m => m ()

+ GHC.Driver.Monad: pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()

+ GHC.Driver.Monad: putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()

+ GHC.Driver.Monad: putMsgM :: GhcMonad m => SDoc -> m ()

+ GHC.Driver.Monad: withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b

+ GHC.Driver.Phases: phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang

+ GHC.Driver.Pipeline.Monad: getPipeSession :: CompPipeline HscEnv

+ GHC.Driver.Pipeline.Monad: instance GHC.Utils.Logger.HasLogger GHC.Driver.Pipeline.Monad.CompPipeline

+ GHC.Driver.Pipeline.Monad: setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()

+ GHC.Driver.Plugins: [driverPlugin] :: Plugin -> [CommandLineOption] -> HscEnv -> IO HscEnv

+ GHC.Driver.Ppr: pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a

+ GHC.Driver.Ppr: pprSTrace :: HasCallStack => SDoc -> a -> a

+ GHC.Driver.Ppr: pprTrace :: String -> SDoc -> a -> a

+ GHC.Driver.Ppr: pprTraceDebug :: String -> SDoc -> a -> a

+ GHC.Driver.Ppr: pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a

+ GHC.Driver.Ppr: pprTraceIt :: Outputable a => String -> a -> a

+ GHC.Driver.Ppr: pprTraceM :: Applicative f => String -> SDoc -> f ()

+ GHC.Driver.Ppr: pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a

+ GHC.Driver.Ppr: printForC :: DynFlags -> Handle -> SDoc -> IO ()

+ GHC.Driver.Ppr: printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()

+ GHC.Driver.Ppr: showPpr :: Outputable a => DynFlags -> a -> String

+ GHC.Driver.Ppr: showSDoc :: DynFlags -> SDoc -> String

+ GHC.Driver.Ppr: showSDocDebug :: DynFlags -> SDoc -> String

+ GHC.Driver.Ppr: showSDocDump :: SDocContext -> SDoc -> String

+ GHC.Driver.Ppr: showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String

+ GHC.Driver.Ppr: warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a

+ GHC.Driver.Session: DT_Dont :: DynamicTooState

+ GHC.Driver.Session: DT_Dyn :: DynamicTooState

+ GHC.Driver.Session: DT_Failed :: DynamicTooState

+ GHC.Driver.Session: DT_OK :: DynamicTooState

+ GHC.Driver.Session: GHC2021 :: Language

+ GHC.Driver.Session: Opt_ByteCode :: GeneralFlag

+ GHC.Driver.Session: Opt_D_dump_c_backend :: DumpFlag

+ GHC.Driver.Session: Opt_D_dump_faststrings :: DumpFlag

+ GHC.Driver.Session: Opt_D_dump_stg_from_core :: DumpFlag

+ GHC.Driver.Session: Opt_DistinctConstructorTables :: GeneralFlag

+ GHC.Driver.Session: Opt_ExposeInternalSymbols :: GeneralFlag

+ GHC.Driver.Session: Opt_FamAppCache :: GeneralFlag

+ GHC.Driver.Session: Opt_InfoTableMap :: GeneralFlag

+ GHC.Driver.Session: Opt_InlineGenerics :: GeneralFlag

+ GHC.Driver.Session: Opt_InlineGenericsAggressively :: GeneralFlag

+ GHC.Driver.Session: Opt_WarnAmbiguousFields :: WarningFlag

+ GHC.Driver.Session: Opt_WarnImplicitLift :: WarningFlag

+ GHC.Driver.Session: Opt_WarnMissingKindSignatures :: WarningFlag

+ GHC.Driver.Session: Opt_WarnOperatorWhitespace :: WarningFlag

+ GHC.Driver.Session: Opt_WarnOperatorWhitespaceExtConflict :: WarningFlag

+ GHC.Driver.Session: Opt_WarnRedundantBangPatterns :: WarningFlag

+ GHC.Driver.Session: [backend] :: DynFlags -> !Backend

+ GHC.Driver.Session: [callerCcFilters] :: DynFlags -> [CallerCcFilter]

+ GHC.Driver.Session: [cfgWeights] :: DynFlags -> Weights

+ GHC.Driver.Session: [dynHiSuf_] :: DynFlags -> String

+ GHC.Driver.Session: [dynObjectSuf_] :: DynFlags -> String

+ GHC.Driver.Session: [dynOutputFile_] :: DynFlags -> Maybe String

+ GHC.Driver.Session: [dynOutputHi] :: DynFlags -> Maybe String

+ GHC.Driver.Session: [dynamicNow] :: DynFlags -> !Bool

+ GHC.Driver.Session: [dynamicTooFailed] :: DynFlags -> IORef Bool

+ GHC.Driver.Session: [hiSuf_] :: DynFlags -> String

+ GHC.Driver.Session: [homeUnitId_] :: DynFlags -> UnitId

+ GHC.Driver.Session: [homeUnitInstanceOf_] :: DynFlags -> Maybe UnitId

+ GHC.Driver.Session: [homeUnitInstantiations_] :: DynFlags -> [(ModuleName, Module)]

+ GHC.Driver.Session: [mainModuleNameIs] :: DynFlags -> ModuleName

+ GHC.Driver.Session: [objectSuf_] :: DynFlags -> String

+ GHC.Driver.Session: [outputFile_] :: DynFlags -> Maybe String

+ GHC.Driver.Session: [targetWays_] :: DynFlags -> Ways

+ GHC.Driver.Session: [unfoldingOpts] :: DynFlags -> !UnfoldingOpts

+ GHC.Driver.Session: data DynamicTooState

+ GHC.Driver.Session: dynamicOutputHi :: DynFlags -> FilePath -> FilePath

+ GHC.Driver.Session: dynamicTooState :: MonadIO m => DynFlags -> m DynamicTooState

+ GHC.Driver.Session: flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)

+ GHC.Driver.Session: hiSuf :: DynFlags -> String

+ GHC.Driver.Session: instance GHC.Classes.Eq GHC.Driver.Session.DynamicTooState

+ GHC.Driver.Session: instance GHC.Classes.Ord GHC.Driver.Session.DynamicTooState

+ GHC.Driver.Session: instance GHC.Show.Show GHC.Driver.Session.DynamicTooState

+ GHC.Driver.Session: objectSuf :: DynFlags -> String

+ GHC.Driver.Session: outputFile :: DynFlags -> Maybe String

+ GHC.Driver.Session: pprDynFlagsDiff :: DynFlags -> DynFlags -> SDoc

+ GHC.Driver.Session: setDynamicNow :: DynFlags -> DynFlags

+ GHC.Driver.Session: setDynamicTooFailed :: MonadIO m => DynFlags -> m ()

+ GHC.Driver.Session: smallestGroups :: WarningFlag -> [String]

+ GHC.Driver.Session: targetProfile :: DynFlags -> Profile

+ GHC.Driver.Session: updatePlatformConstants :: DynFlags -> Maybe PlatformConstants -> IO DynFlags

+ GHC.Driver.Session: wWarningFlagMap :: Map WarningFlag (FlagSpec WarningFlag)

+ GHC.Driver.Session: ways :: DynFlags -> Ways

+ GHC.Driver.Session: xopt_DuplicateRecordFields :: DynFlags -> DuplicateRecordFields

+ GHC.Driver.Session: xopt_FieldSelectors :: DynFlags -> FieldSelectors

+ GHC.Hs: AnnsModule :: [AddEpAnn] -> AnnList -> AnnsModule

+ GHC.Hs: HsParsedModule :: Located HsModule -> [FilePath] -> HsParsedModule

+ GHC.Hs: [am_decls] :: AnnsModule -> AnnList

+ GHC.Hs: [am_main] :: AnnsModule -> [AddEpAnn]

+ GHC.Hs: [hpm_module] :: HsParsedModule -> Located HsModule

+ GHC.Hs: [hpm_src_files] :: HsParsedModule -> [FilePath]

+ GHC.Hs: [hsmodAnn] :: HsModule -> EpAnn AnnsModule

+ GHC.Hs: data AnnsModule

+ GHC.Hs: data HsParsedModule

+ GHC.Hs: instance Data.Data.Data GHC.Hs.AnnsModule

+ GHC.Hs: instance GHC.Classes.Eq GHC.Hs.AnnsModule

+ GHC.Hs.Binds: AnnSig :: AddEpAnn -> [AddEpAnn] -> AnnSig

+ GHC.Hs.Binds: [asDcolon] :: AnnSig -> AddEpAnn

+ GHC.Hs.Binds: [asRest] :: AnnSig -> [AddEpAnn]

+ GHC.Hs.Binds: data AnnSig

+ GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId l, GHC.Hs.Extension.OutputableBndrId r) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.PatSynBind (GHC.Hs.Extension.GhcPass l) (GHC.Hs.Extension.GhcPass r))

+ GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.HsBindLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr))

+ GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.HsLocalBindsLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr))

+ GHC.Hs.Binds: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.HsValBindsLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr))

+ GHC.Hs.Binds: instance Data.Data.Data GHC.Hs.Binds.AnnSig

+ GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.ABExport (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.FixitySig (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.HsIPBinds (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.IPBind (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Binds: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.Sig (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Binds: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Binds.TcSpecPrag

+ GHC.Hs.Decls: DctMulti :: XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass

+ GHC.Hs.Decls: DctSingle :: XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass

+ GHC.Hs.Decls: FunDep :: XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass

+ GHC.Hs.Decls: HsRuleAnn :: Maybe (AddEpAnn, AddEpAnn) -> Maybe (AddEpAnn, AddEpAnn) -> [AddEpAnn] -> HsRuleAnn

+ GHC.Hs.Decls: PrefixConGADT :: [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass

+ GHC.Hs.Decls: RecConGADT :: XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass

+ GHC.Hs.Decls: XDerivClauseTys :: !XXDerivClauseTys pass -> DerivClauseTys pass

+ GHC.Hs.Decls: XFunDep :: !XXFunDep pass -> FunDep pass

+ GHC.Hs.Decls: XInjectivityAnn :: !XXInjectivityAnn pass -> InjectivityAnn pass

+ GHC.Hs.Decls: XTyFamInstDecl :: !XXTyFamInstDecl pass -> TyFamInstDecl pass

+ GHC.Hs.Decls: XViaStrategyPs :: EpAnn [AddEpAnn] -> LHsSigType GhcPs -> XViaStrategyPs

+ GHC.Hs.Decls: [con_bndrs] :: ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)

+ GHC.Hs.Decls: [con_g_args] :: ConDecl pass -> HsConDeclGADTDetails pass

+ GHC.Hs.Decls: [fdTopLevel] :: FamilyDecl pass -> TopLevelFlag

+ GHC.Hs.Decls: [ra_rest] :: HsRuleAnn -> [AddEpAnn]

+ GHC.Hs.Decls: [ra_tmanns] :: HsRuleAnn -> Maybe (AddEpAnn, AddEpAnn)

+ GHC.Hs.Decls: [ra_tyanns] :: HsRuleAnn -> Maybe (AddEpAnn, AddEpAnn)

+ GHC.Hs.Decls: [tfid_xtn] :: TyFamInstDecl pass -> XCTyFamInstDecl pass

+ GHC.Hs.Decls: data DerivClauseTys pass

+ GHC.Hs.Decls: data FunDep pass

+ GHC.Hs.Decls: data HsConDeclGADTDetails pass

+ GHC.Hs.Decls: data HsRuleAnn

+ GHC.Hs.Decls: data TyFamInstDecl pass

+ GHC.Hs.Decls: data XViaStrategyPs

+ GHC.Hs.Decls: getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])

+ GHC.Hs.Decls: instance Data.Data.Data GHC.Hs.Decls.HsRuleAnn

+ GHC.Hs.Decls: instance GHC.Classes.Eq GHC.Hs.Decls.HsRuleAnn

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.AnnDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.ClsInstDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.ConDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.DataFamInstDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.DefaultDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.DerivClauseTys (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.DerivDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.DerivStrategy (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.FamilyDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.ForeignDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.FunDep (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.HsDataDefn (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.HsDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.HsDerivingClause (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.HsGroup (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.InstDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.RuleBndr (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.RuleDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.RuleDecls (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.SpliceDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.StandaloneKindSig (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.TyClDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.TyClGroup (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.TyFamInstDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.WarnDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.WarnDecls (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: instance GHC.Utils.Outputable.Outputable GHC.Hs.Decls.XViaStrategyPs

+ GHC.Hs.Decls: instance GHC.Utils.Outputable.OutputableBndr (Language.Haskell.Syntax.Extension.IdP (GHC.Hs.Extension.GhcPass p)) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.RoleAnnotDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Decls: type HsConDeclH98Details pass = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])

+ GHC.Hs.Decls: type LDerivClauseTys pass = XRec pass (DerivClauseTys pass)

+ GHC.Hs.Doc: ExtractedTHDocs :: Maybe HsDocString -> DeclDocMap -> ArgDocMap -> DeclDocMap -> ExtractedTHDocs

+ GHC.Hs.Doc: [ethd_arg_docs] :: ExtractedTHDocs -> ArgDocMap

+ GHC.Hs.Doc: [ethd_decl_docs] :: ExtractedTHDocs -> DeclDocMap

+ GHC.Hs.Doc: [ethd_inst_docs] :: ExtractedTHDocs -> DeclDocMap

+ GHC.Hs.Doc: [ethd_mod_header] :: ExtractedTHDocs -> Maybe HsDocString

+ GHC.Hs.Doc: data ExtractedTHDocs

+ GHC.Hs.Dump: BlankEpAnnotations :: BlankEpAnnotations

+ GHC.Hs.Dump: BlankSrcSpanFile :: BlankSrcSpan

+ GHC.Hs.Dump: NoBlankEpAnnotations :: BlankEpAnnotations

+ GHC.Hs.Dump: data BlankEpAnnotations

+ GHC.Hs.Dump: instance GHC.Classes.Eq GHC.Hs.Dump.BlankEpAnnotations

+ GHC.Hs.Dump: instance GHC.Show.Show GHC.Hs.Dump.BlankEpAnnotations

+ GHC.Hs.Expr: AnnExplicitSum :: EpaLocation -> [EpaLocation] -> [EpaLocation] -> EpaLocation -> AnnExplicitSum

+ GHC.Hs.Expr: AnnFieldLabel :: Maybe EpaLocation -> AnnFieldLabel

+ GHC.Hs.Expr: AnnProjection :: EpaLocation -> EpaLocation -> AnnProjection

+ GHC.Hs.Expr: AnnsIf :: EpaLocation -> EpaLocation -> EpaLocation -> Maybe EpaLocation -> Maybe EpaLocation -> AnnsIf

+ GHC.Hs.Expr: AnnsLet :: EpaLocation -> EpaLocation -> AnnsLet

+ GHC.Hs.Expr: EpAnnHsCase :: EpaLocation -> EpaLocation -> [AddEpAnn] -> EpAnnHsCase

+ GHC.Hs.Expr: EpAnnUnboundVar :: (EpaLocation, EpaLocation) -> EpaLocation -> EpAnnUnboundVar

+ GHC.Hs.Expr: GrhsAnn :: Maybe EpaLocation -> AddEpAnn -> GrhsAnn

+ GHC.Hs.Expr: [aesBarsAfter] :: AnnExplicitSum -> [EpaLocation]

+ GHC.Hs.Expr: [aesBarsBefore] :: AnnExplicitSum -> [EpaLocation]

+ GHC.Hs.Expr: [aesClose] :: AnnExplicitSum -> EpaLocation

+ GHC.Hs.Expr: [aesOpen] :: AnnExplicitSum -> EpaLocation

+ GHC.Hs.Expr: [afDot] :: AnnFieldLabel -> Maybe EpaLocation

+ GHC.Hs.Expr: [aiElseSemi] :: AnnsIf -> Maybe EpaLocation

+ GHC.Hs.Expr: [aiElse] :: AnnsIf -> EpaLocation

+ GHC.Hs.Expr: [aiIf] :: AnnsIf -> EpaLocation

+ GHC.Hs.Expr: [aiThenSemi] :: AnnsIf -> Maybe EpaLocation

+ GHC.Hs.Expr: [aiThen] :: AnnsIf -> EpaLocation

+ GHC.Hs.Expr: [alIn] :: AnnsLet -> EpaLocation

+ GHC.Hs.Expr: [alLet] :: AnnsLet -> EpaLocation

+ GHC.Hs.Expr: [apClose] :: AnnProjection -> EpaLocation

+ GHC.Hs.Expr: [apOpen] :: AnnProjection -> EpaLocation

+ GHC.Hs.Expr: [ga_sep] :: GrhsAnn -> AddEpAnn

+ GHC.Hs.Expr: [ga_vbar] :: GrhsAnn -> Maybe EpaLocation

+ GHC.Hs.Expr: [hsCaseAnnCase] :: EpAnnHsCase -> EpaLocation

+ GHC.Hs.Expr: [hsCaseAnnOf] :: EpAnnHsCase -> EpaLocation

+ GHC.Hs.Expr: [hsCaseAnnsRest] :: EpAnnHsCase -> [AddEpAnn]

+ GHC.Hs.Expr: [hsUnboundBackquotes] :: EpAnnUnboundVar -> (EpaLocation, EpaLocation)

+ GHC.Hs.Expr: [hsUnboundHole] :: EpAnnUnboundVar -> EpaLocation

+ GHC.Hs.Expr: data AnnExplicitSum

+ GHC.Hs.Expr: data AnnFieldLabel

+ GHC.Hs.Expr: data AnnProjection

+ GHC.Hs.Expr: data AnnsIf

+ GHC.Hs.Expr: data AnnsLet

+ GHC.Hs.Expr: data EpAnnHsCase

+ GHC.Hs.Expr: data EpAnnUnboundVar

+ GHC.Hs.Expr: data GrhsAnn

+ GHC.Hs.Expr: instance (GHC.Hs.Extension.OutputableBndrId pl, GHC.Hs.Extension.OutputableBndrId pr, Language.Haskell.Syntax.Extension.Anno (Language.Haskell.Syntax.Expr.StmtLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr) body) GHC.Types.~ GHC.Parser.Annotation.SrcSpanAnnA, GHC.Utils.Outputable.Outputable body) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.StmtLR (GHC.Hs.Extension.GhcPass pl) (GHC.Hs.Extension.GhcPass pr) body)

+ GHC.Hs.Expr: instance (GHC.Hs.Extension.OutputableBndrId pr, GHC.Utils.Outputable.Outputable body) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.Match (GHC.Hs.Extension.GhcPass pr) body)

+ GHC.Hs.Expr: instance (GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.StmtLR (GHC.Hs.Extension.GhcPass idL) (GHC.Hs.Extension.GhcPass idL) (Language.Haskell.Syntax.Expr.LHsExpr (GHC.Hs.Extension.GhcPass idL))), GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Extension.XXParStmtBlock (GHC.Hs.Extension.GhcPass idL) (GHC.Hs.Extension.GhcPass idR))) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.ParStmtBlock (GHC.Hs.Extension.GhcPass idL) (GHC.Hs.Extension.GhcPass idR))

+ GHC.Hs.Expr: instance (Language.Haskell.Syntax.Extension.Anno a GHC.Types.~ GHC.Parser.Annotation.SrcSpanAnn' (GHC.Parser.Annotation.EpAnn an)) => Language.Haskell.Syntax.Extension.WrapXRec (GHC.Hs.Extension.GhcPass p) a

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.AnnExplicitSum

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.AnnFieldLabel

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.AnnProjection

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.AnnsIf

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.AnnsLet

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.EpAnnHsCase

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.EpAnnUnboundVar

+ GHC.Hs.Expr: instance Data.Data.Data GHC.Hs.Expr.GrhsAnn

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId idL => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.ApplicativeArg (GHC.Hs.Extension.GhcPass idL))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.ArithSeqInfo (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsBracket (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsCmd (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsCmdTop (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsExpr (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsMatchContext (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsSplice (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsSplicedThing (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsStmtContext (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsPragE (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable GHC.Hs.Expr.GrhsAnn

+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Expr.HsArrowMatchContext

+ GHC.Hs.Expr: matchArrowContextErrString :: HsArrowMatchContext -> SDoc

+ GHC.Hs.Expr: pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc

+ GHC.Hs.Extension: instance Language.Haskell.Syntax.Extension.MapXRec (GHC.Hs.Extension.GhcPass p)

+ GHC.Hs.Extension: instance Language.Haskell.Syntax.Extension.UnXRec (GHC.Hs.Extension.GhcPass p)

+ GHC.Hs.Extension: type IsSrcSpanAnn p a = (Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p)

+ GHC.Hs.ImpExp: EpAnnImportDecl :: EpaLocation -> Maybe (EpaLocation, EpaLocation) -> Maybe EpaLocation -> Maybe EpaLocation -> Maybe EpaLocation -> Maybe EpaLocation -> EpAnnImportDecl

+ GHC.Hs.ImpExp: [importDeclAnnAs] :: EpAnnImportDecl -> Maybe EpaLocation

+ GHC.Hs.ImpExp: [importDeclAnnImport] :: EpAnnImportDecl -> EpaLocation

+ GHC.Hs.ImpExp: [importDeclAnnPackage] :: EpAnnImportDecl -> Maybe EpaLocation

+ GHC.Hs.ImpExp: [importDeclAnnPragma] :: EpAnnImportDecl -> Maybe (EpaLocation, EpaLocation)

+ GHC.Hs.ImpExp: [importDeclAnnQualified] :: EpAnnImportDecl -> Maybe EpaLocation

+ GHC.Hs.ImpExp: [importDeclAnnSafe] :: EpAnnImportDecl -> Maybe EpaLocation

+ GHC.Hs.ImpExp: data EpAnnImportDecl

+ GHC.Hs.ImpExp: ieWrappedLName :: IEWrappedName name -> LocatedN name

+ GHC.Hs.ImpExp: instance (GHC.Hs.Extension.OutputableBndrId p, GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Extension.Anno (GHC.Hs.ImpExp.IE (GHC.Hs.Extension.GhcPass p)))) => GHC.Utils.Outputable.Outputable (GHC.Hs.ImpExp.ImportDecl (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.ImpExp: instance Data.Data.Data GHC.Hs.ImpExp.EpAnnImportDecl

+ GHC.Hs.Instances: instance (Data.Data.Data a, Data.Data.Data b) => Data.Data.Data (Language.Haskell.Syntax.Pat.HsRecField' a b)

+ GHC.Hs.Instances: instance (Data.Data.Data a, Data.Data.Data b) => Data.Data.Data (Language.Haskell.Syntax.Type.HsArg a b)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.ABExport GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.ABExport GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.ABExport GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.FixitySig GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.FixitySig GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.FixitySig GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsBindLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsBindLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsBindLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsBindLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsIPBinds GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsIPBinds GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsIPBinds GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsLocalBindsLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsPatSynDir GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsPatSynDir GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsPatSynDir GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsValBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsValBindsLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsValBindsLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsValBindsLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.IPBind GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.IPBind GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.IPBind GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.PatSynBind GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.PatSynBind GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.PatSynBind GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.PatSynBind GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.RecordPatSynField GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.RecordPatSynField GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.RecordPatSynField GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.Sig GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.Sig GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.Sig GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.AnnDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.AnnDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.AnnDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.AnnProvenance GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.AnnProvenance GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.AnnProvenance GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ClsInstDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ClsInstDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ClsInstDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ConDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ConDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ConDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DataFamInstDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DataFamInstDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DataFamInstDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DefaultDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DefaultDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DefaultDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivClauseTys GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivClauseTys GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivClauseTys GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivStrategy GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivStrategy GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.DerivStrategy GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyInfo GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyInfo GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyInfo GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyResultSig GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyResultSig GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FamilyResultSig GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ForeignDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ForeignDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.ForeignDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FunDep GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FunDep GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.FunDep GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsConDeclGADTDetails GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsConDeclGADTDetails GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsConDeclGADTDetails GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsGroup GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsGroup GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.HsGroup GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.InjectivityAnn GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.InjectivityAnn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.InjectivityAnn GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.InstDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.InstDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.InstDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleBndr GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleBndr GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleBndr GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleDecls GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleDecls GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.RuleDecls GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.SpliceDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.SpliceDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.SpliceDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.StandaloneKindSig GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.StandaloneKindSig GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.StandaloneKindSig GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyClDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyClDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyClDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyClGroup GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyClGroup GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyClGroup GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyFamInstDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyFamInstDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.TyFamInstDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.WarnDecl GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.WarnDecl GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.WarnDecl GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.WarnDecls GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.WarnDecls GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Decls.WarnDecls GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ApplicativeArg GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ApplicativeArg GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ApplicativeArg GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ArithSeqInfo GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ArithSeqInfo GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ArithSeqInfo GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.FieldLabelStrings GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.FieldLabelStrings GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.FieldLabelStrings GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHS GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHS GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHS GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHS GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHS GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHS GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHSs GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHSs GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHSs GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHSs GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHSs GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.GRHSs GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsBracket GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsBracket GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsBracket GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsCmdTop GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsCmdTop GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsCmdTop GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsFieldLabel GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsFieldLabel GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsFieldLabel GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsPragE GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsPragE GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsPragE GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsSplice GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsSplice GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsSplice GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsSplicedThing GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsSplicedThing GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsSplicedThing GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsTupArg GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsTupArg GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsTupArg GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.Match GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.Match GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.Match GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.Match GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.Match GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.Match GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.MatchGroup GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.MatchGroup GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.MatchGroup GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ParStmtBlock GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ParStmtBlock GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ParStmtBlock GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.ParStmtBlock GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.StmtLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcPs (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.StmtLR GHC.Hs.Extension.GhcPs GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.StmtLR GHC.Hs.Extension.GhcRn GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcRn)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.StmtLR GHC.Hs.Extension.GhcTc GHC.Hs.Extension.GhcTc (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcTc)))

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Lit.HsLit GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Lit.HsLit GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Lit.HsLit GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Lit.HsOverLit GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Lit.HsOverLit GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Lit.HsOverLit GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Pat.Pat GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Pat.Pat GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Pat.Pat GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.ConDeclField GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.ConDeclField GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.ConDeclField GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.FieldOcc GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.FieldOcc GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.FieldOcc GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsArrow GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsArrow GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsArrow GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsForAllTelescope GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsForAllTelescope GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsForAllTelescope GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsPatSigType GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsPatSigType GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsPatSigType GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsSigType GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsSigType GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsSigType GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.LHsQTyVars GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.LHsQTyVars GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.LHsQTyVars GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data GHC.Hs.Decls.XViaStrategyPs

+ GHC.Hs.Instances: instance Data.Data.Data Language.Haskell.Syntax.Expr.HsArrowMatchContext

+ GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (Language.Haskell.Syntax.Pat.HsRecFields GHC.Hs.Extension.GhcPs body)

+ GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (Language.Haskell.Syntax.Pat.HsRecFields GHC.Hs.Extension.GhcRn body)

+ GHC.Hs.Instances: instance Data.Data.Data body => Data.Data.Data (Language.Haskell.Syntax.Pat.HsRecFields GHC.Hs.Extension.GhcTc body)

+ GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (Language.Haskell.Syntax.Type.HsOuterTyVarBndrs flag GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (Language.Haskell.Syntax.Type.HsOuterTyVarBndrs flag GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (Language.Haskell.Syntax.Type.HsOuterTyVarBndrs flag GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (Language.Haskell.Syntax.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcPs)

+ GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (Language.Haskell.Syntax.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Instances: instance Data.Data.Data flag => Data.Data.Data (Language.Haskell.Syntax.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcTc)

+ GHC.Hs.Instances: instance Data.Data.Data rhs => Data.Data.Data (Language.Haskell.Syntax.Decls.FamEqn GHC.Hs.Extension.GhcPs rhs)

+ GHC.Hs.Instances: instance Data.Data.Data rhs => Data.Data.Data (Language.Haskell.Syntax.Decls.FamEqn GHC.Hs.Extension.GhcRn rhs)

+ GHC.Hs.Instances: instance Data.Data.Data rhs => Data.Data.Data (Language.Haskell.Syntax.Decls.FamEqn GHC.Hs.Extension.GhcTc rhs)

+ GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (Language.Haskell.Syntax.Type.HsScaled GHC.Hs.Extension.GhcPs thing)

+ GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (Language.Haskell.Syntax.Type.HsScaled GHC.Hs.Extension.GhcRn thing)

+ GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (Language.Haskell.Syntax.Type.HsScaled GHC.Hs.Extension.GhcTc thing)

+ GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (Language.Haskell.Syntax.Type.HsWildCardBndrs GHC.Hs.Extension.GhcPs thing)

+ GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (Language.Haskell.Syntax.Type.HsWildCardBndrs GHC.Hs.Extension.GhcRn thing)

+ GHC.Hs.Instances: instance Data.Data.Data thing => Data.Data.Data (Language.Haskell.Syntax.Type.HsWildCardBndrs GHC.Hs.Extension.GhcTc thing)

+ GHC.Hs.Lit: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Lit.HsOverLit (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Lit: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Lit.HsLit (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Pat: EpAnnSumPat :: [AddEpAnn] -> [EpaLocation] -> [EpaLocation] -> EpAnnSumPat

+ GHC.Hs.Pat: [hsRecFieldAnn] :: HsRecField' id arg -> XHsRecField id

+ GHC.Hs.Pat: [sumPatParens] :: EpAnnSumPat -> [AddEpAnn]

+ GHC.Hs.Pat: [sumPatVbarsAfter] :: EpAnnSumPat -> [EpaLocation]

+ GHC.Hs.Pat: [sumPatVbarsBefore] :: EpAnnSumPat -> [EpaLocation]

+ GHC.Hs.Pat: data EpAnnSumPat

+ GHC.Hs.Pat: instance Data.Data.Data GHC.Hs.Pat.EpAnnSumPat

+ GHC.Hs.Pat: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.Pat (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Pat: pprLPat :: OutputableBndrId p => LPat (GhcPass p) -> SDoc

+ GHC.Hs.Type: HsCharTy :: SourceText -> Char -> HsTyLit

+ GHC.Hs.Type: HsOuterExplicit :: XHsOuterExplicit pass flag -> [LHsTyVarBndr flag (NoGhcTc pass)] -> HsOuterTyVarBndrs flag pass

+ GHC.Hs.Type: HsOuterImplicit :: XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass

+ GHC.Hs.Type: HsSig :: XHsSig pass -> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass

+ GHC.Hs.Type: XHsOuterTyVarBndrs :: !XXHsOuterTyVarBndrs pass -> HsOuterTyVarBndrs flag pass

+ GHC.Hs.Type: XHsSigType :: !XXHsSigType pass -> HsSigType pass

+ GHC.Hs.Type: [hso_bndrs] :: HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]

+ GHC.Hs.Type: [hso_xexplicit] :: HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag

+ GHC.Hs.Type: [hso_ximplicit] :: HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass

+ GHC.Hs.Type: [sig_bndrs] :: HsSigType pass -> HsOuterSigTyVarBndrs pass

+ GHC.Hs.Type: [sig_body] :: HsSigType pass -> LHsType pass

+ GHC.Hs.Type: [sig_ext] :: HsSigType pass -> XHsSig pass

+ GHC.Hs.Type: data HsOuterTyVarBndrs flag pass

+ GHC.Hs.Type: data HsSigType pass

+ GHC.Hs.Type: fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)

+ GHC.Hs.Type: hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p) -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]

+ GHC.Hs.Type: hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]

+ GHC.Hs.Type: instance (GHC.Hs.Extension.OutputableBndrId p, GHC.Hs.Type.OutputableBndrFlag flag p) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsTyVarBndr flag (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance (GHC.Hs.Type.OutputableBndrFlag flag p, GHC.Hs.Type.OutputableBndrFlag flag (GHC.Hs.Extension.NoGhcTcPass p), GHC.Hs.Extension.OutputableBndrId p) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsOuterTyVarBndrs flag (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.ConDeclField (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsForAllTelescope (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsPatSigType (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsSigType (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsType (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.LHsQTyVars (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId pass => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsArrow (GHC.Hs.Extension.GhcPass pass))

+ GHC.Hs.Type: instance GHC.Hs.Type.OutputableBndrFlag () p

+ GHC.Hs.Type: instance GHC.Hs.Type.OutputableBndrFlag GHC.Types.Var.Specificity p

+ GHC.Hs.Type: instance GHC.Types.Name.NamedThing (Language.Haskell.Syntax.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcRn)

+ GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.AmbiguousFieldOcc (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: instance GHC.Utils.Outputable.Outputable thing => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsWildCardBndrs (GHC.Hs.Extension.GhcPass p) thing)

+ GHC.Hs.Type: instance GHC.Utils.Outputable.OutputableBndr (Language.Haskell.Syntax.Type.AmbiguousFieldOcc (GHC.Hs.Extension.GhcPass p))

+ GHC.Hs.Type: mapHsOuterImplicit :: (XHsOuterImplicit pass -> XHsOuterImplicit pass) -> HsOuterTyVarBndrs flag pass -> HsOuterTyVarBndrs flag pass

+ GHC.Hs.Type: mkHsExplicitSigType :: EpAnnForallTy -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs -> HsSigType GhcPs

+ GHC.Hs.Type: mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs

+ GHC.Hs.Type: mkHsOuterExplicit :: EpAnnForallTy -> [LHsTyVarBndr flag GhcPs] -> HsOuterTyVarBndrs flag GhcPs

+ GHC.Hs.Type: mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs

+ GHC.Hs.Type: noTypeArgs :: [Void]

+ GHC.Hs.Type: pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc

+ GHC.Hs.Type: pprHsOuterSigTyVarBndrs :: OutputableBndrId p => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc

+ GHC.Hs.Type: type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn) " Location of 'forall' and '->' for HsForAllVis Location of 'forall' and '.' for HsForAllInvis"

+ GHC.Hs.Type: type HsCoreTy = Type

+ GHC.Hs.Type: type HsOuterFamEqnTyVarBndrs = HsOuterTyVarBndrs ()

+ GHC.Hs.Type: type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity

+ GHC.Hs.Utils: [CollNoDictBinders] :: CollectFlag p

+ GHC.Hs.Utils: [CollWithDictBinders] :: CollectFlag GhcTc

+ GHC.Hs.Utils: data CollectFlag p

+ GHC.Hs.Utils: hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs

+ GHC.Hs.Utils: hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs

+ GHC.Hs.Utils: instance GHC.Hs.Extension.IsPass p => GHC.Hs.Utils.CollectPass (GHC.Hs.Extension.GhcPass p)

+ GHC.Hs.Utils: mkHsCharPrimLit :: Char -> HsLit (GhcPass p)

+ GHC.Hs.Utils: mkHsCompAnns :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> EpAnn AnnList -> HsExpr GhcPs

+ GHC.Hs.Utils: mkHsDoAnns :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs

+ GHC.Hs.Utils: mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)

+ GHC.Hs.Utils: mkLocatedList :: Semigroup a => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]

+ GHC.Hs.Utils: spanHsLocaLBinds :: Data (HsLocalBinds (GhcPass p)) => HsLocalBinds (GhcPass p) -> SrcSpan

+ GHC.HsToCore.Binds: dsEvTerm :: EvTerm -> DsM CoreExpr

+ GHC.HsToCore.Docs: con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString

+ GHC.HsToCore.Docs: extractTHDocs :: THDocs -> ExtractedTHDocs

+ GHC.HsToCore.Docs: gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString

+ GHC.HsToCore.Docs: h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString

+ GHC.HsToCore.Docs: sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString

+ GHC.HsToCore.Docs: unionArgMaps :: Map Name (IntMap b) -> Map Name (IntMap b) -> Map Name (IntMap b)

+ GHC.HsToCore.Monad: getCCIndexDsM :: FastString -> DsM CostCentreIndex

+ GHC.HsToCore.Monad: getPmNablas :: DsM Nablas

+ GHC.HsToCore.Monad: instance GHC.Types.TyThing.MonadThings (GHC.Data.IOEnv.IOEnv (GHC.Tc.Types.Env GHC.HsToCore.Types.DsGblEnv GHC.HsToCore.Types.DsLclEnv))

+ GHC.HsToCore.Monad: putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a

+ GHC.HsToCore.Monad: updPmNablas :: Nablas -> DsM a -> DsM a

+ GHC.HsToCore.Pmc: addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a

+ GHC.HsToCore.Pmc: addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a

+ GHC.HsToCore.Pmc: addTyCs :: Origin -> Bag EvVar -> DsM a -> DsM a

+ GHC.HsToCore.Pmc: instance GHC.Base.Monoid GHC.HsToCore.Pmc.CIRB

+ GHC.HsToCore.Pmc: instance GHC.Base.Semigroup GHC.HsToCore.Pmc.CIRB

+ GHC.HsToCore.Pmc: isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool

+ GHC.HsToCore.Pmc: pmcGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (NonEmpty Nablas)

+ GHC.HsToCore.Pmc: pmcMatches :: DsMatchContext -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM [(Nablas, NonEmpty Nablas)]

+ GHC.HsToCore.Pmc: pmcPatBind :: DsMatchContext -> Id -> Pat GhcTc -> DsM ()

+ GHC.HsToCore.Pmc.Check: CA :: (Nablas -> DsM (CheckResult a)) -> CheckAction a

+ GHC.HsToCore.Pmc.Check: [unCA] :: CheckAction a -> Nablas -> DsM (CheckResult a)

+ GHC.HsToCore.Pmc.Check: checkEmptyCase :: PmEmptyCase -> CheckAction PmEmptyCase

+ GHC.HsToCore.Pmc.Check: checkGRHSs :: PmGRHSs Pre -> CheckAction (PmGRHSs Post)

+ GHC.HsToCore.Pmc.Check: checkMatchGroup :: PmMatchGroup Pre -> CheckAction (PmMatchGroup Post)

+ GHC.HsToCore.Pmc.Check: checkPatBind :: PmPatBind Pre -> CheckAction (PmPatBind Post)

+ GHC.HsToCore.Pmc.Check: instance GHC.Base.Functor GHC.HsToCore.Pmc.Check.CheckAction

+ GHC.HsToCore.Pmc.Check: newtype CheckAction a

+ GHC.HsToCore.Pmc.Desugar: desugarEmptyCase :: Id -> DsM PmEmptyCase

+ GHC.HsToCore.Pmc.Desugar: desugarGRHSs :: SrcSpan -> SDoc -> GRHSs GhcTc (LHsExpr GhcTc) -> DsM (PmGRHSs Pre)

+ GHC.HsToCore.Pmc.Desugar: desugarMatches :: [Id] -> NonEmpty (LMatch GhcTc (LHsExpr GhcTc)) -> DsM (PmMatchGroup Pre)

+ GHC.HsToCore.Pmc.Desugar: desugarPatBind :: SrcSpan -> Id -> Pat GhcTc -> DsM (PmPatBind Pre)

+ GHC.HsToCore.Pmc.Ppr: pprUncovered :: Nabla -> [Id] -> SDoc

+ GHC.HsToCore.Pmc.Solver: MkNablas :: Bag Nabla -> Nablas

+ GHC.HsToCore.Pmc.Solver: PhiBotCt :: !Id -> PhiCt

+ GHC.HsToCore.Pmc.Solver: PhiConCt :: !Id -> !PmAltCon -> ![TyVar] -> ![PredType] -> ![Id] -> PhiCt

+ GHC.HsToCore.Pmc.Solver: PhiCoreCt :: !Id -> !CoreExpr -> PhiCt

+ GHC.HsToCore.Pmc.Solver: PhiNotBotCt :: !Id -> PhiCt

+ GHC.HsToCore.Pmc.Solver: PhiNotConCt :: !Id -> !PmAltCon -> PhiCt

+ GHC.HsToCore.Pmc.Solver: PhiTyCt :: !PredType -> PhiCt

+ GHC.HsToCore.Pmc.Solver: addPhiCtNablas :: Nablas -> PhiCt -> DsM Nablas

+ GHC.HsToCore.Pmc.Solver: addPhiCtsNablas :: Nablas -> PhiCts -> DsM Nablas

+ GHC.HsToCore.Pmc.Solver: data Nabla

+ GHC.HsToCore.Pmc.Solver: data PhiCt

+ GHC.HsToCore.Pmc.Solver: generateInhabitingPatterns :: [Id] -> Int -> Nabla -> DsM [Nabla]

+ GHC.HsToCore.Pmc.Solver: initNablas :: Nablas

+ GHC.HsToCore.Pmc.Solver: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.PhiCt

+ GHC.HsToCore.Pmc.Solver: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.TopNormaliseTypeResult

+ GHC.HsToCore.Pmc.Solver: isInhabited :: Nablas -> DsM Bool

+ GHC.HsToCore.Pmc.Solver: lookupRefuts :: Nabla -> Id -> [PmAltCon]

+ GHC.HsToCore.Pmc.Solver: lookupSolution :: Nabla -> Id -> Maybe PmAltConApp

+ GHC.HsToCore.Pmc.Solver: newtype Nablas

+ GHC.HsToCore.Pmc.Solver: type PhiCts = Bag PhiCt

+ GHC.HsToCore.Pmc.Solver.Types: Disjoint :: PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: Equal :: PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: IsBot :: BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: IsNotBot :: BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: MaybeBot :: BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: MkNabla :: !TyState -> !TmState -> Nabla

+ GHC.HsToCore.Pmc.Solver.Types: MkNablas :: Bag Nabla -> Nablas

+ GHC.HsToCore.Pmc.Solver.Types: PACA :: !PmAltCon -> ![TyVar] -> ![Id] -> PmAltConApp

+ GHC.HsToCore.Pmc.Solver.Types: PmAltConLike :: ConLike -> PmAltCon

+ GHC.HsToCore.Pmc.Solver.Types: PmAltLit :: PmLit -> PmAltCon

+ GHC.HsToCore.Pmc.Solver.Types: PmLit :: Type -> PmLitValue -> PmLit

+ GHC.HsToCore.Pmc.Solver.Types: PmLitChar :: Char -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PmLitInt :: Integer -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PmLitOverInt :: Int -> Integer -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PmLitOverRat :: Int -> FractionalLit -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PmLitOverString :: FastString -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PmLitRat :: Rational -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PmLitString :: FastString -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: PossiblyOverlap :: PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: RCM :: !Maybe CompleteMatch -> !Maybe [CompleteMatch] -> ResidualCompleteMatches

+ GHC.HsToCore.Pmc.Solver.Types: TmSt :: !UniqSDFM Id VarInfo -> !CoreMap Id -> !DIdSet -> TmState

+ GHC.HsToCore.Pmc.Solver.Types: TySt :: !Int -> !InertSet -> TyState

+ GHC.HsToCore.Pmc.Solver.Types: VI :: !Id -> ![PmAltConApp] -> !PmAltConSet -> BotInfo -> !ResidualCompleteMatches -> VarInfo

+ GHC.HsToCore.Pmc.Solver.Types: [nabla_tm_st] :: Nabla -> !TmState

+ GHC.HsToCore.Pmc.Solver.Types: [nabla_ty_st] :: Nabla -> !TyState

+ GHC.HsToCore.Pmc.Solver.Types: [paca_con] :: PmAltConApp -> !PmAltCon

+ GHC.HsToCore.Pmc.Solver.Types: [paca_ids] :: PmAltConApp -> ![Id]

+ GHC.HsToCore.Pmc.Solver.Types: [paca_tvs] :: PmAltConApp -> ![TyVar]

+ GHC.HsToCore.Pmc.Solver.Types: [pm_lit_ty] :: PmLit -> Type

+ GHC.HsToCore.Pmc.Solver.Types: [pm_lit_val] :: PmLit -> PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: [rcm_pragmas] :: ResidualCompleteMatches -> !Maybe [CompleteMatch]

+ GHC.HsToCore.Pmc.Solver.Types: [rcm_vanilla] :: ResidualCompleteMatches -> !Maybe CompleteMatch

+ GHC.HsToCore.Pmc.Solver.Types: [ts_dirty] :: TmState -> !DIdSet

+ GHC.HsToCore.Pmc.Solver.Types: [ts_facts] :: TmState -> !UniqSDFM Id VarInfo

+ GHC.HsToCore.Pmc.Solver.Types: [ts_reps] :: TmState -> !CoreMap Id

+ GHC.HsToCore.Pmc.Solver.Types: [ty_st_inert] :: TyState -> !InertSet

+ GHC.HsToCore.Pmc.Solver.Types: [ty_st_n] :: TyState -> !Int

+ GHC.HsToCore.Pmc.Solver.Types: [vi_bot] :: VarInfo -> BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: [vi_id] :: VarInfo -> !Id

+ GHC.HsToCore.Pmc.Solver.Types: [vi_neg] :: VarInfo -> !PmAltConSet

+ GHC.HsToCore.Pmc.Solver.Types: [vi_pos] :: VarInfo -> ![PmAltConApp]

+ GHC.HsToCore.Pmc.Solver.Types: [vi_rcm] :: VarInfo -> !ResidualCompleteMatches

+ GHC.HsToCore.Pmc.Solver.Types: coreExprAsPmLit :: CoreExpr -> Maybe PmLit

+ GHC.HsToCore.Pmc.Solver.Types: data BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: data CompleteMatch

+ GHC.HsToCore.Pmc.Solver.Types: data Nabla

+ GHC.HsToCore.Pmc.Solver.Types: data PmAltCon

+ GHC.HsToCore.Pmc.Solver.Types: data PmAltConApp

+ GHC.HsToCore.Pmc.Solver.Types: data PmAltConSet

+ GHC.HsToCore.Pmc.Solver.Types: data PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: data PmLit

+ GHC.HsToCore.Pmc.Solver.Types: data PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: data ResidualCompleteMatches

+ GHC.HsToCore.Pmc.Solver.Types: data TmState

+ GHC.HsToCore.Pmc.Solver.Types: data TyState

+ GHC.HsToCore.Pmc.Solver.Types: data VarInfo

+ GHC.HsToCore.Pmc.Solver.Types: elemPmAltConSet :: PmAltCon -> PmAltConSet -> Bool

+ GHC.HsToCore.Pmc.Solver.Types: emptyPmAltConSet :: PmAltConSet

+ GHC.HsToCore.Pmc.Solver.Types: eqPmAltCon :: PmAltCon -> PmAltCon -> PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: extendPmAltConSet :: PmAltConSet -> PmAltCon -> PmAltConSet

+ GHC.HsToCore.Pmc.Solver.Types: getRcm :: ResidualCompleteMatches -> [CompleteMatch]

+ GHC.HsToCore.Pmc.Solver.Types: initNablas :: Nablas

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Base.Monoid GHC.HsToCore.Pmc.Solver.Types.Nablas

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Base.Semigroup GHC.HsToCore.Pmc.Solver.Types.Nablas

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Classes.Eq GHC.HsToCore.Pmc.Solver.Types.BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Classes.Eq GHC.HsToCore.Pmc.Solver.Types.PmAltCon

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Classes.Eq GHC.HsToCore.Pmc.Solver.Types.PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Classes.Eq GHC.HsToCore.Pmc.Solver.Types.PmLit

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Show.Show GHC.HsToCore.Pmc.Solver.Types.PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.BotInfo

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.Nabla

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.Nablas

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.PmAltCon

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.PmAltConApp

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.PmAltConSet

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.PmEquality

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.PmLit

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.PmLitValue

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.ResidualCompleteMatches

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.TmState

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.TyState

+ GHC.HsToCore.Pmc.Solver.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Solver.Types.VarInfo

+ GHC.HsToCore.Pmc.Solver.Types: isEmptyPmAltConSet :: PmAltConSet -> Bool

+ GHC.HsToCore.Pmc.Solver.Types: isPmAltConMatchStrict :: PmAltCon -> Bool

+ GHC.HsToCore.Pmc.Solver.Types: isRcmInitialised :: ResidualCompleteMatches -> Bool

+ GHC.HsToCore.Pmc.Solver.Types: literalToPmLit :: Type -> Literal -> Maybe PmLit

+ GHC.HsToCore.Pmc.Solver.Types: negatePmLit :: PmLit -> Maybe PmLit

+ GHC.HsToCore.Pmc.Solver.Types: newtype Nablas

+ GHC.HsToCore.Pmc.Solver.Types: overloadPmLit :: Type -> PmLit -> Maybe PmLit

+ GHC.HsToCore.Pmc.Solver.Types: pmAltConImplBangs :: PmAltCon -> [HsImplBang]

+ GHC.HsToCore.Pmc.Solver.Types: pmAltConSetElems :: PmAltConSet -> [PmAltCon]

+ GHC.HsToCore.Pmc.Solver.Types: pmAltConType :: PmAltCon -> [Type] -> Type

+ GHC.HsToCore.Pmc.Solver.Types: pmLitAsStringLit :: PmLit -> Maybe FastString

+ GHC.HsToCore.Pmc.Solver.Types: pmLitType :: PmLit -> Type

+ GHC.HsToCore.Pmc.Types: Approximate :: Precision

+ GHC.HsToCore.Pmc.Types: CheckResult :: !a -> !Nablas -> !Precision -> CheckResult a

+ GHC.HsToCore.Pmc.Types: GrdVec :: [PmGrd] -> GrdVec

+ GHC.HsToCore.Pmc.Types: PmBang :: !Id -> !Maybe SrcInfo -> PmGrd

+ GHC.HsToCore.Pmc.Types: PmCon :: !Id -> !PmAltCon -> ![TyVar] -> ![EvVar] -> ![Id] -> PmGrd

+ GHC.HsToCore.Pmc.Types: PmEmptyCase :: Id -> PmEmptyCase

+ GHC.HsToCore.Pmc.Types: PmGRHS :: !p -> !SrcInfo -> PmGRHS p

+ GHC.HsToCore.Pmc.Types: PmGRHSs :: !p -> !NonEmpty (PmGRHS p) -> PmGRHSs p

+ GHC.HsToCore.Pmc.Types: PmLet :: !Id -> !CoreExpr -> PmGrd

+ GHC.HsToCore.Pmc.Types: PmMatch :: !p -> !PmGRHSs p -> PmMatch p

+ GHC.HsToCore.Pmc.Types: PmMatchGroup :: NonEmpty (PmMatch p) -> PmMatchGroup p

+ GHC.HsToCore.Pmc.Types: PmPatBind :: PmGRHS p -> PmPatBind p

+ GHC.HsToCore.Pmc.Types: Precise :: Precision

+ GHC.HsToCore.Pmc.Types: RedSets :: !Nablas -> !Nablas -> !OrdList (Nablas, SrcInfo) -> RedSets

+ GHC.HsToCore.Pmc.Types: SrcInfo :: Located SDoc -> SrcInfo

+ GHC.HsToCore.Pmc.Types: [_pm_let_expr] :: PmGrd -> !CoreExpr

+ GHC.HsToCore.Pmc.Types: [_pm_loc] :: PmGrd -> !Maybe SrcInfo

+ GHC.HsToCore.Pmc.Types: [cr_approx] :: CheckResult a -> !Precision

+ GHC.HsToCore.Pmc.Types: [cr_ret] :: CheckResult a -> !a

+ GHC.HsToCore.Pmc.Types: [cr_uncov] :: CheckResult a -> !Nablas

+ GHC.HsToCore.Pmc.Types: [pe_var] :: PmEmptyCase -> Id

+ GHC.HsToCore.Pmc.Types: [pg_grds] :: PmGRHS p -> !p

+ GHC.HsToCore.Pmc.Types: [pg_rhs] :: PmGRHS p -> !SrcInfo

+ GHC.HsToCore.Pmc.Types: [pgs_grhss] :: PmGRHSs p -> !NonEmpty (PmGRHS p)

+ GHC.HsToCore.Pmc.Types: [pgs_lcls] :: PmGRHSs p -> !p

+ GHC.HsToCore.Pmc.Types: [pm_con_args] :: PmGrd -> ![Id]

+ GHC.HsToCore.Pmc.Types: [pm_con_con] :: PmGrd -> !PmAltCon

+ GHC.HsToCore.Pmc.Types: [pm_con_dicts] :: PmGrd -> ![EvVar]

+ GHC.HsToCore.Pmc.Types: [pm_con_tvs] :: PmGrd -> ![TyVar]

+ GHC.HsToCore.Pmc.Types: [pm_grhss] :: PmMatch p -> !PmGRHSs p

+ GHC.HsToCore.Pmc.Types: [pm_id] :: PmGrd -> !Id

+ GHC.HsToCore.Pmc.Types: [pm_pats] :: PmMatch p -> !p

+ GHC.HsToCore.Pmc.Types: [rs_bangs] :: RedSets -> !OrdList (Nablas, SrcInfo)

+ GHC.HsToCore.Pmc.Types: [rs_cov] :: RedSets -> !Nablas

+ GHC.HsToCore.Pmc.Types: [rs_div] :: RedSets -> !Nablas

+ GHC.HsToCore.Pmc.Types: data CheckResult a

+ GHC.HsToCore.Pmc.Types: data PmGRHS p

+ GHC.HsToCore.Pmc.Types: data PmGRHSs p

+ GHC.HsToCore.Pmc.Types: data PmGrd

+ GHC.HsToCore.Pmc.Types: data PmMatch p

+ GHC.HsToCore.Pmc.Types: data Precision

+ GHC.HsToCore.Pmc.Types: data RedSets

+ GHC.HsToCore.Pmc.Types: instance GHC.Base.Functor GHC.HsToCore.Pmc.Types.CheckResult

+ GHC.HsToCore.Pmc.Types: instance GHC.Base.Monoid GHC.HsToCore.Pmc.Types.Precision

+ GHC.HsToCore.Pmc.Types: instance GHC.Base.Semigroup GHC.HsToCore.Pmc.Types.Precision

+ GHC.HsToCore.Pmc.Types: instance GHC.Classes.Eq GHC.HsToCore.Pmc.Types.Precision

+ GHC.HsToCore.Pmc.Types: instance GHC.Show.Show GHC.HsToCore.Pmc.Types.Precision

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Types.GrdVec

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Types.PmEmptyCase

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Types.PmGrd

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Types.Precision

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Types.RedSets

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable GHC.HsToCore.Pmc.Types.SrcInfo

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.HsToCore.Pmc.Types.CheckResult a)

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable p => GHC.Utils.Outputable.Outputable (GHC.HsToCore.Pmc.Types.PmGRHS p)

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable p => GHC.Utils.Outputable.Outputable (GHC.HsToCore.Pmc.Types.PmGRHSs p)

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable p => GHC.Utils.Outputable.Outputable (GHC.HsToCore.Pmc.Types.PmMatch p)

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable p => GHC.Utils.Outputable.Outputable (GHC.HsToCore.Pmc.Types.PmMatchGroup p)

+ GHC.HsToCore.Pmc.Types: instance GHC.Utils.Outputable.Outputable p => GHC.Utils.Outputable.Outputable (GHC.HsToCore.Pmc.Types.PmPatBind p)

+ GHC.HsToCore.Pmc.Types: newtype GrdVec

+ GHC.HsToCore.Pmc.Types: newtype PmEmptyCase

+ GHC.HsToCore.Pmc.Types: newtype PmMatchGroup p

+ GHC.HsToCore.Pmc.Types: newtype PmPatBind p

+ GHC.HsToCore.Pmc.Types: newtype SrcInfo

+ GHC.HsToCore.Pmc.Types: type Post = RedSets

+ GHC.HsToCore.Pmc.Types: type Pre = GrdVec

+ GHC.HsToCore.Pmc.Utils: allPmCheckWarnings :: [WarningFlag]

+ GHC.HsToCore.Pmc.Utils: exhaustive :: DynFlags -> HsMatchContext id -> Bool

+ GHC.HsToCore.Pmc.Utils: exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag

+ GHC.HsToCore.Pmc.Utils: isMatchContextPmChecked :: DynFlags -> Origin -> HsMatchContext id -> Bool

+ GHC.HsToCore.Pmc.Utils: mkPmId :: Type -> DsM Id

+ GHC.HsToCore.Pmc.Utils: needToRunPmCheck :: DynFlags -> Origin -> Bool

+ GHC.HsToCore.Pmc.Utils: overlapping :: DynFlags -> HsMatchContext id -> Bool

+ GHC.HsToCore.Pmc.Utils: redundantBang :: DynFlags -> Bool

+ GHC.HsToCore.Pmc.Utils: tracePm :: String -> SDoc -> DsM ()

+ GHC.HsToCore.Types: DsBound :: Id -> DsMetaVal

+ GHC.HsToCore.Types: DsGblEnv :: Module -> FamInstEnv -> GlobalRdrEnv -> PrintUnqualified -> IORef (Messages DecoratedSDoc) -> (IfGblEnv, IfLclEnv) -> CompleteMatches -> IORef CostCentreState -> DsGblEnv

+ GHC.HsToCore.Types: DsLclEnv :: DsMetaEnv -> RealSrcSpan -> Nablas -> DsLclEnv

+ GHC.HsToCore.Types: DsSplice :: HsExpr GhcTc -> DsMetaVal

+ GHC.HsToCore.Types: [ds_cc_st] :: DsGblEnv -> IORef CostCentreState

+ GHC.HsToCore.Types: [ds_complete_matches] :: DsGblEnv -> CompleteMatches

+ GHC.HsToCore.Types: [ds_fam_inst_env] :: DsGblEnv -> FamInstEnv

+ GHC.HsToCore.Types: [ds_gbl_rdr_env] :: DsGblEnv -> GlobalRdrEnv

+ GHC.HsToCore.Types: [ds_if_env] :: DsGblEnv -> (IfGblEnv, IfLclEnv)

+ GHC.HsToCore.Types: [ds_mod] :: DsGblEnv -> Module

+ GHC.HsToCore.Types: [ds_msgs] :: DsGblEnv -> IORef (Messages DecoratedSDoc)

+ GHC.HsToCore.Types: [ds_unqual] :: DsGblEnv -> PrintUnqualified

+ GHC.HsToCore.Types: [dsl_loc] :: DsLclEnv -> RealSrcSpan

+ GHC.HsToCore.Types: [dsl_meta] :: DsLclEnv -> DsMetaEnv

+ GHC.HsToCore.Types: [dsl_nablas] :: DsLclEnv -> Nablas

+ GHC.HsToCore.Types: data DsGblEnv

+ GHC.HsToCore.Types: data DsLclEnv

+ GHC.HsToCore.Types: data DsMetaVal

+ GHC.HsToCore.Types: instance GHC.Unit.Module.ContainsModule GHC.HsToCore.Types.DsGblEnv

+ GHC.HsToCore.Types: type CompleteMatches = [CompleteMatch]

+ GHC.HsToCore.Types: type DsM = TcRnIf DsGblEnv DsLclEnv

+ GHC.HsToCore.Types: type DsMetaEnv = NameEnv DsMetaVal

+ GHC.HsToCore.Utils: dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr

+ GHC.HsToCore.Utils: mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr

+ GHC.Iface.Binary: QuietBinIFace :: TraceBinIFace

+ GHC.Iface.Binary: TraceBinIFace :: (SDoc -> IO ()) -> TraceBinIFace

+ GHC.Iface.Binary: data TraceBinIFace

+ GHC.Iface.Env: updNameCache :: IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HasLoc a, GHC.Iface.Ext.Ast.HiePass p) => GHC.Iface.Ext.Ast.HasLoc (Language.Haskell.Syntax.Decls.FamEqn (GHC.Hs.Extension.GhcPass p) a)

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HasLoc tm, GHC.Iface.Ext.Ast.HasLoc ty) => GHC.Iface.Ext.Ast.HasLoc (Language.Haskell.Syntax.Type.HsArg tm ty)

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HiePass p, Data.Data.Data (body (GHC.Hs.Extension.GhcPass p)), GHC.Iface.Ext.Ast.AnnoBody p body, GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p)))) => GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.Match (GHC.Hs.Extension.GhcPass p) (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p)))))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.HiePass p, GHC.Iface.Ext.Ast.AnnoBody p body, GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p)))) => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.MatchGroup (GHC.Hs.Extension.GhcPass p) (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p))))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located label)), GHC.Iface.Ext.Ast.ToHie arg, GHC.Iface.Ext.Ast.HasLoc arg, Data.Data.Data arg, Data.Data.Data label) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RContext (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Pat.HsRecField' label arg)))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p))), GHC.Iface.Ext.Ast.AnnoBody p body, GHC.Iface.Ext.Ast.HiePass p) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.Stmt (GHC.Hs.Extension.GhcPass p) (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p))))))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p))), GHC.Iface.Ext.Ast.HiePass p, GHC.Iface.Ext.Ast.AnnoBody p body) => GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Expr.GRHS (GHC.Hs.Extension.GhcPass p) (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p)))))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p))), GHC.Iface.Ext.Ast.HiePass p, GHC.Iface.Ext.Ast.AnnoBody p body) => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.GRHSs (GHC.Hs.Extension.GhcPass p) (GHC.Parser.Annotation.LocatedA (body (GHC.Hs.Extension.GhcPass p))))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie arg, GHC.Iface.Ext.Ast.HasLoc arg, Data.Data.Data arg, GHC.Iface.Ext.Ast.HiePass p) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RContext (Language.Haskell.Syntax.Pat.HsRecFields (GHC.Hs.Extension.GhcPass p) arg))

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie rhs, GHC.Iface.Ext.Ast.HasLoc rhs) => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.FamEqn GHC.Hs.Extension.GhcRn rhs)

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie tm, GHC.Iface.Ext.Ast.ToHie ty) => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Type.HsArg tm ty)

+ GHC.Iface.Ext.Ast: instance (GHC.Iface.Ext.Ast.ToHie tyarg, GHC.Iface.Ext.Ast.ToHie arg, GHC.Iface.Ext.Ast.ToHie rec) => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Type.HsConDetails tyarg arg rec)

+ GHC.Iface.Ext.Ast: instance Data.Data.Data flag => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TVScoped (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsTyVarBndr flag GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance Data.Data.Data flag => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TVScoped (Language.Haskell.Syntax.Type.HsOuterTyVarBndrs flag GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc (GHC.Parser.Annotation.LocatedA a)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc (GHC.Parser.Annotation.LocatedN a)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HasLoc (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.HasType (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Binds.HsBind (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.HasType (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.HasType (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Pat.Pat (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.BindContext (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Binds.HsBind (GHC.Hs.Extension.GhcPass p))))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.Context (Language.Haskell.Syntax.Type.FieldOcc (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.PScoped (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Pat.Pat (GHC.Hs.Extension.GhcPass p))))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.PatSynFieldContext (Language.Haskell.Syntax.Binds.RecordPatSynField (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Binds.IPBind (GHC.Hs.Extension.GhcPass p))))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (Language.Haskell.Syntax.Binds.HsLocalBinds (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (Language.Haskell.Syntax.Binds.HsValBindsLR (GHC.Hs.Extension.GhcPass p) (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (Language.Haskell.Syntax.Expr.ApplicativeArg (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.SigContext (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Binds.Sig (GHC.Hs.Extension.GhcPass p))))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsCmd (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsExpr (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Expr.HsSplice (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Binds.PatSynBind (GHC.Hs.Extension.GhcPass p) (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Expr.HsCmdTop (GHC.Hs.Extension.GhcPass p)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Binds.HsPatSynDir (GHC.Hs.Extension.GhcPass p))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.HsMatchContext (GHC.Hs.Extension.GhcPass p))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.HsStmtContext (GHC.Hs.Extension.GhcPass p))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.HiePass p => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.HsTupArg (GHC.Hs.Extension.GhcPass p))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Data.BooleanFormula.LBooleanFormula (GHC.Parser.Annotation.LocatedN GHC.Types.Name.Name))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.Context (GHC.Types.SrcLoc.Located Language.Haskell.Syntax.Extension.NoExtField))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.Context (GHC.Types.SrcLoc.Located a)) => GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.Context (GHC.Parser.Annotation.LocatedA a))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.EvBindContext (GHC.Parser.Annotation.LocatedA GHC.Tc.Types.Evidence.TcEvBinds))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.IEContext (GHC.Parser.Annotation.LocatedA (GHC.Hs.ImpExp.IE GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.IEContext (GHC.Parser.Annotation.LocatedA GHC.Unit.Module.Name.ModuleName))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.IEContext (GHC.Types.SrcLoc.Located GHC.Types.FieldLabel.FieldLabel))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Type.AmbiguousFieldOcc GHC.Hs.Extension.GhcTc)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Type.FieldOcc GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RFContext (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Type.FieldOcc GHC.Hs.Extension.GhcTc)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.FamilyResultSig GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.RScoped (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.RuleBndr GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsSigType GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (Language.Haskell.Syntax.Decls.FamEqn GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcRn))))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (Language.Haskell.Syntax.Decls.FamEqn GHC.Hs.Extension.GhcRn (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (Language.Haskell.Syntax.Type.HsPatSigType GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (Language.Haskell.Syntax.Type.HsWildCardBndrs GHC.Hs.Extension.GhcRn (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsSigType GHC.Hs.Extension.GhcRn))))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Iface.Ext.Ast.TScoped (Language.Haskell.Syntax.Type.LHsQTyVars GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (GHC.Hs.ImpExp.ImportDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Binds.FixitySig GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.AnnDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.ClsInstDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.ConDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.DataFamInstDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.DefaultDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.DerivDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.FamilyDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.ForeignDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.FunDep GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.InstDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.RoleAnnotDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.RuleDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.RuleDecls GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.SpliceDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.StandaloneKindSig GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.TyClDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.TyFamInstDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.WarnDecl GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.WarnDecls GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.ConDeclField GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedA GHC.Tc.Types.Evidence.HsWrapper)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedC (Language.Haskell.Syntax.Decls.DerivClauseTys GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedC [GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcRn)])

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedL [GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.ConDeclField GHC.Hs.Extension.GhcRn)])

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Parser.Annotation.LocatedP GHC.Types.Basic.OverlapMode)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.DerivStrategy GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.InjectivityAnn GHC.Hs.Extension.GhcRn))

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located Language.Haskell.Syntax.Type.HsIPName)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (GHC.Types.SrcLoc.Located [GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcRn)])

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.AnnProvenance GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.FamilyInfo GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.HsConDeclGADTDetails GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.StandaloneKindSig GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Decls.TyClGroup GHC.Hs.Extension.GhcRn)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.HsBracket a)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.LHsExpr a) => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Expr.ArithSeqInfo a)

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie Data.Void.Void

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie Language.Haskell.Syntax.Decls.ForeignExport

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie Language.Haskell.Syntax.Decls.ForeignImport

+ GHC.Iface.Ext.Ast: instance GHC.Iface.Ext.Ast.ToHie a => GHC.Iface.Ext.Ast.ToHie (Language.Haskell.Syntax.Type.HsScaled GHC.Hs.Extension.GhcRn a)

+ GHC.Iface.Ext.Fields: ExtensibleFields :: Map FieldName BinData -> ExtensibleFields

+ GHC.Iface.Ext.Fields: [getExtensibleFields] :: ExtensibleFields -> Map FieldName BinData

+ GHC.Iface.Ext.Fields: deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields

+ GHC.Iface.Ext.Fields: emptyExtensibleFields :: ExtensibleFields

+ GHC.Iface.Ext.Fields: instance Control.DeepSeq.NFData GHC.Iface.Ext.Fields.ExtensibleFields

+ GHC.Iface.Ext.Fields: instance GHC.Utils.Binary.Binary GHC.Iface.Ext.Fields.ExtensibleFields

+ GHC.Iface.Ext.Fields: newtype ExtensibleFields

+ GHC.Iface.Ext.Fields: readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)

+ GHC.Iface.Ext.Fields: readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)

+ GHC.Iface.Ext.Fields: type FieldName = String

+ GHC.Iface.Ext.Fields: writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields

+ GHC.Iface.Ext.Fields: writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields

+ GHC.Iface.Ext.Types: NodeAnnotation :: !FastString -> !FastString -> NodeAnnotation

+ GHC.Iface.Ext.Types: [nodeAnnotConstr] :: NodeAnnotation -> !FastString

+ GHC.Iface.Ext.Types: [nodeAnnotType] :: NodeAnnotation -> !FastString

+ GHC.Iface.Ext.Types: data NodeAnnotation

+ GHC.Iface.Ext.Types: instance GHC.Classes.Eq GHC.Iface.Ext.Types.NodeAnnotation

+ GHC.Iface.Ext.Types: instance GHC.Classes.Ord GHC.Iface.Ext.Types.NodeAnnotation

+ GHC.Iface.Ext.Types: instance GHC.Utils.Binary.Binary GHC.Iface.Ext.Types.NodeAnnotation

+ GHC.Iface.Ext.Types: instance GHC.Utils.Outputable.Outputable GHC.Iface.Ext.Types.NodeAnnotation

+ GHC.Iface.Ext.Types: pattern HiePath :: FastString -> HiePath

+ GHC.Iface.Ext.Types: type HiePath = LexicalFastString

+ GHC.Iface.Ext.Utils: makeNodeA :: (Monad m, Data a) => a -> SrcSpanAnn' ann -> ReaderT NodeOrigin m [HieAST b]

+ GHC.Iface.Ext.Utils: makeTypeNodeA :: (Monad m, Data a) => a -> SrcSpanAnnA -> Type -> ReaderT NodeOrigin m [HieAST Type]

+ GHC.Iface.Ext.Utils: mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope

+ GHC.Iface.Ext.Utils: mkLScopeN :: LocatedN a -> Scope

+ GHC.Iface.Ext.Utils: mkScopeA :: SrcSpanAnn' ann -> Scope

+ GHC.Iface.Load: cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc

+ GHC.Iface.Load: instance GHC.Utils.Outputable.Outputable GHC.Unit.Module.Warnings.Warnings

+ GHC.Iface.Syntax: IfaceAlt :: IfaceConAlt -> [IfLclName] -> IfaceExpr -> IfaceAlt

+ GHC.Iface.Syntax: data IfaceAlt

+ GHC.Iface.Syntax: instance Control.DeepSeq.NFData GHC.Iface.Syntax.IfaceAlt

+ GHC.Iface.Syntax: instance GHC.Utils.Binary.Binary GHC.Iface.Syntax.IfaceAlt

+ GHC.Iface.Type: IfaceCharTyLit :: Char -> IfaceTyLit

+ GHC.Iface.Type: mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo

+ GHC.Iface.UpdateIdInfos: updateModDetailsIdInfos :: CgInfos -> ModDetails -> ModDetails

+ GHC.IfaceToCore: tcIfaceCompleteMatches :: [IfaceCompleteMatch] -> IfL [CompleteMatch]

+ GHC.IfaceToCore: tcIfaceDecls :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name, TyThing)]

+ GHC.Linker.Dynamic: libmLinkOpts :: [Option]

+ GHC.Linker.Dynamic: linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()

+ GHC.Linker.ExtraObj: checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool

+ GHC.Linker.ExtraObj: getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo

+ GHC.Linker.ExtraObj: getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String

+ GHC.Linker.ExtraObj: ghcLinkInfoNoteName :: String

+ GHC.Linker.ExtraObj: ghcLinkInfoSectionName :: String

+ GHC.Linker.ExtraObj: haveRtsOptsFlags :: DynFlags -> Bool

+ GHC.Linker.ExtraObj: mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath

+ GHC.Linker.ExtraObj: mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath)

+ GHC.Linker.ExtraObj: mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]

+ GHC.Linker.ExtraObj: platformSupportsSavingLinkOpts :: OS -> Bool

+ GHC.Linker.Loader: Loader :: MVar (Maybe LoaderState) -> Loader

+ GHC.Linker.Loader: LoaderState :: ClosureEnv -> !ItblEnv -> ![Linkable] -> ![Linkable] -> ![UnitId] -> ![(FilePath, String)] -> LoaderState

+ GHC.Linker.Loader: [bcos_loaded] :: LoaderState -> ![Linkable]

+ GHC.Linker.Loader: [closure_env] :: LoaderState -> ClosureEnv

+ GHC.Linker.Loader: [itbl_env] :: LoaderState -> !ItblEnv

+ GHC.Linker.Loader: [loader_state] :: Loader -> MVar (Maybe LoaderState)

+ GHC.Linker.Loader: [objs_loaded] :: LoaderState -> ![Linkable]

+ GHC.Linker.Loader: [pkgs_loaded] :: LoaderState -> ![UnitId]

+ GHC.Linker.Loader: [temp_sos] :: LoaderState -> ![(FilePath, String)]

+ GHC.Linker.Loader: data LoaderState

+ GHC.Linker.Loader: deleteFromLoadedEnv :: Interp -> [Name] -> IO ()

+ GHC.Linker.Loader: extendLoadedEnv :: Interp -> [(Name, ForeignHValue)] -> IO ()

+ GHC.Linker.Loader: extendLoadedPkgs :: Interp -> [UnitId] -> IO ()

+ GHC.Linker.Loader: initLoaderState :: Interp -> HscEnv -> IO ()

+ GHC.Linker.Loader: instance GHC.Utils.Outputable.Outputable GHC.Linker.Loader.LibrarySpec

+ GHC.Linker.Loader: loadCmdLineLibs :: Interp -> HscEnv -> IO ()

+ GHC.Linker.Loader: loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO [(Name, ForeignHValue)]

+ GHC.Linker.Loader: loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue

+ GHC.Linker.Loader: loadModule :: Interp -> HscEnv -> Module -> IO ()

+ GHC.Linker.Loader: loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue

+ GHC.Linker.Loader: loadPackages :: Interp -> HscEnv -> [UnitId] -> IO ()

+ GHC.Linker.Loader: newtype Loader

+ GHC.Linker.Loader: showLoaderState :: Interp -> IO SDoc

+ GHC.Linker.Loader: uninitializedLoader :: IO Loader

+ GHC.Linker.Loader: unload :: Interp -> HscEnv -> [Linkable] -> IO ()

+ GHC.Linker.Loader: withExtendedLoadedEnv :: ExceptionMonad m => Interp -> [(Name, ForeignHValue)] -> m a -> m a

+ GHC.Linker.MacOS: getFrameworkOpts :: DynFlags -> Platform -> [String]

+ GHC.Linker.MacOS: getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]

+ GHC.Linker.MacOS: loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)

+ GHC.Linker.MacOS: runInjectRPaths :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()

+ GHC.Linker.Static: exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath

+ GHC.Linker.Static: linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()

+ GHC.Linker.Static: linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()

+ GHC.Linker.Static: linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()

+ GHC.Linker.Types: BCOs :: CompiledByteCode -> [SptEntry] -> Unlinked

+ GHC.Linker.Types: DotA :: FilePath -> Unlinked

+ GHC.Linker.Types: DotDLL :: FilePath -> Unlinked

+ GHC.Linker.Types: DotO :: FilePath -> Unlinked

+ GHC.Linker.Types: LM :: UTCTime -> Module -> [Unlinked] -> Linkable

+ GHC.Linker.Types: Loader :: MVar (Maybe LoaderState) -> Loader

+ GHC.Linker.Types: LoaderState :: ClosureEnv -> !ItblEnv -> ![Linkable] -> ![Linkable] -> ![UnitId] -> ![(FilePath, String)] -> LoaderState

+ GHC.Linker.Types: SptEntry :: Id -> Fingerprint -> SptEntry

+ GHC.Linker.Types: [bcos_loaded] :: LoaderState -> ![Linkable]

+ GHC.Linker.Types: [closure_env] :: LoaderState -> ClosureEnv

+ GHC.Linker.Types: [itbl_env] :: LoaderState -> !ItblEnv

+ GHC.Linker.Types: [linkableModule] :: Linkable -> Module

+ GHC.Linker.Types: [linkableTime] :: Linkable -> UTCTime

+ GHC.Linker.Types: [linkableUnlinked] :: Linkable -> [Unlinked]

+ GHC.Linker.Types: [loader_state] :: Loader -> MVar (Maybe LoaderState)

+ GHC.Linker.Types: [objs_loaded] :: LoaderState -> ![Linkable]

+ GHC.Linker.Types: [pkgs_loaded] :: LoaderState -> ![UnitId]

+ GHC.Linker.Types: [temp_sos] :: LoaderState -> ![(FilePath, String)]

+ GHC.Linker.Types: byteCodeOfObject :: Unlinked -> CompiledByteCode

+ GHC.Linker.Types: data Linkable

+ GHC.Linker.Types: data LoaderState

+ GHC.Linker.Types: data SptEntry

+ GHC.Linker.Types: data Unlinked

+ GHC.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.Linker.Types.Linkable

+ GHC.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.Linker.Types.SptEntry

+ GHC.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.Linker.Types.Unlinked

+ GHC.Linker.Types: isInterpretable :: Unlinked -> Bool

+ GHC.Linker.Types: isObject :: Unlinked -> Bool

+ GHC.Linker.Types: isObjectLinkable :: Linkable -> Bool

+ GHC.Linker.Types: linkableObjs :: Linkable -> [FilePath]

+ GHC.Linker.Types: nameOfObject :: Unlinked -> FilePath

+ GHC.Linker.Types: newtype Loader

+ GHC.Linker.Types: uninitializedLoader :: IO Loader

+ GHC.Linker.Unit: collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]

+ GHC.Linker.Unit: collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])

+ GHC.Linker.Unit: getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String, String)]

+ GHC.Linker.Unit: getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])

+ GHC.Linker.Windows: maybeCreateManifest :: Logger -> TmpFs -> DynFlags -> FilePath -> IO [FilePath]

+ GHC.Parser.Annotation: AddCommaAnn :: EpaLocation -> TrailingAnn

+ GHC.Parser.Annotation: AddEpAnn :: AnnKeywordId -> EpaLocation -> AddEpAnn

+ GHC.Parser.Annotation: AddLollyAnnU :: EpaLocation -> TrailingAnn

+ GHC.Parser.Annotation: AddRarrowAnn :: EpaLocation -> TrailingAnn

+ GHC.Parser.Annotation: AddRarrowAnnU :: EpaLocation -> TrailingAnn

+ GHC.Parser.Annotation: AddSemiAnn :: EpaLocation -> TrailingAnn

+ GHC.Parser.Annotation: AddVbarAnn :: EpaLocation -> TrailingAnn

+ GHC.Parser.Annotation: Anchor :: RealSrcSpan -> AnchorOperation -> Anchor

+ GHC.Parser.Annotation: AnnClosePH :: AnnKeywordId

+ GHC.Parser.Annotation: AnnContext :: Maybe (IsUnicodeSyntax, EpaLocation) -> [EpaLocation] -> [EpaLocation] -> AnnContext

+ GHC.Parser.Annotation: AnnList :: Maybe Anchor -> Maybe AddEpAnn -> Maybe AddEpAnn -> [AddEpAnn] -> [TrailingAnn] -> AnnList

+ GHC.Parser.Annotation: AnnListItem :: [TrailingAnn] -> AnnListItem

+ GHC.Parser.Annotation: AnnOpenPH :: AnnKeywordId

+ GHC.Parser.Annotation: AnnParen :: ParenType -> EpaLocation -> EpaLocation -> AnnParen

+ GHC.Parser.Annotation: AnnParens :: ParenType

+ GHC.Parser.Annotation: AnnParensHash :: ParenType

+ GHC.Parser.Annotation: AnnParensSquare :: ParenType

+ GHC.Parser.Annotation: AnnPragma :: AddEpAnn -> AddEpAnn -> [AddEpAnn] -> AnnPragma

+ GHC.Parser.Annotation: AnnSortKey :: [RealSrcSpan] -> AnnSortKey

+ GHC.Parser.Annotation: DifferentLine :: !Int -> !Int -> DeltaPos

+ GHC.Parser.Annotation: EpAnn :: Anchor -> ann -> EpAnnComments -> EpAnn ann

+ GHC.Parser.Annotation: EpAnnNotUsed :: EpAnn ann

+ GHC.Parser.Annotation: EpaBlockComment :: String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaComment :: EpaCommentTok -> RealSrcSpan -> EpaComment

+ GHC.Parser.Annotation: EpaComments :: ![LEpaComment] -> EpAnnComments

+ GHC.Parser.Annotation: EpaCommentsBalanced :: ![LEpaComment] -> ![LEpaComment] -> EpAnnComments

+ GHC.Parser.Annotation: EpaDelta :: !DeltaPos -> ![LEpaComment] -> EpaLocation

+ GHC.Parser.Annotation: EpaDocCommentNamed :: String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaDocCommentNext :: String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaDocCommentPrev :: String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaDocOptions :: String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaDocSection :: Int -> String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaEofComment :: EpaCommentTok

+ GHC.Parser.Annotation: EpaLineComment :: String -> EpaCommentTok

+ GHC.Parser.Annotation: EpaSpan :: !RealSrcSpan -> EpaLocation

+ GHC.Parser.Annotation: MovedAnchor :: DeltaPos -> AnchorOperation

+ GHC.Parser.Annotation: NameAnn :: NameAdornment -> EpaLocation -> EpaLocation -> EpaLocation -> [TrailingAnn] -> NameAnn

+ GHC.Parser.Annotation: NameAnnCommas :: NameAdornment -> EpaLocation -> [EpaLocation] -> EpaLocation -> [TrailingAnn] -> NameAnn

+ GHC.Parser.Annotation: NameAnnOnly :: NameAdornment -> EpaLocation -> EpaLocation -> [TrailingAnn] -> NameAnn

+ GHC.Parser.Annotation: NameAnnQuote :: EpaLocation -> SrcSpanAnnN -> [TrailingAnn] -> NameAnn

+ GHC.Parser.Annotation: NameAnnRArrow :: EpaLocation -> [TrailingAnn] -> NameAnn

+ GHC.Parser.Annotation: NameAnnTrailing :: [TrailingAnn] -> NameAnn

+ GHC.Parser.Annotation: NameBackquotes :: NameAdornment

+ GHC.Parser.Annotation: NameParens :: NameAdornment

+ GHC.Parser.Annotation: NameParensHash :: NameAdornment

+ GHC.Parser.Annotation: NameSquare :: NameAdornment

+ GHC.Parser.Annotation: NoAnnSortKey :: AnnSortKey

+ GHC.Parser.Annotation: NoEpAnns :: NoEpAnns

+ GHC.Parser.Annotation: SameLine :: !Int -> DeltaPos

+ GHC.Parser.Annotation: SrcSpanAnn :: a -> SrcSpan -> SrcSpanAnn' a

+ GHC.Parser.Annotation: UnchangedAnchor :: AnchorOperation

+ GHC.Parser.Annotation: [ac_close] :: AnnContext -> [EpaLocation]

+ GHC.Parser.Annotation: [ac_darrow] :: AnnContext -> Maybe (IsUnicodeSyntax, EpaLocation)

+ GHC.Parser.Annotation: [ac_open] :: AnnContext -> [EpaLocation]

+ GHC.Parser.Annotation: [ac_prior_tok] :: EpaComment -> RealSrcSpan

+ GHC.Parser.Annotation: [ac_tok] :: EpaComment -> EpaCommentTok

+ GHC.Parser.Annotation: [al_anchor] :: AnnList -> Maybe Anchor

+ GHC.Parser.Annotation: [al_close] :: AnnList -> Maybe AddEpAnn

+ GHC.Parser.Annotation: [al_open] :: AnnList -> Maybe AddEpAnn

+ GHC.Parser.Annotation: [al_rest] :: AnnList -> [AddEpAnn]

+ GHC.Parser.Annotation: [al_trailing] :: AnnList -> [TrailingAnn]

+ GHC.Parser.Annotation: [anchor] :: Anchor -> RealSrcSpan

+ GHC.Parser.Annotation: [anchor_op] :: Anchor -> AnchorOperation

+ GHC.Parser.Annotation: [ann] :: SrcSpanAnn' a -> a

+ GHC.Parser.Annotation: [anns] :: EpAnn ann -> ann

+ GHC.Parser.Annotation: [ap_adornment] :: AnnParen -> ParenType

+ GHC.Parser.Annotation: [ap_close] :: AnnParen -> EpaLocation

+ GHC.Parser.Annotation: [ap_open] :: AnnParen -> EpaLocation

+ GHC.Parser.Annotation: [apr_close] :: AnnPragma -> AddEpAnn

+ GHC.Parser.Annotation: [apr_open] :: AnnPragma -> AddEpAnn

+ GHC.Parser.Annotation: [apr_rest] :: AnnPragma -> [AddEpAnn]

+ GHC.Parser.Annotation: [comments] :: EpAnn ann -> EpAnnComments

+ GHC.Parser.Annotation: [deltaColumn] :: DeltaPos -> !Int

+ GHC.Parser.Annotation: [deltaLine] :: DeltaPos -> !Int

+ GHC.Parser.Annotation: [entry] :: EpAnn ann -> Anchor

+ GHC.Parser.Annotation: [followingComments] :: EpAnnComments -> ![LEpaComment]

+ GHC.Parser.Annotation: [lann_trailing] :: AnnListItem -> [TrailingAnn]

+ GHC.Parser.Annotation: [locA] :: SrcSpanAnn' a -> SrcSpan

+ GHC.Parser.Annotation: [nann_adornment] :: NameAnn -> NameAdornment

+ GHC.Parser.Annotation: [nann_close] :: NameAnn -> EpaLocation

+ GHC.Parser.Annotation: [nann_commas] :: NameAnn -> [EpaLocation]

+ GHC.Parser.Annotation: [nann_name] :: NameAnn -> EpaLocation

+ GHC.Parser.Annotation: [nann_open] :: NameAnn -> EpaLocation

+ GHC.Parser.Annotation: [nann_quote] :: NameAnn -> EpaLocation

+ GHC.Parser.Annotation: [nann_quoted] :: NameAnn -> SrcSpanAnnN

+ GHC.Parser.Annotation: [nann_trailing] :: NameAnn -> [TrailingAnn]

+ GHC.Parser.Annotation: [priorComments] :: EpAnnComments -> ![LEpaComment]

+ GHC.Parser.Annotation: addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]

+ GHC.Parser.Annotation: addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA

+ GHC.Parser.Annotation: addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3

+ GHC.Parser.Annotation: addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3

+ GHC.Parser.Annotation: addCommentsToEpAnn :: Monoid a => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a

+ GHC.Parser.Annotation: addCommentsToSrcAnn :: Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann

+ GHC.Parser.Annotation: addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments -> EpAnn AnnListItem -> EpAnn AnnListItem

+ GHC.Parser.Annotation: addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments -> EpAnn AnnList -> EpAnn AnnList

+ GHC.Parser.Annotation: addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn

+ GHC.Parser.Annotation: annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn]

+ GHC.Parser.Annotation: combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a

+ GHC.Parser.Annotation: combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a

+ GHC.Parser.Annotation: comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO

+ GHC.Parser.Annotation: commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann

+ GHC.Parser.Annotation: data AddEpAnn

+ GHC.Parser.Annotation: data Anchor

+ GHC.Parser.Annotation: data AnchorOperation

+ GHC.Parser.Annotation: data AnnContext

+ GHC.Parser.Annotation: data AnnList

+ GHC.Parser.Annotation: data AnnListItem

+ GHC.Parser.Annotation: data AnnParen

+ GHC.Parser.Annotation: data AnnPragma

+ GHC.Parser.Annotation: data AnnSortKey

+ GHC.Parser.Annotation: data DeltaPos

+ GHC.Parser.Annotation: data EpAnn ann

+ GHC.Parser.Annotation: data EpAnnComments

+ GHC.Parser.Annotation: data EpaComment

+ GHC.Parser.Annotation: data EpaCommentTok

+ GHC.Parser.Annotation: data EpaLocation

+ GHC.Parser.Annotation: data NameAdornment

+ GHC.Parser.Annotation: data NameAnn

+ GHC.Parser.Annotation: data NoEpAnns

+ GHC.Parser.Annotation: data ParenType

+ GHC.Parser.Annotation: data SrcSpanAnn' a

+ GHC.Parser.Annotation: data TrailingAnn

+ GHC.Parser.Annotation: deltaPos :: Int -> Int -> DeltaPos

+ GHC.Parser.Annotation: emptyComments :: EpAnnComments

+ GHC.Parser.Annotation: epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn]

+ GHC.Parser.Annotation: epAnnAnnsL :: EpAnn a -> [a]

+ GHC.Parser.Annotation: epAnnComments :: EpAnn an -> EpAnnComments

+ GHC.Parser.Annotation: epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation

+ GHC.Parser.Annotation: epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan

+ GHC.Parser.Annotation: extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList

+ GHC.Parser.Annotation: getDeltaLine :: DeltaPos -> Int

+ GHC.Parser.Annotation: getFollowingComments :: EpAnnComments -> [LEpaComment]

+ GHC.Parser.Annotation: getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan

+ GHC.Parser.Annotation: getLocAnn :: Located a -> SrcSpanAnnA

+ GHC.Parser.Annotation: instance (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable e) => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated (GHC.Parser.Annotation.SrcSpanAnn' a) e)

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AddEpAnn

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.Anchor

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnchorOperation

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnContext

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnList

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnListItem

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnParen

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnPragma

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnSortKey

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.DeltaPos

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.EpAnnComments

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.EpaComment

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.EpaCommentTok

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.EpaLocation

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.NameAdornment

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.NameAnn

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.NoEpAnns

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.ParenType

+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.TrailingAnn

+ GHC.Parser.Annotation: instance Data.Data.Data a => Data.Data.Data (GHC.Parser.Annotation.SrcSpanAnn' a)

+ GHC.Parser.Annotation: instance Data.Data.Data ann => Data.Data.Data (GHC.Parser.Annotation.EpAnn ann)

+ GHC.Parser.Annotation: instance GHC.Base.Functor GHC.Parser.Annotation.EpAnn

+ GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.AnnList

+ GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.AnnListItem

+ GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.AnnSortKey

+ GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.NameAnn

+ GHC.Parser.Annotation: instance GHC.Base.Monoid a => GHC.Base.Monoid (GHC.Parser.Annotation.EpAnn a)

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.Anchor

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.AnnList

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.AnnListItem

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.AnnSortKey

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.EpAnnComments

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.NameAnn

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup a => GHC.Base.Semigroup (GHC.Parser.Annotation.EpAnn a)

+ GHC.Parser.Annotation: instance GHC.Base.Semigroup an => GHC.Base.Semigroup (GHC.Parser.Annotation.SrcSpanAnn' an)

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AddEpAnn

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.Anchor

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnchorOperation

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnnList

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnnListItem

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnnPragma

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnnSortKey

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.DeltaPos

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.EpAnnComments

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.EpaComment

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.EpaCommentTok

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.EpaLocation

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.NameAdornment

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.NameAnn

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.NoEpAnns

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.ParenType

+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.TrailingAnn

+ GHC.Parser.Annotation: instance GHC.Classes.Eq a => GHC.Classes.Eq (GHC.Parser.Annotation.SrcSpanAnn' a)

+ GHC.Parser.Annotation: instance GHC.Classes.Eq ann => GHC.Classes.Eq (GHC.Parser.Annotation.EpAnn ann)

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.AddEpAnn

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.Anchor

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.DeltaPos

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.EpaComment

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.EpaCommentTok

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.EpaLocation

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.NameAdornment

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.NoEpAnns

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.ParenType

+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.TrailingAnn

+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.Anchor

+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.AnchorOperation

+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.DeltaPos

+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.EpaComment

+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.EpaCommentTok

+ GHC.Parser.Annotation: instance GHC.Types.Name.NamedThing (GHC.Types.SrcLoc.Located a) => GHC.Types.Name.NamedThing (GHC.Parser.Annotation.LocatedAn an a)

+ GHC.Parser.Annotation: instance GHC.Utils.Binary.Binary a => GHC.Utils.Binary.Binary (GHC.Parser.Annotation.LocatedL a)

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated GHC.Parser.Annotation.Anchor GHC.Parser.Annotation.EpaComment)

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AddEpAnn

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.Anchor

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnchorOperation

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnContext

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnList

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnListItem

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnPragma

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnSortKey

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.DeltaPos

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.EpAnnComments

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.EpaComment

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.EpaLocation

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.IsUnicodeSyntax

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.NameAdornment

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.NameAnn

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.TrailingAnn

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Parser.Annotation.EpAnn a)

+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Parser.Annotation.SrcSpanAnn' a)

+ GHC.Parser.Annotation: l2l :: SrcSpanAnn' a -> SrcAnn ann

+ GHC.Parser.Annotation: l2n :: LocatedAn a1 a2 -> LocatedN a2

+ GHC.Parser.Annotation: la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2

+ GHC.Parser.Annotation: la2na :: SrcSpanAnn' a -> SrcSpanAnnN

+ GHC.Parser.Annotation: la2r :: SrcSpanAnn' a -> RealSrcSpan

+ GHC.Parser.Annotation: mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b

+ GHC.Parser.Annotation: n2l :: LocatedN a -> LocatedA a

+ GHC.Parser.Annotation: na2la :: SrcSpanAnn' a -> SrcAnn ann

+ GHC.Parser.Annotation: noAnn :: EpAnn a

+ GHC.Parser.Annotation: noAnnSrcSpan :: SrcSpan -> SrcAnn ann

+ GHC.Parser.Annotation: noComments :: EpAnnCO

+ GHC.Parser.Annotation: noLocA :: a -> LocatedAn an a

+ GHC.Parser.Annotation: noSrcSpanA :: SrcAnn ann

+ GHC.Parser.Annotation: parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId)

+ GHC.Parser.Annotation: placeholderRealSpan :: RealSrcSpan

+ GHC.Parser.Annotation: reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a

+ GHC.Parser.Annotation: reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a

+ GHC.Parser.Annotation: reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e

+ GHC.Parser.Annotation: reLoc :: LocatedAn a e -> Located e

+ GHC.Parser.Annotation: reLocA :: Located e -> LocatedAn ann e

+ GHC.Parser.Annotation: reLocC :: LocatedN e -> LocatedC e

+ GHC.Parser.Annotation: reLocL :: LocatedN e -> LocatedA e

+ GHC.Parser.Annotation: reLocN :: LocatedN a -> Located a

+ GHC.Parser.Annotation: realSpanAsAnchor :: RealSrcSpan -> Anchor

+ GHC.Parser.Annotation: realSrcSpan :: SrcSpan -> RealSrcSpan

+ GHC.Parser.Annotation: removeCommentsA :: SrcAnn ann -> SrcAnn ann

+ GHC.Parser.Annotation: setCommentsEpAnn :: Monoid a => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a

+ GHC.Parser.Annotation: setCommentsSrcAnn :: Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann

+ GHC.Parser.Annotation: setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments

+ GHC.Parser.Annotation: setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments

+ GHC.Parser.Annotation: sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]

+ GHC.Parser.Annotation: spanAsAnchor :: SrcSpan -> Anchor

+ GHC.Parser.Annotation: transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)

+ GHC.Parser.Annotation: type EpAnnCO = EpAnn NoEpAnns " Api Annotations for comments only"

+ GHC.Parser.Annotation: type LEpaComment = GenLocated Anchor EpaComment

+ GHC.Parser.Annotation: type LocatedA = GenLocated SrcSpanAnnA

+ GHC.Parser.Annotation: type LocatedAn an = GenLocated (SrcAnn an)

+ GHC.Parser.Annotation: type LocatedC = GenLocated SrcSpanAnnC

+ GHC.Parser.Annotation: type LocatedL = GenLocated SrcSpanAnnL

+ GHC.Parser.Annotation: type LocatedN = GenLocated SrcSpanAnnN

+ GHC.Parser.Annotation: type LocatedP = GenLocated SrcSpanAnnP

+ GHC.Parser.Annotation: type SrcAnn ann = SrcSpanAnn' (EpAnn ann)

+ GHC.Parser.Annotation: type SrcSpanAnnA = SrcAnn AnnListItem

+ GHC.Parser.Annotation: type SrcSpanAnnC = SrcAnn AnnContext

+ GHC.Parser.Annotation: type SrcSpanAnnL = SrcAnn AnnList

+ GHC.Parser.Annotation: type SrcSpanAnnN = SrcAnn NameAnn

+ GHC.Parser.Annotation: type SrcSpanAnnP = SrcAnn AnnPragma

+ GHC.Parser.Annotation: widenAnchor :: Anchor -> [AddEpAnn] -> Anchor

+ GHC.Parser.Annotation: widenAnchorR :: Anchor -> RealSrcSpan -> Anchor

+ GHC.Parser.Annotation: widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an

+ GHC.Parser.Annotation: widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan

+ GHC.Parser.Errors: CmmUnknownCConv :: !String -> CmmParserError

+ GHC.Parser.Errors: CmmUnknownMacro :: !FastString -> CmmParserError

+ GHC.Parser.Errors: CmmUnknownPrimitive :: !FastString -> CmmParserError

+ GHC.Parser.Errors: CmmUnrecognisedHint :: !String -> CmmParserError

+ GHC.Parser.Errors: CmmUnrecognisedSafety :: !String -> CmmParserError

+ GHC.Parser.Errors: LexErrKind_Char :: !Char -> LexErrKind

+ GHC.Parser.Errors: LexErrKind_EOF :: LexErrKind

+ GHC.Parser.Errors: LexErrKind_UTF8 :: LexErrKind

+ GHC.Parser.Errors: LexError :: LexErr

+ GHC.Parser.Errors: LexErrorInPragma :: LexErr

+ GHC.Parser.Errors: LexNumEscapeRange :: LexErr

+ GHC.Parser.Errors: LexStringCharLit :: LexErr

+ GHC.Parser.Errors: LexStringCharLitEOF :: LexErr

+ GHC.Parser.Errors: LexUnknownPragma :: LexErr

+ GHC.Parser.Errors: LexUnterminatedComment :: LexErr

+ GHC.Parser.Errors: LexUnterminatedOptions :: LexErr

+ GHC.Parser.Errors: LexUnterminatedQQ :: LexErr

+ GHC.Parser.Errors: NumUnderscore_Float :: NumUnderscoreReason

+ GHC.Parser.Errors: NumUnderscore_Integral :: NumUnderscoreReason

+ GHC.Parser.Errors: OperatorWhitespaceOccurrence_Prefix :: OperatorWhitespaceOccurrence

+ GHC.Parser.Errors: OperatorWhitespaceOccurrence_Suffix :: OperatorWhitespaceOccurrence

+ GHC.Parser.Errors: OperatorWhitespaceOccurrence_TightInfix :: OperatorWhitespaceOccurrence

+ GHC.Parser.Errors: OperatorWhitespaceSymbol_PrefixDollar :: OperatorWhitespaceSymbol

+ GHC.Parser.Errors: OperatorWhitespaceSymbol_PrefixDollarDollar :: OperatorWhitespaceSymbol

+ GHC.Parser.Errors: OperatorWhitespaceSymbol_PrefixPercent :: OperatorWhitespaceSymbol

+ GHC.Parser.Errors: PsErrArrowCmdInExpr :: !HsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrArrowCmdInPat :: !HsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrArrowExprInPat :: !HsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrAtInPatPos :: PsErrorDesc

+ GHC.Parser.Errors: PsErrBangPatWithoutSpace :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrCaseCmdInFunAppCmd :: !LHsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrCaseInFunAppExpr :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrCaseInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrCmmLexer :: PsErrorDesc

+ GHC.Parser.Errors: PsErrCmmParser :: !CmmParserError -> PsErrorDesc

+ GHC.Parser.Errors: PsErrDeclSpliceNotAtTopLevel :: !SpliceDecl GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrDoCmdInFunAppCmd :: !LHsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrDoInFunAppExpr :: !Maybe ModuleName -> !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrDoNotationInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrDotsInRecordUpdate :: PsErrorDesc

+ GHC.Parser.Errors: PsErrEmptyDoubleQuotes :: !Bool -> PsErrorDesc

+ GHC.Parser.Errors: PsErrEmptyWhereInPatSynDecl :: !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrExpectedHyphen :: PsErrorDesc

+ GHC.Parser.Errors: PsErrExplicitForall :: !Bool -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIfCmdInFunAppCmd :: !LHsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIfInFunAppExpr :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIfTheElseInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalBangPattern :: !Pat GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalDataTypeContext :: !LHsContext GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalExplicitNamespace :: PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalImportBundleForm :: PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalPatSynExport :: PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalQualifiedDo :: !SDoc -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalRoleName :: !FastString -> [Role] -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalTraditionalRecordSyntax :: !SDoc -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalUnboxedStringInPat :: !HsLit GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrIllegalWhereInDataDecl :: PsErrorDesc

+ GHC.Parser.Errors: PsErrImportPostQualified :: PsErrorDesc

+ GHC.Parser.Errors: PsErrImportQualifiedTwice :: PsErrorDesc

+ GHC.Parser.Errors: PsErrInferredTypeVarNotAllowed :: PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidDataCon :: !HsType GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidInfixDataCon :: !HsType GhcPs -> !RdrName -> !HsType GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidInfixHole :: PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidPackageName :: !FastString -> PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidRecordCon :: !PatBuilder GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidRuleActivationMarker :: PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidTypeSignature :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrInvalidWhereBindInPatSynDecl :: !RdrName -> !HsDecl GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLambdaCase :: PsErrorDesc

+ GHC.Parser.Errors: PsErrLambdaCaseInFunAppExpr :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLambdaCaseInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrLambdaCmdInFunAppCmd :: !LHsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLambdaInFunAppExpr :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLambdaInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrLazyPatWithoutSpace :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLetCmdInFunAppCmd :: !LHsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLetInFunAppExpr :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLetInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrLexer :: !LexErr -> !LexErrKind -> PsErrorDesc

+ GHC.Parser.Errors: PsErrLinearFunction :: PsErrorDesc

+ GHC.Parser.Errors: PsErrMDoInFunAppExpr :: !Maybe ModuleName -> !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrMalformedDecl :: !SDoc -> !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrMalformedEntityString :: PsErrorDesc

+ GHC.Parser.Errors: PsErrMalformedTyOrClDecl :: !LHsType GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrMissingBlock :: PsErrorDesc

+ GHC.Parser.Errors: PsErrMultiWayIf :: PsErrorDesc

+ GHC.Parser.Errors: PsErrMultipleNamesInStandaloneKindSignature :: [LIdP GhcPs] -> PsErrorDesc

+ GHC.Parser.Errors: PsErrNoSingleWhereBindInPatSynDecl :: !RdrName -> !HsDecl GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrNotADataCon :: !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrNumUnderscores :: !NumUnderscoreReason -> PsErrorDesc

+ GHC.Parser.Errors: PsErrOpFewArgs :: !StarIsType -> !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrOverloadedRecordDotInvalid :: PsErrorDesc

+ GHC.Parser.Errors: PsErrOverloadedRecordUpdateNoQualifiedFields :: PsErrorDesc

+ GHC.Parser.Errors: PsErrOverloadedRecordUpdateNotEnabled :: PsErrorDesc

+ GHC.Parser.Errors: PsErrParse :: !String -> PsErrorDesc

+ GHC.Parser.Errors: PsErrParseErrorInCmd :: !SDoc -> PsErrorDesc

+ GHC.Parser.Errors: PsErrParseErrorInPat :: !SDoc -> PsErrorDesc

+ GHC.Parser.Errors: PsErrParseErrorOnInput :: !OccName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrPrecedenceOutOfRange :: !Int -> PsErrorDesc

+ GHC.Parser.Errors: PsErrPrimStringInvalidChar :: PsErrorDesc

+ GHC.Parser.Errors: PsErrProcInFunAppExpr :: !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrQualifiedDoInCmd :: !ModuleName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrRecordSyntaxInPatSynDecl :: !LPat GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrSemiColonsInCondCmd :: !HsExpr GhcPs -> !Bool -> !HsCmd GhcPs -> !Bool -> !HsCmd GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrSemiColonsInCondExpr :: !HsExpr GhcPs -> !Bool -> !HsExpr GhcPs -> !Bool -> !HsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrSpaceInSCC :: PsErrorDesc

+ GHC.Parser.Errors: PsErrSuffixAT :: PsErrorDesc

+ GHC.Parser.Errors: PsErrTupleSectionInPat :: PsErrorDesc

+ GHC.Parser.Errors: PsErrTypeAppWithoutSpace :: !RdrName -> !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnallowedPragma :: !HsPragE GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnexpectedKindAppInDataCon :: !DataConBuilder -> !HsType GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnexpectedQualifiedConstructor :: !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnexpectedTypeAppInDecl :: !LHsType GhcPs -> !SDoc -> !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnexpectedTypeInDecl :: !LHsType GhcPs -> !SDoc -> !RdrName -> [LHsTypeArg GhcPs] -> !SDoc -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnpackDataCon :: PsErrorDesc

+ GHC.Parser.Errors: PsErrUnsupportedBoxedSumExpr :: !SumOrTuple (HsExpr GhcPs) -> PsErrorDesc

+ GHC.Parser.Errors: PsErrUnsupportedBoxedSumPat :: !SumOrTuple (PatBuilder GhcPs) -> PsErrorDesc

+ GHC.Parser.Errors: PsErrVarForTyCon :: !RdrName -> PsErrorDesc

+ GHC.Parser.Errors: PsErrViewPatInExpr :: !LHsExpr GhcPs -> !LHsExpr GhcPs -> PsErrorDesc

+ GHC.Parser.Errors: PsError :: !PsErrorDesc -> ![Hint] -> !SrcSpan -> PsError

+ GHC.Parser.Errors: PsWarnHaddockIgnoreMulti :: !SrcSpan -> PsWarning

+ GHC.Parser.Errors: PsWarnHaddockInvalidPos :: !SrcSpan -> PsWarning

+ GHC.Parser.Errors: PsWarnImportPreQualified :: !SrcSpan -> PsWarning

+ GHC.Parser.Errors: PsWarnOperatorWhitespace :: !SrcSpan -> !FastString -> !OperatorWhitespaceOccurrence -> PsWarning

+ GHC.Parser.Errors: PsWarnOperatorWhitespaceExtConflict :: !SrcSpan -> !OperatorWhitespaceSymbol -> PsWarning

+ GHC.Parser.Errors: PsWarnStarBinder :: !SrcSpan -> PsWarning

+ GHC.Parser.Errors: PsWarnStarIsType :: !SrcSpan -> PsWarning

+ GHC.Parser.Errors: PsWarnTab :: !SrcSpan -> !Word -> PsWarning

+ GHC.Parser.Errors: PsWarnTransitionalLayout :: !SrcSpan -> !TransLayoutReason -> PsWarning

+ GHC.Parser.Errors: PsWarnUnrecognisedPragma :: !SrcSpan -> PsWarning

+ GHC.Parser.Errors: StarIsType :: Bool -> StarIsType

+ GHC.Parser.Errors: SuggestDo :: Hint

+ GHC.Parser.Errors: SuggestInfixBindMaybeAtPat :: !RdrName -> Hint

+ GHC.Parser.Errors: SuggestLetInDo :: Hint

+ GHC.Parser.Errors: SuggestMissingDo :: Hint

+ GHC.Parser.Errors: SuggestPatternSynonyms :: Hint

+ GHC.Parser.Errors: SuggestRecursiveDo :: Hint

+ GHC.Parser.Errors: SuggestTH :: Hint

+ GHC.Parser.Errors: TransLayout_Pipe :: TransLayoutReason

+ GHC.Parser.Errors: TransLayout_Where :: TransLayoutReason

+ GHC.Parser.Errors: TypeApplicationsInPatternsOnlyDataCons :: Hint

+ GHC.Parser.Errors: [errDesc] :: PsError -> !PsErrorDesc

+ GHC.Parser.Errors: [errHints] :: PsError -> ![Hint]

+ GHC.Parser.Errors: [errLoc] :: PsError -> !SrcSpan

+ GHC.Parser.Errors: [tabCount] :: PsWarning -> !Word

+ GHC.Parser.Errors: [tabFirst] :: PsWarning -> !SrcSpan

+ GHC.Parser.Errors: data CmmParserError

+ GHC.Parser.Errors: data Hint

+ GHC.Parser.Errors: data LexErr

+ GHC.Parser.Errors: data LexErrKind

+ GHC.Parser.Errors: data NumUnderscoreReason

+ GHC.Parser.Errors: data OperatorWhitespaceOccurrence

+ GHC.Parser.Errors: data OperatorWhitespaceSymbol

+ GHC.Parser.Errors: data PsError

+ GHC.Parser.Errors: data PsErrorDesc

+ GHC.Parser.Errors: data PsWarning

+ GHC.Parser.Errors: data TransLayoutReason

+ GHC.Parser.Errors: instance GHC.Classes.Eq GHC.Parser.Errors.LexErrKind

+ GHC.Parser.Errors: instance GHC.Classes.Eq GHC.Parser.Errors.NumUnderscoreReason

+ GHC.Parser.Errors: instance GHC.Classes.Ord GHC.Parser.Errors.LexErrKind

+ GHC.Parser.Errors: instance GHC.Classes.Ord GHC.Parser.Errors.NumUnderscoreReason

+ GHC.Parser.Errors: instance GHC.Show.Show GHC.Parser.Errors.LexErrKind

+ GHC.Parser.Errors: instance GHC.Show.Show GHC.Parser.Errors.NumUnderscoreReason

+ GHC.Parser.Errors: newtype StarIsType

+ GHC.Parser.Errors.Ppr: pprError :: PsError -> MsgEnvelope DecoratedSDoc

+ GHC.Parser.Errors.Ppr: pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc

+ GHC.Parser.Lexer: ITproj :: Bool -> Token

+ GHC.Parser.Lexer: OverloadedRecordDotBit :: ExtBits

+ GHC.Parser.Lexer: OverloadedRecordUpdateBit :: ExtBits

+ GHC.Parser.Lexer: ParserOpts :: EnumSet WarningFlag -> !ExtsBitmap -> ParserOpts

+ GHC.Parser.Lexer: [errors] :: PState -> Bag PsError

+ GHC.Parser.Lexer: [header_comments] :: PState -> Maybe [LEpaComment]

+ GHC.Parser.Lexer: [prev_loc2] :: PState -> PsSpan

+ GHC.Parser.Lexer: [prev_loc] :: PState -> PsSpan

+ GHC.Parser.Lexer: [warnings] :: PState -> Bag PsWarning

+ GHC.Parser.Lexer: allocateCommentsP :: MonadP m => RealSrcSpan -> m EpAnnComments

+ GHC.Parser.Lexer: allocateFinalComments :: RealSrcSpan -> [LEpaComment] -> Maybe [LEpaComment] -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])

+ GHC.Parser.Lexer: allocateFinalCommentsP :: MonadP m => RealSrcSpan -> m EpAnnComments

+ GHC.Parser.Lexer: allocatePriorComments :: RealSrcSpan -> [LEpaComment] -> Maybe [LEpaComment] -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])

+ GHC.Parser.Lexer: allocatePriorCommentsP :: MonadP m => RealSrcSpan -> m EpAnnComments

+ GHC.Parser.Lexer: data ParserOpts

+ GHC.Parser.Lexer: getCommentsFor :: MonadP m => SrcSpan -> m EpAnnComments

+ GHC.Parser.Lexer: getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan))

+ GHC.Parser.Lexer: getFinalCommentsFor :: MonadP m => SrcSpan -> m EpAnnComments

+ GHC.Parser.Lexer: getPriorCommentsFor :: MonadP m => SrcSpan -> m EpAnnComments

+ GHC.Parser.Lexer: initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState

+ GHC.Parser.Lexer: initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState

+ GHC.Parser.Lexer: mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)

+ GHC.Parser.Lexer: mkParserOpts :: EnumSet WarningFlag -> EnumSet Extension -> Bool -> Bool -> Bool -> Bool -> ParserOpts

+ GHC.Parser.Lexer: warnopt :: WarningFlag -> ParserOpts -> Bool

+ GHC.Parser.Lexer: xset :: ExtBits -> ExtsBitmap -> ExtsBitmap

+ GHC.Parser.Lexer: xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap

+ GHC.Parser.PostProcess: UnpackednessPragma :: [AddEpAnn] -> SourceText -> SrcUnpackedness -> UnpackednessPragma

+ GHC.Parser.PostProcess: [unECP] :: ECP -> forall b. DisambECP b => PV (LocatedA b)

+ GHC.Parser.PostProcess: addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)

+ GHC.Parser.PostProcess: annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs -> (HsLocalBinds GhcPs, Maybe EpAnnComments)

+ GHC.Parser.PostProcess: checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)

+ GHC.Parser.PostProcess: class DisambTD b

+ GHC.Parser.PostProcess: data UnpackednessPragma

+ GHC.Parser.PostProcess: dataConBuilderCon :: DataConBuilder -> LocatedN RdrName

+ GHC.Parser.PostProcess: dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs

+ GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambECP (GHC.Parser.Types.PatBuilder GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambECP (Language.Haskell.Syntax.Expr.HsCmd GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambECP (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambInfixOp (Language.Haskell.Syntax.Expr.HsExpr GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambTD (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess: instance GHC.Parser.PostProcess.DisambTD GHC.Parser.Types.DataConBuilder

+ GHC.Parser.PostProcess: mkHsAppKindTyPV :: DisambTD b => LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)

+ GHC.Parser.PostProcess: mkHsAppTyHeadPV :: DisambTD b => LHsType GhcPs -> PV (LocatedA b)

+ GHC.Parser.PostProcess: mkHsAppTyPV :: DisambTD b => LocatedA b -> LHsType GhcPs -> PV (LocatedA b)

+ GHC.Parser.PostProcess: mkHsOpTyPV :: DisambTD b => LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)

+ GHC.Parser.PostProcess: mkHsProjUpdatePV :: DisambECP b => SrcSpan -> Located [Located (HsFieldLabel GhcPs)] -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))

+ GHC.Parser.PostProcess: mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs) -> EpAnnCO -> LHsExpr GhcPs

+ GHC.Parser.PostProcess: mkRdrProjection :: NonEmpty (Located (HsFieldLabel GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs

+ GHC.Parser.PostProcess: mkUnpackednessPV :: DisambTD b => Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)

+ GHC.Parser.PostProcess: type Body b :: Type -> Type;

+ GHC.Parser.PostProcess: type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))

+ GHC.Parser.PostProcess: type FunArg b;

+ GHC.Parser.PostProcess: type InfixOp b;

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedA (GHC.Hs.ImpExp.IE GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.ConDecl GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Decls.HsDecl GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsSigType GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedA (Language.Haskell.Syntax.Type.HsType GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedC (Language.Haskell.Syntax.Decls.DerivClauseTys GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Parser.Annotation.LocatedL [GHC.Parser.Annotation.LocatedA (GHC.Hs.ImpExp.IE GHC.Hs.Extension.GhcPs)])

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcPs))

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (GHC.Types.SrcLoc.Located [GHC.Types.SrcLoc.Located (Language.Haskell.Syntax.Decls.HsDerivingClause GHC.Hs.Extension.GhcPs)])

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (Language.Haskell.Syntax.Decls.HsDataDefn GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock (Language.Haskell.Syntax.Decls.HsDecl GHC.Hs.Extension.GhcPs)

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock a => GHC.Parser.PostProcess.Haddock.HasHaddock (Language.Haskell.Syntax.Type.HsScaled GHC.Hs.Extension.GhcPs a)

+ GHC.Parser.PostProcess.Haddock: instance GHC.Parser.PostProcess.Haddock.HasHaddock a => GHC.Parser.PostProcess.Haddock.HasHaddock (Language.Haskell.Syntax.Type.HsWildCardBndrs GHC.Hs.Extension.GhcPs a)

+ GHC.Parser.Types: InfixDataConBuilder :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> DataConBuilder

+ GHC.Parser.Types: PatBuilderApp :: LocatedA (PatBuilder p) -> LocatedA (PatBuilder p) -> PatBuilder p

+ GHC.Parser.Types: PatBuilderAppType :: LocatedA (PatBuilder p) -> HsPatSigType GhcPs -> PatBuilder p

+ GHC.Parser.Types: PatBuilderOpApp :: LocatedA (PatBuilder p) -> LocatedN RdrName -> LocatedA (PatBuilder p) -> EpAnn [AddEpAnn] -> PatBuilder p

+ GHC.Parser.Types: PatBuilderOverLit :: HsOverLit GhcPs -> PatBuilder p

+ GHC.Parser.Types: PatBuilderPar :: LocatedA (PatBuilder p) -> AnnParen -> PatBuilder p

+ GHC.Parser.Types: PatBuilderPat :: Pat p -> PatBuilder p

+ GHC.Parser.Types: PatBuilderVar :: LocatedN RdrName -> PatBuilder p

+ GHC.Parser.Types: PrefixDataConBuilder :: OrdList (LHsType GhcPs) -> LocatedN RdrName -> DataConBuilder

+ GHC.Parser.Types: Sum :: ConTag -> Arity -> LocatedA b -> [EpaLocation] -> [EpaLocation] -> SumOrTuple b

+ GHC.Parser.Types: Tuple :: [Either (EpAnn EpaLocation) (LocatedA b)] -> SumOrTuple b

+ GHC.Parser.Types: data DataConBuilder

+ GHC.Parser.Types: data PatBuilder p

+ GHC.Parser.Types: data SumOrTuple b

+ GHC.Parser.Types: instance GHC.Utils.Outputable.Outputable (GHC.Parser.Types.PatBuilder GHC.Hs.Extension.GhcPs)

+ GHC.Parser.Types: instance GHC.Utils.Outputable.Outputable GHC.Parser.Types.DataConBuilder

+ GHC.Parser.Types: pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc

+ GHC.Parser.Utils: hasImport :: ParserOpts -> String -> Bool

+ GHC.Parser.Utils: isDecl :: ParserOpts -> String -> Bool

+ GHC.Parser.Utils: isImport :: ParserOpts -> String -> Bool

+ GHC.Parser.Utils: isStmt :: ParserOpts -> String -> Bool

+ GHC.Platform: ARMv5 :: ArmISA

+ GHC.Platform: ARMv6 :: ArmISA

+ GHC.Platform: ARMv7 :: ArmISA

+ GHC.Platform: ArchAArch64 :: Arch

+ GHC.Platform: ArchARM :: ArmISA -> [ArmISAExt] -> ArmABI -> Arch

+ GHC.Platform: ArchAlpha :: Arch

+ GHC.Platform: ArchJavaScript :: Arch

+ GHC.Platform: ArchMipseb :: Arch

+ GHC.Platform: ArchMipsel :: Arch

+ GHC.Platform: ArchOS :: Arch -> OS -> ArchOS

+ GHC.Platform: ArchPPC :: Arch

+ GHC.Platform: ArchPPC_64 :: PPC_64ABI -> Arch

+ GHC.Platform: ArchRISCV64 :: Arch

+ GHC.Platform: ArchS390X :: Arch

+ GHC.Platform: ArchSPARC :: Arch

+ GHC.Platform: ArchSPARC64 :: Arch

+ GHC.Platform: ArchUnknown :: Arch

+ GHC.Platform: ArchX86 :: Arch

+ GHC.Platform: ArchX86_64 :: Arch

+ GHC.Platform: BMI1 :: BmiVersion

+ GHC.Platform: BMI2 :: BmiVersion

+ GHC.Platform: BigEndian :: ByteOrder

+ GHC.Platform: ELF_V1 :: PPC_64ABI

+ GHC.Platform: ELF_V2 :: PPC_64ABI

+ GHC.Platform: HARD :: ArmABI

+ GHC.Platform: IWMMX2 :: ArmISAExt

+ GHC.Platform: LittleEndian :: ByteOrder

+ GHC.Platform: NEON :: ArmISAExt

+ GHC.Platform: OSAIX :: OS

+ GHC.Platform: OSDarwin :: OS

+ GHC.Platform: OSDragonFly :: OS

+ GHC.Platform: OSFreeBSD :: OS

+ GHC.Platform: OSHaiku :: OS

+ GHC.Platform: OSHurd :: OS

+ GHC.Platform: OSKFreeBSD :: OS

+ GHC.Platform: OSLinux :: OS

+ GHC.Platform: OSMinGW32 :: OS

+ GHC.Platform: OSNetBSD :: OS

+ GHC.Platform: OSOpenBSD :: OS

+ GHC.Platform: OSQNXNTO :: OS

+ GHC.Platform: OSSolaris2 :: OS

+ GHC.Platform: OSUnknown :: OS

+ GHC.Platform: PW4 :: PlatformWordSize

+ GHC.Platform: PW8 :: PlatformWordSize

+ GHC.Platform: Platform :: !ArchOS -> !PlatformWordSize -> !ByteOrder -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Maybe PlatformConstants -> Platform

+ GHC.Platform: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> PlatformConstants

+ GHC.Platform: PlatformMisc :: String -> Bool -> Bool -> String -> Bool -> Bool -> String -> PlatformMisc

+ GHC.Platform: SOFT :: ArmABI

+ GHC.Platform: SOFTFP :: ArmABI

+ GHC.Platform: SSE1 :: SseVersion

+ GHC.Platform: SSE2 :: SseVersion

+ GHC.Platform: SSE3 :: SseVersion

+ GHC.Platform: SSE4 :: SseVersion

+ GHC.Platform: SSE42 :: SseVersion

+ GHC.Platform: VFPv2 :: ArmISAExt

+ GHC.Platform: VFPv3 :: ArmISAExt

+ GHC.Platform: VFPv3D16 :: ArmISAExt

+ GHC.Platform: [archOS_OS] :: ArchOS -> OS

+ GHC.Platform: [archOS_arch] :: ArchOS -> Arch

+ GHC.Platform: [pc_AP_STACK_SPLIM] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_BITMAP_BITS_SHIFT] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_BLOCKS_PER_MBLOCK] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_BLOCK_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_CINT_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_CLONG_LONG_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_CLONG_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_CONTROL_GROUP_CONST_291] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_ILDV_CREATE_MASK] :: PlatformConstants -> !Integer

+ GHC.Platform: [pc_ILDV_STATE_CREATE] :: PlatformConstants -> !Integer

+ GHC.Platform: [pc_ILDV_STATE_USE] :: PlatformConstants -> !Integer

+ GHC.Platform: [pc_LDV_SHIFT] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_CHARLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Double_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Float_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_INTLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Long_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Real_Double_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Real_Float_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Real_Long_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Real_Vanilla_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Real_XMM_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_SPEC_AP_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_SPEC_SELECTEE_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_Vanilla_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MAX_XMM_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MIN_CHARLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MIN_INTLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MIN_PAYLOAD_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_MUT_ARR_PTRS_CARD_BITS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_Capability_r] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_CostCentreStack_mem_alloc] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_CostCentreStack_scc_count] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgArrBytes_bytes] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgEntCounter_allocd] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgEntCounter_allocs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgEntCounter_entry_count] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgEntCounter_link] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgEntCounter_registeredp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgFunInfoExtraFwd_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgFunInfoExtraRev_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgHeader_ccs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgHeader_ldvw] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgMutArrPtrs_ptrs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgMutArrPtrs_size] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rCCCS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rCurrentNursery] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rCurrentTSO] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rD1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rD2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rD3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rD4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rD5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rD6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rF1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rF2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rF3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rF4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rF5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rF6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rHpAlloc] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rHpLim] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rHp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rL1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR10] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR7] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR8] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rR9] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rSpLim] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rSp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rXMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rXMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rXMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rXMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rXMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rXMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rYMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rYMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rYMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rYMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rYMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rYMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rZMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rZMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rZMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rZMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rZMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgRegTable_rZMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgSmallMutArrPtrs_ptrs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgStack_sp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgStack_stack] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgTSO_alloc_limit] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgTSO_cccs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgTSO_stackobj] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_StgUpdateFrame_updatee] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_bdescr_blocks] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_bdescr_flags] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_bdescr_free] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_bdescr_start] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_stgEagerBlackholeInfo] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_stgGCEnter1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_OFFSET_stgGCFun] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_PROF_HDR_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_REP_CostCentreStack_mem_alloc] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_REP_CostCentreStack_scc_count] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_REP_StgEntCounter_allocd] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_REP_StgEntCounter_allocs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_REP_StgFunInfoExtraFwd_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_REP_StgFunInfoExtraRev_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_RESERVED_C_STACK_BYTES] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_RESERVED_STACK_WORDS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_CostCentreStack] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_StgArrBytes_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_StgFunInfoExtraRev] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_StgMutArrPtrs_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_StgSMPThunkHeader] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_StgSmallMutArrPtrs_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_SIZEOF_StgUpdateFrame_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_STD_HDR_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_TAG_BITS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_TICKY_BIN_COUNT] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [pc_WORD_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform: [platformArchOS] :: Platform -> !ArchOS

+ GHC.Platform: [platformByteOrder] :: Platform -> !ByteOrder

+ GHC.Platform: [platformHasGnuNonexecStack] :: Platform -> !Bool

+ GHC.Platform: [platformHasIdentDirective] :: Platform -> !Bool

+ GHC.Platform: [platformHasSubsectionsViaSymbols] :: Platform -> !Bool

+ GHC.Platform: [platformIsCrossCompiling] :: Platform -> !Bool

+ GHC.Platform: [platformLeadingUnderscore] :: Platform -> !Bool

+ GHC.Platform: [platformMisc_ghcRTSWays] :: PlatformMisc -> String

+ GHC.Platform: [platformMisc_ghcRtsWithLibdw] :: PlatformMisc -> Bool

+ GHC.Platform: [platformMisc_ghcWithInterpreter] :: PlatformMisc -> Bool

+ GHC.Platform: [platformMisc_ghcWithSMP] :: PlatformMisc -> Bool

+ GHC.Platform: [platformMisc_libFFI] :: PlatformMisc -> Bool

+ GHC.Platform: [platformMisc_llvmTarget] :: PlatformMisc -> String

+ GHC.Platform: [platformMisc_targetPlatformString] :: PlatformMisc -> String

+ GHC.Platform: [platformTablesNextToCode] :: Platform -> !Bool

+ GHC.Platform: [platformUnregisterised] :: Platform -> !Bool

+ GHC.Platform: [platformWordSize] :: Platform -> !PlatformWordSize

+ GHC.Platform: [platform_constants] :: Platform -> !Maybe PlatformConstants

+ GHC.Platform: data Arch

+ GHC.Platform: data ArchOS

+ GHC.Platform: data ArmABI

+ GHC.Platform: data ArmISA

+ GHC.Platform: data ArmISAExt

+ GHC.Platform: data BmiVersion

+ GHC.Platform: data ByteOrder

+ GHC.Platform: data OS

+ GHC.Platform: data PPC_64ABI

+ GHC.Platform: data Platform

+ GHC.Platform: data PlatformConstants

+ GHC.Platform: data PlatformMisc

+ GHC.Platform: data PlatformWordSize

+ GHC.Platform: data SseVersion

+ GHC.Platform: genericPlatform :: Platform

+ GHC.Platform: instance GHC.Classes.Eq GHC.Platform.BmiVersion

+ GHC.Platform: instance GHC.Classes.Eq GHC.Platform.Platform

+ GHC.Platform: instance GHC.Classes.Eq GHC.Platform.PlatformWordSize

+ GHC.Platform: instance GHC.Classes.Eq GHC.Platform.SseVersion

+ GHC.Platform: instance GHC.Classes.Ord GHC.Platform.BmiVersion

+ GHC.Platform: instance GHC.Classes.Ord GHC.Platform.PlatformWordSize

+ GHC.Platform: instance GHC.Classes.Ord GHC.Platform.SseVersion

+ GHC.Platform: instance GHC.Read.Read GHC.Platform.Platform

+ GHC.Platform: instance GHC.Read.Read GHC.Platform.PlatformWordSize

+ GHC.Platform: instance GHC.Show.Show GHC.Platform.Platform

+ GHC.Platform: instance GHC.Show.Show GHC.Platform.PlatformWordSize

+ GHC.Platform: isARM :: Arch -> Bool

+ GHC.Platform: lookupPlatformConstants :: [FilePath] -> IO (Maybe PlatformConstants)

+ GHC.Platform: osElfTarget :: OS -> Bool

+ GHC.Platform: osMachOTarget :: OS -> Bool

+ GHC.Platform: osSubsectionsViaSymbols :: OS -> Bool

+ GHC.Platform: platformArch :: Platform -> Arch

+ GHC.Platform: platformCConvNeedsExtension :: Platform -> Bool

+ GHC.Platform: platformConstants :: Platform -> PlatformConstants

+ GHC.Platform: platformHsSOName :: Platform -> FilePath -> FilePath

+ GHC.Platform: platformInIntRange :: Platform -> Integer -> Bool

+ GHC.Platform: platformInWordRange :: Platform -> Integer -> Bool

+ GHC.Platform: platformMaxInt :: Platform -> Integer

+ GHC.Platform: platformMaxWord :: Platform -> Integer

+ GHC.Platform: platformMinInt :: Platform -> Integer

+ GHC.Platform: platformOS :: Platform -> OS

+ GHC.Platform: platformSOExt :: Platform -> FilePath

+ GHC.Platform: platformSOName :: Platform -> FilePath -> FilePath

+ GHC.Platform: platformUsesFrameworks :: Platform -> Bool

+ GHC.Platform: platformWordSizeInBits :: Platform -> Int

+ GHC.Platform: platformWordSizeInBytes :: Platform -> Int

+ GHC.Platform: target32Bit :: Platform -> Bool

+ GHC.Platform.Constants: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> PlatformConstants

+ GHC.Platform.Constants: [pc_AP_STACK_SPLIM] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_BITMAP_BITS_SHIFT] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_BLOCKS_PER_MBLOCK] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_BLOCK_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_CINT_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_CLONG_LONG_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_CLONG_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_CONTROL_GROUP_CONST_291] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_ILDV_CREATE_MASK] :: PlatformConstants -> !Integer

+ GHC.Platform.Constants: [pc_ILDV_STATE_CREATE] :: PlatformConstants -> !Integer

+ GHC.Platform.Constants: [pc_ILDV_STATE_USE] :: PlatformConstants -> !Integer

+ GHC.Platform.Constants: [pc_LDV_SHIFT] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_CHARLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Double_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Float_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_INTLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Long_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Real_Double_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Real_Float_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Real_Long_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Real_Vanilla_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Real_XMM_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_SPEC_AP_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_SPEC_SELECTEE_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_Vanilla_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MAX_XMM_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MIN_CHARLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MIN_INTLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MIN_PAYLOAD_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_MUT_ARR_PTRS_CARD_BITS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_Capability_r] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_CostCentreStack_mem_alloc] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_CostCentreStack_scc_count] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgArrBytes_bytes] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgEntCounter_allocd] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgEntCounter_allocs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgEntCounter_entry_count] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgEntCounter_link] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgEntCounter_registeredp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgFunInfoExtraFwd_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgFunInfoExtraRev_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgHeader_ccs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgHeader_ldvw] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgMutArrPtrs_ptrs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgMutArrPtrs_size] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rCCCS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rCurrentNursery] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rCurrentTSO] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rD1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rD2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rD3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rD4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rD5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rD6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rF1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rF2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rF3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rF4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rF5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rF6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rHpAlloc] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rHpLim] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rHp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rL1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR10] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR7] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR8] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rR9] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rSpLim] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rSp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rXMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rXMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rXMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rXMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rXMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rXMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rYMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rYMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rYMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rYMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rYMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rYMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rZMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rZMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rZMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rZMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rZMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgRegTable_rZMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgSmallMutArrPtrs_ptrs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgStack_sp] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgStack_stack] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgTSO_alloc_limit] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgTSO_cccs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgTSO_stackobj] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_StgUpdateFrame_updatee] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_bdescr_blocks] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_bdescr_flags] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_bdescr_free] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_bdescr_start] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_stgEagerBlackholeInfo] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_stgGCEnter1] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_OFFSET_stgGCFun] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_PROF_HDR_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_REP_CostCentreStack_mem_alloc] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_REP_CostCentreStack_scc_count] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_REP_StgEntCounter_allocd] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_REP_StgEntCounter_allocs] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_REP_StgFunInfoExtraFwd_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_REP_StgFunInfoExtraRev_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_RESERVED_C_STACK_BYTES] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_RESERVED_STACK_WORDS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_CostCentreStack] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_StgArrBytes_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_StgFunInfoExtraRev] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_StgMutArrPtrs_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_StgSMPThunkHeader] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_StgSmallMutArrPtrs_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_SIZEOF_StgUpdateFrame_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_STD_HDR_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_TAG_BITS] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_TICKY_BIN_COUNT] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: [pc_WORD_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

+ GHC.Platform.Constants: data PlatformConstants

+ GHC.Platform.Constants: instance GHC.Classes.Eq GHC.Platform.Constants.PlatformConstants

+ GHC.Platform.Constants: instance GHC.Read.Read GHC.Platform.Constants.PlatformConstants

+ GHC.Platform.Constants: instance GHC.Show.Show GHC.Platform.Constants.PlatformConstants

+ GHC.Platform.Constants: parseConstantsHeader :: FilePath -> IO PlatformConstants

+ GHC.Platform.Profile: Profile :: !Platform -> !Ways -> Profile

+ GHC.Platform.Profile: [profilePlatform] :: Profile -> !Platform

+ GHC.Platform.Profile: [profileWays] :: Profile -> !Ways

+ GHC.Platform.Profile: data Profile

+ GHC.Platform.Profile: profileBuildTag :: Profile -> String

+ GHC.Platform.Profile: profileConstants :: Profile -> PlatformConstants

+ GHC.Platform.Profile: profileIsProfiling :: Profile -> Bool

+ GHC.Platform.Profile: profileWordSizeInBytes :: Profile -> Int

+ GHC.Platform.RISCV64: activeStgRegs :: [GlobalReg]

+ GHC.Platform.RISCV64: callerSaves :: GlobalReg -> Bool

+ GHC.Platform.RISCV64: freeReg :: RegNo -> Bool

+ GHC.Platform.RISCV64: globalRegMaybe :: GlobalReg -> Maybe RealReg

+ GHC.Platform.RISCV64: haveRegBase :: Bool

+ GHC.Platform.Reg: instance GHC.Show.Show GHC.Platform.Reg.Reg

+ GHC.Platform.Ways: WayCustom :: String -> Way

+ GHC.Platform.Ways: WayDebug :: Way

+ GHC.Platform.Ways: WayDyn :: Way

+ GHC.Platform.Ways: WayProf :: Way

+ GHC.Platform.Ways: WayThreaded :: Way

+ GHC.Platform.Ways: WayTracing :: Way

+ GHC.Platform.Ways: addWay :: Way -> Ways -> Ways

+ GHC.Platform.Ways: allowed_combination :: Ways -> Bool

+ GHC.Platform.Ways: data Way

+ GHC.Platform.Ways: fullWays :: Ways -> Ways

+ GHC.Platform.Ways: hasWay :: Ways -> Way -> Bool

+ GHC.Platform.Ways: hostFullWays :: Ways

+ GHC.Platform.Ways: hostIsDebugged :: Bool

+ GHC.Platform.Ways: hostIsDynamic :: Bool

+ GHC.Platform.Ways: hostIsProfiled :: Bool

+ GHC.Platform.Ways: hostIsThreaded :: Bool

+ GHC.Platform.Ways: hostIsTracing :: Bool

+ GHC.Platform.Ways: hostWays :: Ways

+ GHC.Platform.Ways: instance GHC.Classes.Eq GHC.Platform.Ways.Way

+ GHC.Platform.Ways: instance GHC.Classes.Ord GHC.Platform.Ways.Way

+ GHC.Platform.Ways: instance GHC.Show.Show GHC.Platform.Ways.Way

+ GHC.Platform.Ways: rtsWays :: Ways -> Ways

+ GHC.Platform.Ways: type Ways = Set Way

+ GHC.Platform.Ways: wayDesc :: Way -> String

+ GHC.Platform.Ways: wayGeneralFlags :: Platform -> Way -> [GeneralFlag]

+ GHC.Platform.Ways: wayOptP :: Platform -> Way -> [String]

+ GHC.Platform.Ways: wayOptc :: Platform -> Way -> [String]

+ GHC.Platform.Ways: wayOptl :: Platform -> Way -> [String]

+ GHC.Platform.Ways: wayRTSOnly :: Way -> Bool

+ GHC.Platform.Ways: wayTag :: Way -> String

+ GHC.Platform.Ways: wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]

+ GHC.Platform.Ways: waysBuildTag :: Ways -> String

+ GHC.Platform.Ways: waysTag :: Ways -> String

+ GHC.Plugins: anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool

+ GHC.Plugins: anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool

+ GHC.Plugins: anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool

+ GHC.Plugins: coercionHolesOfCo :: Coercion -> UniqSet CoercionHole

+ GHC.Plugins: coercionHolesOfType :: Type -> UniqSet CoercionHole

+ GHC.Plugins: hasCoercionHoleCo :: Coercion -> Bool

+ GHC.Plugins: hasCoercionHoleTy :: Type -> Bool

+ GHC.Plugins: instance GHC.Types.TyThing.MonadThings GHC.Core.Opt.Monad.CoreM

+ GHC.Plugins: isBoxedRuntimeRep :: Type -> Bool

+ GHC.Plugins: isBoxedType :: Type -> Bool

+ GHC.Plugins: isBoxedTypeKind :: Kind -> Bool

+ GHC.Plugins: isCharLitTy :: Type -> Maybe Char

+ GHC.Plugins: isLevityTy :: Type -> Bool

+ GHC.Plugins: isLevityVar :: TyVar -> Bool

+ GHC.Plugins: isLiftedLevity :: Type -> Bool

+ GHC.Plugins: isReflMCo :: MCoercion -> Bool

+ GHC.Plugins: isUnliftedLevity :: Type -> Bool

+ GHC.Plugins: mkCastTyMCo :: Type -> MCoercion -> Type

+ GHC.Plugins: mkCharLitTy :: Char -> Type

+ GHC.Plugins: mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion

+ GHC.Plugins: mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type

+ GHC.Plugins: mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion

+ GHC.Plugins: mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion

+ GHC.Plugins: mkNthCoFunCo :: Int -> CoercionN -> Coercion -> Coercion -> Coercion

+ GHC.Plugins: mkSymMCo :: MCoercion -> MCoercion

+ GHC.Plugins: mkTransMCoL :: MCoercion -> Coercion -> MCoercion

+ GHC.Plugins: pickyIsLiftedTypeKind :: Kind -> Bool

+ GHC.Plugins: promoteOccName :: OccName -> Maybe OccName

+ GHC.Plugins: recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent

+ GHC.Plugins: splitForAllCoVar_maybe :: Type -> Maybe (TyCoVar, Type)

+ GHC.Plugins: splitForAllInvisTVBinders :: Type -> ([InvisTVBinder], Type)

+ GHC.Plugins: splitForAllReqTVBinders :: Type -> ([ReqTVBinder], Type)

+ GHC.Plugins: splitForAllTyCoVar :: Type -> (TyCoVar, Type)

+ GHC.Plugins: splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type)

+ GHC.Plugins: splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)

+ GHC.Plugins: splitForAllTyCoVars :: Type -> ([TyCoVar], Type)

+ GHC.Plugins: splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, Type)

+ GHC.Plugins: splitInvisPiTys :: Type -> ([TyCoBinder], Type)

+ GHC.Plugins: splitInvisPiTysN :: Int -> Type -> ([TyCoBinder], Type)

+ GHC.Plugins: substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo

+ GHC.Plugins: substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder)

+ GHC.Plugins: tYPE :: Type -> Type

+ GHC.Plugins: tcIsBoxedTypeKind :: Kind -> Bool

+ GHC.Plugins: type HoleSet = UniqSet CoercionHole

+ GHC.Plugins: type MCoercionN = MCoercion

+ GHC.Plugins: unliftedTypeKind :: Kind

+ GHC.Prelude: (.&.) :: Bits a => a -> a -> a

+ GHC.Prelude: (.|.) :: Bits a => a -> a -> a

+ GHC.Prelude: bit :: Bits a => Int -> a

+ GHC.Prelude: bitDefault :: (Bits a, Num a) => Int -> a

+ GHC.Prelude: bitSize :: Bits a => a -> Int

+ GHC.Prelude: bitSizeMaybe :: Bits a => a -> Maybe Int

+ GHC.Prelude: class Eq a => Bits a

+ GHC.Prelude: class Bits b => FiniteBits b

+ GHC.Prelude: clearBit :: Bits a => a -> Int -> a

+ GHC.Prelude: complement :: Bits a => a -> a

+ GHC.Prelude: complementBit :: Bits a => a -> Int -> a

+ GHC.Prelude: countLeadingZeros :: FiniteBits b => b -> Int

+ GHC.Prelude: countTrailingZeros :: FiniteBits b => b -> Int

+ GHC.Prelude: finiteBitSize :: FiniteBits b => b -> Int

+ GHC.Prelude: infixl 5 .|.

+ GHC.Prelude: infixl 8 `rotate`

+ GHC.Prelude: isSigned :: Bits a => a -> Bool

+ GHC.Prelude: popCount :: Bits a => a -> Int

+ GHC.Prelude: popCountDefault :: (Bits a, Num a) => a -> Int

+ GHC.Prelude: rotate :: Bits a => a -> Int -> a

+ GHC.Prelude: rotateL :: Bits a => a -> Int -> a

+ GHC.Prelude: rotateR :: Bits a => a -> Int -> a

+ GHC.Prelude: setBit :: Bits a => a -> Int -> a

+ GHC.Prelude: shift :: Bits a => a -> Int -> a

+ GHC.Prelude: shiftL :: Bits a => a -> Int -> a

+ GHC.Prelude: shiftR :: Bits a => a -> Int -> a

+ GHC.Prelude: testBit :: Bits a => a -> Int -> Bool

+ GHC.Prelude: testBitDefault :: (Bits a, Num a) => a -> Int -> Bool

+ GHC.Prelude: toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b

+ GHC.Prelude: unsafeShiftL :: Bits a => a -> Int -> a

+ GHC.Prelude: unsafeShiftR :: Bits a => a -> Int -> a

+ GHC.Prelude: xor :: Bits a => a -> a -> a

+ GHC.Prelude: zeroBits :: Bits a => a

+ GHC.Rename.Env: AmbiguousFields :: AmbiguousResult

+ GHC.Rename.Env: FoundChild :: Parent -> GreName -> ChildLookupResult

+ GHC.Rename.Env: UnambiguousGre :: GreName -> AmbiguousResult

+ GHC.Rename.Env: data AmbiguousResult

+ GHC.Rename.Env: instance GHC.Classes.Eq GHC.Rename.Env.FieldsOrSelectors

+ GHC.Rename.Env: lookupExprOccRn :: DuplicateRecordFields -> RdrName -> RnM (Maybe AmbiguousResult)

+ GHC.Rename.Env: lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)

+ GHC.Rename.Env: lookupRecFieldOcc_update :: DuplicateRecordFields -> RdrName -> RnM AmbiguousResult

+ GHC.Rename.Env: lookupSigCtxtOccRnN :: HsSigCtxt -> SDoc -> LocatedN RdrName -> RnM (LocatedN Name)

+ GHC.Rename.Env: lookupSigOccRnN :: HsSigCtxt -> Sig GhcPs -> LocatedN RdrName -> RnM (LocatedN Name)

+ GHC.Rename.Expr: type AnnoBody body = (Outputable (body GhcPs), Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA, Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA)

+ GHC.Rename.HsType: bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed => HsDocContext -> Maybe assoc -> FreeKiTyVars -> HsOuterTyVarBndrs flag GhcPs -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars)

+ GHC.Rename.HsType: data HsPatSigTypeScoping

+ GHC.Rename.HsType: extractConDeclGADTDetailsTyVars :: HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars

+ GHC.Rename.HsType: extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs -> FreeKiTyVars -> FreeKiTyVars

+ GHC.Rename.HsType: lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn

+ GHC.Rename.HsType: nubN :: Eq a => [LocatedN a] -> [LocatedN a]

+ GHC.Rename.HsType: rnHsPatSigTypeBindingVars :: HsDocContext -> HsPatSigType GhcPs -> (HsPatSigType GhcRn -> RnM (r, FreeVars)) -> RnM (r, FreeVars)

+ GHC.Rename.HsType: rnImplicitTvOccs :: Maybe assoc -> FreeKiTyVars -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars)

+ GHC.Rename.Pat: liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b

+ GHC.Rename.Utils: HsTypePatCtx :: HsDocContext

+ GHC.Rename.Utils: checkCTupSize :: Int -> TcM ()

+ GHC.Rename.Utils: checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()

+ GHC.Runtime.Context: IIDecl :: ImportDecl GhcPs -> InteractiveImport

+ GHC.Runtime.Context: IIModule :: ModuleName -> InteractiveImport

+ GHC.Runtime.Context: InteractiveContext :: DynFlags -> Int -> [InteractiveImport] -> [TyThing] -> GlobalRdrEnv -> ([ClsInst], [FamInst]) -> FixityEnv -> Maybe [Type] -> [Resume] -> Name -> Name -> Maybe FilePath -> ![LoadedPlugin] -> InteractiveContext

+ GHC.Runtime.Context: [ic_cwd] :: InteractiveContext -> Maybe FilePath

+ GHC.Runtime.Context: [ic_default] :: InteractiveContext -> Maybe [Type]

+ GHC.Runtime.Context: [ic_dflags] :: InteractiveContext -> DynFlags

+ GHC.Runtime.Context: [ic_fix_env] :: InteractiveContext -> FixityEnv

+ GHC.Runtime.Context: [ic_imports] :: InteractiveContext -> [InteractiveImport]

+ GHC.Runtime.Context: [ic_instances] :: InteractiveContext -> ([ClsInst], [FamInst])

+ GHC.Runtime.Context: [ic_int_print] :: InteractiveContext -> Name

+ GHC.Runtime.Context: [ic_mod_index] :: InteractiveContext -> Int

+ GHC.Runtime.Context: [ic_monad] :: InteractiveContext -> Name

+ GHC.Runtime.Context: [ic_plugins] :: InteractiveContext -> ![LoadedPlugin]

+ GHC.Runtime.Context: [ic_resume] :: InteractiveContext -> [Resume]

+ GHC.Runtime.Context: [ic_rn_gbl_env] :: InteractiveContext -> GlobalRdrEnv

+ GHC.Runtime.Context: [ic_tythings] :: InteractiveContext -> [TyThing]

+ GHC.Runtime.Context: data InteractiveContext

+ GHC.Runtime.Context: data InteractiveImport

+ GHC.Runtime.Context: emptyInteractiveContext :: DynFlags -> InteractiveContext

+ GHC.Runtime.Context: extendInteractiveContext :: InteractiveContext -> [TyThing] -> [ClsInst] -> [FamInst] -> Maybe [Type] -> FixityEnv -> InteractiveContext

+ GHC.Runtime.Context: extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext

+ GHC.Runtime.Context: icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv

+ GHC.Runtime.Context: icInScopeTTs :: InteractiveContext -> [TyThing]

+ GHC.Runtime.Context: icInteractiveModule :: InteractiveContext -> Module

+ GHC.Runtime.Context: icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified

+ GHC.Runtime.Context: instance GHC.Utils.Outputable.Outputable GHC.Runtime.Context.InteractiveImport

+ GHC.Runtime.Context: setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext

+ GHC.Runtime.Context: substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext

+ GHC.Runtime.Eval: setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m ()

+ GHC.Runtime.Heap.Layout: instance GHC.Bits.Bits GHC.Runtime.Heap.Layout.StgWord

+ GHC.Runtime.Interpreter: [SetupBreakpoint] :: RemoteRef BreakArray -> Int -> Int -> Message ()

+ GHC.Runtime.Interpreter: interpCmd :: Binary a => Interp -> Message a -> IO a

+ GHC.Runtime.Interpreter: storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()

+ GHC.Runtime.Interpreter.Types: Interp :: !InterpInstance -> !Loader -> Interp

+ GHC.Runtime.Interpreter.Types: [interpInstance] :: Interp -> !InterpInstance

+ GHC.Runtime.Interpreter.Types: [interpLoader] :: Interp -> !Loader

+ GHC.Runtime.Interpreter.Types: data InterpInstance

+ GHC.Settings: [platformArchOS] :: Platform -> !ArchOS

+ GHC.Settings: [platform_constants] :: Platform -> !Maybe PlatformConstants

+ GHC.Settings: dynLibSuffix :: GhcNameVersion -> String

+ GHC.Stg.Debug: collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)

+ GHC.Stg.Syntax: NoNumber :: ConstructorNumber

+ GHC.Stg.Syntax: Numbered :: Int -> ConstructorNumber

+ GHC.Stg.Syntax: data ConstructorNumber

+ GHC.Stg.Syntax: freeVarsOfRhs :: XRhsClosure pass ~ DIdSet => GenStgRhs pass -> DIdSet

+ GHC.Stg.Syntax: instance GHC.Utils.Outputable.Outputable GHC.Stg.Syntax.ConstructorNumber

+ GHC.Stg.Syntax: shortStgPprOpts :: StgPprOpts

+ GHC.StgToByteCode: byteCodeGen :: HscEnv -> Module -> [StgTopBinding] -> [TyCon] -> Maybe ModBreaks -> IO CompiledByteCode

+ GHC.StgToByteCode: data UnlinkedBCO

+ GHC.StgToByteCode: instance GHC.Base.Applicative GHC.StgToByteCode.BcM

+ GHC.StgToByteCode: instance GHC.Base.Functor GHC.StgToByteCode.BcM

+ GHC.StgToByteCode: instance GHC.Base.Monad GHC.StgToByteCode.BcM

+ GHC.StgToByteCode: instance GHC.Classes.Eq GHC.StgToByteCode.Discr

+ GHC.StgToByteCode: instance GHC.Classes.Ord GHC.StgToByteCode.Discr

+ GHC.StgToByteCode: instance GHC.Driver.Session.HasDynFlags GHC.StgToByteCode.BcM

+ GHC.StgToByteCode: instance GHC.Utils.Outputable.Outputable GHC.StgToByteCode.Discr

+ GHC.StgToCmm.Closure: CallOpts :: !Profile -> !Bool -> !Bool -> CallOpts

+ GHC.StgToCmm.Closure: [co_loopification] :: CallOpts -> !Bool

+ GHC.StgToCmm.Closure: [co_profile] :: CallOpts -> !Profile

+ GHC.StgToCmm.Closure: [co_ticky] :: CallOpts -> !Bool

+ GHC.StgToCmm.Closure: data CallOpts

+ GHC.StgToCmm.Closure: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.StgToCmm.Closure.CgLoc

+ GHC.StgToCmm.ExtCode: getPlatform :: CmmParse Platform

+ GHC.StgToCmm.ExtCode: getProfile :: CmmParse Profile

+ GHC.StgToCmm.ExtCode: getPtrOpts :: CmmParse PtrOpts

+ GHC.StgToCmm.Foreign: emitPopTupleRegs :: CmmExpr -> FCode ()

+ GHC.StgToCmm.Foreign: emitPushTupleRegs :: CmmExpr -> FCode ()

+ GHC.StgToCmm.Monad: getCallOpts :: FCode CallOpts

+ GHC.StgToCmm.Monad: getProfile :: FCode Profile

+ GHC.StgToCmm.Monad: getPtrOpts :: FCode PtrOpts

+ GHC.StgToCmm.Monad: instance GHC.Utils.Outputable.OutputableP GHC.Platform.Platform GHC.StgToCmm.Monad.CgIdInfo

+ GHC.StgToCmm.Prof: emitInfoTableProv :: InfoProvEnt -> FCode ()

+ GHC.StgToCmm.Prof: initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub

+ GHC.StgToCmm.Types: [cgIPEStub] :: CgInfos -> !CStub

+ GHC.StgToCmm.Utils: cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt

+ GHC.StgToCmm.Utils: convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]

+ GHC.Tc.Deriv.Generate: getPossibleDataCons :: TyCon -> [Type] -> [DataCon]

+ GHC.Tc.Deriv.Generate: tyConInstArgTys :: TyCon -> [Type] -> [Type]

+ GHC.Tc.Gen.App: tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)

+ GHC.Tc.Gen.App: tcExprPrag :: HsPragE GhcRn -> HsPragE GhcTc

+ GHC.Tc.Gen.App: tcInferSigma :: Bool -> LHsExpr GhcRn -> TcM TcSigmaType

+ GHC.Tc.Gen.Expr: tcCheckPolyExprNC :: LHsExpr GhcRn -> TcSigmaType -> TcM (LHsExpr GhcTc)

+ GHC.Tc.Gen.Expr: tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)

+ GHC.Tc.Gen.Head: EPrag :: AppCtxt -> HsPragE (GhcPass (XPass p)) -> HsExprArg (p :: TcPass)

+ GHC.Tc.Gen.Head: ETypeArg :: AppCtxt -> LHsWcType GhcRn -> !XETAType p -> HsExprArg (p :: TcPass)

+ GHC.Tc.Gen.Head: EValArg :: AppCtxt -> EValArg p -> !XEVAType p -> HsExprArg (p :: TcPass)

+ GHC.Tc.Gen.Head: EWrap :: EWrap -> HsExprArg (p :: TcPass)

+ GHC.Tc.Gen.Head: TcpInst :: TcPass

+ GHC.Tc.Gen.Head: TcpRn :: TcPass

+ GHC.Tc.Gen.Head: TcpTc :: TcPass

+ GHC.Tc.Gen.Head: VACall :: HsExpr GhcRn -> Int -> SrcSpan -> AppCtxt

+ GHC.Tc.Gen.Head: VAExpansion :: HsExpr GhcRn -> SrcSpan -> AppCtxt

+ GHC.Tc.Gen.Head: [ValArgQL] :: LHsExpr GhcRn -> (HsExpr GhcTc, AppCtxt) -> [HsExprArg 'TcpInst] -> TcRhoType -> EValArg 'TcpInst

+ GHC.Tc.Gen.Head: [ValArg] :: LHsExpr (GhcPass (XPass p)) -> EValArg p

+ GHC.Tc.Gen.Head: [eva_arg] :: HsExprArg (p :: TcPass) -> EValArg p

+ GHC.Tc.Gen.Head: [eva_arg_ty] :: HsExprArg (p :: TcPass) -> !XEVAType p

+ GHC.Tc.Gen.Head: [eva_ctxt] :: HsExprArg (p :: TcPass) -> AppCtxt

+ GHC.Tc.Gen.Head: [eva_hs_ty] :: HsExprArg (p :: TcPass) -> LHsWcType GhcRn

+ GHC.Tc.Gen.Head: [eva_ty] :: HsExprArg (p :: TcPass) -> !XETAType p

+ GHC.Tc.Gen.Head: addAmbiguousNameErr :: RdrName -> TcM ()

+ GHC.Tc.Gen.Head: addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]

+ GHC.Tc.Gen.Head: addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a

+ GHC.Tc.Gen.Head: addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcType -> ExpRhoType -> TcM a -> TcM a

+ GHC.Tc.Gen.Head: appCtxtLoc :: AppCtxt -> SrcSpan

+ GHC.Tc.Gen.Head: countLeadingValArgs :: [HsExprArg id] -> Int

+ GHC.Tc.Gen.Head: data AppCtxt

+ GHC.Tc.Gen.Head: data EValArg (p :: TcPass)

+ GHC.Tc.Gen.Head: data HsExprArg (p :: TcPass)

+ GHC.Tc.Gen.Head: data TcPass

+ GHC.Tc.Gen.Head: fieldNotInType :: RecSelParent -> RdrName -> SDoc

+ GHC.Tc.Gen.Head: insideExpansion :: AppCtxt -> Bool

+ GHC.Tc.Gen.Head: instance GHC.Hs.Extension.OutputableBndrId (GHC.Tc.Gen.Head.XPass p) => GHC.Utils.Outputable.Outputable (GHC.Tc.Gen.Head.EValArg p)

+ GHC.Tc.Gen.Head: instance GHC.Hs.Extension.OutputableBndrId (GHC.Tc.Gen.Head.XPass p) => GHC.Utils.Outputable.Outputable (GHC.Tc.Gen.Head.HsExprArg p)

+ GHC.Tc.Gen.Head: instance GHC.Utils.Outputable.Outputable GHC.Tc.Gen.Head.AppCtxt

+ GHC.Tc.Gen.Head: instance GHC.Utils.Outputable.Outputable GHC.Tc.Gen.Head.EWrap

+ GHC.Tc.Gen.Head: isHsValArg :: HsExprArg id -> Bool

+ GHC.Tc.Gen.Head: isVisibleArg :: HsExprArg id -> Bool

+ GHC.Tc.Gen.Head: lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]

+ GHC.Tc.Gen.Head: nonBidirectionalErr :: Outputable name => name -> SDoc

+ GHC.Tc.Gen.Head: notSelector :: Name -> SDoc

+ GHC.Tc.Gen.Head: obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)

+ GHC.Tc.Gen.Head: pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc

+ GHC.Tc.Gen.Head: rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc] -> HsExpr GhcTc

+ GHC.Tc.Gen.Head: splitHsApps :: HsExpr GhcRn -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])

+ GHC.Tc.Gen.Head: tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)

+ GHC.Tc.Gen.Head: tcInferAppHead :: (HsExpr GhcRn, AppCtxt) -> [HsExprArg 'TcpRn] -> Maybe TcRhoType -> TcM (HsExpr GhcTc, TcSigmaType)

+ GHC.Tc.Gen.Head: tcInferAppHead_maybe :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> Maybe TcRhoType -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))

+ GHC.Tc.Gen.Head: tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)

+ GHC.Tc.Gen.Head: tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon

+ GHC.Tc.Gen.Head: tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon

+ GHC.Tc.Gen.HsType: HM_FamPat :: HoleMode

+ GHC.Tc.Gen.HsType: HM_Sig :: HoleMode

+ GHC.Tc.Gen.HsType: HM_TyAppPat :: HoleMode

+ GHC.Tc.Gen.HsType: HM_VTA :: HoleMode

+ GHC.Tc.Gen.HsType: bindNamedWildCardBinders :: [Name] -> ([(Name, TcTyVar)] -> TcM a) -> TcM a

+ GHC.Tc.Gen.HsType: bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TcTyVar], a)

+ GHC.Tc.Gen.HsType: bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn -> TcM a -> TcM ([TcTyVar], a)

+ GHC.Tc.Gen.HsType: bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)

+ GHC.Tc.Gen.HsType: data HoleMode

+ GHC.Tc.Gen.HsType: scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]

+ GHC.Tc.Gen.HsType: tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)

+ GHC.Tc.Gen.HsType: tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed => SkolemInfo -> HsOuterTyVarBndrs flag GhcRn -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)

+ GHC.Tc.Gen.Sig: isCompleteHsSig :: LHsSigWcType GhcRn -> Bool

+ GHC.Tc.Solver: findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType

+ GHC.Tc.Solver: pushLevelAndSolveEqualities :: SkolemInfo -> [TcTyVar] -> TcM a -> TcM a

+ GHC.Tc.Solver: pushLevelAndSolveEqualitiesX :: String -> TcM a -> TcM (TcLevel, WantedConstraints, a)

+ GHC.Tc.Solver: reportUnsolvedEqualities :: SkolemInfo -> [TcTyVar] -> TcLevel -> WantedConstraints -> TcM ()

+ GHC.Tc.Solver: simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()

+ GHC.Tc.Solver: simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints

+ GHC.Tc.Solver: tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)

+ GHC.Tc.Solver: tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool

+ GHC.Tc.Solver.Canonical: andWhenContinue :: TcS (StopOrContinue a) -> (a -> TcS (StopOrContinue b)) -> TcS (StopOrContinue b)

+ GHC.Tc.Solver.Canonical: infixr 0 `andWhenContinue`

+ GHC.Tc.Solver.Monad: EqualCtList :: NonEmpty Ct -> EqualCtList

+ GHC.Tc.Solver.Monad: TouchableOuterLevel :: [TcTyVar] -> TcLevel -> TouchabilityTestResult

+ GHC.Tc.Solver.Monad: TouchableSameLevel :: TouchabilityTestResult

+ GHC.Tc.Solver.Monad: Untouchable :: TouchabilityTestResult

+ GHC.Tc.Solver.Monad: [inert_blocked] :: InertCans -> Cts

+ GHC.Tc.Solver.Monad: [inert_cycle_breakers] :: InertSet -> [(TcTyVar, TcType)]

+ GHC.Tc.Solver.Monad: [inert_famapp_cache] :: InertSet -> FunEqMap (TcCoercion, TcType)

+ GHC.Tc.Solver.Monad: [inert_given_eq_lvl] :: InertCans -> TcLevel

+ GHC.Tc.Solver.Monad: [inert_given_eqs] :: InertCans -> Bool

+ GHC.Tc.Solver.Monad: breakTyVarCycle_maybe :: CtEvidence -> CheckTyEqResult -> CanEqLHS -> TcType -> TcS (Maybe (TcTyVar, CoercionN, TcType))

+ GHC.Tc.Solver.Monad: data TouchabilityTestResult

+ GHC.Tc.Solver.Monad: emptyInert :: InertSet

+ GHC.Tc.Solver.Monad: extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()

+ GHC.Tc.Solver.Monad: findEq :: InertCans -> CanEqLHS -> [Ct]

+ GHC.Tc.Solver.Monad: getHasGivenEqs :: TcLevel -> TcS (HasGivenEqs, Cts)

+ GHC.Tc.Solver.Monad: getInnermostGivenEqLevel :: TcS TcLevel

+ GHC.Tc.Solver.Monad: instance GHC.Types.TyThing.MonadThings GHC.Tc.Solver.Monad.TcS

+ GHC.Tc.Solver.Monad: instance GHC.Utils.Outputable.Outputable GHC.Tc.Solver.Monad.EqualCtList

+ GHC.Tc.Solver.Monad: instance GHC.Utils.Outputable.Outputable GHC.Tc.Solver.Monad.TouchabilityTestResult

+ GHC.Tc.Solver.Monad: lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))

+ GHC.Tc.Solver.Monad: lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))

+ GHC.Tc.Solver.Monad: mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool

+ GHC.Tc.Solver.Monad: newtype EqualCtList

+ GHC.Tc.Solver.Monad: resetUnificationFlag :: TcS Bool

+ GHC.Tc.Solver.Monad: rewriterView :: TcType -> Maybe TcType

+ GHC.Tc.Solver.Monad: runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)

+ GHC.Tc.Solver.Monad: setUnificationFlag :: TcLevel -> TcS ()

+ GHC.Tc.Solver.Monad: touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult

+ GHC.Tc.Solver.Monad: wrapTcS :: TcM a -> TcS a

+ GHC.Tc.Solver.Rewrite: instance GHC.Base.Applicative GHC.Tc.Solver.Rewrite.RewriteM

+ GHC.Tc.Solver.Rewrite: instance GHC.Base.Functor GHC.Tc.Solver.Rewrite.RewriteM

+ GHC.Tc.Solver.Rewrite: instance GHC.Base.Monad GHC.Tc.Solver.Rewrite.RewriteM

+ GHC.Tc.Solver.Rewrite: instance GHC.Driver.Session.HasDynFlags GHC.Tc.Solver.Rewrite.RewriteM

+ GHC.Tc.Solver.Rewrite: rewrite :: CtEvidence -> TcType -> TcS (Xi, TcCoercion)

+ GHC.Tc.Solver.Rewrite: rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion])

+ GHC.Tc.Solver.Rewrite: rewriteKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)

+ GHC.Tc.Solver.Rewrite: rewriteType :: CtLoc -> TcType -> TcS TcType

+ GHC.Tc.TyCl: DDataInstance :: Type -> DataDeclInfo

+ GHC.Tc.TyCl: DDataType :: DataDeclInfo

+ GHC.Tc.TyCl: data DataDeclInfo

+ GHC.Tc.TyCl.PatSyn: patSynBuilderOcc :: PatSyn -> Maybe (HsExpr GhcTc, TcSigmaType)

+ GHC.Tc.Types: ArgDoc :: Name -> Int -> DocLoc

+ GHC.Tc.Types: DeclDoc :: Name -> DocLoc

+ GHC.Tc.Types: InstDoc :: Name -> DocLoc

+ GHC.Tc.Types: ModuleDoc :: DocLoc

+ GHC.Tc.Types: [tcg_ksigs] :: TcGblEnv -> NameSet

+ GHC.Tc.Types: [tcg_th_docs] :: TcGblEnv -> TcRef THDocs

+ GHC.Tc.Types: data DocLoc

+ GHC.Tc.Types: instance GHC.Classes.Eq GHC.Tc.Types.DocLoc

+ GHC.Tc.Types: instance GHC.Classes.Ord GHC.Tc.Types.DocLoc

+ GHC.Tc.Types: instance GHC.Driver.Hooks.ContainsHooks (GHC.Tc.Types.Env gbl lcl)

+ GHC.Tc.Types: instance GHC.Utils.Logger.ContainsLogger (GHC.Tc.Types.Env gbl lcl)

+ GHC.Tc.Types: type CompleteMatches = [CompleteMatch]

+ GHC.Tc.Types: type THDocs = Map DocLoc String

+ GHC.Tc.Types.Constraint: AbstractTyConReason :: CtIrredReason

+ GHC.Tc.Types.Constraint: CEqCan :: CtEvidence -> CanEqLHS -> Xi -> EqRel -> Ct

+ GHC.Tc.Types.Constraint: ConstraintHole :: HoleSort

+ GHC.Tc.Types.Constraint: HoleBlockerReason :: HoleSet -> CtIrredReason

+ GHC.Tc.Types.Constraint: IrredShapeReason :: CtIrredReason

+ GHC.Tc.Types.Constraint: LocalGivenEqs :: HasGivenEqs

+ GHC.Tc.Types.Constraint: MaybeGivenEqs :: HasGivenEqs

+ GHC.Tc.Types.Constraint: NoGivenEqs :: HasGivenEqs

+ GHC.Tc.Types.Constraint: NonCanonicalReason :: CheckTyEqResult -> CtIrredReason

+ GHC.Tc.Types.Constraint: ReprEqReason :: CtIrredReason

+ GHC.Tc.Types.Constraint: ShapeMismatchReason :: CtIrredReason

+ GHC.Tc.Types.Constraint: TyFamLHS :: TyCon -> [Xi] -> CanEqLHS

+ GHC.Tc.Types.Constraint: TyVarLHS :: TcTyVar -> CanEqLHS

+ GHC.Tc.Types.Constraint: [cc_lhs] :: Ct -> CanEqLHS

+ GHC.Tc.Types.Constraint: [cc_reason] :: Ct -> CtIrredReason

+ GHC.Tc.Types.Constraint: [ic_given_eqs] :: Implication -> HasGivenEqs

+ GHC.Tc.Types.Constraint: canEqLHSKind :: CanEqLHS -> TcKind

+ GHC.Tc.Types.Constraint: canEqLHSType :: CanEqLHS -> TcType

+ GHC.Tc.Types.Constraint: canEqLHS_maybe :: Xi -> Maybe CanEqLHS

+ GHC.Tc.Types.Constraint: checkTelescopeSkol :: SkolemInfo -> Bool

+ GHC.Tc.Types.Constraint: ctFlavourContainsDerived :: CtFlavour -> Bool

+ GHC.Tc.Types.Constraint: cteHoleBlocker :: CheckTyEqProblem

+ GHC.Tc.Types.Constraint: cteImpredicative :: CheckTyEqProblem

+ GHC.Tc.Types.Constraint: cteInsolubleOccurs :: CheckTyEqProblem

+ GHC.Tc.Types.Constraint: cteOK :: CheckTyEqResult

+ GHC.Tc.Types.Constraint: cteProblem :: CheckTyEqProblem -> CheckTyEqResult

+ GHC.Tc.Types.Constraint: cteSolubleOccurs :: CheckTyEqProblem

+ GHC.Tc.Types.Constraint: cteTypeFamily :: CheckTyEqProblem

+ GHC.Tc.Types.Constraint: cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult

+ GHC.Tc.Types.Constraint: cterFromKind :: CheckTyEqResult -> CheckTyEqResult

+ GHC.Tc.Types.Constraint: cterHasNoProblem :: CheckTyEqResult -> Bool

+ GHC.Tc.Types.Constraint: cterHasOccursCheck :: CheckTyEqResult -> Bool

+ GHC.Tc.Types.Constraint: cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool

+ GHC.Tc.Types.Constraint: cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool

+ GHC.Tc.Types.Constraint: cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult

+ GHC.Tc.Types.Constraint: cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult

+ GHC.Tc.Types.Constraint: data CanEqLHS

+ GHC.Tc.Types.Constraint: data CheckTyEqProblem

+ GHC.Tc.Types.Constraint: data CheckTyEqResult

+ GHC.Tc.Types.Constraint: data CtIrredReason

+ GHC.Tc.Types.Constraint: data HasGivenEqs

+ GHC.Tc.Types.Constraint: eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool

+ GHC.Tc.Types.Constraint: instance GHC.Base.Monoid GHC.Tc.Types.Constraint.CheckTyEqResult

+ GHC.Tc.Types.Constraint: instance GHC.Base.Monoid GHC.Tc.Types.Constraint.HasGivenEqs

+ GHC.Tc.Types.Constraint: instance GHC.Base.Semigroup GHC.Tc.Types.Constraint.CheckTyEqResult

+ GHC.Tc.Types.Constraint: instance GHC.Base.Semigroup GHC.Tc.Types.Constraint.HasGivenEqs

+ GHC.Tc.Types.Constraint: instance GHC.Classes.Eq GHC.Tc.Types.Constraint.HasGivenEqs

+ GHC.Tc.Types.Constraint: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Constraint.CanEqLHS

+ GHC.Tc.Types.Constraint: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Constraint.CheckTyEqResult

+ GHC.Tc.Types.Constraint: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Constraint.CtIrredReason

+ GHC.Tc.Types.Constraint: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Constraint.HasGivenEqs

+ GHC.Tc.Types.Constraint: isInsolubleReason :: CtIrredReason -> Bool

+ GHC.Tc.Types.Constraint: type HoleSet = UniqSet CoercionHole

+ GHC.Tc.Types.Evidence: HER :: IORef EvTerm -> TcType -> Unique -> HoleExprRef

+ GHC.Tc.Types.Evidence: data HoleExprRef

+ GHC.Tc.Types.Evidence: instance Data.Data.Data GHC.Tc.Types.Evidence.HoleExprRef

+ GHC.Tc.Types.Evidence: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Evidence.HoleExprRef

+ GHC.Tc.Types.Evidence: maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion

+ GHC.Tc.Types.Evidence: mkTcGReflLeftMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion

+ GHC.Tc.Types.Evidence: mkTcGReflRightMCo :: Role -> TcType -> TcMCoercionN -> TcCoercion

+ GHC.Tc.Types.Evidence: mkTcSymMCo :: TcMCoercion -> TcMCoercion

+ GHC.Tc.Types.Evidence: type TcMCoercionN = MCoercionN

+ GHC.Tc.Types.Evidence: type TcMCoercionR = MCoercionR

+ GHC.Tc.Types.Origin: CycleBreakerOrigin :: CtOrigin -> CtOrigin

+ GHC.Tc.Types.Origin: HasFieldOrigin :: FastString -> CtOrigin

+ GHC.Tc.Utils.Backpack: implicitRequirementsShallow :: HscEnv -> [(Maybe FastString, Located ModuleName)] -> IO ([ModuleName], [InstantiatedUnit])

+ GHC.Tc.Utils.Env: instance GHC.Types.TyThing.MonadThings (GHC.Data.IOEnv.IOEnv (GHC.Tc.Types.Env GHC.Tc.Types.TcGblEnv GHC.Tc.Types.TcLclEnv))

+ GHC.Tc.Utils.Instantiate: instantiateSigma :: CtOrigin -> [TyVar] -> TcThetaType -> TcSigmaType -> TcM ([TcTyVar], HsWrapper, TcSigmaType)

+ GHC.Tc.Utils.Monad: NoExtraConstraint :: IsExtraConstraint

+ GHC.Tc.Utils.Monad: YesExtraConstraint :: IsExtraConstraint

+ GHC.Tc.Utils.Monad: addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b

+ GHC.Tc.Utils.Monad: data IsExtraConstraint

+ GHC.Tc.Utils.Monad: getCCIndexTcM :: FastString -> TcM CostCentreIndex

+ GHC.Tc.Utils.Monad: instance GHC.Utils.Outputable.Outputable GHC.Tc.Utils.Monad.IsExtraConstraint

+ GHC.Tc.Utils.Monad: mkDecoratedSDocAt :: SrcSpan -> SDoc -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)

+ GHC.Tc.Utils.Monad: setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a

+ GHC.Tc.Utils.Monad: withDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a

+ GHC.Tc.Utils.Monad: withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a

+ GHC.Tc.Utils.Monad: wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)

+ GHC.Tc.Utils.Monad: wrapLocFstMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (LocatedA b, c)

+ GHC.Tc.Utils.Monad: wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)

+ GHC.Tc.Utils.Monad: wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()

+ GHC.Tc.Utils.Monad: wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)

+ GHC.Tc.Utils.TcMType: doNotQuantifyTyVars :: CandidatesQTvs -> (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM ()

+ GHC.Tc.Utils.TcMType: newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar

+ GHC.Tc.Utils.TcMType: newCycleBreakerTyVar :: TcKind -> TcM TcTyVar

+ GHC.Tc.Utils.TcMType: newOpenBoxedTypeKind :: TcM TcKind

+ GHC.Tc.Utils.TcMType: newOpenFlexiTyVar :: TcM TcTyVar

+ GHC.Tc.Utils.TcMType: promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool

+ GHC.Tc.Utils.TcType: CycleBreakerTv :: MetaInfo

+ GHC.Tc.Utils.TcType: RuntimeUnkTv :: MetaInfo

+ GHC.Tc.Utils.TcType: anyRewritableCanEqLHS :: EqRel -> (EqRel -> TcTyVar -> Bool) -> (EqRel -> TyCon -> [TcType] -> Bool) -> TcType -> Bool

+ GHC.Tc.Utils.TcType: anyRewritableTyFamApp :: EqRel -> (EqRel -> TyCon -> [TcType] -> Bool) -> TcType -> Bool

+ GHC.Tc.Utils.TcType: deeperThanOrSame :: TcLevel -> TcLevel -> Bool

+ GHC.Tc.Utils.TcType: isCycleBreakerTyVar :: TcTyVar -> Bool

+ GHC.Tc.Utils.TcType: isPromotableMetaTyVar :: TcTyVar -> Bool

+ GHC.Tc.Utils.TcType: tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool

+ GHC.Tc.Utils.TcType: tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)

+ GHC.Tc.Utils.TcType: tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type)

+ GHC.Tc.Utils.TcType: tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)

+ GHC.Tc.Utils.TcType: tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)

+ GHC.Tc.Utils.TcType: tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)

+ GHC.Tc.Utils.TcType: tcSplitForAllTyVars :: Type -> ([TyVar], Type)

+ GHC.Tc.Utils.TcType: tcSplitSomeForAllTyVars :: (ArgFlag -> Bool) -> Type -> ([TyVar], Type)

+ GHC.Tc.Utils.Unify: checkTyFamEq :: DynFlags -> TyCon -> [TcType] -> TcType -> CheckTyEqResult

+ GHC.Tc.Utils.Unify: checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult

+ GHC.Tc.Utils.Unify: checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult

+ GHC.Tc.Utils.Unify: unifyExpectedType :: HsExpr GhcRn -> TcRhoType -> ExpRhoType -> TcM TcCoercionN

+ GHC.Tc.Utils.Zonk: NoFlexi :: ZonkFlexi

+ GHC.Tc.Utils.Zonk: tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))

+ GHC.Tc.Validity: instance GHC.Classes.Eq GHC.Tc.Validity.TypeOrKindCtxt

+ GHC.Tc.Validity: instance GHC.Utils.Outputable.Outputable GHC.Tc.Validity.TypeOrKindCtxt

+ GHC.Types.Avail: FieldGreName :: FieldLabel -> GreName

+ GHC.Types.Avail: NormalGreName :: Name -> GreName

+ GHC.Types.Avail: availExportsDecl :: AvailInfo -> Bool

+ GHC.Types.Avail: availField :: FieldLabel -> AvailInfo

+ GHC.Types.Avail: availGreName :: AvailInfo -> GreName

+ GHC.Types.Avail: availGreNames :: AvailInfo -> [GreName]

+ GHC.Types.Avail: availSubordinateGreNames :: AvailInfo -> [GreName]

+ GHC.Types.Avail: availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo

+ GHC.Types.Avail: data GreName

+ GHC.Types.Avail: greNameFieldLabel :: GreName -> Maybe FieldLabel

+ GHC.Types.Avail: greNameMangledName :: GreName -> Name

+ GHC.Types.Avail: greNamePrintableName :: GreName -> Name

+ GHC.Types.Avail: greNameSrcSpan :: GreName -> SrcSpan

+ GHC.Types.Avail: instance Data.Data.Data GHC.Types.Avail.GreName

+ GHC.Types.Avail: instance GHC.Classes.Eq GHC.Types.Avail.GreName

+ GHC.Types.Avail: instance GHC.Types.Name.Occurrence.HasOccName GHC.Types.Avail.GreName

+ GHC.Types.Avail: instance GHC.Utils.Binary.Binary GHC.Types.Avail.GreName

+ GHC.Types.Avail: instance GHC.Utils.Outputable.Outputable GHC.Types.Avail.GreName

+ GHC.Types.Avail: partitionGreNames :: [GreName] -> ([Name], [FieldLabel])

+ GHC.Types.Avail: stableGreNameCmp :: GreName -> GreName -> Ordering

+ GHC.Types.Basic: LangAsm :: ForeignSrcLang

+ GHC.Types.Basic: LangC :: ForeignSrcLang

+ GHC.Types.Basic: LangCxx :: ForeignSrcLang

+ GHC.Types.Basic: LangObjc :: ForeignSrcLang

+ GHC.Types.Basic: LangObjcxx :: ForeignSrcLang

+ GHC.Types.Basic: NoUserInlinePrag :: InlineSpec

+ GHC.Types.Basic: RawObject :: ForeignSrcLang

+ GHC.Types.Basic: data ForeignSrcLang

+ GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.TopLevelFlag

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.Activation

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.FunctionOrData

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.InlinePragma

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.InlineSpec

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.LeftOrRight

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.OverlapFlag

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.OverlapMode

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.PromotionFlag

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.RecFlag

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.RuleMatchInfo

+ GHC.Types.Basic: instance GHC.Utils.Binary.Binary GHC.Types.Basic.TupleSort

+ GHC.Types.Basic: instance GHC.Utils.Outputable.OutputableP env GHC.Types.Basic.Alignment

+ GHC.Types.Basic: type FullArgCount = Int

+ GHC.Types.CompleteMatch: CompleteMatch :: UniqDSet ConLike -> Maybe TyCon -> CompleteMatch

+ GHC.Types.CompleteMatch: [cmConLikes] :: CompleteMatch -> UniqDSet ConLike

+ GHC.Types.CompleteMatch: [cmResultTyCon] :: CompleteMatch -> Maybe TyCon

+ GHC.Types.CompleteMatch: completeMatchAppliesAtType :: Type -> CompleteMatch -> Bool

+ GHC.Types.CompleteMatch: data CompleteMatch

+ GHC.Types.CompleteMatch: instance GHC.Utils.Outputable.Outputable GHC.Types.CompleteMatch.CompleteMatch

+ GHC.Types.CompleteMatch: type CompleteMatches = [CompleteMatch]

+ GHC.Types.CompleteMatch: vanillaCompleteMatch :: UniqDSet ConLike -> CompleteMatch

+ GHC.Types.Cpr: AllFieldsSame :: !Cpr -> UnpackConFieldsResult

+ GHC.Types.Cpr: ForeachField :: ![Cpr] -> UnpackConFieldsResult

+ GHC.Types.Cpr: data Cpr

+ GHC.Types.Cpr: data UnpackConFieldsResult

+ GHC.Types.Cpr: flatConCpr :: ConTag -> Cpr

+ GHC.Types.Cpr: flatConCprType :: ConTag -> CprType

+ GHC.Types.Cpr: instance GHC.Classes.Eq GHC.Types.Cpr.Cpr

+ GHC.Types.Cpr: instance GHC.Utils.Binary.Binary GHC.Types.Cpr.Cpr

+ GHC.Types.Cpr: instance GHC.Utils.Outputable.Outputable GHC.Types.Cpr.Cpr

+ GHC.Types.Cpr: isTopCprSig :: CprSig -> Bool

+ GHC.Types.Cpr: pattern ConCpr :: ConTag -> [Cpr] -> Cpr

+ GHC.Types.Cpr: unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult

+ GHC.Types.Demand: (:*) :: !Card -> !SubDemand -> Demand

+ GHC.Types.Demand: C_00 :: Card

+ GHC.Types.Demand: C_01 :: Card

+ GHC.Types.Demand: C_0N :: Card

+ GHC.Types.Demand: C_10 :: Card

+ GHC.Types.Demand: C_11 :: Card

+ GHC.Types.Demand: C_1N :: Card

+ GHC.Types.Demand: Prod :: ![Demand] -> SubDemand

+ GHC.Types.Demand: [dt_args] :: DmdType -> [Demand]

+ GHC.Types.Demand: [dt_div] :: DmdType -> Divergence

+ GHC.Types.Demand: [dt_env] :: DmdType -> DmdEnv

+ GHC.Types.Demand: data Card

+ GHC.Types.Demand: data Demand

+ GHC.Types.Demand: data SubDemand

+ GHC.Types.Demand: instance GHC.Classes.Eq GHC.Types.Demand.Card

+ GHC.Types.Demand: instance GHC.Classes.Eq GHC.Types.Demand.Demand

+ GHC.Types.Demand: instance GHC.Classes.Eq GHC.Types.Demand.SubDemand

+ GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.Card

+ GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.Demand

+ GHC.Types.Demand: instance GHC.Utils.Binary.Binary GHC.Types.Demand.SubDemand

+ GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.Card

+ GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.Demand

+ GHC.Types.Demand: instance GHC.Utils.Outputable.Outputable GHC.Types.Demand.SubDemand

+ GHC.Types.Demand: isAbs :: Card -> Bool

+ GHC.Types.Demand: isStrUsedDmd :: Demand -> Bool

+ GHC.Types.Demand: isStrict :: Card -> Bool

+ GHC.Types.Demand: isUsedOnceDmd :: Demand -> Bool

+ GHC.Types.Demand: isWeakDmd :: Demand -> Bool

+ GHC.Types.Demand: keepAliveDmdType :: DmdType -> VarSet -> DmdType

+ GHC.Types.Demand: lubCard :: Card -> Card -> Card

+ GHC.Types.Demand: lubSubDmd :: SubDemand -> SubDemand -> SubDemand

+ GHC.Types.Demand: mkCalledOnceDmd :: SubDemand -> SubDemand

+ GHC.Types.Demand: mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand

+ GHC.Types.Demand: mkPlusDmdArg :: DmdEnv -> PlusDmdArg

+ GHC.Types.Demand: mkProd :: [Demand] -> SubDemand

+ GHC.Types.Demand: multCard :: Card -> Card -> Card

+ GHC.Types.Demand: multDmd :: Card -> Demand -> Demand

+ GHC.Types.Demand: multDmdType :: Card -> DmdType -> DmdType

+ GHC.Types.Demand: multSubDmd :: Card -> SubDemand -> SubDemand

+ GHC.Types.Demand: oneifyCard :: Card -> Card

+ GHC.Types.Demand: plusCard :: Card -> Card -> Card

+ GHC.Types.Demand: plusDmd :: Demand -> Demand -> Demand

+ GHC.Types.Demand: plusDmdType :: DmdType -> PlusDmdArg -> DmdType

+ GHC.Types.Demand: plusSubDmd :: SubDemand -> SubDemand -> SubDemand

+ GHC.Types.Demand: strictManyApply1Dmd :: Demand

+ GHC.Types.Demand: strictOnceApply1Dmd :: Demand

+ GHC.Types.Demand: toPlusDmdArg :: DmdType -> PlusDmdArg

+ GHC.Types.Demand: topSubDmd :: SubDemand

+ GHC.Types.Demand: type DmdTransformer = SubDemand -> DmdType

+ GHC.Types.Demand: type PlusDmdArg = (DmdEnv, Divergence)

+ GHC.Types.Demand: viewProd :: Arity -> SubDemand -> Maybe [Demand]

+ GHC.Types.Demand: zapDmdEnvSig :: StrictSig -> StrictSig

+ GHC.Types.Error: MsgEnvelope :: SrcSpan -> PrintUnqualified -> e -> Severity -> WarnReason -> MsgEnvelope e

+ GHC.Types.Error: SevDump :: Severity

+ GHC.Types.Error: SevError :: Severity

+ GHC.Types.Error: SevFatal :: Severity

+ GHC.Types.Error: SevInfo :: Severity

+ GHC.Types.Error: SevInteractive :: Severity

+ GHC.Types.Error: SevOutput :: Severity

+ GHC.Types.Error: SevWarning :: Severity

+ GHC.Types.Error: [errMsgContext] :: MsgEnvelope e -> PrintUnqualified

+ GHC.Types.Error: [errMsgDiagnostic] :: MsgEnvelope e -> e

+ GHC.Types.Error: [errMsgReason] :: MsgEnvelope e -> WarnReason

+ GHC.Types.Error: [errMsgSeverity] :: MsgEnvelope e -> Severity

+ GHC.Types.Error: [errMsgSpan] :: MsgEnvelope e -> SrcSpan

+ GHC.Types.Error: addMessage :: MsgEnvelope e -> Messages e -> Messages e

+ GHC.Types.Error: class RenderableDiagnostic a

+ GHC.Types.Error: data DecoratedSDoc

+ GHC.Types.Error: data Messages e

+ GHC.Types.Error: data MsgEnvelope e

+ GHC.Types.Error: data SDoc

+ GHC.Types.Error: data Severity

+ GHC.Types.Error: emptyMessages :: Messages e

+ GHC.Types.Error: errorsFound :: Messages e -> Bool

+ GHC.Types.Error: getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc

+ GHC.Types.Error: getErrorMessages :: Messages e -> Bag (MsgEnvelope e)

+ GHC.Types.Error: getSeverityColour :: Severity -> Scheme -> PprColour

+ GHC.Types.Error: getWarningMessages :: Messages e -> Bag (MsgEnvelope e)

+ GHC.Types.Error: instance GHC.Base.Functor GHC.Types.Error.Messages

+ GHC.Types.Error: instance GHC.Base.Functor GHC.Types.Error.MsgEnvelope

+ GHC.Types.Error: instance GHC.Classes.Eq GHC.Types.Error.Severity

+ GHC.Types.Error: instance GHC.Show.Show (GHC.Types.Error.MsgEnvelope GHC.Types.Error.DecoratedSDoc)

+ GHC.Types.Error: instance GHC.Show.Show GHC.Types.Error.Severity

+ GHC.Types.Error: instance GHC.Types.Error.RenderableDiagnostic GHC.Types.Error.DecoratedSDoc

+ GHC.Types.Error: instance GHC.Utils.Json.ToJson GHC.Types.Error.Severity

+ GHC.Types.Error: isEmptyMessages :: Messages e -> Bool

+ GHC.Types.Error: isErrorMessage :: MsgEnvelope e -> Bool

+ GHC.Types.Error: isWarningMessage :: MsgEnvelope e -> Bool

+ GHC.Types.Error: makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e

+ GHC.Types.Error: mkDecorated :: [SDoc] -> DecoratedSDoc

+ GHC.Types.Error: mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e

+ GHC.Types.Error: mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc

+ GHC.Types.Error: mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> SDoc -> SDoc

+ GHC.Types.Error: mkLongMsgEnvelope :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: mkMessages :: Bag (MsgEnvelope e) -> Messages e

+ GHC.Types.Error: mkMsgEnvelope :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: mkPlainMsgEnvelope :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))

+ GHC.Types.Error: pprMessageBag :: Bag SDoc -> SDoc

+ GHC.Types.Error: renderDiagnostic :: RenderableDiagnostic a => a -> DecoratedSDoc

+ GHC.Types.Error: type ErrorMessages = Bag (MsgEnvelope DecoratedSDoc)

+ GHC.Types.Error: type WarnMsg = MsgEnvelope DecoratedSDoc

+ GHC.Types.Error: type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)

+ GHC.Types.Error: unionMessages :: Messages e -> Messages e -> Messages e

+ GHC.Types.FieldLabel: DuplicateRecordFields :: DuplicateRecordFields

+ GHC.Types.FieldLabel: FieldSelectors :: FieldSelectors

+ GHC.Types.FieldLabel: NoDuplicateRecordFields :: DuplicateRecordFields

+ GHC.Types.FieldLabel: NoFieldSelectors :: FieldSelectors

+ GHC.Types.FieldLabel: [flHasDuplicateRecordFields] :: FieldLabel -> DuplicateRecordFields

+ GHC.Types.FieldLabel: [flHasFieldSelector] :: FieldLabel -> FieldSelectors

+ GHC.Types.FieldLabel: data DuplicateRecordFields

+ GHC.Types.FieldLabel: data FieldLabel

+ GHC.Types.FieldLabel: data FieldSelectors

+ GHC.Types.FieldLabel: fieldLabelPrintableName :: FieldLabel -> Name

+ GHC.Types.FieldLabel: fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName

+ GHC.Types.FieldLabel: flIsOverloaded :: FieldLabel -> Bool

+ GHC.Types.FieldLabel: instance Data.Data.Data GHC.Types.FieldLabel.DuplicateRecordFields

+ GHC.Types.FieldLabel: instance Data.Data.Data GHC.Types.FieldLabel.FieldLabel

+ GHC.Types.FieldLabel: instance Data.Data.Data GHC.Types.FieldLabel.FieldSelectors

+ GHC.Types.FieldLabel: instance GHC.Classes.Eq GHC.Types.FieldLabel.DuplicateRecordFields

+ GHC.Types.FieldLabel: instance GHC.Classes.Eq GHC.Types.FieldLabel.FieldLabel

+ GHC.Types.FieldLabel: instance GHC.Classes.Eq GHC.Types.FieldLabel.FieldSelectors

+ GHC.Types.FieldLabel: instance GHC.Show.Show GHC.Types.FieldLabel.DuplicateRecordFields

+ GHC.Types.FieldLabel: instance GHC.Show.Show GHC.Types.FieldLabel.FieldSelectors

+ GHC.Types.FieldLabel: instance GHC.Types.Name.Occurrence.HasOccName GHC.Types.FieldLabel.FieldLabel

+ GHC.Types.FieldLabel: instance GHC.Utils.Binary.Binary GHC.Types.FieldLabel.DuplicateRecordFields

+ GHC.Types.FieldLabel: instance GHC.Utils.Binary.Binary GHC.Types.FieldLabel.FieldSelectors

+ GHC.Types.FieldLabel: instance GHC.Utils.Binary.Binary GHC.Types.Name.Name => GHC.Utils.Binary.Binary GHC.Types.FieldLabel.FieldLabel

+ GHC.Types.FieldLabel: instance GHC.Utils.Outputable.Outputable GHC.Types.FieldLabel.DuplicateRecordFields

+ GHC.Types.FieldLabel: instance GHC.Utils.Outputable.Outputable GHC.Types.FieldLabel.FieldLabel

+ GHC.Types.FieldLabel: instance GHC.Utils.Outputable.Outputable GHC.Types.FieldLabel.FieldSelectors

+ GHC.Types.Fixity: Fixity :: SourceText -> Int -> FixityDirection -> Fixity

+ GHC.Types.Fixity: Infix :: LexicalFixity

+ GHC.Types.Fixity: InfixL :: FixityDirection

+ GHC.Types.Fixity: InfixN :: FixityDirection

+ GHC.Types.Fixity: InfixR :: FixityDirection

+ GHC.Types.Fixity: Prefix :: LexicalFixity

+ GHC.Types.Fixity: compareFixity :: Fixity -> Fixity -> (Bool, Bool)

+ GHC.Types.Fixity: data Fixity

+ GHC.Types.Fixity: data FixityDirection

+ GHC.Types.Fixity: data LexicalFixity

+ GHC.Types.Fixity: defaultFixity :: Fixity

+ GHC.Types.Fixity: funTyFixity :: Fixity

+ GHC.Types.Fixity: instance Data.Data.Data GHC.Types.Fixity.Fixity

+ GHC.Types.Fixity: instance Data.Data.Data GHC.Types.Fixity.FixityDirection

+ GHC.Types.Fixity: instance Data.Data.Data GHC.Types.Fixity.LexicalFixity

+ GHC.Types.Fixity: instance GHC.Classes.Eq GHC.Types.Fixity.Fixity

+ GHC.Types.Fixity: instance GHC.Classes.Eq GHC.Types.Fixity.FixityDirection

+ GHC.Types.Fixity: instance GHC.Classes.Eq GHC.Types.Fixity.LexicalFixity

+ GHC.Types.Fixity: instance GHC.Utils.Binary.Binary GHC.Types.Fixity.Fixity

+ GHC.Types.Fixity: instance GHC.Utils.Binary.Binary GHC.Types.Fixity.FixityDirection

+ GHC.Types.Fixity: instance GHC.Utils.Outputable.Outputable GHC.Types.Fixity.Fixity

+ GHC.Types.Fixity: instance GHC.Utils.Outputable.Outputable GHC.Types.Fixity.FixityDirection

+ GHC.Types.Fixity: instance GHC.Utils.Outputable.Outputable GHC.Types.Fixity.LexicalFixity

+ GHC.Types.Fixity: maxPrecedence :: Int

+ GHC.Types.Fixity: minPrecedence :: Int

+ GHC.Types.Fixity: negateFixity :: Fixity

+ GHC.Types.Fixity.Env: FixItem :: OccName -> Fixity -> FixItem

+ GHC.Types.Fixity.Env: data FixItem

+ GHC.Types.Fixity.Env: emptyFixityEnv :: FixityEnv

+ GHC.Types.Fixity.Env: emptyIfaceFixCache :: OccName -> Maybe Fixity

+ GHC.Types.Fixity.Env: instance GHC.Utils.Outputable.Outputable GHC.Types.Fixity.Env.FixItem

+ GHC.Types.Fixity.Env: lookupFixity :: FixityEnv -> Name -> Fixity

+ GHC.Types.Fixity.Env: mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity

+ GHC.Types.Fixity.Env: type FixityEnv = NameEnv FixItem

+ GHC.Types.ForeignStubs: CHeader :: SDoc -> CHeader

+ GHC.Types.ForeignStubs: CStub :: SDoc -> CStub

+ GHC.Types.ForeignStubs: ForeignStubs :: CHeader -> CStub -> ForeignStubs

+ GHC.Types.ForeignStubs: NoStubs :: ForeignStubs

+ GHC.Types.ForeignStubs: [getCHeader] :: CHeader -> SDoc

+ GHC.Types.ForeignStubs: [getCStub] :: CStub -> SDoc

+ GHC.Types.ForeignStubs: appendStubC :: ForeignStubs -> CStub -> ForeignStubs

+ GHC.Types.ForeignStubs: data ForeignStubs

+ GHC.Types.ForeignStubs: instance GHC.Base.Monoid GHC.Types.ForeignStubs.CHeader

+ GHC.Types.ForeignStubs: instance GHC.Base.Monoid GHC.Types.ForeignStubs.CStub

+ GHC.Types.ForeignStubs: instance GHC.Base.Semigroup GHC.Types.ForeignStubs.CHeader

+ GHC.Types.ForeignStubs: instance GHC.Base.Semigroup GHC.Types.ForeignStubs.CStub

+ GHC.Types.ForeignStubs: newtype CHeader

+ GHC.Types.ForeignStubs: newtype CStub

+ GHC.Types.HpcInfo: HpcInfo :: Int -> Int -> HpcInfo

+ GHC.Types.HpcInfo: NoHpcInfo :: AnyHpcUsage -> HpcInfo

+ GHC.Types.HpcInfo: [hpcInfoHash] :: HpcInfo -> Int

+ GHC.Types.HpcInfo: [hpcInfoTickCount] :: HpcInfo -> Int

+ GHC.Types.HpcInfo: [hpcUsed] :: HpcInfo -> AnyHpcUsage

+ GHC.Types.HpcInfo: data HpcInfo

+ GHC.Types.HpcInfo: emptyHpcInfo :: AnyHpcUsage -> HpcInfo

+ GHC.Types.HpcInfo: isHpcUsed :: HpcInfo -> AnyHpcUsage

+ GHC.Types.HpcInfo: type AnyHpcUsage = Bool

+ GHC.Types.IPE: InfoTableProvMap :: DCMap -> ClosureMap -> InfoTableProvMap

+ GHC.Types.IPE: [provClosure] :: InfoTableProvMap -> ClosureMap

+ GHC.Types.IPE: [provDC] :: InfoTableProvMap -> DCMap

+ GHC.Types.IPE: data InfoTableProvMap

+ GHC.Types.IPE: emptyInfoTableProvMap :: InfoTableProvMap

+ GHC.Types.IPE: type ClosureMap = UniqMap Name (Type, Maybe (RealSrcSpan, String))

+ GHC.Types.IPE: type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe (RealSrcSpan, String)))

+ GHC.Types.Id: recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent

+ GHC.Types.Id.Make: leftSectionName :: Name

+ GHC.Types.Id.Make: rightSectionName :: Name

+ GHC.Types.Literal: LitNumInt16 :: LitNumType

+ GHC.Types.Literal: LitNumInt32 :: LitNumType

+ GHC.Types.Literal: LitNumInt8 :: LitNumType

+ GHC.Types.Literal: LitNumWord16 :: LitNumType

+ GHC.Types.Literal: LitNumWord32 :: LitNumType

+ GHC.Types.Literal: LitNumWord8 :: LitNumType

+ GHC.Types.Literal: charToIntLit :: Literal -> Literal

+ GHC.Types.Literal: doubleToFloatLit :: Literal -> Literal

+ GHC.Types.Literal: doubleToIntLit :: Literal -> Literal

+ GHC.Types.Literal: extendIntLit :: Platform -> Literal -> Literal

+ GHC.Types.Literal: extendWordLit :: Platform -> Literal -> Literal

+ GHC.Types.Literal: floatToDoubleLit :: Literal -> Literal

+ GHC.Types.Literal: floatToIntLit :: Literal -> Literal

+ GHC.Types.Literal: intToCharLit :: Literal -> Literal

+ GHC.Types.Literal: intToDoubleLit :: Literal -> Literal

+ GHC.Types.Literal: intToFloatLit :: Literal -> Literal

+ GHC.Types.Literal: isMaxBound :: Platform -> Literal -> Bool

+ GHC.Types.Literal: isMinBound :: Platform -> Literal -> Bool

+ GHC.Types.Literal: isOneLit :: Literal -> Bool

+ GHC.Types.Literal: isRubbishLit :: Literal -> Bool

+ GHC.Types.Literal: litNumBitSize :: Platform -> LitNumType -> Maybe Word

+ GHC.Types.Literal: litNumCoerce :: LitNumType -> Platform -> Literal -> Literal

+ GHC.Types.Literal: litNumNarrow :: LitNumType -> Platform -> Literal -> Literal

+ GHC.Types.Literal: litNumWrap :: Platform -> Literal -> Literal

+ GHC.Types.Literal: mkLitInt16 :: Integer -> Literal

+ GHC.Types.Literal: mkLitInt16Wrap :: Integer -> Literal

+ GHC.Types.Literal: mkLitInt32 :: Integer -> Literal

+ GHC.Types.Literal: mkLitInt32Wrap :: Integer -> Literal

+ GHC.Types.Literal: mkLitInt8 :: Integer -> Literal

+ GHC.Types.Literal: mkLitInt8Wrap :: Integer -> Literal

+ GHC.Types.Literal: mkLitWord16 :: Integer -> Literal

+ GHC.Types.Literal: mkLitWord16Wrap :: Integer -> Literal

+ GHC.Types.Literal: mkLitWord32 :: Integer -> Literal

+ GHC.Types.Literal: mkLitWord32Wrap :: Integer -> Literal

+ GHC.Types.Literal: mkLitWord8 :: Integer -> Literal

+ GHC.Types.Literal: mkLitWord8Wrap :: Integer -> Literal

+ GHC.Types.Literal: narrowInt16Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowInt32Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowInt64Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowInt8Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowWord16Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowWord32Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowWord64Lit :: Literal -> Literal

+ GHC.Types.Literal: narrowWord8Lit :: Literal -> Literal

+ GHC.Types.Meta: MetaAW :: (Serialized -> MetaResult) -> MetaRequest

+ GHC.Types.Meta: MetaD :: ([LHsDecl GhcPs] -> MetaResult) -> MetaRequest

+ GHC.Types.Meta: MetaE :: (LHsExpr GhcPs -> MetaResult) -> MetaRequest

+ GHC.Types.Meta: MetaP :: (LPat GhcPs -> MetaResult) -> MetaRequest

+ GHC.Types.Meta: MetaT :: (LHsType GhcPs -> MetaResult) -> MetaRequest

+ GHC.Types.Meta: data MetaRequest

+ GHC.Types.Meta: data MetaResult

+ GHC.Types.Meta: metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized

+ GHC.Types.Meta: metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]

+ GHC.Types.Meta: metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)

+ GHC.Types.Meta: metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)

+ GHC.Types.Meta: metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)

+ GHC.Types.Meta: type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult

+ GHC.Types.Name.Occurrence: promoteOccName :: OccName -> Maybe OccName

+ GHC.Types.Name.Ppr: mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified

+ GHC.Types.Name.Ppr: mkQualModule :: UnitState -> HomeUnit -> QueryQualifyModule

+ GHC.Types.Name.Ppr: mkQualPackage :: UnitState -> QueryQualifyPackage

+ GHC.Types.Name.Ppr: pkgQual :: UnitState -> PrintUnqualified

+ GHC.Types.Name.Reader: FieldGreName :: FieldLabel -> GreName

+ GHC.Types.Name.Reader: NormalGreName :: Name -> GreName

+ GHC.Types.Name.Reader: data GreName

+ GHC.Types.Name.Reader: greDefinitionModule :: GlobalRdrElt -> Maybe Module

+ GHC.Types.Name.Reader: greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan

+ GHC.Types.Name.Reader: greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel

+ GHC.Types.Name.Reader: greMangledName :: GlobalRdrElt -> Name

+ GHC.Types.Name.Reader: greNameSrcSpan :: GreName -> SrcSpan

+ GHC.Types.Name.Reader: grePrintableName :: GlobalRdrElt -> Name

+ GHC.Types.Name.Reader: instance GHC.Types.Name.Occurrence.HasOccName GHC.Types.Name.Reader.GlobalRdrElt

+ GHC.Types.Name.Reader: isDuplicateRecFldGRE :: GlobalRdrElt -> Bool

+ GHC.Types.Name.Reader: isFieldSelectorGRE :: GlobalRdrElt -> Bool

+ GHC.Types.Name.Reader: isNoFieldSelectorGRE :: GlobalRdrElt -> Bool

+ GHC.Types.Name.Reader: lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt

+ GHC.Types.Name.Reader: lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]

+ GHC.Types.Name.Reader: opIsAt :: RdrName -> Bool

+ GHC.Types.Name.Reader: promoteRdrName :: RdrName -> Maybe RdrName

+ GHC.Types.SafeHaskell: Sf_Ignore :: SafeHaskellMode

+ GHC.Types.SafeHaskell: Sf_None :: SafeHaskellMode

+ GHC.Types.SafeHaskell: Sf_Safe :: SafeHaskellMode

+ GHC.Types.SafeHaskell: Sf_SafeInferred :: SafeHaskellMode

+ GHC.Types.SafeHaskell: Sf_Trustworthy :: SafeHaskellMode

+ GHC.Types.SafeHaskell: Sf_Unsafe :: SafeHaskellMode

+ GHC.Types.SafeHaskell: data IfaceTrustInfo

+ GHC.Types.SafeHaskell: data SafeHaskellMode

+ GHC.Types.SafeHaskell: getSafeMode :: IfaceTrustInfo -> SafeHaskellMode

+ GHC.Types.SafeHaskell: instance GHC.Classes.Eq GHC.Types.SafeHaskell.SafeHaskellMode

+ GHC.Types.SafeHaskell: instance GHC.Show.Show GHC.Types.SafeHaskell.SafeHaskellMode

+ GHC.Types.SafeHaskell: instance GHC.Utils.Binary.Binary GHC.Types.SafeHaskell.IfaceTrustInfo

+ GHC.Types.SafeHaskell: instance GHC.Utils.Outputable.Outputable GHC.Types.SafeHaskell.IfaceTrustInfo

+ GHC.Types.SafeHaskell: instance GHC.Utils.Outputable.Outputable GHC.Types.SafeHaskell.SafeHaskellMode

+ GHC.Types.SafeHaskell: noIfaceTrustInfo :: IfaceTrustInfo

+ GHC.Types.SafeHaskell: setSafeMode :: SafeHaskellMode -> IfaceTrustInfo

+ GHC.Types.SafeHaskell: type IsSafeImport = Bool

+ GHC.Types.SourceError: SourceError :: ErrorMessages -> SourceError

+ GHC.Types.SourceError: handleSourceError :: MonadCatch m => (SourceError -> m a) -> m a -> m a

+ GHC.Types.SourceError: instance GHC.Exception.Type.Exception GHC.Types.SourceError.SourceError

+ GHC.Types.SourceError: instance GHC.Show.Show GHC.Types.SourceError.SourceError

+ GHC.Types.SourceError: mkSrcErr :: ErrorMessages -> SourceError

+ GHC.Types.SourceError: newtype SourceError

+ GHC.Types.SourceError: srcErrorMessages :: SourceError -> ErrorMessages

+ GHC.Types.SourceError: throwErrors :: MonadIO io => ErrorMessages -> io a

+ GHC.Types.SourceError: throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> io a

+ GHC.Types.SourceFile: HsBootFile :: HscSource

+ GHC.Types.SourceFile: HsSrcFile :: HscSource

+ GHC.Types.SourceFile: HsigFile :: HscSource

+ GHC.Types.SourceFile: SourceModified :: SourceModified

+ GHC.Types.SourceFile: SourceUnmodified :: SourceModified

+ GHC.Types.SourceFile: SourceUnmodifiedAndStable :: SourceModified

+ GHC.Types.SourceFile: data HscSource

+ GHC.Types.SourceFile: data SourceModified

+ GHC.Types.SourceFile: hscSourceString :: HscSource -> String

+ GHC.Types.SourceFile: instance GHC.Classes.Eq GHC.Types.SourceFile.HscSource

+ GHC.Types.SourceFile: instance GHC.Classes.Ord GHC.Types.SourceFile.HscSource

+ GHC.Types.SourceFile: instance GHC.Show.Show GHC.Types.SourceFile.HscSource

+ GHC.Types.SourceFile: instance GHC.Utils.Binary.Binary GHC.Types.SourceFile.HscSource

+ GHC.Types.SourceFile: isHsBootOrSig :: HscSource -> Bool

+ GHC.Types.SourceFile: isHsigFile :: HscSource -> Bool

+ GHC.Types.SourceText: Base10 :: FractionalExponentBase

+ GHC.Types.SourceText: Base2 :: FractionalExponentBase

+ GHC.Types.SourceText: FL :: SourceText -> Bool -> Rational -> Integer -> FractionalExponentBase -> FractionalLit

+ GHC.Types.SourceText: IL :: SourceText -> Bool -> Integer -> IntegralLit

+ GHC.Types.SourceText: NoSourceText :: SourceText

+ GHC.Types.SourceText: SourceText :: String -> SourceText

+ GHC.Types.SourceText: StringLiteral :: SourceText -> FastString -> Maybe RealSrcSpan -> StringLiteral

+ GHC.Types.SourceText: [fl_exp] :: FractionalLit -> Integer

+ GHC.Types.SourceText: [fl_exp_base] :: FractionalLit -> FractionalExponentBase

+ GHC.Types.SourceText: [fl_neg] :: FractionalLit -> Bool

+ GHC.Types.SourceText: [fl_signi] :: FractionalLit -> Rational

+ GHC.Types.SourceText: [fl_text] :: FractionalLit -> SourceText

+ GHC.Types.SourceText: [il_neg] :: IntegralLit -> Bool

+ GHC.Types.SourceText: [il_text] :: IntegralLit -> SourceText

+ GHC.Types.SourceText: [il_value] :: IntegralLit -> Integer

+ GHC.Types.SourceText: [sl_fs] :: StringLiteral -> FastString

+ GHC.Types.SourceText: [sl_st] :: StringLiteral -> SourceText

+ GHC.Types.SourceText: [sl_tc] :: StringLiteral -> Maybe RealSrcSpan

+ GHC.Types.SourceText: data FractionalExponentBase

+ GHC.Types.SourceText: data FractionalLit

+ GHC.Types.SourceText: data IntegralLit

+ GHC.Types.SourceText: data SourceText

+ GHC.Types.SourceText: data StringLiteral

+ GHC.Types.SourceText: fractionalLitFromRational :: Rational -> FractionalLit

+ GHC.Types.SourceText: instance Data.Data.Data GHC.Types.SourceText.FractionalExponentBase

+ GHC.Types.SourceText: instance Data.Data.Data GHC.Types.SourceText.FractionalLit

+ GHC.Types.SourceText: instance Data.Data.Data GHC.Types.SourceText.IntegralLit

+ GHC.Types.SourceText: instance Data.Data.Data GHC.Types.SourceText.SourceText

+ GHC.Types.SourceText: instance Data.Data.Data GHC.Types.SourceText.StringLiteral

+ GHC.Types.SourceText: instance GHC.Classes.Eq GHC.Types.SourceText.FractionalExponentBase

+ GHC.Types.SourceText: instance GHC.Classes.Eq GHC.Types.SourceText.FractionalLit

+ GHC.Types.SourceText: instance GHC.Classes.Eq GHC.Types.SourceText.IntegralLit

+ GHC.Types.SourceText: instance GHC.Classes.Eq GHC.Types.SourceText.SourceText

+ GHC.Types.SourceText: instance GHC.Classes.Eq GHC.Types.SourceText.StringLiteral

+ GHC.Types.SourceText: instance GHC.Classes.Ord GHC.Types.SourceText.FractionalExponentBase

+ GHC.Types.SourceText: instance GHC.Classes.Ord GHC.Types.SourceText.FractionalLit

+ GHC.Types.SourceText: instance GHC.Classes.Ord GHC.Types.SourceText.IntegralLit

+ GHC.Types.SourceText: instance GHC.Show.Show GHC.Types.SourceText.FractionalExponentBase

+ GHC.Types.SourceText: instance GHC.Show.Show GHC.Types.SourceText.FractionalLit

+ GHC.Types.SourceText: instance GHC.Show.Show GHC.Types.SourceText.IntegralLit

+ GHC.Types.SourceText: instance GHC.Show.Show GHC.Types.SourceText.SourceText

+ GHC.Types.SourceText: instance GHC.Utils.Binary.Binary GHC.Types.SourceText.SourceText

+ GHC.Types.SourceText: instance GHC.Utils.Binary.Binary GHC.Types.SourceText.StringLiteral

+ GHC.Types.SourceText: instance GHC.Utils.Outputable.Outputable GHC.Types.SourceText.FractionalLit

+ GHC.Types.SourceText: instance GHC.Utils.Outputable.Outputable GHC.Types.SourceText.IntegralLit

+ GHC.Types.SourceText: instance GHC.Utils.Outputable.Outputable GHC.Types.SourceText.SourceText

+ GHC.Types.SourceText: instance GHC.Utils.Outputable.Outputable GHC.Types.SourceText.StringLiteral

+ GHC.Types.SourceText: integralFractionalLit :: Bool -> Integer -> FractionalLit

+ GHC.Types.SourceText: mkFractionalLit :: SourceText -> Bool -> Rational -> Integer -> FractionalExponentBase -> FractionalLit

+ GHC.Types.SourceText: mkIntegralLit :: Integral a => a -> IntegralLit

+ GHC.Types.SourceText: mkSourceFractionalLit :: String -> Bool -> Integer -> Integer -> FractionalExponentBase -> FractionalLit

+ GHC.Types.SourceText: mkTHFractionalLit :: Rational -> FractionalLit

+ GHC.Types.SourceText: negateFractionalLit :: FractionalLit -> FractionalLit

+ GHC.Types.SourceText: negateIntegralLit :: IntegralLit -> IntegralLit

+ GHC.Types.SourceText: pprWithSourceText :: SourceText -> SDoc -> SDoc

+ GHC.Types.SourceText: rationalFromFractionalLit :: FractionalLit -> Rational

+ GHC.Types.SrcLoc: combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan

+ GHC.Types.SrcLoc: instance GHC.Utils.Outputable.Outputable e => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated GHC.Types.SrcLoc.RealSrcSpan e)

+ GHC.Types.SrcLoc: instance GHC.Utils.Outputable.Outputable e => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.Located e)

+ GHC.Types.SrcLoc: isZeroWidthSpan :: SrcSpan -> Bool

+ GHC.Types.SrcLoc: pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc

+ GHC.Types.SrcLoc: pprUserSpan :: Bool -> SrcSpan -> SDoc

+ GHC.Types.SrcLoc: srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan

+ GHC.Types.Target: Target :: !TargetId -> !Bool -> !Maybe (InputFileBuffer, UTCTime) -> Target

+ GHC.Types.Target: TargetFile :: !FilePath -> !Maybe Phase -> TargetId

+ GHC.Types.Target: TargetModule :: !ModuleName -> TargetId

+ GHC.Types.Target: [targetAllowObjCode] :: Target -> !Bool

+ GHC.Types.Target: [targetContents] :: Target -> !Maybe (InputFileBuffer, UTCTime)

+ GHC.Types.Target: [targetId] :: Target -> !TargetId

+ GHC.Types.Target: data Target

+ GHC.Types.Target: data TargetId

+ GHC.Types.Target: instance GHC.Classes.Eq GHC.Types.Target.TargetId

+ GHC.Types.Target: instance GHC.Utils.Outputable.Outputable GHC.Types.Target.Target

+ GHC.Types.Target: instance GHC.Utils.Outputable.Outputable GHC.Types.Target.TargetId

+ GHC.Types.Target: pprTarget :: Target -> SDoc

+ GHC.Types.Target: pprTargetId :: TargetId -> SDoc

+ GHC.Types.Target: type InputFileBuffer = StringBuffer

+ GHC.Types.Tickish: Breakpoint :: XBreakpoint pass -> !Int -> [XTickishId pass] -> GenTickish pass

+ GHC.Types.Tickish: CostCentreScope :: TickishScoping

+ GHC.Types.Tickish: HpcTick :: Module -> !Int -> GenTickish pass

+ GHC.Types.Tickish: NoScope :: TickishScoping

+ GHC.Types.Tickish: PlaceCostCentre :: TickishPlacement

+ GHC.Types.Tickish: PlaceNonLam :: TickishPlacement

+ GHC.Types.Tickish: PlaceRuntime :: TickishPlacement

+ GHC.Types.Tickish: ProfNote :: CostCentre -> !Bool -> !Bool -> GenTickish pass

+ GHC.Types.Tickish: SoftScope :: TickishScoping

+ GHC.Types.Tickish: SourceNote :: RealSrcSpan -> String -> GenTickish pass

+ GHC.Types.Tickish: [breakpointExt] :: GenTickish pass -> XBreakpoint pass

+ GHC.Types.Tickish: [breakpointFVs] :: GenTickish pass -> [XTickishId pass]

+ GHC.Types.Tickish: [breakpointId] :: GenTickish pass -> !Int

+ GHC.Types.Tickish: [profNoteCC] :: GenTickish pass -> CostCentre

+ GHC.Types.Tickish: [profNoteCount] :: GenTickish pass -> !Bool

+ GHC.Types.Tickish: [profNoteScope] :: GenTickish pass -> !Bool

+ GHC.Types.Tickish: [sourceName] :: GenTickish pass -> String

+ GHC.Types.Tickish: [sourceSpan] :: GenTickish pass -> RealSrcSpan

+ GHC.Types.Tickish: [tickId] :: GenTickish pass -> !Int

+ GHC.Types.Tickish: [tickModule] :: GenTickish pass -> Module

+ GHC.Types.Tickish: data GenTickish pass

+ GHC.Types.Tickish: data TickishPlacement

+ GHC.Types.Tickish: data TickishScoping

+ GHC.Types.Tickish: instance Data.Data.Data (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassCmm)

+ GHC.Types.Tickish: instance Data.Data.Data (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassCore)

+ GHC.Types.Tickish: instance Data.Data.Data (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassStg)

+ GHC.Types.Tickish: instance GHC.Classes.Eq (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassCmm)

+ GHC.Types.Tickish: instance GHC.Classes.Eq (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassCore)

+ GHC.Types.Tickish: instance GHC.Classes.Eq GHC.Types.Tickish.TickishPlacement

+ GHC.Types.Tickish: instance GHC.Classes.Eq GHC.Types.Tickish.TickishScoping

+ GHC.Types.Tickish: instance GHC.Classes.Ord (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassCmm)

+ GHC.Types.Tickish: instance GHC.Classes.Ord (GHC.Types.Tickish.GenTickish 'GHC.Types.Tickish.TickishPassCore)

+ GHC.Types.Tickish: mkNoCount :: GenTickish pass -> GenTickish pass

+ GHC.Types.Tickish: mkNoScope :: GenTickish pass -> GenTickish pass

+ GHC.Types.Tickish: tickishCanSplit :: GenTickish pass -> Bool

+ GHC.Types.Tickish: tickishContains :: Eq (GenTickish pass) => GenTickish pass -> GenTickish pass -> Bool

+ GHC.Types.Tickish: tickishCounts :: GenTickish pass -> Bool

+ GHC.Types.Tickish: tickishFloatable :: GenTickish pass -> Bool

+ GHC.Types.Tickish: tickishIsCode :: GenTickish pass -> Bool

+ GHC.Types.Tickish: tickishPlace :: GenTickish pass -> TickishPlacement

+ GHC.Types.Tickish: tickishScoped :: GenTickish pass -> TickishScoping

+ GHC.Types.Tickish: tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool

+ GHC.Types.Tickish: type CmmTickish = GenTickish 'TickishPassCmm

+ GHC.Types.Tickish: type CoreTickish = GenTickish 'TickishPassCore

+ GHC.Types.Tickish: type StgTickish = GenTickish 'TickishPassStg

+ GHC.Types.Tickish: type family XTickishId (pass :: TickishPass)

+ GHC.Types.TyThing: ACoAxiom :: CoAxiom Branched -> TyThing

+ GHC.Types.TyThing: AConLike :: ConLike -> TyThing

+ GHC.Types.TyThing: ATyCon :: TyCon -> TyThing

+ GHC.Types.TyThing: AnId :: Id -> TyThing

+ GHC.Types.TyThing: class Monad m => MonadThings m

+ GHC.Types.TyThing: data TyThing

+ GHC.Types.TyThing: implicitClassThings :: Class -> [TyThing]

+ GHC.Types.TyThing: implicitCoTyCon :: TyCon -> [TyThing]

+ GHC.Types.TyThing: implicitConLikeThings :: ConLike -> [TyThing]

+ GHC.Types.TyThing: implicitTyConThings :: TyCon -> [TyThing]

+ GHC.Types.TyThing: implicitTyThings :: TyThing -> [TyThing]

+ GHC.Types.TyThing: instance GHC.Types.Name.NamedThing GHC.Types.TyThing.TyThing

+ GHC.Types.TyThing: instance GHC.Types.TyThing.MonadThings m => GHC.Types.TyThing.MonadThings (Control.Monad.Trans.Reader.ReaderT s m)

+ GHC.Types.TyThing: instance GHC.Utils.Outputable.Outputable GHC.Types.TyThing.TyThing

+ GHC.Types.TyThing: isImplicitTyThing :: TyThing -> Bool

+ GHC.Types.TyThing: lookupDataCon :: MonadThings m => Name -> m DataCon

+ GHC.Types.TyThing: lookupId :: MonadThings m => Name -> m Id

+ GHC.Types.TyThing: lookupThing :: MonadThings m => Name -> m TyThing

+ GHC.Types.TyThing: lookupTyCon :: MonadThings m => Name -> m TyCon

+ GHC.Types.TyThing: mkATyCon :: TyCon -> TyThing

+ GHC.Types.TyThing: mkAnId :: Id -> TyThing

+ GHC.Types.TyThing: pprShortTyThing :: TyThing -> SDoc

+ GHC.Types.TyThing: pprTyThingCategory :: TyThing -> SDoc

+ GHC.Types.TyThing: tyThingAvailInfo :: TyThing -> [AvailInfo]

+ GHC.Types.TyThing: tyThingCategory :: TyThing -> String

+ GHC.Types.TyThing: tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched

+ GHC.Types.TyThing: tyThingConLike :: HasDebugCallStack => TyThing -> ConLike

+ GHC.Types.TyThing: tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon

+ GHC.Types.TyThing: tyThingId :: HasDebugCallStack => TyThing -> Id

+ GHC.Types.TyThing: tyThingParent_maybe :: TyThing -> Maybe TyThing

+ GHC.Types.TyThing: tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon

+ GHC.Types.TyThing: tyThingsTyCoVars :: [TyThing] -> TyCoVarSet

+ GHC.Types.TyThing.Ppr: pprFamInst :: FamInst -> SDoc

+ GHC.Types.TyThing.Ppr: pprTyThing :: ShowSub -> TyThing -> SDoc

+ GHC.Types.TyThing.Ppr: pprTyThingHdr :: TyThing -> SDoc

+ GHC.Types.TyThing.Ppr: pprTyThingInContext :: ShowSub -> TyThing -> SDoc

+ GHC.Types.TyThing.Ppr: pprTyThingInContextLoc :: TyThing -> SDoc

+ GHC.Types.TyThing.Ppr: pprTyThingLoc :: TyThing -> SDoc

+ GHC.Types.TyThing.Ppr: pprTypeForUser :: Type -> SDoc

+ GHC.Types.TypeEnv: emptyTypeEnv :: TypeEnv

+ GHC.Types.TypeEnv: extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv

+ GHC.Types.TypeEnv: extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv

+ GHC.Types.TypeEnv: extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv

+ GHC.Types.TypeEnv: lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing

+ GHC.Types.TypeEnv: mkTypeEnv :: [TyThing] -> TypeEnv

+ GHC.Types.TypeEnv: mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv

+ GHC.Types.TypeEnv: plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv

+ GHC.Types.TypeEnv: type TypeEnv = NameEnv TyThing

+ GHC.Types.TypeEnv: typeEnvClasses :: TypeEnv -> [Class]

+ GHC.Types.TypeEnv: typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]

+ GHC.Types.TypeEnv: typeEnvDataCons :: TypeEnv -> [DataCon]

+ GHC.Types.TypeEnv: typeEnvElts :: TypeEnv -> [TyThing]

+ GHC.Types.TypeEnv: typeEnvFromEntities :: [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv

+ GHC.Types.TypeEnv: typeEnvIds :: TypeEnv -> [Id]

+ GHC.Types.TypeEnv: typeEnvPatSyns :: TypeEnv -> [PatSyn]

+ GHC.Types.TypeEnv: typeEnvTyCons :: TypeEnv -> [TyCon]

+ GHC.Types.Unique: stepUnique :: Unique -> Int -> Unique

+ GHC.Types.Unique.DFM: instance Data.Foldable.Foldable GHC.Types.Unique.DFM.TaggedVal

+ GHC.Types.Unique.DFM: instance Data.Traversable.Traversable GHC.Types.Unique.DFM.TaggedVal

+ GHC.Types.Unique.DFM: mapMaybeUDFM :: forall elt1 elt2 key. (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2

+ GHC.Types.Unique.FM: zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt

+ GHC.Types.Unique.Map: UniqMap :: UniqFM k (k, a) -> UniqMap k a

+ GHC.Types.Unique.Map: addListToUniqMap :: Uniquable k => UniqMap k a -> [(k, a)] -> UniqMap k a

+ GHC.Types.Unique.Map: addListToUniqMap_C :: Uniquable k => (a -> a -> a) -> UniqMap k a -> [(k, a)] -> UniqMap k a

+ GHC.Types.Unique.Map: addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a

+ GHC.Types.Unique.Map: addToUniqMap_Acc :: Uniquable k => (b -> a -> a) -> (b -> a) -> UniqMap k a -> k -> b -> UniqMap k a

+ GHC.Types.Unique.Map: addToUniqMap_C :: Uniquable k => (a -> a -> a) -> UniqMap k a -> k -> a -> UniqMap k a

+ GHC.Types.Unique.Map: adjustUniqMap :: Uniquable k => (a -> a) -> UniqMap k a -> k -> UniqMap k a

+ GHC.Types.Unique.Map: allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool

+ GHC.Types.Unique.Map: alterUniqMap :: Uniquable k => (Maybe a -> Maybe a) -> UniqMap k a -> k -> UniqMap k a

+ GHC.Types.Unique.Map: anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool

+ GHC.Types.Unique.Map: delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a

+ GHC.Types.Unique.Map: delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a

+ GHC.Types.Unique.Map: disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool

+ GHC.Types.Unique.Map: elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool

+ GHC.Types.Unique.Map: emptyUniqMap :: UniqMap k a

+ GHC.Types.Unique.Map: filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a

+ GHC.Types.Unique.Map: instance (Data.Data.Data k, Data.Data.Data a) => Data.Data.Data (GHC.Types.Unique.Map.UniqMap k a)

+ GHC.Types.Unique.Map: instance (GHC.Classes.Eq k, GHC.Classes.Eq a) => GHC.Classes.Eq (GHC.Types.Unique.Map.UniqMap k a)

+ GHC.Types.Unique.Map: instance (GHC.Utils.Outputable.Outputable k, GHC.Utils.Outputable.Outputable a) => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.Map.UniqMap k a)

+ GHC.Types.Unique.Map: instance GHC.Base.Functor (GHC.Types.Unique.Map.UniqMap k)

+ GHC.Types.Unique.Map: instance GHC.Base.Monoid (GHC.Types.Unique.Map.UniqMap k a)

+ GHC.Types.Unique.Map: instance GHC.Base.Semigroup (GHC.Types.Unique.Map.UniqMap k a)

+ GHC.Types.Unique.Map: intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a

+ GHC.Types.Unique.Map: isNullUniqMap :: UniqMap k a -> Bool

+ GHC.Types.Unique.Map: listToUniqMap :: Uniquable k => [(k, a)] -> UniqMap k a

+ GHC.Types.Unique.Map: listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k, a)] -> UniqMap k a

+ GHC.Types.Unique.Map: lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a

+ GHC.Types.Unique.Map: lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a

+ GHC.Types.Unique.Map: mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b

+ GHC.Types.Unique.Map: minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a

+ GHC.Types.Unique.Map: newtype UniqMap k a

+ GHC.Types.Unique.Map: partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)

+ GHC.Types.Unique.Map: plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a

+ GHC.Types.Unique.Map: plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a

+ GHC.Types.Unique.Map: plusUniqMapList :: [UniqMap k a] -> UniqMap k a

+ GHC.Types.Unique.Map: plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a

+ GHC.Types.Unique.Map: sizeUniqMap :: UniqMap k a -> Int

+ GHC.Types.Unique.Map: unitUniqMap :: Uniquable k => k -> a -> UniqMap k a

+ GHC.Types.Unique.SDFM: addToUSDFM :: Uniquable key => UniqSDFM key ele -> key -> ele -> UniqSDFM key ele

+ GHC.Types.Unique.SDFM: data UniqSDFM key ele

+ GHC.Types.Unique.SDFM: emptyUSDFM :: UniqSDFM key ele

+ GHC.Types.Unique.SDFM: equateUSDFM :: Uniquable key => UniqSDFM key ele -> key -> key -> (Maybe ele, UniqSDFM key ele)

+ GHC.Types.Unique.SDFM: instance (GHC.Utils.Outputable.Outputable key, GHC.Utils.Outputable.Outputable ele) => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.SDFM.Shared key ele)

+ GHC.Types.Unique.SDFM: instance (GHC.Utils.Outputable.Outputable key, GHC.Utils.Outputable.Outputable ele) => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.SDFM.UniqSDFM key ele)

+ GHC.Types.Unique.SDFM: lookupUSDFM :: Uniquable key => UniqSDFM key ele -> key -> Maybe ele

+ GHC.Types.Unique.SDFM: traverseUSDFM :: forall key a b f. Applicative f => (a -> f b) -> UniqSDFM key a -> f (UniqSDFM key b)

+ GHC.Types.Var: isInferredArgFlag :: ArgFlag -> Bool

+ GHC.Types.Var: tyVarReqToBinder :: VarBndr a () -> VarBndr a ArgFlag

+ GHC.Types.Var: tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ArgFlag]

+ GHC.Unit.Env: UnitEnv :: !UnitState -> !HomeUnit -> !Platform -> !GhcNameVersion -> UnitEnv

+ GHC.Unit.Env: [ue_home_unit] :: UnitEnv -> !HomeUnit

+ GHC.Unit.Env: [ue_namever] :: UnitEnv -> !GhcNameVersion

+ GHC.Unit.Env: [ue_platform] :: UnitEnv -> !Platform

+ GHC.Unit.Env: [ue_units] :: UnitEnv -> !UnitState

+ GHC.Unit.Env: data UnitEnv

+ GHC.Unit.Env: preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo]

+ GHC.Unit.Env: preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]

+ GHC.Unit.External: EPS :: !ModuleNameEnv ModuleNameWithIsBoot -> !PackageIfaceTable -> InstalledModuleEnv (UniqDSet ModuleName) -> !PackageTypeEnv -> !PackageInstEnv -> !PackageFamInstEnv -> !PackageRuleBase -> !PackageAnnEnv -> !PackageCompleteMatches -> !ModuleEnv FamInstEnv -> !EpsStats -> ExternalPackageState

+ GHC.Unit.External: EpsStats :: !Int -> EpsStats

+ GHC.Unit.External: [eps_PIT] :: ExternalPackageState -> !PackageIfaceTable

+ GHC.Unit.External: [eps_PTE] :: ExternalPackageState -> !PackageTypeEnv

+ GHC.Unit.External: [eps_ann_env] :: ExternalPackageState -> !PackageAnnEnv

+ GHC.Unit.External: [eps_complete_matches] :: ExternalPackageState -> !PackageCompleteMatches

+ GHC.Unit.External: [eps_fam_inst_env] :: ExternalPackageState -> !PackageFamInstEnv

+ GHC.Unit.External: [eps_free_holes] :: ExternalPackageState -> InstalledModuleEnv (UniqDSet ModuleName)

+ GHC.Unit.External: [eps_inst_env] :: ExternalPackageState -> !PackageInstEnv

+ GHC.Unit.External: [eps_is_boot] :: ExternalPackageState -> !ModuleNameEnv ModuleNameWithIsBoot

+ GHC.Unit.External: [eps_mod_fam_inst_env] :: ExternalPackageState -> !ModuleEnv FamInstEnv

+ GHC.Unit.External: [eps_rule_base] :: ExternalPackageState -> !PackageRuleBase

+ GHC.Unit.External: [eps_stats] :: ExternalPackageState -> !EpsStats

+ GHC.Unit.External: [n_ifaces_in, n_decls_in, n_decls_out, n_rules_in, n_rules_out, n_insts_in, n_insts_out] :: EpsStats -> !Int

+ GHC.Unit.External: addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats

+ GHC.Unit.External: data EpsStats

+ GHC.Unit.External: data ExternalPackageState

+ GHC.Unit.External: emptyPackageIfaceTable :: PackageIfaceTable

+ GHC.Unit.External: type PackageCompleteMatches = CompleteMatches

+ GHC.Unit.External: type PackageFamInstEnv = FamInstEnv

+ GHC.Unit.External: type PackageIfaceTable = ModuleEnv ModIface

+ GHC.Unit.External: type PackageInstEnv = InstEnv

+ GHC.Unit.External: type PackageRuleBase = RuleBase

+ GHC.Unit.External: type PackageTypeEnv = TypeEnv

+ GHC.Unit.Finder: Found :: ModLocation -> Module -> FindResult

+ GHC.Unit.Finder: FoundMultiple :: [(Module, ModuleOrigin)] -> FindResult

+ GHC.Unit.Finder: InstalledFound :: ModLocation -> InstalledModule -> InstalledFindResult

+ GHC.Unit.Finder: InstalledNoPackage :: UnitId -> InstalledFindResult

+ GHC.Unit.Finder: InstalledNotFound :: [FilePath] -> Maybe UnitId -> InstalledFindResult

+ GHC.Unit.Finder: NoPackage :: Unit -> FindResult

+ GHC.Unit.Finder: NotFound :: [FilePath] -> Maybe Unit -> [Unit] -> [Unit] -> [(Unit, UnusableUnitReason)] -> [ModuleSuggestion] -> FindResult

+ GHC.Unit.Finder: [fr_mods_hidden] :: FindResult -> [Unit]

+ GHC.Unit.Finder: [fr_paths] :: FindResult -> [FilePath]

+ GHC.Unit.Finder: [fr_pkg] :: FindResult -> Maybe Unit

+ GHC.Unit.Finder: [fr_pkgs_hidden] :: FindResult -> [Unit]

+ GHC.Unit.Finder: [fr_suggestions] :: FindResult -> [ModuleSuggestion]

+ GHC.Unit.Finder: [fr_unusables] :: FindResult -> [(Unit, UnusableUnitReason)]

+ GHC.Unit.Finder: addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module

+ GHC.Unit.Finder: data FindResult

+ GHC.Unit.Finder: data InstalledFindResult

+ GHC.Unit.Finder: findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult

+ GHC.Unit.Finder: findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult

+ GHC.Unit.Finder: findHomeModule :: HscEnv -> ModuleName -> IO FindResult

+ GHC.Unit.Finder: findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult

+ GHC.Unit.Finder: findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable

+ GHC.Unit.Finder: findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)

+ GHC.Unit.Finder: findPluginModule :: HscEnv -> ModuleName -> IO FindResult

+ GHC.Unit.Finder: flushFinderCaches :: HscEnv -> IO ()

+ GHC.Unit.Finder: mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String -> IO ModLocation

+ GHC.Unit.Finder: mkHiPath :: DynFlags -> FilePath -> String -> FilePath

+ GHC.Unit.Finder: mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation

+ GHC.Unit.Finder: mkHomeModLocation2 :: DynFlags -> ModuleName -> FilePath -> String -> IO ModLocation

+ GHC.Unit.Finder: mkObjPath :: DynFlags -> FilePath -> String -> FilePath

+ GHC.Unit.Finder: mkStubPaths :: DynFlags -> ModuleName -> ModLocation -> FilePath

+ GHC.Unit.Finder: type FinderCache = InstalledModuleEnv InstalledFindResult

+ GHC.Unit.Finder: uncacheModule :: HscEnv -> ModuleName -> IO ()

+ GHC.Unit.Finder.Types: Found :: ModLocation -> Module -> FindResult

+ GHC.Unit.Finder.Types: FoundMultiple :: [(Module, ModuleOrigin)] -> FindResult

+ GHC.Unit.Finder.Types: InstalledFound :: ModLocation -> InstalledModule -> InstalledFindResult

+ GHC.Unit.Finder.Types: InstalledNoPackage :: UnitId -> InstalledFindResult

+ GHC.Unit.Finder.Types: InstalledNotFound :: [FilePath] -> Maybe UnitId -> InstalledFindResult

+ GHC.Unit.Finder.Types: NoPackage :: Unit -> FindResult

+ GHC.Unit.Finder.Types: NotFound :: [FilePath] -> Maybe Unit -> [Unit] -> [Unit] -> [(Unit, UnusableUnitReason)] -> [ModuleSuggestion] -> FindResult

+ GHC.Unit.Finder.Types: [fr_mods_hidden] :: FindResult -> [Unit]

+ GHC.Unit.Finder.Types: [fr_paths] :: FindResult -> [FilePath]

+ GHC.Unit.Finder.Types: [fr_pkg] :: FindResult -> Maybe Unit

+ GHC.Unit.Finder.Types: [fr_pkgs_hidden] :: FindResult -> [Unit]

+ GHC.Unit.Finder.Types: [fr_suggestions] :: FindResult -> [ModuleSuggestion]

+ GHC.Unit.Finder.Types: [fr_unusables] :: FindResult -> [(Unit, UnusableUnitReason)]

+ GHC.Unit.Finder.Types: data FindResult

+ GHC.Unit.Finder.Types: data InstalledFindResult

+ GHC.Unit.Finder.Types: type FinderCache = InstalledModuleEnv InstalledFindResult

+ GHC.Unit.Home: DefiniteHomeUnit :: UnitId -> Maybe (u, GenInstantiations u) -> GenHomeUnit u

+ GHC.Unit.Home: IndefiniteHomeUnit :: UnitId -> GenInstantiations u -> GenHomeUnit u

+ GHC.Unit.Home: data GenHomeUnit u

+ GHC.Unit.Home: homeModuleInstantiation :: HomeUnit -> Module -> Module

+ GHC.Unit.Home: homeModuleNameInstantiation :: HomeUnit -> ModuleName -> Module

+ GHC.Unit.Home: homeUnitAsUnit :: HomeUnit -> Unit

+ GHC.Unit.Home: homeUnitId :: GenHomeUnit u -> UnitId

+ GHC.Unit.Home: homeUnitInstanceOf :: HomeUnit -> UnitId

+ GHC.Unit.Home: homeUnitInstanceOfMaybe :: GenHomeUnit u -> Maybe u

+ GHC.Unit.Home: homeUnitInstantiations :: GenHomeUnit u -> GenInstantiations u

+ GHC.Unit.Home: homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v

+ GHC.Unit.Home: isHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool

+ GHC.Unit.Home: isHomeModule :: HomeUnit -> Module -> Bool

+ GHC.Unit.Home: isHomeUnit :: HomeUnit -> Unit -> Bool

+ GHC.Unit.Home: isHomeUnitDefinite :: GenHomeUnit u -> Bool

+ GHC.Unit.Home: isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool

+ GHC.Unit.Home: isHomeUnitIndefinite :: GenHomeUnit u -> Bool

+ GHC.Unit.Home: isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool

+ GHC.Unit.Home: isHomeUnitInstantiating :: GenHomeUnit u -> Bool

+ GHC.Unit.Home: mkHomeInstalledModule :: GenHomeUnit u -> ModuleName -> InstalledModule

+ GHC.Unit.Home: mkHomeModule :: HomeUnit -> ModuleName -> Module

+ GHC.Unit.Home: notHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool

+ GHC.Unit.Home: notHomeInstalledModuleMaybe :: Maybe (GenHomeUnit u) -> InstalledModule -> Bool

+ GHC.Unit.Home: notHomeModule :: HomeUnit -> Module -> Bool

+ GHC.Unit.Home: notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool

+ GHC.Unit.Home: type HomeUnit = GenHomeUnit UnitId

+ GHC.Unit.Home.ModInfo: HomeModInfo :: !ModIface -> !ModDetails -> !Maybe Linkable -> HomeModInfo

+ GHC.Unit.Home.ModInfo: [hm_details] :: HomeModInfo -> !ModDetails

+ GHC.Unit.Home.ModInfo: [hm_iface] :: HomeModInfo -> !ModIface

+ GHC.Unit.Home.ModInfo: [hm_linkable] :: HomeModInfo -> !Maybe Linkable

+ GHC.Unit.Home.ModInfo: addListToHpt :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable

+ GHC.Unit.Home.ModInfo: addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable

+ GHC.Unit.Home.ModInfo: allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool

+ GHC.Unit.Home.ModInfo: anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool

+ GHC.Unit.Home.ModInfo: data HomeModInfo

+ GHC.Unit.Home.ModInfo: delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable

+ GHC.Unit.Home.ModInfo: eltsHpt :: HomePackageTable -> [HomeModInfo]

+ GHC.Unit.Home.ModInfo: emptyHomePackageTable :: HomePackageTable

+ GHC.Unit.Home.ModInfo: filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable

+ GHC.Unit.Home.ModInfo: listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable

+ GHC.Unit.Home.ModInfo: lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo

+ GHC.Unit.Home.ModInfo: lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo

+ GHC.Unit.Home.ModInfo: lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo

+ GHC.Unit.Home.ModInfo: mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable

+ GHC.Unit.Home.ModInfo: pprHPT :: HomePackageTable -> SDoc

+ GHC.Unit.Home.ModInfo: type HomePackageTable = DModuleNameEnv HomeModInfo

+ GHC.Unit.Info: collectExtraCcOpts :: [UnitInfo] -> [String]

+ GHC.Unit.Info: collectFrameworks :: [UnitInfo] -> [String]

+ GHC.Unit.Info: collectFrameworksDirs :: [UnitInfo] -> [String]

+ GHC.Unit.Info: collectIncludeDirs :: [UnitInfo] -> [FilePath]

+ GHC.Unit.Info: collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath]

+ GHC.Unit.Info: unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String]

+ GHC.Unit.Module.Deps: Deps :: [ModuleNameWithIsBoot] -> [(UnitId, Bool)] -> [Module] -> [Module] -> [ModuleName] -> Dependencies

+ GHC.Unit.Module.Deps: UsageFile :: FilePath -> Fingerprint -> Usage

+ GHC.Unit.Module.Deps: UsageHomeModule :: ModuleName -> Fingerprint -> [(OccName, Fingerprint)] -> Maybe Fingerprint -> IsSafeImport -> Usage

+ GHC.Unit.Module.Deps: UsageMergedRequirement :: Module -> Fingerprint -> Usage

+ GHC.Unit.Module.Deps: UsagePackageModule :: Module -> Fingerprint -> IsSafeImport -> Usage

+ GHC.Unit.Module.Deps: [dep_finsts] :: Dependencies -> [Module]

+ GHC.Unit.Module.Deps: [dep_mods] :: Dependencies -> [ModuleNameWithIsBoot]

+ GHC.Unit.Module.Deps: [dep_orphs] :: Dependencies -> [Module]

+ GHC.Unit.Module.Deps: [dep_pkgs] :: Dependencies -> [(UnitId, Bool)]

+ GHC.Unit.Module.Deps: [dep_plgins] :: Dependencies -> [ModuleName]

+ GHC.Unit.Module.Deps: [usg_entities] :: Usage -> [(OccName, Fingerprint)]

+ GHC.Unit.Module.Deps: [usg_exports] :: Usage -> Maybe Fingerprint

+ GHC.Unit.Module.Deps: [usg_file_hash] :: Usage -> Fingerprint

+ GHC.Unit.Module.Deps: [usg_file_path] :: Usage -> FilePath

+ GHC.Unit.Module.Deps: [usg_mod] :: Usage -> Module

+ GHC.Unit.Module.Deps: [usg_mod_hash] :: Usage -> Fingerprint

+ GHC.Unit.Module.Deps: [usg_mod_name] :: Usage -> ModuleName

+ GHC.Unit.Module.Deps: [usg_safe] :: Usage -> IsSafeImport

+ GHC.Unit.Module.Deps: data Dependencies

+ GHC.Unit.Module.Deps: data Usage

+ GHC.Unit.Module.Deps: instance GHC.Classes.Eq GHC.Unit.Module.Deps.Dependencies

+ GHC.Unit.Module.Deps: instance GHC.Classes.Eq GHC.Unit.Module.Deps.Usage

+ GHC.Unit.Module.Deps: instance GHC.Utils.Binary.Binary GHC.Unit.Module.Deps.Dependencies

+ GHC.Unit.Module.Deps: instance GHC.Utils.Binary.Binary GHC.Unit.Module.Deps.Usage

+ GHC.Unit.Module.Deps: noDependencies :: Dependencies

+ GHC.Unit.Module.Graph: InstantiationNode :: InstantiatedUnit -> ModuleGraphNode

+ GHC.Unit.Module.Graph: ModuleNode :: ExtendedModSummary -> ModuleGraphNode

+ GHC.Unit.Module.Graph: data ModuleGraph

+ GHC.Unit.Module.Graph: data ModuleGraphNode

+ GHC.Unit.Module.Graph: emptyMG :: ModuleGraph

+ GHC.Unit.Module.Graph: extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph

+ GHC.Unit.Module.Graph: extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph

+ GHC.Unit.Module.Graph: extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph

+ GHC.Unit.Module.Graph: filterToposortToModules :: [SCC ModuleGraphNode] -> [SCC ModSummary]

+ GHC.Unit.Module.Graph: instance GHC.Utils.Outputable.Outputable GHC.Unit.Module.Graph.ModuleGraphNode

+ GHC.Unit.Module.Graph: isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool

+ GHC.Unit.Module.Graph: mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph

+ GHC.Unit.Module.Graph: mgBootModules :: ModuleGraph -> ModuleSet

+ GHC.Unit.Module.Graph: mgElemModule :: ModuleGraph -> Module -> Bool

+ GHC.Unit.Module.Graph: mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]

+ GHC.Unit.Module.Graph: mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary

+ GHC.Unit.Module.Graph: mgModSummaries :: ModuleGraph -> [ModSummary]

+ GHC.Unit.Module.Graph: mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]

+ GHC.Unit.Module.Graph: mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph

+ GHC.Unit.Module.Graph: mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph

+ GHC.Unit.Module.Graph: needsTemplateHaskellOrQQ :: ModuleGraph -> Bool

+ GHC.Unit.Module.Graph: showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc

+ GHC.Unit.Module.Imported: ImportedBySystem :: ImportedBy

+ GHC.Unit.Module.Imported: ImportedByUser :: ImportedModsVal -> ImportedBy

+ GHC.Unit.Module.Imported: ImportedModsVal :: ModuleName -> SrcSpan -> IsSafeImport -> Bool -> !GlobalRdrEnv -> Bool -> ImportedModsVal

+ GHC.Unit.Module.Imported: [imv_all_exports] :: ImportedModsVal -> !GlobalRdrEnv

+ GHC.Unit.Module.Imported: [imv_is_hiding] :: ImportedModsVal -> Bool

+ GHC.Unit.Module.Imported: [imv_is_safe] :: ImportedModsVal -> IsSafeImport

+ GHC.Unit.Module.Imported: [imv_name] :: ImportedModsVal -> ModuleName

+ GHC.Unit.Module.Imported: [imv_qualified] :: ImportedModsVal -> Bool

+ GHC.Unit.Module.Imported: [imv_span] :: ImportedModsVal -> SrcSpan

+ GHC.Unit.Module.Imported: data ImportedBy

+ GHC.Unit.Module.Imported: data ImportedModsVal

+ GHC.Unit.Module.Imported: importedByUser :: [ImportedBy] -> [ImportedModsVal]

+ GHC.Unit.Module.Imported: type ImportedMods = ModuleEnv [ImportedBy]

+ GHC.Unit.Module.ModDetails: ModDetails :: [AvailInfo] -> !TypeEnv -> ![ClsInst] -> ![FamInst] -> ![CoreRule] -> ![Annotation] -> [CompleteMatch] -> ModDetails

+ GHC.Unit.Module.ModDetails: [md_anns] :: ModDetails -> ![Annotation]

+ GHC.Unit.Module.ModDetails: [md_complete_matches] :: ModDetails -> [CompleteMatch]

+ GHC.Unit.Module.ModDetails: [md_exports] :: ModDetails -> [AvailInfo]

+ GHC.Unit.Module.ModDetails: [md_fam_insts] :: ModDetails -> ![FamInst]

+ GHC.Unit.Module.ModDetails: [md_insts] :: ModDetails -> ![ClsInst]

+ GHC.Unit.Module.ModDetails: [md_rules] :: ModDetails -> ![CoreRule]

+ GHC.Unit.Module.ModDetails: [md_types] :: ModDetails -> !TypeEnv

+ GHC.Unit.Module.ModDetails: data ModDetails

+ GHC.Unit.Module.ModDetails: emptyModDetails :: ModDetails

+ GHC.Unit.Module.ModGuts: CgGuts :: !Module -> [TyCon] -> CoreProgram -> !ForeignStubs -> ![(ForeignSrcLang, FilePath)] -> ![UnitId] -> !HpcInfo -> !Maybe ModBreaks -> [SptEntry] -> CgGuts

+ GHC.Unit.Module.ModGuts: ModGuts :: !Module -> HscSource -> SrcSpan -> ![AvailInfo] -> !Dependencies -> ![Usage] -> !Bool -> !GlobalRdrEnv -> !FixityEnv -> ![TyCon] -> ![ClsInst] -> ![FamInst] -> ![PatSyn] -> ![CoreRule] -> !CoreProgram -> !ForeignStubs -> ![(ForeignSrcLang, FilePath)] -> !Warnings -> [Annotation] -> [CompleteMatch] -> !HpcInfo -> !Maybe ModBreaks -> InstEnv -> FamInstEnv -> SafeHaskellMode -> Bool -> !Maybe HsDocString -> !DeclDocMap -> !ArgDocMap -> ModGuts

+ GHC.Unit.Module.ModGuts: [cg_binds] :: CgGuts -> CoreProgram

+ GHC.Unit.Module.ModGuts: [cg_dep_pkgs] :: CgGuts -> ![UnitId]

+ GHC.Unit.Module.ModGuts: [cg_foreign] :: CgGuts -> !ForeignStubs

+ GHC.Unit.Module.ModGuts: [cg_foreign_files] :: CgGuts -> ![(ForeignSrcLang, FilePath)]

+ GHC.Unit.Module.ModGuts: [cg_hpc_info] :: CgGuts -> !HpcInfo

+ GHC.Unit.Module.ModGuts: [cg_modBreaks] :: CgGuts -> !Maybe ModBreaks

+ GHC.Unit.Module.ModGuts: [cg_module] :: CgGuts -> !Module

+ GHC.Unit.Module.ModGuts: [cg_spt_entries] :: CgGuts -> [SptEntry]

+ GHC.Unit.Module.ModGuts: [cg_tycons] :: CgGuts -> [TyCon]

+ GHC.Unit.Module.ModGuts: [mg_anns] :: ModGuts -> [Annotation]

+ GHC.Unit.Module.ModGuts: [mg_arg_docs] :: ModGuts -> !ArgDocMap

+ GHC.Unit.Module.ModGuts: [mg_binds] :: ModGuts -> !CoreProgram

+ GHC.Unit.Module.ModGuts: [mg_complete_matches] :: ModGuts -> [CompleteMatch]

+ GHC.Unit.Module.ModGuts: [mg_decl_docs] :: ModGuts -> !DeclDocMap

+ GHC.Unit.Module.ModGuts: [mg_deps] :: ModGuts -> !Dependencies

+ GHC.Unit.Module.ModGuts: [mg_doc_hdr] :: ModGuts -> !Maybe HsDocString

+ GHC.Unit.Module.ModGuts: [mg_exports] :: ModGuts -> ![AvailInfo]

+ GHC.Unit.Module.ModGuts: [mg_fam_inst_env] :: ModGuts -> FamInstEnv

+ GHC.Unit.Module.ModGuts: [mg_fam_insts] :: ModGuts -> ![FamInst]

+ GHC.Unit.Module.ModGuts: [mg_fix_env] :: ModGuts -> !FixityEnv

+ GHC.Unit.Module.ModGuts: [mg_foreign] :: ModGuts -> !ForeignStubs

+ GHC.Unit.Module.ModGuts: [mg_foreign_files] :: ModGuts -> ![(ForeignSrcLang, FilePath)]

+ GHC.Unit.Module.ModGuts: [mg_hpc_info] :: ModGuts -> !HpcInfo

+ GHC.Unit.Module.ModGuts: [mg_hsc_src] :: ModGuts -> HscSource

+ GHC.Unit.Module.ModGuts: [mg_inst_env] :: ModGuts -> InstEnv

+ GHC.Unit.Module.ModGuts: [mg_insts] :: ModGuts -> ![ClsInst]

+ GHC.Unit.Module.ModGuts: [mg_loc] :: ModGuts -> SrcSpan

+ GHC.Unit.Module.ModGuts: [mg_modBreaks] :: ModGuts -> !Maybe ModBreaks

+ GHC.Unit.Module.ModGuts: [mg_module] :: ModGuts -> !Module

+ GHC.Unit.Module.ModGuts: [mg_patsyns] :: ModGuts -> ![PatSyn]

+ GHC.Unit.Module.ModGuts: [mg_rdr_env] :: ModGuts -> !GlobalRdrEnv

+ GHC.Unit.Module.ModGuts: [mg_rules] :: ModGuts -> ![CoreRule]

+ GHC.Unit.Module.ModGuts: [mg_safe_haskell] :: ModGuts -> SafeHaskellMode

+ GHC.Unit.Module.ModGuts: [mg_tcs] :: ModGuts -> ![TyCon]

+ GHC.Unit.Module.ModGuts: [mg_trust_pkg] :: ModGuts -> Bool

+ GHC.Unit.Module.ModGuts: [mg_usages] :: ModGuts -> ![Usage]

+ GHC.Unit.Module.ModGuts: [mg_used_th] :: ModGuts -> !Bool

+ GHC.Unit.Module.ModGuts: [mg_warns] :: ModGuts -> !Warnings

+ GHC.Unit.Module.ModGuts: data CgGuts

+ GHC.Unit.Module.ModGuts: data ModGuts

+ GHC.Unit.Module.ModIface: ModIface :: !Module -> !Maybe Module -> !HscSource -> Dependencies -> [Usage] -> ![IfaceExport] -> !Bool -> [(OccName, Fixity)] -> Warnings -> [IfaceAnnotation] -> [IfaceDeclExts phase] -> !Maybe GlobalRdrEnv -> [IfaceClsInst] -> [IfaceFamInst] -> [IfaceRule] -> !AnyHpcUsage -> !IfaceTrustInfo -> !Bool -> [IfaceCompleteMatch] -> Maybe HsDocString -> DeclDocMap -> ArgDocMap -> !IfaceBackendExts phase -> ExtensibleFields -> ModIface_ (phase :: ModIfacePhase)

+ GHC.Unit.Module.ModIface: ModIfaceBackend :: !Fingerprint -> !Fingerprint -> !Fingerprint -> !Fingerprint -> !Fingerprint -> !Fingerprint -> !WhetherHasOrphans -> !WhetherHasFamInst -> !Fingerprint -> !Fingerprint -> !OccName -> Maybe WarningTxt -> !OccName -> Maybe Fixity -> !OccName -> Maybe (OccName, Fingerprint) -> ModIfaceBackend

+ GHC.Unit.Module.ModIface: [mi_anns] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceAnnotation]

+ GHC.Unit.Module.ModIface: [mi_arg_docs] :: ModIface_ (phase :: ModIfacePhase) -> ArgDocMap

+ GHC.Unit.Module.ModIface: [mi_complete_matches] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceCompleteMatch]

+ GHC.Unit.Module.ModIface: [mi_decl_docs] :: ModIface_ (phase :: ModIfacePhase) -> DeclDocMap

+ GHC.Unit.Module.ModIface: [mi_decls] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceDeclExts phase]

+ GHC.Unit.Module.ModIface: [mi_deps] :: ModIface_ (phase :: ModIfacePhase) -> Dependencies

+ GHC.Unit.Module.ModIface: [mi_doc_hdr] :: ModIface_ (phase :: ModIfacePhase) -> Maybe HsDocString

+ GHC.Unit.Module.ModIface: [mi_exp_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_exports] :: ModIface_ (phase :: ModIfacePhase) -> ![IfaceExport]

+ GHC.Unit.Module.ModIface: [mi_ext_fields] :: ModIface_ (phase :: ModIfacePhase) -> ExtensibleFields

+ GHC.Unit.Module.ModIface: [mi_fam_insts] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceFamInst]

+ GHC.Unit.Module.ModIface: [mi_final_exts] :: ModIface_ (phase :: ModIfacePhase) -> !IfaceBackendExts phase

+ GHC.Unit.Module.ModIface: [mi_finsts] :: ModIfaceBackend -> !WhetherHasFamInst

+ GHC.Unit.Module.ModIface: [mi_fix_fn] :: ModIfaceBackend -> !OccName -> Maybe Fixity

+ GHC.Unit.Module.ModIface: [mi_fixities] :: ModIface_ (phase :: ModIfacePhase) -> [(OccName, Fixity)]

+ GHC.Unit.Module.ModIface: [mi_flag_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_globals] :: ModIface_ (phase :: ModIfacePhase) -> !Maybe GlobalRdrEnv

+ GHC.Unit.Module.ModIface: [mi_hash_fn] :: ModIfaceBackend -> !OccName -> Maybe (OccName, Fingerprint)

+ GHC.Unit.Module.ModIface: [mi_hpc] :: ModIface_ (phase :: ModIfacePhase) -> !AnyHpcUsage

+ GHC.Unit.Module.ModIface: [mi_hpc_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_hsc_src] :: ModIface_ (phase :: ModIfacePhase) -> !HscSource

+ GHC.Unit.Module.ModIface: [mi_iface_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_insts] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceClsInst]

+ GHC.Unit.Module.ModIface: [mi_mod_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_module] :: ModIface_ (phase :: ModIfacePhase) -> !Module

+ GHC.Unit.Module.ModIface: [mi_opt_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_orphan] :: ModIfaceBackend -> !WhetherHasOrphans

+ GHC.Unit.Module.ModIface: [mi_orphan_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_plugin_hash] :: ModIfaceBackend -> !Fingerprint

+ GHC.Unit.Module.ModIface: [mi_rules] :: ModIface_ (phase :: ModIfacePhase) -> [IfaceRule]

+ GHC.Unit.Module.ModIface: [mi_sig_of] :: ModIface_ (phase :: ModIfacePhase) -> !Maybe Module

+ GHC.Unit.Module.ModIface: [mi_trust] :: ModIface_ (phase :: ModIfacePhase) -> !IfaceTrustInfo

+ GHC.Unit.Module.ModIface: [mi_trust_pkg] :: ModIface_ (phase :: ModIfacePhase) -> !Bool

+ GHC.Unit.Module.ModIface: [mi_usages] :: ModIface_ (phase :: ModIfacePhase) -> [Usage]

+ GHC.Unit.Module.ModIface: [mi_used_th] :: ModIface_ (phase :: ModIfacePhase) -> !Bool

+ GHC.Unit.Module.ModIface: [mi_warn_fn] :: ModIfaceBackend -> !OccName -> Maybe WarningTxt

+ GHC.Unit.Module.ModIface: [mi_warns] :: ModIface_ (phase :: ModIfacePhase) -> Warnings

+ GHC.Unit.Module.ModIface: data ModIfaceBackend

+ GHC.Unit.Module.ModIface: data ModIface_ (phase :: ModIfacePhase)

+ GHC.Unit.Module.ModIface: emptyFullModIface :: Module -> ModIface

+ GHC.Unit.Module.ModIface: emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)

+ GHC.Unit.Module.ModIface: emptyPartialModIface :: Module -> PartialModIface

+ GHC.Unit.Module.ModIface: instance (Control.DeepSeq.NFData (GHC.Unit.Module.ModIface.IfaceBackendExts phase), Control.DeepSeq.NFData (GHC.Unit.Module.ModIface.IfaceDeclExts phase)) => Control.DeepSeq.NFData (GHC.Unit.Module.ModIface.ModIface_ phase)

+ GHC.Unit.Module.ModIface: instance GHC.Utils.Binary.Binary GHC.Unit.Module.ModIface.ModIface

+ GHC.Unit.Module.ModIface: mi_boot :: ModIface -> IsBootInterface

+ GHC.Unit.Module.ModIface: mi_fix :: ModIface -> OccName -> Fixity

+ GHC.Unit.Module.ModIface: mi_free_holes :: ModIface -> UniqDSet ModuleName

+ GHC.Unit.Module.ModIface: mi_semantic_module :: ModIface_ a -> Module

+ GHC.Unit.Module.ModIface: mkIfaceHashCache :: [(Fingerprint, IfaceDecl)] -> OccName -> Maybe (OccName, Fingerprint)

+ GHC.Unit.Module.ModIface: renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName

+ GHC.Unit.Module.ModIface: type IfaceExport = AvailInfo

+ GHC.Unit.Module.ModIface: type ModIface = ModIface_ 'ModIfaceFinal

+ GHC.Unit.Module.ModIface: type PartialModIface = ModIface_ 'ModIfaceCore

+ GHC.Unit.Module.ModIface: type WhetherHasFamInst = Bool

+ GHC.Unit.Module.ModIface: type WhetherHasOrphans = Bool

+ GHC.Unit.Module.ModIface: type family IfaceBackendExts (phase :: ModIfacePhase)

+ GHC.Unit.Module.ModSummary: ExtendedModSummary :: {-# UNPACK #-} !ModSummary -> [InstantiatedUnit] -> ExtendedModSummary

+ GHC.Unit.Module.ModSummary: ModSummary :: Module -> HscSource -> ModLocation -> UTCTime -> Maybe UTCTime -> Maybe UTCTime -> Maybe UTCTime -> [(Maybe FastString, Located ModuleName)] -> [(Maybe FastString, Located ModuleName)] -> Maybe HsParsedModule -> FilePath -> DynFlags -> Maybe StringBuffer -> ModSummary

+ GHC.Unit.Module.ModSummary: [emsInstantiatedUnits] :: ExtendedModSummary -> [InstantiatedUnit]

+ GHC.Unit.Module.ModSummary: [emsModSummary] :: ExtendedModSummary -> {-# UNPACK #-} !ModSummary

+ GHC.Unit.Module.ModSummary: [ms_hie_date] :: ModSummary -> Maybe UTCTime

+ GHC.Unit.Module.ModSummary: [ms_hs_date] :: ModSummary -> UTCTime

+ GHC.Unit.Module.ModSummary: [ms_hsc_src] :: ModSummary -> HscSource

+ GHC.Unit.Module.ModSummary: [ms_hspp_buf] :: ModSummary -> Maybe StringBuffer

+ GHC.Unit.Module.ModSummary: [ms_hspp_file] :: ModSummary -> FilePath

+ GHC.Unit.Module.ModSummary: [ms_hspp_opts] :: ModSummary -> DynFlags

+ GHC.Unit.Module.ModSummary: [ms_iface_date] :: ModSummary -> Maybe UTCTime

+ GHC.Unit.Module.ModSummary: [ms_location] :: ModSummary -> ModLocation

+ GHC.Unit.Module.ModSummary: [ms_mod] :: ModSummary -> Module

+ GHC.Unit.Module.ModSummary: [ms_obj_date] :: ModSummary -> Maybe UTCTime

+ GHC.Unit.Module.ModSummary: [ms_parsed_mod] :: ModSummary -> Maybe HsParsedModule

+ GHC.Unit.Module.ModSummary: [ms_srcimps] :: ModSummary -> [(Maybe FastString, Located ModuleName)]

+ GHC.Unit.Module.ModSummary: [ms_textual_imps] :: ModSummary -> [(Maybe FastString, Located ModuleName)]

+ GHC.Unit.Module.ModSummary: data ExtendedModSummary

+ GHC.Unit.Module.ModSummary: data ModSummary

+ GHC.Unit.Module.ModSummary: extendModSummaryNoDeps :: ModSummary -> ExtendedModSummary

+ GHC.Unit.Module.ModSummary: findTarget :: ModSummary -> [Target] -> Maybe Target

+ GHC.Unit.Module.ModSummary: instance GHC.Utils.Outputable.Outputable GHC.Unit.Module.ModSummary.ExtendedModSummary

+ GHC.Unit.Module.ModSummary: instance GHC.Utils.Outputable.Outputable GHC.Unit.Module.ModSummary.ModSummary

+ GHC.Unit.Module.ModSummary: isBootSummary :: ModSummary -> IsBootInterface

+ GHC.Unit.Module.ModSummary: msDynObjFilePath :: ModSummary -> DynFlags -> FilePath

+ GHC.Unit.Module.ModSummary: msHiFilePath :: ModSummary -> FilePath

+ GHC.Unit.Module.ModSummary: msHsFilePath :: ModSummary -> FilePath

+ GHC.Unit.Module.ModSummary: msObjFilePath :: ModSummary -> FilePath

+ GHC.Unit.Module.ModSummary: ms_home_allimps :: ModSummary -> [ModuleName]

+ GHC.Unit.Module.ModSummary: ms_home_imps :: ModSummary -> [Located ModuleName]

+ GHC.Unit.Module.ModSummary: ms_home_srcimps :: ModSummary -> [Located ModuleName]

+ GHC.Unit.Module.ModSummary: ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]

+ GHC.Unit.Module.ModSummary: ms_installed_mod :: ModSummary -> InstalledModule

+ GHC.Unit.Module.ModSummary: ms_mod_name :: ModSummary -> ModuleName

+ GHC.Unit.Module.Name: instance GHC.Show.Show GHC.Unit.Module.Name.ModuleName

+ GHC.Unit.Module.Status: HscNotGeneratingCode :: ModIface -> ModDetails -> HscStatus

+ GHC.Unit.Module.Status: HscRecomp :: CgGuts -> !ModLocation -> !ModDetails -> !PartialModIface -> !Maybe Fingerprint -> HscStatus

+ GHC.Unit.Module.Status: HscUpToDate :: ModIface -> ModDetails -> HscStatus

+ GHC.Unit.Module.Status: HscUpdateBoot :: ModIface -> ModDetails -> HscStatus

+ GHC.Unit.Module.Status: HscUpdateSig :: ModIface -> ModDetails -> HscStatus

+ GHC.Unit.Module.Status: [hscs_guts] :: HscStatus -> CgGuts

+ GHC.Unit.Module.Status: [hscs_mod_details] :: HscStatus -> !ModDetails

+ GHC.Unit.Module.Status: [hscs_mod_location] :: HscStatus -> !ModLocation

+ GHC.Unit.Module.Status: [hscs_old_iface_hash] :: HscStatus -> !Maybe Fingerprint

+ GHC.Unit.Module.Status: [hscs_partial_iface] :: HscStatus -> !PartialModIface

+ GHC.Unit.Module.Status: data HscStatus

+ GHC.Unit.Module.Warnings: DeprecatedTxt :: Located SourceText -> [Located StringLiteral] -> WarningTxt

+ GHC.Unit.Module.Warnings: NoWarnings :: Warnings

+ GHC.Unit.Module.Warnings: WarnAll :: WarningTxt -> Warnings

+ GHC.Unit.Module.Warnings: WarnSome :: [(OccName, WarningTxt)] -> Warnings

+ GHC.Unit.Module.Warnings: WarningTxt :: Located SourceText -> [Located StringLiteral] -> WarningTxt

+ GHC.Unit.Module.Warnings: data WarningTxt

+ GHC.Unit.Module.Warnings: data Warnings

+ GHC.Unit.Module.Warnings: emptyIfaceWarnCache :: OccName -> Maybe WarningTxt

+ GHC.Unit.Module.Warnings: instance Data.Data.Data GHC.Unit.Module.Warnings.WarningTxt

+ GHC.Unit.Module.Warnings: instance GHC.Classes.Eq GHC.Unit.Module.Warnings.WarningTxt

+ GHC.Unit.Module.Warnings: instance GHC.Classes.Eq GHC.Unit.Module.Warnings.Warnings

+ GHC.Unit.Module.Warnings: instance GHC.Utils.Binary.Binary GHC.Unit.Module.Warnings.WarningTxt

+ GHC.Unit.Module.Warnings: instance GHC.Utils.Binary.Binary GHC.Unit.Module.Warnings.Warnings

+ GHC.Unit.Module.Warnings: instance GHC.Utils.Outputable.Outputable GHC.Unit.Module.Warnings.WarningTxt

+ GHC.Unit.Module.Warnings: mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt

+ GHC.Unit.Module.Warnings: plusWarns :: Warnings -> Warnings -> Warnings

+ GHC.Unit.Module.Warnings: pprWarningTxtForMsg :: WarningTxt -> SDoc

+ GHC.Unit.Ppr: [unitPprId] :: UnitPprInfo -> FastString

+ GHC.Unit.State: CloseUnitErr :: !UnitId -> !Maybe UnitId -> UnitErr

+ GHC.Unit.State: PackageFlagErr :: !PackageFlag -> ![(UnitInfo, UnusableUnitReason)] -> UnitErr

+ GHC.Unit.State: TrustFlagErr :: !TrustFlag -> ![(UnitInfo, UnusableUnitReason)] -> UnitErr

+ GHC.Unit.State: closeUnitDeps :: UnitInfoMap -> [(UnitId, Maybe UnitId)] -> MaybeErr UnitErr [UnitId]

+ GHC.Unit.State: closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId, Maybe UnitId)] -> MaybeErr UnitErr [UnitId]

+ GHC.Unit.State: data UnitErr

+ GHC.Unit.State: instance GHC.Utils.Outputable.Outputable GHC.Unit.State.UnitErr

+ GHC.Unit.State: mayThrowUnitErr :: MaybeErr UnitErr a -> IO a

+ GHC.Unit.State: pprUnitIdForUser :: UnitState -> UnitId -> SDoc

+ GHC.Unit.State: pprUnitInfoForUser :: UnitInfo -> SDoc

+ GHC.Unit.State: pprWithUnitState :: UnitState -> SDoc -> SDoc

+ GHC.Unit.State: requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]

+ GHC.Unit.State: type PreloadUnitClosure = UniqSet UnitId

+ GHC.Unit.State: type UnitInfoMap = Map UnitId UnitInfo

+ GHC.Unit.Types: UnitKey :: FastString -> UnitKey

+ GHC.Unit.Types: class IsUnitId u

+ GHC.Unit.Types: instance GHC.Types.Unique.Uniquable unit => GHC.Types.Unique.Uniquable (GHC.Unit.Types.Definite unit)

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId GHC.Unit.Types.UnitId

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId GHC.Unit.Types.UnitKey

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId u => GHC.Classes.Eq (GHC.Unit.Types.GenUnit u)

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId u => GHC.Types.Unique.Uniquable (GHC.Unit.Types.GenUnit u)

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId u => GHC.Unit.Types.IsUnitId (GHC.Unit.Types.GenUnit u)

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId unit => GHC.Unit.Types.IsUnitId (GHC.Unit.Types.Definite unit)

+ GHC.Unit.Types: instance GHC.Unit.Types.IsUnitId unit => GHC.Unit.Types.IsUnitId (GHC.Unit.Types.Indefinite unit)

+ GHC.Unit.Types: isHoleUnit :: GenUnit u -> Bool

+ GHC.Unit.Types: mapInstantiations :: IsUnitId v => (u -> v) -> GenInstantiations u -> GenInstantiations v

+ GHC.Unit.Types: newtype Indefinite unit

+ GHC.Unit.Types: newtype UnitKey

+ GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Data.FastString.LexicalFastString

+ GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Data.FastString.NonDetFastString

+ GHC.Utils.Binary.Typeable: getSomeTypeRep :: BinHandle -> IO SomeTypeRep

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary Data.Typeable.Internal.SomeTypeRep

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Serialized.Serialized

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Types.KindRep

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Types.RuntimeRep

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Types.TyCon

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Types.TypeLitSort

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Types.VecCount

+ GHC.Utils.Binary.Typeable: instance GHC.Utils.Binary.Binary GHC.Types.VecElem

+ GHC.Utils.Binary.Typeable: instance forall k (a :: k). Data.Typeable.Internal.Typeable a => GHC.Utils.Binary.Binary (Data.Typeable.Internal.TypeRep a)

+ GHC.Utils.Error: MsgEnvelope :: SrcSpan -> PrintUnqualified -> e -> Severity -> WarnReason -> MsgEnvelope e

+ GHC.Utils.Error: [errMsgContext] :: MsgEnvelope e -> PrintUnqualified

+ GHC.Utils.Error: [errMsgDiagnostic] :: MsgEnvelope e -> e

+ GHC.Utils.Error: [errMsgReason] :: MsgEnvelope e -> WarnReason

+ GHC.Utils.Error: [errMsgSeverity] :: MsgEnvelope e -> Severity

+ GHC.Utils.Error: [errMsgSpan] :: MsgEnvelope e -> SrcSpan

+ GHC.Utils.Error: data DecoratedSDoc

+ GHC.Utils.Error: data Messages e

+ GHC.Utils.Error: data MsgEnvelope e

+ GHC.Utils.Error: data SDoc

+ GHC.Utils.Error: formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc

+ GHC.Utils.Error: mkDecorated :: [SDoc] -> DecoratedSDoc

+ GHC.Utils.Error: mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e

+ GHC.Utils.Error: mkLongMsgEnvelope :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Utils.Error: mkMsgEnvelope :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Utils.Error: mkPlainMsgEnvelope :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc

+ GHC.Utils.Error: pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc

+ GHC.Utils.Error: pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]

+ GHC.Utils.Error: sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e]

+ GHC.Utils.GlobalVars: consIORef :: IORef [a] -> a -> IO ()

+ GHC.Utils.GlobalVars: global :: a -> IORef a

+ GHC.Utils.GlobalVars: globalM :: IO a -> IORef a

+ GHC.Utils.GlobalVars: sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a

+ GHC.Utils.GlobalVars: sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a

+ GHC.Utils.GlobalVars: unsafeHasNoDebugOutput :: Bool

+ GHC.Utils.GlobalVars: unsafeHasNoStateHack :: Bool

+ GHC.Utils.GlobalVars: unsafeHasPprDebug :: Bool

+ GHC.Utils.GlobalVars: v_unsafeHasNoDebugOutput :: IORef Bool

+ GHC.Utils.GlobalVars: v_unsafeHasNoStateHack :: IORef Bool

+ GHC.Utils.GlobalVars: v_unsafeHasPprDebug :: IORef Bool

+ GHC.Utils.Logger: FormatASM :: DumpFormat

+ GHC.Utils.Logger: FormatByteCode :: DumpFormat

+ GHC.Utils.Logger: FormatC :: DumpFormat

+ GHC.Utils.Logger: FormatCMM :: DumpFormat

+ GHC.Utils.Logger: FormatCore :: DumpFormat

+ GHC.Utils.Logger: FormatHaskell :: DumpFormat

+ GHC.Utils.Logger: FormatLLVM :: DumpFormat

+ GHC.Utils.Logger: FormatSTG :: DumpFormat

+ GHC.Utils.Logger: FormatText :: DumpFormat

+ GHC.Utils.Logger: class ContainsLogger t

+ GHC.Utils.Logger: class HasLogger m

+ GHC.Utils.Logger: data DumpFormat

+ GHC.Utils.Logger: data Logger

+ GHC.Utils.Logger: defaultDumpAction :: DumpCache -> LogAction -> DumpAction

+ GHC.Utils.Logger: defaultLogAction :: LogAction

+ GHC.Utils.Logger: defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()

+ GHC.Utils.Logger: defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()

+ GHC.Utils.Logger: defaultTraceAction :: TraceAction a

+ GHC.Utils.Logger: dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()

+ GHC.Utils.Logger: dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

+ GHC.Utils.Logger: dumpIfSet_dyn_printer :: PrintUnqualified -> Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

+ GHC.Utils.Logger: extractLogger :: ContainsLogger t => t -> Logger

+ GHC.Utils.Logger: getLogger :: HasLogger m => m Logger

+ GHC.Utils.Logger: initLogger :: IO Logger

+ GHC.Utils.Logger: instance GHC.Classes.Eq GHC.Utils.Logger.DumpFormat

+ GHC.Utils.Logger: instance GHC.Show.Show GHC.Utils.Logger.DumpFormat

+ GHC.Utils.Logger: jsonLogAction :: LogAction

+ GHC.Utils.Logger: makeThreadSafe :: Logger -> IO Logger

+ GHC.Utils.Logger: popDumpHook :: Logger -> Logger

+ GHC.Utils.Logger: popLogHook :: Logger -> Logger

+ GHC.Utils.Logger: popTraceHook :: Logger -> Logger

+ GHC.Utils.Logger: pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger

+ GHC.Utils.Logger: pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger

+ GHC.Utils.Logger: pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger

+ GHC.Utils.Logger: putDumpMsg :: Logger -> DumpAction

+ GHC.Utils.Logger: putLogMsg :: Logger -> LogAction

+ GHC.Utils.Logger: putTraceMsg :: Logger -> TraceAction a

+ GHC.Utils.Logger: touchDumpFile :: Logger -> DynFlags -> DumpFlag -> IO ()

+ GHC.Utils.Logger: type DumpAction = DynFlags -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()

+ GHC.Utils.Logger: type LogAction = DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()

+ GHC.Utils.Logger: type TraceAction a = DynFlags -> String -> SDoc -> a -> a

+ GHC.Utils.Logger: withDumpFileHandle :: DumpCache -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()

+ GHC.Utils.Misc: readHexSignificandExponentPair :: String -> (Integer, Integer)

+ GHC.Utils.Misc: readSignificandExponentPair :: String -> (Integer, Integer)

+ GHC.Utils.Monad: liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r)

+ GHC.Utils.Monad: liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b)

+ GHC.Utils.Outputable: PDoc :: a -> PDoc a

+ GHC.Utils.Outputable: [sdocUnitIdForUser] :: SDocContext -> !FastString -> SDoc

+ GHC.Utils.Outputable: class OutputableP env a

+ GHC.Utils.Outputable: data LabelStyle

+ GHC.Utils.Outputable: defaultSDocContext :: SDocContext

+ GHC.Utils.Outputable: instance (GHC.Utils.Outputable.OutputableP env a, GHC.Utils.Outputable.OutputableP env b) => GHC.Utils.Outputable.OutputableP env (a, b)

+ GHC.Utils.Outputable: instance (GHC.Utils.Outputable.OutputableP env a, GHC.Utils.Outputable.OutputableP env b, GHC.Utils.Outputable.OutputableP env c) => GHC.Utils.Outputable.OutputableP env (a, b, c)

+ GHC.Utils.Outputable: instance (GHC.Utils.Outputable.OutputableP env key, GHC.Utils.Outputable.OutputableP env elt) => GHC.Utils.Outputable.OutputableP env (Data.Map.Internal.Map key elt)

+ GHC.Utils.Outputable: instance GHC.Classes.Eq GHC.Utils.Outputable.LabelStyle

+ GHC.Utils.Outputable: instance GHC.Classes.Ord GHC.Utils.Outputable.LabelStyle

+ GHC.Utils.Outputable: instance GHC.Show.Show GHC.Utils.Outputable.LabelStyle

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.Outputable Data.IntSet.Internal.IntSet

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.Outputable GHC.Data.FastString.LexicalFastString

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.Outputable GHC.Data.FastString.NonDetFastString

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.OutputableP env (GHC.Utils.Outputable.PDoc a)

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.OutputableP env GHC.Utils.Outputable.SDoc

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.OutputableP env a => GHC.Utils.Outputable.OutputableP env (Data.Graph.SCC a)

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.OutputableP env a => GHC.Utils.Outputable.OutputableP env (Data.Set.Internal.Set a)

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.OutputableP env a => GHC.Utils.Outputable.OutputableP env (GHC.Maybe.Maybe a)

+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.OutputableP env a => GHC.Utils.Outputable.OutputableP env [a]

+ GHC.Utils.Outputable: interpp'SP' :: (a -> SDoc) -> [a] -> SDoc

+ GHC.Utils.Outputable: lambda :: SDoc

+ GHC.Utils.Outputable: newtype PDoc a

+ GHC.Utils.Outputable: pdoc :: OutputableP env a => env -> a -> SDoc

+ GHC.Utils.Outputable: pprPrimInt16 :: Integer -> SDoc

+ GHC.Utils.Outputable: pprPrimInt32 :: Integer -> SDoc

+ GHC.Utils.Outputable: pprPrimInt8 :: Integer -> SDoc

+ GHC.Utils.Outputable: pprPrimWord16 :: Integer -> SDoc

+ GHC.Utils.Outputable: pprPrimWord32 :: Integer -> SDoc

+ GHC.Utils.Outputable: pprPrimWord8 :: Integer -> SDoc

+ GHC.Utils.Outputable: primInt16Suffix :: SDoc

+ GHC.Utils.Outputable: primInt32Suffix :: SDoc

+ GHC.Utils.Outputable: primInt8Suffix :: SDoc

+ GHC.Utils.Outputable: primWord16Suffix :: SDoc

+ GHC.Utils.Outputable: primWord32Suffix :: SDoc

+ GHC.Utils.Outputable: primWord8Suffix :: SDoc

+ GHC.Utils.Outputable: renderWithContext :: SDocContext -> SDoc -> String

+ GHC.Utils.Outputable: showPprUnsafe :: Outputable a => a -> String

+ GHC.Utils.Panic: assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a

+ GHC.Utils.Panic: callStackDoc :: HasCallStack => SDoc

+ GHC.Utils.Panic: pprPanic :: HasCallStack => String -> SDoc -> a

+ GHC.Utils.Panic: showGhcExceptionUnsafe :: GhcException -> ShowS

+ GHC.Utils.Ppr: [asciiSpace] :: Mode -> Bool

+ GHC.Utils.TmpFs: FilesToClean :: !Set FilePath -> !Set FilePath -> FilesToClean

+ GHC.Utils.TmpFs: TFL_CurrentModule :: TempFileLifetime

+ GHC.Utils.TmpFs: TFL_GhcSession :: TempFileLifetime

+ GHC.Utils.TmpFs: [ftcCurrentModule] :: FilesToClean -> !Set FilePath

+ GHC.Utils.TmpFs: [ftcGhcSession] :: FilesToClean -> !Set FilePath

+ GHC.Utils.TmpFs: addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()

+ GHC.Utils.TmpFs: changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()

+ GHC.Utils.TmpFs: cleanCurrentModuleTempFiles :: Logger -> TmpFs -> DynFlags -> IO ()

+ GHC.Utils.TmpFs: cleanTempDirs :: Logger -> TmpFs -> DynFlags -> IO ()

+ GHC.Utils.TmpFs: cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO ()

+ GHC.Utils.TmpFs: data FilesToClean

+ GHC.Utils.TmpFs: data TempFileLifetime

+ GHC.Utils.TmpFs: data TmpFs

+ GHC.Utils.TmpFs: emptyFilesToClean :: FilesToClean

+ GHC.Utils.TmpFs: forkTmpFsFrom :: TmpFs -> IO TmpFs

+ GHC.Utils.TmpFs: initTmpFs :: IO TmpFs

+ GHC.Utils.TmpFs: instance GHC.Show.Show GHC.Utils.TmpFs.TempFileLifetime

+ GHC.Utils.TmpFs: mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()

+ GHC.Utils.TmpFs: newTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath

+ GHC.Utils.TmpFs: newTempLibName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String)

+ GHC.Utils.TmpFs: newTempName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath

+ GHC.Utils.TmpFs: withSystemTempDirectory :: String -> (FilePath -> IO a) -> IO a

+ GHC.Utils.TmpFs: withTempDirectory :: FilePath -> String -> (FilePath -> IO a) -> IO a

+ Language.Haskell.Syntax.Binds: ABE :: XABE p -> IdP p -> IdP p -> HsWrapper -> TcSpecPrags -> ABExport p

+ Language.Haskell.Syntax.Binds: AbsBinds :: XAbsBinds idL idR -> [TyVar] -> [EvVar] -> [ABExport idL] -> [TcEvBinds] -> LHsBinds idL -> Bool -> HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: ClassOpSig :: XClassOpSig pass -> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass

+ Language.Haskell.Syntax.Binds: CompleteMatchSig :: XCompleteMatchSig pass -> SourceText -> XRec pass [LIdP pass] -> Maybe (LIdP pass) -> Sig pass

+ Language.Haskell.Syntax.Binds: EmptyLocalBinds :: XEmptyLocalBinds idL idR -> HsLocalBindsLR idL idR

+ Language.Haskell.Syntax.Binds: ExplicitBidirectional :: MatchGroup id (LHsExpr id) -> HsPatSynDir id

+ Language.Haskell.Syntax.Binds: FixSig :: XFixSig pass -> FixitySig pass -> Sig pass

+ Language.Haskell.Syntax.Binds: FixitySig :: XFixitySig pass -> [LIdP pass] -> Fixity -> FixitySig pass

+ Language.Haskell.Syntax.Binds: FunBind :: XFunBind idL idR -> LIdP idL -> MatchGroup idR (LHsExpr idR) -> [CoreTickish] -> HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: HsIPBinds :: XHsIPBinds idL idR -> HsIPBinds idR -> HsLocalBindsLR idL idR

+ Language.Haskell.Syntax.Binds: HsValBinds :: XHsValBinds idL idR -> HsValBindsLR idL idR -> HsLocalBindsLR idL idR

+ Language.Haskell.Syntax.Binds: IPBind :: XCIPBind id -> Either (XRec id HsIPName) (IdP id) -> LHsExpr id -> IPBind id

+ Language.Haskell.Syntax.Binds: IPBinds :: XIPBinds id -> [LIPBind id] -> HsIPBinds id

+ Language.Haskell.Syntax.Binds: IdSig :: XIdSig pass -> Id -> Sig pass

+ Language.Haskell.Syntax.Binds: ImplicitBidirectional :: HsPatSynDir id

+ Language.Haskell.Syntax.Binds: InlineSig :: XInlineSig pass -> LIdP pass -> InlinePragma -> Sig pass

+ Language.Haskell.Syntax.Binds: IsDefaultMethod :: TcSpecPrags

+ Language.Haskell.Syntax.Binds: MinimalSig :: XMinimalSig pass -> SourceText -> LBooleanFormula (LIdP pass) -> Sig pass

+ Language.Haskell.Syntax.Binds: PSB :: XPSB idL idR -> LIdP idL -> HsPatSynDetails idR -> LPat idR -> HsPatSynDir idR -> PatSynBind idL idR

+ Language.Haskell.Syntax.Binds: PatBind :: XPatBind idL idR -> LPat idL -> GRHSs idR (LHsExpr idR) -> ([CoreTickish], [[CoreTickish]]) -> HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: PatSynBind :: XPatSynBind idL idR -> PatSynBind idL idR -> HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: PatSynSig :: XPatSynSig pass -> [LIdP pass] -> LHsSigType pass -> Sig pass

+ Language.Haskell.Syntax.Binds: RecordPatSynField :: FieldOcc pass -> LIdP pass -> RecordPatSynField pass

+ Language.Haskell.Syntax.Binds: SCCFunSig :: XSCCFunSig pass -> SourceText -> LIdP pass -> Maybe (XRec pass StringLiteral) -> Sig pass

+ Language.Haskell.Syntax.Binds: SpecInstSig :: XSpecInstSig pass -> SourceText -> LHsSigType pass -> Sig pass

+ Language.Haskell.Syntax.Binds: SpecPrag :: Id -> HsWrapper -> InlinePragma -> TcSpecPrag

+ Language.Haskell.Syntax.Binds: SpecPrags :: [LTcSpecPrag] -> TcSpecPrags

+ Language.Haskell.Syntax.Binds: SpecSig :: XSpecSig pass -> LIdP pass -> [LHsSigType pass] -> InlinePragma -> Sig pass

+ Language.Haskell.Syntax.Binds: TypeSig :: XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass

+ Language.Haskell.Syntax.Binds: Unidirectional :: HsPatSynDir id

+ Language.Haskell.Syntax.Binds: ValBinds :: XValBinds idL idR -> LHsBindsLR idL idR -> [LSig idR] -> HsValBindsLR idL idR

+ Language.Haskell.Syntax.Binds: VarBind :: XVarBind idL idR -> IdP idL -> LHsExpr idR -> HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: XABExport :: !XXABExport p -> ABExport p

+ Language.Haskell.Syntax.Binds: XFixitySig :: !XXFixitySig pass -> FixitySig pass

+ Language.Haskell.Syntax.Binds: XHsBindsLR :: !XXHsBindsLR idL idR -> HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: XHsIPBinds :: !XXHsIPBinds id -> HsIPBinds id

+ Language.Haskell.Syntax.Binds: XHsLocalBindsLR :: !XXHsLocalBindsLR idL idR -> HsLocalBindsLR idL idR

+ Language.Haskell.Syntax.Binds: XIPBind :: !XXIPBind id -> IPBind id

+ Language.Haskell.Syntax.Binds: XPatSynBind :: !XXPatSynBind idL idR -> PatSynBind idL idR

+ Language.Haskell.Syntax.Binds: XSig :: !XXSig pass -> Sig pass

+ Language.Haskell.Syntax.Binds: XValBindsLR :: !XXValBindsLR idL idR -> HsValBindsLR idL idR

+ Language.Haskell.Syntax.Binds: [abe_ext] :: ABExport p -> XABE p

+ Language.Haskell.Syntax.Binds: [abe_mono] :: ABExport p -> IdP p

+ Language.Haskell.Syntax.Binds: [abe_poly] :: ABExport p -> IdP p

+ Language.Haskell.Syntax.Binds: [abe_prags] :: ABExport p -> TcSpecPrags

+ Language.Haskell.Syntax.Binds: [abe_wrap] :: ABExport p -> HsWrapper

+ Language.Haskell.Syntax.Binds: [abs_binds] :: HsBindLR idL idR -> LHsBinds idL

+ Language.Haskell.Syntax.Binds: [abs_ev_binds] :: HsBindLR idL idR -> [TcEvBinds]

+ Language.Haskell.Syntax.Binds: [abs_ev_vars] :: HsBindLR idL idR -> [EvVar]

+ Language.Haskell.Syntax.Binds: [abs_exports] :: HsBindLR idL idR -> [ABExport idL]

+ Language.Haskell.Syntax.Binds: [abs_ext] :: HsBindLR idL idR -> XAbsBinds idL idR

+ Language.Haskell.Syntax.Binds: [abs_sig] :: HsBindLR idL idR -> Bool

+ Language.Haskell.Syntax.Binds: [abs_tvs] :: HsBindLR idL idR -> [TyVar]

+ Language.Haskell.Syntax.Binds: [fun_ext] :: HsBindLR idL idR -> XFunBind idL idR

+ Language.Haskell.Syntax.Binds: [fun_id] :: HsBindLR idL idR -> LIdP idL

+ Language.Haskell.Syntax.Binds: [fun_matches] :: HsBindLR idL idR -> MatchGroup idR (LHsExpr idR)

+ Language.Haskell.Syntax.Binds: [fun_tick] :: HsBindLR idL idR -> [CoreTickish]

+ Language.Haskell.Syntax.Binds: [pat_ext] :: HsBindLR idL idR -> XPatBind idL idR

+ Language.Haskell.Syntax.Binds: [pat_lhs] :: HsBindLR idL idR -> LPat idL

+ Language.Haskell.Syntax.Binds: [pat_rhs] :: HsBindLR idL idR -> GRHSs idR (LHsExpr idR)

+ Language.Haskell.Syntax.Binds: [pat_ticks] :: HsBindLR idL idR -> ([CoreTickish], [[CoreTickish]])

+ Language.Haskell.Syntax.Binds: [psb_args] :: PatSynBind idL idR -> HsPatSynDetails idR

+ Language.Haskell.Syntax.Binds: [psb_def] :: PatSynBind idL idR -> LPat idR

+ Language.Haskell.Syntax.Binds: [psb_dir] :: PatSynBind idL idR -> HsPatSynDir idR

+ Language.Haskell.Syntax.Binds: [psb_ext] :: PatSynBind idL idR -> XPSB idL idR

+ Language.Haskell.Syntax.Binds: [psb_id] :: PatSynBind idL idR -> LIdP idL

+ Language.Haskell.Syntax.Binds: [recordPatSynField] :: RecordPatSynField pass -> FieldOcc pass

+ Language.Haskell.Syntax.Binds: [recordPatSynPatVar] :: RecordPatSynField pass -> LIdP pass

+ Language.Haskell.Syntax.Binds: [var_ext] :: HsBindLR idL idR -> XVarBind idL idR

+ Language.Haskell.Syntax.Binds: [var_id] :: HsBindLR idL idR -> IdP idL

+ Language.Haskell.Syntax.Binds: [var_rhs] :: HsBindLR idL idR -> LHsExpr idR

+ Language.Haskell.Syntax.Binds: data ABExport p

+ Language.Haskell.Syntax.Binds: data FixitySig pass

+ Language.Haskell.Syntax.Binds: data HsBindLR idL idR

+ Language.Haskell.Syntax.Binds: data HsIPBinds id

+ Language.Haskell.Syntax.Binds: data HsLocalBindsLR idL idR

+ Language.Haskell.Syntax.Binds: data HsPatSynDir id

+ Language.Haskell.Syntax.Binds: data HsValBindsLR idL idR

+ Language.Haskell.Syntax.Binds: data IPBind id

+ Language.Haskell.Syntax.Binds: data PatSynBind idL idR

+ Language.Haskell.Syntax.Binds: data RecordPatSynField pass

+ Language.Haskell.Syntax.Binds: data Sig pass

+ Language.Haskell.Syntax.Binds: data TcSpecPrag

+ Language.Haskell.Syntax.Binds: data TcSpecPrags

+ Language.Haskell.Syntax.Binds: hasSpecPrags :: TcSpecPrags -> Bool

+ Language.Haskell.Syntax.Binds: hsSigDoc :: Sig name -> SDoc

+ Language.Haskell.Syntax.Binds: instance Data.Data.Data Language.Haskell.Syntax.Binds.TcSpecPrag

+ Language.Haskell.Syntax.Binds: instance Data.Data.Data Language.Haskell.Syntax.Binds.TcSpecPrags

+ Language.Haskell.Syntax.Binds: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Binds.RecordPatSynField a)

+ Language.Haskell.Syntax.Binds: isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isDefaultMethod :: TcSpecPrags -> Bool

+ Language.Haskell.Syntax.Binds: isFixityLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isInlineLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isMinimalLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isPragLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isSpecLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: isTypeLSig :: forall p. UnXRec p => LSig p -> Bool

+ Language.Haskell.Syntax.Binds: noSpecPrags :: TcSpecPrags

+ Language.Haskell.Syntax.Binds: type HsBind id = HsBindLR id id

+ Language.Haskell.Syntax.Binds: type HsLocalBinds id = HsLocalBindsLR id id

+ Language.Haskell.Syntax.Binds: type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass]

+ Language.Haskell.Syntax.Binds: type HsValBinds id = HsValBindsLR id id

+ Language.Haskell.Syntax.Binds: type LFixitySig pass = XRec pass (FixitySig pass)

+ Language.Haskell.Syntax.Binds: type LHsBind id = LHsBindLR id id

+ Language.Haskell.Syntax.Binds: type LHsBindLR idL idR = XRec idL (HsBindLR idL idR)

+ Language.Haskell.Syntax.Binds: type LHsBinds id = LHsBindsLR id id

+ Language.Haskell.Syntax.Binds: type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)

+ Language.Haskell.Syntax.Binds: type LHsLocalBinds id = XRec id (HsLocalBinds id)

+ Language.Haskell.Syntax.Binds: type LHsLocalBindsLR idL idR = XRec idL (HsLocalBindsLR idL idR)

+ Language.Haskell.Syntax.Binds: type LIPBind id = XRec id (IPBind id)

+ Language.Haskell.Syntax.Binds: type LSig pass = XRec pass (Sig pass)

+ Language.Haskell.Syntax.Binds: type LTcSpecPrag = Located TcSpecPrag

+ Language.Haskell.Syntax.Decls: AnnD :: XAnnD p -> AnnDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: AnyclassStrategy :: XAnyClassStrategy pass -> DerivStrategy pass

+ Language.Haskell.Syntax.Decls: CExport :: Located CExportSpec -> Located SourceText -> ForeignExport

+ Language.Haskell.Syntax.Decls: CFunction :: CCallTarget -> CImportSpec

+ Language.Haskell.Syntax.Decls: CImport :: Located CCallConv -> Located Safety -> Maybe Header -> CImportSpec -> Located SourceText -> ForeignImport

+ Language.Haskell.Syntax.Decls: CLabel :: CLabelString -> CImportSpec

+ Language.Haskell.Syntax.Decls: CWrapper :: CImportSpec

+ Language.Haskell.Syntax.Decls: ClassDecl :: XClassDecl pass -> Maybe (LHsContext pass) -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl pass] -> TyClDecl pass

+ Language.Haskell.Syntax.Decls: ClosedTypeFamily :: Maybe [LTyFamInstEqn pass] -> FamilyInfo pass

+ Language.Haskell.Syntax.Decls: ClsInstD :: XClsInstD pass -> ClsInstDecl pass -> InstDecl pass

+ Language.Haskell.Syntax.Decls: ClsInstDecl :: XCClsInstDecl pass -> LHsSigType pass -> LHsBinds pass -> [LSig pass] -> [LTyFamInstDecl pass] -> [LDataFamInstDecl pass] -> Maybe (XRec pass OverlapMode) -> ClsInstDecl pass

+ Language.Haskell.Syntax.Decls: ConDeclGADT :: XConDeclGADT pass -> [LIdP pass] -> XRec pass (HsOuterSigTyVarBndrs pass) -> Maybe (LHsContext pass) -> HsConDeclGADTDetails pass -> LHsType pass -> Maybe LHsDocString -> ConDecl pass

+ Language.Haskell.Syntax.Decls: ConDeclH98 :: XConDeclH98 pass -> LIdP pass -> Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclH98Details pass -> Maybe LHsDocString -> ConDecl pass

+ Language.Haskell.Syntax.Decls: DataDecl :: XDataDecl pass -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> HsDataDefn pass -> TyClDecl pass

+ Language.Haskell.Syntax.Decls: DataDeclRn :: Bool -> NameSet -> DataDeclRn

+ Language.Haskell.Syntax.Decls: DataFamInstD :: XDataFamInstD pass -> DataFamInstDecl pass -> InstDecl pass

+ Language.Haskell.Syntax.Decls: DataFamInstDecl :: FamEqn pass (HsDataDefn pass) -> DataFamInstDecl pass

+ Language.Haskell.Syntax.Decls: DataFamily :: FamilyInfo pass

+ Language.Haskell.Syntax.Decls: DataType :: NewOrData

+ Language.Haskell.Syntax.Decls: DctMulti :: XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass

+ Language.Haskell.Syntax.Decls: DctSingle :: XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass

+ Language.Haskell.Syntax.Decls: DefD :: XDefD p -> DefaultDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: DefaultDecl :: XCDefaultDecl pass -> [LHsType pass] -> DefaultDecl pass

+ Language.Haskell.Syntax.Decls: DerivD :: XDerivD p -> DerivDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: DerivDecl :: XCDerivDecl pass -> LHsSigWcType pass -> Maybe (LDerivStrategy pass) -> Maybe (XRec pass OverlapMode) -> DerivDecl pass

+ Language.Haskell.Syntax.Decls: DocCommentNamed :: String -> HsDocString -> DocDecl

+ Language.Haskell.Syntax.Decls: DocCommentNext :: HsDocString -> DocDecl

+ Language.Haskell.Syntax.Decls: DocCommentPrev :: HsDocString -> DocDecl

+ Language.Haskell.Syntax.Decls: DocD :: XDocD p -> DocDecl -> HsDecl p

+ Language.Haskell.Syntax.Decls: DocGroup :: Int -> HsDocString -> DocDecl

+ Language.Haskell.Syntax.Decls: ExplicitSplice :: SpliceExplicitFlag

+ Language.Haskell.Syntax.Decls: FamDecl :: XFamDecl pass -> FamilyDecl pass -> TyClDecl pass

+ Language.Haskell.Syntax.Decls: FamEqn :: XCFamEqn pass rhs -> LIdP pass -> HsOuterFamEqnTyVarBndrs pass -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs

+ Language.Haskell.Syntax.Decls: FamilyDecl :: XCFamilyDecl pass -> FamilyInfo pass -> TopLevelFlag -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> LFamilyResultSig pass -> Maybe (LInjectivityAnn pass) -> FamilyDecl pass

+ Language.Haskell.Syntax.Decls: ForD :: XForD p -> ForeignDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: ForeignExport :: XForeignExport pass -> LIdP pass -> LHsSigType pass -> ForeignExport -> ForeignDecl pass

+ Language.Haskell.Syntax.Decls: ForeignImport :: XForeignImport pass -> LIdP pass -> LHsSigType pass -> ForeignImport -> ForeignDecl pass

+ Language.Haskell.Syntax.Decls: FunDep :: XCFunDep pass -> [LIdP pass] -> [LIdP pass] -> FunDep pass

+ Language.Haskell.Syntax.Decls: HsAnnotation :: XHsAnnotation pass -> SourceText -> AnnProvenance pass -> XRec pass (HsExpr pass) -> AnnDecl pass

+ Language.Haskell.Syntax.Decls: HsDataDefn :: XCHsDataDefn pass -> NewOrData -> Maybe (LHsContext pass) -> Maybe (XRec pass CType) -> Maybe (LHsKind pass) -> [LConDecl pass] -> HsDeriving pass -> HsDataDefn pass

+ Language.Haskell.Syntax.Decls: HsDerivingClause :: XCHsDerivingClause pass -> Maybe (LDerivStrategy pass) -> LDerivClauseTys pass -> HsDerivingClause pass

+ Language.Haskell.Syntax.Decls: HsGroup :: XCHsGroup p -> HsValBinds p -> [LSpliceDecl p] -> [TyClGroup p] -> [LDerivDecl p] -> [LFixitySig p] -> [LDefaultDecl p] -> [LForeignDecl p] -> [LWarnDecls p] -> [LAnnDecl p] -> [LRuleDecls p] -> [LDocDecl p] -> HsGroup p

+ Language.Haskell.Syntax.Decls: HsRule :: XHsRule pass -> XRec pass (SourceText, RuleName) -> Activation -> Maybe [LHsTyVarBndr () (NoGhcTc pass)] -> [LRuleBndr pass] -> XRec pass (HsExpr pass) -> XRec pass (HsExpr pass) -> RuleDecl pass

+ Language.Haskell.Syntax.Decls: HsRuleRn :: NameSet -> NameSet -> HsRuleRn

+ Language.Haskell.Syntax.Decls: HsRules :: XCRuleDecls pass -> SourceText -> [LRuleDecl pass] -> RuleDecls pass

+ Language.Haskell.Syntax.Decls: ImplicitSplice :: SpliceExplicitFlag

+ Language.Haskell.Syntax.Decls: InjectivityAnn :: XCInjectivityAnn pass -> LIdP pass -> [LIdP pass] -> InjectivityAnn pass

+ Language.Haskell.Syntax.Decls: InstD :: XInstD p -> InstDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: KindSig :: XCKindSig pass -> LHsKind pass -> FamilyResultSig pass

+ Language.Haskell.Syntax.Decls: KindSigD :: XKindSigD p -> StandaloneKindSig p -> HsDecl p

+ Language.Haskell.Syntax.Decls: ModuleAnnProvenance :: AnnProvenance pass

+ Language.Haskell.Syntax.Decls: NewType :: NewOrData

+ Language.Haskell.Syntax.Decls: NewtypeStrategy :: XNewtypeStrategy pass -> DerivStrategy pass

+ Language.Haskell.Syntax.Decls: NoSig :: XNoSig pass -> FamilyResultSig pass

+ Language.Haskell.Syntax.Decls: OpenTypeFamily :: FamilyInfo pass

+ Language.Haskell.Syntax.Decls: PrefixConGADT :: [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass

+ Language.Haskell.Syntax.Decls: RecConGADT :: XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass

+ Language.Haskell.Syntax.Decls: RoleAnnotD :: XRoleAnnotD p -> RoleAnnotDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: RoleAnnotDecl :: XCRoleAnnotDecl pass -> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass

+ Language.Haskell.Syntax.Decls: RuleBndr :: XCRuleBndr pass -> LIdP pass -> RuleBndr pass

+ Language.Haskell.Syntax.Decls: RuleBndrSig :: XRuleBndrSig pass -> LIdP pass -> HsPatSigType pass -> RuleBndr pass

+ Language.Haskell.Syntax.Decls: RuleD :: XRuleD p -> RuleDecls p -> HsDecl p

+ Language.Haskell.Syntax.Decls: SigD :: XSigD p -> Sig p -> HsDecl p

+ Language.Haskell.Syntax.Decls: SpliceD :: XSpliceD p -> SpliceDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: SpliceDecl :: XSpliceDecl p -> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p

+ Language.Haskell.Syntax.Decls: StandaloneKindSig :: XStandaloneKindSig pass -> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass

+ Language.Haskell.Syntax.Decls: StockStrategy :: XStockStrategy pass -> DerivStrategy pass

+ Language.Haskell.Syntax.Decls: SynDecl :: XSynDecl pass -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> LHsType pass -> TyClDecl pass

+ Language.Haskell.Syntax.Decls: TyClD :: XTyClD p -> TyClDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: TyClGroup :: XCTyClGroup pass -> [LTyClDecl pass] -> [LRoleAnnotDecl pass] -> [LStandaloneKindSig pass] -> [LInstDecl pass] -> TyClGroup pass

+ Language.Haskell.Syntax.Decls: TyFamInstD :: XTyFamInstD pass -> TyFamInstDecl pass -> InstDecl pass

+ Language.Haskell.Syntax.Decls: TyFamInstDecl :: XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass

+ Language.Haskell.Syntax.Decls: TyVarSig :: XTyVarSig pass -> LHsTyVarBndr () pass -> FamilyResultSig pass

+ Language.Haskell.Syntax.Decls: TypeAnnProvenance :: LIdP pass -> AnnProvenance pass

+ Language.Haskell.Syntax.Decls: ValD :: XValD p -> HsBind p -> HsDecl p

+ Language.Haskell.Syntax.Decls: ValueAnnProvenance :: LIdP pass -> AnnProvenance pass

+ Language.Haskell.Syntax.Decls: ViaStrategy :: XViaStrategy pass -> DerivStrategy pass

+ Language.Haskell.Syntax.Decls: Warning :: XWarning pass -> [LIdP pass] -> WarningTxt -> WarnDecl pass

+ Language.Haskell.Syntax.Decls: WarningD :: XWarningD p -> WarnDecls p -> HsDecl p

+ Language.Haskell.Syntax.Decls: Warnings :: XWarnings pass -> SourceText -> [LWarnDecl pass] -> WarnDecls pass

+ Language.Haskell.Syntax.Decls: XAnnDecl :: !XXAnnDecl pass -> AnnDecl pass

+ Language.Haskell.Syntax.Decls: XClsInstDecl :: !XXClsInstDecl pass -> ClsInstDecl pass

+ Language.Haskell.Syntax.Decls: XConDecl :: !XXConDecl pass -> ConDecl pass

+ Language.Haskell.Syntax.Decls: XDefaultDecl :: !XXDefaultDecl pass -> DefaultDecl pass

+ Language.Haskell.Syntax.Decls: XDerivClauseTys :: !XXDerivClauseTys pass -> DerivClauseTys pass

+ Language.Haskell.Syntax.Decls: XDerivDecl :: !XXDerivDecl pass -> DerivDecl pass

+ Language.Haskell.Syntax.Decls: XFamEqn :: !XXFamEqn pass rhs -> FamEqn pass rhs

+ Language.Haskell.Syntax.Decls: XFamilyDecl :: !XXFamilyDecl pass -> FamilyDecl pass

+ Language.Haskell.Syntax.Decls: XFamilyResultSig :: !XXFamilyResultSig pass -> FamilyResultSig pass

+ Language.Haskell.Syntax.Decls: XForeignDecl :: !XXForeignDecl pass -> ForeignDecl pass

+ Language.Haskell.Syntax.Decls: XFunDep :: !XXFunDep pass -> FunDep pass

+ Language.Haskell.Syntax.Decls: XHsDataDefn :: !XXHsDataDefn pass -> HsDataDefn pass

+ Language.Haskell.Syntax.Decls: XHsDecl :: !XXHsDecl p -> HsDecl p

+ Language.Haskell.Syntax.Decls: XHsDerivingClause :: !XXHsDerivingClause pass -> HsDerivingClause pass

+ Language.Haskell.Syntax.Decls: XHsGroup :: !XXHsGroup p -> HsGroup p

+ Language.Haskell.Syntax.Decls: XInjectivityAnn :: !XXInjectivityAnn pass -> InjectivityAnn pass

+ Language.Haskell.Syntax.Decls: XInstDecl :: !XXInstDecl pass -> InstDecl pass

+ Language.Haskell.Syntax.Decls: XRoleAnnotDecl :: !XXRoleAnnotDecl pass -> RoleAnnotDecl pass

+ Language.Haskell.Syntax.Decls: XRuleBndr :: !XXRuleBndr pass -> RuleBndr pass

+ Language.Haskell.Syntax.Decls: XRuleDecl :: !XXRuleDecl pass -> RuleDecl pass

+ Language.Haskell.Syntax.Decls: XRuleDecls :: !XXRuleDecls pass -> RuleDecls pass

+ Language.Haskell.Syntax.Decls: XSpliceDecl :: !XXSpliceDecl p -> SpliceDecl p

+ Language.Haskell.Syntax.Decls: XStandaloneKindSig :: !XXStandaloneKindSig pass -> StandaloneKindSig pass

+ Language.Haskell.Syntax.Decls: XTyClDecl :: !XXTyClDecl pass -> TyClDecl pass

+ Language.Haskell.Syntax.Decls: XTyClGroup :: !XXTyClGroup pass -> TyClGroup pass

+ Language.Haskell.Syntax.Decls: XTyFamInstDecl :: !XXTyFamInstDecl pass -> TyFamInstDecl pass

+ Language.Haskell.Syntax.Decls: XWarnDecl :: !XXWarnDecl pass -> WarnDecl pass

+ Language.Haskell.Syntax.Decls: XWarnDecls :: !XXWarnDecls pass -> WarnDecls pass

+ Language.Haskell.Syntax.Decls: [cid_binds] :: ClsInstDecl pass -> LHsBinds pass

+ Language.Haskell.Syntax.Decls: [cid_d_ext] :: InstDecl pass -> XClsInstD pass

+ Language.Haskell.Syntax.Decls: [cid_datafam_insts] :: ClsInstDecl pass -> [LDataFamInstDecl pass]

+ Language.Haskell.Syntax.Decls: [cid_ext] :: ClsInstDecl pass -> XCClsInstDecl pass

+ Language.Haskell.Syntax.Decls: [cid_inst] :: InstDecl pass -> ClsInstDecl pass

+ Language.Haskell.Syntax.Decls: [cid_overlap_mode] :: ClsInstDecl pass -> Maybe (XRec pass OverlapMode)

+ Language.Haskell.Syntax.Decls: [cid_poly_ty] :: ClsInstDecl pass -> LHsSigType pass

+ Language.Haskell.Syntax.Decls: [cid_sigs] :: ClsInstDecl pass -> [LSig pass]

+ Language.Haskell.Syntax.Decls: [cid_tyfam_insts] :: ClsInstDecl pass -> [LTyFamInstDecl pass]

+ Language.Haskell.Syntax.Decls: [con_args] :: ConDecl pass -> HsConDeclH98Details pass

+ Language.Haskell.Syntax.Decls: [con_bndrs] :: ConDecl pass -> XRec pass (HsOuterSigTyVarBndrs pass)

+ Language.Haskell.Syntax.Decls: [con_doc] :: ConDecl pass -> Maybe LHsDocString

+ Language.Haskell.Syntax.Decls: [con_ex_tvs] :: ConDecl pass -> [LHsTyVarBndr Specificity pass]

+ Language.Haskell.Syntax.Decls: [con_ext] :: ConDecl pass -> XConDeclH98 pass

+ Language.Haskell.Syntax.Decls: [con_forall] :: ConDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: [con_g_args] :: ConDecl pass -> HsConDeclGADTDetails pass

+ Language.Haskell.Syntax.Decls: [con_g_ext] :: ConDecl pass -> XConDeclGADT pass

+ Language.Haskell.Syntax.Decls: [con_mb_cxt] :: ConDecl pass -> Maybe (LHsContext pass)

+ Language.Haskell.Syntax.Decls: [con_name] :: ConDecl pass -> LIdP pass

+ Language.Haskell.Syntax.Decls: [con_names] :: ConDecl pass -> [LIdP pass]

+ Language.Haskell.Syntax.Decls: [con_res_ty] :: ConDecl pass -> LHsType pass

+ Language.Haskell.Syntax.Decls: [dd_ND] :: HsDataDefn pass -> NewOrData

+ Language.Haskell.Syntax.Decls: [dd_cType] :: HsDataDefn pass -> Maybe (XRec pass CType)

+ Language.Haskell.Syntax.Decls: [dd_cons] :: HsDataDefn pass -> [LConDecl pass]

+ Language.Haskell.Syntax.Decls: [dd_ctxt] :: HsDataDefn pass -> Maybe (LHsContext pass)

+ Language.Haskell.Syntax.Decls: [dd_derivs] :: HsDataDefn pass -> HsDeriving pass

+ Language.Haskell.Syntax.Decls: [dd_ext] :: HsDataDefn pass -> XCHsDataDefn pass

+ Language.Haskell.Syntax.Decls: [dd_kindSig] :: HsDataDefn pass -> Maybe (LHsKind pass)

+ Language.Haskell.Syntax.Decls: [deriv_clause_ext] :: HsDerivingClause pass -> XCHsDerivingClause pass

+ Language.Haskell.Syntax.Decls: [deriv_clause_strategy] :: HsDerivingClause pass -> Maybe (LDerivStrategy pass)

+ Language.Haskell.Syntax.Decls: [deriv_clause_tys] :: HsDerivingClause pass -> LDerivClauseTys pass

+ Language.Haskell.Syntax.Decls: [deriv_ext] :: DerivDecl pass -> XCDerivDecl pass

+ Language.Haskell.Syntax.Decls: [deriv_overlap_mode] :: DerivDecl pass -> Maybe (XRec pass OverlapMode)

+ Language.Haskell.Syntax.Decls: [deriv_strategy] :: DerivDecl pass -> Maybe (LDerivStrategy pass)

+ Language.Haskell.Syntax.Decls: [deriv_type] :: DerivDecl pass -> LHsSigWcType pass

+ Language.Haskell.Syntax.Decls: [dfid_eqn] :: DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)

+ Language.Haskell.Syntax.Decls: [dfid_ext] :: InstDecl pass -> XDataFamInstD pass

+ Language.Haskell.Syntax.Decls: [dfid_inst] :: InstDecl pass -> DataFamInstDecl pass

+ Language.Haskell.Syntax.Decls: [fdExt] :: FamilyDecl pass -> XCFamilyDecl pass

+ Language.Haskell.Syntax.Decls: [fdFixity] :: FamilyDecl pass -> LexicalFixity

+ Language.Haskell.Syntax.Decls: [fdInfo] :: FamilyDecl pass -> FamilyInfo pass

+ Language.Haskell.Syntax.Decls: [fdInjectivityAnn] :: FamilyDecl pass -> Maybe (LInjectivityAnn pass)

+ Language.Haskell.Syntax.Decls: [fdLName] :: FamilyDecl pass -> LIdP pass

+ Language.Haskell.Syntax.Decls: [fdResultSig] :: FamilyDecl pass -> LFamilyResultSig pass

+ Language.Haskell.Syntax.Decls: [fdTopLevel] :: FamilyDecl pass -> TopLevelFlag

+ Language.Haskell.Syntax.Decls: [fdTyVars] :: FamilyDecl pass -> LHsQTyVars pass

+ Language.Haskell.Syntax.Decls: [fd_e_ext] :: ForeignDecl pass -> XForeignExport pass

+ Language.Haskell.Syntax.Decls: [fd_fe] :: ForeignDecl pass -> ForeignExport

+ Language.Haskell.Syntax.Decls: [fd_fi] :: ForeignDecl pass -> ForeignImport

+ Language.Haskell.Syntax.Decls: [fd_i_ext] :: ForeignDecl pass -> XForeignImport pass

+ Language.Haskell.Syntax.Decls: [fd_name] :: ForeignDecl pass -> LIdP pass

+ Language.Haskell.Syntax.Decls: [fd_sig_ty] :: ForeignDecl pass -> LHsSigType pass

+ Language.Haskell.Syntax.Decls: [feqn_bndrs] :: FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass

+ Language.Haskell.Syntax.Decls: [feqn_ext] :: FamEqn pass rhs -> XCFamEqn pass rhs

+ Language.Haskell.Syntax.Decls: [feqn_fixity] :: FamEqn pass rhs -> LexicalFixity

+ Language.Haskell.Syntax.Decls: [feqn_pats] :: FamEqn pass rhs -> HsTyPats pass

+ Language.Haskell.Syntax.Decls: [feqn_rhs] :: FamEqn pass rhs -> rhs

+ Language.Haskell.Syntax.Decls: [feqn_tycon] :: FamEqn pass rhs -> LIdP pass

+ Language.Haskell.Syntax.Decls: [group_ext] :: TyClGroup pass -> XCTyClGroup pass

+ Language.Haskell.Syntax.Decls: [group_instds] :: TyClGroup pass -> [LInstDecl pass]

+ Language.Haskell.Syntax.Decls: [group_kisigs] :: TyClGroup pass -> [LStandaloneKindSig pass]

+ Language.Haskell.Syntax.Decls: [group_roles] :: TyClGroup pass -> [LRoleAnnotDecl pass]

+ Language.Haskell.Syntax.Decls: [group_tyclds] :: TyClGroup pass -> [LTyClDecl pass]

+ Language.Haskell.Syntax.Decls: [hs_annds] :: HsGroup p -> [LAnnDecl p]

+ Language.Haskell.Syntax.Decls: [hs_defds] :: HsGroup p -> [LDefaultDecl p]

+ Language.Haskell.Syntax.Decls: [hs_derivds] :: HsGroup p -> [LDerivDecl p]

+ Language.Haskell.Syntax.Decls: [hs_docs] :: HsGroup p -> [LDocDecl p]

+ Language.Haskell.Syntax.Decls: [hs_ext] :: HsGroup p -> XCHsGroup p

+ Language.Haskell.Syntax.Decls: [hs_fixds] :: HsGroup p -> [LFixitySig p]

+ Language.Haskell.Syntax.Decls: [hs_fords] :: HsGroup p -> [LForeignDecl p]

+ Language.Haskell.Syntax.Decls: [hs_ruleds] :: HsGroup p -> [LRuleDecls p]

+ Language.Haskell.Syntax.Decls: [hs_splcds] :: HsGroup p -> [LSpliceDecl p]

+ Language.Haskell.Syntax.Decls: [hs_tyclds] :: HsGroup p -> [TyClGroup p]

+ Language.Haskell.Syntax.Decls: [hs_valds] :: HsGroup p -> HsValBinds p

+ Language.Haskell.Syntax.Decls: [hs_warnds] :: HsGroup p -> [LWarnDecls p]

+ Language.Haskell.Syntax.Decls: [rd_act] :: RuleDecl pass -> Activation

+ Language.Haskell.Syntax.Decls: [rd_ext] :: RuleDecl pass -> XHsRule pass

+ Language.Haskell.Syntax.Decls: [rd_lhs] :: RuleDecl pass -> XRec pass (HsExpr pass)

+ Language.Haskell.Syntax.Decls: [rd_name] :: RuleDecl pass -> XRec pass (SourceText, RuleName)

+ Language.Haskell.Syntax.Decls: [rd_rhs] :: RuleDecl pass -> XRec pass (HsExpr pass)

+ Language.Haskell.Syntax.Decls: [rd_tmvs] :: RuleDecl pass -> [LRuleBndr pass]

+ Language.Haskell.Syntax.Decls: [rd_tyvs] :: RuleDecl pass -> Maybe [LHsTyVarBndr () (NoGhcTc pass)]

+ Language.Haskell.Syntax.Decls: [rds_ext] :: RuleDecls pass -> XCRuleDecls pass

+ Language.Haskell.Syntax.Decls: [rds_rules] :: RuleDecls pass -> [LRuleDecl pass]

+ Language.Haskell.Syntax.Decls: [rds_src] :: RuleDecls pass -> SourceText

+ Language.Haskell.Syntax.Decls: [tcdATDefs] :: TyClDecl pass -> [LTyFamDefltDecl pass]

+ Language.Haskell.Syntax.Decls: [tcdATs] :: TyClDecl pass -> [LFamilyDecl pass]

+ Language.Haskell.Syntax.Decls: [tcdCExt] :: TyClDecl pass -> XClassDecl pass

+ Language.Haskell.Syntax.Decls: [tcdCtxt] :: TyClDecl pass -> Maybe (LHsContext pass)

+ Language.Haskell.Syntax.Decls: [tcdDExt] :: TyClDecl pass -> XDataDecl pass

+ Language.Haskell.Syntax.Decls: [tcdDataCusk] :: DataDeclRn -> Bool

+ Language.Haskell.Syntax.Decls: [tcdDataDefn] :: TyClDecl pass -> HsDataDefn pass

+ Language.Haskell.Syntax.Decls: [tcdDocs] :: TyClDecl pass -> [LDocDecl pass]

+ Language.Haskell.Syntax.Decls: [tcdFDs] :: TyClDecl pass -> [LHsFunDep pass]

+ Language.Haskell.Syntax.Decls: [tcdFExt] :: TyClDecl pass -> XFamDecl pass

+ Language.Haskell.Syntax.Decls: [tcdFVs] :: DataDeclRn -> NameSet

+ Language.Haskell.Syntax.Decls: [tcdFam] :: TyClDecl pass -> FamilyDecl pass

+ Language.Haskell.Syntax.Decls: [tcdFixity] :: TyClDecl pass -> LexicalFixity

+ Language.Haskell.Syntax.Decls: [tcdLName] :: TyClDecl pass -> LIdP pass

+ Language.Haskell.Syntax.Decls: [tcdMeths] :: TyClDecl pass -> LHsBinds pass

+ Language.Haskell.Syntax.Decls: [tcdRhs] :: TyClDecl pass -> LHsType pass

+ Language.Haskell.Syntax.Decls: [tcdSExt] :: TyClDecl pass -> XSynDecl pass

+ Language.Haskell.Syntax.Decls: [tcdSigs] :: TyClDecl pass -> [LSig pass]

+ Language.Haskell.Syntax.Decls: [tcdTyVars] :: TyClDecl pass -> LHsQTyVars pass

+ Language.Haskell.Syntax.Decls: [tfid_eqn] :: TyFamInstDecl pass -> TyFamInstEqn pass

+ Language.Haskell.Syntax.Decls: [tfid_ext] :: InstDecl pass -> XTyFamInstD pass

+ Language.Haskell.Syntax.Decls: [tfid_inst] :: InstDecl pass -> TyFamInstDecl pass

+ Language.Haskell.Syntax.Decls: [tfid_xtn] :: TyFamInstDecl pass -> XCTyFamInstDecl pass

+ Language.Haskell.Syntax.Decls: [wd_ext] :: WarnDecls pass -> XWarnings pass

+ Language.Haskell.Syntax.Decls: [wd_src] :: WarnDecls pass -> SourceText

+ Language.Haskell.Syntax.Decls: [wd_warnings] :: WarnDecls pass -> [LWarnDecl pass]

+ Language.Haskell.Syntax.Decls: annProvenanceName_maybe :: forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p)

+ Language.Haskell.Syntax.Decls: collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]

+ Language.Haskell.Syntax.Decls: countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)

+ Language.Haskell.Syntax.Decls: data AnnDecl pass

+ Language.Haskell.Syntax.Decls: data AnnProvenance pass

+ Language.Haskell.Syntax.Decls: data CImportSpec

+ Language.Haskell.Syntax.Decls: data ClsInstDecl pass

+ Language.Haskell.Syntax.Decls: data ConDecl pass

+ Language.Haskell.Syntax.Decls: data DataDeclRn

+ Language.Haskell.Syntax.Decls: data DefaultDecl pass

+ Language.Haskell.Syntax.Decls: data DerivClauseTys pass

+ Language.Haskell.Syntax.Decls: data DerivDecl pass

+ Language.Haskell.Syntax.Decls: data DerivStrategy pass

+ Language.Haskell.Syntax.Decls: data DocDecl

+ Language.Haskell.Syntax.Decls: data FamEqn pass rhs

+ Language.Haskell.Syntax.Decls: data FamilyDecl pass

+ Language.Haskell.Syntax.Decls: data FamilyInfo pass

+ Language.Haskell.Syntax.Decls: data FamilyResultSig pass

+ Language.Haskell.Syntax.Decls: data ForeignDecl pass

+ Language.Haskell.Syntax.Decls: data ForeignExport

+ Language.Haskell.Syntax.Decls: data ForeignImport

+ Language.Haskell.Syntax.Decls: data FunDep pass

+ Language.Haskell.Syntax.Decls: data HsConDeclGADTDetails pass

+ Language.Haskell.Syntax.Decls: data HsDataDefn pass

+ Language.Haskell.Syntax.Decls: data HsDecl p

+ Language.Haskell.Syntax.Decls: data HsDerivingClause pass

+ Language.Haskell.Syntax.Decls: data HsGroup p

+ Language.Haskell.Syntax.Decls: data HsRuleRn

+ Language.Haskell.Syntax.Decls: data InjectivityAnn pass

+ Language.Haskell.Syntax.Decls: data InstDecl pass

+ Language.Haskell.Syntax.Decls: data NewOrData

+ Language.Haskell.Syntax.Decls: data RoleAnnotDecl pass

+ Language.Haskell.Syntax.Decls: data RuleBndr pass

+ Language.Haskell.Syntax.Decls: data RuleDecl pass

+ Language.Haskell.Syntax.Decls: data RuleDecls pass

+ Language.Haskell.Syntax.Decls: data SpliceDecl p

+ Language.Haskell.Syntax.Decls: data SpliceExplicitFlag

+ Language.Haskell.Syntax.Decls: data StandaloneKindSig pass

+ Language.Haskell.Syntax.Decls: data TyClDecl pass

+ Language.Haskell.Syntax.Decls: data TyClGroup pass

+ Language.Haskell.Syntax.Decls: data TyFamInstDecl pass

+ Language.Haskell.Syntax.Decls: data WarnDecl pass

+ Language.Haskell.Syntax.Decls: data WarnDecls pass

+ Language.Haskell.Syntax.Decls: derivStrategyName :: DerivStrategy a -> SDoc

+ Language.Haskell.Syntax.Decls: docDeclDoc :: DocDecl -> HsDocString

+ Language.Haskell.Syntax.Decls: hsGroupInstDecls :: HsGroup id -> [LInstDecl id]

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.CImportSpec

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.DataDeclRn

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.DocDecl

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.ForeignExport

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.ForeignImport

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.HsRuleRn

+ Language.Haskell.Syntax.Decls: instance Data.Data.Data Language.Haskell.Syntax.Decls.NewOrData

+ Language.Haskell.Syntax.Decls: instance GHC.Classes.Eq Language.Haskell.Syntax.Decls.NewOrData

+ Language.Haskell.Syntax.Decls: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Decls.FamilyInfo pass)

+ Language.Haskell.Syntax.Decls: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Decls.DocDecl

+ Language.Haskell.Syntax.Decls: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Decls.ForeignExport

+ Language.Haskell.Syntax.Decls: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Decls.ForeignImport

+ Language.Haskell.Syntax.Decls: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Decls.NewOrData

+ Language.Haskell.Syntax.Decls: isClassDecl :: TyClDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool

+ Language.Haskell.Syntax.Decls: isDataDecl :: TyClDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: isDataFamilyDecl :: TyClDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: isFamilyDecl :: TyClDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool

+ Language.Haskell.Syntax.Decls: isSynDecl :: TyClDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: isTypeFamilyDecl :: TyClDecl pass -> Bool

+ Language.Haskell.Syntax.Decls: newOrDataToFlavour :: NewOrData -> TyConFlavour

+ Language.Haskell.Syntax.Decls: newtype DataFamInstDecl pass

+ Language.Haskell.Syntax.Decls: pprFlavour :: FamilyInfo pass -> SDoc

+ Language.Haskell.Syntax.Decls: pprFullRuleName :: Located (SourceText, RuleName) -> SDoc

+ Language.Haskell.Syntax.Decls: tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass

+ Language.Haskell.Syntax.Decls: tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]

+ Language.Haskell.Syntax.Decls: tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]

+ Language.Haskell.Syntax.Decls: tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]

+ Language.Haskell.Syntax.Decls: tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]

+ Language.Haskell.Syntax.Decls: type HsConDeclH98Details pass = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])

+ Language.Haskell.Syntax.Decls: type HsDeriving pass = [LHsDerivingClause pass] " The optional @deriving@ clauses of a data declaration. "Clauses" is plural because one can specify multiple deriving clauses using the @-XDerivingStrategies@ language extension. The list of 'LHsDerivingClause's corresponds to exactly what the user requested to derive, in order. If no deriving clauses were specified, the list is empty."

+ Language.Haskell.Syntax.Decls: type HsTyPats pass = [LHsTypeArg pass]

+ Language.Haskell.Syntax.Decls: type LAnnDecl pass = XRec pass (AnnDecl pass)

+ Language.Haskell.Syntax.Decls: type LClsInstDecl pass = XRec pass (ClsInstDecl pass)

+ Language.Haskell.Syntax.Decls: type LConDecl pass = XRec pass (ConDecl pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a GADT constructor list"

+ Language.Haskell.Syntax.Decls: type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass)

+ Language.Haskell.Syntax.Decls: type LDefaultDecl pass = XRec pass (DefaultDecl pass)

+ Language.Haskell.Syntax.Decls: type LDerivClauseTys pass = XRec pass (DerivClauseTys pass)

+ Language.Haskell.Syntax.Decls: type LDerivDecl pass = XRec pass (DerivDecl pass)

+ Language.Haskell.Syntax.Decls: type LDerivStrategy pass = XRec pass (DerivStrategy pass)

+ Language.Haskell.Syntax.Decls: type LDocDecl pass = XRec pass (DocDecl)

+ Language.Haskell.Syntax.Decls: type LFamilyDecl pass = XRec pass (FamilyDecl pass)

+ Language.Haskell.Syntax.Decls: type LFamilyResultSig pass = XRec pass (FamilyResultSig pass)

+ Language.Haskell.Syntax.Decls: type LForeignDecl pass = XRec pass (ForeignDecl pass)

+ Language.Haskell.Syntax.Decls: type LHsDecl p = XRec p (HsDecl p) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' "

+ Language.Haskell.Syntax.Decls: type LHsDerivingClause pass = XRec pass (HsDerivingClause pass)

+ Language.Haskell.Syntax.Decls: type LHsFunDep pass = XRec pass (FunDep pass)

+ Language.Haskell.Syntax.Decls: type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)

+ Language.Haskell.Syntax.Decls: type LInstDecl pass = XRec pass (InstDecl pass)

+ Language.Haskell.Syntax.Decls: type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass)

+ Language.Haskell.Syntax.Decls: type LRuleBndr pass = XRec pass (RuleBndr pass)

+ Language.Haskell.Syntax.Decls: type LRuleDecl pass = XRec pass (RuleDecl pass)

+ Language.Haskell.Syntax.Decls: type LRuleDecls pass = XRec pass (RuleDecls pass)

+ Language.Haskell.Syntax.Decls: type LSpliceDecl pass = XRec pass (SpliceDecl pass)

+ Language.Haskell.Syntax.Decls: type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)

+ Language.Haskell.Syntax.Decls: type LTyClDecl pass = XRec pass (TyClDecl pass)

+ Language.Haskell.Syntax.Decls: type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass)

+ Language.Haskell.Syntax.Decls: type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)

+ Language.Haskell.Syntax.Decls: type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a list"

+ Language.Haskell.Syntax.Decls: type LWarnDecl pass = XRec pass (WarnDecl pass)

+ Language.Haskell.Syntax.Decls: type LWarnDecls pass = XRec pass (WarnDecls pass)

+ Language.Haskell.Syntax.Decls: type TyFamDefltDecl = TyFamInstDecl

+ Language.Haskell.Syntax.Decls: type TyFamInstEqn pass = FamEqn pass (LHsType pass)

+ Language.Haskell.Syntax.Expr: ApplicativeArgMany :: XApplicativeArgMany idL -> [ExprLStmt idL] -> HsExpr idL -> LPat idL -> HsStmtContext (ApplicativeArgStmCtxPass idL) -> ApplicativeArg idL

+ Language.Haskell.Syntax.Expr: ApplicativeArgOne :: XApplicativeArgOne idL -> LPat idL -> LHsExpr idL -> Bool -> ApplicativeArg idL

+ Language.Haskell.Syntax.Expr: ApplicativeStmt :: XApplicativeStmt idL idR body -> [(SyntaxExpr idR, ApplicativeArg idL)] -> Maybe (SyntaxExpr idR) -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: ArithSeq :: XArithSeq p -> Maybe (SyntaxExpr p) -> ArithSeqInfo p -> HsExpr p

+ Language.Haskell.Syntax.Expr: ArrowCaseAlt :: HsArrowMatchContext

+ Language.Haskell.Syntax.Expr: ArrowExpr :: HsStmtContext p

+ Language.Haskell.Syntax.Expr: ArrowMatchCtxt :: HsArrowMatchContext -> HsMatchContext p

+ Language.Haskell.Syntax.Expr: BareSplice :: SpliceDecoration

+ Language.Haskell.Syntax.Expr: BindStmt :: XBindStmt idL idR body -> LPat idL -> body -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: BodyStmt :: XBodyStmt idL idR body -> body -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: CaseAlt :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: DecBrG :: XDecBrG p -> HsGroup p -> HsBracket p

+ Language.Haskell.Syntax.Expr: DecBrL :: XDecBrL p -> [LHsDecl p] -> HsBracket p

+ Language.Haskell.Syntax.Expr: DoExpr :: Maybe ModuleName -> HsStmtContext p

+ Language.Haskell.Syntax.Expr: DollarSplice :: SpliceDecoration

+ Language.Haskell.Syntax.Expr: ExpBr :: XExpBr p -> LHsExpr p -> HsBracket p

+ Language.Haskell.Syntax.Expr: ExplicitList :: XExplicitList p -> [LHsExpr p] -> HsExpr p

+ Language.Haskell.Syntax.Expr: ExplicitSum :: XExplicitSum p -> ConTag -> Arity -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: ExplicitTuple :: XExplicitTuple p -> [HsTupArg p] -> Boxity -> HsExpr p

+ Language.Haskell.Syntax.Expr: ExprWithTySig :: XExprWithTySig p -> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p

+ Language.Haskell.Syntax.Expr: FieldLabelStrings :: [Located (HsFieldLabel p)] -> FieldLabelStrings p

+ Language.Haskell.Syntax.Expr: From :: LHsExpr id -> ArithSeqInfo id

+ Language.Haskell.Syntax.Expr: FromThen :: LHsExpr id -> LHsExpr id -> ArithSeqInfo id

+ Language.Haskell.Syntax.Expr: FromThenTo :: LHsExpr id -> LHsExpr id -> LHsExpr id -> ArithSeqInfo id

+ Language.Haskell.Syntax.Expr: FromTo :: LHsExpr id -> LHsExpr id -> ArithSeqInfo id

+ Language.Haskell.Syntax.Expr: FunRhs :: LIdP p -> LexicalFixity -> SrcStrictness -> HsMatchContext p

+ Language.Haskell.Syntax.Expr: GRHS :: XCGRHS p body -> [GuardLStmt p] -> body -> GRHS p body

+ Language.Haskell.Syntax.Expr: GRHSs :: XCGRHSs p body -> [LGRHS p body] -> HsLocalBinds p -> GRHSs p body

+ Language.Haskell.Syntax.Expr: GhciStmtCtxt :: HsStmtContext p

+ Language.Haskell.Syntax.Expr: GroupForm :: TransForm

+ Language.Haskell.Syntax.Expr: HsApp :: XApp p -> LHsExpr p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsAppType :: XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsBinTick :: XBinTick p -> Int -> Int -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsBracket :: XBracket p -> HsBracket p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsCase :: XCase p -> LHsExpr p -> MatchGroup p (LHsExpr p) -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsCmdApp :: XCmdApp id -> LHsCmd id -> LHsExpr id -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdArrApp :: XCmdArrApp id -> LHsExpr id -> LHsExpr id -> HsArrAppType -> Bool -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdArrForm :: XCmdArrForm id -> LHsExpr id -> LexicalFixity -> Maybe Fixity -> [LHsCmdTop id] -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdCase :: XCmdCase id -> LHsExpr id -> MatchGroup id (LHsCmd id) -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdDo :: XCmdDo id -> XRec id [CmdLStmt id] -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdIf :: XCmdIf id -> SyntaxExpr id -> LHsExpr id -> LHsCmd id -> LHsCmd id -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdLam :: XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdLamCase :: XCmdLamCase id -> MatchGroup id (LHsCmd id) -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdLet :: XCmdLet id -> HsLocalBinds id -> LHsCmd id -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdPar :: XCmdPar id -> LHsCmd id -> HsCmd id

+ Language.Haskell.Syntax.Expr: HsCmdTop :: XCmdTop p -> LHsCmd p -> HsCmdTop p

+ Language.Haskell.Syntax.Expr: HsConLikeOut :: XConLikeOut p -> ConLike -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsDo :: XDo p -> HsStmtContext (HsDoRn p) -> XRec p [ExprLStmt p] -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsFieldLabel :: XCHsFieldLabel p -> Located FieldLabelString -> HsFieldLabel p

+ Language.Haskell.Syntax.Expr: HsFirstOrderApp :: HsArrAppType

+ Language.Haskell.Syntax.Expr: HsGetField :: XGetField p -> LHsExpr p -> Located (HsFieldLabel p) -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsHigherOrderApp :: HsArrAppType

+ Language.Haskell.Syntax.Expr: HsIPVar :: XIPVar p -> HsIPName -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsIf :: XIf p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsLam :: XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsLamCase :: XLamCase p -> MatchGroup p (LHsExpr p) -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsLet :: XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsLit :: XLitE p -> HsLit p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsMultiIf :: XMultiIf p -> [LGRHS p (LHsExpr p)] -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsOverLabel :: XOverLabel p -> FastString -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsOverLit :: XOverLitE p -> HsOverLit p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsPar :: XPar p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsPragE :: XPragE p -> HsPragE p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsPragSCC :: XSCC p -> SourceText -> StringLiteral -> HsPragE p

+ Language.Haskell.Syntax.Expr: HsProc :: XProc p -> LPat p -> LHsCmdTop p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsProjection :: XProjection p -> NonEmpty (Located (HsFieldLabel p)) -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsQuasiQuote :: XQuasiQuote id -> IdP id -> IdP id -> SrcSpan -> FastString -> HsSplice id

+ Language.Haskell.Syntax.Expr: HsRecFld :: XRecFld p -> AmbiguousFieldOcc p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsRnBracketOut :: XRnBracketOut p -> HsBracket (HsBracketRn p) -> [PendingRnSplice' p] -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsSpliceE :: XSpliceE p -> HsSplice p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsSpliced :: XSpliced id -> ThModFinalizers -> HsSplicedThing id -> HsSplice id

+ Language.Haskell.Syntax.Expr: HsSplicedExpr :: HsExpr id -> HsSplicedThing id

+ Language.Haskell.Syntax.Expr: HsSplicedPat :: Pat id -> HsSplicedThing id

+ Language.Haskell.Syntax.Expr: HsSplicedTy :: HsType id -> HsSplicedThing id

+ Language.Haskell.Syntax.Expr: HsStatic :: XStatic p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsTcBracketOut :: XTcBracketOut p -> Maybe QuoteWrapper -> HsBracket (HsBracketRn p) -> [PendingTcSplice' p] -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsTick :: XTick p -> CoreTickish -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsTypedSplice :: XTypedSplice id -> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id

+ Language.Haskell.Syntax.Expr: HsUnboundVar :: XUnboundVar p -> OccName -> HsExpr p

+ Language.Haskell.Syntax.Expr: HsUntypedSplice :: XUntypedSplice id -> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id

+ Language.Haskell.Syntax.Expr: HsVar :: XVar p -> LIdP p -> HsExpr p

+ Language.Haskell.Syntax.Expr: IfAlt :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: KappaExpr :: HsArrowMatchContext

+ Language.Haskell.Syntax.Expr: LambdaExpr :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: LastStmt :: XLastStmt idL idR body -> body -> Maybe Bool -> SyntaxExpr idR -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: LetStmt :: XLetStmt idL idR body -> HsLocalBindsLR idL idR -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: ListComp :: HsStmtContext p

+ Language.Haskell.Syntax.Expr: MDoExpr :: Maybe ModuleName -> HsStmtContext p

+ Language.Haskell.Syntax.Expr: MG :: XMG p body -> XRec p [LMatch p body] -> Origin -> MatchGroup p body

+ Language.Haskell.Syntax.Expr: Match :: XCMatch p body -> HsMatchContext (NoGhcTc p) -> [LPat p] -> GRHSs p body -> Match p body

+ Language.Haskell.Syntax.Expr: MatchGroupTc :: [Scaled Type] -> Type -> MatchGroupTc

+ Language.Haskell.Syntax.Expr: Missing :: XMissing id -> HsTupArg id

+ Language.Haskell.Syntax.Expr: MonadComp :: HsStmtContext p

+ Language.Haskell.Syntax.Expr: NegApp :: XNegApp p -> LHsExpr p -> SyntaxExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: OpApp :: XOpApp p -> LHsExpr p -> LHsExpr p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: ParStmt :: XParStmt idL idR body -> [ParStmtBlock idL idR] -> HsExpr idR -> SyntaxExpr idR -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: ParStmtBlock :: XParStmtBlock idL idR -> [ExprLStmt idL] -> [IdP idR] -> SyntaxExpr idR -> ParStmtBlock idL idR

+ Language.Haskell.Syntax.Expr: ParStmtCtxt :: HsStmtContext p -> HsStmtContext p

+ Language.Haskell.Syntax.Expr: PatBindGuards :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: PatBindRhs :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: PatBr :: XPatBr p -> LPat p -> HsBracket p

+ Language.Haskell.Syntax.Expr: PatGuard :: HsMatchContext p -> HsStmtContext p

+ Language.Haskell.Syntax.Expr: PatSyn :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: Present :: XPresent id -> LHsExpr id -> HsTupArg id

+ Language.Haskell.Syntax.Expr: ProcExpr :: HsArrowMatchContext

+ Language.Haskell.Syntax.Expr: RecStmt :: XRecStmt idL idR body -> XRec idR [LStmtLR idL idR body] -> [IdP idR] -> [IdP idR] -> SyntaxExpr idR -> SyntaxExpr idR -> SyntaxExpr idR -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: RecUpd :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: RecordCon :: XRecordCon p -> XRec p (ConLikeP p) -> HsRecordBinds p -> HsExpr p

+ Language.Haskell.Syntax.Expr: RecordUpd :: XRecordUpd p -> LHsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p] -> HsExpr p

+ Language.Haskell.Syntax.Expr: SectionL :: XSectionL p -> LHsExpr p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: SectionR :: XSectionR p -> LHsExpr p -> LHsExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: StmtCtxt :: HsStmtContext p -> HsMatchContext p

+ Language.Haskell.Syntax.Expr: TExpBr :: XTExpBr p -> LHsExpr p -> HsBracket p

+ Language.Haskell.Syntax.Expr: ThModFinalizers :: [ForeignRef (Q ())] -> ThModFinalizers

+ Language.Haskell.Syntax.Expr: ThPatQuote :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: ThPatSplice :: HsMatchContext p

+ Language.Haskell.Syntax.Expr: ThenForm :: TransForm

+ Language.Haskell.Syntax.Expr: TransStmt :: XTransStmt idL idR body -> TransForm -> [ExprLStmt idL] -> [(IdP idR, IdP idR)] -> LHsExpr idR -> Maybe (LHsExpr idR) -> SyntaxExpr idR -> SyntaxExpr idR -> HsExpr idR -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: TransStmtCtxt :: HsStmtContext p -> HsStmtContext p

+ Language.Haskell.Syntax.Expr: TypBr :: XTypBr p -> LHsType p -> HsBracket p

+ Language.Haskell.Syntax.Expr: UntypedDeclSplice :: UntypedSpliceFlavour

+ Language.Haskell.Syntax.Expr: UntypedExpSplice :: UntypedSpliceFlavour

+ Language.Haskell.Syntax.Expr: UntypedPatSplice :: UntypedSpliceFlavour

+ Language.Haskell.Syntax.Expr: UntypedTypeSplice :: UntypedSpliceFlavour

+ Language.Haskell.Syntax.Expr: VarBr :: XVarBr p -> Bool -> LIdP p -> HsBracket p

+ Language.Haskell.Syntax.Expr: XApplicativeArg :: !XXApplicativeArg idL -> ApplicativeArg idL

+ Language.Haskell.Syntax.Expr: XBracket :: !XXBracket p -> HsBracket p

+ Language.Haskell.Syntax.Expr: XCmd :: !XXCmd id -> HsCmd id

+ Language.Haskell.Syntax.Expr: XCmdTop :: !XXCmdTop p -> HsCmdTop p

+ Language.Haskell.Syntax.Expr: XExpr :: !XXExpr p -> HsExpr p

+ Language.Haskell.Syntax.Expr: XGRHS :: !XXGRHS p body -> GRHS p body

+ Language.Haskell.Syntax.Expr: XGRHSs :: !XXGRHSs p body -> GRHSs p body

+ Language.Haskell.Syntax.Expr: XHsFieldLabel :: !XXHsFieldLabel p -> HsFieldLabel p

+ Language.Haskell.Syntax.Expr: XHsPragE :: !XXPragE p -> HsPragE p

+ Language.Haskell.Syntax.Expr: XMatch :: !XXMatch p body -> Match p body

+ Language.Haskell.Syntax.Expr: XMatchGroup :: !XXMatchGroup p body -> MatchGroup p body

+ Language.Haskell.Syntax.Expr: XParStmtBlock :: !XXParStmtBlock idL idR -> ParStmtBlock idL idR

+ Language.Haskell.Syntax.Expr: XSplice :: !XXSplice id -> HsSplice id

+ Language.Haskell.Syntax.Expr: XStmtLR :: !XXStmtLR idL idR body -> StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: XTupArg :: !XXTupArg id -> HsTupArg id

+ Language.Haskell.Syntax.Expr: [app_arg_pattern] :: ApplicativeArg idL -> LPat idL

+ Language.Haskell.Syntax.Expr: [app_stmts] :: ApplicativeArg idL -> [ExprLStmt idL]

+ Language.Haskell.Syntax.Expr: [arg_expr] :: ApplicativeArg idL -> LHsExpr idL

+ Language.Haskell.Syntax.Expr: [bv_pattern] :: ApplicativeArg idL -> LPat idL

+ Language.Haskell.Syntax.Expr: [final_expr] :: ApplicativeArg idL -> HsExpr idL

+ Language.Haskell.Syntax.Expr: [gf_expr] :: HsExpr p -> LHsExpr p

+ Language.Haskell.Syntax.Expr: [gf_ext] :: HsExpr p -> XGetField p

+ Language.Haskell.Syntax.Expr: [gf_field] :: HsExpr p -> Located (HsFieldLabel p)

+ Language.Haskell.Syntax.Expr: [grhssExt] :: GRHSs p body -> XCGRHSs p body

+ Language.Haskell.Syntax.Expr: [grhssGRHSs] :: GRHSs p body -> [LGRHS p body]

+ Language.Haskell.Syntax.Expr: [grhssLocalBinds] :: GRHSs p body -> HsLocalBinds p

+ Language.Haskell.Syntax.Expr: [hflExt] :: HsFieldLabel p -> XCHsFieldLabel p

+ Language.Haskell.Syntax.Expr: [hflLabel] :: HsFieldLabel p -> Located FieldLabelString

+ Language.Haskell.Syntax.Expr: [is_body_stmt] :: ApplicativeArg idL -> Bool

+ Language.Haskell.Syntax.Expr: [m_ctxt] :: Match p body -> HsMatchContext (NoGhcTc p)

+ Language.Haskell.Syntax.Expr: [m_ext] :: Match p body -> XCMatch p body

+ Language.Haskell.Syntax.Expr: [m_grhss] :: Match p body -> GRHSs p body

+ Language.Haskell.Syntax.Expr: [m_pats] :: Match p body -> [LPat p]

+ Language.Haskell.Syntax.Expr: [mc_fixity] :: HsMatchContext p -> LexicalFixity

+ Language.Haskell.Syntax.Expr: [mc_fun] :: HsMatchContext p -> LIdP p

+ Language.Haskell.Syntax.Expr: [mc_strictness] :: HsMatchContext p -> SrcStrictness

+ Language.Haskell.Syntax.Expr: [mg_alts] :: MatchGroup p body -> XRec p [LMatch p body]

+ Language.Haskell.Syntax.Expr: [mg_arg_tys] :: MatchGroupTc -> [Scaled Type]

+ Language.Haskell.Syntax.Expr: [mg_ext] :: MatchGroup p body -> XMG p body

+ Language.Haskell.Syntax.Expr: [mg_origin] :: MatchGroup p body -> Origin

+ Language.Haskell.Syntax.Expr: [mg_res_ty] :: MatchGroupTc -> Type

+ Language.Haskell.Syntax.Expr: [proj_ext] :: HsExpr p -> XProjection p

+ Language.Haskell.Syntax.Expr: [proj_flds] :: HsExpr p -> NonEmpty (Located (HsFieldLabel p))

+ Language.Haskell.Syntax.Expr: [rcon_con] :: HsExpr p -> XRec p (ConLikeP p)

+ Language.Haskell.Syntax.Expr: [rcon_ext] :: HsExpr p -> XRecordCon p

+ Language.Haskell.Syntax.Expr: [rcon_flds] :: HsExpr p -> HsRecordBinds p

+ Language.Haskell.Syntax.Expr: [recS_bind_fn] :: StmtLR idL idR body -> SyntaxExpr idR

+ Language.Haskell.Syntax.Expr: [recS_ext] :: StmtLR idL idR body -> XRecStmt idL idR body

+ Language.Haskell.Syntax.Expr: [recS_later_ids] :: StmtLR idL idR body -> [IdP idR]

+ Language.Haskell.Syntax.Expr: [recS_mfix_fn] :: StmtLR idL idR body -> SyntaxExpr idR

+ Language.Haskell.Syntax.Expr: [recS_rec_ids] :: StmtLR idL idR body -> [IdP idR]

+ Language.Haskell.Syntax.Expr: [recS_ret_fn] :: StmtLR idL idR body -> SyntaxExpr idR

+ Language.Haskell.Syntax.Expr: [recS_stmts] :: StmtLR idL idR body -> XRec idR [LStmtLR idL idR body]

+ Language.Haskell.Syntax.Expr: [rupd_expr] :: HsExpr p -> LHsExpr p

+ Language.Haskell.Syntax.Expr: [rupd_ext] :: HsExpr p -> XRecordUpd p

+ Language.Haskell.Syntax.Expr: [rupd_flds] :: HsExpr p -> Either [LHsRecUpdField p] [LHsRecUpdProj p]

+ Language.Haskell.Syntax.Expr: [stmt_context] :: ApplicativeArg idL -> HsStmtContext (ApplicativeArgStmCtxPass idL)

+ Language.Haskell.Syntax.Expr: [trS_bind] :: StmtLR idL idR body -> SyntaxExpr idR

+ Language.Haskell.Syntax.Expr: [trS_bndrs] :: StmtLR idL idR body -> [(IdP idR, IdP idR)]

+ Language.Haskell.Syntax.Expr: [trS_by] :: StmtLR idL idR body -> Maybe (LHsExpr idR)

+ Language.Haskell.Syntax.Expr: [trS_ext] :: StmtLR idL idR body -> XTransStmt idL idR body

+ Language.Haskell.Syntax.Expr: [trS_fmap] :: StmtLR idL idR body -> HsExpr idR

+ Language.Haskell.Syntax.Expr: [trS_form] :: StmtLR idL idR body -> TransForm

+ Language.Haskell.Syntax.Expr: [trS_ret] :: StmtLR idL idR body -> SyntaxExpr idR

+ Language.Haskell.Syntax.Expr: [trS_stmts] :: StmtLR idL idR body -> [ExprLStmt idL]

+ Language.Haskell.Syntax.Expr: [trS_using] :: StmtLR idL idR body -> LHsExpr idR

+ Language.Haskell.Syntax.Expr: [xarg_app_arg_many] :: ApplicativeArg idL -> XApplicativeArgMany idL

+ Language.Haskell.Syntax.Expr: [xarg_app_arg_one] :: ApplicativeArg idL -> XApplicativeArgOne idL

+ Language.Haskell.Syntax.Expr: data ApplicativeArg idL

+ Language.Haskell.Syntax.Expr: data ArithSeqInfo id

+ Language.Haskell.Syntax.Expr: data GRHS p body

+ Language.Haskell.Syntax.Expr: data GRHSs p body

+ Language.Haskell.Syntax.Expr: data HsArrAppType

+ Language.Haskell.Syntax.Expr: data HsArrowMatchContext

+ Language.Haskell.Syntax.Expr: data HsBracket p

+ Language.Haskell.Syntax.Expr: data HsCmd id

+ Language.Haskell.Syntax.Expr: data HsCmdTop p

+ Language.Haskell.Syntax.Expr: data HsExpr p

+ Language.Haskell.Syntax.Expr: data HsFieldLabel p

+ Language.Haskell.Syntax.Expr: data HsMatchContext p

+ Language.Haskell.Syntax.Expr: data HsPragE p

+ Language.Haskell.Syntax.Expr: data HsSplice id

+ Language.Haskell.Syntax.Expr: data HsSplicedThing id

+ Language.Haskell.Syntax.Expr: data HsStmtContext p

+ Language.Haskell.Syntax.Expr: data HsTupArg id

+ Language.Haskell.Syntax.Expr: data Match p body

+ Language.Haskell.Syntax.Expr: data MatchGroup p body

+ Language.Haskell.Syntax.Expr: data MatchGroupTc

+ Language.Haskell.Syntax.Expr: data ParStmtBlock idL idR

+ Language.Haskell.Syntax.Expr: data SpliceDecoration

+ Language.Haskell.Syntax.Expr: data StmtLR idL idR body

+ Language.Haskell.Syntax.Expr: data TransForm

+ Language.Haskell.Syntax.Expr: data UntypedSpliceFlavour

+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.HsArrAppType

+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.MatchGroupTc

+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.SpliceDecoration

+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.ThModFinalizers

+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.TransForm

+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.UntypedSpliceFlavour

+ Language.Haskell.Syntax.Expr: instance GHC.Classes.Eq Language.Haskell.Syntax.Expr.SpliceDecoration

+ Language.Haskell.Syntax.Expr: instance GHC.Show.Show Language.Haskell.Syntax.Expr.SpliceDecoration

+ Language.Haskell.Syntax.Expr: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.FieldLabelStrings p)

+ Language.Haskell.Syntax.Expr: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsFieldLabel p)

+ Language.Haskell.Syntax.Expr: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Expr.SpliceDecoration

+ Language.Haskell.Syntax.Expr: instance GHC.Utils.Outputable.OutputableBndr (Language.Haskell.Syntax.Expr.FieldLabelStrings p)

+ Language.Haskell.Syntax.Expr: isComprehensionContext :: HsStmtContext id -> Bool

+ Language.Haskell.Syntax.Expr: isInfixMatch :: Match id body -> Bool

+ Language.Haskell.Syntax.Expr: isMonadCompContext :: HsStmtContext id -> Bool

+ Language.Haskell.Syntax.Expr: isMonadStmtContext :: HsStmtContext id -> Bool

+ Language.Haskell.Syntax.Expr: isPatSynCtxt :: HsMatchContext p -> Bool

+ Language.Haskell.Syntax.Expr: isTypedBracket :: HsBracket id -> Bool

+ Language.Haskell.Syntax.Expr: isTypedSplice :: HsSplice id -> Bool

+ Language.Haskell.Syntax.Expr: matchSeparator :: HsMatchContext p -> SDoc

+ Language.Haskell.Syntax.Expr: newtype FieldLabelStrings p

+ Language.Haskell.Syntax.Expr: newtype ThModFinalizers

+ Language.Haskell.Syntax.Expr: pprAStmtContext :: (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc

+ Language.Haskell.Syntax.Expr: pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc

+ Language.Haskell.Syntax.Expr: pprExternalSrcLoc :: (StringLiteral, (Int, Int), (Int, Int)) -> SDoc

+ Language.Haskell.Syntax.Expr: pprFieldLabelStrings :: FieldLabelStrings p -> SDoc

+ Language.Haskell.Syntax.Expr: pprMatchContext :: (Outputable (IdP p), UnXRec p) => HsMatchContext p -> SDoc

+ Language.Haskell.Syntax.Expr: pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p) => HsMatchContext p -> SDoc

+ Language.Haskell.Syntax.Expr: pprStmtContext :: (Outputable (IdP p), UnXRec p) => HsStmtContext p -> SDoc

+ Language.Haskell.Syntax.Expr: prependQualified :: Maybe ModuleName -> SDoc -> SDoc

+ Language.Haskell.Syntax.Expr: qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName

+ Language.Haskell.Syntax.Expr: type CmdLStmt id = LStmt id (LHsCmd id)

+ Language.Haskell.Syntax.Expr: type CmdStmt id = Stmt id (LHsCmd id)

+ Language.Haskell.Syntax.Expr: type CmdSyntaxTable p = [(Name, HsExpr p)]

+ Language.Haskell.Syntax.Expr: type ExprLStmt id = LStmt id (LHsExpr id)

+ Language.Haskell.Syntax.Expr: type ExprStmt id = Stmt id (LHsExpr id)

+ Language.Haskell.Syntax.Expr: type FailOperator id = Maybe (SyntaxExpr id)

+ Language.Haskell.Syntax.Expr: type GhciLStmt id = LStmt id (LHsExpr id)

+ Language.Haskell.Syntax.Expr: type GhciStmt id = Stmt id (LHsExpr id)

+ Language.Haskell.Syntax.Expr: type GuardLStmt id = LStmt id (LHsExpr id)

+ Language.Haskell.Syntax.Expr: type GuardStmt id = Stmt id (LHsExpr id)

+ Language.Haskell.Syntax.Expr: type HsRecordBinds p = HsRecFields p (LHsExpr p)

+ Language.Haskell.Syntax.Expr: type LGRHS id body = XRec id (GRHS id body)

+ Language.Haskell.Syntax.Expr: type LHsCmd id = XRec id (HsCmd id)

+ Language.Haskell.Syntax.Expr: type LHsCmdTop p = XRec p (HsCmdTop p)

+ Language.Haskell.Syntax.Expr: type LHsExpr p = XRec p (HsExpr p) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

+ Language.Haskell.Syntax.Expr: type LHsRecProj p arg = XRec p (RecProj p arg)

+ Language.Haskell.Syntax.Expr: type LHsRecUpdProj p = XRec p (RecUpdProj p)

+ Language.Haskell.Syntax.Expr: type LHsTupArg id = XRec id (HsTupArg id)

+ Language.Haskell.Syntax.Expr: type LMatch id body = XRec id (Match id body)

+ Language.Haskell.Syntax.Expr: type LStmt id body = XRec id (StmtLR id id body)

+ Language.Haskell.Syntax.Expr: type LStmtLR idL idR body = XRec idL (StmtLR idL idR body)

+ Language.Haskell.Syntax.Expr: type RecProj p arg = HsRecField' (FieldLabelStrings p) arg

+ Language.Haskell.Syntax.Expr: type RecUpdProj p = RecProj p (LHsExpr p)

+ Language.Haskell.Syntax.Expr: type SplicePointName = Name

+ Language.Haskell.Syntax.Expr: type Stmt id body = StmtLR id id body

+ Language.Haskell.Syntax.Expr: type family ApplicativeArgStmCtxPass idL

+ Language.Haskell.Syntax.Extension: NoExtField :: NoExtField

+ Language.Haskell.Syntax.Extension: class MapXRec p

+ Language.Haskell.Syntax.Extension: class UnXRec p

+ Language.Haskell.Syntax.Extension: class WrapXRec p a

+ Language.Haskell.Syntax.Extension: data NoExtCon

+ Language.Haskell.Syntax.Extension: data NoExtField

+ Language.Haskell.Syntax.Extension: instance Data.Data.Data Language.Haskell.Syntax.Extension.NoExtCon

+ Language.Haskell.Syntax.Extension: instance Data.Data.Data Language.Haskell.Syntax.Extension.NoExtField

+ Language.Haskell.Syntax.Extension: instance GHC.Classes.Eq Language.Haskell.Syntax.Extension.NoExtCon

+ Language.Haskell.Syntax.Extension: instance GHC.Classes.Eq Language.Haskell.Syntax.Extension.NoExtField

+ Language.Haskell.Syntax.Extension: instance GHC.Classes.Ord Language.Haskell.Syntax.Extension.NoExtCon

+ Language.Haskell.Syntax.Extension: instance GHC.Classes.Ord Language.Haskell.Syntax.Extension.NoExtField

+ Language.Haskell.Syntax.Extension: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Extension.NoExtCon

+ Language.Haskell.Syntax.Extension: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Extension.NoExtField

+ Language.Haskell.Syntax.Extension: mapXRec :: (MapXRec p, Anno a ~ Anno b) => (a -> b) -> XRec p a -> XRec p b

+ Language.Haskell.Syntax.Extension: noExtCon :: NoExtCon -> a

+ Language.Haskell.Syntax.Extension: noExtField :: NoExtField

+ Language.Haskell.Syntax.Extension: type LIdP p = XRec p (IdP p)

+ Language.Haskell.Syntax.Extension: type family NoGhcTc (p :: Type)

+ Language.Haskell.Syntax.Extension: unXRec :: UnXRec p => XRec p a -> a

+ Language.Haskell.Syntax.Extension: wrapXRec :: WrapXRec p a => a -> XRec p a

+ Language.Haskell.Syntax.Lit: HsChar :: XHsChar x -> Char -> HsLit x

+ Language.Haskell.Syntax.Lit: HsCharPrim :: XHsCharPrim x -> Char -> HsLit x

+ Language.Haskell.Syntax.Lit: HsDoublePrim :: XHsDoublePrim x -> FractionalLit -> HsLit x

+ Language.Haskell.Syntax.Lit: HsFloatPrim :: XHsFloatPrim x -> FractionalLit -> HsLit x

+ Language.Haskell.Syntax.Lit: HsFractional :: !FractionalLit -> OverLitVal

+ Language.Haskell.Syntax.Lit: HsInt :: XHsInt x -> IntegralLit -> HsLit x

+ Language.Haskell.Syntax.Lit: HsInt64Prim :: XHsInt64Prim x -> Integer -> HsLit x

+ Language.Haskell.Syntax.Lit: HsIntPrim :: XHsIntPrim x -> Integer -> HsLit x

+ Language.Haskell.Syntax.Lit: HsInteger :: XHsInteger x -> Integer -> Type -> HsLit x

+ Language.Haskell.Syntax.Lit: HsIntegral :: !IntegralLit -> OverLitVal

+ Language.Haskell.Syntax.Lit: HsIsString :: !SourceText -> !FastString -> OverLitVal

+ Language.Haskell.Syntax.Lit: HsRat :: XHsRat x -> FractionalLit -> Type -> HsLit x

+ Language.Haskell.Syntax.Lit: HsString :: XHsString x -> FastString -> HsLit x

+ Language.Haskell.Syntax.Lit: HsStringPrim :: XHsStringPrim x -> !ByteString -> HsLit x

+ Language.Haskell.Syntax.Lit: HsWord64Prim :: XHsWord64Prim x -> Integer -> HsLit x

+ Language.Haskell.Syntax.Lit: HsWordPrim :: XHsWordPrim x -> Integer -> HsLit x

+ Language.Haskell.Syntax.Lit: OverLit :: XOverLit p -> OverLitVal -> HsExpr p -> HsOverLit p

+ Language.Haskell.Syntax.Lit: XLit :: !XXLit x -> HsLit x

+ Language.Haskell.Syntax.Lit: XOverLit :: !XXOverLit p -> HsOverLit p

+ Language.Haskell.Syntax.Lit: [ol_ext] :: HsOverLit p -> XOverLit p

+ Language.Haskell.Syntax.Lit: [ol_val] :: HsOverLit p -> OverLitVal

+ Language.Haskell.Syntax.Lit: [ol_witness] :: HsOverLit p -> HsExpr p

+ Language.Haskell.Syntax.Lit: data HsLit x

+ Language.Haskell.Syntax.Lit: data HsOverLit p

+ Language.Haskell.Syntax.Lit: data OverLitVal

+ Language.Haskell.Syntax.Lit: hsLitNeedsParens :: PprPrec -> HsLit x -> Bool

+ Language.Haskell.Syntax.Lit: hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool

+ Language.Haskell.Syntax.Lit: instance Data.Data.Data Language.Haskell.Syntax.Lit.OverLitVal

+ Language.Haskell.Syntax.Lit: instance GHC.Classes.Eq (Language.Haskell.Syntax.Extension.XXOverLit p) => GHC.Classes.Eq (Language.Haskell.Syntax.Lit.HsOverLit p)

+ Language.Haskell.Syntax.Lit: instance GHC.Classes.Eq (Language.Haskell.Syntax.Lit.HsLit x)

+ Language.Haskell.Syntax.Lit: instance GHC.Classes.Eq Language.Haskell.Syntax.Lit.OverLitVal

+ Language.Haskell.Syntax.Lit: instance GHC.Classes.Ord (Language.Haskell.Syntax.Extension.XXOverLit p) => GHC.Classes.Ord (Language.Haskell.Syntax.Lit.HsOverLit p)

+ Language.Haskell.Syntax.Lit: instance GHC.Classes.Ord Language.Haskell.Syntax.Lit.OverLitVal

+ Language.Haskell.Syntax.Lit: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Lit.OverLitVal

+ Language.Haskell.Syntax.Lit: negateOverLitVal :: OverLitVal -> OverLitVal

+ Language.Haskell.Syntax.Pat: AsPat :: XAsPat p -> LIdP p -> LPat p -> Pat p

+ Language.Haskell.Syntax.Pat: BangPat :: XBangPat p -> LPat p -> Pat p

+ Language.Haskell.Syntax.Pat: ConPat :: XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p

+ Language.Haskell.Syntax.Pat: HsRecField :: XHsRecField id -> Located id -> arg -> Bool -> HsRecField' id arg

+ Language.Haskell.Syntax.Pat: HsRecFields :: [LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg

+ Language.Haskell.Syntax.Pat: LazyPat :: XLazyPat p -> LPat p -> Pat p

+ Language.Haskell.Syntax.Pat: ListPat :: XListPat p -> [LPat p] -> Pat p

+ Language.Haskell.Syntax.Pat: LitPat :: XLitPat p -> HsLit p -> Pat p

+ Language.Haskell.Syntax.Pat: NPat :: XNPat p -> XRec p (HsOverLit p) -> Maybe (SyntaxExpr p) -> SyntaxExpr p -> Pat p

+ Language.Haskell.Syntax.Pat: NPlusKPat :: XNPlusKPat p -> LIdP p -> XRec p (HsOverLit p) -> HsOverLit p -> SyntaxExpr p -> SyntaxExpr p -> Pat p

+ Language.Haskell.Syntax.Pat: ParPat :: XParPat p -> LPat p -> Pat p

+ Language.Haskell.Syntax.Pat: SigPat :: XSigPat p -> LPat p -> HsPatSigType (NoGhcTc p) -> Pat p

+ Language.Haskell.Syntax.Pat: SplicePat :: XSplicePat p -> HsSplice p -> Pat p

+ Language.Haskell.Syntax.Pat: SumPat :: XSumPat p -> LPat p -> ConTag -> Arity -> Pat p

+ Language.Haskell.Syntax.Pat: TuplePat :: XTuplePat p -> [LPat p] -> Boxity -> Pat p

+ Language.Haskell.Syntax.Pat: VarPat :: XVarPat p -> LIdP p -> Pat p

+ Language.Haskell.Syntax.Pat: ViewPat :: XViewPat p -> LHsExpr p -> LPat p -> Pat p

+ Language.Haskell.Syntax.Pat: WildPat :: XWildPat p -> Pat p

+ Language.Haskell.Syntax.Pat: XPat :: !XXPat p -> Pat p

+ Language.Haskell.Syntax.Pat: [hsRecFieldAnn] :: HsRecField' id arg -> XHsRecField id

+ Language.Haskell.Syntax.Pat: [hsRecFieldArg] :: HsRecField' id arg -> arg

+ Language.Haskell.Syntax.Pat: [hsRecFieldLbl] :: HsRecField' id arg -> Located id

+ Language.Haskell.Syntax.Pat: [hsRecPun] :: HsRecField' id arg -> Bool

+ Language.Haskell.Syntax.Pat: [pat_args] :: Pat p -> HsConPatDetails p

+ Language.Haskell.Syntax.Pat: [pat_con] :: Pat p -> XRec p (ConLikeP p)

+ Language.Haskell.Syntax.Pat: [pat_con_ext] :: Pat p -> XConPat p

+ Language.Haskell.Syntax.Pat: [rec_dotdot] :: HsRecFields p arg -> Maybe (Located Int)

+ Language.Haskell.Syntax.Pat: [rec_flds] :: HsRecFields p arg -> [LHsRecField p arg]

+ Language.Haskell.Syntax.Pat: data HsRecField' id arg

+ Language.Haskell.Syntax.Pat: data HsRecFields p arg

+ Language.Haskell.Syntax.Pat: data Pat p

+ Language.Haskell.Syntax.Pat: hsConPatArgs :: forall p. UnXRec p => HsConPatDetails p -> [LPat p]

+ Language.Haskell.Syntax.Pat: hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)

+ Language.Haskell.Syntax.Pat: hsRecFields :: forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]

+ Language.Haskell.Syntax.Pat: hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]

+ Language.Haskell.Syntax.Pat: instance (GHC.Utils.Outputable.Outputable arg, GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Extension.XRec p (Language.Haskell.Syntax.Pat.HsRecField p arg))) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.HsRecFields p arg)

+ Language.Haskell.Syntax.Pat: instance (GHC.Utils.Outputable.Outputable p, GHC.Utils.Outputable.OutputableBndr p, GHC.Utils.Outputable.Outputable arg) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.HsRecField' p arg)

+ Language.Haskell.Syntax.Pat: instance Data.Foldable.Foldable (Language.Haskell.Syntax.Pat.HsRecField' id)

+ Language.Haskell.Syntax.Pat: instance Data.Traversable.Traversable (Language.Haskell.Syntax.Pat.HsRecField' id)

+ Language.Haskell.Syntax.Pat: instance GHC.Base.Functor (Language.Haskell.Syntax.Pat.HsRecField' id)

+ Language.Haskell.Syntax.Pat: type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))

+ Language.Haskell.Syntax.Pat: type HsRecField p arg = HsRecField' (FieldOcc p) arg

+ Language.Haskell.Syntax.Pat: type HsRecUpdField p = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)

+ Language.Haskell.Syntax.Pat: type LHsRecField p arg = XRec p (HsRecField p arg)

+ Language.Haskell.Syntax.Pat: type LHsRecField' p id arg = XRec p (HsRecField' id arg)

+ Language.Haskell.Syntax.Pat: type LHsRecUpdField p = XRec p (HsRecUpdField p)

+ Language.Haskell.Syntax.Pat: type LPat p = XRec p (Pat p)

+ Language.Haskell.Syntax.Pat: type family ConLikeP x

+ Language.Haskell.Syntax.Type: Ambiguous :: XAmbiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass

+ Language.Haskell.Syntax.Type: ConDeclField :: XConDeclField pass -> [LFieldOcc pass] -> LBangType pass -> Maybe LHsDocString -> ConDeclField pass

+ Language.Haskell.Syntax.Type: FieldOcc :: XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass

+ Language.Haskell.Syntax.Type: HsAppKindTy :: XAppKindTy pass -> LHsType pass -> LHsKind pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsAppTy :: XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsArgPar :: SrcSpan -> HsArg tm ty

+ Language.Haskell.Syntax.Type: HsBangTy :: XBangTy pass -> HsSrcBang -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsBoxedOrConstraintTuple :: HsTupleSort

+ Language.Haskell.Syntax.Type: HsCharTy :: SourceText -> Char -> HsTyLit

+ Language.Haskell.Syntax.Type: HsDocTy :: XDocTy pass -> LHsType pass -> LHsDocString -> HsType pass

+ Language.Haskell.Syntax.Type: HsExplicitListTy :: XExplicitListTy pass -> PromotionFlag -> [LHsType pass] -> HsType pass

+ Language.Haskell.Syntax.Type: HsExplicitMult :: IsUnicodeSyntax -> Maybe AddEpAnn -> LHsType pass -> HsArrow pass

+ Language.Haskell.Syntax.Type: HsExplicitTupleTy :: XExplicitTupleTy pass -> [LHsType pass] -> HsType pass

+ Language.Haskell.Syntax.Type: HsForAllInvis :: XHsForAllInvis pass -> [LHsTyVarBndr Specificity pass] -> HsForAllTelescope pass

+ Language.Haskell.Syntax.Type: HsForAllTy :: XForAllTy pass -> HsForAllTelescope pass -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsForAllVis :: XHsForAllVis pass -> [LHsTyVarBndr () pass] -> HsForAllTelescope pass

+ Language.Haskell.Syntax.Type: HsFunTy :: XFunTy pass -> HsArrow pass -> LHsType pass -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsIPName :: FastString -> HsIPName

+ Language.Haskell.Syntax.Type: HsIParamTy :: XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsKindSig :: XKindSig pass -> LHsType pass -> LHsKind pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsLazy :: HsImplBang

+ Language.Haskell.Syntax.Type: HsLinearArrow :: IsUnicodeSyntax -> Maybe AddEpAnn -> HsArrow pass

+ Language.Haskell.Syntax.Type: HsListTy :: XListTy pass -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsNumTy :: SourceText -> Integer -> HsTyLit

+ Language.Haskell.Syntax.Type: HsOpTy :: XOpTy pass -> LHsType pass -> LIdP pass -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsOuterExplicit :: XHsOuterExplicit pass flag -> [LHsTyVarBndr flag (NoGhcTc pass)] -> HsOuterTyVarBndrs flag pass

+ Language.Haskell.Syntax.Type: HsOuterImplicit :: XHsOuterImplicit pass -> HsOuterTyVarBndrs flag pass

+ Language.Haskell.Syntax.Type: HsPS :: XHsPS pass -> LHsType pass -> HsPatSigType pass

+ Language.Haskell.Syntax.Type: HsPSRn :: [Name] -> [Name] -> HsPSRn

+ Language.Haskell.Syntax.Type: HsParTy :: XParTy pass -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsQTvs :: XHsQTvs pass -> [LHsTyVarBndr () pass] -> LHsQTyVars pass

+ Language.Haskell.Syntax.Type: HsQualTy :: XQualTy pass -> Maybe (LHsContext pass) -> LHsType pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsRecTy :: XRecTy pass -> [LConDeclField pass] -> HsType pass

+ Language.Haskell.Syntax.Type: HsScaled :: HsArrow pass -> a -> HsScaled pass a

+ Language.Haskell.Syntax.Type: HsSig :: XHsSig pass -> HsOuterSigTyVarBndrs pass -> LHsType pass -> HsSigType pass

+ Language.Haskell.Syntax.Type: HsSpliceTy :: XSpliceTy pass -> HsSplice pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsSrcBang :: SourceText -> SrcUnpackedness -> SrcStrictness -> HsSrcBang

+ Language.Haskell.Syntax.Type: HsStarTy :: XStarTy pass -> Bool -> HsType pass

+ Language.Haskell.Syntax.Type: HsStrTy :: SourceText -> FastString -> HsTyLit

+ Language.Haskell.Syntax.Type: HsStrict :: HsImplBang

+ Language.Haskell.Syntax.Type: HsSumTy :: XSumTy pass -> [LHsType pass] -> HsType pass

+ Language.Haskell.Syntax.Type: HsTupleTy :: XTupleTy pass -> HsTupleSort -> [LHsType pass] -> HsType pass

+ Language.Haskell.Syntax.Type: HsTyLit :: XTyLit pass -> HsTyLit -> HsType pass

+ Language.Haskell.Syntax.Type: HsTyVar :: XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass

+ Language.Haskell.Syntax.Type: HsTypeArg :: SrcSpan -> ty -> HsArg tm ty

+ Language.Haskell.Syntax.Type: HsUnboxedTuple :: HsTupleSort

+ Language.Haskell.Syntax.Type: HsUnpack :: Maybe Coercion -> HsImplBang

+ Language.Haskell.Syntax.Type: HsUnrestrictedArrow :: IsUnicodeSyntax -> HsArrow pass

+ Language.Haskell.Syntax.Type: HsValArg :: tm -> HsArg tm ty

+ Language.Haskell.Syntax.Type: HsWC :: XHsWC pass thing -> thing -> HsWildCardBndrs pass thing

+ Language.Haskell.Syntax.Type: HsWildCardTy :: XWildCardTy pass -> HsType pass

+ Language.Haskell.Syntax.Type: InfixCon :: arg -> arg -> HsConDetails tyarg arg rec

+ Language.Haskell.Syntax.Type: KindedTyVar :: XKindedTyVar pass -> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass

+ Language.Haskell.Syntax.Type: NoSrcStrict :: SrcStrictness

+ Language.Haskell.Syntax.Type: NoSrcUnpack :: SrcUnpackedness

+ Language.Haskell.Syntax.Type: PrefixCon :: [tyarg] -> [arg] -> HsConDetails tyarg arg rec

+ Language.Haskell.Syntax.Type: RecCon :: rec -> HsConDetails tyarg arg rec

+ Language.Haskell.Syntax.Type: SrcLazy :: SrcStrictness

+ Language.Haskell.Syntax.Type: SrcNoUnpack :: SrcUnpackedness

+ Language.Haskell.Syntax.Type: SrcStrict :: SrcStrictness

+ Language.Haskell.Syntax.Type: SrcUnpack :: SrcUnpackedness

+ Language.Haskell.Syntax.Type: Unambiguous :: XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass

+ Language.Haskell.Syntax.Type: UserTyVar :: XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass

+ Language.Haskell.Syntax.Type: XAmbiguousFieldOcc :: !XXAmbiguousFieldOcc pass -> AmbiguousFieldOcc pass

+ Language.Haskell.Syntax.Type: XConDeclField :: !XXConDeclField pass -> ConDeclField pass

+ Language.Haskell.Syntax.Type: XFieldOcc :: !XXFieldOcc pass -> FieldOcc pass

+ Language.Haskell.Syntax.Type: XHsForAllTelescope :: !XXHsForAllTelescope pass -> HsForAllTelescope pass

+ Language.Haskell.Syntax.Type: XHsOuterTyVarBndrs :: !XXHsOuterTyVarBndrs pass -> HsOuterTyVarBndrs flag pass

+ Language.Haskell.Syntax.Type: XHsPatSigType :: !XXHsPatSigType pass -> HsPatSigType pass

+ Language.Haskell.Syntax.Type: XHsSigType :: !XXHsSigType pass -> HsSigType pass

+ Language.Haskell.Syntax.Type: XHsType :: !XXType pass -> HsType pass

+ Language.Haskell.Syntax.Type: XHsWildCardBndrs :: !XXHsWildCardBndrs pass thing -> HsWildCardBndrs pass thing

+ Language.Haskell.Syntax.Type: XLHsQTyVars :: !XXLHsQTyVars pass -> LHsQTyVars pass

+ Language.Haskell.Syntax.Type: XTyVarBndr :: !XXTyVarBndr pass -> HsTyVarBndr flag pass

+ Language.Haskell.Syntax.Type: [cd_fld_doc] :: ConDeclField pass -> Maybe LHsDocString

+ Language.Haskell.Syntax.Type: [cd_fld_ext] :: ConDeclField pass -> XConDeclField pass

+ Language.Haskell.Syntax.Type: [cd_fld_names] :: ConDeclField pass -> [LFieldOcc pass]

+ Language.Haskell.Syntax.Type: [cd_fld_type] :: ConDeclField pass -> LBangType pass

+ Language.Haskell.Syntax.Type: [extFieldOcc] :: FieldOcc pass -> XCFieldOcc pass

+ Language.Haskell.Syntax.Type: [hsf_invis_bndrs] :: HsForAllTelescope pass -> [LHsTyVarBndr Specificity pass]

+ Language.Haskell.Syntax.Type: [hsf_vis_bndrs] :: HsForAllTelescope pass -> [LHsTyVarBndr () pass]

+ Language.Haskell.Syntax.Type: [hsf_xinvis] :: HsForAllTelescope pass -> XHsForAllInvis pass

+ Language.Haskell.Syntax.Type: [hsf_xvis] :: HsForAllTelescope pass -> XHsForAllVis pass

+ Language.Haskell.Syntax.Type: [hso_bndrs] :: HsOuterTyVarBndrs flag pass -> [LHsTyVarBndr flag (NoGhcTc pass)]

+ Language.Haskell.Syntax.Type: [hso_xexplicit] :: HsOuterTyVarBndrs flag pass -> XHsOuterExplicit pass flag

+ Language.Haskell.Syntax.Type: [hso_ximplicit] :: HsOuterTyVarBndrs flag pass -> XHsOuterImplicit pass

+ Language.Haskell.Syntax.Type: [hsps_body] :: HsPatSigType pass -> LHsType pass

+ Language.Haskell.Syntax.Type: [hsps_ext] :: HsPatSigType pass -> XHsPS pass

+ Language.Haskell.Syntax.Type: [hsps_imp_tvs] :: HsPSRn -> [Name]

+ Language.Haskell.Syntax.Type: [hsps_nwcs] :: HsPSRn -> [Name]

+ Language.Haskell.Syntax.Type: [hsq_explicit] :: LHsQTyVars pass -> [LHsTyVarBndr () pass]

+ Language.Haskell.Syntax.Type: [hsq_ext] :: LHsQTyVars pass -> XHsQTvs pass

+ Language.Haskell.Syntax.Type: [hst_body] :: HsType pass -> LHsType pass

+ Language.Haskell.Syntax.Type: [hst_ctxt] :: HsType pass -> Maybe (LHsContext pass)

+ Language.Haskell.Syntax.Type: [hst_tele] :: HsType pass -> HsForAllTelescope pass

+ Language.Haskell.Syntax.Type: [hst_xforall] :: HsType pass -> XForAllTy pass

+ Language.Haskell.Syntax.Type: [hst_xqual] :: HsType pass -> XQualTy pass

+ Language.Haskell.Syntax.Type: [hswc_body] :: HsWildCardBndrs pass thing -> thing

+ Language.Haskell.Syntax.Type: [hswc_ext] :: HsWildCardBndrs pass thing -> XHsWC pass thing

+ Language.Haskell.Syntax.Type: [rdrNameFieldOcc] :: FieldOcc pass -> LocatedN RdrName

+ Language.Haskell.Syntax.Type: [sig_bndrs] :: HsSigType pass -> HsOuterSigTyVarBndrs pass

+ Language.Haskell.Syntax.Type: [sig_body] :: HsSigType pass -> LHsType pass

+ Language.Haskell.Syntax.Type: [sig_ext] :: HsSigType pass -> XHsSig pass

+ Language.Haskell.Syntax.Type: data AmbiguousFieldOcc pass

+ Language.Haskell.Syntax.Type: data ConDeclField pass

+ Language.Haskell.Syntax.Type: data FieldOcc pass

+ Language.Haskell.Syntax.Type: data HsArg tm ty

+ Language.Haskell.Syntax.Type: data HsArrow pass

+ Language.Haskell.Syntax.Type: data HsConDetails tyarg arg rec

+ Language.Haskell.Syntax.Type: data HsForAllTelescope pass

+ Language.Haskell.Syntax.Type: data HsImplBang

+ Language.Haskell.Syntax.Type: data HsOuterTyVarBndrs flag pass

+ Language.Haskell.Syntax.Type: data HsPSRn

+ Language.Haskell.Syntax.Type: data HsPatSigType pass

+ Language.Haskell.Syntax.Type: data HsScaled pass a

+ Language.Haskell.Syntax.Type: data HsSigType pass

+ Language.Haskell.Syntax.Type: data HsSrcBang

+ Language.Haskell.Syntax.Type: data HsTupleSort

+ Language.Haskell.Syntax.Type: data HsTyLit

+ Language.Haskell.Syntax.Type: data HsTyVarBndr flag pass

+ Language.Haskell.Syntax.Type: data HsType pass

+ Language.Haskell.Syntax.Type: data HsWildCardBndrs pass thing

+ Language.Haskell.Syntax.Type: data LHsQTyVars pass

+ Language.Haskell.Syntax.Type: data SrcStrictness

+ Language.Haskell.Syntax.Type: data SrcUnpackedness

+ Language.Haskell.Syntax.Type: hsIPNameFS :: HsIPName -> FastString

+ Language.Haskell.Syntax.Type: hsLinear :: a -> HsScaled pass a

+ Language.Haskell.Syntax.Type: hsMult :: HsScaled pass a -> HsArrow pass

+ Language.Haskell.Syntax.Type: hsPatSigType :: HsPatSigType pass -> LHsType pass

+ Language.Haskell.Syntax.Type: hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass]

+ Language.Haskell.Syntax.Type: hsScaledThing :: HsScaled pass a -> a

+ Language.Haskell.Syntax.Type: hsUnrestricted :: a -> HsScaled pass a

+ Language.Haskell.Syntax.Type: instance (Data.Data.Data tyarg, Data.Data.Data arg, Data.Data.Data rec) => Data.Data.Data (Language.Haskell.Syntax.Type.HsConDetails tyarg arg rec)

+ Language.Haskell.Syntax.Type: instance (GHC.Classes.Eq (Language.Haskell.Syntax.Extension.XCFieldOcc pass), GHC.Classes.Eq (Language.Haskell.Syntax.Extension.XXFieldOcc pass)) => GHC.Classes.Eq (Language.Haskell.Syntax.Type.FieldOcc pass)

+ Language.Haskell.Syntax.Type: instance (GHC.Utils.Outputable.Outputable tm, GHC.Utils.Outputable.Outputable ty) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsArg tm ty)

+ Language.Haskell.Syntax.Type: instance (GHC.Utils.Outputable.Outputable tyarg, GHC.Utils.Outputable.Outputable arg, GHC.Utils.Outputable.Outputable rec) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsConDetails tyarg arg rec)

+ Language.Haskell.Syntax.Type: instance Data.Data.Data Language.Haskell.Syntax.Type.HsIPName

+ Language.Haskell.Syntax.Type: instance Data.Data.Data Language.Haskell.Syntax.Type.HsPSRn

+ Language.Haskell.Syntax.Type: instance Data.Data.Data Language.Haskell.Syntax.Type.HsTupleSort

+ Language.Haskell.Syntax.Type: instance Data.Data.Data Language.Haskell.Syntax.Type.HsTyLit

+ Language.Haskell.Syntax.Type: instance GHC.Classes.Eq Language.Haskell.Syntax.Type.HsIPName

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.FieldOcc pass)

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Type.HsIPName

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Type.HsTyLit

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsScaled pass a)

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.OutputableBndr (GHC.Types.SrcLoc.GenLocated GHC.Types.SrcLoc.SrcSpan (Language.Haskell.Syntax.Type.FieldOcc pass))

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.OutputableBndr (Language.Haskell.Syntax.Type.FieldOcc pass)

+ Language.Haskell.Syntax.Type: instance GHC.Utils.Outputable.OutputableBndr Language.Haskell.Syntax.Type.HsIPName

+ Language.Haskell.Syntax.Type: isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool

+ Language.Haskell.Syntax.Type: mapHsOuterImplicit :: (XHsOuterImplicit pass -> XHsOuterImplicit pass) -> HsOuterTyVarBndrs flag pass -> HsOuterTyVarBndrs flag pass

+ Language.Haskell.Syntax.Type: newtype HsIPName

+ Language.Haskell.Syntax.Type: noTypeArgs :: [Void]

+ Language.Haskell.Syntax.Type: numVisibleArgs :: [HsArg tm ty] -> Arity

+ Language.Haskell.Syntax.Type: type BangType pass = HsType pass

+ Language.Haskell.Syntax.Type: type HsContext pass = [LHsType pass]

+ Language.Haskell.Syntax.Type: type HsCoreTy = Type

+ Language.Haskell.Syntax.Type: type HsKind pass = HsType pass

+ Language.Haskell.Syntax.Type: type HsOuterFamEqnTyVarBndrs = HsOuterTyVarBndrs ()

+ Language.Haskell.Syntax.Type: type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity

+ Language.Haskell.Syntax.Type: type LBangType pass = XRec pass (BangType pass)

+ Language.Haskell.Syntax.Type: type LConDeclField pass = XRec pass (ConDeclField pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

+ Language.Haskell.Syntax.Type: type LFieldOcc pass = XRec pass (FieldOcc pass)

+ Language.Haskell.Syntax.Type: type LHsContext pass = XRec pass (HsContext pass) " 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit' For details on above see note [exact print annotations] in GHC.Parser.Annotation"

+ Language.Haskell.Syntax.Type: type LHsKind pass = XRec pass (HsKind pass) " 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'"

+ Language.Haskell.Syntax.Type: type LHsSigType pass = XRec pass (HsSigType pass)

+ Language.Haskell.Syntax.Type: type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass)

+ Language.Haskell.Syntax.Type: type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)

+ Language.Haskell.Syntax.Type: type LHsType pass = XRec pass (HsType pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

+ Language.Haskell.Syntax.Type: type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)

+ Language.Haskell.Syntax.Type: type LHsWcType pass = HsWildCardBndrs pass (LHsType pass)

+ Language.Haskell.Syntax.Type: type Mult = Type

- GHC: DynFlags :: GhcMode -> GhcLink -> HscTarget -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> PlatformConstants -> [(String, String)] -> LlvmConfig -> Int -> Int -> Int -> Int -> Int -> Maybe String -> Maybe String -> [Int] -> Maybe Int -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> Int -> Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> Module -> Maybe String -> IntWithInf -> IntWithInf -> UnitId -> Maybe IndefUnitId -> [(ModuleName, Module)] -> Set Way -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> IORef Bool -> String -> String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> Maybe FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [LoadedPlugin] -> [StaticPlugin] -> Hooks -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> Maybe [UnitDatabase UnitId] -> UnitState -> IORef FilesToClean -> IORef (Map FilePath FilePath) -> IORef Int -> IORef (Set FilePath) -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> Int -> Int -> Int -> Int -> Int -> Bool -> Int -> Int -> LogAction -> DumpAction -> TraceAction -> FlushOut -> FlushErr -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> Maybe String -> IORef (ModuleEnv Int) -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Int -> Int -> CfgWeights -> DynFlags

+ GHC: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> LlvmConfig -> Int -> Int -> Int -> Int -> Int -> Maybe String -> Maybe String -> [Int] -> Maybe Int -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> Int -> Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> IORef Bool -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> Maybe FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> FlushErr -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> IORef (ModuleEnv Int) -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Word -> Int -> Weights -> DynFlags

- GHC: ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule

+ GHC: ParsedModule :: ModSummary -> ParsedSource -> [FilePath] -> ParsedModule

- GHC: TargetFile :: FilePath -> Maybe Phase -> TargetId

+ GHC: TargetFile :: !FilePath -> !Maybe Phase -> TargetId

- GHC: TargetModule :: ModuleName -> TargetId

+ GHC: TargetModule :: !ModuleName -> TargetId

- GHC: [initialUnique] :: DynFlags -> Int

+ GHC: [initialUnique] :: DynFlags -> Word

- GHC: class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m

+ GHC: class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m) => GhcMonad m

- GHC: cyclicModuleErr :: [ModSummary] -> SDoc

+ GHC: cyclicModuleErr :: [ModuleGraphNode] -> SDoc

- GHC: getDocs :: GhcMonad m => Name -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))

+ GHC: getDocs :: GhcMonad m => Name -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))

- GHC: getNameToInstancesIndex :: GhcMonad m => [Module] -> Maybe [Module] -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))

+ GHC: getNameToInstancesIndex :: GhcMonad m => [Module] -> Maybe [Module] -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst])))

- GHC: hasImport :: ParserFlags -> String -> Bool

+ GHC: hasImport :: ParserOpts -> String -> Bool

- GHC: interpretPackageEnv :: DynFlags -> IO DynFlags

+ GHC: interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags

- GHC: isDecl :: ParserFlags -> String -> Bool

+ GHC: isDecl :: ParserOpts -> String -> Bool

- GHC: isImport :: ParserFlags -> String -> Bool

+ GHC: isImport :: ParserOpts -> String -> Bool

- GHC: isStmt :: ParserFlags -> String -> Bool

+ GHC: isStmt :: ParserOpts -> String -> Bool

- GHC: mkModuleGraph :: [ModSummary] -> ModuleGraph

+ GHC: mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph

- GHC: parseDynamicFlags :: MonadIO m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn])

+ GHC: parseDynamicFlags :: MonadIO m => Logger -> DynFlags -> [Located String] -> m (DynFlags, [Located String], [Warn])

- GHC: resumeExec :: GhcMonad m => (SrcSpan -> Bool) -> SingleStep -> m ExecResult

+ GHC: resumeExec :: GhcMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ExecResult

- GHC: runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)

+ GHC: runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)

- GHC: showGhcException :: GhcException -> ShowS

+ GHC: showGhcException :: SDocContext -> GhcException -> ShowS

- GHC: topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]

+ GHC: topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]

- GHC.Builtin.Types.Literals: typeNatCoAxiomRules :: Map FastString CoAxiomRule

+ GHC.Builtin.Types.Literals: typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule

- GHC.Builtin.Utils: builtinRules :: EnableBignumRules -> [CoreRule]

+ GHC.Builtin.Utils: builtinRules :: [CoreRule]

- GHC.ByteCode.Asm: assembleBCOs :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] -> Maybe ModBreaks -> IO CompiledByteCode

+ GHC.ByteCode.Asm: assembleBCOs :: Interp -> Profile -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()] -> Maybe ModBreaks -> IO CompiledByteCode

- GHC.ByteCode.Asm: assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO

+ GHC.ByteCode.Asm: assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO

- GHC.ByteCode.InfoTable: mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv

+ GHC.ByteCode.InfoTable: mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv

- GHC.ByteCode.Instr: ProtoBCO :: a -> [BCInstr] -> [StgWord] -> Word16 -> Int -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet) -> [FFIInfo] -> ProtoBCO a

+ GHC.ByteCode.Instr: ProtoBCO :: a -> [BCInstr] -> [StgWord] -> Word16 -> Int -> Either [CgStgAlt] CgStgRhs -> [FFIInfo] -> ProtoBCO a

- GHC.ByteCode.Instr: [protoBCOExpr] :: ProtoBCO a -> Either [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)

+ GHC.ByteCode.Instr: [protoBCOExpr] :: ProtoBCO a -> Either [CgStgAlt] CgStgRhs

- GHC.ByteCode.Linker: linkBCO :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO

+ GHC.ByteCode.Linker: linkBCO :: Interp -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray -> UnlinkedBCO -> IO ResolvedBCO

- GHC.ByteCode.Linker: lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())

+ GHC.ByteCode.Linker: lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())

- GHC.ByteCode.Linker: lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())

+ GHC.ByteCode.Linker: lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())

- GHC.Cmm.CLabel: ForeignLabelInPackage :: Unit -> ForeignLabelSource

+ GHC.Cmm.CLabel: ForeignLabelInPackage :: UnitId -> ForeignLabelSource

- GHC.Cmm.CLabel: labelDynamic :: NCGConfig -> Module -> CLabel -> Bool

+ GHC.Cmm.CLabel: labelDynamic :: NCGConfig -> CLabel -> Bool

- GHC.Cmm.CLabel: mkApEntryLabel :: DynFlags -> Bool -> Int -> CLabel

+ GHC.Cmm.CLabel: mkApEntryLabel :: Platform -> Bool -> Int -> CLabel

- GHC.Cmm.CLabel: mkApInfoTableLabel :: DynFlags -> Bool -> Int -> CLabel

+ GHC.Cmm.CLabel: mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel

- GHC.Cmm.CLabel: mkConInfoTableLabel :: Name -> CafInfo -> CLabel

+ GHC.Cmm.CLabel: mkConInfoTableLabel :: Name -> ConInfoTableLocation -> CLabel

- GHC.Cmm.CLabel: mkSelectorEntryLabel :: DynFlags -> Bool -> Int -> CLabel

+ GHC.Cmm.CLabel: mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel

- GHC.Cmm.CLabel: mkSelectorInfoLabel :: DynFlags -> Bool -> Int -> CLabel

+ GHC.Cmm.CLabel: mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel

- GHC.Cmm.CLabel: pprCLabel :: DynFlags -> CLabel -> SDoc

+ GHC.Cmm.CLabel: pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc

- GHC.Cmm.CLabel: pprDebugCLabel :: CLabel -> SDoc

+ GHC.Cmm.CLabel: pprDebugCLabel :: Platform -> CLabel -> SDoc

- GHC.Cmm.CLabel: toClosureLbl :: CLabel -> CLabel

+ GHC.Cmm.CLabel: toClosureLbl :: Platform -> CLabel -> CLabel

- GHC.Cmm.CLabel: toEntryLbl :: CLabel -> CLabel

+ GHC.Cmm.CLabel: toEntryLbl :: Platform -> CLabel -> CLabel

- GHC.Cmm.CLabel: toInfoLbl :: CLabel -> CLabel

+ GHC.Cmm.CLabel: toInfoLbl :: Platform -> CLabel -> CLabel

- GHC.Cmm.CLabel: toSlowEntryLbl :: CLabel -> CLabel

+ GHC.Cmm.CLabel: toSlowEntryLbl :: Platform -> CLabel -> CLabel

- GHC.Cmm.CallConv: assignArgumentsPos :: DynFlags -> ByteOff -> Convention -> (a -> CmmType) -> [a] -> (ByteOff, [(a, ParamLocation)])

+ GHC.Cmm.CallConv: assignArgumentsPos :: Profile -> ByteOff -> Convention -> (a -> CmmType) -> [a] -> (ByteOff, [(a, ParamLocation)])

- GHC.Cmm.CallConv: realArgRegsCover :: DynFlags -> [GlobalReg]

+ GHC.Cmm.CallConv: realArgRegsCover :: Platform -> [GlobalReg]

- GHC.Cmm.Expr: CmmFloat :: Rational -> Width -> CmmLit

+ GHC.Cmm.Expr: CmmFloat :: Rational -> !Width -> CmmLit

- GHC.Cmm.Expr: CmmInt :: !Integer -> Width -> CmmLit

+ GHC.Cmm.Expr: CmmInt :: !Integer -> !Width -> CmmLit

- GHC.Cmm.Expr: CmmLabelDiffOff :: CLabel -> CLabel -> Int -> Width -> CmmLit

+ GHC.Cmm.Expr: CmmLabelDiffOff :: CLabel -> CLabel -> !Int -> !Width -> CmmLit

- GHC.Cmm.Expr: CmmLabelOff :: CLabel -> Int -> CmmLit

+ GHC.Cmm.Expr: CmmLabelOff :: CLabel -> !Int -> CmmLit

- GHC.Cmm.Expr: CmmLit :: CmmLit -> CmmExpr

+ GHC.Cmm.Expr: CmmLit :: !CmmLit -> CmmExpr

- GHC.Cmm.Expr: CmmRegOff :: !CmmReg -> Int -> CmmExpr

+ GHC.Cmm.Expr: CmmRegOff :: !CmmReg -> !Int -> CmmExpr

- GHC.Cmm.Expr: LocalReg :: {-# UNPACK #-} !Unique -> CmmType -> LocalReg

+ GHC.Cmm.Expr: LocalReg :: {-# UNPACK #-} !Unique -> !CmmType -> LocalReg

- GHC.Cmm.Expr: foldLocalRegsDefd :: DefinerOfRegs LocalReg a => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b

+ GHC.Cmm.Expr: foldLocalRegsDefd :: DefinerOfRegs LocalReg a => Platform -> (b -> LocalReg -> b) -> b -> a -> b

- GHC.Cmm.Expr: foldLocalRegsUsed :: UserOfRegs LocalReg a => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b

+ GHC.Cmm.Expr: foldLocalRegsUsed :: UserOfRegs LocalReg a => Platform -> (b -> LocalReg -> b) -> b -> a -> b

- GHC.Cmm.Expr: foldRegsDefd :: DefinerOfRegs r a => DynFlags -> (b -> r -> b) -> b -> a -> b

+ GHC.Cmm.Expr: foldRegsDefd :: DefinerOfRegs r a => Platform -> (b -> r -> b) -> b -> a -> b

- GHC.Cmm.Expr: foldRegsUsed :: UserOfRegs r a => DynFlags -> (b -> r -> b) -> b -> a -> b

+ GHC.Cmm.Expr: foldRegsUsed :: UserOfRegs r a => Platform -> (b -> r -> b) -> b -> a -> b

- GHC.Cmm.Graph: copyInOflow :: DynFlags -> Convention -> Area -> [CmmFormal] -> [CmmFormal] -> (Int, [GlobalReg], CmmAGraph)

+ GHC.Cmm.Graph: copyInOflow :: Profile -> Convention -> Area -> [CmmFormal] -> [CmmFormal] -> (Int, [GlobalReg], CmmAGraph)

- GHC.Cmm.Graph: copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> (Int, [GlobalReg], CmmAGraph)

+ GHC.Cmm.Graph: copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> (Int, [GlobalReg], CmmAGraph)

- GHC.Cmm.Graph: mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal] -> (Int, [GlobalReg], CmmAGraph)

+ GHC.Cmm.Graph: mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal] -> (Int, [GlobalReg], CmmAGraph)

- GHC.Cmm.Graph: mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] -> BlockId -> ByteOff -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph

+ GHC.Cmm.Graph: mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] -> BlockId -> ByteOff -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph

- GHC.Cmm.Graph: mkFinalCall :: DynFlags -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph

+ GHC.Cmm.Graph: mkFinalCall :: Profile -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph

- GHC.Cmm.Graph: mkJump :: DynFlags -> Convention -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph

+ GHC.Cmm.Graph: mkJump :: Profile -> Convention -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph

- GHC.Cmm.Graph: mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph

+ GHC.Cmm.Graph: mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> [CmmExpr] -> CmmAGraph

- GHC.Cmm.Graph: mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr] -> BlockId -> ByteOff -> UpdFrameOffset -> CmmAGraph

+ GHC.Cmm.Graph: mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr] -> BlockId -> ByteOff -> UpdFrameOffset -> CmmAGraph

- GHC.Cmm.Graph: mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg] -> CmmAGraph

+ GHC.Cmm.Graph: mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg] -> CmmAGraph

- GHC.Cmm.Graph: mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph

+ GHC.Cmm.Graph: mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset -> CmmAGraph

- GHC.Cmm.Info: closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a)

+ GHC.Cmm.Info: cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a -> IO (Stream IO RawCmmGroup a)

- GHC.Cmm.Info: conInfoTableSizeB :: DynFlags -> Int

+ GHC.Cmm.Info: conInfoTableSizeB :: Profile -> Int

- GHC.Cmm.Info: funInfoArity :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: funInfoArity :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: funInfoTable :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: funInfoTable :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: getConstrTag :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: infoTable :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: infoTable :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: infoTableClosureType :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: infoTablePtrs :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Info: infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr

- GHC.Cmm.Info: stdClosureTypeOffset :: DynFlags -> ByteOff

+ GHC.Cmm.Info: stdClosureTypeOffset :: Profile -> ByteOff

- GHC.Cmm.Info: stdInfoTableSizeB :: DynFlags -> ByteOff

+ GHC.Cmm.Info: stdInfoTableSizeB :: Profile -> ByteOff

- GHC.Cmm.Info: stdInfoTableSizeW :: DynFlags -> WordOff

+ GHC.Cmm.Info: stdInfoTableSizeW :: Profile -> WordOff

- GHC.Cmm.Info: stdNonPtrsOffset :: DynFlags -> ByteOff

+ GHC.Cmm.Info: stdNonPtrsOffset :: Profile -> ByteOff

- GHC.Cmm.Info: stdPtrsOffset :: DynFlags -> ByteOff

+ GHC.Cmm.Info: stdPtrsOffset :: Profile -> ByteOff

- GHC.Cmm.Info: stdSrtBitmapOffset :: DynFlags -> ByteOff

+ GHC.Cmm.Info: stdSrtBitmapOffset :: Profile -> ByteOff

- GHC.Cmm.Info.Build: cafAnal :: LabelSet -> CLabel -> CmmGraph -> CAFEnv

+ GHC.Cmm.Info.Build: cafAnal :: Platform -> LabelSet -> CLabel -> CmmGraph -> CAFEnv

- GHC.Cmm.Info.Build: cafAnalData :: CmmStatics -> CAFSet

+ GHC.Cmm.Info.Build: cafAnalData :: Platform -> CmmStatics -> CAFSet

- GHC.Cmm.Lint: cmmLint :: (Outputable d, Outputable h) => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc

+ GHC.Cmm.Lint: cmmLint :: (OutputableP Platform d, OutputableP Platform h) => Platform -> GenCmmGroup d h CmmGraph -> Maybe SDoc

- GHC.Cmm.Lint: cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc

+ GHC.Cmm.Lint: cmmLintGraph :: Platform -> CmmGraph -> Maybe SDoc

- GHC.Cmm.Liveness: cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg

+ GHC.Cmm.Liveness: cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg

- GHC.Cmm.Liveness: cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg

+ GHC.Cmm.Liveness: cmmLocalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness LocalReg

- GHC.Cmm.Liveness: gen_kill :: (DefinerOfRegs r n, UserOfRegs r n) => DynFlags -> n -> CmmLive r -> CmmLive r

+ GHC.Cmm.Liveness: gen_kill :: (DefinerOfRegs r n, UserOfRegs r n) => Platform -> n -> CmmLive r -> CmmLive r

- GHC.Cmm.Node: [CmmCall] :: {cml_target :: CmmExpr, cml_cont :: Maybe Label, cml_args_regs :: [GlobalReg], cml_args :: ByteOff, cml_ret_args :: ByteOff, cml_ret_off :: ByteOff} -> CmmNode O C

+ GHC.Cmm.Node: [CmmCall] :: CmmExpr -> Maybe Label -> [GlobalReg] -> ByteOff -> ByteOff -> ByteOff -> CmmNode O C

- GHC.Cmm.Node: [CmmCondBranch] :: {cml_pred :: CmmExpr, cml_true, cml_false :: {-# UNPACK #-} !Label, cml_likely :: Maybe Bool} -> CmmNode O C

+ GHC.Cmm.Node: [CmmCondBranch] :: CmmExpr -> {-# UNPACK #-} !Label -> Maybe Bool -> CmmNode O C

- GHC.Cmm.Node: [CmmForeignCall] :: {tgt :: ForeignTarget, res :: [CmmFormal], args :: [CmmActual], succ :: {-# UNPACK #-} !Label, ret_args :: ByteOff, ret_off :: ByteOff, intrbl :: Bool} -> CmmNode O C

+ GHC.Cmm.Node: [CmmForeignCall] :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> {-# UNPACK #-} !Label -> ByteOff -> ByteOff -> Bool -> CmmNode O C

- GHC.Cmm.Node: type CmmTickish = Tickish ()

+ GHC.Cmm.Node: type CmmTickish = GenTickish 'TickishPassCmm

- GHC.Cmm.Parser: parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)

+ GHC.Cmm.Parser: parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))

- GHC.Cmm.Ppr.Decl: pprCmmGroup :: (Outputable d, Outputable info, Outputable g) => GenCmmGroup d info g -> SDoc

+ GHC.Cmm.Ppr.Decl: pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g) => Platform -> GenCmmGroup d info g -> SDoc

- GHC.Cmm.Ppr.Decl: pprCmms :: (Outputable info, Outputable g) => [GenCmmGroup RawCmmStatics info g] -> SDoc

+ GHC.Cmm.Ppr.Decl: pprCmms :: (OutputableP Platform info, OutputableP Platform g) => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc

- GHC.Cmm.Ppr.Decl: pprSection :: Section -> SDoc

+ GHC.Cmm.Ppr.Decl: pprSection :: Platform -> Section -> SDoc

- GHC.Cmm.ProcPoint: splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet -> ProcPointSet -> LabelMap Status -> CmmDecl -> UniqSM [CmmDecl]

+ GHC.Cmm.ProcPoint: splitAtProcPoints :: Platform -> CLabel -> ProcPointSet -> ProcPointSet -> LabelMap Status -> CmmDecl -> UniqSM [CmmDecl]

- GHC.Cmm.Sink: cmmSink :: DynFlags -> CmmGraph -> CmmGraph

+ GHC.Cmm.Sink: cmmSink :: Platform -> CmmGraph -> CmmGraph

- GHC.Cmm.Switch.Implement: cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph

+ GHC.Cmm.Switch.Implement: cmmImplementSwitchPlans :: Backend -> Platform -> CmmGraph -> UniqSM CmmGraph

- GHC.Cmm.Type: cInt :: DynFlags -> CmmType

+ GHC.Cmm.Type: cInt :: Platform -> CmmType

- GHC.Cmm.Type: cIntWidth :: DynFlags -> Width

+ GHC.Cmm.Type: cIntWidth :: Platform -> Width

- GHC.Cmm.Type: rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType

+ GHC.Cmm.Type: rEP_CostCentreStack_mem_alloc :: Platform -> CmmType

- GHC.Cmm.Type: rEP_CostCentreStack_scc_count :: DynFlags -> CmmType

+ GHC.Cmm.Type: rEP_CostCentreStack_scc_count :: Platform -> CmmType

- GHC.Cmm.Type: rEP_StgEntCounter_allocd :: DynFlags -> CmmType

+ GHC.Cmm.Type: rEP_StgEntCounter_allocd :: Platform -> CmmType

- GHC.Cmm.Type: rEP_StgEntCounter_allocs :: DynFlags -> CmmType

+ GHC.Cmm.Type: rEP_StgEntCounter_allocs :: Platform -> CmmType

- GHC.Cmm.Utils: cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Utils: cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr

- GHC.Cmm.Utils: cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Utils: cmmIsTagged :: Platform -> CmmExpr -> CmmExpr

- GHC.Cmm.Utils: cmmPointerMask :: DynFlags -> CmmExpr

+ GHC.Cmm.Utils: cmmPointerMask :: Platform -> CmmExpr

- GHC.Cmm.Utils: cmmTagMask :: DynFlags -> CmmExpr

+ GHC.Cmm.Utils: cmmTagMask :: Platform -> CmmExpr

- GHC.Cmm.Utils: cmmUntag :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.Cmm.Utils: cmmUntag :: Platform -> CmmExpr -> CmmExpr

- GHC.CmmToAsm: cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, Outputable statics, Outputable instr, Outputable jumpDest) => DynFlags -> Module -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply -> DwarfFiles -> LabelMap DebugBlock -> RawCmmDecl -> Int -> IO (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel], Maybe [RegAllocStats statics instr], Maybe [RegAllocStats], LabelMap [UnwindPoint])

+ GHC.CmmToAsm: cmmNativeGen :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest) => Logger -> DynFlags -> ModLocation -> NcgImpl statics instr jumpDest -> UniqSupply -> DwarfFiles -> LabelMap DebugBlock -> RawCmmDecl -> Int -> IO (UniqSupply, DwarfFiles, [NatCmmDecl statics instr], [CLabel], Maybe [RegAllocStats statics instr], Maybe [RegAllocStats], LabelMap [UnwindPoint])

- GHC.CmmToAsm: nativeCodeGen :: forall a. DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a

+ GHC.CmmToAsm: nativeCodeGen :: forall a. Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply -> Stream IO RawCmmGroup a -> IO a

- GHC.CmmToAsm.BlockLayout: sequenceTop :: (Instruction instr, Outputable instr) => DynFlags -> NcgImpl statics instr jumpDest -> Maybe CFG -> NatCmmDecl statics instr -> NatCmmDecl statics instr

+ GHC.CmmToAsm.BlockLayout: sequenceTop :: Instruction instr => NcgImpl statics instr jumpDest -> Maybe CFG -> NatCmmDecl statics instr -> NatCmmDecl statics instr

- GHC.CmmToAsm.CFG: addImmediateSuccessor :: DynFlags -> BlockId -> BlockId -> CFG -> CFG

+ GHC.CmmToAsm.CFG: addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG

- GHC.CmmToAsm.CFG: addNodesBetween :: DynFlags -> CFG -> [(BlockId, BlockId, BlockId)] -> CFG

+ GHC.CmmToAsm.CFG: addNodesBetween :: Weights -> CFG -> [(BlockId, BlockId, BlockId)] -> CFG

- GHC.CmmToAsm.CFG: getCfg :: CfgWeights -> CmmGraph -> CFG

+ GHC.CmmToAsm.CFG: getCfg :: Platform -> Weights -> CmmGraph -> CFG

- GHC.CmmToAsm.CFG: getCfgProc :: CfgWeights -> RawCmmDecl -> CFG

+ GHC.CmmToAsm.CFG: getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG

- GHC.CmmToAsm.CFG: optimizeCFG :: Bool -> CfgWeights -> RawCmmDecl -> CFG -> CFG

+ GHC.CmmToAsm.CFG: optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG

- GHC.CmmToAsm.Config: NCGConfig :: !Platform -> !Maybe Int -> !Int -> !Bool -> !Bool -> !Word -> !Word -> !Bool -> !Int -> !Bool -> !Bool -> !Bool -> Maybe SseVersion -> Maybe BmiVersion -> !Bool -> !Bool -> !Bool -> NCGConfig

+ GHC.CmmToAsm.Config: NCGConfig :: !Platform -> !SDocContext -> !Module -> !Maybe Int -> !Bool -> !Bool -> !Word -> !Word -> !Bool -> !Bool -> !Bool -> !Bool -> Maybe SseVersion -> Maybe BmiVersion -> !Bool -> !Bool -> !Bool -> !Weights -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> NCGConfig

- GHC.CmmToAsm.Dwarf: dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock] -> IO (SDoc, UniqSupply)

+ GHC.CmmToAsm.Dwarf: dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> IO (SDoc, UniqSupply)

- GHC.CmmToAsm.Instr: mkLoadInstr :: Instruction instr => NCGConfig -> Reg -> Int -> Int -> instr

+ GHC.CmmToAsm.Instr: mkLoadInstr :: Instruction instr => NCGConfig -> Reg -> Int -> Int -> [instr]

- GHC.CmmToAsm.Instr: mkSpillInstr :: Instruction instr => NCGConfig -> Reg -> Int -> Int -> instr

+ GHC.CmmToAsm.Instr: mkSpillInstr :: Instruction instr => NCGConfig -> Reg -> Int -> Int -> [instr]

- GHC.CmmToAsm.Monad: NatM_State :: UniqSupply -> Int -> [CLabel] -> Maybe Reg -> DynFlags -> NCGConfig -> Module -> ModLocation -> DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State

+ GHC.CmmToAsm.Monad: NatM_State :: UniqSupply -> Int -> [CLabel] -> Maybe Reg -> NCGConfig -> ModLocation -> DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State

- GHC.CmmToAsm.Monad: mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation -> DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State

+ GHC.CmmToAsm.Monad: mkNatM_State :: UniqSupply -> Int -> NCGConfig -> ModLocation -> DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State

- GHC.CmmToAsm.PIC: pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc

+ GHC.CmmToAsm.PIC: pprImportedSymbol :: NCGConfig -> CLabel -> SDoc

- GHC.CmmToAsm.Reg.Graph: regAlloc :: (Outputable statics, Outputable instr, Instruction instr) => NCGConfig -> UniqFM RegClass (UniqSet RealReg) -> UniqSet Int -> Int -> [LiveCmmDecl statics instr] -> Maybe CFG -> UniqSM ([NatCmmDecl statics instr], Maybe Int, [RegAllocStats statics instr])

+ GHC.CmmToAsm.Reg.Graph: regAlloc :: (OutputableP Platform statics, Instruction instr) => NCGConfig -> UniqFM RegClass (UniqSet RealReg) -> UniqSet Int -> Int -> [LiveCmmDecl statics instr] -> Maybe CFG -> UniqSM ([NatCmmDecl statics instr], Maybe Int, [RegAllocStats statics instr])

- GHC.CmmToAsm.Reg.Graph.SpillCost: slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr) => Platform -> Maybe CFG -> LiveCmmDecl statics instr -> SpillCostInfo

+ GHC.CmmToAsm.Reg.Graph.SpillCost: slurpSpillCostInfo :: forall instr statics. Instruction instr => Platform -> Maybe CFG -> LiveCmmDecl statics instr -> SpillCostInfo

- GHC.CmmToAsm.Reg.Linear: regAlloc :: (Outputable instr, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)

+ GHC.CmmToAsm.Reg.Linear: regAlloc :: Instruction instr => NCGConfig -> LiveCmmDecl statics instr -> UniqSM (NatCmmDecl statics instr, Maybe Int, Maybe RegAllocStats)

- GHC.CmmToAsm.Reg.Linear.JoinToTargets: joinToTargets :: (FR freeRegs, Instruction instr, Outputable instr) => BlockMap RegSet -> BlockId -> instr -> RegM freeRegs ([NatBasicBlock instr], instr)

+ GHC.CmmToAsm.Reg.Linear.JoinToTargets: joinToTargets :: (FR freeRegs, Instruction instr) => BlockMap RegSet -> BlockId -> instr -> RegM freeRegs ([NatBasicBlock instr], instr)

- GHC.CmmToAsm.Reg.Linear.State: loadR :: Instruction instr => Reg -> Int -> RegM freeRegs instr

+ GHC.CmmToAsm.Reg.Linear.State: loadR :: Instruction instr => Reg -> Int -> RegM freeRegs [instr]

- GHC.CmmToAsm.Reg.Linear.State: spillR :: Instruction instr => Reg -> Unique -> RegM freeRegs (instr, Int)

+ GHC.CmmToAsm.Reg.Linear.State: spillR :: Instruction instr => Reg -> Unique -> RegM freeRegs ([instr], Int)

- GHC.CmmToAsm.Reg.Liveness: cmmTopLiveness :: (Outputable instr, Instruction instr) => Maybe CFG -> Platform -> NatCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)

+ GHC.CmmToAsm.Reg.Liveness: cmmTopLiveness :: Instruction instr => Maybe CFG -> Platform -> NatCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)

- GHC.CmmToAsm.Reg.Liveness: regLiveness :: (Outputable instr, Instruction instr) => Platform -> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)

+ GHC.CmmToAsm.Reg.Liveness: regLiveness :: Instruction instr => Platform -> LiveCmmDecl statics instr -> UniqSM (LiveCmmDecl statics instr)

- GHC.CmmToAsm.Reg.Liveness: stripLive :: (Outputable statics, Outputable instr, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr

+ GHC.CmmToAsm.Reg.Liveness: stripLive :: (OutputableP Platform statics, Instruction instr) => NCGConfig -> LiveCmmDecl statics instr -> NatCmmDecl statics instr

- GHC.CmmToAsm.SPARC.CodeGen.Sanity: checkBlock :: CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr

+ GHC.CmmToAsm.SPARC.CodeGen.Sanity: checkBlock :: Platform -> CmmBlock -> NatBasicBlock Instr -> NatBasicBlock Instr

- GHC.CmmToAsm.SPARC.Ppr: pprImm :: Imm -> SDoc

+ GHC.CmmToAsm.SPARC.Ppr: pprImm :: Platform -> Imm -> SDoc

- GHC.CmmToAsm.SPARC.Ppr: pprInstr :: Instr -> SDoc

+ GHC.CmmToAsm.SPARC.Ppr: pprInstr :: Platform -> Instr -> SDoc

- GHC.CmmToAsm.X86.Ppr: pprImm :: Imm -> SDoc

+ GHC.CmmToAsm.X86.Ppr: pprImm :: Platform -> Imm -> SDoc

- GHC.CmmToLlvm: llvmCodeGen :: DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a

+ GHC.CmmToLlvm: llvmCodeGen :: Logger -> DynFlags -> Handle -> Stream IO RawCmmGroup a -> IO a

- GHC.CmmToLlvm: llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()

+ GHC.CmmToLlvm: llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()

- GHC.CmmToLlvm.Base: runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a

+ GHC.CmmToLlvm.Base: runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a

- GHC.CmmToLlvm.Mangler: llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()

+ GHC.CmmToLlvm.Mangler: llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()

- GHC.Core: AnnTick :: Tickish Id -> AnnExpr bndr annot -> AnnExpr' bndr annot

+ GHC.Core: AnnTick :: CoreTickish -> AnnExpr bndr annot -> AnnExpr' bndr annot

- GHC.Core: RuleOpts :: !Platform -> !Bool -> !Bool -> RuleOpts

+ GHC.Core: RuleOpts :: !Platform -> !Bool -> !Bool -> !Bool -> RuleOpts

- GHC.Core: Tick :: Tickish Id -> Expr b -> Expr b

+ GHC.Core: Tick :: CoreTickish -> Expr b -> Expr b

- GHC.Core: cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering

+ GHC.Core: cmpAlt :: Alt a -> Alt a -> Ordering

- GHC.Core: collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])

+ GHC.Core: collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a -> (AnnExpr b a, [AnnExpr b a], [CoreTickish])

- GHC.Core: collectArgsTicks :: (Tickish Id -> Bool) -> Expr b -> (Expr b, [Arg b], [Tickish Id])

+ GHC.Core: collectArgsTicks :: (CoreTickish -> Bool) -> Expr b -> (Expr b, [Arg b], [CoreTickish])

- GHC.Core: ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool

+ GHC.Core: ltAlt :: Alt a -> Alt a -> Bool

- GHC.Core.Coercion: CoercionHole :: CoVar -> BlockSubstFlag -> IORef (Maybe Coercion) -> CoercionHole

+ GHC.Core.Coercion: CoercionHole :: CoVar -> IORef (Maybe Coercion) -> CoercionHole

- GHC.Core.Coercion: mkSubCo :: Coercion -> Coercion

+ GHC.Core.Coercion: mkSubCo :: HasDebugCallStack => Coercion -> Coercion

- GHC.Core.Coercion: simplifyArgsWorker :: [TyCoBinder] -> Kind -> TyCoVarSet -> [Role] -> [(Type, Coercion)] -> ([Type], [Coercion], CoercionN)

+ GHC.Core.Coercion: simplifyArgsWorker :: [TyCoBinder] -> Kind -> TyCoVarSet -> [Role] -> [(Type, Coercion)] -> ([Type], [Coercion], MCoercionN)

- GHC.Core.Coercion.Opt: optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo

+ GHC.Core.Coercion.Opt: optCoercion :: OptCoercionOpts -> TCvSubst -> Coercion -> NormalCo

- GHC.Core.DataCon: FieldLabel :: FieldLabelString -> Bool -> a -> FieldLbl a

+ GHC.Core.DataCon: FieldLabel :: FieldLabelString -> DuplicateRecordFields -> FieldSelectors -> Name -> FieldLabel

- GHC.Core.DataCon: [flLabel] :: FieldLbl a -> FieldLabelString

+ GHC.Core.DataCon: [flLabel] :: FieldLabel -> FieldLabelString

- GHC.Core.DataCon: [flSelector] :: FieldLbl a -> a

+ GHC.Core.DataCon: [flSelector] :: FieldLabel -> Name

- GHC.Core.DataCon: dataConDisplayType :: DynFlags -> DataCon -> Type

+ GHC.Core.DataCon: dataConDisplayType :: Bool -> DataCon -> Type

- GHC.Core.FamInstEnv: FamInst :: CoAxiom Unbranched -> FamFlavor -> Name -> [Maybe Name] -> [TyVar] -> [CoVar] -> [Type] -> Type -> FamInst

+ GHC.Core.FamInstEnv: FamInst :: CoAxiom Unbranched -> FamFlavor -> Name -> [RoughMatchTc] -> [TyVar] -> [CoVar] -> [Type] -> Type -> FamInst

- GHC.Core.FamInstEnv: [fi_tcs] :: FamInst -> [Maybe Name]

+ GHC.Core.FamInstEnv: [fi_tcs] :: FamInst -> [RoughMatchTc]

- GHC.Core.FamInstEnv: mkImportedFamInst :: Name -> [Maybe Name] -> CoAxiom Unbranched -> FamInst

+ GHC.Core.FamInstEnv: mkImportedFamInst :: Name -> [RoughMatchTc] -> CoAxiom Unbranched -> FamInst

- GHC.Core.FamInstEnv: topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] -> Maybe (Coercion, Type, Coercion)

+ GHC.Core.FamInstEnv: topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type] -> Maybe (Coercion, Type, MCoercion)

- GHC.Core.InstEnv: ClsInst :: Name -> [Maybe Name] -> Name -> [TyVar] -> Class -> [Type] -> DFunId -> OverlapFlag -> IsOrphan -> ClsInst

+ GHC.Core.InstEnv: ClsInst :: Name -> [RoughMatchTc] -> Name -> [TyVar] -> Class -> [Type] -> DFunId -> OverlapFlag -> IsOrphan -> ClsInst

- GHC.Core.InstEnv: [is_tcs] :: ClsInst -> [Maybe Name]

+ GHC.Core.InstEnv: [is_tcs] :: ClsInst -> [RoughMatchTc]

- GHC.Core.InstEnv: instanceBindFun :: TyCoVar -> BindFlag

+ GHC.Core.InstEnv: instanceBindFun :: BindFun

- GHC.Core.InstEnv: instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool

+ GHC.Core.InstEnv: instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool

- GHC.Core.InstEnv: instanceRoughTcs :: ClsInst -> [Maybe Name]

+ GHC.Core.InstEnv: instanceRoughTcs :: ClsInst -> [RoughMatchTc]

- GHC.Core.InstEnv: lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either MsgDoc (ClsInst, [Type])

+ GHC.Core.InstEnv: lookupUniqueInstEnv :: InstEnvs -> Class -> [Type] -> Either SDoc (ClsInst, [Type])

- GHC.Core.InstEnv: mkImportedInstance :: Name -> [Maybe Name] -> Name -> DFunId -> OverlapFlag -> IsOrphan -> ClsInst

+ GHC.Core.InstEnv: mkImportedInstance :: Name -> [RoughMatchTc] -> Name -> DFunId -> OverlapFlag -> IsOrphan -> ClsInst

- GHC.Core.InstEnv: roughMatchTcs :: [Type] -> [Maybe Name]

+ GHC.Core.InstEnv: roughMatchTcs :: [Type] -> [RoughMatchTc]

- GHC.Core.Lint: dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()

+ GHC.Core.Lint: dumpIfSet :: Logger -> DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()

- GHC.Core.Lint: dumpPassResult :: DynFlags -> PrintUnqualified -> Maybe DumpFlag -> SDoc -> SDoc -> CoreProgram -> [CoreRule] -> IO ()

+ GHC.Core.Lint: dumpPassResult :: Logger -> DynFlags -> PrintUnqualified -> Maybe DumpFlag -> SDoc -> SDoc -> CoreProgram -> [CoreRule] -> IO ()

- GHC.Core.Lint: lintAxioms :: DynFlags -> [CoAxiom Branched] -> WarnsAndErrs

+ GHC.Core.Lint: lintAxioms :: Logger -> DynFlags -> SDoc -> [CoAxiom Branched] -> IO ()

- GHC.Core.Lint: lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)

+ GHC.Core.Lint: lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs

- GHC.Core.Lint: lintExpr :: DynFlags -> [Var] -> CoreExpr -> Maybe MsgDoc

+ GHC.Core.Lint: lintExpr :: DynFlags -> [Var] -> CoreExpr -> Maybe (Bag SDoc)

- GHC.Core.Lint: lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()

+ GHC.Core.Lint: lintInteractiveExpr :: SDoc -> HscEnv -> CoreExpr -> IO ()

- GHC.Core.Lint: lintUnfolding :: Bool -> DynFlags -> SrcLoc -> VarSet -> CoreExpr -> Maybe MsgDoc

+ GHC.Core.Lint: lintUnfolding :: Bool -> DynFlags -> SrcLoc -> VarSet -> CoreExpr -> Maybe (Bag SDoc)

- GHC.Core.Multiplicity: Scaled :: Mult -> a -> Scaled a

+ GHC.Core.Multiplicity: Scaled :: !Mult -> a -> Scaled a

- GHC.Core.Opt.ConstantFold: builtinRules :: EnableBignumRules -> [CoreRule]

+ GHC.Core.Opt.ConstantFold: builtinRules :: [CoreRule]

- GHC.Core.Opt.CprAnal: cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram

+ GHC.Core.Opt.CprAnal: cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram

- GHC.Core.Opt.DmdAnal: dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram

+ GHC.Core.Opt.DmdAnal: dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram

- GHC.Core.Opt.FloatOut: floatOutwards :: FloatOutSwitches -> DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram

+ GHC.Core.Opt.FloatOut: floatOutwards :: Logger -> FloatOutSwitches -> DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram

- GHC.Core.Opt.Monad: SimplMode :: [String] -> CompilerPhase -> DynFlags -> Bool -> Bool -> Bool -> Bool -> SimplMode

+ GHC.Core.Opt.Monad: SimplMode :: [String] -> CompilerPhase -> !UnfoldingOpts -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Logger -> DynFlags -> SimplMode

- GHC.Core.Opt.Monad: [sm_case_case] :: SimplMode -> Bool

+ GHC.Core.Opt.Monad: [sm_case_case] :: SimplMode -> !Bool

- GHC.Core.Opt.Monad: [sm_eta_expand] :: SimplMode -> Bool

+ GHC.Core.Opt.Monad: [sm_eta_expand] :: SimplMode -> !Bool

- GHC.Core.Opt.Monad: [sm_inline] :: SimplMode -> Bool

+ GHC.Core.Opt.Monad: [sm_inline] :: SimplMode -> !Bool

- GHC.Core.Opt.Monad: [sm_rules] :: SimplMode -> Bool

+ GHC.Core.Opt.Monad: [sm_rules] :: SimplMode -> !Bool

- GHC.Core.Opt.Simplify.Env: SimplEnv :: SimplMode -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> InScopeSet -> SimplEnv

+ GHC.Core.Opt.Simplify.Env: SimplEnv :: !SimplMode -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> !InScopeSet -> !Int -> SimplEnv

- GHC.Core.Opt.Simplify.Env: [seInScope] :: SimplEnv -> InScopeSet

+ GHC.Core.Opt.Simplify.Env: [seInScope] :: SimplEnv -> !InScopeSet

- GHC.Core.Opt.Simplify.Env: [seMode] :: SimplEnv -> SimplMode

+ GHC.Core.Opt.Simplify.Env: [seMode] :: SimplEnv -> !SimplMode

- GHC.Core.Opt.Simplify.Monad: initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) -> UniqSupply -> Int -> SimplM a -> IO (a, SimplCount)

+ GHC.Core.Opt.Simplify.Monad: initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv) -> Int -> SimplM a -> IO (a, SimplCount)

- GHC.Core.Opt.Simplify.Utils: TickIt :: Tickish Id -> SimplCont -> SimplCont

+ GHC.Core.Opt.Simplify.Utils: TickIt :: CoreTickish -> SimplCont -> SimplCont

- GHC.Core.Opt.Simplify.Utils: abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats -> OutExpr -> SimplM ([OutBind], OutExpr)

+ GHC.Core.Opt.Simplify.Utils: abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats -> OutExpr -> SimplM ([OutBind], OutExpr)

- GHC.Core.Opt.Simplify.Utils: simplEnvForGHCi :: DynFlags -> SimplEnv

+ GHC.Core.Opt.Simplify.Utils: simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv

- GHC.Core.Opt.Specialise: specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> [CoreArg] -> Unfolding -> Unfolding

+ GHC.Core.Opt.Specialise: specUnfolding :: SimpleOpts -> [Var] -> (CoreExpr -> CoreExpr) -> [CoreArg] -> Unfolding -> Unfolding

- GHC.Core.Opt.WorkWrap.Utils: mkWwBodies :: DynFlags -> FamInstEnvs -> VarSet -> Id -> [Demand] -> CprResult -> UniqSM (Maybe WwResult)

+ GHC.Core.Opt.WorkWrap.Utils: mkWwBodies :: DynFlags -> FamInstEnvs -> VarSet -> Id -> [Demand] -> Cpr -> UniqSM (Maybe WwResult)

- GHC.Core.Opt.WorkWrap.Utils: wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)

+ GHC.Core.Opt.WorkWrap.Utils: wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand

- GHC.Core.PatSyn: mkPatSyn :: Name -> Bool -> ([InvisTVBinder], ThetaType) -> ([InvisTVBinder], ThetaType) -> [Type] -> Type -> (Id, Bool) -> Maybe (Id, Bool) -> [FieldLabel] -> PatSyn

+ GHC.Core.PatSyn: mkPatSyn :: Name -> Bool -> ([InvisTVBinder], ThetaType) -> ([InvisTVBinder], ThetaType) -> [Type] -> Type -> PatSynMatcher -> PatSynBuilder -> [FieldLabel] -> PatSyn

- GHC.Core.PatSyn: patSynBuilder :: PatSyn -> Maybe (Id, Bool)

+ GHC.Core.PatSyn: patSynBuilder :: PatSyn -> PatSynBuilder

- GHC.Core.PatSyn: patSynMatcher :: PatSyn -> (Id, Bool)

+ GHC.Core.PatSyn: patSynMatcher :: PatSyn -> PatSynMatcher

- GHC.Core.Ppr: pprCoreAlt :: OutputableBndr a => (AltCon, [a], Expr a) -> SDoc

+ GHC.Core.Ppr: pprCoreAlt :: OutputableBndr a => Alt a -> SDoc

- GHC.Core.SimpleOpt: exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr, [Tickish Id])

+ GHC.Core.SimpleOpt: exprIsLambda_maybe :: InScopeEnv -> CoreExpr -> Maybe (Var, CoreExpr, [CoreTickish])

- GHC.Core.SimpleOpt: simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr

+ GHC.Core.SimpleOpt: simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr

- GHC.Core.SimpleOpt: simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr

+ GHC.Core.SimpleOpt: simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr

- GHC.Core.SimpleOpt: simpleOptPgm :: DynFlags -> Module -> CoreProgram -> [CoreRule] -> IO (CoreProgram, [CoreRule])

+ GHC.Core.SimpleOpt: simpleOptPgm :: SimpleOpts -> Module -> CoreProgram -> [CoreRule] -> (CoreProgram, [CoreRule], CoreProgram)

- GHC.Core.Subst: substTickish :: Subst -> Tickish Id -> Tickish Id

+ GHC.Core.Subst: substTickish :: Subst -> CoreTickish -> CoreTickish

- GHC.Core.TyCo.Rep: CoercionHole :: CoVar -> BlockSubstFlag -> IORef (Maybe Coercion) -> CoercionHole

+ GHC.Core.TyCo.Rep: CoercionHole :: CoVar -> IORef (Maybe Coercion) -> CoercionHole

- GHC.Core.TyCo.Rep: Scaled :: Mult -> a -> Scaled a

+ GHC.Core.TyCo.Rep: Scaled :: !Mult -> a -> Scaled a

- GHC.Core.TyCon: mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> Type -> Bool -> Bool -> TyCon

+ GHC.Core.TyCon: mkSynonymTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon

- GHC.Core.Type: splitFunTy :: Type -> (Type, Type, Type)

+ GHC.Core.Type: splitFunTy :: Type -> (Mult, Type, Type)

- GHC.Core.Type: splitFunTy_maybe :: Type -> Maybe (Type, Type, Type)

+ GHC.Core.Type: splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type)

- GHC.Core.Unfold: callSiteInline :: DynFlags -> Id -> Bool -> Bool -> [ArgSummary] -> CallCtxt -> Maybe CoreExpr

+ GHC.Core.Unfold: callSiteInline :: Logger -> DynFlags -> Int -> Id -> Bool -> Bool -> [ArgSummary] -> CallCtxt -> Maybe CoreExpr

- GHC.Core.Unfold: certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding

+ GHC.Core.Unfold: certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding

- GHC.Core.Unfold: couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool

+ GHC.Core.Unfold: couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool

- GHC.Core.Unfold: smallEnoughToInline :: DynFlags -> Unfolding -> Bool

+ GHC.Core.Unfold: smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool

- GHC.Core.Unify: MaybeApart :: a -> UnifyResultM a

+ GHC.Core.Unify: MaybeApart :: MaybeApartReason -> a -> UnifyResultM a

- GHC.Core.Unify: instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool

+ GHC.Core.Unify: instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool

- GHC.Core.Unify: roughMatchTcs :: [Type] -> [Maybe Name]

+ GHC.Core.Unify: roughMatchTcs :: [Type] -> [RoughMatchTc]

- GHC.Core.Unify: tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst -> Type -> Type -> Maybe TCvSubst

+ GHC.Core.Unify: tcMatchTyX_BM :: BindFun -> TCvSubst -> Type -> Type -> Maybe TCvSubst

- GHC.Core.Unify: tcUnifyTyKis :: (TyCoVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst

+ GHC.Core.Unify: tcUnifyTyKis :: BindFun -> [Type] -> [Type] -> Maybe TCvSubst

- GHC.Core.Unify: tcUnifyTys :: (TyCoVar -> BindFlag) -> [Type] -> [Type] -> Maybe TCvSubst

+ GHC.Core.Unify: tcUnifyTys :: BindFun -> [Type] -> [Type] -> Maybe TCvSubst

- GHC.Core.Unify: tcUnifyTysFG :: (TyVar -> BindFlag) -> [Type] -> [Type] -> UnifyResult

+ GHC.Core.Unify: tcUnifyTysFG :: BindFun -> [Type] -> [Type] -> UnifyResult

- GHC.Core.Utils: addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]

+ GHC.Core.Utils: addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]

- GHC.Core.Utils: cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool

+ GHC.Core.Utils: cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool

- GHC.Core.Utils: filterAlts :: TyCon -> [Type] -> [AltCon] -> [(AltCon, [Var], a)] -> ([AltCon], [(AltCon, [Var], a)])

+ GHC.Core.Utils: filterAlts :: TyCon -> [Type] -> [AltCon] -> [Alt b] -> ([AltCon], [Alt b])

- GHC.Core.Utils: findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)

+ GHC.Core.Utils: findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)

- GHC.Core.Utils: findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)

+ GHC.Core.Utils: findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))

- GHC.Core.Utils: isDefaultAlt :: (AltCon, a, b) -> Bool

+ GHC.Core.Utils: isDefaultAlt :: Alt b -> Bool

- GHC.Core.Utils: mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]

+ GHC.Core.Utils: mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]

- GHC.Core.Utils: mkTick :: Tickish Id -> CoreExpr -> CoreExpr

+ GHC.Core.Utils: mkTick :: CoreTickish -> CoreExpr -> CoreExpr

- GHC.Core.Utils: mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr

+ GHC.Core.Utils: mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr

- GHC.Core.Utils: mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr

+ GHC.Core.Utils: mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr

- GHC.Core.Utils: stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b

+ GHC.Core.Utils: stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b

- GHC.Core.Utils: stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]

+ GHC.Core.Utils: stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]

- GHC.Core.Utils: stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)

+ GHC.Core.Utils: stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)

- GHC.Core.Utils: stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b

+ GHC.Core.Utils: stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b

- GHC.Core.Utils: stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]

+ GHC.Core.Utils: stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]

- GHC.Core.Utils: tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr

+ GHC.Core.Utils: tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr

- GHC.CoreToIface: toIfaceAlt :: (AltCon, [Var], CoreExpr) -> (IfaceConAlt, [FastString], IfaceExpr)

+ GHC.CoreToIface: toIfaceAlt :: CoreAlt -> IfaceAlt

- GHC.CoreToIface: toIfaceTickish :: Tickish Id -> Maybe IfaceTickish

+ GHC.CoreToIface: toIfaceTickish :: CoreTickish -> Maybe IfaceTickish

- GHC.CoreToStg: coreToStg :: DynFlags -> Module -> CoreProgram -> ([StgTopBinding], CollectedCCs)

+ GHC.CoreToStg: coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)

- GHC.Data.BooleanFormula: type LBooleanFormula a = Located (BooleanFormula a)

+ GHC.Data.BooleanFormula: type LBooleanFormula a = LocatedL (BooleanFormula a)

- GHC.Data.FastMutInt: newFastMutInt :: IO FastMutInt

+ GHC.Data.FastMutInt: newFastMutInt :: Int -> IO FastMutInt

- GHC.Data.Stream: Stream :: m (Either b (a, Stream m a b)) -> Stream m a b

+ GHC.Data.Stream: Stream :: (forall r' r. (a -> m r') -> (b -> StreamS m r' r) -> StreamS m r' r) -> Stream m a b

- GHC.Data.Stream: consume :: Monad m => Stream m a b -> (a -> m ()) -> m b

+ GHC.Data.Stream: consume :: (Monad m, Monad n) => Stream m a b -> (forall a. m a -> n a) -> (a -> n ()) -> n b

- GHC.Data.Stream: liftIO :: IO a -> Stream IO b a

+ GHC.Data.Stream: liftIO :: MonadIO m => IO a -> m a

- GHC.Data.Stream: mapAccumL_ :: Monad m => (c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)

+ GHC.Data.Stream: mapAccumL_ :: forall m a b c r. Monad m => (c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)

- GHC.Driver.CodeOutput: codeOutput :: DynFlags -> Module -> FilePath -> ModLocation -> ForeignStubs -> [(ForeignSrcLang, FilePath)] -> [UnitId] -> Stream IO RawCmmGroup a -> IO (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)

+ GHC.Driver.CodeOutput: codeOutput :: Logger -> TmpFs -> DynFlags -> UnitState -> Module -> FilePath -> ModLocation -> (a -> ForeignStubs) -> [(ForeignSrcLang, FilePath)] -> [UnitId] -> Stream IO RawCmmGroup a -> IO (FilePath, (Bool, Maybe FilePath), [(ForeignSrcLang, FilePath)], a)

- GHC.Driver.CodeOutput: outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, Maybe FilePath)

+ GHC.Driver.CodeOutput: outputForeignStubs :: Logger -> TmpFs -> DynFlags -> UnitState -> Module -> ModLocation -> ForeignStubs -> IO (Bool, Maybe FilePath)

- GHC.Driver.CodeOutput: profilingInitCode :: Module -> CollectedCCs -> SDoc

+ GHC.Driver.CodeOutput: profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub

- GHC.Driver.Hooks: dsForeignsHook :: Hooks -> Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))

+ GHC.Driver.Hooks: dsForeignsHook :: Hooks -> Maybe DsForeignsHook

- GHC.Driver.Hooks: runPhaseHook :: Hooks -> Maybe (PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath))

+ GHC.Driver.Hooks: runPhaseHook :: Hooks -> Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath))

- GHC.Driver.Hooks: stgToCmmHook :: Hooks -> Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)

+ GHC.Driver.Hooks: stgToCmmHook :: Hooks -> Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos))

- GHC.Driver.Main: HscRecomp :: CgGuts -> !ModLocation -> !PartialModIface -> !Maybe Fingerprint -> !DynFlags -> HscStatus

+ GHC.Driver.Main: HscRecomp :: CgGuts -> !ModLocation -> !ModDetails -> !PartialModIface -> !Maybe Fingerprint -> HscStatus

- GHC.Driver.Main: doCodeGen :: HscEnv -> Module -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo -> IO (Stream IO CmmGroupSRTs CgInfos)

+ GHC.Driver.Main: doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [StgTopBinding] -> HpcInfo -> IO (Stream IO CmmGroupSRTs CgInfos)

- GHC.Driver.Main: hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()

+ GHC.Driver.Main: hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)

- GHC.Driver.Main: hscIncrementalCompile :: Bool -> Maybe TcGblEnv -> Maybe Messager -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> (Int, Int) -> IO (HscStatus, DynFlags)

+ GHC.Driver.Main: hscIncrementalCompile :: Bool -> Maybe TcGblEnv -> Maybe Messager -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> (Int, Int) -> IO (HscStatus, HscEnv)

- GHC.Driver.Main: hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()

+ GHC.Driver.Main: hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()

- GHC.Driver.Main: hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)

+ GHC.Driver.Main: hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)

- GHC.Driver.Main: hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]

+ GHC.Driver.Main: hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]

- GHC.Driver.Main: ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a

+ GHC.Driver.Main: ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a

- GHC.Driver.Main: showModuleIndex :: (Int, Int) -> String

+ GHC.Driver.Main: showModuleIndex :: (Int, Int) -> SDoc

- GHC.Driver.Main: type Messager = HscEnv -> (Int, Int) -> RecompileRequired -> ModSummary -> IO ()

+ GHC.Driver.Main: type Messager = HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> IO ()

- GHC.Driver.Make: cyclicModuleErr :: [ModSummary] -> SDoc

+ GHC.Driver.Make: cyclicModuleErr :: [ModuleGraphNode] -> SDoc

- GHC.Driver.Make: downsweep :: HscEnv -> [ModSummary] -> [ModuleName] -> Bool -> IO [Either ErrorMessages ModSummary]

+ GHC.Driver.Make: downsweep :: HscEnv -> [ExtendedModSummary] -> [ModuleName] -> Bool -> IO [Either ErrorMessages ExtendedModSummary]

- GHC.Driver.Make: moduleGraphNodes :: Bool -> [ModSummary] -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode)

+ GHC.Driver.Make: moduleGraphNodes :: Bool -> [ModuleGraphNode] -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)

- GHC.Driver.Make: noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg

+ GHC.Driver.Make: noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc

- GHC.Driver.Make: summariseModule :: HscEnv -> NodeMap ModSummary -> IsBootInterface -> Located ModuleName -> Bool -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO (Maybe (Either ErrorMessages ModSummary))

+ GHC.Driver.Make: summariseModule :: HscEnv -> ModNodeMap ExtendedModSummary -> IsBootInterface -> Located ModuleName -> Bool -> Maybe (StringBuffer, UTCTime) -> [ModuleName] -> IO (Maybe (Either ErrorMessages ExtendedModSummary))

- GHC.Driver.Make: topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]

+ GHC.Driver.Make: topSortModuleGraph :: Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModuleGraphNode]

- GHC.Driver.Make: type SummaryNode = Node Int ModSummary

+ GHC.Driver.Make: type SummaryNode = Node Int ModuleGraphNode

- GHC.Driver.Monad: class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m

+ GHC.Driver.Monad: class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m) => GhcMonad m

- GHC.Driver.Pipeline: PipeState :: HscEnv -> Maybe ModLocation -> [FilePath] -> Maybe ModIface -> PipeState

+ GHC.Driver.Pipeline: PipeState :: HscEnv -> Maybe ModLocation -> [FilePath] -> Maybe (ModIface, ModDetails) -> PipeState

- GHC.Driver.Pipeline: [iface] :: PipeState -> Maybe ModIface

+ GHC.Driver.Pipeline: [iface] :: PipeState -> Maybe (ModIface, ModDetails)

- GHC.Driver.Pipeline: checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool

+ GHC.Driver.Pipeline: checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool

- GHC.Driver.Pipeline: doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()

+ GHC.Driver.Pipeline: doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()

- GHC.Driver.Pipeline: getOutputFilename :: Phase -> PipelineOutput -> String -> DynFlags -> Phase -> Maybe ModLocation -> IO FilePath

+ GHC.Driver.Pipeline: getOutputFilename :: Logger -> TmpFs -> Phase -> PipelineOutput -> String -> DynFlags -> Phase -> Maybe ModLocation -> IO FilePath

- GHC.Driver.Pipeline: hscPostBackendPhase :: HscSource -> HscTarget -> Phase

+ GHC.Driver.Pipeline: hscPostBackendPhase :: HscSource -> Backend -> Phase

- GHC.Driver.Pipeline: link :: GhcLink -> DynFlags -> Bool -> HomePackageTable -> IO SuccessFlag

+ GHC.Driver.Pipeline: link :: GhcLink -> Logger -> TmpFs -> Hooks -> DynFlags -> UnitEnv -> Bool -> HomePackageTable -> IO SuccessFlag

- GHC.Driver.Pipeline: linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool

+ GHC.Driver.Pipeline: linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool

- GHC.Driver.Pipeline: runPhase :: PhasePlus -> FilePath -> DynFlags -> CompPipeline (PhasePlus, FilePath)

+ GHC.Driver.Pipeline: runPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)

- GHC.Driver.Pipeline.Monad: PipeState :: HscEnv -> Maybe ModLocation -> [FilePath] -> Maybe ModIface -> PipeState

+ GHC.Driver.Pipeline.Monad: PipeState :: HscEnv -> Maybe ModLocation -> [FilePath] -> Maybe (ModIface, ModDetails) -> PipeState

- GHC.Driver.Pipeline.Monad: [iface] :: PipeState -> Maybe ModIface

+ GHC.Driver.Pipeline.Monad: [iface] :: PipeState -> Maybe (ModIface, ModDetails)

- GHC.Driver.Pipeline.Monad: pipeStateModIface :: PipeState -> Maybe ModIface

+ GHC.Driver.Pipeline.Monad: pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails)

- GHC.Driver.Pipeline.Monad: setIface :: ModIface -> CompPipeline ()

+ GHC.Driver.Pipeline.Monad: setIface :: ModIface -> ModDetails -> CompPipeline ()

- GHC.Driver.Plugins: Plugin :: CorePlugin -> TcPlugin -> HoleFitPlugin -> ([CommandLineOption] -> DynFlags -> IO DynFlags) -> ([CommandLineOption] -> IO PluginRecompile) -> ([CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule) -> ([CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)) -> ([CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv) -> ([CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)) -> (forall lcl. [CommandLineOption] -> ModIface -> IfM lcl ModIface) -> Plugin

+ GHC.Driver.Plugins: Plugin :: CorePlugin -> TcPlugin -> HoleFitPlugin -> ([CommandLineOption] -> HscEnv -> IO HscEnv) -> ([CommandLineOption] -> IO PluginRecompile) -> ([CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule) -> ([CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)) -> ([CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv) -> ([CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)) -> (forall lcl. [CommandLineOption] -> ModIface -> IfM lcl ModIface) -> Plugin

- GHC.Driver.Plugins: mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a]

+ GHC.Driver.Plugins: mapPlugins :: HscEnv -> (Plugin -> [CommandLineOption] -> a) -> [a]

- GHC.Driver.Plugins: plugins :: DynFlags -> [PluginWithArgs]

+ GHC.Driver.Plugins: plugins :: HscEnv -> [PluginWithArgs]

- GHC.Driver.Plugins: withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a

+ GHC.Driver.Plugins: withPlugins :: Monad m => HscEnv -> PluginOperation m a -> a -> m a

- GHC.Driver.Plugins: withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()

+ GHC.Driver.Plugins: withPlugins_ :: Monad m => HscEnv -> ConstPluginOperation m a -> a -> m ()

- GHC.Driver.Session: DynFlags :: GhcMode -> GhcLink -> HscTarget -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> PlatformConstants -> [(String, String)] -> LlvmConfig -> Int -> Int -> Int -> Int -> Int -> Maybe String -> Maybe String -> [Int] -> Maybe Int -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> Int -> Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> Module -> Maybe String -> IntWithInf -> IntWithInf -> UnitId -> Maybe IndefUnitId -> [(ModuleName, Module)] -> Set Way -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> IORef Bool -> String -> String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> Maybe FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [LoadedPlugin] -> [StaticPlugin] -> Hooks -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> Maybe [UnitDatabase UnitId] -> UnitState -> IORef FilesToClean -> IORef (Map FilePath FilePath) -> IORef Int -> IORef (Set FilePath) -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> Int -> Int -> Int -> Int -> Int -> Bool -> Int -> Int -> LogAction -> DumpAction -> TraceAction -> FlushOut -> FlushErr -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> Maybe String -> IORef (ModuleEnv Int) -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Int -> Int -> CfgWeights -> DynFlags

+ GHC.Driver.Session: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> LlvmConfig -> Int -> Int -> Int -> Int -> Int -> Maybe String -> Maybe String -> [Int] -> Maybe Int -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> Maybe Int -> Maybe Int -> Int -> Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> IORef Bool -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> Maybe FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> FlushErr -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> IORef (ModuleEnv Int) -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Word -> Int -> Weights -> DynFlags

- GHC.Driver.Session: PlatformConstants :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Bool -> Int -> Integer -> Integer -> Integer -> PlatformConstants

+ GHC.Driver.Session: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> PlatformConstants

- GHC.Driver.Session: PlatformMisc :: String -> Bool -> Bool -> String -> Bool -> Bool -> Bool -> Bool -> String -> PlatformMisc

+ GHC.Driver.Session: PlatformMisc :: String -> Bool -> Bool -> String -> Bool -> Bool -> String -> PlatformMisc

- GHC.Driver.Session: Settings :: {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> PlatformConstants -> [(String, String)] -> Settings

+ GHC.Driver.Session: Settings :: {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> Settings

- GHC.Driver.Session: [initialUnique] :: DynFlags -> Int

+ GHC.Driver.Session: [initialUnique] :: DynFlags -> Word

- GHC.Driver.Session: [pc_AP_STACK_SPLIM] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_AP_STACK_SPLIM] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_BITMAP_BITS_SHIFT] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_BITMAP_BITS_SHIFT] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_BLOCKS_PER_MBLOCK] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_BLOCKS_PER_MBLOCK] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_BLOCK_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_BLOCK_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_CINT_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_CINT_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_CLONG_LONG_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_CLONG_LONG_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_CLONG_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_CLONG_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_CONTROL_GROUP_CONST_291] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_CONTROL_GROUP_CONST_291] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_ILDV_CREATE_MASK] :: PlatformConstants -> Integer

+ GHC.Driver.Session: [pc_ILDV_CREATE_MASK] :: PlatformConstants -> !Integer

- GHC.Driver.Session: [pc_ILDV_STATE_CREATE] :: PlatformConstants -> Integer

+ GHC.Driver.Session: [pc_ILDV_STATE_CREATE] :: PlatformConstants -> !Integer

- GHC.Driver.Session: [pc_ILDV_STATE_USE] :: PlatformConstants -> Integer

+ GHC.Driver.Session: [pc_ILDV_STATE_USE] :: PlatformConstants -> !Integer

- GHC.Driver.Session: [pc_LDV_SHIFT] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_LDV_SHIFT] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_CHARLIKE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_CHARLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Double_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Double_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Float_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Float_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_INTLIKE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_INTLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Long_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Long_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Real_Double_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Real_Double_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Real_Float_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Real_Float_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Real_Long_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Real_Long_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Real_Vanilla_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Real_Vanilla_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Real_XMM_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Real_XMM_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_SPEC_AP_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_SPEC_AP_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_SPEC_SELECTEE_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_SPEC_SELECTEE_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_Vanilla_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_Vanilla_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MAX_XMM_REG] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MAX_XMM_REG] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MIN_CHARLIKE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MIN_CHARLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MIN_INTLIKE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MIN_INTLIKE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MIN_PAYLOAD_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MIN_PAYLOAD_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_MUT_ARR_PTRS_CARD_BITS] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_MUT_ARR_PTRS_CARD_BITS] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_Capability_r] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_Capability_r] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_CostCentreStack_mem_alloc] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_CostCentreStack_mem_alloc] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_CostCentreStack_scc_count] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_CostCentreStack_scc_count] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgArrBytes_bytes] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgArrBytes_bytes] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgEntCounter_allocd] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgEntCounter_allocd] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgEntCounter_allocs] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgEntCounter_allocs] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgEntCounter_entry_count] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgEntCounter_entry_count] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgEntCounter_link] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgEntCounter_link] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgEntCounter_registeredp] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgEntCounter_registeredp] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgFunInfoExtraFwd_arity] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgFunInfoExtraFwd_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgFunInfoExtraRev_arity] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgFunInfoExtraRev_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgHeader_ccs] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgHeader_ccs] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgHeader_ldvw] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgHeader_ldvw] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgMutArrPtrs_ptrs] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgMutArrPtrs_ptrs] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgMutArrPtrs_size] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgMutArrPtrs_size] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rCCCS] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rCCCS] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rCurrentNursery] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rCurrentNursery] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rCurrentTSO] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rCurrentTSO] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD2] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD2] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD3] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD3] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD4] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD4] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD5] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD5] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD6] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rD6] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF2] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF2] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF3] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF3] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF4] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF4] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF5] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF5] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF6] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rF6] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rHpAlloc] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rHpAlloc] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rHpLim] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rHpLim] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rHp] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rHp] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rL1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rL1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR10] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR10] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR2] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR2] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR3] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR3] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR4] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR4] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR5] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR5] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR6] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR6] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR7] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR7] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR8] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR8] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR9] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rR9] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rSpLim] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rSpLim] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rSp] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rSp] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM2] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM3] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM4] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM5] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM6] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rXMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM2] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM3] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM4] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM5] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM6] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rYMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM2] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM2] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM3] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM3] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM4] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM4] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM5] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM5] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM6] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgRegTable_rZMM6] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgSmallMutArrPtrs_ptrs] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgSmallMutArrPtrs_ptrs] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgStack_sp] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgStack_sp] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgStack_stack] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgStack_stack] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgTSO_alloc_limit] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgTSO_alloc_limit] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgTSO_cccs] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgTSO_cccs] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgTSO_stackobj] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgTSO_stackobj] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_StgUpdateFrame_updatee] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_StgUpdateFrame_updatee] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_bdescr_blocks] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_bdescr_blocks] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_bdescr_flags] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_bdescr_flags] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_bdescr_free] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_bdescr_free] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_bdescr_start] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_bdescr_start] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_stgEagerBlackholeInfo] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_stgEagerBlackholeInfo] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_stgGCEnter1] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_stgGCEnter1] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_OFFSET_stgGCFun] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_OFFSET_stgGCFun] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_PROF_HDR_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_PROF_HDR_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_REP_CostCentreStack_mem_alloc] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_REP_CostCentreStack_mem_alloc] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_REP_CostCentreStack_scc_count] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_REP_CostCentreStack_scc_count] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_REP_StgEntCounter_allocd] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_REP_StgEntCounter_allocd] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_REP_StgEntCounter_allocs] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_REP_StgEntCounter_allocs] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_REP_StgFunInfoExtraFwd_arity] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_REP_StgFunInfoExtraFwd_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_REP_StgFunInfoExtraRev_arity] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_REP_StgFunInfoExtraRev_arity] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_RESERVED_C_STACK_BYTES] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_RESERVED_C_STACK_BYTES] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_RESERVED_STACK_WORDS] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_RESERVED_STACK_WORDS] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_CostCentreStack] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_CostCentreStack] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_StgArrBytes_NoHdr] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_StgArrBytes_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_StgFunInfoExtraRev] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_StgFunInfoExtraRev] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_StgMutArrPtrs_NoHdr] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_StgMutArrPtrs_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_StgSMPThunkHeader] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_StgSMPThunkHeader] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_StgSmallMutArrPtrs_NoHdr] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_StgSmallMutArrPtrs_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_SIZEOF_StgUpdateFrame_NoHdr] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_SIZEOF_StgUpdateFrame_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_STD_HDR_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_STD_HDR_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_TAG_BITS] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_TAG_BITS] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_TICKY_BIN_COUNT] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_TICKY_BIN_COUNT] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: [pc_WORD_SIZE] :: PlatformConstants -> Int

+ GHC.Driver.Session: [pc_WORD_SIZE] :: PlatformConstants -> {-# UNPACK #-} !Int

- GHC.Driver.Session: isSse2Enabled :: DynFlags -> Bool

+ GHC.Driver.Session: isSse2Enabled :: Platform -> Bool

- GHC.Driver.Session: isSseEnabled :: DynFlags -> Bool

+ GHC.Driver.Session: isSseEnabled :: Platform -> Bool

- GHC.Driver.Session: supportedLanguagesAndExtensions :: PlatformMini -> [String]

+ GHC.Driver.Session: supportedLanguagesAndExtensions :: ArchOS -> [String]

- GHC.Driver.Session: versionedAppDir :: String -> PlatformMini -> MaybeT IO FilePath

+ GHC.Driver.Session: versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath

- GHC.Driver.Session: versionedFilePath :: PlatformMini -> FilePath

+ GHC.Driver.Session: versionedFilePath :: ArchOS -> FilePath

- GHC.Hs: HsModule :: LayoutInfo -> Maybe (Located ModuleName) -> Maybe (Located [LIE GhcPs]) -> [LImportDecl GhcPs] -> [LHsDecl GhcPs] -> Maybe (Located WarningTxt) -> Maybe LHsDocString -> HsModule

+ GHC.Hs: HsModule :: EpAnn AnnsModule -> LayoutInfo -> Maybe (LocatedA ModuleName) -> Maybe (LocatedL [LIE GhcPs]) -> [LImportDecl GhcPs] -> [LHsDecl GhcPs] -> Maybe (LocatedP WarningTxt) -> Maybe LHsDocString -> HsModule

- GHC.Hs: [hsmodDeprecMessage] :: HsModule -> Maybe (Located WarningTxt)

+ GHC.Hs: [hsmodDeprecMessage] :: HsModule -> Maybe (LocatedP WarningTxt)

- GHC.Hs: [hsmodExports] :: HsModule -> Maybe (Located [LIE GhcPs])

+ GHC.Hs: [hsmodExports] :: HsModule -> Maybe (LocatedL [LIE GhcPs])

- GHC.Hs: [hsmodName] :: HsModule -> Maybe (Located ModuleName)

+ GHC.Hs: [hsmodName] :: HsModule -> Maybe (LocatedA ModuleName)

- GHC.Hs.Binds: emptyLHsBinds :: LHsBindsLR idL idR

+ GHC.Hs.Binds: emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR

- GHC.Hs.Binds: isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool

+ GHC.Hs.Binds: isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool

- GHC.Hs.Binds: pprMinimalSig :: OutputableBndr name => LBooleanFormula (Located name) -> SDoc

+ GHC.Hs.Binds: pprMinimalSig :: OutputableBndr name => LBooleanFormula (GenLocated l name) -> SDoc

- GHC.Hs.Binds: ppr_sig :: OutputableBndrId p => Sig (GhcPass p) -> SDoc

+ GHC.Hs.Binds: ppr_sig :: forall p. OutputableBndrId p => Sig (GhcPass p) -> SDoc

- GHC.Hs.Decls: AnyclassStrategy :: DerivStrategy pass

+ GHC.Hs.Decls: AnyclassStrategy :: XAnyClassStrategy pass -> DerivStrategy pass

- GHC.Hs.Decls: ClassDecl :: XClassDecl pass -> LHsContext pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl] -> TyClDecl pass

+ GHC.Hs.Decls: ClassDecl :: XClassDecl pass -> Maybe (LHsContext pass) -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl pass] -> TyClDecl pass

- GHC.Hs.Decls: ClsInstDecl :: XCClsInstDecl pass -> LHsSigType pass -> LHsBinds pass -> [LSig pass] -> [LTyFamInstDecl pass] -> [LDataFamInstDecl pass] -> Maybe (Located OverlapMode) -> ClsInstDecl pass

+ GHC.Hs.Decls: ClsInstDecl :: XCClsInstDecl pass -> LHsSigType pass -> LHsBinds pass -> [LSig pass] -> [LTyFamInstDecl pass] -> [LDataFamInstDecl pass] -> Maybe (XRec pass OverlapMode) -> ClsInstDecl pass

- GHC.Hs.Decls: ConDeclGADT :: XConDeclGADT pass -> [Located (IdP pass)] -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> LHsType pass -> Maybe LHsDocString -> ConDecl pass

+ GHC.Hs.Decls: ConDeclGADT :: XConDeclGADT pass -> [LIdP pass] -> XRec pass (HsOuterSigTyVarBndrs pass) -> Maybe (LHsContext pass) -> HsConDeclGADTDetails pass -> LHsType pass -> Maybe LHsDocString -> ConDecl pass

- GHC.Hs.Decls: ConDeclH98 :: XConDeclH98 pass -> Located (IdP pass) -> Located Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclDetails pass -> Maybe LHsDocString -> ConDecl pass

+ GHC.Hs.Decls: ConDeclH98 :: XConDeclH98 pass -> LIdP pass -> Bool -> [LHsTyVarBndr Specificity pass] -> Maybe (LHsContext pass) -> HsConDeclH98Details pass -> Maybe LHsDocString -> ConDecl pass

- GHC.Hs.Decls: DataDecl :: XDataDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> HsDataDefn pass -> TyClDecl pass

+ GHC.Hs.Decls: DataDecl :: XDataDecl pass -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> HsDataDefn pass -> TyClDecl pass

- GHC.Hs.Decls: DataFamInstDecl :: FamInstEqn pass (HsDataDefn pass) -> DataFamInstDecl pass

+ GHC.Hs.Decls: DataFamInstDecl :: FamEqn pass (HsDataDefn pass) -> DataFamInstDecl pass

- GHC.Hs.Decls: DerivDecl :: XCDerivDecl pass -> LHsSigWcType pass -> Maybe (LDerivStrategy pass) -> Maybe (Located OverlapMode) -> DerivDecl pass

+ GHC.Hs.Decls: DerivDecl :: XCDerivDecl pass -> LHsSigWcType pass -> Maybe (LDerivStrategy pass) -> Maybe (XRec pass OverlapMode) -> DerivDecl pass

- GHC.Hs.Decls: FamEqn :: XCFamEqn pass rhs -> Located (IdP pass) -> Maybe [LHsTyVarBndr () pass] -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs

+ GHC.Hs.Decls: FamEqn :: XCFamEqn pass rhs -> LIdP pass -> HsOuterFamEqnTyVarBndrs pass -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs

- GHC.Hs.Decls: FamilyDecl :: XCFamilyDecl pass -> FamilyInfo pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> LFamilyResultSig pass -> Maybe (LInjectivityAnn pass) -> FamilyDecl pass

+ GHC.Hs.Decls: FamilyDecl :: XCFamilyDecl pass -> FamilyInfo pass -> TopLevelFlag -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> LFamilyResultSig pass -> Maybe (LInjectivityAnn pass) -> FamilyDecl pass

- GHC.Hs.Decls: ForeignExport :: XForeignExport pass -> Located (IdP pass) -> LHsSigType pass -> ForeignExport -> ForeignDecl pass

+ GHC.Hs.Decls: ForeignExport :: XForeignExport pass -> LIdP pass -> LHsSigType pass -> ForeignExport -> ForeignDecl pass

- GHC.Hs.Decls: ForeignImport :: XForeignImport pass -> Located (IdP pass) -> LHsSigType pass -> ForeignImport -> ForeignDecl pass

+ GHC.Hs.Decls: ForeignImport :: XForeignImport pass -> LIdP pass -> LHsSigType pass -> ForeignImport -> ForeignDecl pass

- GHC.Hs.Decls: HsAnnotation :: XHsAnnotation pass -> SourceText -> AnnProvenance (IdP pass) -> Located (HsExpr pass) -> AnnDecl pass

+ GHC.Hs.Decls: HsAnnotation :: XHsAnnotation pass -> SourceText -> AnnProvenance pass -> XRec pass (HsExpr pass) -> AnnDecl pass

- GHC.Hs.Decls: HsDataDefn :: XCHsDataDefn pass -> NewOrData -> LHsContext pass -> Maybe (Located CType) -> Maybe (LHsKind pass) -> [LConDecl pass] -> HsDeriving pass -> HsDataDefn pass

+ GHC.Hs.Decls: HsDataDefn :: XCHsDataDefn pass -> NewOrData -> Maybe (LHsContext pass) -> Maybe (XRec pass CType) -> Maybe (LHsKind pass) -> [LConDecl pass] -> HsDeriving pass -> HsDataDefn pass

- GHC.Hs.Decls: HsDerivingClause :: XCHsDerivingClause pass -> Maybe (LDerivStrategy pass) -> Located [LHsSigType pass] -> HsDerivingClause pass

+ GHC.Hs.Decls: HsDerivingClause :: XCHsDerivingClause pass -> Maybe (LDerivStrategy pass) -> LDerivClauseTys pass -> HsDerivingClause pass

- GHC.Hs.Decls: HsGroup :: XCHsGroup p -> HsValBinds p -> [LSpliceDecl p] -> [TyClGroup p] -> [LDerivDecl p] -> [LFixitySig p] -> [LDefaultDecl p] -> [LForeignDecl p] -> [LWarnDecls p] -> [LAnnDecl p] -> [LRuleDecls p] -> [LDocDecl] -> HsGroup p

+ GHC.Hs.Decls: HsGroup :: XCHsGroup p -> HsValBinds p -> [LSpliceDecl p] -> [TyClGroup p] -> [LDerivDecl p] -> [LFixitySig p] -> [LDefaultDecl p] -> [LForeignDecl p] -> [LWarnDecls p] -> [LAnnDecl p] -> [LRuleDecls p] -> [LDocDecl p] -> HsGroup p

- GHC.Hs.Decls: HsRule :: XHsRule pass -> Located (SourceText, RuleName) -> Activation -> Maybe [LHsTyVarBndr () (NoGhcTc pass)] -> [LRuleBndr pass] -> Located (HsExpr pass) -> Located (HsExpr pass) -> RuleDecl pass

+ GHC.Hs.Decls: HsRule :: XHsRule pass -> XRec pass (SourceText, RuleName) -> Activation -> Maybe [LHsTyVarBndr () (NoGhcTc pass)] -> [LRuleBndr pass] -> XRec pass (HsExpr pass) -> XRec pass (HsExpr pass) -> RuleDecl pass

- GHC.Hs.Decls: InjectivityAnn :: Located (IdP pass) -> [Located (IdP pass)] -> InjectivityAnn pass

+ GHC.Hs.Decls: InjectivityAnn :: XCInjectivityAnn pass -> LIdP pass -> [LIdP pass] -> InjectivityAnn pass

- GHC.Hs.Decls: ModuleAnnProvenance :: AnnProvenance name

+ GHC.Hs.Decls: ModuleAnnProvenance :: AnnProvenance pass

- GHC.Hs.Decls: NewtypeStrategy :: DerivStrategy pass

+ GHC.Hs.Decls: NewtypeStrategy :: XNewtypeStrategy pass -> DerivStrategy pass

- GHC.Hs.Decls: RoleAnnotDecl :: XCRoleAnnotDecl pass -> Located (IdP pass) -> [Located (Maybe Role)] -> RoleAnnotDecl pass

+ GHC.Hs.Decls: RoleAnnotDecl :: XCRoleAnnotDecl pass -> LIdP pass -> [XRec pass (Maybe Role)] -> RoleAnnotDecl pass

- GHC.Hs.Decls: RuleBndr :: XCRuleBndr pass -> Located (IdP pass) -> RuleBndr pass

+ GHC.Hs.Decls: RuleBndr :: XCRuleBndr pass -> LIdP pass -> RuleBndr pass

- GHC.Hs.Decls: RuleBndrSig :: XRuleBndrSig pass -> Located (IdP pass) -> HsPatSigType pass -> RuleBndr pass

+ GHC.Hs.Decls: RuleBndrSig :: XRuleBndrSig pass -> LIdP pass -> HsPatSigType pass -> RuleBndr pass

- GHC.Hs.Decls: SpliceDecl :: XSpliceDecl p -> Located (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p

+ GHC.Hs.Decls: SpliceDecl :: XSpliceDecl p -> XRec p (HsSplice p) -> SpliceExplicitFlag -> SpliceDecl p

- GHC.Hs.Decls: StandaloneKindSig :: XStandaloneKindSig pass -> Located (IdP pass) -> LHsSigType pass -> StandaloneKindSig pass

+ GHC.Hs.Decls: StandaloneKindSig :: XStandaloneKindSig pass -> LIdP pass -> LHsSigType pass -> StandaloneKindSig pass

- GHC.Hs.Decls: StockStrategy :: DerivStrategy pass

+ GHC.Hs.Decls: StockStrategy :: XStockStrategy pass -> DerivStrategy pass

- GHC.Hs.Decls: SynDecl :: XSynDecl pass -> Located (IdP pass) -> LHsQTyVars pass -> LexicalFixity -> LHsType pass -> TyClDecl pass

+ GHC.Hs.Decls: SynDecl :: XSynDecl pass -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> LHsType pass -> TyClDecl pass

- GHC.Hs.Decls: TyFamInstDecl :: TyFamInstEqn pass -> TyFamInstDecl pass

+ GHC.Hs.Decls: TyFamInstDecl :: XCTyFamInstDecl pass -> TyFamInstEqn pass -> TyFamInstDecl pass

- GHC.Hs.Decls: TypeAnnProvenance :: Located name -> AnnProvenance name

+ GHC.Hs.Decls: TypeAnnProvenance :: LIdP pass -> AnnProvenance pass

- GHC.Hs.Decls: ValueAnnProvenance :: Located name -> AnnProvenance name

+ GHC.Hs.Decls: ValueAnnProvenance :: LIdP pass -> AnnProvenance pass

- GHC.Hs.Decls: Warning :: XWarning pass -> [Located (IdP pass)] -> WarningTxt -> WarnDecl pass

+ GHC.Hs.Decls: Warning :: XWarning pass -> [LIdP pass] -> WarningTxt -> WarnDecl pass

- GHC.Hs.Decls: [cid_overlap_mode] :: ClsInstDecl pass -> Maybe (Located OverlapMode)

+ GHC.Hs.Decls: [cid_overlap_mode] :: ClsInstDecl pass -> Maybe (XRec pass OverlapMode)

- GHC.Hs.Decls: [con_args] :: ConDecl pass -> HsConDeclDetails pass

+ GHC.Hs.Decls: [con_args] :: ConDecl pass -> HsConDeclH98Details pass

- GHC.Hs.Decls: [con_forall] :: ConDecl pass -> Located Bool

+ GHC.Hs.Decls: [con_forall] :: ConDecl pass -> Bool

- GHC.Hs.Decls: [con_name] :: ConDecl pass -> Located (IdP pass)

+ GHC.Hs.Decls: [con_name] :: ConDecl pass -> LIdP pass

- GHC.Hs.Decls: [con_names] :: ConDecl pass -> [Located (IdP pass)]

+ GHC.Hs.Decls: [con_names] :: ConDecl pass -> [LIdP pass]

- GHC.Hs.Decls: [dd_cType] :: HsDataDefn pass -> Maybe (Located CType)

+ GHC.Hs.Decls: [dd_cType] :: HsDataDefn pass -> Maybe (XRec pass CType)

- GHC.Hs.Decls: [dd_ctxt] :: HsDataDefn pass -> LHsContext pass

+ GHC.Hs.Decls: [dd_ctxt] :: HsDataDefn pass -> Maybe (LHsContext pass)

- GHC.Hs.Decls: [deriv_clause_tys] :: HsDerivingClause pass -> Located [LHsSigType pass]

+ GHC.Hs.Decls: [deriv_clause_tys] :: HsDerivingClause pass -> LDerivClauseTys pass

- GHC.Hs.Decls: [deriv_overlap_mode] :: DerivDecl pass -> Maybe (Located OverlapMode)

+ GHC.Hs.Decls: [deriv_overlap_mode] :: DerivDecl pass -> Maybe (XRec pass OverlapMode)

- GHC.Hs.Decls: [dfid_eqn] :: DataFamInstDecl pass -> FamInstEqn pass (HsDataDefn pass)

+ GHC.Hs.Decls: [dfid_eqn] :: DataFamInstDecl pass -> FamEqn pass (HsDataDefn pass)

- GHC.Hs.Decls: [fdLName] :: FamilyDecl pass -> Located (IdP pass)

+ GHC.Hs.Decls: [fdLName] :: FamilyDecl pass -> LIdP pass

- GHC.Hs.Decls: [fd_name] :: ForeignDecl pass -> Located (IdP pass)

+ GHC.Hs.Decls: [fd_name] :: ForeignDecl pass -> LIdP pass

- GHC.Hs.Decls: [feqn_bndrs] :: FamEqn pass rhs -> Maybe [LHsTyVarBndr () pass]

+ GHC.Hs.Decls: [feqn_bndrs] :: FamEqn pass rhs -> HsOuterFamEqnTyVarBndrs pass

- GHC.Hs.Decls: [feqn_tycon] :: FamEqn pass rhs -> Located (IdP pass)

+ GHC.Hs.Decls: [feqn_tycon] :: FamEqn pass rhs -> LIdP pass

- GHC.Hs.Decls: [hs_docs] :: HsGroup p -> [LDocDecl]

+ GHC.Hs.Decls: [hs_docs] :: HsGroup p -> [LDocDecl p]

- GHC.Hs.Decls: [rd_lhs] :: RuleDecl pass -> Located (HsExpr pass)

+ GHC.Hs.Decls: [rd_lhs] :: RuleDecl pass -> XRec pass (HsExpr pass)

- GHC.Hs.Decls: [rd_name] :: RuleDecl pass -> Located (SourceText, RuleName)

+ GHC.Hs.Decls: [rd_name] :: RuleDecl pass -> XRec pass (SourceText, RuleName)

- GHC.Hs.Decls: [rd_rhs] :: RuleDecl pass -> Located (HsExpr pass)

+ GHC.Hs.Decls: [rd_rhs] :: RuleDecl pass -> XRec pass (HsExpr pass)

- GHC.Hs.Decls: [tcdCtxt] :: TyClDecl pass -> LHsContext pass

+ GHC.Hs.Decls: [tcdCtxt] :: TyClDecl pass -> Maybe (LHsContext pass)

- GHC.Hs.Decls: [tcdDocs] :: TyClDecl pass -> [LDocDecl]

+ GHC.Hs.Decls: [tcdDocs] :: TyClDecl pass -> [LDocDecl pass]

- GHC.Hs.Decls: [tcdLName] :: TyClDecl pass -> Located (IdP pass)

+ GHC.Hs.Decls: [tcdLName] :: TyClDecl pass -> LIdP pass

- GHC.Hs.Decls: annProvenanceName_maybe :: AnnProvenance name -> Maybe name

+ GHC.Hs.Decls: annProvenanceName_maybe :: forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p)

- GHC.Hs.Decls: data AnnProvenance name

+ GHC.Hs.Decls: data AnnProvenance pass

- GHC.Hs.Decls: familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p))

+ GHC.Hs.Decls: familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p))

- GHC.Hs.Decls: flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]

+ GHC.Hs.Decls: flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]

- GHC.Hs.Decls: getConNames :: ConDecl GhcRn -> [Located Name]

+ GHC.Hs.Decls: getConNames :: ConDecl GhcRn -> [LocatedN Name]

- GHC.Hs.Decls: hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]

+ GHC.Hs.Decls: hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]

- GHC.Hs.Decls: partitionBindsAndSigs :: [LHsDecl GhcPs] -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])

+ GHC.Hs.Decls: partitionBindsAndSigs :: [LHsDecl GhcPs] -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])

- GHC.Hs.Decls: pprHsFamInstLHS :: OutputableBndrId p => IdP (GhcPass p) -> Maybe [LHsTyVarBndr () (GhcPass p)] -> HsTyPats (GhcPass p) -> LexicalFixity -> LHsContext (GhcPass p) -> SDoc

+ GHC.Hs.Decls: pprHsFamInstLHS :: OutputableBndrId p => IdP (GhcPass p) -> HsOuterFamEqnTyVarBndrs (GhcPass p) -> HsTyPats (GhcPass p) -> LexicalFixity -> Maybe (LHsContext (GhcPass p)) -> SDoc

- GHC.Hs.Decls: tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)

+ GHC.Hs.Decls: tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN => TyClDecl (GhcPass p) -> IdP (GhcPass p)

- GHC.Hs.Decls: tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))

+ GHC.Hs.Decls: tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))

- GHC.Hs.Decls: tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p))

+ GHC.Hs.Decls: tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))

- GHC.Hs.Decls: tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)

+ GHC.Hs.Decls: tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)

- GHC.Hs.Decls: type HsDeriving pass = Located [LHsDerivingClause pass] " The optional @deriving@ clauses of a data declaration. "Clauses" is plural because one can specify multiple deriving clauses using the @-XDerivingStrategies@ language extension. The list of 'LHsDerivingClause's corresponds to exactly what the user requested to derive, in order. If no deriving clauses were specified, the list is empty."

+ GHC.Hs.Decls: type HsDeriving pass = [LHsDerivingClause pass] " The optional @deriving@ clauses of a data declaration. "Clauses" is plural because one can specify multiple deriving clauses using the @-XDerivingStrategies@ language extension. The list of 'LHsDerivingClause's corresponds to exactly what the user requested to derive, in order. If no deriving clauses were specified, the list is empty."

- GHC.Hs.Decls: type LAnnDecl pass = Located (AnnDecl pass)

+ GHC.Hs.Decls: type LAnnDecl pass = XRec pass (AnnDecl pass)

- GHC.Hs.Decls: type LClsInstDecl pass = Located (ClsInstDecl pass)

+ GHC.Hs.Decls: type LClsInstDecl pass = XRec pass (ClsInstDecl pass)

- GHC.Hs.Decls: type LConDecl pass = Located (ConDecl pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a GADT constructor list"

+ GHC.Hs.Decls: type LConDecl pass = XRec pass (ConDecl pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a GADT constructor list"

- GHC.Hs.Decls: type LDataFamInstDecl pass = Located (DataFamInstDecl pass)

+ GHC.Hs.Decls: type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass)

- GHC.Hs.Decls: type LDefaultDecl pass = Located (DefaultDecl pass)

+ GHC.Hs.Decls: type LDefaultDecl pass = XRec pass (DefaultDecl pass)

- GHC.Hs.Decls: type LDerivDecl pass = Located (DerivDecl pass)

+ GHC.Hs.Decls: type LDerivDecl pass = XRec pass (DerivDecl pass)

- GHC.Hs.Decls: type LDerivStrategy pass = Located (DerivStrategy pass)

+ GHC.Hs.Decls: type LDerivStrategy pass = XRec pass (DerivStrategy pass)

- GHC.Hs.Decls: type LDocDecl = Located (DocDecl)

+ GHC.Hs.Decls: type LDocDecl pass = XRec pass (DocDecl)

- GHC.Hs.Decls: type LFamilyDecl pass = Located (FamilyDecl pass)

+ GHC.Hs.Decls: type LFamilyDecl pass = XRec pass (FamilyDecl pass)

- GHC.Hs.Decls: type LFamilyResultSig pass = Located (FamilyResultSig pass)

+ GHC.Hs.Decls: type LFamilyResultSig pass = XRec pass (FamilyResultSig pass)

- GHC.Hs.Decls: type LForeignDecl pass = Located (ForeignDecl pass)

+ GHC.Hs.Decls: type LForeignDecl pass = XRec pass (ForeignDecl pass)

- GHC.Hs.Decls: type LHsDecl p = Located (HsDecl p) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' "

+ GHC.Hs.Decls: type LHsDecl p = XRec p (HsDecl p) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' "

- GHC.Hs.Decls: type LHsDerivingClause pass = Located (HsDerivingClause pass)

+ GHC.Hs.Decls: type LHsDerivingClause pass = XRec pass (HsDerivingClause pass)

- GHC.Hs.Decls: type LHsFunDep pass = Located (FunDep (Located (IdP pass)))

+ GHC.Hs.Decls: type LHsFunDep pass = XRec pass (FunDep pass)

- GHC.Hs.Decls: type LInjectivityAnn pass = Located (InjectivityAnn pass)

+ GHC.Hs.Decls: type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)

- GHC.Hs.Decls: type LInstDecl pass = Located (InstDecl pass)

+ GHC.Hs.Decls: type LInstDecl pass = XRec pass (InstDecl pass)

- GHC.Hs.Decls: type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)

+ GHC.Hs.Decls: type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass)

- GHC.Hs.Decls: type LRuleBndr pass = Located (RuleBndr pass)

+ GHC.Hs.Decls: type LRuleBndr pass = XRec pass (RuleBndr pass)

- GHC.Hs.Decls: type LRuleDecl pass = Located (RuleDecl pass)

+ GHC.Hs.Decls: type LRuleDecl pass = XRec pass (RuleDecl pass)

- GHC.Hs.Decls: type LRuleDecls pass = Located (RuleDecls pass)

+ GHC.Hs.Decls: type LRuleDecls pass = XRec pass (RuleDecls pass)

- GHC.Hs.Decls: type LSpliceDecl pass = Located (SpliceDecl pass)

+ GHC.Hs.Decls: type LSpliceDecl pass = XRec pass (SpliceDecl pass)

- GHC.Hs.Decls: type LStandaloneKindSig pass = Located (StandaloneKindSig pass)

+ GHC.Hs.Decls: type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)

- GHC.Hs.Decls: type LTyClDecl pass = Located (TyClDecl pass)

+ GHC.Hs.Decls: type LTyClDecl pass = XRec pass (TyClDecl pass)

- GHC.Hs.Decls: type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass)

+ GHC.Hs.Decls: type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass)

- GHC.Hs.Decls: type LTyFamInstDecl pass = Located (TyFamInstDecl pass)

+ GHC.Hs.Decls: type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)

- GHC.Hs.Decls: type LTyFamInstEqn pass = Located (TyFamInstEqn pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a list"

+ GHC.Hs.Decls: type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a list"

- GHC.Hs.Decls: type LWarnDecl pass = Located (WarnDecl pass)

+ GHC.Hs.Decls: type LWarnDecl pass = XRec pass (WarnDecl pass)

- GHC.Hs.Decls: type LWarnDecls pass = Located (WarnDecls pass)

+ GHC.Hs.Decls: type LWarnDecls pass = XRec pass (WarnDecls pass)

- GHC.Hs.Decls: type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)

+ GHC.Hs.Decls: type TyFamInstEqn pass = FamEqn pass (LHsType pass)

- GHC.Hs.Doc: ArgDocMap :: Map Name (Map Int HsDocString) -> ArgDocMap

+ GHC.Hs.Doc: ArgDocMap :: Map Name (IntMap HsDocString) -> ArgDocMap

- GHC.Hs.Dump: showAstData :: Data a => BlankSrcSpan -> a -> SDoc

+ GHC.Hs.Dump: showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc

- GHC.Hs.Expr: isEmptyMatchGroup :: MatchGroup id body -> Bool

+ GHC.Hs.Expr: isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool

- GHC.Hs.Expr: isSingletonMatchGroup :: [LMatch id body] -> Bool

+ GHC.Hs.Expr: isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool

- GHC.Hs.Expr: pprComp :: (OutputableBndrId p, Outputable body) => [LStmt (GhcPass p) body] -> SDoc

+ GHC.Hs.Expr: pprComp :: (OutputableBndrId p, Outputable body, Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) => [LStmt (GhcPass p) body] -> SDoc

- GHC.Hs.Expr: pprDo :: (OutputableBndrId p, Outputable body) => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc

+ GHC.Hs.Expr: pprDo :: (OutputableBndrId p, Outputable body, Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc

- GHC.Hs.Expr: pprFunBind :: (OutputableBndrId idR, Outputable body) => MatchGroup (GhcPass idR) body -> SDoc

+ GHC.Hs.Expr: pprFunBind :: OutputableBndrId idR => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc

- GHC.Hs.Expr: pprPatBind :: forall bndr p body. (OutputableBndrId bndr, OutputableBndrId p, Outputable body) => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc

+ GHC.Hs.Expr: pprPatBind :: forall bndr p. (OutputableBndrId bndr, OutputableBndrId p) => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc

- GHC.Hs.Expr: pprQuals :: (OutputableBndrId p, Outputable body) => [LStmt (GhcPass p) body] -> SDoc

+ GHC.Hs.Expr: pprQuals :: (OutputableBndrId p, Outputable body, Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA) => [LStmt (GhcPass p) body] -> SDoc

- GHC.Hs.Expr: pprStmt :: forall idL idR body. (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc

+ GHC.Hs.Expr: pprStmt :: forall idL idR body. (OutputableBndrId idL, OutputableBndrId idR, Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, Outputable body) => StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc

- GHC.Hs.Expr: pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => HsStmtContext (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc

+ GHC.Hs.Expr: pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body, Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) => HsStmtContext (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc

- GHC.Hs.Expr: ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Outputable body) => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc

+ GHC.Hs.Expr: ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR, Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA, Outputable body) => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc

- GHC.Hs.Expr: tupArgPresent :: LHsTupArg id -> Bool

+ GHC.Hs.Expr: tupArgPresent :: HsTupArg (GhcPass p) -> Bool

- GHC.Hs.Extension: [GhcPs] :: GhcPs

+ GHC.Hs.Extension: [GhcPs] :: GhcPass 'Parsed

- GHC.Hs.Extension: [GhcRn] :: GhcRn

+ GHC.Hs.Extension: [GhcRn] :: GhcPass 'Renamed

- GHC.Hs.Extension: [GhcTc] :: GhcTc

+ GHC.Hs.Extension: [GhcTc] :: GhcPass 'Typechecked

- GHC.Hs.Extension: type OutputableBndrId pass = (OutputableBndr (IdGhcP pass), OutputableBndr (IdGhcP (NoGhcTcPass pass)), IsPass pass)

+ GHC.Hs.Extension: type OutputableBndrId pass = (OutputableBndr (IdGhcP pass), OutputableBndr (IdGhcP (NoGhcTcPass pass)), Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass)), Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass))), IsPass pass)

- GHC.Hs.Extension: type family XXIE x

+ GHC.Hs.Extension: type family NoGhcTcPass (p :: Pass) :: Pass

- GHC.Hs.ImpExp: IEModuleContents :: XIEModuleContents pass -> Located ModuleName -> IE pass

+ GHC.Hs.ImpExp: IEModuleContents :: XIEModuleContents pass -> XRec pass ModuleName -> IE pass

- GHC.Hs.ImpExp: IEName :: Located name -> IEWrappedName name

+ GHC.Hs.ImpExp: IEName :: LocatedN name -> IEWrappedName name

- GHC.Hs.ImpExp: IEPattern :: Located name -> IEWrappedName name

+ GHC.Hs.ImpExp: IEPattern :: EpaLocation -> LocatedN name -> IEWrappedName name

- GHC.Hs.ImpExp: IEThingWith :: XIEThingWith pass -> LIEWrappedName (IdP pass) -> IEWildcard -> [LIEWrappedName (IdP pass)] -> [Located (FieldLbl (IdP pass))] -> IE pass

+ GHC.Hs.ImpExp: IEThingWith :: XIEThingWith pass -> LIEWrappedName (IdP pass) -> IEWildcard -> [LIEWrappedName (IdP pass)] -> IE pass

- GHC.Hs.ImpExp: IEType :: Located name -> IEWrappedName name

+ GHC.Hs.ImpExp: IEType :: EpaLocation -> LocatedN name -> IEWrappedName name

- GHC.Hs.ImpExp: ImportDecl :: XCImportDecl pass -> SourceText -> Located ModuleName -> Maybe StringLiteral -> IsBootInterface -> Bool -> ImportDeclQualifiedStyle -> Bool -> Maybe (Located ModuleName) -> Maybe (Bool, Located [LIE pass]) -> ImportDecl pass

+ GHC.Hs.ImpExp: ImportDecl :: XCImportDecl pass -> SourceText -> XRec pass ModuleName -> Maybe StringLiteral -> IsBootInterface -> Bool -> ImportDeclQualifiedStyle -> Bool -> Maybe (XRec pass ModuleName) -> Maybe (Bool, XRec pass [LIE pass]) -> ImportDecl pass

- GHC.Hs.ImpExp: [ideclAs] :: ImportDecl pass -> Maybe (Located ModuleName)

+ GHC.Hs.ImpExp: [ideclAs] :: ImportDecl pass -> Maybe (XRec pass ModuleName)

- GHC.Hs.ImpExp: [ideclHiding] :: ImportDecl pass -> Maybe (Bool, Located [LIE pass])

+ GHC.Hs.ImpExp: [ideclHiding] :: ImportDecl pass -> Maybe (Bool, XRec pass [LIE pass])

- GHC.Hs.ImpExp: [ideclName] :: ImportDecl pass -> Located ModuleName

+ GHC.Hs.ImpExp: [ideclName] :: ImportDecl pass -> XRec pass ModuleName

- GHC.Hs.ImpExp: ieLWrappedName :: LIEWrappedName name -> Located name

+ GHC.Hs.ImpExp: ieLWrappedName :: LIEWrappedName name -> LocatedN name

- GHC.Hs.ImpExp: importDeclQualifiedStyle :: Maybe (Located a) -> Maybe (Located a) -> ImportDeclQualifiedStyle

+ GHC.Hs.ImpExp: importDeclQualifiedStyle :: Maybe EpaLocation -> Maybe EpaLocation -> (Maybe EpaLocation, ImportDeclQualifiedStyle)

- GHC.Hs.ImpExp: simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)

+ GHC.Hs.ImpExp: simpleImportDecl :: ModuleName -> ImportDecl GhcPs

- GHC.Hs.ImpExp: type LIE pass = Located (IE pass) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'"

+ GHC.Hs.ImpExp: type LIE pass = XRec pass (IE pass) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'"

- GHC.Hs.ImpExp: type LIEWrappedName name = Located (IEWrappedName name)

+ GHC.Hs.ImpExp: type LIEWrappedName name = LocatedA (IEWrappedName name)

- GHC.Hs.ImpExp: type LImportDecl pass = Located (ImportDecl pass) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'"

+ GHC.Hs.ImpExp: type LImportDecl pass = XRec pass (ImportDecl pass) " When in a list this may have - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'"

- GHC.Hs.Pat: AsPat :: XAsPat p -> Located (IdP p) -> LPat p -> Pat p

+ GHC.Hs.Pat: AsPat :: XAsPat p -> LIdP p -> LPat p -> Pat p

- GHC.Hs.Pat: ConPat :: XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p

+ GHC.Hs.Pat: ConPat :: XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p

- GHC.Hs.Pat: HsRecField :: Located id -> arg -> Bool -> HsRecField' id arg

+ GHC.Hs.Pat: HsRecField :: XHsRecField id -> Located id -> arg -> Bool -> HsRecField' id arg

- GHC.Hs.Pat: NPat :: XNPat p -> Located (HsOverLit p) -> Maybe (SyntaxExpr p) -> SyntaxExpr p -> Pat p

+ GHC.Hs.Pat: NPat :: XNPat p -> XRec p (HsOverLit p) -> Maybe (SyntaxExpr p) -> SyntaxExpr p -> Pat p

- GHC.Hs.Pat: NPlusKPat :: XNPlusKPat p -> Located (IdP p) -> Located (HsOverLit p) -> HsOverLit p -> SyntaxExpr p -> SyntaxExpr p -> Pat p

+ GHC.Hs.Pat: NPlusKPat :: XNPlusKPat p -> LIdP p -> XRec p (HsOverLit p) -> HsOverLit p -> SyntaxExpr p -> SyntaxExpr p -> Pat p

- GHC.Hs.Pat: VarPat :: XVarPat p -> Located (IdP p) -> Pat p

+ GHC.Hs.Pat: VarPat :: XVarPat p -> LIdP p -> Pat p

- GHC.Hs.Pat: [pat_con] :: Pat p -> Located (ConLikeP p)

+ GHC.Hs.Pat: [pat_con] :: Pat p -> XRec p (ConLikeP p)

- GHC.Hs.Pat: hsConPatArgs :: HsConPatDetails p -> [LPat p]

+ GHC.Hs.Pat: hsConPatArgs :: forall p. UnXRec p => HsConPatDetails p -> [LPat p]

- GHC.Hs.Pat: hsRecFields :: HsRecFields p arg -> [XCFieldOcc p]

+ GHC.Hs.Pat: hsRecFields :: forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]

- GHC.Hs.Pat: hsRecFieldsArgs :: HsRecFields p arg -> [arg]

+ GHC.Hs.Pat: hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]

- GHC.Hs.Pat: pprConArgs :: OutputableBndrId p => HsConPatDetails (GhcPass p) -> SDoc

+ GHC.Hs.Pat: pprConArgs :: (OutputableBndrId p, Outputable (Anno (IdGhcP p))) => HsConPatDetails (GhcPass p) -> SDoc

- GHC.Hs.Pat: type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))

+ GHC.Hs.Pat: type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))

- GHC.Hs.Pat: type LHsRecField p arg = Located (HsRecField p arg)

+ GHC.Hs.Pat: type LHsRecField p arg = XRec p (HsRecField p arg)

- GHC.Hs.Pat: type LHsRecField' p arg = Located (HsRecField' p arg)

+ GHC.Hs.Pat: type LHsRecField' p id arg = XRec p (HsRecField' id arg)

- GHC.Hs.Pat: type LHsRecUpdField p = Located (HsRecUpdField p)

+ GHC.Hs.Pat: type LHsRecUpdField p = XRec p (HsRecUpdField p)

- GHC.Hs.Pat: type LPat p = XRec p Pat

+ GHC.Hs.Pat: type LPat p = XRec p (Pat p)

- GHC.Hs.Type: Ambiguous :: XAmbiguous pass -> Located RdrName -> AmbiguousFieldOcc pass

+ GHC.Hs.Type: Ambiguous :: XAmbiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass

- GHC.Hs.Type: FieldOcc :: XCFieldOcc pass -> Located RdrName -> FieldOcc pass

+ GHC.Hs.Type: FieldOcc :: XCFieldOcc pass -> LocatedN RdrName -> FieldOcc pass

- GHC.Hs.Type: HsExplicitMult :: IsUnicodeSyntax -> LHsType pass -> HsArrow pass

+ GHC.Hs.Type: HsExplicitMult :: IsUnicodeSyntax -> Maybe AddEpAnn -> LHsType pass -> HsArrow pass

- GHC.Hs.Type: HsIParamTy :: XIParamTy pass -> Located HsIPName -> LHsType pass -> HsType pass

+ GHC.Hs.Type: HsIParamTy :: XIParamTy pass -> XRec pass HsIPName -> LHsType pass -> HsType pass

- GHC.Hs.Type: HsLinearArrow :: IsUnicodeSyntax -> HsArrow pass

+ GHC.Hs.Type: HsLinearArrow :: IsUnicodeSyntax -> Maybe AddEpAnn -> HsArrow pass

- GHC.Hs.Type: HsOpTy :: XOpTy pass -> LHsType pass -> Located (IdP pass) -> LHsType pass -> HsType pass

+ GHC.Hs.Type: HsOpTy :: XOpTy pass -> LHsType pass -> LIdP pass -> LHsType pass -> HsType pass

- GHC.Hs.Type: HsQualTy :: XQualTy pass -> LHsContext pass -> LHsType pass -> HsType pass

+ GHC.Hs.Type: HsQualTy :: XQualTy pass -> Maybe (LHsContext pass) -> LHsType pass -> HsType pass

- GHC.Hs.Type: HsTyVar :: XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass

+ GHC.Hs.Type: HsTyVar :: XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass

- GHC.Hs.Type: InfixCon :: arg -> arg -> HsConDetails arg rec

+ GHC.Hs.Type: InfixCon :: arg -> arg -> HsConDetails tyarg arg rec

- GHC.Hs.Type: KindedTyVar :: XKindedTyVar pass -> flag -> Located (IdP pass) -> LHsKind pass -> HsTyVarBndr flag pass

+ GHC.Hs.Type: KindedTyVar :: XKindedTyVar pass -> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass

- GHC.Hs.Type: PrefixCon :: [arg] -> HsConDetails arg rec

+ GHC.Hs.Type: PrefixCon :: [tyarg] -> [arg] -> HsConDetails tyarg arg rec

- GHC.Hs.Type: RecCon :: rec -> HsConDetails arg rec

+ GHC.Hs.Type: RecCon :: rec -> HsConDetails tyarg arg rec

- GHC.Hs.Type: Unambiguous :: XUnambiguous pass -> Located RdrName -> AmbiguousFieldOcc pass

+ GHC.Hs.Type: Unambiguous :: XUnambiguous pass -> LocatedN RdrName -> AmbiguousFieldOcc pass

- GHC.Hs.Type: UserTyVar :: XUserTyVar pass -> flag -> Located (IdP pass) -> HsTyVarBndr flag pass

+ GHC.Hs.Type: UserTyVar :: XUserTyVar pass -> flag -> LIdP pass -> HsTyVarBndr flag pass

- GHC.Hs.Type: XHsType :: XXType pass -> HsType pass

+ GHC.Hs.Type: XHsType :: !XXType pass -> HsType pass

- GHC.Hs.Type: [hst_ctxt] :: HsType pass -> LHsContext pass

+ GHC.Hs.Type: [hst_ctxt] :: HsType pass -> Maybe (LHsContext pass)

- GHC.Hs.Type: [rdrNameFieldOcc] :: FieldOcc pass -> Located RdrName

+ GHC.Hs.Type: [rdrNameFieldOcc] :: FieldOcc pass -> LocatedN RdrName

- GHC.Hs.Type: class OutputableBndrFlag flag

+ GHC.Hs.Type: class OutputableBndrFlag flag p

- GHC.Hs.Type: data HsConDetails arg rec

+ GHC.Hs.Type: data HsConDetails tyarg arg rec

- GHC.Hs.Type: getBangStrictness :: LHsType a -> HsSrcBang

+ GHC.Hs.Type: getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang

- GHC.Hs.Type: getBangType :: LHsType a -> LHsType a

+ GHC.Hs.Type: getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)

- GHC.Hs.Type: getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p) -> Maybe (Located (IdP (GhcPass p)))

+ GHC.Hs.Type: getLHsInstDeclClass_maybe :: Anno (IdGhcP p) ~ SrcSpanAnnN => LHsSigType (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))

- GHC.Hs.Type: hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))

+ GHC.Hs.Type: hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))

- GHC.Hs.Type: hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]

+ GHC.Hs.Type: hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]

- GHC.Hs.Type: hsSigWcType :: LHsSigWcType pass -> LHsType pass

+ GHC.Hs.Type: hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p

- GHC.Hs.Type: hsTvbAllKinded :: LHsQTyVars pass -> Bool

+ GHC.Hs.Type: hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool

- GHC.Hs.Type: hsTyGetAppHead_maybe :: LHsType (GhcPass p) -> Maybe (Located (IdP (GhcPass p)))

+ GHC.Hs.Type: hsTyGetAppHead_maybe :: Anno (IdGhcP p) ~ SrcSpanAnnN => LHsType (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))

- GHC.Hs.Type: hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass)

+ GHC.Hs.Type: hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p))

- GHC.Hs.Type: ignoreParens :: LHsType pass -> LHsType pass

+ GHC.Hs.Type: ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)

- GHC.Hs.Type: lhsTypeArgSrcSpan :: LHsTypeArg pass -> SrcSpan

+ GHC.Hs.Type: lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan

- GHC.Hs.Type: mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs

+ GHC.Hs.Type: mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs

- GHC.Hs.Type: mkFieldOcc :: Located RdrName -> FieldOcc GhcPs

+ GHC.Hs.Type: mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs

- GHC.Hs.Type: mkHsForAllInvisTele :: [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)

+ GHC.Hs.Type: mkHsForAllInvisTele :: EpAnnForallTy -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)

- GHC.Hs.Type: mkHsForAllVisTele :: [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)

+ GHC.Hs.Type: mkHsForAllVisTele :: EpAnnForallTy -> [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)

- GHC.Hs.Type: mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p)

+ GHC.Hs.Type: mkHsOpTy :: Anno (IdGhcP p) ~ SrcSpanAnnN => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p)) -> LHsType (GhcPass p) -> HsType (GhcPass p)

- GHC.Hs.Type: mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs

+ GHC.Hs.Type: mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs

- GHC.Hs.Type: pprHsForAll :: forall p. OutputableBndrId p => HsForAllTelescope (GhcPass p) -> LHsContext (GhcPass p) -> SDoc

+ GHC.Hs.Type: pprHsForAll :: forall p. OutputableBndrId p => HsForAllTelescope (GhcPass p) -> Maybe (LHsContext (GhcPass p)) -> SDoc

- GHC.Hs.Type: pprLHsContext :: OutputableBndrId p => LHsContext (GhcPass p) -> SDoc

+ GHC.Hs.Type: pprLHsContext :: OutputableBndrId p => Maybe (LHsContext (GhcPass p)) -> SDoc

- GHC.Hs.Type: splitHsFunType :: LHsType (GhcPass p) -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn])

+ GHC.Hs.Type: splitHsFunType :: LHsType (GhcPass p) -> ([AddEpAnn], EpAnnComments, [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))

- GHC.Hs.Type: splitLHsForAllTyInvis :: LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsType pass)

+ GHC.Hs.Type: splitLHsForAllTyInvis :: LHsType (GhcPass pass) -> ((EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]), LHsType (GhcPass pass))

- GHC.Hs.Type: splitLHsForAllTyInvis_KP :: LHsType pass -> (Maybe [LHsTyVarBndr Specificity pass], LHsType pass)

+ GHC.Hs.Type: splitLHsForAllTyInvis_KP :: LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]), LHsType (GhcPass pass))

- GHC.Hs.Type: splitLHsGadtTy :: LHsType pass -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass)

+ GHC.Hs.Type: splitLHsGadtTy :: LHsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)

- GHC.Hs.Type: splitLHsInstDeclTy :: LHsSigType GhcRn -> ([Name], LHsContext GhcRn, LHsType GhcRn)

+ GHC.Hs.Type: splitLHsInstDeclTy :: LHsSigType GhcRn -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)

- GHC.Hs.Type: splitLHsPatSynTy :: LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsContext pass, [LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass)

+ GHC.Hs.Type: splitLHsPatSynTy :: LHsSigType (GhcPass p) -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], Maybe (LHsContext (GhcPass p)), [LHsTyVarBndr Specificity (GhcPass p)], Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))

- GHC.Hs.Type: splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)

+ GHC.Hs.Type: splitLHsQualTy :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))

- GHC.Hs.Type: splitLHsSigmaTyInvis :: LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass)

+ GHC.Hs.Type: splitLHsSigmaTyInvis :: LHsType (GhcPass p) -> ([LHsTyVarBndr Specificity (GhcPass p)], Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))

- GHC.Hs.Type: type LBangType pass = Located (BangType pass)

+ GHC.Hs.Type: type LBangType pass = XRec pass (BangType pass)

- GHC.Hs.Type: type LConDeclField pass = Located (ConDeclField pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

+ GHC.Hs.Type: type LConDeclField pass = XRec pass (ConDeclField pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

- GHC.Hs.Type: type LFieldOcc pass = Located (FieldOcc pass)

+ GHC.Hs.Type: type LFieldOcc pass = XRec pass (FieldOcc pass)

- GHC.Hs.Type: type LHsContext pass = Located (HsContext pass) " 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit' For details on above see note [Api annotations] in GHC.Parser.Annotation"

+ GHC.Hs.Type: type LHsContext pass = XRec pass (HsContext pass) " 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit' For details on above see note [exact print annotations] in GHC.Parser.Annotation"

- GHC.Hs.Type: type LHsKind pass = Located (HsKind pass) " 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'"

+ GHC.Hs.Type: type LHsKind pass = XRec pass (HsKind pass) " 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'"

- GHC.Hs.Type: type LHsSigType pass = HsImplicitBndrs pass (LHsType pass)

+ GHC.Hs.Type: type LHsSigType pass = XRec pass (HsSigType pass)

- GHC.Hs.Type: type LHsTyVarBndr flag pass = Located (HsTyVarBndr flag pass)

+ GHC.Hs.Type: type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)

- GHC.Hs.Type: type LHsType pass = Located (HsType pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

+ GHC.Hs.Type: type LHsType pass = XRec pass (HsType pass) " May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when in a list"

- GHC.Hs.Utils: class (XRec p Pat ~ Located (Pat p)) => CollectPass p

+ GHC.Hs.Utils: class UnXRec p => CollectPass p

- GHC.Hs.Utils: collectHsBindBinders :: CollectPass p => HsBindLR p idR -> [IdP p]

+ GHC.Hs.Utils: collectHsBindBinders :: CollectPass p => CollectFlag p -> HsBindLR p idR -> [IdP p]

- GHC.Hs.Utils: collectHsBindListBinders :: CollectPass p => [LHsBindLR p idR] -> [IdP p]

+ GHC.Hs.Utils: collectHsBindListBinders :: forall p idR. CollectPass p => CollectFlag p -> [LHsBindLR p idR] -> [IdP p]

- GHC.Hs.Utils: collectHsBindsBinders :: CollectPass p => LHsBindsLR p idR -> [IdP p]

+ GHC.Hs.Utils: collectHsBindsBinders :: CollectPass p => CollectFlag p -> LHsBindsLR p idR -> [IdP p]

- GHC.Hs.Utils: collectHsIdBinders :: CollectPass (GhcPass idL) => HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectHsIdBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectHsValBinders :: CollectPass (GhcPass idL) => HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectHsValBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectLStmtBinders :: CollectPass (GhcPass idL) => LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectLStmtBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectLStmtsBinders :: CollectPass (GhcPass idL) => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectLStmtsBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> [LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectLocalBinders :: CollectPass (GhcPass idL) => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectLocalBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]

+ GHC.Hs.Utils: collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]

- GHC.Hs.Utils: collectPatBinders :: CollectPass p => LPat p -> [IdP p]

+ GHC.Hs.Utils: collectPatBinders :: CollectPass p => CollectFlag p -> LPat p -> [IdP p]

- GHC.Hs.Utils: collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p]

+ GHC.Hs.Utils: collectPatsBinders :: CollectPass p => CollectFlag p -> [LPat p] -> [IdP p]

- GHC.Hs.Utils: collectStmtBinders :: CollectPass (GhcPass idL) => StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectStmtBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectStmtsBinders :: CollectPass (GhcPass idL) => [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]

+ GHC.Hs.Utils: collectStmtsBinders :: CollectPass (GhcPass idL) => CollectFlag (GhcPass idL) -> [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)]

- GHC.Hs.Utils: collectXXPat :: CollectPass p => Proxy p -> XXPat p -> [IdP p] -> [IdP p]

+ GHC.Hs.Utils: collectXXPat :: CollectPass p => Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]

- GHC.Hs.Utils: emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR

+ GHC.Hs.Utils: emptyRecStmt :: Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL => StmtLR (GhcPass idL) GhcPs bodyR

- GHC.Hs.Utils: emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR

+ GHC.Hs.Utils: emptyRecStmtId :: Stmt GhcTc (LocatedA (HsCmd GhcTc))

- GHC.Hs.Utils: emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR

+ GHC.Hs.Utils: emptyRecStmtName :: Anno [GenLocated (Anno (StmtLR GhcRn GhcRn bodyR)) (StmtLR GhcRn GhcRn bodyR)] ~ SrcSpanAnnL => StmtLR GhcRn GhcRn bodyR

- GHC.Hs.Utils: emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)

+ GHC.Hs.Utils: emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

- GHC.Hs.Utils: getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]

+ GHC.Hs.Utils: getPatSynBinds :: forall id. UnXRec id => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]

- GHC.Hs.Utils: hsDataFamInstBinders :: IsPass p => DataFamInstDecl (GhcPass p) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])

+ GHC.Hs.Utils: hsDataFamInstBinders :: IsPass p => DataFamInstDecl (GhcPass p) -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])

- GHC.Hs.Utils: hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]

+ GHC.Hs.Utils: hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a) => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)]

- GHC.Hs.Utils: hsLTyClDeclBinders :: IsPass p => Located (TyClDecl (GhcPass p)) -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])

+ GHC.Hs.Utils: hsLTyClDeclBinders :: IsPass p => LocatedA (TyClDecl (GhcPass p)) -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])

- GHC.Hs.Utils: hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]

+ GHC.Hs.Utils: hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]

- GHC.Hs.Utils: isInfixFunBind :: HsBindLR id1 id2 -> Bool

+ GHC.Hs.Utils: isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool

- GHC.Hs.Utils: lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))] -> [(SrcSpan, [Name])]

+ GHC.Hs.Utils: lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] -> [(SrcSpan, [Name])]

- GHC.Hs.Utils: missingTupArg :: HsTupArg GhcPs

+ GHC.Hs.Utils: missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs

- GHC.Hs.Utils: mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)

+ GHC.Hs.Utils: mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id) -> LHsExpr (GhcPass id)

- GHC.Hs.Utils: mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)

+ GHC.Hs.Utils: mkBigLHsVarTup :: IsSrcSpanAnn p a => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: mkBodyStmt :: Located (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))

+ GHC.Hs.Utils: mkBodyStmt :: LocatedA (bodyR GhcPs) -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))

- GHC.Hs.Utils: mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs

+ GHC.Hs.Utils: mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs

- GHC.Hs.Utils: mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

+ GHC.Hs.Utils: mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

- GHC.Hs.Utils: mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

+ GHC.Hs.Utils: mkGroupUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

- GHC.Hs.Utils: mkHsCaseAlt :: LPat (GhcPass p) -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p)))

+ GHC.Hs.Utils: mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) => LPat (GhcPass p) -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))

- GHC.Hs.Utils: mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs

+ GHC.Hs.Utils: mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf -> HsCmd GhcPs

- GHC.Hs.Utils: mkHsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs

+ GHC.Hs.Utils: mkHsDo :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs

- GHC.Hs.Utils: mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs

+ GHC.Hs.Utils: mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf -> HsExpr GhcPs

- GHC.Hs.Utils: mkHsLam :: IsPass p => XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)

+ GHC.Hs.Utils: mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a)) -> [LSig GhcRn] -> NameEnv a

+ GHC.Hs.Utils: mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a)) -> [LSig GhcRn] -> NameEnv a

- GHC.Hs.Utils: mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)

+ GHC.Hs.Utils: mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)

+ GHC.Hs.Utils: mkLHsVarTuple :: IsSrcSpanAnn p a => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))

+ GHC.Hs.Utils: mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR)) -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))

- GHC.Hs.Utils: mkMatch :: forall p. IsPass p => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p))

+ GHC.Hs.Utils: mkMatch :: forall p. IsPass p => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p))

- GHC.Hs.Utils: mkMatchGroup :: XMG name (Located (body name)) ~ NoExtField => Origin -> [LMatch name (Located (body name))] -> MatchGroup name (Located (body name))

+ GHC.Hs.Utils: mkMatchGroup :: AnnoBody p body => Origin -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))

- GHC.Hs.Utils: mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> Pat GhcPs

+ GHC.Hs.Utils: mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs

- GHC.Hs.Utils: mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs

+ GHC.Hs.Utils: mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn EpaLocation -> Pat GhcPs

- GHC.Hs.Utils: mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs

+ GHC.Hs.Utils: mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs

- GHC.Hs.Utils: mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs) -> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))

+ GHC.Hs.Utils: mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))

- GHC.Hs.Utils: mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR

+ GHC.Hs.Utils: mkRecStmt :: Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL => EpAnn AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR

- GHC.Hs.Utils: mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn) -> StmtLR GhcRn GhcRn (Located (bodyR GhcRn))

+ GHC.Hs.Utils: mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn) -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))

- GHC.Hs.Utils: mkSimpleMatch :: HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p)))

+ GHC.Hs.Utils: mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) => HsMatchContext (NoGhcTc (GhcPass p)) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))

- GHC.Hs.Utils: mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc) -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))

+ GHC.Hs.Utils: mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc) -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))

- GHC.Hs.Utils: mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn

+ GHC.Hs.Utils: mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)] -> HsBind GhcRn

- GHC.Hs.Utils: mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

+ GHC.Hs.Utils: mkTransformByStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

- GHC.Hs.Utils: mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

+ GHC.Hs.Utils: mkTransformStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)

- GHC.Hs.Utils: mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs

+ GHC.Hs.Utils: mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs

- GHC.Hs.Utils: mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs

+ GHC.Hs.Utils: mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs

- GHC.Hs.Utils: nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)

+ GHC.Hs.Utils: nlHsApps :: IsSrcSpanAnn p a => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)

+ GHC.Hs.Utils: nlHsTyConApp :: IsSrcSpanAnn p a => LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)

- GHC.Hs.Utils: nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)

+ GHC.Hs.Utils: nlHsTyVar :: IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsType (GhcPass p)

- GHC.Hs.Utils: nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)

+ GHC.Hs.Utils: nlHsVar :: IsSrcSpanAnn p a => IdP (GhcPass p) -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)

+ GHC.Hs.Utils: nlHsVarApps :: IsSrcSpanAnn p a => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)

- GHC.Hs.Utils: nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)

+ GHC.Hs.Utils: nlVarPat :: IsSrcSpanAnn p a => IdP (GhcPass p) -> LPat (GhcPass p)

- GHC.Hs.Utils: nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id)

+ GHC.Hs.Utils: nl_HsVar :: IsSrcSpanAnn p a => IdP (GhcPass p) -> HsExpr (GhcPass p)

- GHC.Hs.Utils: unguardedGRHSs :: Located (body (GhcPass p)) -> GRHSs (GhcPass p) (Located (body (GhcPass p)))

+ GHC.Hs.Utils: unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))

- GHC.Hs.Utils: unguardedRHS :: SrcSpan -> Located (body (GhcPass p)) -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]

+ GHC.Hs.Utils: unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]

- GHC.HsToCore: deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)

+ GHC.HsToCore: deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts)

- GHC.HsToCore: deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)

+ GHC.HsToCore: deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr)

- GHC.HsToCore.Coverage: hpcInitCode :: Module -> HpcInfo -> SDoc

+ GHC.HsToCore.Coverage: hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub

- GHC.HsToCore.Docs: collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]

+ GHC.HsToCore.Docs: collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]

- GHC.HsToCore.Docs: conArgDocs :: ConDecl GhcRn -> Map Int HsDocString

+ GHC.HsToCore.Docs: conArgDocs :: ConDecl GhcRn -> IntMap HsDocString

- GHC.HsToCore.Docs: declTypeDocs :: HsDecl GhcRn -> Map Int HsDocString

+ GHC.HsToCore.Docs: declTypeDocs :: HsDecl GhcRn -> IntMap HsDocString

- GHC.HsToCore.Docs: extractDocs :: TcGblEnv -> (Maybe HsDocString, DeclDocMap, ArgDocMap)

+ GHC.HsToCore.Docs: extractDocs :: MonadIO m => TcGblEnv -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)

- GHC.HsToCore.Docs: filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]

+ GHC.HsToCore.Docs: filterClasses :: forall p doc. IsPass p => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)]

- GHC.HsToCore.Docs: filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]

+ GHC.HsToCore.Docs: filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]

- GHC.HsToCore.Docs: getInstLoc :: InstDecl (GhcPass p) -> SrcSpan

+ GHC.HsToCore.Docs: getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan

- GHC.HsToCore.Docs: getMainDeclBinder :: CollectPass (GhcPass p) => HsDecl (GhcPass p) -> [IdP (GhcPass p)]

+ GHC.HsToCore.Docs: getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p)) => HsDecl (GhcPass p) -> [IdP (GhcPass p)]

- GHC.HsToCore.Docs: mkDecls :: (struct -> [Located decl]) -> (decl -> hsDecl) -> struct -> [Located hsDecl]

+ GHC.HsToCore.Docs: mkDecls :: (struct -> [GenLocated l decl]) -> (decl -> hsDecl) -> struct -> [GenLocated l hsDecl]

- GHC.HsToCore.Docs: mkMaps :: [Name] -> [(LHsDecl GhcRn, [HsDocString])] -> (Map Name HsDocString, Map Name (Map Int HsDocString))

+ GHC.HsToCore.Docs: mkMaps :: [Name] -> [(LHsDecl GhcRn, [HsDocString])] -> (Map Name HsDocString, Map Name (IntMap HsDocString))

- GHC.HsToCore.Docs: sigNameNoLoc :: Sig pass -> [IdP pass]

+ GHC.HsToCore.Docs: sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]

- GHC.HsToCore.Docs: subordinates :: Map RealSrcSpan Name -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)]

+ GHC.HsToCore.Docs: subordinates :: Map RealSrcSpan Name -> HsDecl GhcRn -> [(Name, [HsDocString], IntMap HsDocString)]

- GHC.HsToCore.Docs: typeDocs :: HsType GhcRn -> Map Int HsDocString

+ GHC.HsToCore.Docs: typeDocs :: HsType GhcRn -> IntMap HsDocString

- GHC.HsToCore.Expr: dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr

+ GHC.HsToCore.Expr: dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr

- GHC.HsToCore.GuardedRHSs: dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -> Type -> Maybe (NonEmpty Deltas) -> DsM (MatchResult CoreExpr)

+ GHC.HsToCore.GuardedRHSs: dsGRHSs :: HsMatchContext GhcRn -> GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM (MatchResult CoreExpr)

- GHC.HsToCore.GuardedRHSs: dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> Maybe (NonEmpty Deltas) -> DsM CoreExpr

+ GHC.HsToCore.GuardedRHSs: dsGuarded :: GRHSs GhcTc (LHsExpr GhcTc) -> Type -> NonEmpty Nablas -> DsM CoreExpr

- GHC.HsToCore.Match: matchSinglePatVar :: Id -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)

+ GHC.HsToCore.Match: matchSinglePatVar :: Id -> Maybe CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr)

- GHC.HsToCore.Monad: dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]

+ GHC.HsToCore.Monad: dsGetCompleteMatches :: DsM CompleteMatches

- GHC.HsToCore.Monad: initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)

+ GHC.HsToCore.Monad: initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)

- GHC.HsToCore.Monad: initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)

+ GHC.HsToCore.Monad: initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)

- GHC.HsToCore.Monad: initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)

+ GHC.HsToCore.Monad: initTcDsForSolver :: TcM a -> DsM a

- GHC.HsToCore.Utils: mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr

+ GHC.HsToCore.Utils: mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr

- GHC.HsToCore.Utils: mkSelectorBinds :: [[Tickish Id]] -> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])

+ GHC.HsToCore.Utils: mkSelectorBinds :: [[CoreTickish]] -> LPat GhcTc -> CoreExpr -> DsM (Id, [(Id, CoreExpr)])

- GHC.Iface.Binary: putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()

+ GHC.Iface.Binary: putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()

- GHC.Iface.Binary: readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> TcRnIf a b ModIface

+ GHC.Iface.Binary: readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath -> TcRnIf a b ModIface

- GHC.Iface.Binary: readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCacheUpdater -> IO ModIface

+ GHC.Iface.Binary: readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath -> NameCacheUpdater -> IO ModIface

- GHC.Iface.Binary: writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()

+ GHC.Iface.Binary: writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()

- GHC.Iface.Ext.Ast: enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> Hsc (HieASTs Type)

+ GHC.Iface.Ext.Ast: enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> DsM (HieASTs Type)

- GHC.Iface.Ext.Ast: getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> Hsc (HieASTs TypeIndex, Array TypeIndex HieTypeFlat)

+ GHC.Iface.Ext.Ast: getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon] -> DsM (HieASTs TypeIndex, Array TypeIndex HieTypeFlat)

- GHC.Iface.Ext.Debug: diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (Map FastString (HieAST a))

+ GHC.Iface.Ext.Debug: diffAsts :: (Outputable a, Eq a, Ord a) => Diff a -> Diff (Map HiePath (HieAST a))

- GHC.Iface.Ext.Debug: validateScopes :: Module -> Map FastString (HieAST a) -> [SDoc]

+ GHC.Iface.Ext.Debug: validateScopes :: Module -> Map HiePath (HieAST a) -> [SDoc]

- GHC.Iface.Ext.Types: HieASTs :: Map FastString (HieAST a) -> HieASTs a

+ GHC.Iface.Ext.Types: HieASTs :: Map HiePath (HieAST a) -> HieASTs a

- GHC.Iface.Ext.Types: NodeInfo :: Set (FastString, FastString) -> [a] -> NodeIdentifiers a -> NodeInfo a

+ GHC.Iface.Ext.Types: NodeInfo :: Set NodeAnnotation -> [a] -> NodeIdentifiers a -> NodeInfo a

- GHC.Iface.Ext.Types: [getAsts] :: HieASTs a -> Map FastString (HieAST a)

+ GHC.Iface.Ext.Types: [getAsts] :: HieASTs a -> Map HiePath (HieAST a)

- GHC.Iface.Ext.Types: [nodeAnnotations] :: NodeInfo a -> Set (FastString, FastString)

+ GHC.Iface.Ext.Types: [nodeAnnotations] :: NodeInfo a -> Set NodeAnnotation

- GHC.Iface.Ext.Utils: definedInAsts :: Map FastString (HieAST a) -> Name -> Bool

+ GHC.Iface.Ext.Utils: definedInAsts :: Map HiePath (HieAST a) -> Name -> Bool

- GHC.Iface.Ext.Utils: getNameBinding :: Name -> Map FastString (HieAST a) -> Maybe Span

+ GHC.Iface.Ext.Utils: getNameBinding :: Name -> Map HiePath (HieAST a) -> Maybe Span

- GHC.Iface.Ext.Utils: getNameBindingInClass :: Name -> Span -> Map FastString (HieAST a) -> Maybe Span

+ GHC.Iface.Ext.Utils: getNameBindingInClass :: Name -> Span -> Map HiePath (HieAST a) -> Maybe Span

- GHC.Iface.Ext.Utils: getNameScope :: Name -> Map FastString (HieAST a) -> Maybe [Scope]

+ GHC.Iface.Ext.Utils: getNameScope :: Name -> Map HiePath (HieAST a) -> Maybe [Scope]

- GHC.Iface.Ext.Utils: getNameScopeAndBinding :: Name -> Map FastString (HieAST a) -> Maybe ([Scope], Maybe Span)

+ GHC.Iface.Ext.Utils: getNameScopeAndBinding :: Name -> Map HiePath (HieAST a) -> Maybe ([Scope], Maybe Span)

- GHC.Iface.Ext.Utils: resolveTyVarScopeLocal :: HieAST a -> Map FastString (HieAST a) -> HieAST a

+ GHC.Iface.Ext.Utils: resolveTyVarScopeLocal :: HieAST a -> Map HiePath (HieAST a) -> HieAST a

- GHC.Iface.Ext.Utils: resolveTyVarScopes :: Map FastString (HieAST a) -> Map FastString (HieAST a)

+ GHC.Iface.Ext.Utils: resolveTyVarScopes :: Map HiePath (HieAST a) -> Map HiePath (HieAST a)

- GHC.Iface.Load: findAndReadIface :: SDoc -> InstalledModule -> Module -> IsBootInterface -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))

+ GHC.Iface.Load: findAndReadIface :: SDoc -> InstalledModule -> Module -> IsBootInterface -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))

- GHC.Iface.Load: importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)

+ GHC.Iface.Load: importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)

- GHC.Iface.Load: initExternalPackageState :: DynFlags -> ExternalPackageState

+ GHC.Iface.Load: initExternalPackageState :: ExternalPackageState

- GHC.Iface.Load: loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr MsgDoc ModIface)

+ GHC.Iface.Load: loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr SDoc ModIface)

- GHC.Iface.Load: loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -> Maybe FastString -> RnM (MaybeErr MsgDoc ModIface)

+ GHC.Iface.Load: loadSrcInterface_maybe :: SDoc -> ModuleName -> IsBootInterface -> Maybe FastString -> RnM (MaybeErr SDoc ModIface)

- GHC.Iface.Load: moduleFreeHolesPrecise :: SDoc -> Module -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))

+ GHC.Iface.Load: moduleFreeHolesPrecise :: SDoc -> Module -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName))

- GHC.Iface.Load: pprModIface :: ModIface -> SDoc

+ GHC.Iface.Load: pprModIface :: UnitState -> ModIface -> SDoc

- GHC.Iface.Load: pprModIfaceSimple :: ModIface -> SDoc

+ GHC.Iface.Load: pprModIfaceSimple :: UnitState -> ModIface -> SDoc

- GHC.Iface.Load: readIface :: Module -> FilePath -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)

+ GHC.Iface.Load: readIface :: Module -> FilePath -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)

- GHC.Iface.Load: tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)

+ GHC.Iface.Load: tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing)

- GHC.Iface.Load: writeIface :: DynFlags -> FilePath -> ModIface -> IO ()

+ GHC.Iface.Load: writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO ()

- GHC.Iface.Make: tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl

+ GHC.Iface.Make: tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl

- GHC.Iface.Recomp.Flags: fingerprintDynFlags :: DynFlags -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint

+ GHC.Iface.Recomp.Flags: fingerprintDynFlags :: HscEnv -> Module -> (BinHandle -> Name -> IO ()) -> IO Fingerprint

- GHC.Iface.Syntax: IfaceCompleteMatch :: [IfExtName] -> IfExtName -> IfaceCompleteMatch

+ GHC.Iface.Syntax: IfaceCompleteMatch :: [IfExtName] -> Maybe IfaceTyCon -> IfaceCompleteMatch

- GHC.Iface.Tidy.StaticPtrTable: sptModuleInitCode :: Module -> [SptEntry] -> SDoc

+ GHC.Iface.Tidy.StaticPtrTable: sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub

- GHC.IfaceToCore: importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)

+ GHC.IfaceToCore: importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing)

- GHC.IfaceToCore: tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)

+ GHC.IfaceToCore: tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing)

- GHC.Parser: parseDeclaration :: P (LHsDecl GhcPs)

+ GHC.Parser: parseDeclaration :: P (GenLocated SrcSpanAnnA (HsDecl GhcPs))

- GHC.Parser: parseIdentifier :: P (Located RdrName)

+ GHC.Parser: parseIdentifier :: P (LocatedN RdrName)

- GHC.Parser: parseImport :: P (LImportDecl GhcPs)

+ GHC.Parser: parseImport :: P (GenLocated SrcSpanAnnA (ImportDecl GhcPs))

- GHC.Parser: parsePattern :: P (Located (Pat (GhcPass 'Parsed)))

+ GHC.Parser: parsePattern :: P (GenLocated SrcSpanAnnA (Pat GhcPs))

- GHC.Parser: parseStatement :: P (LStmt GhcPs (LHsExpr GhcPs))

+ GHC.Parser: parseStatement :: P (GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))

- GHC.Parser: parseStmt :: P (Maybe (LStmt GhcPs (LHsExpr GhcPs)))

+ GHC.Parser: parseStmt :: P (Maybe (GenLocated SrcSpanAnnA (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))

- GHC.Parser: parseType :: P (LHsType GhcPs)

+ GHC.Parser: parseType :: P (GenLocated SrcSpanAnnA (HsType GhcPs))

- GHC.Parser: parseTypeSignature :: P (LHsDecl GhcPs)

+ GHC.Parser: parseTypeSignature :: P (GenLocated SrcSpanAnnA (HsDecl GhcPs))

- GHC.Parser.Header: checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()

+ GHC.Parser.Header: checkProcessArgsResult :: MonadIO m => [Located String] -> m ()

- GHC.Parser.Header: getImports :: DynFlags -> StringBuffer -> FilePath -> FilePath -> IO (Either ErrorMessages ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName))

+ GHC.Parser.Header: getImports :: ParserOpts -> Bool -> StringBuffer -> FilePath -> FilePath -> IO (Either (Bag PsError) ([(Maybe FastString, Located ModuleName)], [(Maybe FastString, Located ModuleName)], Located ModuleName))

- GHC.Parser.Header: optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages

+ GHC.Parser.Header: optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc

- GHC.Parser.Lexer: ITblockComment :: String -> Token

+ GHC.Parser.Lexer: ITblockComment :: String -> PsSpan -> Token

- GHC.Parser.Lexer: ITdocCommentNamed :: String -> Token

+ GHC.Parser.Lexer: ITdocCommentNamed :: String -> PsSpan -> Token

- GHC.Parser.Lexer: ITdocCommentNext :: String -> Token

+ GHC.Parser.Lexer: ITdocCommentNext :: String -> PsSpan -> Token

- GHC.Parser.Lexer: ITdocCommentPrev :: String -> Token

+ GHC.Parser.Lexer: ITdocCommentPrev :: String -> PsSpan -> Token

- GHC.Parser.Lexer: ITdocOptions :: String -> Token

+ GHC.Parser.Lexer: ITdocOptions :: String -> PsSpan -> Token

- GHC.Parser.Lexer: ITdocSection :: Int -> String -> Token

+ GHC.Parser.Lexer: ITdocSection :: Int -> String -> PsSpan -> Token

- GHC.Parser.Lexer: ITlineComment :: String -> Token

+ GHC.Parser.Lexer: ITlineComment :: String -> PsSpan -> Token

- GHC.Parser.Lexer: PState :: StringBuffer -> ParserFlags -> (DynFlags -> Messages) -> Maybe RealSrcSpan -> !Int -> Maybe Token -> PsSpan -> !Int -> PsLoc -> [LayoutContext] -> [Int] -> [FastString] -> [PsLocated Token] -> Maybe (PsLocated Token) -> PsSpan -> [ALRContext] -> Maybe ALRLayout -> Bool -> [(ApiAnnKey, [RealSrcSpan])] -> Maybe RealSrcSpan -> [RealLocated AnnotationComment] -> [(RealSrcSpan, [RealLocated AnnotationComment])] -> OrdList (PsLocated HdkComment) -> PState

+ GHC.Parser.Lexer: PState :: StringBuffer -> ParserOpts -> Bag PsWarning -> Bag PsError -> Maybe RealSrcSpan -> !Word -> Maybe (PsLocated Token) -> PsSpan -> PsSpan -> PsSpan -> !Int -> PsLoc -> [LayoutContext] -> [Int] -> [FastString] -> [PsLocated Token] -> Maybe (PsLocated Token) -> PsSpan -> [ALRContext] -> Maybe ALRLayout -> Bool -> Maybe (RealSrcSpan, RealSrcSpan) -> Maybe [LEpaComment] -> [LEpaComment] -> OrdList (PsLocated HdkComment) -> PState

- GHC.Parser.Lexer: [comment_q] :: PState -> [RealLocated AnnotationComment]

+ GHC.Parser.Lexer: [comment_q] :: PState -> [LEpaComment]

- GHC.Parser.Lexer: [eof_pos] :: PState -> Maybe RealSrcSpan

+ GHC.Parser.Lexer: [eof_pos] :: PState -> Maybe (RealSrcSpan, RealSrcSpan)

- GHC.Parser.Lexer: [last_tk] :: PState -> Maybe Token

+ GHC.Parser.Lexer: [last_tk] :: PState -> Maybe (PsLocated Token)

- GHC.Parser.Lexer: [options] :: PState -> ParserFlags

+ GHC.Parser.Lexer: [options] :: PState -> ParserOpts

- GHC.Parser.Lexer: [pExtsBitmap] :: ParserFlags -> !ExtsBitmap

+ GHC.Parser.Lexer: [pExtsBitmap] :: ParserOpts -> !ExtsBitmap

- GHC.Parser.Lexer: [pWarningFlags] :: ParserFlags -> EnumSet WarningFlag

+ GHC.Parser.Lexer: [pWarningFlags] :: ParserOpts -> EnumSet WarningFlag

- GHC.Parser.Lexer: [tab_count] :: PState -> !Int

+ GHC.Parser.Lexer: [tab_count] :: PState -> !Word

- GHC.Parser.Lexer: addError :: MonadP m => SrcSpan -> SDoc -> m ()

+ GHC.Parser.Lexer: addError :: MonadP m => PsError -> m ()

- GHC.Parser.Lexer: addFatalError :: MonadP m => SrcSpan -> SDoc -> m a

+ GHC.Parser.Lexer: addFatalError :: MonadP m => PsError -> m a

- GHC.Parser.Lexer: addWarning :: MonadP m => WarningFlag -> SrcSpan -> SDoc -> m ()

+ GHC.Parser.Lexer: addWarning :: MonadP m => WarningFlag -> PsWarning -> m ()

- GHC.Parser.Lexer: allocateComments :: RealSrcSpan -> [RealLocated AnnotationComment] -> ([RealLocated AnnotationComment], [(RealSrcSpan, [RealLocated AnnotationComment])])

+ GHC.Parser.Lexer: allocateComments :: RealSrcSpan -> [LEpaComment] -> ([LEpaComment], [LEpaComment])

- GHC.Parser.Lexer: commentToAnnotation :: RealLocated Token -> RealLocated AnnotationComment

+ GHC.Parser.Lexer: commentToAnnotation :: RealLocated Token -> LEpaComment

- GHC.Parser.Lexer: failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a

+ GHC.Parser.Lexer: failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a

- GHC.Parser.Lexer: failMsgP :: String -> P a

+ GHC.Parser.Lexer: failMsgP :: (SrcSpan -> PsError) -> P a

- GHC.Parser.Lexer: getErrorMessages :: PState -> DynFlags -> ErrorMessages

+ GHC.Parser.Lexer: getErrorMessages :: PState -> Bag PsError

- GHC.Parser.Lexer: getMessages :: PState -> DynFlags -> Messages

+ GHC.Parser.Lexer: getMessages :: PState -> (Bag PsWarning, Bag PsError)

- GHC.Parser.Lexer: lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]

+ GHC.Parser.Lexer: lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]

- GHC.Parser.PostProcess: ECP :: (forall b. DisambECP b => PV (Located b)) -> ECP

+ GHC.Parser.PostProcess: ECP :: (forall b. DisambECP b => PV (LocatedA b)) -> ECP

- GHC.Parser.PostProcess: ImpExpAllWith :: [Located ImpExpQcSpec] -> ImpExpSubSpec

+ GHC.Parser.PostProcess: ImpExpAllWith :: [LocatedA ImpExpQcSpec] -> ImpExpSubSpec

- GHC.Parser.PostProcess: ImpExpList :: [Located ImpExpQcSpec] -> ImpExpSubSpec

+ GHC.Parser.PostProcess: ImpExpList :: [LocatedA ImpExpQcSpec] -> ImpExpSubSpec

- GHC.Parser.PostProcess: ImpExpQcName :: Located RdrName -> ImpExpQcSpec

+ GHC.Parser.PostProcess: ImpExpQcName :: LocatedN RdrName -> ImpExpQcSpec

- GHC.Parser.PostProcess: ImpExpQcType :: Located RdrName -> ImpExpQcSpec

+ GHC.Parser.PostProcess: ImpExpQcType :: EpaLocation -> LocatedN RdrName -> ImpExpQcSpec

- GHC.Parser.PostProcess: RuleTyTmVar :: Located RdrName -> Maybe (LHsType GhcPs) -> RuleTyTmVar

+ GHC.Parser.PostProcess: RuleTyTmVar :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe (LHsType GhcPs) -> RuleTyTmVar

- GHC.Parser.PostProcess: Sum :: ConTag -> Arity -> Located b -> SumOrTuple b

+ GHC.Parser.PostProcess: Sum :: ConTag -> Arity -> LocatedA b -> [EpaLocation] -> [EpaLocation] -> SumOrTuple b

- GHC.Parser.PostProcess: Tuple :: [Located (Maybe (Located b))] -> SumOrTuple b

+ GHC.Parser.PostProcess: Tuple :: [Either (EpAnn EpaLocation) (LocatedA b)] -> SumOrTuple b

- GHC.Parser.PostProcess: addFatalError :: MonadP m => SrcSpan -> SDoc -> m a

+ GHC.Parser.PostProcess: addFatalError :: MonadP m => PsError -> m a

- GHC.Parser.PostProcess: checkContext :: LHsType GhcPs -> P ([AddAnn], LHsContext GhcPs)

+ GHC.Parser.PostProcess: checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)

- GHC.Parser.PostProcess: checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs]) -> P (Located ([AddAnn], [LConDecl GhcPs]))

+ GHC.Parser.PostProcess: checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs]) -> P (Located ([AddEpAnn], [LConDecl GhcPs]))

- GHC.Parser.PostProcess: checkImportDecl :: Maybe (Located Token) -> Maybe (Located Token) -> P ()

+ GHC.Parser.PostProcess: checkImportDecl :: Maybe EpaLocation -> Maybe EpaLocation -> P ()

- GHC.Parser.PostProcess: checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])

+ GHC.Parser.PostProcess: checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])

- GHC.Parser.PostProcess: checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)

+ GHC.Parser.PostProcess: checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)

- GHC.Parser.PostProcess: checkPrecP :: Located (SourceText, Int) -> Located (OrdList (Located RdrName)) -> P ()

+ GHC.Parser.PostProcess: checkPrecP :: Located (SourceText, Int) -> Located (OrdList (LocatedN RdrName)) -> P ()

- GHC.Parser.PostProcess: checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)

+ GHC.Parser.PostProcess: checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)

- GHC.Parser.PostProcess: checkValDef :: Located (PatBuilder GhcPs) -> Maybe (LHsType GhcPs) -> Located (a, GRHSs GhcPs (LHsExpr GhcPs)) -> P ([AddAnn], HsBind GhcPs)

+ GHC.Parser.PostProcess: checkValDef :: SrcSpan -> LocatedA (PatBuilder GhcPs) -> Maybe (AddEpAnn, LHsType GhcPs) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs)

- GHC.Parser.PostProcess: checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)

+ GHC.Parser.PostProcess: checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)

- GHC.Parser.PostProcess: class b ~ (Body b) GhcPs => DisambECP b where {

+ GHC.Parser.PostProcess: class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where {

- GHC.Parser.PostProcess: cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])

+ GHC.Parser.PostProcess: cvBindsAndSigs :: OrdList (LHsDecl GhcPs) -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs], [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])

- GHC.Parser.PostProcess: ecpFromCmd' :: DisambECP b => LHsCmd GhcPs -> PV (Located b)

+ GHC.Parser.PostProcess: ecpFromCmd' :: DisambECP b => LHsCmd GhcPs -> PV (LocatedA b)

- GHC.Parser.PostProcess: ecpFromExp' :: DisambECP b => LHsExpr GhcPs -> PV (Located b)

+ GHC.Parser.PostProcess: ecpFromExp' :: DisambECP b => LHsExpr GhcPs -> PV (LocatedA b)

- GHC.Parser.PostProcess: failOpFewArgs :: Located RdrName -> P a

+ GHC.Parser.PostProcess: failOpFewArgs :: MonadP m => LocatedN RdrName -> m a

- GHC.Parser.PostProcess: mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs

+ GHC.Parser.PostProcess: mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs

- GHC.Parser.PostProcess: mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo -> P (LTyClDecl GhcPs)

+ GHC.Parser.PostProcess: mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo -> [AddEpAnn] -> P (LTyClDecl GhcPs)

- GHC.Parser.PostProcess: mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs -> ConDecl GhcPs

+ GHC.Parser.PostProcess: mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs

- GHC.Parser.PostProcess: mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (Located CType) -> (Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs], LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LInstDecl GhcPs)

+ GHC.Parser.PostProcess: mkDataFamInst :: SrcSpan -> NewOrData -> Maybe (LocatedP CType) -> (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LInstDecl GhcPs)

- GHC.Parser.PostProcess: mkExport :: Located CCallConv -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs)

+ GHC.Parser.PostProcess: mkExport :: Located CCallConv -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)

- GHC.Parser.PostProcess: mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> LHsType GhcPs -> Located (FamilyResultSig GhcPs) -> Maybe (LInjectivityAnn GhcPs) -> P (LTyClDecl GhcPs)

+ GHC.Parser.PostProcess: mkFamDecl :: SrcSpan -> FamilyInfo GhcPs -> TopLevelFlag -> LHsType GhcPs -> Located (FamilyResultSig GhcPs) -> Maybe (LInjectivityAnn GhcPs) -> [AddEpAnn] -> P (LTyClDecl GhcPs)

- GHC.Parser.PostProcess: mkGadtDecl :: [Located RdrName] -> LHsType GhcPs -> P (ConDecl GhcPs, [AddAnn])

+ GHC.Parser.PostProcess: mkGadtDecl :: SrcSpan -> [LocatedN RdrName] -> LHsSigType GhcPs -> [AddEpAnn] -> P (LConDecl GhcPs)

- GHC.Parser.PostProcess: mkHsAppPV :: DisambECP b => SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsAppPV :: DisambECP b => SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsAppTypePV :: DisambECP b => SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsAppTypePV :: DisambECP b => SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsAsPatPV :: DisambECP b => SrcSpan -> Located RdrName -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsAsPatPV :: DisambECP b => SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsBangPatPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsBangPatPV :: DisambECP b => SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsCasePV :: DisambECP b => SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsCasePV :: DisambECP b => SrcSpan -> LHsExpr GhcPs -> LocatedL [LMatch GhcPs (LocatedA b)] -> EpAnnHsCase -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsConOpPV :: DisambInfixOp b => Located RdrName -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsConOpPV :: DisambInfixOp b => LocatedN RdrName -> PV (LocatedN b)

- GHC.Parser.PostProcess: mkHsDo :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs

+ GHC.Parser.PostProcess: mkHsDo :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs

- GHC.Parser.PostProcess: mkHsDoPV :: DisambECP b => SrcSpan -> Maybe ModuleName -> Located [LStmt GhcPs (Located b)] -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsDoPV :: DisambECP b => SrcSpan -> Maybe ModuleName -> LocatedL [LStmt GhcPs (LocatedA b)] -> AnnList -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsExplicitListPV :: DisambECP b => SrcSpan -> [Located b] -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsExplicitListPV :: DisambECP b => SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsIfPV :: DisambECP b => SrcSpan -> LHsExpr GhcPs -> Bool -> Located b -> Bool -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsIfPV :: DisambECP b => SrcSpan -> LHsExpr GhcPs -> Bool -> LocatedA b -> Bool -> LocatedA b -> AnnsIf -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsInfixHolePV :: DisambInfixOp b => SrcSpan -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsInfixHolePV :: DisambInfixOp b => SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)

- GHC.Parser.PostProcess: mkHsLamCasePV :: DisambECP b => SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsLamCasePV :: DisambECP b => SrcSpan -> LocatedL [LMatch GhcPs (LocatedA b)] -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsLamPV :: DisambECP b => SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsLamPV :: DisambECP b => SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsLazyPatPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsLazyPatPV :: DisambECP b => SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsLetPV :: DisambECP b => SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsLetPV :: DisambECP b => SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsNegAppPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsNegAppPV :: DisambECP b => SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsOpAppPV :: DisambECP b => SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsOpAppPV :: DisambECP b => SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsParPV :: DisambECP b => SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsRecordPV :: DisambECP b => SrcSpan -> SrcSpan -> Located b -> ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsRecordPV :: DisambECP b => Bool -> SrcSpan -> SrcSpan -> LocatedA b -> ([Fbind b], Maybe SrcSpan) -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsSectionR_PV :: DisambECP b => SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsSectionR_PV :: DisambECP b => SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b)

- GHC.Parser.PostProcess: mkHsTySigPV :: DisambECP b => SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsTySigPV :: DisambECP b => SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsVarOpPV :: DisambInfixOp b => Located RdrName -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsVarOpPV :: DisambInfixOp b => LocatedN RdrName -> PV (LocatedN b)

- GHC.Parser.PostProcess: mkHsVarPV :: DisambECP b => Located RdrName -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsVarPV :: DisambECP b => LocatedN RdrName -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkHsViewPatPV :: DisambECP b => SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b)

+ GHC.Parser.PostProcess: mkHsViewPatPV :: DisambECP b => SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)

+ GHC.Parser.PostProcess: mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)

- GHC.Parser.PostProcess: mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs) -> P (HsDecl GhcPs)

+ GHC.Parser.PostProcess: mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)

- GHC.Parser.PostProcess: mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)

+ GHC.Parser.PostProcess: mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)

- GHC.Parser.PostProcess: mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)

+ GHC.Parser.PostProcess: mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs

- GHC.Parser.PostProcess: mkPatSynMatchGroup :: Located RdrName -> Located (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs))

+ GHC.Parser.PostProcess: mkPatSynMatchGroup :: LocatedN RdrName -> LocatedL (OrdList (LHsDecl GhcPs)) -> P (MatchGroup GhcPs (LHsExpr GhcPs))

- GHC.Parser.PostProcess: mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs

+ GHC.Parser.PostProcess: mkRdrRecordCon :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs

- GHC.Parser.PostProcess: mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs

+ GHC.Parser.PostProcess: mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)

- GHC.Parser.PostProcess: mkRecConstrOrUpdate :: LHsExpr GhcPs -> SrcSpan -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan) -> PV (HsExpr GhcPs)

+ GHC.Parser.PostProcess: mkRecConstrOrUpdate :: Bool -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)

- GHC.Parser.PostProcess: mkRoleAnnotDecl :: SrcSpan -> Located RdrName -> [Located (Maybe FastString)] -> P (LRoleAnnotDecl GhcPs)

+ GHC.Parser.PostProcess: mkRoleAnnotDecl :: SrcSpan -> LocatedN RdrName -> [Located (Maybe FastString)] -> [AddEpAnn] -> P (LRoleAnnotDecl GhcPs)

- GHC.Parser.PostProcess: mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs

+ GHC.Parser.PostProcess: mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)

- GHC.Parser.PostProcess: mkStandaloneKindSig :: SrcSpan -> Located [Located RdrName] -> LHsKind GhcPs -> P (LStandaloneKindSig GhcPs)

+ GHC.Parser.PostProcess: mkStandaloneKindSig :: SrcSpan -> Located [LocatedN RdrName] -> LHsSigType GhcPs -> [AddEpAnn] -> P (LStandaloneKindSig GhcPs)

- GHC.Parser.PostProcess: mkSumOrTuplePV :: DisambECP b => SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)

+ GHC.Parser.PostProcess: mkSumOrTuplePV :: DisambECP b => SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)

- GHC.Parser.PostProcess: mkTyData :: SrcSpan -> NewOrData -> Maybe (Located CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> HsDeriving GhcPs -> P (LTyClDecl GhcPs)

+ GHC.Parser.PostProcess: mkTyData :: SrcSpan -> NewOrData -> Maybe (LocatedP CType) -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Maybe (LHsKind GhcPs) -> [LConDecl GhcPs] -> Located (HsDeriving GhcPs) -> [AddEpAnn] -> P (LTyClDecl GhcPs)

- GHC.Parser.PostProcess: mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> P (LInstDecl GhcPs)

+ GHC.Parser.PostProcess: mkTyFamInst :: SrcSpan -> TyFamInstEqn GhcPs -> [AddEpAnn] -> P (LInstDecl GhcPs)

- GHC.Parser.PostProcess: mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs] -> LHsType GhcPs -> LHsType GhcPs -> P (TyFamInstEqn GhcPs, [AddAnn])

+ GHC.Parser.PostProcess: mkTyFamInstEqn :: SrcSpan -> HsOuterFamEqnTyVarBndrs GhcPs -> LHsType GhcPs -> LHsType GhcPs -> [AddEpAnn] -> P (LTyFamInstEqn GhcPs)

- GHC.Parser.PostProcess: mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> P (LTyClDecl GhcPs)

+ GHC.Parser.PostProcess: mkTySynonym :: SrcSpan -> LHsType GhcPs -> LHsType GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs)

- GHC.Parser.PostProcess: mkTypeImpExp :: Located RdrName -> P (Located RdrName)

+ GHC.Parser.PostProcess: mkTypeImpExp :: LocatedN RdrName -> P (LocatedN RdrName)

- GHC.Parser.PostProcess: placeHolderPunRhs :: DisambECP b => PV (Located b)

+ GHC.Parser.PostProcess: placeHolderPunRhs :: DisambECP b => PV (LocatedA b)

- GHC.Parser.PostProcess: rejectPragmaPV :: DisambECP b => Located b -> PV ()

+ GHC.Parser.PostProcess: rejectPragmaPV :: DisambECP b => LocatedA b -> PV ()

- GHC.Parser.PostProcess: superFunArg :: DisambECP b => (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b)

+ GHC.Parser.PostProcess: superFunArg :: DisambECP b => (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)

- GHC.Parser.PostProcess: superInfixOp :: DisambECP b => (DisambInfixOp (InfixOp b) => PV (Located b)) -> PV (Located b)

+ GHC.Parser.PostProcess: superInfixOp :: DisambECP b => (DisambInfixOp (InfixOp b) => PV (LocatedA b)) -> PV (LocatedA b)

- GHC.Plugins: CoercionHole :: CoVar -> BlockSubstFlag -> IORef (Maybe Coercion) -> CoercionHole

+ GHC.Plugins: CoercionHole :: CoVar -> IORef (Maybe Coercion) -> CoercionHole

- GHC.Plugins: mkSubCo :: Coercion -> Coercion

+ GHC.Plugins: mkSubCo :: HasDebugCallStack => Coercion -> Coercion

- GHC.Plugins: nameIsFromExternalPackage :: Unit -> Name -> Bool

+ GHC.Plugins: nameIsFromExternalPackage :: HomeUnit -> Name -> Bool

- GHC.Plugins: simplifyArgsWorker :: [TyCoBinder] -> Kind -> TyCoVarSet -> [Role] -> [(Type, Coercion)] -> ([Type], [Coercion], CoercionN)

+ GHC.Plugins: simplifyArgsWorker :: [TyCoBinder] -> Kind -> TyCoVarSet -> [Role] -> [(Type, Coercion)] -> ([Type], [Coercion], MCoercionN)

- GHC.Plugins: splitFunTy :: Type -> (Type, Type, Type)

+ GHC.Plugins: splitFunTy :: Type -> (Mult, Type, Type)

- GHC.Plugins: splitFunTy_maybe :: Type -> Maybe (Type, Type, Type)

+ GHC.Plugins: splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type)

- GHC.Plugins: substTickish :: Subst -> Tickish Id -> Tickish Id

+ GHC.Plugins: substTickish :: Subst -> CoreTickish -> CoreTickish

- GHC.Prelude: class Foldable (t :: Type -> Type)

+ GHC.Prelude: class Foldable (t :: TYPE LiftedRep -> Type)

- GHC.Prelude: infixl 1 >>

+ GHC.Prelude: infixl 1 >>=

- GHC.Prelude: infixl 6 +

+ GHC.Prelude: infixl 6 `xor`

- GHC.Prelude: infixl 7 *

+ GHC.Prelude: infixl 7 .&.

- GHC.Rename.Bind: rnGRHS :: HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> LGRHS GhcPs (Located (body GhcPs)) -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)

+ GHC.Rename.Bind: rnGRHS :: AnnoBody body => HsMatchContext GhcRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> LGRHS GhcPs (LocatedA (body GhcPs)) -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars)

- GHC.Rename.Bind: rnGRHSs :: HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> GRHSs GhcPs (Located (body GhcPs)) -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)

+ GHC.Rename.Bind: rnGRHSs :: AnnoBody body => HsMatchContext GhcRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> GRHSs GhcPs (LocatedA (body GhcPs)) -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)

- GHC.Rename.Bind: rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> MatchGroup GhcPs (Located (body GhcPs)) -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)

+ GHC.Rename.Bind: rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars)) -> MatchGroup GhcPs (LocatedA (body GhcPs)) -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)

- GHC.Rename.Env: IncorrectParent :: Name -> Name -> SDoc -> [Name] -> ChildLookupResult

+ GHC.Rename.Env: IncorrectParent :: Name -> GreName -> [Name] -> ChildLookupResult

- GHC.Rename.Env: lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name)

+ GHC.Rename.Env: lookupFamInstName :: Maybe Name -> LocatedN RdrName -> RnM (LocatedN Name)

- GHC.Rename.Env: lookupIfThenElse :: Bool -> RnM (SyntaxExpr GhcRn, FreeVars)

+ GHC.Rename.Env: lookupIfThenElse :: RnM (Maybe Name)

- GHC.Rename.Env: lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)

+ GHC.Rename.Env: lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName -> TcRn (GenLocated (SrcSpanAnn' ann) Name)

- GHC.Rename.Env: lookupSigCtxtOccRn :: HsSigCtxt -> SDoc -> Located RdrName -> RnM (Located Name)

+ GHC.Rename.Env: lookupSigCtxtOccRn :: HsSigCtxt -> SDoc -> LocatedA RdrName -> RnM (LocatedA Name)

- GHC.Rename.Env: lookupSigOccRn :: HsSigCtxt -> Sig GhcPs -> Located RdrName -> RnM (Located Name)

+ GHC.Rename.Env: lookupSigOccRn :: HsSigCtxt -> Sig GhcPs -> LocatedA RdrName -> RnM (LocatedA Name)

- GHC.Rename.Env: newTopSrcBinder :: Located RdrName -> RnM Name

+ GHC.Rename.Env: newTopSrcBinder :: LocatedN RdrName -> RnM Name

- GHC.Rename.Expr: rnStmts :: Outputable (body GhcPs) => HsStmtContext GhcRn -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)

+ GHC.Rename.Expr: rnStmts :: AnnoBody body => HsStmtContext GhcRn -> (body GhcPs -> RnM (body GhcRn, FreeVars)) -> [LStmt GhcPs (LocatedA (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)

- GHC.Rename.Fixity: lookupTyFixityRn :: Located Name -> RnM Fixity

+ GHC.Rename.Fixity: lookupTyFixityRn :: LocatedN Name -> RnM Fixity

- GHC.Rename.HsType: AlwaysBind :: HsSigWcTypeScoping

+ GHC.Rename.HsType: AlwaysBind :: HsPatSigTypeScoping

- GHC.Rename.HsType: NeverBind :: HsSigWcTypeScoping

+ GHC.Rename.HsType: NeverBind :: HsPatSigTypeScoping

- GHC.Rename.HsType: bindLHsTyVarBndrs :: OutputableBndrFlag flag => HsDocContext -> WarnUnusedForalls -> Maybe a -> [LHsTyVarBndr flag GhcPs] -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)

+ GHC.Rename.HsType: bindLHsTyVarBndrs :: OutputableBndrFlag flag 'Renamed => HsDocContext -> WarnUnusedForalls -> Maybe a -> [LHsTyVarBndr flag GhcPs] -> ([LHsTyVarBndr flag GhcRn] -> RnM (b, FreeVars)) -> RnM (b, FreeVars)

- GHC.Rename.HsType: mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)

+ GHC.Rename.HsType: mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn -> RnM (Pat GhcRn)

- GHC.Rename.HsType: mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id) -> RnM (HsExpr (GhcPass id))

+ GHC.Rename.HsType: mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn)

- GHC.Rename.HsType: newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name

+ GHC.Rename.HsType: newTyVarNameRn :: Maybe a -> LocatedN RdrName -> RnM Name

- GHC.Rename.HsType: nubL :: Eq a => [Located a] -> [Located a]

+ GHC.Rename.HsType: nubL :: Eq a => [GenLocated l a] -> [GenLocated l a]

- GHC.Rename.HsType: rnContext :: HsDocContext -> LHsContext GhcPs -> RnM (LHsContext GhcRn, FreeVars)

+ GHC.Rename.HsType: rnContext :: HsDocContext -> Maybe (LHsContext GhcPs) -> RnM (Maybe (LHsContext GhcRn), FreeVars)

- GHC.Rename.HsType: rnHsPatSigType :: HsSigWcTypeScoping -> HsDocContext -> HsPatSigType GhcPs -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars)

+ GHC.Rename.HsType: rnHsPatSigType :: HsPatSigTypeScoping -> HsDocContext -> HsPatSigType GhcPs -> (HsPatSigType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars)

- GHC.Rename.HsType: rnLTyVar :: Located RdrName -> RnM (Located Name)

+ GHC.Rename.HsType: rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name)

- GHC.Rename.HsType: type FreeKiTyVars = [Located RdrName]

+ GHC.Rename.HsType: type FreeKiTyVars = [LocatedN RdrName]

- GHC.Rename.Names: calculateAvails :: DynFlags -> ModIface -> IsSafeImport -> IsBootInterface -> ImportedBy -> ImportAvails

+ GHC.Rename.Names: calculateAvails :: HomeUnit -> ModIface -> IsSafeImport -> IsBootInterface -> ImportedBy -> ImportAvails

- GHC.Rename.Names: newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel

+ GHC.Rename.Names: newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel

- GHC.Rename.Pat: applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)

+ GHC.Rename.Pat: applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name)

- GHC.Rename.Pat: rnHsRecFields :: forall arg. HsRecFieldContext -> (SrcSpan -> RdrName -> arg) -> HsRecFields GhcPs (Located arg) -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)

+ GHC.Rename.Pat: rnHsRecFields :: forall arg. HsRecFieldContext -> (SrcSpan -> RdrName -> arg) -> HsRecFields GhcPs (LocatedA arg) -> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)

- GHC.Rename.Utils: ClassDeclCtx :: Located RdrName -> HsDocContext

+ GHC.Rename.Utils: ClassDeclCtx :: LocatedN RdrName -> HsDocContext

- GHC.Rename.Utils: ConDeclCtx :: [Located Name] -> HsDocContext

+ GHC.Rename.Utils: ConDeclCtx :: [LocatedN Name] -> HsDocContext

- GHC.Rename.Utils: FamPatCtx :: Located RdrName -> HsDocContext

+ GHC.Rename.Utils: FamPatCtx :: LocatedN RdrName -> HsDocContext

- GHC.Rename.Utils: ForeignDeclCtx :: Located RdrName -> HsDocContext

+ GHC.Rename.Utils: ForeignDeclCtx :: LocatedN RdrName -> HsDocContext

- GHC.Rename.Utils: TyDataCtx :: Located RdrName -> HsDocContext

+ GHC.Rename.Utils: TyDataCtx :: LocatedN RdrName -> HsDocContext

- GHC.Rename.Utils: TyFamilyCtx :: Located RdrName -> HsDocContext

+ GHC.Rename.Utils: TyFamilyCtx :: LocatedN RdrName -> HsDocContext

- GHC.Rename.Utils: TySynCtx :: Located RdrName -> HsDocContext

+ GHC.Rename.Utils: TySynCtx :: LocatedN RdrName -> HsDocContext

- GHC.Rename.Utils: addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()

+ GHC.Rename.Utils: addNameClashErrRn :: RdrName -> NonEmpty GlobalRdrElt -> RnM ()

- GHC.Rename.Utils: checkDupRdrNames :: [Located RdrName] -> RnM ()

+ GHC.Rename.Utils: checkDupRdrNames :: [LocatedN RdrName] -> RnM ()

- GHC.Rename.Utils: checkShadowedRdrNames :: [Located RdrName] -> RnM ()

+ GHC.Rename.Utils: checkShadowedRdrNames :: [LocatedN RdrName] -> RnM ()

- GHC.Rename.Utils: checkTupSize :: Int -> RnM ()

+ GHC.Rename.Utils: checkTupSize :: Int -> TcM ()

- GHC.Rename.Utils: mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)

+ GHC.Rename.Utils: mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent)

- GHC.Rename.Utils: newLocalBndrRn :: Located RdrName -> RnM Name

+ GHC.Rename.Utils: newLocalBndrRn :: LocatedN RdrName -> RnM Name

- GHC.Rename.Utils: newLocalBndrsRn :: [Located RdrName] -> RnM [Name]

+ GHC.Rename.Utils: newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name]

- GHC.Runtime.Eval: getDocs :: GhcMonad m => Name -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))

+ GHC.Runtime.Eval: getDocs :: GhcMonad m => Name -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))

- GHC.Runtime.Eval: resumeExec :: GhcMonad m => (SrcSpan -> Bool) -> SingleStep -> m ExecResult

+ GHC.Runtime.Eval: resumeExec :: GhcMonad m => (SrcSpan -> Bool) -> SingleStep -> Maybe Int -> m ExecResult

- GHC.Runtime.Heap.Layout: arrPtrsHdrSize :: DynFlags -> ByteOff

+ GHC.Runtime.Heap.Layout: arrPtrsHdrSize :: Profile -> ByteOff

- GHC.Runtime.Heap.Layout: arrPtrsHdrSizeW :: DynFlags -> WordOff

+ GHC.Runtime.Heap.Layout: arrPtrsHdrSizeW :: Profile -> WordOff

- GHC.Runtime.Heap.Layout: arrPtrsRep :: DynFlags -> WordOff -> SMRep

+ GHC.Runtime.Heap.Layout: arrPtrsRep :: Platform -> WordOff -> SMRep

- GHC.Runtime.Heap.Layout: arrWordsHdrSize :: DynFlags -> ByteOff

+ GHC.Runtime.Heap.Layout: arrWordsHdrSize :: Profile -> ByteOff

- GHC.Runtime.Heap.Layout: arrWordsHdrSizeW :: DynFlags -> WordOff

+ GHC.Runtime.Heap.Layout: arrWordsHdrSizeW :: Profile -> WordOff

- GHC.Runtime.Heap.Layout: card :: DynFlags -> Int -> Int

+ GHC.Runtime.Heap.Layout: card :: Platform -> Int -> Int

- GHC.Runtime.Heap.Layout: cardRoundUp :: DynFlags -> Int -> Int

+ GHC.Runtime.Heap.Layout: cardRoundUp :: Platform -> Int -> Int

- GHC.Runtime.Heap.Layout: cardTableSizeB :: DynFlags -> Int -> ByteOff

+ GHC.Runtime.Heap.Layout: cardTableSizeB :: Platform -> Int -> ByteOff

- GHC.Runtime.Heap.Layout: cardTableSizeW :: DynFlags -> Int -> WordOff

+ GHC.Runtime.Heap.Layout: cardTableSizeW :: Platform -> Int -> WordOff

- GHC.Runtime.Heap.Layout: fixedHdrSize :: DynFlags -> ByteOff

+ GHC.Runtime.Heap.Layout: fixedHdrSize :: Profile -> ByteOff

- GHC.Runtime.Heap.Layout: fixedHdrSizeW :: DynFlags -> WordOff

+ GHC.Runtime.Heap.Layout: fixedHdrSizeW :: Profile -> WordOff

- GHC.Runtime.Heap.Layout: hdrSize :: DynFlags -> SMRep -> ByteOff

+ GHC.Runtime.Heap.Layout: hdrSize :: Profile -> SMRep -> ByteOff

- GHC.Runtime.Heap.Layout: hdrSizeW :: DynFlags -> SMRep -> WordOff

+ GHC.Runtime.Heap.Layout: hdrSizeW :: Profile -> SMRep -> WordOff

- GHC.Runtime.Heap.Layout: heapClosureSizeW :: DynFlags -> SMRep -> WordOff

+ GHC.Runtime.Heap.Layout: heapClosureSizeW :: Profile -> SMRep -> WordOff

- GHC.Runtime.Heap.Layout: mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep

+ GHC.Runtime.Heap.Layout: mkHeapRep :: Profile -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo -> SMRep

- GHC.Runtime.Heap.Layout: profHdrSize :: DynFlags -> WordOff

+ GHC.Runtime.Heap.Layout: profHdrSize :: Profile -> WordOff

- GHC.Runtime.Heap.Layout: smallArrPtrsHdrSize :: DynFlags -> ByteOff

+ GHC.Runtime.Heap.Layout: smallArrPtrsHdrSize :: Profile -> ByteOff

- GHC.Runtime.Heap.Layout: smallArrPtrsHdrSizeW :: DynFlags -> WordOff

+ GHC.Runtime.Heap.Layout: smallArrPtrsHdrSizeW :: Profile -> WordOff

- GHC.Runtime.Heap.Layout: thunkHdrSize :: DynFlags -> WordOff

+ GHC.Runtime.Heap.Layout: thunkHdrSize :: Profile -> WordOff

- GHC.Runtime.Interpreter: abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()

+ GHC.Runtime.Interpreter: abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()

- GHC.Runtime.Interpreter: addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())

+ GHC.Runtime.Interpreter: addLibrarySearchPath :: Interp -> String -> IO (Ptr ())

- GHC.Runtime.Interpreter: addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()

+ GHC.Runtime.Interpreter: addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()

- GHC.Runtime.Interpreter: breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool

+ GHC.Runtime.Interpreter: breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool

- GHC.Runtime.Interpreter: costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]

+ GHC.Runtime.Interpreter: costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]

- GHC.Runtime.Interpreter: createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]

+ GHC.Runtime.Interpreter: createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]

- GHC.Runtime.Interpreter: evalIO :: HscEnv -> ForeignHValue -> IO ()

+ GHC.Runtime.Interpreter: evalIO :: Interp -> ForeignHValue -> IO ()

- GHC.Runtime.Interpreter: evalStmt :: HscEnv -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus_ [ForeignHValue] [HValueRef])

+ GHC.Runtime.Interpreter: evalStmt :: Interp -> DynFlags -> Bool -> EvalExpr ForeignHValue -> IO (EvalStatus_ [ForeignHValue] [HValueRef])

- GHC.Runtime.Interpreter: evalString :: HscEnv -> ForeignHValue -> IO String

+ GHC.Runtime.Interpreter: evalString :: Interp -> ForeignHValue -> IO String

- GHC.Runtime.Interpreter: evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String

+ GHC.Runtime.Interpreter: evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String

- GHC.Runtime.Interpreter: findSystemLibrary :: HscEnv -> String -> IO (Maybe String)

+ GHC.Runtime.Interpreter: findSystemLibrary :: Interp -> String -> IO (Maybe String)

- GHC.Runtime.Interpreter: freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()

+ GHC.Runtime.Interpreter: freeHValueRefs :: Interp -> [HValueRef] -> IO ()

- GHC.Runtime.Interpreter: getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)

+ GHC.Runtime.Interpreter: getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)

- GHC.Runtime.Interpreter: getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)

+ GHC.Runtime.Interpreter: getClosure :: Interp -> ForeignHValue -> IO (GenClosure ForeignHValue)

- GHC.Runtime.Interpreter: initObjLinker :: HscEnv -> IO ()

+ GHC.Runtime.Interpreter: initObjLinker :: Interp -> IO ()

- GHC.Runtime.Interpreter: loadArchive :: HscEnv -> String -> IO ()

+ GHC.Runtime.Interpreter: loadArchive :: Interp -> String -> IO ()

- GHC.Runtime.Interpreter: loadDLL :: HscEnv -> String -> IO (Maybe String)

+ GHC.Runtime.Interpreter: loadDLL :: Interp -> String -> IO (Maybe String)

- GHC.Runtime.Interpreter: loadObj :: HscEnv -> String -> IO ()

+ GHC.Runtime.Interpreter: loadObj :: Interp -> String -> IO ()

- GHC.Runtime.Interpreter: lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)

+ GHC.Runtime.Interpreter: lookupClosure :: Interp -> String -> IO (Maybe HValueRef)

- GHC.Runtime.Interpreter: lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))

+ GHC.Runtime.Interpreter: lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))

- GHC.Runtime.Interpreter: mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())

+ GHC.Runtime.Interpreter: mallocData :: Interp -> ByteString -> IO (RemotePtr ())

- GHC.Runtime.Interpreter: mkCostCentres :: HscEnv -> String -> [(String, String)] -> IO [RemotePtr CostCentre]

+ GHC.Runtime.Interpreter: mkCostCentres :: Interp -> String -> [(String, String)] -> IO [RemotePtr CostCentre]

- GHC.Runtime.Interpreter: mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)

+ GHC.Runtime.Interpreter: mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)

- GHC.Runtime.Interpreter: newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)

+ GHC.Runtime.Interpreter: newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)

- GHC.Runtime.Interpreter: purgeLookupSymbolCache :: HscEnv -> IO ()

+ GHC.Runtime.Interpreter: purgeLookupSymbolCache :: Interp -> IO ()

- GHC.Runtime.Interpreter: removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool

+ GHC.Runtime.Interpreter: removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool

- GHC.Runtime.Interpreter: resolveObjs :: HscEnv -> IO SuccessFlag

+ GHC.Runtime.Interpreter: resolveObjs :: Interp -> IO SuccessFlag

- GHC.Runtime.Interpreter: resumeStmt :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef]) -> IO (EvalStatus_ [ForeignHValue] [HValueRef])

+ GHC.Runtime.Interpreter: resumeStmt :: Interp -> DynFlags -> Bool -> ForeignRef (ResumeContext [HValueRef]) -> IO (EvalStatus_ [ForeignHValue] [HValueRef])

- GHC.Runtime.Interpreter: seqHValue :: HscEnv -> ForeignHValue -> IO (EvalResult ())

+ GHC.Runtime.Interpreter: seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())

- GHC.Runtime.Interpreter: stopInterp :: HscEnv -> IO ()

+ GHC.Runtime.Interpreter: stopInterp :: Interp -> IO ()

- GHC.Runtime.Interpreter: unloadObj :: HscEnv -> String -> IO ()

+ GHC.Runtime.Interpreter: unloadObj :: Interp -> String -> IO ()

- GHC.Runtime.Interpreter.Types: ExternalInterp :: !IServConfig -> !IServ -> Interp

+ GHC.Runtime.Interpreter.Types: ExternalInterp :: !IServConfig -> !IServ -> InterpInstance

- GHC.Runtime.Interpreter.Types: InternalInterp :: Interp

+ GHC.Runtime.Interpreter.Types: InternalInterp :: InterpInstance

- GHC.Runtime.Loader: getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)

+ GHC.Runtime.Loader: getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)

- GHC.Runtime.Loader: initializePlugins :: HscEnv -> DynFlags -> IO DynFlags

+ GHC.Runtime.Loader: initializePlugins :: HscEnv -> IO HscEnv

- GHC.Runtime.Loader: lessUnsafeCoerce :: DynFlags -> String -> a -> IO b

+ GHC.Runtime.Loader: lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b

- GHC.Settings: Platform :: !PlatformMini -> !PlatformWordSize -> !ByteOrder -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> Platform

+ GHC.Settings: Platform :: !ArchOS -> !PlatformWordSize -> !ByteOrder -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Maybe PlatformConstants -> Platform

- GHC.Settings: PlatformMisc :: String -> Bool -> Bool -> String -> Bool -> Bool -> Bool -> Bool -> String -> PlatformMisc

+ GHC.Settings: PlatformMisc :: String -> Bool -> Bool -> String -> Bool -> Bool -> String -> PlatformMisc

- GHC.Settings: Settings :: {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> PlatformConstants -> [(String, String)] -> Settings

+ GHC.Settings: Settings :: {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> Settings

- GHC.Stg.Lift.Analysis: RhsSk :: !DmdShell -> !Skeleton -> Skeleton

+ GHC.Stg.Lift.Analysis: RhsSk :: !Card -> !Skeleton -> Skeleton

- GHC.Stg.Lint: lintStgTopBindings :: forall a. (OutputablePass a, BinderP a ~ Id) => DynFlags -> Module -> Bool -> String -> [GenStgTopBinding a] -> IO ()

+ GHC.Stg.Lint: lintStgTopBindings :: forall a. (OutputablePass a, BinderP a ~ Id) => Logger -> DynFlags -> InteractiveContext -> Module -> Bool -> String -> [GenStgTopBinding a] -> IO ()

- GHC.Stg.Pipeline: stg2stg :: DynFlags -> Module -> [StgTopBinding] -> IO [StgTopBinding]

+ GHC.Stg.Pipeline: stg2stg :: Logger -> DynFlags -> InteractiveContext -> Module -> [StgTopBinding] -> IO [StgTopBinding]

- GHC.Stg.Syntax: StgConApp :: DataCon -> [StgArg] -> [Type] -> GenStgExpr pass

+ GHC.Stg.Syntax: StgConApp :: DataCon -> XConApp pass -> [StgArg] -> [Type] -> GenStgExpr pass

- GHC.Stg.Syntax: StgRhsCon :: CostCentreStack -> DataCon -> [StgArg] -> GenStgRhs pass

+ GHC.Stg.Syntax: StgRhsCon :: CostCentreStack -> DataCon -> ConstructorNumber -> [StgTickish] -> [StgArg] -> GenStgRhs pass

- GHC.Stg.Syntax: StgTick :: Tickish Id -> GenStgExpr pass -> GenStgExpr pass

+ GHC.Stg.Syntax: StgTick :: StgTickish -> GenStgExpr pass -> GenStgExpr pass

- GHC.Stg.Syntax: stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)

+ GHC.Stg.Syntax: stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p)

- GHC.Stg.Syntax: stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p

+ GHC.Stg.Syntax: stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p

- GHC.Stg.Syntax: type OutputablePass pass = (Outputable (XLet pass), Outputable (XLetNoEscape pass), Outputable (XRhsClosure pass), OutputableBndr (BinderP pass))

+ GHC.Stg.Syntax: type OutputablePass pass = (Outputable (XLet pass), Outputable (XConApp pass), Outputable (XLetNoEscape pass), Outputable (XRhsClosure pass), OutputableBndr (BinderP pass))

- GHC.Stg.Syntax: type family XLetNoEscape (pass :: StgPass)

+ GHC.Stg.Syntax: type family XConApp (pass :: StgPass)

- GHC.StgToCmm: codeGen :: DynFlags -> Module -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos

+ GHC.StgToCmm: codeGen :: Logger -> TmpFs -> DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos)

- GHC.StgToCmm.ArgRep: idArgRep :: Id -> ArgRep

+ GHC.StgToCmm.ArgRep: idArgRep :: Platform -> Id -> ArgRep

- GHC.StgToCmm.ArgRep: toArgRep :: PrimRep -> ArgRep

+ GHC.StgToCmm.ArgRep: toArgRep :: Platform -> PrimRep -> ArgRep

- GHC.StgToCmm.Bind: cgTopRhsClosure :: DynFlags -> RecFlag -> Id -> CostCentreStack -> UpdateFlag -> [Id] -> CgStgExpr -> (CgIdInfo, FCode ())

+ GHC.StgToCmm.Bind: cgTopRhsClosure :: Platform -> RecFlag -> Id -> CostCentreStack -> UpdateFlag -> [Id] -> CgStgExpr -> (CgIdInfo, FCode ())

- GHC.StgToCmm.Bind: emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()

+ GHC.StgToCmm.Bind: emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()

- GHC.StgToCmm.CgUtils: baseRegOffset :: DynFlags -> GlobalReg -> Int

+ GHC.StgToCmm.CgUtils: baseRegOffset :: Platform -> GlobalReg -> Int

- GHC.StgToCmm.CgUtils: fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl

+ GHC.StgToCmm.CgUtils: fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl

- GHC.StgToCmm.CgUtils: get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr

+ GHC.StgToCmm.CgUtils: get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr

- GHC.StgToCmm.CgUtils: get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr

+ GHC.StgToCmm.CgUtils: get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr

- GHC.StgToCmm.CgUtils: regTableOffset :: DynFlags -> Int -> CmmExpr

+ GHC.StgToCmm.CgUtils: regTableOffset :: Platform -> Int -> CmmExpr

- GHC.StgToCmm.Closure: closureSlowEntryLabel :: ClosureInfo -> CLabel

+ GHC.StgToCmm.Closure: closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel

- GHC.StgToCmm.Closure: funTag :: DynFlags -> ClosureInfo -> DynTag

+ GHC.StgToCmm.Closure: funTag :: Platform -> ClosureInfo -> DynTag

- GHC.StgToCmm.Closure: getCallMethod :: DynFlags -> Name -> Id -> LambdaFormInfo -> RepArity -> RepArity -> CgLoc -> Maybe SelfLoopInfo -> CallMethod

+ GHC.StgToCmm.Closure: getCallMethod :: CallOpts -> Name -> Id -> LambdaFormInfo -> RepArity -> RepArity -> CgLoc -> Maybe SelfLoopInfo -> CallMethod

- GHC.StgToCmm.Closure: isSmallFamily :: DynFlags -> Int -> Bool

+ GHC.StgToCmm.Closure: isSmallFamily :: Platform -> Int -> Bool

- GHC.StgToCmm.Closure: lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag

+ GHC.StgToCmm.Closure: lfDynTag :: Platform -> LambdaFormInfo -> DynTag

- GHC.StgToCmm.Closure: mkClosureInfo :: DynFlags -> Bool -> Id -> LambdaFormInfo -> Int -> Int -> String -> ClosureInfo

+ GHC.StgToCmm.Closure: mkClosureInfo :: Profile -> Bool -> Id -> LambdaFormInfo -> Int -> Int -> String -> ClosureInfo

- GHC.StgToCmm.Closure: mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable

+ GHC.StgToCmm.Closure: mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable

- GHC.StgToCmm.Closure: nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool

+ GHC.StgToCmm.Closure: nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool

- GHC.StgToCmm.Closure: staticClosureLabel :: ClosureInfo -> CLabel

+ GHC.StgToCmm.Closure: staticClosureLabel :: Platform -> ClosureInfo -> CLabel

- GHC.StgToCmm.Closure: tagForArity :: DynFlags -> RepArity -> DynTag

+ GHC.StgToCmm.Closure: tagForArity :: Platform -> RepArity -> DynTag

- GHC.StgToCmm.Closure: tagForCon :: DynFlags -> DataCon -> DynTag

+ GHC.StgToCmm.Closure: tagForCon :: Platform -> DataCon -> DynTag

- GHC.StgToCmm.DataCon: buildDynCon :: Id -> Bool -> CostCentreStack -> DataCon -> [NonVoid StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)

+ GHC.StgToCmm.DataCon: buildDynCon :: Id -> ConstructorNumber -> Bool -> CostCentreStack -> DataCon -> [NonVoid StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)

- GHC.StgToCmm.DataCon: cgTopRhsCon :: DynFlags -> Id -> DataCon -> [NonVoid StgArg] -> (CgIdInfo, FCode ())

+ GHC.StgToCmm.DataCon: cgTopRhsCon :: DynFlags -> Id -> DataCon -> ConstructorNumber -> [NonVoid StgArg] -> (CgIdInfo, FCode ())

- GHC.StgToCmm.Env: litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo

+ GHC.StgToCmm.Env: litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo

- GHC.StgToCmm.Env: mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph

+ GHC.StgToCmm.Env: mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph

- GHC.StgToCmm.Foreign: loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph

+ GHC.StgToCmm.Foreign: loadThreadState :: MonadUnique m => Profile -> m CmmAGraph

- GHC.StgToCmm.Foreign: saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph

+ GHC.StgToCmm.Foreign: saveThreadState :: MonadUnique m => Profile -> m CmmAGraph

- GHC.StgToCmm.Heap: mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]

+ GHC.StgToCmm.Heap: mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]

- GHC.StgToCmm.Heap: mkStaticClosureFields :: DynFlags -> CmmInfoTable -> CostCentreStack -> CafInfo -> [CmmLit] -> [CmmLit]

+ GHC.StgToCmm.Heap: mkStaticClosureFields :: Profile -> CmmInfoTable -> CostCentreStack -> CafInfo -> [CmmLit] -> [CmmLit]

- GHC.StgToCmm.Layout: emitClosureAndInfoTable :: CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()

+ GHC.StgToCmm.Layout: emitClosureAndInfoTable :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()

- GHC.StgToCmm.Layout: mkVirtConstrOffsets :: DynFlags -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)])

+ GHC.StgToCmm.Layout: mkVirtConstrOffsets :: Profile -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)])

- GHC.StgToCmm.Layout: mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)

+ GHC.StgToCmm.Layout: mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)

- GHC.StgToCmm.Layout: mkVirtHeapOffsets :: DynFlags -> ClosureHeader -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)])

+ GHC.StgToCmm.Layout: mkVirtHeapOffsets :: Profile -> ClosureHeader -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [(NonVoid a, ByteOff)])

- GHC.StgToCmm.Layout: mkVirtHeapOffsetsWithPadding :: DynFlags -> ClosureHeader -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [FieldOffOrPadding a])

+ GHC.StgToCmm.Layout: mkVirtHeapOffsetsWithPadding :: Profile -> ClosureHeader -> [NonVoid (PrimRep, a)] -> (WordOff, WordOff, [FieldOffOrPadding a])

- GHC.StgToCmm.Layout: toArgRep :: PrimRep -> ArgRep

+ GHC.StgToCmm.Layout: toArgRep :: Platform -> PrimRep -> ArgRep

- GHC.StgToCmm.Monad: getCmm :: FCode () -> FCode CmmGroup

+ GHC.StgToCmm.Monad: getCmm :: FCode a -> FCode (a, CmmGroup)

- GHC.StgToCmm.Prof: costCentreFrom :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.StgToCmm.Prof: costCentreFrom :: Platform -> CmmExpr -> CmmExpr

- GHC.StgToCmm.Prof: dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]

+ GHC.StgToCmm.Prof: dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]

- GHC.StgToCmm.Prof: staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]

+ GHC.StgToCmm.Prof: staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]

- GHC.StgToCmm.Types: CgInfos :: !NonCaffySet -> !ModuleLFInfos -> CgInfos

+ GHC.StgToCmm.Types: CgInfos :: !NonCaffySet -> !ModuleLFInfos -> !CStub -> CgInfos

- GHC.StgToCmm.Utils: callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph

+ GHC.StgToCmm.Utils: callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph

- GHC.StgToCmm.Utils: callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph

+ GHC.StgToCmm.Utils: callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph

- GHC.StgToCmm.Utils: callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)

+ GHC.StgToCmm.Utils: callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)

- GHC.StgToCmm.Utils: cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.StgToCmm.Utils: cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr

- GHC.StgToCmm.Utils: cmmIsTagged :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.StgToCmm.Utils: cmmIsTagged :: Platform -> CmmExpr -> CmmExpr

- GHC.StgToCmm.Utils: cmmUntag :: DynFlags -> CmmExpr -> CmmExpr

+ GHC.StgToCmm.Utils: cmmUntag :: Platform -> CmmExpr -> CmmExpr

- GHC.StgToCmm.Utils: get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr

+ GHC.StgToCmm.Utils: get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr

- GHC.SysTools: copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()

+ GHC.SysTools: copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO ()

- GHC.SysTools: copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath -> IO ()

+ GHC.SysTools: copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath -> IO ()

- GHC.SysTools.Elf: readElfNoteAsString :: DynFlags -> FilePath -> String -> String -> IO (Maybe String)

+ GHC.SysTools.Elf: readElfNoteAsString :: Logger -> DynFlags -> FilePath -> String -> String -> IO (Maybe String)

- GHC.SysTools.Elf: readElfSectionByName :: DynFlags -> ByteString -> String -> IO (Maybe ByteString)

+ GHC.SysTools.Elf: readElfSectionByName :: Logger -> DynFlags -> ByteString -> String -> IO (Maybe ByteString)

- GHC.SysTools.Info: getCompilerInfo :: DynFlags -> IO CompilerInfo

+ GHC.SysTools.Info: getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo

- GHC.SysTools.Info: getCompilerInfo' :: DynFlags -> IO CompilerInfo

+ GHC.SysTools.Info: getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo

- GHC.SysTools.Info: getLinkerInfo :: DynFlags -> IO LinkerInfo

+ GHC.SysTools.Info: getLinkerInfo :: Logger -> DynFlags -> IO LinkerInfo

- GHC.SysTools.Info: getLinkerInfo' :: DynFlags -> IO LinkerInfo

+ GHC.SysTools.Info: getLinkerInfo' :: Logger -> DynFlags -> IO LinkerInfo

- GHC.SysTools.Process: builderMainLoop :: DynFlags -> (String -> String) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode

+ GHC.SysTools.Process: builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath -> [String] -> Maybe FilePath -> Maybe [(String, String)] -> IO ExitCode

- GHC.SysTools.Process: runSomething :: DynFlags -> String -> String -> [Option] -> IO ()

+ GHC.SysTools.Process: runSomething :: Logger -> DynFlags -> String -> String -> [Option] -> IO ()

- GHC.SysTools.Process: runSomethingFiltered :: DynFlags -> (String -> String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String, String)] -> IO ()

+ GHC.SysTools.Process: runSomethingFiltered :: Logger -> DynFlags -> (String -> String) -> String -> String -> [Option] -> Maybe FilePath -> Maybe [(String, String)] -> IO ()

- GHC.SysTools.Process: runSomethingResponseFile :: DynFlags -> (String -> String) -> String -> String -> [Option] -> Maybe [(String, String)] -> IO ()

+ GHC.SysTools.Process: runSomethingResponseFile :: Logger -> TmpFs -> DynFlags -> (String -> String) -> String -> String -> [Option] -> Maybe [(String, String)] -> IO ()

- GHC.SysTools.Process: runSomethingWith :: DynFlags -> String -> String -> [Option] -> ([String] -> IO (ExitCode, a)) -> IO a

+ GHC.SysTools.Process: runSomethingWith :: Logger -> DynFlags -> String -> String -> [Option] -> ([String] -> IO (ExitCode, a)) -> IO a

- GHC.SysTools.Tasks: askLd :: DynFlags -> [Option] -> IO String

+ GHC.SysTools.Tasks: askLd :: Logger -> DynFlags -> [Option] -> IO String

- GHC.SysTools.Tasks: askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String

+ GHC.SysTools.Tasks: askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String

- GHC.SysTools.Tasks: figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion)

+ GHC.SysTools.Tasks: figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)

- GHC.SysTools.Tasks: runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()

- GHC.SysTools.Tasks: runAs :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runAs :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runClang :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runClang :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runCpp :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runCpp :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runInstallNameTool :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runLibtool :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runLibtool :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runLink :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runLlvmLlc :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runLlvmOpt :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runMergeObjects :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runPp :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runPp :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runRanlib :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runRanlib :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runUnlit :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runUnlit :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: runWindres :: DynFlags -> [Option] -> IO ()

+ GHC.SysTools.Tasks: runWindres :: Logger -> DynFlags -> [Option] -> IO ()

- GHC.SysTools.Tasks: touch :: DynFlags -> String -> String -> IO ()

+ GHC.SysTools.Tasks: touch :: Logger -> DynFlags -> String -> String -> IO ()

- GHC.SysTools.Tasks: traceToolCommand :: DynFlags -> String -> IO a -> IO a

+ GHC.SysTools.Tasks: traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a

- GHC.Tc.Deriv.Functor: gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Functor: gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Functor: gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Functor: gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Functor: gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Functor: gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Data_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Data_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)

+ GHC.Tc.Deriv.Generate: gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)

- GHC.Tc.Deriv.Generate: mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs

+ GHC.Tc.Deriv.Generate: mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs

- GHC.Tc.Deriv.Generate: mkRdrFunBindEC :: Arity -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs

+ GHC.Tc.Deriv.Generate: mkRdrFunBindEC :: Arity -> (LHsExpr GhcPs -> LHsExpr GhcPs) -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs

- GHC.Tc.Deriv.Generate: mkRdrFunBindSE :: Arity -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs

+ GHC.Tc.Deriv.Generate: mkRdrFunBindSE :: Arity -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs

- GHC.Tc.Deriv.Generics: gen_Generic_binds :: GenericKind -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, FamInst)

+ GHC.Tc.Deriv.Generics: gen_Generic_binds :: GenericKind -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst)

- GHC.Tc.Deriv.Utils: CanDeriveStock :: (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) -> OriginativeDerivStatus

+ GHC.Tc.Deriv.Utils: CanDeriveStock :: (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) -> OriginativeDerivStatus

- GHC.Tc.Deriv.Utils: DerivSpecStock :: DerivInstTys -> (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])) -> DerivSpecMechanism

+ GHC.Tc.Deriv.Utils: DerivSpecStock :: DerivInstTys -> (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) -> DerivSpecMechanism

- GHC.Tc.Deriv.Utils: [dsm_stock_gen_fn] :: DerivSpecMechanism -> SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])

+ GHC.Tc.Deriv.Utils: [dsm_stock_gen_fn] :: DerivSpecMechanism -> SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])

- GHC.Tc.Deriv.Utils: hasStockDeriving :: Class -> Maybe (SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))

+ GHC.Tc.Deriv.Utils: hasStockDeriving :: Class -> Maybe (SrcSpan -> TyCon -> [Type] -> [Type] -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))

- GHC.Tc.Gen.Bind: badBootDeclErr :: MsgDoc

+ GHC.Tc.Gen.Bind: badBootDeclErr :: SDoc

- GHC.Tc.Gen.Export: exports_from_avail :: Maybe (Located [LIE GhcPs]) -> GlobalRdrEnv -> ImportAvails -> Module -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)

+ GHC.Tc.Gen.Export: exports_from_avail :: Maybe (LocatedL [LIE GhcPs]) -> GlobalRdrEnv -> ImportAvails -> Module -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)

- GHC.Tc.Gen.Export: rnExports :: Bool -> Maybe (Located [LIE GhcPs]) -> RnM TcGblEnv

+ GHC.Tc.Gen.Export: rnExports :: Bool -> Maybe (LocatedL [LIE GhcPs]) -> RnM TcGblEnv

- GHC.Tc.Gen.Foreign: isForeignExport :: LForeignDecl name -> Bool

+ GHC.Tc.Gen.Foreign: isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool

- GHC.Tc.Gen.Foreign: isForeignImport :: LForeignDecl name -> Bool

+ GHC.Tc.Gen.Foreign: isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool

- GHC.Tc.Gen.HsType: addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a

+ GHC.Tc.Gen.HsType: addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a

- GHC.Tc.Gen.HsType: bindExplicitTKBndrs_Skol :: OutputableBndrFlag flag => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)

+ GHC.Tc.Gen.HsType: bindExplicitTKBndrs_Skol :: OutputableBndrFlag flag 'Renamed => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)

- GHC.Tc.Gen.HsType: bindExplicitTKBndrs_Tv :: OutputableBndrFlag flag => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)

+ GHC.Tc.Gen.HsType: bindExplicitTKBndrs_Tv :: OutputableBndrFlag flag 'Renamed => [LHsTyVarBndr flag GhcRn] -> TcM a -> TcM ([VarBndr TyVar flag], a)

- GHC.Tc.Gen.HsType: funsSigCtxt :: [Located Name] -> UserTypeCtxt

+ GHC.Tc.Gen.HsType: funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt

- GHC.Tc.Gen.HsType: kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()

+ GHC.Tc.Gen.HsType: kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()

- GHC.Tc.Gen.HsType: kindGeneralizeSome :: (TcTyVar -> Bool) -> TcType -> TcM [KindVar]

+ GHC.Tc.Gen.HsType: kindGeneralizeSome :: WantedConstraints -> TcType -> TcM [KindVar]

- GHC.Tc.Gen.HsType: pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc

+ GHC.Tc.Gen.HsType: pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc

- GHC.Tc.Gen.HsType: tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type

+ GHC.Tc.Gen.HsType: tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type

- GHC.Tc.Gen.HsType: tcHsContext :: LHsContext GhcRn -> TcM [PredType]

+ GHC.Tc.Gen.HsType: tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]

- GHC.Tc.Gen.HsType: tcHsPatSigType :: UserTypeCtxt -> HsPatSigType GhcRn -> TcM ([(Name, TcTyVar)], [(Name, TcTyVar)], TcType)

+ GHC.Tc.Gen.HsType: tcHsPatSigType :: UserTypeCtxt -> HoleMode -> HsPatSigType GhcRn -> ContextKind -> TcM ([(Name, TcTyVar)], [(Name, TcTyVar)], TcType)

- GHC.Tc.Gen.Match: MC :: HsMatchContext GhcRn -> (Located (body GhcRn) -> ExpRhoType -> TcM (Located (body GhcTc))) -> TcMatchCtxt body

+ GHC.Tc.Gen.Match: MC :: HsMatchContext GhcRn -> (LocatedA (body GhcRn) -> ExpRhoType -> TcM (LocatedA (body GhcTc))) -> TcMatchCtxt body

- GHC.Tc.Gen.Match: [mc_body] :: TcMatchCtxt body -> Located (body GhcRn) -> ExpRhoType -> TcM (Located (body GhcTc))

+ GHC.Tc.Gen.Match: [mc_body] :: TcMatchCtxt body -> LocatedA (body GhcRn) -> ExpRhoType -> TcM (LocatedA (body GhcTc))

- GHC.Tc.Gen.Match: tcDoStmts :: HsStmtContext GhcRn -> Located [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc)

+ GHC.Tc.Gen.Match: tcDoStmts :: HsStmtContext GhcRn -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)] -> ExpRhoType -> TcM (HsExpr GhcTc)

- GHC.Tc.Gen.Match: tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn)) -> TcM (GRHS GhcTc (Located (body GhcTc)))

+ GHC.Tc.Gen.Match: tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn)) -> TcM (GRHS GhcTc (LocatedA (body GhcTc)))

- GHC.Tc.Gen.Match: tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))

+ GHC.Tc.Gen.Match: tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (GRHSs GhcTc (LHsExpr GhcTc))

- GHC.Tc.Gen.Match: tcMatchesCase :: Outputable (body GhcRn) => TcMatchCtxt body -> Scaled TcSigmaType -> MatchGroup GhcRn (Located (body GhcRn)) -> ExpRhoType -> TcM (MatchGroup GhcTc (Located (body GhcTc)))

+ GHC.Tc.Gen.Match: tcMatchesCase :: AnnoBody body => TcMatchCtxt body -> Scaled TcSigmaType -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> ExpRhoType -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))

- GHC.Tc.Gen.Match: tcMatchesFun :: Located Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))

+ GHC.Tc.Gen.Match: tcMatchesFun :: LocatedN Name -> MatchGroup GhcRn (LHsExpr GhcRn) -> ExpRhoType -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))

- GHC.Tc.Gen.Match: tcStmts :: Outputable (body GhcRn) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type -> TcM [LStmt GhcTc (Located (body GhcTc))]

+ GHC.Tc.Gen.Match: tcStmts :: AnnoBody body => HsStmtContext GhcRn -> TcStmtChecker body rho_type -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type -> TcM [LStmt GhcTc (LocatedA (body GhcTc))]

- GHC.Tc.Gen.Match: tcStmtsAndThen :: Outputable (body GhcRn) => HsStmtContext GhcRn -> TcStmtChecker body rho_type -> [LStmt GhcRn (Located (body GhcRn))] -> rho_type -> (rho_type -> TcM thing) -> TcM ([LStmt GhcTc (Located (body GhcTc))], thing)

+ GHC.Tc.Gen.Match: tcStmtsAndThen :: AnnoBody body => HsStmtContext GhcRn -> TcStmtChecker body rho_type -> [LStmt GhcRn (LocatedA (body GhcRn))] -> rho_type -> (rho_type -> TcM thing) -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)

- GHC.Tc.Gen.Match: type TcStmtChecker body rho_type = forall thing. HsStmtContext GhcRn -> Stmt GhcRn (Located (body GhcRn)) -> rho_type -> (rho_type -> TcM thing) -> TcM (Stmt GhcTc (Located (body GhcTc)), thing)

+ GHC.Tc.Gen.Match: type TcStmtChecker body rho_type = forall thing. HsStmtContext GhcRn -> Stmt GhcRn (LocatedA (body GhcRn)) -> rho_type -> (rho_type -> TcM thing) -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)

- GHC.Tc.Gen.Splice: runMeta' :: Bool -> (hs_syn -> SDoc) -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn)) -> LHsExpr GhcTc -> TcM hs_syn

+ GHC.Tc.Gen.Splice: runMeta' :: Bool -> (hs_syn -> SDoc) -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn)) -> LHsExpr GhcTc -> TcM hs_syn

- GHC.Tc.Module: getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)

+ GHC.Tc.Module: getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface)

- GHC.Tc.Module: isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)

+ GHC.Tc.Module: isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name)

- GHC.Tc.Module: runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)

+ GHC.Tc.Module: runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a)

- GHC.Tc.Module: tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] -> IO (Messages, Maybe TcGblEnv)

+ GHC.Tc.Module: tcRnDeclsi :: HscEnv -> [LHsDecl GhcPs] -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)

- GHC.Tc.Module: tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages, Maybe Type)

+ GHC.Tc.Module: tcRnExpr :: HscEnv -> TcRnExprMode -> LHsExpr GhcPs -> IO (Messages DecoratedSDoc, Maybe Type)

- GHC.Tc.Module: tcRnGetInfo :: HscEnv -> Name -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))

+ GHC.Tc.Module: tcRnGetInfo :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))

- GHC.Tc.Module: tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO (Messages, Maybe GlobalRdrEnv)

+ GHC.Tc.Module: tcRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO (Messages DecoratedSDoc, Maybe GlobalRdrEnv)

- GHC.Tc.Module: tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages, Maybe TcGblEnv)

+ GHC.Tc.Module: tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)

- GHC.Tc.Module: tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)

+ GHC.Tc.Module: tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing)

- GHC.Tc.Module: tcRnLookupRdrName :: HscEnv -> Located RdrName -> IO (Messages, Maybe [Name])

+ GHC.Tc.Module: tcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (Messages DecoratedSDoc, Maybe [Name])

- GHC.Tc.Module: tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv -> ModIface -> IO (Messages, Maybe TcGblEnv)

+ GHC.Tc.Module: tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv -> ModIface -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)

- GHC.Tc.Module: tcRnModule :: HscEnv -> ModSummary -> Bool -> HsParsedModule -> IO (Messages, Maybe TcGblEnv)

+ GHC.Tc.Module: tcRnModule :: HscEnv -> ModSummary -> Bool -> HsParsedModule -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)

- GHC.Tc.Module: tcRnStmt :: HscEnv -> GhciLStmt GhcPs -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))

+ GHC.Tc.Module: tcRnStmt :: HscEnv -> GhciLStmt GhcPs -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv))

- GHC.Tc.Module: tcRnType :: HscEnv -> ZonkFlexi -> Bool -> LHsType GhcPs -> IO (Messages, Maybe (Type, Kind))

+ GHC.Tc.Module: tcRnType :: HscEnv -> ZonkFlexi -> Bool -> LHsType GhcPs -> IO (Messages DecoratedSDoc, Maybe (Type, Kind))

- GHC.Tc.Solver: simplifyDefault :: ThetaType -> TcM ()

+ GHC.Tc.Solver: simplifyDefault :: ThetaType -> TcM Bool

- GHC.Tc.Solver: simplifyInfer :: TcLevel -> InferMode -> [TcIdSigInst] -> [(Name, TcTauType)] -> WantedConstraints -> TcM ([TcTyVar], [EvVar], TcEvBinds, WantedConstraints, Bool)

+ GHC.Tc.Solver: simplifyInfer :: TcLevel -> InferMode -> [TcIdSigInst] -> [(Name, TcTauType)] -> WantedConstraints -> TcM ([TcTyVar], [EvVar], TcEvBinds, Bool)

- GHC.Tc.Solver: solveEqualities :: TcM a -> TcM a

+ GHC.Tc.Solver: solveEqualities :: String -> TcM a -> TcM a

- GHC.Tc.Solver: tcNormalise :: Bag EvVar -> Type -> TcM Type

+ GHC.Tc.Solver: tcNormalise :: InertSet -> Type -> TcM Type

- GHC.Tc.Solver.Monad: IC :: InertEqs -> FunEqMap Ct -> DictMap Ct -> [QCInst] -> DictMap Ct -> Cts -> Int -> InertCans

+ GHC.Tc.Solver.Monad: IC :: InertEqs -> FunEqMap EqualCtList -> DictMap Ct -> [QCInst] -> DictMap Ct -> Cts -> Cts -> TcLevel -> Bool -> InertCans

- GHC.Tc.Solver.Monad: IS :: InertCans -> [(TcTyVar, TcType)] -> ExactFunEqMap (TcCoercion, TcType, CtFlavour) -> DictMap CtEvidence -> InertSet

+ GHC.Tc.Solver.Monad: IS :: InertCans -> [(TcTyVar, TcType)] -> FunEqMap (TcCoercion, TcType) -> DictMap CtEvidence -> InertSet

- GHC.Tc.Solver.Monad: WL :: [Ct] -> [Ct] -> [Ct] -> Bag Implication -> WorkList

+ GHC.Tc.Solver.Monad: WL :: [Ct] -> [Ct] -> Bag Implication -> WorkList

- GHC.Tc.Solver.Monad: [inert_funeqs] :: InertCans -> FunEqMap Ct

+ GHC.Tc.Solver.Monad: [inert_funeqs] :: InertCans -> FunEqMap EqualCtList

- GHC.Tc.Solver.Monad: findTyEqs :: InertCans -> TyVar -> EqualCtList

+ GHC.Tc.Solver.Monad: findTyEqs :: InertCans -> TyVar -> [Ct]

- GHC.Tc.Solver.Monad: getUnsolvedInerts :: TcS (Bag Implication, Cts, Cts, Cts)

+ GHC.Tc.Solver.Monad: getUnsolvedInerts :: TcS (Bag Implication, Cts)

- GHC.Tc.Solver.Monad: newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)

+ GHC.Tc.Solver.Monad: newWantedEq_SI :: ShadowInfo -> CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)

- GHC.Tc.TyCl: dataDeclChecks :: Name -> NewOrData -> LHsContext GhcRn -> [LConDecl GhcRn] -> TcM Bool

+ GHC.Tc.TyCl: dataDeclChecks :: Name -> NewOrData -> Maybe (LHsContext GhcRn) -> [LConDecl GhcRn] -> TcM Bool

- GHC.Tc.TyCl: tcConDecls :: KnotTied TyCon -> NewOrData -> [TyConBinder] -> TcKind -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon]

+ GHC.Tc.TyCl: tcConDecls :: NewOrData -> DataDeclInfo -> KnotTied TyCon -> [TyConBinder] -> TcKind -> [LConDecl GhcRn] -> TcM [DataCon]

- GHC.Tc.TyCl.Build: buildPatSyn :: Name -> Bool -> (Id, Bool) -> Maybe (Id, Bool) -> ([InvisTVBinder], ThetaType) -> ([InvisTVBinder], ThetaType) -> [Type] -> Type -> [FieldLabel] -> PatSyn

+ GHC.Tc.TyCl.Build: buildPatSyn :: Name -> Bool -> PatSynMatcher -> PatSynBuilder -> ([InvisTVBinder], ThetaType) -> ([InvisTVBinder], ThetaType) -> [Type] -> Type -> [FieldLabel] -> PatSyn

- GHC.Tc.TyCl.PatSyn: tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)

+ GHC.Tc.TyCl.PatSyn: tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)

- GHC.Tc.TyCl.PatSyn: tcPatSynDecl :: PatSynBind GhcRn GhcRn -> Maybe TcSigInfo -> TcM (LHsBinds GhcTc, TcGblEnv)

+ GHC.Tc.TyCl.PatSyn: tcPatSynDecl :: PatSynBind GhcRn GhcRn -> Maybe TcSigInfo -> TcPragEnv -> TcM (LHsBinds GhcTc, TcGblEnv)

- GHC.Tc.TyCl.Utils: mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> (Id, LHsBind GhcRn)

+ GHC.Tc.TyCl.Utils: mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors -> (Id, LHsBind GhcRn)

- GHC.Tc.Types: TcGblEnv :: Module -> Module -> HscSource -> GlobalRdrEnv -> Maybe [Type] -> FixityEnv -> RecFieldEnv -> TypeEnv -> TcRef TypeEnv -> !InstEnv -> !FamInstEnv -> AnnEnv -> [AvailInfo] -> ImportAvails -> DefUses -> TcRef [GlobalRdrElt] -> TcRef NameSet -> TcRef Bool -> TcRef Bool -> TcRef OccSet -> [(Module, Fingerprint)] -> Maybe [(Located (IE GhcRn), Avails)] -> [LImportDecl GhcRn] -> Maybe (HsGroup GhcRn) -> TcRef [FilePath] -> TcRef [LHsDecl GhcPs] -> TcRef [(ForeignSrcLang, FilePath)] -> TcRef NameSet -> TcRef [(TcLclEnv, ThModFinalizers)] -> TcRef [String] -> TcRef (Map TypeRep Dynamic) -> TcRef (Maybe (ForeignRef (IORef QState))) -> Bag EvBind -> Maybe Id -> LHsBinds GhcTc -> NameSet -> [LTcSpecPrag] -> Warnings -> [Annotation] -> [TyCon] -> [ClsInst] -> [FamInst] -> [LRuleDecl GhcTc] -> [LForeignDecl GhcTc] -> [PatSyn] -> Maybe LHsDocString -> !AnyHpcUsage -> SelfBootInfo -> Maybe Name -> TcRef (Bool, WarningMessages) -> [TcPluginSolver] -> [HoleFitPlugin] -> RealSrcSpan -> TcRef WantedConstraints -> [CompleteMatch] -> TcRef CostCentreState -> TcGblEnv

+ GHC.Tc.Types: TcGblEnv :: Module -> Module -> HscSource -> GlobalRdrEnv -> Maybe [Type] -> FixityEnv -> RecFieldEnv -> TypeEnv -> TcRef TypeEnv -> !InstEnv -> !FamInstEnv -> AnnEnv -> [AvailInfo] -> ImportAvails -> DefUses -> TcRef [GlobalRdrElt] -> TcRef NameSet -> TcRef Bool -> TcRef Bool -> TcRef OccSet -> [(Module, Fingerprint)] -> Maybe [(LIE GhcRn, Avails)] -> [LImportDecl GhcRn] -> Maybe (HsGroup GhcRn) -> TcRef [FilePath] -> TcRef [LHsDecl GhcPs] -> TcRef [(ForeignSrcLang, FilePath)] -> TcRef NameSet -> TcRef [(TcLclEnv, ThModFinalizers)] -> TcRef [String] -> TcRef (Map TypeRep Dynamic) -> TcRef (Maybe (ForeignRef (IORef QState))) -> TcRef THDocs -> Bag EvBind -> Maybe Id -> LHsBinds GhcTc -> NameSet -> [LTcSpecPrag] -> Warnings -> [Annotation] -> [TyCon] -> NameSet -> [ClsInst] -> [FamInst] -> [LRuleDecl GhcTc] -> [LForeignDecl GhcTc] -> [PatSyn] -> Maybe LHsDocString -> !AnyHpcUsage -> SelfBootInfo -> Maybe Name -> TcRef (Bool, WarningMessages) -> [TcPluginSolver] -> [HoleFitPlugin] -> RealSrcSpan -> TcRef WantedConstraints -> !CompleteMatches -> TcRef CostCentreState -> TcGblEnv

- GHC.Tc.Types: TcLclEnv :: RealSrcSpan -> [ErrCtxt] -> Bool -> TcLevel -> ThStage -> ThBindEnv -> ArrowCtxt -> LocalRdrEnv -> TcTypeEnv -> TcRef UsageEnv -> TcBinderStack -> TcRef WantedConstraints -> TcRef Messages -> TcLclEnv

+ GHC.Tc.Types: TcLclEnv :: RealSrcSpan -> [ErrCtxt] -> Bool -> TcLevel -> ThStage -> ThBindEnv -> ArrowCtxt -> LocalRdrEnv -> TcTypeEnv -> TcRef UsageEnv -> TcBinderStack -> TcRef WantedConstraints -> TcRef (Messages DecoratedSDoc) -> TcLclEnv

- GHC.Tc.Types: [tcg_complete_matches] :: TcGblEnv -> [CompleteMatch]

+ GHC.Tc.Types: [tcg_complete_matches] :: TcGblEnv -> !CompleteMatches

- GHC.Tc.Types: [tcg_rn_exports] :: TcGblEnv -> Maybe [(Located (IE GhcRn), Avails)]

+ GHC.Tc.Types: [tcg_rn_exports] :: TcGblEnv -> Maybe [(LIE GhcRn, Avails)]

- GHC.Tc.Types: [tcl_errs] :: TcLclEnv -> TcRef Messages

+ GHC.Tc.Types: [tcl_errs] :: TcLclEnv -> TcRef (Messages DecoratedSDoc)

- GHC.Tc.Types: lintGblEnv :: DynFlags -> TcGblEnv -> (Bag SDoc, Bag SDoc)

+ GHC.Tc.Types: lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM ()

- GHC.Tc.Types: type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))

+ GHC.Tc.Types: type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))

- GHC.Tc.Types.Constraint: CIrredCan :: CtEvidence -> CtIrredStatus -> Ct

+ GHC.Tc.Types.Constraint: CIrredCan :: CtEvidence -> CtIrredReason -> Ct

- GHC.Tc.Types.Constraint: ExprHole :: Id -> HoleSort

+ GHC.Tc.Types.Constraint: ExprHole :: HoleExprRef -> HoleSort

- GHC.Tc.Types.Constraint: Implic :: TcLevel -> [TcTyVar] -> SkolemInfo -> [EvVar] -> Bool -> Bool -> TcLclEnv -> WantedConstraints -> EvBindsVar -> VarSet -> VarSet -> ImplicStatus -> Implication

+ GHC.Tc.Types.Constraint: Implic :: TcLevel -> [TcTyVar] -> SkolemInfo -> [EvVar] -> HasGivenEqs -> Bool -> TcLclEnv -> WantedConstraints -> EvBindsVar -> VarSet -> VarSet -> ImplicStatus -> Implication

- GHC.Tc.Types.Constraint: [cc_rhs] :: Ct -> TcType

+ GHC.Tc.Types.Constraint: [cc_rhs] :: Ct -> Xi

- GHC.Tc.Types.Constraint: mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct

+ GHC.Tc.Types.Constraint: mkIrredCt :: CtIrredReason -> CtEvidence -> Ct

- GHC.Tc.Types.Constraint: type Xi = Type

+ GHC.Tc.Types.Constraint: type Xi = TcType

- GHC.Tc.Types.Evidence: maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion

+ GHC.Tc.Types.Evidence: maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion

- GHC.Tc.Types.Evidence: mkTcSubCo :: TcCoercionN -> TcCoercionR

+ GHC.Tc.Types.Evidence: mkTcSubCo :: HasDebugCallStack => TcCoercionN -> TcCoercionR

- GHC.Tc.Types.Origin: ForAllSkol :: SDoc -> SDoc -> SkolemInfo

+ GHC.Tc.Types.Origin: ForAllSkol :: SDoc -> SkolemInfo

- GHC.Tc.Types.Origin: KindEqOrigin :: TcType -> Maybe TcType -> CtOrigin -> Maybe TypeOrKind -> CtOrigin

+ GHC.Tc.Types.Origin: KindEqOrigin :: TcType -> TcType -> CtOrigin -> Maybe TypeOrKind -> CtOrigin

- GHC.Tc.Utils.Backpack: tcRnCheckUnit :: HscEnv -> Unit -> IO (Messages, Maybe ())

+ GHC.Tc.Utils.Backpack: tcRnCheckUnit :: HscEnv -> Unit -> IO (Messages DecoratedSDoc, Maybe ())

- GHC.Tc.Utils.Backpack: tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages, Maybe TcGblEnv)

+ GHC.Tc.Utils.Backpack: tcRnInstantiateSignature :: HscEnv -> Module -> RealSrcSpan -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)

- GHC.Tc.Utils.Backpack: tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv -> ModIface -> IO (Messages, Maybe TcGblEnv)

+ GHC.Tc.Utils.Backpack: tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv -> ModIface -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)

- GHC.Tc.Utils.Env: newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name

+ GHC.Tc.Utils.Env: newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name

- GHC.Tc.Utils.Env: newFamInstTyConName :: Located Name -> [Type] -> TcM Name

+ GHC.Tc.Utils.Env: newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name

- GHC.Tc.Utils.Env: tcLookupLocated :: Located Name -> TcM TcTyThing

+ GHC.Tc.Utils.Env: tcLookupLocated :: LocatedA Name -> TcM TcTyThing

- GHC.Tc.Utils.Env: tcLookupLocatedClass :: Located Name -> TcM Class

+ GHC.Tc.Utils.Env: tcLookupLocatedClass :: LocatedA Name -> TcM Class

- GHC.Tc.Utils.Env: tcLookupLocatedGlobal :: Located Name -> TcM TyThing

+ GHC.Tc.Utils.Env: tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing

- GHC.Tc.Utils.Env: tcLookupLocatedGlobalId :: Located Name -> TcM Id

+ GHC.Tc.Utils.Env: tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id

- GHC.Tc.Utils.Env: tcLookupLocatedTyCon :: Located Name -> TcM TyCon

+ GHC.Tc.Utils.Env: tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon

- GHC.Tc.Utils.Monad: addErr :: MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: addErr :: SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: addErrAt :: SrcSpan -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: addErrAt :: SrcSpan -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: addErrCtxt :: MsgDoc -> TcM a -> TcM a

+ GHC.Tc.Utils.Monad: addErrCtxt :: SDoc -> TcM a -> TcM a

- GHC.Tc.Utils.Monad: addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a

+ GHC.Tc.Utils.Monad: addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a

- GHC.Tc.Utils.Monad: addErrTc :: MsgDoc -> TcM ()

+ GHC.Tc.Utils.Monad: addErrTc :: SDoc -> TcM ()

- GHC.Tc.Utils.Monad: addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()

+ GHC.Tc.Utils.Monad: addErrTcM :: (TidyEnv, SDoc) -> TcM ()

- GHC.Tc.Utils.Monad: addErrs :: [(SrcSpan, MsgDoc)] -> TcRn ()

+ GHC.Tc.Utils.Monad: addErrs :: [(SrcSpan, SDoc)] -> TcRn ()

- GHC.Tc.Utils.Monad: addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a

+ GHC.Tc.Utils.Monad: addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a

- GHC.Tc.Utils.Monad: addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a

+ GHC.Tc.Utils.Monad: addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a

- GHC.Tc.Utils.Monad: addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: addMessages :: Messages -> TcRn ()

+ GHC.Tc.Utils.Monad: addMessages :: Messages DecoratedSDoc -> TcRn ()

- GHC.Tc.Utils.Monad: addWarn :: WarnReason -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: addWarn :: WarnReason -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: addWarnTc :: WarnReason -> MsgDoc -> TcM ()

+ GHC.Tc.Utils.Monad: addWarnTc :: WarnReason -> SDoc -> TcM ()

- GHC.Tc.Utils.Monad: addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()

+ GHC.Tc.Utils.Monad: addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM ()

- GHC.Tc.Utils.Monad: add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: add_warn :: WarnReason -> SDoc -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: checkErr :: Bool -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: checkErr :: Bool -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: checkTc :: Bool -> MsgDoc -> TcM ()

+ GHC.Tc.Utils.Monad: checkTc :: Bool -> SDoc -> TcM ()

- GHC.Tc.Utils.Monad: checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()

+ GHC.Tc.Utils.Monad: checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()

- GHC.Tc.Utils.Monad: dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: emitAnonTypeHole :: TcTyVar -> TcM ()

+ GHC.Tc.Utils.Monad: emitAnonTypeHole :: IsExtraConstraint -> TcTyVar -> TcM ()

- GHC.Tc.Utils.Monad: failAt :: SrcSpan -> MsgDoc -> TcRn a

+ GHC.Tc.Utils.Monad: failAt :: SrcSpan -> SDoc -> TcRn a

- GHC.Tc.Utils.Monad: failIfM :: MsgDoc -> IfL a

+ GHC.Tc.Utils.Monad: failIfM :: SDoc -> IfL a

- GHC.Tc.Utils.Monad: failIfTc :: Bool -> MsgDoc -> TcM ()

+ GHC.Tc.Utils.Monad: failIfTc :: Bool -> SDoc -> TcM ()

- GHC.Tc.Utils.Monad: failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()

+ GHC.Tc.Utils.Monad: failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()

- GHC.Tc.Utils.Monad: failWith :: MsgDoc -> TcRn a

+ GHC.Tc.Utils.Monad: failWith :: SDoc -> TcRn a

- GHC.Tc.Utils.Monad: failWithTc :: MsgDoc -> TcM a

+ GHC.Tc.Utils.Monad: failWithTc :: SDoc -> TcM a

- GHC.Tc.Utils.Monad: failWithTcM :: (TidyEnv, MsgDoc) -> TcM a

+ GHC.Tc.Utils.Monad: failWithTcM :: (TidyEnv, SDoc) -> TcM a

- GHC.Tc.Utils.Monad: getCCIndexM :: ContainsCostCentreState gbl => FastString -> TcRnIf gbl lcl CostCentreIndex

+ GHC.Tc.Utils.Monad: getCCIndexM :: (gbl -> TcRef CostCentreState) -> FastString -> TcRnIf gbl lcl CostCentreIndex

- GHC.Tc.Utils.Monad: getErrsVar :: TcRn (TcRef Messages)

+ GHC.Tc.Utils.Monad: getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc))

- GHC.Tc.Utils.Monad: getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified

+ GHC.Tc.Utils.Monad: getPrintUnqualified :: TcRn PrintUnqualified

- GHC.Tc.Utils.Monad: initTc :: HscEnv -> HscSource -> Bool -> Module -> RealSrcSpan -> TcM r -> IO (Messages, Maybe r)

+ GHC.Tc.Utils.Monad: initTc :: HscEnv -> HscSource -> Bool -> Module -> RealSrcSpan -> TcM r -> IO (Messages DecoratedSDoc, Maybe r)

- GHC.Tc.Utils.Monad: initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)

+ GHC.Tc.Utils.Monad: initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a)

- GHC.Tc.Utils.Monad: initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r -> IO (Messages, Maybe r)

+ GHC.Tc.Utils.Monad: initTcWithGbl :: HscEnv -> TcGblEnv -> RealSrcSpan -> TcM r -> IO (Messages DecoratedSDoc, Maybe r)

- GHC.Tc.Utils.Monad: mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg

+ GHC.Tc.Utils.Monad: mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc)

- GHC.Tc.Utils.Monad: reportError :: ErrMsg -> TcRn ()

+ GHC.Tc.Utils.Monad: reportError :: MsgEnvelope DecoratedSDoc -> TcRn ()

- GHC.Tc.Utils.Monad: reportErrors :: [ErrMsg] -> TcM ()

+ GHC.Tc.Utils.Monad: reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM ()

- GHC.Tc.Utils.Monad: reportWarning :: WarnReason -> ErrMsg -> TcRn ()

+ GHC.Tc.Utils.Monad: reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn ()

- GHC.Tc.Utils.Monad: setErrsVar :: TcRef Messages -> TcRn a -> TcRn a

+ GHC.Tc.Utils.Monad: setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a

- GHC.Tc.Utils.Monad: tryTc :: TcRn a -> TcRn (Maybe a, Messages)

+ GHC.Tc.Utils.Monad: tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc)

- GHC.Tc.Utils.Monad: warnIf :: Bool -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: warnIf :: Bool -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()

+ GHC.Tc.Utils.Monad: warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn ()

- GHC.Tc.Utils.Monad: warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()

+ GHC.Tc.Utils.Monad: warnTc :: WarnReason -> Bool -> SDoc -> TcM ()

- GHC.Tc.Utils.Monad: warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()

+ GHC.Tc.Utils.Monad: warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM ()

- GHC.Tc.Utils.Monad: withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a

+ GHC.Tc.Utils.Monad: withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a

- GHC.Tc.Utils.TcMType: emitNewExprHole :: OccName -> Id -> Type -> TcM ()

+ GHC.Tc.Utils.TcMType: emitNewExprHole :: OccName -> Type -> TcM HoleExprRef

- GHC.Tc.Utils.TcMType: newCoercionHole :: BlockSubstFlag -> TcPredType -> TcM CoercionHole

+ GHC.Tc.Utils.TcMType: newCoercionHole :: TcPredType -> TcM CoercionHole

- GHC.Tc.Utils.Unify: canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool

+ GHC.Tc.Utils.Unify: canSolveByUnification :: MetaInfo -> TcType -> Bool

- GHC.Tc.Utils.Unify: matchActualFunTySigma :: SDoc -> CtOrigin -> Maybe (HsExpr GhcRn) -> (Arity, [Scaled TcSigmaType]) -> TcSigmaType -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)

+ GHC.Tc.Utils.Unify: matchActualFunTySigma :: SDoc -> Maybe SDoc -> (Arity, [Scaled TcSigmaType]) -> TcRhoType -> TcM (HsWrapper, Scaled TcSigmaType, TcSigmaType)

- GHC.Tc.Utils.Unify: matchActualFunTysRho :: SDoc -> CtOrigin -> Maybe (HsExpr GhcRn) -> Arity -> TcSigmaType -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)

+ GHC.Tc.Utils.Unify: matchActualFunTysRho :: SDoc -> CtOrigin -> Maybe SDoc -> Arity -> TcSigmaType -> TcM (HsWrapper, [Scaled TcSigmaType], TcRhoType)

- GHC.Tc.Utils.Unify: unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN

+ GHC.Tc.Utils.Unify: unifyKind :: Maybe SDoc -> TcKind -> TcKind -> TcM CoercionN

- GHC.Tc.Utils.Unify: unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercionN

+ GHC.Tc.Utils.Unify: unifyType :: Maybe SDoc -> TcTauType -> TcTauType -> TcM TcCoercionN

- GHC.Tc.Utils.Zonk: mkHsCaseAlt :: LPat (GhcPass p) -> Located (body (GhcPass p)) -> LMatch (GhcPass p) (Located (body (GhcPass p)))

+ GHC.Tc.Utils.Zonk: mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) => LPat (GhcPass p) -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))

- GHC.ThToHs: convertToHsDecls :: Origin -> SrcSpan -> [Dec] -> Either MsgDoc [LHsDecl GhcPs]

+ GHC.ThToHs: convertToHsDecls :: Origin -> SrcSpan -> [Dec] -> Either SDoc [LHsDecl GhcPs]

- GHC.ThToHs: convertToHsExpr :: Origin -> SrcSpan -> Exp -> Either MsgDoc (LHsExpr GhcPs)

+ GHC.ThToHs: convertToHsExpr :: Origin -> SrcSpan -> Exp -> Either SDoc (LHsExpr GhcPs)

- GHC.ThToHs: convertToHsType :: Origin -> SrcSpan -> Type -> Either MsgDoc (LHsType GhcPs)

+ GHC.ThToHs: convertToHsType :: Origin -> SrcSpan -> Type -> Either SDoc (LHsType GhcPs)

- GHC.ThToHs: convertToPat :: Origin -> SrcSpan -> Pat -> Either MsgDoc (LPat GhcPs)

+ GHC.ThToHs: convertToPat :: Origin -> SrcSpan -> Pat -> Either SDoc (LPat GhcPs)

- GHC.Types.Avail: Avail :: Name -> AvailInfo

+ GHC.Types.Avail: Avail :: GreName -> AvailInfo

- GHC.Types.Avail: AvailTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo

+ GHC.Types.Avail: AvailTC :: Name -> [GreName] -> AvailInfo

- GHC.Types.Cpr: CprType :: !Arity -> !CprResult -> CprType

+ GHC.Types.Cpr: CprType :: !Arity -> !Cpr -> CprType

- GHC.Types.Cpr: [ct_cpr] :: CprType -> !CprResult

+ GHC.Types.Cpr: [ct_cpr] :: CprType -> !Cpr

- GHC.Types.Cpr: asConCpr :: CprResult -> Maybe ConTag

+ GHC.Types.Cpr: asConCpr :: Cpr -> Maybe (ConTag, [Cpr])

- GHC.Types.Cpr: botCpr :: CprResult

+ GHC.Types.Cpr: botCpr :: Cpr

- GHC.Types.Cpr: mkCprSig :: Arity -> CprResult -> CprSig

+ GHC.Types.Cpr: mkCprSig :: Arity -> Cpr -> CprSig

- GHC.Types.Cpr: topCpr :: CprResult

+ GHC.Types.Cpr: topCpr :: Cpr

- GHC.Types.Demand: addCaseBndrDmd :: Demand -> [Demand] -> [Demand]

+ GHC.Types.Demand: addCaseBndrDmd :: SubDemand -> [Demand] -> [Demand]

- GHC.Types.Demand: dmdTransformDataConSig :: Arity -> CleanDemand -> DmdType

+ GHC.Types.Demand: dmdTransformDataConSig :: Arity -> DmdTransformer

- GHC.Types.Demand: dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType

+ GHC.Types.Demand: dmdTransformDictSelSig :: StrictSig -> DmdTransformer

- GHC.Types.Demand: dmdTransformSig :: StrictSig -> CleanDemand -> DmdType

+ GHC.Types.Demand: dmdTransformSig :: StrictSig -> DmdTransformer

- GHC.Types.Demand: isAbsDmd :: JointDmd (Str s) (Use u) -> Bool

+ GHC.Types.Demand: isAbsDmd :: Demand -> Bool

- GHC.Types.Demand: isStrictDmd :: JointDmd (Str s) (Use u) -> Bool

+ GHC.Types.Demand: isStrictDmd :: Demand -> Bool

- GHC.Types.Demand: isUsedOnce :: JointDmd (Str s) (Use u) -> Bool

+ GHC.Types.Demand: isUsedOnce :: Card -> Bool

- GHC.Types.Demand: oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u)

+ GHC.Types.Demand: oneifyDmd :: Demand -> Demand

- GHC.Types.Demand: peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)

+ GHC.Types.Demand: peelCallDmd :: SubDemand -> (Card, SubDemand)

- GHC.Types.Demand: peelManyCalls :: Int -> CleanDemand -> DmdShell

+ GHC.Types.Demand: peelManyCalls :: Int -> SubDemand -> Card

- GHC.Types.FieldLabel: FieldLabel :: FieldLabelString -> Bool -> a -> FieldLbl a

+ GHC.Types.FieldLabel: FieldLabel :: FieldLabelString -> DuplicateRecordFields -> FieldSelectors -> Name -> FieldLabel

- GHC.Types.FieldLabel: [flLabel] :: FieldLbl a -> FieldLabelString

+ GHC.Types.FieldLabel: [flLabel] :: FieldLabel -> FieldLabelString

- GHC.Types.FieldLabel: [flSelector] :: FieldLbl a -> a

+ GHC.Types.FieldLabel: [flSelector] :: FieldLabel -> Name

- GHC.Types.Literal: LitRubbish :: Literal

+ GHC.Types.Literal: LitRubbish :: Bool -> Literal

- GHC.Types.Literal: mkLitInt64Wrap :: Platform -> Integer -> Literal

+ GHC.Types.Literal: mkLitInt64Wrap :: Integer -> Literal

- GHC.Types.Literal: mkLitWord64Wrap :: Platform -> Integer -> Literal

+ GHC.Types.Literal: mkLitWord64Wrap :: Integer -> Literal

- GHC.Types.Literal: rubbishLit :: Literal

+ GHC.Types.Literal: rubbishLit :: Bool -> Literal

- GHC.Types.Name: nameIsFromExternalPackage :: Unit -> Name -> Bool

+ GHC.Types.Name: nameIsFromExternalPackage :: HomeUnit -> Name -> Bool

- GHC.Types.Name.Reader: GRE :: Name -> Parent -> Bool -> [ImportSpec] -> GlobalRdrElt

+ GHC.Types.Name.Reader: GRE :: GreName -> Parent -> Bool -> [ImportSpec] -> GlobalRdrElt

- GHC.Types.Name.Reader: [gre_name] :: GlobalRdrElt -> Name

+ GHC.Types.Name.Reader: [gre_name] :: GlobalRdrElt -> GreName

- GHC.Types.Name.Reader: shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv

+ GHC.Types.Name.Reader: shadowNames :: GlobalRdrEnv -> [GreName] -> GlobalRdrEnv

- GHC.Types.Unique.Supply: initUniqSupply :: Int -> Int -> IO ()

+ GHC.Types.Unique.Supply: initUniqSupply :: Word -> Int -> IO ()

- GHC.Unit.Info: GenericUnitInfo :: uid -> compid -> [(modulename, mod)] -> srcpkgid -> srcpkgname -> Version -> Maybe srcpkgname -> String -> [uid] -> [(uid, String)] -> [FilePath] -> [String] -> [String] -> [String] -> [FilePath] -> [FilePath] -> [String] -> [FilePath] -> [String] -> [String] -> [String] -> [FilePath] -> [FilePath] -> [FilePath] -> [(modulename, Maybe mod)] -> [modulename] -> Bool -> Bool -> Bool -> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod

+ GHC.Unit.Info: GenericUnitInfo :: uid -> compid -> [(modulename, mod)] -> srcpkgid -> srcpkgname -> Version -> Maybe srcpkgname -> ShortText -> [uid] -> [(uid, ShortText)] -> [FilePathST] -> [ShortText] -> [ShortText] -> [ShortText] -> [FilePathST] -> [FilePathST] -> [ShortText] -> [FilePathST] -> [ShortText] -> [ShortText] -> [ShortText] -> [FilePathST] -> [FilePathST] -> [FilePathST] -> [(modulename, Maybe mod)] -> [modulename] -> Bool -> Bool -> Bool -> GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod

- GHC.Unit.Info: [unitAbiDepends] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [(uid, String)]

+ GHC.Unit.Info: [unitAbiDepends] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [(uid, ShortText)]

- GHC.Unit.Info: [unitAbiHash] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> String

+ GHC.Unit.Info: [unitAbiHash] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> ShortText

- GHC.Unit.Info: [unitCcOptions] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitCcOptions] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: [unitExtDepFrameworkDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitExtDepFrameworkDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitExtDepFrameworks] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitExtDepFrameworks] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: [unitExtDepLibsGhc] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitExtDepLibsGhc] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: [unitExtDepLibsSys] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitExtDepLibsSys] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: [unitHaddockHTMLs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitHaddockHTMLs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitHaddockInterfaces] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitHaddockInterfaces] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitImportDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitImportDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitIncludeDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitIncludeDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitIncludes] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitIncludes] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: [unitLibraries] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitLibraries] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: [unitLibraryDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitLibraryDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitLibraryDynDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePath]

+ GHC.Unit.Info: [unitLibraryDynDirs] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [FilePathST]

- GHC.Unit.Info: [unitLinkerOptions] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [String]

+ GHC.Unit.Info: [unitLinkerOptions] :: GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod -> [ShortText]

- GHC.Unit.Info: mapUnitInfo :: (u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v

+ GHC.Unit.Info: mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v

- GHC.Unit.Info: mkUnitPprInfo :: GenUnitInfo u -> UnitPprInfo

+ GHC.Unit.Info: mkUnitPprInfo :: (u -> FastString) -> GenUnitInfo u -> UnitPprInfo

- GHC.Unit.Ppr: UnitPprInfo :: String -> Version -> Maybe String -> UnitPprInfo

+ GHC.Unit.Ppr: UnitPprInfo :: FastString -> String -> Version -> Maybe String -> UnitPprInfo

- GHC.Unit.State: UnitState :: UnitInfoMap -> PreloadUnitClosure -> Map PackageName IndefUnitId -> Map UnitId UnitId -> Map UnitId UnitId -> [UnitId] -> [Unit] -> !ModuleNameProvidersMap -> !ModuleNameProvidersMap -> Map ModuleName [InstantiatedModule] -> !Bool -> UnitState

+ GHC.Unit.State: UnitState :: UnitInfoMap -> PreloadUnitClosure -> UniqFM PackageName IndefUnitId -> Map UnitId UnitId -> Map UnitId UnitId -> [UnitId] -> [Unit] -> !ModuleNameProvidersMap -> !ModuleNameProvidersMap -> Map ModuleName [InstantiatedModule] -> !Bool -> UnitState

- GHC.Unit.State: [packageNameMap] :: UnitState -> Map PackageName IndefUnitId

+ GHC.Unit.State: [packageNameMap] :: UnitState -> UniqFM PackageName IndefUnitId

- GHC.Unit.State: initUnits :: DynFlags -> IO DynFlags

+ GHC.Unit.State: initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)

- GHC.Unit.Types: Indefinite :: !unit -> Maybe UnitPprInfo -> Indefinite unit

+ GHC.Unit.Types: Indefinite :: unit -> Indefinite unit

- GHC.Unit.Types: [indefUnit] :: Indefinite unit -> !unit

+ GHC.Unit.Types: [indefUnit] :: Indefinite unit -> unit

- GHC.Unit.Types: mapGenUnit :: (u -> v) -> (v -> FastString) -> GenUnit u -> GenUnit v

+ GHC.Unit.Types: mapGenUnit :: IsUnitId v => (u -> v) -> GenUnit u -> GenUnit v

- GHC.Unit.Types: mkInstantiatedUnit :: IndefUnitId -> Instantiations -> InstantiatedUnit

+ GHC.Unit.Types: mkInstantiatedUnit :: IsUnitId u => Indefinite u -> GenInstantiations u -> GenInstantiatedUnit u

- GHC.Unit.Types: mkInstantiatedUnitHash :: IndefUnitId -> Instantiations -> FastString

+ GHC.Unit.Types: mkInstantiatedUnitHash :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString

- GHC.Unit.Types: mkVirtUnit :: IndefUnitId -> Instantiations -> Unit

+ GHC.Unit.Types: mkVirtUnit :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u

- GHC.Unit.Types: unitFS :: Unit -> FastString

+ GHC.Unit.Types: unitFS :: IsUnitId u => u -> FastString

- GHC.Unit.Types: unitString :: Unit -> String

+ GHC.Unit.Types: unitString :: IsUnitId u => u -> String

- GHC.Utils.Error: NotValid :: MsgDoc -> Validity

+ GHC.Utils.Error: NotValid :: SDoc -> Validity

- GHC.Utils.Error: compilationProgressMsg :: DynFlags -> String -> IO ()

+ GHC.Utils.Error: compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()

+ GHC.Utils.Error: debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()

- GHC.Utils.Error: emptyMessages :: Messages

+ GHC.Utils.Error: emptyMessages :: Messages e

- GHC.Utils.Error: errorMsg :: DynFlags -> MsgDoc -> IO ()

+ GHC.Utils.Error: errorMsg :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: errorsFound :: DynFlags -> Messages -> Bool

+ GHC.Utils.Error: errorsFound :: Messages e -> Bool

- GHC.Utils.Error: fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()

+ GHC.Utils.Error: fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc

+ GHC.Utils.Error: getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc

- GHC.Utils.Error: getInvalids :: [Validity] -> [MsgDoc]

+ GHC.Utils.Error: getInvalids :: [Validity] -> [SDoc]

- GHC.Utils.Error: ghcExit :: DynFlags -> Int -> IO ()

+ GHC.Utils.Error: ghcExit :: Logger -> DynFlags -> Int -> IO ()

- GHC.Utils.Error: isEmptyMessages :: Messages -> Bool

+ GHC.Utils.Error: isEmptyMessages :: Messages e -> Bool

- GHC.Utils.Error: logInfo :: DynFlags -> MsgDoc -> IO ()

+ GHC.Utils.Error: logInfo :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: logOutput :: DynFlags -> MsgDoc -> IO ()

+ GHC.Utils.Error: logOutput :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg

+ GHC.Utils.Error: makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e

- GHC.Utils.Error: mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc

+ GHC.Utils.Error: mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc

- GHC.Utils.Error: mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc

+ GHC.Utils.Error: mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> SDoc -> SDoc

- GHC.Utils.Error: mkLongWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg

+ GHC.Utils.Error: mkLongWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc

- GHC.Utils.Error: mkPlainWarnMsg :: DynFlags -> SrcSpan -> MsgDoc -> ErrMsg

+ GHC.Utils.Error: mkPlainWarnMsg :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc

- GHC.Utils.Error: mkWarnMsg :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> ErrMsg

+ GHC.Utils.Error: mkWarnMsg :: SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc

- GHC.Utils.Error: pprMessageBag :: Bag MsgDoc -> SDoc

+ GHC.Utils.Error: pprMessageBag :: Bag SDoc -> SDoc

- GHC.Utils.Error: printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()

+ GHC.Utils.Error: printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()

- GHC.Utils.Error: printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()

+ GHC.Utils.Error: printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()

- GHC.Utils.Error: putMsg :: DynFlags -> MsgDoc -> IO ()

+ GHC.Utils.Error: putMsg :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: showPass :: DynFlags -> String -> IO ()

+ GHC.Utils.Error: showPass :: Logger -> DynFlags -> String -> IO ()

- GHC.Utils.Error: traceCmd :: DynFlags -> String -> String -> IO a -> IO a

+ GHC.Utils.Error: traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a

- GHC.Utils.Error: type ErrorMessages = Bag ErrMsg

+ GHC.Utils.Error: type ErrorMessages = Bag (MsgEnvelope DecoratedSDoc)

- GHC.Utils.Error: type WarnMsg = ErrMsg

+ GHC.Utils.Error: type WarnMsg = MsgEnvelope DecoratedSDoc

- GHC.Utils.Error: type WarningMessages = Bag WarnMsg

+ GHC.Utils.Error: type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)

- GHC.Utils.Error: unionMessages :: Messages -> Messages -> Messages

+ GHC.Utils.Error: unionMessages :: Messages e -> Messages e -> Messages e

- GHC.Utils.Error: warningMsg :: DynFlags -> MsgDoc -> IO ()

+ GHC.Utils.Error: warningMsg :: Logger -> DynFlags -> SDoc -> IO ()

- GHC.Utils.Error: withTiming :: MonadIO m => DynFlags -> SDoc -> (a -> ()) -> m a -> m a

+ GHC.Utils.Error: withTiming :: MonadIO m => Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a

- GHC.Utils.Error: withTimingSilent :: MonadIO m => DynFlags -> SDoc -> (a -> ()) -> m a -> m a

+ GHC.Utils.Error: withTimingSilent :: MonadIO m => Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a

- GHC.Utils.Misc: notNull :: [a] -> Bool

+ GHC.Utils.Misc: notNull :: Foldable f => f a -> Bool

- GHC.Utils.Outputable: AsmStyle :: CodeStyle

+ GHC.Utils.Outputable: AsmStyle :: LabelStyle

- GHC.Utils.Outputable: CStyle :: CodeStyle

+ GHC.Utils.Outputable: CStyle :: LabelStyle

- GHC.Utils.Outputable: PprCode :: CodeStyle -> PprStyle

+ GHC.Utils.Outputable: PprCode :: LabelStyle -> PprStyle

- GHC.Utils.Outputable: SDC :: !PprStyle -> !Scheme -> !PprColour -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> DynFlags -> SDocContext

+ GHC.Utils.Outputable: SDC :: !PprStyle -> !Scheme -> !PprColour -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !FastString -> SDoc -> SDocContext

- GHC.Utils.Outputable: pprCode :: CodeStyle -> SDoc -> SDoc

+ GHC.Utils.Outputable: pprCode :: LabelStyle -> SDoc -> SDoc

- GHC.Utils.Panic: showGhcException :: GhcException -> ShowS

+ GHC.Utils.Panic: showGhcException :: SDocContext -> GhcException -> ShowS

- GHC.Utils.Ppr: PageMode :: Mode

+ GHC.Utils.Ppr: PageMode :: Bool -> Mode

Files

GHC.hs +340/−163
GHC/Builtin/Names.hs +217/−138
GHC/Builtin/Names/TH.hs +24/−15
GHC/Builtin/PrimOps.hs +59/−39
GHC/Builtin/RebindableNames.hs +0/−6
GHC/Builtin/Types.hs +345/−74
GHC/Builtin/Types.hs-boot +33/−7
GHC/Builtin/Types/Literals.hs +291/−119
GHC/Builtin/Types/Prim.hs +47/−44
GHC/Builtin/Types/Prim.hs-boot +5/−0
GHC/Builtin/Uniques.hs +253/−34
GHC/Builtin/Uniques.hs-boot +23/−1
GHC/Builtin/Utils.hs +20/−28
GHC/ByteCode/Asm.hs +133/−47
GHC/ByteCode/InfoTable.hs +29/−21
GHC/ByteCode/Instr.hs +69/−36
GHC/ByteCode/Linker.hs +85/−61
GHC/ByteCode/Types.hs +60/−5
GHC/Cmm.hs +26/−2
GHC/Cmm/CLabel.hs +397/−258
GHC/Cmm/CallConv.hs +80/−65
GHC/Cmm/CommonBlockElim.hs +2/−2
GHC/Cmm/Dataflow/Collections.hs +1/−3
GHC/Cmm/Dataflow/Label.hs +10/−3
GHC/Cmm/DebugBlock.hs +40/−25
GHC/Cmm/Expr.hs +39/−23
GHC/Cmm/Graph.hs +46/−45
GHC/Cmm/Info.hs +104/−99
GHC/Cmm/Info/Build.hs +153/−134
GHC/Cmm/LRegSet.hs +53/−0
GHC/Cmm/LayoutStack.hs +37/−35
GHC/Cmm/Lexer.x +5/−4
GHC/Cmm/Lint.hs +48/−45
GHC/Cmm/Liveness.hs +87/−17
GHC/Cmm/MachOp.hs +35/−0
GHC/Cmm/Monad.hs +0/−51
GHC/Cmm/Node.hs +17/−18
GHC/Cmm/Opt.hs +47/−48
GHC/Cmm/Parser.y +239/−169
GHC/Cmm/Parser/Monad.hs +82/−0
GHC/Cmm/Pipeline.hs +106/−108
GHC/Cmm/Ppr.hs +64/−60
GHC/Cmm/Ppr/Decl.hs +41/−44
GHC/Cmm/Ppr/Expr.hs +17/−12
GHC/Cmm/ProcPoint.hs +140/−141
GHC/Cmm/Sink.hs +140/−105
GHC/Cmm/Switch.hs +9/−8
GHC/Cmm/Switch/Implement.hs +5/−5
GHC/Cmm/Type.hs +22/−20
GHC/Cmm/Utils.hs +21/−25
GHC/CmmToAsm.hs +276/−324
GHC/CmmToAsm/AArch64.hs +60/−0
GHC/CmmToAsm/AArch64/CodeGen.hs +1437/−0
GHC/CmmToAsm/AArch64/Cond.hs +66/−0
GHC/CmmToAsm/AArch64/Instr.hs +762/−0
GHC/CmmToAsm/AArch64/Ppr.hs +588/−0
GHC/CmmToAsm/AArch64/RegInfo.hs +31/−0
GHC/CmmToAsm/AArch64/Regs.hs +167/−0
GHC/CmmToAsm/BlockLayout.hs +39/−39
GHC/CmmToAsm/CFG.hs +38/−39
GHC/CmmToAsm/CFG/Dominators.hs +566/−597
GHC/CmmToAsm/CFG/Weight.hs +78/−0
GHC/CmmToAsm/CPrim.hs +1/−0
GHC/CmmToAsm/Config.hs +18/−2
GHC/CmmToAsm/Dwarf.hs +36/−34
GHC/CmmToAsm/Dwarf/Constants.hs +4/−2
GHC/CmmToAsm/Dwarf/Types.hs +65/−42
GHC/CmmToAsm/Format.hs +5/−0
GHC/CmmToAsm/Instr.hs +16/−59
GHC/CmmToAsm/Monad.hs +20/−69
GHC/CmmToAsm/PIC.hs +85/−66
GHC/CmmToAsm/PPC.hs +60/−0
GHC/CmmToAsm/PPC/CodeGen.hs +70/−17
GHC/CmmToAsm/PPC/Instr.hs +63/−67
GHC/CmmToAsm/PPC/Ppr.hs +131/−146
GHC/CmmToAsm/PPC/Regs.hs +1/−0
GHC/CmmToAsm/Ppr.hs +13/−23
GHC/CmmToAsm/Reg/Graph.hs +10/−5
GHC/CmmToAsm/Reg/Graph/Base.hs +2/−1
GHC/CmmToAsm/Reg/Graph/Spill.hs +31/−35
GHC/CmmToAsm/Reg/Graph/SpillClean.hs +3/−1
GHC/CmmToAsm/Reg/Graph/SpillCost.hs +6/−3
GHC/CmmToAsm/Reg/Graph/Stats.hs +21/−14
GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +12/−3
GHC/CmmToAsm/Reg/Linear.hs +126/−90
GHC/CmmToAsm/Reg/Linear/AArch64.hs +137/−0
GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +17/−8
GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +12/−10
GHC/CmmToAsm/Reg/Linear/PPC.hs +2/−4
GHC/CmmToAsm/Reg/Linear/SPARC.hs +1/−2
GHC/CmmToAsm/Reg/Linear/State.hs +2/−14
GHC/CmmToAsm/Reg/Linear/Stats.hs +2/−1
GHC/CmmToAsm/Reg/Linear/X86.hs +0/−1
GHC/CmmToAsm/Reg/Linear/X86_64.hs +0/−1
GHC/CmmToAsm/Reg/Liveness.hs +54/−16
GHC/CmmToAsm/Reg/Target.hs +13/−5
GHC/CmmToAsm/SPARC.hs +74/−0
GHC/CmmToAsm/SPARC/CodeGen.hs +37/−8
GHC/CmmToAsm/SPARC/CodeGen/Base.hs +1/−0
GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs +7/−2
GHC/CmmToAsm/SPARC/CodeGen/Expand.hs +3/−2
GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs +1/−1
GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs +4/−3
GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs +8/−5
GHC/CmmToAsm/SPARC/Imm.hs +1/−0
GHC/CmmToAsm/SPARC/Instr.hs +56/−65
GHC/CmmToAsm/SPARC/Ppr.hs +180/−160
GHC/CmmToAsm/SPARC/Regs.hs +1/−0
GHC/CmmToAsm/SPARC/Stack.hs +1/−0
GHC/CmmToAsm/Types.hs +32/−0
GHC/CmmToAsm/Utils.hs +33/−0
GHC/CmmToAsm/X86.hs +65/−0
GHC/CmmToAsm/X86/CodeGen.hs +79/−46
GHC/CmmToAsm/X86/Instr.hs +78/−71
GHC/CmmToAsm/X86/Ppr.hs +85/−77
GHC/CmmToAsm/X86/RegInfo.hs +1/−0
GHC/CmmToAsm/X86/Regs.hs +1/−0
GHC/CmmToC.hs +240/−239
GHC/CmmToLlvm.hs +17/−15
GHC/CmmToLlvm/Base.hs +21/−23
GHC/CmmToLlvm/CodeGen.hs +73/−31
GHC/CmmToLlvm/Data.hs +1/−1
GHC/CmmToLlvm/Mangler.hs +4/−3
GHC/CmmToLlvm/Ppr.hs +2/−0
GHC/CmmToLlvm/Regs.hs +7/−7
GHC/Core.hs +31/−300
GHC/Core/Class.hs +2/−1
GHC/Core/Coercion.hs +197/−125
GHC/Core/Coercion.hs-boot +1/−1
GHC/Core/Coercion/Axiom.hs +25/−5
GHC/Core/Coercion/Opt.hs +43/−25
GHC/Core/ConLike.hs +14/−7
GHC/Core/ConLike.hs-boot +0/−9
GHC/Core/DataCon.hs +40/−31
GHC/Core/DataCon.hs-boot +7/−3
GHC/Core/FVs.hs +75/−92
GHC/Core/FamInstEnv.hs +42/−329
GHC/Core/InstEnv.hs +96/−48
GHC/Core/Lint.hs +180/−163
GHC/Core/Make.hs +38/−23
GHC/Core/Map.hs +0/−835
GHC/Core/Map/Expr.hs +393/−0
GHC/Core/Map/Type.hs +562/−0
GHC/Core/Multiplicity.hs +1/−2
GHC/Core/Opt/Arity.hs +1925/−1299
GHC/Core/Opt/CSE.hs +80/−25
GHC/Core/Opt/CallArity.hs +16/−14
GHC/Core/Opt/CallerCC.hs +224/−0
GHC/Core/Opt/CallerCC.hs-boot +8/−0
GHC/Core/Opt/ConstantFold.hs +3319/−2335
GHC/Core/Opt/CprAnal.hs +228/−144
GHC/Core/Opt/DmdAnal.hs +474/−336
GHC/Core/Opt/Exitify.hs +5/−7
GHC/Core/Opt/FloatIn.hs +14/−9
GHC/Core/Opt/FloatOut.hs +12/−9
GHC/Core/Opt/LiberateCase.hs +27/−26
GHC/Core/Opt/Monad.hs +64/−39
GHC/Core/Opt/OccurAnal.hs +3045/−2865
GHC/Core/Opt/Pipeline.hs +206/−127
GHC/Core/Opt/SetLevels.hs +19/−14
GHC/Core/Opt/Simplify.hs +240/−156
GHC/Core/Opt/Simplify/Env.hs +76/−39
GHC/Core/Opt/Simplify/Monad.hs +78/−55
GHC/Core/Opt/Simplify/Utils.hs +65/−46
GHC/Core/Opt/SpecConstr.hs +26/−27
GHC/Core/Opt/Specialise.hs +186/−171
GHC/Core/Opt/StaticArgs.hs +8/−6
GHC/Core/Opt/WorkWrap.hs +182/−94
GHC/Core/Opt/WorkWrap/Utils.hs +494/−351
GHC/Core/PatSyn.hs +64/−40
GHC/Core/PatSyn.hs-boot +0/−13
GHC/Core/Ppr.hs +32/−16
GHC/Core/Ppr/TyThing.hs +0/−205
GHC/Core/Predicate.hs +4/−2
GHC/Core/Rules.hs +15/−8
GHC/Core/Seq.hs +4/−3
GHC/Core/SimpleOpt.hs +108/−348
GHC/Core/SimpleOpt.hs-boot +11/−0
GHC/Core/Stats.hs +4/−3
GHC/Core/Subst.hs +47/−14
GHC/Core/Tidy.hs +9/−7
GHC/Core/TyCo/FVs.hs +29/−18
GHC/Core/TyCo/Ppr.hs +57/−20
GHC/Core/TyCo/Rep.hs +53/−141
GHC/Core/TyCo/Rep.hs-boot +2/−1
GHC/Core/TyCo/Subst.hs +22/−8
GHC/Core/TyCo/Tidy.hs +42/−22
GHC/Core/TyCon.hs +263/−317
GHC/Core/TyCon.hs-boot +9/−0
GHC/Core/TyCon/Env.hs +147/−0
GHC/Core/TyCon/RecWalk.hs +99/−0
GHC/Core/TyCon/Set.hs +73/−0
GHC/Core/Type.hs +536/−172
GHC/Core/Type.hs-boot +3/−0
GHC/Core/Unfold.hs +255/−341
GHC/Core/Unfold.hs-boot +11/−12
GHC/Core/Unfold/Make.hs +311/−0
GHC/Core/Unify.hs +575/−197
GHC/Core/UsageEnv.hs +16/−4
GHC/Core/Utils.hs +94/−79
GHC/CoreToByteCode.hs +0/−2066
GHC/CoreToIface.hs +13/−10
GHC/CoreToStg.hs +138/−85
GHC/CoreToStg/Prep.hs +104/−56
GHC/Data/Bag.hs +13/−3
GHC/Data/Bitmap.hs +0/−1
GHC/Data/BooleanFormula.hs +4/−3
GHC/Data/EnumSet.hs +4/−0
GHC/Data/FastMutInt.hs +22/−37
GHC/Data/FastString.hs +109/−38
GHC/Data/Graph/Color.hs +2/−1
GHC/Data/Graph/Directed.hs +5/−2
GHC/Data/Graph/Ops.hs +2/−1
GHC/Data/Graph/UnVar.hs +68/−32
GHC/Data/IOEnv.hs +37/−5
GHC/Data/List/SetOps.hs +4/−1
GHC/Data/Maybe.hs +11/−1
GHC/Data/OrdList.hs +66/−5
GHC/Data/Stream.hs +86/−77
GHC/Data/StringBuffer.hs +7/−59
GHC/Data/TrieMap.hs +61/−14
GHC/Driver/Backend.hs +94/−5
GHC/Driver/Backpack.hs +251/−173
GHC/Driver/Backpack/Syntax.hs +7/−2
GHC/Driver/CmdLine.hs +11/−1
GHC/Driver/CodeOutput.hs +145/−75
GHC/Driver/Config.hs +38/−0
GHC/Driver/Env.hs +287/−0
GHC/Driver/Env/Types.hs +163/−0
GHC/Driver/Errors.hs +93/−0
GHC/Driver/Finder.hs +0/−851
GHC/Driver/Flags.hs +24/−10
GHC/Driver/Hooks.hs +78/−42
GHC/Driver/Hooks.hs-boot +6/−0
GHC/Driver/Main.hs +2172/−2037
GHC/Driver/Make.hs +2968/−2776
GHC/Driver/MakeFile.hs +54/−34
GHC/Driver/Monad.hs +74/−6
GHC/Driver/Phases.hs +25/−69
GHC/Driver/Pipeline.hs +2150/−2296
GHC/Driver/Pipeline/Monad.hs +33/−12
GHC/Driver/Plugins.hs +30/−24
GHC/Driver/Ppr.hs +136/−0
GHC/Driver/Ppr.hs-boot +9/−0
GHC/Driver/Session.hs +5042/−5318
GHC/Driver/Session.hs-boot +0/−3
GHC/Driver/Types.hs +0/−3407
GHC/Driver/Ways.hs +0/−202
GHC/Hs.hs +36/−13
GHC/Hs/Binds.hs +111/−694
GHC/Hs/Decls.hs +1198/−2613
GHC/Hs/Doc.hs +22/−15
GHC/Hs/Dump.hs +171/−32
GHC/Hs/Expr.hs +1868/−3107
GHC/Hs/Expr.hs-boot +20/−32
GHC/Hs/Extension.hs +44/−595
GHC/Hs/ImpExp.hs +135/−77
GHC/Hs/Instances.hs +88/−26
GHC/Hs/Lit.hs +22/−178
GHC/Hs/Pat.hs +128/−384
GHC/Hs/Pat.hs-boot +8/−11
GHC/Hs/Stats.hs +7/−6
GHC/Hs/Type.hs +1246/−2084
GHC/Hs/Utils.hs +567/−353
GHC/HsToCore.hs +86/−63
GHC/HsToCore/Arrows.hs +54/−131
GHC/HsToCore/Binds.hs +45/−42
GHC/HsToCore/Coverage.hs +169/−154
GHC/HsToCore/Docs.hs +178/−81
GHC/HsToCore/Expr.hs +130/−228
GHC/HsToCore/Expr.hs-boot +4/−6
GHC/HsToCore/Foreign/Call.hs +16/−40
GHC/HsToCore/Foreign/Decl.hs +61/−67
GHC/HsToCore/GuardedRHSs.hs +43/−39
GHC/HsToCore/ListComp.hs +14/−14
GHC/HsToCore/Match.hs +100/−89
GHC/HsToCore/Match.hs-boot +2/−1
GHC/HsToCore/Match/Constructor.hs +9/−9
GHC/HsToCore/Match/Literal.hs +228/−87
GHC/HsToCore/Monad.hs +117/−88
GHC/HsToCore/PmCheck.hs +0/−1311
GHC/HsToCore/PmCheck/Oracle.hs +0/−1785
GHC/HsToCore/PmCheck/Ppr.hs +0/−222
GHC/HsToCore/PmCheck/Types.hs +0/−595
GHC/HsToCore/PmCheck/Types.hs-boot +0/−9
GHC/HsToCore/Pmc.hs +512/−0
GHC/HsToCore/Pmc/Check.hs +353/−0
GHC/HsToCore/Pmc/Desugar.hs +541/−0
GHC/HsToCore/Pmc/Ppr.hs +210/−0
GHC/HsToCore/Pmc/Solver.hs +1964/−0
GHC/HsToCore/Pmc/Solver/Types.hs +703/−0
GHC/HsToCore/Pmc/Types.hs +240/−0
GHC/HsToCore/Pmc/Utils.hs +148/−0
GHC/HsToCore/Quote.hs +388/−309
GHC/HsToCore/Types.hs +89/−0
GHC/HsToCore/Usage.hs +32/−21
GHC/HsToCore/Utils.hs +119/−31
GHC/Iface/Binary.hs +43/−54
GHC/Iface/Env.hs +30/−6
GHC/Iface/Ext/Ast.hs +444/−343
GHC/Iface/Ext/Binary.hs +5/−9
GHC/Iface/Ext/Debug.hs +5/−6
GHC/Iface/Ext/Fields.hs +94/−0
GHC/Iface/Ext/Types.hs +47/−13
GHC/Iface/Ext/Utils.hs +45/−18
GHC/Iface/Load.hs +466/−247
GHC/Iface/Load.hs-boot +1/−1
GHC/Iface/Make.hs +90/−62
GHC/Iface/Recomp.hs +71/−48
GHC/Iface/Recomp/Binary.hs +1/−2
GHC/Iface/Recomp/Flags.hs +11/−8
GHC/Iface/Rename.hs +57/−49
GHC/Iface/Syntax.hs +57/−42
GHC/Iface/Tidy.hs +106/−96
GHC/Iface/Tidy/StaticPtrTable.hs +26/−16
GHC/Iface/Type.hs +147/−72
GHC/Iface/UpdateIdInfos.hs +160/−0
GHC/IfaceToCore.hs +235/−82
GHC/IfaceToCore.hs-boot +11/−8
GHC/Linker.hs +36/−0
GHC/Linker/Dynamic.hs +260/−0
GHC/Linker/ExtraObj.hs +270/−0
GHC/Linker/Loader.hs +1740/−0
GHC/Linker/MacOS.hs +176/−0
GHC/Linker/Static.hs +335/−0
GHC/Linker/Types.hs +176/−0
GHC/Linker/Unit.hs +63/−0
GHC/Linker/Windows.hs +67/−0
GHC/Llvm/MetaData.hs +0/−1
GHC/Llvm/Ppr.hs +1/−0
GHC/Llvm/Types.hs +2/−1
GHC/Parser.y +4409/−4000
GHC/Parser/Annotation.hs +1277/−418
GHC/Parser/CharClass.hs +0/−1
GHC/Parser/Errors.hs +430/−0
GHC/Parser/Errors/Ppr.hs +620/−0
GHC/Parser/Header.hs +86/−73
GHC/Parser/Lexer.x +472/−357
GHC/Parser/PostProcess.hs +2993/−3089
GHC/Parser/PostProcess/Haddock.hs +133/−105
GHC/Parser/Types.hs +106/−0
GHC/Parser/Utils.hs +58/−0
GHC/Platform.hs +325/−0
GHC/Platform/Constants.hs +298/−0
GHC/Platform/Profile.hs +52/−0
GHC/Platform/RISCV64.hs +10/−0
GHC/Platform/Reg.hs +3/−1
GHC/Platform/Reg/Class.hs +1/−0
GHC/Platform/Regs.hs +6/−0
GHC/Platform/Ways.hs +272/−0
GHC/Plugins.hs +17/−5
GHC/Prelude.hs +58/−4
GHC/Rename/Bind.hs +125/−100
GHC/Rename/Doc.hs +0/−25
GHC/Rename/Env.hs +471/−204
GHC/Rename/Expr.hs +666/−272
GHC/Rename/Expr.hs-boot +15/−5
GHC/Rename/Fixity.hs +19/−15
GHC/Rename/HsType.hs +389/−252
GHC/Rename/Module.hs +429/−334
GHC/Rename/Names.hs +456/−211
GHC/Rename/Pat.hs +146/−119
GHC/Rename/Splice.hs +49/−37
GHC/Rename/Unbound.hs +47/−21
GHC/Rename/Utils.hs +133/−80
GHC/Runtime/Context.hs +400/−0
GHC/Runtime/Debugger.hs +48/−36
GHC/Runtime/Eval.hs +133/−181
GHC/Runtime/Eval/Types.hs +1/−1
GHC/Runtime/Heap/Inspect.hs +68/−12
GHC/Runtime/Heap/Layout.hs +88/−82
GHC/Runtime/Interpreter.hs +186/−170
GHC/Runtime/Interpreter/Types.hs +13/−2
GHC/Runtime/Linker.hs +0/−1780
GHC/Runtime/Linker/Types.hs +0/−108
GHC/Runtime/Loader.hs +65/−50
GHC/Settings.hs +4/−12
GHC/Settings/Config.hs +28/−0
GHC/Settings/Constants.hs +4/−4
GHC/Settings/IO.hs +38/−16
GHC/Stg/CSE.hs +11/−10
GHC/Stg/Debug.hs +240/−0
GHC/Stg/DepAnal.hs +3/−4
GHC/Stg/FVs.hs +7/−7
GHC/Stg/Lift.hs +6/−6
GHC/Stg/Lift/Analysis.hs +33/−44
GHC/Stg/Lift/Monad.hs +3/−2
GHC/Stg/Lint.hs +30/−26
GHC/Stg/Pipeline.hs +12/−8
GHC/Stg/Stats.hs +2/−5
GHC/Stg/Subst.hs +4/−0
GHC/Stg/Syntax.hs +86/−47
GHC/Stg/Unarise.hs +23/−49
GHC/StgToByteCode.hs +2268/−0
GHC/StgToCmm.hs +108/−71
GHC/StgToCmm/ArgRep.hs +29/−24
GHC/StgToCmm/Bind.hs +81/−67
GHC/StgToCmm/CgUtils.hs +90/−89
GHC/StgToCmm/Closure.hs +96/−78
GHC/StgToCmm/DataCon.hs +68/−30
GHC/StgToCmm/Env.hs +22/−17
GHC/StgToCmm/Expr.hs +71/−41
GHC/StgToCmm/ExtCode.hs +16/−3
GHC/StgToCmm/Foreign.hs +162/−97
GHC/StgToCmm/Heap.hs +37/−33
GHC/StgToCmm/Hpc.hs +7/−5
GHC/StgToCmm/Layout.hs +50/−41
GHC/StgToCmm/Monad.hs +73/−23
GHC/StgToCmm/Prim.hs +3221/−3031
GHC/StgToCmm/Prof.hs +125/−81
GHC/StgToCmm/Ticky.hs +23/−20
GHC/StgToCmm/Types.hs +4/−0
GHC/StgToCmm/Utils.hs +72/−20
GHC/SysTools.hs +18/−292
GHC/SysTools/BaseDir.hs +8/−6
GHC/SysTools/Elf.hs +35/−28
GHC/SysTools/ExtraObj.hs +0/−246
GHC/SysTools/FileCleanup.hs +0/−314
GHC/SysTools/Info.hs +87/−87
GHC/SysTools/Process.hs +56/−35
GHC/SysTools/Tasks.hs +90/−141
GHC/SysTools/Terminal.hs +1/−1
GHC/Tc/Deriv.hs +40/−34
GHC/Tc/Deriv/Functor.hs +25/−27
GHC/Tc/Deriv/Generate.hs +533/−331
GHC/Tc/Deriv/Generics.hs +99/−18
GHC/Tc/Deriv/Infer.hs +5/−8
GHC/Tc/Deriv/Utils.hs +39/−32
GHC/Tc/Errors.hs +185/−157
GHC/Tc/Errors/Hole.hs +20/−11
GHC/Tc/Errors/Hole/FitTypes.hs +2/−2
GHC/Tc/Gen/Annotation.hs +13/−8
GHC/Tc/Gen/App.hs +1208/−0
GHC/Tc/Gen/Arrow.hs +46/−33
GHC/Tc/Gen/Bind.hs +188/−185
GHC/Tc/Gen/Default.hs +22/−12
GHC/Tc/Gen/Export.hs +129/−136
GHC/Tc/Gen/Expr.hs +1636/−2952
GHC/Tc/Gen/Expr.hs-boot +8/−10
GHC/Tc/Gen/Foreign.hs +43/−30
GHC/Tc/Gen/Head.hs +1285/−0
GHC/Tc/Gen/HsType.hs +4206/−3913
GHC/Tc/Gen/Match.hs +97/−69
GHC/Tc/Gen/Match.hs-boot +4/−4
GHC/Tc/Gen/Pat.hs +213/−62
GHC/Tc/Gen/Rule.hs +7/−7
GHC/Tc/Gen/Sig.hs +124/−124
GHC/Tc/Gen/Splice.hs +299/−131
GHC/Tc/Gen/Splice.hs-boot +1/−1
GHC/Tc/Instance/Class.hs +49/−15
GHC/Tc/Instance/Family.hs +29/−16
GHC/Tc/Instance/FunDeps.hs +8/−8
GHC/Tc/Instance/Typeable.hs +33/−12
GHC/Tc/Module.hs +254/−224
GHC/Tc/Module.hs-boot +1/−1
GHC/Tc/Plugin.hs +8/−8
GHC/Tc/Solver.hs +2516/−2645
GHC/Tc/Solver/Canonical.hs +3189/−2551
GHC/Tc/Solver/Flatten.hs +0/−1948
GHC/Tc/Solver/Interact.hs +302/−637
GHC/Tc/Solver/Monad.hs +4228/−3665
GHC/Tc/Solver/Rewrite.hs +1046/−0
GHC/Tc/TyCl.hs +5219/−4917
GHC/Tc/TyCl/Build.hs +8/−8
GHC/Tc/TyCl/Class.hs +28/−22
GHC/Tc/TyCl/Instance.hs +181/−78
GHC/Tc/TyCl/PatSyn.hs +271/−186
GHC/Tc/TyCl/PatSyn.hs-boot +4/−3
GHC/Tc/TyCl/Utils.hs +106/−71
GHC/Tc/Types.hs +80/−92
GHC/Tc/Types/Constraint.hs +521/−249
GHC/Tc/Types/EvTerm.hs +20/−9
GHC/Tc/Types/Evidence.hs +55/−14
GHC/Tc/Types/Origin.hs +33/−30
GHC/Tc/Utils/Backpack.hs +138/−108
GHC/Tc/Utils/Env.hs +64/−48
GHC/Tc/Utils/Instantiate.hs +137/−154
GHC/Tc/Utils/Monad.hs +331/−214
GHC/Tc/Utils/TcMType.hs +363/−203
GHC/Tc/Utils/TcType.hs +310/−268
GHC/Tc/Utils/TcType.hs-boot +4/−0
GHC/Tc/Utils/Unify.hs +2075/−2081
GHC/Tc/Utils/Unify.hs-boot +5/−5
GHC/Tc/Utils/Zonk.hs +224/−130
GHC/Tc/Validity.hs +128/−115
GHC/ThToHs.hs +450/−372
GHC/Types/Avail.hs +207/−94
GHC/Types/Basic.hs +185/−339
GHC/Types/CompleteMatch.hs +40/−0
GHC/Types/CostCentre.hs +8/−5
GHC/Types/Cpr.hs +139/−72
GHC/Types/Demand.hs +1906/−2080
GHC/Types/Error.hs +387/−0
GHC/Types/FieldLabel.hs +113/−40
GHC/Types/Fixity.hs +119/−0
GHC/Types/Fixity/Env.hs +46/−0
GHC/Types/ForeignCall.hs +25/−24
GHC/Types/ForeignStubs.hs +46/−0
GHC/Types/HpcInfo.hs +34/−0
GHC/Types/IPE.hs +36/−0
GHC/Types/Id.hs +23/−13
GHC/Types/Id.hs-boot +7/−0
GHC/Types/Id/Info.hs +5/−4
GHC/Types/Id/Make.hs +166/−54
GHC/Types/Literal.hs +372/−154
GHC/Types/Meta.hs +53/−0
GHC/Types/Name.hs +63/−20
GHC/Types/Name.hs-boot +25/−2
GHC/Types/Name/Cache.hs +3/−1
GHC/Types/Name/Occurrence.hs +29/−12
GHC/Types/Name/Occurrence.hs-boot +9/−1
GHC/Types/Name/Ppr.hs +169/−0
GHC/Types/Name/Reader.hs +241/−165
GHC/Types/Name/Shape.hs +22/−13
GHC/Types/RepType.hs +15/−8
GHC/Types/SafeHaskell.hs +86/−0
GHC/Types/SourceError.hs +64/−0
GHC/Types/SourceFile.hs +94/−0
GHC/Types/SourceText.hs +324/−0
GHC/Types/SrcLoc.hs +39/−19
GHC/Types/Target.hs +67/−0
GHC/Types/Tickish.hs +372/−0
GHC/Types/TyThing.hs +315/−0
GHC/Types/TyThing.hs-boot +8/−0
GHC/Types/TyThing/Ppr.hs +211/−0
GHC/Types/TypeEnv.hs +96/−0
GHC/Types/Unique.hs +18/−141
GHC/Types/Unique/DFM.hs +9/−2
GHC/Types/Unique/FM.hs +22/−3
GHC/Types/Unique/Map.hs +206/−0
GHC/Types/Unique/SDFM.hs +121/−0
GHC/Types/Unique/Supply.hs +165/−140
GHC/Types/Var.hs +56/−22
GHC/Types/Var.hs-boot +8/−0
GHC/Types/Var/Env.hs +1/−0
GHC/Unit.hs +48/−28
GHC/Unit/Env.hs +61/−0
GHC/Unit/External.hs +131/−0
GHC/Unit/Finder.hs +612/−0
GHC/Unit/Finder/Types.hs +56/−0
GHC/Unit/Home.hs +211/−0
GHC/Unit/Home/ModInfo.hs +121/−0
GHC/Unit/Info.hs +119/−38
GHC/Unit/Module.hs +5/−13
GHC/Unit/Module/Deps.hs +195/−0
GHC/Unit/Module/Graph.hs +208/−0
GHC/Unit/Module/Imported.hs +54/−0
GHC/Unit/Module/ModDetails.hs +51/−0
GHC/Unit/Module/ModGuts.hs +140/−0
GHC/Unit/Module/ModIface.hs +535/−0
GHC/Unit/Module/ModSummary.hs +183/−0
GHC/Unit/Module/Name.hs +2/−2
GHC/Unit/Module/Status.hs +39/−0
GHC/Unit/Module/Warnings.hs +146/−0
GHC/Unit/Parser.hs +1/−1
GHC/Unit/Ppr.hs +15/−10
GHC/Unit/State.hs +229/−333
GHC/Unit/State.hs-boot +5/−6
GHC/Unit/Types.hs +71/−106
GHC/Utils/Binary.hs +174/−402
GHC/Utils/Binary/Typeable.hs +232/−0
GHC/Utils/BufHandle.hs +1/−2
GHC/Utils/Encoding.hs +0/−501
GHC/Utils/Error.hs +149/−663
GHC/Utils/Error.hs-boot +0/−50
GHC/Utils/Exception.hs +1/−2
GHC/Utils/GlobalVars.hs +112/−0
GHC/Utils/Logger.hs +473/−0
GHC/Utils/Misc.hs +130/−76
GHC/Utils/Monad.hs +191/−3
GHC/Utils/Outputable.hs +309/−223
GHC/Utils/Outputable.hs-boot +0/−5
GHC/Utils/Panic.hs +71/−31
GHC/Utils/Ppr.hs +46/−4
GHC/Utils/TmpFs.hs +409/−0
HsVersions.h +4/−4
Language/Haskell/Syntax.hs +62/−0
Language/Haskell/Syntax/Binds.hs +944/−0
Language/Haskell/Syntax/Decls.hs +1818/−0
Language/Haskell/Syntax/Expr.hs +1800/−0
Language/Haskell/Syntax/Expr.hs-boot +22/−0
Language/Haskell/Syntax/Extension.hs +696/−0
Language/Haskell/Syntax/Lit.hs +204/−0
Language/Haskell/Syntax/Pat.hs +375/−0
Language/Haskell/Syntax/Pat.hs-boot +13/−0
Language/Haskell/Syntax/Type.hs +1313/−0
cbits/genSym.c +5/−27
ghc.cabal +514/−430

GHC.hs view

@@ -27,14 +27,21 @@         needsTemplateHaskellOrQQ,          -- * Flags and settings-        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,-        GhcMode(..), GhcLink(..), defaultObjectTarget,-        parseDynamicFlags,+        DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,+        GhcMode(..), GhcLink(..),+        parseDynamicFlags, parseTargetFiles,         getSessionDynFlags, setSessionDynFlags,-        getProgramDynFlags, setProgramDynFlags, setLogAction,+        getProgramDynFlags, setProgramDynFlags,         getInteractiveDynFlags, setInteractiveDynFlags,         interpretPackageEnv, +        -- * Logging+        Logger, getLogger,+        pushLogHook, popLogHook,+        pushLogHookM, popLogHookM, modifyLogger,+        putMsgM, putLogMsgM,++         -- * Targets         Target(..), TargetId(..), Phase,         setTargets,@@ -152,9 +159,10 @@         GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,         modInfoModBreaks,         ModBreaks(..), BreakIndex,-        BreakInfo(breakInfo_number, breakInfo_module),+        BreakInfo(..),         GHC.Runtime.Eval.back,         GHC.Runtime.Eval.forward,+        GHC.Runtime.Eval.setupBreakpoint,          -- * Abstract syntax elements @@ -215,7 +223,7 @@         FamInst,          -- ** Types and Kinds-        Type, splitForAllTys, funResultTy,+        Type, splitForAllTyCoVars, funResultTy,         pprParendType, pprTypeApp,         Kind,         PredType,@@ -264,6 +272,7 @@          -- * Exceptions         GhcException(..), showGhcException,+        GhcApiError(..),          -- * Token stream manipulations         Token,@@ -274,10 +283,7 @@         parser,          -- * API Annotations-        ApiAnns(..),AnnKeywordId(..),AnnotationComment(..), ApiAnnKey,-        getAnnotation, getAndRemoveAnnotation,-        getAnnotationComments, getAndRemoveAnnotationComments,-        unicodeAnn,+        AnnKeywordId(..),EpaComment(..),          -- * Miscellaneous         --sessionHscEnv,@@ -294,31 +300,68 @@  import GHC.Prelude hiding (init) -import GHC.ByteCode.Types-import GHC.Runtime.Eval-import GHC.Runtime.Eval.Types-import GHC.Runtime.Interpreter-import GHC.Runtime.Interpreter.Types-import GHCi.RemoteTypes+import GHC.Platform+import GHC.Platform.Ways -import GHC.Core.Ppr.TyThing  ( pprFamInst )+import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename+                           , isSourceFilename, startPhase )+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.CmdLine+import GHC.Driver.Session hiding (WarnReason(..))+import GHC.Driver.Backend+import GHC.Driver.Config import GHC.Driver.Main import GHC.Driver.Make import GHC.Driver.Hooks import GHC.Driver.Pipeline   ( compileOne' ) import GHC.Driver.Monad-import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn )+import GHC.Driver.Ppr++import GHC.ByteCode.Types+import qualified GHC.Linker.Loader as Loader+import GHC.Runtime.Loader+import GHC.Runtime.Eval+import GHC.Runtime.Eval.Types+import GHC.Runtime.Interpreter+import GHC.Runtime.Context+import GHCi.RemoteTypes++import qualified GHC.Parser as Parser+import GHC.Parser.Lexer+import GHC.Parser.Annotation+import GHC.Parser.Errors.Ppr+import GHC.Parser.Utils+ import GHC.Iface.Load        ( loadSysInterface )+import GHC.Hs+import GHC.Builtin.Types.Prim ( alphaTyVars )+import GHC.Iface.Tidy+import GHC.Data.Bag        ( listToBag )+import GHC.Data.StringBuffer+import GHC.Data.FastString+import qualified GHC.LanguageExtensions as LangExt++import GHC.Tc.Utils.Monad    ( finalSafeMode, fixSafeInstances, initIfaceTcRn ) import GHC.Tc.Types+import GHC.Tc.Utils.TcType+import GHC.Tc.Module+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Instance.Family++import GHC.Utils.TmpFs+import GHC.SysTools+import GHC.SysTools.BaseDir++import GHC.Utils.Error+import GHC.Utils.Monad+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+ import GHC.Core.Predicate-import GHC.Unit.State-import GHC.Types.Name.Set-import GHC.Types.Name.Reader-import GHC.Hs import GHC.Core.Type  hiding( typeKind )-import GHC.Tc.Utils.TcType-import GHC.Types.Id-import GHC.Builtin.Types.Prim ( alphaTyVars ) import GHC.Core.TyCon import GHC.Core.TyCo.Ppr   ( pprForAll ) import GHC.Core.Class@@ -326,41 +369,39 @@ import GHC.Core.FVs        ( orphNamesOfFamInst ) import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts ) import GHC.Core.InstEnv+import GHC.Core++import GHC.Types.Id import GHC.Types.Name      hiding ( varName ) import GHC.Types.Avail import GHC.Types.SrcLoc-import GHC.Core-import GHC.Iface.Tidy-import GHC.Driver.Phases   ( Phase(..), isHaskellSrcFilename )-import GHC.Driver.Finder-import GHC.Driver.Types-import GHC.Driver.CmdLine-import GHC.Driver.Session hiding (WarnReason(..))-import GHC.Driver.Ways-import GHC.SysTools-import GHC.SysTools.BaseDir+import GHC.Types.TyThing.Ppr  ( pprFamInst ) import GHC.Types.Annotations-import GHC.Unit.Module-import GHC.Utils.Panic-import GHC.Platform-import GHC.Data.Bag        ( listToBag )-import GHC.Utils.Error-import GHC.Utils.Monad-import GHC.Utils.Misc-import GHC.Data.StringBuffer-import GHC.Utils.Outputable+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.Fixity+import GHC.Types.Target import GHC.Types.Basic-import GHC.Data.FastString-import qualified GHC.Parser as Parser-import GHC.Parser.Lexer-import GHC.Parser.Annotation-import qualified GHC.LanguageExtensions as LangExt+import GHC.Types.TyThing import GHC.Types.Name.Env-import GHC.Tc.Module-import GHC.Tc.Utils.Instantiate-import GHC.Tc.Instance.Family-import GHC.SysTools.FileCleanup+import GHC.Types.Name.Ppr+import GHC.Types.TypeEnv+import GHC.Types.SourceFile +import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+ import Data.Foldable import qualified Data.Map.Strict as Map import Data.Set (Set)@@ -383,6 +424,7 @@ import System.IO.Error  ( isDoesNotExistError ) import System.Environment ( getEnv ) import System.Directory+import Data.List (isPrefixOf)   -- %************************************************************************@@ -488,10 +530,12 @@    cleanup = do       hsc_env <- getSession       let dflags = hsc_dflags hsc_env+      let logger = hsc_logger hsc_env+      let tmpfs  = hsc_tmpfs hsc_env       liftIO $ do-          cleanTempFiles dflags-          cleanTempDirs dflags-          stopInterp hsc_env -- shut down the IServ+          cleanTempFiles logger tmpfs dflags+          cleanTempDirs logger tmpfs dflags+          traverse_ stopInterp (hsc_interp hsc_env)           --  exceptions will be blocked while we clean the temporary files,           -- so there shouldn't be any difficulty if we receive further           -- signals.@@ -515,11 +559,12 @@                    ; mySettings <- initSysTools top_dir                    ; myLlvmConfig <- lazyInitLlvmConfig top_dir                    ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)-                   ; checkBrokenTablesNextToCode dflags+                   ; hsc_env <- newHscEnv dflags+                   ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags                    ; setUnsafeGlobalDynFlags dflags                       -- c.f. DynFlags.parseDynamicFlagsFull, which                       -- creates DynFlags and sets the UnsafeGlobalDynFlags-                   ; newHscEnv dflags }+                   ; return hsc_env }        ; setSession env }  -- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which@@ -528,9 +573,9 @@ -- version where this bug is fixed. -- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and -- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333-checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()-checkBrokenTablesNextToCode dflags-  = do { broken <- checkBrokenTablesNextToCode' dflags+checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()+checkBrokenTablesNextToCode logger dflags+  = do { broken <- checkBrokenTablesNextToCode' logger dflags        ; when broken          $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr               ; liftIO $ fail "unsupported linker"@@ -541,13 +586,13 @@                    text "when using binutils ld (please see:" <+>                    text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)" -checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool-checkBrokenTablesNextToCode' dflags+checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool+checkBrokenTablesNextToCode' logger dflags   | not (isARM arch)                 = return False   | WayDyn `S.notMember` ways dflags = return False   | not tablesNextToCode             = return False   | otherwise                        = do-    linkerInfo <- liftIO $ getLinkerInfo dflags+    linkerInfo <- liftIO $ getLinkerInfo logger dflags     case linkerInfo of       GnuLD _  -> return True       _        -> return False@@ -589,19 +634,18 @@ -- read), and prepares the compilers knowledge about packages.  It can -- be called again to load new packages: just add new package flags to -- (packageFlags dflags).------ Returns a list of new packages that may need to be linked in using--- the dynamic linker (see 'linkPackages') as a result of new package--- flags.  If you are not doing linking or doing static linking, you--- can ignore the list of packages returned.--- setSessionDynFlags :: GhcMonad m => DynFlags -> m ()-setSessionDynFlags dflags = do-  dflags' <- checkNewDynFlags dflags-  dflags''' <- liftIO $ initUnits dflags'+setSessionDynFlags dflags0 = do+  logger <- getLogger+  dflags1 <- checkNewDynFlags logger dflags0+  hsc_env <- getSession+  let cached_unit_dbs = hsc_unit_dbs hsc_env+  (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags1 cached_unit_dbs +  dflags <- liftIO $ updatePlatformConstants dflags1 mconstants+   -- Interpreter-  interp  <- if gopt Opt_ExternalInterpreter dflags+  interp <- if gopt Opt_ExternalInterpreter dflags     then do          let            prog = pgm_i dflags ++ flavour@@ -613,7 +657,7 @@              | otherwise = ""            msg = text "Starting " <> text prog          tr <- if verbosity dflags >= 3-                then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)+                then return (logInfo logger dflags $ withPprStyle defaultDumpStyle msg)                 else return (pure ())          let           conf = IServConfig@@ -621,23 +665,34 @@             , iservConfOpts     = getOpts dflags opt_i             , iservConfProfiled = profiled             , iservConfDynamic  = dynamic-            , iservConfHook     = createIservProcessHook (hooks dflags)+            , iservConfHook     = createIservProcessHook (hsc_hooks hsc_env)             , iservConfTrace    = tr             }          s <- liftIO $ newMVar IServPending-         return (Just (ExternalInterp conf (IServ s)))+         loader <- liftIO Loader.uninitializedLoader+         return (Just (Interp (ExternalInterp conf (IServ s)) loader))     else #if defined(HAVE_INTERNAL_INTERPRETER)-      return (Just InternalInterp)+     do+      loader <- liftIO Loader.uninitializedLoader+      return (Just (Interp InternalInterp loader)) #else       return Nothing #endif -  modifySession $ \h -> h{ hsc_dflags = dflags'''-                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }+  let unit_env = UnitEnv+        { ue_platform  = targetPlatform dflags+        , ue_namever   = ghcNameVersion dflags+        , ue_home_unit = home_unit+        , ue_units     = unit_state+        }+  modifySession $ \h -> h{ hsc_dflags = dflags+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags }                          , hsc_interp = hsc_interp h <|> interp                            -- we only update the interpreter if there wasn't                            -- already one set up+                         , hsc_unit_env = unit_env+                         , hsc_unit_dbs = Just dbs                          }   invalidateModSummaryCache @@ -650,24 +705,31 @@ setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool setProgramDynFlags dflags = setProgramDynFlags_ True dflags --- | Set the action taken when the compiler produces a message.  This--- can also be accomplished using 'setProgramDynFlags', but using--- 'setLogAction' avoids invalidating the cached module graph.-setLogAction :: GhcMonad m => LogAction -> m ()-setLogAction action = do-  dflags' <- getProgramDynFlags-  void $ setProgramDynFlags_ False $-    dflags' { log_action = action }- setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool setProgramDynFlags_ invalidate_needed dflags = do-  dflags' <- checkNewDynFlags dflags+  logger <- getLogger+  dflags0 <- checkNewDynFlags logger dflags   dflags_prev <- getProgramDynFlags-  let changed = packageFlagsChanged dflags_prev dflags'-  dflags'' <- if changed-               then liftIO $ initUnits dflags'-               else return dflags'-  modifySession $ \h -> h{ hsc_dflags = dflags'' }+  let changed = packageFlagsChanged dflags_prev dflags0+  if changed+    then do+        hsc_env <- getSession+        let cached_unit_dbs = hsc_unit_dbs hsc_env+        (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 cached_unit_dbs++        dflags1 <- liftIO $ updatePlatformConstants dflags0 mconstants++        let unit_env = UnitEnv+              { ue_platform  = targetPlatform dflags1+              , ue_namever   = ghcNameVersion dflags1+              , ue_home_unit = home_unit+              , ue_units     = unit_state+              }+        modifySession $ \h -> h{ hsc_dflags   = dflags1+                               , hsc_unit_dbs = Just dbs+                               , hsc_unit_env = unit_env+                               }+    else modifySession $ \h -> h{ hsc_dflags = dflags0 }   when invalidate_needed $ invalidateModSummaryCache   return changed @@ -702,46 +764,149 @@ getProgramDynFlags = getSessionDynFlags  -- | Set the 'DynFlags' used to evaluate interactive expressions.+-- Also initialise (load) plugins.+-- -- Note: this cannot be used for changes to packages.  Use -- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the -- 'unitState' into the interactive @DynFlags@. setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do-  dflags' <- checkNewDynFlags dflags-  dflags'' <- checkNewInteractiveDynFlags dflags'-  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}+  logger <- getLogger+  dflags' <- checkNewDynFlags logger dflags+  dflags'' <- checkNewInteractiveDynFlags logger dflags'+  modifySessionM $ \hsc_env0 -> do+    let ic0 = hsc_IC hsc_env0 +    -- Initialise (load) plugins in the interactive environment with the new+    -- DynFlags+    plugin_env <- liftIO $ initializePlugins $ mkInteractiveHscEnv $+                    hsc_env0 { hsc_IC = ic0 { ic_dflags = dflags'' }}++    -- Update both plugins cache and DynFlags in the interactive context.+    return $ hsc_env0+                { hsc_IC = ic0+                    { ic_plugins = hsc_plugins plugin_env+                    , ic_dflags  = hsc_dflags  plugin_env+                    }+                }++ -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))  -parseDynamicFlags :: MonadIO m =>-                     DynFlags -> [Located String]-                  -> m (DynFlags, [Located String], [Warn])-parseDynamicFlags dflags cmdline = do+parseDynamicFlags+    :: MonadIO m+    => Logger+    -> DynFlags+    -> [Located String]+    -> m (DynFlags, [Located String], [Warn])+parseDynamicFlags logger dflags cmdline = do   (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline-  dflags2 <- liftIO $ interpretPackageEnv dflags1+  dflags2 <- liftIO $ interpretPackageEnv logger dflags1   return (dflags2, leftovers, warns) +-- | Parse command line arguments that look like files.+-- First normalises its arguments and then splits them into source files+-- and object files.+-- A source file can be turned into a 'Target' via 'guessTarget'+parseTargetFiles :: DynFlags -> [String] -> (DynFlags, [(String, Maybe Phase)], [String])+parseTargetFiles dflags0 fileish_args =+  let+    normal_fileish_paths = map normalise_hyp fileish_args+    (srcs, objs)         = partition_args normal_fileish_paths [] [] +    dflags1 = dflags0 { ldInputs = map (FileOption "") objs+                                   ++ ldInputs dflags0 }+    {-+      We split out the object files (.o, .dll) and add them+      to ldInputs for use by the linker.++      The following things should be considered compilation manager inputs:++       - haskell source files (strings ending in .hs, .lhs or other+         haskellish extension),++       - module names (not forgetting hierarchical module names),++       - things beginning with '-' are flags that were not recognised by+         the flag parser, and we want them to generate errors later in+         checkOptions, so we class them as source files (#5921)++       - and finally we consider everything without an extension to be+         a comp manager input, as shorthand for a .hs or .lhs filename.++      Everything else is considered to be a linker object, and passed+      straight through to the linker.+    -}+  in (dflags1, srcs, objs)++-- -----------------------------------------------------------------------------++-- | Splitting arguments into source files and object files.  This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.+partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+               -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+  | "none" <- suff      = partition_args args srcs objs+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs+        where phase = startPhase suff+              (slurp,rest) = break (== "-x") args+              these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+  | otherwise               = partition_args args srcs (arg:objs)+++looks_like_an_input :: String -> Bool+looks_like_an_input m =  isSourceFilename m+                      || looksLikeModuleName m+                      || "-" `isPrefixOf` m+                      || not (hasExtension m)+++-- | To simplify the handling of filepaths, we normalise all filepaths right+-- away. Note the asymmetry of FilePath.normalise:+--    Linux:   p\/q -> p\/q; p\\q -> p\\q+--    Windows: p\/q -> p\\q; p\\q -> p\\q+-- #12674: Filenames starting with a hyphen get normalised from ./-foo.hs+-- to -foo.hs. We have to re-prepend the current directory.+normalise_hyp :: FilePath -> FilePath+normalise_hyp fp+  | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp+  | otherwise                           = nfp+  where+#if defined(mingw32_HOST_OS)+    strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp+#else+    strt_dot_sl = "./" `isPrefixOf` fp+#endif+    cur_dir = '.' : [pathSeparator]+    nfp = normalise fp++-----------------------------------------------------------------------------+ -- | Checks the set of new DynFlags for possibly erroneous option -- combinations when invoking 'setSessionDynFlags' and friends, and if -- found, returns a fixed copy (if possible).-checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags-checkNewDynFlags dflags = do+checkNewDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+checkNewDynFlags logger dflags = do   -- See Note [DynFlags consistency]   let (dflags', warnings) = makeDynFlagsConsistent dflags-  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)+  liftIO $ handleFlagWarnings logger dflags (map (Warn NoReason) warnings)   return dflags' -checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags-checkNewInteractiveDynFlags dflags0 = do+checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags+checkNewInteractiveDynFlags logger dflags0 = do   -- We currently don't support use of StaticPointers in expressions entered on   -- the REPL. See #12356.   if xopt LangExt.StaticPointers dflags0-  then do liftIO $ printOrThrowWarnings dflags0 $ listToBag-            [mkPlainWarnMsg dflags0 interactiveSrcSpan+  then do liftIO $ printOrThrowWarnings logger dflags0 $ listToBag+            [mkPlainWarnMsg interactiveSrcSpan              $ text "StaticPointers is not supported in GHCi interactive expressions."]           return $ xopt_unset dflags0 LangExt.StaticPointers   else return dflags0@@ -863,9 +1028,7 @@ data ParsedModule =   ParsedModule { pm_mod_summary   :: ModSummary                , pm_parsed_source :: ParsedSource-               , pm_extra_src_files :: [FilePath]-               , pm_annotations :: ApiAnns }-               -- See Note [Api annotations] in GHC.Parser.Annotation+               , pm_extra_src_files :: [FilePath] }  instance ParsedMod ParsedModule where   modSummary m    = pm_mod_summary m@@ -957,9 +1120,8 @@    hsc_env <- getSession    let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }    hpm <- liftIO $ hscParse hsc_env_tmp ms-   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)-                           (hpm_annotations hpm))-               -- See Note [Api annotations] in GHC.Parser.Annotation+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm))+               -- See Note [exact print annotations] in GHC.Parser.Annotation  -- | Typecheck and rename a parsed module. --@@ -972,8 +1134,7 @@  (tc_gbl_env, rn_info)        <- liftIO $ hscTypecheckRename hsc_env_tmp ms $                       HsParsedModule { hpm_module = parsedSource pmod,-                                       hpm_src_files = pm_extra_src_files pmod,-                                       hpm_annotations = pm_annotations pmod }+                                       hpm_src_files = pm_extra_src_files pmod }  details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env  safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env @@ -1012,7 +1173,7 @@ -- -- A module must be loaded before dependent modules can be typechecked.  This -- always includes generating a 'ModIface' and, depending on the--- @DynFlags@\'s 'GHC.Driver.Session.hscTarget', may also include code generation.+-- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation. -- -- This function will always cause recompilation and will always overwrite -- previous compilation results (potentially files on disk).@@ -1131,7 +1292,7 @@         gutsToCoreModule safe_mode (Right mg) = CoreModule {           cm_module  = mg_module mg,           cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))-                                           (mg_tcs mg)+                                           (mg_tcs mg) (mg_patsyns mg)                                            (mg_fam_insts mg),           cm_binds   = mg_binds mg,           cm_safe    = safe_mode@@ -1163,8 +1324,8 @@     return $ ic_instances (hsc_IC hsc_env)  getPrintUnqual :: GhcMonad m => m PrintUnqualified-getPrintUnqual = withSession $ \hsc_env ->-  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))+getPrintUnqual = withSession $ \hsc_env -> do+  return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env)  -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo {@@ -1216,6 +1377,18 @@                         minf_modBreaks = emptyModBreaks                 })) +availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv+availsToGlobalRdrEnv mod_name avails+  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)+  where+      -- We're building a GlobalRdrEnv as if the user imported+      -- all the specified modules into the global interactive module+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}+    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,+                         is_qual = False,+                         is_dloc = srcLocSpan interactiveSrcLoc }++ getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl =   case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of@@ -1239,7 +1412,7 @@  modInfoTopLevelScope :: ModuleInfo -> Maybe [Name] modInfoTopLevelScope minf-  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)+  = fmap (map greMangledName . globalRdrEnvElts) (minf_rdr_env minf)  modInfoExports :: ModuleInfo -> [Name] modInfoExports minf = concatMap availNames $! minf_exports minf@@ -1259,7 +1432,8 @@                                ModuleInfo                             -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do-  return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))+  let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)+  return (fmap mk_print_unqual (minf_rdr_env minf))  modInfoLookupName :: GhcMonad m =>                      ModuleInfo -> Name@@ -1267,10 +1441,7 @@ modInfoLookupName minf name = withSession $ \hsc_env -> do    case lookupTypeEnv (minf_type_env minf) name of      Just tyThing -> return (Just tyThing)-     Nothing      -> do-       eps <- liftIO $ readIORef (hsc_EPS hsc_env)-       return $! lookupType (hsc_dflags hsc_env)-                            (hsc_HPT hsc_env) (eps_PTE eps) name+     Nothing      -> liftIO (lookupType hsc_env name)  modInfoIface :: ModuleInfo -> Maybe ModIface modInfoIface = minf_iface@@ -1296,7 +1467,7 @@ -- 'setContext'. lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing) lookupGlobalName name = withSession $ \hsc_env -> do-   liftIO $ lookupTypeHscEnv hsc_env name+   liftIO $ lookupType hsc_env name  findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a] findGlobalAnns deserialize target = withSession $ \hsc_env -> do@@ -1315,7 +1486,7 @@                      -- if it is visible from at least one module in the list.   -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load                      -- modules for everything that is in scope unqualified.-  -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))+  -> m (Messages DecoratedSDoc, Maybe (NameEnv ([ClsInst], [FamInst]))) getNameToInstancesIndex visible_mods mods_to_load = do   hsc_env <- getSession   liftIO $ runTcInteractive hsc_env $@@ -1413,29 +1584,25 @@ -- | Return module source as token stream, including comments. -- -- The module must be in the module graph and its source must be available.--- Throws a 'GHC.Driver.Types.SourceError' on parse error.+-- Throws a 'GHC.Driver.Env.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-    POk _ ts  -> return ts-    PFailed pst ->-        do dflags <- getDynFlags-           throwErrors (getErrorMessages pst dflags)+  case lexTokenStream (initParserOpts dflags) source startLoc of+    POk _ ts    -> return ts+    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))  -- | Give even more information on the source than 'getTokenStream' -- This function allows reconstructing the source completely with -- '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-    POk _ ts -> return $ addSourceToTokens startLoc source ts-    PFailed pst ->-        do dflags <- getDynFlags-           throwErrors (getErrorMessages pst dflags)+  case lexTokenStream (initParserOpts dflags) source startLoc of+    POk _ ts    -> return $ addSourceToTokens startLoc source ts+    PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))  -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the@@ -1492,16 +1659,14 @@ -- using the algorithm that is used for an @import@ declaration. findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do-  let-    dflags   = hsc_dflags hsc_env-    this_pkg = homeUnit dflags-  --+  let dflags     = hsc_dflags hsc_env+      home_unit  = hsc_home_unit hsc_env   case maybe_pkg of-    Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do+    Just pkg | not (isHomeUnit home_unit (fsToUnit pkg)) && pkg /= fsLit "this" -> liftIO $ do       res <- findImportedModule hsc_env mod_name maybe_pkg       case res of         Found _ m -> return m-        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err     _otherwise -> do       home <- lookupLoadedHomeModule mod_name       case home of@@ -1509,9 +1674,9 @@         Nothing -> liftIO $ do            res <- findImportedModule hsc_env mod_name maybe_pkg            case res of-             Found loc m | moduleUnit m /= this_pkg -> return m+             Found loc m | not (isHomeModule home_unit m) -> return m                          | otherwise -> modNotLoadedError dflags m loc-             err -> throwOneError $ noModError dflags noSrcSpan mod_name err+             err -> throwOneError $ noModError hsc_env noSrcSpan mod_name err  modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $@@ -1536,7 +1701,7 @@       res <- findExposedPackageModule hsc_env mod_name Nothing       case res of         Found _ m -> return m-        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err+        err       -> throwOneError $ noModError hsc_env noSrcSpan mod_name err  lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->@@ -1608,15 +1773,15 @@        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-         (warns, Left errs)+         let (warns,errs) = getMessages pst in+         (fmap pprWarning warns, Left (fmap pprError errs))       POk pst rdr_module ->-         let (warns,_) = getMessages pst dflags in-         (warns, Right rdr_module)+         let (warns,_) = getMessages pst in+         (fmap pprWarning warns, Right rdr_module)  -- ----------------------------------------------------------------------------- -- | Find the package environment (if one exists)@@ -1646,8 +1811,8 @@ -- > id1 -- > id2 ---interpretPackageEnv :: DynFlags -> IO DynFlags-interpretPackageEnv dflags = do+interpretPackageEnv :: Logger -> DynFlags -> IO DynFlags+interpretPackageEnv logger dflags = do     mPkgEnv <- runMaybeT $ msum $ [                    getCmdLineArg >>= \env -> msum [                        probeNullEnv env@@ -1675,18 +1840,18 @@         return dflags       Just envfile -> do         content <- readFile envfile-        compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)+        compilationProgressMsg logger dflags (text "Loaded package environment from " <> text envfile)         let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags          return dflags'   where     -- Loading environments (by name or by location) -    platformArchOs = platformMini (targetPlatform dflags)+    archOS = platformArchOS (targetPlatform dflags)      namedEnvPath :: String -> MaybeT IO FilePath     namedEnvPath name = do-     appdir <- versionedAppDir (programName dflags) platformArchOs+     appdir <- versionedAppDir (programName dflags) archOS      return $ appdir </> "environments" </> name      probeEnvName :: String -> MaybeT IO FilePath@@ -1723,7 +1888,7 @@      -- e.g. .ghc.environment.x86_64-linux-7.6.3     localEnvFileName :: FilePath-    localEnvFileName = ".ghc.environment" <.> versionedFilePath platformArchOs+    localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS      -- Search for an env file, starting in the current dir and looking upwards.     -- Fail if we get to the users home dir or the filesystem root. That is,@@ -1754,3 +1919,15 @@          "Package environment "       ++ show env       ++ " (specified in GHC_ENVIRONMENT) not found"++-- | An error thrown if the GHC API is used in an incorrect fashion.+newtype GhcApiError = GhcApiError String++instance Show GhcApiError where+  show (GhcApiError msg) = msg++instance Exception GhcApiError++mkApiErr :: DynFlags -> SDoc -> GhcApiError+mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)+

GHC/Builtin/Names.hs view

@@ -142,6 +142,7 @@ import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Data.FastString@@ -246,12 +247,13 @@         typeLitSortTyConName,         typeLitSymbolDataConName,         typeLitNatDataConName,+        typeLitCharDataConName,         typeRepIdName,         mkTrTypeName,         mkTrConName,         mkTrAppName,         mkTrFunName,-        typeSymbolTypeRepName, typeNatTypeRepName,+        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,         trGhcPrimModuleName,          -- KindReps for common cases@@ -264,6 +266,7 @@          -- Numeric stuff         negateName, minusName, geName, eqName,+        mkRationalBase2Name, mkRationalBase10Name,          -- Conversion functions         rationalTyConName,@@ -316,6 +319,7 @@          -- GHC Extensions         groupWithName,+        considerAccessibleName,          -- Strings and lists         unpackCStringName, unpackCStringUtf8Name,@@ -328,6 +332,9 @@         fromListNName,         toListName, +        -- Overloaded record dot, record update+        getFieldName, setFieldName,+         -- List operations         concatName, filterName, mapName,         zipName, foldrName, buildName, augmentName, appendName,@@ -335,7 +342,7 @@         -- FFI primitive types that are not wired-in.         stablePtrTyConName, ptrTyConName, funPtrTyConName,         int8TyConName, int16TyConName, int32TyConName, int64TyConName,-        word16TyConName, word32TyConName, word64TyConName,+        word8TyConName, word16TyConName, word32TyConName, word64TyConName,          -- Others         otherwiseIdName, inlineIdName,@@ -377,8 +384,6 @@         integerModName,         integerDivModName,         integerQuotRemName,-        integerToFloatName,-        integerToDoubleName,         integerEncodeFloatName,         integerEncodeDoubleName,         integerGcdName,@@ -431,6 +436,10 @@         bignatFromWordListName,          -- Float/Double+        integerToFloatName,+        integerToDoubleName,+        naturalToFloatName,+        naturalToDoubleName,         rationalToFloatName,         rationalToDoubleName, @@ -438,10 +447,10 @@         randomClassName, randomGenClassName, monadPlusClassName,          -- Type-level naturals-        knownNatClassName, knownSymbolClassName,+        knownNatClassName, knownSymbolClassName, knownCharClassName,          -- Overloaded labels-        isLabelClassName,+        fromLabelClassOpName,          -- Implicit Parameters         ipClassName,@@ -551,7 +560,8 @@     tYPEABLE, tYPEABLE_INTERNAL, gENERICS,     rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,     aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS,-    cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPENATS, dATA_TYPE_EQUALITY,+    cONTROL_EXCEPTION_BASE, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,+    gHC_TYPENATS, gHC_TYPENATS_INTERNAL, dATA_TYPE_EQUALITY,     dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module  gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values@@ -614,7 +624,9 @@ cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics") gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")+gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal") gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")+gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal") dATA_TYPE_EQUALITY = mkBaseModule (fsLit "Data.Type.Equality") dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce") dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")@@ -642,12 +654,11 @@ gHC_RECORDS :: Module gHC_RECORDS = mkBaseModule (fsLit "GHC.Records") -mAIN, rOOT_MAIN :: Module-mAIN            = mkMainModule_ mAIN_NAME+rOOT_MAIN :: Module rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation  mkInteractiveModule :: Int -> Module--- (mkInteractiveMoudule 9) makes module 'interactive:M9'+-- (mkInteractiveMoudule 9) makes module 'interactive:Ghci9' mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))  pRELUDE_NAME, mAIN_NAME :: ModuleName@@ -787,12 +798,13 @@ compose_RDR :: RdrName compose_RDR             = varQual_RDR gHC_BASE (fsLit ".") -not_RDR, getTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,+not_RDR, getTag_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,     and_RDR, range_RDR, inRange_RDR, index_RDR,     unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&") not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not") getTag_RDR              = varQual_RDR gHC_BASE (fsLit "getTag")+dataToTag_RDR           = varQual_RDR gHC_PRIM (fsLit "dataToTag#") succ_RDR                = varQual_RDR gHC_ENUM (fsLit "succ") pred_RDR                = varQual_RDR gHC_ENUM (fsLit "pred") minBound_RDR            = varQual_RDR gHC_ENUM (fsLit "minBound")@@ -1119,8 +1131,9 @@   -- Functions for GHC extensions-groupWithName :: Name-groupWithName = varQual gHC_EXTS (fsLit "groupWith") groupWithIdKey+groupWithName, considerAccessibleName :: Name+groupWithName          = varQual gHC_EXTS (fsLit "groupWith")          groupWithIdKey+considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey  -- Random PrelBase functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName,@@ -1186,8 +1199,6 @@    , integerModName    , integerDivModName    , integerQuotRemName-   , integerToFloatName-   , integerToDoubleName    , integerEncodeFloatName    , integerEncodeDoubleName    , integerGcdName@@ -1313,8 +1324,6 @@ integerModName            = bniVarQual "integerMod"                integerModIdKey integerDivModName         = bniVarQual "integerDivMod#"            integerDivModIdKey integerQuotRemName        = bniVarQual "integerQuotRem#"           integerQuotRemIdKey-integerToFloatName        = bniVarQual "integerToFloat#"           integerToFloatIdKey-integerToDoubleName       = bniVarQual "integerToDouble#"          integerToDoubleIdKey integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey@@ -1338,7 +1347,7 @@ rationalTyConName, ratioTyConName, ratioDataConName, realClassName,     integralClassName, realFracClassName, fractionalClassName,     fromRationalName, toIntegerName, toRationalName, fromIntegralName,-    realToFracName :: Name+    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name rationalTyConName   = tcQual  gHC_REAL (fsLit "Rational")     rationalTyConKey ratioTyConName      = tcQual  gHC_REAL (fsLit "Ratio")        ratioTyConKey ratioDataConName    = dcQual  gHC_REAL (fsLit ":%")           ratioDataConKey@@ -1351,14 +1360,21 @@ toRationalName      = varQual gHC_REAL (fsLit "toRational")   toRationalClassOpKey fromIntegralName    = varQual  gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey-+mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey+mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey  -- other GHC.Float functions-rationalToFloatName, rationalToDoubleName :: Name+integerToFloatName, integerToDoubleName,+  naturalToFloatName, naturalToDoubleName,+  rationalToFloatName, rationalToDoubleName :: Name+integerToFloatName   = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey+integerToDoubleName  = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey+naturalToFloatName   = varQual gHC_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey+naturalToDoubleName  = varQual gHC_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey @@ -1404,10 +1420,12 @@ typeLitSortTyConName   , typeLitSymbolDataConName   , typeLitNatDataConName+  , typeLitCharDataConName   :: Name typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey+typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey  -- Class Typeable, and functions for constructing `Typeable` dictionaries typeableClassName@@ -1421,6 +1439,7 @@   , typeRepIdName   , typeNatTypeRepName   , typeSymbolTypeRepName+  , typeCharTypeRepName   , trGhcPrimModuleName   :: Name typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey@@ -1434,6 +1453,7 @@ mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+typeCharTypeRepName   = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey -- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) -- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey@@ -1514,6 +1534,11 @@ fromListNName   = varQual gHC_EXTS (fsLit "fromListN") fromListNClassOpKey toListName      = varQual gHC_EXTS (fsLit "toList")    toListClassOpKey +-- HasField class ops+getFieldName, setFieldName :: Name+getFieldName   = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey+setFieldName   = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey+ -- Class Show showClassName :: Name showClassName   = clsQual gHC_SHOW (fsLit "Show")      showClassKey@@ -1562,7 +1587,8 @@ int64TyConName    = tcQual gHC_INT  (fsLit "Int64") int64TyConKey  -- Word module-word16TyConName, word32TyConName, word64TyConName :: Name+word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name+word8TyConName    = tcQual  gHC_WORD (fsLit "Word8")  word8TyConKey word16TyConName   = tcQual  gHC_WORD (fsLit "Word16") word16TyConKey word32TyConName   = tcQual  gHC_WORD (fsLit "Word32") word32TyConKey word64TyConName   = tcQual  gHC_WORD (fsLit "Word64") word64TyConKey@@ -1615,11 +1641,13 @@ knownNatClassName     = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey knownSymbolClassName :: Name knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey+knownCharClassName :: Name+knownCharClassName  = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey  -- Overloaded labels-isLabelClassName :: Name-isLabelClassName- = clsQual gHC_OVER_LABELS (fsLit "IsLabel") isLabelClassNameKey+fromLabelClassOpName :: Name+fromLabelClassOpName+ = varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey  -- Implicit Parameters ipClassName :: Name@@ -1690,13 +1718,18 @@ All these are original names; hence mkOrig -} +{-# INLINE varQual #-}+{-# INLINE tcQual #-}+{-# INLINE clsQual #-}+{-# INLINE dcQual #-} varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name-varQual  = mk_known_key_name varName-tcQual   = mk_known_key_name tcName-clsQual  = mk_known_key_name clsName-dcQual   = mk_known_key_name dataName+varQual  modu str unique = mk_known_key_name varName modu str unique+tcQual   modu str unique = mk_known_key_name tcName modu str unique+clsQual  modu str unique = mk_known_key_name clsName modu str unique+dcQual   modu str unique = mk_known_key_name dataName modu str unique  mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name+{-# INLINE mk_known_key_name #-} mk_known_key_name space modu str unique   = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan @@ -1763,7 +1796,7 @@ constructorClassKey = mkPreludeClassUnique 40 selectorClassKey    = mkPreludeClassUnique 41 --- KnownNat: see Note [KnowNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence+-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence knownNatClassNameKey :: Unique knownNatClassNameKey = mkPreludeClassUnique 42 @@ -1771,23 +1804,23 @@ knownSymbolClassNameKey :: Unique knownSymbolClassNameKey = mkPreludeClassUnique 43 -ghciIoClassKey :: Unique-ghciIoClassKey = mkPreludeClassUnique 44+knownCharClassNameKey :: Unique+knownCharClassNameKey = mkPreludeClassUnique 44 -isLabelClassNameKey :: Unique-isLabelClassNameKey = mkPreludeClassUnique 45+ghciIoClassKey :: Unique+ghciIoClassKey = mkPreludeClassUnique 45  semigroupClassKey, monoidClassKey :: Unique-semigroupClassKey = mkPreludeClassUnique 46-monoidClassKey    = mkPreludeClassUnique 47+semigroupClassKey = mkPreludeClassUnique 47+monoidClassKey    = mkPreludeClassUnique 48  -- Implicit Parameters ipClassKey :: Unique-ipClassKey = mkPreludeClassUnique 48+ipClassKey = mkPreludeClassUnique 49  -- Overloaded record fields hasFieldClassNameKey :: Unique-hasFieldClassNameKey = mkPreludeClassUnique 49+hasFieldClassNameKey = mkPreludeClassUnique 50   ---------------- Template Haskell -------------------@@ -1865,10 +1898,10 @@     wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,     word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey,     word64PrimTyConKey, word64TyConKey,-    liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,+    anyBoxConKey, kindConKey, boxityConKey,     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,-    eqReprPrimTyConKey, eqPhantPrimTyConKey, voidPrimTyConKey,+    eqReprPrimTyConKey, eqPhantPrimTyConKey,     compactPrimTyConKey :: Unique statePrimTyConKey                       = mkPreludeTyConUnique 50 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51@@ -1878,7 +1911,6 @@ eqPhantPrimTyConKey                     = mkPreludeTyConUnique 55 mutVarPrimTyConKey                      = mkPreludeTyConUnique 56 ioTyConKey                              = mkPreludeTyConUnique 57-voidPrimTyConKey                        = mkPreludeTyConUnique 58 wordPrimTyConKey                        = mkPreludeTyConUnique 59 wordTyConKey                            = mkPreludeTyConUnique 60 word8PrimTyConKey                       = mkPreludeTyConUnique 61@@ -1889,8 +1921,6 @@ word32TyConKey                          = mkPreludeTyConUnique 66 word64PrimTyConKey                      = mkPreludeTyConUnique 67 word64TyConKey                          = mkPreludeTyConUnique 68-liftedConKey                            = mkPreludeTyConUnique 69-unliftedConKey                          = mkPreludeTyConUnique 70 anyBoxConKey                            = mkPreludeTyConUnique 71 kindConKey                              = mkPreludeTyConUnique 72 boxityConKey                            = mkPreludeTyConUnique 73@@ -1905,16 +1935,24 @@ eitherTyConKey :: Unique eitherTyConKey                          = mkPreludeTyConUnique 84 +nonEmptyTyConKey :: Unique+nonEmptyTyConKey                        = mkPreludeTyConUnique 85+ -- Kind constructors-liftedTypeKindTyConKey, tYPETyConKey,-  constraintKindTyConKey, runtimeRepTyConKey,+liftedTypeKindTyConKey, unliftedTypeKindTyConKey,+  tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey,+  constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,   vecCountTyConKey, vecElemTyConKey :: Unique liftedTypeKindTyConKey                  = mkPreludeTyConUnique 87-tYPETyConKey                            = mkPreludeTyConUnique 88+unliftedTypeKindTyConKey                = mkPreludeTyConUnique 88+tYPETyConKey                            = mkPreludeTyConUnique 89 constraintKindTyConKey                  = mkPreludeTyConUnique 92+levityTyConKey                          = mkPreludeTyConUnique 94 runtimeRepTyConKey                      = mkPreludeTyConUnique 95 vecCountTyConKey                        = mkPreludeTyConUnique 96 vecElemTyConKey                         = mkPreludeTyConUnique 97+liftedRepTyConKey                       = mkPreludeTyConUnique 98+unliftedRepTyConKey                     = mkPreludeTyConUnique 99  pluginTyConKey, frontendPluginTyConKey :: Unique pluginTyConKey                          = mkPreludeTyConUnique 102@@ -1971,83 +2009,57 @@ uIntTyConKey    = mkPreludeTyConUnique 162 uWordTyConKey   = mkPreludeTyConUnique 163 --- Type-level naturals-typeNatKindConNameKey, typeSymbolKindConNameKey,-  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,-  typeNatLeqTyFamNameKey, typeNatSubTyFamNameKey-  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey-  , typeNatDivTyFamNameKey-  , typeNatModTyFamNameKey-  , typeNatLogTyFamNameKey-  :: Unique-typeNatKindConNameKey     = mkPreludeTyConUnique 164-typeSymbolKindConNameKey  = mkPreludeTyConUnique 165-typeNatAddTyFamNameKey    = mkPreludeTyConUnique 166-typeNatMulTyFamNameKey    = mkPreludeTyConUnique 167-typeNatExpTyFamNameKey    = mkPreludeTyConUnique 168-typeNatLeqTyFamNameKey    = mkPreludeTyConUnique 169-typeNatSubTyFamNameKey    = mkPreludeTyConUnique 170-typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 171-typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 172-typeNatDivTyFamNameKey  = mkPreludeTyConUnique 173-typeNatModTyFamNameKey  = mkPreludeTyConUnique 174-typeNatLogTyFamNameKey  = mkPreludeTyConUnique 175- -- Custom user type-errors errorMessageTypeErrorFamKey :: Unique-errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 176--+errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 181 -ntTyConKey:: Unique-ntTyConKey = mkPreludeTyConUnique 177 coercibleTyConKey :: Unique-coercibleTyConKey = mkPreludeTyConUnique 178+coercibleTyConKey = mkPreludeTyConUnique 183  proxyPrimTyConKey :: Unique-proxyPrimTyConKey = mkPreludeTyConUnique 179+proxyPrimTyConKey = mkPreludeTyConUnique 184  specTyConKey :: Unique-specTyConKey = mkPreludeTyConUnique 180+specTyConKey = mkPreludeTyConUnique 185  anyTyConKey :: Unique-anyTyConKey = mkPreludeTyConUnique 181+anyTyConKey = mkPreludeTyConUnique 186 -smallArrayPrimTyConKey        = mkPreludeTyConUnique  182-smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  183+smallArrayPrimTyConKey        = mkPreludeTyConUnique  187+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  188  staticPtrTyConKey  :: Unique-staticPtrTyConKey  = mkPreludeTyConUnique 184+staticPtrTyConKey  = mkPreludeTyConUnique 189  staticPtrInfoTyConKey :: Unique-staticPtrInfoTyConKey = mkPreludeTyConUnique 185+staticPtrInfoTyConKey = mkPreludeTyConUnique 190  callStackTyConKey :: Unique-callStackTyConKey = mkPreludeTyConUnique 186+callStackTyConKey = mkPreludeTyConUnique 191  -- Typeables typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique-typeRepTyConKey       = mkPreludeTyConUnique 187-someTypeRepTyConKey   = mkPreludeTyConUnique 188-someTypeRepDataConKey = mkPreludeTyConUnique 189+typeRepTyConKey       = mkPreludeTyConUnique 192+someTypeRepTyConKey   = mkPreludeTyConUnique 193+someTypeRepDataConKey = mkPreludeTyConUnique 194   typeSymbolAppendFamNameKey :: Unique-typeSymbolAppendFamNameKey = mkPreludeTyConUnique 190+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195  -- Unsafe equality unsafeEqualityTyConKey :: Unique-unsafeEqualityTyConKey = mkPreludeTyConUnique 191+unsafeEqualityTyConKey = mkPreludeTyConUnique 196  -- Linear types multiplicityTyConKey :: Unique-multiplicityTyConKey = mkPreludeTyConUnique 192+multiplicityTyConKey = mkPreludeTyConUnique 197  unrestrictedFunTyConKey :: Unique-unrestrictedFunTyConKey = mkPreludeTyConUnique 193+unrestrictedFunTyConKey = mkPreludeTyConUnique 198  multMulTyConKey :: Unique-multMulTyConKey = mkPreludeTyConUnique 194+multMulTyConKey = mkPreludeTyConUnique 199  ---------------- Template Haskell ------------------- --      GHC.Builtin.Names.TH: USES TyConUniques 200-299@@ -2059,6 +2071,38 @@  #include "primop-vector-uniques.hs-incl" +------------- Type-level Symbol, Nat, Char ----------+--      USES TyConUniques 400-499+-----------------------------------------------------+typeSymbolKindConNameKey, typeCharKindConNameKey,+  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,+  typeNatSubTyFamNameKey+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey+  , typeLeqCharTyFamNameKey+  , typeNatDivTyFamNameKey+  , typeNatModTyFamNameKey+  , typeNatLogTyFamNameKey+  , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey+  , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey+  :: Unique+typeSymbolKindConNameKey  = mkPreludeTyConUnique 400+typeCharKindConNameKey    = mkPreludeTyConUnique 401+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 402+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 403+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 404+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 405+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 407+typeCharCmpTyFamNameKey   = mkPreludeTyConUnique 408+typeLeqCharTyFamNameKey   = mkPreludeTyConUnique 409+typeNatDivTyFamNameKey  = mkPreludeTyConUnique 410+typeNatModTyFamNameKey  = mkPreludeTyConUnique 411+typeNatLogTyFamNameKey  = mkPreludeTyConUnique 412+typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413+typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414+typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415+typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416+ {- ************************************************************************ *                                                                      *@@ -2071,7 +2115,8 @@     floatDataConKey, intDataConKey, nilDataConKey,     ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,     word8DataConKey, ioDataConKey, heqDataConKey,-    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey :: Unique+    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey,+    nonEmptyDataConKey :: Unique  charDataConKey                          = mkPreludeDataConUnique  1 consDataConKey                          = mkPreludeDataConUnique  2@@ -2090,6 +2135,7 @@ wordDataConKey                          = mkPreludeDataConUnique 15 ioDataConKey                            = mkPreludeDataConUnique 16 heqDataConKey                           = mkPreludeDataConUnique 18+nonEmptyDataConKey                      = mkPreludeDataConUnique 19  -- Generic data constructors crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique@@ -2173,58 +2219,61 @@ metaConsDataConKey                      = mkPreludeDataConUnique 69 metaSelDataConKey                       = mkPreludeDataConUnique 70 -vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey :: Unique+vecRepDataConKey, tupleRepDataConKey, sumRepDataConKey,+  boxedRepDataConKey :: Unique vecRepDataConKey                        = mkPreludeDataConUnique 71 tupleRepDataConKey                      = mkPreludeDataConUnique 72 sumRepDataConKey                        = mkPreludeDataConUnique 73+boxedRepDataConKey                      = mkPreludeDataConUnique 74  -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types-runtimeRepSimpleDataConKeys, unliftedSimpleRepDataConKeys, unliftedRepDataConKeys :: [Unique]-liftedRepDataConKey :: Unique-runtimeRepSimpleDataConKeys@(liftedRepDataConKey : unliftedSimpleRepDataConKeys)-  = map mkPreludeDataConUnique [74..88]+-- Includes all nullary-data-constructor reps. Does not+-- include BoxedRep, VecRep, SumRep, TupleRep.+runtimeRepSimpleDataConKeys :: [Unique]+runtimeRepSimpleDataConKeys+  = map mkPreludeDataConUnique [75..87] -unliftedRepDataConKeys = vecRepDataConKey :-                         tupleRepDataConKey :-                         sumRepDataConKey :-                         unliftedSimpleRepDataConKeys+liftedDataConKey,unliftedDataConKey :: Unique+liftedDataConKey = mkPreludeDataConUnique 88+unliftedDataConKey = mkPreludeDataConUnique 89  -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types -- VecCount vecCountDataConKeys :: [Unique]-vecCountDataConKeys = map mkPreludeDataConUnique [89..94]+vecCountDataConKeys = map mkPreludeDataConUnique [90..95]  -- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types -- VecElem vecElemDataConKeys :: [Unique]-vecElemDataConKeys = map mkPreludeDataConUnique [95..104]+vecElemDataConKeys = map mkPreludeDataConUnique [96..105]  -- Typeable things kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,     kindRepFunDataConKey, kindRepTYPEDataConKey,     kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey     :: Unique-kindRepTyConAppDataConKey = mkPreludeDataConUnique 105-kindRepVarDataConKey      = mkPreludeDataConUnique 106-kindRepAppDataConKey      = mkPreludeDataConUnique 107-kindRepFunDataConKey      = mkPreludeDataConUnique 108-kindRepTYPEDataConKey     = mkPreludeDataConUnique 109-kindRepTypeLitSDataConKey = mkPreludeDataConUnique 110-kindRepTypeLitDDataConKey = mkPreludeDataConUnique 111+kindRepTyConAppDataConKey = mkPreludeDataConUnique 106+kindRepVarDataConKey      = mkPreludeDataConUnique 107+kindRepAppDataConKey      = mkPreludeDataConUnique 108+kindRepFunDataConKey      = mkPreludeDataConUnique 109+kindRepTYPEDataConKey     = mkPreludeDataConUnique 110+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112 -typeLitSymbolDataConKey, typeLitNatDataConKey :: Unique-typeLitSymbolDataConKey   = mkPreludeDataConUnique 112-typeLitNatDataConKey      = mkPreludeDataConUnique 113+typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique+typeLitSymbolDataConKey   = mkPreludeDataConUnique 113+typeLitNatDataConKey      = mkPreludeDataConUnique 114+typeLitCharDataConKey     = mkPreludeDataConUnique 115  -- Unsafe equality unsafeReflDataConKey :: Unique-unsafeReflDataConKey      = mkPreludeDataConUnique 114+unsafeReflDataConKey      = mkPreludeDataConUnique 116  -- Multiplicity  oneDataConKey, manyDataConKey :: Unique-oneDataConKey = mkPreludeDataConUnique 115-manyDataConKey = mkPreludeDataConUnique 116+oneDataConKey = mkPreludeDataConUnique 117+manyDataConKey = mkPreludeDataConUnique 118  -- ghc-bignum integerISDataConKey, integerINDataConKey, integerIPDataConKey,@@ -2314,6 +2363,9 @@ otherwiseIdKey                = mkPreludeMiscIdUnique 43 assertIdKey                   = mkPreludeMiscIdUnique 44 +leftSectionKey, rightSectionKey :: Unique+leftSectionKey                = mkPreludeMiscIdUnique 45+rightSectionKey               = mkPreludeMiscIdUnique 46  rootMainKey, runMainKey :: Unique rootMainKey                   = mkPreludeMiscIdUnique 101@@ -2337,19 +2389,23 @@ inlineIdKey                   = mkPreludeMiscIdUnique 120 -- see below -mapIdKey, groupWithIdKey, dollarIdKey :: Unique-mapIdKey              = mkPreludeMiscIdUnique 121-groupWithIdKey        = mkPreludeMiscIdUnique 122-dollarIdKey           = mkPreludeMiscIdUnique 123--coercionTokenIdKey :: Unique-coercionTokenIdKey    = mkPreludeMiscIdUnique 124+mapIdKey, groupWithIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique+mapIdKey                = mkPreludeMiscIdUnique 121+groupWithIdKey          = mkPreludeMiscIdUnique 122+dollarIdKey             = mkPreludeMiscIdUnique 123+coercionTokenIdKey      = mkPreludeMiscIdUnique 124+noinlineIdKey           = mkPreludeMiscIdUnique 125+considerAccessibleIdKey = mkPreludeMiscIdUnique 126 -noinlineIdKey                 = mkPreludeMiscIdUnique 125+integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique+integerToFloatIdKey    = mkPreludeMiscIdUnique 128+integerToDoubleIdKey   = mkPreludeMiscIdUnique 129+naturalToFloatIdKey    = mkPreludeMiscIdUnique 130+naturalToDoubleIdKey   = mkPreludeMiscIdUnique 131  rationalToFloatIdKey, rationalToDoubleIdKey :: Unique-rationalToFloatIdKey   = mkPreludeMiscIdUnique 130-rationalToDoubleIdKey  = mkPreludeMiscIdUnique 131+rationalToFloatIdKey   = mkPreludeMiscIdUnique 132+rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133  magicDictKey :: Unique magicDictKey                  = mkPreludeMiscIdUnique 156@@ -2395,6 +2451,10 @@ failMClassOpKey :: Unique failMClassOpKey = mkPreludeMiscIdUnique 176 +-- fromLabel+fromLabelClassOpKey :: Unique+fromLabelClassOpKey = mkPreludeMiscIdUnique 177+ -- Arrow notation arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,     loopAIdKey :: Unique@@ -2451,6 +2511,7 @@   , mkTrFunKey   , typeNatTypeRepKey   , typeSymbolTypeRepKey+  , typeCharTypeRepKey   , typeRepIdKey   :: Unique mkTyConKey            = mkPreludeMiscIdUnique 503@@ -2459,19 +2520,22 @@ mkTrAppKey            = mkPreludeMiscIdUnique 506 typeNatTypeRepKey     = mkPreludeMiscIdUnique 507 typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508-typeRepIdKey          = mkPreludeMiscIdUnique 509-mkTrFunKey            = mkPreludeMiscIdUnique 510+typeCharTypeRepKey    = mkPreludeMiscIdUnique 509+typeRepIdKey          = mkPreludeMiscIdUnique 510+mkTrFunKey            = mkPreludeMiscIdUnique 511  -- Representations for primitive types trTYPEKey-  ,trTYPE'PtrRepLiftedKey+  , trTYPE'PtrRepLiftedKey   , trRuntimeRepKey   , tr'PtrRepLiftedKey+  , trLiftedRepKey   :: Unique-trTYPEKey              = mkPreludeMiscIdUnique 511-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 512-trRuntimeRepKey        = mkPreludeMiscIdUnique 513-tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 514+trTYPEKey              = mkPreludeMiscIdUnique 512+trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513+trRuntimeRepKey        = mkPreludeMiscIdUnique 514+tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 515+trLiftedRepKey         = mkPreludeMiscIdUnique 516  -- KindReps for common cases starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique@@ -2515,6 +2579,10 @@ unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570 unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571 +-- HasField class ops+getFieldClassOpKey, setFieldClassOpKey :: Unique+getFieldClassOpKey = mkPreludeMiscIdUnique 572+setFieldClassOpKey = mkPreludeMiscIdUnique 573  ------------------------------------------------------ -- ghc-bignum uses 600-699 uniques@@ -2548,8 +2616,6 @@    , integerModIdKey    , integerDivModIdKey    , integerQuotRemIdKey-   , integerToFloatIdKey-   , integerToDoubleIdKey    , integerEncodeFloatIdKey    , integerEncodeDoubleIdKey    , integerGcdIdKey@@ -2631,8 +2697,6 @@ integerModIdKey            = mkPreludeMiscIdUnique 625 integerDivModIdKey         = mkPreludeMiscIdUnique 626 integerQuotRemIdKey        = mkPreludeMiscIdUnique 627-integerToFloatIdKey        = mkPreludeMiscIdUnique 628-integerToDoubleIdKey       = mkPreludeMiscIdUnique 629 integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 630 integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 631 integerGcdIdKey            = mkPreludeMiscIdUnique 632@@ -2687,6 +2751,15 @@  bignatFromWordListIdKey    = mkPreludeMiscIdUnique 690 +------------------------------------------------------+-- ghci optimization for big rationals 700-749 uniques+------------------------------------------------------++-- Creating rationals at runtime.+mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique+mkRationalBase2IdKey  = mkPreludeMiscIdUnique 700+mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique+ {- ************************************************************************ *                                                                      *@@ -2757,12 +2830,18 @@ *                                                                      * ************************************************************************ -The following names should be considered by GHCi to be in scope always.+GHCi's :info command will usually filter out instances mentioning types whose+names are not in scope. GHCi makes an exception for some commonly used names,+such as Data.Kind.Type, which may not actually be in scope but should be+treated as though they were in scope. The list in the definition of+pretendNameIsInScope below contains these commonly used names.  -}  pretendNameIsInScope :: Name -> Bool pretendNameIsInScope n   = any (n `hasKey`)-    [ liftedTypeKindTyConKey, tYPETyConKey-    , runtimeRepTyConKey, liftedRepDataConKey ]+    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey+    , liftedDataConKey, unliftedDataConKey+    , tYPETyConKey+    , runtimeRepTyConKey, boxedRepDataConKey ]

GHC/Builtin/Names/TH.hs view

@@ -9,11 +9,13 @@ import GHC.Prelude ()  import GHC.Builtin.Names( mk_known_key_name )-import GHC.Unit+import GHC.Unit.Types+import GHC.Unit.Module.Name import GHC.Types.Name( Name ) import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName ) import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Data.FastString  -- To add a name, do three things@@ -56,7 +58,7 @@     condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName,+    labelEName, implicitParamVarEName, getFieldEName, projectionEName,     -- FieldExp     fieldExpName,     -- Body@@ -102,7 +104,7 @@     promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,     wildCardTName, implicitParamTName,     -- TyLit-    numTyLitName, strTyLitName,+    numTyLitName, strTyLitName, charTyLitName,     -- TyVarBndr     plainTVName, kindedTVName,     plainInvisTVName, kindedInvisTVName,@@ -286,7 +288,7 @@     sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName :: Name+    labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name varEName              = libFun (fsLit "varE")              varEIdKey conEName              = libFun (fsLit "conE")              conEIdKey litEName              = libFun (fsLit "litE")              litEIdKey@@ -324,6 +326,8 @@ unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey labelEName            = libFun (fsLit "labelE")            labelEIdKey implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey+getFieldEName         = libFun (fsLit "getFieldE")         getFieldEIdKey+projectionEName       = libFun (fsLit "projectionE")       projectionEIdKey  -- type FieldExp = ... fieldExpName :: Name@@ -468,9 +472,10 @@ implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey  -- data TyLit = ...-numTyLitName, strTyLitName :: Name+numTyLitName, strTyLitName, charTyLitName :: Name numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey+charTyLitName = libFun (fsLit "charTyLit") charTyLitIdKey  -- data TyVarBndr = ... plainTVName, kindedTVName :: Name@@ -809,7 +814,8 @@     letEIdKey, caseEIdKey, doEIdKey, compEIdKey,     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,-    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,+    getFieldEIdKey, projectionEIdKey :: Unique varEIdKey              = mkPreludeMiscIdUnique 270 conEIdKey              = mkPreludeMiscIdUnique 271 litEIdKey              = mkPreludeMiscIdUnique 272@@ -843,6 +849,8 @@ labelEIdKey            = mkPreludeMiscIdUnique 300 implicitParamVarEIdKey = mkPreludeMiscIdUnique 301 mdoEIdKey              = mkPreludeMiscIdUnique 302+getFieldEIdKey         = mkPreludeMiscIdUnique 303+projectionEIdKey       = mkPreludeMiscIdUnique 304  -- type FieldExp = ... fieldExpIdKey :: Unique@@ -989,14 +997,15 @@ infixTIdKey         = mkPreludeMiscIdUnique 410  -- data TyLit = ...-numTyLitIdKey, strTyLitIdKey :: Unique-numTyLitIdKey = mkPreludeMiscIdUnique 411-strTyLitIdKey = mkPreludeMiscIdUnique 412+numTyLitIdKey, strTyLitIdKey, charTyLitIdKey :: Unique+numTyLitIdKey  = mkPreludeMiscIdUnique 411+strTyLitIdKey  = mkPreludeMiscIdUnique 412+charTyLitIdKey = mkPreludeMiscIdUnique 413  -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique-plainTVIdKey       = mkPreludeMiscIdUnique 413-kindedTVIdKey      = mkPreludeMiscIdUnique 414+plainTVIdKey       = mkPreludeMiscIdUnique 414+kindedTVIdKey      = mkPreludeMiscIdUnique 415  plainInvisTVIdKey, kindedInvisTVIdKey :: Unique plainInvisTVIdKey       = mkPreludeMiscIdUnique 482@@ -1004,10 +1013,10 @@  -- data Role = ... nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique-nominalRIdKey          = mkPreludeMiscIdUnique 415-representationalRIdKey = mkPreludeMiscIdUnique 416-phantomRIdKey          = mkPreludeMiscIdUnique 417-inferRIdKey            = mkPreludeMiscIdUnique 418+nominalRIdKey          = mkPreludeMiscIdUnique 416+representationalRIdKey = mkPreludeMiscIdUnique 417+phantomRIdKey          = mkPreludeMiscIdUnique 418+inferRIdKey            = mkPreludeMiscIdUnique 419  -- data Kind = ... starKIdKey, constraintKIdKey :: Unique

GHC/Builtin/PrimOps.hs view

@@ -17,6 +17,7 @@         primOpOutOfLine, primOpCodeSize,         primOpOkForSpeculation, primOpOkForSideEffects,         primOpIsCheap, primOpFixity, primOpDocs,+        primOpIsDiv,          getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..), @@ -38,13 +39,15 @@ import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) ) import GHC.Core.Type-import GHC.Types.RepType ( typePrimRep1, tyConPrimRep1 )-import GHC.Types.Basic   ( Arity, Fixity(..), FixityDirection(..), Boxity(..),-                           SourceText(..) )+import GHC.Types.RepType ( tyConPrimRep1 )+import GHC.Types.Basic   ( Arity, Boxity(..) )+import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc  ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString )-import GHC.Types.Unique  ( Unique, mkPrimOpIdUnique, mkPrimOpWrapperUnique )-import GHC.Unit          ( Unit )+import GHC.Types.SourceText  ( SourceText(..) )+import GHC.Types.Unique  ( Unique)+import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique )+import GHC.Unit.Types    ( Unit ) import GHC.Utils.Outputable import GHC.Data.FastString @@ -102,33 +105,17 @@ \subsection[PrimOp-info]{The essential info about each @PrimOp@} *                                                                      * ************************************************************************--The @String@ in the @PrimOpInfos@ is the ``base name'' by which the user may-refer to the primitive operation.  The conventional \tr{#}-for--unboxed ops is added on later.--The reason for the funny characters in the names is so we do not-interfere with the programmer's Haskell name spaces.--We use @PrimKinds@ for the ``type'' information, because they're-(slightly) more convenient to use than @TyCons@. -}  data PrimOpInfo-  = Dyadic      OccName         -- string :: T -> T -> T-                Type-  | Monadic     OccName         -- string :: T -> T-                Type-  | Compare     OccName         -- string :: T -> T -> Int#+  = Compare     OccName         -- string :: T -> T -> Int#                 Type   | GenPrimOp   OccName         -- string :: \/a1..an . T1 -> .. -> Tk -> T                 [TyVar]                 [Type]                 Type -mkDyadic, mkMonadic, mkCompare :: FastString -> Type -> PrimOpInfo-mkDyadic str  ty = Dyadic  (mkVarOccFS str) ty-mkMonadic str ty = Monadic (mkVarOccFS str) ty+mkCompare :: FastString -> Type -> PrimOpInfo mkCompare str ty = Compare (mkVarOccFS str) ty  mkGenPrimOp :: FastString -> [TyVar] -> [Type] -> Type -> PrimOpInfo@@ -539,6 +526,51 @@ -- that (it's exprIsDupable that does) so the problem doesn't occur -- even if primOpIsCheap sometimes says 'True'. ++-- | True of dyadic operators that can fail only if the second arg is zero!+--+-- This function probably belongs in an automagically generated file.. but it's+-- such a special case I thought I'd leave it here for now.+primOpIsDiv :: PrimOp -> Bool+primOpIsDiv op = case op of++  -- TODO: quotRemWord2, Int64, Word64+  IntQuotOp       -> True+  Int8QuotOp      -> True+  Int16QuotOp     -> True+  Int32QuotOp     -> True++  IntRemOp        -> True+  Int8RemOp       -> True+  Int16RemOp      -> True+  Int32RemOp      -> True++  IntQuotRemOp    -> True+  Int8QuotRemOp   -> True+  Int16QuotRemOp  -> True+  Int32QuotRemOp  -> True++  WordQuotOp      -> True+  Word8QuotOp     -> True+  Word16QuotOp    -> True+  Word32QuotOp    -> True++  WordRemOp       -> True+  Word8RemOp      -> True+  Word16RemOp     -> True+  Word32RemOp     -> True++  WordQuotRemOp   -> True+  Word8QuotRemOp  -> True+  Word16QuotRemOp -> True+  Word32QuotRemOp -> True++  FloatDivOp      -> True+  DoubleDivOp     -> True+  _               -> False+++ {- ************************************************************************ *                                                                      *@@ -574,8 +606,6 @@ primOpType :: PrimOp -> Type  -- you may want to use primOpSig instead primOpType op   = case primOpInfo op of-    Dyadic  _occ ty -> dyadic_fun_ty ty-    Monadic _occ ty -> monadic_fun_ty ty     Compare _occ ty -> compare_fun_ty ty      GenPrimOp _occ tyvars arg_tys res_ty ->@@ -584,15 +614,11 @@ primOpResultType :: PrimOp -> Type primOpResultType op   = case primOpInfo op of-    Dyadic  _occ ty  -> ty-    Monadic _occ ty  -> ty     Compare _occ _ty -> intPrimTy     GenPrimOp _occ _tyvars _arg_tys res_ty -> res_ty  primOpOcc :: PrimOp -> OccName primOpOcc op = case primOpInfo op of-               Dyadic    occ _     -> occ-               Monadic   occ _     -> occ                Compare   occ _     -> occ                GenPrimOp occ _ _ _ -> occ @@ -654,7 +680,7 @@  STG requires that primop applications be saturated. This makes code generation significantly simpler since otherwise we would need to define a calling-convention for curried applications that can accomodate levity polymorphism.+convention for curried applications that can accommodate levity polymorphism.  To ensure saturation, CorePrep eta expands expand all primop applications as described in Note [Eta expansion of hasNoBinding things in CorePrep] in@@ -691,8 +717,8 @@  isComparisonPrimOp :: PrimOp -> Bool isComparisonPrimOp op = case primOpInfo op of-                          Compare {} -> True-                          _          -> False+                          Compare {}   -> True+                          GenPrimOp {} -> False  -- primOpSig is like primOpType but gives the result split apart: -- (type variables, argument types, result type)@@ -705,8 +731,6 @@     arity = length arg_tys     (tyvars, arg_tys, res_ty)       = case (primOpInfo op) of-        Monadic   _occ ty                    -> ([],     [ty],    ty       )-        Dyadic    _occ ty                    -> ([],     [ty,ty], ty       )         Compare   _occ ty                    -> ([],     [ty,ty], intPrimTy)         GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   ) @@ -721,8 +745,6 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op   = case (primOpInfo op) of-      Dyadic  _ ty                        -> ReturnsPrim (typePrimRep1 ty)-      Monadic _ ty                        -> ReturnsPrim (typePrimRep1 ty)       Compare _ _                         -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)       GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)                          | otherwise      -> ReturnsAlg tc@@ -746,9 +768,7 @@  -- Utils: -dyadic_fun_ty, monadic_fun_ty, compare_fun_ty :: Type -> Type-dyadic_fun_ty  ty = mkVisFunTysMany [ty, ty] ty-monadic_fun_ty ty = mkVisFunTyMany  ty ty+compare_fun_ty :: Type -> Type compare_fun_ty ty = mkVisFunTysMany [ty, ty] intPrimTy  -- Output stuff:

− GHC/Builtin/RebindableNames.hs

@@ -1,6 +0,0 @@-module GHC.Builtin.RebindableNames where--import GHC.Data.FastString--reboundIfSymbol :: FastString-reboundIfSymbol = fsLit "ifThenElse"

GHC/Builtin/Types.hs view

@@ -55,7 +55,7 @@         wordTyCon, wordDataCon, wordTyConName, wordTy,          -- * Word8-        word8TyCon, word8DataCon, word8TyConName, word8Ty,+        word8TyCon, word8DataCon, word8Ty,          -- * List         listTyCon, listTyCon_RDR, listTyConName, listTyConKey,@@ -64,24 +64,33 @@         promotedNilDataCon, promotedConsDataCon,         mkListTy, mkPromotedListTy, +        -- * NonEmpty+        nonEmptyTyCon, nonEmptyTyConName,+        nonEmptyDataCon, nonEmptyDataConName,+         -- * Maybe         maybeTyCon, maybeTyConName,         nothingDataCon, nothingDataConName, promotedNothingDataCon,         justDataCon, justDataConName, promotedJustDataCon,+        mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,          -- * Tuples         mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,         tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,         promotedTupleDataCon,         unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,-        pairTyCon,+        soloTyCon,+        pairTyCon, mkPromotedPairTy, isPromotedPairType,+        unboxedUnitTy,         unboxedUnitTyCon, unboxedUnitDataCon,         unboxedTupleKind, unboxedSumKind,+        filterCTuple,          -- ** Constraint tuples-        cTupleTyConName, cTupleTyConNames, isCTupleTyConName,+        cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,         cTupleTyConNameArity_maybe,-        cTupleDataConName, cTupleDataConNames,+        cTupleDataCon, cTupleDataConName, cTupleDataConNames,+        cTupleSelId, cTupleSelIdName,          -- * Any         anyTyCon, anyTy, anyTypeOfKind,@@ -93,11 +102,14 @@         mkSumTy, sumTyCon, sumDataCon,          -- * Kinds-        typeNatKindCon, typeNatKind, typeSymbolKindCon, typeSymbolKind,-        isLiftedTypeKindTyConName, liftedTypeKind,-        typeToTypeKind, constraintKind,-        liftedTypeKindTyCon, constraintKindTyCon,  constraintKindTyConName,-        liftedTypeKindTyConName,+        typeSymbolKindCon, typeSymbolKind,+        isLiftedTypeKindTyConName,+        typeToTypeKind,+        liftedRepTyCon, unliftedRepTyCon,+        constraintKind, liftedTypeKind, unliftedTypeKind,+        constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,+        constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,+        liftedRepTyConName, unliftedRepTyConName,          -- * Equality predicates         heqTyCon, heqTyConName, heqClass, heqDataCon,@@ -105,13 +117,16 @@         coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,          -- * RuntimeRep and friends-        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,+        runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon, -        runtimeRepTy, liftedRepTy, liftedRepDataCon, liftedRepDataConTyCon,+        boxedRepDataConTyCon,+        runtimeRepTy, liftedRepTy, unliftedRepTy,          vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon, -        liftedRepDataConTy, unliftedRepDataConTy,+        liftedDataConTyCon, unliftedDataConTyCon,+        liftedDataConTy, unliftedDataConTy,+         intRepDataConTy,         int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,         wordRepDataConTy,@@ -156,33 +171,36 @@ -- friends: import GHC.Builtin.Names import GHC.Builtin.Types.Prim-import {-# SOURCE #-} GHC.Builtin.Uniques+import GHC.Builtin.Uniques  -- others: import GHC.Core.Coercion.Axiom import GHC.Types.Id+import GHC.Types.TyThing+import GHC.Types.SourceText import GHC.Types.Var (VarBndr (Bndr)) import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import GHC.Unit.Module        ( Module ) import GHC.Core.Type+import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp)) import GHC.Types.RepType import GHC.Core.DataCon-import {-# SOURCE #-} GHC.Core.ConLike+import GHC.Core.ConLike import GHC.Core.TyCon import GHC.Core.Class     ( Class, mkClass ) import GHC.Types.Name.Reader import GHC.Types.Name as Name import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )-import GHC.Types.Name.Set ( NameSet, mkNameSet, elemNameSet ) import GHC.Types.Basic import GHC.Types.ForeignCall-import GHC.Types.SrcLoc   ( noSrcSpan )-import GHC.Types.Unique+import GHC.Types.Unique.Set import Data.Array import GHC.Data.FastString+import GHC.Data.BooleanFormula ( mkAnd )+ import GHC.Utils.Outputable import GHC.Utils.Misc-import GHC.Data.BooleanFormula ( mkAnd )+import GHC.Utils.Panic  import qualified Data.ByteString.Char8 as BS @@ -206,6 +224,43 @@  See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType. ++Note [Wired-in Types and Type Constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This module include a lot of wired-in types and type constructors. Here,+these are presented in a tabular format to make it easier to find the+wired-in type identifier corresponding to a known Haskell type. Data+constructors are nested under their corresponding types with two spaces+of indentation.++Identifier              Type    Haskell name          Notes+----------------------------------------------------------------------------+liftedTypeKindTyCon     TyCon   GHC.Types.Type        Synonym for: TYPE LiftedRep+unliftedTypeKindTyCon   TyCon   GHC.Types.Type        Synonym for: TYPE UnliftedRep+liftedRepTyCon          TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Lifted+unliftedRepTyCon        TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Unlifted+levityTyCon             TyCon   GHC.Types.Levity      Data type+  liftedDataConTyCon    TyCon   GHC.Types.Lifted      Data constructor+  unliftedDataConTyCon  TyCon   GHC.Types.Unlifted    Data constructor+vecCountTyCon           TyCon   GHC.Types.VecCount    Data type+  vec2DataConTy         Type    GHC.Types.Vec2        Data constructor+  vec4DataConTy         Type    GHC.Types.Vec4        Data constructor+  vec8DataConTy         Type    GHC.Types.Vec8        Data constructor+  vec16DataConTy        Type    GHC.Types.Vec16       Data constructor+  vec32DataConTy        Type    GHC.Types.Vec32       Data constructor+  vec64DataConTy        Type    GHC.Types.Vec64       Data constructor+runtimeRepTyCon         TyCon   GHC.Types.RuntimeRep  Data type+  boxedRepDataConTyCon  TyCon   GHC.Types.BoxedRep    Data constructor+  intRepDataConTy       Type    GHC.Types.IntRep      Data constructor+  doubleRepDataConTy    Type    GHC.Types.DoubleRep   Data constructor+  floatRepDataConTy     Type    GHC.Types.FloatRep    Data constructor+boolTyCon               TyCon   GHC.Types.Bool        Data type+  trueDataCon           DataCon GHC.Types.True        Data constructor+  falseDataCon          DataCon GHC.Types.False       Data constructor+  promotedTrueDataCon   TyCon   GHC.Types.True        Data constructor+  promotedFalseDataCon  TyCon   GHC.Types.False       Data constructor+ ************************************************************************ *                                                                      * \subsection{Wired in type constructors}@@ -214,8 +269,10 @@  If you change which things are wired in, make sure you change their names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc+ -} + -- This list is used only to define GHC.Builtin.Utils.wiredInThings. That in turn -- is used to initialise the name environment carried around by the renamer. -- This means that if we look up the name of a TyCon (or its implicit binders)@@ -238,6 +295,14 @@                   -- need to look out for them.                   unitTyCon                 , unboxedUnitTyCon++                -- Solo (i.e., the bosed 1-tuple) is also not treated+                -- like other tuples (i.e. we /do/ include it here),+                -- since it does not use special syntax like other tuples+                -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names+                -- have known keys) in GHC.Builtin.Types.+                , soloTyCon+                 , anyTyCon                 , boolTyCon                 , charTyCon@@ -246,23 +311,26 @@                 , floatTyCon                 , intTyCon                 , wordTyCon-                , word8TyCon                 , listTyCon                 , orderingTyCon                 , maybeTyCon                 , heqTyCon                 , eqTyCon                 , coercibleTyCon-                , typeNatKindCon                 , typeSymbolKindCon                 , runtimeRepTyCon+                , levityTyCon                 , vecCountTyCon                 , vecElemTyCon                 , constraintKindTyCon                 , liftedTypeKindTyCon+                , unliftedTypeKindTyCon                 , multiplicityTyCon                 , naturalTyCon                 , integerTyCon+                , liftedRepTyCon+                , unliftedRepTyCon+                , nonEmptyTyCon                 ]  mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name@@ -342,6 +410,10 @@ nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon +nonEmptyTyConName, nonEmptyDataConName :: Name+nonEmptyTyConName   = mkWiredInTyConName   UserSyntax  gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey nonEmptyTyCon+nonEmptyDataConName = mkWiredInDataConName UserSyntax  gHC_BASE (fsLit ":|") nonEmptyDataConKey nonEmptyDataCon+ maybeTyConName, nothingDataConName, justDataConName :: Name maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")                                           maybeTyConKey maybeTyCon@@ -350,10 +422,9 @@ justDataConName    = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")                                           justDataConKey justDataCon -wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name+wordTyConName, wordDataConName, word8DataConName :: Name wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon-word8TyConName     = mkWiredInTyConName   UserSyntax gHC_WORD  (fsLit "Word8")  word8TyConKey    word8TyCon word8DataConName   = mkWiredInDataConName UserSyntax gHC_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon  floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name@@ -474,16 +545,20 @@         -- at (promoted) use-sites of MkT.  -- Kinds-typeNatKindConName, typeSymbolKindConName :: Name-typeNatKindConName    = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Nat")    typeNatKindConNameKey    typeNatKindCon+typeSymbolKindConName :: Name typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon  constraintKindTyConName :: Name constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey   constraintKindTyCon -liftedTypeKindTyConName :: Name+liftedTypeKindTyConName, unliftedTypeKindTyConName :: Name liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type") liftedTypeKindTyConKey liftedTypeKindTyCon+unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon +liftedRepTyConName, unliftedRepTyConName :: Name+liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep") liftedRepTyConKey liftedRepTyCon+unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon+ multiplicityTyConName :: Name multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")                           multiplicityTyConKey multiplicityTyCon@@ -498,18 +573,24 @@  -- reported. Making them built-in make it so that they are always considered in  -- scope. -runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName :: Name+runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon vecRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "VecRep") vecRepDataConKey vecRepDataCon tupleRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon sumRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "SumRep") sumRepDataConKey sumRepDataCon+boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon +levityTyConName, liftedDataConName, unliftedDataConName :: Name+levityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Levity") levityTyConKey levityTyCon+liftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted") liftedDataConKey liftedDataCon+unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon++ -- See Note [Wiring in RuntimeRep] runtimeRepSimpleDataConNames :: [Name] runtimeRepSimpleDataConNames   = zipWith3Lazy mk_special_dc_name-      [ fsLit "LiftedRep", fsLit "UnliftedRep"-      , fsLit "IntRep"+      [ fsLit "IntRep"       , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"       , fsLit "WordRep"       , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", fsLit "Word64Rep"@@ -676,24 +757,23 @@ ************************************************************************ -} -typeNatKindCon, typeSymbolKindCon :: TyCon--- data Nat+typeSymbolKindCon :: TyCon -- data Symbol-typeNatKindCon    = pcTyCon typeNatKindConName    Nothing [] [] typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] [] -typeNatKind, typeSymbolKind :: Kind-typeNatKind    = mkTyConTy typeNatKindCon+typeSymbolKind :: Kind typeSymbolKind = mkTyConTy typeSymbolKindCon  constraintKindTyCon :: TyCon -- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon! constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] [] -liftedTypeKind, typeToTypeKind, constraintKind :: Kind-liftedTypeKind   = tYPE liftedRepTy+-- See Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.+liftedTypeKind, unliftedTypeKind, typeToTypeKind, constraintKind :: Kind+liftedTypeKind   = mkTyConTy liftedTypeKindTyCon+unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon typeToTypeKind   = liftedTypeKind `mkVisFunTyMany` liftedTypeKind-constraintKind   = mkTyConApp constraintKindTyCon []+constraintKind   = mkTyConTy constraintKindTyCon  {- ************************************************************************@@ -721,20 +801,23 @@       but no actual declaration and no info table  * ConstraintTuples-    - Are known-key rather than wired-in. Reason: it's awkward to-      have all the superclass selectors wired-in.+    - A wired-in type.     - Declared as classes in GHC.Classes, e.g.          class (c1,c2) => (c1,c2)     - Given constraints: the superclasses automatically become available     - Wanted constraints: there is a built-in instance          instance (c1,c2) => (c1,c2)-      See GHC.Tc.Solver.Interact.matchCTuple-    - Currently just go up to 62; beyond that+      See GHC.Tc.Instance.Class.matchCTuple+    - Currently just go up to 64; beyond that       you have to use manual nesting     - Their OccNames look like (%,,,%), so they can easily be       distinguished from term tuples.  But (following Haskell) we       pretty-print saturated constraint tuples with round parens;       see BasicTypes.tupleParens.+    - Unlike BoxedTuples and UnboxedTuples, which only wire+      in type constructors and data constructors, ConstraintTuples also wire in+      superclass selector functions. For instance, $p1(%,%) and $p2(%,%) are+      the selectors for the binary constraint tuple.  * In quite a lot of places things are restricted just to   BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish@@ -912,26 +995,26 @@ commas :: Arity -> String commas ar = take (ar-1) (repeat ',') +cTupleTyCon :: Arity -> TyCon+cTupleTyCon i+  | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = fstOf3 (cTupleArr ! i)+ cTupleTyConName :: Arity -> Name-cTupleTyConName arity-  = mkExternalName (mkCTupleTyConUnique arity) gHC_CLASSES-                   (mkCTupleOcc tcName arity) noSrcSpan+cTupleTyConName a = tyConName (cTupleTyCon a)  cTupleTyConNames :: [Name] cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE]) -cTupleTyConNameSet :: NameSet-cTupleTyConNameSet = mkNameSet cTupleTyConNames+cTupleTyConKeys :: UniqSet Unique+cTupleTyConKeys = mkUniqSet $ map getUnique cTupleTyConNames  isCTupleTyConName :: Name -> Bool--- Use Type.isCTupleClass where possible isCTupleTyConName n  = ASSERT2( isExternalName n, ppr n )-   nameModule n == gHC_CLASSES-   && n `elemNameSet` cTupleTyConNameSet+   getUnique n `elementOfUniqSet` cTupleTyConKeys  -- | If the given name is that of a constraint tuple, return its arity.--- Note that this is inefficient. cTupleTyConNameArity_maybe :: Name -> Maybe Arity cTupleTyConNameArity_maybe n   | not (isCTupleTyConName n) = Nothing@@ -941,14 +1024,46 @@     -- case, we have to adjust accordingly our calculated arity.     adjustArity a = if a > 0 then a + 1 else a +cTupleDataCon :: Arity -> DataCon+cTupleDataCon i+  | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = sndOf3 (cTupleArr ! i)+ cTupleDataConName :: Arity -> Name-cTupleDataConName arity-  = mkExternalName (mkCTupleDataConUnique arity) gHC_CLASSES-                   (mkCTupleOcc dataName arity) noSrcSpan+cTupleDataConName i = dataConName (cTupleDataCon i)  cTupleDataConNames :: [Name] cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE]) +cTupleSelId :: ConTag -- Superclass position+            -> Arity  -- Arity+            -> Id+cTupleSelId sc_pos arity+  | sc_pos > arity+  = panic ("cTupleSelId: index out of bounds: superclass position: "+           ++ show sc_pos ++ " > arity " ++ show arity)++  | sc_pos <= 0+  = panic ("cTupleSelId: Superclass positions start from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 2+  = panic ("cTupleSelId: Arity starts from 2. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_CTUPLE_SIZE+  = thdOf3 (mk_ctuple arity) ! (sc_pos - 1)  -- Build one specially++  | otherwise+  = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1)++cTupleSelIdName :: ConTag -- Superclass position+                -> Arity  -- Arity+                -> Name+cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity)+ tupleTyCon :: Boxity -> Arity -> TyCon tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)@@ -970,10 +1085,34 @@ tupleDataConName :: Boxity -> Arity -> Name tupleDataConName sort i = dataConName (tupleDataCon sort i) +mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type+mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]++isPromotedPairType :: Type -> Maybe (Type, Type)+isPromotedPairType t+  | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t+  , tc == promotedTupleDataCon Boxed 2+  = Just (x, y)+  | otherwise = Nothing+ boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon) boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]] unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]] +-- | Cached type constructors, data constructors, and superclass selectors for+-- constraint tuples. The outer array is indexed by the arity of the constraint+-- tuple and the inner array is indexed by the superclass position.+cTupleArr :: Array Int (TyCon, DataCon, Array Int Id)+cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]]+  -- Although GHC does not make use of unary constraint tuples+  -- (see Note [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType),+  -- this array creates one anyway. This is primarily motivated by the fact+  -- that (1) the indices of an Array must be contiguous, and (2) we would like+  -- the index of a constraint tuple in this Array to correspond to its Arity.+  -- We could envision skipping over the unary constraint tuple and having index+  -- 1 correspond to a 2-constraint tuple (and so on), but that's more+  -- complicated than it's worth.+ -- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed -- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type -- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep@@ -1038,6 +1177,45 @@     tc_uniq = mkTupleTyConUnique   boxity arity     dc_uniq = mkTupleDataConUnique boxity arity +mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id)+mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr)+  where+    tycon = mkClassTyCon tc_name binders roles+                         rhs klass+                         (mkPrelTyConRepName tc_name)++    klass     = mk_ctuple_class tycon sc_theta sc_sel_ids+    tuple_con = pcDataConW dc_name tvs (map unrestricted sc_theta) tycon++    binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)+    roles   = replicate arity Nominal+    rhs     = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple}++    modu    = gHC_CLASSES+    tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq+                         (ATyCon tycon) BuiltInSyntax+    dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq+                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_uniq = mkCTupleTyConUnique   arity+    dc_uniq = mkCTupleDataConUnique arity++    tvs            = binderVars binders+    sc_theta       = map mkTyVarTy tvs+    sc_sel_ids     = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]]+    sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids++    mk_sc_sel_id sc_pos =+      let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity+          sc_sel_id_occ  = mkCTupleOcc tcName arity+          sc_sel_id_name = mkWiredInIdName+                             gHC_CLASSES+                             (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ))+                             sc_sel_id_uniq+                             sc_sel_id+          sc_sel_id      = mkDictSelId sc_sel_id_name klass++      in sc_sel_id+ unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 @@ -1050,9 +1228,15 @@ unitDataConId :: Id unitDataConId = dataConWorkId unitDataCon +soloTyCon :: TyCon+soloTyCon = tupleTyCon Boxed 1+ pairTyCon :: TyCon pairTyCon = tupleTyCon Boxed 2 +unboxedUnitTy :: Type+unboxedUnitTy = mkTyConApp unboxedUnitTyCon []+ unboxedUnitTyCon :: TyCon unboxedUnitTyCon = tupleTyCon Unboxed 0 @@ -1243,7 +1427,10 @@   = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]             [] [] (mkAnd []) tycon -+mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class+mk_ctuple_class tycon sc_theta sc_sel_ids+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids+            [] [] (mkAnd []) tycon  {- ********************************************************************* *                                                                      *@@ -1318,17 +1505,57 @@ runtimeRepTy = mkTyConTy runtimeRepTyCon  -- Type synonyms; see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim--- type Type = tYPE 'LiftedRep+-- and Note [Prefer Type over TYPE 'LiftedRep] in GHC.Core.TyCo.Rep.+--+-- @type Type = TYPE ('BoxedRep 'Lifted)@ liftedTypeKindTyCon :: TyCon-liftedTypeKindTyCon   = buildSynTyCon liftedTypeKindTyConName-                                       [] liftedTypeKind []-                                       (tYPE liftedRepTy)+liftedTypeKindTyCon =+    buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs+  where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp liftedRepTyCon []] +-- | @type UnliftedType = TYPE ('BoxedRep 'Unlifted)@+unliftedTypeKindTyCon :: TyCon+unliftedTypeKindTyCon =+    buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs+  where rhs = TyCoRep.TyConApp tYPETyCon [mkTyConApp unliftedRepTyCon []]++-- | @type LiftedRep = 'BoxedRep 'Lifted@+liftedRepTyCon :: TyCon+liftedRepTyCon = buildSynTyCon+  liftedRepTyConName [] runtimeRepTy [] liftedRepTy++-- | @type UnliftedRep = 'BoxedRep 'Unlifted@+unliftedRepTyCon :: TyCon+unliftedRepTyCon = buildSynTyCon+  unliftedRepTyConName [] runtimeRepTy [] unliftedRepTy+ runtimeRepTyCon :: TyCon runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []-                          (vecRepDataCon : tupleRepDataCon :-                           sumRepDataCon : runtimeRepSimpleDataCons)+    (vecRepDataCon : tupleRepDataCon :+     sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons) +levityTyCon :: TyCon+levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]++liftedDataCon, unliftedDataCon :: DataCon+liftedDataCon = pcSpecialDataCon liftedDataConName+    [] levityTyCon LiftedInfo+unliftedDataCon = pcSpecialDataCon unliftedDataConName+    [] levityTyCon UnliftedInfo++boxedRepDataCon :: DataCon+boxedRepDataCon = pcSpecialDataCon boxedRepDataConName+  [ mkTyConTy levityTyCon ] runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in RepType+    prim_rep_fun [lev]+      = case tyConRuntimeRepInfo (tyConAppTyCon lev) of+          LiftedInfo -> [LiftedRep]+          UnliftedInfo -> [UnliftedRep]+          _ -> pprPanic "boxedRepDataCon" (ppr lev)+    prim_rep_fun args+      = pprPanic "boxedRepDataCon" (ppr args)+ vecRepDataCon :: DataCon vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon                                                    , mkTyConTy vecElemTyCon ]@@ -1382,11 +1609,9 @@ -- See Note [Wiring in RuntimeRep] -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType runtimeRepSimpleDataCons :: [DataCon]-liftedRepDataCon :: DataCon-runtimeRepSimpleDataCons@(liftedRepDataCon : _)+runtimeRepSimpleDataCons   = zipWithLazy mk_runtime_rep_dc-    [ LiftedRep, UnliftedRep-    , IntRep+    [ IntRep     , Int8Rep, Int16Rep, Int32Rep, Int64Rep     , WordRep     , Word8Rep, Word16Rep, Word32Rep, Word64Rep@@ -1399,15 +1624,13 @@       = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))  -- See Note [Wiring in RuntimeRep]-liftedRepDataConTy, unliftedRepDataConTy,-  intRepDataConTy,+intRepDataConTy,   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,   wordRepDataConTy,   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,   addrRepDataConTy,   floatRepDataConTy, doubleRepDataConTy :: Type-[liftedRepDataConTy, unliftedRepDataConTy,-   intRepDataConTy,+[intRepDataConTy,    int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,    wordRepDataConTy,    word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,@@ -1459,13 +1682,30 @@   doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)                                 vecElemDataCons -liftedRepDataConTyCon :: TyCon-liftedRepDataConTyCon = promoteDataCon liftedRepDataCon --- The type ('LiftedRep)+liftedDataConTyCon :: TyCon+liftedDataConTyCon = promoteDataCon liftedDataCon++unliftedDataConTyCon :: TyCon+unliftedDataConTyCon = promoteDataCon unliftedDataCon++liftedDataConTy :: Type+liftedDataConTy = mkTyConTy liftedDataConTyCon++unliftedDataConTy :: Type+unliftedDataConTy = mkTyConTy unliftedDataConTyCon++boxedRepDataConTyCon :: TyCon+boxedRepDataConTyCon = promoteDataCon boxedRepDataCon++-- The type ('BoxedRep 'Lifted) liftedRepTy :: Type-liftedRepTy = liftedRepDataConTy+liftedRepTy = mkTyConApp boxedRepDataConTyCon [liftedDataConTy] +-- The type ('BoxedRep 'Unlifted)+unliftedRepTy :: Type+unliftedRepTy = mkTyConApp boxedRepDataConTyCon [unliftedDataConTy]+ {- ********************************************************************* *                                                                      *      The boxed primitive types: Char, Int, etc@@ -1547,7 +1787,7 @@                             (NoSourceText, fsLit "HsWord8"))) []                      [word8DataCon] word8DataCon :: DataCon-word8DataCon = pcDataCon word8DataConName [] [wordPrimTy] word8TyCon+word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon  floatTy :: Type floatTy = mkTyConTy floatTyCon@@ -1684,6 +1924,17 @@ -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy -- gets the over-specific type (Type -> Type) +-- NonEmpty lists (used for 'ProjectionE')+nonEmptyTyCon :: TyCon+nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon]++nonEmptyDataCon :: DataCon+nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -}+                    nonEmptyDataConName+                    alpha_tyvar [] alpha_tyvar+                    (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])+                    nonEmptyTyCon+ -- Wired-in type Maybe  maybeTyCon :: TyCon@@ -1696,6 +1947,20 @@ justDataCon :: DataCon justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon +mkPromotedMaybeTy :: Kind -> Maybe Type -> Type+mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]+mkPromotedMaybeTy k Nothing  = mkTyConApp promotedNothingDataCon [k]++mkMaybeTy :: Type -> Kind+mkMaybeTy t = mkTyConApp maybeTyCon [t]++isPromotedMaybeTy :: Type -> Maybe (Maybe Type)+isPromotedMaybeTy t+  | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x+  | Just (tc,[_])   <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing+  | otherwise = Nothing++ {- ** ********************************************************************* *                                                                      *@@ -1839,8 +2104,6 @@       | otherwise       = pprPanic "extractPromotedList" (ppr tys) -- --------------------------------------- -- ghc-bignum ---------------------------------------@@ -1933,3 +2196,11 @@  naturalNBDataCon :: DataCon naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon+++-- | Replaces constraint tuple names with corresponding boxed ones.+filterCTuple :: RdrName -> RdrName+filterCTuple (Exact n)+  | Just arity <- cTupleTyConNameArity_maybe n+  = Exact $ tupleTyConName BoxedTuple arity+filterCTuple rdr = rdr

GHC/Builtin/Types.hs-boot view

@@ -2,12 +2,14 @@  import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon ) import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind)+import {-# SOURCE #-} GHC.Core.DataCon  ( DataCon ) -import GHC.Types.Basic (Arity, TupleSort)-import GHC.Types.Name (Name)+import GHC.Types.Basic (Arity, TupleSort, Boxity, ConTag)+import {-# SOURCE #-} GHC.Types.Name (Name)  listTyCon :: TyCon-typeNatKind, typeSymbolKind :: Type+typeSymbolKind :: Type+charTy :: Type mkBoxedTupleTy :: [Type] -> Type  coercibleTyCon, heqTyCon :: TyCon@@ -15,17 +17,27 @@ unitTy :: Type  liftedTypeKind :: Kind+unliftedTypeKind :: Kind+ liftedTypeKindTyCon :: TyCon+unliftedTypeKindTyCon :: TyCon +liftedRepTyCon :: TyCon+unliftedRepTyCon :: TyCon+ constraintKind :: Kind -runtimeRepTyCon, vecCountTyCon, vecElemTyCon :: TyCon+runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon :: TyCon runtimeRepTy :: Type -liftedRepDataConTyCon, vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon+boxedRepDataConTyCon :: TyCon+liftedDataConTyCon :: TyCon+vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepDataConTy, unliftedRepDataConTy,-  intRepDataConTy,+liftedRepTy, unliftedRepTy :: Type+liftedDataConTy, unliftedDataConTy :: Type++intRepDataConTy,   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,   wordRepDataConTy,   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,@@ -55,4 +67,18 @@  tupleTyConName :: TupleSort -> Arity -> Name + integerTy, naturalTy :: Type++promotedTupleDataCon :: Boxity -> Arity -> TyCon++tupleDataCon :: Boxity -> Arity -> DataCon+tupleTyCon   :: Boxity -> Arity -> TyCon++cTupleDataCon :: Arity -> DataCon+cTupleDataConName :: Arity -> Name+cTupleTyConName :: Arity -> Name+cTupleSelIdName :: ConTag -> Arity -> Name++sumDataCon :: ConTag -> Arity -> DataCon+sumTyCon :: Arity -> TyCon

GHC/Builtin/Types/Literals.hs view

@@ -11,7 +11,6 @@   , typeNatAddTyCon   , typeNatMulTyCon   , typeNatExpTyCon-  , typeNatLeqTyCon   , typeNatSubTyCon   , typeNatDivTyCon   , typeNatModTyCon@@ -19,6 +18,11 @@   , typeNatCmpTyCon   , typeSymbolCmpTyCon   , typeSymbolAppendTyCon+  , typeCharCmpTyCon+  , typeConsSymbolTyCon+  , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon   ) where  import GHC.Prelude@@ -32,15 +36,17 @@ 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                   ( gHC_TYPELITS+                  , gHC_TYPELITS_INTERNAL                   , gHC_TYPENATS+                  , gHC_TYPENATS_INTERNAL                   , typeNatAddTyFamNameKey                   , typeNatMulTyFamNameKey                   , typeNatExpTyFamNameKey-                  , typeNatLeqTyFamNameKey                   , typeNatSubTyFamNameKey                   , typeNatDivTyFamNameKey                   , typeNatModTyFamNameKey@@ -48,18 +54,22 @@                   , typeNatCmpTyFamNameKey                   , typeSymbolCmpTyFamNameKey                   , typeSymbolAppendFamNameKey+                  , typeCharCmpTyFamNameKey+                  , typeConsSymbolTyFamNameKey+                  , typeUnconsSymbolTyFamNameKey+                  , typeCharToNatTyFamNameKey+                  , typeNatToCharTyFamNameKey                   ) import GHC.Data.FastString-import qualified Data.Map as Map-import Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List  ( isPrefixOf, isSuffixOf )+import qualified Data.Char as Char  {- Note [Type-level literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~-There are currently two forms of type-level literals: natural numbers, and-symbols (even though this module is named GHC.Builtin.Types.Literals, it covers both).+There are currently three forms of type-level literals: natural numbers, symbols, and+characters.  Type-level literals are supported by CoAxiomRules (conditional axioms), which power the built-in type families (see Note [Adding built-in type families]).@@ -140,7 +150,6 @@   [ typeNatAddTyCon   , typeNatMulTyCon   , typeNatExpTyCon-  , typeNatLeqTyCon   , typeNatSubTyCon   , typeNatDivTyCon   , typeNatModTyCon@@ -148,6 +157,11 @@   , typeNatCmpTyCon   , typeSymbolCmpTyCon   , typeSymbolAppendTyCon+  , typeCharCmpTyCon+  , typeConsSymbolTyCon+  , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon   ]  typeNatAddTyCon :: TyCon@@ -205,10 +219,6 @@   name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")             typeNatModTyFamNameKey typeNatModTyCon ---- typeNatExpTyCon :: TyCon typeNatExpTyCon = mkTypeNatFunTyCon2 name   BuiltInSynFamily@@ -233,29 +243,10 @@   -typeNatLeqTyCon :: TyCon-typeNatLeqTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])-    boolTy-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective--  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?")-                typeNatLeqTyFamNameKey typeNatLeqTyCon-  ops = BuiltInSynFamily-    { sfMatchFam      = matchFamLeq-    , sfInteractTop   = interactTopLeq-    , sfInteractInert = interactInertLeq-    }- typeNatCmpTyCon :: TyCon typeNatCmpTyCon =   mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])     orderingKind     Nothing     (BuiltInSynFamTyCon ops)@@ -263,7 +254,7 @@     NotInjective    where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat")+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS_INTERNAL (fsLit "CmpNat")                 typeNatCmpTyFamNameKey typeNatCmpTyCon   ops = BuiltInSynFamily     { sfMatchFam      = matchFamCmpNat@@ -282,7 +273,7 @@     NotInjective    where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol")+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpSymbol")                 typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon   ops = BuiltInSynFamily     { sfMatchFam      = matchFamCmpSymbol@@ -301,26 +292,96 @@   name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")                 typeSymbolAppendFamNameKey typeSymbolAppendTyCon +typeConsSymbolTyCon :: TyCon+typeConsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True, True])+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "ConsSymbol")+                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamConsSymbol+      , sfInteractTop   = interactTopConsSymbol+      , sfInteractInert = interactInertConsSymbol+      } +typeUnconsSymbolTyCon :: TyCon+typeUnconsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeSymbolKind ])+    (mkMaybeTy charSymbolPairKind)+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "UnconsSymbol")+                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamUnconsSymbol+      , sfInteractTop   = interactTopUnconsSymbol+      , sfInteractInert = interactInertUnconsSymbol+      } +typeCharToNatTyCon :: TyCon+typeCharToNatTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CharToNat")+                  typeCharToNatTyFamNameKey typeCharToNatTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamCharToNat+      , sfInteractTop   = interactTopCharToNat+      , sfInteractInert = \_ _ _ _ -> []+      }+++typeNatToCharTyCon :: TyCon+typeNatToCharTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ naturalTy ])+    charTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "NatToChar")+                  typeNatToCharTyFamNameKey typeNatToCharTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamNatToChar+      , sfInteractTop   = interactTopNatToChar+      , sfInteractInert = \_ _ _ _ -> []+      }+ -- Make a unary built-in constructor of kind: Nat -> Nat mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon1 op tcb =   mkFamilyTyCon op-    (mkTemplateAnonTyConBinders [ typeNatKind ])-    typeNatKind+    (mkTemplateAnonTyConBinders [ naturalTy ])+    naturalTy     Nothing     (BuiltInSynFamTyCon tcb)     Nothing     NotInjective - -- Make a binary built-in constructor of kind: Nat -> Nat -> Nat mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon mkTypeNatFunTyCon2 op tcb =   mkFamilyTyCon op-    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])-    typeNatKind+    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+    naturalTy     Nothing     (BuiltInSynFamTyCon tcb)     Nothing@@ -337,7 +398,6 @@     Nothing     NotInjective - {------------------------------------------------------------------------------- Built-in rules axioms -------------------------------------------------------------------------------}@@ -348,10 +408,13 @@ axAddDef   , axMulDef   , axExpDef-  , axLeqDef   , axCmpNatDef   , axCmpSymbolDef   , axAppendSymbolDef+  , axConsSymbolDef+  , axUnconsSymbolDef+  , axCharToNatDef+  , axNatToCharDef   , axAdd0L   , axAdd0R   , axMul0L@@ -361,10 +424,8 @@   , axExp1L   , axExp0R   , axExp1R-  , axLeqRefl   , axCmpNatRefl   , axCmpSymbolRefl-  , axLeq0L   , axSubDef   , axSub0R   , axAppendSymbol0R@@ -376,19 +437,16 @@   , axLogDef   :: CoAxiomRule -axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $+axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon isNumLitTy isNumLitTy $               \x y -> Just $ num (x + y) -axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $+axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon isNumLitTy isNumLitTy $               \x y -> Just $ num (x * y) -axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $+axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $               \x y -> Just $ num (x ^ y) -axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $-              \x y -> Just $ bool (x <= y)--axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon+axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy               $ \x y -> Just $ ordering (compare x y)  axCmpSymbolDef =@@ -401,7 +459,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"@@ -415,18 +473,35 @@            return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)     } -axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $+axConsSymbolDef =+  mkBinAxiom "ConsSymbolDef" typeConsSymbolTyCon isCharLitTy isStrLitTy $+    \c str -> Just $ mkStrLitTy (consFS c str)++axUnconsSymbolDef =+  mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $+    \str -> Just $+      mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str))++axCharToNatDef =+  mkUnAxiom "CharToNatDef" typeCharToNatTyCon isCharLitTy $+    \c -> Just $ num (charToInteger c)++axNatToCharDef =+  mkUnAxiom "NatToCharDef" typeNatToCharTyCon isNumLitTy $+    \n -> fmap mkCharLitTy (integerToChar n)++axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $               \x y -> fmap num (minus x y) -axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $+axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon isNumLitTy isNumLitTy $               \x y -> do guard (y /= 0)                          return (num (div x y)) -axModDef = mkBinAxiom "ModDef" typeNatModTyCon $+axModDef = mkBinAxiom "ModDef" typeNatModTyCon isNumLitTy isNumLitTy $               \x y -> do guard (y /= 0)                          return (num (mod x y)) -axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $+axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon isNumLitTy $               \x -> do (a,_) <- genLog x 2                        return (num a) @@ -443,12 +518,10 @@ axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1 axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1 axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t-axLeqRefl   = mkAxiom1 "LeqRefl"  $ \(Pair s _) -> (s <== s) === bool True axCmpNatRefl    = mkAxiom1 "CmpNatRefl"                 $ \(Pair s _) -> (cmpNat s s) === ordering EQ axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"                 $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ-axLeq0L     = mkAxiom1 "Leq0L"    $ \(Pair s _) -> (num 0 <== s) === bool True axAppendSymbol0R  = mkAxiom1 "Concat0R"             $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t axAppendSymbol0L  = mkAxiom1 "Concat0L"@@ -457,15 +530,19 @@ -- 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-  , axLeqDef   , axCmpNatDef   , axCmpSymbolDef+  , axCmpCharDef   , axAppendSymbolDef+  , axConsSymbolDef+  , axUnconsSymbolDef+  , axCharToNatDef+  , axNatToCharDef   , axAdd0L   , axAdd0R   , axMul0L@@ -475,10 +552,9 @@   , axExp1L   , axExp0R   , axExp1R-  , axLeqRefl   , axCmpNatRefl   , axCmpSymbolRefl-  , axLeq0L+  , axCmpCharRefl   , axSubDef   , axSub0R   , axAppendSymbol0R@@ -514,9 +590,6 @@ (.^.) :: Type -> Type -> Type s .^. t = mkTyConApp typeNatExpTyCon [s,t] -(<==) :: Type -> Type -> Type-s <== t = mkTyConApp typeNatLeqTyCon [s,t]- cmpNat :: Type -> Type -> Type cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t] @@ -532,17 +605,11 @@ num :: Integer -> Type num = mkNumLitTy -bool :: Bool -> Type-bool b = if b then mkTyConApp promotedTrueDataCon []-              else mkTyConApp promotedFalseDataCon []+charSymbolPair :: Type -> Type -> Type+charSymbolPair = mkPromotedPairTy charTy typeSymbolKind -isBoolLitTy :: Type -> Maybe Bool-isBoolLitTy tc =-  do (tc,[]) <- splitTyConApp_maybe tc-     case () of-       _ | tc == promotedFalseDataCon -> return False-         | tc == promotedTrueDataCon  -> return True-         | otherwise                   -> Nothing+charSymbolPairKind :: Kind+charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind]  orderingKind :: Kind orderingKind = mkTyConApp orderingTyCon []@@ -568,40 +635,37 @@               Just a  -> p a               Nothing -> False --mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule-mkUnAxiom str tc f =+mkUnAxiom :: String -> TyCon -> (Type -> Maybe a) -> (a -> Maybe Type) -> CoAxiomRule+mkUnAxiom str tc isReqTy f =   CoAxiomRule     { coaxrName      = fsLit str     , coaxrAsmpRoles = [Nominal]     , coaxrRole      = Nominal     , coaxrProves    = \cs ->         do [Pair s1 s2] <- return cs-           s2' <- isNumLitTy s2+           s2' <- isReqTy s2            z   <- f s2'            return (mkTyConApp tc [s1] === z)     } -- -- For the definitional axioms mkBinAxiom :: String -> TyCon ->-              (Integer -> Integer -> Maybe Type) -> CoAxiomRule-mkBinAxiom str tc f =+              (Type -> Maybe a) ->+              (Type -> Maybe b) ->+              (a -> b -> Maybe Type) -> CoAxiomRule+mkBinAxiom str tc isReqTy1 isReqTy2 f =   CoAxiomRule     { coaxrName      = fsLit str     , coaxrAsmpRoles = [Nominal, Nominal]     , coaxrRole      = Nominal     , coaxrProves    = \cs ->         do [Pair s1 s2, Pair t1 t2] <- return cs-           s2' <- isNumLitTy s2-           t2' <- isNumLitTy t2+           s2' <- isReqTy1 s2+           t2' <- isReqTy2 t2            z   <- f s2' t2'            return (mkTyConApp tc [s1,t1] === z)     } -- mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule mkAxiom1 str f =   CoAxiomRule@@ -664,8 +728,6 @@         mbY = isNumLitTy t matchFamMod _ = Nothing -- matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamExp [s,t]   | Just 0 <- mbY = Just (axExp0R, [s], num 1)@@ -684,16 +746,6 @@ matchFamLog _ = Nothing  -matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamLeq [s,t]-  | Just 0 <- mbX = Just (axLeq0L, [t], bool True)-  | Just x <- mbX, Just y <- mbY =-    Just (axLeqDef, [s,t], bool (x <= y))-  | tcEqType s t  = Just (axLeqRefl, [s], bool True)-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamLeq _ = Nothing- matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type) matchFamCmpNat [s,t]   | Just x <- mbX, Just y <- mbY =@@ -706,7 +758,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@@ -723,6 +775,50 @@   mbY = isStrLitTy t matchFamAppendSymbol _ = Nothing +matchFamConsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamConsSymbol [s,t]+  | Just x <- mbX, Just y <- mbY =+    Just (axConsSymbolDef, [s,t], mkStrLitTy (consFS x y))+  where+  mbX = isCharLitTy s+  mbY = isStrLitTy t+matchFamConsSymbol _ = Nothing++reifyCharSymbolPairTy :: (Char, FastString) -> Type+reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)++matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamUnconsSymbol [s]+  | Just x <- mbX =+    Just (axUnconsSymbolDef, [s]+         , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS x)))+  where+  mbX = isStrLitTy s+matchFamUnconsSymbol _ = Nothing++matchFamCharToNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCharToNat [c]+  | Just c' <- isCharLitTy c, n <- charToInteger c'+  = Just (axCharToNatDef, [c], mkNumLitTy n)+  | otherwise = Nothing+matchFamCharToNat _ = Nothing++matchFamNatToChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamNatToChar [n]+  | Just n' <- isNumLitTy n, Just c <- integerToChar n'+  = Just (axNatToCharDef, [n], mkCharLitTy c)+  | otherwise = Nothing+matchFamNatToChar _ = Nothing++charToInteger :: Char -> Integer+charToInteger c = fromIntegral (Char.ord c)++integerToChar :: Integer -> Maybe Char+integerToChar n | inBounds = Just (Char.chr (fromInteger n))+  where inBounds = n >= charToInteger minBound &&+                   n <= charToInteger maxBound+integerToChar _ = Nothing+ {------------------------------------------------------------------------------- Interact with axioms -------------------------------------------------------------------------------}@@ -813,14 +909,6 @@   -interactTopLeq :: [Xi] -> Xi -> [Pair Type]-interactTopLeq [s,t] r-  | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)-  where-  mbY = isNumLitTy t-  mbZ = isBoolLitTy r-interactTopLeq _ _ = []- interactTopCmpNat :: [Xi] -> Xi -> [Pair Type] interactTopCmpNat [s,t] r   | Just EQ <- isOrderingLitTy r = [ s === t ]@@ -852,6 +940,47 @@  interactTopAppendSymbol _ _ = [] +interactTopConsSymbol :: [Xi] -> Xi -> [Pair Type]+interactTopConsSymbol [s,t] r+  -- ConsSymbol a b ~ "blah" => (a ~ 'b', b ~ "lah")+  | Just fs <- isStrLitTy r+  , Just (x, xs) <- unconsFS fs =+    [ s === mkCharLitTy x, t === mkStrLitTy xs ]++interactTopConsSymbol _ _ = []++interactTopUnconsSymbol :: [Xi] -> Xi -> [Pair Type]+interactTopUnconsSymbol [s] r+  -- (UnconsSymbol b ~ Nothing) => (b ~ "")+  | Just Nothing <- mbX =+    [ s === mkStrLitTy nilFS ]+  -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")+  | Just (Just r) <- mbX+  , Just (c, str) <- isPromotedPairType r+  , Just chr <- isCharLitTy c+  , Just str1 <- isStrLitTy str =+    [ s === (mkStrLitTy $ consFS chr str1) ]++  where+  mbX = isPromotedMaybeTy r++interactTopUnconsSymbol _ _ = []++interactTopCharToNat :: [Xi] -> Xi -> [Pair Type]+interactTopCharToNat [s] r+  -- (CharToNat c ~ 122) => (c ~ 'z')+  | Just n <- isNumLitTy r+  , Just c <- integerToChar n+  = [ s === mkCharLitTy c ]+interactTopCharToNat _ _ = []++interactTopNatToChar :: [Xi] -> Xi -> [Pair Type]+interactTopNatToChar [s] r+  -- (NatToChar n ~ 'z') => (n ~ 122)+  | Just c <- isCharLitTy r+  = [ s === mkNumLitTy (charToInteger c) ]+interactTopNatToChar _ _ = []+ {------------------------------------------------------------------------------- Interaction with inerts -------------------------------------------------------------------------------}@@ -896,18 +1025,6 @@ interactInertLog _ _ _ _ = []  -interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertLeq [x1,y1] z1 [x2,y2] z2-  | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ]-  | bothTrue && tcEqType y1 x2                 = [ (x1 <== y2) === bool True ]-  | bothTrue && tcEqType y2 x1                 = [ (x2 <== y1) === bool True ]-  where bothTrue = isJust $ do True <- isBoolLitTy z1-                               True <- isBoolLitTy z2-                               return ()--interactInertLeq _ _ _ _ = []-- interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type] interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2   | sameZ && tcEqType x1 x2         = [ y1 === y2 ]@@ -916,7 +1033,18 @@ interactInertAppendSymbol _ _ _ _ = []  +interactInertConsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertConsSymbol [x1, y1] z1 [x2, y2] z2+  | sameZ         = [ x1 === x2, y1 === y2 ]+  where sameZ = tcEqType z1 z2+interactInertConsSymbol _ _ _ _ = [] +interactInertUnconsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertUnconsSymbol [x1] z1 [x2] z2+  | tcEqType z1 z2 = [ x1 === x2 ]+interactInertUnconsSymbol _ _ _ _ = []++ {- ----------------------------------------------------------------------------- These inverse functions are used for simplifying propositions using concrete natural numbers.@@ -989,3 +1117,47 @@   underLoop s i     | i < base  = s     | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)++-----------------------------------------------------------------------------++typeCharCmpTyCon :: TyCon+typeCharCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, charTy ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpChar")+                  typeCharCmpTyFamNameKey typeCharCmpTyCon+  ops = BuiltInSynFamily+      { sfMatchFam      = matchFamCmpChar+      , sfInteractTop   = interactTopCmpChar+      , sfInteractInert = \_ _ _ _ -> []+      }++interactTopCmpChar :: [Xi] -> Xi -> [Pair Type]+interactTopCmpChar [s,t] r+  | Just EQ <- isOrderingLitTy r = [ s === t ]+interactTopCmpChar _ _ = []++cmpChar :: Type -> Type -> Type+cmpChar s t = mkTyConApp typeCharCmpTyCon [s,t]++axCmpCharDef, axCmpCharRefl :: CoAxiomRule+axCmpCharDef =+  mkBinAxiom "CmpCharDef" typeCharCmpTyCon isCharLitTy isCharLitTy $+    \chr1 chr2 -> Just $ ordering $ compare chr1 chr2+axCmpCharRefl = mkAxiom1 "CmpCharRefl"+  $ \(Pair s _) -> (cmpChar s s) === ordering EQ++matchFamCmpChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCmpChar [s,t]+  | Just x <- mbX, Just y <- mbY =+    Just (axCmpCharDef, [s,t], ordering (compare x y))+  | tcEqType s t = Just (axCmpCharRefl, [s], ordering EQ)+  where mbX = isCharLitTy s+        mbY = isCharLitTy t+matchFamCmpChar _ = Nothing

GHC/Builtin/Types/Prim.hs view

@@ -23,11 +23,14 @@         alphaTys, alphaTy, betaTy, gammaTy, deltaTy,         alphaTyVarsUnliftedRep, alphaTyVarUnliftedRep,         alphaTysUnliftedRep, alphaTyUnliftedRep,-        runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep1Ty, runtimeRep2Ty,-        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar,+        runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar,+        runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty, -        multiplicityTyVar,+        openAlphaTyVar, openBetaTyVar, openGammaTyVar,+        openAlphaTy, openBetaTy, openGammaTy, +        multiplicityTyVar1, multiplicityTyVar2,+         -- Kind constructors...         tYPETyCon, tYPETyConName, @@ -45,7 +48,6 @@         floatPrimTyCon,         floatPrimTy, floatPrimTyConName,         doublePrimTyCon,        doublePrimTy, doublePrimTyConName, -        voidPrimTyCon,          voidPrimTy,         statePrimTyCon,         mkStatePrimTy,         realWorldTyCon,         realWorldTy, realWorldStatePrimTy, @@ -99,7 +101,7 @@ import {-# SOURCE #-} GHC.Builtin.Types   ( runtimeRepTy, unboxedTupleKind, liftedTypeKind   , vecRepDataConTyCon, tupleRepDataConTyCon-  , liftedRepDataConTy, unliftedRepDataConTy+  , liftedRepTy, unliftedRepTy   , intRepDataConTy   , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy   , wordRepDataConTy@@ -116,14 +118,18 @@  import GHC.Types.Var    ( TyVar, mkTyVar ) import GHC.Types.Name+import {-# SOURCE #-} GHC.Types.TyThing import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Builtin.Names import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid                          -- import loops which show up if you import Type instead+import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, tYPE )  import Data.Char @@ -180,7 +186,6 @@     , stableNamePrimTyCon     , compactPrimTyCon     , statePrimTyCon-    , voidPrimTyCon     , proxyPrimTyCon     , threadIdPrimTyCon     , wordPrimTyCon@@ -190,6 +195,7 @@     , word64PrimTyCon      , tYPETyCon+    , funTyCon  #include "primop-vector-tycons.hs-incl"     ]@@ -198,18 +204,18 @@ mkPrimTc fs unique tycon   = mkWiredInName gHC_PRIM (mkTcOccFS fs)                   unique-                  (ATyCon tycon)        -- Relevant TyCon+                  (mkATyCon tycon)        -- Relevant TyCon                   UserSyntax  mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name mkBuiltInPrimTc fs unique tycon   = mkWiredInName gHC_PRIM (mkTcOccFS fs)                   unique-                  (ATyCon tycon)        -- Relevant TyCon+                  (mkATyCon tycon)        -- Relevant TyCon                   BuiltInSyntax  -charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName, voidPrimTyConName :: Name+charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, proxyPrimTyConName, realWorldTyConName, arrayPrimTyConName, arrayArrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutableArrayArrayPrimTyConName, smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName :: Name charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon@@ -225,7 +231,6 @@ floatPrimTyConName            = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon doublePrimTyConName           = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon-voidPrimTyConName             = mkPrimTc (fsLit "Void#") voidPrimTyConKey voidPrimTyCon proxyPrimTyConName            = mkPrimTc (fsLit "Proxy#") proxyPrimTyConKey proxyPrimTyCon eqPrimTyConName               = mkPrimTc (fsLit "~#") eqPrimTyConKey eqPrimTyCon eqReprPrimTyConName           = mkBuiltInPrimTc (fsLit "~R#") eqReprPrimTyConKey eqReprPrimTyCon@@ -363,7 +368,7 @@ (alphaTy:betaTy:gammaTy:deltaTy:_) = alphaTys  alphaTyVarsUnliftedRep :: [TyVar]-alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepDataConTy)+alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat (tYPE unliftedRepTy)  alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep@@ -373,27 +378,32 @@ alphaTyUnliftedRep :: Type (alphaTyUnliftedRep:_) = alphaTysUnliftedRep -runtimeRep1TyVar, runtimeRep2TyVar :: TyVar-(runtimeRep1TyVar : runtimeRep2TyVar : _)+runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar :: TyVar+(runtimeRep1TyVar : runtimeRep2TyVar : runtimeRep3TyVar : _)   = drop 16 (mkTemplateTyVars (repeat runtimeRepTy))  -- selects 'q','r' -runtimeRep1Ty, runtimeRep2Ty :: Type+runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar+runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar -openAlphaTyVar, openBetaTyVar :: TyVar+openAlphaTyVar, openBetaTyVar, openGammaTyVar :: TyVar -- alpha :: TYPE r1 -- beta  :: TYPE r2-[openAlphaTyVar,openBetaTyVar]-  = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty]+-- gamma :: TYPE r3+[openAlphaTyVar,openBetaTyVar,openGammaTyVar]+  = mkTemplateTyVars [tYPE runtimeRep1Ty, tYPE runtimeRep2Ty, tYPE runtimeRep3Ty] -openAlphaTy, openBetaTy :: Type+openAlphaTy, openBetaTy, openGammaTy :: Type openAlphaTy = mkTyVarTy openAlphaTyVar openBetaTy  = mkTyVarTy openBetaTyVar+openGammaTy = mkTyVarTy openGammaTyVar -multiplicityTyVar :: TyVar-multiplicityTyVar = mkTemplateTyVars (repeat multiplicityTy) !! 13  -- selects 'n'+multiplicityTyVar1, multiplicityTyVar2  :: TyVar+(multiplicityTyVar1 : multiplicityTyVar2 : _)+   = drop 13 (mkTemplateTyVars (repeat multiplicityTy))  -- selects 'n', 'm' + {- ************************************************************************ *                                                                      *@@ -408,8 +418,9 @@ -- | The @FUN@ type constructor. -- -- @--- FUN :: forall {m :: Multiplicity} {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.---         TYPE rep1 -> TYPE rep2 -> *+-- FUN :: forall (m :: Multiplicity) ->+--        forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}.+--        TYPE rep1 -> TYPE rep2 -> * -- @ -- -- The runtime representations quantification is left inferred. This@@ -422,14 +433,14 @@ -- @ -- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep). --             TYPE rep1 -> TYPE rep2 -> Type--- type Arr = FUN+-- type Arr = FUN 'Many -- @ -- funTyCon :: TyCon funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm   where     -- See also unrestrictedFunTyCon-    tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar+    tc_bndrs = [ mkNamedTyConBinder Required multiplicityTyVar1                , mkNamedTyConBinder Inferred runtimeRep1TyVar                , mkNamedTyConBinder Inferred runtimeRep2TyVar ]                ++ mkTemplateAnonTyConBinders [ tYPE runtimeRep1Ty@@ -449,26 +460,28 @@ All types that classify values have a kind of the form (TYPE rr), where      data RuntimeRep     -- Defined in ghc-prim:GHC.Types-      = LiftedRep-      | UnliftedRep+      = BoxedRep Levity       | IntRep       | FloatRep       .. etc .. +    data Levity = Lifted | Unlifted+     rr :: RuntimeRep      TYPE :: RuntimeRep -> TYPE 'LiftedRep  -- Built in  So for example:-    Int        :: TYPE 'LiftedRep-    Array# Int :: TYPE 'UnliftedRep+    Int        :: TYPE ('BoxedRep 'Lifted)+    Array# Int :: TYPE ('BoxedRep 'Unlifted)     Int#       :: TYPE 'IntRep     Float#     :: TYPE 'FloatRep-    Maybe      :: TYPE 'LiftedRep -> TYPE 'LiftedRep+    Maybe      :: TYPE ('BoxedRep 'Lifted) -> TYPE ('BoxedRep 'Lifted)     (# , #)    :: TYPE r1 -> TYPE r2 -> TYPE (TupleRep [r1, r2])  We abbreviate '*' specially:-    type * = TYPE 'LiftedRep+    type LiftedRep = 'BoxedRep 'Lifted+    type * = TYPE LiftedRep  The 'rr' parameter tells us how the value is represented at runtime. @@ -501,7 +514,7 @@ Note [PrimRep and kindPrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As part of its source code, in GHC.Core.TyCon, GHC has-  data PrimRep = LiftedRep | UnliftedRep | IntRep | FloatRep | ...etc...+  data PrimRep = BoxedRep Levity | IntRep | FloatRep | ...etc...  Notice that  * RuntimeRep is part of the syntax tree of the program being compiled@@ -546,13 +559,9 @@  mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name mkPrimTcName built_in_syntax occ key tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (ATyCon tycon) built_in_syntax+  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax  -------------------------------- | Given a RuntimeRep, applies TYPE to it.--- see Note [TYPE and RuntimeRep]-tYPE :: Type -> Type-tYPE rr = TyConApp tYPETyCon [rr]  -- Given a Multiplicity, applies FUN to it. functionWithMultiplicity :: Type -> Type@@ -579,8 +588,8 @@ primRepToRuntimeRep :: PrimRep -> Type primRepToRuntimeRep rep = case rep of   VoidRep       -> TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]-  LiftedRep     -> liftedRepDataConTy-  UnliftedRep   -> unliftedRepDataConTy+  LiftedRep     -> liftedRepTy+  UnliftedRep   -> unliftedRepTy   IntRep        -> intRepDataConTy   Int8Rep       -> int8RepDataConTy   Int16Rep      -> int16RepDataConTy@@ -896,12 +905,6 @@ -- Note: the ``state-pairing'' types are not truly primitive, -- so they are defined in \tr{GHC.Builtin.Types}, not here. --voidPrimTy :: Type-voidPrimTy = TyConApp voidPrimTyCon []--voidPrimTyCon :: TyCon-voidPrimTyCon    = pcPrimTyCon voidPrimTyConName [] VoidRep  mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]

+ GHC/Builtin/Types/Prim.hs-boot view

@@ -0,0 +1,5 @@+module GHC.Builtin.Types.Prim where++import GHC.Core.TyCon++tYPETyCon :: TyCon

GHC/Builtin/Uniques.hs view

@@ -22,23 +22,52 @@       -- *** Constraint     , mkCTupleTyConUnique     , mkCTupleDataConUnique+    , mkCTupleSelIdUnique++      -- ** Making built-in uniques+    , mkAlphaTyVarUnique+    , mkPrimOpIdUnique, mkPrimOpWrapperUnique+    , mkPreludeMiscIdUnique, mkPreludeDataConUnique+    , mkPreludeTyConUnique, mkPreludeClassUnique+    , mkCoVarUnique++    , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique+    , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique+    , mkCostCentreUnique++    , mkBuiltinUnique+    , mkPseudoUniqueD+    , mkPseudoUniqueE+    , mkPseudoUniqueH++      -- ** Deriving uniquesc+      -- *** From TyCon name uniques+    , tyConRepNameUnique+      -- *** From DataCon name uniques+    , dataConWorkerUnique, dataConTyRepNameUnique++    , initTyVarUnique+    , initExitJoinUnique+     ) where  #include "HsVersions.h"  import GHC.Prelude -import GHC.Builtin.Types-import GHC.Core.TyCon-import GHC.Core.DataCon-import GHC.Types.Id+import {-# SOURCE #-} GHC.Builtin.Types+import {-# SOURCE #-} GHC.Core.TyCon+import {-# SOURCE #-} GHC.Core.DataCon+import {-# SOURCE #-} GHC.Types.Id+import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic-import GHC.Utils.Outputable import GHC.Types.Unique-import GHC.Types.Name+import GHC.Data.FastString++import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic -import Data.Bits import Data.Maybe  -- | Get the 'Name' associated with a known-key 'Unique'.@@ -50,35 +79,38 @@       '5' -> Just $ getTupleTyConName Unboxed n       '7' -> Just $ getTupleDataConName Boxed n       '8' -> Just $ getTupleDataConName Unboxed n+      'j' -> Just $ getCTupleSelIdName n       'k' -> Just $ getCTupleTyConName n-      'm' -> Just $ getCTupleDataConUnique n+      'm' -> Just $ getCTupleDataConName n       _   -> Nothing   where     (tag, n) = unpkUnique u ------------------------------------------------------ Anonymous sums------ Sum arities start from 2. The encoding is a bit funny: we break up the--- integral part into bitfields for the arity, an alternative index (which is--- taken to be 0xff in the case of the TyCon), and, in the case of a datacon, a--- tag (used to identify the sum's TypeRep binding).------ This layout is chosen to remain compatible with the usual unique allocation--- for wired-in data constructors described in GHC.Types.Unique------ TyCon for sum of arity k:---   00000000 kkkkkkkk 11111100+{-+Note [Unique layout for unboxed sums]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- TypeRep of TyCon for sum of arity k:---   00000000 kkkkkkkk 11111101------ DataCon for sum of arity k and alternative n (zero-based):---   00000000 kkkkkkkk nnnnnn00------ TypeRep for sum DataCon of arity k and alternative n (zero-based):---   00000000 kkkkkkkk nnnnnn10+Sum arities start from 2. The encoding is a bit funny: we break up the+integral part into bitfields for the arity, an alternative index (which is+taken to be 0xfc in the case of the TyCon), and, in the case of a datacon, a+tag (used to identify the sum's TypeRep binding). +This layout is chosen to remain compatible with the usual unique allocation+for wired-in data constructors described in GHC.Types.Unique++TyCon for sum of arity k:+  00000000 kkkkkkkk 11111100++TypeRep of TyCon for sum of arity k:+  00000000 kkkkkkkk 11111101++DataCon for sum of arity k and alternative n (zero-based):+  00000000 kkkkkkkk nnnnnn00++TypeRep for sum DataCon of arity k and alternative n (zero-based):+  00000000 kkkkkkkk nnnnnn10+-}+ mkSumTyConUnique :: Arity -> Unique mkSumTyConUnique arity =     ASSERT(arity < 0x3f) -- 0x3f since we only have 6 bits to encode the@@ -127,15 +159,70 @@ --    * u+1: its worker Id --    * u+2: the TyConRepName of the promoted TyCon ------------------------------------------------------ Constraint tuples+{-+Note [Unique layout for constraint tuple selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constraint tuples, like boxed and unboxed tuples, have their type and data+constructor Uniques wired in (see+Note [Uniques for tuple type and data constructors]). Constraint tuples are+somewhat more involved, however. For a boxed or unboxed n-tuple, we need:++* A Unique for the type constructor, and+* A Unique for the data constructor++With a constraint n-tuple, however, we need:++* A Unique for the type constructor,+* A Unique for the data constructor, and+* A Unique for each of the n superclass selectors++To pick a concrete example (n = 2), the binary constraint tuple has a type+constructor and data constructor (%,%) along with superclass selectors+$p1(%,%) and $p2(%,%).++Just as we wire in the Uniques for constraint tuple type constructors and data+constructors, we wish to wire in the Uniques for the superclass selectors as+well. Not only does this make everything consistent, it also avoids a+compile-time performance penalty whenever GHC.Classes is loaded from an+interface file. This is because GHC.Classes defines constraint tuples as class+definitions, and if these classes weren't wired in, then loading GHC.Classes+would also load every single constraint tuple type constructor, data+constructor, and superclass selector. See #18635.++We encode the Uniques for constraint tuple superclass selectors as follows. The+integral part of the Unique is broken up into bitfields for the arity and the+position of the superclass. Given a selector for a constraint tuple with+arity n (zero-based) and position k (where 1 <= k <= n), its Unique will look+like:++  00000000 nnnnnnnn kkkkkkkk++We can use bit-twiddling tricks to access the arity and position with+cTupleSelIdArityBits and cTupleSelIdPosBitmask, respectively.++This pattern bears a certain resemblance to the way that the Uniques for+unboxed sums are encoded. This is because for a unboxed sum of arity n, there+are n corresponding data constructors, each with an alternative position k.+Similarly, for a constraint tuple of arity n, there are n corresponding+superclass selectors. Reading Note [Unique layout for unboxed sums] will+instill an appreciation for how the encoding for constraint tuple superclass+selector Uniques takes inspiration from the encoding for unboxed sum Uniques.+-}+ mkCTupleTyConUnique :: Arity -> Unique mkCTupleTyConUnique a = mkUnique 'k' (2*a)  mkCTupleDataConUnique :: Arity -> Unique mkCTupleDataConUnique a = mkUnique 'm' (3*a) +mkCTupleSelIdUnique :: ConTagZ -> Arity -> Unique+mkCTupleSelIdUnique sc_pos arity+  | sc_pos >= arity+  = panic ("mkCTupleSelIdUnique: " ++ show sc_pos ++ " >= " ++ show arity)+  | otherwise+  = mkUnique 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)+ getCTupleTyConName :: Int -> Name getCTupleTyConName n =     case n `divMod` 2 of@@ -143,14 +230,36 @@       (arity, 1) -> mkPrelTyConRepName $ cTupleTyConName arity       _          -> panic "getCTupleTyConName: impossible" -getCTupleDataConUnique :: Int -> Name-getCTupleDataConUnique n =+getCTupleDataConName :: Int -> Name+getCTupleDataConName n =     case n `divMod` 3 of       (arity,  0) -> cTupleDataConName arity-      (_arity, 1) -> panic "getCTupleDataConName: no worker"+      (arity,  1) -> getName $ dataConWrapId $ cTupleDataCon arity       (arity,  2) -> mkPrelTyConRepName $ cTupleDataConName arity       _           -> panic "getCTupleDataConName: impossible" +getCTupleSelIdName :: Int -> Name+getCTupleSelIdName n = cTupleSelIdName (sc_pos + 1) arity+  where+    arity  = n `shiftR` cTupleSelIdArityBits+    sc_pos = n .&. cTupleSelIdPosBitmask++-- Given the arity of a constraint tuple, this is the number of bits by which+-- one must shift it to the left in order to encode the arity in the Unique+-- of a superclass selector for that constraint tuple. Alternatively, given the+-- Unique for a constraint tuple superclass selector, this is the number of+-- bits by which one must shift it to the right to retrieve the arity of the+-- constraint tuple. See Note [Unique layout for constraint tuple selectors].+cTupleSelIdArityBits :: Int+cTupleSelIdArityBits = 8++-- Given the Unique for a constraint tuple superclass selector, one can+-- retrieve the position of the selector by ANDing this mask, which will+-- clear all but the eight least significant bits.+-- See Note [Unique layout for constraint tuple selectors].+cTupleSelIdPosBitmask :: Int+cTupleSelIdPosBitmask = 0xff+ -------------------------------------------------- -- Normal tuples @@ -178,3 +287,113 @@       (arity, 2) -> fromMaybe (panic "getTupleDataCon")                     $ tyConRepName_maybe $ promotedTupleDataCon boxity arity       _          -> panic "getTupleDataConName: impossible"++{-+Note [Uniques for wired-in prelude things and known masks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Allocation of unique supply characters:+        v,t,u : for renumbering value-, type- and usage- vars.+        B:   builtin+        C-E: pseudo uniques     (used in native-code generator)+        I:   GHCi evaluation+        X:   uniques from mkLocalUnique+        _:   unifiable tyvars   (above)+        0-9: prelude things below+             (no numbers left any more..)+        ::   (prelude) parallel array data constructors++        other a-z: lower case chars for unique supplies.  Used so far:++        a       TypeChecking?+        c       StgToCmm/Renamer+        d       desugarer+        f       AbsC flattener+        g       SimplStg+        i       TypeChecking interface files+        j       constraint tuple superclass selectors+        k       constraint tuple tycons+        m       constraint tuple datacons+        n       Native/LLVM codegen+        r       Hsc name cache+        s       simplifier+        u       Cmm pipeline+        y       GHCi bytecode generator+        z       anonymous sums+-}++mkAlphaTyVarUnique     :: Int -> Unique+mkPreludeClassUnique   :: Int -> Unique+mkPrimOpIdUnique       :: Int -> Unique+-- See Note [Primop wrappers] in GHC.Builtin.PrimOps.+mkPrimOpWrapperUnique  :: Int -> Unique+mkPreludeMiscIdUnique  :: Int -> Unique+mkCoVarUnique          :: Int -> Unique++mkAlphaTyVarUnique   i = mkUnique '1' i+mkCoVarUnique        i = mkUnique 'g' i+mkPreludeClassUnique i = mkUnique '2' i++--------------------------------------------------+mkPrimOpIdUnique op         = mkUnique '9' (2*op)+mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)+mkPreludeMiscIdUnique  i    = mkUnique '0' i++-- The "tyvar uniques" print specially nicely: a, b, c, etc.+-- See pprUnique for details++initTyVarUnique :: Unique+initTyVarUnique = mkUnique 't' 0++mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,+  mkBuiltinUnique :: Int -> Unique++mkBuiltinUnique i = mkUnique 'B' i+mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs+mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs+mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs++mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique+mkRegSingleUnique = mkUnique 'R'+mkRegSubUnique    = mkUnique 'S'+mkRegPairUnique   = mkUnique 'P'+mkRegClassUnique  = mkUnique 'L'++mkCostCentreUnique :: Int -> Unique+mkCostCentreUnique = mkUnique 'C'++mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique+-- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence+mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)+mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)+mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)+mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)++initExitJoinUnique :: Unique+initExitJoinUnique = mkUnique 's' 0+++--------------------------------------------------+-- Wired-in type constructor keys occupy *two* slots:+--    * u: the TyCon itself+--    * u+1: the TyConRepName of the TyCon++mkPreludeTyConUnique   :: Int -> Unique+mkPreludeTyConUnique i                = mkUnique '3' (2*i)++tyConRepNameUnique :: Unique -> Unique+tyConRepNameUnique  u = incrUnique u++--------------------------------------------------+-- Wired-in data constructor keys occupy *three* slots:+--    * u: the DataCon itself+--    * u+1: its worker Id+--    * u+2: the TyConRepName of the promoted TyCon+-- Prelude data constructors are too simple to need wrappers.++mkPreludeDataConUnique :: Arity -> Unique+mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic++--------------------------------------------------+dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique+dataConWorkerUnique  u = incrUnique u+dataConTyRepNameUnique u = stepUnique u 2

GHC/Builtin/Uniques.hs-boot view

@@ -2,8 +2,9 @@  import GHC.Prelude import GHC.Types.Unique-import GHC.Types.Name+import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic+import GHC.Data.FastString  -- Needed by GHC.Builtin.Types knownUniqueName :: Unique -> Maybe Name@@ -16,3 +17,24 @@  mkTupleTyConUnique :: Boxity -> Arity -> Unique mkTupleDataConUnique :: Boxity -> Arity -> Unique++mkAlphaTyVarUnique     :: Int -> Unique+mkPreludeClassUnique   :: Int -> Unique+mkPrimOpIdUnique       :: Int -> Unique+mkPrimOpWrapperUnique  :: Int -> Unique+mkPreludeMiscIdUnique  :: Int -> Unique+mkCoVarUnique          :: Int -> Unique++mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,+  mkBuiltinUnique :: Int -> Unique++mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique+mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique++initExitJoinUnique, initTyVarUnique :: Unique++mkPreludeTyConUnique   :: Int -> Unique+tyConRepNameUnique :: Unique -> Unique++mkPreludeDataConUnique :: Arity -> Unique+dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique

GHC/Builtin/Utils.hs view

@@ -50,30 +50,33 @@ import GHC.Prelude  import GHC.Builtin.Uniques-import GHC.Types.Unique ( isValidKnownKeyUnique )--import GHC.Core.ConLike ( ConLike(..) )+import GHC.Builtin.PrimOps+import GHC.Builtin.Types+import GHC.Builtin.Types.Literals ( typeNatTyCons )+import GHC.Builtin.Types.Prim import GHC.Builtin.Names.TH ( templateHaskellNames ) import GHC.Builtin.Names++import GHC.Core.ConLike ( ConLike(..) ) import GHC.Core.Opt.ConstantFold-import GHC.Types.Avail-import GHC.Builtin.PrimOps import GHC.Core.DataCon-import GHC.Types.Basic+import GHC.Core.Class+import GHC.Core.TyCon++import GHC.Types.Avail import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Id.Make-import GHC.Utils.Outputable-import GHC.Builtin.Types.Prim-import GHC.Builtin.Types-import GHC.Driver.Types-import GHC.Core.Class-import GHC.Core.TyCon import GHC.Types.Unique.FM+import GHC.Types.TyThing+import GHC.Types.Unique ( isValidKnownKeyUnique )++import GHC.Utils.Outputable import GHC.Utils.Misc as Utils-import GHC.Builtin.Types.Literals ( typeNatTyCons )+import GHC.Utils.Panic import GHC.Hs.Doc+import GHC.Unit.Module.ModIface (IfaceExport)  import Control.Applicative ((<|>)) import Data.List        ( intercalate , find )@@ -125,15 +128,7 @@   = all_names   where     all_names =-      -- We exclude most tuples from this list—see-      -- Note [Infinite families of known-key names] in GHC.Builtin.Names.-      -- We make an exception for Solo (i.e., the boxed 1-tuple), since it does-      -- not use special syntax like other tuples.-      -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)-      -- in GHC.Builtin.Types.-      tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 :-      concat [ wired_tycon_kk_names funTyCon-             , concatMap wired_tycon_kk_names primTyCons+      concat [ concatMap wired_tycon_kk_names primTyCons              , concatMap wired_tycon_kk_names wiredInTyCons              , concatMap wired_tycon_kk_names typeNatTyCons              , map idName wiredInIds@@ -256,24 +251,21 @@             Export lists for pseudo-modules (GHC.Prim) *                                                                      * ************************************************************************--GHC.Prim "exports" all the primops and primitive types, some-wired-in Ids. -}  ghcPrimExports :: [IfaceExport] ghcPrimExports  = map (avail . idName) ghcPrimIds ++    map (avail . idName . primOpId) allThePrimOps ++-   [ AvailTC n [n] []-   | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc  ]+   [ availTC n [n] []+   | tc <- exposedPrimTyCons, let n = tyConName tc  ]  ghcPrimDeclDocs :: DeclDocMap ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs   where     names = map idName ghcPrimIds ++             map (idName . primOpId) allThePrimOps ++-            map tyConName (funTyCon : exposedPrimTyCons)+            map tyConName exposedPrimTyCons     findName (nameStr, doc)       | Just name <- find ((nameStr ==) . getOccString) names       = Just (name, mkHsDocString doc)

GHC/ByteCode/Asm.hs view

@@ -1,4 +1,6 @@-{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE DeriveFunctor   #-}+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- --  (c) The University of Glasgow 2002-2006@@ -7,10 +9,10 @@ -- | Bytecode assembler and linker module GHC.ByteCode.Asm (         assembleBCOs, assembleOneBCO,-         bcoFreeNames,         SizedSeq, sizeSS, ssElts,-        iNTERP_STACK_CHECK_THRESH+        iNTERP_STACK_CHECK_THRESH,+        mkTupleInfoLit   ) where  #include "HsVersions.h"@@ -22,24 +24,27 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHC.Runtime.Interpreter+import GHC.Runtime.Heap.Layout hiding ( WordOff ) -import GHC.Driver.Types import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Literal+import GHC.Types.Unique+import GHC.Types.Unique.DSet++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+ import GHC.Core.TyCon import GHC.Data.FastString+import GHC.Data.SizedSeq+ import GHC.StgToCmm.Layout     ( ArgRep(..) )-import GHC.Runtime.Heap.Layout-import GHC.Driver.Session-import GHC.Utils.Outputable+import GHC.Cmm.Expr+import GHC.Cmm.CallConv        ( tupleRegsCover ) import GHC.Platform-import GHC.Utils.Misc-import GHC.Types.Unique-import GHC.Types.Unique.DSet---- From iserv-import SizedSeq+import GHC.Platform.Profile  import Control.Monad import Control.Monad.ST ( runST )@@ -53,12 +58,12 @@  import Data.Array.Unsafe( castSTUArray ) -import Foreign+import Foreign hiding (shiftL, shiftR) import Data.Char        ( ord ) import Data.List        ( genericLength )-import Data.Map (Map)+import Data.Map.Strict (Map) import Data.Maybe (fromMaybe)-import qualified Data.Map as Map+import qualified Data.Map.Strict as Map  -- ----------------------------------------------------------------------------- -- Unlinked BCOs@@ -91,13 +96,19 @@  -- Top level assembler fn. assembleBCOs-  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]+  :: Interp+  -> Profile+  -> [ProtoBCO Name]+  -> [TyCon]+  -> [RemotePtr ()]   -> Maybe ModBreaks   -> IO CompiledByteCode-assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do-  itblenv <- mkITbls hsc_env tycons-  bcos    <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos-  (bcos',ptrs) <- mallocStrings hsc_env bcos+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  itblenv <- mkITbls interp profile tycons+  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos+  (bcos',ptrs) <- mallocStrings interp bcos   return CompiledByteCode     { bc_bcos = bcos'     , bc_itbls =  itblenv@@ -113,10 +124,10 @@ --  b) For -fexternal-interpreter It's more efficient to malloc the strings --     as a single batch message, especially when compiling in parallel. ---mallocStrings :: HscEnv -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])-mallocStrings hsc_env ulbcos = do+mallocStrings :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])+mallocStrings interp ulbcos = do   let bytestrings = reverse (execState (mapM_ collect ulbcos) [])-  ptrs <- iservCmd hsc_env (MallocStrings bytestrings)+  ptrs <- interpCmd interp (MallocStrings bytestrings)   return (evalState (mapM splice ulbcos) ptrs, ptrs)  where   splice bco@UnlinkedBCO{..} = do@@ -149,10 +160,12 @@   collectPtr _ = return ()  -assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO-assembleOneBCO hsc_env pbco = do-  ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco-  ([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]+assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO+assembleOneBCO interp profile pbco = do+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  ubco <- assembleBCO (profilePlatform profile) pbco+  ([ubco'], _ptrs) <- mallocStrings interp [ubco]   return ubco'  assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO@@ -176,10 +189,12 @@       -- this BCO to be long.       (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm       ((n_insns, lbl_map), long_jumps)-        | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)+        | isLarge (fromIntegral $ Map.size lbl_map0)+          || isLarge n_insns0+                    = (inspectAsm platform True initial_offset asm, True)         | otherwise = ((n_insns0, lbl_map0), False) -      env :: Word16 -> Word+      env :: LocalLabel -> Word       env lbl = fromMaybe         (pprPanic "assembleBCO.findLabel" (ppr lbl))         (Map.lookup lbl lbl_map)@@ -219,13 +234,13 @@ data Operand   = Op Word   | SmallOp Word16-  | LabelOp Word16+  | LabelOp LocalLabel -- (unused)  | LargeOp Word  data Assembler a   = AllocPtr (IO BCOPtr) (Word -> Assembler a)   | AllocLit [BCONPtr] (Word -> Assembler a)-  | AllocLabel Word16 (Assembler a)+  | AllocLabel LocalLabel (Assembler a)   | Emit Word16 [Operand] (Assembler a)   | NullAsm a   deriving (Functor)@@ -250,13 +265,13 @@ lit :: [BCONPtr] -> Assembler Word lit l = AllocLit l return -label :: Word16 -> Assembler ()+label :: LocalLabel -> Assembler () label w = AllocLabel w (return ())  emit :: Word16 -> [Operand] -> Assembler () emit w ops = Emit w ops (return ()) -type LabelEnv = Word16 -> Word+type LabelEnv = LocalLabel -> Word  largeOp :: Bool -> Operand -> Bool largeOp long_jumps op = case op of@@ -296,7 +311,7 @@         in ((), (st_i1,st_l0,st_p0))       go k -type LabelEnvMap = Map Word16 Word+type LabelEnvMap = Map LocalLabel Word  data InspectState = InspectState   { instrCount :: !Word@@ -374,6 +389,16 @@                            -> do let ul_bco = assembleBCO platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit (push_alts pk) [Op p]+  PUSH_ALTS_TUPLE proto tuple_info tuple_proto+                           -> do let ul_bco = assembleBCO platform proto+                                     ul_tuple_bco = assembleBCO platform+                                                                tuple_proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)+                                 info <- int (fromIntegral $+                                              mkTupleInfoSig platform tuple_info)+                                 emit bci_PUSH_ALTS_T+                                      [Op p, Op info, Op p_tup]   PUSH_PAD8                -> emit bci_PUSH_PAD8 []   PUSH_PAD16               -> emit bci_PUSH_PAD16 []   PUSH_PAD32               -> emit bci_PUSH_PAD32 []@@ -431,7 +456,8 @@   JMP       l              -> emit bci_JMP [LabelOp l]   ENTER                    -> emit bci_ENTER []   RETURN                   -> emit bci_RETURN []-  RETURN_UBX rep           -> emit (return_ubx rep) []+  RETURN_UNLIFTED rep      -> emit (return_unlifted rep) []+  RETURN_TUPLE             -> emit bci_RETURN_T []   CCALL off m_addr i       -> do np <- addr m_addr                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]   BRK_FUN index uniq cc    -> do p1 <- ptr BCOPtrBreakArray@@ -456,20 +482,30 @@     literal (LitNumber nt i) = case nt of       LitNumInt     -> int (fromIntegral i)       LitNumWord    -> int (fromIntegral i)+      LitNumInt8    -> int8 (fromIntegral i)+      LitNumWord8   -> int8 (fromIntegral i)+      LitNumInt16   -> int16 (fromIntegral i)+      LitNumWord16  -> int16 (fromIntegral i)+      LitNumInt32   -> int32 (fromIntegral i)+      LitNumWord32  -> int32 (fromIntegral i)       LitNumInt64   -> int64 (fromIntegral i)       LitNumWord64  -> int64 (fromIntegral i)       LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"       LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural"+     -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most     -- likely to elicit a crash (rather than corrupt memory) in case absence     -- analysis messed up.-    literal LitRubbish         = int 0+    literal (LitRubbish {}) = int 0      litlabel fs = lit [BCONPtrLbl fs]     addr (RemotePtr a) = words [fromIntegral a]     float = words . mkLitF     double = words . mkLitD platform     int = words . mkLitI+    int8 = words . mkLitI64 platform+    int16 = words . mkLitI64 platform+    int32 = words . mkLitI64 platform     int64 = words . mkLitI64 platform     words ws = lit (map BCONPtrWord ws)     word w = words [w]@@ -488,16 +524,66 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_ubx :: ArgRep -> Word16-return_ubx V   = bci_RETURN_V-return_ubx P   = bci_RETURN_P-return_ubx N   = bci_RETURN_N-return_ubx L   = bci_RETURN_L-return_ubx F   = bci_RETURN_F-return_ubx D   = bci_RETURN_D-return_ubx V16 = error "return_ubx: vector"-return_ubx V32 = error "return_ubx: vector"-return_ubx V64 = error "return_ubx: vector"+return_unlifted :: ArgRep -> Word16+return_unlifted V   = bci_RETURN_V+return_unlifted P   = bci_RETURN_P+return_unlifted N   = bci_RETURN_N+return_unlifted L   = bci_RETURN_L+return_unlifted F   = bci_RETURN_F+return_unlifted D   = bci_RETURN_D+return_unlifted V16 = error "return_unlifted: vector"+return_unlifted V32 = error "return_unlifted: vector"+return_unlifted V64 = error "return_unlifted: vector"++{-+  we can only handle up to a fixed number of words on the stack,+  because we need a stg_ctoi_tN stack frame for each size N. See+  Note [unboxed tuple bytecodes and tuple_BCO].++  If needed, you can support larger tuples by adding more in+  StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and+  raising this limit.++  Note that the limit is the number of words passed on the stack.+  If the calling convention passes part of the tuple in registers, the+  maximum number of tuple elements may be larger. Elements can also+  take multiple words on the stack (for example Double# on a 32 bit+  platform).++ -}+maxTupleNativeStackSize :: WordOff+maxTupleNativeStackSize = 62++{-+  Construct the tuple_info word that stg_ctoi_t and stg_ret_t use+  to convert a tuple between the native calling convention and the+  interpreter.++  See Note [GHCi tuple layout] for more information.+ -}+mkTupleInfoSig :: Platform -> TupleInfo -> Word32+mkTupleInfoSig platform TupleInfo{..}+  | tupleNativeStackSize > maxTupleNativeStackSize+  = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"+             (ppr tupleNativeStackSize <+> text "stack words." <+>+              text "Use -fobject-code to get around this limit"+             )+  | otherwise+  = ASSERT(length regs <= 24) {- 24 bits for bitmap -}+    ASSERT(tupleNativeStackSize < 255) {- 8 bits for stack size -}+    ASSERT(all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}+    foldl' reg_bit 0 (zip regs [0..]) .|.+      (fromIntegral tupleNativeStackSize `shiftL` 24)+  where+    reg_bit :: Word32 -> (GlobalReg, Int) -> Word32+    reg_bit x (r, n)+      | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n+      | otherwise                = x+    regs = tupleRegsCover platform++mkTupleInfoLit :: Platform -> TupleInfo -> Literal+mkTupleInfoLit platform tuple_info =+  mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info  -- Make lists of host-sized words for literals, so that when the -- words are placed in memory at increasing addresses, the

GHC/ByteCode/InfoTable.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} -- --  (c) The University of Glasgow 2002-2006@@ -11,19 +12,25 @@  import GHC.Prelude +import GHC.Driver.Session+ import GHC.Platform+import GHC.Platform.Profile+ import GHC.ByteCode.Types import GHC.Runtime.Interpreter-import GHC.Driver.Session-import GHC.Driver.Types+ import GHC.Types.Name       ( Name, getName ) import GHC.Types.Name.Env+import GHC.Types.RepType+ import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity ) import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) import GHC.Core.Multiplicity     ( scaledThing )-import GHC.Types.RepType+ import GHC.StgToCmm.Layout  ( mkVirtConstrSizes ) import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )+ import GHC.Utils.Misc import GHC.Utils.Panic @@ -32,30 +39,30 @@ -}  -- Make info tables for the data decls in this module-mkITbls :: HscEnv -> [TyCon] -> IO ItblEnv-mkITbls hsc_env tcs =+mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv+mkITbls interp profile tcs =   foldr plusNameEnv emptyNameEnv <$>-    mapM (mkITbl hsc_env) (filter isDataTyCon tcs)+    mapM mkITbl (filter isDataTyCon tcs)  where-  mkITbl :: HscEnv -> TyCon -> IO ItblEnv-  mkITbl hsc_env tc+  mkITbl :: TyCon -> IO ItblEnv+  mkITbl tc     | dcs `lengthIs` n -- paranoia; this is an assertion.-    = make_constr_itbls hsc_env dcs+    = make_constr_itbls interp profile dcs        where           dcs = tyConDataCons tc           n   = tyConFamilySize tc-  mkITbl _ _ = panic "mkITbl"+  mkITbl _ = panic "mkITbl"  mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs]  -- Assumes constructors are numbered from zero, not one-make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv-make_constr_itbls hsc_env cons =+make_constr_itbls :: Interp -> Profile -> [DataCon] -> IO ItblEnv+make_constr_itbls interp profile cons =+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter   mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])  where-  dflags = hsc_dflags hsc_env-   mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)   mk_itbl dcon conNo = do      let rep_args = [ NonVoid prim_rep@@ -63,19 +70,20 @@                     , prim_rep <- typePrimRep (scaledThing arg) ]           (tot_wds, ptr_wds) =-             mkVirtConstrSizes dflags rep_args+             mkVirtConstrSizes profile rep_args           ptrs'  = ptr_wds          nptrs' = tot_wds - ptr_wds          nptrs_really-            | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'-            | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'+            | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'+            | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs'           descr = dataConIdentity dcon -         platform = targetPlatform dflags+         platform = profilePlatform profile+         constants = platformConstants platform          tables_next_to_code = platformTablesNextToCode platform -     r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really-                              conNo (tagForCon dflags dcon) descr)+     r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really+                              conNo (tagForCon platform dcon) descr)      return (getName dcon, ItblPtr r)

GHC/ByteCode/Instr.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- --  (c) The University of Glasgow 2002-2006@@ -6,7 +7,7 @@  -- | Bytecode instruction definitions module GHC.ByteCode.Instr (-        BCInstr(..), ProtoBCO(..), bciStackUse,+        BCInstr(..), ProtoBCO(..), bciStackUse, LocalLabel(..)   ) where  #include "HsVersions.h"@@ -17,22 +18,19 @@ import GHCi.RemoteTypes import GHCi.FFI (C_ffi_cif) import GHC.StgToCmm.Layout     ( ArgRep(..) )-import GHC.Core.Ppr import GHC.Utils.Outputable-import GHC.Data.FastString import GHC.Types.Name import GHC.Types.Unique-import GHC.Types.Id-import GHC.Core import GHC.Types.Literal import GHC.Core.DataCon-import GHC.Types.Var.Set import GHC.Builtin.PrimOps import GHC.Runtime.Heap.Layout  import Data.Word import GHC.Stack.CCS (CostCentre) +import GHC.Stg.Syntax+ -- ---------------------------------------------------------------------------- -- Bytecode instructions @@ -45,13 +43,18 @@         protoBCOBitmapSize :: Word16,         protoBCOArity      :: Int,         -- what the BCO came from, for debugging only-        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),+        protoBCOExpr       :: Either [CgStgAlt] CgStgRhs,         -- malloc'd pointers         protoBCOFFIs       :: [FFIInfo]    } -type LocalLabel = Word16+-- | A local block label (e.g. identifying a case alternative).+newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }+  deriving (Eq, Ord) +instance Outputable LocalLabel where+  ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl+ data BCInstr    -- Messing with the stack    = STKCHECK  Word@@ -86,6 +89,9 @@    -- Push an alt continuation    | PUSH_ALTS          (ProtoBCO Name)    | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep+   | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation+                        !TupleInfo+                        (ProtoBCO Name) -- tuple return BCO     -- Pushing 8, 16 and 32 bits of padding (for constructors).    | PUSH_PAD8@@ -168,8 +174,9 @@     -- To Infinity And Beyond    | ENTER-   | RETURN             -- return a lifted value-   | RETURN_UBX ArgRep -- return an unlifted value, here's its rep+   | RETURN                 -- return a lifted value+   | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep+   | RETURN_TUPLE           -- return an unboxed tuple (info already on stack)     -- Breakpoints    | BRK_FUN          Word16 Unique (RemotePtr CostCentre)@@ -188,37 +195,46 @@       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity                 <+> text (show ffis) <> colon)         $$ nest 3 (case origin of-                      Left alts -> vcat (zipWith (<+>) (char '{' : repeat (char ';'))-                                                       (map (pprCoreAltShort.deAnnAlt) alts)) <+> char '}'-                      Right rhs -> pprCoreExprShort (deAnnotate rhs))+                      Left alts ->+                        vcat (zipWith (<+>) (char '{' : repeat (char ';'))+                             (map (pprStgAltShort shortStgPprOpts) alts))+                      Right rhs ->+                        pprStgRhsShort shortStgPprOpts rhs+                  )         $$ nest 3 (text "bitmap: " <+> text (show bsize) <+> ppr bitmap)         $$ nest 3 (vcat (map ppr instrs)) --- Print enough of the Core expression to enable the reader to find--- the expression in the -ddump-prep output.  That is, we need to+-- Print enough of the STG expression to enable the reader to find+-- the expression in the -ddump-stg output.  That is, we need to -- include at least a binder. -pprCoreExprShort :: CoreExpr -> SDoc-pprCoreExprShort expr@(Lam _ _)-  = let-        (bndrs, _) = collectBinders expr-    in-    char '\\' <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow <+> text "..."+pprStgExprShort :: OutputablePass pass => StgPprOpts -> GenStgExpr pass -> SDoc+pprStgExprShort _ (StgCase _expr var _ty _alts) =+  text "case of" <+> ppr var+pprStgExprShort _ (StgLet _ bnd _) =+  text "let" <+> pprStgBindShort bnd <+> text "in ..."+pprStgExprShort _ (StgLetNoEscape _ bnd _) =+  text "let-no-escape" <+> pprStgBindShort bnd <+> text "in ..."+pprStgExprShort opts (StgTick t e) = ppr t <+> pprStgExprShort opts e+pprStgExprShort opts e = pprStgExpr opts e -pprCoreExprShort (Case _expr var _ty _alts)- = text "case of" <+> ppr var+pprStgBindShort :: OutputablePass pass => GenStgBinding pass -> SDoc+pprStgBindShort (StgNonRec x _) =+  ppr x <+> text "= ..."+pprStgBindShort (StgRec bs) =+  char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }" -pprCoreExprShort (Let (NonRec x _) _) = text "let" <+> ppr x <+> ptext (sLit ("= ... in ..."))-pprCoreExprShort (Let (Rec bs) _) = text "let {" <+> ppr (fst (head bs)) <+> ptext (sLit ("= ...; ... } in ..."))+pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc+pprStgAltShort opts (con, args, expr) =+  ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr -pprCoreExprShort (Tick t e) = ppr t <+> pprCoreExprShort e-pprCoreExprShort (Cast e _) = pprCoreExprShort e <+> text "`cast` T"+pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc+pprStgRhsShort opts (StgRhsClosure _ext _cc upd_flag args body) =+  hang (hsep [ char '\\' <> ppr upd_flag, brackets (interppSP args) ])+       4 (pprStgExprShort opts body)+pprStgRhsShort opts rhs = pprStgRhs opts rhs -pprCoreExprShort e = pprCoreExpr e -pprCoreAltShort :: CoreAlt -> SDoc-pprCoreAltShort (con, args, expr) = ppr con <+> sep (map ppr args) <+> text "->" <+> pprCoreExprShort expr- instance Outputable BCInstr where    ppr (STKCHECK n)          = text "STKCHECK" <+> ppr n    ppr (PUSH_L offset)       = text "PUSH_L  " <+> ppr offset@@ -234,8 +250,13 @@    ppr (PUSH_PRIMOP op)      = text "PUSH_G  " <+> text "GHC.PrimopWrappers."                                                <> ppr op    ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco)+    ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)    ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)+   ppr (PUSH_ALTS_TUPLE bco tuple_info tuple_bco) =+                               hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info)+                                    2+                                    (ppr tuple_bco $+$ ppr bco)     ppr PUSH_PAD8             = text "PUSH_PAD8"    ppr PUSH_PAD16            = text "PUSH_PAD16"@@ -291,9 +312,12 @@                                                <+> text "by" <+> ppr n    ppr ENTER                 = text "ENTER"    ppr RETURN                = text "RETURN"-   ppr (RETURN_UBX pk)       = text "RETURN_UBX  " <+> ppr pk+   ppr (RETURN_UNLIFTED pk)  = text "RETURN_UNLIFTED  " <+> ppr pk+   ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"    ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>" ++ -- ----------------------------------------------------------------------------- -- The stack use, in words, of each bytecode insn.  These _must_ be -- correct, or overestimates of reality, to be safe.@@ -321,8 +345,16 @@ bciStackUse PUSH_G{}              = 1 bciStackUse PUSH_PRIMOP{}         = 1 bciStackUse PUSH_BCO{}            = 1-bciStackUse (PUSH_ALTS bco)       = 2 + protoBCOStackUse bco-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS bco)       = 2 {- profiling only, restore CCCS -} ++                                    3 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} ++                                         4 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS_TUPLE bco info _) =+   -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)+   -- tuple+   -- (tuple_info, tuple_bco, stg_ret_t)+   1 {- profiling only -} ++   7 + fromIntegral (tupleSize info) + protoBCOStackUse bco bciStackUse (PUSH_PAD8)           = 1  -- overapproximation bciStackUse (PUSH_PAD16)          = 1  -- overapproximation bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch@@ -360,7 +392,8 @@ bciStackUse JMP{}                 = 0 bciStackUse ENTER{}               = 0 bciStackUse RETURN{}              = 0-bciStackUse RETURN_UBX{}          = 1+bciStackUse RETURN_UNLIFTED{}     = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header bciStackUse CCALL{}               = 0 bciStackUse SWIZZLE{}             = 0 bciStackUse BRK_FUN{}             = 0

GHC/ByteCode/Linker.hs view

@@ -1,7 +1,6 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MagicHash             #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-} --@@ -9,34 +8,43 @@ --  -- | Bytecode assembler and linker-module GHC.ByteCode.Linker (-        ClosureEnv, emptyClosureEnv, extendClosureEnv,-        linkBCO, lookupStaticPtr,-        lookupIE,-        nameToCLabel, linkFail-  ) where+module GHC.ByteCode.Linker+  ( ClosureEnv+  , emptyClosureEnv+  , extendClosureEnv+  , linkBCO+  , lookupStaticPtr+  , lookupIE+  , nameToCLabel+  , linkFail+  )+where  #include "HsVersions.h"  import GHC.Prelude +import GHC.Runtime.Interpreter+import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray-import SizedSeq -import GHC.Runtime.Interpreter-import GHC.ByteCode.Types-import GHC.Driver.Types-import GHC.Types.Name-import GHC.Types.Name.Env import GHC.Builtin.PrimOps-import GHC.Unit++import GHC.Unit.Types+import GHC.Unit.Module.Name+ import GHC.Data.FastString+import GHC.Data.SizedSeq+ import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Utils.Misc +import GHC.Types.Name+import GHC.Types.Name.Env+ -- Standard libraries import Data.Array.Unboxed import Foreign.Ptr@@ -60,88 +68,104 @@ -}  linkBCO-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray+  :: Interp+  -> ItblEnv+  -> ClosureEnv+  -> NameEnv Int+  -> RemoteRef BreakArray   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO hsc_env ie ce bco_ix breakarray+linkBCO interp ie ce bco_ix breakarray            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do   -- fromIntegral Word -> Word64 should be a no op if Word is Word64   -- otherwise it will result in a cast to longlong on 32bit systems.-  lits <- mapM (fmap fromIntegral . lookupLiteral hsc_env ie) (ssElts lits0)-  ptrs <- mapM (resolvePtr hsc_env ie ce bco_ix breakarray) (ssElts ptrs0)+  lits <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)+  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)   return (ResolvedBCO isLittleEndian arity insns bitmap               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)               (addListToSS emptySS ptrs)) -lookupLiteral :: HscEnv -> ItblEnv -> BCONPtr -> IO Word-lookupLiteral _ _ (BCONPtrWord lit) = return lit-lookupLiteral hsc_env _ (BCONPtrLbl  sym) = do-  Ptr a# <- lookupStaticPtr hsc_env sym-  return (W# (int2Word# (addr2Int# a#)))-lookupLiteral hsc_env ie (BCONPtrItbl nm)  = do-  Ptr a# <- lookupIE hsc_env ie nm-  return (W# (int2Word# (addr2Int# a#)))-lookupLiteral _ _ (BCONPtrStr _) =-  -- should be eliminated during assembleBCOs-  panic "lookupLiteral: BCONPtrStr"+lookupLiteral :: Interp -> ItblEnv -> BCONPtr -> IO Word+lookupLiteral interp ie ptr = case ptr of+  BCONPtrWord lit -> return lit+  BCONPtrLbl  sym -> do+    Ptr a# <- lookupStaticPtr interp sym+    return (W# (int2Word# (addr2Int# a#)))+  BCONPtrItbl nm -> do+    Ptr a# <- lookupIE interp ie nm+    return (W# (int2Word# (addr2Int# a#)))+  BCONPtrStr _ ->+    -- should be eliminated during assembleBCOs+    panic "lookupLiteral: BCONPtrStr" -lookupStaticPtr :: HscEnv -> FastString -> IO (Ptr ())-lookupStaticPtr hsc_env addr_of_label_string = do-  m <- lookupSymbol hsc_env addr_of_label_string+lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())+lookupStaticPtr interp addr_of_label_string = do+  m <- lookupSymbol interp addr_of_label_string   case m of     Just ptr -> return ptr     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"                   (unpackFS addr_of_label_string) -lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())-lookupIE hsc_env ie con_nm =+lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())+lookupIE interp ie con_nm =   case lookupNameEnv ie con_nm of     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))     Nothing -> do -- try looking up in the object files.        let sym_to_find1 = nameToCLabel con_nm "con_info"-       m <- lookupSymbol hsc_env sym_to_find1+       m <- lookupSymbol interp sym_to_find1        case m of           Just addr -> return addr           Nothing              -> do -- perhaps a nullary constructor?                    let sym_to_find2 = nameToCLabel con_nm "static_info"-                   n <- lookupSymbol hsc_env sym_to_find2+                   n <- lookupSymbol interp sym_to_find2                    case n of                       Just addr -> return addr                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"                                       (unpackFS sym_to_find1 ++ " or " ++                                        unpackFS sym_to_find2) -lookupPrimOp :: HscEnv -> PrimOp -> IO (RemotePtr ())-lookupPrimOp hsc_env primop = do+lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())+lookupPrimOp interp primop = do   let sym_to_find = primopToCLabel primop "closure"-  m <- lookupSymbol hsc_env (mkFastString sym_to_find)+  m <- lookupSymbol interp (mkFastString sym_to_find)   case m of     Just p -> return (toRemotePtr p)     Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find  resolvePtr-  :: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray+  :: Interp+  -> ItblEnv+  -> ClosureEnv+  -> NameEnv Int+  -> RemoteRef BreakArray   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)-  | Just ix <- lookupNameEnv bco_ix nm =-    return (ResolvedBCORef ix) -- ref to another BCO in this group-  | Just (_, rhv) <- lookupNameEnv ce nm =-    return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))-  | otherwise =-    ASSERT2(isExternalName nm, ppr nm)-    do let sym_to_find = nameToCLabel nm "closure"-       m <- lookupSymbol hsc_env sym_to_find-       case m of-         Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))-         Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)-resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =-  ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op-resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =-  ResolvedBCOPtrBCO <$> linkBCO hsc_env ie ce bco_ix breakarray bco-resolvePtr _ _ _ _ breakarray BCOPtrBreakArray =-  return (ResolvedBCOPtrBreakArray breakarray)+resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of+  BCOPtrName nm+    | Just ix <- lookupNameEnv bco_ix nm+    -> return (ResolvedBCORef ix) -- ref to another BCO in this group++    | Just (_, rhv) <- lookupNameEnv ce nm+    -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))++    | otherwise+    -> ASSERT2(isExternalName nm, ppr nm)+       do+          let sym_to_find = nameToCLabel nm "closure"+          m <- lookupSymbol interp sym_to_find+          case m of+            Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)++  BCOPtrPrimOp op+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op++  BCOPtrBCO bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco++  BCOPtrBreakArray+    -> return (ResolvedBCOPtrBreakArray breakarray)  linkFail :: String -> String -> IO a linkFail who what

GHC/ByteCode/Types.hs view

@@ -1,11 +1,16 @@-{-# LANGUAGE MagicHash, RecordWildCards, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-} -- --  (c) The University of Glasgow 2002-2006 --  -- | Bytecode assembler types module GHC.ByteCode.Types-  ( CompiledByteCode(..), seqCompiledByteCode, FFIInfo(..)+  ( CompiledByteCode(..), seqCompiledByteCode+  , FFIInfo(..)+  , RegBitmap(..)+  , TupleInfo(..), voidTupleInfo+  , ByteOff(..), WordOff(..)   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)   , CgBreakInfo(..)@@ -16,12 +21,12 @@ import GHC.Prelude  import GHC.Data.FastString+import GHC.Data.SizedSeq import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps-import SizedSeq import GHC.Core.Type import GHC.Types.SrcLoc import GHCi.BreakArray@@ -36,8 +41,9 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Maybe (catMaybes)-import GHC.Exts.Heap+import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS+import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )  -- ----------------------------------------------------------------------------- -- Compiled Byte Code@@ -67,11 +73,60 @@   rnf bc_strs `seq`   rnf (fmap seqModBreaks bc_breaks) +newtype ByteOff = ByteOff Int+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)++newtype WordOff = WordOff Int+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)++newtype RegBitmap = RegBitmap { unRegBitmap :: Word32 }+    deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Bits, FiniteBits, Outputable)++{- Note [GHCi TupleInfo]+~~~~~~~~~~~~~~~~~~~~~~~~++   This contains the data we need for passing unboxed tuples between+   bytecode and native code++   In general we closely follow the native calling convention that+   GHC uses for unboxed tuples, but we don't use any registers in+   bytecode. All tuple elements are expanded to use a full register+   or a full word on the stack.++   The position of tuple elements that are returned on the stack in+   the native calling convention is unchanged when returning the same+   tuple in bytecode.++   The order of the remaining elements is determined by the register in+   which they would have been returned, rather than by their position in+   the tuple in the Haskell source code. This makes jumping between bytecode+   and native code easier: A map of live registers is enough to convert the+   tuple.++   See GHC.StgToByteCode.layoutTuple for more details.+-}+data TupleInfo = TupleInfo+  { tupleSize            :: !WordOff   -- total size of tuple in words+  , tupleRegs            :: !GlobalRegSet+  , tupleNativeStackSize :: !WordOff {- words spilled on the stack by+                                        GHCs native calling convention -}+  } deriving (Show)++instance Outputable TupleInfo where+  ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>+                      text "stack" <+> ppr tupleNativeStackSize <+>+                      text "regs"  <+>+                      ppr (map (text.show) $ regSetToList tupleRegs) <>+                      char '>'++voidTupleInfo :: TupleInfo+voidTupleInfo = TupleInfo 0 emptyRegSet 0+ type ItblEnv = NameEnv (Name, ItblPtr)         -- We need the Name in the range so we know which         -- elements to filter out when unloading a module -newtype ItblPtr = ItblPtr (RemotePtr StgInfoTable)+newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)   deriving (Show, NFData)  data UnlinkedBCO

GHC/Cmm.hs view

@@ -3,7 +3,11 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + module GHC.Cmm (      -- * Cmm top-level datatypes      CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,@@ -96,6 +100,8 @@         Section         d +  deriving (Functor)+ type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph @@ -222,6 +228,12 @@   | CmmFileEmbed FilePath         -- ^ an embedded binary file +instance Outputable CmmStatic where+  ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit+  ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n+  ppr (CmmString _) = text "CmmString"+  ppr (CmmFileEmbed fp) = text "CmmFileEmbed" <+> text fp+ -- Static data before SRT generation data GenCmmStatics (rawOnly :: Bool) where     CmmStatics@@ -246,20 +258,32 @@ -- These are used by the LLVM and NCG backends, when populating Cmm -- with lists of instructions. -data GenBasicBlock i = BasicBlock BlockId [i]+data GenBasicBlock i+   = BasicBlock BlockId [i]+   deriving (Functor) + -- | The branch block id is that of the first block in -- the branch, which is that branch's entry point blockId :: GenBasicBlock i -> BlockId blockId (BasicBlock blk_id _ ) = blk_id -newtype ListGraph i = ListGraph [GenBasicBlock i]+newtype ListGraph i+   = ListGraph [GenBasicBlock i]+   deriving (Functor)  instance Outputable instr => Outputable (ListGraph instr) where     ppr (ListGraph blocks) = vcat (map ppr blocks) +instance OutputableP env instr => OutputableP env (ListGraph instr) where+    pdoc env g = ppr (fmap (pdoc env) g)++ instance Outputable instr => Outputable (GenBasicBlock instr) where     ppr = pprBBlock++instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where+    pdoc env block = ppr (fmap (pdoc env) block)  pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) =

GHC/Cmm/CLabel.hs view

@@ -9,13 +9,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + module GHC.Cmm.CLabel (         CLabel, -- abstract type         NeedExternDecl (..),         ForeignLabelSource(..),-        pprDebugCLabel,+        DynamicLinkerLabelInfo(..),+        ConInfoTableLocation(..),+        getConInfoTableLocation, +        -- * Constructors         mkClosureLabel,         mkSRTLabel,         mkInfoTableLabel,@@ -40,6 +46,7 @@         mkAsmTempLabel,         mkAsmTempDerivedLabel,         mkAsmTempEndLabel,+        mkAsmTempProcEndLabel,         mkAsmTempDieLabel,          mkDirty_MUT_VAR_Label,@@ -65,7 +72,6 @@          mkSelectorInfoLabel,         mkSelectorEntryLabel,-         mkCmmInfoLabel,         mkCmmEntryLabel,         mkCmmRetInfoLabel,@@ -74,44 +80,57 @@         mkCmmDataLabel,         mkRtsCmmDataLabel,         mkCmmClosureLabel,-         mkRtsApFastLabel,-         mkPrimCallLabel,-         mkForeignLabel,-        addLabelSize,--        foreignLabelStdcallInfo,-        isBytesLabel,-        isForeignLabel,-        isSomeRODataLabel,-        isStaticClosureLabel,-        mkCCLabel, mkCCSLabel,+        mkCCLabel,+        mkCCSLabel,+        mkIPELabel,+        InfoProvEnt(..), -        DynamicLinkerLabelInfo(..),         mkDynamicLinkerLabel,-        dynamicLinkerLabelInfo,-         mkPicBaseLabel,         mkDeadStripPreventer,-         mkHpcTicksLabel,          -- * Predicates         hasCAF,-        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,+        needsCDecl,+        maybeLocalBlockLabel,+        externallyVisibleCLabel,         isMathFun,-        isCFunctionLabel, isGcPtrLabel, labelDynamic,-        isLocalCLabel, mayRedirectTo,+        isCFunctionLabel,+        isGcPtrLabel,+        labelDynamic,+        isLocalCLabel,+        mayRedirectTo,+        isInfoTableLabel,+        isConInfoTableLabel,+        isIdLabel,+        isTickyLabel,+        hasHaskellName,+        hasIdLabelInfo,+        isBytesLabel,+        isForeignLabel,+        isSomeRODataLabel,+        isStaticClosureLabel,          -- * Conversions-        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,+        toClosureLbl,+        toSlowEntryLbl,+        toEntryLbl,+        toInfoLbl, +        -- * Pretty-printing+        LabelStyle (..),+        pprDebugCLabel,         pprCLabel,-        isInfoTableLabel,-        isConInfoTableLabel,-        isIdLabel, isTickyLabel+        ppInternalProcLabel,++        -- * Others+        dynamicLinkerLabelInfo,+        addLabelSize,+        foreignLabelStdcallInfo     ) where  #include "HsVersions.h"@@ -121,12 +140,13 @@ import GHC.Types.Id.Info import GHC.Types.Basic import {-# SOURCE #-} GHC.Cmm.BlockId (BlockId, mkBlockId)-import GHC.Unit+import GHC.Unit.Types import GHC.Types.Name import GHC.Types.Unique import GHC.Builtin.PrimOps import GHC.Types.CostCentre import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Driver.Session import GHC.Platform@@ -134,7 +154,7 @@ import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.CmmToAsm.Config-+import GHC.Types.SrcLoc -- ----------------------------------------------------------------------------- -- The CLabel type @@ -237,11 +257,12 @@    | CC_Label  CostCentre   | CCS_Label CostCentreStack+  | IPE_Label InfoProvEnt     -- | These labels are generated and used inside the NCG only.   --    They are special variants of a label used for dynamic linking-  --    see module PositionIndependentCode for details.+  --    see module "GHC.CmmToAsm.PIC" for details.   | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel    -- | This label is generated and used inside the NCG only.@@ -268,6 +289,12 @@    deriving Eq +instance Show CLabel where+  show = showPprUnsafe . pprDebugCLabel genericPlatform++instance Outputable CLabel where+  ppr = text . show+ isIdLabel :: CLabel -> Bool isIdLabel IdLabel{} = True isIdLabel _ = False@@ -309,25 +336,27 @@   compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =     compare a1 a2 `thenCmp`     compare b1 b2 `thenCmp`-    compare c1 c2 `thenCmp`+    uniqCompareFS c1 c2 `thenCmp`     compare d1 d2   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2   compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2   compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =-    compare a1 a2 `thenCmp`+    uniqCompareFS a1 a2 `thenCmp`     compare b1 b2 `thenCmp`     compare c1 c2 `thenCmp`     compare d1 d2   compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2   compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =     compare a1 a2 `thenCmp`-    compare b1 b2+    uniqCompareFS b1 b2   compare (StringLitLabel u1) (StringLitLabel u2) =     nonDetCmpUnique u1 u2   compare (CC_Label a1) (CC_Label a2) =     compare a1 a2   compare (CCS_Label a1) (CCS_Label a2) =     compare a1 a2+  compare (IPE_Label a1) (IPE_Label a2) =+    compare a1 a2   compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =     compare a1 a2 `thenCmp`     compare b1 b2@@ -370,12 +399,14 @@   compare _ HpcTicksLabel{} = GT   compare SRTLabel{} _ = LT   compare _ SRTLabel{} = GT+  compare (IPE_Label {}) _ = LT+  compare  _ (IPE_Label{}) = GT  -- | Record where a foreign label is stored. data ForeignLabelSource     -- | Label is in a named package-   = ForeignLabelInPackage Unit+   = ForeignLabelInPackage UnitId     -- | Label is in some external, system package that doesn't also    --   contain compiled Haskell code, and is not associated with any .hi files.@@ -397,25 +428,25 @@ --      We can't make a Show instance for CLabel because lots of its components don't have instances. --      The regular Outputable instance only shows the label name, and not its other info. ---pprDebugCLabel :: CLabel -> SDoc-pprDebugCLabel lbl- = case lbl of-        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"-                                       <> whenPprDebug (text ":" <> text (show info)))-        CmmLabel pkg _ext _name _info-         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)+pprDebugCLabel :: Platform -> CLabel -> SDoc+pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra+   where+      extra = case lbl of+         IdLabel _ _ info+            -> text "IdLabel" <> whenPprDebug (text ":" <> ppr info) -        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")+         CmmLabel pkg _ext _name _info+            -> text "CmmLabel" <+> ppr pkg -        ForeignLabel _name mSuffix src funOrData-            -> ppr lbl <> (parens $ text "ForeignLabel"-                                <+> ppr mSuffix-                                <+> ppr src-                                <+> ppr funOrData)+         RtsLabel{}+            -> text "RtsLabel" -        _               -> ppr lbl <> (parens $ text "other CLabel")+         ForeignLabel _name mSuffix src funOrData+             -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData +         _  -> text "other CLabel" + data IdLabelInfo   = Closure             -- ^ Label for closure   | InfoTable           -- ^ Info tables for closures; always read-only@@ -427,9 +458,19 @@    | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id -  | ConEntry            -- ^ Constructor entry point-  | ConInfoTable        -- ^ Corresponding info table+  | ConEntry ConInfoTableLocation+  -- ^ Constructor entry point, when `-fdistinct-info-tables` is enabled then+  -- each usage of a constructor will be given a unique number and a fresh info+  -- table will be created in the module where the constructor is used. The+  -- argument is used to keep track of which info table a usage of a constructor+  -- should use. When the argument is 'Nothing' then it uses the info table which+  -- is defined in the module where the datatype is declared, this is the usual case.+  -- When it is (Just (m, k)) it will use the kth info table defined in module m. The+  -- point of this inefficiency is so that you can work out where allocations of data+  -- constructors are coming from when you are debugging. +  | ConInfoTable ConInfoTableLocation        -- ^ Corresponding info table+   | ClosureTable        -- ^ Table of closures for Enum tycons    | Bytes               -- ^ Content of a string literal. See@@ -438,9 +479,38 @@                         -- instead of a closure entry-point.                         -- See Note [Proc-point local block entry-point]. -  deriving (Eq, Ord, Show)+  deriving (Eq, Ord) +-- | Which module is the info table from, and which number was it.+data ConInfoTableLocation = UsageSite Module Int+                          | DefinitionSite+                              deriving (Eq, Ord) +instance Outputable ConInfoTableLocation where+  ppr (UsageSite m n) = text "Loc(" <> ppr n <> text "):" <+> ppr m+  ppr DefinitionSite = empty++getConInfoTableLocation :: IdLabelInfo -> Maybe ConInfoTableLocation+getConInfoTableLocation (ConInfoTable ci) = Just ci+getConInfoTableLocation _ = Nothing++instance Outputable IdLabelInfo where+  ppr Closure    = text "Closure"+  ppr InfoTable  = text "InfoTable"+  ppr Entry      = text "Entry"+  ppr Slow       = text "Slow"++  ppr LocalInfoTable  = text "LocalInfoTable"+  ppr LocalEntry      = text "LocalEntry"++  ppr RednCounts      = text "RednCounts"+  ppr (ConEntry mn) = text "ConEntry" <+> ppr mn+  ppr (ConInfoTable mn) = text "ConInfoTable" <+> ppr mn+  ppr ClosureTable = text "ClosureTable"+  ppr Bytes        = text "Bytes"+  ppr BlockInfoTable  = text "BlockInfoTable"++ data RtsLabelInfo   = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks   | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}@@ -448,13 +518,11 @@   | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks   | RtsApEntry           Bool{-updatable-} Int{-arity-} -  | RtsPrimOp PrimOp-  | RtsApFast     FastString    -- ^ _fast versions of generic apply+  | RtsPrimOp            PrimOp+  | RtsApFast            NonDetFastString    -- ^ _fast versions of generic apply   | RtsSlowFastTickyCtr String -  deriving (Eq, Ord)-  -- NOTE: Eq on PtrString compares the pointer only, so this isn't-  -- a real equality.+  deriving (Eq,Ord)   -- | What type of Cmm label we're dealing with.@@ -505,13 +573,15 @@ mkInfoTableLabel            :: Name -> CafInfo -> CLabel mkEntryLabel                :: Name -> CafInfo -> CLabel mkClosureTableLabel         :: Name -> CafInfo -> CLabel-mkConInfoTableLabel         :: Name -> CafInfo -> CLabel+mkConInfoTableLabel         :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel                :: Name -> CLabel mkClosureLabel name         c     = IdLabel name c Closure mkInfoTableLabel name       c     = IdLabel name c InfoTable mkEntryLabel name           c     = IdLabel name c Entry mkClosureTableLabel name    c     = IdLabel name c ClosureTable-mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable+-- Special case for the normal 'DefinitionSite' case so that the 'ConInfoTable' application can be floated to a CAF.+mkConInfoTableLabel name DefinitionSite = IdLabel name NoCafRefs (ConInfoTable DefinitionSite)+mkConInfoTableLabel name k = IdLabel name NoCafRefs (ConInfoTable k) mkBytesLabel name                 = IdLabel name NoCafRefs Bytes  mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel@@ -598,24 +668,24 @@ mkRtsPrimOpLabel :: PrimOp -> CLabel mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) -mkSelectorInfoLabel :: DynFlags -> Bool -> Int -> CLabel-mkSelectorInfoLabel dflags upd offset =-   ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+mkSelectorInfoLabel :: Platform -> Bool -> Int -> CLabel+mkSelectorInfoLabel platform upd offset =+   ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))    RtsLabel (RtsSelectorInfoTable upd offset) -mkSelectorEntryLabel :: DynFlags -> Bool -> Int -> CLabel-mkSelectorEntryLabel dflags upd offset =-   ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+mkSelectorEntryLabel :: Platform -> Bool -> Int -> CLabel+mkSelectorEntryLabel platform upd offset =+   ASSERT(offset >= 0 && offset <= pc_MAX_SPEC_SELECTEE_SIZE (platformConstants platform))    RtsLabel (RtsSelectorEntry upd offset) -mkApInfoTableLabel :: DynFlags -> Bool -> Int -> CLabel-mkApInfoTableLabel dflags upd arity =-   ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+mkApInfoTableLabel :: Platform -> Bool -> Int -> CLabel+mkApInfoTableLabel platform upd arity =+   ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))    RtsLabel (RtsApInfoTable upd arity) -mkApEntryLabel :: DynFlags -> Bool -> Int -> CLabel-mkApEntryLabel dflags upd arity =-   ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+mkApEntryLabel :: Platform -> Bool -> Int -> CLabel+mkApEntryLabel platform upd arity =+   ASSERT(arity > 0 && arity <= pc_MAX_SPEC_AP_SIZE (platformConstants platform))    RtsLabel (RtsApEntry upd arity)  @@ -667,7 +737,7 @@ isSomeRODataLabel :: CLabel -> Bool -- info table defined in haskell (.hs) isSomeRODataLabel (IdLabel _ _ ClosureTable) = True-isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True+isSomeRODataLabel (IdLabel _ _ ConInfoTable {}) = True isSomeRODataLabel (IdLabel _ _ InfoTable) = True isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True@@ -679,13 +749,13 @@ isInfoTableLabel :: CLabel -> Bool isInfoTableLabel (IdLabel _ _ InfoTable)      = True isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True-isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True+isInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True isInfoTableLabel _                            = False  -- | Whether label is points to constructor info table isConInfoTableLabel :: CLabel -> Bool-isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True+isConInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True isConInfoTableLabel _                            = False  -- | Get the label size field from a ForeignLabel@@ -698,14 +768,31 @@ mkBitmapLabel   :: Unique -> CLabel mkBitmapLabel   uniq            = LargeBitmapLabel uniq +-- | Info Table Provenance Entry+-- See Note [Mapping Info Tables to Source Positions]+data InfoProvEnt = InfoProvEnt+                               { infoTablePtr :: !CLabel+                               -- Address of the info table+                               , infoProvEntClosureType :: !Int+                               -- The closure type of the info table (from ClosureMacros.h)+                               , infoTableType :: !String+                               -- The rendered Haskell type of the closure the table represents+                               , infoProvModule :: !Module+                               -- Origin module+                               , infoTableProv :: !(Maybe (RealSrcSpan, String)) }+                               -- Position and information about the info table+                               deriving (Eq, Ord)+ -- Constructing Cost Center Labels mkCCLabel  :: CostCentre      -> CLabel mkCCSLabel :: CostCentreStack -> CLabel+mkIPELabel :: InfoProvEnt -> CLabel mkCCLabel           cc          = CC_Label cc mkCCSLabel          ccs         = CCS_Label ccs+mkIPELabel          ipe         = IPE_Label ipe  mkRtsApFastLabel :: FastString -> CLabel-mkRtsApFastLabel str = RtsLabel (RtsApFast str)+mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))  mkRtsSlowFastTickyCtrLabel :: String -> CLabel mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)@@ -744,6 +831,10 @@ mkAsmTempEndLabel :: CLabel -> CLabel mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end") +-- | A label indicating the end of a procedure.+mkAsmTempProcEndLabel :: CLabel -> CLabel+mkAsmTempProcEndLabel l = mkAsmTempDerivedLabel l (fsLit "_proc_end")+ -- | Construct a label for a DWARF Debug Information Entity (DIE) -- describing another symbol. mkAsmTempDieLabel :: CLabel -> CLabel@@ -752,39 +843,48 @@ -- ----------------------------------------------------------------------------- -- Convert between different kinds of label -toClosureLbl :: CLabel -> CLabel-toClosureLbl (IdLabel n c _) = IdLabel n c Closure-toClosureLbl (CmmLabel m ext str _) = CmmLabel m ext str CmmClosure-toClosureLbl l = pprPanic "toClosureLbl" (ppr l)+toClosureLbl :: Platform -> CLabel -> CLabel+toClosureLbl platform lbl = case lbl of+   IdLabel n c _        -> IdLabel n c Closure+   CmmLabel m ext str _ -> CmmLabel m ext str CmmClosure+   _                    -> pprPanic "toClosureLbl" (pprDebugCLabel platform lbl) -toSlowEntryLbl :: CLabel -> CLabel-toSlowEntryLbl (IdLabel n _ BlockInfoTable)-  = pprPanic "toSlowEntryLbl" (ppr n)-toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow-toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)+toSlowEntryLbl :: Platform -> CLabel -> CLabel+toSlowEntryLbl platform lbl = case lbl of+   IdLabel n _ BlockInfoTable -> pprPanic "toSlowEntryLbl" (ppr n)+   IdLabel n c _              -> IdLabel n c Slow+   _                          -> pprPanic "toSlowEntryLbl" (pprDebugCLabel platform lbl) -toEntryLbl :: CLabel -> CLabel-toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry-toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry-toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)-                              -- See Note [Proc-point local block entry-point].-toEntryLbl (IdLabel n c _)               = IdLabel n c Entry-toEntryLbl (CmmLabel m ext str CmmInfo)    = CmmLabel m ext str CmmEntry-toEntryLbl (CmmLabel m ext str CmmRetInfo) = CmmLabel m ext str CmmRet-toEntryLbl l = pprPanic "toEntryLbl" (ppr l)+toEntryLbl :: Platform -> CLabel -> CLabel+toEntryLbl platform lbl = case lbl of+   IdLabel n c LocalInfoTable    -> IdLabel n c LocalEntry+   IdLabel n c (ConInfoTable k)  -> IdLabel n c (ConEntry k) -toInfoLbl :: CLabel -> CLabel-toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable-toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable-toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable-toInfoLbl (CmmLabel m ext str CmmEntry)= CmmLabel m ext str CmmInfo-toInfoLbl (CmmLabel m ext str CmmRet)  = CmmLabel m ext str CmmRetInfo-toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)+   IdLabel n _ BlockInfoTable    -> mkLocalBlockLabel (nameUnique n)+                   -- See Note [Proc-point local block entry-point].+   IdLabel n c _                 -> IdLabel n c Entry+   CmmLabel m ext str CmmInfo    -> CmmLabel m ext str CmmEntry+   CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet+   _                             -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl) +toInfoLbl :: Platform -> CLabel -> CLabel+toInfoLbl platform lbl = case lbl of+   IdLabel n c LocalEntry      -> IdLabel n c LocalInfoTable+   IdLabel n c (ConEntry k)    -> IdLabel n c (ConInfoTable k)++   IdLabel n c _               -> IdLabel n c InfoTable+   CmmLabel m ext str CmmEntry -> CmmLabel m ext str CmmInfo+   CmmLabel m ext str CmmRet   -> CmmLabel m ext str CmmRetInfo+   _                           -> pprPanic "CLabel.toInfoLbl" (pprDebugCLabel platform lbl)+ hasHaskellName :: CLabel -> Maybe Name hasHaskellName (IdLabel n _ _) = Just n hasHaskellName _               = Nothing +hasIdLabelInfo :: CLabel -> Maybe IdLabelInfo+hasIdLabelInfo (IdLabel _ _ l) = Just l+hasIdLabelInfo _ = Nothing+ -- ----------------------------------------------------------------------------- -- Does a CLabel's referent itself refer to a CAF? hasCAF :: CLabel -> Bool@@ -844,6 +944,7 @@ needsCDecl l@(ForeignLabel{})           = not (isMathFun l) needsCDecl (CC_Label _)                 = True needsCDecl (CCS_Label _)                = True+needsCDecl (IPE_Label {})               = True needsCDecl (HpcTicksLabel _)            = True needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel" needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"@@ -966,6 +1067,7 @@ externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info externallyVisibleCLabel (CC_Label _)            = True externallyVisibleCLabel (CCS_Label _)           = True+externallyVisibleCLabel (IPE_Label {})          = True externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False externallyVisibleCLabel (HpcTicksLabel _)       = True externallyVisibleCLabel (LargeBitmapLabel _)    = False@@ -1025,6 +1127,7 @@ labelType (StringLitLabel _)                    = DataLabel labelType (CC_Label _)                          = DataLabel labelType (CCS_Label _)                         = DataLabel+labelType (IPE_Label {})                        = DataLabel labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right? labelType PicBaseLabel                          = DataLabel labelType (DeadStripPreventer _)                = DataLabel@@ -1038,7 +1141,7 @@     LocalInfoTable -> DataLabel     BlockInfoTable -> DataLabel     Closure       -> GcPtrLabel-    ConInfoTable  -> DataLabel+    ConInfoTable {} -> DataLabel     ClosureTable  -> DataLabel     RednCounts    -> DataLabel     Bytes         -> DataLabel@@ -1069,20 +1172,20 @@ -- that data resides in a DLL or not. [Win32 only.] -- @labelDynamic@ returns @True@ if the label is located -- in a DLL, be it a data reference or not.-labelDynamic :: NCGConfig -> Module -> CLabel -> Bool-labelDynamic config this_mod lbl =+labelDynamic :: NCGConfig -> CLabel -> Bool+labelDynamic config lbl =   case lbl of    -- is the RTS in a DLL or not?    RtsLabel _ ->-     externalDynamicRefs && (this_pkg /= rtsUnit)+     externalDynamicRefs && (this_unit /= rtsUnitId)     IdLabel n _ _ ->      externalDynamicRefs && isDynLinkName platform this_mod n     -- When compiling in the "dyn" way, each package is to be linked into    -- its own shared library.-   CmmLabel pkg _ _ _-    | os == OSMinGW32 -> externalDynamicRefs && (toUnitId this_pkg /= pkg)+   CmmLabel lbl_unit _ _ _+    | os == OSMinGW32 -> externalDynamicRefs && (this_unit /= lbl_unit)     | otherwise       -> externalDynamicRefs     LocalBlockLabel _    -> False@@ -1101,7 +1204,7 @@             -- When compiling in the "dyn" way, each package is to be             -- linked into its own DLL.             ForeignLabelInPackage pkgId ->-                externalDynamicRefs && (this_pkg /= pkgId)+                externalDynamicRefs && (this_unit /= pkgId)         else -- On Mac OS X and on ELF platforms, false positives are OK,             -- so we claim that all foreign imports come from dynamic@@ -1113,6 +1216,7 @@     -- CCS_Label always contains a CostCentre defined in the current module    CCS_Label _ -> False+   IPE_Label {} -> True     HpcTicksLabel m ->      externalDynamicRefs && this_mod /= m@@ -1123,7 +1227,8 @@     externalDynamicRefs = ncgExternalDynamicRefs config     platform = ncgPlatform config     os = platformOS platform-    this_pkg = moduleUnit this_mod+    this_mod = ncgThisModule config+    this_unit = toUnitId (moduleUnit this_mod)   -----------------------------------------------------------------------------@@ -1206,35 +1311,51 @@ and are not externally visible. -} -instance Outputable CLabel where-  ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c+instance OutputableP Platform CLabel where+  pdoc platform lbl = getPprStyle $ \case+                        PprCode CStyle   -> pprCLabel platform CStyle lbl+                        PprCode AsmStyle -> pprCLabel platform AsmStyle lbl+                        _                -> pprCLabel platform CStyle lbl+                                            -- default to CStyle -pprCLabel :: DynFlags -> CLabel -> SDoc-pprCLabel dflags = \case-   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u+pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc+pprCLabel platform sty lbl =+  let+    -- some platform (e.g. Darwin) require a leading "_" for exported asm+    -- symbols+    maybe_underscore :: SDoc -> SDoc+    maybe_underscore doc = case sty of+      AsmStyle | platformLeadingUnderscore platform -> pp_cSEP <> doc+      _                                             -> doc -   (AsmTempLabel u)-      | not (platformUnregisterised platform)+    tempLabelPrefixOrUnderscore :: Platform -> SDoc+    tempLabelPrefixOrUnderscore platform = case sty of+      AsmStyle -> ptext (asmTempLabelPrefix platform)+      CStyle   -> char '_'+++  in case lbl of+   LocalBlockLabel u -> case sty of+      AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u+      CStyle   -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u++   AsmTempLabel u       -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u -   (AsmTempDerivedLabel l suf)-      | useNCG+   AsmTempDerivedLabel l suf       -> ptext (asmTempLabelPrefix platform)          <> case l of AsmTempLabel u    -> pprUniqueAlways u                       LocalBlockLabel u -> pprUniqueAlways u-                      _other            -> pprCLabel dflags l+                      _other            -> pprCLabel platform sty l          <> ftext suf -   (DynamicLinkerLabel info lbl)-      | useNCG-      -> pprDynamicLinkerAsmLabel platform info lbl+   DynamicLinkerLabel info lbl+      -> pprDynamicLinkerAsmLabel platform info (pprCLabel platform AsmStyle lbl)     PicBaseLabel-      | useNCG       -> text "1b" -   (DeadStripPreventer lbl)-      | useNCG+   DeadStripPreventer lbl       ->       {-          `lbl` can be temp one but we need to ensure that dsp label will stay@@ -1242,121 +1363,152 @@          optional `_` (underscore) because this is how you mark non-temp symbols          on some platforms (Darwin)       -}-      maybe_underscore $ text "dsp_" <> pprCLabel dflags lbl <> text "_dsp"+      maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp" -   (StringLitLabel u)-      | useNCG-      -> pprUniqueAlways u <> ptext (sLit "_str")+   StringLitLabel u+      -> maybe_underscore $ pprUniqueAlways u <> ptext (sLit "_str") -   lbl -> getPprStyle $ \sty ->-            if useNCG && asmStyle sty-            then maybe_underscore $ pprAsmCLbl lbl-            else pprCLbl platform lbl+   ForeignLabel fs (Just sz) _ _+      | AsmStyle <- sty+      , OSMinGW32 <- platformOS platform+      -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.+         -- (The C compiler does this itself).+         maybe_underscore $ ftext fs <> char '@' <> int sz -  where-    platform = targetPlatform dflags-    useNCG   = hscTarget dflags == HscAsm+   ForeignLabel fs _ _ _+      -> maybe_underscore $ ftext fs -    maybe_underscore :: SDoc -> SDoc-    maybe_underscore doc =-      if platformLeadingUnderscore platform-      then pp_cSEP <> doc-      else doc -    pprAsmCLbl (ForeignLabel fs (Just sz) _ _)-     | platformOS platform == OSMinGW32-        -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.-        -- (The C compiler does this itself).-        = ftext fs <> char '@' <> int sz-    pprAsmCLbl lbl = pprCLbl platform lbl+   IdLabel name _cafs flavor -> case sty of+      AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor+                   where+                      isRandomGenerated = not (isExternalName name)+                      internalNamePrefix =+                         if isRandomGenerated+                            then ptext (asmTempLabelPrefix platform)+                            else empty+      CStyle   -> ppr name <> ppIdFlavor flavor -pprCLbl :: Platform -> CLabel -> SDoc-pprCLbl platform = \case-   (StringLitLabel u)   -> pprUniqueAlways u <> text "_str"-   (SRTLabel u)         -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"-   (LargeBitmapLabel u) -> tempLabelPrefixOrUnderscore platform-                           <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"-                           -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')-                           -- until that gets resolved we'll just force them to start-                           -- with a letter so the label will be legal assembly code.+   SRTLabel u+      -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt" -   (CmmLabel _ _ str CmmCode)     -> ftext str-   (CmmLabel _ _ str CmmData)     -> ftext str-   (CmmLabel _ _ str CmmPrimCall) -> ftext str+   RtsLabel (RtsApFast (NonDetFastString str))+      -> maybe_underscore $ ftext str <> text "_fast" -   (LocalBlockLabel u) -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u+   RtsLabel (RtsSelectorInfoTable upd_reqd offset)+      -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),+                                  ptext (if upd_reqd+                                         then (sLit "_upd_info")+                                         else (sLit "_noupd_info"))+                                 ] -   (RtsLabel (RtsApFast str)) -> ftext str <> text "_fast"+   RtsLabel (RtsSelectorEntry upd_reqd offset)+      -> maybe_underscore $ hcat [text "stg_sel_", text (show offset),+                                        ptext (if upd_reqd+                                                then (sLit "_upd_entry")+                                                else (sLit "_noupd_entry"))+                                 ] -   (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) ->-    hcat [text "stg_sel_", text (show offset),-          ptext (if upd_reqd-                 then (sLit "_upd_info")-                 else (sLit "_noupd_info"))-        ]+   RtsLabel (RtsApInfoTable upd_reqd arity)+      -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),+                                        ptext (if upd_reqd+                                                then (sLit "_upd_info")+                                                else (sLit "_noupd_info"))+                                 ] -   (RtsLabel (RtsSelectorEntry upd_reqd offset)) ->-    hcat [text "stg_sel_", text (show offset),-                ptext (if upd_reqd-                        then (sLit "_upd_entry")-                        else (sLit "_noupd_entry"))-        ]+   RtsLabel (RtsApEntry upd_reqd arity)+      -> maybe_underscore $ hcat [text "stg_ap_", text (show arity),+                                        ptext (if upd_reqd+                                                then (sLit "_upd_entry")+                                                else (sLit "_noupd_entry"))+                                 ] -   (RtsLabel (RtsApInfoTable upd_reqd arity)) ->-    hcat [text "stg_ap_", text (show arity),-                ptext (if upd_reqd-                        then (sLit "_upd_info")-                        else (sLit "_noupd_info"))-        ]+   RtsLabel (RtsPrimOp primop)+      -> maybe_underscore $ text "stg_" <> ppr primop -   (RtsLabel (RtsApEntry upd_reqd arity)) ->-    hcat [text "stg_ap_", text (show arity),-                ptext (if upd_reqd-                        then (sLit "_upd_entry")-                        else (sLit "_noupd_entry"))-        ]+   RtsLabel (RtsSlowFastTickyCtr pat)+      -> maybe_underscore $ text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr") -   (CmmLabel _ _ fs CmmInfo)    -> ftext fs <> text "_info"-   (CmmLabel _ _ fs CmmEntry)   -> ftext fs <> text "_entry"-   (CmmLabel _ _ fs CmmRetInfo) -> ftext fs <> text "_info"-   (CmmLabel _ _ fs CmmRet)     -> ftext fs <> text "_ret"-   (CmmLabel _ _ fs CmmClosure) -> ftext fs <> text "_closure"+   LargeBitmapLabel u+      -> maybe_underscore $ tempLabelPrefixOrUnderscore platform+                            <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"+                            -- Some bitmaps for tuple constructors have a numeric tag (e.g. '7')+                            -- until that gets resolved we'll just force them to start+                            -- with a letter so the label will be legal assembly code. -   (RtsLabel (RtsPrimOp primop)) -> text "stg_" <> ppr primop-   (RtsLabel (RtsSlowFastTickyCtr pat)) ->-      text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")+   HpcTicksLabel mod+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc") -   (ForeignLabel str _ _ _) -> ftext str+   CC_Label cc   -> maybe_underscore $ ppr cc+   CCS_Label ccs -> maybe_underscore $ ppr ccs+   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe") -   (IdLabel name _cafs flavor) -> internalNamePrefix platform name <> ppr name <> ppIdFlavor flavor -   (CC_Label cc)       -> ppr cc-   (CCS_Label ccs)     -> ppr ccs-   (HpcTicksLabel mod) -> text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")+   CmmLabel _ _ fs CmmCode     -> maybe_underscore $ ftext fs+   CmmLabel _ _ fs CmmData     -> maybe_underscore $ ftext fs+   CmmLabel _ _ fs CmmPrimCall -> maybe_underscore $ ftext fs+   CmmLabel _ _ fs CmmInfo     -> maybe_underscore $ ftext fs <> text "_info"+   CmmLabel _ _ fs CmmEntry    -> maybe_underscore $ ftext fs <> text "_entry"+   CmmLabel _ _ fs CmmRetInfo  -> maybe_underscore $ ftext fs <> text "_info"+   CmmLabel _ _ fs CmmRet      -> maybe_underscore $ ftext fs <> text "_ret"+   CmmLabel _ _ fs CmmClosure  -> maybe_underscore $ ftext fs <> text "_closure" -   (AsmTempLabel {})        -> panic "pprCLbl AsmTempLabel"-   (AsmTempDerivedLabel {}) -> panic "pprCLbl AsmTempDerivedLabel"-   (DynamicLinkerLabel {})  -> panic "pprCLbl DynamicLinkerLabel"-   (PicBaseLabel {})        -> panic "pprCLbl PicBaseLabel"-   (DeadStripPreventer {})  -> panic "pprCLbl DeadStripPreventer"+-- Note [Internal proc labels]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Some tools (e.g. the `perf` utility on Linux) rely on the symbol table+-- for resolution of function names. To help these tools we provide the+-- (enabled by default) -fexpose-all-symbols flag which causes GHC to produce+-- symbols even for symbols with are internal to a module (although such+-- symbols will have only local linkage).+--+-- Note that these labels are *not* referred to by code. They are strictly for+-- diagnostics purposes.+--+-- To avoid confusion, it is desirable to add a module-qualifier to the+-- symbol name. However, the Name type's Internal constructor doesn't carry+-- knowledge of the current Module. Consequently, we have to pass this around+-- explicitly. -ppIdFlavor :: IdLabelInfo -> SDoc-ppIdFlavor x = pp_cSEP <> text-               (case x of-                       Closure          -> "closure"-                       InfoTable        -> "info"-                       LocalInfoTable   -> "info"-                       Entry            -> "entry"-                       LocalEntry       -> "entry"-                       Slow             -> "slow"-                       RednCounts       -> "ct"-                       ConEntry         -> "con_entry"-                       ConInfoTable     -> "con_info"-                       ClosureTable     -> "closure_tbl"-                       Bytes            -> "bytes"-                       BlockInfoTable   -> "info"-                      )+-- | Generate a label for a procedure internal to a module (if+-- 'Opt_ExposeAllSymbols' is enabled).+-- See Note [Internal proc labels].+ppInternalProcLabel :: Module     -- ^ the current module+                    -> CLabel+                    -> Maybe SDoc -- ^ the internal proc label+ppInternalProcLabel this_mod (IdLabel nm _ flavour)+  | isInternalName nm+  = Just+     $ text "_" <> ppr this_mod+    <> char '_'+    <> ztext (zEncodeFS (occNameFS (occName nm)))+    <> char '_'+    <> pprUniqueAlways (getUnique nm)+    <> ppIdFlavor flavour+ppInternalProcLabel _ _ = Nothing +ppIdFlavor :: IdLabelInfo -> SDoc+ppIdFlavor x = pp_cSEP <> case x of+   Closure          -> text "closure"+   InfoTable        -> text "info"+   LocalInfoTable   -> text "info"+   Entry            -> text "entry"+   LocalEntry       -> text "entry"+   Slow             -> text "slow"+   RednCounts       -> text "ct"+   ConEntry loc      ->+      case loc of+        DefinitionSite -> text "con_entry"+        UsageSite m n ->+          ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry"+   ConInfoTable k   ->+    case k of+      DefinitionSite -> text "con_info"+      UsageSite m n ->+        ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info"+   ClosureTable     -> text "closure_tbl"+   Bytes            -> text "bytes"+   BlockInfoTable   -> text "info"  pp_cSEP :: SDoc pp_cSEP = char '_'@@ -1369,23 +1521,6 @@         ForeignLabelInThisPackage       -> parens $ text "this package"         ForeignLabelInExternalPackage   -> parens $ text "external package" -internalNamePrefix :: Platform -> Name -> SDoc-internalNamePrefix platform name = getPprStyle $ \ sty ->-  if asmStyle sty && isRandomGenerated then-      ptext (asmTempLabelPrefix platform)-  else-    empty-  where-    isRandomGenerated = not $ isExternalName name--tempLabelPrefixOrUnderscore :: Platform -> SDoc-tempLabelPrefixOrUnderscore platform =-  getPprStyle $ \ sty ->-   if asmStyle sty then-      ptext (asmTempLabelPrefix platform)-   else-      char '_'- -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. @@ -1395,32 +1530,33 @@     OSAIX    -> sLit "__L" -- follow IBM XL C's convention     _        -> sLit ".L" -pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc-pprDynamicLinkerAsmLabel platform dllInfo lbl =+pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc+pprDynamicLinkerAsmLabel platform dllInfo ppLbl =     case platformOS platform of       OSDarwin         | platformArch platform == ArchX86_64 ->           case dllInfo of-            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"-            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"-            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"-            GotSymbolOffset -> ppr lbl+            CodeStub        -> char 'L' <> ppLbl <> text "$stub"+            SymbolPtr       -> char 'L' <> ppLbl <> text "$non_lazy_ptr"+            GotSymbolPtr    -> ppLbl <> text "@GOTPCREL"+            GotSymbolOffset -> ppLbl+        | platformArch platform == ArchAArch64 -> ppLbl         | otherwise ->           case dllInfo of-            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"-            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+            CodeStub  -> char 'L' <> ppLbl <> text "$stub"+            SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"             _         -> panic "pprDynamicLinkerAsmLabel"        OSAIX ->           case dllInfo of-            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention+            SymbolPtr -> text "LC.." <> ppLbl -- GCC's naming convention             _         -> panic "pprDynamicLinkerAsmLabel"        _ | osElfTarget (platformOS platform) -> elfLabel        OSMinGW32 ->           case dllInfo of-            SymbolPtr -> text "__imp_" <> ppr lbl+            SymbolPtr -> text "__imp_" <> ppLbl             _         -> panic "pprDynamicLinkerAsmLabel"        _ -> panic "pprDynamicLinkerAsmLabel"@@ -1429,32 +1565,35 @@       | platformArch platform == ArchPPC       = case dllInfo of           CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]-                       ppr lbl <> text "+32768@plt"-          SymbolPtr -> text ".LC_" <> ppr lbl+                       ppLbl <> text "+32768@plt"+          SymbolPtr -> text ".LC_" <> ppLbl           _         -> panic "pprDynamicLinkerAsmLabel" +      | platformArch platform == ArchAArch64+      = ppLbl++       | platformArch platform == ArchX86_64       = case dllInfo of-          CodeStub        -> ppr lbl <> text "@plt"-          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"-          GotSymbolOffset -> ppr lbl-          SymbolPtr       -> text ".LC_" <> ppr lbl+          CodeStub        -> ppLbl <> text "@plt"+          GotSymbolPtr    -> ppLbl <> text "@gotpcrel"+          GotSymbolOffset -> ppLbl+          SymbolPtr       -> text ".LC_" <> ppLbl        | platformArch platform == ArchPPC_64 ELF_V1         || platformArch platform == ArchPPC_64 ELF_V2       = case dllInfo of-          GotSymbolPtr    -> text ".LC_"  <> ppr lbl-                                  <> text "@toc"-          GotSymbolOffset -> ppr lbl-          SymbolPtr       -> text ".LC_" <> ppr lbl+          GotSymbolPtr    -> text ".LC_"  <> ppLbl <> text "@toc"+          GotSymbolOffset -> ppLbl+          SymbolPtr       -> text ".LC_" <> ppLbl           _               -> panic "pprDynamicLinkerAsmLabel"        | otherwise       = case dllInfo of-          CodeStub        -> ppr lbl <> text "@plt"-          SymbolPtr       -> text ".LC_" <> ppr lbl-          GotSymbolPtr    -> ppr lbl <> text "@got"-          GotSymbolOffset -> ppr lbl <> text "@gotoff"+          CodeStub        -> ppLbl <> text "@plt"+          SymbolPtr       -> text ".LC_" <> ppLbl+          GotSymbolPtr    -> ppLbl <> text "@got"+          GotSymbolOffset -> ppLbl <> text "@gotoff"  -- Figure out whether `symbol` may serve as an alias -- to `target` within one compilation unit.@@ -1570,12 +1709,12 @@  The emitted assembly is -#### INDIRECTEE+==== INDIRECTEE a1_rXq_closure:                         -- module local haskell value         .quad   GHC.Types.I#_con_info   -- an Int         .quad   42 -#### BEFORE+==== BEFORE .globl T15155.a_closure                 -- exported newtype wrapped value T15155.a_closure:         .quad   stg_IND_STATIC_info     -- the closure info@@ -1583,7 +1722,7 @@         .quad   0         .quad   0 -#### AFTER+==== AFTER .globl T15155.a_closure                 -- exported newtype wrapped value .equiv a1_rXq_closure,T15155.a_closure  -- both are shared

GHC/Cmm/CallConv.hs view

@@ -2,10 +2,12 @@   ParamLocation(..),   assignArgumentsPos,   assignStack,-  realArgRegsCover+  realArgRegsCover,+  tupleRegsCover ) where  import GHC.Prelude+import Data.List (nub)  import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout@@ -14,7 +16,9 @@  import GHC.Driver.Session import GHC.Platform+import GHC.Platform.Profile import GHC.Utils.Outputable+import GHC.Utils.Panic  -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention.@@ -31,7 +35,7 @@ -- Given a list of arguments, and a function that tells their types, -- return a list showing where each argument is passed ---assignArgumentsPos :: DynFlags+assignArgumentsPos :: Profile                    -> ByteOff           -- stack offset to start with                    -> Convention                    -> (a -> CmmType)    -- how to get a type from an arg@@ -41,16 +45,16 @@                       , [(a, ParamLocation)] -- args and locations                       ) -assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)+assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)     where-      platform = targetPlatform dflags+      platform = profilePlatform profile       regs = case (reps, conv) of-               (_,   NativeNodeCall)   -> getRegsWithNode dflags-               (_,   NativeDirectCall) -> getRegsWithoutNode dflags-               ([_], NativeReturn)     -> allRegs dflags-               (_,   NativeReturn)     -> getRegsWithNode dflags+               (_,   NativeNodeCall)   -> getRegsWithNode platform+               (_,   NativeDirectCall) -> getRegsWithoutNode platform+               ([_], NativeReturn)     -> allRegs platform+               (_,   NativeReturn)     -> getRegsWithNode platform                -- GC calling convention *must* put values in registers-               (_,   GC)               -> allRegs dflags+               (_,   GC)               -> allRegs platform                (_,   Slow)             -> nodeOnly       -- The calling conventions first assign arguments to registers,       -- then switch to the stack when we first run out of registers@@ -67,11 +71,11 @@                                     | otherwise      = int         where vec = case (w, regs) of                       (W128, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))+                          | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))                       (W256, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))+                          | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))                       (W512, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))+                          | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))                       _ -> (assts, (r:rs))               float = case (w, regs) of                         (W32, (vs, fs, ds, ls, s:ss))@@ -93,8 +97,8 @@               k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'               ty = arg_ty r               w  = typeWidth ty-              gcp | isGcPtrType ty = VGcPtr-                  | otherwise      = VNonGcPtr+              !gcp | isGcPtrType ty = VGcPtr+                   | otherwise      = VNonGcPtr               passFloatInXmm = passFloatArgsInXmm platform  passFloatArgsInXmm :: Platform -> Bool@@ -107,7 +111,7 @@ -- support vector registers in its calling convention. However, this has now -- been fixed. This function remains only as a convenient way to re-enable -- spilling when debugging code generation.-passVectorInReg :: Width -> DynFlags -> Bool+passVectorInReg :: Width -> Profile -> Bool passVectorInReg _ _ = True  assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]@@ -142,56 +146,57 @@ -- We take these register supplies from the *real* registers, i.e. those -- that are guaranteed to map to machine registers. -getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs-getRegsWithoutNode dflags =-  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)-  , realFloatRegs dflags-  , realDoubleRegs dflags-  , realLongRegs dflags-  , realXmmRegNos dflags)+getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs+getRegsWithoutNode platform =+  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)+  , realFloatRegs platform+  , realDoubleRegs platform+  , realLongRegs platform+  , realXmmRegNos platform)  -- getRegsWithNode uses R1/node even if it isn't a register-getRegsWithNode dflags =-  ( if null (realVanillaRegs dflags)+getRegsWithNode platform =+  ( if null (realVanillaRegs platform)     then [VanillaReg 1]-    else realVanillaRegs dflags-  , realFloatRegs dflags-  , realDoubleRegs dflags-  , realLongRegs dflags-  , realXmmRegNos dflags)+    else realVanillaRegs platform+  , realFloatRegs platform+  , realDoubleRegs platform+  , realLongRegs platform+  , realXmmRegNos platform) -allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]-allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]-allXmmRegs :: DynFlags -> [Int]+allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]+allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]+allXmmRegs :: Platform -> [Int] -allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)-allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)-allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)-allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)-allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)+allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))+allFloatRegs   platform = map FloatReg   $ regList (pc_MAX_Float_REG   (platformConstants platform))+allDoubleRegs  platform = map DoubleReg  $ regList (pc_MAX_Double_REG  (platformConstants platform))+allLongRegs    platform = map LongReg    $ regList (pc_MAX_Long_REG    (platformConstants platform))+allXmmRegs     platform =                  regList (pc_MAX_XMM_REG     (platformConstants platform)) -realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]-realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]-realXmmRegNos :: DynFlags -> [Int]+realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]+realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg] -realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)-realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)-realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)-realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)+realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))+realFloatRegs   platform = map FloatReg   $ regList (pc_MAX_Real_Float_REG   (platformConstants platform))+realDoubleRegs  platform = map DoubleReg  $ regList (pc_MAX_Real_Double_REG  (platformConstants platform))+realLongRegs    platform = map LongReg    $ regList (pc_MAX_Real_Long_REG    (platformConstants platform)) -realXmmRegNos dflags-    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)-    | otherwise            = []+realXmmRegNos :: Platform -> [Int]+realXmmRegNos platform+    | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))+    | otherwise              = []  regList :: Int -> [Int] regList n = [1 .. n] -allRegs :: DynFlags -> AvailRegs-allRegs dflags = (allVanillaRegs dflags,-                  allFloatRegs dflags,-                  allDoubleRegs dflags,-                  allLongRegs dflags,-                  allXmmRegs dflags)+allRegs :: Platform -> AvailRegs+allRegs platform = ( allVanillaRegs platform+                   , allFloatRegs   platform+                   , allDoubleRegs  platform+                   , allLongRegs    platform+                   , allXmmRegs     platform+                   )  nodeOnly :: AvailRegs nodeOnly = ([VanillaReg 1], [], [], [], [])@@ -201,18 +206,28 @@ -- now just x86-64, where Float and Double registers overlap---passing this set -- of registers is guaranteed to preserve the contents of all live registers. We -- only use this functionality in hand-written C-- code in the RTS.-realArgRegsCover :: DynFlags -> [GlobalReg]-realArgRegsCover dflags-    | passFloatArgsInXmm (targetPlatform dflags)-    = map ($VGcPtr) (realVanillaRegs dflags) ++-      realLongRegs dflags ++-      realDoubleRegs dflags -- we only need to save the low Double part of XMM registers.-                            -- Moreover, the NCG can't load/store full XMM-                            -- registers for now...+realArgRegsCover :: Platform -> [GlobalReg]+realArgRegsCover platform+    | passFloatArgsInXmm platform+    = map ($ VGcPtr) (realVanillaRegs platform) +++      realLongRegs platform +++      realDoubleRegs platform -- we only need to save the low Double part of XMM registers.+                              -- Moreover, the NCG can't load/store full XMM+                              -- registers for now...      | otherwise-    = map ($VGcPtr) (realVanillaRegs dflags) ++-      realFloatRegs dflags ++-      realDoubleRegs dflags ++-      realLongRegs dflags+    = map ($ VGcPtr) (realVanillaRegs platform) +++      realFloatRegs  platform +++      realDoubleRegs platform +++      realLongRegs   platform       -- we don't save XMM registers if they are not used for parameter passing++-- Like realArgRegsCover but always includes the node. This covers the real+-- and virtual registers used for unboxed tuples.+--+-- Note: if anything changes in how registers for unboxed tuples overlap,+--       make sure to also update GHC.StgToByteCode.layoutTuple.++tupleRegsCover :: Platform -> [GlobalReg]+tupleRegsCover platform =+  nub (VanillaReg 1 VGcPtr : realArgRegsCover platform)

GHC/Cmm/CommonBlockElim.hs view

@@ -18,12 +18,12 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections-import Data.Bits import Data.Maybe (mapMaybe) import qualified Data.List as List import Data.Word import qualified Data.Map as M import GHC.Utils.Outputable+import GHC.Utils.Panic import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique@@ -300,7 +300,7 @@              foldr blockCons code (map CmmTick ticks)  -- Group by [Label]--- See Note [Compressed TrieMap] in GHC.Core.Map about the usage of GenMap.+-- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap. groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])] groupByLabel =   go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))

GHC/Cmm/Dataflow/Collections.hs view

@@ -1,8 +1,6 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}  module GHC.Cmm.Dataflow.Collections     ( IsSet(..)

GHC/Cmm/Dataflow/Label.hs view

@@ -1,8 +1,8 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}  module GHC.Cmm.Dataflow.Label     ( Label@@ -43,6 +43,9 @@ instance Outputable Label where   ppr label = ppr (getUnique label) +instance OutputableP env Label where+  pdoc _ l = ppr l+ ----------------------------------------------------------------------------- -- LabelSet @@ -128,6 +131,9 @@ instance Outputable a => Outputable (LabelMap a) where   ppr = ppr . mapToList +instance OutputableP env a => OutputableP env (LabelMap a) where+  pdoc env = pdoc env . mapToList+ instance TrieMap LabelMap where   type Key LabelMap = Label   emptyTM = mapEmpty@@ -135,6 +141,7 @@   alterTM k f m = mapAlter f k m   foldTM k m z = mapFoldr k z m   mapTM f m = mapMap f m+  filterTM f m = mapFilter f m  ----------------------------------------------------------------------------- -- FactBase

GHC/Cmm/DebugBlock.hs view

@@ -1,6 +1,13 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE LambdaCase #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------@@ -32,12 +39,13 @@ import GHC.Cmm.CLabel import GHC.Cmm import GHC.Cmm.Utils-import GHC.Core import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Utils.Misc      ( seqList )  import GHC.Cmm.Dataflow.Block@@ -70,19 +78,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.@@ -109,7 +118,9 @@               -- recover by copying ticks below.               scp' | SubScope _ scp' <- scp      = scp'                    | CombinedScope scp' _ <- scp = scp'+#if __GLASGOW_HASKELL__ < 901                    | otherwise                   = panic "findP impossible"+#endif        scopeMap = foldr (uncurry insertMulti) Map.empty childScopes @@ -485,12 +496,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@,@@ -509,20 +520,24 @@                 | 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+  pdoc = pprUnwindExpr 0 +pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc+pprUnwindExpr p env = \case+  UwConst i     -> ppr i+  UwReg g 0     -> ppr g+  UwReg g x     -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))+  UwDeref e     -> char '*' <> pprUnwindExpr 3 env e+  UwLabel l     -> pdoc env l+  UwPlus e0 e1+   | p <= 0     -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1+  UwMinus e0 e1+   | p <= 0     -> pprUnwindExpr 1 env e0 <> char '-' <> pprUnwindExpr 1 env e1+  UwTimes e0 e1+   | p <= 1     -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1+  other         -> parens (pprUnwindExpr 0 env other)+ -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as -- possible.@@ -545,5 +560,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)

GHC/Cmm/Expr.hs view

@@ -38,8 +38,8 @@ import GHC.Cmm.CLabel import GHC.Cmm.MachOp import GHC.Cmm.Type-import GHC.Driver.Session-import GHC.Utils.Outputable (panic)+import GHC.Utils.Panic (panic)+import GHC.Utils.Outputable import GHC.Types.Unique  import Data.Set (Set)@@ -53,18 +53,19 @@ -----------------------------------------------------------------------------  data CmmExpr-  = CmmLit CmmLit               -- Literal+  = CmmLit !CmmLit               -- Literal   | CmmLoad !CmmExpr !CmmType   -- Read memory location   | CmmReg !CmmReg              -- Contents of register   | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)   | CmmStackSlot Area {-# UNPACK #-} !Int                                 -- addressing expression of a stack slot                                 -- See Note [CmmStackSlot aliasing]-  | CmmRegOff !CmmReg Int+  | CmmRegOff !CmmReg !Int         -- CmmRegOff reg i         --        ** is shorthand only, meaning **         -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]         --      where rep = typeWidth (cmmRegType reg)+  deriving Show  instance Eq CmmExpr where       -- Equality ignores the types   CmmLit l1          == CmmLit l2          = l1==l2@@ -78,7 +79,7 @@ data CmmReg   = CmmLocal  {-# UNPACK #-} !LocalReg   | CmmGlobal GlobalReg-  deriving( Eq, Ord )+  deriving( Eq, Ord, Show )  -- | A stack area is either the stack slot where a variable is spilled -- or the stack space where function arguments and results are passed.@@ -86,7 +87,7 @@   = Old            -- See Note [Old Area]   | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId                    -- See Note [Continuation BlockId] in GHC.Cmm.Node.-  deriving (Eq, Ord)+  deriving (Eq, Ord, Show)  {- Note [Old Area] ~~~~~~~~~~~~~~~~~~@@ -173,16 +174,16 @@ -}  data CmmLit-  = CmmInt !Integer  Width+  = CmmInt !Integer  !Width         -- Interpretation: the 2's complement representation of the value         -- is truncated to the specified size.  This is easier than trying         -- to keep the value within range, because we don't know whether         -- it will be used as a signed or unsigned value (the CmmType doesn't         -- distinguish between signed & unsigned).-  | CmmFloat  Rational Width+  | CmmFloat  Rational !Width   | CmmVec [CmmLit]                     -- Vector literal   | CmmLabel    CLabel                  -- Address of label-  | CmmLabelOff CLabel Int              -- Address of label + byte offset+  | CmmLabelOff CLabel !Int              -- Address of label + byte offset          -- Due to limitations in the C backend, the following         -- MUST ONLY be used inside the info table indicated by label2@@ -191,7 +192,7 @@         -- Don't use it at all unless tablesNextToCode.         -- It is also used inside the NCG during when generating         -- position-independent code.-  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset+  | CmmLabelDiffOff CLabel CLabel !Int !Width -- label1 - label2 + offset         -- In an expression, the width just has the effect of MO_SS_Conv         -- from wordWidth to the desired width.         --@@ -209,8 +210,18 @@                      -- During the stack-layout pass, CmmHighStackMark                      -- is replaced by a CmmInt for the actual number                      -- of bytes used-  deriving Eq+  deriving (Eq, Show) +instance Outputable CmmLit where+  ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w+  ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w+  ppr (CmmVec xs) = text "CmmVec" <+> ppr xs+  ppr (CmmLabel _) = text "CmmLabel"+  ppr (CmmLabelOff _ _) = text "CmmLabelOff"+  ppr (CmmLabelDiffOff _ _ _ _) = text "CmmLabelDiffOff"+  ppr (CmmBlock blk) = text "CmmBlock" <+> ppr blk+  ppr CmmHighStackMark = text "CmmHighStackMark"+ cmmExprType :: Platform -> CmmExpr -> CmmType cmmExprType platform = \case    (CmmLit lit)        -> cmmLitType platform lit@@ -265,10 +276,11 @@ -----------------------------------------------------------------------------  data LocalReg-  = LocalReg {-# UNPACK #-} !Unique CmmType+  = LocalReg {-# UNPACK #-} !Unique !CmmType     -- ^ Parameters:     --   1. Identifier     --   2. Type+  deriving Show  instance Eq LocalReg where   (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2@@ -331,17 +343,17 @@ regSetToList     = Set.toList  class Ord r => UserOfRegs r a where-  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b+  foldRegsUsed :: Platform -> (b -> r -> b) -> b -> a -> b  foldLocalRegsUsed :: UserOfRegs LocalReg a-                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+                  => Platform -> (b -> LocalReg -> b) -> b -> a -> b foldLocalRegsUsed = foldRegsUsed  class Ord r => DefinerOfRegs r a where-  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b+  foldRegsDefd :: Platform -> (b -> r -> b) -> b -> a -> b  foldLocalRegsDefd :: DefinerOfRegs LocalReg a-                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+                  => Platform -> (b -> LocalReg -> b) -> b -> a -> b foldLocalRegsDefd = foldRegsDefd  instance UserOfRegs LocalReg CmmReg where@@ -353,6 +365,7 @@     foldRegsDefd _ _ z (CmmGlobal _)  = z  instance UserOfRegs GlobalReg CmmReg where+    {-# INLINEABLE foldRegsUsed #-}     foldRegsUsed _ _ z (CmmLocal _)    = z     foldRegsUsed _ f z (CmmGlobal reg) = f z reg @@ -369,20 +382,21 @@ instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where   -- The (Ord r) in the context is necessary here   -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance-  foldRegsUsed dflags f !z e = expr z e+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed platform f !z e = expr z e     where expr z (CmmLit _)          = z-          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr-          expr z (CmmReg r)          = foldRegsUsed dflags f z r-          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs-          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r+          expr z (CmmLoad addr _)    = foldRegsUsed platform f z addr+          expr z (CmmReg r)          = foldRegsUsed platform f z r+          expr z (CmmMachOp _ exprs) = foldRegsUsed platform f z exprs+          expr z (CmmRegOff r _)     = foldRegsUsed platform f z r           expr z (CmmStackSlot _ _)  = z  instance UserOfRegs r a => UserOfRegs r [a] where-  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as+  foldRegsUsed platform f set as = foldl' (foldRegsUsed platform f) set as   {-# INLINABLE foldRegsUsed #-}  instance DefinerOfRegs r a => DefinerOfRegs r [a] where-  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as+  foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as   {-# INLINABLE foldRegsDefd #-}  -----------------------------------------------------------------------------@@ -510,6 +524,8 @@    PicBaseReg == PicBaseReg = True    _r1 == _r2 = False +-- NOTE: this Ord instance affects the tuple layout in GHCi, see+--       Note [GHCi tuple layout] instance Ord GlobalReg where    compare (VanillaReg i _) (VanillaReg j _) = compare i j      -- Ignore type when seeking clashes

GHC/Cmm/Graph.hs view

@@ -23,6 +23,8 @@  import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>) +import GHC.Platform.Profile+ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.CallConv@@ -31,7 +33,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.ForeignCall import GHC.Data.OrdList@@ -196,28 +197,28 @@ mkStore  l r  = mkMiddle $ CmmStore  l r  ---------- Control transfer-mkJump          :: DynFlags -> Convention -> CmmExpr+mkJump          :: Profile -> Convention -> CmmExpr                 -> [CmmExpr]                 -> UpdFrameOffset                 -> CmmAGraph-mkJump dflags conv e actuals updfr_off =-  lastWithArgs dflags Jump Old conv actuals updfr_off $+mkJump profile conv e actuals updfr_off =+  lastWithArgs profile Jump Old conv actuals updfr_off $     toCall e Nothing updfr_off 0  -- | A jump where the caller says what the live GlobalRegs are.  Used -- for low-level hand-written Cmm.-mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]                 -> CmmAGraph-mkRawJump dflags e updfr_off vols =-  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $+mkRawJump profile e updfr_off vols =+  lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $     \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols  -mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]+mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]                 -> UpdFrameOffset -> [CmmExpr]                 -> CmmAGraph-mkJumpExtra dflags conv e actuals updfr_off extra_stack =-  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $+mkJumpExtra profile conv e actuals updfr_off extra_stack =+  lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $     toCall e Nothing updfr_off 0  mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph@@ -227,43 +228,43 @@ mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph mkSwitch e tbl   = mkLast $ CmmSwitch e tbl -mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset+mkReturn        :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset                 -> CmmAGraph-mkReturn dflags e actuals updfr_off =-  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $+mkReturn profile e actuals updfr_off =+  lastWithArgs profile Ret  Old NativeReturn actuals updfr_off $     toCall e Nothing updfr_off 0  mkBranch        :: BlockId -> CmmAGraph mkBranch bid     = mkLast (CmmBranch bid) -mkFinalCall   :: DynFlags+mkFinalCall   :: Profile               -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset               -> CmmAGraph-mkFinalCall dflags f _ actuals updfr_off =-  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $+mkFinalCall profile f _ actuals updfr_off =+  lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $     toCall f Nothing updfr_off 0 -mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]                 -> BlockId                 -> ByteOff                 -> UpdFrameOffset                 -> [CmmExpr]                 -> CmmAGraph-mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do-  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals-     updfr_off extra_stack $-       toCall f (Just ret_lbl) updfr_off ret_off+mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack =+  lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals+    updfr_off extra_stack $+      toCall f (Just ret_lbl) updfr_off ret_off  -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be -- already on the stack).-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]                 -> BlockId                 -> ByteOff                 -> UpdFrameOffset                 -> CmmAGraph-mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do-  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $-       toCall f (Just ret_lbl) updfr_off ret_off+mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off =+  lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $+    toCall f (Just ret_lbl) updfr_off ret_off  mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as@@ -292,25 +293,25 @@ -- variables in their spill slots.  Therefore, for copying arguments -- and results, we provide different functions to pass the arguments -- in an overflow area and to pass them in spill slots.-copyInOflow  :: DynFlags -> Convention -> Area+copyInOflow  :: Profile -> Convention -> Area              -> [CmmFormal]              -> [CmmFormal]              -> (Int, [GlobalReg], CmmAGraph) -copyInOflow dflags conv area formals extra_stk+copyInOflow profile conv area formals extra_stk   = (offset, gregs, catAGraphs $ map mkMiddle nodes)-  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk+  where (offset, gregs, nodes) = copyIn profile conv area formals extra_stk  -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments.-copyIn :: DynFlags -> Convention -> Area+copyIn :: Profile -> Convention -> Area        -> [CmmFormal]        -> [CmmFormal]        -> (ByteOff, [GlobalReg], [CmmNode O O])-copyIn dflags conv area formals extra_stk+copyIn profile conv area formals extra_stk   = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     -- See Note [Width of parameters]     ci (reg, RegisterParam r@(VanillaReg {})) =         let local = CmmLocal reg@@ -346,7 +347,7 @@      (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk -    (stk_size, args) = assignArgumentsPos dflags stk_off conv+    (stk_size, args) = assignArgumentsPos profile stk_off conv                                           localRegType formals  -- Factoring out the common parts of the copyout functions yielded something@@ -354,7 +355,7 @@  data Transfer = Call | JumpRet | Jump | Ret deriving Eq -copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]+copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]              -> UpdFrameOffset              -> [CmmExpr] -- extra stack args              -> (Int, [GlobalReg], CmmAGraph)@@ -368,10 +369,10 @@ -- the info table for return and adjust the offsets of the other -- parameters.  If this is a call instruction, we adjust the offsets -- of the other parameters.-copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff+copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff   = (stk_size, regs, graph)   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)      -- See Note [Width of parameters]@@ -419,7 +420,7 @@        assignStack platform init_offset (cmmExprType platform) extra_stack_stuff      args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it-    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv+    (stk_size, args) = assignArgumentsPos profile extra_stack_off conv                                           (cmmExprType platform) actuals  @@ -450,29 +451,29 @@ -- https://github.com/ghc-proposals/ghc-proposals/pull/74  -mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]+mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]             -> (Int, [GlobalReg], CmmAGraph)-mkCallEntry dflags conv formals extra_stk-  = copyInOflow dflags conv Old formals extra_stk+mkCallEntry profile conv formals extra_stk+  = copyInOflow profile conv Old formals extra_stk -lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]+lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]              -> UpdFrameOffset              -> (ByteOff -> [GlobalReg] -> CmmAGraph)              -> CmmAGraph-lastWithArgs dflags transfer area conv actuals updfr_off last =-  lastWithArgsAndExtraStack dflags transfer area conv actuals+lastWithArgs profile transfer area conv actuals updfr_off last =+  lastWithArgsAndExtraStack profile transfer area conv actuals                             updfr_off noExtraStack last -lastWithArgsAndExtraStack :: DynFlags+lastWithArgsAndExtraStack :: Profile              -> Transfer -> Area -> Convention -> [CmmExpr]              -> UpdFrameOffset -> [CmmExpr]              -> (ByteOff -> [GlobalReg] -> CmmAGraph)              -> CmmAGraph-lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off+lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off                           extra_stack last =   copies <*> last outArgs regs  where-  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals+  (outArgs, regs, copies) = copyOutOflow profile conv transfer area actuals                                updfr_off extra_stack

GHC/Cmm/Info.hs view

@@ -5,6 +5,7 @@   srtEscape,    -- info table accessors+  PtrOpts (..),   closureInfoPtr,   entryCode,   getConstrTag,@@ -45,17 +46,18 @@ import GHC.Cmm.Dataflow.Collections  import GHC.Platform+import GHC.Platform.Profile import GHC.Data.Maybe import GHC.Driver.Session import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic import GHC.Types.Unique.Supply+import GHC.Utils.Logger import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable  import Data.ByteString (ByteString)-import Data.Bits  -- When we split at proc points, we need an empty info table. mkEmptyContInfoTable :: CLabel -> CmmInfoTable@@ -66,22 +68,23 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a+cmmToRawCmm :: Logger -> DynFlags -> Stream IO CmmGroupSRTs a             -> IO (Stream IO RawCmmGroup a)-cmmToRawCmm dflags cmms-  = do { uniqs <- mkSplitUniqSupply 'i'-       ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl])-             do_one uniqs cmm =+cmmToRawCmm logger dflags cmms+  = do {+       ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]+             do_one cmm = do+               uniqs <- mkSplitUniqSupply 'i'                -- NB. strictness fixes a space leak.  DO NOT REMOVE.-               withTimingSilent dflags (text "Cmm -> Raw Cmm")-                                forceRes $-                 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of-                   (b,uniqs') -> return (uniqs',b)-       ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)+               withTimingSilent logger dflags (text "Cmm -> Raw Cmm")+                          (\x -> seqList x ())+                  -- TODO: It might be better to make `mkInfoTable` run in+                  -- IO as well so we don't have to pass around+                  -- a UniqSupply (see #16843)+                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable dflags) cmm)+       ; return (Stream.mapM do_one cmms)        } -    where forceRes (uniqs, rawcmms) =-            uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms  -- Make a concrete info table, represented as a list of CmmStatic -- (it can't be simply a list of Word, because the SRT field is@@ -251,7 +254,7 @@                            ++ [ liveness_lit, slow_entry ]            ; return (Nothing, Nothing, extra_bits, liveness_data) }       where-        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)+        slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)         srt_lit = case srt_label of                     []          -> mkIntCLit platform 0                     (lit:_rest) -> ASSERT( null _rest ) lit@@ -367,7 +370,7 @@                      [b] -> b                      _   -> panic "mkLiveness"     bitmap_word = toStgWord platform (fromIntegral n_bits)-              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)+              .|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform))      lits = mkWordCLit platform (fromIntegral n_bits)          : map (mkStgWordCLit platform) bitmap@@ -441,20 +444,25 @@ -- ------------------------------------------------------------------------- +data PtrOpts = PtrOpts+   { po_profile     :: !Profile -- ^ Platform profile+   , po_align_check :: !Bool    -- ^ Insert alignment check (cf @-falignment-sanitisation@)+   }+ -- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is -- enabled.-wordAligned :: DynFlags -> CmmExpr -> CmmExpr-wordAligned dflags e-  | gopt Opt_AlignmentSanitisation dflags+wordAligned :: PtrOpts -> CmmExpr -> CmmExpr+wordAligned opts e+  | po_align_check opts   = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]   | otherwise   = e-  where platform = targetPlatform dflags+  where platform = profilePlatform (po_profile opts) -closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer and returns the info table pointer-closureInfoPtr dflags e =-    CmmLoad (wordAligned dflags e) (bWord (targetPlatform dflags))+-- | Takes a closure pointer and returns the info table pointer+closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr+closureInfoPtr opts e =+    CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts)))  -- | Takes an info pointer (the first word of a closure) and returns its entry -- code@@ -464,94 +472,95 @@       then e       else CmmLoad e (bWord platform) -getConstrTag :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer, and return the *zero-indexed*+-- | Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs).-getConstrTag dflags closure_ptr-  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag dflags info_table]+getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr+getConstrTag opts closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table]   where-    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)-    platform = targetPlatform dflags+    info_table = infoTable profile (closureInfoPtr opts closure_ptr)+    platform   = profilePlatform profile+    profile    = po_profile opts -cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr--- Takes a closure pointer, and return the closure type+-- | Takes a closure pointer, and return the closure type -- obtained from the info table-cmmGetClosureType dflags closure_ptr-  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType dflags info_table]+cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr+cmmGetClosureType opts closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table]   where-    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)-    platform = targetPlatform dflags+    info_table = infoTable profile (closureInfoPtr opts closure_ptr)+    platform   = profilePlatform profile+    profile    = po_profile opts -infoTable :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info pointer (the first word of a closure)+-- | Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present)-infoTable dflags info_ptr-  | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags)+infoTable :: Profile -> CmmExpr -> CmmExpr+infoTable profile info_ptr+  | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile)   | otherwise                         = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer-  where platform = targetPlatform dflags+  where platform = profilePlatform profile -infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the constr tag+-- | Takes an info table pointer (from infoTable) and returns the constr tag -- field of the info table (same as the srt_bitmap field)+infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr infoTableConstrTag = infoTableSrtBitmap -infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the srt_bitmap+-- | Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table-infoTableSrtBitmap dflags info_tbl-  = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord platform)-    where platform = targetPlatform dflags+infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr+infoTableSrtBitmap profile info_tbl+  = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)+    where platform = profilePlatform profile -infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr--- Takes an info table pointer (from infoTable) and returns the closure type+-- | Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table.-infoTableClosureType dflags info_tbl-  = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset dflags)) (bHalfWord platform)-    where platform = targetPlatform dflags+infoTableClosureType :: Profile -> CmmExpr -> CmmExpr+infoTableClosureType profile info_tbl+  = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)+    where platform = profilePlatform profile -infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr-infoTablePtrs dflags info_tbl-  = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset dflags)) (bHalfWord platform)-    where platform = targetPlatform dflags+infoTablePtrs :: Profile -> CmmExpr -> CmmExpr+infoTablePtrs profile info_tbl+  = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)+    where platform = profilePlatform profile -infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr-infoTableNonPtrs dflags info_tbl-  = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset dflags)) (bHalfWord platform)-    where platform = targetPlatform dflags+infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr+infoTableNonPtrs profile info_tbl+  = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)+    where platform = profilePlatform profile -funInfoTable :: DynFlags -> CmmExpr -> CmmExpr--- Takes the info pointer of a function,--- and returns a pointer to the first word of the StgFunInfoExtra struct--- in the info table.-funInfoTable dflags info_ptr+-- | Takes the info pointer of a function, and returns a pointer to the first+-- word of the StgFunInfoExtra struct in the info table.+funInfoTable :: Profile -> CmmExpr -> CmmExpr+funInfoTable profile info_ptr   | platformTablesNextToCode platform-  = cmmOffsetB platform info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)+  = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile - pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform))   | otherwise-  = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW dflags)+  = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile)                                   -- Past the entry code pointer   where-    platform = targetPlatform dflags+    platform = profilePlatform profile --- Takes the info pointer of a function, returns the function's arity-funInfoArity :: DynFlags -> CmmExpr -> CmmExpr-funInfoArity dflags iptr+-- | Takes the info pointer of a function, returns the function's arity+funInfoArity :: Profile -> CmmExpr -> CmmExpr+funInfoArity profile iptr   = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))   where-   platform = targetPlatform dflags-   fun_info = funInfoTable dflags iptr+   platform = profilePlatform profile+   fun_info = funInfoTable profile iptr    rep = cmmBits (widthFromBytes rep_bytes)    tablesNextToCode = platformTablesNextToCode platform     (rep_bytes, offset)     | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc-                         , oFFSET_StgFunInfoExtraRev_arity dflags )+                         , pc_OFFSET_StgFunInfoExtraRev_arity pc )     | otherwise        = ( pc_REP_StgFunInfoExtraFwd_arity pc-                         , oFFSET_StgFunInfoExtraFwd_arity dflags )+                         , pc_OFFSET_StgFunInfoExtraFwd_arity pc ) -   pc = platformConstants dflags+   pc = platformConstants platform  ----------------------------------------------------------------------------- --@@ -559,13 +568,13 @@ -- ----------------------------------------------------------------------------- -stdInfoTableSizeW :: DynFlags -> WordOff+stdInfoTableSizeW :: Profile -> WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable-stdInfoTableSizeW dflags+stdInfoTableSizeW profile   = fixedInfoTableSizeW-  + if sccProfilingEnabled dflags+  + if profileIsProfiling profile        then profInfoTableSizeW        else 0 @@ -586,28 +595,24 @@   maxStdInfoTableSizeW   + 1 {- srt label -} -stdInfoTableSizeB  :: DynFlags -> ByteOff-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * platformWordSizeInBytes platform-   where platform = targetPlatform dflags+stdInfoTableSizeB  :: Profile -> ByteOff+stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile -stdSrtBitmapOffset :: DynFlags -> ByteOff--- Byte offset of the SRT bitmap half-word which is--- in the *higher-addressed* part of the type_lit-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - halfWordSize platform-   where platform = targetPlatform dflags+-- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed*+-- part of the type_lit+stdSrtBitmapOffset :: Profile -> ByteOff+stdSrtBitmapOffset profile = stdInfoTableSizeB profile - halfWordSize (profilePlatform profile) -stdClosureTypeOffset :: DynFlags -> ByteOff--- Byte offset of the closure type half-word-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - platformWordSizeInBytes platform-   where platform = targetPlatform dflags+-- | Byte offset of the closure type half-word+stdClosureTypeOffset :: Profile -> ByteOff+stdClosureTypeOffset profile = stdInfoTableSizeB profile - profileWordSizeInBytes profile -stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff-stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform-   where platform = targetPlatform dflags+stdPtrsOffset :: Profile -> ByteOff+stdPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile -stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * platformWordSizeInBytes platform + halfWordSize platform-   where platform = targetPlatform dflags+stdNonPtrsOffset :: Profile -> ByteOff+stdNonPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile+                                                     + halfWordSize (profilePlatform profile) -conInfoTableSizeB :: DynFlags -> Int-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + platformWordSizeInBytes platform-   where platform = targetPlatform dflags+conInfoTableSizeB :: Profile -> Int+conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile

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@@ -10,6 +17,9 @@  import GHC.Prelude hiding (succ) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Cmm.BlockId@@ -19,7 +29,6 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Unit.Module-import GHC.Platform import GHC.Data.Graph.Directed import GHC.Cmm.CLabel import GHC.Cmm@@ -27,12 +36,12 @@ import GHC.Driver.Session import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Runtime.Heap.Layout import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap-import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Config+import GHC.CmmToAsm  import Control.Monad import Data.Map.Strict (Map)@@ -432,7 +441,7 @@ are never CAFFY and never exported).  Not doing this caused #17947 where we analysed the function first mapped the-name to CAFFY. We then saw the ticky constructor, and becuase it has the same+name to CAFFY. We then saw the ticky constructor, and because it has the same Name as the function and is not CAFFY we overrode the CafInfo of the name as non-CAFFY. -}@@ -453,26 +462,31 @@ -- 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 -mkCAFLabel :: CLabel -> CAFLabel-mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)+mkCAFLabel :: Platform -> CLabel -> CAFLabel+mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)  -- 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 -addCafLabel :: CLabel -> CAFSet -> CAFSet-addCafLabel l s+addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet+addCafLabel platform l s   | Just _ <- hasHaskellName l-  , let caf_label = mkCAFLabel l+  , let caf_label = mkCAFLabel platform l     -- For imported Ids hasCAF will have accurate CafInfo     -- Locals are initialized as CAFFY. We turn labels with empty SRTs into     -- non-CAFFYs in doSRTs@@ -482,21 +496,20 @@   = s  cafAnalData-  :: CmmStatics+  :: Platform+  -> CmmStatics   -> CAFSet--cafAnalData (CmmStaticsRaw _lbl _data) =-    Set.empty--cafAnalData (CmmStatics _lbl _itbl _ccs payload) =-    foldl' analyzeStatic Set.empty payload-  where-    analyzeStatic s lit =-      case lit of-        CmmLabel c -> addCafLabel c s-        CmmLabelOff c _ -> addCafLabel c s-        CmmLabelDiffOff c1 c2 _ _ -> addCafLabel c1 $! addCafLabel c2 s-        _ -> s+cafAnalData platform st = case st of+   CmmStaticsRaw _lbl _data           -> Set.empty+   CmmStatics _lbl _itbl _ccs payload ->+       foldl' analyzeStatic Set.empty payload+     where+       analyzeStatic s lit =+         case lit of+           CmmLabel c -> addCafLabel platform c s+           CmmLabelOff c _ -> addCafLabel platform c s+           CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s+           _ -> s  -- | -- For each code block:@@ -506,16 +519,17 @@ -- This gives us a `CAFEnv`: a mapping from code block to sets of labels -- cafAnal-  :: LabelSet   -- The blocks representing continuations, ie. those+  :: Platform+  -> LabelSet   -- The blocks representing continuations, ie. those                 -- that will get RET info tables.  These labels will                 -- get their own SRTs, so we don't aggregate CAFs from                 -- references to these labels, we just use the label.   -> CLabel     -- The top label of the proc   -> CmmGraph   -> CAFEnv-cafAnal contLbls topLbl cmmGraph =+cafAnal platform contLbls topLbl cmmGraph =   analyzeCmmBwd cafLattice-    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty+    (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty   cafLattice :: DataflowLattice CAFSet@@ -526,8 +540,8 @@         in changedIf (Set.size new' > Set.size old) new'  -cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet-cafTransfers contLbls entry topLbl+cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet+cafTransfers platform contLbls entry topLbl   block@(BlockCC eNode middle xNode) fBase =     let joined :: CAFSet         joined = cafsInNode xNode $! live'@@ -545,11 +559,11 @@         successorFact s           -- If this is a loop back to the entry, we can refer to the           -- entry label.-          | s == entry = Just (addCafLabel topLbl Set.empty)+          | s == entry = Just (addCafLabel platform topLbl Set.empty)           -- If this is a continuation, we want to refer to the           -- SRT for the continuation's info table           | s `setMember` contLbls-          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))+          = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))           -- Otherwise, takes the CAF references from the destination           | otherwise           = lookupFact s fBase@@ -561,20 +575,20 @@         addCafExpr expr !set =           case expr of             CmmLit (CmmLabel c) ->-              addCafLabel c set+              addCafLabel platform c set             CmmLit (CmmLabelOff c _) ->-              addCafLabel c set+              addCafLabel platform c set             CmmLit (CmmLabelDiffOff c1 c2 _ _) ->-              addCafLabel c1 $! addCafLabel c2 set+              addCafLabel platform c1 $! addCafLabel platform c2 set             _ ->               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  @@ -595,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 =@@ -633,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@@ -648,35 +663,34 @@ --   where the label is --   - the info label for a continuation or dynamic closure --   - the closure label for a top-level function (not a CAF)-getLabelledBlocks :: CmmDecl -> [(SomeLabel, CAFLabel)]-getLabelledBlocks (CmmData _ (CmmStaticsRaw _ _)) =-  []-getLabelledBlocks (CmmData _ (CmmStatics lbl _ _ _)) =-  [ (DeclLabel lbl, mkCAFLabel lbl) ]-getLabelledBlocks (CmmProc top_info _ _ _) =-  [ (BlockLabel blockId, caf_lbl)-  | (blockId, info) <- mapToList (info_tbls top_info)-  , let rep = cit_rep info-  , not (isStaticRep rep) || not (isThunkRep rep)-  , let !caf_lbl = mkCAFLabel (cit_lbl info)-  ]+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]+getLabelledBlocks platform decl = case decl of+   CmmData _ (CmmStaticsRaw _ _)    -> []+   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]+   CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)+                                       | (blockId, info) <- mapToList (info_tbls top_info)+                                       , let rep = cit_rep info+                                       , not (isStaticRep rep) || not (isThunkRep rep)+                                       , let !caf_lbl = mkCAFLabel platform (cit_lbl info)+                                       ]  -- | Put the labelled blocks that we will be annotating with SRTs into -- dependency order.  This is so that we can process them one at a -- time, resolving references to earlier blocks to point to their -- SRTs. CAFs themselves are not included here; see getCAFs below. depAnalSRTs-  :: CAFEnv+  :: Platform+  -> CAFEnv   -> Map CLabel CAFSet -- CAFEnv for statics   -> [CmmDecl]   -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]-depAnalSRTs cafEnv cafEnv_static decls =-  srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$-                           text "nodes:" <+> ppr (map node_payload nodes) $$-                           text "graph:" <+> ppr graph) graph+depAnalSRTs platform cafEnv cafEnv_static decls =+  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 decls+  labelledBlocks = concatMap (getLabelledBlocks platform) decls   labelToBlock :: Map CAFLabel SomeLabel   labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks @@ -700,9 +714,9 @@ --    SRT, since the point of SRTs is to keep CAFs alive. --  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. --    instead we generate their SRTs after everything else.-getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]-getCAFs cafEnv decls =-  [ (g_entry g, mkCAFLabel topLbl, cafs)+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]+getCAFs platform cafEnv decls =+  [ (g_entry g, mkCAFLabel platform topLbl, cafs)   | CmmProc top_info topLbl _ g <- decls   , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]   , let rep = cit_rep info@@ -746,11 +760,11 @@     get_name (_l, Just _srt_entry) = Nothing  -- | resolve a CAFLabel to its SRTEntry using the SRTMap-resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry-resolveCAF srtMap lbl@(CAFLabel l) =-    srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret+resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry+resolveCAF platform srtMap lbl@(CAFLabel l) =+    srtTrace "resolveCAF" ("l:" <+> pdoc platform l <+> "resolved:" <+> pdoc platform ret) ret   where-    ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap+    ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap  -- | Attach SRTs to all info tables in the CmmDecls, and add SRT -- declarations to the ModuleSRTInfo.@@ -765,6 +779,8 @@ doSRTs dflags moduleSRTInfo procs data_ = do   us <- mkSplitUniqSupply 'u' +  let profile = targetProfile dflags+   -- Ignore the original grouping of decls, and combine all the   -- CAFEnvs into a single CAFEnv.   let static_data_env :: Map CLabel CAFSet@@ -774,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)@@ -788,6 +804,8 @@       decls = map snd data_ ++ concat procss       staticFuns = mapFromList (getStaticFuns decls) +      platform = targetPlatform dflags+   -- Put the decls in dependency order. Why? So that we can implement   -- [Inline] and [Filter].  If we need to refer to an SRT that has   -- a single entry, we use the entry itself, which means that we@@ -796,16 +814,16 @@   -- them.   let     sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]-    sccs = {-# SCC depAnalSRTs #-} depAnalSRTs cafEnv static_data_env decls+    sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls      cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]-    cafsWithSRTs = getCAFs cafEnv decls+    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.@@ -834,7 +852,7 @@     funSRTMap = mapFromList (concat funSRTs)     has_caf_refs' = or has_caf_refs     decls' =-      concatMap (updInfoSRTs dflags srtFieldMap funSRTMap has_caf_refs') decls+      concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls    -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are   -- not analysed in oneSRT so we never add entries for them to the SRTMap.@@ -850,12 +868,12 @@                           -- be CAFFY.                           -- See Note [Ticky labels in SRT analysis] above for                           -- why we exclude ticky labels here.-                          Map.insert (mkCAFLabel lbl) Nothing srtMap+                          Map.insert (mkCAFLabel platform lbl) Nothing srtMap                       | otherwise ->                           -- 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')@@ -928,7 +946,10 @@   topSRT <- get    let-    config = initConfig dflags+    this_mod = thisModule topSRT+    config = initNCGConfig dflags this_mod+    profile = targetProfile dflags+    platform = profilePlatform profile     srtMap = moduleSRTMap topSRT      blockids = getBlockLabels lbls@@ -947,7 +968,7 @@      -- Resolve references to their SRT entries     resolved :: [SRTEntry]-    resolved = mapMaybe (resolveCAF srtMap) (Set.toList nonRec)+    resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec)      -- The set of all SRTEntries in SRTs that we refer to from here.     allBelow =@@ -959,18 +980,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@@ -982,7 +1003,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 ->@@ -999,23 +1020,21 @@            in                state{ moduleSRTMap = srt_map } -    this_mod = thisModule topSRT-     allStaticData =       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     -- We're going to build an SRT for this group, which should include function     -- references in the group. See Note [recursive SRTs].     let allBelow_funs =-          Set.fromList (map (SRTEntry . toClosureLbl) otherFunLabels)+          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 @@ -1028,11 +1047,11 @@           -- when dynamic linking is used we cannot guarantee that the offset           -- between the SRT and the info table will fit in the offset field.           -- Consequently we build a singleton SRT in this case.-          not (labelDynamic config this_mod lbl)+          not (labelDynamic config lbl)            -- MachO relocations can't express offsets between compilation units at           -- all, so we are always forced to build a singleton SRT in this case.-            && (not (osMachOTarget $ platformOS $ ncgPlatform config)+            && (not (osMachOTarget $ platformOS $ profilePlatform profile)                || isLocalCLabel this_mod lbl) -> do            -- If we have a static function closure, then it becomes the@@ -1047,8 +1066,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) @@ -1060,7 +1079,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@@ -1070,7 +1089,7 @@                 Just (fun,block) ->                   return ( [], [(block, cafList)], SRTEntry fun )                 Nothing -> do-                  (decls, entry) <- lift $ buildSRTChain dflags cafList+                  (decls, entry) <- lift $ buildSRTChain profile cafList                   return (decls, [], entry)             updateSRTMap (Just srtEntry)             let allBelowThis = Set.union allBelow filtered@@ -1080,47 +1099,47 @@                 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)  --- | build a static SRT object (or a chain of objects) from a list of+-- | Build a static SRT object (or a chain of objects) from a list of -- SRTEntries. buildSRTChain-   :: DynFlags+   :: Profile    -> [SRTEntry]    -> UniqSM         ( [CmmDeclSRTs] -- The SRT object(s)         , SRTEntry      -- label to use in the info table         ) buildSRTChain _ [] = panic "buildSRT: empty"-buildSRTChain dflags cafSet =+buildSRTChain profile cafSet =   case splitAt mAX_SRT_SIZE cafSet of     (these, []) -> do-      (decl,lbl) <- buildSRT dflags these+      (decl,lbl) <- buildSRT profile these       return ([decl], lbl)     (these,those) -> do-      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)-      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)+      (rest, rest_lbl) <- buildSRTChain profile (head these : those)+      (decl,lbl) <- buildSRT profile (rest_lbl : tail these)       return (decl:rest, lbl)   where     mAX_SRT_SIZE = 16  -buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)-buildSRT dflags refs = do+buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)+buildSRT profile refs = do   id <- getUniqueM   let     lbl = mkSRTLabel id-    platform = targetPlatform dflags+    platform = profilePlatform profile     srt_n_info = mkSRTInfoLabel (length refs)     fields =-      mkStaticClosure dflags srt_n_info dontCareCCS+      mkStaticClosure profile srt_n_info dontCareCCS         [ CmmLabel lbl | SRTEntry lbl <- refs ]         [] -- no padding         [mkIntCLit platform 0] -- link field@@ -1130,7 +1149,7 @@ -- | Update info tables with references to their SRTs. Also generate -- static closures, splicing in SRT fields as necessary. updInfoSRTs-  :: DynFlags+  :: Profile   -> LabelMap CLabel               -- SRT labels for each block   -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures   -> Bool                          -- Whether the CmmDecl's group has CAF references@@ -1140,13 +1159,13 @@ updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))   = [CmmData s (CmmStaticsRaw lbl statics)] -updInfoSRTs dflags _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]   where     caf_info = if caffy then MayHaveCafRefs else NoCafRefs-    field_lits = mkStaticClosureFields dflags itbl ccs caf_info payload+    field_lits = mkStaticClosureFields profile itbl ccs caf_info payload -updInfoSRTs dflags srt_env funSRTEnv caffy (CmmProc top_info top_l live g)+updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]   | otherwise = [ proc ]   where@@ -1172,10 +1191,10 @@               -- 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 dflags info_tbl ccs caf_info srtEntries+          fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries           new_rep = case cit_rep of              HeapRep sta ptrs nptrs ty ->                HeapRep sta (ptrs + length srtEntries) nptrs ty

+ GHC/Cmm/LRegSet.hs view

@@ -0,0 +1,53 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.Cmm.LRegSet (+    LRegSet,+    LRegKey,++    emptyLRegSet,+    nullLRegSet,+    insertLRegSet,+    elemLRegSet,++    deleteFromLRegSet,+    sizeLRegSet,++    plusLRegSet,+    elemsLRegSet+  ) where++import GHC.Prelude+import GHC.Types.Unique+import GHC.Cmm.Expr++import Data.IntSet as IntSet++-- Compact sets for membership tests of local variables.++type LRegSet = IntSet.IntSet+type LRegKey = Int++emptyLRegSet :: LRegSet+emptyLRegSet = IntSet.empty++nullLRegSet :: LRegSet -> Bool+nullLRegSet = IntSet.null++insertLRegSet :: LocalReg -> LRegSet -> LRegSet+insertLRegSet l = IntSet.insert (getKey (getUnique l))++elemLRegSet :: LocalReg -> LRegSet -> Bool+elemLRegSet l = IntSet.member (getKey (getUnique l))++deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet+deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set++sizeLRegSet :: IntSet -> Int+sizeLRegSet = IntSet.size++plusLRegSet :: IntSet -> IntSet -> IntSet+plusLRegSet = IntSet.union++elemsLRegSet :: IntSet -> [Int]+elemsLRegSet = IntSet.toList

GHC/Cmm/LayoutStack.hs view

@@ -5,6 +5,9 @@  import GHC.Prelude hiding ((<*>)) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.Utils      ( callerSaveVolatileRegs, newTemp  ) -- XXX layering violation import GHC.StgToCmm.Foreign    ( saveThreadState, loadThreadState ) -- XXX layering violation @@ -29,14 +32,13 @@ import GHC.Types.Unique.FM import GHC.Utils.Misc -import GHC.Platform import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable hiding ( isEmpty )+import GHC.Utils.Panic import qualified Data.Set as Set import Control.Monad.Fix import Data.Array as Array-import Data.Bits import Data.List (nub)  {- Note [Stack Layout]@@ -243,8 +245,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+        platform = profilePlatform profile      (final_stackmaps, _final_high_sp, new_blocks) <-           mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->@@ -252,8 +256,8 @@                    rec_stackmaps rec_high_sp blocks      blocks_with_reloads <--        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks-    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads+        insertReloadsAsNeeded platform procpoints final_stackmaps entry new_blocks+    new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads     return (ofBlockList entry new_blocks', final_stackmaps)  -- -----------------------------------------------------------------------------@@ -446,26 +450,25 @@  handleLastNode dflags procpoints liveness cont_info stackmaps                stack0@StackMap { sm_sp = sp0 } tscp middle last- = case last of-    --  At each return / tail call,-    --  adjust Sp to point to the last argument pushed, which-    --  is cml_args, after popping any other junk from the stack.-    CmmCall{ cml_cont = Nothing, .. } -> do-      let sp_off = sp0 - cml_args-      return ([], sp_off, last, [], mapEmpty)--    --  At each CmmCall with a continuation:-    CmmCall{ cml_cont = Just cont_lbl, .. } ->-       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off+  = case last of+      --  At each return / tail call,+      --  adjust Sp to point to the last argument pushed, which+      --  is cml_args, after popping any other junk from the stack.+      CmmCall{ cml_cont = Nothing, .. } -> do+        let sp_off = sp0 - cml_args+        return ([], sp_off, last, [], mapEmpty) -    CmmForeignCall{ succ = cont_lbl, .. } -> do-       return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off-            -- one word of args: the return address+      --  At each CmmCall with a continuation:+      CmmCall{ cml_cont = Just cont_lbl, .. } ->+        return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off -    CmmBranch {}     ->  handleBranches-    CmmCondBranch {} ->  handleBranches-    CmmSwitch {}     ->  handleBranches+      CmmForeignCall{ succ = cont_lbl, .. } ->+        return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off+              -- one word of args: the return address +      CmmBranch {}     ->  handleBranches+      CmmCondBranch {} ->  handleBranches+      CmmSwitch {}     ->  handleBranches   where      platform = targetPlatform dflags      -- Calls and ForeignCalls are handled the same way:@@ -1018,7 +1021,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@@ -1040,30 +1043,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 =     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@@ -1131,18 +1133,18 @@ that safe foreign call is replace by an unsafe one in the Cmm graph. -} -lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock-lowerSafeForeignCall dflags block+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall profile block   | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block   = do-    let platform = targetPlatform dflags+    let platform = profilePlatform profile     -- Both 'id' and 'new_base' are KindNonPtr because they're     -- RTS-only objects and are not subject to garbage collection     id <- newTemp (bWord platform)     new_base <- newTemp (cmmRegType platform baseReg)-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags-    save_state_code <- saveThreadState dflags-    load_state_code <- loadThreadState dflags+    let (caller_save, caller_load) = callerSaveVolatileRegs platform+    save_state_code <- saveThreadState profile+    load_state_code <- loadThreadState profile     let suspend = save_state_code  <*>                   caller_save <*>                   mkMiddle (callSuspendThread platform id intrbl)@@ -1155,7 +1157,7 @@                   load_state_code          (_, regs, copyout) =-             copyOutOflow dflags NativeReturn Jump (Young succ)+             copyOutOflow profile NativeReturn Jump (Young succ)                             (map (CmmReg . CmmLocal) res)                             ret_off []

GHC/Cmm/Lexer.x view

@@ -20,12 +20,13 @@ import GHC.Cmm.Expr  import GHC.Parser.Lexer-import GHC.Cmm.Monad+import GHC.Cmm.Parser.Monad import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Parser.CharClass+import GHC.Parser.Errors import GHC.Utils.Misc --import TRACE @@ -325,7 +326,7 @@     AlexEOF -> do let span = mkPsSpan loc1 loc1                   liftP (setLastToken span 0)                   return (L span CmmT_EOF)-    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) "lexical error"+    AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) (PsError PsErrCmmLexer [])     AlexSkip inp2 _ -> do         setInput inp2         lexToken@@ -361,8 +362,8 @@         s'   = stepOn s  getInput :: PD AlexInput-getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)+getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b)  setInput :: AlexInput -> PD ()-setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()+setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } () }

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]))

GHC/Cmm/Liveness.hs view

@@ -6,15 +6,18 @@ module GHC.Cmm.Liveness     ( CmmLocalLive     , cmmLocalLiveness+    , cmmLocalLivenessL     , cmmGlobalLiveness     , liveLattice+    , liveLatticeL     , gen_kill+    , gen_killL     ) where  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@@ -22,10 +25,14 @@ import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label+import GHC.Cmm.LRegSet  import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic +import GHC.Types.Unique+ ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block -----------------------------------------------------------------------------@@ -51,17 +58,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@@ -71,10 +78,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@@ -84,10 +91,73 @@        , 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) #-}++-----------------------------------------------------------------------------+-- | Specialization that only retains the keys for local variables.+--+-- Local variablas are mostly glorified Ints, and some parts of the compiler+-- really don't care about anything but the Int part. So we can avoid some+-- overhead by computing a IntSet instead of a Set LocalReg which (unsurprisingly)+-- is quite a bit faster.+-----------------------------------------------------------------------------++type BlockEntryLivenessL  = LabelMap LRegSet++-- | The dataflow lattice+liveLatticeL :: DataflowLattice LRegSet+liveLatticeL = DataflowLattice emptyLRegSet add+  where+    add (OldFact old) (NewFact new) =+        let !join = plusLRegSet old new+        in changedIf (sizeLRegSet join > sizeLRegSet old) join+++cmmLocalLivenessL :: Platform -> CmmGraph -> BlockEntryLivenessL+cmmLocalLivenessL platform graph =+    check $ analyzeCmmBwd liveLatticeL (xferLiveL platform) graph mapEmpty+  where+    entry = g_entry graph+    check facts =+        noLiveOnEntryL entry (expectJust "check" $ mapLookup entry facts) facts++-- | On entry to the procedure, there had better not be any LocalReg's live-in.+noLiveOnEntryL :: BlockId -> LRegSet -> a -> a+noLiveOnEntryL bid in_fact x =+  if nullLRegSet in_fact then x+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr reg_uniques)+    where+        -- We convert the int's to uniques so that the printing matches that+        -- of registers.+        reg_uniques = map mkUniqueGrimily $ elemsLRegSet in_fact+++++gen_killL+    :: (DefinerOfRegs LocalReg n, UserOfRegs LocalReg n)+    => Platform -> n -> LRegSet -> LRegSet+gen_killL platform node set =+    let !afterKill = foldRegsDefd platform deleteFromLRegSet set node+    in foldRegsUsed platform (flip insertLRegSet) afterKill node+{-# INLINE gen_killL #-}++xferLiveL+    :: ( UserOfRegs LocalReg (CmmNode O O)+       , DefinerOfRegs LocalReg (CmmNode O O)+       , UserOfRegs LocalReg (CmmNode O C)+       , DefinerOfRegs LocalReg (CmmNode O C)+       )+    => Platform -> TransferFun LRegSet+xferLiveL platform (BlockCC eNode middle xNode) fBase =+    let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase+        !result = foldNodesBwdOO (gen_killL platform) middle joined+    in mapSingleton (entryLabel eNode) result++

GHC/Cmm/MachOp.hs view

@@ -586,6 +586,41 @@   | MO_F32_Fabs   | MO_F32_Sqrt +  -- 64-bit int/word ops for when they exceed the native word size+  -- (i.e. on 32-bit architectures)+  | MO_I64_ToI+  | MO_I64_FromI+  | MO_W64_ToW+  | MO_W64_FromW++  | MO_x64_Neg+  | MO_x64_Add+  | MO_x64_Sub+  | MO_x64_Mul+  | MO_I64_Quot+  | MO_I64_Rem+  | MO_W64_Quot+  | MO_W64_Rem++  | MO_x64_And+  | MO_x64_Or+  | MO_x64_Xor+  | MO_x64_Not+  | MO_x64_Shl+  | MO_I64_Shr+  | MO_W64_Shr++  | MO_x64_Eq+  | MO_x64_Ne+  | MO_I64_Ge+  | MO_I64_Gt+  | MO_I64_Le+  | MO_I64_Lt+  | MO_W64_Ge+  | MO_W64_Gt+  | MO_W64_Le+  | MO_W64_Lt+   | MO_UF_Conv Width    | MO_S_Mul2    Width

− GHC/Cmm/Monad.hs

@@ -1,51 +0,0 @@--------------------------------------------------------------------------------- A Parser monad with access to the 'DynFlags'.------ The 'P' monad only has access to the subset of 'DynFlags'--- required for parsing Haskell.---- The parser for C-- requires access to a lot more of the 'DynFlags',--- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.-------------------------------------------------------------------------------module GHC.Cmm.Monad (-    PD(..)-  , liftP-  , failMsgPD-  ) where--import GHC.Prelude--import Control.Monad--import GHC.Driver.Session-import GHC.Parser.Lexer--newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }--instance Functor PD where-  fmap = liftM--instance Applicative PD where-  pure = returnPD-  (<*>) = ap--instance Monad PD where-  (>>=) = thenPD--liftP :: P a -> PD a-liftP (P f) = PD $ \_ s -> f s--failMsgPD :: String -> PD a-failMsgPD = liftP . failMsgP--returnPD :: a -> PD a-returnPD = liftP . return--thenPD :: PD a -> (a -> PD b) -> PD b-(PD m) `thenPD` k = PD $ \d s ->-        case m d s of-                POk s1 a         -> unPD (k a) d s1-                PFailed s1 -> PFailed s1--instance HasDynFlags PD where-   getDynFlags = PD $ \d s -> POk s d

GHC/Cmm/Node.hs view

@@ -1,13 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}@@ -31,12 +30,11 @@ import GHC.Platform.Regs import GHC.Cmm.Expr import GHC.Cmm.Switch-import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.ForeignCall import GHC.Utils.Outputable import GHC.Runtime.Heap.Layout-import GHC.Core (Tickish)+import GHC.Types.Tickish (CmmTickish) import qualified GHC.Types.Unique as U  import GHC.Cmm.Dataflow.Block@@ -320,7 +318,8 @@ -- Instances of register and slot users / definers  instance UserOfRegs LocalReg (CmmNode e x) where-  foldRegsUsed dflags f !z n = case n of+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr     CmmStore addr rval -> fold f (fold f z addr) rval     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args@@ -331,10 +330,11 @@     _ -> z     where fold :: forall a b. UserOfRegs LocalReg a                => (b -> LocalReg -> b) -> b -> a -> b-          fold f z n = foldRegsUsed dflags f z n+          fold f z n = foldRegsUsed platform f z n  instance UserOfRegs GlobalReg (CmmNode e x) where-  foldRegsUsed dflags f !z n = case n of+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr     CmmStore addr rval -> fold f (fold f z addr) rval     CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args@@ -345,26 +345,29 @@     _ -> z     where fold :: forall a b.  UserOfRegs GlobalReg a                => (b -> GlobalReg -> b) -> b -> a -> b-          fold f z n = foldRegsUsed dflags f z n+          fold f z n = foldRegsUsed platform f z n  instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where   -- The (Ord r) in the context is necessary here   -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance-  foldRegsUsed _      _ !z (PrimTarget _)      = z-  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e+  {-# INLINEABLE foldRegsUsed #-}+  foldRegsUsed _        _ !z (PrimTarget _)      = z+  foldRegsUsed platform f !z (ForeignTarget e _) = foldRegsUsed platform f z e  instance DefinerOfRegs LocalReg (CmmNode e x) where-  foldRegsDefd dflags f !z n = case n of+  {-# INLINEABLE foldRegsDefd #-}+  foldRegsDefd platform f !z n = case n of     CmmAssign lhs _ -> fold f z lhs     CmmUnsafeForeignCall _ fs _ -> fold f z fs     CmmForeignCall {res=res} -> fold f z res     _ -> z     where fold :: forall a b. DefinerOfRegs LocalReg a                => (b -> LocalReg -> b) -> b -> a -> b-          fold f z n = foldRegsDefd dflags f z n+          fold f z n = foldRegsDefd platform f z n  instance DefinerOfRegs GlobalReg (CmmNode e x) where-  foldRegsDefd dflags f !z n = case n of+  {-# INLINEABLE foldRegsDefd #-}+  foldRegsDefd platform f !z n = case n of     CmmAssign lhs _ -> fold f z lhs     CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)     CmmCall        {} -> fold f z activeRegs@@ -373,9 +376,8 @@     _ -> z     where fold :: forall a b. DefinerOfRegs GlobalReg a                => (b -> GlobalReg -> b) -> b -> a -> b-          fold f z n = foldRegsDefd dflags f z n+          fold f z n = foldRegsDefd platform f z n -          platform = targetPlatform dflags           activeRegs = activeStgRegs platform           activeCallerSavesRegs = filter (callerSaves platform) activeRegs @@ -594,9 +596,6 @@ mapCollectSuccessors _ n = (n, [])  -- --------------------------------------------------------------------------------- | Tickish in Cmm context (annotations only)-type CmmTickish = Tickish ()  -- | Tick scope identifier, allowing us to reason about what -- annotations in a Cmm block should scope over. We especially take

GHC/Cmm/Opt.hs view

@@ -19,10 +19,9 @@ import GHC.Cmm import GHC.Utils.Misc -import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform -import Data.Bits import Data.Maybe  @@ -58,7 +57,7 @@     -> Maybe CmmExpr  cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]-  = Just $ case op of+  = Just $! case op of       MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)       MO_Not _   -> CmmLit (CmmInt (complement x) rep) @@ -90,13 +89,13 @@         -- but remember to use the signedness from the widening, just in case         -- the final conversion is a widen.         | rep1 < rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]+            Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]         -- Nested widenings: collapse if the signedness is the same         | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->-            Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]+            Just $! cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]         -- Nested narrowings: collapse         | rep1 > rep2 && rep2 > rep3 ->-            Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]+            Just $! cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]         | otherwise ->             Nothing   where@@ -117,34 +116,34 @@   = case mop of         -- for comparisons: don't forget to narrow the arguments before         -- comparing, since they might be out of range.-        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))-        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform))+        MO_Eq _   -> Just $! CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))+        MO_Ne _   -> Just $! CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform)) -        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth platform))-        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))-        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth platform))-        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform))+        MO_U_Gt _ -> Just $! CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth platform))+        MO_U_Ge _ -> Just $! CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))+        MO_U_Lt _ -> Just $! CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth platform))+        MO_U_Le _ -> Just $! CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform)) -        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth platform))-        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))-        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))-        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))+        MO_S_Gt _ -> Just $! CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth platform))+        MO_S_Ge _ -> Just $! CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))+        MO_S_Lt _ -> Just $! CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth platform))+        MO_S_Le _ -> Just $! CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform)) -        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)-        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)-        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)-        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)-        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)-        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)-        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)+        MO_Add r -> Just $! CmmLit (CmmInt (x + y) r)+        MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r)+        MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r)+        MO_U_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `quot` y_u) r)+        MO_U_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x_u `rem`  y_u) r)+        MO_S_Quot r | y /= 0 -> Just $! CmmLit (CmmInt (x `quot` y) r)+        MO_S_Rem  r | y /= 0 -> Just $! CmmLit (CmmInt (x `rem` y) r) -        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)-        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)-        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)+        MO_And   r -> Just $! CmmLit (CmmInt (x .&. y) r)+        MO_Or    r -> Just $! CmmLit (CmmInt (x .|. y) r)+        MO_Xor   r -> Just $! CmmLit (CmmInt (x `xor` y) r) -        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)-        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)-        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)+        MO_Shl   r -> Just $! CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+        MO_U_Shr r -> Just $! CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)+        MO_S_Shr r -> Just $! CmmLit (CmmInt (x `shiftR` fromIntegral y) r)          _          -> Nothing @@ -162,7 +161,7 @@  cmmMachOpFoldM platform op [x@(CmmLit _), y]    | not (isLit y) && isCommutableMachOp op-   = Just (cmmMachOpFold platform op [y, x])+   = Just $! (cmmMachOpFold platform op [y, x])  -- Turn (a+b)+c into a+(b+c) where possible.  Because literals are -- moved to the right, it is more likely that we will find@@ -183,7 +182,7 @@ cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]    | mop2 `associates_with` mop1      && not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])+   = Just $! (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])    where      MO_Add{} `associates_with` MO_Sub{} = True      mop1 `associates_with` mop2 =@@ -192,7 +191,7 @@ -- special case: (a - b) + c  ==>  a + (c - b) cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]    | not (isLit arg1) && not (isPicReg arg1)-   = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])+   = Just $! (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])  -- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N) --@@ -205,27 +204,27 @@ cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]                           , CmmLit (CmmInt n rep) ]   | isPicReg pic-  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]+  = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]   where off = fromIntegral (narrowS rep n)  -- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))+  = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n))  -- Fold label(+/-)offset into a CmmLit where possible  cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]-  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))+  = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))   -- Comparison of literal with widened operand: perform the comparison@@ -245,7 +244,7 @@         -- and the literal fits in the smaller size:     i == narrow_fn rep i         -- then we can do the comparison at the smaller size-  = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])+  = Just $! (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])  where     maybe_conversion (MO_UU_Conv from to)         | to > from@@ -320,8 +319,8 @@         MO_Mul    _ -> Just x         MO_S_Quot _ -> Just x         MO_U_Quot _ -> Just x-        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)-        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)+        MO_S_Rem  _ -> Just $! CmmLit (CmmInt 0 rep)+        MO_U_Rem  _ -> Just $! CmmLit (CmmInt 0 rep)          -- Comparisons; trickier         -- See Note [Comparison operators]@@ -346,18 +345,18 @@   = case mop of         MO_Mul rep            | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])+                 Just $! (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p $ wordWidth platform)])         MO_U_Quot rep            | Just p <- exactLog2 n ->-                 Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])+                 Just $! (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p $ wordWidth platform)])         MO_U_Rem rep            | Just _ <- exactLog2 n ->-                 Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])+                 Just $! (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])         MO_S_Quot rep            | Just p <- exactLog2 n,              CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require                                 -- it is a reg.  FIXME: remove this restriction.-                Just (cmmMachOpFold platform (MO_S_Shr rep)+                Just $! (cmmMachOpFold platform (MO_S_Shr rep)                   [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])         MO_S_Rem rep            | Just p <- exactLog2 n,@@ -366,7 +365,7 @@                 -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).                 -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)                 -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.-                Just (cmmMachOpFold platform (MO_Sub rep)+                Just $! (cmmMachOpFold platform (MO_Sub rep)                     [x, cmmMachOpFold platform (MO_And rep)                       [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])         _ -> Nothing

GHC/Cmm/Parser.y view

@@ -205,13 +205,15 @@ import GHC.Prelude import qualified Prelude -- for happy-generated code +import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.ExtCode-import GHC.Cmm.CallConv import GHC.StgToCmm.Prof import GHC.StgToCmm.Heap import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit-                               , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff-                               , getUpdFrameOff )+                                 , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff+                                 , getUpdFrameOff, getProfile, getPlatform, getPtrOpts ) import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Utils import GHC.StgToCmm.Foreign@@ -219,8 +221,8 @@ import GHC.StgToCmm.Closure import GHC.StgToCmm.Layout     hiding (ArgRep(..)) import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )-import GHC.Core           ( Tickish(SourceNote) )  import GHC.Cmm.Opt import GHC.Cmm.Graph@@ -231,19 +233,25 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel-import GHC.Cmm.Monad+import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile, getPtrOpts)+import qualified GHC.Cmm.Parser.Monad as PD+import GHC.Cmm.CallConv import GHC.Runtime.Heap.Layout import GHC.Parser.Lexer+import GHC.Parser.Errors  import GHC.Types.CostCentre import GHC.Types.ForeignCall import GHC.Unit.Module-import GHC.Platform+import GHC.Unit.Home import GHC.Types.Literal import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.SrcLoc+import GHC.Types.Tickish  ( GenTickish(SourceNote) ) import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Utils.Error import GHC.Data.StringBuffer import GHC.Data.FastString@@ -251,7 +259,7 @@ import GHC.Settings.Constants import GHC.Utils.Outputable import GHC.Types.Basic-import GHC.Data.Bag     ( emptyBag, unitBag )+import GHC.Data.Bag     ( Bag, emptyBag, unitBag, isEmptyBag ) import GHC.Types.Var  import Control.Monad@@ -378,9 +386,11 @@         | cmmdata                       { $1 }         | decl                          { $1 }         | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'-                {% liftP . withHomeUnitId $ \pkg ->-                   do lits <- sequence $6;-                      staticClosure pkg $3 $5 (map getLit lits) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        lits <- sequence $6;+                        staticClosure home_unit_id $3 $5 (map getLit lits) }  -- The only static closures in the RTS are dummy closures like -- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need@@ -399,8 +409,10 @@  data_label :: { CmmParse CLabel }     : NAME ':'-                {% liftP . withHomeUnitId $ \pkg ->-                   return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }+                {% do+                   home_unit_id <- getHomeUnitId+                   liftP $ pure $ do+                     pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) $1) }  statics :: { [CmmParse [CmmStatic]] }         : {- empty -}                   { [] }@@ -419,9 +431,9 @@                                                         fromIntegral $3)] }         | 'CLOSURE' '(' NAME lits ')'                 { do { lits <- sequence $4-                ; dflags <- getDynFlags+                ; profile <- getProfile                      ; return $ map CmmStaticLit $-                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)+                        mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)                          -- mkForeignLabel because these are only used                          -- for CHARLIKE and INTLIKE closures in the RTS.                         dontCareCCS (map getLit lits) [] [] [] } }@@ -437,8 +449,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@@ -456,104 +469,117 @@  info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }         : NAME-                {% liftP . withHomeUnitId $ \pkg ->-                   do   newFunctionName $1 pkg-                        return (mkCmmCodeLabel pkg $1, Nothing, []) }+                {% do+                     home_unit_id <- getHomeUnitId+                     liftP $ pure $ do+                       newFunctionName $1 home_unit_id+                       return (mkCmmCodeLabel home_unit_id $1, Nothing, []) }           | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'                 -- ptrs, nptrs, closure type, description, type-                {% liftP . withHomeUnitId $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $11 $13-                          rep  = mkRTSRep (fromIntegral $9) $-                                   mkHeapRep dflags False (fromIntegral $5)-                                                   (fromIntegral $7) Thunk-                              -- not really Thunk, but that makes the info table-                              -- we want.-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile $11 $13+                            rep  = mkRTSRep (fromIntegral $9) $+                                     mkHeapRep profile False (fromIntegral $5)+                                                     (fromIntegral $7) Thunk+                                -- not really Thunk, but that makes the info table+                                -- we want.+                        return (mkCmmEntryLabel home_unit_id $3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []) }          | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'                 -- ptrs, nptrs, closure type, description, type, fun type-                {% liftP . withHomeUnitId $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $11 $13-                          ty   = Fun 0 (ArgSpec (fromIntegral $15))-                                -- Arity zero, arg_type $15-                          rep = mkRTSRep (fromIntegral $9) $-                                    mkHeapRep dflags False (fromIntegral $5)-                                                    (fromIntegral $7) ty-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile $11 $13+                            ty   = Fun 0 (ArgSpec (fromIntegral $15))+                                  -- Arity zero, arg_type $15+                            rep = mkRTSRep (fromIntegral $9) $+                                      mkHeapRep profile False (fromIntegral $5)+                                                      (fromIntegral $7) ty+                        return (mkCmmEntryLabel home_unit_id $3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []) }                 -- we leave most of the fields zero here.  This is only used                 -- to generate the BCO info table in the RTS at the moment.          | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'                 -- ptrs, nptrs, tag, closure type, description, type-                {% liftP . withHomeUnitId $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $13 $15-                          ty  = Constr (fromIntegral $9)  -- Tag-                                       (BS8.pack $13)-                          rep = mkRTSRep (fromIntegral $11) $-                                  mkHeapRep dflags False (fromIntegral $5)-                                                  (fromIntegral $7) ty-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },-                              []) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile $13 $15+                            ty  = Constr (fromIntegral $9)  -- Tag+                                         (BS8.pack $13)+                            rep = mkRTSRep (fromIntegral $11) $+                                    mkHeapRep profile False (fromIntegral $5)+                                                    (fromIntegral $7) ty+                        return (mkCmmEntryLabel home_unit_id $3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },+                                []) }                       -- If profiling is on, this string gets duplicated,                      -- but that's the way the old code did it we can fix it some other time.          | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'                 -- selector, closure type, description, type-                {% liftP . withHomeUnitId $ \pkg ->-                   do dflags <- getDynFlags-                      let prof = profilingInfo dflags $9 $11-                          ty  = ThunkSelector (fromIntegral $5)-                          rep = mkRTSRep (fromIntegral $7) $-                                   mkHeapRep dflags False 0 0 ty-                      return (mkCmmEntryLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        profile <- getProfile+                        let prof = profilingInfo profile $9 $11+                            ty  = ThunkSelector (fromIntegral $5)+                            rep = mkRTSRep (fromIntegral $7) $+                                     mkHeapRep profile False 0 0 ty+                        return (mkCmmEntryLabel home_unit_id $3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id $3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []) }          | 'INFO_TABLE_RET' '(' NAME ',' INT ')'                 -- closure type (no live regs)-                {% liftP . withHomeUnitId $ \pkg ->-                   do let prof = NoProfilingInfo-                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []-                      return (mkCmmRetLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              []) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        let prof = NoProfilingInfo+                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []+                        return (mkCmmRetLabel home_unit_id $3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                []) }          | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'                 -- closure type, live regs-                {% liftP . withHomeUnitId $ \pkg ->-                   do dflags <- getDynFlags-                      let platform = targetPlatform dflags-                      live <- sequence $7-                      let prof = NoProfilingInfo-                          -- drop one for the info pointer-                          bitmap = mkLiveness platform (drop 1 live)-                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap-                      return (mkCmmRetLabel pkg $3,-                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3-                                           , cit_rep = rep-                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                              live) }+                {% do+                      home_unit_id <- getHomeUnitId+                      liftP $ pure $ do+                        platform <- getPlatform+                        live <- sequence $7+                        let prof = NoProfilingInfo+                            -- drop one for the info pointer+                            bitmap = mkLiveness platform (drop 1 live)+                            rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap+                        return (mkCmmRetLabel home_unit_id $3,+                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id $3+                                             , cit_rep = rep+                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                                live) }  body    :: { CmmParse () }         : {- empty -}                   { return () }@@ -687,8 +713,8 @@  vols    :: { [GlobalReg] }         : '[' ']'                       { [] }-        | '[' '*' ']'                   {% do df <- getDynFlags-                                         ; return (realArgRegsCover df) }+        | '[' '*' ']'                   {% do platform <- PD.getPlatform+                                         ; return (realArgRegsCover platform) }                                            -- All of them. See comment attached                                            -- to realArgRegsCover         | '[' globals ']'               { $2 }@@ -772,7 +798,7 @@  -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType }-        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord (targetPlatform dflags) }+        : {- empty -}                   {% do platform <- PD.getPlatform; return $ bWord platform }         | '::' type                     { $2 }  cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }@@ -861,7 +887,7 @@         | 'bits512'             { b512 }         | 'float32'             { f32 }         | 'float64'             { f64 }-        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord (targetPlatform dflags) }+        | 'gcptr'               {% do platform <- PD.getPlatform; return $ gcWord platform }  { section :: String -> SectionType@@ -881,8 +907,7 @@ -- the op. mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr mkMachOp fn args = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- getPlatform   arg_exprs <- sequence args   return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs) @@ -894,13 +919,13 @@ nameToMachOp :: FastString -> PD (Width -> MachOp) nameToMachOp name =   case lookupUFM machOps name of-        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)+        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []         Just m  -> return m  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do-  dflags <- getDynFlags-  case lookupUFM (exprMacros dflags) name of+  ptr_opts <- PD.getPtrOpts+  case lookupUFM (exprMacros ptr_opts) name of      Just f  -> return $ do         args <- sequence args_code         return (f args)@@ -908,20 +933,22 @@         mo <- nameToMachOp name         return $ mkMachOp mo args_code -exprMacros :: DynFlags -> UniqFM FastString ([CmmExpr] -> CmmExpr)-exprMacros dflags = listToUFM [+exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)+exprMacros ptr_opts = listToUFM [   ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),-  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),-  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),-  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),-  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform (closureInfoPtr dflags x) ),-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),-  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),-  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),-  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr ptr_opts x ),+  ( fsLit "STD_INFO",     \ [x] -> infoTable profile x ),+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )   ]-  where platform = targetPlatform dflags+  where+    profile  = po_profile ptr_opts+    platform = profilePlatform profile  -- we understand a subset of C-- primitives: machOps = listToUFM $@@ -991,9 +1018,48 @@         ( "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)) [++        ( "pow64f", (MO_F64_Pwr,) ),+        ( "sin64f", (MO_F64_Sin,) ),+        ( "cos64f", (MO_F64_Cos,) ),+        ( "tan64f", (MO_F64_Tan,) ),+        ( "sinh64f", (MO_F64_Sinh,) ),+        ( "cosh64f", (MO_F64_Cosh,) ),+        ( "tanh64f", (MO_F64_Tanh,) ),+        ( "asin64f", (MO_F64_Asin,) ),+        ( "acos64f", (MO_F64_Acos,) ),+        ( "atan64f", (MO_F64_Atan,) ),+        ( "asinh64f", (MO_F64_Asinh,) ),+        ( "acosh64f", (MO_F64_Acosh,) ),+        ( "log64f", (MO_F64_Log,) ),+        ( "log1p64f", (MO_F64_Log1P,) ),+        ( "exp64f", (MO_F64_Exp,) ),+        ( "expM164f", (MO_F64_ExpM1,) ),+        ( "fabs64f", (MO_F64_Fabs,) ),+        ( "sqrt64f", (MO_F64_Sqrt,) ),++        ( "pow32f", (MO_F32_Pwr,) ),+        ( "sin32f", (MO_F32_Sin,) ),+        ( "cos32f", (MO_F32_Cos,) ),+        ( "tan32f", (MO_F32_Tan,) ),+        ( "sinh32f", (MO_F32_Sinh,) ),+        ( "cosh32f", (MO_F32_Cosh,) ),+        ( "tanh32f", (MO_F32_Tanh,) ),+        ( "asin32f", (MO_F32_Asin,) ),+        ( "acos32f", (MO_F32_Acos,) ),+        ( "atan32f", (MO_F32_Atan,) ),+        ( "asinh32f", (MO_F32_Asinh,) ),+        ( "acosh32f", (MO_F32_Acosh,) ),+        ( "log32f", (MO_F32_Log,) ),+        ( "log1p32f", (MO_F32_Log1P,) ),+        ( "exp32f", (MO_F32_Exp,) ),+        ( "expM132f", (MO_F32_ExpM1,) ),+        ( "fabs32f", (MO_F32_Fabs,) ),+        ( "sqrt32f", (MO_F32_Sqrt,) ),+         ( "read_barrier", (MO_ReadBarrier,)),         ( "write_barrier", (MO_WriteBarrier,)),         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),@@ -1030,10 +1096,6 @@         ( "xchg16", (MO_Xchg W16,)),         ( "xchg32", (MO_Xchg W32,)),         ( "xchg64", (MO_Xchg W64,))--        -- ToDo: the rest, maybe-        -- edit: which rest?-        -- also: how do we tell CMM Lint how to type check callish macops?     ]   where     memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])@@ -1044,7 +1106,7 @@         args' = init args         align = case last args of           CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger-          e -> pprPgmError "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@@ -1054,12 +1116,12 @@ parseSafety "safe"   = return PlaySafe parseSafety "unsafe" = return PlayRisky parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = failMsgPD ("unrecognised safety: " ++ str)+parseSafety str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedSafety str)) []  parseCmmHint :: String -> PD ForeignHint parseCmmHint "ptr"    = return AddrHint parseCmmHint "signed" = return SignedHint-parseCmmHint str      = failMsgPD ("unrecognised hint: " ++ str)+parseCmmHint str      = failMsgPD $ PsError (PsErrCmmParser (CmmUnrecognisedHint str)) []  -- labels are always pointers, so we might as well infer the hint inferCmmHint :: CmmExpr -> ForeignHint@@ -1078,7 +1140,7 @@ isPtrGlobalReg _                     = False  happyError :: PD a-happyError = PD $ \_ s -> unP srcParseFail s+happyError = PD $ \_ _ s -> unP srcParseFail s  -- ----------------------------------------------------------------------------- -- Statement-level macros@@ -1086,7 +1148,7 @@ stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ()) stmtMacro fun args_code = do   case lookupUFM stmtMacros fun of-    Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun)+    Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownMacro fun)) []     Just fcode -> return $ do         args <- sequence args_code         code (fcode args)@@ -1119,6 +1181,9 @@   ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),   ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ), +  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),+  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),+   ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),   ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ), @@ -1136,15 +1201,14 @@  emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode () emitPushUpdateFrame sp e = do-  dflags <- getDynFlags-  emitUpdateFrame dflags sp mkUpdInfoLabel e+  emitUpdateFrame sp mkUpdInfoLabel e  pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse () pushStackFrame fields body = do-  dflags <- getDynFlags+  profile <- getProfile   exprs <- sequence fields   updfr_off <- getUpdFrameOff-  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old+  let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old                                            [] updfr_off exprs   emit g   withUpdFrameOff new_updfr_off body@@ -1155,28 +1219,27 @@   -> CmmParse ()   -> CmmParse () reserveStackFrame psize preg body = do-  dflags <- getDynFlags-  let platform = targetPlatform dflags+  platform <- getPlatform   old_updfr_off <- getUpdFrameOff   reg <- preg   esize <- psize   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 -profilingInfo dflags desc_str ty_str-  = if not (sccProfilingEnabled dflags)+profilingInfo profile desc_str ty_str+  = if not (profileIsProfiling profile)     then NoProfilingInfo     else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)  staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload-  = do dflags <- getDynFlags-       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+  = do profile <- getProfile+       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []        code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits  foreignCall@@ -1189,16 +1252,15 @@         -> PD (CmmParse ()) foreignCall conv_string results_code expr_code args_code safety ret   = do  conv <- case conv_string of-          "C" -> return CCallConv+          "C"       -> return CCallConv           "stdcall" -> return StdCallConv-          _ -> failMsgPD ("unknown calling convention: " ++ conv_string)+          _         -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownCConv conv_string)) []         return $ do-          dflags <- getDynFlags+          platform <- getPlatform           results <- sequence results_code           expr <- expr_code           args <- sequence args_code           let-                  platform = targetPlatform dflags                   expr' = adjCallTarget platform conv expr args                   (arg_exprs, arg_hints) = unzip args                   (res_regs,  res_hints) = unzip results@@ -1210,34 +1272,34 @@  doReturn :: [CmmParse CmmExpr] -> CmmParse () doReturn exprs_code = do-  dflags <- getDynFlags+  profile <- getProfile   exprs <- sequence exprs_code   updfr_off <- getUpdFrameOff-  emit (mkReturnSimple dflags exprs updfr_off)+  emit (mkReturnSimple profile exprs updfr_off) -mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph-mkReturnSimple dflags actuals updfr_off =-  mkReturn dflags e actuals updfr_off+mkReturnSimple  :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph+mkReturnSimple profile actuals updfr_off =+  mkReturn profile e actuals updfr_off   where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off)                              (gcWord platform))-        platform = targetPlatform dflags+        platform = profilePlatform profile  doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse () doRawJump expr_code vols = do-  dflags <- getDynFlags+  profile <- getProfile   expr <- expr_code   updfr_off <- getUpdFrameOff-  emit (mkRawJump dflags expr updfr_off vols)+  emit (mkRawJump profile expr updfr_off vols)  doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]                 -> [CmmParse CmmExpr] -> CmmParse () doJumpWithStack expr_code stk_code args_code = do-  dflags <- getDynFlags+  profile <- getProfile   expr <- expr_code   stk_args <- sequence stk_code   args <- sequence args_code   updfr_off <- getUpdFrameOff-  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)+  emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)  doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]        -> CmmParse ()@@ -1267,8 +1329,10 @@         -> [CmmParse CmmExpr]         -> PD (CmmParse ()) primCall results_code name args_code-  = case lookupUFM callishMachOps name of-        Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)+  = do+    platform <- PD.getPlatform+    case lookupUFM (callishMachOps platform) name of+        Nothing -> failMsgPD $ PsError (PsErrCmmParser (CmmUnknownPrimitive name)) []         Just f  -> return $ do                 results <- sequence results_code                 args <- sequence args_code@@ -1277,7 +1341,7 @@  doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse () doStore rep addr_code val_code-  = do dflags <- getDynFlags+  = do platform <- getPlatform        addr <- addr_code        val <- val_code         -- if the specified store type does not match the type of the expr@@ -1287,7 +1351,6 @@         -- be noticed.        let val_width = typeWidth (cmmExprType platform val)            rep_width = typeWidth rep-           platform  = targetPlatform dflags        let coerce_val                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]                 | otherwise              = val@@ -1389,8 +1452,7 @@         table_entries <- mapM emitArm arms         let table = M.fromList (concat table_entries) -        dflags <- getDynFlags-        let platform = targetPlatform dflags+        platform <- getPlatform         let range = fromMaybe (0, platformMaxWord platform) mb_range          expr <- scrut@@ -1415,34 +1477,42 @@  -- The initial environment: we define some constants that the compiler -- knows about here.-initEnv :: DynFlags -> Env-initEnv dflags = listToUFM [+initEnv :: Profile -> Env+initEnv profile = listToUFM [   ( fsLit "SIZEOF_StgHeader",-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth platform)) )),+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),   ( fsLit "SIZEOF_StgInfoTable",-    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth platform)) ))+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))   ]-  where platform = targetPlatform dflags+  where platform = profilePlatform profile -parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)-parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do++parseCmmFile :: DynFlags -> Module -> HomeUnit -> FilePath -> IO (Bag PsWarning, Bag PsError, Maybe (CmmGroup, [InfoProvEnt]))+parseCmmFile dflags this_mod home_unit filename = do   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-    PFailed pst ->-        return (getMessages pst dflags, Nothing)+  case unPD cmmParse dflags home_unit init_state of+    PFailed pst -> do+        let (warnings,errors) = getMessages pst+        return (warnings, errors, Nothing)     POk pst code -> do         st <- initC-        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()-            (cmm,_) = runC dflags no_module st fcode-        let ms = getMessages pst dflags-        if (errorsFound dflags ms)-         then return (ms, Nothing)-         else return (ms, Just cmm)+        let fcode = do+              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)+                                              (mapMaybe topInfoTable cmm)+              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info+              return (cmm ++ cmm2, used_info)+            (cmm, _) = runC dflags no_module st fcode+            (warnings,errors) = getMessages pst+        if not (isEmptyBag errors)+         then return (warnings, errors, Nothing)+         else return (warnings, errors, Just cmm)   where         no_module = panic "parseCmmFile: no module" }

+ GHC/Cmm/Parser/Monad.hs view

@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- A Parser monad with access to the 'DynFlags'.+--+-- The 'P' monad only has access to the subset of 'DynFlags'+-- required for parsing Haskell.++-- The parser for C-- requires access to a lot more of the 'DynFlags',+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.+-----------------------------------------------------------------------------+module GHC.Cmm.Parser.Monad (+    PD(..)+  , liftP+  , failMsgPD+  , getProfile+  , getPlatform+  , getPtrOpts+  , getHomeUnitId+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Profile+import GHC.Cmm.Info++import Control.Monad++import GHC.Driver.Session+import GHC.Parser.Lexer+import GHC.Parser.Errors+import GHC.Types.SrcLoc+import GHC.Unit.Types+import GHC.Unit.Home++newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }++instance Functor PD where+  fmap = liftM++instance Applicative PD where+  pure = returnPD+  (<*>) = ap++instance Monad PD where+  (>>=) = thenPD++liftP :: P a -> PD a+liftP (P f) = PD $ \_ _ s -> f s++failMsgPD :: (SrcSpan -> PsError) -> PD a+failMsgPD = liftP . failMsgP++returnPD :: a -> PD a+returnPD = liftP . return++thenPD :: PD a -> (a -> PD b) -> PD b+(PD m) `thenPD` k = PD $ \d hu s ->+        case m d hu s of+                POk s1 a   -> unPD (k a) d hu s1+                PFailed s1 -> PFailed s1++instance HasDynFlags PD where+   getDynFlags = PD $ \d _ s -> POk s d++getProfile :: PD Profile+getProfile = targetProfile <$> getDynFlags++getPlatform :: PD Platform+getPlatform = profilePlatform <$> getProfile++getPtrOpts :: PD PtrOpts+getPtrOpts = do+   dflags <- getDynFlags+   profile <- getProfile+   pure $ PtrOpts+      { po_profile     = profile+      , po_align_check = gopt Opt_AlignmentSanitisation dflags+      }++-- | Return the UnitId of the home-unit. This is used to create labels.+getHomeUnitId :: PD UnitId+getHomeUnitId = PD $ \_ hu s -> POk s (homeUnitId hu)

GHC/Cmm/Pipeline.hs view

@@ -1,6 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TupleSections #-}  module GHC.Cmm.Pipeline (   -- | Converts C-- with an implicit stack and native C-- calls into@@ -24,8 +22,10 @@  import GHC.Types.Unique.Supply import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Utils.Error-import GHC.Driver.Types+import GHC.Utils.Logger+import GHC.Driver.Env import Control.Monad import GHC.Utils.Outputable import GHC.Platform@@ -42,122 +42,120 @@  -> CmmGroup             -- Input C-- with Procedures  -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $-  do let dflags = hsc_dflags hsc_env--     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog+cmmPipeline hsc_env srtInfo prog = do+  let logger = hsc_logger hsc_env+  let dflags = hsc_dflags hsc_env+  let forceRes (info, group) = info `seq` foldr (\decl r -> decl `seq` r) () group+  withTimingSilent logger dflags (text "Cmm pipeline") forceRes $ do+     tops <- {-# SCC "tops" #-} mapM (cpsTop logger 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)+     let platform = targetPlatform dflags+     dumpWith logger dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)       return (srtInfo, cmms) -  where forceRes (info, group) =-          info `seq` foldr (\decl r -> decl `seq` r) () group -        dflags = hsc_dflags hsc_env--cpsTop :: HscEnv -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))-cpsTop _ p@(CmmData _ statics) = return (Right (cafAnalData statics, p))-cpsTop hsc_env proc =+cpsTop :: Logger -> DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))+cpsTop _logger dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))+cpsTop logger dflags proc =     do-       ----------- Control-flow optimisations ----------------------------------+      ----------- Control-flow optimisations ---------------------------------- -       -- The first round of control-flow optimisation speeds up the-       -- later passes by removing lots of empty blocks, so we do it-       -- even when optimisation isn't turned on.-       ---       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}-            return $ cmmCfgOptsProc splitting_proc_points proc-       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+      -- The first round of control-flow optimisation speeds up the+      -- later passes by removing lots of empty blocks, so we do it+      -- even when optimisation isn't turned on.+      --+      CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}+           return $ cmmCfgOptsProc splitting_proc_points proc+      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g -       let !TopInfo {stack_info=StackInfo { arg_space = entry_off-                                          , do_layout = do_layout }} = h+      let !TopInfo {stack_info=StackInfo { arg_space = entry_off+                                         , do_layout = do_layout }} = h -       ----------- Eliminate common blocks --------------------------------------       g <- {-# SCC "elimCommonBlocks" #-}-            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g-                          Opt_D_dump_cmm_cbe "Post common block elimination"+      ----------- Eliminate common blocks -------------------------------------+      g <- {-# SCC "elimCommonBlocks" #-}+           condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+                         Opt_D_dump_cmm_cbe "Post common block elimination" -       -- Any work storing block Labels must be performed _after_-       -- elimCommonBlocks+      -- Any work storing block Labels must be performed _after_+      -- elimCommonBlocks -       ----------- Implement switches -------------------------------------------       g <- {-# SCC "createSwitchPlans" #-}-            runUniqSM $ cmmImplementSwitchPlans dflags g-       dump Opt_D_dump_cmm_switch "Post switch plan" g+      ----------- Implement switches ------------------------------------------+      g <- {-# SCC "createSwitchPlans" #-}+           runUniqSM $ cmmImplementSwitchPlans (backend dflags) platform g+      dump Opt_D_dump_cmm_switch "Post switch plan" g -       ----------- Proc points --------------------------------------------------       let-         call_pps :: ProcPointSet -- LabelMap-         call_pps = {-# SCC "callProcPoints" #-} callProcPoints g-       proc_points <--          if splitting_proc_points-             then do-               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $-                  minimalProcPointSet (targetPlatform dflags) call_pps g-               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"-                     FormatCMM (ppr l $$ ppr pp $$ ppr g)-               return pp-             else-               return call_pps+      ----------- Proc points -------------------------------------------------+      let+        call_pps :: ProcPointSet -- LabelMap+        call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+      proc_points <-+         if splitting_proc_points+            then do+              pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $+                 minimalProcPointSet platform call_pps g+              dumpWith logger dflags Opt_D_dump_cmm_proc "Proc points"+                    FormatCMM (pdoc platform l $$ ppr pp $$ pdoc platform g)+              return pp+            else+              return call_pps -       ----------- Layout the stack and manifest Sp -----------------------------       (g, stackmaps) <--            {-# SCC "layoutStack" #-}-            if do_layout-               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g-               else return (g, mapEmpty)-       dump Opt_D_dump_cmm_sp "Layout Stack" g+      ----------- Layout the stack and manifest Sp ----------------------------+      (g, stackmaps) <-+           {-# SCC "layoutStack" #-}+           if do_layout+              then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+              else return (g, mapEmpty)+      dump Opt_D_dump_cmm_sp "Layout Stack" g -       ----------- Sink and inline assignments  ---------------------------------       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]-            condPass Opt_CmmSink (cmmSink dflags) g-                     Opt_D_dump_cmm_sink "Sink assignments"+      ----------- Sink and inline assignments  --------------------------------+      g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+           condPass Opt_CmmSink (cmmSink platform) g+                    Opt_D_dump_cmm_sink "Sink assignments" -       ------------- CAF analysis -----------------------------------------------       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g-       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)+      ------------- CAF analysis ----------------------------------------------+      let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g+      dumpWith logger dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) -       g <- if splitting_proc_points-            then do-               ------------- Split into separate procedures ------------------------               let pp_map = {-# SCC "procPointAnalysis" #-}-                            procPointAnalysis proc_points g-               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-                                      (CmmProc h l v g)-               dumps Opt_D_dump_cmm_split "Post splitting" g-               return g-             else do-               -- attach info tables to return points-               return $ [attachContInfoTables call_pps (CmmProc h l v g)]+      g <- if splitting_proc_points+           then do+             ------------- Split into separate procedures -----------------------+             let pp_map = {-# SCC "procPointAnalysis" #-}+                          procPointAnalysis proc_points g+             dumpWith logger dflags Opt_D_dump_cmm_procmap "procpoint map"+                FormatCMM (ppr pp_map)+             g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+                  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+           else+             -- attach info tables to return points+             return $ [attachContInfoTables call_pps (CmmProc h l v g)] -       ------------- Populate info tables with stack info ------------------       g <- {-# SCC "setInfoTableStackMap" #-}-            return $ map (setInfoTableStackMap platform stackmaps) g-       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g+      ------------- Populate info tables with stack info -----------------+      g <- {-# SCC "setInfoTableStackMap" #-}+           return $ map (setInfoTableStackMap platform stackmaps) g+      dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g -       ----------- Control-flow optimisations ------------------------------       g <- {-# SCC "cmmCfgOpts(2)" #-}-            return $ if optLevel dflags >= 1-                     then map (cmmCfgOptsProc splitting_proc_points) g-                     else g-       g <- return (map removeUnreachableBlocksProc g)-            -- See Note [unreachable blocks]-       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+      ----------- Control-flow optimisations -----------------------------+      g <- {-# SCC "cmmCfgOpts(2)" #-}+           return $ if optLevel dflags >= 1+                    then map (cmmCfgOptsProc splitting_proc_points) g+                    else g+      g <- return (map removeUnreachableBlocksProc g)+           -- See Note [unreachable blocks]+      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g -       return (Left (cafEnv, g))+      return (Left (cafEnv, g)) -  where dflags = hsc_dflags hsc_env-        platform = targetPlatform dflags-        dump = dumpGraph dflags+  where platform = targetPlatform dflags+        dump = dumpGraph logger dflags          dumps flag name-           = mapM_ (dumpWith dflags flag name FormatCMM . ppr)+           = mapM_ (dumpWith logger dflags flag name FormatCMM . pdoc platform)          condPass flag pass g dumpflag dumpname =             if gopt flag dflags@@ -171,7 +169,7 @@         -- tablesNextToCode is off.  The latter is because we have no         -- label to put on info tables for basic blocks that are not         -- the entry point.-        splitting_proc_points = hscTarget dflags /= HscAsm+        splitting_proc_points = backend dflags /= NCG                              || not (platformTablesNextToCode platform)                              || -- Note [inconsistent-pic-reg]                                 usingInconsistentPicReg@@ -350,24 +348,24 @@   return (initUs_ us m)  -dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()-dumpGraph dflags flag name g = do+dumpGraph :: Logger -> DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()+dumpGraph logger dflags flag name g = do   when (gopt Opt_DoCmmLinting dflags) $ do_lint g-  dumpWith dflags flag name FormatCMM (ppr g)+  dumpWith logger dflags flag name FormatCMM (pdoc platform g)  where-  do_lint g = case cmmLintGraph dflags g of-                 Just err -> do { fatalErrorMsg dflags err-                                ; ghcExit dflags 1+  platform = targetPlatform dflags+  do_lint g = case cmmLintGraph platform g of+                 Just err -> do { fatalErrorMsg logger dflags err+                                ; ghcExit logger dflags 1                                 }                  Nothing  -> return () -dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpWith dflags flag txt fmt sdoc = do-  dumpIfSet_dyn dflags flag txt fmt sdoc+dumpWith :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+dumpWith logger dflags flag txt fmt sdoc = do+  dumpIfSet_dyn logger dflags flag txt fmt sdoc   when (not (dopt flag dflags)) $     -- If `-ddump-cmm-verbose -ddump-to-file` is specified,     -- dump each Cmm pipeline stage output to a separate file.  #16930     when (dopt Opt_D_dump_cmm_verbose dflags)-      $ dumpAction dflags (mkDumpStyle alwaysQualify)-                   (dumpOptionsFromFlag flag) txt fmt sdoc-  dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc+      $ putDumpMsg logger dflags (mkDumpStyle alwaysQualify) flag txt fmt sdoc+  dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc

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

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,61 +50,54 @@ import GHC.Cmm.Ppr.Expr import GHC.Cmm -import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Data.FastString -import Data.List-import System.IO+import Data.List (intersperse)  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 ]  -- --------------------------------------------------------------------------@@ -108,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@@ -141,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@@ -156,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"

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,8 +44,9 @@  import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Platform-import GHC.Driver.Session (targetPlatform) import GHC.Cmm.Expr  import GHC.Utils.Outputable@@ -52,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@@ -72,6 +74,9 @@ instance Outputable GlobalReg where     ppr e = pprGlobalReg e +instance OutputableP env GlobalReg where+    pdoc _ = ppr+ -- -------------------------------------------------------------------------- -- Expressions --@@ -145,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)@@ -202,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>"

GHC/Cmm/ProcPoint.hs view

@@ -1,4 +1,7 @@-{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE GADTs #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module GHC.Cmm.ProcPoint@@ -11,7 +14,6 @@  import GHC.Prelude hiding (last, unzip, succ, zip) -import GHC.Driver.Session import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm@@ -24,6 +26,7 @@ import GHC.Data.Maybe import Control.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block@@ -206,7 +209,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)@@ -237,156 +240,152 @@ -- 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 ->-                     CmmDecl -> UniqSM [CmmDecl]-splitAtProcPoints dflags 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-     let add_block-             :: LabelMap (LabelMap CmmBlock)-             -> CmmBlock-             -> LabelMap (LabelMap CmmBlock)-         add_block graphEnv b =-           case mapLookup bid procMap of-             Just ProcPoint -> add graphEnv bid bid b-             Just (ReachedBy set) ->-               case setElems set of-                 []   -> graphEnv-                 [id] -> add graphEnv id bid b-                 _    -> panic "Each block should be reachable from only one ProcPoint"-             Nothing -> graphEnv-           where bid = entryLabel b-         add graphEnv procId bid b = mapInsert procId graph' graphEnv-               where graph  = mapLookup procId graphEnv `orElse` mapEmpty-                     graph' = mapInsert bid b graph+splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl+                  -> UniqSM [CmmDecl]+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]+splitAtProcPoints platform entry_label callPPs procPoints procMap cmmProc = do+  -- Build a map from procpoints to the blocks they reach+  let (CmmProc (TopInfo {info_tbls = info_tbls}) top_l _ g@(CmmGraph {g_entry=entry})) = cmmProc -     let liveness = cmmGlobalLiveness dflags g-     let ppLiveness pp = filter isArgReg $-                         regSetToList $-                         expectJust "ppLiveness" $ mapLookup pp liveness+  let add graphEnv procId bid b = mapInsert procId graph' graphEnv+        where+          graph' = mapInsert bid b graph+          graph  = mapLookup procId graphEnv `orElse` mapEmpty -     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g+  let add_block :: LabelMap (LabelMap CmmBlock) -> CmmBlock -> LabelMap (LabelMap CmmBlock)+      add_block graphEnv b =+        case mapLookup bid procMap of+          Just ProcPoint -> add graphEnv bid bid b+          Just (ReachedBy set) ->+            case setElems set of+              []   -> graphEnv+              [id] -> add graphEnv id bid b+              _    -> panic "Each block should be reachable from only one ProcPoint"+          Nothing -> graphEnv+        where+          bid = entryLabel b -     -- Build a map from proc point BlockId to pairs of:-     --  * Labels for their new procedures-     --  * Labels for the info tables of their new procedures (only if-     --    the proc point is a callPP)-     -- Due to common blockification, we may overestimate the set of procpoints.-     let add_label map pp = mapInsert pp lbls map-           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))-                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>-                                                    Just info_table_lbl)-                      where block_lbl      = blockLbl pp-                            info_table_lbl = infoTblLbl pp -         procLabels :: LabelMap (CLabel, Maybe CLabel)-         procLabels = foldl' add_label mapEmpty-                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))+  let liveness = cmmGlobalLiveness platform g+  let ppLiveness pp = filter isArgReg $ regSetToList $+                        expectJust "ppLiveness" $ mapLookup pp liveness+  graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g -     -- In each new graph, add blocks jumping off to the new procedures,-     -- and replace branches to procpoints with branches to the jump-off blocks-     let add_jump_block-             :: (LabelMap Label, [CmmBlock])-             -> (Label, CLabel)-             -> UniqSM (LabelMap Label, [CmmBlock])-         add_jump_block (env, bs) (pp, l) =-           do bid <- liftM mkBlockId getUniqueM-              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump-                  live = ppLiveness pp-                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0-              return (mapInsert pp bid env, b : bs)+  -- Build a map from proc point BlockId to pairs of:+  --  * Labels for their new procedures+  --  * Labels for the info tables of their new procedures (only if+  --    the proc point is a callPP)+  -- Due to common blockification, we may overestimate the set of procpoints.+  let add_label map pp = mapInsert pp lbls map+        where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))+                   | otherwise   = (block_lbl, guard (setMember pp callPPs) >>+                                                 Just info_table_lbl)+                   where block_lbl      = blockLbl pp+                         info_table_lbl = infoTblLbl pp -         add_jumps-             :: LabelMap CmmGraph-             -> (Label, LabelMap CmmBlock)-             -> UniqSM (LabelMap CmmGraph)-         add_jumps newGraphEnv (ppId, blockEnv) =-           do let needed_jumps = -- find which procpoints we currently branch to-                    mapFoldr add_if_branch_to_pp [] blockEnv-                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]-                  add_if_branch_to_pp block rst =-                    case lastNode block of-                      CmmBranch id          -> add_if_pp id rst-                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)-                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids-                      _                     -> rst+      procLabels :: LabelMap (CLabel, Maybe CLabel)+      procLabels = foldl' add_label mapEmpty+                          (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) -                  -- 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-                             | otherwise        = toEntryLbl info_lbl-                  jump_label Nothing  block_lbl = block_lbl+  -- In each new graph, add blocks jumping off to the new procedures,+  -- and replace branches to procpoints with branches to the jump-off blocks+  let add_jump_block :: (LabelMap Label, [CmmBlock])+                     -> (Label, CLabel)+                     -> UniqSM (LabelMap Label, [CmmBlock])+      add_jump_block (env, bs) (pp, l) = do+        bid <- liftM mkBlockId getUniqueM+        let b    = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump+            live = ppLiveness pp+            jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0+        return (mapInsert pp bid env, b : bs) -                  add_if_pp id rst = case mapLookup id procLabels of-                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst-                                       Nothing                 -> rst-              (jumpEnv, jumpBlocks) <--                 foldM add_jump_block (mapEmpty, []) needed_jumps-                  -- update the entry block-              let b = expectJust "block in env" $ mapLookup ppId blockEnv-                  blockEnv' = mapInsert ppId b blockEnv-                  -- replace branches to procpoints with branches to jumps-                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'-                  -- add the jump blocks to the graph-                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks-              let g' = ofBlockMap ppId blockEnv'''-              -- pprTrace "g' pre jumps" (ppr g') $ do-              return (mapInsert ppId g' newGraphEnv)+  -- when jumping to a PP that has an info table, if+  -- tablesNextToCode is off we must jump to the entry+  -- label instead.+  let tablesNextToCode = platformTablesNextToCode platform -     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv+  let jump_label (Just info_lbl) _+                 | tablesNextToCode = info_lbl+                 | otherwise        = toEntryLbl platform info_lbl+      jump_label Nothing  block_lbl = block_lbl -     let to_proc (bid, g)-             | bid == entry-             =  CmmProc (TopInfo {info_tbls  = info_tbls,-                                  stack_info = stack_info})-                        top_l live g'-             | otherwise-             = case expectJust "pp label" $ mapLookup bid procLabels of-                 (lbl, Just info_lbl)-                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)-                                        , stack_info=stack_info})-                               lbl live g'-                 (lbl, Nothing)-                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})-                               lbl live g'-                where-                 g' = replacePPIds g-                 live = ppLiveness (g_entry g')-                 stack_info = StackInfo { arg_space = 0-                                        , do_layout = True }-                               -- cannot use panic, this is printed by -ddump-cmm+  let add_if_pp id rst =+        case mapLookup id procLabels of+          Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst+          Nothing                 -> rst -         -- References to procpoint IDs can now be replaced with the-         -- infotable's label-         replacePPIds g = {-# SCC "replacePPIds" #-}-                          mapGraphNodes (id, mapExp repl, mapExp repl) g-           where repl e@(CmmLit (CmmBlock bid)) =-                   case mapLookup bid procLabels of-                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)-                     _ -> e-                 repl e = e+  let add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]+      add_if_branch_to_pp block rst =+        case lastNode block of+          CmmBranch id            -> add_if_pp id rst+          CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)+          CmmSwitch _ ids         -> foldr add_if_pp rst $ switchTargetsToList ids+          _                       -> rst -     -- The C back end expects to see return continuations before the-     -- call sites.  Here, we sort them in reverse order -- it gets-     -- reversed later.-     let (_, block_order) =-             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)-                   (revPostorder g)-         add_block_num (i, map) block =-           (i + 1, mapInsert (entryLabel block) i map)-         sort_fn (bid, _) (bid', _) =-           compare (expectJust "block_order" $ mapLookup bid  block_order)-                   (expectJust "block_order" $ mapLookup bid' block_order)-     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv-     return -- pprTrace "procLabels" (ppr procLabels)-            -- pprTrace "splitting graphs" (ppr procs)-            procs-splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]+  let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)+      add_jumps newGraphEnv (ppId, blockEnv) = do+        -- find which procpoints we currently branch to+        let needed_jumps = mapFoldr add_if_branch_to_pp [] blockEnv++        (jumpEnv, jumpBlocks) <-+           foldM add_jump_block (mapEmpty, []) needed_jumps+            -- update the entry block+        let b = expectJust "block in env" $ mapLookup ppId blockEnv+            blockEnv' = mapInsert ppId b blockEnv+            -- replace branches to procpoints with branches to jumps+            blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'+            -- add the jump blocks to the graph+            blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks+        let g' = ofBlockMap ppId blockEnv'''+        -- pprTrace "g' pre jumps" (ppr g') $ do+        return (mapInsert ppId g' newGraphEnv)++  graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv++  let to_proc (bid, g)+          | bid == entry+          =  CmmProc (TopInfo {info_tbls  = info_tbls,+                               stack_info = stack_info})+                     top_l live g'+          | otherwise+          = case expectJust "pp label" $ mapLookup bid procLabels of+              (lbl, Just info_lbl)+                 -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)+                                     , stack_info=stack_info})+                            lbl live g'+              (lbl, Nothing)+                 -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})+                            lbl live g'+             where+              g' = replacePPIds g+              live = ppLiveness (g_entry g')+              stack_info = StackInfo { arg_space = 0+                                     , do_layout = True }+                            -- cannot use panic, this is printed by -ddump-cmm++      -- References to procpoint IDs can now be replaced with the+      -- infotable's label+      replacePPIds g = {-# SCC "replacePPIds" #-}+                       mapGraphNodes (id, mapExp repl, mapExp repl) g+        where repl e@(CmmLit (CmmBlock bid)) =+                case mapLookup bid procLabels of+                  Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)+                  _ -> e+              repl e = e++  -- The C back end expects to see return continuations before the+  -- call sites.  Here, we sort them in reverse order -- it gets+  -- reversed later.+  let add_block_num (i, map) block =+        (i + 1, mapInsert (entryLabel block) i map)+  let (_, block_order) =+          foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)+                (revPostorder g)+  let sort_fn (bid, _) (bid', _) =+        compare (expectJust "block_order" $ mapLookup bid  block_order)+                (expectJust "block_order" $ mapLookup bid' block_order)++  return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv  -- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a -- recursive lookup, see comment below.

GHC/Cmm/Sink.hs view

@@ -1,4 +1,6 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module GHC.Cmm.Sink (      cmmSink   ) where@@ -8,6 +10,7 @@ import GHC.Cmm import GHC.Cmm.Opt import GHC.Cmm.Liveness+import GHC.Cmm.LRegSet import GHC.Cmm.Utils import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Label@@ -16,30 +19,13 @@ import GHC.Platform.Regs  import GHC.Platform-import GHC.Driver.Session-import GHC.Types.Unique import GHC.Types.Unique.FM  import qualified Data.IntSet as IntSet import Data.List (partition)-import qualified Data.Set as Set import Data.Maybe --- Compact sets for membership tests of local variables.--type LRegSet = IntSet.IntSet--emptyLRegSet :: LRegSet-emptyLRegSet = IntSet.empty--nullLRegSet :: LRegSet -> Bool-nullLRegSet = IntSet.null--insertLRegSet :: LocalReg -> LRegSet -> LRegSet-insertLRegSet l = IntSet.insert (getKey (getUnique l))--elemLRegSet :: LocalReg -> LRegSet -> Bool-elemLRegSet l = IntSet.member (getKey (getUnique l))+import GHC.Exts (inline)  -- ----------------------------------------------------------------------------- -- Sinking and inlining@@ -165,11 +151,11 @@   --     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-  getLive l = mapFindWithDefault Set.empty l liveness+  liveness = cmmLocalLivenessL platform graph+  getLive l = mapFindWithDefault emptyLRegSet l liveness    blocks = revPostorder graph @@ -181,7 +167,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 @@ -190,20 +175,20 @@       -- Annotate the middle nodes with the registers live *after*       -- 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 = IntSet.unions (map getLive succs)+      live_middle = gen_killL 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       -- of registers live in them.       (joins, nonjoins) = partition (`mapMember` join_pts) succs-      live_in_joins = Set.unions (map getLive joins)+      live_in_joins = IntSet.unions (map getLive joins)        -- We do not want to sink an assignment into multiple branches,       -- so identify the set of registers live in multiple successors.@@ -212,31 +197,33 @@       -- now live in multiple branches.       init_live_sets = map getLive nonjoins       live_in_multi live_sets r =-         case filter (Set.member r) live_sets of+         case filter (elemLRegSet r) live_sets of            (_one:_two:_) -> True            _ -> 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 :: (LocalReg, CmmExpr, AbsMem)+                      -> [LRegSet] -> (Bool, [LRegSet])       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-                        || r `Set.member` live_in_joins+            should_drop =  conflicts platform a final_last+                        || not (isTrivial platform rhs) && live_in_multi live_sets r+                        || r `elemLRegSet` live_in_joins              live_sets' | should_drop = live_sets                        | otherwise   = map upd live_sets -            upd set | r `Set.member` set = set `Set.union` live_rhs+            upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs                     | otherwise          = set -            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs+            live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet 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 +242,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 +255,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 -> LRegSet -> [CmmNode O O] -> [(LRegSet, CmmNode O O)]+annotate platform live nodes = snd $ foldr ann (live,[]) nodes+  where ann n (live,nodes) = (gen_killL platform n live, (live,n) : nodes)  -- -- Find the blocks that have multiple successors (join points)@@ -287,14 +274,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 -> LRegSet -> 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)+              needed = r `elemLRegSet` live+                       || 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,8 +300,8 @@ --    * a list of assignments that will be placed *after* that block. -- -walk :: DynFlags-     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with+walk :: Platform+     -> [(LRegSet, CmmNode O O)]    -- nodes of the block, annotated with                                         -- the set of registers live *after*                                         -- this node. @@ -327,7 +314,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 +323,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 @@ -369,24 +355,24 @@ -- out of inlining, but the inliner will see that r is live -- after the instruction and choose not to inline r in the rhs. ---shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool+shouldDiscard :: CmmNode e x -> LRegSet -> Bool shouldDiscard node live    = case node of        CmmAssign r (CmmReg r') | r == r' -> True-       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)+       CmmAssign (CmmLocal r) _ -> not (r `elemLRegSet` live)        _otherwise -> False   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 +383,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,8 +392,9 @@ -- inlining opens up opportunities for doing so.  tryToInline-   :: DynFlags-   -> LocalRegSet               -- set of registers live after this+   :: forall x. Platform+   -> LRegSet               -- set of registers live after this+  --  -> LocalRegSet               -- set of registers live after this                                 -- node.  We cannot inline anything                                 -- that is live after the node, unless                                 -- it is small enough to duplicate.@@ -418,43 +405,50 @@       , Assignments             -- Remaining assignments       ) -tryToInline dflags live node assigs = go usages node emptyLRegSet assigs+tryToInline platform liveAfter node assigs =+  -- pprTrace "tryToInline assig length:" (ppr $ length assigs) $+    go usages liveAfter 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, [])+  go :: UniqFM LocalReg Int -> LRegSet -> CmmNode O x -> LRegSet -> Assignments+     -> (CmmNode O x, Assignments)+  go _usages _live node _skipped [] = (node, []) -  go usages node skipped (a@(l,rhs,_) : rest)-   | cannot_inline           = dont_inline-   | occurs_none             = discard  -- Note [discard during inlining]-   | occurs_once             = inline_and_discard-   | isTrivial dflags rhs    = inline_and_keep-   | otherwise               = dont_inline+  go usages live node skipped (a@(l,rhs,_) : rest)+   | cannot_inline            = dont_inline+   | occurs_none              = discard  -- Note [discard during inlining]+   | occurs_once              = inline_and_discard+   | 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+        inline_and_discard = go usages' live inl_node skipped rest+          where usages' = foldLocalRegsUsed platform addUsage usages rhs -        discard = go usages node skipped rest+        discard = go usages live node skipped rest          dont_inline        = keep node  -- don't inline the assignment, keep it         inline_and_keep    = keep inl_node -- inline the assignment, keep it +        keep :: CmmNode O x -> (CmmNode O x, Assignments)         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 rhs-                -- we must not inline anything that is mentioned in the RHS-                -- of a binding that we have already skipped, so we set the-                -- usages of the regs on the RHS to 2.+          where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest +                -- Avoid discarding of assignments to vars on the rhs.+                -- See Note [Keeping assignemnts mentioned in skipped RHSs]+                -- usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2)+                                            -- usages rhs+                live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m)+                                            live rhs+         cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]                         || l `elemLRegSet` skipped-                        || not (okToInline dflags rhs node)+                        || not (okToInline platform rhs node) +        -- How often is l used in the current node.         l_usages = lookupUFM usages l-        l_live   = l `elemRegSet` live+        l_live   = l `elemLRegSet` live          occurs_once = not l_live && l_usages == Just 1         occurs_none = not l_live && l_usages == Nothing@@ -470,7 +464,28 @@         inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args         inl_exp other = other +{- Note [Keeping assignemnts mentioned in skipped RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +    If we have to assignments: [z = y, y = e1] and we skip+    z we *must* retain the assignment y = e1. This is because+    we might inline "z = y" into another node later on so we+    must ensure y is still defined at this point.++    If we dropped the assignment of "y = e1" then we would end up+    referencing a variable which hasn't been mentioned after+    inlining.++    We use a hack to do this.++    We pretend the regs from the rhs are live after the current+    node. Since we only discard assignments to variables+    which are dead after the current block this prevents discarding of the+    assignment. It still allows inlining should e1 be a trivial rhs+    however.++-}+ {- Note [improveConditional]  cmmMachOpFold tries to simplify conditionals to turn things like@@ -558,36 +573,42 @@  regsUsedIn :: LRegSet -> CmmExpr -> Bool regsUsedIn ls _ | nullLRegSet ls = False-regsUsedIn ls e = wrapRecExpf f e False-  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True-        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True-        f _ z = z+regsUsedIn ls e = go ls e False+  where use :: LRegSet -> CmmExpr -> Bool -> Bool+        use ls (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True+        use ls (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True+        use _ls _ z = z +        go :: LRegSet -> CmmExpr -> Bool -> Bool+        go ls (CmmMachOp _ es) z = foldr (go ls) z es+        go ls (CmmLoad addr _) z = go ls addr z+        go ls e                z = use ls e z+ -- we don't inline into CmmUnsafeForeignCall if the expression refers -- to global registers.  This is a HACK to avoid global registers -- clashing with C argument-passing registers, really the back-end -- 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 +627,35 @@    -- (7) otherwise, no conflict   | otherwise = False-  where-    platform = targetPlatform dflags +{- Note [Inlining foldRegsDefd]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~++   foldRegsDefd is, after optimization, *not* a small function so+   it's only marked INLINEABLE, but not INLINE.++   However in some specific cases we call it *very* often making it+   important to avoid the overhead of allocating the folding function.++   So we simply force inlining via the magic inline function.+   For T3294 this improves allocation with -O by ~1%.++-}+ -- 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 =+    -- See Note [Inlining foldRegsDefd]+    inline 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 =+    -- See Note [Inlining foldRegsDefd]+    inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmLocal  r) expr)                  False node  -- Note [Sinking and calls]

GHC/Cmm/Switch.hs view

@@ -8,14 +8,15 @@      switchTargetsToList, eqSwitchTargetWith,       SwitchPlan(..),-     targetSupportsSwitch,+     backendSupportsSwitch,      createSwitchPlan,   ) where  import GHC.Prelude  import GHC.Utils.Outputable-import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Utils.Panic import GHC.Cmm.Dataflow.Label (Label)  import Data.Maybe@@ -316,12 +317,12 @@ -}  --- | Does the target support switch out of the box? Then leave this to the--- target!-targetSupportsSwitch :: HscTarget -> Bool-targetSupportsSwitch HscC = True-targetSupportsSwitch HscLlvm = True-targetSupportsSwitch _ = False+-- | Does the backend support switch out of the box? Then leave this to the+-- backend!+backendSupportsSwitch :: Backend -> Bool+backendSupportsSwitch ViaC = True+backendSupportsSwitch LLVM = True+backendSupportsSwitch _    = False  -- | This function creates a SwitchPlan from a SwitchTargets value, breaking it -- down into smaller pieces suitable for code generation.

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)-    | targetSupportsSwitch (hscTarget 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]

GHC/Cmm/Type.hs view

@@ -32,9 +32,9 @@ import GHC.Prelude  import GHC.Platform-import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.Word import Data.Int@@ -50,14 +50,15 @@   -- and is used extensively in pattern-matching  data CmmType    -- The important one!-  = CmmType CmmCat Width+  = CmmType CmmCat !Width+  deriving Show  data CmmCat                -- "Category" (not exported)    = GcPtrCat              -- GC pointer    | BitsCat               -- Non-pointer    | FloatCat              -- Float    | VecCat Length CmmCat  -- Vector-   deriving( Eq )+   deriving( Eq, Show )         -- See Note [Signed vs unsigned] at the end  instance Outputable CmmType where@@ -130,8 +131,8 @@ gcWord :: Platform -> CmmType gcWord platform = CmmType GcPtrCat (wordWidth platform) -cInt :: DynFlags -> CmmType-cInt dflags = cmmBits (cIntWidth  dflags)+cInt :: Platform -> CmmType+cInt platform = cmmBits (cIntWidth platform)  ------------ Predicates ---------------- isFloatType, isGcPtrType, isBitsType :: CmmType -> Bool@@ -196,8 +197,8 @@  PW8 -> 0xFFFFFFFF  -- cIntRep is the Width for a C-language 'int'-cIntWidth :: DynFlags -> Width-cIntWidth dflags = case cINT_SIZE dflags of+cIntWidth :: Platform -> Width+cIntWidth platform = case pc_CINT_SIZE (platformConstants platform) of                    4 -> W32                    8 -> W64                    s -> panic ("cIntWidth: Unknown cINT_SIZE: " ++ show s)@@ -311,6 +312,8 @@ -- Hints are extra type information we attach to the arguments and -- results of a foreign call, where more type information is sometimes -- needed by the ABI to make the correct kind of call.+--+-- See Note [Signed vs unsigned] for one case where this is used.  data ForeignHint   = NoHint | AddrHint | SignedHint@@ -323,25 +326,25 @@ -- These don't really belong here, but I don't know where is best to -- put them. -rEP_CostCentreStack_mem_alloc :: DynFlags -> CmmType-rEP_CostCentreStack_mem_alloc dflags+rEP_CostCentreStack_mem_alloc :: Platform -> CmmType+rEP_CostCentreStack_mem_alloc platform     = cmmBits (widthFromBytes (pc_REP_CostCentreStack_mem_alloc pc))-    where pc = platformConstants dflags+    where pc = platformConstants platform -rEP_CostCentreStack_scc_count :: DynFlags -> CmmType-rEP_CostCentreStack_scc_count dflags+rEP_CostCentreStack_scc_count :: Platform -> CmmType+rEP_CostCentreStack_scc_count platform     = cmmBits (widthFromBytes (pc_REP_CostCentreStack_scc_count pc))-    where pc = platformConstants dflags+    where pc = platformConstants platform -rEP_StgEntCounter_allocs :: DynFlags -> CmmType-rEP_StgEntCounter_allocs dflags+rEP_StgEntCounter_allocs :: Platform -> CmmType+rEP_StgEntCounter_allocs platform     = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocs pc))-    where pc = platformConstants dflags+    where pc = platformConstants platform -rEP_StgEntCounter_allocd :: DynFlags -> CmmType-rEP_StgEntCounter_allocd dflags+rEP_StgEntCounter_allocd :: Platform -> CmmType+rEP_StgEntCounter_allocd platform     = cmmBits (widthFromBytes (pc_REP_StgEntCounter_allocd pc))-    where pc = platformConstants dflags+    where pc = platformConstants platform  ------------------------------------------------------------------------- {-      Note [Signed vs unsigned]@@ -427,4 +430,3 @@ this, the cons outweigh the pros.  -}-

GHC/Cmm/Utils.hs view

@@ -14,7 +14,7 @@  module GHC.Cmm.Utils(         -- CmmType-        primRepCmmType, slotCmmType, slotForeignHint,+        primRepCmmType, slotCmmType,         typeCmmType, typeForeignHint, primRepForeignHint,          -- CmmLit@@ -48,7 +48,7 @@          -- Tagging         cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,-        cmmConstrTag1,+        cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,          -- Overlap and usage         regsOverlap, regUsedIn,@@ -79,13 +79,12 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Utils.Outputable-import GHC.Driver.Session+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Platform.Regs  import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Data.Bits import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block@@ -160,14 +159,6 @@ primRepForeignHint DoubleRep    = NoHint primRepForeignHint (VecRep {})  = NoHint -slotForeignHint :: SlotTy -> ForeignHint-slotForeignHint PtrLiftedSlot   = AddrHint-slotForeignHint PtrUnliftedSlot = AddrHint-slotForeignHint WordSlot        = NoHint-slotForeignHint Word64Slot      = NoHint-slotForeignHint FloatSlot       = NoHint-slotForeignHint DoubleSlot      = NoHint- typeForeignHint :: UnaryType -> ForeignHint typeForeignHint = primRepForeignHint . typePrimRep1 @@ -266,9 +257,11 @@    CmmStackSlot area off -> CmmStackSlot area (off - byte_off)   -- note stack area offsets increase towards lower addresses    CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]-      -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)]-   _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]-         where width = cmmExprWidth platform e+      -> let !lit_off = (byte_off1 + toInteger byte_off)+         in CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt lit_off rep)]+   _ -> let !width = cmmExprWidth platform e+        in+        CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]  -- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above. cmmRegOff :: CmmReg -> Int -> CmmExpr@@ -430,26 +423,29 @@ -- --------------------------------------------------- +tAG_MASK :: Platform -> Int+tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1++mAX_PTR_TAG :: Platform -> Int+mAX_PTR_TAG = tAG_MASK+ -- Tag bits mask-cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr-cmmTagMask dflags = mkIntExpr (targetPlatform dflags) (tAG_MASK dflags)-cmmPointerMask dflags = mkIntExpr (targetPlatform dflags) (complement (tAG_MASK dflags))+cmmTagMask, cmmPointerMask :: Platform -> CmmExpr+cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)+cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))  -- Used to untag a possibly tagged pointer -- A static label need not be untagged-cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr+cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr cmmUntag _ e@(CmmLit (CmmLabel _)) = e -- Default case-cmmUntag dflags e = cmmAndWord platform e (cmmPointerMask dflags)-   where platform = targetPlatform dflags+cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)  -- Test if a closure pointer is untagged-cmmIsTagged dflags e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask dflags)) (zeroExpr platform)-   where platform = targetPlatform dflags+cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)  -- Get constructor tag, but one based.-cmmConstrTag1 dflags e = cmmAndWord platform e (cmmTagMask dflags)-   where platform = targetPlatform dflags+cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)   -----------------------------------------------------------------------------

GHC/CmmToAsm.hs view

@@ -2,53 +2,89 @@ -- -- (c) The University of Glasgow 1993-2004 ----- This is the top-level module in the native code generator. -- -- -----------------------------------------------------------------------------  {-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,     DeriveFunctor #-}--#if !defined(GHC_LOADED_INTO_GHCI)+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UnboxedTuples #-}-#endif+{-# LANGUAGE ScopedTypeVariables #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module GHC.CmmToAsm (-                    -- * Module entry point-                    nativeCodeGen+-- | Native code generator+--+-- The native-code generator has machine-independent and+-- machine-dependent modules.+--+-- This module ("GHC.CmmToAsm") is the top-level machine-independent+-- module.  Before entering machine-dependent land, we do some+-- machine-independent optimisations (defined below) on the+-- 'CmmStmts's.+--+-- We convert to the machine-specific 'Instr' datatype with+-- 'cmmCodeGen', assuming an infinite supply of registers.  We then use+-- a machine-independent register allocator ('regAlloc') to rejoin+-- reality.  Obviously, 'regAlloc' has machine-specific helper+-- functions (see about "RegAllocInfo" below).+--+-- Finally, we order the basic blocks of the function so as to minimise+-- the number of jumps between blocks, by utilising fallthrough wherever+-- possible.+--+-- The machine-dependent bits break down as follows:+--+--   * ["MachRegs"]  Everything about the target platform's machine+--     registers (and immediate operands, and addresses, which tend to+--     intermingle/interact with registers).+--+--   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should+--     have a module of its own), plus a miscellany of other things+--     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)+--+--   * ["MachCodeGen"]  is where 'Cmm' stuff turns into+--     machine instructions.+--+--   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really+--     a 'SDoc').+--+--   * ["RegAllocInfo"] In the register allocator, we manipulate+--     'MRegsState's, which are 'BitSet's, one bit per machine register.+--     When we want to say something about a specific machine register+--     (e.g., ``it gets clobbered by this instruction''), we set/unset+--     its bit.  Obviously, we do this 'BitSet' thing for efficiency+--     reasons.+--+--     The 'RegAllocInfo' module collects together the machine-specific+--     info needed to do register allocation.+--+--    * ["RegisterAlloc"] The (machine-independent) register allocator.+-- -}+--+module GHC.CmmToAsm+   ( nativeCodeGen -                    -- * Test-only exports: see trac #12744-                    -- used by testGraphNoSpills, which needs to access-                    -- the register allocator intermediate data structures-                    -- cmmNativeGen emits-                  , cmmNativeGen-                  , NcgImpl(..)-                  , x86NcgImpl-                  ) where+   -- * Test-only exports: see trac #12744+   -- used by testGraphNoSpills, which needs to access+   -- the register allocator intermediate data structures+   -- cmmNativeGen emits+   , cmmNativeGen+   , NcgImpl(..)+   , initNCGConfig+   )+where  #include "HsVersions.h"  import GHC.Prelude -import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen-import qualified GHC.CmmToAsm.X86.Regs    as X86.Regs-import qualified GHC.CmmToAsm.X86.Instr   as X86.Instr-import qualified GHC.CmmToAsm.X86.Ppr     as X86.Ppr--import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC.CodeGen-import qualified GHC.CmmToAsm.SPARC.Regs    as SPARC.Regs-import qualified GHC.CmmToAsm.SPARC.Instr   as SPARC.Instr-import qualified GHC.CmmToAsm.SPARC.Ppr     as SPARC.Ppr-import qualified GHC.CmmToAsm.SPARC.ShortcutJump   as SPARC.ShortcutJump-import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC.CodeGen.Expand--import qualified GHC.CmmToAsm.PPC.CodeGen as PPC.CodeGen-import qualified GHC.CmmToAsm.PPC.Regs    as PPC.Regs-import qualified GHC.CmmToAsm.PPC.RegInfo as PPC.RegInfo-import qualified GHC.CmmToAsm.PPC.Instr   as PPC.Instr-import qualified GHC.CmmToAsm.PPC.Ppr     as PPC.Ppr+import qualified GHC.CmmToAsm.X86   as X86+import qualified GHC.CmmToAsm.PPC   as PPC+import qualified GHC.CmmToAsm.SPARC as SPARC+import qualified GHC.CmmToAsm.AArch64 as AArch64  import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear                as Linear@@ -71,6 +107,7 @@ import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Dwarf import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Cmm.DebugBlock  import GHC.Cmm.BlockId@@ -87,12 +124,14 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Misc+import GHC.Utils.Logger -import GHC.Types.Basic       ( Alignment ) import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.Set import GHC.Utils.Error@@ -100,180 +139,40 @@ import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream --- DEBUGGING ONLY---import GHC.Data.OrdList--import Data.List+import Data.List (sortBy, groupBy) import Data.Maybe import Data.Ord         ( comparing ) import Control.Exception import Control.Monad import System.IO -{--The native-code generator has machine-independent and-machine-dependent modules.--This module ("AsmCodeGen") is the top-level machine-independent-module.  Before entering machine-dependent land, we do some-machine-independent optimisations (defined below) on the-'CmmStmts's.--We convert to the machine-specific 'Instr' datatype with-'cmmCodeGen', assuming an infinite supply of registers.  We then use-a machine-independent register allocator ('regAlloc') to rejoin-reality.  Obviously, 'regAlloc' has machine-specific helper-functions (see about "RegAllocInfo" below).--Finally, we order the basic blocks of the function so as to minimise-the number of jumps between blocks, by utilising fallthrough wherever-possible.--The machine-dependent bits break down as follows:--  * ["MachRegs"]  Everything about the target platform's machine-    registers (and immediate operands, and addresses, which tend to-    intermingle/interact with registers).--  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should-    have a module of its own), plus a miscellany of other things-    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)--  * ["MachCodeGen"]  is where 'Cmm' stuff turns into-    machine instructions.--  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really-    a 'SDoc').--  * ["RegAllocInfo"] In the register allocator, we manipulate-    'MRegsState's, which are 'BitSet's, one bit per machine register.-    When we want to say something about a specific machine register-    (e.g., ``it gets clobbered by this instruction''), we set/unset-    its bit.  Obviously, we do this 'BitSet' thing for efficiency-    reasons.--    The 'RegAllocInfo' module collects together the machine-specific-    info needed to do register allocation.--   * ["RegisterAlloc"] The (machine-independent) register allocator.--}- ---------------------nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+nativeCodeGen :: forall a . Logger -> DynFlags -> Module -> ModLocation -> Handle -> UniqSupply               -> Stream IO RawCmmGroup a               -> IO a-nativeCodeGen dflags this_mod modLoc h us cmms- = let config   = initConfig dflags+nativeCodeGen logger dflags this_mod modLoc h us cmms+ = let config   = initNCGConfig dflags this_mod        platform = ncgPlatform config-       nCG' :: ( Outputable statics, Outputable instr-               , Outputable jumpDest, Instruction instr)+       nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)             => NcgImpl statics instr jumpDest -> IO a-       nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms+       nCG' ncgImpl = nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms    in case platformArch platform of-      ArchX86       -> nCG' (x86NcgImpl    config)-      ArchX86_64    -> nCG' (x86_64NcgImpl config)-      ArchPPC       -> nCG' (ppcNcgImpl    config)-      ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"-      ArchSPARC     -> nCG' (sparcNcgImpl  config)+      ArchX86       -> nCG' (X86.ncgX86     config)+      ArchX86_64    -> nCG' (X86.ncgX86_64  config)+      ArchPPC       -> nCG' (PPC.ncgPPC     config)+      ArchPPC_64 _  -> nCG' (PPC.ncgPPC     config)+      ArchSPARC     -> nCG' (SPARC.ncgSPARC config)       ArchSPARC64   -> panic "nativeCodeGen: No NCG for SPARC64"+      ArchS390X     -> panic "nativeCodeGen: No NCG for S390X"       ArchARM {}    -> panic "nativeCodeGen: No NCG for ARM"-      ArchAArch64   -> panic "nativeCodeGen: No NCG for AArch64"-      ArchPPC_64 _  -> nCG' (ppcNcgImpl    config)+      ArchAArch64   -> nCG' (AArch64.ncgAArch64 config)       ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"+      ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript" -x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)-                                  X86.Instr.Instr X86.Instr.JumpDest-x86NcgImpl config- = (x86_64NcgImpl config)--x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)-                                  X86.Instr.Instr X86.Instr.JumpDest-x86_64NcgImpl config- = NcgImpl {-        ncgConfig                 = config-       ,cmmTopCodeGen             = X86.CodeGen.cmmTopCodeGen-       ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config-       ,getJumpDestBlockId        = X86.Instr.getJumpDestBlockId-       ,canShortcut               = X86.Instr.canShortcut-       ,shortcutStatics           = X86.Instr.shortcutStatics-       ,shortcutJump              = X86.Instr.shortcutJump-       ,pprNatCmmDecl             = X86.Ppr.pprNatCmmDecl config-       ,maxSpillSlots             = X86.Instr.maxSpillSlots config-       ,allocatableRegs           = X86.Regs.allocatableRegs platform-       ,ncgAllocMoreStack         = X86.Instr.allocMoreStack platform-       ,ncgExpandTop              = id-       ,ncgMakeFarBranches        = const id-       ,extractUnwindPoints       = X86.CodeGen.extractUnwindPoints-       ,invertCondBranches        = X86.CodeGen.invertCondBranches-   }-    where-      platform = ncgPlatform config--ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest-ppcNcgImpl config- = NcgImpl {-        ncgConfig                 = config-       ,cmmTopCodeGen             = PPC.CodeGen.cmmTopCodeGen-       ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config-       ,getJumpDestBlockId        = PPC.RegInfo.getJumpDestBlockId-       ,canShortcut               = PPC.RegInfo.canShortcut-       ,shortcutStatics           = PPC.RegInfo.shortcutStatics-       ,shortcutJump              = PPC.RegInfo.shortcutJump-       ,pprNatCmmDecl             = PPC.Ppr.pprNatCmmDecl config-       ,maxSpillSlots             = PPC.Instr.maxSpillSlots config-       ,allocatableRegs           = PPC.Regs.allocatableRegs platform-       ,ncgAllocMoreStack         = PPC.Instr.allocMoreStack platform-       ,ncgExpandTop              = id-       ,ncgMakeFarBranches        = PPC.Instr.makeFarBranches-       ,extractUnwindPoints       = const []-       ,invertCondBranches        = \_ _ -> id-   }-    where-      platform = ncgPlatform config--sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest-sparcNcgImpl config- = NcgImpl {-        ncgConfig                 = config-       ,cmmTopCodeGen             = SPARC.CodeGen.cmmTopCodeGen-       ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr platform-       ,getJumpDestBlockId        = SPARC.ShortcutJump.getJumpDestBlockId-       ,canShortcut               = SPARC.ShortcutJump.canShortcut-       ,shortcutStatics           = SPARC.ShortcutJump.shortcutStatics-       ,shortcutJump              = SPARC.ShortcutJump.shortcutJump-       ,pprNatCmmDecl             = SPARC.Ppr.pprNatCmmDecl config-       ,maxSpillSlots             = SPARC.Instr.maxSpillSlots config-       ,allocatableRegs           = SPARC.Regs.allocatableRegs-       ,ncgAllocMoreStack         = noAllocMoreStack-       ,ncgExpandTop              = map SPARC.CodeGen.Expand.expandTop-       ,ncgMakeFarBranches        = const id-       ,extractUnwindPoints       = const []-       ,invertCondBranches        = \_ _ -> id-   }-    where-      platform = ncgPlatform config------- Allocating more stack space for spilling is currently only--- supported for the linear register allocator on x86/x86_64, the rest--- default to the panic below.  To support allocating extra stack on--- more platforms provide a definition of ncgAllocMoreStack.----noAllocMoreStack :: Int -> NatCmmDecl statics instr-                 -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)])-noAllocMoreStack amount _-  = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"-        ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"-        ++  "   is a known limitation in the linear allocator.\n"-        ++  "\n"-        ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."-        ++  "   You can still file a bug report if you like.\n"-- -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation. data NativeGenAcc statics instr@@ -318,42 +217,46 @@ See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock". -} -nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,-                   Instruction instr)-               => DynFlags-               -> Module -> ModLocation+nativeCodeGen' :: (OutputableP Platform statics, Outputable jumpDest, Instruction instr)+               => Logger+               -> DynFlags+               -> NCGConfig+               -> ModLocation                -> NcgImpl statics instr jumpDest                -> Handle                -> UniqSupply                -> Stream IO RawCmmGroup a                -> IO a-nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms+nativeCodeGen' logger dflags config modLoc ncgImpl h us cmms  = do         -- BufHandle is a performance hack.  We could hide it inside         -- Pretty if it weren't for the fact that we do lots of little         -- printDocs here (in order to do codegen in constant space).         bufh <- newBufHandle h         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty-        (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us+        (ngs, us', a) <- cmmNativeGenStream logger dflags config modLoc ncgImpl bufh us                                          cmms ngs0-        _ <- finishNativeGen dflags modLoc bufh us' ngs+        _ <- finishNativeGen logger dflags config modLoc bufh us' ngs         return a  finishNativeGen :: Instruction instr-                => DynFlags+                => Logger+                -> DynFlags+                -> NCGConfig                 -> ModLocation                 -> BufHandle                 -> UniqSupply                 -> NativeGenAcc statics instr                 -> IO UniqSupply-finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs- = withTimingSilent dflags (text "NCG") (`seq` ()) $ do+finishNativeGen logger dflags config modLoc bufh@(BufHandle _ _ h) us ngs+ = withTimingSilent logger dflags (text "NCG") (`seq` ()) $ do         -- Write debug data and finish-        let emitDw = debugLevel dflags > 0-        us' <- if not emitDw then return us else do-          (dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)-          emitNativeCode dflags bufh dwarf-          return us'+        us' <- if not (ncgDwarfEnabled config)+                  then return us+                  else do+                     (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)+                     emitNativeCode logger dflags config bufh dwarf+                     return us'         bFlush bufh          -- dump global NCG stats for graph coloring allocator@@ -368,8 +271,8 @@            dump_stats (Color.pprStats stats graphGlobal) -          let platform = targetPlatform dflags-          dumpIfSet_dyn dflags+          let platform = ncgPlatform config+          dumpIfSet_dyn logger dflags                   Opt_D_dump_asm_conflicts "Register conflict graph"                   FormatText                   $ Color.dotGraph@@ -386,30 +289,38 @@           dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)          -- write out the imports-        let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)+        let ctx = ncgAsmContext config         printSDocLn ctx Pretty.LeftMode h-                $ makeImportsDoc dflags (concat (ngs_imports ngs))+                $ makeImportsDoc config (concat (ngs_imports ngs))         return us'   where-    dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify)-                   (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"+    dump_stats = putDumpMsg logger dflags (mkDumpStyle alwaysQualify)+                   Opt_D_dump_asm_stats "NCG stats"                    FormatText -cmmNativeGenStream :: (Outputable statics, Outputable instr-                      ,Outputable jumpDest, Instruction instr)-              => DynFlags-              -> Module -> ModLocation+cmmNativeGenStream :: forall statics jumpDest instr a . (OutputableP Platform statics, Outputable jumpDest, Instruction instr)+              => Logger+              -> DynFlags+              -> NCGConfig+              -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle               -> UniqSupply-              -> Stream IO RawCmmGroup a+              -> Stream.Stream IO RawCmmGroup a               -> NativeGenAcc statics instr               -> IO (NativeGenAcc statics instr, UniqSupply, a) -cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs- = do r <- Stream.runStream cmm_stream-      case r of-        Left a ->+cmmNativeGenStream logger dflags config modLoc ncgImpl h us cmm_stream ngs+ = loop us (Stream.runStream cmm_stream) ngs+  where+    ncglabel = text "NCG"+    loop :: UniqSupply+              -> Stream.StreamS IO RawCmmGroup a+              -> NativeGenAcc statics instr+              -> IO (NativeGenAcc statics instr, UniqSupply, a)+    loop us s ngs =+      case s of+        Stream.Done a ->           return (ngs { ngs_imports = reverse $ ngs_imports ngs                       , ngs_natives = reverse $ ngs_natives ngs                       , ngs_colorStats = reverse $ ngs_colorStats ngs@@ -417,44 +328,44 @@                       },                   us,                   a)-        Right (cmms, cmm_stream') -> do+        Stream.Effect m -> m >>= \cmm_stream' -> loop us cmm_stream' ngs+        Stream.Yield cmms cmm_stream' -> do           (us', ngs'') <--            withTimingSilent+            withTimingSilent logger                 dflags                 ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do               -- Generate debug information-              let debugFlag = debugLevel dflags > 0-                  !ndbgs | debugFlag = cmmDebugGen modLoc cmms-                         | otherwise = []+              let !ndbgs | ncgDwarfEnabled config = cmmDebugGen modLoc cmms+                         | otherwise              = []                   dbgMap = debugToMap ndbgs                -- Generate native code-              (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h-                                               dbgMap us cmms ngs 0+              (ngs',us') <- cmmNativeGens logger dflags config modLoc ncgImpl h+                                          dbgMap us cmms ngs 0                -- 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)+                dumpIfSet_dyn logger dflags Opt_D_dump_debug "Debug Infos" FormatText+                  (vcat $ map (pdoc platform) ldbgs)                -- Accumulate debug information for emission in finishNativeGen.               let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }               return (us', ngs'') -          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'-              cmm_stream' ngs''+          loop us' cmm_stream' ngs'' -    where ncglabel = text "NCG"  -- | Do native code generation on all these cmms. -- cmmNativeGens :: forall statics instr jumpDest.-                 (Outputable statics, Outputable instr-                 ,Outputable jumpDest, Instruction instr)-              => DynFlags-              -> Module -> ModLocation+                 (OutputableP Platform statics, Outputable jumpDest, Instruction instr)+              => Logger+              -> DynFlags+              -> NCGConfig+              -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle               -> LabelMap DebugBlock@@ -464,7 +375,7 @@               -> Int               -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go+cmmNativeGens logger dflags config modLoc ncgImpl h dbgMap = go   where     go :: UniqSupply -> [RawCmmDecl]        -> NativeGenAcc statics instr -> Int@@ -477,7 +388,7 @@         let fileIds = ngs_dwarfFiles ngs         (us', fileIds', native, imports, colorStats, linearStats, unwinds)           <- {-# SCC "cmmNativeGen" #-}-             cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap+             cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap                           cmm count          -- Generate .file directives for every new file that has been@@ -489,14 +400,15 @@             pprDecl (f,n) = text "\t.file " <> ppr n <+>                             pprFilePathString (unpackFS f) -        emitNativeCode dflags h $ vcat $+        emitNativeCode logger dflags config h $ vcat $           map pprDecl newFileIds ++           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 debugLevel dflags > 0+        let !labels' = if ncgDwarfEnabled config                        then cmmDebugLabels isMetaInstr native else []             !natives' = if dopt Opt_D_dump_asm_stats dflags                         then native : ngs_natives ngs else []@@ -513,14 +425,14 @@         go us' cmms ngs' (count + 1)  -emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()-emitNativeCode dflags h sdoc = do+emitNativeCode :: Logger -> DynFlags -> NCGConfig -> BufHandle -> SDoc -> IO ()+emitNativeCode logger dflags config h sdoc = do -        let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)+        let ctx = ncgAsmContext config         {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc          -- dump native code-        dumpIfSet_dyn dflags+        dumpIfSet_dyn logger dflags                 Opt_D_dump_asm "Asm code" FormatASM                 sdoc @@ -528,10 +440,10 @@ --      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 instr, Outputable jumpDest)-    => DynFlags-    -> Module -> ModLocation+    :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)+    => Logger+    -> DynFlags+    -> ModLocation     -> NcgImpl statics instr jumpDest         -> UniqSupply         -> DwarfFiles@@ -547,44 +459,45 @@                 , LabelMap [UnwindPoint]                    -- unwinding information for blocks                 ) -cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count+cmmNativeGen logger dflags modLoc ncgImpl us fileIds dbgMap cmm count  = do         let config   = ncgConfig ncgImpl         let platform = ncgPlatform config+        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         let fixed_cmm =                 {-# SCC "fixStgRegisters" #-}-                fixStgRegisters dflags cmm+                fixStgRegisters platform cmm          -- cmm to cmm optimisations         let (opt_cmm, imports) =                 {-# SCC "cmmToCmm" #-}-                cmmToCmm config this_mod fixed_cmm+                cmmToCmm config fixed_cmm -        dumpIfSet_dyn dflags+        dumpIfSet_dyn logger dflags                 Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM-                (pprCmmGroup [opt_cmm])+                (pprCmmGroup platform [opt_cmm])          let cmmCfg = {-# SCC "getCFG" #-}-                     getCfgProc (cfgWeightInfo dflags) opt_cmm+                     getCfgProc platform weights opt_cmm          -- generate native code from cmm         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =                 {-# SCC "genMachCode" #-}-                initUs us $ genMachCode dflags this_mod modLoc+                initUs us $ genMachCode config modLoc                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg -        dumpIfSet_dyn dflags+        dumpIfSet_dyn logger dflags                 Opt_D_dump_asm_native "Native code" FormatASM                 (vcat $ map (pprNatCmmDecl ncgImpl) native) -        maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name+        maybeDumpCfg logger dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name          -- tag instructions with register liveness information         -- also drops dead code. We don't keep the cfg in sync on@@ -597,10 +510,10 @@                 initUs usGen                         $ mapM (cmmTopLiveness livenessCfg platform) native -        dumpIfSet_dyn dflags+        dumpIfSet_dyn logger dflags                 Opt_D_dump_asm_liveness "Liveness annotations added"                 FormatCMM-                (vcat $ map ppr withLiveness)+                (vcat $ map (pprLiveCmmDecl platform) withLiveness)          -- allocate registers         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-@@ -637,18 +550,18 @@                   -- dump out what happened during register allocation-                dumpIfSet_dyn dflags+                dumpIfSet_dyn logger dflags                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced) -                dumpIfSet_dyn dflags+                dumpIfSet_dyn logger dflags                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"                         FormatText                         (vcat   $ map (\(stage, stats)                                         -> text "# --------------------------"                                         $$ text "#  cmm " <> int count <> text " Stage " <> int stage-                                        $$ ppr stats)+                                        $$ ppr (fmap (pprInstr platform) stats))                                 $ zip [0..] regAllocStats)                  let mPprStats =@@ -681,7 +594,7 @@                           $ liftM unzip3                           $ mapM reg_alloc withLiveness -                dumpIfSet_dyn dflags+                dumpIfSet_dyn logger dflags                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM                         (vcat $ map (pprNatCmmDecl ncgImpl) alloced)@@ -703,11 +616,11 @@             cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)          let cfgWithFixupBlks =-                (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg+                (\cfg -> addNodesBetween weights cfg cfgRegAllocUpdates) <$> livenessCfg          -- Insert stack update blocks         let postRegCFG =-                pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))+                pure (foldl' (\m (from,to) -> addImmediateSuccessor weights from to m ))                      <*> cfgWithFixupBlks                      <*> pure stack_updt_blks @@ -716,7 +629,7 @@                 {-# SCC "generateJumpTables" #-}                 generateJumpTables ncgImpl alloced -        when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags+        when (not $ null nativeCfgWeights) $ dumpIfSet_dyn logger dflags                 Opt_D_dump_cfg_weights "CFG Update information"                 FormatText                 ( text "stack:" <+> ppr stack_updt_blks $$@@ -729,9 +642,9 @@          let optimizedCFG :: Maybe CFG             optimizedCFG =-                optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG+                optimizeCFG (gopt Opt_CmmStaticPred dflags) weights cmm <$!> postShortCFG -        maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name+        maybeDumpCfg logger dflags optimizedCFG "CFG Weights - Final" proc_name          --TODO: Partially check validity of the cfg.         let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks@@ -751,7 +664,6 @@                 checkLayout shorted $                 {-# SCC "sequenceBlocks" #-}                 map (BlockLayout.sequenceTop-                        dflags                         ncgImpl optimizedCFG)                     shorted @@ -773,7 +685,7 @@                 ncgExpandTop ncgImpl branchOpt                 --ncgExpandTop ncgImpl sequenced -        dumpIfSet_dyn dflags+        dumpIfSet_dyn logger dflags                 Opt_D_dump_asm_expanded "Synthetic instructions expanded"                 FormatCMM                 (vcat $ map (pprNatCmmDecl ncgImpl) expanded)@@ -795,12 +707,12 @@                 , ppr_raStatsLinear                 , unwinds ) -maybeDumpCfg :: DynFlags -> Maybe CFG -> String -> SDoc -> IO ()-maybeDumpCfg _dflags Nothing _ _ = return ()-maybeDumpCfg dflags (Just cfg) msg proc_name+maybeDumpCfg :: Logger -> DynFlags -> Maybe CFG -> String -> SDoc -> IO ()+maybeDumpCfg _logger _dflags Nothing _ _ = return ()+maybeDumpCfg logger dflags (Just cfg) msg proc_name         | null cfg = return ()         | otherwise-        = dumpIfSet_dyn+        = dumpIfSet_dyn logger                 dflags Opt_D_dump_cfg_weights msg                 FormatText                 (proc_name <> char ':' $$ pprEdgeWeights cfg)@@ -848,8 +760,8 @@  -- | Build a doc for all the imports. ---makeImportsDoc :: DynFlags -> [CLabel] -> SDoc-makeImportsDoc dflags imports+makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc+makeImportsDoc config imports  = dyld_stubs imports             $$             -- On recent versions of Darwin, the linker supports@@ -877,7 +789,6 @@              else Outputable.empty)   where-        config   = initConfig dflags         platform = ncgPlatform config          -- Generate "symbol stubs" for all external symbols that might@@ -891,7 +802,7 @@                 | needImportedSymbols config                 = vcat $                         (pprGotDeclaration config :) $-                        map ( pprImportedSymbol dflags config . fst . head) $+                        map ( pprImportedSymbol config . fst . head) $                         groupBy (\(_,a) (_,b) -> a == b) $                         sortBy (\(_,a) (_,b) -> compare a b) $                         map doPpr $@@ -899,10 +810,9 @@                 | otherwise                 = Outputable.empty -        doPpr lbl = (lbl, renderWithStyle-                              (initSDocContext dflags astyle)-                              (pprCLabel dflags lbl))-        astyle = mkCodeStyle AsmStyle+        doPpr lbl = (lbl, renderWithContext+                              (ncgAsmContext config)+                              (pprCLabel platform AsmStyle lbl))  -- ----------------------------------------------------------------------------- -- Generate jump tables@@ -1013,8 +923,8 @@ -- Unique supply breaks abstraction.  Is that bad?  genMachCode-        :: DynFlags-        -> Module -> ModLocation+        :: NCGConfig+        -> ModLocation         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])         -> DwarfFiles         -> LabelMap DebugBlock@@ -1027,9 +937,9 @@                 , CFG                 ) -genMachCode dflags this_mod modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg+genMachCode config modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg   = do  { initial_us <- getUniqueSupplyM-        ; let initial_st           = mkNatM_State initial_us 0 dflags this_mod+        ; let initial_st           = mkNatM_State initial_us 0 config                                                   modLoc fileIds dbgMap cmm_cfg               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)               final_delta          = natm_delta final_st@@ -1066,54 +976,46 @@     temp assignments, and certain assigns to mem...) -} -cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])-cmmToCmm _ _ top@(CmmData _ _) = (top, [])-cmmToCmm config this_mod (CmmProc info lbl live graph)-    = runCmmOpt config this_mod $+cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])+cmmToCmm _ top@(CmmData _ _) = (top, [])+cmmToCmm config (CmmProc info lbl live graph)+    = runCmmOpt config $       do blocks' <- mapM cmmBlockConFold (toBlockList graph)          return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks') --- Avoids using unboxed tuples when loading into GHCi-#if !defined(GHC_LOADED_INTO_GHCI)- type OptMResult a = (# a, [CLabel] #)  pattern OptMResult :: a -> b -> (# a, b #) pattern OptMResult x y = (# x, y #) {-# COMPLETE OptMResult #-}-#else -data OptMResult a = OptMResult !a ![CLabel] deriving (Functor)-#endif--newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a)+newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)     deriving (Functor)  instance Applicative CmmOptM where-    pure x = CmmOptM $ \_ _ imports -> OptMResult x imports+    pure x = CmmOptM $ \_ imports -> OptMResult x imports     (<*>) = ap  instance Monad CmmOptM where   (CmmOptM f) >>= g =-    CmmOptM $ \config this_mod imports0 ->-                case f config this_mod imports0 of+    CmmOptM $ \config imports0 ->+                case f config imports0 of                   OptMResult x imports1 ->                     case g x of-                      CmmOptM g' -> g' config this_mod imports1+                      CmmOptM g' -> g' config imports1  instance CmmMakeDynamicReferenceM CmmOptM where     addImport = addImportCmmOpt-    getThisModule = CmmOptM $ \_ this_mod imports -> OptMResult this_mod imports  addImportCmmOpt :: CLabel -> CmmOptM ()-addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)+addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)  getCmmOptConfig :: CmmOptM NCGConfig-getCmmOptConfig = CmmOptM $ \config _ imports -> OptMResult config imports+getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports -runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])-runCmmOpt config this_mod (CmmOptM f) =-  case f config this_mod [] of+runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])+runCmmOpt config (CmmOptM f) =+  case f config [] of     OptMResult result imports -> (result, imports)  cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock@@ -1200,30 +1102,28 @@          arch = platformArch platform      case expr of         CmmLoad addr rep-           -> do addr' <- cmmExprNative DataReference addr-                 return $ CmmLoad addr' rep+          -> do addr' <- cmmExprNative DataReference addr+                return $ CmmLoad addr' rep          CmmMachOp mop args-           -> do args' <- mapM (cmmExprNative DataReference) args-                 return $ CmmMachOp mop args'+          -> do args' <- mapM (cmmExprNative DataReference) args+                return $ CmmMachOp mop args'          CmmLit (CmmBlock id)-           -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))-           -- we must convert block Ids to CLabels here, because we-           -- might have to do the PIC transformation.  Hence we must-           -- not modify BlockIds beyond this point.+          -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))+          -- we must convert block Ids to CLabels here, because we+          -- might have to do the PIC transformation.  Hence we must+          -- not modify BlockIds beyond this point.          CmmLit (CmmLabel lbl)-           -> do-                cmmMakeDynamicReference config referenceKind lbl+          -> cmmMakeDynamicReference config referenceKind lbl         CmmLit (CmmLabelOff lbl off)-           -> do-                 dynRef <- cmmMakeDynamicReference config referenceKind lbl-                 -- need to optimize here, since it's late-                 return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [-                     dynRef,-                     (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))-                   ]+          -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl+                -- need to optimize here, since it's late+                return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [+                    dynRef,+                    (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))+                  ]          -- On powerpc (non-PIC), it's easier to jump directly to a label than         -- to use the register table, so we replace these registers@@ -1244,3 +1144,55 @@         other            -> return other +-- | Initialize the native code generator configuration from the DynFlags+initNCGConfig :: DynFlags -> Module -> NCGConfig+initNCGConfig dflags this_mod = NCGConfig+   { ncgPlatform              = targetPlatform dflags+   , ncgThisModule            = this_mod+   , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)+   , ncgProcAlignment         = cmmProcAlignment dflags+   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags+   , ncgPIC                   = positionIndependent dflags+   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags+   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags+   , ncgSplitSections         = gopt Opt_SplitSections dflags+   , ncgRegsIterative         = gopt Opt_RegsIterative dflags+   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags+   , ncgCfgWeights            = cfgWeights dflags+   , ncgCfgBlockLayout        = gopt Opt_CfgBlocklayout dflags+   , ncgCfgWeightlessLayout   = gopt Opt_WeightlessBlocklayout dflags++     -- With -O1 and greater, the cmmSink pass does constant-folding, so+     -- we don't need to do it again in the native code generator.+   , ncgDoConstantFolding     = optLevel dflags < 1++   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags+   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags+   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags+   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of+                                 ArchX86_64 -> bmiVersion dflags+                                 ArchX86    -> bmiVersion dflags+                                 _          -> Nothing++     -- We assume  SSE1 and SSE2 operations are available on both+     -- x86 and x86_64. Historically we didn't default to SSE2 and+     -- SSE1 on x86, which results in defacto nondeterminism for how+     -- rounding behaves in the associated x87 floating point instructions+     -- because variations in the spill/fpu stack placement of arguments for+     -- operations would change the precision and final result of what+     -- would otherwise be the same expressions with respect to single or+     -- double precision IEEE floating point computations.+   , ncgSseVersion =+      let v | sseVersion dflags < Just SSE2 = Just SSE2+            | otherwise                     = sseVersion dflags+      in case platformArch (targetPlatform dflags) of+            ArchX86_64 -> v+            ArchX86    -> v+            _          -> Nothing++   , ncgDwarfEnabled        = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0 && platformArch (targetPlatform dflags) /= ArchAArch64+   , ncgDwarfUnwindings     = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 0+   , ncgDwarfStripBlockInfo = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags < 2 -- We strip out block information when running with -g0 or -g1.+   , ncgDwarfSourceNotes    = osElfTarget (platformOS (targetPlatform dflags)) && debugLevel dflags > 2 -- We produce GHC-specific source-note DIEs only with -g3+   , ncgExposeInternalSymbols = gopt Opt_ExposeInternalSymbols dflags+   }

+ GHC/CmmToAsm/AArch64.hs view

@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for x86 and x86-64 architectures+module GHC.CmmToAsm.AArch64+   ( ncgAArch64 )+where++import GHC.Prelude++import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types++import qualified GHC.CmmToAsm.AArch64.Instr   as AArch64+import qualified GHC.CmmToAsm.AArch64.Ppr     as AArch64+import qualified GHC.CmmToAsm.AArch64.CodeGen as AArch64+import qualified GHC.CmmToAsm.AArch64.Regs    as AArch64+import qualified GHC.CmmToAsm.AArch64.RegInfo as AArch64++ncgAArch64 :: NCGConfig -> NcgImpl RawCmmStatics AArch64.Instr AArch64.JumpDest+ncgAArch64 config+ = NcgImpl {+        ncgConfig                 = config+       ,cmmTopCodeGen             = AArch64.cmmTopCodeGen+       ,generateJumpTableForInstr = AArch64.generateJumpTableForInstr config+       ,getJumpDestBlockId        = AArch64.getJumpDestBlockId+       ,canShortcut               = AArch64.canShortcut+       ,shortcutStatics           = AArch64.shortcutStatics+       ,shortcutJump              = AArch64.shortcutJump+       ,pprNatCmmDecl             = AArch64.pprNatCmmDecl config+       ,maxSpillSlots             = AArch64.maxSpillSlots config+       ,allocatableRegs           = AArch64.allocatableRegs platform+       ,ncgAllocMoreStack         = AArch64.allocMoreStack platform+       ,ncgExpandTop              = id+       ,ncgMakeFarBranches        = const id+       ,extractUnwindPoints       = const []+       ,invertCondBranches        = \_ _ -> id+  }+    where+      platform = ncgPlatform config++-- | Instruction instance for aarch64+instance Instruction AArch64.Instr where+        regUsageOfInstr         = AArch64.regUsageOfInstr+        patchRegsOfInstr        = AArch64.patchRegsOfInstr+        isJumpishInstr          = AArch64.isJumpishInstr+        jumpDestsOfInstr        = AArch64.jumpDestsOfInstr+        patchJumpInstr          = AArch64.patchJumpInstr+        mkSpillInstr            = AArch64.mkSpillInstr+        mkLoadInstr             = AArch64.mkLoadInstr+        takeDeltaInstr          = AArch64.takeDeltaInstr+        isMetaInstr             = AArch64.isMetaInstr+        mkRegRegMoveInstr _     = AArch64.mkRegRegMoveInstr+        takeRegRegMoveInstr     = AArch64.takeRegRegMoveInstr+        mkJumpInstr             = AArch64.mkJumpInstr+        mkStackAllocInstr       = AArch64.mkStackAllocInstr+        mkStackDeallocInstr     = AArch64.mkStackDeallocInstr+        mkComment               = pure . AArch64.COMMENT+        pprInstr                = AArch64.pprInstr

+ GHC/CmmToAsm/AArch64/CodeGen.hs view

@@ -0,0 +1,1437 @@+{-# language GADTs #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NumericUnderscores #-}+module GHC.CmmToAsm.AArch64.CodeGen (+      cmmTopCodeGen+    , generateJumpTableForInstr+)++where++-- NCG stuff:+import GHC.Prelude hiding (EQ)++import GHC.Platform.Regs+import GHC.CmmToAsm.AArch64.Instr+import GHC.CmmToAsm.AArch64.Regs+import GHC.CmmToAsm.AArch64.Cond++import GHC.CmmToAsm.CPrim+import GHC.Cmm.DebugBlock+import GHC.CmmToAsm.Monad+   ( NatM, getNewRegNat+   , getPicBaseMaybeNat, getPlatform, getConfig+   , getDebugBlock, getFileId+   )+-- import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import GHC.Data.OrdList+import GHC.Utils.Outputable++import Control.Monad    ( mapAndUnzipM, when, foldM )+import Data.Word+import Data.Maybe+import GHC.Float++import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Utils.Panic++-- Note [General layout of an NCG]+-- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get+-- @RawCmmDecl@; see GHC.Cmm+--+--   RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph+--+--   GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g+--                    | CmmData Section d+--+-- As a result we want to transform this to a list of @NatCmmDecl@, which is+-- defined @GHC.CmmToAsm.Instr@ as+--+--   type NatCmmDecl statics instr+--        = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)+--+-- Thus well' turn+--   GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph+-- into+--   [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)]+--+-- where @CmmGraph@ is+--+--   type CmmGraph = GenCmmGraph CmmNode+--   data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+--   type CmmBlock = Block CmmNode C C+--+-- and @ListGraph Instr@ is+--+--   newtype ListGraph i = ListGraph [GenBasicBlock i]+--   data GenBasicBlock i = BasicBlock BlockId [i]++cmmTopCodeGen+    :: RawCmmDecl+    -> NatM [NatCmmDecl RawCmmStatics Instr]++-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  -- do+  --   traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n"+  --         ++ showSDocUnsafe (ppr cmm)++  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  case picBaseMb of+      Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented"+      Nothing -> return tops++-- ... or CmmData.+cmmTopCodeGen _cmm@(CmmData sec dat) = do+  -- do+  --   traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n"+  --         ++ showSDocUnsafe (ppr cmm)+  return [CmmData sec dat] -- no translation, we just use CmmStatic++basicBlockCodeGen+        :: Block CmmNode C C+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl RawCmmStatics Instr])++basicBlockCodeGen block = do+  config <- getConfig+  -- do+  --   traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+  --         ++ showSDocUnsafe (ppr block)+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes++      header_comment_instr = unitOL $ MULTILINE_COMMENT (+          text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+          $+$ pdoc (ncgPlatform config) block+          )+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span name)+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col name+    _ -> return nilOL+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (!tail_instrs,_) <- stmtToInstrs mid_bid tail+  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts+  --      unwinding info. See Ticket 19913+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)+++-- -----------------------------------------------------------------------------+-- | Utilities+ann :: SDoc -> Instr -> Instr+ann doc instr {- | debugIsOn -} = ANN doc instr+-- ann _ instr = instr+{-# INLINE ann #-}++-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with+-- -dppr-debug.  The idea is that we can trivially see how a cmm expression+-- ended up producing the assmebly we see.  By having the verbatim AST printed+-- we can simply check the patterns that were matched to arrive at the assmebly+-- we generated.+--+-- pprExpr will hide a lot of noise of the underlying data structure and print+-- the expression into something that can be easily read by a human. However+-- going back to the exact CmmExpr representation can be labourous and adds+-- indirections to find the matches that lead to the assembly.+--+-- An improvement oculd be to have+--+--    (pprExpr genericPlatform e) <> parens (text. show e)+--+-- to have the best of both worlds.+--+-- Note: debugIsOn is too restrictive, it only works for debug compilers.+-- However, we do not only want to inspect this for debug compilers. Ideally+-- we'd have a check for -dppr-debug here already, such that we don't even+-- generate the ANN expressions. However, as they are lazy, they shouldn't be+-- forced until we actually force them, and without -dppr-debug they should+-- never end up being forced.+annExpr :: CmmExpr -> Instr -> Instr+annExpr e instr {- | debugIsOn -} = ANN (text . show $ e) instr+-- annExpr e instr {- | debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch++-- TODO jump tables would be a lot faster, but we'll use bare bones for now.+-- this is usually done by sticking the jump table ids into an instruction+-- and then have the @generateJumpTableForInstr@ callback produce the jump+-- table as a static.+--+-- See Ticket 19912+--+-- data SwitchTargets =+--    SwitchTargets+--        Bool                       -- Signed values+--        (Integer, Integer)         -- Range+--        (Maybe Label)              -- Default value+--        (M.Map Integer Label)      -- The branches+--+-- Non Jumptable plan:+-- xE <- expr+--+genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch expr targets = do -- pprPanic "genSwitch" (ppr expr)+  (reg, format, code) <- getSomeReg expr+  let w = formatToWidth format+  let mkbranch acc (key, bid) = do+        (keyReg, _format, code) <- getSomeReg (CmmLit (CmmInt key w))+        return $ code `appOL`+                 toOL [ CMP (OpReg w reg) (OpReg w keyReg)+                      , BCOND EQ (TBlock bid)+                      ] `appOL` acc+      def_code = case switchTargetsDefault targets of+        Just bid -> unitOL (B (TBlock bid))+        Nothing  -> nilOL++  switch_code <- foldM mkbranch nilOL (switchTargetsCases targets)+  return $ code `appOL` switch_code `appOL` def_code++-- We don't do jump tables for now, see Ticket 19912+generateJumpTableForInstr :: NCGConfig -> Instr+  -> Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let !newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')++-- | `bid` refers to the current block and is used to update the CFG+--   if new blocks are inserted in the control flow.+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block.+stmtToInstrs bid stmt = do+  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"+  --     ++ showSDocUnsafe (ppr stmt)+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genCCall target result_regs args bid++    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT (ftext s)))+      CmmTick {}     -> return nilOL++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode format reg src+        | otherwise              -> assignReg_IntCode format reg src+          where ty = cmmRegType platform reg+                format = cmmTypeFormat ty++      CmmStore addr src+        | isFloatType ty         -> assignMem_FltCode format addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType platform src+                format = cmmTypeFormat ty++      CmmBranch id          -> genBranch id++      --We try to arrange blocks such that the likely branch is the fallthrough+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _prediction ->+          genCondBranch bid true false arg++      CmmSwitch arg ids -> genSwitch arg ids++      CmmCall { cml_target = arg } -> genJump arg++      CmmUnwind _regs -> return nilOL++      _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)++-- | Sometimes we need to change the Format of a register. Primarily during+-- conversion.+swizzleRegisterRep :: Format -> Register -> Register+swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code+swizzleRegisterRep format (Any _ codefn)     = Any   format codefn++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence if it's not mapped to a registers something+        -- went wrong earlier in the pipeline.+-- | Convert a BlockId to some CmmStatic data+-- TODO: Add JumpTable Logic, see Ticket 19912+-- jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+-- jumpTableEntry config Nothing   = CmmStaticLit (CmmInt 0 (ncgWordWidth config))+-- jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+--     where blockLabel = blockLbl blockid++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, rep, code tmp)+    Fixed rep reg code ->+        return (reg, rep, code)++-- TODO OPT: we might be able give getRegister+--          a hint, what kind of register we want.+getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg expr = do+  r <- getRegister expr+  case r of+    Any rep code | isFloatFormat rep -> do+      tmp <- getNewRegNat rep+      return (tmp, rep, code tmp)+    Any II32 code -> do+      tmp <- getNewRegNat FF32+      return (tmp, FF32, code tmp)+    Any II64 code -> do+      tmp <- getNewRegNat FF64+      return (tmp, FF64, code tmp)+    Any _w _code -> do+      config <- getConfig+      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)+    -- can't do much for fixed.+    Fixed rep reg code ->+      return (reg, rep, code)++-- TODO: TODO, bounds. We can't put any immediate+-- value in. They are constrained.+-- See Ticket 19911+litToImm' :: CmmLit -> NatM (Operand, InstrBlock)+litToImm' lit = return (OpImm (litToImm lit), nilOL)+++getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- Note [Handling PIC on AArch64]+-- AArch64 does not have a special PIC register, the general approach is to+-- simply go through the GOT, and there is assembly support for this:+--+--   // Load the address of 'sym' from the GOT using ADRP and LDR (used for+--   // position-independent code on AArch64):+--   adrp x0, #:got:sym+--   ldr x0, [x0, #:got_lo12:sym]+--+-- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions+--+-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the+-- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@+-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two+-- callsites for this. One is in this module to produce the @target@ in @genCCall@+-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.+--+-- Conceptually we do not want any special PicBaseReg to be used on AArch64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.+--++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register+-- OPTIMIZATION WARNING: CmmExpr rewrites+-- 1. Rewrite: Reg + (-n) => Reg - n+--    TODO: this expression souldn't even be generated to begin with.+getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0+  = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])++getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0+  = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])+++-- Generic case.+getRegister' config plat expr+  = case expr of+    CmmReg (CmmGlobal PicBaseReg)+      -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)+    CmmLit lit+      -> case lit of++        -- TODO handle CmmInt 0 specially, use wzr or xzr.++        CmmInt i W8 | i >= 0 -> do+          return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))+        CmmInt i W16 | i >= 0 -> do+          return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i))))))++        CmmInt i W8  -> do+          return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowS W8 i))))))+        CmmInt i W16 -> do+          return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowS W16 i))))))++        -- We need to be careful to not shorten this for negative literals.+        -- Those need the upper bits set. We'd either have to explicitly sign+        -- or figure out something smarter. Lowered to+        -- `MOV dst XZR`+        CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i)))))+        CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do+          let  half0 = fromIntegral (fromIntegral i :: Word16)+               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+          return (Any (intFormat w) (\dst -> toOL [ annExpr expr+                                                  $ MOV (OpReg W32 dst) (OpImm (ImmInt half0))+                                                  , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16)+                                                  ]))+        -- fallback for W32+        CmmInt i W32 -> do+          let  half0 = fromIntegral (fromIntegral i :: Word16)+               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+          return (Any (intFormat W32) (\dst -> toOL [ annExpr expr+                                                    $ MOV (OpReg W32 dst) (OpImm (ImmInt half0))+                                                    , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16)+                                                    ]))+        -- anything else+        CmmInt i W64 -> do+          let  half0 = fromIntegral (fromIntegral i :: Word16)+               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+               half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)+               half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)+          return (Any (intFormat W64) (\dst -> toOL [ annExpr expr+                                                    $ MOV (OpReg W64 dst) (OpImm (ImmInt half0))+                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16)+                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32)+                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48)+                                                    ]))+        CmmInt _i rep -> do+          (op, imm_code) <- litToImm' lit+          return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op)))++        -- floatToBytes (fromRational f)+        CmmFloat 0 w   -> do+          (op, imm_code) <- litToImm' lit+          return (Any (floatFormat w) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg w dst) op)))++        CmmFloat _f W8  -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)+        CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)+        CmmFloat f W32 -> do+          let word = castFloatToWord32 (fromRational f) :: Word32+              half0 = fromIntegral (fromIntegral word :: Word16)+              half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16)+          tmp <- getNewRegNat (intFormat W32)+          return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0))+                                                      , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16)+                                                      , MOV (OpReg W32 dst) (OpReg W32 tmp)+                                                      ]))+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+              half0 = fromIntegral (fromIntegral word :: Word16)+              half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16)+              half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16)+              half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16)+          tmp <- getNewRegNat (intFormat W64)+          return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0))+                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16)+                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32)+                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48)+                                                      , MOV (OpReg W64 dst) (OpReg W64 tmp)+                                                      ]))+        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)+        CmmLabel _lbl -> do+          (op, imm_code) <- litToImm' lit+          let rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op)))++        CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          (op, imm_code) <- litToImm' lit+          let rep = cmmLitType plat lit+              format = cmmTypeFormat rep+              -- width = typeWidth rep+          return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op))++        CmmLabelOff lbl off -> do+          (op, imm_code) <- litToImm' (CmmLabel lbl)+          let rep = cmmLitType plat lit+              format = cmmTypeFormat rep+              width = typeWidth rep+          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+          return (Any format (\dst -> imm_code `appOL` off_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r)))++        CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+    CmmLoad mem rep -> do+      Amode addr addr_code <- getAmode plat mem+      let format = cmmTypeFormat rep+      return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr)))+    CmmStackSlot _ _+      -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)+    CmmReg reg+      -> return (Fixed (cmmTypeFormat (cmmRegType plat reg))+                       (getRegisterReg plat reg)+                       nilOL)+    CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do+      getRegister' config plat $+            CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+          where width = typeWidth (cmmRegType plat reg)++    CmmRegOff reg off -> do+      (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+      (reg, _format, code) <- getSomeReg $ CmmReg reg+      return $ Any (intFormat width) (\dst -> off_code `appOL` code `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r))+          where width = typeWidth (cmmRegType plat reg)++++    -- for MachOps, see GHC.Cmm.MachOp+    -- For CmmMachOp, see GHC.Cmm.Expr+    CmmMachOp op [e] -> do+      (reg, _format, code) <- getSomeReg e+      case op of+        MO_Not w -> return $ Any (intFormat w) (\dst -> code `snocOL` MVN (OpReg w dst) (OpReg w reg))++        MO_S_Neg w -> return $ Any (intFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg))+        MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg))++        MO_SF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)+        MO_FS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)++        -- TODO this is very hacky+        -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@+        -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend).+        MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))+        MO_SS_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` SBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))++        -- Conversions+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e++        _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)+      where toImm W8 =  (OpImm (ImmInt 7))+            toImm W16 = (OpImm (ImmInt 15))+            toImm W32 = (OpImm (ImmInt 31))+            toImm W64 = (OpImm (ImmInt 63))+            toImm W128 = (OpImm (ImmInt 127))+            toImm W256 = (OpImm (ImmInt 255))+            toImm W512 = (OpImm (ImmInt 511))+    -- Dyadic machops:+    --+    -- The general idea is:+    -- compute x<i> <- x+    -- compute x<j> <- y+    -- OP x<r>, x<i>, x<j>+    --+    -- TODO: for now we'll only implement the 64bit versions. And rely on the+    --      fallthrough to alert us if things go wrong!+    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring+    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg+    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    -- 1. Compute Reg +/- n directly.+    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.+    CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)]+      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))+            r' = getRegisterReg plat reg+    CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)]+      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))+            r' = getRegisterReg plat reg++    -- 2. Shifts. x << n, x >> n.+    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))+    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))+    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    -- 3. Logic &&, ||+    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->+      return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))+            r' = getRegisterReg plat reg++    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (fromIntegral n) ->+      return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))+            r' = getRegisterReg plat reg++    -- Generic case.+    CmmMachOp op [x, y] -> do+      -- alright, so we have an operation, and two expressions. And we want to essentially do+      -- ensure we get float regs+      let genOp w op = do+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            when ((isFloatFormat format_x && isIntFormat format_y) || (isIntFormat format_x && isFloatFormat format_y)) $ pprPanic "getRegister:genOp" (text "formats don't match:" <+> text (show format_x) <+> text "/=" <+> text (show format_y))+            return $ Any format_x (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))++          withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op+          -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op++          intOp w op = do+            -- compute x<m> <- x+            -- compute x<o> <- y+            -- <OP> x<n>, x<m>, x<o>+            (reg_x, _format_x, code_x) <- getSomeReg x+            (reg_y, _format_y, code_y) <- getSomeReg y+            return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+          floatOp w op = do+            (reg_fx, _format_x, code_fx) <- getFloatReg x+            (reg_fy, _format_y, code_fy) <- getFloatReg y+            return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))+          -- need a special one for conditionals, as they return ints+          floatCond w op = do+            (reg_fx, _format_x, code_fx) <- getFloatReg x+            (reg_fy, _format_y, code_fy) <- getFloatReg y+            return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++      case op of+        -- Integer operations+        -- Add/Sub should only be Interger Options.+        -- But our Cmm parser doesn't care about types+        -- and thus we end up with <float> + <float> => MO_Add <float> <float>+        MO_Add w -> genOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_Sub w -> genOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        --    31  30  29  28+        --  .---+---+---+---+-- - -+        --  | N | Z | C | V |+        --  '---+---+---+---+-- - -+        --  Negative+        --  Zero+        --  Carry+        --  oVerflow+        --+        --  .------+-------------------------------------+-----------------+----------.+        --  | Code | Meaning                             | Flags           | Encoding |+        --  |------+-------------------------------------+-----------------+----------|+        --  |  EQ  | Equal                               | Z = 1           | 0000     |+        --  |  NE  | Not Equal                           | Z = 0           | 0001     |+        --  |  HI  | Unsigned Higher                     | C = 1 && Z = 0  | 1000     |+        --  |  HS  | Unsigned Higher or Same             | C = 1           | 0010     |+        --  |  LS  | Unsigned Lower or Same              | C = 0 || Z = 1  | 1001     |+        --  |  LO  | Unsigned Lower                      | C = 0           | 0011     |+        --  |  GT  | Signed Greater Than                 | Z = 0 && N = V  | 1100     |+        --  |  GE  | Signed Greater Than or Equal        | N = V           | 1010     |+        --  |  LE  | Signed Less Than or Equal           | Z = 1 || N /= V | 1101     |+        --  |  LT  | Signed Less Than                    | N /= V          | 1011     |+        --  |  CS  | Carry Set (Unsigned Overflow)       | C = 1           | 0010     |+        --  |  CC  | Carry Clear (No Unsigned Overflow)  | C = 0           | 0011     |+        --  |  VS  | Signed Overflow                     | V = 1           | 0110     |+        --  |  VC  | No Signed Overflow                  | V = 0           | 0111     |+        --  |  MI  | Minus, Negative                     | N = 1           | 0100     |+        --  |  PL  | Plus, Positive or Zero (!)          | N = 0           | 0101     |+        --  |  AL  | Always                              | Any             | 1110     |+        --  |  NV  | Never                               | Any             | 1111     |+        --- '-------------------------------------------------------------------------'++        MO_Eq w -> intOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])+        MO_Ne w -> intOp w (\d x y -> toOL [ CMP x y, CSET d NE ])+        MO_Mul w -> intOp w (\d x y -> unitOL $ MUL d x y)++        -- Signed multiply/divide+        MO_S_MulMayOflo w -> intOp w (\d x y -> toOL [ MUL d x y, CSET d VS ])+        MO_S_Quot w -> intOp w (\d x y -> unitOL $ SDIV d x y)++        -- No native rem instruction. So we'll compute the following+        -- Rd  <- Rx / Ry             | 2 <- 7 / 3      -- SDIV Rd Rx Ry+        -- Rd' <- Rx - Rd * Ry        | 1 <- 7 - 2 * 3  -- MSUB Rd' Rd Ry Rx+        --        |     '---|----------------|---'   |+        --        |         '----------------|-------'+        --        '--------------------------'+        -- Note the swap in Rx and Ry.+        MO_S_Rem w -> withTempIntReg w $ \t ->+          intOp w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ])++        -- Unsigned multiply/divide+        MO_U_MulMayOflo _w -> unsupportedP plat expr+        MO_U_Quot w -> intOp w (\d x y -> unitOL $ UDIV d x y)+        MO_U_Rem w  -> withTempIntReg w $ \t ->+          intOp w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])++        -- Signed comparisons -- see above for the CSET discussion+        MO_S_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGE ])+        MO_S_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLE ])+        MO_S_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SGT ])+        MO_S_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d SLT ])++        -- Unsigned comparisons+        MO_U_Ge w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGE ])+        MO_U_Le w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULE ])+        MO_U_Gt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d UGT ])+        MO_U_Lt w -> intOp w (\d x y -> toOL [ CMP x y, CSET d ULT ])++        -- Floating point arithmetic+        MO_F_Add w   -> floatOp w (\d x y -> unitOL $ ADD d x y)+        MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ SUB d x y)+        MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ MUL d x y)+        MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ SDIV d x y)++        -- Floating point comparison+        MO_F_Eq w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ])+        MO_F_Ne w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ])++        -- careful with the floating point operations.+        -- SLE is effectively LE or unordered (NaN)+        -- SLT is the same. ULE, and ULT will not return true for NaN.+        -- This is a bit counter intutive. Don't let yourself be fooled by+        -- the S/U prefix for floats, it's only meaningful for integers.+        MO_F_Ge w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ])+        MO_F_Le w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x+        MO_F_Gt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ])+        MO_F_Lt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x++        -- Bitwise operations+        MO_And   w -> intOp w (\d x y -> unitOL $ AND d x y)+        MO_Or    w -> intOp w (\d x y -> unitOL $ ORR d x y)+        MO_Xor   w -> intOp w (\d x y -> unitOL $ EOR d x y)+        -- MO_Not   W64 ->+        MO_Shl   w -> intOp w (\d x y -> unitOL $ LSL d x y)+        MO_U_Shr w -> intOp w (\d x y -> unitOL $ LSR d x y)+        MO_S_Shr w -> intOp w (\d x y -> unitOL $ ASR d x y)++        -- TODO++        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr)+    CmmMachOp _op _xs+      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)++  where+    unsupportedP :: OutputableP env a => env -> a -> b+    unsupportedP platform op = pprPanic "Unsupported op:" (pdoc platform op)++    isNbitEncodeable :: Int -> Integer -> Bool+    isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)+    -- This needs to check if n can be encoded as a bitmask immediate:+    --+    -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly+    --+    isBitMaskImmediate :: Integer -> Bool+    isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000+                                    ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000+                                    ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000+                                    ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000+                                    ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000+                                    ,0b0011_1111, 0b0111_1110, 0b1111_1100+                                    ,0b0111_1111, 0b1111_1110+                                    ,0b1111_1111]+++-- -----------------------------------------------------------------------------+--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++getAmode :: Platform -> CmmExpr -> NatM Amode+-- TODO: Specialize stuff we can destructure here.++-- OPTIMIZATION WARNING: Addressing modes.+-- Addressing options:+-- LDUR/STUR: imm9: -256 - 255+getAmode platform (CmmRegOff reg off) | -256 <= off, off <= 255+  = return $ Amode (AddrRegImm reg' off') nilOL+    where reg' = getRegisterReg platform reg+          off' = ImmInt off+-- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4+getAmode platform (CmmRegOff reg off)+  | typeWidth (cmmRegType platform reg) == W32, 0 <= off, off <= 16380, off `mod` 4 == 0+  = return $ Amode (AddrRegImm reg' off') nilOL+    where reg' = getRegisterReg platform reg+          off' = ImmInt off+-- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8+getAmode platform (CmmRegOff reg off)+  | typeWidth (cmmRegType platform reg) == W64, 0 <= off, off <= 32760, off `mod` 8 == 0+  = return $ Amode (AddrRegImm reg' off') nilOL+    where reg' = getRegisterReg platform reg+          off' = ImmInt off++-- For Stores we often see something like this:+-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)+-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]+-- for `n` in range.+getAmode _platform (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | -256 <= off, off <= 255+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger off)) code++getAmode _platform (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | -256 <= -off, -off <= 255+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger (-off))) code++-- Generic case+getAmode _platform expr+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrReg reg) code++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_IntCode rep addrE srcE+  = do+    (src_reg, _format, code) <- getSomeReg srcE+    platform <- getPlatform+    Amode addr addr_code <- getAmode platform addrE+    return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))+            `consOL` (code+            `appOL` addr_code+            `snocOL` STR rep (OpReg (formatToWidth rep) src_reg) (OpAddr addr))++assignReg_IntCode _ reg src+  = do+    platform <- getPlatform+    let dst = getRegisterReg platform reg+    r <- getRegister src+    return $ case r of+      Any _ code              -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst+      Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` (fcode `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg))++-- Let's treat Floating point stuff+-- as integer code for now. Opaque.+assignMem_FltCode = assignMem_IntCode+assignReg_FltCode = assignReg_IntCode++-- -----------------------------------------------------------------------------+-- Jumps+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock+genJump expr@(CmmLit (CmmLabel lbl))+  = return $ unitOL (annExpr expr (J (TLabel lbl)))++genJump expr = do+    (target, _format, code) <- getSomeReg expr+    return (code `appOL` unitOL (annExpr expr (J (TReg target))))++-- -----------------------------------------------------------------------------+--  Unconditional branches+genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr++-- -----------------------------------------------------------------------------+-- Conditional branches+genCondJump+    :: BlockId+    -> CmmExpr+    -> NatM InstrBlock+genCondJump bid expr = do+    case expr of+      -- Optimized == 0 case.+      CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL` (annExpr expr (CBZ (OpReg w reg_x) (TBlock bid)))++      -- Optimized /= 0 case.+      CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL`  (annExpr expr (CBNZ (OpReg w reg_x) (TBlock bid)))++      -- Generic case.+      CmmMachOp mop [x, y] -> do++        let bcond w cmp = do+              -- compute both sides.+              (reg_x, _format_x, code_x) <- getSomeReg x+              (reg_y, _format_y, code_y) <- getSomeReg y+              return $ code_x `appOL` code_y `snocOL` CMP (OpReg w reg_x) (OpReg w reg_y) `snocOL` (annExpr expr (BCOND cmp (TBlock bid)))+            fbcond w cmp = do+              -- ensure we get float regs+              (reg_fx, _format_fx, code_fx) <- getFloatReg x+              (reg_fy, _format_fy, code_fy) <- getFloatReg y+              return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (TBlock bid)))++        case mop of+          MO_F_Eq w -> fbcond w EQ+          MO_F_Ne w -> fbcond w NE++          MO_F_Gt w -> fbcond w OGT+          MO_F_Ge w -> fbcond w OGE+          MO_F_Lt w -> fbcond w OLT+          MO_F_Le w -> fbcond w OLE++          MO_Eq w   -> bcond w EQ+          MO_Ne w   -> bcond w NE++          MO_S_Gt w -> bcond w SGT+          MO_S_Ge w -> bcond w SGE+          MO_S_Lt w -> bcond w SLT+          MO_S_Le w -> bcond w SLE+          MO_U_Gt w -> bcond w UGT+          MO_U_Ge w -> bcond w UGE+          MO_U_Lt w -> bcond w ULT+          MO_U_Le w -> bcond w ULE+          _ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr)+      _ -> pprPanic "AArch64.genCondJump: " (text $ show expr)+++genCondBranch+    :: BlockId      -- the source of the jump+    -> BlockId      -- the true branch target+    -> BlockId      -- the false branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock -- Instructions++genCondBranch _ true false expr = do+  b1 <- genCondJump true expr+  b2 <- genBranch false+  return (b1 `appOL` b2)++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- As per *convention*:+-- x0-x7:   (volatile) argument registers+-- x8:      (volatile) indirect result register / Linux syscall no+-- x9-x15:  (volatile) caller saved regs+-- x16,x17: (volatile) intra-procedure-call registers+-- x18:     (volatile) platform register. don't use for portability+-- x19-x28: (non-volatile) callee save regs+-- x29:     (non-volatile) frame pointer+-- x30:                    link register+-- x31:                    stack pointer / zero reg+--+-- Thus, this is what a c function will expect. Find the arguments in x0-x7,+-- anything above that on the stack.  We'll ignore c functions with more than+-- 8 arguments for now.  Sorry.+--+-- We need to make sure we preserve x9-x15, don't want to touch x16, x17.++-- Note [PLT vs GOT relocations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- When linking objects together, we may need to lookup foreign references. That+-- is symbolic references to functions or values in other objects. When+-- compiling the object, we can not know where those elements will end up in+-- memory (relative to the current location). Thus the use of symbols. There+-- are two types of items we are interested, code segments we want to jump to+-- and continue execution there (functions, ...), and data items we want to look+-- up (strings, numbers, ...). For functions we can use the fact that we can use+-- an intermediate jump without visibility to the programs execution.  If we+-- want to jump to a function that is simply too far away to reach for the B/BL+-- instruction, we can create a small piece of code that loads the full target+-- address and jumps to that on demand. Say f wants to call g, however g is out+-- of range for a direct jump, we can create a function h in range for f, that+-- will load the address of g, and jump there. The area where we construct h+-- is called the Procedure Linking Table (PLT), we have essentially replaced+-- f -> g with f -> h -> g.  This is fine for function calls.  However if we+-- want to lookup values, this trick doesn't work, so we need something else.+-- We will instead reserve a slot in memory, and have a symbol pointing to that+-- slot. Now what we essentially do is, we reference that slot, and expect that+-- slot to hold the final resting address of the data we are interested in.+-- Thus what that symbol really points to is the location of the final data.+-- The block of memory where we hold all those slots is the Global Offset Table+-- (GOT).  Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y].+--+-- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only+-- have 19bits (+/- 1MB).  Symbol lookups are also within +/- 1MB, thus for most+-- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within+-- 4GB of the PC, and load that.  For anything outside of that range, we'd have+-- to go through the GOT.+--+--  adrp x0, <symbol>+--  add x0, :lo:<symbol>+--+-- will compute the address of <symbol> int x0 if <symbol> is within 4GB of the+-- PC.+--+-- If we want to get the slot in the global offset table (GOT), we can do this:+--+--   adrp x0, #:got:<symbol>+--   ldr x0, [x0, #:got_lo12:<symbol>]+--+-- this will compute the address anywhere in the addressable 64bit space into+-- x0, by loading the address from the GOT slot.+--+-- To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which+-- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]+-- instaed of the add instruction.+--+-- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do+-- not need to go through the GOT, unless we want to address the full address+-- range within 64bit.++genCCall+    :: ForeignTarget      -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> BlockId            -- The block we are in+    -> NatM (InstrBlock, Maybe BlockId)+-- TODO: Specialize where we can.+-- Generic impl+genCCall target dest_regs arg_regs bid = do+  -- we want to pass arg_regs into allArgRegs+  -- pprTraceM "genCCall target" (ppr target)+  -- pprTraceM "genCCall formal" (ppr dest_regs)+  -- pprTraceM "genCCall actual" (ppr arg_regs)++  case target of+    -- The target :: ForeignTarget call can either+    -- be a foreign procedure with an address expr+    -- and a calling convention.+    ForeignTarget expr _cconv -> do+      (call_target, call_target_code) <- case expr of+        -- if this is a label, let's just directly to it.  This will produce the+        -- correct CALL relocation for BL...+        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)+        -- ... if it's not a label--well--let's compute the expression into a+        -- register and jump to that. See Note [PLT vs GOT relocations]+        _ -> do (reg, _format, reg_code) <- getSomeReg expr+                pure (TReg reg, reg_code)+      -- compute the code and register logic for all arg_regs.+      -- this will give us the format information to match on.+      arg_regs' <- mapM getSomeReg arg_regs++      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes+      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in+      -- STG; this thenn breaks packing of stack arguments, if we need to pack+      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type+      -- in Cmm proper. Option two, which we choose here is to use extended Hint+      -- information to contain the size information and use that when packing+      -- arguments, spilled onto the stack.+      let (_res_hints, arg_hints) = foreignTargetHints target+          arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints++      platform <- getPlatform+      let packStack = platformOS platform == OSDarwin++      (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++      -- if we pack the stack, we may need to adjust to multiple of 8byte.+      -- if we don't pack the stack, it will always be multiple of 8.+      let stackSpace = if stackSpace' `mod` 8 /= 0+                       then 8 * (stackSpace' `div` 8 + 1)+                       else stackSpace'++      (returnRegs, readResultsCode)   <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL++      let moveStackDown 0 = toOL [ PUSH_STACK_FRAME+                                 , DELTA (-16) ]+          moveStackDown i | odd i = moveStackDown (i + 1)+          moveStackDown i = toOL [ PUSH_STACK_FRAME+                                 , SUB (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))+                                 , DELTA (-8 * i - 16) ]+          moveStackUp 0 = toOL [ POP_STACK_FRAME+                               , DELTA 0 ]+          moveStackUp i | odd i = moveStackUp (i + 1)+          moveStackUp i = toOL [ ADD (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))+                               , POP_STACK_FRAME+                               , DELTA 0 ]++      let code =    call_target_code          -- compute the label (possibly into a register)+            `appOL` moveStackDown (stackSpace `div` 8)+            `appOL` passArgumentsCode         -- put the arguments into x0, ...+            `appOL` (unitOL $ BL call_target passRegs returnRegs) -- branch and link.+            `appOL` readResultsCode           -- parse the results into registers+            `appOL` moveStackUp (stackSpace `div` 8)+      return (code, Nothing)++    PrimTarget MO_F32_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    PrimTarget MO_F64_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg++    -- or a possibly side-effecting machine operation+    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)+    PrimTarget mop -> do+      -- We'll need config to construct forien targets+      case mop of+        -- 64 bit float ops+        MO_F64_Pwr   -> mkCCall "pow"++        MO_F64_Sin   -> mkCCall "sin"+        MO_F64_Cos   -> mkCCall "cos"+        MO_F64_Tan   -> mkCCall "tan"++        MO_F64_Sinh  -> mkCCall "sinh"+        MO_F64_Cosh  -> mkCCall "cosh"+        MO_F64_Tanh  -> mkCCall "tanh"++        MO_F64_Asin  -> mkCCall "asin"+        MO_F64_Acos  -> mkCCall "acos"+        MO_F64_Atan  -> mkCCall "atan"++        MO_F64_Asinh -> mkCCall "asinh"+        MO_F64_Acosh -> mkCCall "acosh"+        MO_F64_Atanh -> mkCCall "atanh"++        MO_F64_Log   -> mkCCall "log"+        MO_F64_Log1P -> mkCCall "log1p"+        MO_F64_Exp   -> mkCCall "exp"+        MO_F64_ExpM1 -> mkCCall "expm1"+        MO_F64_Fabs  -> mkCCall "fabs"+        MO_F64_Sqrt  -> mkCCall "sqrt"++        -- 32 bit float ops+        MO_F32_Pwr   -> mkCCall "powf"++        MO_F32_Sin   -> mkCCall "sinf"+        MO_F32_Cos   -> mkCCall "cosf"+        MO_F32_Tan   -> mkCCall "tanf"+        MO_F32_Sinh  -> mkCCall "sinhf"+        MO_F32_Cosh  -> mkCCall "coshf"+        MO_F32_Tanh  -> mkCCall "tanhf"+        MO_F32_Asin  -> mkCCall "asinf"+        MO_F32_Acos  -> mkCCall "acosf"+        MO_F32_Atan  -> mkCCall "atanf"+        MO_F32_Asinh -> mkCCall "asinhf"+        MO_F32_Acosh -> mkCCall "acoshf"+        MO_F32_Atanh -> mkCCall "atanhf"+        MO_F32_Log   -> mkCCall "logf"+        MO_F32_Log1P -> mkCCall "log1pf"+        MO_F32_Exp   -> mkCCall "expf"+        MO_F32_ExpM1 -> mkCCall "expm1f"+        MO_F32_Fabs  -> mkCCall "fabsf"+        MO_F32_Sqrt  -> mkCCall "sqrtf"++        -- 64-bit primops+        MO_I64_ToI   -> mkCCall "hs_int64ToInt"+        MO_I64_FromI -> mkCCall "hs_intToInt64"+        MO_W64_ToW   -> mkCCall "hs_word64ToWord"+        MO_W64_FromW -> mkCCall "hs_wordToWord64"+        MO_x64_Neg   -> mkCCall "hs_neg64"+        MO_x64_Add   -> mkCCall "hs_add64"+        MO_x64_Sub   -> mkCCall "hs_sub64"+        MO_x64_Mul   -> mkCCall "hs_mul64"+        MO_I64_Quot  -> mkCCall "hs_quotInt64"+        MO_I64_Rem   -> mkCCall "hs_remInt64"+        MO_W64_Quot  -> mkCCall "hs_quotWord64"+        MO_W64_Rem   -> mkCCall "hs_remWord64"+        MO_x64_And   -> mkCCall "hs_and64"+        MO_x64_Or    -> mkCCall "hs_or64"+        MO_x64_Xor   -> mkCCall "hs_xor64"+        MO_x64_Not   -> mkCCall "hs_not64"+        MO_x64_Shl   -> mkCCall "hs_uncheckedShiftL64"+        MO_I64_Shr   -> mkCCall "hs_uncheckedIShiftRA64"+        MO_W64_Shr   -> mkCCall "hs_uncheckedShiftRL64"+        MO_x64_Eq    -> mkCCall "hs_eq64"+        MO_x64_Ne    -> mkCCall "hs_ne64"+        MO_I64_Ge    -> mkCCall "hs_geInt64"+        MO_I64_Gt    -> mkCCall "hs_gtInt64"+        MO_I64_Le    -> mkCCall "hs_leInt64"+        MO_I64_Lt    -> mkCCall "hs_ltInt64"+        MO_W64_Ge    -> mkCCall "hs_geWord64"+        MO_W64_Gt    -> mkCCall "hs_gtWord64"+        MO_W64_Le    -> mkCCall "hs_leWord64"+        MO_W64_Lt    -> mkCCall "hs_ltWord64"++        -- Conversion+        MO_UF_Conv w        -> mkCCall (word2FloatLabel w)++        -- Arithmatic+        -- These are not supported on X86, so I doubt they are used much.+        MO_S_Mul2     _w -> unsupported mop+        MO_S_QuotRem  _w -> unsupported mop+        MO_U_QuotRem  _w -> unsupported mop+        MO_U_QuotRem2 _w -> unsupported mop+        MO_Add2       _w -> unsupported mop+        MO_AddWordC   _w -> unsupported mop+        MO_SubWordC   _w -> unsupported mop+        MO_AddIntC    _w -> unsupported mop+        MO_SubIntC    _w -> unsupported mop+        MO_U_Mul2     _w -> unsupported mop++        -- Memory Ordering+        -- TODO DMBSY is probably *way* too much!+        MO_ReadBarrier      ->  return (unitOL DMBSY, Nothing)+        MO_WriteBarrier     ->  return (unitOL DMBSY, Nothing)+        MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)+        -- Prefetch+        MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.++        -- Memory copy/set/move/cmp, with alignment for optimization++        -- TODO Optimize and use e.g. quad registers to move memory around instead+        -- of offloading this to memcpy. For small memcpys we can utilize+        -- the 128bit quad registers in NEON to move block of bytes around.+        -- Might also make sense of small memsets? Use xzr? What's the function+        -- call overhead?+        MO_Memcpy  _align   -> mkCCall "memcpy"+        MO_Memset  _align   -> mkCCall "memset"+        MO_Memmove _align   -> mkCCall "memmove"+        MO_Memcmp  _align   -> mkCCall "memcmp"++        MO_PopCnt w         -> mkCCall (popCntLabel w)+        MO_Pdep w           -> mkCCall (pdepLabel w)+        MO_Pext w           -> mkCCall (pextLabel w)+        MO_Clz w            -> mkCCall (clzLabel w)+        MO_Ctz w            -> mkCCall (ctzLabel w)+        MO_BSwap w          -> mkCCall (bSwapLabel w)+        MO_BRev w           -> mkCCall (bRevLabel w)++        -- -- Atomic read-modify-write.+        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+        MO_AtomicRead w     -> mkCCall (atomicReadLabel w)+        MO_AtomicWrite w    -> mkCCall (atomicWriteLabel w)+        MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)+        -- -- Should be an AtomicRMW variant eventually.+        -- -- Sequential consistent.+        -- TODO: this should be implemented properly!+        MO_Xchg w           -> mkCCall (xchgLabel w)++  where+    unsupported :: Show a => a -> b+    unsupported mop = panic ("outOfLineCmmOp: " ++ show mop+                          ++ " not supported here")+    mkCCall :: String -> NatM (InstrBlock, Maybe BlockId)+    mkCCall name = do+      config <- getConfig+      target <- cmmMakeDynamicReference config CallReference $+          mkForeignLabel (fsLit name) Nothing ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs bid++    -- TODO: Optimize using paired stores and loads (STP, LDP). It is+    -- automomatically done by the allocator for us. However it's not optimal,+    -- as we'd rather want to have control over+    --     all spill/load registers, so we can optimize with instructions like+    --       STP xA, xB, [sp, #-16]!+    --     and+    --       LDP xA, xB, sp, #16+    --+    passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)+    passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode)+    -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace))+    -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1)))+    -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do+    --   -- allocate this on the stack+    --   (r0, format0, code_r0) <- getSomeReg arg0+    --   (r1, format1, code_r1) <- getSomeReg arg1+    --   let w0 = formatToWidth format0+    --       w1 = formatToWidth format1+    --       stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8)))+    --   passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode)++      -- float promotion.+      -- According to+      --  ISO/IEC 9899:2018+      --  Information technology — Programming languages — C+      --+      -- e.g.+      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf+      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf+      --+      -- GHC would need to know the prototype.+      --+      -- > If the expression that denotes the called function has a type that does not include a+      -- > prototype, the integer promotions are performed on each argument, and arguments that+      -- > have type float are promoted to double.+      --+      -- As we have no way to get prototypes for C yet, we'll *not* promote this+      -- which is in line with the x86_64 backend :(+      --+      -- See the encode_values.cmm test.+      --+      -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg)+      -- if w == W32.  But *only* if we don't have a prototype m(+      --+      -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture+      --+    -- Still have GP regs, and we want to pass an GP argument.++    -- AArch64-Darwin: stack packing and alignment+    --+    -- According to the "Writing ARM64 Code for Apple Platforms" document form+    -- Apple, specifically the section "Handle Data Types and Data Alignment Properly"+    -- we need to not only pack, but also align arguments on the stack.+    --+    -- Data type   Size (in bytes)   Natural alignment (in bytes)+    -- BOOL, bool  1                 1+    -- char        1                 1+    -- short       2                 2+    -- int         4                 4+    -- long        8                 8+    -- long long   8                 8+    -- pointer     8                 8+    -- size_t      8                 8+    -- NSInteger   8                 8+    -- CFIndex     8                 8+    -- fpos_t      8                 8+    -- off_t       8                 8+    --+    -- We can see that types are aligned by their sizes so the easiest way to+    -- guarantee alignment during packing seems to be to pad to a multiple of the+    -- size we want to pack. Failure to get this right can result in pretty+    -- subtle bugs, e.g. #20137.++    passArguments pack (gpReg:gpRegs) fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+      passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass gp argument: " <> ppr r) $ MOV (OpReg w gpReg) (OpReg w r)))++    -- Still have FP regs, and we want to pass an FP argument.+    passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+      passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) (accumCode `appOL` code_r `snocOL` (ann (text "Pass fp argument: " <> ppr r) $ MOV (OpReg w fpReg) (OpReg w r)))++    -- No mor regs left to pass. Must pass on stack.+    passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do+      let w = formatToWidth format+          bytes = widthInBits w `div` 8+          space = if pack then bytes else 8+          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)+                      | otherwise                           = stackSpace+          stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+      passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)++    -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          bytes = widthInBits w `div` 8+          space = if pack then bytes else 8+          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)+                      | otherwise                           = stackSpace+          stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+      passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)++    -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.+    passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          bytes = widthInBits w `div` 8+          space = if pack then bytes else 8+          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)+                      | otherwise                           = stackSpace+          stackCode = code_r `snocOL` (ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) $ STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace'))))+      passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)++    passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM ([Reg], InstrBlock)+    readResults _ _ [] accumRegs accumCode = return (accumRegs, accumCode)+    readResults [] _ _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)+    readResults _ [] _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)+    readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do+      -- gp/fp reg -> dst+      platform <- getPlatform+      let rep = cmmRegType platform (CmmLocal dst)+          format = cmmTypeFormat rep+          w   = cmmRegWidth platform (CmmLocal dst)+          r_dst = getRegisterReg platform (CmmLocal dst)+      if isFloatFormat format+        then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))+        else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg))++    unaryFloatOp w op arg_reg dest_reg = do+      platform <- getPlatform+      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg+      let dst = getRegisterReg platform (CmmLocal dest_reg)+      let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)+      return (code, Nothing)

+ GHC/CmmToAsm/AArch64/Cond.hs view

@@ -0,0 +1,66 @@+module GHC.CmmToAsm.AArch64.Cond  where++import GHC.Prelude++-- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions++-- TODO: This appears to go a bit overboard? Maybe we should stick with what LLVM+-- settled on for fcmp?+-- false: always yields false, regardless of operands.+-- oeq: yields true if both operands are not a QNAN and op1 is equal to op2.+-- ogt: yields true if both operands are not a QNAN and op1 is greater than op2.+-- oge: yields true if both operands are not a QNAN and op1 is greater than or equal to op2.+-- olt: yields true if both operands are not a QNAN and op1 is less than op2.+-- ole: yields true if both operands are not a QNAN and op1 is less than or equal to op2.+-- one: yields true if both operands are not a QNAN and op1 is not equal to op2.+-- ord: yields true if both operands are not a QNAN.+-- ueq: yields true if either operand is a QNAN or op1 is equal to op2.+-- ugt: yields true if either operand is a QNAN or op1 is greater than op2.+-- uge: yields true if either operand is a QNAN or op1 is greater than or equal to op2.+-- ult: yields true if either operand is a QNAN or op1 is less than op2.+-- ule: yields true if either operand is a QNAN or op1 is less than or equal to op2.+-- une: yields true if either operand is a QNAN or op1 is not equal to op2.+-- uno: yields true if either operand is a QNAN.+-- true: always yields true, regardless of operands.+--+-- LLVMs icmp knows about:+-- eq: yields true if the operands are equal, false otherwise. No sign interpretation is necessary or performed.+-- ne: yields true if the operands are unequal, false otherwise. No sign interpretation is necessary or performed.+-- ugt: interprets the operands as unsigned values and yields true if op1 is greater than op2.+-- uge: interprets the operands as unsigned values and yields true if op1 is greater than or equal to op2.+-- ult: interprets the operands as unsigned values and yields true if op1 is less than op2.+-- ule: interprets the operands as unsigned values and yields true if op1 is less than or equal to op2.+-- sgt: interprets the operands as signed values and yields true if op1 is greater than op2.+-- sge: interprets the operands as signed values and yields true if op1 is greater than or equal to op2.+-- slt: interprets the operands as signed values and yields true if op1 is less than op2.+-- sle: interprets the operands as signed values and yields true if op1 is less than or equal to op2.++data Cond+    = ALWAYS -- b.al+    | EQ     -- b.eq+    | NE     -- b.ne+    -- signed+    | SLT    -- b.lt+    | SLE    -- b.le+    | SGE    -- b.ge+    | SGT    -- b.gt+    -- unsigned+    | ULT    -- b.lo+    | ULE    -- b.ls+    | UGE    -- b.hs+    | UGT    -- b.hi+    -- ordered+    | OLT    -- b.mi+    | OLE    -- b.ls+    | OGE    -- b.ge+    | OGT    -- b.gt+    -- unordered+    | UOLT   -- b.lt+    | UOLE   -- b.le+    | UOGE   -- b.pl+    | UOGT   -- b.hi+    -- others+    | NEVER  -- b.nv+    | VS     -- oVerflow set+    | VC     -- oVerflow clear+    deriving Eq

+ GHC/CmmToAsm/AArch64/Instr.hs view

@@ -0,0 +1,762 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.AArch64.Instr++where++import GHC.Prelude++import GHC.CmmToAsm.AArch64.Cond+import GHC.CmmToAsm.AArch64.Regs++import GHC.CmmToAsm.Instr (RegUsage(..))+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Config+import GHC.Platform.Reg++import GHC.Platform.Regs+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Utils.Outputable+import GHC.Platform+import GHC.Types.Unique.Supply++import GHC.Utils.Panic++import Control.Monad (replicateM)+import Data.Maybe (fromMaybe)++import GHC.Stack++-- | TODO: verify this!+stackFrameHeaderSize :: Platform -> Int+stackFrameHeaderSize _ = 64++-- | All registers are 8 byte wide.+spillSlotSize :: Int+spillSlotSize = 8++-- | The number of bytes that the stack pointer should be aligned+-- to.+stackAlign :: Int+stackAlign = 16++-- | The number of spill slots available without allocating more.+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+--  = 0 -- set to zero, to see when allocMoreStack has to fire.+    = let platform = ncgPlatform config+      in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform)+         `div` spillSlotSize) - 1++-- | Convert a spill slot number to a *byte* offset, with no sign.+spillSlotToOffset :: NCGConfig -> Int -> Int+spillSlotToOffset config slot+   = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot++-- | Get the registers that are being used by this instruction.+-- regUsage doesn't need to do any trickery for jumps and such.+-- Just state precisely the regs read and written by that insn.+-- The consequences of control flow transfers, as far as register+-- allocation goes, are taken care of by the register allocator.+--+-- RegUsage = RU [<read regs>] [<write regs>]++instance Outputable RegUsage where+    ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'++regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of+  ANN _ i                  -> regUsageOfInstr platform i+  -- 1. Arithmetic Instructions ------------------------------------------------+  ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  CMN l r                  -> usage (regOp l ++ regOp r, [])+  CMP l r                  -> usage (regOp l ++ regOp r, [])+  MSUB dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  NEG dst src              -> usage (regOp src, regOp dst)+  SDIV dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  UDIV dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)++  -- 2. Bit Manipulation Instructions ------------------------------------------+  SBFM dst src _ _         -> usage (regOp src, regOp dst)+  UBFM dst src _ _         -> usage (regOp src, regOp dst)++  -- 3. Logical and Move Instructions ------------------------------------------+  AND dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ASR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  BIC dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  BICS dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  EON dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  EOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  LSL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  LSR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOV dst src              -> usage (regOp src, regOp dst)+  MOVK dst src             -> usage (regOp src, regOp dst)+  MVN dst src              -> usage (regOp src, regOp dst)+  ORR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ROR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  TST src1 src2            -> usage (regOp src1 ++ regOp src2, [])+  -- 4. Branch Instructions ----------------------------------------------------+  J t                      -> usage (regTarget t, [])+  B t                      -> usage (regTarget t, [])+  BCOND _ t                -> usage (regTarget t, [])+  BL t ps _rs              -> usage (regTarget t ++ ps, callerSavedRegisters)++  -- 5. Atomic Instructions ----------------------------------------------------+  -- 6. Conditional Instructions -----------------------------------------------+  CSET dst _               -> usage ([], regOp dst)+  CBZ src _                -> usage (regOp src, [])+  CBNZ src _               -> usage (regOp src, [])+  -- 7. Load and Store Instructions --------------------------------------------+  STR _ src dst            -> usage (regOp src ++ regOp dst, [])+  LDR _ dst src            -> usage (regOp src, regOp dst)+  -- TODO is this right? see STR, which I'm only partial about being right?+  STP _ src1 src2 dst      -> usage (regOp src1 ++ regOp src2 ++ regOp dst, [])+  LDP _ dst1 dst2 src      -> usage (regOp src, regOp dst1 ++ regOp dst2)++  -- 8. Synchronization Instructions -------------------------------------------+  DMBSY                    -> usage ([], [])++  -- 9. Floating Point Instructions --------------------------------------------+  FCVT dst src             -> usage (regOp src, regOp dst)+  SCVTF dst src            -> usage (regOp src, regOp dst)+  FCVTZS dst src           -> usage (regOp src, regOp dst)+  FABS dst src             -> usage (regOp src, regOp dst)++  _ -> panic "regUsageOfInstr"++  where+        -- filtering the usage is necessary, otherwise the register+        -- allocator will try to allocate pre-defined fixed stg+        -- registers as well, as they show up.+        usage (src, dst) = RU (filter (interesting platform) src)+                              (filter (interesting platform) dst)++        regAddr :: AddrMode -> [Reg]+        regAddr (AddrRegReg r1 r2) = [r1, r2]+        regAddr (AddrRegImm r1 _)  = [r1]+        regAddr (AddrReg r1)       = [r1]+        regOp :: Operand -> [Reg]+        regOp (OpReg _ r1) = [r1]+        regOp (OpRegExt _ r1 _ _) = [r1]+        regOp (OpRegShift _ r1 _ _) = [r1]+        regOp (OpAddr a) = regAddr a+        regOp (OpImm _) = []+        regOp (OpImmShift _ _ _) = []+        regTarget :: Target -> [Reg]+        regTarget (TBlock _) = []+        regTarget (TLabel _) = []+        regTarget (TReg r1)  = [r1]++        -- Is this register interesting for the register allocator?+        interesting :: Platform -> Reg -> Bool+        interesting _        (RegVirtual _)                 = True+        interesting _        (RegReal (RealRegSingle (-1))) = False+        interesting platform (RegReal (RealRegSingle i))    = freeReg platform i+        interesting _        (RegReal (RealRegPair{}))+            = panic "AArch64.Instr.interesting: no reg pairs on this arch"++-- Save caller save registers+-- This is x0-x18+--+-- For SIMD/FP Registers:+-- Registers v8-v15 must be preserved by a callee across subroutine calls;+-- the remaining registers (v0-v7, v16-v31) do not need to be preserved (or+-- should be preserved by the caller). Additionally, only the bottom 64 bits+-- of each value stored in v8-v15 need to be preserved [7]; it is the+-- responsibility of the caller to preserve larger values.+--+-- .---------------------------------------------------------------------------------------------------------------------------------------------------------------.+-- |  0 |  1 |  2 |  3 |  4 |  5 |  6 |  7 |  8 |  9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 |+-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |+-- |== General Purpose registers ==================================================================================================================================|+-- | <---- argument passing -------------> | IR | <------- tmp registers --------> | IP0| IP1| PL | <------------------- callee saved ------------> | FP | LR | SP |+-- | <------ free registers --------------------------------------------------------------------> | BR | Sp | Hp | R1 | R2 | R3 | R4 | R5 | R6 | SL | -- | -- | -- |+-- |== SIMD/FP Registers ==========================================================================================================================================|+-- | <---- argument passing -------------> | <-- callee saved (lower 64 bits) ---> | <--------------------------------------- caller saved ----------------------> |+-- | <------ free registers -------------> | F1 | F2 | F3 | F4 | D1 | D2 | D3 | D4 | <------ free registers -----------------------------------------------------> |+-- '---------------------------------------------------------------------------------------------------------------------------------------------------------------'+-- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer+-- BR: Base, SL: SpLim+callerSavedRegisters :: [Reg]+callerSavedRegisters+    = map regSingle [0..18]+    ++ map regSingle [32..39]+    ++ map regSingle [48..63]++-- | Apply a given mapping to all the register references in this+-- instruction.+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of+    -- 0. Meta Instructions+    ANN d i        -> ANN d (patchRegsOfInstr i env)+    -- 1. Arithmetic Instructions ----------------------------------------------+    ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)+    CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)+    CMP o1 o2      -> CMP (patchOp o1) (patchOp o2)+    MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+    MUL o1 o2 o3   -> MUL (patchOp o1) (patchOp o2) (patchOp o3)+    NEG o1 o2      -> NEG (patchOp o1) (patchOp o2)+    SDIV o1 o2 o3  -> SDIV (patchOp o1) (patchOp o2) (patchOp o3)+    SUB o1 o2 o3   -> SUB  (patchOp o1) (patchOp o2) (patchOp o3)+    UDIV o1 o2 o3  -> UDIV (patchOp o1) (patchOp o2) (patchOp o3)++    -- 2. Bit Manipulation Instructions ----------------------------------------+    SBFM o1 o2 o3 o4 -> SBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+    UBFM o1 o2 o3 o4 -> UBFM (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)++    -- 3. Logical and Move Instructions ----------------------------------------+    AND o1 o2 o3   -> AND  (patchOp o1) (patchOp o2) (patchOp o3)+    ANDS o1 o2 o3  -> ANDS (patchOp o1) (patchOp o2) (patchOp o3)+    ASR o1 o2 o3   -> ASR  (patchOp o1) (patchOp o2) (patchOp o3)+    BIC o1 o2 o3   -> BIC  (patchOp o1) (patchOp o2) (patchOp o3)+    BICS o1 o2 o3  -> BICS (patchOp o1) (patchOp o2) (patchOp o3)+    EON o1 o2 o3   -> EON  (patchOp o1) (patchOp o2) (patchOp o3)+    EOR o1 o2 o3   -> EOR  (patchOp o1) (patchOp o2) (patchOp o3)+    LSL o1 o2 o3   -> LSL  (patchOp o1) (patchOp o2) (patchOp o3)+    LSR o1 o2 o3   -> LSR  (patchOp o1) (patchOp o2) (patchOp o3)+    MOV o1 o2      -> MOV  (patchOp o1) (patchOp o2)+    MOVK o1 o2     -> MOVK (patchOp o1) (patchOp o2)+    MVN o1 o2      -> MVN  (patchOp o1) (patchOp o2)+    ORR o1 o2 o3   -> ORR  (patchOp o1) (patchOp o2) (patchOp o3)+    ROR o1 o2 o3   -> ROR  (patchOp o1) (patchOp o2) (patchOp o3)+    TST o1 o2      -> TST  (patchOp o1) (patchOp o2)++    -- 4. Branch Instructions --------------------------------------------------+    J t            -> J (patchTarget t)+    B t            -> B (patchTarget t)+    BL t rs ts     -> BL (patchTarget t) rs ts+    BCOND c t      -> BCOND c (patchTarget t)++    -- 5. Atomic Instructions --------------------------------------------------+    -- 6. Conditional Instructions ---------------------------------------------+    CSET o c       -> CSET (patchOp o) c+    CBZ o l        -> CBZ (patchOp o) l+    CBNZ o l       -> CBNZ (patchOp o) l+    -- 7. Load and Store Instructions ------------------------------------------+    STR f o1 o2    -> STR f (patchOp o1) (patchOp o2)+    LDR f o1 o2    -> LDR f (patchOp o1) (patchOp o2)+    STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3)+    LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3)++    -- 8. Synchronization Instructions -----------------------------------------+    DMBSY          -> DMBSY++    -- 9. Floating Point Instructions ------------------------------------------+    FCVT o1 o2     -> FCVT (patchOp o1) (patchOp o2)+    SCVTF o1 o2    -> SCVTF (patchOp o1) (patchOp o2)+    FCVTZS o1 o2   -> FCVTZS (patchOp o1) (patchOp o2)+    FABS o1 o2     -> FABS (patchOp o1) (patchOp o2)++    _ -> pprPanic "patchRegsOfInstr" (text $ show instr)+    where+        patchOp :: Operand -> Operand+        patchOp (OpReg w r) = OpReg w (env r)+        patchOp (OpRegExt w r x s) = OpRegExt w (env r) x s+        patchOp (OpRegShift w r m s) = OpRegShift w (env r) m s+        patchOp (OpAddr a) = OpAddr (patchAddr a)+        patchOp op = op+        patchTarget :: Target -> Target+        patchTarget (TReg r) = TReg (env r)+        patchTarget t = t+        patchAddr :: AddrMode -> AddrMode+        patchAddr (AddrRegReg r1 r2) = AddrRegReg (env r1) (env r2)+        patchAddr (AddrRegImm r1 i)  = AddrRegImm (env r1) i+        patchAddr (AddrReg r) = AddrReg (env r)+--------------------------------------------------------------------------------+-- | Checks whether this instruction is a jump/branch instruction.+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr = case instr of+    ANN _ i -> isJumpishInstr i+    CBZ{} -> True+    CBNZ{} -> True+    J{} -> True+    B{} -> True+    BL{} -> True+    BCOND{} -> True+    _ -> False++-- | Checks whether this instruction is a jump/branch instruction.+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (CBZ _ t) = [ id | TBlock id <- [t]]+jumpDestsOfInstr (CBNZ _ t) = [ id | TBlock id <- [t]]+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BL t _ _) = [ id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++-- | Change the destination of this jump instruction.+-- Used in the linear allocator when adding fixup blocks for join+-- points.+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr instr patchF+    = case instr of+        ANN d i -> ANN d (patchJumpInstr i patchF)+        CBZ r (TBlock bid) -> CBZ r (TBlock (patchF bid))+        CBNZ r (TBlock bid) -> CBNZ r (TBlock (patchF bid))+        J (TBlock bid) -> J (TBlock (patchF bid))+        B (TBlock bid) -> B (TBlock (patchF bid))+        BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs+        BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))+        _ -> pprPanic "patchJumpInstr" (text $ show instr)++-- -----------------------------------------------------------------------------+-- Note [Spills and Reloads]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading+-- registers.  AArch64s maximum displacement for SP relative spills and reloads+-- is essentially [-256,255], or [0, 0xFFF]*8 = [0, 32760] for 64bits.+--+-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't address any location in a+-- single instruction.  The idea is to use the Inter Procedure 0 (ip0) register+-- to perform the computations for larger offsets.+--+-- Using sp to compute the offset will violate assumptions about the stack pointer+-- pointing to the top of the stack during signal handling.  As we can't force+-- every signal to use its own stack, we have to ensure that the stack poitner+-- always poitns to the top of the stack, and we can't use it for computation.+--+-- | An instruction to spill a register into a spill slot.+mkSpillInstr+   :: HasCallStack+   => NCGConfig+   -> Reg       -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkSpillInstr config reg delta slot =+  case (spillSlotToOffset config slot) - delta of+    imm | -256 <= imm && imm <= 255                               -> [ mkStrSp imm ]+    imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff           -> [ mkStrSp imm ]+    imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0    -> [ mkIp0SpillAddr (imm .&~. 0xfff)+                                                                     , mkStrIp0 (imm .&.  0xfff)+                                                                     ]+    imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm)+    where+        a .&~. b = a .&. (complement b)++        fmt = case reg of+            RegReal (RealRegSingle n) | n < 32 -> II64+            _                                  -> FF64+        mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))+        mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))+        mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))++        off = spillSlotToOffset config slot++mkLoadInstr+   :: NCGConfig+   -> Reg       -- register to load+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkLoadInstr config reg delta slot =+  case (spillSlotToOffset config slot) - delta of+    imm | -256 <= imm && imm <= 255                               -> [ mkLdrSp imm ]+    imm | imm > 0 && imm .&. 0x7 == 0x0 && imm <= 0xfff           -> [ mkLdrSp imm ]+    imm | imm > 0xfff && imm <= 0xffffff && imm .&. 0x7 == 0x0    -> [ mkIp0SpillAddr (imm .&~. 0xfff)+                                                                     , mkLdrIp0 (imm .&.  0xfff)+                                                                     ]+    imm -> pprPanic "mkSpillInstr" (text "Unable to spill into" <+> int imm)+    where+        a .&~. b = a .&. (complement b)++        fmt = case reg of+            RegReal (RealRegSingle n) | n < 32 -> II64+            _                                  -> FF64++        mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))+        mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))+        mkLdrIp0 imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))++        off = spillSlotToOffset config slot++--------------------------------------------------------------------------------+-- | See if this instruction is telling us the current C stack delta+takeDeltaInstr :: Instr -> Maybe Int+takeDeltaInstr (ANN _ i) = takeDeltaInstr i+takeDeltaInstr (DELTA i) = Just i+takeDeltaInstr _         = Nothing++-- Not real instructions.  Just meta data+isMetaInstr :: Instr -> Bool+isMetaInstr instr+ = case instr of+    ANN _ i     -> isMetaInstr i+    COMMENT{}   -> True+    MULTILINE_COMMENT{} -> True+    LOCATION{}  -> True+    LDATA{}     -> True+    NEWBLOCK{}  -> True+    DELTA{}     -> True+    PUSH_STACK_FRAME -> True+    POP_STACK_FRAME -> True+    _           -> False++-- | Copy the value in a register to another one.+-- Must work for all register classes.+mkRegRegMoveInstr :: Reg -> Reg -> Instr+mkRegRegMoveInstr src dst = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)++-- | Take the source and destination from this reg -> reg move instruction+-- or Nothing if it's not one+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+--takeRegRegMoveInstr (MOV (OpReg fmt dst) (OpReg fmt' src)) | fmt == fmt' = Just (src, dst)+takeRegRegMoveInstr _ = Nothing++-- | Make an unconditional jump instruction.+mkJumpInstr :: BlockId -> [Instr]+mkJumpInstr id = [B (TBlock id)]++mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr platform n+    | n == 0 = []+    | n > 0 && n < 4096 = [ ANN (text "Alloc More Stack") $ SUB sp sp (OpImm (ImmInt n)) ]+    | n > 0 =  ANN (text "Alloc More Stack") (SUB sp sp (OpImm (ImmInt 4095))) : mkStackAllocInstr platform (n - 4095)+mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n)++mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr platform n+    | n == 0 = []+    | n > 0 && n < 4096 = [ ANN (text "Dealloc More Stack") $ ADD sp sp (OpImm (ImmInt n)) ]+    | n > 0 =  ANN (text "Dealloc More Stack") (ADD sp sp (OpImm (ImmInt 4095))) : mkStackDeallocInstr platform (n - 4095)+mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)++--+-- See note [extra spill slots] in X86/Instr.hs+--+allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr+  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)])++allocMoreStack _ _ top@(CmmData _ _) = return (top,[])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+    let entries = entryBlocks proc++    uniqs <- replicateM (length entries) getUniqueM++    let+      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+        where x = slots * spillSlotSize -- sp delta++      alloc   = mkStackAllocInstr   platform delta+      dealloc = mkStackDeallocInstr platform delta++      retargetList = (zip entries (map mkBlockId uniqs))++      new_blockmap :: LabelMap BlockId+      new_blockmap = mapFromList retargetList++      insert_stack_insn (BasicBlock id insns)+        | Just new_blockid <- mapLookup id new_blockmap+        = [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ]+          , BasicBlock new_blockid block' ]+        | otherwise+        = [ BasicBlock id block' ]+        where+          block' = foldr insert_dealloc [] insns++      insert_dealloc insn r = case insn of+        J _ -> dealloc ++ (insn : r)+        ANN _ (J _) -> dealloc ++ (insn : r)+        _other | jumpDestsOfInstr insn /= []+            -> patchJumpInstr insn retarget : r+        _other -> insn : r++        where retarget b = fromMaybe b (mapLookup b new_blockmap)++      new_code = concatMap insert_stack_insn code+    -- in+    return (CmmProc info lbl live (ListGraph new_code), retargetList)+-- -----------------------------------------------------------------------------+-- Machine's assembly language++-- We have a few common "instructions" (nearly all the pseudo-ops) but+-- mostly all of 'Instr' is machine-specific.++-- Some additional (potential future) instructions are commented out. They are+-- not needed yet for the backend but could be used in the future.+data Instr+    -- comment pseudo-op+    = COMMENT SDoc+    | MULTILINE_COMMENT SDoc++    -- Annotated instruction. Should print <instr> # <doc>+    | ANN SDoc Instr++    -- location pseudo-op (file, line, col, name)+    | LOCATION Int Int Int String++    -- some static data spat out during code+    -- generation.  Will be extracted before+    -- pretty-printing.+    | LDATA   Section RawCmmStatics++    -- start a new basic block.  Useful during+    -- codegen, removed later.  Preceding+    -- instruction should be a jump, as per the+    -- invariants for a BasicBlock (see Cmm).+    | NEWBLOCK BlockId++    -- specify current stack offset for+    -- benefit of subsequent passes+    | DELTA   Int++    -- 0. Pseudo Instructions --------------------------------------------------+    -- These are instructions not contained or only partially contained in the+    -- official ISA, but make reading clearer. Some of them might even be+    -- implemented in the assembler, but are not guaranteed to be portable.+    -- | SXTB Operand Operand+    -- | SXTH Operand Operand+    -- | SXTW Operand Operand+    -- | SXTX Operand Operand+    | PUSH_STACK_FRAME+    | POP_STACK_FRAME+    -- 1. Arithmetic Instructions ----------------------------------------------+    -- | ADC Operand Operand Operang -- rd = rn + rm + C+    -- | ADCS ...+    | ADD Operand Operand Operand -- rd = rn + rm+    -- | ADDS Operand Operand Operand -- rd = rn + rm+    -- | ADR ...+    -- | ADRP ...+    | CMN Operand Operand -- rd + op2+    | CMP Operand Operand -- rd - op2+    -- | MADD ...+    -- | MNEG ...+    | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm+    | MUL Operand Operand Operand -- rd = rn × rm+    | NEG Operand Operand -- rd = -op2+    -- | NEGS ...+    -- | NGC ...+    -- | NGCS ...+    -- | SBC ...+    -- | SBCS ...+    | SDIV Operand Operand Operand -- rd = rn ÷ rm+    -- | SMADDL ...+    -- | SMNEGL ...+    -- | SMSUBL ...+    -- | SMULH ...+    -- | SMULL ...+    | SUB Operand Operand Operand -- rd = rn - op2+    -- | SUBS ...+    | UDIV Operand Operand Operand -- rd = rn ÷ rm+    -- | UMADDL ...  -- Xd = Xa + Wn × Wm+    -- | UMNEGL ... -- Xd = - Wn × Wm+    -- | UMSUBL ... -- Xd = Xa - Wn × Wm+    -- | UMULH ... -- Xd = (Xn × Xm)_127:64+    -- | UMULL ... -- Xd = Wn × Wm++    -- 2. Bit Manipulation Instructions ----------------------------------------+    | SBFM Operand Operand Operand Operand -- rd = rn[i,j]+    -- SXTB = SBFM <Wd>, <Wn>, #0, #7+    -- SXTH = SBFM <Wd>, <Wn>, #0, #15+    -- SXTW = SBFM <Wd>, <Wn>, #0, #31+    | UBFM Operand Operand Operand Operand -- rd = rn[i,j]+    -- UXTB = UBFM <Wd>, <Wn>, #0, #7+    -- UXTH = UBFM <Wd>, <Wn>, #0, #15++    -- 3. Logical and Move Instructions ----------------------------------------+    | AND Operand Operand Operand -- rd = rn & op2+    | ANDS Operand Operand Operand -- rd = rn & op2+    | ASR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits+    | BIC Operand Operand Operand -- rd = rn & ~op2+    | BICS Operand Operand Operand -- rd = rn & ~op2+    | EON Operand Operand Operand -- rd = rn ⊕ ~op2+    | EOR Operand Operand Operand -- rd = rn ⊕ op2+    | LSL Operand Operand Operand -- rd = rn ≪ rm  or rd = rn ≪ #i, i is 6 bits+    | LSR Operand Operand Operand -- rd = rn ≫ rm  or rd = rn ≫ #i, i is 6 bits+    | MOV Operand Operand -- rd = rn  or  rd = #i+    | MOVK Operand Operand+    -- | MOVN Operand Operand+    -- | MOVZ Operand Operand+    | MVN Operand Operand -- rd = ~rn+    | ORN Operand Operand Operand -- rd = rn | ~op2+    | ORR Operand Operand Operand -- rd = rn | op2+    | ROR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits+    | TST Operand Operand -- rn & op2+    -- Load and stores.+    -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.+    | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr+    | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr+    | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8)+    | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8)++    -- Conditional instructions+    | CSET Operand Cond   -- if(cond) op <- 1 else op <- 0++    | CBZ Operand Target  -- if op == 0, then branch.+    | CBNZ Operand Target -- if op /= 0, then branch.+    -- Branching.+    | J Target            -- like B, but only generated from genJump. Used to distinguish genJumps from others.+    | B Target            -- unconditional branching b/br. (To a blockid, label or register)+    | BL Target [Reg] [Reg] -- branch and link (e.g. set x30 to next pc, and branch)+    | BCOND Cond Target   -- branch with condition. b.<cond>++    -- 8. Synchronization Instructions -----------------------------------------+    | DMBSY+    -- 9. Floating Point Instructions+    -- Float ConVerT+    | FCVT Operand Operand+    -- Signed ConVerT Float+    | SCVTF Operand Operand+    -- Float ConVerT to Zero Signed+    | FCVTZS Operand Operand+    -- Float ABSolute value+    | FABS Operand Operand++instance Show Instr where+    show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2+    show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2+    show _ = "missing"++data Target+    = TBlock BlockId+    | TLabel CLabel+    | TReg   Reg+++-- Extension+-- {Unsigned|Signed}XT{Byte|Half|Word|Doube}+data ExtMode+    = EUXTB | EUXTH | EUXTW | EUXTX+    | ESXTB | ESXTH | ESXTW | ESXTX+    deriving (Eq, Show)++data ShiftMode+    = SLSL | SLSR | SASR | SROR+    deriving (Eq, Show)+++-- We can also add ExtShift to Extension.+-- However at most 3bits.+type ExtShift = Int+-- at most 6bits+type RegShift = Int++data Operand+        = OpReg Width Reg            -- register+        | OpRegExt Width Reg ExtMode ExtShift -- rm, <ext>[, <shift left>]+        | OpRegShift Width Reg ShiftMode RegShift     -- rm, <shift>, <0-64>+        | OpImm Imm            -- immediate value+        | OpImmShift Imm ShiftMode RegShift+        | OpAddr AddrMode       -- memory reference+        deriving (Eq, Show)++-- Smart constructors+opReg :: Width -> Reg -> Operand+opReg = OpReg++xzr, wzr, sp, ip0 :: Operand+xzr = OpReg W64 (RegReal (RealRegSingle (-1)))+wzr = OpReg W32 (RegReal (RealRegSingle (-1)))+sp  = OpReg W64 (RegReal (RealRegSingle 31))+ip0 = OpReg W64 (RegReal (RealRegSingle 16))++_x :: Int -> Operand+_x i = OpReg W64 (RegReal (RealRegSingle i))+x0,  x1,  x2,  x3,  x4,  x5,  x6,  x7  :: Operand+x8,  x9,  x10, x11, x12, x13, x14, x15 :: Operand+x16, x17, x18, x19, x20, x21, x22, x23 :: Operand+x24, x25, x26, x27, x28, x29, x30, x31 :: Operand+x0  = OpReg W64 (RegReal (RealRegSingle  0))+x1  = OpReg W64 (RegReal (RealRegSingle  1))+x2  = OpReg W64 (RegReal (RealRegSingle  2))+x3  = OpReg W64 (RegReal (RealRegSingle  3))+x4  = OpReg W64 (RegReal (RealRegSingle  4))+x5  = OpReg W64 (RegReal (RealRegSingle  5))+x6  = OpReg W64 (RegReal (RealRegSingle  6))+x7  = OpReg W64 (RegReal (RealRegSingle  7))+x8  = OpReg W64 (RegReal (RealRegSingle  8))+x9  = OpReg W64 (RegReal (RealRegSingle  9))+x10 = OpReg W64 (RegReal (RealRegSingle 10))+x11 = OpReg W64 (RegReal (RealRegSingle 11))+x12 = OpReg W64 (RegReal (RealRegSingle 12))+x13 = OpReg W64 (RegReal (RealRegSingle 13))+x14 = OpReg W64 (RegReal (RealRegSingle 14))+x15 = OpReg W64 (RegReal (RealRegSingle 15))+x16 = OpReg W64 (RegReal (RealRegSingle 16))+x17 = OpReg W64 (RegReal (RealRegSingle 17))+x18 = OpReg W64 (RegReal (RealRegSingle 18))+x19 = OpReg W64 (RegReal (RealRegSingle 19))+x20 = OpReg W64 (RegReal (RealRegSingle 20))+x21 = OpReg W64 (RegReal (RealRegSingle 21))+x22 = OpReg W64 (RegReal (RealRegSingle 22))+x23 = OpReg W64 (RegReal (RealRegSingle 23))+x24 = OpReg W64 (RegReal (RealRegSingle 24))+x25 = OpReg W64 (RegReal (RealRegSingle 25))+x26 = OpReg W64 (RegReal (RealRegSingle 26))+x27 = OpReg W64 (RegReal (RealRegSingle 27))+x28 = OpReg W64 (RegReal (RealRegSingle 28))+x29 = OpReg W64 (RegReal (RealRegSingle 29))+x30 = OpReg W64 (RegReal (RealRegSingle 30))+x31 = OpReg W64 (RegReal (RealRegSingle 31))++_d :: Int -> Operand+_d = OpReg W64 . RegReal . RealRegSingle+d0,  d1,  d2,  d3,  d4,  d5,  d6,  d7  :: Operand+d8,  d9,  d10, d11, d12, d13, d14, d15 :: Operand+d16, d17, d18, d19, d20, d21, d22, d23 :: Operand+d24, d25, d26, d27, d28, d29, d30, d31 :: Operand+d0  = OpReg W64 (RegReal (RealRegSingle 32))+d1  = OpReg W64 (RegReal (RealRegSingle 33))+d2  = OpReg W64 (RegReal (RealRegSingle 34))+d3  = OpReg W64 (RegReal (RealRegSingle 35))+d4  = OpReg W64 (RegReal (RealRegSingle 36))+d5  = OpReg W64 (RegReal (RealRegSingle 37))+d6  = OpReg W64 (RegReal (RealRegSingle 38))+d7  = OpReg W64 (RegReal (RealRegSingle 39))+d8  = OpReg W64 (RegReal (RealRegSingle 40))+d9  = OpReg W64 (RegReal (RealRegSingle 41))+d10 = OpReg W64 (RegReal (RealRegSingle 42))+d11 = OpReg W64 (RegReal (RealRegSingle 43))+d12 = OpReg W64 (RegReal (RealRegSingle 44))+d13 = OpReg W64 (RegReal (RealRegSingle 45))+d14 = OpReg W64 (RegReal (RealRegSingle 46))+d15 = OpReg W64 (RegReal (RealRegSingle 47))+d16 = OpReg W64 (RegReal (RealRegSingle 48))+d17 = OpReg W64 (RegReal (RealRegSingle 49))+d18 = OpReg W64 (RegReal (RealRegSingle 50))+d19 = OpReg W64 (RegReal (RealRegSingle 51))+d20 = OpReg W64 (RegReal (RealRegSingle 52))+d21 = OpReg W64 (RegReal (RealRegSingle 53))+d22 = OpReg W64 (RegReal (RealRegSingle 54))+d23 = OpReg W64 (RegReal (RealRegSingle 55))+d24 = OpReg W64 (RegReal (RealRegSingle 56))+d25 = OpReg W64 (RegReal (RealRegSingle 57))+d26 = OpReg W64 (RegReal (RealRegSingle 58))+d27 = OpReg W64 (RegReal (RealRegSingle 59))+d28 = OpReg W64 (RegReal (RealRegSingle 60))+d29 = OpReg W64 (RegReal (RealRegSingle 61))+d30 = OpReg W64 (RegReal (RealRegSingle 62))+d31 = OpReg W64 (RegReal (RealRegSingle 63))++opRegUExt :: Width -> Reg -> Operand+opRegUExt W64 r = OpRegExt W64 r EUXTX 0+opRegUExt W32 r = OpRegExt W32 r EUXTW 0+opRegUExt W16 r = OpRegExt W16 r EUXTH 0+opRegUExt W8  r = OpRegExt W8  r EUXTB 0+opRegUExt w  _r = pprPanic "opRegUExt" (text $ show w)++opRegSExt :: Width -> Reg -> Operand+opRegSExt W64 r = OpRegExt W64 r ESXTX 0+opRegSExt W32 r = OpRegExt W32 r ESXTW 0+opRegSExt W16 r = OpRegExt W16 r ESXTH 0+opRegSExt W8  r = OpRegExt W8  r ESXTB 0+opRegSExt w  _r = pprPanic "opRegSExt" (text $ show w)

+ GHC/CmmToAsm/AArch64/Ppr.hs view

@@ -0,0 +1,588 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE CPP #-}++module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Prelude hiding (EQ)++import Data.Word+import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST+import Control.Monad.ST++import GHC.CmmToAsm.AArch64.Instr+import GHC.CmmToAsm.AArch64.Regs+import GHC.CmmToAsm.AArch64.Cond+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Format+import GHC.Platform.Reg+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils++import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)++import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Ppr.Expr () -- For Outputable instances++import GHC.Types.Unique ( pprUniqueAlways, getUnique )+import GHC.Platform+import GHC.Utils.Outputable++import GHC.Utils.Panic++pprProcAlignment :: NCGConfig -> SDoc+pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)+   where+      platform = ncgPlatform config++pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section $$ pprDatas config dats++pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config in+  pprProcAlignment config $$+  case topInfoTable proc of+    Nothing ->+        -- special case for code without info table:+        pprSectionAlign config (Section Text lbl) $$+        -- do not+        -- pprProcAlignment config $$+        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) $$+        pprSizeDecl platform lbl++    Just (CmmStaticsRaw info_lbl _) ->+      pprSectionAlign config (Section Text info_lbl) $$+      -- pprProcAlignment config $$+      (if platformHasSubsectionsViaSymbols platform+          then ppr (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+      -- elimination, it might be the target of a goto.+      (if platformHasSubsectionsViaSymbols platform+       then -- See Note [Subsections Via Symbols]+                text "\t.long "+            <+> ppr info_lbl+            <+> char '-'+            <+> ppr (mkDeadStripPreventer info_lbl)+       else empty) $$+      pprSizeDecl platform info_lbl++pprLabel :: Platform -> CLabel -> SDoc+pprLabel platform lbl =+   pprGloblDecl platform lbl+   $$ pprTypeDecl platform lbl+   $$ (pdoc platform lbl <> char ':')++pprAlign :: Platform -> Alignment -> SDoc+pprAlign _platform alignment+        = text "\t.balign " <> int (alignmentBytes alignment)++-- | Print appropriate alignment for the given section type.+pprAlignForSection :: Platform -> SectionType -> SDoc+pprAlignForSection _platform _seg+    -- .balign is stable, whereas .align is platform dependent.+    = text "\t.balign 8" --  always 8++instance Outputable Instr where+    ppr = pprInstr genericPlatform++-- | Print section header and appropriate alignment for that section.+--+-- This one will emit the header:+--+--     .section .text+--     .balign 8+--+pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign _config (Section (OtherSection _) _) =+     panic "AArch64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+    pprSectionHeader config sec+    $$ pprAlignForSection (ncgPlatform config) seg++-- | Output the ELF .size directive.+pprSizeDecl :: Platform -> CLabel -> SDoc+pprSizeDecl platform lbl+ = if osElfTarget (platformOS platform)+   then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl+   else empty++pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr+              -> SDoc+pprBasicBlock config info_env (BasicBlock blockid instrs)+  = maybe_infotable $+    pprLabel platform asmLbl $$+    vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$+    (if  ncgDwarfEnabled config+      then ppr (mkAsmTempEndLabel asmLbl) <> char ':'+      else empty+    )+  where+    -- Filter out identity moves. E.g. mov x18, x18 will be dropped.+    optInstrs = filter f instrs+      where f (MOV o1 o2) | o1 == o2 = False+            f _ = True++    asmLbl = blockLbl blockid+    platform = ncgPlatform config+    maybe_infotable c = case mapLookup blockid info_env of+       Nothing   -> c+       Just (CmmStaticsRaw info_lbl info) ->+          --  pprAlignForSection platform Text $$+           infoTableLoc $$+           vcat (map (pprData config) info) $$+           pprLabel platform info_lbl $$+           c $$+           (if ncgDwarfEnabled config+             then ppr (mkAsmTempEndLabel info_lbl) <> char ':'+             else empty)+    -- Make sure the info table has the right .loc for the block+    -- coming right after it. See [Note: Info Offset]+    infoTableLoc = case instrs of+      (l@LOCATION{} : _) -> pprInstr platform l+      _other             -> empty++pprDatas :: NCGConfig -> RawCmmStatics -> SDoc+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+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 (ncgPlatform config) alias+    $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind')++pprDatas config (CmmStaticsRaw lbl dats)+  = vcat (pprLabel platform lbl : map (pprData config) dats)+   where+      platform = ncgPlatform config++pprData :: NCGConfig -> CmmStatic -> SDoc+pprData _config (CmmString str) = pprString str+pprData _config (CmmFileEmbed path) = pprFileEmbed path++pprData config (CmmUninitialised bytes)+ = let platform = ncgPlatform config+   in if platformOS platform == OSDarwin+         then text ".space " <> int bytes+         else text ".skip "  <> int bytes++pprData config (CmmStaticLit lit) = pprDataItem config lit++pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl platform lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = text "\t.globl " <> pdoc platform lbl++-- Note [Always use objects for info tables]+-- See discussion in X86.Ppr+-- for why this is necessary.  Essentially we need to ensure that we never+-- pass function symbols when we migth want to lookup the info table.  If we+-- did, we could end up with procedure linking tables (PLT)s, and thus the+-- lookup wouldn't point to the function, but into the jump table.+--+-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as+-- well.+pprLabelType' :: Platform -> CLabel -> SDoc+pprLabelType' platform lbl =+  if isCFunctionLabel lbl || functionOkInfoTable then+    text "@function"+  else+    text "@object"+  where+    functionOkInfoTable = platformTablesNextToCode platform &&+      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)++-- this is called pprTypeAndSizeDecl in PPC.Ppr+pprTypeDecl :: Platform -> CLabel -> SDoc+pprTypeDecl platform lbl+    = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl+      then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl+      else empty++pprDataItem :: NCGConfig -> CmmLit -> SDoc+pprDataItem config lit+  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+    where+        platform = ncgPlatform config++        imm = litToImm lit++        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 _ = [text "\t.quad\t"  <> pprImm platform imm]++        ppr_item FF32  (CmmFloat r _)+           = let bs = floatToBytes (fromRational r)+             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 platform (ImmInt b)) bs++        ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)++floatToBytes :: Float -> [Int]+floatToBytes f+   = runST (do+        arr <- newArray_ ((0::Int),3)+        writeArray arr 0 f+        arr <- castFloatToWord8Array arr+        i0 <- readArray arr 0+        i1 <- readArray arr 1+        i2 <- readArray arr 2+        i3 <- readArray arr 3+        return (map fromIntegral [i0,i1,i2,i3])+     )++castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)+castFloatToWord8Array = U.castSTUArray++pprImm :: Platform -> Imm -> SDoc+pprImm _ (ImmInt i)     = int i+pprImm _ (ImmInteger i) = integer i+pprImm p (ImmCLbl l)    = pdoc p l+pprImm p (ImmIndex l i) = pdoc p l <> char '+' <> int i+pprImm _ (ImmLit s)     = s++-- TODO: See pprIm below for why this is a bad idea!+pprImm _ (ImmFloat f)+  | f == 0 = text "wzr"+  | otherwise = float (fromRational f)+pprImm _ (ImmDouble d)+  | d == 0 = text "xzr"+  | otherwise = double (fromRational d)++pprImm p (ImmConstantSum a b) = pprImm p a <> char '+' <> pprImm p b+pprImm p (ImmConstantDiff a b) = pprImm p a <> char '-'+                   <> lparen <> pprImm p b <> rparen+++-- aarch64 GNU as uses // for comments.+asmComment :: SDoc -> SDoc+asmComment c = whenPprDebug $ text "#" <+> c++asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = whenPprDebug $ text "//" <+> c++asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/"++pprIm :: Platform -> Imm -> SDoc+pprIm platform im = case im of+  ImmInt i     -> char '#' <> int i+  ImmInteger i -> char '#' <> integer i++  -- TODO: This will only work for+  -- The floating point value must be expressable as ±n ÷ 16 × 2^r,+  -- where n and r are integers such that 16 ≤ n ≤ 31 and -3 ≤ r ≤ 4.+  -- and 0 needs to be encoded as wzr/xzr.+  --+  -- Except for 0, we might want to either split it up into enough+  -- ADD operations into an Integer register and then just bit copy it into+  -- the double register? See the toBytes + fromRational above for data items.+  -- This is something the x86 backend does.+  --+  -- We could also just turn them into statics :-/ Which is what the+  -- PowerPC backend odes.+  ImmFloat f | f == 0 -> text "wzr"+  ImmFloat f -> char '#' <> float (fromRational f)+  ImmDouble d | d == 0 -> text "xzr"+  ImmDouble d -> char '#' <> double (fromRational d)+  -- =<lbl> pseudo instruction!+  ImmCLbl l    -> char '=' <> pdoc platform l+  ImmIndex l o -> text "[=" <> pdoc platform l <> comma <+> char '#' <> int o <> char ']'+  _            -> panic "AArch64.pprIm"++pprExt :: ExtMode -> SDoc+pprExt EUXTB = text "uxtb"+pprExt EUXTH = text "uxth"+pprExt EUXTW = text "uxtw"+pprExt EUXTX = text "uxtx"+pprExt ESXTB = text "sxtb"+pprExt ESXTH = text "sxth"+pprExt ESXTW = text "sxtw"+pprExt ESXTX = text "sxtx"++pprShift :: ShiftMode -> SDoc+pprShift SLSL = text "lsl"+pprShift SLSR = text "lsr"+pprShift SASR = text "asr"+pprShift SROR = text "ror"++pprOp :: Platform -> Operand -> SDoc+pprOp plat op = case op of+  OpReg w r           -> pprReg w r+  OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x+  OpRegExt w r x i -> pprReg w r <> comma <+> pprExt x <> comma <+> char '#' <> int i+  OpRegShift w r s i -> pprReg w r <> comma <+> pprShift s <> comma <+> char '#' <> int i+  OpImm im          -> pprIm plat im+  OpImmShift im s i -> pprIm plat im <> comma <+> pprShift s <+> char '#' <> int i+  -- TODO: Address compuation always use registers as 64bit -- is this correct?+  OpAddr (AddrRegReg r1 r2) -> char '[' <+> pprReg W64 r1 <> comma <+> pprReg W64 r2 <+> char ']'+  OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']'+  OpAddr (AddrReg r1)       -> char '[' <+> pprReg W64 r1 <+> char ']'++pprReg :: Width -> Reg -> SDoc+pprReg w r = case r of+  RegReal    (RealRegSingle i) -> ppr_reg_no w i+  RegReal    (RealRegPair{})   -> panic "AArch64.pprReg: no reg pairs on this arch!"+  -- virtual regs should not show up, but this is helpful for debugging.+  RegVirtual (VirtualRegI u)   -> text "%vI_" <> pprUniqueAlways u+  RegVirtual (VirtualRegF u)   -> text "%vF_" <> pprUniqueAlways u+  RegVirtual (VirtualRegD u)   -> text "%vD_" <> pprUniqueAlways u+  _                            -> pprPanic "AArch64.pprReg" (text $ show r)++  where+    ppr_reg_no :: Width -> Int -> SDoc+    ppr_reg_no w 31+         | w == W64 = text "sp"+         | w == W32 = text "wsp"++    ppr_reg_no w i+         | i < 0, w == W32 = text "wzr"+         | i < 0, w == W64 = text "xzr"+         | i < 0 = pprPanic "Invalid Zero Reg" (ppr w <+> int i)+         -- General Purpose Registers+         | i <= 31, w == W8  = text "w" <> int i      -- there are no byte or half+         | i <= 31, w == W16 = text "w" <> int i      -- words... word will do.+         | i <= 31, w == W32 = text "w" <> int i+         | i <= 31, w == W64 = text "x" <> int i+         | i <= 31 = pprPanic "Invalid Reg" (ppr w <+> int i)+         -- Floating Point Registers+         | i <= 63, w == W8  = text "b" <> int (i-32)+         | i <= 63, w == W16 = text "h" <> int (i-32)+         | i <= 63, w == W32 = text "s" <> int (i-32)+         | i <= 63, w == W64 = text "d" <> int (i-32)+         -- no support for 'q'uad in GHC's NCG yet.+         | otherwise = text "very naughty powerpc register"++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ (RegReal (RealRegSingle i))) | i > 31 = True+isFloatOp (OpReg _ (RegVirtual (VirtualRegF _))) = True+isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True+isFloatOp _ = False++pprInstr :: Platform -> Instr -> SDoc+pprInstr platform instr = case instr of+  -- Meta Instructions ---------------------------------------------------------+  COMMENT s  -> asmComment s+  MULTILINE_COMMENT s -> asmMultilineComment s+  ANN d i -> pprInstr platform i <+> asmDoubleslashComment d+  LOCATION file line col _name+    -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col+  DELTA d    -> asmComment $ text ("\tdelta = " ++ show d)+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"+  LDATA _ _  -> panic "pprInstr: LDATA"++  -- Pseudo Instructions -------------------------------------------------------++  PUSH_STACK_FRAME -> text "\tstp x29, x30, [sp, #-16]!"+                   $$ text "\tmov x29, sp"++  POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16"+  -- ===========================================================================+  -- AArch64 Instruction Set+  -- 1. Arithmetic Instructions ------------------------------------------------+  ADD  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfadd"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+    | otherwise -> text "\tadd"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  CMN  o1 o2    -> text "\tcmn"  <+> pprOp platform o1 <> comma <+> pprOp platform o2+  CMP  o1 o2+    | isFloatOp o1 && isFloatOp o2 -> text "\tfcmp"  <+> pprOp platform o1 <> comma <+> pprOp platform o2+    | otherwise -> text "\tcmp" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  MSUB o1 o2 o3 o4 -> text "\tmsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+  MUL  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfmul"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+    | otherwise -> text "\tmul"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  NEG  o1 o2+    | isFloatOp o1 && isFloatOp o2 -> text "\tfneg"  <+> pprOp platform o1 <> comma <+> pprOp platform o2+    | otherwise -> text "\tneg"  <+> pprOp platform o1 <> comma <+> pprOp platform o2+  SDIV o1 o2 o3 | isFloatOp o1 && isFloatOp o2 && isFloatOp o3+    -> text "\tfdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  SDIV o1 o2 o3 -> text "\tsdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3++  SUB  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> text "\tfsub"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+    | otherwise -> text "\tsub"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  UDIV o1 o2 o3 -> text "\tudiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3++  -- 2. Bit Manipulation Instructions ------------------------------------------+  SBFM o1 o2 o3 o4 -> text "\tsbfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+  UBFM o1 o2 o3 o4 -> text "\tubfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+  -- 3. Logical and Move Instructions ------------------------------------------+  AND o1 o2 o3  -> text "\tand" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  ANDS o1 o2 o3 -> text "\tands" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  ASR o1 o2 o3  -> text "\tasr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  BIC o1 o2 o3  -> text "\tbic" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  BICS o1 o2 o3 -> text "\tbics" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  EON o1 o2 o3  -> text "\teon" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  EOR o1 o2 o3  -> text "\teor" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  LSL o1 o2 o3  -> text "\tlsl" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  LSR o1 o2 o3  -> text "\tlsr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  MOV o1 o2+    | isFloatOp o1 || isFloatOp o2 -> text "\tfmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2+    | otherwise -> text "\tmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  MOVK o1 o2    -> text "\tmovk" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  MVN o1 o2     -> text "\tmvn" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  ORN o1 o2 o3  -> text "\torn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  ORR o1 o2 o3  -> text "\torr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  ROR o1 o2 o3  -> text "\tror" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  TST o1 o2     -> text "\ttst" <+> pprOp platform o1 <> comma <+> pprOp platform o2++  -- 4. Branch Instructions ----------------------------------------------------+  J t            -> pprInstr platform (B t)+  B (TBlock bid) -> text "\tb" <+> pdoc platform (mkLocalBlockLabel (getUnique bid))+  B (TLabel lbl) -> text "\tb" <+> pdoc platform lbl+  B (TReg r)     -> text "\tbr" <+> pprReg W64 r++  BL (TBlock bid) _ _ -> text "\tbl" <+> pdoc platform (mkLocalBlockLabel (getUnique bid))+  BL (TLabel lbl) _ _ -> text "\tbl" <+> pdoc platform lbl+  BL (TReg r)     _ _ -> text "\tblr" <+> pprReg W64 r++  BCOND c (TBlock bid) -> text "\t" <> pprBcond c <+> pdoc platform (mkLocalBlockLabel (getUnique bid))+  BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pdoc platform lbl+  BCOND _ (TReg _)     -> panic "AArch64.ppr: No conditional branching to registers!"++  -- 5. Atomic Instructions ----------------------------------------------------+  -- 6. Conditional Instructions -----------------------------------------------+  CSET o c  -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c++  CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid))+  CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform lbl+  CBZ _ (TReg _)     -> panic "AArch64.ppr: No conditional (cbz) branching to registers!"++  CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid))+  CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform lbl+  CBNZ _ (TReg _)     -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!"++  -- 7. Load and Store Instructions --------------------------------------------+  -- NOTE: GHC may do whacky things where it only load the lower part of an+  --       address. Not observing the correct size when loading will lead+  --       inevitably to crashes.+  STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->+    text "\tstrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->+    text "\tstrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  STR _f o1 o2 -> text "\tstr" <+> pprOp platform o1 <> comma <+> pprOp platform o2++#if defined(darwin_HOST_OS)+  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.++  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.++  LDR _f o1 (OpImm (ImmIndex lbl off)) ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.++  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]"++  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]"++  LDR _f o1 (OpImm (ImmCLbl lbl)) ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff"+#else+  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.++  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.++  LDR _f o1 (OpImm (ImmIndex lbl off)) ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.++  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]"++  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$+    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]"++  LDR _f o1 (OpImm (ImmCLbl lbl)) ->+    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$+    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl+#endif++  LDR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->+    text "\tldrsb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->+    text "\tldrsh" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  LDR _f o1 o2 -> text "\tldr" <+> pprOp platform o1 <> comma <+> pprOp platform o2++  STP _f o1 o2 o3 -> text "\tstp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  LDP _f o1 o2 o3 -> text "\tldp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3++  -- 8. Synchronization Instructions -------------------------------------------+  DMBSY -> text "\tdmb sy"+  -- 9. Floating Point Instructions --------------------------------------------+  FCVT o1 o2 -> text "\tfcvt" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  SCVTF o1 o2 -> text "\tscvtf" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  FCVTZS o1 o2 -> text "\tfcvtzs" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  FABS o1 o2 -> text "\tfabs" <+> pprOp platform o1 <> comma <+> pprOp platform o2++pprBcond :: Cond -> SDoc+pprBcond c = text "b." <> pprCond c++pprCond :: Cond -> SDoc+pprCond c = case c of+  ALWAYS -> text "al" -- Always+  EQ     -> text "eq" -- Equal+  NE     -> text "ne" -- Not Equal++  SLT    -> text "lt" -- Signed less than                  ; Less than, or unordered+  SLE    -> text "le" -- Signed less than or equal         ; Less than or equal, or unordered+  SGE    -> text "ge" -- Signed greater than or equal      ; Greater than or equal+  SGT    -> text "gt" -- Signed greater than               ; Greater than++  ULT    -> text "lo" -- Carry clear/ unsigned lower       ; less than+  ULE    -> text "ls" -- Unsigned lower or same            ; Less than or equal+  UGE    -> text "hs" -- Carry set/unsigned higher or same ; Greater than or equal, or unordered+  UGT    -> text "hi" -- Unsigned higher                   ; Greater than, or unordered++  NEVER  -> text "nv" -- Never+  VS     -> text "vs" -- Overflow                          ; Unordered (at least one NaN operand)+  VC     -> text "vc" -- No overflow                       ; Not unordered++  -- Orderd variants.  Respecting NaN.+  OLT    -> text "mi"+  OLE    -> text "ls"+  OGE    -> text "ge"+  OGT    -> text "gt"++  -- Unordered+  UOLT   -> text "lt"+  UOLE   -> text "le"+  UOGE   -> text "pl"+  UOGT   -> text "hi"

+ GHC/CmmToAsm/AArch64/RegInfo.hs view

@@ -0,0 +1,31 @@+module GHC.CmmToAsm.AArch64.RegInfo where++import GHC.Prelude++import GHC.CmmToAsm.AArch64.Instr+import GHC.Cmm.BlockId+import GHC.Cmm++import GHC.Utils.Outputable++data JumpDest = DestBlockId BlockId++-- Debug Instance+instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid++-- TODO: documen what this does. See Ticket 19914+getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++-- TODO: document what this does. See Ticket 19914+canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++-- TODO: document what this does. See Ticket 19914+shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++-- TODO: document what this does. See Ticket 19914+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other

+ GHC/CmmToAsm/AArch64/Regs.hs view

@@ -0,0 +1,167 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module GHC.CmmToAsm.AArch64.Regs where++import GHC.Prelude++import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.CmmToAsm.Format++import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import GHC.Types.Unique++import GHC.Platform.Regs+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Platform++allMachRegNos   :: [RegNo]+allMachRegNos   = [0..31] ++ [32..63]+-- allocatableRegs is allMachRegNos with the fixed-use regs removed.+-- i.e., these are the regs for which we are prepared to allow the+-- register allocator to attempt to map VRegs to.+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform+   = let isFree i = freeReg platform i+     in  map RealRegSingle $ filter isFree allMachRegNos+++-- argRegs is the set of regs which are read for an n-argument call to C.+allGpArgRegs :: [Reg]+allGpArgRegs = map regSingle [0..7]+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [32..39]++-- STG:+-- 19: Base+-- 20: Sp+-- 21: Hp+-- 22-27: R1-R6+-- 28: SpLim++-- This is the STG Sp reg.+-- sp :: Reg+-- sp = regSingle 20++-- addressing modes ------------------------------------------------------------++data AddrMode+        = AddrRegReg    Reg Reg+        | AddrRegImm    Reg Imm+        | AddrReg       Reg+        deriving (Eq, Show)++-- -----------------------------------------------------------------------------+-- Immediates++data Imm+  = ImmInt      Int+  | ImmInteger  Integer     -- Sigh.+  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)+  | ImmLit      SDoc        -- Simple string+  | ImmIndex    CLabel Int+  | ImmFloat    Rational+  | ImmDouble   Rational+  | ImmConstantSum Imm Imm+  | ImmConstantDiff Imm Imm+  deriving (Eq, Show)++instance Show SDoc where+  show = showPprUnsafe . ppr++instance Eq SDoc where+  lhs == rhs = show lhs == show rhs++strImmLit :: String -> Imm+strImmLit s = ImmLit (text s)+++litToImm :: CmmLit -> Imm+litToImm (CmmInt i w)        = ImmInteger (narrowS w i)+                -- narrow to the width: a CmmInt might be out of+                -- range, but we assume that ImmInteger only contains+                -- in-range values.  A signed value should be fine here.+litToImm (CmmFloat f W32)    = ImmFloat f+litToImm (CmmFloat f W64)    = ImmDouble f+litToImm (CmmLabel l)        = ImmCLbl l+litToImm (CmmLabelOff l off) = ImmIndex l off+litToImm (CmmLabelDiffOff l1 l2 off _)+                             = ImmConstantSum+                               (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+                               (ImmInt off)+litToImm _                   = panic "AArch64.Regs.litToImm: no match"+++-- == To satisfy GHC.CmmToAsm.Reg.Target =======================================++-- squeese functions for the graph allocator -----------------------------------+-- | regSqueeze_class reg+--      Calculate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+--+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int+virtualRegSqueeze cls vr+ = case cls of+        RcInteger+         -> case vr of+                VirtualRegI{}           -> 1+                VirtualRegHi{}          -> 1+                _other                  -> 0++        RcDouble+         -> case vr of+                VirtualRegD{}           -> 1+                VirtualRegF{}           -> 0+                _other                  -> 0++        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr+ = case cls of+        RcInteger+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 1     -- first fp reg is 32+                        | otherwise     -> 0++                RealRegPair{}           -> 0++        RcDouble+         -> case rr of+                RealRegSingle regNo+                        | regNo < 32    -> 0+                        | otherwise     -> 1++                RealRegPair{}           -> 0++        _other -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+   | not (isFloatFormat format) = VirtualRegI u+   | otherwise+   = case format of+        FF32    -> VirtualRegD u+        FF64    -> VirtualRegD u+        _       -> panic "AArch64.mkVirtualReg"++{-# INLINE classOfRealReg      #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+        | i < 32        = RcInteger+        | otherwise     = RcDouble++classOfRealReg (RealRegPair{})+        = panic "regClass(ppr): no reg pairs on this architecture"++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloat         -> text "red"+        RcDouble        -> text "green"

GHC/CmmToAsm/BlockLayout.hs view

@@ -1,14 +1,14 @@------ Copyright (c) 2018 Andreas Klebinger---- {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-} +--+-- Copyright (c) 2018 Andreas Klebinger+--+ module GHC.CmmToAsm.BlockLayout     ( sequenceTop, backendMaintainsCfg) where@@ -16,9 +16,13 @@ #include "HsVersions.h" import GHC.Prelude +import GHC.Driver.Ppr     (pprTrace)+ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Monad import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Config  import GHC.Cmm.BlockId import GHC.Cmm@@ -26,12 +30,12 @@ import GHC.Cmm.Dataflow.Label  import GHC.Platform-import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform) import GHC.Types.Unique.FM import GHC.Utils.Misc  import GHC.Data.Graph.Directed import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Maybe  -- DEBUGGING ONLY@@ -472,7 +476,6 @@                  applyEdges edges newEnds newFronts (Set.insert (from,to) combined)             | otherwise             = applyEdges edges chainEnds chainFronts combined-         where          getFronts chain = takeL neighbourOverlapp chain         getEnds chain = takeR neighbourOverlapp chain@@ -526,7 +529,7 @@ -- An Edge is irrelevant if the ends are part of the same chain. -- We say these edges are already linked buildChains :: [CfgEdge] -> [BlockId]-            -> ( LabelMap BlockChain  -- Resulting chains, indexd by end if chain.+            -> ( LabelMap BlockChain  -- Resulting chains, indexed by end if chain.                , Set.Set (BlockId, BlockId)) --List of fused edges. buildChains edges blocks   = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty@@ -574,19 +577,14 @@         , Just predChain <- mapLookup from chainEnds         , Just succChain <- mapLookup to chainStarts         , predChain /= succChain -- Otherwise we try to create a cycle.-        = do-            -- pprTraceM "Fusing edge" (ppr edge)-            fuseChain predChain succChain+          = fuseChain predChain succChain          | (alreadyPlaced from) &&           (alreadyPlaced to)-        =   --pprTraceM "Skipping:" (ppr edge) >>-            buildNext placed chainStarts chainEnds todo linked+          = buildNext placed chainStarts chainEnds todo linked          | otherwise-        = do -- pprTraceM "Finding chain for:" (ppr edge $$-             --         text "placed" <+> ppr placed)-             findChain+          = findChain       where         from = edgeFrom edge         to   = edgeTo   edge@@ -655,7 +653,7 @@  -- | Place basic blocks based on the given CFG. -- See Note [Chain based CFG serialization]-sequenceChain :: forall a i. (Instruction i, Outputable i)+sequenceChain :: forall a i. Instruction i               => LabelMap a -- ^ Keys indicate an info table on the block.               -> CFG -- ^ Control flow graph and some meta data.               -> [GenBasicBlock i] -- ^ List of basic blocks to be placed.@@ -802,31 +800,33 @@ -- fallthroughs.  sequenceTop-    :: (Instruction instr, Outputable instr)-    => DynFlags -- Determine which layout algo to use-    -> NcgImpl statics instr jumpDest+    :: Instruction instr+    => NcgImpl statics instr jumpDest     -> Maybe CFG -- ^ CFG if we have one.     -> NatCmmDecl statics instr -- ^ Function to serialize     -> NatCmmDecl statics instr -sequenceTop _     _       _           top@(CmmData _ _) = top-sequenceTop dflags ncgImpl edgeWeights-            (CmmProc info lbl live (ListGraph blocks))-  | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)-  --Use chain based algorithm-  , Just cfg <- edgeWeights-  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $-                            {-# SCC layoutBlocks #-}-                            sequenceChain info cfg blocks )-  | otherwise-  --Use old algorithm-  = let cfg = if dontUseCfg then Nothing else edgeWeights-    in  CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $-                                {-# SCC layoutBlocks #-}-                                sequenceBlocks cfg info blocks)-  where-    dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||-                 (not $ backendMaintainsCfg (targetPlatform dflags))+sequenceTop _       _           top@(CmmData _ _) = top+sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks))+  = let+      config     = ncgConfig ncgImpl+      platform   = ncgPlatform config++    in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $+         if -- Chain based algorithm+            | ncgCfgBlockLayout config+            , backendMaintainsCfg platform+            , Just cfg <- edgeWeights+            -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks++            -- Old algorithm without edge weights+            | ncgCfgWeightlessLayout config+               || not (backendMaintainsCfg platform)+            -> {-# SCC layoutBlocks #-} sequenceBlocks Nothing info blocks++            -- Old algorithm with edge weights (if any)+            | otherwise+            -> {-# SCC layoutBlocks #-} sequenceBlocks edgeWeights info blocks  -- The old algorithm: -- It is very simple (and stupid): We make a graph out of

GHC/CmmToAsm/CFG.hs view

@@ -1,16 +1,15 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE TupleSections              #-} -- -- Copyright (c) 2018 Andreas Klebinger -- -{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts           #-}- module GHC.CmmToAsm.CFG     ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)     , TransitionSource(..)@@ -46,6 +45,7 @@ #include "HsVersions.h"  import GHC.Prelude+import GHC.Platform  import GHC.Cmm.BlockId import GHC.Cmm as Cmm@@ -63,6 +63,7 @@  import GHC.Types.Unique import qualified GHC.CmmToAsm.CFG.Dominators as Dom+import GHC.CmmToAsm.CFG.Weight import Data.IntMap.Strict (IntMap) import Data.IntSet (IntSet) @@ -74,12 +75,12 @@ import Data.Bifunctor  import GHC.Utils.Outputable+import GHC.Utils.Panic -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace import GHC.Cmm.Ppr () -- For Outputable instances-import qualified GHC.Driver.Session as D  import Data.List (sort, nub, partition) import Data.STRef.Strict@@ -353,12 +354,11 @@ --             \                  \ --              -> C    =>         -> C ---addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG-addImmediateSuccessor dflags node follower cfg-    = updateEdges . addWeightEdge node follower uncondWeight $ cfg+addImmediateSuccessor :: Weights -> BlockId -> BlockId -> CFG -> CFG+addImmediateSuccessor weights node follower cfg+    = updateEdges . addWeightEdge node follower weight $ cfg     where-        uncondWeight = fromIntegral . D.uncondWeight .-                       D.cfgWeightInfo $ dflags+        weight = fromIntegral (uncondWeight weights)         targets = getSuccessorEdges cfg node         successors = map fst targets :: [BlockId]         updateEdges = addNewSuccs . remOldSuccs@@ -529,13 +529,12 @@ -- these cases. -- We assign the old edge info to the edge A -> B and assign B -> C the -- weight of an unconditional jump.-addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG-addNodesBetween dflags m updates =+addNodesBetween :: Weights -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG+addNodesBetween weights m updates =   foldl'  updateWeight m .           weightUpdates $ updates     where-      weight = fromIntegral . D.uncondWeight .-                D.cfgWeightInfo $ dflags+      weight = fromIntegral (uncondWeight weights)       -- We might add two blocks for different jumps along a single       -- edge. So we end up with edges:   A -> B -> C   ,   A -> D -> C       -- in this case after applying the first update the weight for A -> C@@ -605,24 +604,24 @@  -} -- | Generate weights for a Cmm proc based on some simple heuristics.-getCfgProc :: D.CfgWeights -> 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 :: D.CfgWeights -> CmmGraph -> CFG-getCfg weights graph =+getCfg :: Platform -> Weights -> CmmGraph -> CFG+getCfg platform weights graph =   foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks   where-    D.CFGWeights-            { D.uncondWeight = uncondWeight-            , D.condBranchWeight = condBranchWeight-            , D.switchWeight = switchWeight-            , D.callWeight = callWeight-            , D.likelyCondWeight = likelyCondWeight-            , D.unlikelyCondWeight = unlikelyCondWeight+    Weights+            { uncondWeight = uncondWeight+            , condBranchWeight = condBranchWeight+            , switchWeight = switchWeight+            , callWeight = callWeight+            , likelyCondWeight = likelyCondWeight+            , unlikelyCondWeight = unlikelyCondWeight             --  Last two are used in other places-            --, D.infoTablePenalty = infoTablePenalty-            --, D.backEdgeBonus = backEdgeBonus+            --, infoTablePenalty = infoTablePenalty+            --, backEdgeBonus = backEdgeBonus             } = weights     -- Explicitly add all nodes to the cfg to ensure they are part of the     -- CFG.@@ -651,7 +650,7 @@             mkEdge target weight = ((bid,target), mkEdgeInfo weight)             branchInfo =               foldRegsUsed-                (panic "foldRegsDynFlags")+                (panic "GHC.CmmToAsm.CFG.getCfg: foldRegsUsed")                 (\info r -> if r == SpLim || r == HpLim || r == BaseReg                     then HeapStackCheck else info)                 NoInfo cond@@ -669,7 +668,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@@ -691,7 +690,7 @@     typedEdges =       classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)] -optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG+optimizeCFG :: Bool -> Weights -> RawCmmDecl -> CFG -> CFG optimizeCFG _ _ (CmmData {}) cfg = cfg optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =   (if doStaticPred then staticPredCfg (g_entry graph) else id) $@@ -702,7 +701,7 @@ -- performance. -- -- Most importantly we penalize jumps across info tables.-optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG+optHsPatterns :: Weights -> RawCmmDecl -> CFG -> CFG optHsPatterns _ (CmmData {}) cfg = cfg optHsPatterns weights (CmmProc info _lab _live graph) cfg =     {-# SCC optHsPatterns #-}@@ -724,7 +723,7 @@               --Keep irrelevant edges irrelevant               | weight <= 0 = 0               | otherwise-              = weight + fromIntegral (D.backEdgeBonus weights)+              = weight + fromIntegral (backEdgeBonus weights)         in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)                     cfg backedges @@ -736,7 +735,7 @@         fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight         fupdate _ to weight           | mapMember to info-          = weight - (fromIntegral $ D.infoTablePenalty weights)+          = weight - (fromIntegral $ infoTablePenalty weights)           | otherwise = weight      -- | If a block has two successors, favour the one with fewer

GHC/CmmToAsm/CFG/Dominators.hs view

@@ -1,597 +1,566 @@-{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}
-
-{- |
-  Module      :  Dominators
-  Copyright   :  (c) Matt Morrow 2009
-  License     :  BSD3
-  Maintainer  :  <morrow@moonpatio.com>
-  Stability   :  experimental
-  Portability :  portable
-
-  Taken from the dom-lt package.
-
-  The Lengauer-Tarjan graph dominators algorithm.
-
-    \[1\] Lengauer, Tarjan,
-      /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.
-
-    \[2\] Muchnick,
-      /Advanced Compiler Design and Implementation/, 1997.
-
-    \[3\] Brisk, Sarrafzadeh,
-      /Interference Graphs for Procedures in Static Single/
-      /Information Form are Interval Graphs/, 2007.
-
-  Originally taken from the dom-lt package.
--}
-
-module GHC.CmmToAsm.CFG.Dominators (
-   Node,Path,Edge
-  ,Graph,Rooted
-  ,idom,ipdom
-  ,domTree,pdomTree
-  ,dom,pdom
-  ,pddfs,rpddfs
-  ,fromAdj,fromEdges
-  ,toAdj,toEdges
-  ,asTree,asGraph
-  ,parents,ancestors
-) where
-
-import GHC.Prelude
-
-import Data.Bifunctor
-import Data.Tuple (swap)
-
-import Data.Tree
-import Data.IntMap(IntMap)
-import Data.IntSet(IntSet)
-import qualified Data.IntMap.Strict as IM
-import qualified Data.IntSet as IS
-
-import Control.Monad
-import Control.Monad.ST.Strict
-
-import Data.Array.ST
-import Data.Array.Base hiding ((!))
-  -- (unsafeNewArray_
-  -- ,unsafeWrite,unsafeRead
-  -- ,readArray,writeArray)
-
-import GHC.Utils.Misc (debugIsOn)
-
------------------------------------------------------------------------------
-
-type Node       = Int
-type Path       = [Node]
-type Edge       = (Node,Node)
-type Graph      = IntMap IntSet
-type Rooted     = (Node, Graph)
-
------------------------------------------------------------------------------
-
--- | /Dominators/.
--- Complexity as for @idom@
-dom :: Rooted -> [(Node, Path)]
-dom = ancestors . domTree
-
--- | /Post-dominators/.
--- Complexity as for @idom@.
-pdom :: Rooted -> [(Node, Path)]
-pdom = ancestors . pdomTree
-
--- | /Dominator tree/.
--- Complexity as for @idom@.
-domTree :: Rooted -> Tree Node
-domTree a@(r,_) =
-  let is = filter ((/=r).fst) (idom a)
-      tg = fromEdges (fmap swap is)
-  in asTree (r,tg)
-
--- | /Post-dominator tree/.
--- Complexity as for @idom@.
-pdomTree :: Rooted -> Tree Node
-pdomTree a@(r,_) =
-  let is = filter ((/=r).fst) (ipdom a)
-      tg = fromEdges (fmap swap is)
-  in asTree (r,tg)
-
--- | /Immediate dominators/.
--- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
--- \"a functional inverse of Ackermann's function\".
---
--- This Complexity bound assumes /O(1)/ indexing. Since we're
--- using @IntMap@, it has an additional /lg |V|/ factor
--- somewhere in there. I'm not sure where.
-idom :: Rooted -> [(Node,Node)]
-idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
-
--- | /Immediate post-dominators/.
--- Complexity as for @idom@.
-ipdom :: Rooted -> [(Node,Node)]
-ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
-
------------------------------------------------------------------------------
-
--- | /Post-dominated depth-first search/.
-pddfs :: Rooted -> [Node]
-pddfs = reverse . rpddfs
-
--- | /Reverse post-dominated depth-first search/.
-rpddfs :: Rooted -> [Node]
-rpddfs = concat . levels . pdomTree
-
------------------------------------------------------------------------------
-
-type Dom s a = S s (Env s) a
-type NodeSet    = IntSet
-type NodeMap a  = IntMap a
-data Env s = Env
-  {succE      :: !Graph
-  ,predE      :: !Graph
-  ,bucketE    :: !Graph
-  ,dfsE       :: {-# UNPACK #-}!Int
-  ,zeroE      :: {-# UNPACK #-}!Node
-  ,rootE      :: {-# UNPACK #-}!Node
-  ,labelE     :: {-# UNPACK #-}!(Arr s Node)
-  ,parentE    :: {-# UNPACK #-}!(Arr s Node)
-  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)
-  ,childE     :: {-# UNPACK #-}!(Arr s Node)
-  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)
-  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)
-  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)
-  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)
-  ,domE       :: {-# UNPACK #-}!(Arr s Node)
-  ,rnE        :: {-# UNPACK #-}!(Arr s Node)}
-
------------------------------------------------------------------------------
-
-idomM :: Dom s [(Node,Node)]
-idomM = do
-  dfsDom =<< rootM
-  n <- gets dfsE
-  forM_ [n,n-1..1] (\i-> do
-    w <- ndfsM i
-    sw <- sdnoM w
-    ps <- predsM w
-    forM_ ps (\v-> do
-      u <- eval v
-      su <- sdnoM u
-      when (su < sw)
-        (store sdnoE w su))
-    z <- ndfsM =<< sdnoM w
-    modify(\e->e{bucketE=IM.adjust
-                      (w`IS.insert`)
-                      z (bucketE e)})
-    pw <- parentM w
-    link pw w
-    bps <- bucketM pw
-    forM_ bps (\v-> do
-      u <- eval v
-      su <- sdnoM u
-      sv <- sdnoM v
-      let dv = case su < sv of
-                True-> u
-                False-> pw
-      store domE v dv))
-  forM_ [1..n] (\i-> do
-    w <- ndfsM i
-    j <- sdnoM w
-    z <- ndfsM j
-    dw <- domM w
-    when (dw /= z)
-      (do ddw <- domM dw
-          store domE w ddw))
-  fromEnv
-
------------------------------------------------------------------------------
-
-eval :: Node -> Dom s Node
-eval v = do
-  n0 <- zeroM
-  a  <- ancestorM v
-  case a==n0 of
-    True-> labelM v
-    False-> do
-      compress v
-      a   <- ancestorM v
-      l   <- labelM v
-      la  <- labelM a
-      sl  <- sdnoM l
-      sla <- sdnoM la
-      case sl <= sla of
-        True-> return l
-        False-> return la
-
-compress :: Node -> Dom s ()
-compress v = do
-  n0  <- zeroM
-  a   <- ancestorM v
-  aa  <- ancestorM a
-  when (aa /= n0) (do
-    compress a
-    a   <- ancestorM v
-    aa  <- ancestorM a
-    l   <- labelM v
-    la  <- labelM a
-    sl  <- sdnoM l
-    sla <- sdnoM la
-    when (sla < sl)
-      (store labelE v la)
-    store ancestorE v aa)
-
------------------------------------------------------------------------------
-
-link :: Node -> Node -> Dom s ()
-link v w = do
-  n0  <- zeroM
-  lw  <- labelM w
-  slw <- sdnoM lw
-  let balance s = do
-        c   <- childM s
-        lc  <- labelM c
-        slc <- sdnoM lc
-        case slw < slc of
-          False-> return s
-          True-> do
-            zs  <- sizeM s
-            zc  <- sizeM c
-            cc  <- childM c
-            zcc <- sizeM cc
-            case 2*zc <= zs+zcc of
-              True-> do
-                store ancestorE c s
-                store childE s cc
-                balance s
-              False-> do
-                store sizeE c zs
-                store ancestorE s c
-                balance c
-  s   <- balance w
-  lw  <- labelM w
-  zw  <- sizeM w
-  store labelE s lw
-  store sizeE v . (+zw) =<< sizeM v
-  let follow s = do
-        when (s /= n0) (do
-          store ancestorE s v
-          follow =<< childM s)
-  zv  <- sizeM v
-  follow =<< case zv < 2*zw of
-              False-> return s
-              True-> do
-                cv <- childM v
-                store childE v s
-                return cv
-
------------------------------------------------------------------------------
-
-dfsDom :: Node -> Dom s ()
-dfsDom i = do
-  _   <- go i
-  n0  <- zeroM
-  r   <- rootM
-  store parentE r n0
-  where go i = do
-          n <- nextM
-          store dfnE   i n
-          store sdnoE  i n
-          store ndfsE  n i
-          store labelE i i
-          ss <- succsM i
-          forM_ ss (\j-> do
-            s <- sdnoM j
-            case s==0 of
-              False-> return()
-              True-> do
-                store parentE j i
-                go j)
-
------------------------------------------------------------------------------
-
-initEnv :: Rooted -> ST s (Env s)
-initEnv (r0,g0) = do
-  let (g,rnmap) = renum 1 g0
-      pred      = predG g
-      r         = rnmap IM.! r0
-      n         = IM.size g
-      ns        = [0..n]
-      m         = n+1
-
-  let bucket = IM.fromList
-        (zip ns (repeat mempty))
-
-  rna <- newI m
-  writes rna (fmap swap
-        (IM.toList rnmap))
-
-  doms      <- newI m
-  sdno      <- newI m
-  size      <- newI m
-  parent    <- newI m
-  ancestor  <- newI m
-  child     <- newI m
-  label     <- newI m
-  ndfs      <- newI m
-  dfn       <- newI m
-
-  forM_ [0..n] (doms.=0)
-  forM_ [0..n] (sdno.=0)
-  forM_ [1..n] (size.=1)
-  forM_ [0..n] (ancestor.=0)
-  forM_ [0..n] (child.=0)
-
-  (doms.=r) r
-  (size.=0) 0
-  (label.=0) 0
-
-  return (Env
-    {rnE        = rna
-    ,dfsE       = 0
-    ,zeroE      = 0
-    ,rootE      = r
-    ,labelE     = label
-    ,parentE    = parent
-    ,ancestorE  = ancestor
-    ,childE     = child
-    ,ndfsE      = ndfs
-    ,dfnE       = dfn
-    ,sdnoE      = sdno
-    ,sizeE      = size
-    ,succE      = g
-    ,predE      = pred
-    ,bucketE    = bucket
-    ,domE       = doms})
-
-fromEnv :: Dom s [(Node,Node)]
-fromEnv = do
-  dom   <- gets domE
-  rn    <- gets rnE
-  -- r     <- gets rootE
-  (_,n) <- st (getBounds dom)
-  forM [1..n] (\i-> do
-    j <- st(rn!:i)
-    d <- st(dom!:i)
-    k <- st(rn!:d)
-    return (j,k))
-
------------------------------------------------------------------------------
-
-zeroM :: Dom s Node
-zeroM = gets zeroE
-domM :: Node -> Dom s Node
-domM = fetch domE
-rootM :: Dom s Node
-rootM = gets rootE
-succsM :: Node -> Dom s [Node]
-succsM i = gets (IS.toList . (! i) . succE)
-predsM :: Node -> Dom s [Node]
-predsM i = gets (IS.toList . (! i) . predE)
-bucketM :: Node -> Dom s [Node]
-bucketM i = gets (IS.toList . (! i) . bucketE)
-sizeM :: Node -> Dom s Int
-sizeM = fetch sizeE
-sdnoM :: Node -> Dom s Int
-sdnoM = fetch sdnoE
--- dfnM :: Node -> Dom s Int
--- dfnM = fetch dfnE
-ndfsM :: Int -> Dom s Node
-ndfsM = fetch ndfsE
-childM :: Node -> Dom s Node
-childM = fetch childE
-ancestorM :: Node -> Dom s Node
-ancestorM = fetch ancestorE
-parentM :: Node -> Dom s Node
-parentM = fetch parentE
-labelM :: Node -> Dom s Node
-labelM = fetch labelE
-nextM :: Dom s Int
-nextM = do
-  n <- gets dfsE
-  let n' = n+1
-  modify(\e->e{dfsE=n'})
-  return n'
-
------------------------------------------------------------------------------
-
-type A = STUArray
-type Arr s a = A s Int a
-
-infixl 9 !:
-infixr 2 .=
-
-(.=) :: (MArray (A s) a (ST s))
-     => Arr s a -> a -> Int -> ST s ()
-(v .= x) i
-  | debugIsOn = writeArray v i x
-  | otherwise = unsafeWrite v i x
-
-(!:) :: (MArray (A s) a (ST s))
-     => A s Int a -> Int -> ST s a
-a !: i
-  | debugIsOn = do
-      o <- readArray a i
-      return $! o
-  | otherwise = do
-      o <- unsafeRead a i
-      return $! o
-
-new :: (MArray (A s) a (ST s))
-    => Int -> ST s (Arr s a)
-new n = unsafeNewArray_ (0,n-1)
-
-newI :: Int -> ST s (Arr s Int)
-newI = new
-
--- newD :: Int -> ST s (Arr s Double)
--- newD = new
-
--- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]
--- dump a = do
---   (m,n) <- getBounds a
---   forM [m..n] (\i -> a!:i)
-
-writes :: (MArray (A s) a (ST s))
-     => Arr s a -> [(Int,a)] -> ST s ()
-writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
-
--- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)
--- arr xs = do
---   let n = length xs
---   a <- new n
---   go a n 0 xs
---   return a
---   where go _ _ _    [] = return ()
---         go a n i (x:xs)
---           | i <= n = (a.=x) i >> go a n (i+1) xs
---           | otherwise = return ()
-
------------------------------------------------------------------------------
-
-(!) :: Monoid a => IntMap a -> Int -> a
-(!) g n = maybe mempty id (IM.lookup n g)
-
-fromAdj :: [(Node, [Node])] -> Graph
-fromAdj = IM.fromList . fmap (second IS.fromList)
-
-fromEdges :: [Edge] -> Graph
-fromEdges = collectI IS.union fst (IS.singleton . snd)
-
-toAdj :: Graph -> [(Node, [Node])]
-toAdj = fmap (second IS.toList) . IM.toList
-
-toEdges :: Graph -> [Edge]
-toEdges = concatMap (uncurry (fmap . (,))) . toAdj
-
-predG :: Graph -> Graph
-predG g = IM.unionWith IS.union (go g) g0
-  where g0 = fmap (const mempty) g
-        f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
-        f m i a = foldl' (\m p -> IM.insertWith mappend p
-                                      (IS.singleton i) m)
-                        m
-                       (IS.toList a)
-        go :: IntMap IntSet -> IntMap IntSet
-        go = flip IM.foldlWithKey' mempty f
-
-pruneReach :: Rooted -> Rooted
-pruneReach (r,g) = (r,g2)
-  where is = reachable
-              (maybe mempty id
-                . flip IM.lookup g) $ r
-        g2 = IM.fromList
-            . fmap (second (IS.filter (`IS.member`is)))
-            . filter ((`IS.member`is) . fst)
-            . IM.toList $ g
-
-tip :: Tree a -> (a, [Tree a])
-tip (Node a ts) = (a, ts)
-
-parents :: Tree a -> [(a, a)]
-parents (Node i xs) = p i xs
-        ++ concatMap parents xs
-  where p i = fmap (flip (,) i . rootLabel)
-
-ancestors :: Tree a -> [(a, [a])]
-ancestors = go []
-  where go acc (Node i xs)
-          = let acc' = i:acc
-            in p acc' xs ++ concatMap (go acc') xs
-        p is = fmap (flip (,) is . rootLabel)
-
-asGraph :: Tree Node -> Rooted
-asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
-  where go (Node a ts) = let as = (fst . unzip . fmap tip) ts
-                          in (a, as) : concatMap go ts
-
-asTree :: Rooted -> Tree Node
-asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))
-                   f = (g !)
-            in go r
-
-reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
-reachable f a = go (IS.singleton a) a
-  where go seen a = let s = f a
-                        as = IS.toList (s `IS.difference` seen)
-                    in foldl' go (s `IS.union` seen) as
-
-collectI :: (c -> c -> c)
-        -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
-collectI (<>) f g
-  = foldl' (\m a -> IM.insertWith (<>)
-                                  (f a)
-                                  (g a) m) mempty
-
--- collect :: (Ord b) => (c -> c -> c)
---         -> (a -> b) -> (a -> c) -> [a] -> Map b c
--- collect (<>) f g
---   = foldl' (\m a -> SM.insertWith (<>)
---                                   (f a)
---                                   (g a) m) mempty
-
--- (renamed, old -> new)
-renum :: Int -> Graph -> (Graph, NodeMap Node)
-renum from = (\(_,m,g)->(g,m))
-  . IM.foldlWithKey'
-      f (from,mempty,mempty)
-  where
-    f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet
-      -> (Int, NodeMap Node, IntMap IntSet)
-    f (!n,!env,!new) i ss =
-            let (j,n2,env2) = go n env i
-                (n3,env3,ss2) = IS.fold
-                  (\k (!n,!env,!new)->
-                      case go n env k of
-                        (l,n2,env2)-> (n2,env2,l `IS.insert` new))
-                  (n2,env2,mempty) ss
-                new2 = IM.insertWith IS.union j ss2 new
-            in (n3,env3,new2)
-    go :: Int
-        -> NodeMap Node
-        -> Node
-        -> (Node,Int,NodeMap Node)
-    go !n !env i =
-        case IM.lookup i env of
-        Just j -> (j,n,env)
-        Nothing -> (n,n+1,IM.insert i n env)
-
------------------------------------------------------------------------------
-
-newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
-instance Functor (S z s) where
-  fmap f (S g) = S (\k -> g (k . f))
-instance Monad (S z s) where
-  return = pure
-  S g >>= f = S (\k -> g (\a -> unS (f a) k))
-instance Applicative (S z s) where
-  pure a = S (\k -> k a)
-  (<*>) = ap
--- get :: S z s s
--- get = S (\k s -> k s s)
-gets :: (s -> a) -> S z s a
-gets f = S (\k s -> k (f s) s)
--- set :: s -> S z s ()
--- set s = S (\k _ -> k () s)
-modify :: (s -> s) -> S z s ()
-modify f = S (\k -> k () . f)
--- runS :: S z s a -> s -> ST z (a, s)
--- runS (S g) = g (\a s -> return (a,s))
-evalS :: S z s a -> s -> ST z a
-evalS (S g) = g ((return .) . const)
--- execS :: S z s a -> s -> ST z s
--- execS (S g) = g ((return .) . flip const)
-st :: ST z a -> S z s a
-st m = S (\k s-> do
-  a <- m
-  k a s)
-store :: (MArray (A z) a (ST z))
-      => (s -> Arr z a) -> Int -> a -> S z s ()
-store f i x = do
-  a <- gets f
-  st ((a.=x) i)
-fetch :: (MArray (A z) a (ST z))
-      => (s -> Arr z a) -> Int -> S z s a
-fetch f i = do
-  a <- gets f
-  st (a!:i)
-
+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Strict #-}++{- |+  Module      :  GHC.CmmToAsm.CFG.Dominators+  Copyright   :  (c) Matt Morrow 2009+  License     :  BSD3+  Maintainer  :  <klebinger.andreas@gmx.at>+  Stability   :  stable+  Portability :  portable++  The Lengauer-Tarjan graph dominators algorithm.++    \[1\] Lengauer, Tarjan,+      /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.++    \[2\] Muchnick,+      /Advanced Compiler Design and Implementation/, 1997.++    \[3\] Brisk, Sarrafzadeh,+      /Interference Graphs for Procedures in Static Single/+      /Information Form are Interval Graphs/, 2007.++ * Strictness++ Unless stated otherwise all exposed functions might fully evaluate their input+ but are not guaranteed to do so.++-}++module GHC.CmmToAsm.CFG.Dominators (+   Node,Path,Edge+  ,Graph,Rooted+  ,idom,ipdom+  ,domTree,pdomTree+  ,dom,pdom+  ,pddfs,rpddfs+  ,fromAdj,fromEdges+  ,toAdj,toEdges+  ,asTree,asGraph+  ,parents,ancestors+) where++import GHC.Prelude+import Data.Bifunctor+import Data.Tuple (swap)++import Data.Tree+import Data.IntMap(IntMap)+import Data.IntSet(IntSet)+import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS++import Control.Monad+import Control.Monad.ST.Strict++import Data.Array.ST+import Data.Array.Base+  (unsafeNewArray_+  ,unsafeWrite,unsafeRead)++-----------------------------------------------------------------------------++type Node       = Int+type Path       = [Node]+type Edge       = (Node,Node)+type Graph      = IntMap IntSet+type Rooted     = (Node, Graph)++-----------------------------------------------------------------------------++-- | /Dominators/.+-- Complexity as for @idom@+dom :: Rooted -> [(Node, Path)]+dom = ancestors . domTree++-- | /Post-dominators/.+-- Complexity as for @idom@.+pdom :: Rooted -> [(Node, Path)]+pdom = ancestors . pdomTree++-- | /Dominator tree/.+-- Complexity as for @idom@.+domTree :: Rooted -> Tree Node+domTree a@(r,_) =+  let is = filter ((/=r).fst) (idom a)+      tg = fromEdges (fmap swap is)+  in asTree (r,tg)++-- | /Post-dominator tree/.+-- Complexity as for @idom@.+pdomTree :: Rooted -> Tree Node+pdomTree a@(r,_) =+  let is = filter ((/=r).fst) (ipdom a)+      tg = fromEdges (fmap swap is)+  in asTree (r,tg)++-- | /Immediate dominators/.+-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is+-- \"a functional inverse of Ackermann's function\".+--+-- This Complexity bound assumes /O(1)/ indexing. Since we're+-- using @IntMap@, it has an additional /lg |V|/ factor+-- somewhere in there. I'm not sure where.+idom :: Rooted -> [(Node,Node)]+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))++-- | /Immediate post-dominators/.+-- Complexity as for @idom@.+ipdom :: Rooted -> [(Node,Node)]+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))++-----------------------------------------------------------------------------++-- | /Post-dominated depth-first search/.+pddfs :: Rooted -> [Node]+pddfs = reverse . rpddfs++-- | /Reverse post-dominated depth-first search/.+rpddfs :: Rooted -> [Node]+rpddfs = concat . levels . pdomTree++-----------------------------------------------------------------------------++type Dom s a = S s (Env s) a+type NodeSet    = IntSet+type NodeMap a  = IntMap a+data Env s = Env+  {succE      :: !Graph+  ,predE      :: !Graph+  ,bucketE    :: !Graph+  ,dfsE       :: {-# UNPACK #-}!Int+  ,zeroE      :: {-# UNPACK #-}!Node+  ,rootE      :: {-# UNPACK #-}!Node+  ,labelE     :: {-# UNPACK #-}!(Arr s Node)+  ,parentE    :: {-# UNPACK #-}!(Arr s Node)+  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)+  ,childE     :: {-# UNPACK #-}!(Arr s Node)+  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)+  ,dfnE       :: {-# UNPACK #-}!(Arr s Int)+  ,sdnoE      :: {-# UNPACK #-}!(Arr s Int)+  ,sizeE      :: {-# UNPACK #-}!(Arr s Int)+  ,domE       :: {-# UNPACK #-}!(Arr s Node)+  ,rnE        :: {-# UNPACK #-}!(Arr s Node)}++-----------------------------------------------------------------------------++idomM :: Dom s [(Node,Node)]+idomM = do+  dfsDom =<< rootM+  n <- gets dfsE+  forM_ [n,n-1..1] (\i-> do+    w <- ndfsM i+    ps <- predsM w+    forM_ ps (\v-> do+      sw <- sdnoM w+      u <- eval v+      su <- sdnoM u+      when (su < sw)+        (store sdnoE w su))+    z <- ndfsM =<< sdnoM w+    modify(\e->e{bucketE=IM.adjust+                      (w`IS.insert`)+                      z (bucketE e)})+    pw <- parentM w+    link pw w+    bps <- bucketM pw+    forM_ bps (\v-> do+      u <- eval v+      su <- sdnoM u+      sv <- sdnoM v+      let dv = case su < sv of+                True-> u+                False-> pw+      store domE v dv))+  forM_ [1..n] (\i-> do+    w <- ndfsM i+    j <- sdnoM w+    z <- ndfsM j+    dw <- domM w+    when (dw /= z)+      (do ddw <- domM dw+          store domE w ddw))+  fromEnv++-----------------------------------------------------------------------------++eval :: Node -> Dom s Node+eval v = do+  n0 <- zeroM+  a  <- ancestorM v+  case a==n0 of+    True-> labelM v+    False-> do+      compress v+      a   <- ancestorM v+      l   <- labelM v+      la  <- labelM a+      sl  <- sdnoM l+      sla <- sdnoM la+      case sl <= sla of+        True-> return l+        False-> return la++compress :: Node -> Dom s ()+compress v = do+  n0  <- zeroM+  a   <- ancestorM v+  aa  <- ancestorM a+  when (aa /= n0) (do+    compress a+    a   <- ancestorM v+    aa  <- ancestorM a+    l   <- labelM v+    la  <- labelM a+    sl  <- sdnoM l+    sla <- sdnoM la+    when (sla < sl)+      (store labelE v la)+    store ancestorE v aa)++-----------------------------------------------------------------------------++link :: Node -> Node -> Dom s ()+link v w = do+  n0  <- zeroM+  lw  <- labelM w+  slw <- sdnoM lw+  let balance s = do+        c   <- childM s+        lc  <- labelM c+        slc <- sdnoM lc+        case slw < slc of+          False-> return s+          True-> do+            zs  <- sizeM s+            zc  <- sizeM c+            cc  <- childM c+            zcc <- sizeM cc+            case 2*zc <= zs+zcc of+              True-> do+                store ancestorE c s+                store childE s cc+                balance s+              False-> do+                store sizeE c zs+                store ancestorE s c+                balance c+  s   <- balance w+  lw  <- labelM w+  zw  <- sizeM w+  store labelE s lw+  store sizeE v . (+zw) =<< sizeM v+  let follow s =+        when (s /= n0) (do+          store ancestorE s v+          follow =<< childM s)+  zv  <- sizeM v+  follow =<< case zv < 2*zw of+              False-> return s+              True-> do+                cv <- childM v+                store childE v s+                return cv++-----------------------------------------------------------------------------++dfsDom :: Node -> Dom s ()+dfsDom i = do+  _   <- go i+  n0  <- zeroM+  r   <- rootM+  store parentE r n0+  where go i = do+          n <- nextM+          store dfnE   i n+          store sdnoE  i n+          store ndfsE  n i+          store labelE i i+          ss <- succsM i+          forM_ ss (\j-> do+            s <- sdnoM j+            case s==0 of+              False-> return()+              True-> do+                store parentE j i+                go j)++-----------------------------------------------------------------------------++initEnv :: Rooted -> ST s (Env s)+initEnv (r0,g0) = do+  -- Graph renumbered to indices from 1 to |V|+  let (g,rnmap) = renum 1 g0+      pred      = predG g -- reverse graph+      root      = rnmap IM.! r0 -- renamed root+      n         = IM.size g+      ns        = [0..n]+      m         = n+1++  let bucket = IM.fromList+        (zip ns (repeat mempty))++  rna <- newI m+  writes rna (fmap swap+        (IM.toList rnmap))++  doms      <- newI m+  sdno      <- newI m+  size      <- newI m+  parent    <- newI m+  ancestor  <- newI m+  child     <- newI m+  label     <- newI m+  ndfs      <- newI m+  dfn       <- newI m++  -- Initialize all arrays+  forM_ [0..n] (doms.=0)+  forM_ [0..n] (sdno.=0)+  forM_ [1..n] (size.=1)+  forM_ [0..n] (ancestor.=0)+  forM_ [0..n] (child.=0)++  (doms.=root) root+  (size.=0) 0+  (label.=0) 0++  return (Env+    {rnE        = rna+    ,dfsE       = 0+    ,zeroE      = 0+    ,rootE      = root+    ,labelE     = label+    ,parentE    = parent+    ,ancestorE  = ancestor+    ,childE     = child+    ,ndfsE      = ndfs+    ,dfnE       = dfn+    ,sdnoE      = sdno+    ,sizeE      = size+    ,succE      = g+    ,predE      = pred+    ,bucketE    = bucket+    ,domE       = doms})++fromEnv :: Dom s [(Node,Node)]+fromEnv = do+  dom   <- gets domE+  rn    <- gets rnE+  -- r     <- gets rootE+  (_,n) <- st (getBounds dom)+  forM [1..n] (\i-> do+    j <- st(rn!:i)+    d <- st(dom!:i)+    k <- st(rn!:d)+    return (j,k))++-----------------------------------------------------------------------------++zeroM :: Dom s Node+zeroM = gets zeroE+domM :: Node -> Dom s Node+domM = fetch domE+rootM :: Dom s Node+rootM = gets rootE+succsM :: Node -> Dom s [Node]+succsM i = gets (IS.toList . (! i) . succE)+predsM :: Node -> Dom s [Node]+predsM i = gets (IS.toList . (! i) . predE)+bucketM :: Node -> Dom s [Node]+bucketM i = gets (IS.toList . (! i) . bucketE)+sizeM :: Node -> Dom s Int+sizeM = fetch sizeE+sdnoM :: Node -> Dom s Int+sdnoM = fetch sdnoE+-- dfnM :: Node -> Dom s Int+-- dfnM = fetch dfnE+ndfsM :: Int -> Dom s Node+ndfsM = fetch ndfsE+childM :: Node -> Dom s Node+childM = fetch childE+ancestorM :: Node -> Dom s Node+ancestorM = fetch ancestorE+parentM :: Node -> Dom s Node+parentM = fetch parentE+labelM :: Node -> Dom s Node+labelM = fetch labelE+nextM :: Dom s Int+nextM = do+  n <- gets dfsE+  let n' = n+1+  modify(\e->e{dfsE=n'})+  return n'++-----------------------------------------------------------------------------++type A = STUArray+type Arr s a = A s Int a++infixl 9 !:+infixr 2 .=++-- | arr .= x idx => write x to index+(.=) :: (MArray (A s) a (ST s))+     => Arr s a -> a -> Int -> ST s ()+(v .= x) i = unsafeWrite v i x++(!:) :: (MArray (A s) a (ST s))+     => A s Int a -> Int -> ST s a+a !: i = do+  o <- unsafeRead a i+  return $! o++new :: (MArray (A s) a (ST s))+    => Int -> ST s (Arr s a)+new n = unsafeNewArray_ (0,n-1)++newI :: Int -> ST s (Arr s Int)+newI = new++writes :: (MArray (A s) a (ST s))+     => Arr s a -> [(Int,a)] -> ST s ()+writes a xs = forM_ xs (\(i,x) -> (a.=x) i)+++(!) :: Monoid a => IntMap a -> Int -> a+(!) g n = maybe mempty id (IM.lookup n g)++fromAdj :: [(Node, [Node])] -> Graph+fromAdj = IM.fromList . fmap (second IS.fromList)++fromEdges :: [Edge] -> Graph+fromEdges = collectI IS.union fst (IS.singleton . snd)++toAdj :: Graph -> [(Node, [Node])]+toAdj = fmap (second IS.toList) . IM.toList++toEdges :: Graph -> [Edge]+toEdges = concatMap (uncurry (fmap . (,))) . toAdj++predG :: Graph -> Graph+predG g = IM.unionWith IS.union (go g) g0+  where g0 = fmap (const mempty) g+        go = flip IM.foldrWithKey mempty (\i a m ->+                foldl' (\m p -> IM.insertWith mappend p+                                      (IS.singleton i) m)+                        m+                       (IS.toList a))++pruneReach :: Rooted -> Rooted+pruneReach (r,g) = (r,g2)+  where is = reachable+              (maybe mempty id+                . flip IM.lookup g) $ r+        g2 = IM.fromList+            . fmap (second (IS.filter (`IS.member`is)))+            . filter ((`IS.member`is) . fst)+            . IM.toList $ g++tip :: Tree a -> (a, [Tree a])+tip (Node a ts) = (a, ts)++parents :: Tree a -> [(a, a)]+parents (Node i xs) = p i xs+        ++ concatMap parents xs+  where p i = fmap (flip (,) i . rootLabel)++ancestors :: Tree a -> [(a, [a])]+ancestors = go []+  where go acc (Node i xs)+          = let acc' = i:acc+            in p acc' xs ++ concatMap (go acc') xs+        p is = fmap (flip (,) is . rootLabel)++asGraph :: Tree Node -> Rooted+asGraph t@(Node a _) = let g = go t in (a, fromAdj g)+  where go (Node a ts) = let as = (fst . unzip . fmap tip) ts+                          in (a, as) : concatMap go ts++asTree :: Rooted -> Tree Node+asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))+                   f = (g !)+            in go r++reachable :: (Node -> NodeSet) -> (Node -> NodeSet)+reachable f a = go (IS.singleton a) a+  where go seen a = let s = f a+                        as = IS.toList (s `IS.difference` seen)+                    in foldl' go (s `IS.union` seen) as++collectI :: (c -> c -> c)+        -> (a -> Int) -> (a -> c) -> [a] -> IntMap c+collectI (<>) f g+  = foldl' (\m a -> IM.insertWith (<>)+                                  (f a)+                                  (g a) m) mempty++-- | renum n g: Rename all nodes+--+-- Gives nodes sequential names starting at n.+-- Returns the new graph and a mapping.+-- (renamed, old -> new)+renum :: Int -> Graph -> (Graph, NodeMap Node)+renum from = (\(_,m,g)->(g,m))+  . IM.foldrWithKey+      (\i ss (!n,!env,!new)->+          let (j,n2,env2) = go n env i+              (n3,env3,ss2) = IS.fold+                (\k (!n,!env,!new)->+                    case go n env k of+                      (l,n2,env2)-> (n2,env2,l `IS.insert` new))+                (n2,env2,mempty) ss+              new2 = IM.insertWith IS.union j ss2 new+          in (n3,env3,new2)) (from,mempty,mempty)+  where go :: Int+           -> NodeMap Node+           -> Node+           -> (Node,Int,NodeMap Node)+        go !n !env i =+          case IM.lookup i env of+            Just j -> (j,n,env)+            Nothing -> (n,n+1,IM.insert i n env)++-----------------------------------------------------------------------------++-- Nothing better than reinvinting the state monad.+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}+instance Functor (S z s) where+  fmap f (S g) = S (\k -> g (k . f))+instance Monad (S z s) where+  return = pure+  S g >>= f = S (\k -> g (\a -> unS (f a) k))+instance Applicative (S z s) where+  pure a = S (\k -> k a)+  (<*>) = ap+-- get :: S z s s+-- get = S (\k s -> k s s)+gets :: (s -> a) -> S z s a+gets f = S (\k s -> k (f s) s)+-- set :: s -> S z s ()+-- set s = S (\k _ -> k () s)+modify :: (s -> s) -> S z s ()+modify f = S (\k -> k () . f)+-- runS :: S z s a -> s -> ST z (a, s)+-- runS (S g) = g (\a s -> return (a,s))+evalS :: S z s a -> s -> ST z a+evalS (S g) = g ((return .) . const)+-- execS :: S z s a -> s -> ST z s+-- execS (S g) = g ((return .) . flip const)+st :: ST z a -> S z s a+st m = S (\k s-> do+  a <- m+  k a s)+store :: (MArray (A z) a (ST z))+      => (s -> Arr z a) -> Int -> a -> S z s ()+store f i x = do+  a <- gets f+  st ((a.=x) i)+fetch :: (MArray (A z) a (ST z))+      => (s -> Arr z a) -> Int -> S z s a+fetch f i = do+  a <- gets f+  st (a!:i)

+ GHC/CmmToAsm/CFG/Weight.hs view

@@ -0,0 +1,78 @@+module GHC.CmmToAsm.CFG.Weight+   ( Weights (..)+   , defaultWeights+   , parseWeights+   )+where++import GHC.Prelude+import GHC.Utils.Panic++-- | Edge weights to use when generating a CFG from CMM+data Weights = Weights+   { uncondWeight       :: Int+   , condBranchWeight   :: Int+   , switchWeight       :: Int+   , callWeight         :: Int+   , likelyCondWeight   :: Int+   , unlikelyCondWeight :: Int+   , infoTablePenalty   :: Int+   , backEdgeBonus      :: Int+   }++-- | Default edge weights+defaultWeights :: Weights+defaultWeights = Weights+   { uncondWeight       = 1000+   , condBranchWeight   = 800+   , switchWeight       = 1+   , callWeight         = -10+   , likelyCondWeight   = 900+   , unlikelyCondWeight = 300+   , infoTablePenalty   = 300+   , backEdgeBonus      = 400+   }++parseWeights :: String -> Weights -> Weights+parseWeights s oldWeights =+        foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments+    where+        assignments = map assignment $ settings s+        update "uncondWeight" n w =+            w {uncondWeight = n}+        update "condBranchWeight" n w =+            w {condBranchWeight = n}+        update "switchWeight" n w =+            w {switchWeight = n}+        update "callWeight" n w =+            w {callWeight = n}+        update "likelyCondWeight" n w =+            w {likelyCondWeight = n}+        update "unlikelyCondWeight" n w =+            w {unlikelyCondWeight = n}+        update "infoTablePenalty" n w =+            w {infoTablePenalty = n}+        update "backEdgeBonus" n w =+            w {backEdgeBonus = n}+        update other _ _+            = panic $ other +++                      " is not a CFG weight parameter. " +++                      exampleString+        settings s+            | (s1,rest) <- break (== ',') s+            , null rest+            = [s1]+            | (s1,rest) <- break (== ',') s+            = s1 : settings (drop 1 rest)++        assignment as+            | (name, _:val) <- break (== '=') as+            = (name,read val)+            | otherwise+            = panic $ "Invalid CFG weight parameters." ++ exampleString++        exampleString = "Example parameters: uncondWeight=1000," +++            "condBranchWeight=800,switchWeight=0,callWeight=300" +++            ",likelyCondWeight=900,unlikelyCondWeight=300" +++            ",infoTablePenalty=300,backEdgeBonus=400"+

GHC/CmmToAsm/CPrim.hs view

@@ -20,6 +20,7 @@ import GHC.Cmm.Type import GHC.Cmm.MachOp import GHC.Utils.Outputable+import GHC.Utils.Panic  popCntLabel :: Width -> String popCntLabel w = "hs_popcnt" ++ pprWidth w

GHC/CmmToAsm/Config.hs view

@@ -2,6 +2,7 @@ module GHC.CmmToAsm.Config    ( NCGConfig(..)    , ncgWordWidth+   , ncgSpillPreallocSize    , platformWordWidth    ) where@@ -9,18 +10,21 @@ import GHC.Prelude import GHC.Platform import GHC.Cmm.Type (Width(..))+import GHC.CmmToAsm.CFG.Weight+import GHC.Unit.Module (Module)+import GHC.Utils.Outputable  -- | Native code generator configuration data NCGConfig = NCGConfig    { ncgPlatform              :: !Platform        -- ^ Target platform+   , ncgAsmContext            :: !SDocContext     -- ^ Context for ASM code generation+   , ncgThisModule            :: !Module          -- ^ The name of the module we are currently compiling    , ncgProcAlignment         :: !(Maybe Int)     -- ^ Mandatory proc alignment-   , ncgDebugLevel            :: !Int             -- ^ Debug level    , ncgExternalDynamicRefs   :: !Bool            -- ^ Generate code to link against dynamic libraries    , ncgPIC                   :: !Bool            -- ^ Enable Position-Independent Code    , ncgInlineThresholdMemcpy :: !Word            -- ^ If inlining `memcpy` produces less than this threshold (in pseudo-instruction unit), do it    , ncgInlineThresholdMemset :: !Word            -- ^ Ditto for `memset`    , ncgSplitSections         :: !Bool            -- ^ Split sections-   , ncgSpillPreallocSize     :: !Int             -- ^ Size in bytes of the pre-allocated spill space on the C stack    , ncgRegsIterative         :: !Bool    , ncgAsmLinting            :: !Bool            -- ^ Perform ASM linting pass    , ncgDoConstantFolding     :: !Bool            -- ^ Perform CMM constant folding@@ -29,11 +33,23 @@    , ncgDumpRegAllocStages    :: !Bool    , ncgDumpAsmStats          :: !Bool    , ncgDumpAsmConflicts      :: !Bool+   , ncgCfgWeights            :: !Weights         -- ^ CFG edge weights+   , ncgCfgBlockLayout        :: !Bool            -- ^ Use CFG based block layout algorithm+   , ncgCfgWeightlessLayout   :: !Bool            -- ^ Layout based on last instruction per block.+   , ncgDwarfEnabled          :: !Bool            -- ^ Enable Dwarf generation+   , ncgDwarfUnwindings       :: !Bool            -- ^ Enable unwindings+   , ncgDwarfStripBlockInfo   :: !Bool            -- ^ Strip out block information from generated Dwarf+   , ncgExposeInternalSymbols :: !Bool            -- ^ Expose symbol table entries for internal symbols+   , ncgDwarfSourceNotes      :: !Bool            -- ^ Enable GHC-specific source note DIEs    }  -- | Return Word size ncgWordWidth :: NCGConfig -> Width ncgWordWidth config = platformWordWidth (ncgPlatform config)++-- | Size in bytes of the pre-allocated spill space on the C stack+ncgSpillPreallocSize :: NCGConfig -> Int+ncgSpillPreallocSize config = pc_RESERVED_C_STACK_BYTES (platformConstants (ncgPlatform config))  -- | Return Word size platformWordWidth :: Platform -> Width

GHC/CmmToAsm/Dwarf.hs view

@@ -7,9 +7,8 @@ import GHC.Cmm.CLabel import GHC.Cmm.Expr        ( GlobalReg(..) ) import GHC.Settings.Config ( cProjectName, cProjectVersion )-import GHC.Core            ( Tickish(..) )+import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock-import GHC.Driver.Session import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Platform@@ -18,6 +17,7 @@  import GHC.CmmToAsm.Dwarf.Constants import GHC.CmmToAsm.Dwarf.Types+import GHC.CmmToAsm.Config  import Control.Arrow    ( first ) import Control.Monad    ( mfilter )@@ -32,23 +32,22 @@ import qualified GHC.Cmm.Dataflow.Collections as H  -- | Generate DWARF/debug information-dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]+dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]             -> IO (SDoc, UniqSupply)-dwarfGen _  _      us [] = return (empty, us)-dwarfGen df modLoc us blocks = do-  let platform = targetPlatform df+dwarfGen _      _      us []     = return (empty, us)+dwarfGen config modLoc us blocks = do+  let platform = ncgPlatform config    -- Convert debug data structures to DWARF info records-  -- We strip out block information when running with -g0 or -g1.   let procs = debugSplitProcs blocks       stripBlocks dbg-        | debugLevel df < 2 = dbg { dblBlocks = [] }-        | otherwise         = dbg+        | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }+        | otherwise                     = dbg   compPath <- getCurrentDirectory   let lowLabel = dblCLabel $ head procs-      highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs+      highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs       dwarfUnit = DwarfCompileUnit-        { dwChildren = map (procToDwarf df) (map stripBlocks procs)+        { dwChildren = map (procToDwarf config) (map stripBlocks procs)         , dwName = fromMaybe "" (ml_hs_file modLoc)         , dwCompDir = addTrailingPathSeparator compPath         , dwProducer = cProjectName ++ " " ++ cProjectVersion@@ -74,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@@ -89,8 +88,8 @@                  pprDwarfFrame platform (debugFrame framesU procs)    -- .aranges section: Information about the bounds of compilation units-  let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs-               | otherwise                 = [DwarfARange lowLabel highLabel]+  let aranges' | ncgSplitSections config = map mkDwarfARange procs+               | otherwise               = [DwarfARange lowLabel highLabel]   let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU    return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')@@ -100,19 +99,19 @@ -- scattered in the final binary. Without split sections, we could make a -- single arange based on the first/last proc. mkDwarfARange :: DebugBlock -> DwarfARange-mkDwarfARange proc = DwarfARange start end+mkDwarfARange proc = DwarfARange lbl end   where-    start = dblCLabel proc-    end = mkAsmTempEndLabel start+    lbl = dblCLabel proc+    end = mkAsmTempProcEndLabel lbl  -- | Header for a compilation unit, establishing global format -- parameters 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)@@ -121,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@@ -175,12 +174,12 @@ -}  -- | Generate DWARF info for a procedure debug block-procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo-procToDwarf df prc-  = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)+procToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo+procToDwarf config prc+  = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)                     , dwName     = case dblSourceTick prc of                          Just s@SourceNote{} -> sourceName s-                         _otherwise -> showSDocDump df $ ppr $ dblLabel prc+                         _otherwise -> show (dblLabel prc)                     , dwLabel    = dblCLabel prc                     , dwParent   = fmap mkAsmTempDieLabel                                    $ mfilter goodParent@@ -190,25 +189,28 @@   goodParent a | a == dblCLabel prc = False                -- Omit parent if it would be self-referential   goodParent a | not (externallyVisibleCLabel a)-               , debugLevel df < 2 = False-               -- We strip block information when running -g0 or -g1, don't-               -- refer to blocks in that case. Fixes #14894.+               , ncgDwarfStripBlockInfo config = False+               -- If we strip block information, don't refer to blocks.+               -- Fixes #14894.   goodParent _ = True  -- | Generate DWARF info for a block-blockToDwarf :: DebugBlock -> DwarfInfo-blockToDwarf blk-  = DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk)-                              ++ map blockToDwarf (dblBlocks blk)+blockToDwarf :: NCGConfig -> DebugBlock -> DwarfInfo+blockToDwarf config blk+  = DwarfBlock { dwChildren = map (blockToDwarf config) (dblBlocks blk) ++ srcNotes                , dwLabel    = dblCLabel blk                , dwMarker   = marker                }   where+    srcNotes+      | ncgDwarfSourceNotes config = concatMap tickToDwarf (dblTicks blk)+      | otherwise                  = []+     marker       | Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk       | otherwise                 = Nothing   -- block was optimized out -tickToDwarf :: Tickish () -> [DwarfInfo]+tickToDwarf :: CmmTickish -> [DwarfInfo] tickToDwarf  (SourceNote ss _) = [DwarfSrcNote ss] tickToDwarf _ = []

GHC/CmmToAsm/Dwarf/Constants.hs view

@@ -48,7 +48,7 @@ -- * Dwarf attributes dW_AT_name, dW_AT_stmt_list, dW_AT_low_pc, dW_AT_high_pc, dW_AT_language,   dW_AT_comp_dir, dW_AT_producer, dW_AT_external, dW_AT_frame_base,-  dW_AT_use_UTF8, dW_AT_MIPS_linkage_name :: Word+  dW_AT_use_UTF8, dW_AT_linkage_name :: Word dW_AT_name              = 0x03 dW_AT_stmt_list         = 0x10 dW_AT_low_pc            = 0x11@@ -59,7 +59,7 @@ dW_AT_external          = 0x3f dW_AT_frame_base        = 0x40 dW_AT_use_UTF8          = 0x53-dW_AT_MIPS_linkage_name = 0x2007+dW_AT_linkage_name      = 0x6e  -- * Custom DWARF attributes -- Chosen a more or less random section of the vendor-extensible region@@ -217,6 +217,7 @@     | r == xmm14 -> 31     | r == xmm15 -> 32   ArchPPC_64 _ -> fromIntegral $ toRegNo r+  ArchAArch64  -> fromIntegral $ toRegNo r   _other -> error "dwarfRegNo: Unsupported platform or unknown register!"  -- | Virtual register number to use for return address.@@ -229,4 +230,5 @@     ArchX86    -> 8  -- eip     ArchX86_64 -> 16 -- rip     ArchPPC_64 ELF_V2 -> 65 -- lr (link register)+    ArchAArch64-> 30     _other     -> error "dwarfReturnRegNo: Unsupported platform!"

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(..)@@ -41,7 +46,6 @@ import qualified Data.ByteString as BS import qualified Control.Monad.Trans.State.Strict as S import Control.Monad (zipWithM, join)-import Data.Bits import qualified Data.Map as Map import Data.Word import Data.Char@@ -100,7 +104,7 @@       -- DwAbbrSubprogramWithParent       subprogramAttrs =            [ (dW_AT_name, dW_FORM_string)-           , (dW_AT_MIPS_linkage_name, dW_FORM_string)+           , (dW_AT_linkage_name, dW_FORM_string)            , (dW_AT_external, dW_FORM_flag)            , (dW_AT_low_pc, dW_FORM_addr)            , (dW_AT_high_pc, dW_FORM_addr)@@ -156,6 +160,12 @@         pprDwarfInfoClose     noChildren = pprDwarfInfoOpen platform haveSrc d +-- | 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+    $ 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 -- has to be kept in synch.@@ -167,20 +177,21 @@   $$ pprString producer   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir-  $$ pprWord platform (ppr lowLabel)-  $$ pprWord platform (ppr highLabel)+     -- Offset due to Note [Info Offset]+  $$ pprWord platform (pdoc platform lowLabel <> text "-1")+  $$ pprWord platform (pdoc platform highLabel)   $$ if haveSrc      then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)      else empty-pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label-                                    parent) = sdocWithDynFlags $ \df ->-  ppr (mkAsmTempDieLabel label) <> colon+pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =+  pdoc platform (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev abbrev   $$ pprString name-  $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))+  $$ pprLabelString platform label   $$ pprFlag (externallyVisibleCLabel label)-  $$ pprWord platform (ppr label)-  $$ pprWord platform (ppr $ mkAsmTempEndLabel label)+     -- Offset due to Note [Info Offset]+  $$ pprWord platform (pdoc platform label <> text "-1")+  $$ pprWord platform (pdoc platform $ mkAsmTempProcEndLabel label)   $$ pprByte 1   $$ pprByte dW_OP_call_frame_cfa   $$ parentValue@@ -188,17 +199,17 @@     abbrev = case parent of Nothing -> DwAbbrSubprogram                             Just _  -> DwAbbrSubprogramWithParent     parentValue = maybe empty pprParentDie parent-    pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)-pprDwarfInfoOpen _ _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->-  ppr (mkAsmTempDieLabel label) <> colon+    pprParentDie sym = sectionOffset platform (pdoc platform sym) (ptext dwarfInfoLabel)+pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =+  pdoc platform (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev DwAbbrBlockWithoutCode-  $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))-pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->-  ppr (mkAsmTempDieLabel label) <> colon+  $$ pprLabelString platform label+pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =+  pdoc platform (mkAsmTempDieLabel label) <> colon   $$ pprAbbrev DwAbbrBlock-  $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))-  $$ pprWord platform (ppr marker)-  $$ pprWord platform (ppr $ mkAsmTempEndLabel marker)+  $$ pprLabelString platform label+  $$ pprWord platform (pdoc platform marker)+  $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker) pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =   pprAbbrev DwAbbrGhcSrcNote   $$ pprString' (ftext $ srcSpanFile ss)@@ -234,7 +245,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@@ -246,10 +257,13 @@      $$ pprWord platform (char '0')  pprDwarfARange :: Platform -> DwarfARange -> SDoc-pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length+pprDwarfARange platform arng =+    -- Offset due to Note [Info offset].+    pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")+    $$ 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.@@ -280,8 +294,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@@ -290,7 +304,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@@ -303,9 +317,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)@@ -333,7 +347,7 @@             , pprLEBWord 0             ] $$        wordAlign platform $$-       ppr cieEndLabel <> colon $$+       pdoc platform cieEndLabel <> colon $$        -- Procedure unwind tables        vcat (map (pprFrameProc platform cieLabel cieInit) procs) @@ -344,21 +358,21 @@ pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)   = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")         fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")-        procEnd     = mkAsmTempEndLabel procLbl+        procEnd     = mkAsmTempProcEndLabel 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 '-' <>+                      -- see Note [Info Offset]+    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@@ -388,15 +402,16 @@          in if oldUws == uws              then (empty, oldUws)-             else let -- see [Note: Info Offset]+             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)                   in (doc, uws)  -- Note [Info Offset]+-- ~~~~~~~~~~~~~~~~~~ -- -- GDB was pretty much written with C-like programs in mind, and as a -- result they assume that once you have a return address, it is a@@ -416,6 +431,14 @@ -- correct function name for the frame, as that uses the symbol table, -- which we can not manipulate as easily. --+-- We apply this offset in several places:+--+--  * unwind information in .debug_frames+--  * the subprogram and lexical_block DIEs in .debug_info+--  * the ranges in .debug_aranges+--+-- In the latter two cases we apply the offset unconditionally.+-- -- There's a GDB patch to address this at [1]. At the moment of writing -- it's not merged, so I recommend building GDB with the patch if you -- care about unwinding. The hack above doesn't cover every case.@@ -493,7 +516,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

GHC/CmmToAsm/Format.hs view

@@ -12,6 +12,7 @@     Format(..),     intFormat,     floatFormat,+    isIntFormat,     isFloatFormat,     cmmTypeFormat,     formatToWidth,@@ -24,6 +25,7 @@  import GHC.Cmm import GHC.Utils.Outputable+import GHC.Utils.Panic  -- It looks very like the old MachRep, but it's now of purely local -- significance, here in the native code generator.  You can change it@@ -72,6 +74,9 @@          other   -> pprPanic "Format.floatFormat" (ppr other) +-- | Check if a format represent an integer value.+isIntFormat :: Format -> Bool+isIntFormat = not . isFloatFormat  -- | Check if a format represents a floating point value. isFloatFormat :: Format -> Bool

GHC/CmmToAsm/Instr.hs view

@@ -1,28 +1,18 @@ -module GHC.CmmToAsm.Instr (-        RegUsage(..),-        noUsage,-        GenBasicBlock(..), blockId,-        ListGraph(..),-        NatCmm,-        NatCmmDecl,-        NatBasicBlock,-        topInfoTable,-        entryBlocks,-        Instruction(..)-)-+module GHC.CmmToAsm.Instr+   ( Instruction(..)+   , RegUsage(..)+   , noUsage+   ) where  import GHC.Prelude  import GHC.Platform import GHC.Platform.Reg+import GHC.Utils.Outputable (SDoc)  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import GHC.Cmm hiding (topInfoTable)  import GHC.CmmToAsm.Config @@ -41,56 +31,17 @@                 reads :: [Reg],                 writes :: [Reg]                 }+        deriving Show  -- | No regs read or written to. noUsage :: RegUsage noUsage  = RU [] [] --- Our flavours of the Cmm types--- Type synonyms for Cmm populated with native code-type NatCmm instr-        = GenCmmGroup-                RawCmmStatics-                (LabelMap RawCmmStatics)-                (ListGraph instr)--type NatCmmDecl statics instr-        = GenCmmDecl-                statics-                (LabelMap RawCmmStatics)-                (ListGraph instr)---type NatBasicBlock instr-        = GenBasicBlock instr----- | Returns the info table associated with the CmmDecl's entry point,--- if any.-topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i-topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))-  = mapLookup (blockId b) infos-topInfoTable _-  = Nothing---- | Return the list of BlockIds in a CmmDecl that are entry points--- for this proc (i.e. they may be jumped to from outside this proc).-entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]-entryBlocks (CmmProc info _ _ (ListGraph code)) = entries-  where-        infos = mapKeys info-        entries = case code of-                    [] -> infos-                    BasicBlock entry _ : _ -- first block is the entry point-                       | entry `elem` infos -> infos-                       | otherwise          -> entry : infos-entryBlocks _ = []- -- | Common things that we can do with instructions, on all architectures. --      These are used by the shared parts of the native code generator, --      specifically the register allocators. ---class   Instruction instr where+class Instruction instr where          -- | Get the registers that are being used by this instruction.         --      regUsage doesn't need to do any trickery for jumps and such.@@ -140,7 +91,7 @@                 -> Reg          -- ^ the reg to spill                 -> Int          -- ^ the current stack delta                 -> Int          -- ^ spill slot to use-                -> instr+                -> [instr]        -- ^ instructions           -- | An instruction to reload a register from a spill slot.@@ -149,7 +100,7 @@                 -> Reg          -- ^ the reg to reload.                 -> Int          -- ^ the current stack delta                 -> Int          -- ^ the spill slot to use-                -> instr+                -> [instr]        -- ^ instructions          -- | See if this instruction is telling us the current C stack delta         takeDeltaInstr@@ -204,3 +155,9 @@                 :: Platform                 -> Int                 -> [instr]++        -- | Pretty-print an instruction+        pprInstr :: Platform -> instr -> SDoc++        -- Create a comment instruction+        mkComment :: SDoc -> [instr]

GHC/CmmToAsm/Monad.hs view

@@ -16,7 +16,6 @@          NatM, -- instance Monad         initNat,-        initConfig,         addImportNat,         addNodeBetweenNat,         addImmediateSuccessorNat,@@ -34,7 +33,7 @@         getNewRegPairNat,         getPicBaseMaybeNat,         getPicBaseNat,-        getDynFlags,+        getCfgWeights,         getModLoc,         getFileId,         getDebugBlock,@@ -53,6 +52,7 @@ import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -63,15 +63,14 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Types.Unique         ( Unique )-import GHC.Driver.Session import GHC.Unit.Module  import Control.Monad    ( ap ) -import GHC.CmmToAsm.Instr-import GHC.Utils.Outputable (SDoc, pprPanic, ppr)-import GHC.Cmm (RawCmmDecl, RawCmmStatics)+import GHC.Utils.Outputable (SDoc, ppr)+import GHC.Utils.Panic      (pprPanic) import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.CFG.Weight  data NcgImpl statics instr jumpDest = NcgImpl {     ncgConfig                 :: !NCGConfig,@@ -81,6 +80,8 @@     canShortcut               :: instr -> Maybe jumpDest,     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,+    -- | 'Module' is only for printing internal labels. See Note [Internal proc+    -- labels] in CLabel.     pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],@@ -107,9 +108,7 @@                 natm_delta       :: Int,                 natm_imports     :: [(CLabel)],                 natm_pic         :: Maybe Reg,-                natm_dflags      :: DynFlags,                 natm_config      :: NCGConfig,-                natm_this_module :: Module,                 natm_modloc      :: ModLocation,                 natm_fileid      :: DwarfFiles,                 natm_debug_map   :: LabelMap DebugBlock,@@ -127,69 +126,22 @@ unNat :: NatM a -> NatM_State -> (a, NatM_State) unNat (NatM a) = a -mkNatM_State :: UniqSupply -> Int -> DynFlags -> Module -> ModLocation ->+mkNatM_State :: UniqSupply -> Int -> NCGConfig -> ModLocation ->                 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State-mkNatM_State us delta dflags this_mod+mkNatM_State us delta config         = \loc dwf dbg cfg ->                 NatM_State                         { natm_us = us                         , natm_delta = delta                         , natm_imports = []                         , natm_pic = Nothing-                        , natm_dflags = dflags-                        , natm_config = initConfig dflags-                        , natm_this_module = this_mod+                        , natm_config = config                         , natm_modloc = loc                         , natm_fileid = dwf                         , natm_debug_map = dbg                         , natm_cfg = cfg                         } --- | Initialize the native code generator configuration from the DynFlags-initConfig :: DynFlags -> NCGConfig-initConfig dflags = NCGConfig-   { ncgPlatform              = targetPlatform dflags-   , ncgProcAlignment         = cmmProcAlignment dflags-   , ncgDebugLevel            = debugLevel dflags-   , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags-   , ncgPIC                   = positionIndependent dflags-   , ncgInlineThresholdMemcpy = fromIntegral $ maxInlineMemcpyInsns dflags-   , ncgInlineThresholdMemset = fromIntegral $ maxInlineMemsetInsns dflags-   , ncgSplitSections         = gopt Opt_SplitSections dflags-   , ncgSpillPreallocSize     = rESERVED_C_STACK_BYTES dflags-   , ncgRegsIterative         = gopt Opt_RegsIterative dflags-   , ncgAsmLinting            = gopt Opt_DoAsmLinting dflags--     -- With -O1 and greater, the cmmSink pass does constant-folding, so-     -- we don't need to do it again in the native code generator.-   , ncgDoConstantFolding     = optLevel dflags < 1--   , ncgDumpRegAllocStages    = dopt Opt_D_dump_asm_regalloc_stages dflags-   , ncgDumpAsmStats          = dopt Opt_D_dump_asm_stats dflags-   , ncgDumpAsmConflicts      = dopt Opt_D_dump_asm_conflicts dflags-   , ncgBmiVersion            = case platformArch (targetPlatform dflags) of-                                 ArchX86_64 -> bmiVersion dflags-                                 ArchX86    -> bmiVersion dflags-                                 _          -> Nothing--     -- We Assume  SSE1 and SSE2 operations are available on both-     -- x86 and x86_64. Historically we didn't default to SSE2 and-     -- SSE1 on x86, which results in defacto nondeterminism for how-     -- rounding behaves in the associated x87 floating point instructions-     -- because variations in the spill/fpu stack placement of arguments for-     -- operations would change the precision and final result of what-     -- would otherwise be the same expressions with respect to single or-     -- double precision IEEE floating point computations.-   , ncgSseVersion =-      let v | sseVersion dflags < Just SSE2 = Just SSE2-            | otherwise                     = sseVersion dflags-      in case platformArch (targetPlatform dflags) of-            ArchX86_64 -> v-            ArchX86    -> v-            _          -> Nothing-   }-- initNat :: NatM_State -> NatM a -> (a, NatM_State) initNat init_st m         = case unNat m init_st of { (r,st) -> (r,st) }@@ -236,21 +188,21 @@     case takeUniqFromSupply $ natm_us st of     (uniq, us') -> (uniq, st {natm_us = us'}) -instance HasDynFlags NatM where-    getDynFlags = NatM $ \ st -> (natm_dflags st, st)-- getDeltaNat :: NatM Int getDeltaNat = NatM $ \ st -> (natm_delta st, st) +-- | Get CFG edge weights+getCfgWeights :: NatM Weights+getCfgWeights = NatM $ \ st -> (ncgCfgWeights (natm_config st), st)  setDeltaNat :: Int -> NatM () setDeltaNat delta = NatM $ \ st -> ((), st {natm_delta = delta}) - getThisModuleNat :: NatM Module-getThisModuleNat = NatM $ \ st -> (natm_this_module st, st)+getThisModuleNat = NatM $ \ st -> (ncgThisModule $ natm_config st, st) +instance HasModule NatM where+  getModule = getThisModuleNat  addImportNat :: CLabel -> NatM () addImportNat imp@@ -264,9 +216,8 @@ -- | Record that we added a block between `from` and `old`. addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM () addNodeBetweenNat from between to- = do   df <- getDynFlags-        let jmpWeight = fromIntegral . uncondWeight .-                        cfgWeightInfo $ df+ = do   weights <- getCfgWeights+        let jmpWeight = fromIntegral (uncondWeight weights)         updateCfgNat (updateCfg jmpWeight from between to)   where     -- When transforming A -> B to A -> A' -> B@@ -286,8 +237,8 @@ --   block -> X to `succ` -> X addImmediateSuccessorNat :: BlockId -> BlockId -> NatM () addImmediateSuccessorNat block succ = do-   dflags <- getDynFlags-   updateCfgNat (addImmediateSuccessor dflags block succ)+   weights <- getCfgWeights+   updateCfgNat (addImmediateSuccessor weights block succ)  getBlockIdNat :: NatM BlockId getBlockIdNat

GHC/CmmToAsm/PIC.hs view

@@ -2,7 +2,7 @@   This module handles generation of position independent code and   dynamic-linking related issues for the native code generator. -  This depends both the architecture and OS, so we define it here+  This depends on both the architecture and OS, so we define it here   instead of in one of the architecture specific modules.    Things outside this module which are related to this:@@ -54,28 +54,21 @@ import qualified GHC.CmmToAsm.X86.Instr as X86  import GHC.Platform-import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Monad import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types   import GHC.Cmm.Dataflow.Collections import GHC.Cmm-import GHC.Cmm.CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,-                          mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),-                          dynamicLinkerLabelInfo, mkPicBaseLabel,-                          labelDynamic, externallyVisibleCLabel )--import GHC.Cmm.CLabel           ( mkForeignLabel )-+import GHC.Cmm.CLabel  import GHC.Types.Basic-import GHC.Unit.Module  import GHC.Utils.Outputable+import GHC.Utils.Panic -import GHC.Driver.Session import GHC.Data.FastString  @@ -101,11 +94,9 @@  class Monad m => CmmMakeDynamicReferenceM m where     addImport :: CLabel -> m ()-    getThisModule :: m Module  instance CmmMakeDynamicReferenceM NatM where     addImport = addImportNat-    getThisModule = getThisModuleNat  cmmMakeDynamicReference   :: CmmMakeDynamicReferenceM m@@ -119,13 +110,11 @@   = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through    | otherwise-  = do this_mod <- getThisModule-       let platform = ncgPlatform config+  = do let platform = ncgPlatform config        case howToAccessLabel                 config                 (platformArch platform)                 (platformOS   platform)-                this_mod                 referenceKind lbl of          AccessViaStub -> do@@ -133,6 +122,15 @@               addImport stub               return $ CmmLit $ CmmLabel stub +        -- GOT relative loads work differently on AArch64.  We don't do two+        -- step loads. The got symbol is loaded directly, and not through an+        -- additional load. Thus we do not need the CmmLoad decoration we have+        -- on other platforms.+        AccessViaSymbolPtr | ArchAArch64 <- platformArch platform -> do+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl+              addImport symbolPtr+              return $ cmmMakePicReference config symbolPtr+         AccessViaSymbolPtr -> do               let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl               addImport symbolPtr@@ -146,7 +144,6 @@                 -- so just jump there if it's a call or a jump               _ -> return $ CmmLit $ CmmLabel lbl - -- ----------------------------------------------------------------------------- -- Create a position independent reference to a label. -- (but do not bother with dynamic linking).@@ -161,6 +158,11 @@   | OSMinGW32 <- platformOS platform   = CmmLit $ CmmLabel lbl +  -- no pic base reg on AArch64, however indicate this symbol should go through+  -- the global offset table (GOT).+  | ArchAArch64 <- platformArch platform+  = CmmLit $ CmmLabel lbl+   | OSAIX <- platformOS platform   = CmmMachOp (MO_Add W32)           [ CmmReg (CmmGlobal PicBaseReg)@@ -214,7 +216,7 @@         | AccessViaSymbolPtr         | AccessDirectly -howToAccessLabel :: NCGConfig -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle+howToAccessLabel :: NCGConfig -> Arch -> OS -> ReferenceKind -> CLabel -> LabelAccessStyle  -- Windows -- In Windows speak, a "module" is a set of objects linked into the@@ -237,7 +239,7 @@ -- into the same .exe file. In this case we always access symbols directly, -- and never use __imp_SYMBOL. ---howToAccessLabel config _ OSMinGW32 this_mod _ lbl+howToAccessLabel config _arch OSMinGW32 _kind lbl          -- Assume all symbols will be in the same PE, so just access them directly.         | not (ncgExternalDynamicRefs config)@@ -245,14 +247,28 @@          -- If the target symbol is in another PE we need to access it via the         --      appropriate __imp_SYMBOL pointer.-        | labelDynamic config this_mod lbl+        | labelDynamic config lbl         = AccessViaSymbolPtr          -- Target symbol is in the same PE as the caller, so just access it directly.         | otherwise         = AccessDirectly +-- On AArch64, relocations for JUMP and CALL will be emitted with 26bits, this+-- is enough for ~64MB of range. Anything else will need to go through a veneer,+-- which is the job of the linker to build.  We might only want to lookup+-- Data References through the GOT.+howToAccessLabel config ArchAArch64 _os _kind lbl+        | not (ncgExternalDynamicRefs config)+        = AccessDirectly +        | labelDynamic config lbl+        = AccessViaSymbolPtr++        | otherwise+        = AccessDirectly++ -- Mach-O (Darwin, Mac OS X) -- -- Indirect access is required in the following cases:@@ -261,9 +277,9 @@ -- It is always possible to access something indirectly, -- even when it's not necessary. ---howToAccessLabel config arch OSDarwin this_mod DataReference lbl+howToAccessLabel config arch OSDarwin DataReference lbl         -- data access to a dynamic library goes via a symbol pointer-        | labelDynamic config this_mod lbl+        | labelDynamic config lbl         = AccessViaSymbolPtr          -- when generating PIC code, all cross-module data references must@@ -282,32 +298,32 @@         | otherwise         = AccessDirectly -howToAccessLabel config arch OSDarwin this_mod JumpReference lbl+howToAccessLabel config arch OSDarwin JumpReference lbl         -- dyld code stubs don't work for tailcalls because the         -- stack alignment is only right for regular calls.         -- Therefore, we have to go via a symbol pointer:-        | arch == ArchX86 || arch == ArchX86_64-        , labelDynamic config this_mod lbl+        | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64+        , labelDynamic config lbl         = AccessViaSymbolPtr  -howToAccessLabel config arch OSDarwin this_mod _ lbl+howToAccessLabel config arch OSDarwin _kind lbl         -- Code stubs are the usual method of choice for imported code;         -- not needed on x86_64 because Apple's new linker, ld64, generates-        -- them automatically.+        -- them automatically, neither on Aarch64 (arm64).         | arch /= ArchX86_64-        , labelDynamic config this_mod lbl+        , arch /= ArchAArch64+        , labelDynamic config lbl         = AccessViaStub          | otherwise         = AccessDirectly - ---------------------------------------------------------------------------- -- AIX  -- quite simple (for now)-howToAccessLabel _config _arch OSAIX _this_mod kind _lbl+howToAccessLabel _config _arch OSAIX kind _lbl         = case kind of             DataReference -> AccessViaSymbolPtr             CallReference -> AccessDirectly@@ -324,7 +340,7 @@ -- from position independent code. It is also required from the main program -- when dynamic libraries containing Haskell code are used. -howToAccessLabel _ (ArchPPC_64 _) os _ kind _+howToAccessLabel _config (ArchPPC_64 _) os kind _lbl         | osElfTarget os         = case kind of           -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC@@ -336,7 +352,7 @@           -- regular calls are handled by the runtime linker           _             -> AccessDirectly -howToAccessLabel config _ os _ _ _+howToAccessLabel config _arch os _kind _lbl         -- no PIC -> the dynamic linker does everything for us;         --           if we don't dynamically link to Haskell code,         --           it actually manages to do so without messing things up.@@ -345,11 +361,11 @@           not (ncgExternalDynamicRefs config)         = AccessDirectly -howToAccessLabel config arch os this_mod DataReference lbl+howToAccessLabel config arch os DataReference lbl         | osElfTarget os         = case () of             -- A dynamic label needs to be accessed via a symbol pointer.-          _ | labelDynamic config this_mod lbl+          _ | labelDynamic config lbl             -> AccessViaSymbolPtr              -- For PowerPC32 -fPIC, we have to access even static data@@ -375,25 +391,25 @@         -- (AccessDirectly, because we get an implicit symbol stub)         -- and calling functions from PIC code on non-i386 platforms (via a symbol stub) -howToAccessLabel config arch os this_mod CallReference lbl+howToAccessLabel config arch os CallReference lbl         | osElfTarget os-        , labelDynamic config this_mod lbl && not (ncgPIC config)+        , labelDynamic config lbl && not (ncgPIC config)         = AccessDirectly          | osElfTarget os         , arch /= ArchX86-        , labelDynamic config this_mod lbl+        , labelDynamic config lbl         , ncgPIC config         = AccessViaStub -howToAccessLabel config _ os this_mod _ lbl+howToAccessLabel config _arch os _kind lbl         | osElfTarget os-        = if labelDynamic config this_mod lbl+        = if labelDynamic config lbl             then AccessViaSymbolPtr             else AccessDirectly  -- all other platforms-howToAccessLabel config _ _ _ _ _+howToAccessLabel config _arch _os _kind _lbl         | not (ncgPIC config)         = AccessDirectly @@ -573,21 +589,21 @@ -- and one for non-PIC. -- -pprImportedSymbol :: DynFlags -> NCGConfig -> CLabel -> SDoc-pprImportedSymbol dflags config importedLbl = case (arch,os) of+pprImportedSymbol :: NCGConfig -> CLabel -> SDoc+pprImportedSymbol config importedLbl = case (arch,os) of    (ArchX86, OSDarwin)         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl         -> if not pic              then               vcat [                   text ".symbol_stub",-                  text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),-                      text "\t.indirect_symbol" <+> pprCLabel dflags lbl,-                      text "\tjmp *L" <> pprCLabel dflags lbl+                  text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+                      text "\t.indirect_symbol" <+> ppr_lbl lbl,+                      text "\tjmp *L" <> ppr_lbl lbl                           <> text "$lazy_ptr",-                  text "L" <> pprCLabel dflags lbl+                  text "L" <> ppr_lbl lbl                       <> text "$stub_binder:",-                      text "\tpushl $L" <> pprCLabel dflags lbl+                      text "\tpushl $L" <> ppr_lbl lbl                           <> text "$lazy_ptr",                       text "\tjmp dyld_stub_binding_helper"               ]@@ -595,16 +611,16 @@               vcat [                   text ".section __TEXT,__picsymbolstub2,"                       <> text "symbol_stubs,pure_instructions,25",-                  text "L" <> pprCLabel dflags lbl <> ptext (sLit "$stub:"),-                      text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+                  text "L" <> ppr_lbl lbl <> ptext (sLit "$stub:"),+                      text "\t.indirect_symbol" <+> ppr_lbl lbl,                       text "\tcall ___i686.get_pc_thunk.ax",                   text "1:",-                      text "\tmovl L" <> pprCLabel dflags lbl+                      text "\tmovl L" <> ppr_lbl lbl                           <> text "$lazy_ptr-1b(%eax),%edx",                       text "\tjmp *%edx",-                  text "L" <> pprCLabel dflags lbl+                  text "L" <> ppr_lbl lbl                       <> text "$stub_binder:",-                      text "\tlea L" <> pprCLabel dflags lbl+                      text "\tlea L" <> ppr_lbl lbl                           <> text "$lazy_ptr-1b(%eax),%eax",                       text "\tpushl %eax",                       text "\tjmp dyld_stub_binding_helper"@@ -612,24 +628,26 @@            $+$ vcat [        text ".section __DATA, __la_sym_ptr"                     <> (if pic then int 2 else int 3)                     <> text ",lazy_symbol_pointers",-                text "L" <> pprCLabel dflags lbl <> ptext (sLit "$lazy_ptr:"),-                    text "\t.indirect_symbol" <+> pprCLabel dflags lbl,-                    text "\t.long L" <> pprCLabel dflags lbl+                text "L" <> ppr_lbl lbl <> ptext (sLit "$lazy_ptr:"),+                    text "\t.indirect_symbol" <+> ppr_lbl lbl,+                    text "\t.long L" <> ppr_lbl lbl                     <> text "$stub_binder"]          | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl         -> vcat [                 text ".non_lazy_symbol_pointer",-                char 'L' <> pprCLabel dflags lbl <> text "$non_lazy_ptr:",-                text "\t.indirect_symbol" <+> pprCLabel dflags lbl,+                char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",+                text "\t.indirect_symbol" <+> ppr_lbl lbl,                 text "\t.long\t0"]          | otherwise         -> empty -   (_, OSDarwin) -> empty+   (ArchAArch64, OSDarwin)+        -> empty  +    -- XCOFF / AIX    --    -- Similar to PPC64 ELF v1, there's dedicated TOC register (r2). To@@ -644,8 +662,8 @@    (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [-                   text "LC.." <> pprCLabel dflags lbl <> char ':',-                   text "\t.long" <+> pprCLabel dflags lbl ]+                   text "LC.." <> ppr_lbl lbl <> char ':',+                   text "\t.long" <+> ppr_lbl lbl ]             _ -> empty     -- ELF / Linux@@ -682,8 +700,8 @@         -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)               -> vcat [-                   text ".LC_" <> pprCLabel dflags lbl <> char ':',-                   text "\t.quad" <+> pprCLabel dflags lbl ]+                   text ".LC_" <> ppr_lbl lbl <> char ':',+                   text "\t.quad" <+> ppr_lbl lbl ]             _ -> empty     _ | osElfTarget os@@ -696,8 +714,8 @@                   in vcat [                       text ".section \".got2\", \"aw\"",-                      text ".LC_" <> pprCLabel dflags lbl <> char ':',-                      ptext symbolSize <+> pprCLabel dflags lbl ]+                      text ".LC_" <> ppr_lbl lbl <> char ':',+                      ptext symbolSize <+> ppr_lbl lbl ]              -- PLT code stubs are generated automatically by the dynamic linker.             _ -> empty@@ -705,8 +723,9 @@    _ -> panic "PIC.pprImportedSymbol: no match"  where    platform = ncgPlatform config-   arch     = platformArch platform-   os       = platformOS   platform+   ppr_lbl  = pprCLabel     platform AsmStyle+   arch     = platformArch  platform+   os       = platformOS    platform    pic      = ncgPIC config  --------------------------------------------------------------------------------

+ GHC/CmmToAsm/PPC.hs view

@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for PPC architectures+module GHC.CmmToAsm.PPC+   ( ncgPPC+   )+where++import GHC.Prelude++import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types++import qualified GHC.CmmToAsm.PPC.Instr   as PPC+import qualified GHC.CmmToAsm.PPC.Ppr     as PPC+import qualified GHC.CmmToAsm.PPC.CodeGen as PPC+import qualified GHC.CmmToAsm.PPC.Regs    as PPC+import qualified GHC.CmmToAsm.PPC.RegInfo as PPC++ncgPPC :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr PPC.JumpDest+ncgPPC config = NcgImpl+   { ncgConfig                 = config+   , cmmTopCodeGen             = PPC.cmmTopCodeGen+   , generateJumpTableForInstr = PPC.generateJumpTableForInstr config+   , getJumpDestBlockId        = PPC.getJumpDestBlockId+   , canShortcut               = PPC.canShortcut+   , shortcutStatics           = PPC.shortcutStatics+   , shortcutJump              = PPC.shortcutJump+   , pprNatCmmDecl             = PPC.pprNatCmmDecl config+   , maxSpillSlots             = PPC.maxSpillSlots config+   , allocatableRegs           = PPC.allocatableRegs platform+   , ncgAllocMoreStack         = PPC.allocMoreStack platform+   , ncgExpandTop              = id+   , ncgMakeFarBranches        = PPC.makeFarBranches+   , extractUnwindPoints       = const []+   , invertCondBranches        = \_ _ -> id+   }+    where+      platform = ncgPlatform config++-- | Instruction instance for powerpc+instance Instruction PPC.Instr where+   regUsageOfInstr     = PPC.regUsageOfInstr+   patchRegsOfInstr    = PPC.patchRegsOfInstr+   isJumpishInstr      = PPC.isJumpishInstr+   jumpDestsOfInstr    = PPC.jumpDestsOfInstr+   patchJumpInstr      = PPC.patchJumpInstr+   mkSpillInstr        = PPC.mkSpillInstr+   mkLoadInstr         = PPC.mkLoadInstr+   takeDeltaInstr      = PPC.takeDeltaInstr+   isMetaInstr         = PPC.isMetaInstr+   mkRegRegMoveInstr _ = PPC.mkRegRegMoveInstr+   takeRegRegMoveInstr = PPC.takeRegRegMoveInstr+   mkJumpInstr         = PPC.mkJumpInstr+   mkStackAllocInstr   = PPC.mkStackAllocInstr+   mkStackDeallocInstr = PPC.mkStackDeallocInstr+   pprInstr            = PPC.pprInstr+   mkComment           = const []

GHC/CmmToAsm/PPC/CodeGen.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}  ----------------------------------------------------------------------------- --@@ -30,6 +31,7 @@ import GHC.CmmToAsm.PPC.Cond import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types import GHC.Cmm.DebugBlock    ( DebugBlock(..) ) import GHC.CmmToAsm.Monad@@ -38,7 +40,6 @@    , getPicBaseMaybeNat, getPlatform, getConfig    , getDebugBlock, getFileId    )-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config@@ -56,15 +57,15 @@ import GHC.Cmm.CLabel import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Core              ( Tickish(..) )+import GHC.Types.Tickish     ( GenTickish(..) ) import GHC.Types.SrcLoc      ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )  -- The rest: import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic  import Control.Monad    ( mapAndUnzipM, when )-import Data.Bits import Data.Word  import GHC.Types.Basic@@ -116,7 +117,7 @@         return (CmmProc info lab live (ListGraph (b':blocks)) : statics)       fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc" -cmmTopCodeGen (CmmData sec dat) = do+cmmTopCodeGen (CmmData sec dat) =   return [CmmData sec dat]  -- no translation, we just use CmmStatic  basicBlockCodeGen@@ -786,7 +787,7 @@         (reg, code) <- getSomeReg x         (reg', off', code')  <-                      if i `mod` 4 == 0-                      then do return (reg, off, code)+                      then return (reg, off, code)                       else do                            tmp <- getNewRegNat II64                            return (tmp, ImmInt 0,@@ -799,7 +800,7 @@         (reg, code) <- getSomeReg x         (reg', off', code')  <-                      if i `mod` 4 == 0-                      then do return (reg, off, code)+                      then return (reg, off, code)                       else do                            tmp <- getNewRegNat II64                            return (tmp, ImmInt 0,@@ -881,8 +882,7 @@ -- extend small integers to 32 bit or 64 bit first  getCondCode (CmmMachOp mop [x, y])-  = do-    case mop of+  = case mop of       MO_F_Eq W32 -> condFltCode EQQ x y       MO_F_Ne W32 -> condFltCode NE  x y       MO_F_Gt W32 -> condFltCode GTT x y@@ -1670,7 +1670,7 @@             codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32          case labelOrExpr of-            Left lbl -> do -- the linker does all the work for us+            Left lbl -> -- the linker does all the work for us                 return (         codeBefore                         `snocOL` BL lbl usedRegs                         `appOL`  maybeNOP -- some ABI require a NOP after BL@@ -1716,7 +1716,7 @@     where         platform = ncgPlatform config -        uses_pic_base_implicitly = do+        uses_pic_base_implicitly =             -- See Note [implicit register in PPC PIC code]             -- on why we claim to use PIC register here             when (ncgPIC config && target32Bit platform) $ do@@ -2009,6 +2009,39 @@                     MO_F64_Acosh -> (fsLit "acosh", False)                     MO_F64_Atanh -> (fsLit "atanh", False) +                    MO_I64_ToI   -> (fsLit "hs_int64ToInt", False)+                    MO_I64_FromI -> (fsLit "hs_intToInt64", False)+                    MO_W64_ToW   -> (fsLit "hs_word64ToWord", False)+                    MO_W64_FromW -> (fsLit "hs_wordToWord64", False)++                    MO_x64_Neg   -> (fsLit "hs_neg64", False)+                    MO_x64_Add   -> (fsLit "hs_add64", False)+                    MO_x64_Sub   -> (fsLit "hs_sub64", False)+                    MO_x64_Mul   -> (fsLit "hs_mul64", False)+                    MO_I64_Quot  -> (fsLit "hs_quotInt64", False)+                    MO_I64_Rem   -> (fsLit "hs_remInt64", False)+                    MO_W64_Quot  -> (fsLit "hs_quotWord64", False)+                    MO_W64_Rem   -> (fsLit "hs_remWord64", False)++                    MO_x64_And   -> (fsLit "hs_and64", False)+                    MO_x64_Or    -> (fsLit "hs_or64", False)+                    MO_x64_Xor   -> (fsLit "hs_xor64", False)+                    MO_x64_Not   -> (fsLit "hs_not64", False)+                    MO_x64_Shl   -> (fsLit "hs_uncheckedShiftL64", False)+                    MO_I64_Shr   -> (fsLit "hs_uncheckedIShiftRA64", False)+                    MO_W64_Shr   -> (fsLit "hs_uncheckedShiftRL64", False)++                    MO_x64_Eq    -> (fsLit "hs_eq64", False)+                    MO_x64_Ne    -> (fsLit "hs_ne64", False)+                    MO_I64_Ge    -> (fsLit "hs_geInt64", False)+                    MO_I64_Gt    -> (fsLit "hs_gtInt64", False)+                    MO_I64_Le    -> (fsLit "hs_leInt64", False)+                    MO_I64_Lt    -> (fsLit "hs_ltInt64", False)+                    MO_W64_Ge    -> (fsLit "hs_geWord64", False)+                    MO_W64_Gt    -> (fsLit "hs_gtWord64", False)+                    MO_W64_Le    -> (fsLit "hs_leWord64", False)+                    MO_W64_Lt    -> (fsLit "hs_ltWord64", False)+                     MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)                      MO_Memcpy _  -> (fsLit "memcpy", False)@@ -2381,6 +2414,10 @@ coerceInt2FP' (ArchPPC_64 _) fromRep toRep x = do     (src, code) <- getSomeReg x     platform <- getPlatform+    upper <- getNewRegNat II64+    lower <- getNewRegNat II64+    l1 <- getBlockIdNat+    l2 <- getBlockIdNat     let         code' dst = code `appOL` maybe_exts `appOL` toOL [                 ST II64 src (spRel platform 3),@@ -2388,12 +2425,28 @@                 FCFID dst dst             ] `appOL` maybe_frsp dst -        maybe_exts = case fromRep of-                        W8 ->  unitOL $ EXTS II8 src src-                        W16 -> unitOL $ EXTS II16 src src-                        W32 -> unitOL $ EXTS II32 src src-                        W64 -> nilOL-                        _       -> panic "PPC.CodeGen.coerceInt2FP: no match"+        maybe_exts+          = case fromRep of+              W8 ->  unitOL $ EXTS II8 src src+              W16 -> unitOL $ EXTS II16 src src+              W32 -> unitOL $ EXTS II32 src src+              W64 -> case toRep of+                        W32 -> toOL [ SRA II64 upper src (RIImm (ImmInt 53))+                                    , CLRLI II64 lower src 53+                                    , ADD upper upper (RIImm (ImmInt 1))+                                    , ADD lower lower (RIImm (ImmInt 2047))+                                    , CMPL II64 upper (RIImm (ImmInt 2))+                                    , OR lower lower (RIReg src)+                                    , CLRRI II64 lower lower 11+                                    , BCC LTT l2 Nothing+                                    , BCC ALWAYS l1 Nothing+                                    , NEWBLOCK l1+                                    , MR src lower+                                    , BCC ALWAYS l2 Nothing+                                    , NEWBLOCK l2+                                    ]+                        _   -> nilOL+              _       -> panic "PPC.CodeGen.coerceInt2FP: no match"          maybe_frsp dst                 = case toRep of

GHC/CmmToAsm/PPC/Instr.hs view

@@ -12,23 +12,37 @@  #include "HsVersions.h" -module GHC.CmmToAsm.PPC.Instr (-    archWordFormat,-    RI(..),-    Instr(..),-    stackFrameHeaderSize,-    maxSpillSlots,-    allocMoreStack,-    makeFarBranches-)-+module GHC.CmmToAsm.PPC.Instr+   ( Instr(..)+   , RI(..)+   , archWordFormat+   , stackFrameHeaderSize+   , maxSpillSlots+   , allocMoreStack+   , makeFarBranches+   , mkJumpInstr+   , mkLoadInstr+   , mkSpillInstr+   , patchJumpInstr+   , patchRegsOfInstr+   , jumpDestsOfInstr+   , takeRegRegMoveInstr+   , takeDeltaInstr+   , mkRegRegMoveInstr+   , mkStackAllocInstr+   , mkStackDeallocInstr+   , regUsageOfInstr+   , isJumpishInstr+   , isMetaInstr+   ) where  import GHC.Prelude  import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond-import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config@@ -43,7 +57,7 @@ import GHC.Cmm.Info import GHC.Data.FastString import GHC.Cmm.CLabel-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply@@ -60,34 +74,16 @@  | otherwise = II64  --- | Instruction instance for powerpc-instance Instruction Instr where-        regUsageOfInstr         = ppc_regUsageOfInstr-        patchRegsOfInstr        = ppc_patchRegsOfInstr-        isJumpishInstr          = ppc_isJumpishInstr-        jumpDestsOfInstr        = ppc_jumpDestsOfInstr-        patchJumpInstr          = ppc_patchJumpInstr-        mkSpillInstr            = ppc_mkSpillInstr-        mkLoadInstr             = ppc_mkLoadInstr-        takeDeltaInstr          = ppc_takeDeltaInstr-        isMetaInstr             = ppc_isMetaInstr-        mkRegRegMoveInstr _     = ppc_mkRegRegMoveInstr-        takeRegRegMoveInstr     = ppc_takeRegRegMoveInstr-        mkJumpInstr             = ppc_mkJumpInstr-        mkStackAllocInstr       = ppc_mkStackAllocInstr-        mkStackDeallocInstr     = ppc_mkStackDeallocInstr---ppc_mkStackAllocInstr :: Platform -> Int -> [Instr]-ppc_mkStackAllocInstr platform amount-  = ppc_mkStackAllocInstr' platform (-amount)+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr platform amount+  = mkStackAllocInstr' platform (-amount) -ppc_mkStackDeallocInstr :: Platform -> Int -> [Instr]-ppc_mkStackDeallocInstr platform amount-  = ppc_mkStackAllocInstr' platform amount+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr platform amount+  = mkStackAllocInstr' platform amount -ppc_mkStackAllocInstr' :: Platform -> Int -> [Instr]-ppc_mkStackAllocInstr' platform amount+mkStackAllocInstr' :: Platform -> Int -> [Instr]+mkStackAllocInstr' platform amount   | fits16Bits amount   = [ LD fmt r0 (AddrRegImm sp zero)     , STU fmt r0 (AddrRegImm sp immAmount)@@ -313,8 +309,8 @@ -- The consequences of control flow transfers, as far as register -- allocation goes, are taken care of by the register allocator. ---ppc_regUsageOfInstr :: Platform -> Instr -> RegUsage-ppc_regUsageOfInstr platform instr+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr  = case instr of     LD      _ reg addr       -> usage (regAddr addr, [reg])     LDFAR   _ reg addr       -> usage (regAddr addr, [reg])@@ -406,8 +402,8 @@  -- | Apply a given mapping to all the register references in this -- instruction.-ppc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-ppc_patchRegsOfInstr instr env+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env  = case instr of     LD      fmt reg addr    -> LD fmt (env reg) (fixAddr addr)     LDFAR   fmt reg addr    -> LDFAR fmt (env reg) (fixAddr addr)@@ -497,8 +493,8 @@ -- | Checks whether this instruction is a jump/branch instruction. -- One that can change the flow of control in a way that the -- register allocator needs to worry about.-ppc_isJumpishInstr :: Instr -> Bool-ppc_isJumpishInstr instr+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr  = case instr of     BCC{}       -> True     BCCFAR{}    -> True@@ -512,8 +508,8 @@ -- | Checks whether this instruction is a jump/branch instruction. -- One that can change the flow of control in a way that the -- register allocator needs to worry about.-ppc_jumpDestsOfInstr :: Instr -> [BlockId]-ppc_jumpDestsOfInstr insn+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr insn   = case insn of         BCC _ id _       -> [id]         BCCFAR _ id _    -> [id]@@ -524,8 +520,8 @@ -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join -- points.-ppc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr-ppc_patchJumpInstr insn patchF+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr insn patchF   = case insn of         BCC cc id p     -> BCC cc (patchF id) p         BCCFAR cc id p  -> BCCFAR cc (patchF id) p@@ -536,14 +532,14 @@ -- -----------------------------------------------------------------------------  -- | An instruction to spill a register into a spill slot.-ppc_mkSpillInstr+mkSpillInstr    :: NCGConfig    -> Reg       -- register to spill    -> Int       -- current stack delta    -> Int       -- spill slot to use-   -> Instr+   -> [Instr] -ppc_mkSpillInstr config reg delta slot+mkSpillInstr config reg delta slot   = let platform = ncgPlatform config         off      = spillSlotToOffset platform slot         arch     = platformArch platform@@ -558,17 +554,17 @@                 Just _  -> ST                 Nothing -> STFAR -- pseudo instruction: 32 bit offsets -    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))+    in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))]  -ppc_mkLoadInstr+mkLoadInstr    :: NCGConfig    -> Reg       -- register to load    -> Int       -- current stack delta    -> Int       -- spill slot to use-   -> Instr+   -> [Instr] -ppc_mkLoadInstr config reg delta slot+mkLoadInstr config reg delta slot   = let platform = ncgPlatform config         off      = spillSlotToOffset platform slot         arch     = platformArch platform@@ -583,7 +579,7 @@                 Just _  -> LD                 Nothing -> LDFAR -- pseudo instruction: 32 bit offsets -    in instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))+    in [instr fmt reg (AddrRegImm sp (ImmInt (off-delta)))]   -- | The size of a minimal stackframe header including minimal@@ -629,21 +625,21 @@  -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta-ppc_takeDeltaInstr+takeDeltaInstr     :: Instr     -> Maybe Int -ppc_takeDeltaInstr instr+takeDeltaInstr instr  = case instr of      DELTA i  -> Just i      _        -> Nothing  -ppc_isMetaInstr+isMetaInstr     :: Instr     -> Bool -ppc_isMetaInstr instr+isMetaInstr instr  = case instr of     COMMENT{}   -> True     LOCATION{}  -> True@@ -655,29 +651,29 @@  -- | Copy the value in a register to another one. -- Must work for all register classes.-ppc_mkRegRegMoveInstr+mkRegRegMoveInstr     :: Reg     -> Reg     -> Instr -ppc_mkRegRegMoveInstr src dst+mkRegRegMoveInstr src dst     = MR dst src   -- | Make an unconditional jump instruction.-ppc_mkJumpInstr+mkJumpInstr     :: BlockId     -> [Instr] -ppc_mkJumpInstr id+mkJumpInstr id     = [BCC ALWAYS id Nothing]   -- | Take the source and destination from this reg -> reg move instruction -- or Nothing if it's not one-ppc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)-ppc_takeRegRegMoveInstr (MR dst src) = Just (src,dst)-ppc_takeRegRegMoveInstr _  = Nothing+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+takeRegRegMoveInstr (MR dst src) = Just (src,dst)+takeRegRegMoveInstr _  = Nothing  -- ----------------------------------------------------------------------------- -- Making far branches

GHC/CmmToAsm/PPC/Ppr.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}+ ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language@@ -6,8 +8,11 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.CmmToAsm.PPC.Ppr (pprNatCmmDecl) where+module GHC.CmmToAsm.PPC.Ppr+   ( pprNatCmmDecl+   , pprInstr+   )+where  import GHC.Prelude @@ -15,12 +20,13 @@ import GHC.CmmToAsm.PPC.Instr import GHC.CmmToAsm.PPC.Cond import GHC.CmmToAsm.Ppr-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format import GHC.Platform.Reg import GHC.Platform.Reg.Class import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils  import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Dataflow.Collections@@ -34,11 +40,10 @@ import GHC.Platform import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Driver.Session (targetPlatform)+import GHC.Utils.Panic  import Data.Word import Data.Int-import Data.Bits  -- ----------------------------------------------------------------------------- -- Printing this stuff out@@ -55,19 +60,20 @@          -- 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 ncgDebugLevel config > 0-          then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+         ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel lbl)+                                          <> char ':' $$+                                          pprProcEndLabel platform lbl) $$          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@@ -76,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 @@ -89,47 +95,52 @@    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 +pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name+                -> SDoc+pprProcEndLabel platform lbl =+    pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'+ pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr               -> SDoc pprBasicBlock config info_env (BasicBlock blockid instrs)   = maybe_infotable $$     pprLabel platform asmLbl $$     vcat (map (pprInstr platform) instrs) $$-    (if  ncgDebugLevel config > 0-      then ppr (mkAsmTempEndLabel asmLbl) <> char ':'-      else empty+    ppWhen (ncgDwarfEnabled config) (+      pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':'+      <> pprProcEndLabel platform asmLbl     )   where     asmLbl = blockLbl blockid@@ -145,15 +156,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@@ -163,32 +174,27 @@    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' -instance Outputable Instr where-    ppr instr = sdocWithDynFlags $ \dflags ->-                  pprInstr (targetPlatform dflags) instr-- pprReg :: Reg -> SDoc  pprReg r@@ -231,58 +237,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 _)  = text "naughty float immediate"-pprImm (ImmDouble _) = text "naughty double immediate"--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@@ -323,11 +313,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 =@@ -338,13 +328,8 @@                     <> int (fromIntegral (fromIntegral x :: Word32))]  -        ppr_item FF32 (CmmFloat r _)-           = let bs = floatToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs--        ppr_item FF64 (CmmFloat r _)-           = let bs = doubleToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+        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"@@ -408,7 +393,7 @@            char '\t',            pprReg reg,            text ", ",-           pprAddr addr+           pprAddr platform addr        ]     LDFAR fmt reg (AddrRegImm source off)@@ -430,7 +415,7 @@            text "arx\t",            pprReg reg1,            text ", ",-           pprAddr addr+           pprAddr platform addr            ]     LA fmt reg addr@@ -450,7 +435,7 @@            char '\t',            pprReg reg,            text ", ",-           pprAddr addr+           pprAddr platform addr            ]     ST fmt reg addr@@ -463,7 +448,7 @@            char '\t',            pprReg reg,            text ", ",-           pprAddr addr+           pprAddr platform addr            ]     STFAR fmt reg (AddrRegImm source off)@@ -485,7 +470,7 @@            char '\t',            pprReg reg,            text ", ",-           pprAddr addr+           pprAddr platform addr            ]     STC fmt reg1 addr@@ -498,7 +483,7 @@            text "cx.\t",            pprReg reg1,            text ", ",-           pprAddr addr+           pprAddr platform addr            ]     LIS reg imm@@ -508,7 +493,7 @@            char '\t',            pprReg reg,            text ", ",-           pprImm imm+           pprImm platform imm            ]     LI reg imm@@ -518,7 +503,7 @@            char '\t',            pprReg reg,            text ", ",-           pprImm imm+           pprImm platform imm            ]     MR reg1 reg2@@ -541,7 +526,7 @@            char '\t',            pprReg reg,            text ", ",-           pprRI ri+           pprRI platform ri            ]          where            op = hcat [@@ -559,7 +544,7 @@            char '\t',            pprReg reg,            text ", ",-           pprRI ri+           pprRI platform ri            ]           where               op = hcat [@@ -577,7 +562,7 @@            pprCond cond,            pprPrediction prediction,            char '\t',-           ppr lbl+           pdoc platform lbl            ]          where lbl = mkLocalBlockLabel (getUnique blockid)                pprPrediction p = case p of@@ -595,7 +580,7 @@            ],            hcat [                text "\tb\t",-               ppr lbl+               pdoc platform lbl            ]           ]           where lbl = mkLocalBlockLabel (getUnique blockid)@@ -612,7 +597,7 @@            char '\t',            text "b",            char '\t',-           ppr lbl+           pdoc platform lbl        ]     MTCTR reg@@ -643,12 +628,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 _@@ -658,7 +643,7 @@          ]     ADD reg1 reg2 ri-      -> pprLogic (sLit "add") reg1 reg2 ri+      -> pprLogic platform (sLit "add") reg1 reg2 ri     ADDIS reg1 reg2 imm       -> hcat [@@ -669,26 +654,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 [@@ -702,14 +687,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 [@@ -784,23 +769,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 [@@ -811,7 +796,7 @@             text ", ",             pprReg reg2,             text ", ",-            pprImm imm+            pprImm platform imm         ]     XORIS reg1 reg2 imm@@ -823,7 +808,7 @@             text ", ",             pprReg reg2,             text ", ",-            pprImm imm+            pprImm platform imm         ]     EXTS fmt reg1 reg2@@ -882,21 +867,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 [@@ -1026,8 +1011,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@@ -1038,12 +1023,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@@ -1057,7 +1042,7 @@         text ", ",         pprReg reg2,         text ", ",-        pprRI ri+        pprRI platform ri     ]  @@ -1103,9 +1088,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

GHC/CmmToAsm/PPC/Regs.hs view

@@ -62,6 +62,7 @@  import GHC.Platform.Regs import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import Data.Word        ( Word8, Word16, Word32, Word64 )

GHC/CmmToAsm/Ppr.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash #-}  ----------------------------------------------------------------------------- --@@ -9,9 +9,6 @@ -----------------------------------------------------------------------------  module GHC.CmmToAsm.Ppr (-        castFloatToWord8Array,-        castDoubleToWord8Array,-        floatToBytes,         doubleToBytes,         pprASCII,         pprString,@@ -29,6 +26,7 @@ import GHC.CmmToAsm.Config import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import qualified Data.Array.Unsafe as U ( castSTUArray )@@ -37,19 +35,24 @@ import Control.Monad.ST  import Data.Word-import Data.Bits import Data.ByteString (ByteString) import qualified Data.ByteString as BS import GHC.Exts import GHC.Word -+#if !MIN_VERSION_base(4,16,0)+word8ToWord# :: Word# -> Word#+word8ToWord# w = w+{-# INLINE word8ToWord# #-}+#endif  -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing -castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)-castFloatToWord8Array = U.castSTUArray+-- ToDo: this code is currently shared between SPARC and LLVM.+--       Similar functions for (single precision) floats are+--       present in the SPARC backend only. We need to fix both+--       LLVM and SPARC.  castDoubleToWord8Array :: STUArray s Int Double -> ST s (STUArray s Int Word8) castDoubleToWord8Array = U.castSTUArray@@ -62,19 +65,6 @@ -- ToDo: this stuff is very similar to the shenanigans in PprAbs, -- could they be merged? -floatToBytes :: Float -> [Int]-floatToBytes f-   = runST (do-        arr <- newArray_ ((0::Int),3)-        writeArray arr 0 f-        arr <- castFloatToWord8Array arr-        i0 <- readArray arr 0-        i1 <- readArray arr 1-        i2 <- readArray arr 2-        i3 <- readArray arr 3-        return (map fromIntegral [i0,i1,i2,i3])-     )- doubleToBytes :: Double -> [Int] doubleToBytes d    = runST (do@@ -118,7 +108,7 @@        -- we know that the Chars we create are in the ASCII range        -- so we bypass the check in "chr"        chr' :: Word8 -> Char-       chr' (W8# w#) = C# (chr# (word2Int# w#))+       chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#)))         octal :: Word8 -> String        octal w = [ chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)@@ -211,7 +201,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"

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@@ -17,11 +21,13 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Platform.Reg.Class import GHC.Platform.Reg  import GHC.Data.Bag import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique.Set@@ -44,7 +50,7 @@  -- | The top level of the graph coloring register allocator. regAlloc-        :: (Outputable statics, Outputable instr, 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.@@ -89,8 +95,7 @@ regAlloc_spin         :: forall instr statics.            (Instruction instr,-            Outputable instr,-            Outputable statics)+            OutputableP Platform statics)         => NCGConfig         -> Int  -- ^ Number of solver iterations we've already performed.         -> Color.Triv VirtualReg RegClass RealReg@@ -388,7 +393,7 @@  -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph-        :: (Outputable statics, Outputable instr, Instruction instr)+        :: (OutputableP Platform statics, Instruction instr)         => Platform -> Color.Graph VirtualReg RegClass RealReg         -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr @@ -413,7 +418,7 @@                 = pprPanic "patchRegsFromGraph: register mapping failed."                         (  text "There is no node in the graph for register "                                 <> ppr reg-                        $$ ppr code+                        $$ pprLiveCmmDecl platform code                         $$ Color.dotGraph                                 (\_ -> text "white")                                 (trivColorable platform

GHC/CmmToAsm/Reg/Graph/Base.hs view

@@ -27,6 +27,7 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Utils.Monad (concatMapM)  @@ -140,7 +141,7 @@ -- | The total squeese on a particular node with a list of neighbors. -- --   A version of this should be constructed for each particular architecture,---   possibly including uses of bound, so that alised registers don't get+--   possibly including uses of bound, so that aliased registers don't get --   counted twice, as per the paper. squeese :: (RegClass    -> UniqSet Reg)         -> (Reg         -> UniqSet Reg)

GHC/CmmToAsm/Reg/Graph/Spill.hs view

@@ -1,4 +1,3 @@- -- | When there aren't enough registers to hold all the vregs we have to spill --   some of those vregs to slots on the stack. This module is used modify the --   code to use those slots.@@ -7,6 +6,7 @@         SpillStats(..),         accSpillSL ) where+ import GHC.Prelude  import GHC.CmmToAsm.Reg.Liveness@@ -24,9 +24,10 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform -import Data.List+import Data.List (nub, (\\), intersect) import Data.Maybe import Data.IntSet              (IntSet) import qualified Data.IntSet    as IntSet@@ -181,46 +182,41 @@         -> UniqFM Reg Int -- ^ map of vregs to slots they're being spilled to.         -> LiveInstr instr         -> SpillM [LiveInstr instr]--regSpill_instr _ _ li@(LiveInstr _ Nothing)- = do   return [li]--regSpill_instr platform regSlotMap-        (LiveInstr instr (Just _))- = do-        -- work out which regs are read and written in this instr-        let RU rlRead rlWritten = regUsageOfInstr platform instr+regSpill_instr _ _ li@(LiveInstr _ Nothing) = return [li]+regSpill_instr platform regSlotMap (LiveInstr instr (Just _)) = do+  -- work out which regs are read and written in this instr+  let RU rlRead rlWritten = regUsageOfInstr platform instr -        -- sometimes a register is listed as being read more than once,-        --      nub this so we don't end up inserting two lots of spill code.-        let rsRead_             = nub rlRead-        let rsWritten_          = nub rlWritten+  -- sometimes a register is listed as being read more than once,+  --      nub this so we don't end up inserting two lots of spill code.+  let rsRead_             = nub rlRead+  let rsWritten_          = nub rlWritten -        -- if a reg is modified, it appears in both lists, want to undo this..-        let rsRead              = rsRead_    \\ rsWritten_-        let rsWritten           = rsWritten_ \\ rsRead_-        let rsModify            = intersect rsRead_ rsWritten_+  -- if a reg is modified, it appears in both lists, want to undo this..+  let rsRead              = rsRead_    \\ rsWritten_+  let rsWritten           = rsWritten_ \\ rsRead_+  let rsModify            = intersect rsRead_ rsWritten_ -        -- work out if any of the regs being used are currently being spilled.-        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead-        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten-        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify+  -- work out if any of the regs being used are currently being spilled.+  let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead+  let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten+  let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify -        -- rewrite the instr and work out spill code.-        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead-        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten-        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify+  -- rewrite the instr and work out spill code.+  (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead+  (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten+  (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify -        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)-        let prefixes                    = concat mPrefixes-        let postfixes                   = concat mPostfixes+  let (mPrefixes, mPostfixes) = unzip (prepost1 ++ prepost2 ++ prepost3)+  let prefixes                = concat mPrefixes+  let postfixes               = concat mPostfixes -        -- final code-        let instrs'     =  prefixes-                        ++ [LiveInstr instr3 Nothing]-                        ++ postfixes+  -- final code+  let instrs' =  prefixes+              ++ [LiveInstr instr3 Nothing]+              ++ postfixes -        return $ instrs'+  return instrs'   -- | Add a RELOAD met a instruction to load a value for an instruction that

GHC/CmmToAsm/Reg/Graph/SpillClean.hs view

@@ -44,12 +44,14 @@ import GHC.Types.Unique.Set import GHC.Types.Unique.FM import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Utils.Monad.State import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Cmm.Dataflow.Collections -import Data.List+import Data.List (nub, foldl1', find) import Data.Maybe import Data.IntSet              (IntSet) import qualified Data.IntSet    as IntSet

GHC/CmmToAsm/Reg/Graph/SpillCost.hs view

@@ -1,4 +1,6 @@-{-# LANGUAGE ScopedTypeVariables, GADTs, BangPatterns #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module GHC.CmmToAsm.Reg.Graph.SpillCost (         SpillCostRecord,         plusSpillCostRecord,@@ -29,6 +31,7 @@ import GHC.Types.Unique.Set import GHC.Data.Graph.Directed          (flattenSCCs) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Utils.Monad.State import GHC.CmmToAsm.CFG@@ -75,7 +78,7 @@ --   For each vreg, the number of times it was written to, read from, --   and the number of instructions it was live on entry to (lifetime) ---slurpSpillCostInfo :: forall instr statics. (Outputable instr, Instruction instr)+slurpSpillCostInfo :: forall instr statics. Instruction instr                    => Platform                    -> Maybe CFG                    -> LiveCmmDecl statics instr@@ -115,7 +118,7 @@                  | otherwise                 = pprPanic "RegSpillCost.slurpSpillCostInfo"-                $ text "no liveness information on instruction " <> ppr instr+                $ text "no liveness information on instruction " <> pprInstr platform instr          countLIs scale rsLiveEntry (LiveInstr instr (Just live) : lis)          = do

GHC/CmmToAsm/Reg/Graph/Stats.hs view

@@ -1,5 +1,9 @@-{-# LANGUAGE BangPatterns, CPP #-}+{-# LANGUAGE BangPatterns, CPP, DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Carries interesting info for debugging / profiling of the@@ -23,15 +27,17 @@ import GHC.CmmToAsm.Reg.Graph.Spill import GHC.CmmToAsm.Reg.Graph.SpillCost import GHC.CmmToAsm.Reg.Graph.TrivColorable-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg.Class-import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types+ import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class -import GHC.Utils.Outputable import GHC.Types.Unique.FM import GHC.Types.Unique.Set+import GHC.Utils.Outputable import GHC.Utils.Monad.State  -- | Holds interesting statistics from the register allocator.@@ -112,15 +118,16 @@           -- | Target platform         , raPlatform    :: !Platform         }+        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@@ -135,7 +142,7 @@            text "#  Spill"          $$ text "#  Code with liveness information."-        $$ ppr (raCode s)+        $$ pdoc (raPlatform s) (raCode s)         $$ text ""          $$ (if (not $ isNullUFM $ raCoalesced s)@@ -149,14 +156,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)."@@ -175,19 +182,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)

GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view

@@ -115,11 +115,15 @@                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 15                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> panic "trivColorable ArchAArch64"+                            -- We should be able to allocate *a lot* more in princple.+                            -- essentially all 32 - SP, so 31, we'd trash the link reg+                            -- as well as the platform and all others though.+                            ArchAArch64   -> 18                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"                             ArchS390X     -> panic "trivColorable ArchS390X"+                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER@@ -146,11 +150,15 @@                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 0                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> panic "trivColorable ArchAArch64"+                            -- we can in princple address all the float regs as+                            -- segments. So we could have 64 Float regs. Or+                            -- 128 Half regs, or even 256 Byte regs.+                            ArchAArch64   -> 0                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"                             ArchS390X     -> panic "trivColorable ArchS390X"+                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT@@ -179,11 +187,12 @@                             ArchSPARC64   -> panic "trivColorable ArchSPARC64"                             ArchPPC_64 _  -> 20                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> panic "trivColorable ArchAArch64"+                            ArchAArch64   -> 32                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"                             ArchS390X     -> panic "trivColorable ArchS390X"+                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE

GHC/CmmToAsm/Reg/Linear.hs view

@@ -113,16 +113,19 @@ import GHC.CmmToAsm.Reg.Linear.FreeRegs import GHC.CmmToAsm.Reg.Linear.Stats import GHC.CmmToAsm.Reg.Linear.JoinToTargets-import qualified GHC.CmmToAsm.Reg.Linear.PPC    as PPC-import qualified GHC.CmmToAsm.Reg.Linear.SPARC  as SPARC-import qualified GHC.CmmToAsm.Reg.Linear.X86    as X86-import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64+import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC+import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC+import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86+import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64+import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Reg.Utils import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types import GHC.Platform.Reg+import GHC.Platform.Reg.Class (RegClass(..))  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -134,10 +137,11 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import Data.Maybe-import Data.List+import Data.List (partition, nub) import Control.Monad  -- -----------------------------------------------------------------------------@@ -145,7 +149,7 @@  -- Allocate registers regAlloc-        :: (Outputable instr, Instruction instr)+        :: Instruction instr         => NCGConfig         -> LiveCmmDecl statics instr         -> UniqSM ( NatCmmDecl statics instr@@ -169,18 +173,18 @@         | LiveInfo info entry_ids@(first_id:_) block_live _ <- static         = do                 -- do register allocation on each component.-                (final_blocks, stats, stack_use)+                !(!final_blocks, !stats, !stack_use)                         <- linearRegAlloc config entry_ids block_live sccs                  -- make sure the block that was first in the input list                 --      stays at the front of the output-                let ((first':_), rest')+                let !(!(!first':_), !rest')                                 = partition ((== first_id) . blockId) final_blocks                  let max_spill_slots = maxSpillSlots config                     extra_stack                       | stack_use > max_spill_slots-                      = Just (stack_use - max_spill_slots)+                      = Just $! stack_use - max_spill_slots                       | otherwise                       = Nothing @@ -202,7 +206,7 @@ --   an entry in the block map or it is the first block. -- linearRegAlloc-        :: (Outputable instr, Instruction instr)+        :: forall instr. (Instruction instr)         => NCGConfig         -> [BlockId] -- ^ entry points         -> BlockMap RegSet@@ -220,21 +224,24 @@       ArchSPARC64    -> panic "linearRegAlloc ArchSPARC64"       ArchPPC        -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)       ArchARM _ _ _  -> panic "linearRegAlloc ArchARM"-      ArchAArch64    -> panic "linearRegAlloc ArchAArch64"+      ArchAArch64    -> go $ (frInitFreeRegs platform :: AArch64.FreeRegs)       ArchPPC_64 _   -> go $ (frInitFreeRegs platform :: PPC.FreeRegs)       ArchAlpha      -> panic "linearRegAlloc ArchAlpha"       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"+      ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"       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  -- | Constraints on the instruction instances used by the -- linear allocator. type OutputableRegConstraint freeRegs instr =-        (FR freeRegs, Outputable freeRegs, Outputable instr, Instruction instr)+        (FR freeRegs, Outputable freeRegs, Instruction instr)  linearRegAlloc'         :: OutputableRegConstraint freeRegs instr@@ -271,7 +278,7 @@  linearRA_SCCs entry_ids block_live blocksAcc (CyclicSCC blocks : sccs)  = do-        blockss' <- process entry_ids block_live blocks [] (return []) False+        blockss' <- process entry_ids block_live blocks         linearRA_SCCs entry_ids block_live                 (reverse (concat blockss') ++ blocksAcc)                 sccs@@ -288,45 +295,41 @@    more sanity checking to guard against this eventuality. -} -process :: OutputableRegConstraint freeRegs instr+process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)         => [BlockId]         -> BlockMap RegSet         -> [GenBasicBlock (LiveInstr instr)]-        -> [GenBasicBlock (LiveInstr instr)]-        -> [[NatBasicBlock instr]]-        -> Bool         -> RegM freeRegs [[NatBasicBlock instr]]--process _ _ [] []         accum _-        = return $ reverse accum--process entry_ids block_live [] next_round accum madeProgress-        | not madeProgress+process entry_ids block_live =+    \blocks -> go blocks [] (return []) False+  where+    go :: [GenBasicBlock (LiveInstr instr)]+       -> [GenBasicBlock (LiveInstr instr)]+       -> [[NatBasicBlock instr]]+       -> Bool+       -> RegM freeRegs [[NatBasicBlock instr]]+    go [] []         accum _madeProgress+      = return $ reverse accum +    go [] next_round accum madeProgress+      | not madeProgress           {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming.              pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out."                 (  text "Unreachable blocks:"                 $$ vcat (map ppr next_round)) -}-        = return $ reverse accum--        | otherwise-        = process entry_ids block_live-                  next_round [] accum False+      = return $ reverse accum -process entry_ids block_live (b@(BasicBlock id _) : blocks)-        next_round accum madeProgress- = do-        block_assig <- getBlockAssigR+      | otherwise+      = go next_round [] accum False -        if isJust (lookupBlockAssignment id block_assig)-             || id `elem` entry_ids-         then do-                b'  <- processBlock block_live b-                process entry_ids block_live blocks-                        next_round (b' : accum) True+    go (b@(BasicBlock id _) : blocks) next_round accum madeProgress+      = do+          block_assig <- getBlockAssigR+          if isJust (lookupBlockAssignment id block_assig) || id `elem` entry_ids+            then do b' <- processBlock block_live b+                    go blocks next_round (b' : accum) True -         else   process entry_ids block_live blocks-                        (b : next_round) accum madeProgress+            else do go blocks (b : next_round) accum madeProgress   -- | Do register allocation on this basic block@@ -342,7 +345,7 @@         initBlock id block_live          (instrs', fixups)-                <- linearRA block_live [] [] id instrs+                <- linearRA block_live id instrs         -- pprTraceM "blockResult" $ ppr (instrs', fixups)         return  $ BasicBlock id instrs' : fixups @@ -379,30 +382,28 @@  -- | Do allocation for a sequence of instructions. linearRA-        :: OutputableRegConstraint freeRegs instr+        :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)         => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.-        -> [instr]                              -- ^ accumulator for instructions already processed.-        -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.         -> BlockId                              -- ^ id of the current block, for debugging.         -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.-         -> RegM freeRegs                 ( [instr]                       --   instructions after register allocation                 , [NatBasicBlock instr])        --   fresh blocks of fixup code.---linearRA _          accInstr accFixup _ []-        = return-                ( reverse accInstr              -- instrs need to be returned in the correct order.-                , accFixup)                     -- it doesn't matter what order the fixup blocks are returned in.---linearRA block_live accInstr accFixups id (instr:instrs)- = do-        (accInstr', new_fixups) <- raInsn block_live accInstr id instr--        linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs+linearRA block_live block_id = go [] []+  where+    go :: [instr]                              -- ^ accumulator for instructions already processed.+       -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.+       -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.+       -> RegM freeRegs+               ( [instr]                       --   instructions after register allocation+               , [NatBasicBlock instr] )       --   fresh blocks of fixup code.+    go !accInstr !accFixups [] = do+        return ( reverse accInstr               -- instrs need to be returned in the correct order.+               , accFixups )                    -- it doesn't matter what order the fixup blocks are returned in. +    go accInstr accFixups (instr:instrs) = do+        (accInstr', new_fixups) <- raInsn block_live accInstr block_id instr+        go accInstr' (new_fixups ++ accFixups) instrs  -- | Do allocation for a single instruction. raInsn@@ -466,7 +467,10 @@                         -- See Note [Unique Determinism and code generation]  raInsn _ _ _ instr-        = pprPanic "raInsn" (text "no match for:" <> ppr instr)+        = do+            platform <- getPlatform+            let instr' = fmap (pprInstr platform) instr+            pprPanic "raInsn" (text "no match for:" <> ppr instr')  -- ToDo: what can we do about --@@ -487,7 +491,7 @@   genRaInsn :: forall freeRegs instr.-             OutputableRegConstraint freeRegs instr+             (OutputableRegConstraint freeRegs instr)           => BlockMap RegSet           -> [instr]           -> BlockId@@ -497,7 +501,7 @@           -> RegM freeRegs ([instr], [NatBasicBlock instr])  genRaInsn block_live new_instrs block_id instr r_dying w_dying = do---   pprTraceM "genRaInsn" $ ppr (block_id, instr)+-- pprTraceM "genRaInsn" $ ppr (block_id, instr)   platform <- getPlatform   case regUsageOfInstr platform instr of { RU read written ->     do@@ -509,20 +513,21 @@     -- so using nub isn't a problem).     let virt_read       = nub [ vr      | (RegVirtual vr) <- read ] :: [VirtualReg] -    -- debugging-{-    freeregs <- getFreeRegsR-    assig    <- getAssigR-    pprDebugAndThen (defaultDynFlags Settings{ sTargetPlatform=platform } undefined) trace "genRaInsn"-        (ppr instr-                $$ text "r_dying      = " <+> ppr r_dying-                $$ text "w_dying      = " <+> ppr w_dying-                $$ text "virt_read    = " <+> ppr virt_read-                $$ text "virt_written = " <+> ppr virt_written-                $$ text "freeregs     = " <+> text (show freeregs)-                $$ text "assig        = " <+> ppr assig)-        $ do--}+--     do+--         let real_read       = nub [ rr      | (RegReal rr) <- read]+--         freeregs <- getFreeRegsR+--         assig    <- getAssigR +--         pprTraceM "genRaInsn"+--                 (          text "block        = " <+> ppr block_id+--                         $$ text "instruction  = " <+> ppr instr+--                         $$ text "r_dying      = " <+> ppr r_dying+--                         $$ text "w_dying      = " <+> ppr w_dying+--                         $$ text "read         = " <+> ppr real_read    <+> ppr virt_read+--                         $$ text "written      = " <+> ppr real_written <+> ppr virt_written+--                         $$ text "freeregs     = " <+> ppr freeregs+--                         $$ text "assign       = " <+> ppr assig)+     -- (a), (b) allocate real regs for all regs read by this instruction.     (r_spills, r_allocd) <-         allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read@@ -580,7 +585,6 @@                         Nothing -> x                         Just y  -> y -     -- (j) free up stack slots for dead spilled regs     -- TODO (can't be bothered right now) @@ -592,9 +596,33 @@                                  | src == dst   -> []                                 _               -> [patched_instr] -    let code = squashed_instr ++ w_spills ++ reverse r_spills-                ++ clobber_saves ++ new_instrs+    -- On the use of @reverse@ below.+    -- Since we can have spills and reloads produce multiple instructions+    -- we need to ensure they are emitted in the correct order.  We used to only+    -- emit single instructions in mkSpill/mkReload/mkRegRegMove.+    -- As such order of spills and reloads didn't matter.  However,  with+    -- mutliple instructions potentially issued by those functions we need to be+    -- careful to not break execution order. Reversing the spills (clobber will+    -- also spill), will ensure they are emitted in the right order.+    --+    -- See also Ticket 19910 for changing the return type from [] to OrdList. +    -- For debugging, uncomment the follow line and the mkComment lines.+    -- u <- getUniqueR+    let code = concat [ --  mkComment (text "<genRaInsn(" <> ppr u <> text ")>")+                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):squashed>")]+                        squashed_instr+                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):w_spills>")+                      , reverse w_spills+                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):r_spills>")+                      , reverse r_spills+                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):clobber_saves>")+                      , reverse clobber_saves+                        -- ,mkComment (text "<genRaInsn(" <> ppr u <> text "):new_instrs>")+                      , new_instrs+                        -- ,mkComment (text "</genRaInsn(" <> ppr u <> text ")>")+                      ]+ --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do --    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do @@ -610,6 +638,7 @@   platform <- getPlatform   assig <- getAssigR   free <- getFreeRegsR+   let loop assig !free [] = do setAssigR assig; setFreeRegsR free; return ()       loop assig !free (RegReal rr : rs) = loop assig (frReleaseReg platform rr free) rs       loop assig !free (r:rs) =@@ -663,8 +692,9 @@          (instrs,assig') <- clobber assig [] to_spill         setAssigR assig'-        return instrs-+        return $ -- mkComment (text "<saveClobberedTemps>") +++                 instrs+--              ++ mkComment (text "</saveClobberedTemps>")    where      -- See Note [UniqFM and the register allocator]      clobber :: RegMap Loc -> [instr] -> [(Unique,RealReg)] -> RegM freeRegs ([instr], RegMap Loc)@@ -701,7 +731,7 @@                    let new_assign  = addToUFM_Directly assig temp (InBoth reg slot) -                  clobber new_assign (spill : instrs) rest+                  clobber new_assign (spill ++ instrs) rest   @@ -715,8 +745,18 @@ clobberRegs clobbered  = do   platform <- getPlatform         freeregs <- getFreeRegsR-        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered +        let gpRegs  = frGetFreeRegs platform RcInteger freeregs :: [RealReg]+            fltRegs = frGetFreeRegs platform RcFloat   freeregs :: [RealReg]+            dblRegs = frGetFreeRegs platform RcDouble  freeregs :: [RealReg]++        let extra_clobbered = [ r | r <- clobbered+                                  , r `elem` (gpRegs ++ fltRegs ++ dblRegs) ]++        setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered++        -- setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs clobbered+         assig           <- getAssigR         setAssigR $! clobber assig (nonDetUFMToList assig)           -- This is non-deterministic but we do not@@ -762,7 +802,7 @@ --   the list of free registers and free stack slots.  allocateRegsAndSpill-        :: forall freeRegs instr. (FR freeRegs, Outputable instr, Instruction instr)+        :: forall freeRegs instr. (FR freeRegs, Instruction instr)         => Bool                 -- True <=> reading (load up spilled regs)         -> [VirtualReg]         -- don't push these out         -> [instr]              -- spill insns@@ -820,7 +860,7 @@  -- reading is redundant with reason, but we keep it around because it's -- convenient and it maintains the recursive structure of the allocator. -- EZY-allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)                         => Bool                         -> [VirtualReg]                         -> [instr]@@ -841,7 +881,7 @@         case freeRegs_thisClass of          -- case (2): we have a free register          (first_free : _) ->-           do   let final_reg+           do   let !final_reg                         | Just reg <- pref_reg                         , reg `elem` freeRegs_thisClass                         = reg@@ -902,10 +942,7 @@                         | (temp_to_push_out, (my_reg :: RealReg)) : _                                         <- candidates_inReg                         = do-                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out-                                let spill_store  = (if reading then id else reverse)-                                                        [ -- COMMENT (fsLit "spill alloc")-                                                           spill_insn ]+                                (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out                                  -- record that this temp was spilled                                 recordSpill (SpillAlloc temp_to_push_out)@@ -955,8 +992,7 @@  = do         insn <- loadR (RegReal hreg) slot         recordSpill (SpillLoad $ getUnique vreg)-        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills+        return  $  {- mkComment (text "spill load") : -} insn ++ spills  loadTemp _ _ _ spills =    return spills-

+ GHC/CmmToAsm/Reg/Linear/AArch64.hs view

@@ -0,0 +1,137 @@+module GHC.CmmToAsm.Reg.Linear.AArch64 where++import GHC.Prelude++import GHC.CmmToAsm.AArch64.Regs+import GHC.Platform.Reg.Class+import GHC.Platform.Reg++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Platform++import Data.Word++import GHC.Stack+-- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp+-- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON+-- extension in Armv8-A.+--+-- Armv8-A is a fundamental change to the Arm architecture. It supports the+-- 64-bit Execution state called “AArch64”, and a new 64-bit instruction set+-- “A64”. To provide compatibility with the Armv7-A (32-bit architecture)+-- instruction set, a 32-bit variant of Armv8-A “AArch32” is provided. Most of+-- existing Armv7-A code can be run in the AArch32 execution state of Armv8-A.+--+-- these can be addresses as q/d/s/h/b 0..31, or v.f<size>[idx]+-- where size is 64, 32, 16, 8, ... and the index i allows us+-- to access the given part.+--+-- History of Arm Adv SIMD+-- .---------------------------------------------------------------------------.+-- | Armv6                  | Armv7-A                | Armv8-A AArch64         |+-- | SIMD extension         | NEON                   | NEON                    |+-- |===========================================================================|+-- | - Operates on 32-bit   | - Separate reg. bank,  | - Separate reg. bank,   |+-- |   GP ARM registers     |    32x64-bit NEON regs |   32x128-bit NEON regs  |+-- | - 8-bit/16-bit integer | - 8/16/32/64-bit int   | - 8/16/32/64-bit int    |+-- |                        | - Single percision fp  | - Single percision fp   |+-- |                        |                        | - Double precision fp   |+-- |                        |                        | - Single/Double fp are  |+-- |                        |                        |   IEEE compliant        |+-- | - 2x16-bit/4x8-bit ops | - Up to 16x8-bit ops   | - Up to 16x8-bit ops    |+-- |   per instruction      |   per instruction      |   per instruction       |+-- '---------------------------------------------------------------------------'++data FreeRegs = FreeRegs !Word32 !Word32++instance Show FreeRegs where+  show (FreeRegs g f) = "FreeRegs: " ++ showBits g ++ "; " ++ showBits f++instance Outputable FreeRegs where+    ppr (FreeRegs g f) = text "   " <+> foldr (\i x -> pad_int i    <+> x) (text "") [0..31]+                      $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0..31]+                      $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0..31]+      where pad_int i | i < 10 = char ' ' <> int i+            pad_int i = int i+            -- remember bit = 1 means it's available.+            show_bit bits bit | testBit bits bit = text "  "+            show_bit _    _ = text " x"++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0++showBits :: Word32 -> String+showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]++-- FR instance implementation (See Linear.FreeRegs)+allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs g f)+    | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))+    | r < 32 && testBit g r = FreeRegs (clearBit g r) f+    | r > 31 = panic $ "Linear.AArch64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+    | otherwise = pprPanic "Linear.AArch64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)+allocateReg _ _ = panic "Linear.AArch64.allocReg: bad reg"++-- we start from 28 downwards... the logic is similar to the ppc logic.+-- 31 is Stack Pointer+-- 30 is Link Register+-- 29 is Stack Frame (by convention)+-- 19-28 are callee save+-- the lower ones are all caller save++-- For this reason someone decided to give aarch64 only 6 regs for+-- STG:+-- 19: Base+-- 20: Sp+-- 21: Hp+-- 22-27: R1-R6+-- 28: SpLim++-- For LLVM code gen interop:+-- See https://lists.llvm.org/pipermail/llvm-commits/Week-of-Mon-20150119/253722.html+-- and the current ghccc implementation here:+-- https://github.com/llvm/llvm-project/blob/161ae1f39816edf667aaa190bce702a86879c7bd/llvm/lib/Target/AArch64/AArch64CallingConvention.td#L324-L363+-- and https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/generated-code+-- for the STG discussion.+{- For reference the ghcc from the link above:+let Entry = 1 in+def CC_AArch64_GHC : CallingConv<[+  CCIfType<[iPTR], CCBitConvertToType<i64>>,++  // Handle all vector types as either f64 or v2f64.+  CCIfType<[v1i64, v2i32, v4i16, v8i8, v2f32], CCBitConvertToType<f64>>,+  CCIfType<[v2i64, v4i32, v8i16, v16i8, v4f32, f128], CCBitConvertToType<v2f64>>,++  CCIfType<[v2f64], CCAssignToReg<[Q4, Q5]>>,+  CCIfType<[f32], CCAssignToReg<[S8, S9, S10, S11]>>,+  CCIfType<[f64], CCAssignToReg<[D12, D13, D14, D15]>>,++  // Promote i8/i16/i32 arguments to i64.+  CCIfType<[i8, i16, i32], CCPromoteToType<i64>>,++  // Pass in STG registers: Base, Sp, Hp, R1, R2, R3, R4, R5, R6, SpLim+  CCIfType<[i64], CCAssignToReg<[X19, X20, X21, X22, X23, X24, X25, X26, X27, X28]>>+]>;+-}++getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f)+  | RcFloat   <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted.+  | RcDouble  <- cls = go 32 f 31+  | RcInteger <- cls = go  0 g 18+    where+        go _   _ i | i < 0 = []+        go off x i | testBit x i = RealRegSingle (off + i) : (go off x $! i - 1)+                   | otherwise   = go off x $! i - 1++initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text  "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)+  | r > 31 = FreeRegs g (setBit f (r - 32))+  | otherwise = FreeRegs (setBit g r) f+releaseReg _ _ = pprPanic "Linear.AArch64.releaseReg" (text "bad reg")

GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view

@@ -30,14 +30,16 @@ --      getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f --      allocateReg f r = filter (/= r) f -import qualified GHC.CmmToAsm.Reg.Linear.PPC    as PPC-import qualified GHC.CmmToAsm.Reg.Linear.SPARC  as SPARC-import qualified GHC.CmmToAsm.Reg.Linear.X86    as X86-import qualified GHC.CmmToAsm.Reg.Linear.X86_64 as X86_64+import qualified GHC.CmmToAsm.Reg.Linear.PPC     as PPC+import qualified GHC.CmmToAsm.Reg.Linear.SPARC   as SPARC+import qualified GHC.CmmToAsm.Reg.Linear.X86     as X86+import qualified GHC.CmmToAsm.Reg.Linear.X86_64  as X86_64+import qualified GHC.CmmToAsm.Reg.Linear.AArch64 as AArch64 -import qualified GHC.CmmToAsm.PPC.Instr   as PPC.Instr-import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr-import qualified GHC.CmmToAsm.X86.Instr   as X86.Instr+import qualified GHC.CmmToAsm.PPC.Instr     as PPC.Instr+import qualified GHC.CmmToAsm.SPARC.Instr   as SPARC.Instr+import qualified GHC.CmmToAsm.X86.Instr     as X86.Instr+import qualified GHC.CmmToAsm.AArch64.Instr as AArch64.Instr  class Show freeRegs => FR freeRegs where     frAllocateReg :: Platform -> RealReg -> freeRegs -> freeRegs@@ -63,6 +65,12 @@     frInitFreeRegs = PPC.initFreeRegs     frReleaseReg   = \_ -> PPC.releaseReg +instance FR AArch64.FreeRegs where+    frAllocateReg = \_ -> AArch64.allocateReg+    frGetFreeRegs = \_ -> AArch64.getFreeRegs+    frInitFreeRegs = AArch64.initFreeRegs+    frReleaseReg = \_ -> AArch64.releaseReg+ instance FR SPARC.FreeRegs where     frAllocateReg  = SPARC.allocateReg     frGetFreeRegs  = \_ -> SPARC.getFreeRegs@@ -78,10 +86,11 @@    ArchSPARC     -> SPARC.Instr.maxSpillSlots config    ArchSPARC64   -> panic "maxSpillSlots ArchSPARC64"    ArchARM _ _ _ -> panic "maxSpillSlots ArchARM"-   ArchAArch64   -> panic "maxSpillSlots ArchAArch64"+   ArchAArch64   -> AArch64.Instr.maxSpillSlots config    ArchPPC_64 _  -> PPC.Instr.maxSpillSlots config    ArchAlpha     -> panic "maxSpillSlots ArchAlpha"    ArchMipseb    -> panic "maxSpillSlots ArchMipseb"    ArchMipsel    -> panic "maxSpillSlots ArchMipsel"+   ArchRISCV64   -> panic "maxSpillSlots ArchRISCV64"    ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"    ArchUnknown   -> panic "maxSpillSlots ArchUnknown"

GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view

@@ -18,12 +18,15 @@ import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+ import GHC.Platform.Reg  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections import GHC.Data.Graph.Directed-import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Monad (concatMapM) import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set@@ -32,7 +35,7 @@ --      vregs are in the correct regs for its destination. -- joinToTargets-        :: (FR freeRegs, Instruction instr, Outputable instr)+        :: (FR freeRegs, Instruction instr)         => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs                                         --      that are known to be live on the entry to each block. @@ -56,7 +59,7 @@  ----- joinToTargets'-        :: (FR freeRegs, Instruction instr, Outputable instr)+        :: (FR freeRegs, Instruction instr)         => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs                                         --      that are known to be live on the entry to each block. @@ -110,7 +113,7 @@   -- this is the first time we jumped to this block.-joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)+joinToTargets_first :: (FR freeRegs, Instruction instr)                     => BlockMap RegSet                     -> [NatBasicBlock instr]                     -> BlockId@@ -139,7 +142,7 @@   -- we've jumped to this block before-joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)+joinToTargets_again :: (Instruction instr, FR freeRegs)                     => BlockMap RegSet                     -> [NatBasicBlock instr]                     -> BlockId@@ -304,7 +307,7 @@ --      go via a spill slot. -- handleComponent delta _  (AcyclicSCC (DigraphNode vreg src dsts))-        = mapM (makeMove delta vreg src) dsts+        = concatMapM (makeMove delta vreg src) dsts   -- Handle some cyclic moves.@@ -338,7 +341,7 @@          -- make sure to do all the reloads after all the spills,         --      so we don't end up clobbering the source values.-        return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad])+        return (instrSpill ++ concat remainingFixUps ++ instrLoad)  handleComponent _ _ (CyclicSCC _)  = panic "Register Allocator: handleComponent cyclic"@@ -352,7 +355,7 @@     -> Unique   -- ^ unique of the vreg that we're moving.     -> Loc      -- ^ source location.     -> Loc      -- ^ destination location.-    -> RegM freeRegs instr  -- ^ move instruction.+    -> RegM freeRegs [instr]  -- ^ move instruction.  makeMove delta vreg src dst  = do config <- getConfig@@ -361,7 +364,7 @@       case (src, dst) of           (InReg s, InReg d) ->               do recordSpill (SpillJoinRR vreg)-                 return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)+                 return $ [mkRegRegMoveInstr platform (RegReal s) (RegReal d)]           (InMem s, InReg d) ->               do recordSpill (SpillJoinRM vreg)                  return $ mkLoadInstr config (RegReal d) delta s@@ -375,4 +378,3 @@               panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("                   ++ show dst ++ ")"                   ++ " we don't handle mem->mem moves.")-

GHC/CmmToAsm/Reg/Linear/PPC.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}- -- | Free regs map for PowerPC module GHC.CmmToAsm.Reg.Linear.PPC where @@ -10,10 +8,10 @@ import GHC.Platform.Reg  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import Data.Word-import Data.Bits  -- The PowerPC has 32 integer and 32 floating point registers. -- This is 32bit PowerPC, so Word64 is inefficient - two Word32s are much@@ -48,9 +46,9 @@  getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily getFreeRegs cls (FreeRegs g f)+    | RcFloat <- cls = [] -- no float regs on PowerPC, use double     | RcDouble <- cls = go f (0x80000000) 63     | RcInteger <- cls = go g (0x80000000) 31-    | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class" (ppr cls)     where         go _ 0 _ = []         go x m i | x .&. m /= 0 = RealRegSingle i : (go x (m `shiftR` 1) $! i-1)

GHC/CmmToAsm/Reg/Linear/SPARC.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Free regs map for SPARC module GHC.CmmToAsm.Reg.Linear.SPARC where@@ -12,10 +11,10 @@  import GHC.Platform.Regs import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import Data.Word-import Data.Bits   --------------------------------------------------------------------------------

GHC/CmmToAsm/Reg/Linear/State.hs view

@@ -1,9 +1,6 @@ {-# LANGUAGE CPP, PatternSynonyms, DeriveFunctor #-} {-# LANGUAGE ScopedTypeVariables #-}--#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}-#endif  -- | State monad for the linear register allocator. @@ -56,21 +53,12 @@  import Control.Monad (ap) --- Avoids using unboxed tuples when loading into GHCi-#if !defined(GHC_LOADED_INTO_GHCI)- type RA_Result freeRegs a = (# RA_State freeRegs, a #)  pattern RA_Result :: a -> b -> (# a, b #) pattern RA_Result a b = (# a, b #) {-# COMPLETE RA_Result #-}-#else -data RA_Result freeRegs a = RA_Result {-# UNPACK #-} !(RA_State freeRegs) !a-  deriving (Functor)--#endif- -- | The register allocator monad type. newtype RegM freeRegs a         = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }@@ -127,7 +115,7 @@   spillR :: Instruction instr-       => Reg -> Unique -> RegM freeRegs (instr, Int)+       => Reg -> Unique -> RegM freeRegs ([instr], Int)  spillR reg temp = RegM $ \s ->   let (stack1,slot) = getStackSlotFor (ra_stack s) temp@@ -137,7 +125,7 @@   loadR :: Instruction instr-      => Reg -> Int -> RegM freeRegs instr+      => Reg -> Int -> RegM freeRegs [instr]  loadR reg slot = RegM $ \s ->   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)

GHC/CmmToAsm/Reg/Linear/Stats.hs view

@@ -12,10 +12,11 @@ import GHC.CmmToAsm.Reg.Liveness import GHC.CmmToAsm.Instr import GHC.Types.Unique (Unique)+import GHC.CmmToAsm.Types  import GHC.Types.Unique.FM-import GHC.Utils.Outputable +import GHC.Utils.Outputable import GHC.Utils.Monad.State  -- | Build a map of how many times each reg was alloced, clobbered, loaded etc.

GHC/CmmToAsm/Reg/Linear/X86.hs view

@@ -13,7 +13,6 @@ import GHC.Utils.Outputable  import Data.Word-import Data.Bits  newtype FreeRegs = FreeRegs Word32     deriving (Show,Outputable)

GHC/CmmToAsm/Reg/Linear/X86_64.hs view

@@ -13,7 +13,6 @@ import GHC.Utils.Outputable  import Data.Word-import Data.Bits  newtype FreeRegs = FreeRegs Word64     deriving (Show,Outputable)

GHC/CmmToAsm/Reg/Liveness.hs view

@@ -2,7 +2,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -----------------------------------------------------------------------------@@ -26,6 +30,7 @@          mapBlockTop,    mapBlockTopM,   mapSCCM,         mapGenBlockTop, mapGenBlockTopM,+        mapLiveCmmDecl, pprLiveCmmDecl,         stripLive,         stripLiveBlock,         slurpConflicts,@@ -43,6 +48,8 @@ import GHC.CmmToAsm.Instr import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils  import GHC.Cmm.BlockId import GHC.Cmm.Dataflow.Collections@@ -52,6 +59,7 @@ import GHC.Data.Graph.Directed import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM@@ -59,7 +67,7 @@ import GHC.Data.Bag import GHC.Utils.Monad.State -import Data.List+import Data.List (mapAccumL, groupBy, partition) import Data.Maybe import Data.IntSet              (IntSet) @@ -105,6 +113,8 @@         -- | reload this reg from a stack slot         | RELOAD Int Reg +        deriving (Functor)+ instance Instruction instr => Instruction (InstrSR instr) where         regUsageOfInstr platform i          = case i of@@ -162,10 +172,15 @@         mkStackDeallocInstr platform amount =              Instr <$> mkStackDeallocInstr platform amount +        pprInstr platform i = ppr (fmap (pprInstr platform) i) +        mkComment               = fmap Instr . mkComment++ -- | An instruction with liveness information. data LiveInstr instr         = LiveInstr (InstrSR instr) (Maybe Liveness)+        deriving (Functor)  -- | Liveness information. --   The regs which die are ones which are no longer live in the *next* instruction@@ -239,15 +254,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@@ -493,7 +512,7 @@  -- | Strip away liveness information, yielding NatCmmDecl stripLive-        :: (Outputable statics, Outputable instr, Instruction instr)+        :: (OutputableP Platform statics, Instruction instr)         => NCGConfig         -> LiveCmmDecl statics instr         -> NatCmmDecl statics instr@@ -501,7 +520,7 @@ stripLive config live         = stripCmm live - where  stripCmm :: (Outputable statics, Outputable instr, 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)@@ -518,8 +537,21 @@          -- If the proc has blocks but we don't know what the first one was, then we're dead.         stripCmm proc-                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)+                 = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprLiveCmmDecl (ncgPlatform config) proc) ++-- | Pretty-print a `LiveCmmDecl`+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+   :: (instr -> b)+   -> LiveCmmDecl statics instr+   -> LiveCmmDecl statics b+mapLiveCmmDecl f proc = fmap (fmap (fmap (fmap (fmap f)))) proc+ -- | Strip away liveness information from a basic block, --   and make real spill instructions out of SPILL, RELOAD pseudos along the way. @@ -535,16 +567,20 @@  where  (instrs', _)                 = runState (spillNat [] lis) 0 +        -- spillNat :: [instr] -> [LiveInstr instr] -> State Int [instr]+        spillNat :: Instruction instr => [instr] -> [LiveInstr instr] -> State Int [instr]         spillNat acc []          =      return (reverse acc) +        -- The SPILL/RELOAD cases do not appear to be exercised by our codegens+        --         spillNat acc (LiveInstr (SPILL reg slot) _ : instrs)          = do   delta   <- get-                spillNat (mkSpillInstr config reg delta slot : acc) instrs+                spillNat (mkSpillInstr config reg delta slot ++ acc) instrs          spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs)          = do   delta   <- get-                spillNat (mkLoadInstr config reg delta slot : acc) instrs+                spillNat (mkLoadInstr config reg delta slot ++ acc) instrs          spillNat acc (LiveInstr (Instr instr) _ : instrs)          | Just i <- takeDeltaInstr instr@@ -652,15 +688,16 @@ -- | Convert a NatCmmDecl to a LiveCmmDecl, with liveness information  cmmTopLiveness-        :: (Outputable instr, Instruction instr)-        => Maybe CFG -> Platform+        :: Instruction instr+        => Maybe CFG+        -> Platform         -> NatCmmDecl statics instr         -> UniqSM (LiveCmmDecl statics instr) cmmTopLiveness cfg platform cmm         = regLiveness platform $ natCmmTopToLive cfg cmm  natCmmTopToLive-        :: (Instruction instr, Outputable instr)+        :: Instruction instr         => Maybe CFG -> NatCmmDecl statics instr         -> LiveCmmDecl statics instr @@ -746,7 +783,7 @@ --  regLiveness-        :: (Outputable instr, Instruction instr)+        :: Instruction instr         => Platform         -> LiveCmmDecl statics instr         -> UniqSM (LiveCmmDecl statics instr)@@ -829,7 +866,7 @@ --  want for the next pass. -- computeLiveness-        :: (Outputable instr, Instruction instr)+        :: Instruction instr         => Platform         -> [SCC (LiveBasicBlock instr)]         -> ([SCC (LiveBasicBlock instr)],       -- instructions annotated with list of registers@@ -840,10 +877,11 @@ computeLiveness platform sccs  = case checkIsReverseDependent sccs of         Nothing         -> livenessSCCs platform mapEmpty [] sccs-        Just bad        -> pprPanic "RegAlloc.Liveness.computeLiveness"+        Just bad        -> let sccs' = fmap (fmap (fmap (fmap (pprInstr platform)))) sccs+                           in pprPanic "RegAlloc.Liveness.computeLiveness"                                 (vcat   [ text "SCCs aren't in reverse dependent order"                                         , text "bad blockId" <+> ppr bad-                                        , ppr sccs])+                                        , ppr sccs'])  livenessSCCs        :: Instruction instr

GHC/CmmToAsm/Reg/Target.hs view

@@ -28,6 +28,7 @@ import GHC.CmmToAsm.Format  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Platform @@ -35,7 +36,9 @@ import qualified GHC.CmmToAsm.X86.RegInfo    as X86 import qualified GHC.CmmToAsm.PPC.Regs       as PPC import qualified GHC.CmmToAsm.SPARC.Regs     as SPARC+import qualified GHC.CmmToAsm.AArch64.Regs   as AArch64 + targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> Int targetVirtualRegSqueeze platform     = case platformArch platform of@@ -47,10 +50,11 @@       ArchSPARC64   -> panic "targetVirtualRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.virtualRegSqueeze       ArchARM _ _ _ -> panic "targetVirtualRegSqueeze ArchARM"-      ArchAArch64   -> panic "targetVirtualRegSqueeze ArchAArch64"+      ArchAArch64   -> AArch64.virtualRegSqueeze       ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"+      ArchRISCV64   -> panic "targetVirtualRegSqueeze ArchRISCV64"       ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"       ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown" @@ -66,10 +70,11 @@       ArchSPARC64   -> panic "targetRealRegSqueeze ArchSPARC64"       ArchPPC_64 _  -> PPC.realRegSqueeze       ArchARM _ _ _ -> panic "targetRealRegSqueeze ArchARM"-      ArchAArch64   -> panic "targetRealRegSqueeze ArchAArch64"+      ArchAArch64   -> AArch64.realRegSqueeze       ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"+      ArchRISCV64   -> panic "targetRealRegSqueeze ArchRISCV64"       ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"       ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown" @@ -84,10 +89,11 @@       ArchSPARC64   -> panic "targetClassOfRealReg ArchSPARC64"       ArchPPC_64 _  -> PPC.classOfRealReg       ArchARM _ _ _ -> panic "targetClassOfRealReg ArchARM"-      ArchAArch64   -> panic "targetClassOfRealReg ArchAArch64"+      ArchAArch64   -> AArch64.classOfRealReg       ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"       ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"+      ArchRISCV64   -> panic "targetClassOfRealReg ArchRISCV64"       ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"       ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown" @@ -102,10 +108,11 @@       ArchSPARC64   -> panic "targetMkVirtualReg ArchSPARC64"       ArchPPC_64 _  -> PPC.mkVirtualReg       ArchARM _ _ _ -> panic "targetMkVirtualReg ArchARM"-      ArchAArch64   -> panic "targetMkVirtualReg ArchAArch64"+      ArchAArch64   -> AArch64.mkVirtualReg       ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"       ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"+      ArchRISCV64   -> panic "targetMkVirtualReg ArchRISCV64"       ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"       ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown" @@ -120,10 +127,11 @@       ArchSPARC64   -> panic "targetRegDotColor ArchSPARC64"       ArchPPC_64 _  -> PPC.regDotColor       ArchARM _ _ _ -> panic "targetRegDotColor ArchARM"-      ArchAArch64   -> panic "targetRegDotColor ArchAArch64"+      ArchAArch64   -> AArch64.regDotColor       ArchAlpha     -> panic "targetRegDotColor ArchAlpha"       ArchMipseb    -> panic "targetRegDotColor ArchMipseb"       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"+      ArchRISCV64   -> panic "targetRegDotColor ArchRISCV64"       ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"       ArchUnknown   -> panic "targetRegDotColor ArchUnknown"

+ GHC/CmmToAsm/SPARC.hs view

@@ -0,0 +1,74 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for SPARC architectures+module GHC.CmmToAsm.SPARC+   ( ncgSPARC+   )+where++import GHC.Prelude+import GHC.Utils.Panic++import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Instr++import qualified GHC.CmmToAsm.SPARC.Instr          as SPARC+import qualified GHC.CmmToAsm.SPARC.Ppr            as SPARC+import qualified GHC.CmmToAsm.SPARC.CodeGen        as SPARC+import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC+import qualified GHC.CmmToAsm.SPARC.Regs           as SPARC+import qualified GHC.CmmToAsm.SPARC.ShortcutJump   as SPARC+++ncgSPARC :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr SPARC.JumpDest+ncgSPARC config = NcgImpl+   { ncgConfig                 = config+   , cmmTopCodeGen             = SPARC.cmmTopCodeGen+   , generateJumpTableForInstr = SPARC.generateJumpTableForInstr platform+   , getJumpDestBlockId        = SPARC.getJumpDestBlockId+   , canShortcut               = SPARC.canShortcut+   , shortcutStatics           = SPARC.shortcutStatics+   , shortcutJump              = SPARC.shortcutJump+   , pprNatCmmDecl             = SPARC.pprNatCmmDecl config+   , maxSpillSlots             = SPARC.maxSpillSlots config+   , allocatableRegs           = SPARC.allocatableRegs+   , ncgExpandTop              = map SPARC.expandTop+   , ncgMakeFarBranches        = const id+   , extractUnwindPoints       = const []+   , invertCondBranches        = \_ _ -> id+   -- Allocating more stack space for spilling isn't currently supported for the+   -- linear register allocator on SPARC, hence the panic below.+   , ncgAllocMoreStack         = noAllocMoreStack+   }+    where+      platform = ncgPlatform config++      noAllocMoreStack amount _+        = panic $   "Register allocator: out of stack slots (need " ++ show amount ++ ")\n"+              ++  "   If you are trying to compile SHA1.hs from the crypto library then this\n"+              ++  "   is a known limitation in the linear allocator.\n"+              ++  "\n"+              ++  "   Try enabling the graph colouring allocator with -fregs-graph instead."+              ++  "   You can still file a bug report if you like.\n"+++-- | instance for sparc instruction set+instance Instruction SPARC.Instr where+   regUsageOfInstr         = SPARC.regUsageOfInstr+   patchRegsOfInstr        = SPARC.patchRegsOfInstr+   isJumpishInstr          = SPARC.isJumpishInstr+   jumpDestsOfInstr        = SPARC.jumpDestsOfInstr+   patchJumpInstr          = SPARC.patchJumpInstr+   mkSpillInstr            = SPARC.mkSpillInstr+   mkLoadInstr             = SPARC.mkLoadInstr+   takeDeltaInstr          = SPARC.takeDeltaInstr+   isMetaInstr             = SPARC.isMetaInstr+   mkRegRegMoveInstr       = SPARC.mkRegRegMoveInstr+   takeRegRegMoveInstr     = SPARC.takeRegRegMoveInstr+   mkJumpInstr             = SPARC.mkJumpInstr+   pprInstr                = SPARC.pprInstr+   mkComment               = const []+   mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"+   mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"

GHC/CmmToAsm/SPARC/CodeGen.hs view

@@ -34,7 +34,7 @@ import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Stack-import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types import GHC.CmmToAsm.Format import GHC.CmmToAsm.Monad   ( NatM, getNewRegNat, getNewLabelNat, getPlatform, getConfig ) import GHC.CmmToAsm.Config@@ -55,7 +55,7 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Data.OrdList-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import Control.Monad    ( mapAndUnzipM )@@ -73,7 +73,7 @@        return tops -cmmTopCodeGen (CmmData sec dat) = do+cmmTopCodeGen (CmmData sec dat) =   return [CmmData sec dat]  -- no translation, we just use CmmStatic  @@ -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)@@ -429,8 +430,8 @@                  PrimTarget mop                  -> do  res     <- outOfLineMachOp mop-                        lblOrMopExpr <- case res of-                                Left lbl -> do+                        case res of+                                Left lbl ->                                         return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False))                                  Right mopExpr -> do@@ -440,8 +441,6 @@                                                       _ -> panic "SPARC.CodeGen.genCCall: arg_to_int"                                         return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) -                        return lblOrMopExpr-         let argcode = concatOL argcodes          let (move_sp_down, move_sp_up)@@ -660,6 +659,36 @@         MO_F64_Asinh  -> fsLit "asinh"         MO_F64_Acosh  -> fsLit "acosh"         MO_F64_Atanh  -> fsLit "atanh"++        MO_I64_ToI   -> fsLit "hs_int64ToInt"+        MO_I64_FromI -> fsLit "hs_intToInt64"+        MO_W64_ToW   -> fsLit "hs_word64ToWord"+        MO_W64_FromW -> fsLit "hs_wordToWord64"+        MO_x64_Neg   -> fsLit "hs_neg64"+        MO_x64_Add   -> fsLit "hs_add64"+        MO_x64_Sub   -> fsLit "hs_sub64"+        MO_x64_Mul   -> fsLit "hs_mul64"+        MO_I64_Quot  -> fsLit "hs_quotInt64"+        MO_I64_Rem   -> fsLit "hs_remInt64"+        MO_W64_Quot  -> fsLit "hs_quotWord64"+        MO_W64_Rem   -> fsLit "hs_remWord64"+        MO_x64_And   -> fsLit "hs_and64"+        MO_x64_Or    -> fsLit "hs_or64"+        MO_x64_Xor   -> fsLit "hs_xor64"+        MO_x64_Not   -> fsLit "hs_not64"+        MO_x64_Shl   -> fsLit "hs_uncheckedShiftL64"+        MO_I64_Shr   -> fsLit "hs_uncheckedIShiftRA64"+        MO_W64_Shr   -> fsLit "hs_uncheckedShiftRL64"+        MO_x64_Eq    -> fsLit "hs_eq64"+        MO_x64_Ne    -> fsLit "hs_ne64"+        MO_I64_Ge    -> fsLit "hs_geInt64"+        MO_I64_Gt    -> fsLit "hs_gtInt64"+        MO_I64_Le    -> fsLit "hs_leInt64"+        MO_I64_Lt    -> fsLit "hs_ltInt64"+        MO_W64_Ge    -> fsLit "hs_geWord64"+        MO_W64_Gt    -> fsLit "hs_gtWord64"+        MO_W64_Le    -> fsLit "hs_leWord64"+        MO_W64_Lt    -> fsLit "hs_ltWord64"          MO_UF_Conv w -> fsLit $ word2FloatLabel w

GHC/CmmToAsm/SPARC/CodeGen/Base.hs view

@@ -28,6 +28,7 @@ import GHC.Platform  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.OrdList  --------------------------------------------------------------------------------

GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs view

@@ -22,6 +22,7 @@  import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic   getCondCode :: CmmExpr -> NatM CondCode@@ -55,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)

GHC/CmmToAsm/SPARC/CodeGen/Expand.hs view

@@ -13,13 +13,14 @@ import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Regs-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types import GHC.Cmm +import GHC.Platform.Reg  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.OrdList  -- | Expand out synthetic instructions in this top level thing

GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs view

@@ -27,7 +27,7 @@  import Control.Monad (liftM) import GHC.Data.OrdList-import GHC.Utils.Outputable+import GHC.Utils.Panic  -- | The dual to getAnyReg: compute an expression into a register, but --      we don't mind which one it is.

GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs view

@@ -16,9 +16,7 @@ import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.Instr--- GHC.CmmToAsm.SPARC.Ppr() import GHC.CmmToAsm.Monad-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format import GHC.Platform.Reg @@ -26,6 +24,7 @@  import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic  -- | Code to assign a 64 bit value to memory. assignMem_I64Code@@ -210,4 +209,6 @@   iselExpr64 expr-   = pprPanic "iselExpr64(sparc)" (ppr expr)+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(sparc)" (pdoc platform expr)

GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs view

@@ -7,23 +7,26 @@ where  import GHC.Prelude+import GHC.Platform  import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Ppr        () -- For Outputable instances-import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Types  import GHC.Cmm  import GHC.Utils.Outputable+import GHC.Utils.Panic   -- | 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 @@ -31,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

GHC/CmmToAsm/SPARC/Imm.hs view

@@ -13,6 +13,7 @@ import GHC.Cmm.CLabel  import GHC.Utils.Outputable+import GHC.Utils.Panic  -- | An immediate value. --      Not all of these are directly representable by the machine.

GHC/CmmToAsm/SPARC/Instr.hs view

@@ -9,22 +9,31 @@ ----------------------------------------------------------------------------- #include "HsVersions.h" -module GHC.CmmToAsm.SPARC.Instr (-        RI(..),-        riZero,--        fpRelEA,-        moveSp,--        isUnconditionalJump,--        Instr(..),-        maxSpillSlots-)-+module GHC.CmmToAsm.SPARC.Instr+   ( Instr(..)+   , RI(..)+   , riZero+   , fpRelEA+   , moveSp+   , isUnconditionalJump+   , maxSpillSlots+   , patchRegsOfInstr+   , patchJumpInstr+   , mkRegRegMoveInstr+   , mkLoadInstr+   , mkSpillInstr+   , mkJumpInstr+   , takeDeltaInstr+   , isMetaInstr+   , isJumpishInstr+   , jumpDestsOfInstr+   , takeRegRegMoveInstr+   , regUsageOfInstr+   ) where  import GHC.Prelude+import GHC.Platform  import GHC.CmmToAsm.SPARC.Stack import GHC.CmmToAsm.SPARC.Imm@@ -33,19 +42,19 @@ import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Base import GHC.CmmToAsm.Reg.Target-import GHC.CmmToAsm.Instr-import GHC.Platform.Reg.Class-import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) -import GHC.Cmm.CLabel+import GHC.Platform.Reg.Class+import GHC.Platform.Reg import GHC.Platform.Regs++import GHC.Cmm.CLabel import GHC.Cmm.BlockId import GHC.Cmm import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Platform+import GHC.Utils.Panic   -- | Register or immediate@@ -88,24 +97,6 @@         _               -> False  --- | instance for sparc instruction set-instance Instruction Instr where-        regUsageOfInstr         = sparc_regUsageOfInstr-        patchRegsOfInstr        = sparc_patchRegsOfInstr-        isJumpishInstr          = sparc_isJumpishInstr-        jumpDestsOfInstr        = sparc_jumpDestsOfInstr-        patchJumpInstr          = sparc_patchJumpInstr-        mkSpillInstr            = sparc_mkSpillInstr-        mkLoadInstr             = sparc_mkLoadInstr-        takeDeltaInstr          = sparc_takeDeltaInstr-        isMetaInstr             = sparc_isMetaInstr-        mkRegRegMoveInstr       = sparc_mkRegRegMoveInstr-        takeRegRegMoveInstr     = sparc_takeRegRegMoveInstr-        mkJumpInstr             = sparc_mkJumpInstr-        mkStackAllocInstr       = panic "no sparc_mkStackAllocInstr"-        mkStackDeallocInstr     = panic "no sparc_mkStackDeallocInstr"-- -- | SPARC instruction set. --      Not complete. This is only the ones we need. --@@ -218,8 +209,8 @@ --      consequences of control flow transfers, as far as register --      allocation goes, are taken care of by the register allocator. ---sparc_regUsageOfInstr :: Platform -> Instr -> RegUsage-sparc_regUsageOfInstr platform instr+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr  = case instr of     LD    _ addr reg            -> usage (regAddr addr,         [reg])     ST    _ reg addr            -> usage (reg : regAddr addr,   [])@@ -285,8 +276,8 @@   -- | Apply a given mapping to tall the register references in this instruction.-sparc_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-sparc_patchRegsOfInstr instr env = case instr of+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of     LD    fmt addr reg          -> LD fmt (fixAddr addr) (env reg)     ST    fmt reg addr          -> ST fmt (env reg) (fixAddr addr) @@ -337,8 +328,8 @@   ---------------------------------------------------------------------------------sparc_isJumpishInstr :: Instr -> Bool-sparc_isJumpishInstr instr+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr  = case instr of         BI{}            -> True         BF{}            -> True@@ -347,8 +338,8 @@         CALL{}          -> True         _               -> False -sparc_jumpDestsOfInstr :: Instr -> [BlockId]-sparc_jumpDestsOfInstr insn+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr insn   = case insn of         BI   _ _ id     -> [id]         BF   _ _ id     -> [id]@@ -356,8 +347,8 @@         _               -> []  -sparc_patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr-sparc_patchJumpInstr insn patchF+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr insn patchF   = case insn of         BI cc annul id  -> BI cc annul (patchF id)         BF cc annul id  -> BF cc annul (patchF id)@@ -368,14 +359,14 @@ -------------------------------------------------------------------------------- -- | Make a spill instruction. --      On SPARC we spill below frame pointer leaving 2 words/spill-sparc_mkSpillInstr+mkSpillInstr     :: NCGConfig     -> Reg      -- ^ register to spill     -> Int      -- ^ current stack delta     -> Int      -- ^ spill slot to use-    -> Instr+    -> [Instr] -sparc_mkSpillInstr config reg _ slot+mkSpillInstr config reg _ slot  = let  platform = ncgPlatform config         off      = spillSlotToOffset config slot         off_w    = 1 + (off `div` 4)@@ -384,18 +375,18 @@                         RcFloat   -> FF32                         RcDouble  -> FF64 -    in ST fmt reg (fpRel (negate off_w))+    in [ST fmt reg (fpRel (negate off_w))]   -- | Make a spill reload instruction.-sparc_mkLoadInstr+mkLoadInstr     :: NCGConfig     -> Reg      -- ^ register to load into     -> Int      -- ^ current stack delta     -> Int      -- ^ spill slot to use-    -> Instr+    -> [Instr] -sparc_mkLoadInstr config reg _ slot+mkLoadInstr config reg _ slot   = let platform = ncgPlatform config         off      = spillSlotToOffset config slot         off_w    = 1 + (off `div` 4)@@ -404,26 +395,26 @@                         RcFloat   -> FF32                         RcDouble  -> FF64 -        in LD fmt (fpRel (- off_w)) reg+        in [LD fmt (fpRel (- off_w)) reg]   -------------------------------------------------------------------------------- -- | See if this instruction is telling us the current C stack delta-sparc_takeDeltaInstr+takeDeltaInstr         :: Instr         -> Maybe Int -sparc_takeDeltaInstr instr+takeDeltaInstr instr  = case instr of         DELTA i         -> Just i         _               -> Nothing  -sparc_isMetaInstr+isMetaInstr         :: Instr         -> Bool -sparc_isMetaInstr instr+isMetaInstr instr  = case instr of         COMMENT{}       -> True         LDATA{}         -> True@@ -437,13 +428,13 @@ --      floating point and integer regs. If we need to do that then we --      have to go via memory. ---sparc_mkRegRegMoveInstr+mkRegRegMoveInstr     :: Platform     -> Reg     -> Reg     -> Instr -sparc_mkRegRegMoveInstr platform src dst+mkRegRegMoveInstr platform src dst         | srcClass      <- targetClassOfReg platform src         , dstClass      <- targetClassOfReg platform dst         , srcClass == dstClass@@ -460,8 +451,8 @@ --      The register allocator attempts to eliminate reg->reg moves whenever it can, --      by assigning the src and dest temporaries to the same real register. ---sparc_takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)-sparc_takeRegRegMoveInstr instr+takeRegRegMoveInstr :: Instr -> Maybe (Reg,Reg)+takeRegRegMoveInstr instr  = case instr of         ADD False False src (RIReg src2) dst          | g0 == src2           -> Just (src, dst)@@ -472,10 +463,10 @@   -- | Make an unconditional branch instruction.-sparc_mkJumpInstr+mkJumpInstr         :: BlockId         -> [Instr] -sparc_mkJumpInstr id+mkJumpInstr id  =       [BI ALWAYS False id         , NOP]                  -- fill the branch delay slot.

GHC/CmmToAsm/SPARC/Ppr.hs view

@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-} + ----------------------------------------------------------------------------- -- -- Pretty-printing assembly language@@ -9,7 +13,6 @@ -----------------------------------------------------------------------------  {-# OPTIONS_GHC -fno-warn-orphans #-}- module GHC.CmmToAsm.SPARC.Ppr (         pprNatCmmDecl,         pprBasicBlock,@@ -26,17 +29,24 @@  import GHC.Prelude +import Data.Word+import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST++import Control.Monad.ST+ import GHC.CmmToAsm.SPARC.Regs import GHC.CmmToAsm.SPARC.Instr import GHC.CmmToAsm.SPARC.Cond import GHC.CmmToAsm.SPARC.Imm import GHC.CmmToAsm.SPARC.AddrMode import GHC.CmmToAsm.SPARC.Base-import GHC.CmmToAsm.Instr import GHC.Platform.Reg import GHC.CmmToAsm.Format import GHC.CmmToAsm.Ppr import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils  import GHC.Cmm hiding (topInfoTable) import GHC.Cmm.Ppr() -- For Outputable instances@@ -47,6 +57,7 @@  import GHC.Types.Unique ( pprUniqueAlways ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Data.FastString @@ -70,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@@ -79,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@@ -92,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@@ -104,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@@ -122,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.@@ -266,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@@ -290,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.@@ -353,219 +364,228 @@     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]+floatToBytes f+   = runST (do+        arr <- newArray_ ((0::Int),3)+        writeArray arr 0 f+        arr <- castFloatToWord8Array arr+        i0 <- readArray arr 0+        i1 <- readArray arr 1+        i2 <- readArray arr 2+        i3 <- readArray arr 3+        return (map fromIntegral [i0,i1,i2,i3])+     ) --- | Pretty print an instruction.-pprInstr :: Instr -> SDoc+castFloatToWord8Array :: STUArray s Int Float -> ST s (STUArray s Int Word8)+castFloatToWord8Array = U.castSTUArray --- 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"+-- | Pretty print an instruction.+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.@@ -604,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     ]

GHC/CmmToAsm/SPARC/Regs.hs view

@@ -41,6 +41,7 @@  import GHC.Types.Unique import GHC.Utils.Outputable+import GHC.Utils.Panic  {-         The SPARC has 64 registers of interest; 32 integer registers and 32

GHC/CmmToAsm/SPARC/Stack.hs view

@@ -16,6 +16,7 @@ import GHC.CmmToAsm.Config  import GHC.Utils.Outputable+import GHC.Utils.Panic  -- | Get an AddrMode relative to the address in sp. --      This gives us a stack relative addressing mode for volatile

+ GHC/CmmToAsm/Types.hs view

@@ -0,0 +1,32 @@+module GHC.CmmToAsm.Types+   ( NatCmm+   , NatCmmDecl+   , NatBasicBlock+   , GenBasicBlock(..)+   , blockId+   , ListGraph(..)+   , RawCmmStatics+   , RawCmmDecl+   )+where++import GHC.Cmm.Dataflow.Label+import GHC.Cmm+++-- Our flavours of the Cmm types+-- Type synonyms for Cmm populated with native code+type NatCmm instr+        = GenCmmGroup+                RawCmmStatics+                (LabelMap RawCmmStatics)+                (ListGraph instr)++type NatCmmDecl statics instr+        = GenCmmDecl+                statics+                (LabelMap RawCmmStatics)+                (ListGraph instr)++type NatBasicBlock instr+        = GenBasicBlock instr

+ GHC/CmmToAsm/Utils.hs view

@@ -0,0 +1,33 @@+module GHC.CmmToAsm.Utils+   ( topInfoTable+   , entryBlocks+   )+where++import GHC.Prelude++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label+import GHC.Cmm hiding (topInfoTable)++-- | Returns the info table associated with the CmmDecl's entry point,+-- if any.+topInfoTable :: GenCmmDecl a (LabelMap i) (ListGraph b) -> Maybe i+topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))+  = mapLookup (blockId b) infos+topInfoTable _+  = Nothing++-- | Return the list of BlockIds in a CmmDecl that are entry points+-- for this proc (i.e. they may be jumped to from outside this proc).+entryBlocks :: GenCmmDecl a (LabelMap i) (ListGraph b) -> [BlockId]+entryBlocks (CmmProc info _ _ (ListGraph code)) = entries+  where+        infos = mapKeys info+        entries = case code of+                    [] -> infos+                    BasicBlock entry _ : _ -- first block is the entry point+                       | entry `elem` infos -> infos+                       | otherwise          -> entry : infos+entryBlocks _ = []

+ GHC/CmmToAsm/X86.hs view

@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for x86 and x86-64 architectures+module GHC.CmmToAsm.X86+   ( ncgX86_64+   , ncgX86+   )+where++import GHC.Prelude++import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Types.Basic (Alignment)++import qualified GHC.CmmToAsm.X86.Instr   as X86+import qualified GHC.CmmToAsm.X86.Ppr     as X86+import qualified GHC.CmmToAsm.X86.CodeGen as X86+import qualified GHC.CmmToAsm.X86.Regs    as X86++ncgX86 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest+ncgX86 = ncgX86_64+++ncgX86_64 :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics) X86.Instr X86.JumpDest+ncgX86_64 config = NcgImpl+   { ncgConfig                 = config+   , cmmTopCodeGen             = X86.cmmTopCodeGen+   , generateJumpTableForInstr = X86.generateJumpTableForInstr config+   , getJumpDestBlockId        = X86.getJumpDestBlockId+   , canShortcut               = X86.canShortcut+   , shortcutStatics           = X86.shortcutStatics+   , shortcutJump              = X86.shortcutJump+   , pprNatCmmDecl             = X86.pprNatCmmDecl config+   , maxSpillSlots             = X86.maxSpillSlots config+   , allocatableRegs           = X86.allocatableRegs platform+   , ncgAllocMoreStack         = X86.allocMoreStack platform+   , ncgExpandTop              = id+   , ncgMakeFarBranches        = const id+   , extractUnwindPoints       = X86.extractUnwindPoints+   , invertCondBranches        = X86.invertCondBranches+   }+    where+      platform = ncgPlatform config++-- | Instruction instance for x86 instruction set.+instance Instruction X86.Instr where+   regUsageOfInstr         = X86.regUsageOfInstr+   patchRegsOfInstr        = X86.patchRegsOfInstr+   isJumpishInstr          = X86.isJumpishInstr+   jumpDestsOfInstr        = X86.jumpDestsOfInstr+   patchJumpInstr          = X86.patchJumpInstr+   mkSpillInstr            = X86.mkSpillInstr+   mkLoadInstr             = X86.mkLoadInstr+   takeDeltaInstr          = X86.takeDeltaInstr+   isMetaInstr             = X86.isMetaInstr+   mkRegRegMoveInstr       = X86.mkRegRegMoveInstr+   takeRegRegMoveInstr     = X86.takeRegRegMoveInstr+   mkJumpInstr             = X86.mkJumpInstr+   mkStackAllocInstr       = X86.mkStackAllocInstr+   mkStackDeallocInstr     = X86.mkStackDeallocInstr+   pprInstr                = X86.pprInstr+   mkComment               = const []

GHC/CmmToAsm/X86/CodeGen.hs view

@@ -1,13 +1,8 @@-{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE BangPatterns #-}--#if __GLASGOW_HASKELL__ <= 808--- GHC 8.10 deprecates this flag, but GHC 8.8 needs it--- The default iteration limit is a bit too low for the definitions--- in this module.-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}-#endif+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -46,17 +41,18 @@  import GHC.Platform.Regs import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types import GHC.Cmm.DebugBlock    ( DebugBlock(..), UnwindPoint(..), UnwindTable    , UnwindExpr(UwReg), toUnwindExpr    )-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Monad    ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat    , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat    , getPicBaseMaybeNat, getDebugBlock, getFileId    , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+   , getCfgWeights    ) import GHC.CmmToAsm.CFG import GHC.CmmToAsm.Format@@ -67,7 +63,7 @@ -- Our intermediate code: import GHC.Types.Basic import GHC.Cmm.BlockId-import GHC.Unit ( primUnitId )+import GHC.Unit.Types ( primUnitId ) import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm@@ -76,20 +72,20 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel-import GHC.Core          ( Tickish(..) )+import GHC.Types.Tickish ( GenTickish(..) ) import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )  -- The rest: import GHC.Types.ForeignCall ( CCallConv(..) ) import GHC.Data.OrdList import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Driver.Session import GHC.Utils.Misc import GHC.Types.Unique.Supply ( getUniqueM )  import Control.Monad-import Data.Bits import Data.Foldable (fold) import Data.Int import Data.Maybe@@ -129,7 +125,7 @@       Just picBase -> initializePicBase_x86 ArchX86 os picBase tops       Nothing -> return tops -cmmTopCodeGen (CmmData sec dat) = do+cmmTopCodeGen (CmmData sec dat) =   return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic  {- Note [Verifying basic blocks]@@ -227,7 +223,7 @@ addSpUnwindings :: Instr -> NatM (OrdList Instr) addSpUnwindings instr@(DELTA d) = do     config <- getConfig-    if ncgDebugLevel config >= 1+    if ncgDwarfUnwindings config         then do lbl <- mkAsmTempLabel <$> getUniqueM                 let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)                 return $ toOL [ instr, UNWIND lbl unwind ]@@ -618,7 +614,9 @@             )  iselExpr64 expr-   = pprPanic "iselExpr64(i386)" (ppr expr)+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(i386)" (pdoc platform expr)   --------------------------------------------------------------------------------@@ -746,11 +744,11 @@  getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),                                      CmmLit displacement])- | not is32Bit = do+ | not is32Bit =       return $ Any II64 (\dst -> unitOL $         LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps     case mop of       MO_F_Neg w  -> sse2NegCode w x @@ -882,7 +880,7 @@                  return (swizzleRegisterRep e_code new_format)  -getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps   case mop of       MO_F_Eq _ -> condFltReg is32Bit EQQ x y       MO_F_Ne _ -> condFltReg is32Bit NE  x y@@ -1046,7 +1044,9 @@     --------------------     add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register     add_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger y = add_int rep x y+        | is32BitInteger y+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x y     add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y       where format = intFormat rep     -- TODO: There are other interesting patterns we want to replace@@ -1055,7 +1055,9 @@     --------------------     sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register     sub_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger (-y) = add_int rep x (-y)+        | is32BitInteger (-y)+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x (-y)     sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y      -- our three-operand add instruction:@@ -1176,9 +1178,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@@ -1367,17 +1369,16 @@ -- (see trivialCode where this function is used for an example).  getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand (CmmLit lit) = do+getNonClobberedOperand (CmmLit lit) =   if isSuitableFloatingPointLit lit-    then do-      let CmmFloat _ w = lit-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      return (OpAddr addr, code)-     else do--  is32Bit <- is32BitPlatform-  platform <- getPlatform-  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))+  then do+    let CmmFloat _ w = lit+    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+    return (OpAddr addr, code)+  else do+    is32Bit <- is32BitPlatform+    platform <- getPlatform+    if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))     then return (OpImm (litToImm lit), nilOL)     else getNonClobberedOperand_generic (CmmLit lit) @@ -1403,7 +1404,7 @@                 else                    return (src, nilOL)       return (OpAddr src', mem_code `appOL` save_code)-    else do+    else       -- if its a word or gcptr on 32bit?       getNonClobberedOperand_generic (CmmLoad mem pk) @@ -1411,8 +1412,8 @@  getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) getNonClobberedOperand_generic e = do-    (reg, code) <- getNonClobberedReg e-    return (OpReg reg, code)+  (reg, code) <- getNonClobberedReg e+  return (OpReg reg, code)  amodeCouldBeClobbered :: Platform -> AddrMode -> Bool amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)@@ -1574,7 +1575,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@@ -1789,7 +1792,7 @@   Amode target code <- getAmode mem   return (code `snocOL` JMP (OpAddr target) regs) -genJump (CmmLit lit) regs = do+genJump (CmmLit lit) regs =   return (unitOL (JMP (OpImm (litToImm lit)) regs))  genJump expr regs = do@@ -2110,12 +2113,12 @@         -- final move should go away, because it's the last use of arg         -- and the first use of dst_r.         AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ], bid)+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)         AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)-                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                  , MOV format (OpReg arg) (OpReg dst_r)-                                  ], bid)+                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                   , MOV format (OpReg arg) (OpReg dst_r)+                                   ], bid)         -- In these cases we need a new block id, and have to return it so         -- that later instruction selection can reference it.         AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)@@ -2175,10 +2178,10 @@       --  bid -> lbl2       --  bid -> lbl1 -> lbl2       --  We also changes edges originating at bid to start at lbl2 instead.-      dflags <- getDynFlags+      weights <- getCfgWeights       updateCfgNat (addWeightEdge bid lbl1 110 .                     addWeightEdge lbl1 lbl2 110 .-                    addImmediateSuccessor dflags bid lbl2)+                    addImmediateSuccessor weights bid lbl2)        -- The following instruction sequence corresponds to the pseudo-code       --@@ -3043,7 +3046,7 @@                                    X87Store fmt  tmp_amode,                                    -- X87Store only supported for the CDECL ABI                                    -- NB: This code will need to be-                                   -- revisted once GHC does more work around+                                   -- revisited once GHC does more work around                                    -- SIGFPE f                                    MOV fmt (OpAddr tmp_amode) (OpReg r_dest),                                    ADD II32 (OpImm (ImmInt b)) (OpReg esp),@@ -3387,6 +3390,36 @@               MO_F64_Asinh  -> fsLit "asinh"               MO_F64_Acosh  -> fsLit "acosh"               MO_F64_Atanh  -> fsLit "atanh"++              MO_I64_ToI   -> fsLit "hs_int64ToInt"+              MO_I64_FromI -> fsLit "hs_intToInt64"+              MO_W64_ToW   -> fsLit "hs_word64ToWord"+              MO_W64_FromW -> fsLit "hs_wordToWord64"+              MO_x64_Neg   -> fsLit "hs_neg64"+              MO_x64_Add   -> fsLit "hs_add64"+              MO_x64_Sub   -> fsLit "hs_sub64"+              MO_x64_Mul   -> fsLit "hs_mul64"+              MO_I64_Quot  -> fsLit "hs_quotInt64"+              MO_I64_Rem   -> fsLit "hs_remInt64"+              MO_W64_Quot  -> fsLit "hs_quotWord64"+              MO_W64_Rem   -> fsLit "hs_remWord64"+              MO_x64_And   -> fsLit "hs_and64"+              MO_x64_Or    -> fsLit "hs_or64"+              MO_x64_Xor   -> fsLit "hs_xor64"+              MO_x64_Not   -> fsLit "hs_not64"+              MO_x64_Shl   -> fsLit "hs_uncheckedShiftL64"+              MO_I64_Shr   -> fsLit "hs_uncheckedIShiftRA64"+              MO_W64_Shr   -> fsLit "hs_uncheckedShiftRL64"+              MO_x64_Eq    -> fsLit "hs_eq64"+              MO_x64_Ne    -> fsLit "hs_ne64"+              MO_I64_Ge    -> fsLit "hs_geInt64"+              MO_I64_Gt    -> fsLit "hs_gtInt64"+              MO_I64_Le    -> fsLit "hs_leInt64"+              MO_I64_Lt    -> fsLit "hs_ltInt64"+              MO_W64_Ge    -> fsLit "hs_geWord64"+              MO_W64_Gt    -> fsLit "hs_gtWord64"+              MO_W64_Le    -> fsLit "hs_leWord64"+              MO_W64_Lt    -> fsLit "hs_ltWord64"                MO_Memcpy _  -> fsLit "memcpy"               MO_Memset _  -> fsLit "memset"

GHC/CmmToAsm/X86/Instr.hs view

@@ -9,10 +9,31 @@ -----------------------------------------------------------------------------  module GHC.CmmToAsm.X86.Instr-   ( Instr(..), Operand(..), PrefetchVariant(..), JumpDest(..)-   , getJumpDestBlockId, canShortcut, shortcutStatics-   , shortcutJump, allocMoreStack-   , maxSpillSlots, archWordFormat+   ( Instr(..)+   , Operand(..)+   , PrefetchVariant(..)+   , JumpDest(..)+   , getJumpDestBlockId+   , canShortcut+   , shortcutStatics+   , shortcutJump+   , allocMoreStack+   , maxSpillSlots+   , archWordFormat+   , takeRegRegMoveInstr+   , regUsageOfInstr+   , takeDeltaInstr+   , mkLoadInstr+   , mkJumpInstr+   , mkStackAllocInstr+   , mkStackDeallocInstr+   , mkSpillInstr+   , mkRegRegMoveInstr+   , jumpDestsOfInstr+   , patchRegsOfInstr+   , patchJumpInstr+   , isMetaInstr+   , isJumpishInstr    ) where @@ -22,8 +43,10 @@  import GHC.CmmToAsm.X86.Cond import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage) import GHC.Platform.Reg.Class import GHC.Platform.Reg import GHC.CmmToAsm.Reg.Target@@ -36,13 +59,14 @@ import GHC.Cmm import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform -import GHC.Types.Basic (Alignment) import GHC.Cmm.CLabel import GHC.Types.Unique.Set import GHC.Types.Unique import GHC.Types.Unique.Supply+import GHC.Types.Basic (Alignment) import GHC.Cmm.DebugBlock (UnwindTable)  import Control.Monad@@ -55,24 +79,6 @@  | is32Bit   = II32  | otherwise = II64 --- | Instruction instance for x86 instruction set.-instance Instruction Instr where-        regUsageOfInstr         = x86_regUsageOfInstr-        patchRegsOfInstr        = x86_patchRegsOfInstr-        isJumpishInstr          = x86_isJumpishInstr-        jumpDestsOfInstr        = x86_jumpDestsOfInstr-        patchJumpInstr          = x86_patchJumpInstr-        mkSpillInstr            = x86_mkSpillInstr-        mkLoadInstr             = x86_mkLoadInstr-        takeDeltaInstr          = x86_takeDeltaInstr-        isMetaInstr             = x86_isMetaInstr-        mkRegRegMoveInstr       = x86_mkRegRegMoveInstr-        takeRegRegMoveInstr     = x86_takeRegRegMoveInstr-        mkJumpInstr             = x86_mkJumpInstr-        mkStackAllocInstr       = x86_mkStackAllocInstr-        mkStackDeallocInstr     = x86_mkStackDeallocInstr-- -- ----------------------------------------------------------------------------- -- Intel x86 instructions @@ -344,8 +350,8 @@  -- | Returns which registers are read and written as a (read, written) -- pair.-x86_regUsageOfInstr :: Platform -> Instr -> RegUsage-x86_regUsageOfInstr platform instr+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr  = case instr of     MOV    _ src dst    -> usageRW src dst     CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]@@ -429,7 +435,7 @@      -- note: might be a better way to do this     PREFETCH _  _ src -> mkRU (use_R src []) []-    LOCK i              -> x86_regUsageOfInstr platform i+    LOCK i              -> regUsageOfInstr platform i     XADD _ src dst      -> usageMM src dst     CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)     XCHG _ src dst      -> usageMM src (OpReg dst)@@ -513,8 +519,8 @@  -- | Applies the supplied function to all registers in instructions. -- Typically used to change virtual registers to real registers.-x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-x86_patchRegsOfInstr instr env+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env  = case instr of     MOV  fmt src dst     -> patch2 (MOV  fmt) src dst     CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)@@ -589,7 +595,7 @@      PREFETCH lvl format src -> PREFETCH lvl format (patchOp src) -    LOCK i               -> LOCK (x86_patchRegsOfInstr i env)+    LOCK i               -> LOCK (patchRegsOfInstr i env)     XADD fmt src dst     -> patch2 (XADD fmt) src dst     CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst     XCHG fmt src dst     -> XCHG fmt (patchOp src) (env dst)@@ -620,10 +626,10 @@   ---------------------------------------------------------------------------------x86_isJumpishInstr+isJumpishInstr         :: Instr -> Bool -x86_isJumpishInstr instr+isJumpishInstr instr  = case instr of         JMP{}           -> True         JXX{}           -> True@@ -633,21 +639,21 @@         _               -> False  -x86_jumpDestsOfInstr+jumpDestsOfInstr         :: Instr         -> [BlockId] -x86_jumpDestsOfInstr insn+jumpDestsOfInstr insn   = case insn of         JXX _ id        -> [id]         JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]         _               -> []  -x86_patchJumpInstr+patchJumpInstr         :: Instr -> (BlockId -> BlockId) -> Instr -x86_patchJumpInstr insn patchF+patchJumpInstr insn patchF   = case insn of         JXX cc id       -> JXX cc (patchF id)         JMP_TBL op ids section lbl@@ -663,40 +669,40 @@  -- ----------------------------------------------------------------------------- -- | Make a spill instruction.-x86_mkSpillInstr+mkSpillInstr     :: NCGConfig     -> Reg      -- register to spill     -> Int      -- current stack delta     -> Int      -- spill slot to use-    -> Instr+    -> [Instr] -x86_mkSpillInstr config reg delta slot+mkSpillInstr config reg delta slot   = let off     = spillSlotToOffset platform slot - delta     in     case targetClassOfReg platform reg of-           RcInteger   -> MOV (archWordFormat is32Bit)-                              (OpReg reg) (OpAddr (spRel platform off))-           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel platform off))+           RcInteger   -> [MOV (archWordFormat is32Bit)+                                   (OpReg reg) (OpAddr (spRel platform off))]+           RcDouble    -> [MOV FF64 (OpReg reg) (OpAddr (spRel platform off))]            _         -> panic "X86.mkSpillInstr: no match"     where platform = ncgPlatform config           is32Bit = target32Bit platform  -- | Make a spill reload instruction.-x86_mkLoadInstr+mkLoadInstr     :: NCGConfig     -> Reg      -- register to load     -> Int      -- current stack delta     -> Int      -- spill slot to use-    -> Instr+    -> [Instr] -x86_mkLoadInstr config reg delta slot+mkLoadInstr config reg delta slot   = let off     = spillSlotToOffset platform slot - delta     in         case targetClassOfReg platform reg of-              RcInteger -> MOV (archWordFormat is32Bit)-                               (OpAddr (spRel platform off)) (OpReg reg)-              RcDouble  -> MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)-              _           -> panic "X86.x86_mkLoadInstr"+              RcInteger -> ([MOV (archWordFormat is32Bit)+                                 (OpAddr (spRel platform off)) (OpReg reg)])+              RcDouble  -> ([MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)])+              _         -> panic "X86.mkLoadInstr"     where platform = ncgPlatform config           is32Bit = target32Bit platform @@ -724,21 +730,21 @@ --------------------------------------------------------------------------------  -- | See if this instruction is telling us the current C stack delta-x86_takeDeltaInstr+takeDeltaInstr         :: Instr         -> Maybe Int -x86_takeDeltaInstr instr+takeDeltaInstr instr  = case instr of         DELTA i         -> Just i         _               -> Nothing  -x86_isMetaInstr+isMetaInstr         :: Instr         -> Bool -x86_isMetaInstr instr+isMetaInstr instr  = case instr of         COMMENT{}       -> True         LOCATION{}      -> True@@ -756,18 +762,18 @@ --      floating point and integer regs. If we need to do that then we --      have to go via memory. ---x86_mkRegRegMoveInstr+mkRegRegMoveInstr     :: Platform     -> Reg     -> Reg     -> Instr -x86_mkRegRegMoveInstr platform src dst+mkRegRegMoveInstr platform src dst  = case targetClassOfReg platform src of         RcInteger -> case platformArch platform of                      ArchX86    -> MOV II32 (OpReg src) (OpReg dst)                      ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)-                     _          -> panic "x86_mkRegRegMoveInstr: Bad arch"+                     _          -> panic "X86.mkRegRegMoveInstr: Bad arch"         RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)         -- this code is the lie we tell ourselves because both float and double         -- use the same register class.on x86_64 and x86 32bit with SSE2,@@ -778,22 +784,22 @@ --      The register allocator attempts to eliminate reg->reg moves whenever it can, --      by assigning the src and dest temporaries to the same real register. ---x86_takeRegRegMoveInstr+takeRegRegMoveInstr         :: Instr         -> Maybe (Reg,Reg) -x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))+takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))         = Just (r1,r2) -x86_takeRegRegMoveInstr _  = Nothing+takeRegRegMoveInstr _  = Nothing   -- | Make an unconditional branch instruction.-x86_mkJumpInstr+mkJumpInstr         :: BlockId         -> [Instr] -x86_mkJumpInstr id+mkJumpInstr id         = [JXX ALWAYS id]  -- Note [Windows stack layout]@@ -826,21 +832,22 @@ --   In essence each allocation larger than a page size needs to be chunked and --   a probe emitted after each page allocation.  You have to hit the guard --   page so the kernel can map in the next page, otherwise you'll segfault.+--   See Note [Windows stack allocations]. -- needs_probe_call :: Platform -> Int -> Bool needs_probe_call platform amount   = case platformOS platform of      OSMinGW32 -> case platformArch platform of                     ArchX86    -> amount > (4 * 1024)-                    ArchX86_64 -> amount > (8 * 1024)+                    ArchX86_64 -> amount > (4 * 1024)                     _          -> False      _         -> False -x86_mkStackAllocInstr+mkStackAllocInstr         :: Platform         -> Int         -> [Instr]-x86_mkStackAllocInstr platform amount+mkStackAllocInstr platform amount   = case platformOS platform of       OSMinGW32 ->         -- These will clobber AX but this should be ok because@@ -856,7 +863,7 @@         --         -- We emit a call because the stack probes are quite involved and         -- would bloat code size a lot.  GHC doesn't really have an -Os.-        -- __chkstk is guaranteed to leave all nonvolatile registers and AX+        -- ___chkstk is guaranteed to leave all nonvolatile registers and AX         -- untouched.  It's part of the standard prologue code for any Windows         -- function dropping the stack more than a page.         -- See Note [Windows stack layout]@@ -879,22 +886,22 @@                            [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)                            , TEST II64 (OpReg rsp) (OpReg rsp)                            ]-            _ -> panic "x86_mkStackAllocInstr"+            _ -> panic "X86.mkStackAllocInstr"       _       ->         case platformArch platform of           ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]           ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]-          _ -> panic "x86_mkStackAllocInstr"+          _ -> panic "X86.mkStackAllocInstr" -x86_mkStackDeallocInstr+mkStackDeallocInstr         :: Platform         -> Int         -> [Instr]-x86_mkStackDeallocInstr platform amount+mkStackDeallocInstr platform amount   = case platformArch platform of       ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]       ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]-      _ -> panic "x86_mkStackDeallocInstr"+      _ -> panic "X86.mkStackDeallocInstr"   --@@ -975,7 +982,7 @@       insert_dealloc insn r = case insn of          JMP _ _     -> dealloc ++ (insn : r)          JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"-         _other      -> x86_patchJumpInstr insn retarget : r+         _other      -> patchJumpInstr insn retarget : r            where retarget b = fromMaybe b (mapLookup b new_blockmap)        new_code = concatMap insert_stack_insns code

GHC/CmmToAsm/X86/Ppr.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -8,7 +9,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} module GHC.CmmToAsm.X86.Ppr (         pprNatCmmDecl,         pprData,@@ -24,30 +24,32 @@  import GHC.Prelude +import GHC.Platform+import GHC.Platform.Reg+ import GHC.CmmToAsm.X86.Regs import GHC.CmmToAsm.X86.Instr import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.Instr import GHC.CmmToAsm.Config import GHC.CmmToAsm.Format-import GHC.Platform.Reg+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils import GHC.CmmToAsm.Ppr -+import GHC.Cmm              hiding (topInfoTable) import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)-import GHC.Driver.Session-import GHC.Cmm              hiding (topInfoTable) import GHC.Cmm.BlockId import GHC.Cmm.CLabel++import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes) import GHC.Types.Unique ( pprUniqueAlways )-import GHC.Platform+ import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.Word-import Data.Bits  -- ----------------------------------------------------------------------------- -- Printing this stuff out@@ -87,35 +89,56 @@         -- special case for code without info table:         pprSectionAlign config (Section Text lbl) $$         pprProcAlignment config $$+        pprProcLabel config lbl $$         pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed         vcat (map (pprBasicBlock config top_info) blocks) $$-        (if ncgDebugLevel config > 0-         then ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+        ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$         pprSizeDecl platform lbl      Just (CmmStaticsRaw info_lbl _) ->       pprSectionAlign config (Section Text info_lbl) $$       pprProcAlignment config $$+      pprProcLabel config 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) $$+      ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$       -- above: Even the first block gets a label, because with branch-chain       -- elimination, it might be the target of a goto.       (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 +-- | Output an internal proc label. See Note [Internal proc labels] in CLabel.+pprProcLabel :: NCGConfig -> CLabel -> SDoc+pprProcLabel config lbl+  | ncgExposeInternalSymbols config+  , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl+  = lbl' <> char ':'+  | otherwise+  = empty++pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name+                -> SDoc+pprProcEndLabel platform lbl =+    pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'++pprBlockEndLabel :: Platform -> CLabel -- ^ Block name+                 -> SDoc+pprBlockEndLabel platform lbl =+    pdoc platform (mkAsmTempEndLabel lbl) <> char ':'+ -- | Output the ELF .size directive. 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@@ -123,9 +146,11 @@   = maybe_infotable $     pprLabel platform asmLbl $$     vcat (map (pprInstr platform) instrs) $$-    (if ncgDebugLevel config > 0-      then ppr (mkAsmTempEndLabel asmLbl) <> char ':'-      else empty+    ppWhen (ncgDwarfEnabled config) (+      -- Emit both end labels since this may end up being a standalone+      -- top-level block+      pprBlockEndLabel platform asmLbl+      <> pprProcEndLabel platform asmLbl     )   where     asmLbl = blockLbl blockid@@ -138,10 +163,8 @@            vcat (map (pprData config) info) $$            pprLabel platform infoLbl $$            c $$-           (if ncgDebugLevel config > 0-               then ppr (mkAsmTempEndLabel infoLbl) <> char ':'-               else empty-           )+           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> char ':')+     -- Make sure the info table has the right .loc for the block     -- coming right after it. See [Note: Info Offset]     infoTableLoc = case instrs of@@ -151,15 +174,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)@@ -178,10 +201,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 =@@ -244,14 +267,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@@ -269,11 +292,6 @@         log2 8 = 3         log2 n = 1 + log2 (n `quot` 2) -instance Outputable Instr where-    ppr instr = sdocWithDynFlags $ \dflags ->-                  pprInstr (targetPlatform dflags) instr-- pprReg :: Platform -> Format -> Reg -> SDoc pprReg platform f r   = case r of@@ -420,25 +438,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 _)  = text "naughty float immediate"-pprImm (ImmDouble _) = text "naughty double immediate"--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@@ -464,7 +480,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@@ -513,17 +529,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 FF32  (CmmFloat r _)-           = let bs = floatToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+        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 FF64 (CmmFloat r _)-           = let bs = doubleToBytes (fromRational r)-             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs+        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@@ -538,10 +549,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@@ -556,13 +567,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]--        ppr_item _ _-                = panic "X86.Ppr.ppr_item: no match"+                      [text "\t.quad\t" <> pprImm platform imm]   asmComment :: SDoc -> SDoc@@ -583,8 +591,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"@@ -826,14 +834,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@@ -842,7 +850,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@@ -941,7 +949,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@@ -966,7 +974,7 @@      = hcat [            pprMnemonic name format,            char '$',-           pprImm imm,+           pprImm platform imm,            comma,            pprOperand platform format op1        ]

GHC/CmmToAsm/X86/RegInfo.hs view

@@ -14,6 +14,7 @@ import GHC.Platform.Reg  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique

GHC/CmmToAsm/X86/Regs.hs view

@@ -58,6 +58,7 @@ import GHC.Cmm import GHC.Cmm.CLabel           ( CLabel ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform  import qualified Data.Array as A

GHC/CmmToC.hs view

@@ -1,5 +1,7 @@-{-# LANGUAGE CPP, DeriveFunctor, GADTs, PatternSynonyms #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP           #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs         #-}+{-# LANGUAGE LambdaCase    #-}  ----------------------------------------------------------------------------- --@@ -19,9 +21,10 @@ -- ----------------------------------------------------------------------------- -module GHC.CmmToC (-        writeC-  ) where+module GHC.CmmToC+   ( cmmToC+   )+where  #include "HsVersions.h" @@ -42,8 +45,10 @@ -- Utils import GHC.CmmToAsm.CPrim import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.Set import GHC.Types.Unique.FM@@ -54,50 +59,42 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Control.Monad.ST-import Data.Bits import Data.Char import Data.List (intersperse) import Data.Map (Map) import Data.Word-import System.IO import qualified Data.Map as Map import Control.Monad (ap) import qualified Data.Array.Unsafe as U ( castSTUArray ) import Data.Array.ST  -- ----------------------------------------------------------------------------- Top level--writeC :: DynFlags -> Handle -> RawCmmGroup -> IO ()-writeC dflags handle cmm = printForC dflags handle (pprC dflags cmm $$ blankLine)---- -------------------------------------------------------------------------- -- Now do some real work -- -- for fun, we could call cmmToCmm over the tops... -- -pprC :: DynFlags -> RawCmmGroup -> SDoc-pprC dflags tops = vcat $ intersperse blankLine $ map (pprTop dflags) tops+cmmToC :: Platform -> RawCmmGroup -> SDoc+cmmToC platform tops = (vcat $ intersperse blankLine $ map (pprTop platform) tops) $$ blankLine  -- -- top level procs ---pprTop :: DynFlags -> RawCmmDecl -> SDoc-pprTop dflags = \case+pprTop :: Platform -> RawCmmDecl -> SDoc+pprTop platform = \case   (CmmProc infos clbl _in_live_regs graph) ->     (case mapLookup (g_entry graph) infos of        Nothing -> empty        Just (CmmStaticsRaw info_clbl info_dat) ->            pprDataExterns platform info_dat $$-           pprWordArray dflags info_is_in_rodata info_clbl info_dat) $$+           pprWordArray platform info_is_in_rodata info_clbl info_dat) $$     (vcat [            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 dflags) blocks),+           vcat (map (pprBBlock platform) blocks),            rbrace ]     )     where@@ -114,26 +111,25 @@   (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     ]    (CmmData section (CmmStaticsRaw lbl lits)) ->     pprDataExterns platform lits $$-    pprWordArray dflags (isSecConstant section) lbl lits+    pprWordArray platform (isSecConstant section) lbl lits   where     isSecConstant section = case sectionProtection section of       ReadOnlySection -> True       WriteProtectedSection -> True       _ -> False-    platform = targetPlatform dflags  -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump.@@ -142,10 +138,10 @@ -- as many jumps as possible into fall throughs. -- -pprBBlock :: DynFlags -> CmmBlock -> SDoc-pprBBlock dflags block =+pprBBlock :: Platform -> CmmBlock -> SDoc+pprBBlock platform block =   nest 4 (pprBlockId (entryLabel block) <> colon) $$-  nest 8 (vcat (map (pprStmt dflags) (blockToList nodes)) $$ pprStmt dflags last)+  nest 8 (vcat (map (pprStmt platform) (blockToList nodes)) $$ pprStmt platform last)  where   (_, nodes, last)  = blockSplit block @@ -153,19 +149,23 @@ -- Info tables. Just arrays of words. -- See codeGen/ClosureInfo, and nativeGen/PprMach -pprWordArray :: DynFlags -> Bool -> CLabel -> [CmmStatic] -> SDoc-pprWordArray dflags is_ro lbl ds+pprWordArray :: Platform -> Bool -> CLabel -> [CmmStatic] -> SDoc+pprWordArray platform is_ro lbl ds   = -- 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 "= {" ]-    $$ nest 8 (commafy (pprStatics dflags ds))+    $$ nest 8 (commafy (staticLitsToWords platform $ toLits ds))     $$ text "};"   where-    platform = targetPlatform dflags+    toLits :: [CmmStatic] -> [CmmLit]+    toLits = map f+      where+        f (CmmStaticLit lit) = lit+        f static             = pprPanic "pprWordArray: Unexpected literal"  (pprStatic platform static)  pprAlignment :: Width -> SDoc pprAlignment words =@@ -203,9 +203,8 @@ -- Statements. -- -pprStmt :: DynFlags -> CmmNode e x -> SDoc--pprStmt dflags stmt =+pprStmt :: Platform -> CmmNode e x -> SDoc+pprStmt platform stmt =     case stmt of     CmmEntry{}   -> empty     CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")@@ -217,19 +216,18 @@     CmmTick _ -> empty     CmmUnwind{} -> empty -    CmmAssign dest src -> pprAssign dflags dest src+    CmmAssign dest src -> pprAssign platform dest src      CmmStore  dest src         | typeWidth rep == W64 && wordWidth platform /= W64         -> (if isFloatType rep then text "ASSIGN_DBL"                                else ptext (sLit ("ASSIGN_Word64"))) <>-           parens (mkP_ <> pprExpr1 dflags dest <> comma <> pprExpr dflags src) <> semi+           parens (mkP_ <> pprExpr1 platform dest <> comma <> pprExpr platform src) <> semi          | otherwise-        -> hsep [ pprExpr dflags (CmmLoad dest rep), equals, pprExpr dflags src <> semi ]+        -> hsep [ pprExpr platform (CmmLoad dest rep), equals, pprExpr platform src <> semi ]         where           rep = cmmExprType platform src-          platform = targetPlatform dflags      CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->         fnCall@@ -237,29 +235,28 @@         (res_hints, arg_hints) = foreignTargetHints target         hresults = zip results res_hints         hargs    = zip args arg_hints-        platform = targetPlatform dflags          ForeignConvention cconv _ _ ret = conv -        cast_fn = parens (cCast dflags (pprCFunType platform (char '*') cconv hresults hargs) fn)+        cast_fn = parens (cCast platform (pprCFunType platform (char '*') cconv hresults hargs) fn)          -- See wiki:commentary/compiler/backends/ppr-c#prototypes         fnCall =             case fn of               CmmLit (CmmLabel lbl)                 | StdCallConv <- cconv ->-                    pprCall dflags (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                         -- can't add the @n suffix ourselves, because                         -- it isn't valid C.                 | CmmNeverReturns <- ret ->-                    pprCall dflags cast_fn cconv hresults hargs <> semi+                    pprCall platform cast_fn cconv hresults hargs <> semi                 | not (isMathFun lbl) ->-                    pprForeignCall dflags (ppr lbl) cconv hresults hargs+                    pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs               _ ->-                    pprCall dflags cast_fn cconv hresults hargs <> semi+                    pprCall platform cast_fn cconv hresults hargs <> semi                         -- for a dynamic call, no declaration is necessary.      CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty@@ -282,28 +279,27 @@           -- builtins (see bug #5967).           | Just _align <- machOpMemcpyishAlign op           = (text ";EFF_(" <> fn <> char ')' <> semi) $$-            pprForeignCall dflags fn cconv hresults hargs+            pprForeignCall platform fn cconv hresults hargs           | otherwise-          = pprCall dflags fn cconv hresults hargs+          = pprCall platform fn cconv hresults hargs      CmmBranch ident               -> pprBranch ident-    CmmCondBranch expr yes no _   -> pprCondBranch dflags expr yes no-    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr dflags expr) <> semi-    CmmSwitch arg ids             -> pprSwitch dflags arg ids+    CmmCondBranch expr yes no _   -> pprCondBranch platform expr yes no+    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) -pprForeignCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]+pprForeignCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]                -> SDoc-pprForeignCall dflags fn cconv results args = fn_call+pprForeignCall platform fn cconv results args = fn_call   where-    platform = targetPlatform dflags     fn_call = braces (                  pprCFunType platform (char '*' <> text "ghcFunPtr") cconv results args <> semi               $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi-              $$ pprCall dflags (text "ghcFunPtr") cconv results args <> semi+              $$ pprCall platform (text "ghcFunPtr") cconv results args <> semi              )     cast_fn = parens (parens (pprCFunType platform (char '*') cconv results args) <> fn) @@ -326,9 +322,9 @@  -- --------------------------------------------------------------------- -- conditional branches to local labels-pprCondBranch :: DynFlags -> CmmExpr -> BlockId -> BlockId -> SDoc-pprCondBranch dflags expr yes no-        = hsep [ text "if" , parens(pprExpr dflags expr) ,+pprCondBranch :: Platform -> CmmExpr -> BlockId -> BlockId -> SDoc+pprCondBranch platform expr yes no+        = hsep [ text "if" , parens (pprExpr platform expr) ,                         text "goto", pprBlockId yes <> semi,                         text "else goto", pprBlockId no <> semi ] @@ -337,23 +333,22 @@ -- -- we find the fall-through cases ---pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc-pprSwitch dflags e ids-  = (hang (text "switch" <+> parens ( pprExpr dflags e ) <+> lbrace)+pprSwitch :: Platform -> CmmExpr -> SwitchTargets -> SDoc+pprSwitch platform e ids+  = (hang (text "switch" <+> parens ( pprExpr platform e ) <+> lbrace)                 4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace   where     (pairs, mbdef) = switchTargetsFallThrough ids-    platform = targetPlatform dflags      -- fall through case     caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix         where         do_fallthrough ix =-                 hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,+                 hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,                         text "/* fall through */" ]          final_branch ix =-                hsep [ text "case" , pprHexVal dflags ix (wordWidth platform) <> colon ,+                hsep [ text "case" , pprHexVal platform ix (wordWidth platform) <> colon ,                        text "goto" , (pprBlockId ident) <> semi ]      caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"@@ -375,30 +370,28 @@ -- -- (similar invariants apply to the rest of the pretty printer). -pprExpr :: DynFlags -> CmmExpr -> SDoc-pprExpr dflags e = case e of-    CmmLit lit      -> pprLit dflags lit-    CmmLoad e ty    -> pprLoad dflags e ty+pprExpr :: Platform -> CmmExpr -> SDoc+pprExpr platform e = case e of+    CmmLit lit      -> pprLit platform lit+    CmmLoad e ty    -> pprLoad platform e ty     CmmReg reg      -> pprCastReg reg     CmmRegOff reg 0 -> pprCastReg reg      -- CmmRegOff is an alias of MO_Add     CmmRegOff reg i -> pprCastReg reg <> char '+' <>-                       pprHexVal dflags (fromIntegral i) (wordWidth platform)+                       pprHexVal platform (fromIntegral i) (wordWidth platform) -    CmmMachOp mop args -> pprMachOpApp dflags mop args+    CmmMachOp mop args -> pprMachOpApp platform mop args      CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"-  where-    platform = targetPlatform dflags  -pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc-pprLoad dflags e ty+pprLoad :: Platform -> CmmExpr -> CmmType -> SDoc+pprLoad platform e ty   | width == W64, wordWidth platform /= W64   = (if isFloatType ty then text "PK_DBL"                        else text "PK_Word64")-    <> parens (mkP_ <> pprExpr1 dflags e)+    <> parens (mkP_ <> pprExpr1 platform e)    | otherwise   = case e of@@ -414,34 +407,33 @@         --       (For tagging to work, I had to avoid unaligned loads. --ARY)                         -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift platform)) -        _other -> cLoad dflags e ty+        _other -> cLoad platform e ty   where     width = typeWidth ty-    platform = targetPlatform dflags -pprExpr1 :: DynFlags -> CmmExpr -> SDoc-pprExpr1 dflags e = case e of-   CmmLit lit  -> pprLit1 dflags lit-   CmmReg _reg -> pprExpr dflags e-   _           -> parens (pprExpr dflags e)+pprExpr1 :: Platform -> CmmExpr -> SDoc+pprExpr1 platform e = case e of+   CmmLit lit  -> pprLit1 platform lit+   CmmReg _reg -> pprExpr platform e+   _           -> parens (pprExpr platform e)  -- -------------------------------------------------------------------------- -- MachOp applications -pprMachOpApp :: DynFlags -> MachOp -> [CmmExpr] -> SDoc+pprMachOpApp :: Platform -> MachOp -> [CmmExpr] -> SDoc -pprMachOpApp dflags op args+pprMachOpApp platform op args   | isMulMayOfloOp op-  = text "mulIntMayOflo" <> parens (commafy (map (pprExpr dflags) args))+  = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args))   where isMulMayOfloOp (MO_U_MulMayOflo _) = True         isMulMayOfloOp (MO_S_MulMayOflo _) = True         isMulMayOfloOp _ = False -pprMachOpApp dflags mop args+pprMachOpApp platform mop args   | Just ty <- machOpNeedsCast mop-  = ty <> parens (pprMachOpApp' dflags mop args)+  = ty <> parens (pprMachOpApp' platform mop args)   | otherwise-  = pprMachOpApp' dflags mop args+  = pprMachOpApp' platform mop args  -- Comparisons in C have type 'int', but we want type W_ (this is what -- resultRepOfMachOp says).  The other C operations inherit their type@@ -451,8 +443,8 @@   | isComparisonMachOp mop = Just mkW_   | otherwise              = Nothing -pprMachOpApp' :: DynFlags -> MachOp -> [CmmExpr] -> SDoc-pprMachOpApp' dflags mop args+pprMachOpApp' :: Platform -> MachOp -> [CmmExpr] -> SDoc+pprMachOpApp' platform mop args  = case args of     -- dyadic     [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y@@ -463,11 +455,10 @@     _     -> panic "PprC.pprMachOp : machop with wrong number of args"    where-    platform = targetPlatform dflags         -- Cast needed for signed integer ops-    pprArg e | signedOp    mop = cCast dflags (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e-             | needsFCasts mop = cCast dflags (machRep_F_CType (typeWidth (cmmExprType platform e))) e-             | otherwise       = pprExpr1 dflags e+    pprArg e | signedOp    mop = cCast platform (machRep_S_CType platform (typeWidth (cmmExprType platform e))) e+             | needsFCasts mop = cCast platform (machRep_F_CType (typeWidth (cmmExprType platform e))) e+             | otherwise       = pprExpr1 platform e     needsFCasts (MO_F_Eq _)   = False     needsFCasts (MO_F_Ne _)   = False     needsFCasts (MO_F_Neg _)  = True@@ -477,9 +468,9 @@ -- -------------------------------------------------------------------------- -- Literals -pprLit :: DynFlags -> CmmLit -> SDoc-pprLit dflags lit = case lit of-    CmmInt i rep      -> pprHexVal dflags i rep+pprLit :: Platform -> CmmLit -> SDoc+pprLit platform lit = case lit of+    CmmInt i rep      -> pprHexVal platform i rep      CmmFloat f w       -> parens (machRep_F_CType w) <> str         where d = fromRational f :: Double@@ -503,77 +494,88 @@         -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i      where-        pprCLabelAddr lbl = char '&' <> ppr lbl+        pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl -pprLit1 :: DynFlags -> CmmLit -> SDoc-pprLit1 dflags lit = case lit of-   (CmmLabelOff _ _)         -> parens (pprLit dflags lit)-   (CmmLabelDiffOff _ _ _ _) -> parens (pprLit dflags lit)-   (CmmFloat _ _)            -> parens (pprLit dflags lit)-   _                         -> pprLit dflags lit+pprLit1 :: Platform -> CmmLit -> SDoc+pprLit1 platform lit = case lit of+   (CmmLabelOff _ _)         -> parens (pprLit platform lit)+   (CmmLabelDiffOff _ _ _ _) -> parens (pprLit platform lit)+   (CmmFloat _ _)            -> parens (pprLit platform lit)+   _                         -> pprLit platform lit  -- --------------------------------------------------------------------------- -- Static data -pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]-pprStatics dflags = pprStatics'+-- | Produce a list of word sized literals encoding the given list of 'CmmLit's.+staticLitsToWords :: Platform -> [CmmLit] -> [SDoc]+staticLitsToWords platform = go . foldMap decomposeMultiWord   where-    platform    = targetPlatform dflags-    pprStatics' = \case-      [] -> []-      (CmmStaticLit (CmmFloat f W32) : rest)-        -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding-        | wordWidth platform == W64, CmmStaticLit (CmmInt 0 W32) : rest' <- rest-        -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest'-        -- adjacent floats aren't padded but combined into a single word-        | wordWidth platform == W64, CmmStaticLit (CmmFloat g W32) : rest' <- rest-        -> pprLit1 dflags (floatPairToWord platform f g) : pprStatics' rest'-        | wordWidth platform == W32-        -> pprLit1 dflags (floatToWord platform f) : pprStatics' rest-        | otherwise-        -> pprPanic "pprStatics: float" (vcat (map ppr' rest))-          where ppr' (CmmStaticLit l) = ppr (cmmLitType platform l)-                ppr' _other           = text "bad static!"+    -- rem_bytes is how many bytes remain in the word we are currently filling.+    -- accum is the word we are filling.+    go :: [CmmLit] -> [SDoc]+    go [] = []+    go lits@(lit : _)+      | Just _ <- isSubWordLit lit+      = goSubWord wordWidthBytes 0 lits+    go (lit : rest)+      = pprLit1 platform lit : go rest -      (CmmStaticLit (CmmFloat f W64) : rest)-        -> map (pprLit1 dflags) (doubleToWords platform f) ++ pprStatics' rest+    goSubWord :: Int -> Integer -> [CmmLit] -> [SDoc]+    goSubWord rem_bytes accum (lit : rest)+      | Just (bytes, w) <- isSubWordLit lit+      , rem_bytes >= widthInBytes w+      = let accum' = (accum `shiftL` widthInBits w) .|. fixEndian w bytes+        in goSubWord (rem_bytes - widthInBytes w) accum' rest+    goSubWord rem_bytes accum rest+      = pprWord (fixEndian (wordWidth platform) $ accum `shiftL` (8*rem_bytes)) : go rest -      (CmmStaticLit (CmmInt i W64) : rest)-        | wordWidth platform == W32-        -> case platformByteOrder platform of-            BigEndian    -> pprStatics' (CmmStaticLit (CmmInt q W32) :-                                         CmmStaticLit (CmmInt r W32) : rest)-            LittleEndian -> pprStatics' (CmmStaticLit (CmmInt r W32) :-                                         CmmStaticLit (CmmInt q W32) : rest)-           where r = i .&. 0xffffffff-                 q = i `shiftR` 32+    fixEndian :: Width -> Integer -> Integer+    fixEndian w = case platformByteOrder platform of+      BigEndian    -> id+      LittleEndian -> byteSwap w -      (CmmStaticLit (CmmInt a W32) : CmmStaticLit (CmmInt b W32) : rest)-        | wordWidth platform == W64-        -> case platformByteOrder platform of-             BigEndian    -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) : rest)-             LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) : rest)+    -- Decompose multi-word or floating-point literals into multiple+    -- single-word (or smaller) literals.+    decomposeMultiWord :: CmmLit -> [CmmLit]+    decomposeMultiWord (CmmFloat n W64)+      -- This will produce a W64 integer, which will then be broken up further+      -- on the next iteration on 32-bit platforms.+      = [doubleToWord64 n]+    decomposeMultiWord (CmmFloat n W32)+      = [floatToWord32 n]+    decomposeMultiWord (CmmInt n W64)+      | W32 <- wordWidth platform+      = [CmmInt hi W32, CmmInt lo W32]+      where+        hi = n `shiftR` 32+        lo = n .&. 0xffffffff+    decomposeMultiWord lit = [lit] -      (CmmStaticLit (CmmInt a W16) : CmmStaticLit (CmmInt b W16) : rest)-        | wordWidth platform == W32-        -> case platformByteOrder platform of-             BigEndian    -> pprStatics' (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) : rest)-             LittleEndian -> pprStatics' (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) : rest)+    -- Decompose a sub-word-sized literal into the integer value and its+    -- (sub-word-sized) width.+    isSubWordLit :: CmmLit -> Maybe (Integer, Width)+    isSubWordLit lit =+      case lit of+        CmmInt n w+          | w < wordWidth platform   -> Just (n, w)+        _                            -> Nothing -      (CmmStaticLit (CmmInt _ w) : _)-        | w /= wordWidth platform-        -> pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)+    wordWidthBytes = widthInBytes $ wordWidth platform -      (CmmStaticLit lit : rest)-        -> pprLit1 dflags lit : pprStatics' rest+    pprWord :: Integer -> SDoc+    pprWord n = pprHexVal platform n (wordWidth platform) -      (other : _)-        -> pprPanic "pprStatics: other" (pprStatic dflags other)+byteSwap :: Width -> Integer -> Integer+byteSwap width n = foldl' f 0 bytes+  where+    f acc m = (acc `shiftL` 8) .|. m+    bytes = [ byte i | i <- [0..widthInBytes width - 1] ]+    byte i = (n `shiftR` (i*8)) .&. 0xff -pprStatic :: DynFlags -> CmmStatic -> SDoc-pprStatic dflags s = case s of+pprStatic :: Platform -> CmmStatic -> SDoc+pprStatic platform s = case s of -    CmmStaticLit lit   -> nest 4 (pprLit dflags lit)+    CmmStaticLit lit   -> nest 4 (pprLit platform lit)     CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))      -- these should be inlined, like the old .hc@@ -854,6 +856,35 @@         (MO_Prefetch_Data _ ) -> unsupported         --- we could support prefetch via "__builtin_prefetch"         --- Not adding it for now+        MO_I64_ToI   -> unsupported+        MO_I64_FromI -> unsupported+        MO_W64_ToW   -> unsupported+        MO_W64_FromW -> unsupported+        MO_x64_Neg   -> unsupported+        MO_x64_Add   -> unsupported+        MO_x64_Sub   -> unsupported+        MO_x64_Mul   -> unsupported+        MO_I64_Quot  -> unsupported+        MO_I64_Rem   -> unsupported+        MO_W64_Quot  -> unsupported+        MO_W64_Rem   -> unsupported+        MO_x64_And   -> unsupported+        MO_x64_Or    -> unsupported+        MO_x64_Xor   -> unsupported+        MO_x64_Not   -> unsupported+        MO_x64_Shl   -> unsupported+        MO_I64_Shr   -> unsupported+        MO_W64_Shr   -> unsupported+        MO_x64_Eq    -> unsupported+        MO_x64_Ne    -> unsupported+        MO_I64_Ge    -> unsupported+        MO_I64_Gt    -> unsupported+        MO_I64_Le    -> unsupported+        MO_I64_Lt    -> unsupported+        MO_W64_Ge    -> unsupported+        MO_W64_Gt    -> unsupported+        MO_W64_Le    -> unsupported+        MO_W64_Lt    -> unsupported     where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop                             ++ " not supported!") @@ -881,7 +912,7 @@ -- -- Generating assignments is what we're all about, here ---pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc+pprAssign :: Platform -> CmmReg -> CmmExpr -> SDoc  -- dest is a reg, rhs is a reg pprAssign _ r1 (CmmReg r2)@@ -889,11 +920,10 @@    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]  -- dest is a reg, rhs is a CmmRegOff-pprAssign dflags r1 (CmmRegOff r2 off)+pprAssign platform r1 (CmmRegOff r2 off)    | isPtrReg r1 && isPtrReg r2 && (off `rem` platformWordSizeInBytes platform == 0)    = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]   where-        platform = targetPlatform dflags         off1 = off `shiftR` wordShift platform          (op,off') | off >= 0  = (char '+', off1)@@ -902,10 +932,10 @@ -- dest is a reg, rhs is anything. -- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting -- the lvalue elicits a warning from new GCC versions (3.4+).-pprAssign dflags r1 r2-  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 dflags r2)-  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 dflags r2)-  | otherwise                    = mkAssign (pprExpr dflags r2)+pprAssign platform r1 r2+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 platform r2)+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 platform r2)+  | otherwise                    = mkAssign (pprExpr platform r2)     where mkAssign x = if r1 == CmmGlobal BaseReg                        then text "ASSIGN_BaseReg" <> parens x <> semi                        else pprReg r1 <> text " = " <> x <> semi@@ -1004,8 +1034,8 @@ -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: DynFlags -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc-pprCall dflags ppr_fn cconv results args+pprCall :: Platform -> SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCall platform ppr_fn cconv results args   | not (is_cishCC cconv)   = panic $ "pprCall: unknown calling convention" @@ -1013,8 +1043,6 @@   =     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi   where-     platform = targetPlatform dflags-      ppr_assign []           rhs = rhs      ppr_assign [(one,hint)] rhs          = pprLocalReg one <> text " = "@@ -1022,12 +1050,12 @@      ppr_assign _other _rhs = panic "pprCall: multiple results"       pprArg (expr, AddrHint)-        = cCast dflags (text "void *") expr+        = cCast platform (text "void *") expr         -- see comment by machRepHintCType below      pprArg (expr, SignedHint)-        = cCast dflags (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr+        = cCast platform (machRep_S_CType platform $ typeWidth $ cmmExprType platform expr) expr      pprArg (expr, _other)-        = pprExpr dflags expr+        = pprExpr platform expr       pprUnHint AddrHint   rep = parens (machRepCType platform rep)      pprUnHint SignedHint rep = parens (machRepCType platform rep)@@ -1067,7 +1095,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 " */"              ]@@ -1090,7 +1118,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 @@ -1159,18 +1187,18 @@ -- --------------------------------------------------------------------- -- C types for MachReps -cCast :: DynFlags -> SDoc -> CmmExpr -> SDoc-cCast dflags ty expr = parens ty <> pprExpr1 dflags expr+cCast :: Platform -> SDoc -> CmmExpr -> SDoc+cCast platform ty expr = parens ty <> pprExpr1 platform expr -cLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc-cLoad dflags expr rep+cLoad :: Platform -> CmmExpr -> CmmType -> SDoc+cLoad platform expr rep     = if bewareLoadStoreAlignment (platformArch platform)       then let decl = machRepCType platform rep <+> text "x" <> semi                struct = text "struct" <+> braces (decl)                packed_attr = text "__attribute__((packed))"                cast = parens (struct <+> packed_attr <> char '*')-           in parens (cast <+> pprExpr1 dflags expr) <> text "->x"-      else char '*' <> parens (cCast dflags (machRepPtrCType platform rep) expr)+           in parens (cast <+> pprExpr1 platform expr) <> text "->x"+      else char '*' <> parens (cCast platform (machRepPtrCType platform rep) expr)     where -- On these platforms, unaligned loads are known to cause problems           bewareLoadStoreAlignment ArchAlpha    = True           bewareLoadStoreAlignment ArchMipseb   = True@@ -1183,7 +1211,6 @@           -- on unknown arches           bewareLoadStoreAlignment ArchUnknown  = True           bewareLoadStoreAlignment _            = False-          platform = targetPlatform dflags  isCmmWordType :: Platform -> CmmType -> Bool -- True of GcPtrReg/NonGcReg of native word size@@ -1271,70 +1298,31 @@ -- This is a hack to turn the floating point numbers into ints that we -- can safely initialise to static locations. -castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)-castFloatToWord32Array = U.castSTUArray--castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)-castDoubleToWord64Array = U.castSTUArray--floatToWord :: Platform -> Rational -> CmmLit-floatToWord platform r-  = runST (do+floatToWord32 :: Rational -> CmmLit+floatToWord32 r+  = runST $ do         arr <- newArray_ ((0::Int),0)         writeArray arr 0 (fromRational r)         arr' <- castFloatToWord32Array arr         w32 <- readArray arr' 0-        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth platform))-    )-    where wo | wordWidth platform == W64-             , BigEndian <- platformByteOrder platform-             = 32-             | otherwise-             = 0--floatPairToWord :: Platform -> Rational -> Rational -> CmmLit-floatPairToWord platform r1 r2-  = runST (do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r1)-        writeArray arr 1 (fromRational r2)-        arr' <- castFloatToWord32Array arr-        w32_1 <- readArray arr' 0-        w32_2 <- readArray arr' 1-        return (pprWord32Pair w32_1 w32_2)-    )-    where pprWord32Pair w32_1 w32_2-              | BigEndian <- platformByteOrder platform =-                  CmmInt ((shiftL i1 32) .|. i2) W64-              | otherwise =-                  CmmInt ((shiftL i2 32) .|. i1) W64-              where i1 = toInteger w32_1-                    i2 = toInteger w32_2+        return (CmmInt (toInteger w32) W32)+  where+    castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)+    castFloatToWord32Array = U.castSTUArray -doubleToWords :: Platform -> Rational -> [CmmLit]-doubleToWords platform r-  = runST (do+doubleToWord64 :: Rational -> CmmLit+doubleToWord64 r+  = runST $ do         arr <- newArray_ ((0::Int),1)         writeArray arr 0 (fromRational r)         arr' <- castDoubleToWord64Array arr         w64 <- readArray arr' 0-        return (pprWord64 w64)-    )-    where targetWidth = wordWidth platform-          pprWord64 w64-              | targetWidth == W64 =-                  [ CmmInt (toInteger w64) targetWidth ]-              | targetWidth == W32 =-                  [ CmmInt (toInteger targetW1) targetWidth-                  , CmmInt (toInteger targetW2) targetWidth-                  ]-              | otherwise = panic "doubleToWords.pprWord64"-              where (targetW1, targetW2) = case platformByteOrder platform of-                        BigEndian    -> (wHi, wLo)-                        LittleEndian -> (wLo, wHi)-                    wHi = w64 `shiftR` 32-                    wLo = w64 .&. 0xFFFFffff+        return $ CmmInt (toInteger w64) W64+  where+    castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)+    castDoubleToWord64Array = U.castSTUArray + -- --------------------------------------------------------------------------- -- Utils @@ -1344,23 +1332,36 @@ commafy :: [SDoc] -> SDoc commafy xs = hsep $ punctuate comma xs --- Print in C hex format: 0x13fa-pprHexVal :: DynFlags -> Integer -> Width -> SDoc-pprHexVal dflags w rep-  | w < 0     = parens (char '-' <>-                    text "0x" <> intToDoc (-w) <> repsuffix rep)-  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+-- | Print in C hex format+--+-- Examples:+--+--   5114    :: W32  ===>  ((StgWord32)0x13faU)+--   (-5114) :: W32  ===>  ((StgWord32)(-0x13faU))+--+-- We use casts to support types smaller than `unsigned int`; C literal+-- suffixes support longer but not shorter types.+pprHexVal :: Platform -> Integer -> Width -> SDoc+pprHexVal platform w rep = parens ctype <> rawlit   where+      rawlit+        | w < 0     = parens (char '-' <>+                          text "0x" <> intToDoc (-w) <> repsuffix rep)+        | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+      ctype = machRep_U_CType platform rep+         -- type suffix for literals:         -- Integer literals are unsigned in Cmm/C.  We explicitly cast to         -- signed values for doing signed operations, but at all other         -- times values are unsigned.  This also helps eliminate occasional         -- warnings about integer overflow from gcc. +      constants = platformConstants platform+       repsuffix W64 =-               if cINT_SIZE       dflags == 8 then char 'U'-          else if cLONG_SIZE      dflags == 8 then text "UL"-          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"+               if pc_CINT_SIZE       constants == 8 then char 'U'+          else if pc_CLONG_SIZE      constants == 8 then text "UL"+          else if pc_CLONG_LONG_SIZE constants == 8 then text "ULL"           else panic "pprHexVal: Can't find a 64-bit type"       repsuffix _ = char 'U'

GHC/CmmToLlvm.hs view

@@ -34,6 +34,8 @@ import GHC.Utils.Error import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger import GHC.SysTools ( figureLlvmVersion ) import qualified GHC.Data.Stream as Stream @@ -44,25 +46,25 @@ -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator ---llvmCodeGen :: DynFlags -> Handle+llvmCodeGen :: Logger -> DynFlags -> Handle                -> Stream.Stream IO RawCmmGroup a                -> IO a-llvmCodeGen dflags h cmm_stream-  = withTiming dflags (text "LLVM CodeGen") (const ()) $ do+llvmCodeGen logger dflags h cmm_stream+  = withTiming logger dflags (text "LLVM CodeGen") (const ()) $ do        bufh <- newBufHandle h         -- Pass header-       showPass dflags "LLVM CodeGen"+       showPass logger dflags "LLVM CodeGen"         -- get llvm version, cache for later use-       mb_ver <- figureLlvmVersion dflags+       mb_ver <- figureLlvmVersion logger dflags         -- warn if unsupported        forM_ mb_ver $ \ver -> do-         debugTraceMsg dflags 2+         debugTraceMsg logger dflags 2               (text "Using LLVM version:" <+> text (llvmVersionStr ver))          let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags-         when (not (llvmVersionSupported ver) && doWarn) $ putMsg dflags $+         when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger dflags $            "You are using an unsupported version of LLVM!" $$            "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>            "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>@@ -70,7 +72,7 @@            "We will try though..."          let isS390X = platformArch (targetPlatform dflags) == ArchS390X          let major_ver = head . llvmVersionList $ ver-         when (isS390X && major_ver < 10 && doWarn) $ putMsg dflags $+         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger dflags $            "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>            "You are using LLVM version: " <> text (llvmVersionStr ver) @@ -81,14 +83,14 @@            llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver         -- run code generation-       a <- runLlvm dflags llvm_ver bufh $-         llvmCodeGen' dflags (liftStream cmm_stream)+       a <- runLlvm logger dflags llvm_ver bufh $+         llvmCodeGen' dflags cmm_stream         bFlush bufh         return a -llvmCodeGen' :: DynFlags -> Stream.Stream LlvmM RawCmmGroup a -> LlvmM a+llvmCodeGen' :: DynFlags -> Stream.Stream IO RawCmmGroup a -> LlvmM a llvmCodeGen' dflags cmm_stream   = do  -- Preamble         renderLlvm header@@ -96,7 +98,7 @@         cmmMetaLlvmPrelude          -- Procedures-        a <- Stream.consume cmm_stream llvmGroupLlvmGens+        a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens          -- Declare aliases for forward references         opts <- getLlvmOpts@@ -166,11 +168,11 @@ cmmLlvmGen cmm@CmmProc{} = do      -- rewrite assignments to global regs-    dflags <- getDynFlags-    let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm+    platform <- getPlatform+    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

GHC/CmmToLlvm/Base.hs view

@@ -15,19 +15,19 @@         LiveGlobalRegs,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion, llvmVersionSupported, parseLlvmVersion,-        supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,+        LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,+        llvmVersionSupported, parseLlvmVersion,         llvmVersionStr, llvmVersionList,          LlvmM,-        runLlvm, liftStream, withClearVars, varLookup, varInsert,+        runLlvm, withClearVars, varLookup, varInsert,         markStackReg, checkStackReg,         funLookup, funInsert, getLlvmVer, getDynFlags,         dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,         ghcInternalFunctions, getPlatform, getLlvmOpts,          getMetaUniqueId,-        setUniqMeta, getUniqMeta,+        setUniqMeta, getUniqMeta, liftIO,          cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,         llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,@@ -62,8 +62,7 @@ import GHC.Utils.BufHandle   ( BufHandle ) import GHC.Types.Unique.Set import GHC.Types.Unique.Supply-import GHC.Utils.Error-import qualified GHC.Data.Stream as Stream+import GHC.Utils.Logger  import Data.Maybe (fromJust) import Control.Monad (ap)@@ -308,6 +307,7 @@   { envVersion :: LlvmVersion      -- ^ LLVM version   , envOpts    :: LlvmOpts         -- ^ LLVM backend options   , envDynFlags :: DynFlags        -- ^ Dynamic flags+  , envLogger :: !Logger           -- ^ Logger   , envOutput :: BufHandle         -- ^ Output buffer   , envMask :: !Char               -- ^ Mask for creating unique values   , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs@@ -338,6 +338,10 @@ instance HasDynFlags LlvmM where     getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) +instance HasLogger LlvmM where+    getLogger = LlvmM $ \env -> return (envLogger env, env)++ -- | Get target platform getPlatform :: LlvmM Platform getPlatform = llvmOptsPlatform <$> getLlvmOpts@@ -361,8 +365,8 @@                               return (x, env)  -- | Get initial Llvm environment.-runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a-runLlvm dflags ver out m = do+runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a+runLlvm logger dflags ver out m = do     (a, _) <- runLlvmM m env     return a   where env = LlvmEnv { envFunMap = emptyUFM@@ -373,6 +377,7 @@                       , envVersion = ver                       , envOpts = initLlvmOpts dflags                       , envDynFlags = dflags+                      , envLogger = logger                       , envOutput = out                       , envMask = 'n'                       , envFreshMeta = MetaId 0@@ -387,14 +392,6 @@ modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () modifyEnv f = LlvmM (\env -> return ((), f env)) --- | Lift a stream into the LlvmM monad-liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x-liftStream s = Stream.Stream $ do-  r <- liftIO $ Stream.runStream s-  case r of-    Left b        -> return (Left b)-    Right (a, r2) -> return (Right (a, liftStream r2))- -- | Clear variables from the environment for a subcomputation withClearVars :: LlvmM a -> LlvmM a withClearVars m = LlvmM $ \env -> do@@ -432,7 +429,8 @@ dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () dumpIfSetLlvm flag hdr fmt doc = do   dflags <- getDynFlags-  liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc+  logger <- getLogger+  liftIO $ dumpIfSet_dyn logger dflags flag hdr fmt doc  -- | Prints the given contents to the output handle renderLlvm :: Outp.SDoc -> LlvmM ()@@ -441,7 +439,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@@ -481,9 +479,8 @@ ghcInternalFunctions :: LlvmM () ghcInternalFunctions = do     platform <- getPlatform-    dflags <- getDynFlags     let w = llvmWord platform-        cint = LMInt $ widthInBits $ cIntWidth dflags+        cint = LMInt $ widthInBits $ cIntWidth platform     mk "memcmp" cint [i8Ptr, i8Ptr, w]     mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]     mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]@@ -505,9 +502,10 @@ strCLabel_llvm :: CLabel -> LlvmM LMString strCLabel_llvm lbl = do     dflags <- getDynFlags-    let sdoc = pprCLabel dflags lbl-        str = Outp.renderWithStyle-                  (initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))+    platform <- getPlatform+    let sdoc = pprCLabel platform CStyle lbl+        str = Outp.renderWithContext+                  (initSDocContext dflags (Outp.PprCode Outp.CStyle))                   sdoc     return (fsLit str)

GHC/CmmToLlvm/CodeGen.hs view

@@ -10,6 +10,9 @@  import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Regs@@ -25,11 +28,11 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Collections -import GHC.Driver.Session import GHC.Data.FastString import GHC.Types.ForeignCall-import GHC.Utils.Outputable hiding (panic, pprPanic)-import qualified GHC.Utils.Outputable as Outputable+import GHC.Utils.Outputable+import GHC.Utils.Panic (assertPanic)+import qualified GHC.Utils.Panic as Panic import GHC.Platform import GHC.Data.OrdList import GHC.Types.Unique.Supply@@ -185,18 +188,18 @@         else barrier  -- | Foreign Calls-genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]-              -> LlvmM StmtData+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData  -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions. genCall (PrimTarget MO_ReadBarrier) _ _ =     barrierUnless [ArchX86, ArchX86_64, ArchSPARC]-genCall (PrimTarget MO_WriteBarrier) _ _ = do++genCall (PrimTarget MO_WriteBarrier) _ _ =     barrierUnless [ArchX86, ArchX86_64, ArchSPARC] -genCall (PrimTarget MO_Touch) _ _- = return (nilOL, [])+genCall (PrimTarget MO_Touch) _ _ =+    return (nilOL, [])  genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do     dstV <- getCmmRegW (CmmLocal dst)@@ -514,9 +517,8 @@      -- make the actual call     case retTy of-        LMVoid -> do+        LMVoid ->             statement $ Expr $ Call ccTy fptr argVars fnAttrs-         _ -> do             v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs             -- get the return register@@ -905,6 +907,37 @@     MO_Cmpxchg _     -> unsupported     MO_Xchg _        -> unsupported +    MO_I64_ToI       -> fsLit "hs_int64ToInt"+    MO_I64_FromI     -> fsLit "hs_intToInt64"+    MO_W64_ToW       -> fsLit "hs_word64ToWord"+    MO_W64_FromW     -> fsLit "hs_wordToWord64"+    MO_x64_Neg       -> fsLit "hs_neg64"+    MO_x64_Add       -> fsLit "hs_add64"+    MO_x64_Sub       -> fsLit "hs_sub64"+    MO_x64_Mul       -> fsLit "hs_mul64"+    MO_I64_Quot      -> fsLit "hs_quotInt64"+    MO_I64_Rem       -> fsLit "hs_remInt64"+    MO_W64_Quot      -> fsLit "hs_quotWord64"+    MO_W64_Rem       -> fsLit "hs_remWord64"+    MO_x64_And       -> fsLit "hs_and64"+    MO_x64_Or        -> fsLit "hs_or64"+    MO_x64_Xor       -> fsLit "hs_xor64"+    MO_x64_Not       -> fsLit "hs_not64"+    MO_x64_Shl       -> fsLit "hs_uncheckedShiftL64"+    MO_I64_Shr       -> fsLit "hs_uncheckedIShiftRA64"+    MO_W64_Shr       -> fsLit "hs_uncheckedShiftRL64"+    MO_x64_Eq        -> fsLit "hs_eq64"+    MO_x64_Ne        -> fsLit "hs_ne64"+    MO_I64_Ge        -> fsLit "hs_geInt64"+    MO_I64_Gt        -> fsLit "hs_gtInt64"+    MO_I64_Le        -> fsLit "hs_leInt64"+    MO_I64_Lt        -> fsLit "hs_ltInt64"+    MO_W64_Ge        -> fsLit "hs_geWord64"+    MO_W64_Gt        -> fsLit "hs_gtWord64"+    MO_W64_Le        -> fsLit "hs_leWord64"+    MO_W64_Lt        -> fsLit "hs_ltWord64"++ -- | Tail function calls genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData @@ -1507,9 +1540,9 @@     MO_And _   -> genBinMach LM_MO_And     MO_Or  _   -> genBinMach LM_MO_Or     MO_Xor _   -> genBinMach LM_MO_Xor-    MO_Shl _   -> genBinMach LM_MO_Shl-    MO_U_Shr _ -> genBinMach LM_MO_LShr-    MO_S_Shr _ -> genBinMach LM_MO_AShr+    MO_Shl _   -> genBinCastYMach LM_MO_Shl+    MO_U_Shr _ -> genBinCastYMach LM_MO_LShr+    MO_S_Shr _ -> genBinCastYMach LM_MO_AShr      MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add     MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub@@ -1553,20 +1586,27 @@ #endif      where-        binLlvmOp ty binOp = do+        binLlvmOp ty binOp allow_y_cast = do           platform <- getPlatform           runExprData $ do             vx <- exprToVarW x             vy <- exprToVarW y-            if getVarType vx == getVarType vy-                then do-                    doExprW (ty vx) $ binOp vx vy -                else do+            if | getVarType vx == getVarType vy+               -> doExprW (ty vx) $ binOp vx vy++               | allow_y_cast+               -> do+                    vy' <- singletonPanic "binLlvmOp cast"<$>+                            castVarsW Signed [(vy, (ty vx))]+                    doExprW (ty vx) $ binOp vx vy'++               | otherwise+               -> do                     -- Error. Continue anyway so we can debug the generated ll file.                     dflags <- getDynFlags-                    let style = mkCodeStyle CStyle-                        toString doc = renderWithStyle (initSDocContext dflags style) doc+                    let style = PprCode CStyle+                        toString doc = renderWithContext (initSDocContext dflags style) doc                         cmmToStr = (lines . toString . PprCmm.pprExpr platform)                     statement $ Comment $ map fsLit $ cmmToStr x                     statement $ Comment $ map fsLit $ cmmToStr y@@ -1584,7 +1624,7 @@         -- comparisons while LLVM return i1. Need to extend to llvmWord type         -- if expected. See Note [Literals and branch conditions].         genBinComp opt cmp = do-            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) False             dflags <- getDynFlags             platform <- getPlatform             if getVarType v1 == i1@@ -1598,8 +1638,10 @@                     panic $ "genBinComp: Compare returned type other then i1! "                         ++ (showSDoc dflags $ ppr $ getVarType v1) -        genBinMach op = binLlvmOp getVarType (LlvmOp op)+        genBinMach op = binLlvmOp getVarType (LlvmOp op) False +        genBinCastYMach op = binLlvmOp getVarType (LlvmOp op) True+         genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)          -- | Detect if overflow will occur in signed multiply of the two@@ -1717,19 +1759,19 @@   runExprData $ do     iptr <- exprToVarW e     case getVarType iptr of-         LMPointer _ -> do+        LMPointer _ ->                     doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) -         i@(LMInt _) | i == llvmWord platform -> do+        i@(LMInt _) | i == llvmWord platform -> do                     let pty = LMPointer $ cmmToLlvmType ty                     ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty                     doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) -         other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"-                        (PprCmm.pprExpr platform e <+> text (-                            "Size of Ptr: " ++ show (llvmPtrBits platform) ++-                            ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                            ", Var: " ++ showSDoc dflags (ppVar opts iptr)))+        other -> pprPanic "exprToVar: CmmLoad expression is not right type!"+                     (PprCmm.pprExpr platform e <+> text (+                         "Size of Ptr: " ++ show (llvmPtrBits platform) +++                         ", Size of var: " ++ show (llvmWidthInBits platform other) +++                         ", Var: " ++ showSDoc dflags (ppVar opts iptr)))   where     loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr                   | otherwise = Load ptr@@ -2004,10 +2046,10 @@  -- | Error functions panic :: HasCallStack => String -> a-panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s+panic s = Panic.panic $ "GHC.CmmToLlvm.CodeGen." ++ s  pprPanic :: HasCallStack => String -> SDoc -> a-pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d+pprPanic s d = Panic.pprPanic ("GHC.CmmToLlvm.CodeGen." ++ s) d   -- | Returns TBAA meta data by unique

GHC/CmmToLlvm/Data.hs view

@@ -20,7 +20,7 @@ import GHC.Platform  import GHC.Data.FastString-import GHC.Utils.Outputable+import GHC.Utils.Panic import qualified Data.ByteString as BS  -- ----------------------------------------------------------------------------

GHC/CmmToLlvm/Mangler.hs view

@@ -17,15 +17,16 @@ import GHC.Platform ( platformArch, Arch(..) ) import GHC.Utils.Error ( withTiming ) import GHC.Utils.Outputable ( text )+import GHC.Utils.Logger  import Control.Exception import qualified Data.ByteString.Char8 as B import System.IO  -- | Read in assembly file and process-llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO ()-llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-}-    withTiming dflags (text "LLVM Mangler") id $+llvmFixupAsm :: Logger -> DynFlags -> FilePath -> FilePath -> IO ()+llvmFixupAsm logger dflags f1 f2 = {-# SCC "llvm_mangler" #-}+    withTiming logger dflags (text "LLVM Mangler") id $     withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do         go r w         hClose r

GHC/CmmToLlvm/Ppr.hs view

@@ -11,6 +11,8 @@  import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Llvm import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Data

GHC/CmmToLlvm/Regs.hs view

@@ -18,7 +18,7 @@ import GHC.Cmm.Expr import GHC.Platform import GHC.Data.FastString-import GHC.Utils.Outputable ( panic )+import GHC.Utils.Panic ( panic ) import GHC.Types.Unique  -- | Get the LlvmVar function variable storing the real register@@ -50,12 +50,12 @@         VanillaReg 9 _ -> wordGlobal $ "R9" ++ suf         VanillaReg 10 _ -> wordGlobal $ "R10" ++ suf         SpLim          -> wordGlobal $ "SpLim" ++ suf-        FloatReg 1     -> floatGlobal $"F1" ++ suf-        FloatReg 2     -> floatGlobal $"F2" ++ suf-        FloatReg 3     -> floatGlobal $"F3" ++ suf-        FloatReg 4     -> floatGlobal $"F4" ++ suf-        FloatReg 5     -> floatGlobal $"F5" ++ suf-        FloatReg 6     -> floatGlobal $"F6" ++ suf+        FloatReg 1     -> floatGlobal $ "F1" ++ suf+        FloatReg 2     -> floatGlobal $ "F2" ++ suf+        FloatReg 3     -> floatGlobal $ "F3" ++ suf+        FloatReg 4     -> floatGlobal $ "F4" ++ suf+        FloatReg 5     -> floatGlobal $ "F5" ++ suf+        FloatReg 6     -> floatGlobal $ "F6" ++ suf         DoubleReg 1    -> doubleGlobal $ "D1" ++ suf         DoubleReg 2    -> doubleGlobal $ "D2" ++ suf         DoubleReg 3    -> doubleGlobal $ "D3" ++ suf

GHC/Core.hs view

@@ -6,14 +6,14 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE BangPatterns #-}+ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core (         -- * Main data types-        Expr(..), Alt, Bind(..), AltCon(..), Arg,-        Tickish(..), TickishScoping(..), TickishPlacement(..),+        Expr(..), Alt(..), Bind(..), AltCon(..), Arg,         CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,         TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr, @@ -29,6 +29,7 @@          mkIntLit, mkIntLitWrap,         mkWordLit, mkWordLitWrap,+        mkWord8Lit,         mkWord64LitWord64, mkInt64LitInt64,         mkCharLit, mkStringLit,         mkFloatLit, mkFloatLitFloat,@@ -51,12 +52,6 @@         isValArg, isTypeArg, isCoArg, isTyCoArg, valArgCount, valBndrCount,         isRuntimeArg, isRuntimeVar, -        -- * Tick-related functions-        tickishCounts, tickishScoped, tickishScopesLike, tickishFloatable,-        tickishCanSplit, mkNoCount, mkNoScope,-        tickishIsCode, tickishPlace,-        tickishContains,-         -- * Unfolding data types         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..), @@ -74,7 +69,7 @@         canUnfold, neverUnfoldGuidance, isStableSource,          -- * Annotated expression data types-        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt,+        AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt(..),          -- ** Operations on annotated expressions         collectAnnArgs, collectAnnArgsTicks,@@ -102,7 +97,6 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.CostCentre import GHC.Types.Var.Env( InScopeSet ) import GHC.Types.Var import GHC.Core.Type@@ -111,15 +105,19 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env( NameEnv, emptyNameEnv ) import GHC.Types.Literal+import GHC.Types.Tickish import GHC.Core.DataCon import GHC.Unit.Module import GHC.Types.Basic-import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Types.Unique.Set-import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan )+ import GHC.Utils.Binary+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic +import GHC.Driver.Ppr+ import Data.Data hiding (TyCon) import Data.Int import Data.Word@@ -262,7 +260,7 @@   | Case  (Expr b) b Type [Alt b]   -- See Note [Case expression invariants]                                     -- and Note [Why does Case have a 'Type' field?]   | Cast  (Expr b) CoercionR        -- The Coercion has Representational role-  | Tick  (Tickish Id) (Expr b)+  | Tick  CoreTickish (Expr b)   | Type  Type   | Coercion Coercion   deriving Data@@ -277,7 +275,9 @@  -- If you edit this type, you may need to update the GHC formalism -- See Note [GHC Formalism] in GHC.Core.Lint-type Alt b = (AltCon, [b], Expr b)+data Alt b+    = Alt AltCon [b] (Expr b)+    deriving (Data)  -- | A case alternative constructor (i.e. pattern match) @@ -925,279 +925,6 @@ type MOutCoercion = MCoercion  -{- *********************************************************************-*                                                                      *-              Ticks-*                                                                      *-************************************************************************--}---- | Allows attaching extra information to points in expressions---- If you edit this type, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-data Tickish id =-    -- | An @{-# SCC #-}@ profiling annotation, either automatically-    -- added by the desugarer as a result of -auto-all, or added by-    -- the user.-    ProfNote {-      profNoteCC    :: CostCentre, -- ^ the cost centre-      profNoteCount :: !Bool,      -- ^ bump the entry count?-      profNoteScope :: !Bool       -- ^ scopes over the enclosed expression-                                   -- (i.e. not just a tick)-    }--  -- | A "tick" used by HPC to track the execution of each-  -- subexpression in the original source code.-  | HpcTick {-      tickModule :: Module,-      tickId     :: !Int-    }--  -- | A breakpoint for the GHCi debugger.  This behaves like an HPC-  -- tick, but has a list of free variables which will be available-  -- for inspection in GHCi when the program stops at the breakpoint.-  ---  -- NB. we must take account of these Ids when (a) counting free variables,-  -- and (b) substituting (don't substitute for them)-  | Breakpoint-    { breakpointId     :: !Int-    , breakpointFVs    :: [id]  -- ^ the order of this list is important:-                                -- it matches the order of the lists in the-                                -- appropriate entry in 'GHC.Driver.Types.ModBreaks'.-                                ---                                -- Careful about substitution!  See-                                -- Note [substTickish] in "GHC.Core.Subst".-    }--  -- | A source note.-  ---  -- Source notes are pure annotations: Their presence should neither-  -- influence compilation nor execution. The semantics are given by-  -- causality: The presence of a source note means that a local-  -- change in the referenced source code span will possibly provoke-  -- the generated code to change. On the flip-side, the functionality-  -- of annotated code *must* be invariant against changes to all-  -- source code *except* the spans referenced in the source notes-  -- (see "Causality of optimized Haskell" paper for details).-  ---  -- Therefore extending the scope of any given source note is always-  -- valid. Note that it is still undesirable though, as this reduces-  -- their usefulness for debugging and profiling. Therefore we will-  -- generally try only to make use of this property where it is-  -- necessary to enable optimizations.-  | SourceNote-    { sourceSpan :: RealSrcSpan -- ^ Source covered-    , sourceName :: String      -- ^ Name for source location-                                --   (uses same names as CCs)-    }--  deriving (Eq, Ord, Data)---- | A "counting tick" (where tickishCounts is True) is one that--- counts evaluations in some way.  We cannot discard a counting tick,--- and the compiler should preserve the number of counting ticks as--- far as possible.------ However, we still allow the simplifier to increase or decrease--- sharing, so in practice the actual number of ticks may vary, except--- that we never change the value from zero to non-zero or vice versa.-tickishCounts :: Tickish id -> Bool-tickishCounts n@ProfNote{} = profNoteCount n-tickishCounts HpcTick{}    = True-tickishCounts Breakpoint{} = True-tickishCounts _            = False----- | Specifies the scoping behaviour of ticks. This governs the--- behaviour of ticks that care about the covered code and the cost--- associated with it. Important for ticks relating to profiling.-data TickishScoping =-    -- | No scoping: The tick does not care about what code it-    -- covers. Transformations can freely move code inside as well as-    -- outside without any additional annotation obligations-    NoScope--    -- | Soft scoping: We want all code that is covered to stay-    -- covered.  Note that this scope type does not forbid-    -- transformations from happening, as long as all results of-    -- the transformations are still covered by this tick or a copy of-    -- it. For example-    ---    --   let x = tick<...> (let y = foo in bar) in baz-    --     ===>-    --   let x = tick<...> bar; y = tick<...> foo in baz-    ---    -- Is a valid transformation as far as "bar" and "foo" is-    -- concerned, because both still are scoped over by the tick.-    ---    -- Note though that one might object to the "let" not being-    -- covered by the tick any more. However, we are generally lax-    -- with this - constant costs don't matter too much, and given-    -- that the "let" was effectively merged we can view it as having-    -- lost its identity anyway.-    ---    -- Also note that this scoping behaviour allows floating a tick-    -- "upwards" in pretty much any situation. For example:-    ---    --   case foo of x -> tick<...> bar-    --     ==>-    --   tick<...> case foo of x -> bar-    ---    -- While this is always legal, we want to make a best effort to-    -- only make us of this where it exposes transformation-    -- opportunities.-  | SoftScope--    -- | Cost centre scoping: We don't want any costs to move to other-    -- cost-centre stacks. This means we not only want no code or cost-    -- to get moved out of their cost centres, but we also object to-    -- code getting associated with new cost-centre ticks - or-    -- changing the order in which they get applied.-    ---    -- A rule of thumb is that we don't want any code to gain new-    -- annotations. However, there are notable exceptions, for-    -- example:-    ---    --   let f = \y -> foo in tick<...> ... (f x) ...-    --     ==>-    --   tick<...> ... foo[x/y] ...-    ---    -- In-lining lambdas like this is always legal, because inlining a-    -- function does not change the cost-centre stack when the-    -- function is called.-  | CostCentreScope--  deriving (Eq)---- | Returns the intended scoping rule for a Tickish-tickishScoped :: Tickish id -> TickishScoping-tickishScoped n@ProfNote{}-  | profNoteScope n        = CostCentreScope-  | otherwise              = NoScope-tickishScoped HpcTick{}    = NoScope-tickishScoped Breakpoint{} = CostCentreScope-   -- Breakpoints are scoped: eventually we're going to do call-   -- stacks, but also this helps prevent the simplifier from moving-   -- breakpoints around and changing their result type (see #1531).-tickishScoped SourceNote{} = SoftScope---- | Returns whether the tick scoping rule is at least as permissive--- as the given scoping rule.-tickishScopesLike :: Tickish id -> TickishScoping -> Bool-tickishScopesLike t scope = tickishScoped t `like` scope-  where NoScope         `like` _               = True-        _               `like` NoScope         = False-        SoftScope       `like` _               = True-        _               `like` SoftScope       = False-        CostCentreScope `like` _               = True---- | Returns @True@ for ticks that can be floated upwards easily even--- where it might change execution counts, such as:------   Just (tick<...> foo)---     ==>---   tick<...> (Just foo)------ This is a combination of @tickishSoftScope@ and--- @tickishCounts@. Note that in principle splittable ticks can become--- floatable using @mkNoTick@ -- even though there's currently no--- tickish for which that is the case.-tickishFloatable :: Tickish id -> Bool-tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)---- | Returns @True@ for a tick that is both counting /and/ scoping and--- can be split into its (tick, scope) parts using 'mkNoScope' and--- 'mkNoTick' respectively.-tickishCanSplit :: Tickish id -> Bool-tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}-                   = True-tickishCanSplit _  = False--mkNoCount :: Tickish id -> Tickish id-mkNoCount n | not (tickishCounts n)   = n-            | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"-mkNoCount n@ProfNote{}                = n {profNoteCount = False}-mkNoCount _                           = panic "mkNoCount: Undefined split!"--mkNoScope :: Tickish id -> Tickish id-mkNoScope n | tickishScoped n == NoScope  = n-            | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"-mkNoScope n@ProfNote{}                    = n {profNoteScope = False}-mkNoScope _                               = panic "mkNoScope: Undefined split!"---- | Return @True@ if this source annotation compiles to some backend--- code. Without this flag, the tickish is seen as a simple annotation--- that does not have any associated evaluation code.------ What this means that we are allowed to disregard the tick if doing--- so means that we can skip generating any code in the first place. A--- typical example is top-level bindings:------   foo = tick<...> \y -> ...---     ==>---   foo = \y -> tick<...> ...------ Here there is just no operational difference between the first and--- the second version. Therefore code generation should simply--- translate the code as if it found the latter.-tickishIsCode :: Tickish id -> Bool-tickishIsCode SourceNote{} = False-tickishIsCode _tickish     = True  -- all the rest for now----- | Governs the kind of expression that the tick gets placed on when--- annotating for example using @mkTick@. If we find that we want to--- put a tickish on an expression ruled out here, we try to float it--- inwards until we find a suitable expression.-data TickishPlacement =--    -- | Place ticks exactly on run-time expressions. We can still-    -- move the tick through pure compile-time constructs such as-    -- other ticks, casts or type lambdas. This is the most-    -- restrictive placement rule for ticks, as all tickishs have in-    -- common that they want to track runtime processes. The only-    -- legal placement rule for counting ticks.-    PlaceRuntime--    -- | As @PlaceRuntime@, but we float the tick through all-    -- lambdas. This makes sense where there is little difference-    -- between annotating the lambda and annotating the lambda's code.-  | PlaceNonLam--    -- | In addition to floating through lambdas, cost-centre style-    -- tickishs can also be moved from constructors, non-function-    -- variables and literals. For example:-    ---    --   let x = scc<...> C (scc<...> y) (scc<...> 3) in ...-    ---    -- Neither the constructor application, the variable or the-    -- literal are likely to have any cost worth mentioning. And even-    -- if y names a thunk, the call would not care about the-    -- evaluation context. Therefore removing all annotations in the-    -- above example is safe.-  | PlaceCostCentre--  deriving (Eq)---- | Placement behaviour we want for the ticks-tickishPlace :: Tickish id -> TickishPlacement-tickishPlace n@ProfNote{}-  | profNoteCount n        = PlaceRuntime-  | otherwise              = PlaceCostCentre-tickishPlace HpcTick{}     = PlaceRuntime-tickishPlace Breakpoint{}  = PlaceRuntime-tickishPlace SourceNote{}  = PlaceNonLam---- | Returns whether one tick "contains" the other one, therefore--- making the second tick redundant.-tickishContains :: Eq b => Tickish b -> Tickish b -> Bool-tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)-  = containsSpan sp1 sp2 && n1 == n2-    -- compare the String last-tickishContains t1 t2-  = t1 == t2- {- ************************************************************************ *                                                                      *@@ -1393,6 +1120,7 @@    { roPlatform                :: !Platform -- ^ Target platform    , roNumConstantFolding      :: !Bool     -- ^ Enable more advanced numeric constant folding    , roExcessRationalPrecision :: !Bool     -- ^ Cut down precision of Rational values to that of Float/Double if disabled+   , roBignumRules             :: !Bool     -- ^ Enable rules for bignums    }  type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr@@ -1829,10 +1557,10 @@   ppr (LitAlt lit) = ppr lit   ppr DEFAULT      = text "__DEFAULT" -cmpAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Ordering-cmpAlt (con1, _, _) (con2, _, _) = con1 `cmpAltCon` con2+cmpAlt :: Alt a -> Alt a -> Ordering+cmpAlt (Alt con1 _ _) (Alt con2 _ _) = con1 `cmpAltCon` con2 -ltAlt :: (AltCon, a, b) -> (AltCon, a, b) -> Bool+ltAlt :: Alt a -> Alt a -> Bool ltAlt a1 a2 = (a1 `cmpAlt` a2) == LT  cmpAltCon :: AltCon -> AltCon -> Ordering@@ -1931,7 +1659,7 @@ deTagBind (Rec prs)             = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]  deTagAlt :: TaggedAlt t -> CoreAlt-deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)+deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs)  {- ************************************************************************@@ -1993,6 +1721,9 @@ mkWordLitWrap :: Platform -> Integer -> Expr b mkWordLitWrap platform w = Lit (mkLitWordWrap platform w) +mkWord8Lit :: Integer -> Expr b+mkWord8Lit    w = Lit (mkLitWord8 w)+ mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w)) @@ -2128,7 +1859,7 @@ rhssOfBind (Rec pairs)    = [rhs | (_,rhs) <- pairs]  rhssOfAlts :: [Alt b] -> [Expr b]-rhssOfAlts alts = [e | (_,_,e) <- alts]+rhssOfAlts alts = [e | Alt _ _ e <- alts]  -- | Collapse all the bindings in the supplied groups into a single -- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group@@ -2200,8 +1931,8 @@  -- | Like @collectArgs@, but also collects looks through floatable -- ticks if it means that we can find more arguments.-collectArgsTicks :: (Tickish Id -> Bool) -> Expr b-                 -> (Expr b, [Arg b], [Tickish Id])+collectArgsTicks :: (CoreTickish -> Bool) -> Expr b+                 -> (Expr b, [Arg b], [CoreTickish]) collectArgsTicks skipTick expr   = go expr [] []   where@@ -2286,12 +2017,12 @@   | AnnLet      (AnnBind bndr annot) (AnnExpr bndr annot)   | AnnCast     (AnnExpr bndr annot) (annot, Coercion)                    -- Put an annotation on the (root of) the coercion-  | AnnTick     (Tickish Id) (AnnExpr bndr annot)+  | AnnTick     CoreTickish (AnnExpr bndr annot)   | AnnType     Type   | AnnCoercion Coercion  -- | A clone of the 'Alt' type but allowing annotation at every tree node-type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)+data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot)  -- | A clone of the 'Bind' type but allowing annotation at every tree node data AnnBind bndr annot@@ -2307,8 +2038,8 @@     go (_, AnnApp f a) as = go f (a:as)     go e               as = (e, as) -collectAnnArgsTicks :: (Tickish Var -> Bool) -> AnnExpr b a-                       -> (AnnExpr b a, [AnnExpr b a], [Tickish Var])+collectAnnArgsTicks :: (CoreTickish -> Bool) -> AnnExpr b a+                       -> (AnnExpr b a, [AnnExpr b a], [CoreTickish]) collectAnnArgsTicks tickishOk expr   = go expr [] []   where@@ -2336,7 +2067,7 @@   = Case (deAnnotate scrut) v t (map deAnnAlt alts)  deAnnAlt :: AnnAlt bndr annot -> Alt bndr-deAnnAlt (con,args,rhs) = (con,args,deAnnotate rhs)+deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs)  deAnnBind  :: AnnBind b annot -> Bind b deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)

GHC/Core/Class.hs view

@@ -33,6 +33,7 @@ import GHC.Types.Basic import GHC.Types.Unique import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)@@ -79,7 +80,7 @@ -- --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'', --- For details on above see note [Api annotations] in GHC.Parser.Annotation+-- For details on above see note [exact print annotations] in GHC.Parser.Annotation type FunDep a = ([a],[a])  type ClassOpItem = (Id, DefMethInfo)

GHC/Core/Coercion.hs view

@@ -1,18 +1,20 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- (c) The University of Glasgow 2006 -} -{-# LANGUAGE RankNTypes, CPP, MultiWayIf, FlexibleContexts, BangPatterns,-             ScopedTypeVariables #-}- -- | Module for (a) type kinds and (b) type coercions, -- as used in System FC. See 'GHC.Core.Expr' for -- more on System FC and how coercions fit into it. -- module GHC.Core.Coercion (         -- * Main data type-        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionR,-        UnivCoProvenance, CoercionHole(..), BlockSubstFlag(..),+        Coercion, CoercionN, CoercionR, CoercionP, MCoercion(..), MCoercionN, MCoercionR,+        UnivCoProvenance, CoercionHole(..),         coHoleCoVar, setCoHoleCoVar,         LeftOrRight(..),         Var, CoVar, TyCoVar,@@ -31,8 +33,8 @@         mkAxInstRHS, mkUnbranchedAxInstRHS,         mkAxInstLHS, mkUnbranchedAxInstLHS,         mkPiCo, mkPiCos, mkCoCast,-        mkSymCo, mkTransCo, mkTransMCo,-        mkNthCo, nthCoRole, mkLRCo,+        mkSymCo, mkTransCo,+        mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo,         mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo,         mkForAllCo, mkForAllCos, mkHomoForAllCos,         mkPhantomCo,@@ -67,8 +69,11 @@         pickLR,          isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,-        isReflCoVar_maybe, isGReflMCo, coToMCo,+        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,+        mkCoherenceRightMCo, +        coToMCo, mkTransMCo, mkTransMCoL, mkCastTyMCo, mkSymMCo, isReflMCo,+         -- ** Coercion variables         mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,         isCoVar_maybe,@@ -76,7 +81,7 @@         -- ** Free variables         tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,         tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,-        coercionSize,+        coercionSize, anyFreeVarsOfCo,          -- ** Substitution         CvSubstEnv, emptyCvSubstEnv,@@ -118,7 +123,8 @@          simplifyArgsWorker, -        badCoercionHole, badCoercionHoleCo+        hasCoercionHoleTy, hasCoercionHoleCo,+        HoleSet, coercionHolesOfType, coercionHolesOfCo        ) where  #include "HsVersions.h"@@ -135,15 +141,14 @@ import GHC.Core.TyCo.Tidy import GHC.Core.Type import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Core.Coercion.Axiom import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name hiding ( varName )-import GHC.Utils.Misc import GHC.Types.Basic-import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Data.Pair import GHC.Types.SrcLoc@@ -152,7 +157,12 @@ import GHC.Data.List.SetOps import GHC.Data.Maybe import GHC.Types.Unique.FM+import GHC.Types.Unique.Set +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import Control.Monad (foldM, zipWithM) import Data.Function ( on ) import Data.Char( isDigit )@@ -288,6 +298,70 @@                        ('_' : rest) -> all isDigit rest                        _            -> False ++{- *********************************************************************+*                                                                      *+              MCoercion+*                                                                      *+********************************************************************* -}++coToMCo :: Coercion -> MCoercion+-- Convert a coercion to a MCoercion,+-- It's not clear whether or not isReflexiveCo would be better here+coToMCo co | isReflCo co = MRefl+           | otherwise   = MCo co++-- | Tests if this MCoercion is obviously generalized reflexive+-- Guaranteed to work very quickly.+isGReflMCo :: MCoercion -> Bool+isGReflMCo MRefl = True+isGReflMCo (MCo co) | isGReflCo co = True+isGReflMCo _ = False++-- | Make a generalized reflexive coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflCo r ty mco+  | isGReflMCo mco = if r == Nominal then Refl ty+                     else GRefl r ty MRefl+  | otherwise    = GRefl r ty mco++-- | Compose two MCoercions via transitivity+mkTransMCo :: MCoercion -> MCoercion -> MCoercion+mkTransMCo MRefl     co2       = co2+mkTransMCo co1       MRefl     = co1+mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)++mkTransMCoL :: MCoercion -> Coercion -> MCoercion+mkTransMCoL MRefl     co2 = MCo co2+mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2)++-- | Get the reverse of an 'MCoercion'+mkSymMCo :: MCoercion -> MCoercion+mkSymMCo MRefl    = MRefl+mkSymMCo (MCo co) = MCo (mkSymCo co)++-- | Cast a type by an 'MCoercion'+mkCastTyMCo :: Type -> MCoercion -> Type+mkCastTyMCo ty MRefl    = ty+mkCastTyMCo ty (MCo co) = ty `mkCastTy` co++mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflLeftMCo r ty MRefl    = mkReflCo r ty+mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co++mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflRightMCo r ty MRefl    = mkReflCo r ty+mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co++-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'+mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion+mkCoherenceRightMCo _ _  MRefl    co2 = co2+mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2++isReflMCo :: MCoercion -> Bool+isReflMCo MRefl = True+isReflMCo _     = False+ {- %************************************************************************ %*                                                                      *@@ -383,8 +457,8 @@     -- Invariant:  co :: subst1(k2) ~ subst2(k2)      go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)-      | Just (a, t1) <- splitForAllTy_maybe k1-      , Just (b, t2) <- splitForAllTy_maybe k2+      | Just (a, t1) <- splitForAllTyCoVar_maybe k1+      , Just (b, t2) <- splitForAllTyCoVar_maybe k2         -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)         --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)         --           a :: s1@@ -556,13 +630,6 @@ isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl isGReflCo _         = False --- | Tests if this MCoercion is obviously generalized reflexive--- Guaranteed to work very quickly.-isGReflMCo :: MCoercion -> Bool-isGReflMCo MRefl = True-isGReflMCo (MCo co) | isGReflCo co = True-isGReflMCo _ = False- -- | Tests if this coercion is obviously reflexive. Guaranteed to work -- very quickly. Sometimes a coercion can be reflexive, but not obviously -- so. c.f. 'isReflexiveCo'@@ -603,10 +670,6 @@   = Nothing   where (Pair ty1 ty2, r) = coercionKindRole co -coToMCo :: Coercion -> MCoercion-coToMCo c = if isReflCo c-  then MRefl-  else MCo c  {- %************************************************************************@@ -669,13 +732,6 @@  -} --- | Make a generalized reflexive coercion-mkGReflCo :: Role -> Type -> MCoercionN -> Coercion-mkGReflCo r ty mco-  | isGReflMCo mco = if r == Nominal then Refl ty-                     else GRefl r ty MRefl-  | otherwise    = GRefl r ty mco- -- | Make a reflexive coercion mkReflCo :: Role -> Type -> Coercion mkReflCo Nominal ty = Refl ty@@ -990,12 +1046,6 @@   = GRefl r t1 (MCo $ mkTransCo co1 co2) mkTransCo co1 co2                 = TransCo co1 co2 --- | Compose two MCoercions via transitivity-mkTransMCo :: MCoercion -> MCoercion -> MCoercion-mkTransMCo MRefl     co2       = co2-mkTransMCo co1       MRefl     = co1-mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)- mkNthCo :: HasDebugCallStack         => Role  -- The role of the coercion you're creating         -> Int   -- Zero-indexed@@ -1009,7 +1059,7 @@      go r 0 co       | Just (ty, _) <- isReflCo_maybe co-      , Just (tv, _) <- splitForAllTy_maybe ty+      , Just (tv, _) <- splitForAllTyCoVar_maybe ty       = -- works for both tyvar and covar         ASSERT( r == Nominal )         mkNomReflCo (varType tv)@@ -1037,23 +1087,8 @@       -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)       -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4)) -    go r n co@(FunCo r0 w arg res)-      -- See Note [Function coercions]-      -- If FunCo _ mult arg_co res_co ::   (s1:TYPE sk1 :mult-> s2:TYPE sk2)-      --                                  ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2)-      -- Then we want to behave as if co was-      --    TyConAppCo mult argk_co resk_co arg_co res_co-      -- where-      --    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)-      --    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)-      --                             i.e. mkRuntimeRepCo-      = case n of-          0 -> ASSERT( r == Nominal ) w-          1 -> ASSERT( r == Nominal ) mkRuntimeRepCo arg-          2 -> ASSERT( r == Nominal ) mkRuntimeRepCo res-          3 -> ASSERT( r == r0 )      arg-          4 -> ASSERT( r == r0 )      res-          _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr co)+    go _ n (FunCo _ w arg res)+      = mkNthCoFunCo n w arg res      go r n (TyConAppCo r0 tc arg_cos) = ASSERT2( r == nthRole r0 tc n                                                     , (vcat [ ppr tc@@ -1075,8 +1110,8 @@     good_call       -- If the Coercion passed in is between forall-types, then the Int must       -- be 0 and the role must be Nominal.-      | Just (_tv1, _) <- splitForAllTy_maybe ty1-      , Just (_tv2, _) <- splitForAllTy_maybe ty2+      | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1+      , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2       = n == 0 && r == Nominal        -- If the Coercion passed in is between T tys and T tys', then the Int@@ -1105,7 +1140,28 @@       | otherwise       = True -+-- | Extract the nth field of a FunCo+mkNthCoFunCo :: Int         -- ^ "n"+             -> CoercionN   -- ^ multiplicity coercion+             -> Coercion    -- ^ argument coercion+             -> Coercion    -- ^ result coercion+             -> Coercion    -- ^ nth coercion from a FunCo+-- See Note [Function coercions]+-- If FunCo _ mult arg_co res_co ::   (s1:TYPE sk1 :mult-> s2:TYPE sk2)+--                                  ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2)+-- Then we want to behave as if co was+--    TyConAppCo mult argk_co resk_co arg_co res_co+-- where+--    argk_co :: sk1 ~ tk1  =  mkNthCo 0 (mkKindCo arg_co)+--    resk_co :: sk2 ~ tk2  =  mkNthCo 0 (mkKindCo res_co)+--                             i.e. mkRuntimeRepCo+mkNthCoFunCo n w co1 co2 = case n of+  0 -> w+  1 -> mkRuntimeRepCo co1+  2 -> mkRuntimeRepCo co2+  3 -> co1+  4 -> co2+  _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr w $$ ppr co1 $$ ppr co2)  -- | If you're about to call @mkNthCo r n co@, then @r@ should be -- whatever @nthCoRole n co@ returns.@@ -1114,7 +1170,7 @@   | Just (tc, _) <- splitTyConApp_maybe lty   = nthRole r tc n -  | Just _ <- splitForAllTy_maybe lty+  | Just _ <- splitForAllTyCoVar_maybe lty   = Nominal    | otherwise@@ -1164,7 +1220,7 @@ mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion mkCoherenceLeftCo r ty co co2   | isGReflCo co = co2-  | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2+  | otherwise    = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2  -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@, -- produces @co' :: ty' ~r (ty |> co)@@ -1173,7 +1229,7 @@ mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion mkCoherenceRightCo r ty co co2   | isGReflCo co = co2-  | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)+  | otherwise    = co2 `mkTransCo` GRefl r ty (MCo co)  -- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@. mkKindCo :: Coercion -> Coercion@@ -1193,7 +1249,7 @@   | otherwise   = KindCo co -mkSubCo :: Coercion -> Coercion+mkSubCo :: HasDebugCallStack => Coercion -> Coercion -- Input coercion is Nominal, result is Representational -- see also Note [Role twiddling functions] mkSubCo (Refl ty) = GRefl Representational ty MRefl@@ -1596,7 +1652,7 @@ situation where the main coercion is reflexive, via the special cases for Refl and GRefl. -This is important when flattening  (ty |> co). We flatten ty, yielding+This is important when rewriting  (ty |> co). We rewrite ty, yielding    fco :: ty ~ ty' and now we want a coercion xco between    xco :: (ty |> co) ~ (ty' |> co)@@ -1651,6 +1707,11 @@                                     -- ^ ev is evidence;                                     -- Usually a co :: old type ~ new type +instance Outputable ev => Outputable (NormaliseStepResult ev) where+  ppr NS_Done           = text "NS_Done"+  ppr NS_Abort          = text "NS_Abort"+  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]+ mapStepResult :: (ev1 -> ev2)               -> NormaliseStepResult ev1 -> NormaliseStepResult ev2 mapStepResult f (NS_Step rec_nts ty ev) = NS_Step rec_nts ty (f ev)@@ -2307,7 +2368,7 @@     args `getNth` d    | d == 0-  , Just (tv,_) <- splitForAllTy_maybe ty+  , Just (tv,_) <- splitForAllTyCoVar_maybe ty   = tyVarKind tv    | otherwise@@ -2606,18 +2667,19 @@ %*                                                                      * %************************************************************************ -The function below morally belongs in GHC.Tc.Solver.Flatten, but it is used also in+The function below morally belongs in GHC.Tc.Solver.Rewrite, but it is used also in FamInstEnv, and so lives here.  Note [simplifyArgsWorker] ~~~~~~~~~~~~~~~~~~~~~~~~~-Invariant (F2) of Note [Flattening] says that flattening is homogeneous.-This causes some trouble when flattening a function applied to a telescope+Invariant (F2) of Note [Rewriting] in GHC.Tc.Solver.Rewrite says that+rewriting is homogeneous.+This causes some trouble when rewriting a function applied to a telescope of arguments, perhaps with dependency. For example, suppose    type family F :: forall (j :: Type) (k :: Type). Maybe j -> Either j k -> Bool -> [k] -and we wish to flatten the args of (with kind applications explicit)+and we wish to rewrite the args of (with kind applications explicit)    F a b (Just a c) (Right a b d) False @@ -2633,7 +2695,7 @@   [G] cco :: c ~ fc   [G] dco :: d ~ fd -The first step is to flatten all the arguments. This is done before calling+The first step is to rewrite all the arguments. This is done before calling simplifyArgsWorker. We start from    a@@ -2654,26 +2716,26 @@   co6 :: Maybe fa ~ Maybe a   co7 :: Either fa fb ~ Either a b -We now process the flattened args in left-to-right order. The first two args-need no further processing. But now consider the third argument. Let f3 = the flattened+We now process the rewritten args in left-to-right order. The first two args+need no further processing. But now consider the third argument. Let f3 = the rewritten result, Just fa (fc |> aco) |> co6.-This f3 flattened argument has kind (Maybe a), due to+This f3 rewritten argument has kind (Maybe a), due to (F2). And yet, when we build the application (F fa fb ...), we need this argument to have kind (Maybe fa), not (Maybe a). We must cast this argument. The coercion to use is determined by the kind of F: we see in F's kind that the third argument has kind Maybe j. Critically, we also know that the argument corresponding to j-(in our example, a) flattened with a coercion co1. We can thus know the+(in our example, a) rewrote with a coercion co1. We can thus know the coercion needed for the 3rd argument is (Maybe (sym co1)), thus building (f3 |> Maybe (sym co1))  More generally, we must use the Lifting Lemma, as implemented in Coercion.liftCoSubst. As we work left-to-right, any variable that is a dependent parameter (j and k, in our example) gets mapped in a lifting context-to the coercion that is output from flattening the corresponding argument (co1-and co2, in our example). Then, after flattening later arguments, we lift the+to the coercion that is output from rewriting the corresponding argument (co1+and co2, in our example). Then, after rewriting later arguments, we lift the kind of these arguments in the lifting context that we've be building up.-This coercion is then used to keep the result of flattening well-kinded.+This coercion is then used to keep the result of rewriting well-kinded.  Working through our example, this is what happens: @@ -2689,7 +2751,7 @@    4. Lifting the kind (Either j k) with our LC      yields co9 :: Either fa fb ~ Either a b. Use (f4 |> sym co9) as the 4th-     argument to F, where f4 is the flattened form of argument 4, written above.+     argument to F, where f4 is the rewritten form of argument 4, written above.    5. We lift Bool with our LC, getting <Bool>;      casting has no effect.@@ -2730,14 +2792,14 @@   co :: (forall j. j -> Type) ~ (forall (j :: Star). (j |> axStar) -> Star)   co = forall (j :: sym axStar). (<j> -> sym axStar) -  We are flattening:+  We are rewriting:   a (forall (j :: Star). (j |> axStar) -> Star)   -- 1     (Proxy |> co)                                 -- 2     (bo |> sym axStar)                            -- 3     (NoWay |> sym bc)                             -- 4       :: Star -First, we flatten all the arguments (before simplifyArgsWorker), like so:+First, we rewrite all the arguments (before simplifyArgsWorker), like so:      (forall j. j -> Type, co1 :: (forall j. j -> Type) ~                                  (forall (j :: Star). (j |> axStar) -> Star))  -- 1@@ -2749,7 +2811,7 @@  1. Lifting Type (the kind of the first arg) gives us a reflexive coercion, so we    don't use it. But we do build a lifting context [k -> co1] (where co1 is a-   result of flattening an argument, written above).+   result of rewriting an argument, written above).  2. Lifting k gives us co1, so the second argument becomes (Proxy |> co |> sym co1).    This is not a dependent argument, so we don't extend the lifting context.@@ -2768,10 +2830,10 @@ decomposed it, we would end up with coercions whose types include j, which is out of scope here. Accordingly, decomposePiCos takes a list of types whose kinds are the *right-hand* types in the decomposed coercion. (See comments on-decomposePiCos.) Because the flattened types have unflattened kinds (because-flattening is homogeneous), passing the list of flattened types to decomposePiCos+decomposePiCos.) Because the rewritten types have unrewritten kinds (because+rewriting is homogeneous), passing the list of rewritten types to decomposePiCos just won't do: later arguments' kinds won't be as expected. So we need to get-the *unflattened* types to pass to decomposePiCos. We can do this easily enough+the *unrewritten* types to pass to decomposePiCos. We can do this easily enough by taking the kind of the argument coercions, passed in originally.  (Alternative 1: We could re-engineer decomposePiCos to deal with this situation.@@ -2783,7 +2845,7 @@ complication of decomposePiCos would end up layered on top of all the complication here. Please, no.) -(Alternative 3: We could pass the unflattened arguments into simplifyArgsWorker+(Alternative 3: We could pass the unrewritten arguments into simplifyArgsWorker so that we don't have to recreate them. But that would complicate the interface of this function to handle a very dark, dark corner case. Better to keep our demons to ourselves here instead of exposing them to callers. This decision is@@ -2804,7 +2866,7 @@                            == bo ~ bo   res_co :: Type ~ Star -We then use these casts on (the flattened) (3) and (4) to get+We then use these casts on (the rewritten) (3) and (4) to get    (Bool |> sym axStar |> co5 :: Type)   -- (C3)   (False |> sym bc |> co6    :: bo)     -- (C4)@@ -2825,9 +2887,9 @@  This recursive call returns ([Bool, False], [...], Refl). The Bool and False are the correct arguments we wish to return. But we must be careful about the-result coercion: our new, flattened application will have kind Type, but we+result coercion: our new, rewritten application will have kind Type, but we want to make sure that the result coercion casts this back to Star. (Why?-Because we started with an application of kind Star, and flattening is homogeneous.)+Because we started with an application of kind Star, and rewriting is homogeneous.)  So, we have to twiddle the result coercion appropriately. @@ -2871,7 +2933,7 @@       k :: Type       x :: k -  flatten (f @Type @((->) k) x)+  rewrite (f @Type @((->) k) x)  After instantiating [a |-> Type, b |-> ((->) k)], we see that `b (Any @a)` is `k -> Any @a`, and thus the third argument of `x :: k` is well-kinded.@@ -2879,7 +2941,7 @@ -}  --- This is shared between the flattener and the normaliser in GHC.Core.FamInstEnv.+-- This is shared between the rewriter and the normaliser in GHC.Core.FamInstEnv. -- See Note [simplifyArgsWorker] {-# INLINE simplifyArgsWorker #-} simplifyArgsWorker :: [TyCoBinder] -> Kind@@ -2887,15 +2949,15 @@                        -- list of binders can be shorter or longer than the list of args                    -> TyCoVarSet   -- free vars of the args                    -> [Role]   -- list of roles, r-                   -> [(Type, Coercion)] -- flattened type arguments, arg-                                         -- each comes with the coercion used to flatten it,-                                         -- with co :: flattened_type ~ original_type-                   -> ([Type], [Coercion], CoercionN)+                   -> [(Type, Coercion)] -- rewritten type arguments, arg+                                         -- each comes with the coercion used to rewrite it,+                                         -- with co :: rewritten_type ~ original_type+                   -> ([Type], [Coercion], MCoercionN) -- Returns (xis, cos, res_co), where each co :: xi ~ arg, -- and res_co :: kind (f xis) ~ kind (f tys), where f is the function applied to the args -- Precondition: if f :: forall bndrs. inner_ki (where bndrs and inner_ki are passed in),--- then (f orig_tys) is well kinded. Note that (f flattened_tys) might *not* be well-kinded.--- Massaging the flattened_tys in order to make (f flattened_tys) well-kinded is what this+-- then (f orig_tys) is well kinded. Note that (f rewritten_tys) might *not* be well-kinded.+-- Massaging the rewritten_tys in order to make (f rewritten_tys) well-kinded is what this -- function is all about. That is, (f xis), where xis are the returned arguments, *is* -- well kinded. simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs@@ -2907,25 +2969,26 @@     go :: [Type]      -- Xis accumulator, in reverse order        -> [Coercion]  -- Coercions accumulator, in reverse order                       -- These are in 1-to-1 correspondence-       -> LiftingContext  -- mapping from tyvars to flattening coercions+       -> LiftingContext  -- mapping from tyvars to rewriting coercions        -> [TyCoBinder]    -- Unsubsted binders of function's kind        -> Kind        -- Unsubsted result kind of function (not a Pi-type)-       -> [Role]      -- Roles at which to flatten these ...-       -> [(Type, Coercion)]  -- flattened arguments, with their flattening coercions-       -> ([Type], [Coercion], CoercionN)+       -> [Role]      -- Roles at which to rewrite these ...+       -> [(Type, Coercion)]  -- rewritten arguments, with their rewriting coercions+       -> ([Type], [Coercion], MCoercionN)     go acc_xis acc_cos !lc binders inner_ki _ []         -- The !lc makes the function strict in the lifting context         -- which means GHC can unbox that pair.  A modest win.       = (reverse acc_xis, reverse acc_cos, kind_co)       where         final_kind = mkPiTys binders inner_ki-        kind_co = liftCoSubst Nominal lc final_kind+        kind_co | noFreeVarsOfType final_kind = MRefl+                | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind      go acc_xis acc_cos lc (binder:binders) inner_ki (role:roles) ((xi,co):args)-      = -- By Note [Flattening] in GHC.Tc.Solver.Flatten invariant (F2),+      = -- By Note [Rewriting] in GHC.Tc.Solver.Rewrite invariant (F2),          -- tcTypeKind(xi) = tcTypeKind(ty). But, it's possible that xi will be          -- used as an argument to a function whose kind is different, if-         -- earlier arguments have been flattened to new types. We thus+         -- earlier arguments have been rewritten to new types. We thus          -- need a coercion (kind_co :: old_kind ~ new_kind).          --          -- The bangs here have been observed to improve performance@@ -2954,8 +3017,8 @@     go acc_xis acc_cos lc [] inner_ki roles args       = let co1 = liftCoSubst Nominal lc inner_ki             co1_kind              = coercionKind co1-            unflattened_tys       = map (coercionRKind . snd) args-            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unflattened_tys+            unrewritten_tys       = map (coercionRKind . snd) args+            (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys             casted_args           = ASSERT2( equalLength args arg_cos                                            , ppr args $$ ppr arg_cos )                                     [ (casted_xi, casted_co)@@ -2969,20 +3032,20 @@                -- ... -> k, that k will be substituted to perhaps reveal more                -- binders.             zapped_lc             = zapLiftingContext lc-            Pair flattened_kind _ = co1_kind-            (bndrs, new_inner)    = splitPiTys flattened_kind+            Pair rewritten_kind _ = co1_kind+            (bndrs, new_inner)    = splitPiTys rewritten_kind              (xis_out, cos_out, res_co_out)               = go acc_xis acc_cos zapped_lc bndrs new_inner roles casted_args         in-        (xis_out, cos_out, res_co_out `mkTransCo` res_co)+        (xis_out, cos_out, res_co_out `mkTransMCoL` res_co)      go _ _ _ _ _ _ _ = panic         "simplifyArgsWorker wandered into deeper water than usual"            -- This debug information is commented out because leaving it in            -- causes a ~2% increase in allocations in T9872d.-           -- That's independent of the analogous case in flatten_args_fast-           -- in GHC.Tc.Solver.Flatten:+           -- That's independent of the analogous case in rewrite_args_fast+           -- in GHC.Tc.Solver.Rewrite:            -- each of these causes a 2% increase on its own, so commenting them            -- both out gives a 4% decrease in T9872d.            {-@@ -3001,31 +3064,40 @@ %************************************************************************ -} -bad_co_hole_ty :: Type -> Monoid.Any-bad_co_hole_co :: Coercion -> Monoid.Any-(bad_co_hole_ty, _, bad_co_hole_co, _)+has_co_hole_ty :: Type -> Monoid.Any+has_co_hole_co :: Coercion -> Monoid.Any+(has_co_hole_ty, _, has_co_hole_co, _)   = foldTyCo folder ()   where     folder = TyCoFolder { tcf_view  = const Nothing                         , tcf_tyvar = const2 (Monoid.Any False)                         , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = const hole+                        , tcf_hole  = const2 (Monoid.Any True)                         , tcf_tycobinder = const2                         }      const2 :: a -> b -> c -> a     const2 x _ _ = x -    hole :: CoercionHole -> Monoid.Any-    hole (CoercionHole { ch_blocker = YesBlockSubst }) = Monoid.Any True-    hole _                                             = Monoid.Any False+-- | Is there a coercion hole in this type?+hasCoercionHoleTy :: Type -> Bool+hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty --- | Is there a blocking coercion hole in this type? See--- "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]-badCoercionHole :: Type -> Bool-badCoercionHole = Monoid.getAny . bad_co_hole_ty+-- | Is there a coercion hole in this coercion?+hasCoercionHoleCo :: Coercion -> Bool+hasCoercionHoleCo = Monoid.getAny . has_co_hole_co --- | Is there a blocking coercion hole in this coercion? See--- GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]-badCoercionHoleCo :: Coercion -> Bool-badCoercionHoleCo = Monoid.getAny . bad_co_hole_co+-- | A set of 'CoercionHole's+type HoleSet = UniqSet CoercionHole++-- | Extract out all the coercion holes from a given type+coercionHolesOfType :: Type -> UniqSet CoercionHole+coercionHolesOfCo   :: Coercion -> UniqSet CoercionHole+(coercionHolesOfType, _, coercionHolesOfCo, _) = foldTyCo folder ()+  where+    folder = TyCoFolder { tcf_view  = const Nothing  -- don't look through synonyms+                        , tcf_tyvar = \ _ _ -> mempty+                        , tcf_covar = \ _ _ -> mempty+                        , tcf_hole  = const unitUniqSet+                        , tcf_tycobinder = \ _ _ _ -> ()+                        }

GHC/Core/Coercion.hs-boot view

@@ -30,7 +30,7 @@ mkGReflCo :: Role -> Type -> MCoercionN -> Coercion mkNomReflCo :: Type -> Coercion mkKindCo :: Coercion -> Coercion-mkSubCo :: Coercion -> Coercion+mkSubCo :: HasDebugCallStack => Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion

GHC/Core/Coercion/Axiom.hs view

@@ -1,7 +1,12 @@--- (c) The University of Glasgow 2012+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE RoleAnnotations     #-}+{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP, DataKinds, DeriveDataTypeable, GADTs, KindSignatures,-             ScopedTypeVariables, StandaloneDeriving, RoleAnnotations #-}+-- (c) The University of Glasgow 2012  -- | Module for coercion axioms, used to represent type family instances -- and newtypes@@ -41,6 +46,7 @@ import GHC.Types.Var import GHC.Utils.Misc import GHC.Utils.Binary+import GHC.Utils.Panic import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable )@@ -379,7 +385,7 @@  Note [Implicit axioms] ~~~~~~~~~~~~~~~~~~~~~~-See also Note [Implicit TyThings] in GHC.Driver.Types+See also Note [Implicit TyThings] in GHC.Types.TyThing * A CoAxiom arising from data/type family instances is not "implicit".   That is, it has its own IfaceAxiom declaration in an interface file @@ -567,7 +573,9 @@   x == y = coaxrName x == coaxrName y  instance Ord CoAxiomRule where-  compare x y = compare (coaxrName x) (coaxrName y)+  -- we compare lexically to avoid non-deterministic output when sets of rules+  -- are printed+  compare x y = lexicalCompareFS (coaxrName x) (coaxrName y)  instance Outputable CoAxiomRule where   ppr = ppr . coaxrName@@ -576,9 +584,21 @@ -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily   { sfMatchFam      :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+    -- Does this reduce on the given arguments?+    -- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)+    -- That is: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)+    --              :: F tys ~r rhs,+    -- where the r in the output is coaxrRole of the rule. It is up to the+    -- caller to ensure that this role is appropriate.+   , sfInteractTop   :: [Type] -> Type -> [TypeEqn]+    -- If given these type arguments and RHS, returns the equalities that+    -- are guaranteed to hold.+   , sfInteractInert :: [Type] -> Type ->                        [Type] -> Type -> [TypeEqn]+    -- If given one set of arguments and result, and another set of arguments+    -- and result, returns the equalities that are guaranteed to hold.   }  -- Provides default implementations that do nothing.

GHC/Core/Coercion/Opt.hs view

@@ -2,13 +2,19 @@  {-# LANGUAGE CPP #-} -module GHC.Core.Coercion.Opt ( optCoercion, checkAxInstCo ) where+module GHC.Core.Coercion.Opt+   ( optCoercion+   , checkAxInstCo+   , OptCoercionOpts (..)+   )+where  #include "HsVersions.h"  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst import GHC.Core.Coercion@@ -18,15 +24,15 @@ import GHC.Core.Coercion.Axiom import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Utils.Outputable-import GHC.Core.FamInstEnv ( flattenTys ) import GHC.Data.Pair import GHC.Data.List.SetOps ( getNth )-import GHC.Utils.Misc import GHC.Core.Unify-import GHC.Core.InstEnv import Control.Monad   ( zipWithM ) +import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic+ {- %************************************************************************ %*                                                                      *@@ -105,12 +111,17 @@ (h1 ~N (n1; h2; sym n2)) in g. -} -optCoercion :: DynFlags -> TCvSubst -> Coercion -> NormalCo+-- | Coercion optimisation options+newtype OptCoercionOpts = OptCoercionOpts+   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)+   }++optCoercion :: OptCoercionOpts -> TCvSubst -> Coercion -> NormalCo -- ^ optCoercion applies a substitution to a coercion, --   *and* optimises it to reduce its size-optCoercion dflags env co-  | hasNoOptCoercion dflags = substCo env co-  | otherwise               = optCoercion' env co+optCoercion opts env co+  | optCoercionEnabled opts = optCoercion' env co+  | otherwise               = substCo env co  optCoercion' :: TCvSubst -> Coercion -> NormalCo optCoercion' env co@@ -319,9 +330,10 @@   , Just (_tc, args) <- ASSERT( r == _r )                         splitTyConApp_maybe ty   = liftCoSubst (chooseRole rep r) env (args `getNth` n)+   | Just (ty, _) <- isReflCo_maybe co   , n == 0-  , Just (tv, _) <- splitForAllTy_maybe ty+  , Just (tv, _) <- splitForAllTyCoVar_maybe ty       -- works for both tyvar and covar   = liftCoSubst (chooseRole rep r) env (varType tv) @@ -329,6 +341,11 @@   = ASSERT( r == r1 )     opt_co4_wrap env sym rep r (cos `getNth` n) +-- see the definition of GHC.Builtin.Types.Prim.funTyCon+opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2))+  = ASSERT( r == r1 )+    opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2)+ opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))       -- works for both tyvar and covar   = ASSERT( r == _r )@@ -336,18 +353,16 @@     opt_co4_wrap env sym rep Nominal eta  opt_co4 env sym rep r (NthCo _r n co)-  | TyConAppCo _ _ cos <- co'-  , let nth_co = cos `getNth` n+  | Just nth_co <- case co' of+      TyConAppCo _ _ cos -> Just (cos `getNth` n)+      FunCo _ w co1 co2  -> Just (mkNthCoFunCo n w co1 co2)+      ForAllCo _ eta _   -> Just eta+      _                  -> Nothing   = if rep && (r == Nominal)       -- keep propagating the SubCo     then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co     else nth_co -  | ForAllCo _ eta _ <- co'-  = if rep-    then opt_co4_wrap (zapLiftingContext env) False True Nominal eta-    else eta-   | otherwise   = wrapRole rep r $ NthCo r n co'   where@@ -514,8 +529,8 @@    -- can't optimize the AppTy case because we can't build the kind coercions. -  | Just (tv1, ty1) <- splitForAllTy_ty_maybe oty1-  , Just (tv2, ty2) <- splitForAllTy_ty_maybe oty2+  | Just (tv1, ty1) <- splitForAllTyVar_maybe oty1+  , Just (tv2, ty2) <- splitForAllTyVar_maybe oty2       -- NB: prov isn't interesting here either   = let k1   = tyVarKind tv1         k2   = tyVarKind tv2@@ -527,8 +542,8 @@     in     mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2') -  | Just (cv1, ty1) <- splitForAllTy_co_maybe oty1-  , Just (cv2, ty2) <- splitForAllTy_co_maybe oty2+  | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1+  , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2       -- NB: prov isn't interesting here either   = let k1    = varType cv1         k2    = varType cv2@@ -555,7 +570,10 @@    where     prov' = case prov of+#if __GLASGOW_HASKELL__ < 901+-- This alt is redundant with the first match of the FunDef       PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco+#endif       ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco       PluginProv _       -> prov       CorePrepProv       -> prov@@ -988,7 +1006,7 @@     check_no_conflict _    [] = Nothing     check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)          -- See Note [Apartness] in GHC.Core.FamInstEnv-      | SurelyApart <- tcUnifyTysFG instanceBindFun flat lhs_incomp+      | SurelyApart <- tcUnifyTysFG alwaysBindFun flat lhs_incomp       = check_no_conflict flat rest       | otherwise       = Just b@@ -1102,7 +1120,7 @@   = Just (tv, kind_co, r)    | Pair ty1 ty2  <- coercionKind co-  , Just (tv1, _) <- splitForAllTy_ty_maybe ty1+  , Just (tv1, _) <- splitForAllTyVar_maybe ty1   , isForAllTy_ty ty2   , let kind_co = mkNthCo Nominal 0 co   = Just ( tv1, kind_co@@ -1118,7 +1136,7 @@   = Just (cv, kind_co, r)    | Pair ty1 ty2  <- coercionKind co-  , Just (cv1, _) <- splitForAllTy_co_maybe ty1+  , Just (cv1, _) <- splitForAllCoVar_maybe ty1   , isForAllTy_co ty2   = let kind_co  = mkNthCo Nominal 0 co         r        = coVarRole cv1

GHC/Core/ConLike.hs view

@@ -9,6 +9,7 @@  module GHC.Core.ConLike (           ConLike(..)+        , isVanillaConLike         , conLikeArity         , conLikeFieldLabels         , conLikeInstOrigArgTys@@ -16,13 +17,13 @@         , conLikeExTyCoVars         , conLikeName         , conLikeStupidTheta-        , conLikeWrapId_maybe         , conLikeImplBangs         , conLikeFullSig         , conLikeResTy         , conLikeFieldType         , conLikesWithFields         , conLikeIsInfix+        , conLikeHasBuilder     ) where  #include "HsVersions.h"@@ -41,6 +42,7 @@ import GHC.Core.Type(mkTyConApp) import GHC.Core.Multiplicity +import Data.Maybe( isJust ) import qualified Data.Data as Data  {-@@ -55,6 +57,12 @@ data ConLike = RealDataCon DataCon              | PatSynCon PatSyn +-- | Is this a \'vanilla\' constructor-like thing+-- (no existentials, no provided constraints)?+isVanillaConLike :: ConLike -> Bool+isVanillaConLike (RealDataCon con) = isVanillaDataCon con+isVanillaConLike (PatSynCon   ps ) = isVanillaPatSyn  ps+ {- ************************************************************************ *                                                                      *@@ -144,12 +152,11 @@ conLikeStupidTheta (RealDataCon data_con) = dataConStupidTheta data_con conLikeStupidTheta (PatSynCon {})         = [] --- | Returns the `Id` of the wrapper. This is also known as the builder in--- some contexts. The value is Nothing only in the case of unidirectional--- pattern synonyms.-conLikeWrapId_maybe :: ConLike -> Maybe Id-conLikeWrapId_maybe (RealDataCon data_con) = Just $ dataConWrapId data_con-conLikeWrapId_maybe (PatSynCon pat_syn)    = fst <$> patSynBuilder pat_syn+-- | 'conLikeHasBuilder' returns True except for+-- uni-directional pattern synonyms, which have no builder+conLikeHasBuilder :: ConLike -> Bool+conLikeHasBuilder (RealDataCon {})    = True+conLikeHasBuilder (PatSynCon pat_syn) = isJust (patSynBuilder pat_syn)  -- | Returns the strictness information for each constructor conLikeImplBangs :: ConLike -> [HsImplBang]

− GHC/Core/ConLike.hs-boot

@@ -1,9 +0,0 @@-module GHC.Core.ConLike where-import {-# SOURCE #-} GHC.Core.DataCon (DataCon)-import {-# SOURCE #-} GHC.Core.PatSyn (PatSyn)-import GHC.Types.Name ( Name )--data ConLike = RealDataCon DataCon-             | PatSynCon PatSyn--conLikeName :: ConLike -> Name

GHC/Core/DataCon.hs view

@@ -21,7 +21,7 @@         substEqSpec, filterEqSpec,          -- ** Field labels-        FieldLbl(..), FieldLabel, FieldLabelString,+        FieldLabel(..), FieldLabelString,          -- ** Type construction         mkDataCon, fIRST_TAG,@@ -51,9 +51,10 @@         splitDataProductType_maybe,          -- ** Predicates on DataCons-        isNullarySrcDataCon, isNullaryRepDataCon, isTupleDataCon, isUnboxedTupleCon,-        isUnboxedSumCon,-        isVanillaDataCon, classDataCon, dataConCannotMatch,+        isNullarySrcDataCon, isNullaryRepDataCon,+        isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,+        isUnboxedSumDataCon,+        isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch,         dataConUserTyVarsArePermuted,         isBanged, isMarkedStrict, eqHsBang, isSrcStrict, isSrcUnpacked,         specialPromotedDc,@@ -72,23 +73,25 @@ import GHC.Core.Unify import GHC.Core.TyCon import GHC.Core.Multiplicity+import {-# SOURCE #-} GHC.Types.TyThing import GHC.Types.FieldLabel+import GHC.Types.SourceText import GHC.Core.Class import GHC.Types.Name import GHC.Builtin.Names import GHC.Core.Predicate import GHC.Types.Var-import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Types.Basic import GHC.Data.FastString-import GHC.Unit+import GHC.Unit.Types+import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Types.Unique.Set-import GHC.Types.Unique( mkAlphaTyVarUnique )+import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) -import GHC.Driver.Session-import GHC.LanguageExtensions as LangExt+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic  import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB@@ -305,7 +308,7 @@ -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen', --             'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma' --- For details on above see note [Api annotations] in GHC.Parser.Annotation+-- For details on above see note [exact print annotations] in GHC.Parser.Annotation data DataCon   = MkData {         dcName    :: Name,      -- This is the name of the *source data con*@@ -673,7 +676,7 @@ -- emit a warning (in checkValidDataCon) and treat it like -- @(HsSrcBang _ NoSrcUnpack SrcLazy)@ data HsSrcBang =-  HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.Basic+  HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.SourceText             SrcUnpackedness             SrcStrictness   deriving Data.Data@@ -1193,11 +1196,11 @@ -- the union of the 'dataConWorkId' and the 'dataConWrapId' dataConImplicitTyThings :: DataCon -> [TyThing] dataConImplicitTyThings (MkData { dcWorkId = work, dcRep = rep })-  = [AnId work] ++ wrap_ids+  = [mkAnId work] ++ wrap_ids   where     wrap_ids = case rep of                  NoDataConRep               -> []-                 DCR { dcr_wrap_id = wrap } -> [AnId wrap]+                 DCR { dcr_wrap_id = wrap } -> [mkAnId wrap]  -- | The labels for the fields of this particular 'DataCon' dataConFieldLabels :: DataCon -> [FieldLabel]@@ -1338,7 +1341,7 @@ Used when we don't want to introduce linear types to user (in holes and in types in hie used by haddock). -3. dataConDisplayType (depends on DynFlags):+3. dataConDisplayType (take a boolean indicating if -XLinearTypes is enabled): The type we'd like to show in error messages, :info and -ddump-types. Ideally, it should reflect the type written by the user; the function returns a type with arrows that would be required@@ -1385,9 +1388,9 @@        mkVisFunTys arg_tys' $        res_ty -dataConDisplayType :: DynFlags -> DataCon -> Type-dataConDisplayType dflags dc-  = if xopt LangExt.LinearTypes dflags+dataConDisplayType :: Bool -> DataCon -> Type+dataConDisplayType show_linear_types dc+  = if show_linear_types     then dataConWrapperType dc     else dataConNonlinearType dc @@ -1469,16 +1472,23 @@ isTupleDataCon :: DataCon -> Bool isTupleDataCon (MkData {dcRepTyCon = tc}) = isTupleTyCon tc -isUnboxedTupleCon :: DataCon -> Bool-isUnboxedTupleCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc+isBoxedTupleDataCon :: DataCon -> Bool+isBoxedTupleDataCon (MkData {dcRepTyCon = tc}) = isBoxedTupleTyCon tc -isUnboxedSumCon :: DataCon -> Bool-isUnboxedSumCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc+isUnboxedTupleDataCon :: DataCon -> Bool+isUnboxedTupleDataCon (MkData {dcRepTyCon = tc}) = isUnboxedTupleTyCon tc +isUnboxedSumDataCon :: DataCon -> Bool+isUnboxedSumDataCon (MkData {dcRepTyCon = tc}) = isUnboxedSumTyCon tc+ -- | Vanilla 'DataCon's are those that are nice boring Haskell 98 constructors isVanillaDataCon :: DataCon -> Bool isVanillaDataCon dc = dcVanilla dc +-- | Is this the 'DataCon' of a newtype?+isNewDataCon :: DataCon -> Bool+isNewDataCon dc = isNewTyCon (dataConTyCon dc)+ -- | Should this DataCon be allowed in a type even without -XDataKinds? -- Currently, only Lifted & Unlifted specialPromotedDc :: DataCon -> Bool@@ -1554,15 +1564,13 @@ -- | Extract the type constructor, type argument, data constructor and it's -- /representation/ argument types from a type if it is a product type. ----- Precisely, we return @Just@ for any type that is all of:+-- Precisely, we return @Just@ for any data type that is all of: -- --  * Concrete (i.e. constructors visible)--- --  * Single-constructor------  * Not existentially quantified+--  * ... which has no existentials ----- Whether the type is a @data@ type or a @newtype@+-- Whether the type is a @data@ type or a @newtype@. splitDataProductType_maybe         :: Type                         -- ^ A product type, perhaps         -> Maybe (TyCon,                -- The type constructor@@ -1570,13 +1578,14 @@                   DataCon,              -- The data constructor                   [Scaled Type])        -- Its /representation/ arg types -        -- Rejecting existentials is conservative.  Maybe some things-        -- could be made to work with them, but I'm not going to sweat-        -- it through till someone finds it's important.+        -- Rejecting existentials means we don't have to worry about+        -- freshening and substituting type variables+        -- (See "GHC.Type.Id.Make.dataConArgUnpack")  splitDataProductType_maybe ty   | Just (tycon, ty_args) <- splitTyConApp_maybe ty-  , Just con <- isDataProductTyCon_maybe tycon+  , Just con <- tyConSingleDataCon_maybe tycon+  , null (dataConExTyCoVars con) -- no existentials! See above   = Just (tycon, ty_args, con, dataConInstArgTys con ty_args)   | otherwise   = Nothing

GHC/Core/DataCon.hs-boot view

@@ -1,8 +1,8 @@ module GHC.Core.DataCon where  import GHC.Prelude-import GHC.Types.Var( TyVar, TyCoVar, InvisTVBinder )-import GHC.Types.Name( Name, NamedThing )+import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, InvisTVBinder )+import {-# SOURCE #-} GHC.Types.Name( Name, NamedThing ) import {-# SOURCE #-} GHC.Core.TyCon( TyCon ) import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Types.Unique ( Uniquable )@@ -15,6 +15,7 @@ data EqSpec  dataConName      :: DataCon -> Name+dataConWorkId    :: DataCon -> Id dataConTyCon     :: DataCon -> TyCon dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar]@@ -25,10 +26,13 @@ dataConStupidTheta :: DataCon -> ThetaType dataConFullSig :: DataCon                -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type)-isUnboxedSumCon :: DataCon -> Bool+isUnboxedSumDataCon :: DataCon -> Bool  instance Eq DataCon instance Uniquable DataCon instance NamedThing DataCon instance Outputable DataCon instance OutputableBndr DataCon++dataConWrapId :: DataCon -> Id+promoteDataCon :: DataCon -> TyCon

GHC/Core/FVs.hs view

@@ -6,20 +6,17 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}  -- | A module concerned with finding the free variables of an expression. module GHC.Core.FVs (         -- * Free variables of expressions and binding groups-        exprFreeVars,+        exprFreeVars,     exprsFreeVars,         exprFreeVarsDSet,-        exprFreeVarsList,-        exprFreeIds,-        exprFreeIdsDSet,-        exprFreeIdsList,-        exprsFreeIdsDSet,-        exprsFreeIdsList,-        exprsFreeVars,-        exprsFreeVarsList,+        exprFreeVarsList, exprsFreeVarsList,+        exprFreeIds,      exprsFreeIds,+        exprFreeIdsDSet,  exprsFreeIdsDSet,+        exprFreeIdsList,  exprsFreeIdsList,         bindFreeVars,          -- * Selective free variables of expressions@@ -32,12 +29,13 @@         varTypeTyCoFVs,         idUnfoldingVars, idFreeVars, dIdFreeVars,         bndrRuleAndUnfoldingVarsDSet,+        bndrRuleAndUnfoldingIds,         idFVs,-        idRuleVars, idRuleRhsVars, stableUnfoldingVars,+        idRuleVars, stableUnfoldingVars,         ruleFreeVars, rulesFreeVars,         rulesFreeVarsDSet, mkRuleInfo,         ruleLhsFreeIds, ruleLhsFreeIdsList,-        ruleRhsFreeVars, ruleRhsFreeIds,+        ruleRhsFreeVars, rulesRhsFreeIds,          expr_fvs, @@ -66,9 +64,8 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name.Set-import GHC.Types.Unique.Set-import GHC.Types.Unique (Uniquable (..)) import GHC.Types.Name+import GHC.Types.Tickish import GHC.Types.Var.Set import GHC.Types.Var import GHC.Core.Type@@ -80,10 +77,10 @@ import GHC.Builtin.Types( unrestrictedFunTyConName ) import GHC.Builtin.Types.Prim( funTyConName ) import GHC.Data.Maybe( orElse )-import GHC.Utils.Misc-import GHC.Types.Basic( Activation )-import GHC.Utils.Outputable+ import GHC.Utils.FV as FV+import GHC.Utils.Misc+import GHC.Utils.Panic  {- ************************************************************************@@ -126,6 +123,9 @@ exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids exprFreeIds = exprSomeFreeVars isLocalId +exprsFreeIds :: [CoreExpr] -> IdSet        -- Find all locally-defined free Ids+exprsFreeIds = exprsSomeFreeVars isLocalId+ -- | Find all locally-defined free Ids in an expression -- returning a deterministic set. exprFreeIdsDSet :: CoreExpr -> DIdSet -- Find all locally-defined free Ids@@ -270,7 +270,7 @@   = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr       (mapUnionFV alt_fvs alts)) fv_cand in_scope acc   where-    alt_fvs (_, bndrs, rhs) = addBndrs bndrs (expr_fvs rhs)+    alt_fvs (Alt _ bndrs rhs) = addBndrs bndrs (expr_fvs rhs)  expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc   = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))@@ -291,8 +291,8 @@ exprs_fvs :: [CoreExpr] -> FV exprs_fvs exprs = mapUnionFV expr_fvs exprs -tickish_fvs :: Tickish Id -> FV-tickish_fvs (Breakpoint _ ids) = FV.mkFVs ids+tickish_fvs :: CoreTickish -> FV+tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids tickish_fvs _ = emptyFV  {-@@ -328,7 +328,7 @@     go (Case e _ ty as)     = go e `unionNameSet` orphNamesOfType ty                               `unionNameSet` unionNameSets (map go_alt as) -    go_alt (_,_,r) = go r+    go_alt (Alt _ _ r)      = go r  -- | Finds the free /external/ names of several expressions: see 'exprOrphNames' for details exprsOrphNames :: [CoreExpr] -> NameSet@@ -451,88 +451,71 @@ ************************************************************************ -} +data RuleFVsFrom+  = LhsOnly+  | RhsOnly+  | BothSides++-- | Those locally-defined variables free in the left and/or right hand sides+-- of the rule, depending on the first argument. Returns an 'FV' computation.+ruleFVs :: RuleFVsFrom -> CoreRule -> FV+ruleFVs !_   (BuiltinRule {}) = emptyFV+ruleFVs from (Rule { ru_fn = _do_not_include+                     -- See Note [Rule free var hack]+                   , ru_bndrs = bndrs+                   , ru_rhs = rhs, ru_args = args })+  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs)+  where+    exprs = case from of+      LhsOnly   -> args+      RhsOnly   -> [rhs]+      BothSides -> rhs:args++-- | Those locally-defined variables free in the left and/or right hand sides+-- from several rules, depending on the first argument.+-- Returns an 'FV' computation.+rulesFVs :: RuleFVsFrom -> [CoreRule] -> FV+rulesFVs from = mapUnionFV (ruleFVs from)+ -- | Those variables free in the right hand side of a rule returned as a -- non-deterministic set ruleRhsFreeVars :: CoreRule -> VarSet-ruleRhsFreeVars (BuiltinRule {}) = noFVs-ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs })-  = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)-      -- See Note [Rule free var hack]+ruleRhsFreeVars = fvVarSet . ruleFVs RhsOnly --- | Those variables free in the both the left right hand sides of a rule+-- | Those locally-defined free 'Id's in the right hand side of several rules -- returned as a non-deterministic set-ruleFreeVars :: CoreRule -> VarSet-ruleFreeVars = fvVarSet . ruleFVs+rulesRhsFreeIds :: [CoreRule] -> VarSet+rulesRhsFreeIds = fvVarSet . filterFV isLocalId . rulesFVs RhsOnly --- | Those variables free in the both the left right hand sides of a rule--- returned as FV computation-ruleFVs :: CoreRule -> FV-ruleFVs (BuiltinRule {}) = emptyFV-ruleFVs (Rule { ru_fn = _do_not_include-                  -- See Note [Rule free var hack]-              , ru_bndrs = bndrs-              , ru_rhs = rhs, ru_args = args })-  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs (rhs:args))+ruleLhsFreeIds :: CoreRule -> VarSet+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a non-deterministic set+ruleLhsFreeIds = fvVarSet . filterFV isLocalId . ruleFVs LhsOnly --- | Those variables free in the both the left right hand sides of rules--- returned as FV computation-rulesFVs :: [CoreRule] -> FV-rulesFVs = mapUnionFV ruleFVs+ruleLhsFreeIdsList :: CoreRule -> [Var]+-- ^ This finds all locally-defined free Ids on the left hand side of a rule+-- and returns them as a deterministically ordered list+ruleLhsFreeIdsList = fvVarList . filterFV isLocalId . ruleFVs LhsOnly +-- | Those variables free in the both the left right hand sides of a rule+-- returned as a non-deterministic set+ruleFreeVars :: CoreRule -> VarSet+ruleFreeVars = fvVarSet . ruleFVs BothSides+ -- | Those variables free in the both the left right hand sides of rules -- returned as a deterministic set rulesFreeVarsDSet :: [CoreRule] -> DVarSet-rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs rules+rulesFreeVarsDSet rules = fvDVarSet $ rulesFVs BothSides rules +-- | Those variables free in both the left right hand sides of several rules+rulesFreeVars :: [CoreRule] -> VarSet+rulesFreeVars rules = fvVarSet $ rulesFVs BothSides rules+ -- | Make a 'RuleInfo' containing a number of 'CoreRule's, suitable -- for putting into an 'IdInfo' mkRuleInfo :: [CoreRule] -> RuleInfo mkRuleInfo rules = RuleInfo rules (rulesFreeVarsDSet rules) -idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet--- Just the variables free on the *rhs* of a rule-idRuleRhsVars is_active id-  = mapUnionVarSet get_fvs (idCoreRules id)-  where-    get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs-                  , ru_rhs = rhs, ru_act = act })-      | is_active act-            -- See Note [Finding rule RHS free vars] in "GHC.Core.Opt.OccurAnal"-      = delOneFromUniqSet_Directly fvs (getUnique fn)-            -- Note [Rule free var hack]-      where-        fvs = fvVarSet $ filterFV isLocalVar $ addBndrs bndrs (expr_fvs rhs)-    get_fvs _ = noFVs---- | Those variables free in the right hand side of several rules-rulesFreeVars :: [CoreRule] -> VarSet-rulesFreeVars rules = mapUnionVarSet ruleFreeVars rules--ruleLhsFreeIds :: CoreRule -> VarSet--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns them as a non-deterministic set-ruleLhsFreeIds = fvVarSet . ruleLhsFVIds--ruleLhsFreeIdsList :: CoreRule -> [Var]--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns them as a deterministically ordered list-ruleLhsFreeIdsList = fvVarList . ruleLhsFVIds--ruleLhsFVIds :: CoreRule -> FV--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns an FV computation-ruleLhsFVIds (BuiltinRule {}) = emptyFV-ruleLhsFVIds (Rule { ru_bndrs = bndrs, ru_args = args })-  = filterFV isLocalId $ addBndrs bndrs (exprs_fvs args)--ruleRhsFreeIds :: CoreRule -> VarSet--- ^ This finds all locally-defined free Ids on the left hand side of a rule--- and returns them as a non-deterministic set-ruleRhsFreeIds (BuiltinRule {}) = emptyVarSet-ruleRhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args })-  = fvVarSet $ filterFV isLocalId $-     addBndrs bndrs $ exprs_fvs args- {- Note [Rule free var hack]  (Not a hack any more) ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -588,9 +571,6 @@ freeVarsOfAnn :: FVAnn -> DIdSet freeVarsOfAnn fvs = fvs -noFVs :: VarSet-noFVs = emptyVarSet- aFreeVar :: Var -> DVarSet aFreeVar = unitDVarSet @@ -662,6 +642,9 @@ bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id +bndrRuleAndUnfoldingIds :: Id -> IdSet+bndrRuleAndUnfoldingIds id = fvVarSet $ filterFV isId $ bndrRuleAndUnfoldingFVs id+ bndrRuleAndUnfoldingFVs :: Id -> FV bndrRuleAndUnfoldingFVs id   | isId id   = idRuleFVs id `unionFV` idUnfoldingFVs id@@ -776,8 +759,8 @@         (alts_fvs_s, alts2) = mapAndUnzip fv_alt alts         alts_fvs            = unionFVss alts_fvs_s -        fv_alt (con,args,rhs) = (delBindersFV args (freeVarsOf rhs2),-                                 (con, args, rhs2))+        fv_alt (Alt con args rhs) = (delBindersFV args (freeVarsOf rhs2),+                                     (AnnAlt con args rhs2))                               where                                  rhs2 = go rhs @@ -799,8 +782,8 @@         , AnnTick tickish expr2 )       where         expr2 = go expr-        tickishFVs (Breakpoint _ ids) = mkDVarSet ids-        tickishFVs _                  = emptyDVarSet+        tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids+        tickishFVs _                    = emptyDVarSet      go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)     go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)

GHC/Core/FamInstEnv.hs view

@@ -1,12 +1,14 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations -{-# LANGUAGE CPP, GADTs, ScopedTypeVariables, BangPatterns, TupleSections,-    DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Core.FamInstEnv (         FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,         famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,@@ -33,10 +35,7 @@         -- Normalisation         topNormaliseType, topNormaliseType_maybe,         normaliseType, normaliseTcApp,-        topReduceTyFamApp_maybe, reduceTyFamApp_maybe,--        -- Flattening-        flattenTys+        topReduceTyFamApp_maybe, reduceTyFamApp_maybe     ) where  #include "HsVersions.h"@@ -53,18 +52,17 @@ import GHC.Types.Var.Env import GHC.Types.Name import GHC.Types.Unique.DFM-import GHC.Utils.Outputable import GHC.Data.Maybe-import GHC.Core.Map-import GHC.Types.Unique-import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.SrcLoc-import GHC.Data.FastString import Control.Monad import Data.List( mapAccumL ) import Data.Array( Array, assocs ) +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ {- ************************************************************************ *                                                                      *@@ -106,8 +104,9 @@             , fi_fam   :: Name          -- Family name                  -- Used for "rough matching"; same idea as for class instances-                -- See Note [Rough-match field] in GHC.Core.InstEnv-            , fi_tcs   :: [Maybe Name]  -- Top of type args+                -- See Note [Rough matching in class and family instances]+                -- in GHC.Core.Unify+            , fi_tcs   :: [RoughMatchTc]  -- Top of type args                 -- INVARIANT: fi_tcs = roughMatchTcs fi_tys              -- Used for "proper matching"; ditto@@ -222,7 +221,7 @@ pprFamInst :: FamInst -> SDoc -- Prints the FamInst as a family instance declaration -- NB: This function, FamInstEnv.pprFamInst, is used only for internal,---     debug printing. See GHC.Core.Ppr.TyThing.pprFamInst for printing for the user+--     debug printing. See GHC.Types.TyThing.Ppr.pprFamInst for printing for the user pprFamInst (FamInst { fi_flavor = flavor, fi_axiom = ax                     , fi_tvs = tvs, fi_tys = tys, fi_rhs = rhs })   = hang (ppr_tc_sort <+> text "instance"@@ -266,7 +265,7 @@ -- interface file.  In particular, we get the rough match info from the iface -- (instead of computing it here). mkImportedFamInst :: Name               -- Name of the family-                  -> [Maybe Name]       -- Rough match info+                  -> [RoughMatchTc]     -- Rough match info                   -> CoAxiom Unbranched -- Axiom introduced                   -> FamInst            -- Resulting family instance mkImportedFamInst fam mb_tcs axiom@@ -430,7 +429,8 @@ apart(target, pattern) = not (unify(flatten(target), pattern))  where flatten (implemented in flattenTys, below) converts all type-family-applications into fresh variables. (See Note [Flattening].)+applications into fresh variables. (See+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.)  Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~@@ -523,7 +523,7 @@                    (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })   = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2              -- See Note [Compatibility of eta-reduced axioms]-    in case tcUnifyTysFG (const BindMe) commonlhs1 commonlhs2 of+    in case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of       SurelyApart -> True       Unifiable subst         | Type.substTyAddInScope subst rhs1 `eqType`@@ -1143,6 +1143,7 @@    | Just ax           <- isBuiltInSynFamTyCon_maybe tc   , Just (coax,ts,ty) <- sfMatchFam ax tys+  , role == coaxrRole coax   = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)     in Just (co, ty) @@ -1177,7 +1178,8 @@                         , cab_incomps = incomps }) = branch             in_scope = mkInScopeSet (unionVarSets $                             map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-            -- See Note [Flattening] below+            -- See Note [Flattening type-family applications when matching instances]+            -- in GHC.Core.Unify             flattened_target = flattenTys in_scope target_tys         in case tcMatchTys tpl_lhs target_tys of         Just subst -- matching worked. now, check for apartness.@@ -1194,16 +1196,16 @@ -- (POPL '14). This should be used when determining if an equation -- ('CoAxBranch') of a closed type family can be used to reduce a certain target -- type family application.-apartnessCheck :: [Type]     -- ^ /flattened/ target arguments. Make sure-                             -- they're flattened! See Note [Flattening].-                             -- (NB: This "flat" is a different-                             -- "flat" than is used in GHC.Tc.Solver.Flatten.)+apartnessCheck :: [Type]+  -- ^ /flattened/ target arguments. Make sure they're flattened! See+  -- Note [Flattening type-family applications when matching instances]+  -- in GHC.Core.Unify.                -> CoAxBranch -- ^ the candidate equation we wish to use                              -- Precondition: this matches the target                -> Bool       -- ^ True <=> equation can fire apartnessCheck flattened_target (CoAxBranch { cab_incomps = incomps })   = all (isSurelyApart-         . tcUnifyTysFG (const BindMe) flattened_target+         . tcUnifyTysFG alwaysBindFun flattened_target          . coAxBranchLHS) incomps   where     isSurelyApart SurelyApart = True@@ -1317,7 +1319,7 @@     tyFamStepper :: NormaliseStepper (Coercion, MCoercionN)     tyFamStepper rec_nts tc tys  -- Try to step a type/data family       = case topReduceTyFamApp_maybe env tc tys of-          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, MCo res_co)+          Just (co, rhs, res_co) -> NS_Step rec_nts rhs (co, res_co)           _                      -> NS_Done  ---------------@@ -1363,14 +1365,14 @@     assemble_result :: Role       -- r, ambient role in NormM monad                     -> Type       -- nty, result type, possibly of changed kind                     -> Coercion   -- orig_ty ~r nty, possibly heterogeneous-                    -> CoercionN  -- typeKind(orig_ty) ~N typeKind(nty)+                    -> MCoercionN -- typeKind(orig_ty) ~N typeKind(nty)                     -> (Coercion, Type)   -- (co :: orig_ty ~r nty_casted, nty_casted)                                           -- where nty_casted has same kind as orig_ty     assemble_result r nty orig_to_nty kind_co       = ( final_co, nty_old_kind )       where-        nty_old_kind = nty `mkCastTy` mkSymCo kind_co-        final_co     = mkCoherenceRightCo r nty (mkSymCo kind_co) orig_to_nty+        nty_old_kind = nty `mkCastTyMCo` mkSymMCo kind_co+        final_co     = mkCoherenceRightMCo r nty (mkSymMCo kind_co) orig_to_nty  --------------- -- | Try to simplify a type-family application, by *one* step@@ -1379,7 +1381,7 @@ --         res_co :: typeKind(F tys) ~ typeKind(rhs) -- Type families and data families; always Representational role topReduceTyFamApp_maybe :: FamInstEnvs -> TyCon -> [Type]-                        -> Maybe (Coercion, Type, Coercion)+                        -> Maybe (Coercion, Type, MCoercion) topReduceTyFamApp_maybe envs fam_tc arg_tys   | isFamilyTyCon fam_tc   -- type families and data families   , Just (co, rhs) <- reduceTyFamApp_maybe envs role fam_tc ntys@@ -1392,7 +1394,7 @@                               normalise_tc_args fam_tc arg_tys  normalise_tc_args :: TyCon -> [Type]             -- tc tys-                  -> NormM (Coercion, [Type], CoercionN)+                  -> NormM (Coercion, [Type], MCoercionN)                   -- (co, new_tys), where                   -- co :: tc tys ~ tc new_tys; might not be homogeneous                   -- res_co :: typeKind(tc tys) ~N typeKind(tc new_tys)@@ -1457,14 +1459,14 @@     go_app_tys :: Type   -- function                -> [Type] -- args                -> NormM (Coercion, Type)-    -- cf. GHC.Tc.Solver.Flatten.flatten_app_ty_args+    -- cf. GHC.Tc.Solver.Rewrite.rewrite_app_ty_args     go_app_tys (AppTy ty1 ty2) tys = go_app_tys ty1 (ty2 : tys)     go_app_tys fun_ty arg_tys       = do { (fun_co, nfun) <- go fun_ty            ; case tcSplitTyConApp_maybe nfun of                Just (tc, xis) ->                  do { (second_co, nty) <- go (mkTyConApp tc (xis ++ arg_tys))-                   -- flatten_app_ty_args avoids redundantly processing the xis,+                   -- rewrite_app_ty_args avoids redundantly processing the xis,                    -- but that's a much more performance-sensitive function.                    -- This type normalisation is not called in a loop.                     ; return (mkAppCos fun_co (map mkNomReflCo arg_tys) `mkTransCo` second_co, nty) }@@ -1475,29 +1477,29 @@                     ; role <- getRole                     ; let nty = mkAppTys nfun nargs                           nco = mkAppCos fun_co args_cos-                          nty_casted = nty `mkCastTy` mkSymCo res_co-                          final_co = mkCoherenceRightCo role nty (mkSymCo res_co) nco+                          nty_casted = nty `mkCastTyMCo` mkSymMCo res_co+                          final_co = mkCoherenceRightMCo role nty (mkSymMCo res_co) nco                     ; return (final_co, nty_casted) } }  normalise_args :: Kind    -- of the function                -> [Role]  -- roles at which to normalise args                -> [Type]  -- args-               -> NormM ([Coercion], [Type], Coercion)+               -> NormM ([Coercion], [Type], MCoercion) -- returns (cos, xis, res_co), where each xi is the normalised -- version of the corresponding type, each co is orig_arg ~ xi, -- and the res_co :: kind(f orig_args) ~ kind(f xis) -- NB: The xis might *not* have the same kinds as the input types, -- but the resulting application *will* be well-kinded--- cf. GHC.Tc.Solver.Flatten.flatten_args_slow+-- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args   = do { normed_args <- zipWithM normalise1 roles args        ; let (xis, cos, res_co) = simplifyArgsWorker ki_binders inner_ki fvs roles normed_args-       ; return (map mkSymCo cos, xis, mkSymCo res_co) }+       ; return (map mkSymCo cos, xis, mkSymMCo res_co) }   where     (ki_binders, inner_ki) = splitPiTys fun_ki     fvs = tyCoVarsOfTypes args -    -- flattener conventions are different from ours+    -- rewriter conventions are different from ours     impedance_match :: NormM (Coercion, Type) -> NormM (Type, Coercion)     impedance_match action = do { (co, ty) <- action                                 ; return (ty, mkSymCo co) }@@ -1561,292 +1563,3 @@ instance Applicative NormM where   pure x = NormM $ \ _ _ _ -> x   (<*>)  = ap--{--************************************************************************-*                                                                      *-              Flattening-*                                                                      *-************************************************************************--Note [Flattening]-~~~~~~~~~~~~~~~~~-As described in "Closed type families with overlapping equations"-http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf-we need to flatten core types before unifying them, when checking for "surely-apart"-against earlier equations of a closed type family.-Flattening means replacing all top-level uses of type functions with-fresh variables, *taking care to preserve sharing*. That is, the type-(Either (F a b) (F a b)) should flatten to (Either c c), never (Either-c d).--Here is a nice example of why it's all necessary:--  type family F a b where-    F Int Bool = Char-    F a   b    = Double-  type family G a         -- open, no instances--How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,-while the second equation does. But, before reducing, we must make sure that the-target can never become (F Int Bool). Well, no matter what G Float becomes, it-certainly won't become *both* Int and Bool, so indeed we're safe reducing-(F (G Float) (G Float)) to Double.--This is necessary not only to get more reductions (which we might be-willing to give up on), but for substitutivity. If we have (F x x), we-can see that (F x x) can reduce to Double. So, it had better be the-case that (F blah blah) can reduce to Double, no matter what (blah)-is!  Flattening as done below ensures this.--The algorithm works by building up a TypeMap TyVar, mapping-type family applications to fresh variables. This mapping must-be threaded through all the function calls, as any entry in-the mapping must be propagated to all future nodes in the tree.--The algorithm also must track the set of in-scope variables, in-order to make fresh variables as it flattens. (We are far from a-source of fresh Uniques.) See Wrinkle 2, below.--There are wrinkles, of course:--1. The flattening algorithm must account for the possibility-   of inner `forall`s. (A `forall` seen here can happen only-   because of impredicativity. However, the flattening operation-   is an algorithm in Core, which is impredicative.)-   Suppose we have (forall b. F b) -> (forall b. F b). Of course,-   those two bs are entirely unrelated, and so we should certainly-   not flatten the two calls F b to the same variable. Instead, they-   must be treated separately. We thus carry a substitution that-   freshens variables; we must apply this substitution (in-   `coreFlattenTyFamApp`) before looking up an application in the environment.-   Note that the range of the substitution contains only TyVars, never anything-   else.--   For the sake of efficiency, we only apply this substitution when absolutely-   necessary. Namely:--   * We do not perform the substitution at all if it is empty.-   * We only need to worry about the arguments of a type family that are within-     the arity of said type family, so we can get away with not applying the-     substitution to any oversaturated type family arguments.-   * Importantly, we do /not/ achieve this substitution by recursively-     flattening the arguments, as this would be wrong. Consider `F (G a)`,-     where F and G are type families. We might decide that `F (G a)` flattens-     to `beta`. Later, the substitution is non-empty (but does not map `a`) and-     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,-     `F gamma` is unknown, and so we flatten it to `delta`, but it really-     should have been `beta`! Argh!--     Moral of the story: instead of flattening the arguments, just substitute-     them directly.--2. There are two different reasons we might add a variable-   to the in-scope set as we work:--     A. We have just invented a new flattening variable.-     B. We have entered a `forall`.--   Annoying here is that in-scope variable source (A) must be-   threaded through the calls. For example, consider (F b -> forall c. F c).-   Suppose that, when flattening F b, we invent a fresh variable c.-   Now, when we encounter (forall c. F c), we need to know c is already in-   scope so that we locally rename c to c'. However, if we don't thread through-   the in-scope set from one argument of (->) to the other, we won't know this-   and might get very confused.--   In contrast, source (B) increases only as we go deeper, as in-scope sets-   normally do. However, even here we must be careful. The TypeMap TyVar that-   contains mappings from type family applications to freshened variables will-   be threaded through both sides of (forall b. F b) -> (forall b. F b). We-   thus must make sure that the two `b`s don't get renamed to the same b1. (If-   they did, then looking up `F b1` would yield the same flatten var for-   each.) So, even though `forall`-bound variables should really be in the-   in-scope set only when they are in scope, we retain these variables even-   outside of their scope. This ensures that, if we encounter a fresh-   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a-   larger in-scope set than strictly necessary is always OK, as in-scope sets-   are only ever used to avoid collisions.--   Sadly, the freshening substitution described in (1) really mustn't bind-   variables outside of their scope: note that its domain is the *unrenamed*-   variables. This means that the substitution gets "pushed down" (like a-   reader monad) while the in-scope set gets threaded (like a state monad).-   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;-   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet-   traveling separately as necessary.--3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:--     type family F ty_1 ... ty_k :: res_k--   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a-   flattening skolem. But we must instead flatten it to-   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the-   type family.--   Why is this better? Consider the following concrete example from #16995:--     type family Param :: Type -> Type--     type family LookupParam (a :: Type) :: Type where-       LookupParam (f Char) = Bool-       LookupParam x        = Int--     foo :: LookupParam (Param ())-     foo = 42--   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to-   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if-   `alpha` is apart from `f Char`, so it won't fall through to the second-   equation. But since the `Param` type family has arity 0, we can instead-   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is-   apart from `f Char`, permitting the second equation to be reached.--   Not only does this allow more programs to be accepted, it's also important-   for correctness. Not doing this was the root cause of the Core Lint error-   in #16995.--flattenTys is defined here because of module dependencies.--}--data FlattenEnv-  = FlattenEnv { fe_type_map :: TypeMap TyVar-                 -- domain: exactly-saturated type family applications-                 -- range: fresh variables-               , fe_in_scope :: InScopeSet }-                 -- See Note [Flattening]--emptyFlattenEnv :: InScopeSet -> FlattenEnv-emptyFlattenEnv in_scope-  = FlattenEnv { fe_type_map = emptyTypeMap-               , fe_in_scope = in_scope }--updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv-updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }--flattenTys :: InScopeSet -> [Type] -> [Type]--- See Note [Flattening]--- NB: the returned types may mention fresh type variables,---     arising from the flattening.  We don't return the---     mapping from those fresh vars to the ty-fam---     applications they stand for (we could, but no need)-flattenTys in_scope tys-  = snd $ coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys--coreFlattenTys :: TvSubstEnv -> FlattenEnv-               -> [Type] -> (FlattenEnv, [Type])-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)--coreFlattenTy :: TvSubstEnv -> FlattenEnv-              -> Type -> (FlattenEnv, Type)-coreFlattenTy subst = go-  where-    go env ty | Just ty' <- coreView ty = go env ty'--    go env (TyVarTy tv)-      | Just ty <- lookupVarEnv subst tv = (env, ty)-      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in-                                           (env', mkTyVarTy $ setTyVarKind tv ki)-    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1-                                 (env2, ty2') = go env1 ty2 in-                             (env2, AppTy ty1' ty2')-    go env (TyConApp tc tys)-         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,-         -- which are generative and thus can be preserved during flattening-      | not (isGenerativeTyCon tc Nominal)-      = coreFlattenTyFamApp subst env tc tys--      | otherwise-      = let (env', tys') = coreFlattenTys subst env tys in-        (env', mkTyConApp tc tys')--    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-      = let (env1, ty1') = go env  ty1-            (env2, ty2') = go env1 ty2-            (env3, mult') = go env2 mult in-        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })--    go env (ForAllTy (Bndr tv vis) ty)-      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv-            (env2, ty') = coreFlattenTy subst' env1 ty in-        (env2, ForAllTy (Bndr tv' vis) ty')--    go env ty@(LitTy {}) = (env, ty)--    go env (CastTy ty co)-      = let (env1, ty') = go env ty-            (env2, co') = coreFlattenCo subst env1 co in-        (env2, CastTy ty' co')--    go env (CoercionTy co)-      = let (env', co') = coreFlattenCo subst env co in-        (env', CoercionTy co')----- when flattening, we don't care about the contents of coercions.--- so, just return a fresh variable of the right (flattened) type-coreFlattenCo :: TvSubstEnv -> FlattenEnv-              -> Coercion -> (FlattenEnv, Coercion)-coreFlattenCo subst env co-  = (env2, mkCoVarCo covar)-  where-    (env1, kind') = coreFlattenTy subst env (coercionType co)-    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'-    -- Add the covar to the FlattenEnv's in-scope set.-    -- See Note [Flattening], wrinkle 2A.-    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)--coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv-                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)-coreFlattenVarBndr subst env tv-  = (env2, subst', tv')-  where-    -- See Note [Flattening], wrinkle 2B.-    kind          = varType tv-    (env1, kind') = coreFlattenTy subst env kind-    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')-    subst'        = extendVarEnv subst tv (mkTyVarTy tv')-    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')--coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv-                    -> TyCon         -- type family tycon-                    -> [Type]        -- args, already flattened-                    -> (FlattenEnv, Type)-coreFlattenTyFamApp tv_subst env fam_tc fam_args-  = case lookupTypeMap type_map fam_ty of-      Just tv -> (env', mkAppTys (mkTyVarTy tv) leftover_args')-      Nothing -> let tyvar_name = mkFlattenFreshTyName fam_tc-                     tv         = uniqAway in_scope $-                                  mkTyVar tyvar_name (typeKind fam_ty)--                     ty'   = mkAppTys (mkTyVarTy tv) leftover_args'-                     env'' = env' { fe_type_map = extendTypeMap type_map fam_ty tv-                                  , fe_in_scope = extendInScopeSet in_scope tv }-                 in (env'', ty')-  where-    arity = tyConArity fam_tc-    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv-    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )-                                    splitAt arity fam_args-    -- Apply the substitution before looking up an application in the-    -- environment. See Note [Flattening], wrinkle 1.-    -- NB: substTys short-cuts the common case when the substitution is empty.-    sat_fam_args' = substTys tcv_subst sat_fam_args-    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args-    -- `fam_tc` may be over-applied to `fam_args` (see Note [Flattening],-    -- wrinkle 3), so we split it into the arguments needed to saturate it-    -- (sat_fam_args') and the rest (leftover_args')-    fam_ty = mkTyConApp fam_tc sat_fam_args'-    FlattenEnv { fe_type_map = type_map-               , fe_in_scope = in_scope } = env'--mkFlattenFreshTyName :: Uniquable a => a -> Name-mkFlattenFreshTyName unq-  = mkSysTvName (getUnique unq) (fsLit "flt")--mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar-mkFlattenFreshCoVar in_scope kind-  = let uniq = unsafeGetFreshLocalUnique in_scope-        name = mkSystemVarName uniq (fsLit "flc")-    in mkCoVar name kind

GHC/Core/InstEnv.hs view

@@ -36,7 +36,8 @@ import GHC.Tc.Utils.TcType -- InstEnv is really part of the type checker,               -- and depends on TcType in many ways import GHC.Core ( IsOrphan(..), isOrphan, chooseOrphanAnchor )-import GHC.Unit+import GHC.Unit.Module.Env+import GHC.Unit.Types import GHC.Core.Class import GHC.Types.Var import GHC.Types.Var.Set@@ -44,15 +45,16 @@ import GHC.Types.Name.Set import GHC.Types.Unique (getUnique) import GHC.Core.Unify-import GHC.Utils.Outputable-import GHC.Utils.Error import GHC.Types.Basic import GHC.Types.Unique.DFM-import GHC.Utils.Misc import GHC.Types.Id import Data.Data        ( Data )-import Data.Maybe       ( isJust, isNothing )+import Data.Maybe       ( isJust ) +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ {- ************************************************************************ *                                                                      *@@ -68,8 +70,8 @@   = ClsInst {   -- Used for "rough matching"; see                 -- Note [ClsInst laziness and the rough-match fields]                 -- INVARIANT: is_tcs = roughMatchTcs is_tys-               is_cls_nm :: Name        -- ^ Class name-             , is_tcs  :: [Maybe Name]  -- ^ Top of type args+               is_cls_nm :: Name          -- ^ Class name+             , is_tcs  :: [RoughMatchTc]  -- ^ Top of type args                 -- | @is_dfun_name = idName . is_dfun@.                --@@ -105,10 +107,10 @@     stableNameCmp (is_cls_nm x) (is_cls_nm y) `mappend`     mconcat (map cmp (zip (is_tcs x) (is_tcs y)))   where-    cmp (Nothing, Nothing) = EQ-    cmp (Nothing, Just _) = LT-    cmp (Just _, Nothing) = GT-    cmp (Just x, Just y) = stableNameCmp x y+    cmp (OtherTc,   OtherTc)   = EQ+    cmp (OtherTc,   KnownTc _) = LT+    cmp (KnownTc _, OtherTc)   = GT+    cmp (KnownTc x, KnownTc y) = stableNameCmp x y  isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool isOverlappable i = hasOverlappableFlag (overlapMode (is_flag i))@@ -133,25 +135,16 @@   pull in interfaces that it refers to. See Note [Proper-match fields].  * Rough-match fields. During instance lookup, we use the is_cls_nm :: Name and-  is_tcs :: [Maybe Name] fields to perform a "rough match", *without* poking+  is_tcs :: [RoughMatchTc] fields to perform a "rough match", *without* poking   inside the DFunId. The rough-match fields allow us to say "definitely does not-  match", based only on Names.+  match", based only on Names.  See GHC.Core.Unify+  Note [Rough matching in class and family instances]    This laziness is very important; see #12367. Try hard to avoid pulling on   the structured fields unless you really need the instance.  * Another place to watch is InstEnv.instIsVisible, which needs the module to   which the ClsInst belongs. We can get this from is_dfun_name.--* In is_tcs,-    Nothing  means that this type arg is a type variable--    (Just n) means that this type arg is a-                TyConApp with a type constructor of n.-                This is always a real tycon, never a synonym!-                (Two different synonyms might match, but two-                different real tycons can't.)-                NB: newtypes are not transparent, though! -}  {-@@ -204,10 +197,9 @@ updateClsInstDFun tidy_dfun ispec   = ispec { is_dfun = tidy_dfun (is_dfun ispec) } -instanceRoughTcs :: ClsInst -> [Maybe Name]+instanceRoughTcs :: ClsInst -> [RoughMatchTc] instanceRoughTcs = is_tcs - instance NamedThing ClsInst where    getName ispec = getName (is_dfun ispec) @@ -231,7 +223,7 @@ pprInstances ispecs = vcat (map pprInstance ispecs)  instanceHead :: ClsInst -> ([TyVar], Class, [Type])--- Returns the head, using the fresh tyavs from the ClsInst+-- Returns the head, using the fresh tyvars from the ClsInst instanceHead (ClsInst { is_tvs = tvs, is_tys = tys, is_dfun = dfun })    = (tvs, cls, tys)    where@@ -298,12 +290,12 @@      choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedInstance :: Name         -- ^ the name of the class-                   -> [Maybe Name] -- ^ the types which the class was applied to-                   -> Name         -- ^ the 'Name' of the dictionary binding-                   -> DFunId       -- ^ the 'Id' of the dictionary.-                   -> OverlapFlag  -- ^ may this instance overlap?-                   -> IsOrphan     -- ^ is this instance an orphan?+mkImportedInstance :: Name           -- ^ the name of the class+                   -> [RoughMatchTc] -- ^ the types which the class was applied to+                   -> Name           -- ^ the 'Name' of the dictionary binding+                   -> DFunId         -- ^ the 'Id' of the dictionary.+                   -> OverlapFlag    -- ^ may this instance overlap?+                   -> IsOrphan       -- ^ is this instance an orphan?                    -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file@@ -757,6 +749,49 @@ where the 'Nothing' indicates that 'b' can be freely instantiated. (The caller instantiates it to a flexi type variable, which will  presumably later become fixed via functional dependencies.)++Note [Infinitary substitution in lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  class C a b+  instance C c c+  instance C d (Maybe d)+  [W] C e (Maybe e)++You would think we could just use the second instance, because the first doesn't+unify. But that's just ever so slightly wrong. The reason we check for unifiers+along with matchers is that we don't want the possibility that a type variable+instantiation could cause an instance choice to change. Yet if we have+  type family M = Maybe M+and choose (e |-> M), then both instances match. This is absurd, but we cannot+rule it out. Yet, worrying about this case is awfully inconvenient to users,+and so we pretend the problem doesn't exist, by considering a lookup that runs into+this occurs-check issue to indicate that an instance surely does not apply (i.e.+is like the SurelyApart case). In the brief time that we didn't treat infinitary+substitutions specially, two tickets were filed: #19044 and #19052, both trying+to do Real Work.++Why don't we just exclude any instances that are MaybeApart? Because we might+have a [W] C e (F e), where F is a type family. The second instance above does+not match, but it should be included as a future possibility. Unification will+return MaybeApart MARTypeFamily in this case.++What can go wrong with this design choice? We might get incoherence -- but not+loss of type safety. In particular, if we have [W] C M M (for the M type family+above), then GHC might arbitrarily choose either instance, depending on how+M reduces (or doesn't).++For type families, we can't just ignore the problem (as we essentially do here),+because doing so would give us a hole in the type safety proof (as explored in+Section 6 of "Closed Type Families with Overlapping Equations", POPL'14). This+possibility of an infinitary substitution manifests as closed type families that+look like they should reduce, but don't. Users complain: #9082 and #17311. For+open type families, we actually can have unsoundness if we don't take infinitary+substitutions into account: #8162. But, luckily, for class instances, we just+risk coherence -- not great, but it seems better to give users what they likely+want. (Also, note that this problem existed for the entire decade of 201x without+anyone noticing, so it's manifestly not ruining anyone's day.) -}  -- |Look up an instance in the given instance environment. The given class application must match exactly@@ -764,7 +799,7 @@ -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs                     -> Class -> [Type]-                    -> Either MsgDoc (ClsInst, [Type])+                    -> Either SDoc (ClsInst, [Type]) lookupUniqueInstEnv instEnv cls tys   = case lookupInstEnv False instEnv cls tys of       ([(inst, inst_tys)], _, _)@@ -797,7 +832,6 @@   = lookup ie   where     rough_tcs  = roughMatchTcs tys-    all_tvs    = all isNothing rough_tcs      --------------     lookup env = case lookupUDFM env cls of@@ -825,18 +859,24 @@       = find ms us rest        | otherwise-      = ASSERT2( tyCoVarsOfTypes tys `disjointVarSet` tpl_tv_set,-                 (ppr cls <+> ppr tys <+> ppr all_tvs) $$+      = ASSERT2( tys_tv_set `disjointVarSet` tpl_tv_set,+                 (ppr cls <+> ppr tys) $$                  (ppr tpl_tvs <+> ppr tpl_tys)                 )                 -- Unification will break badly if the variables overlap                 -- They shouldn't because we allocate separate uniques for them                 -- See Note [Template tyvars are fresh]-        case tcUnifyTys instanceBindFun tpl_tys tys of-            Just _   -> find ms (item:us) rest-            Nothing  -> find ms us        rest+        case tcUnifyTysFG instanceBindFun tpl_tys tys of+          -- We consider MaybeApart to be a case where the instance might+          -- apply in the future. This covers an instance like C Int and+          -- a target like [W] C (F a), where F is a type family.+            SurelyApart              -> find ms us        rest+              -- Note [Infinitary substitution in lookup]+            MaybeApart MARInfinite _ -> find ms us        rest+            _                        -> find ms (item:us) rest       where         tpl_tv_set = mkVarSet tpl_tvs+        tys_tv_set = tyCoVarsOfTypes tys  --------------- -- This is the common way to call this function.@@ -1008,9 +1048,9 @@ ************************************************************************ -} -instanceBindFun :: TyCoVar -> BindFlag-instanceBindFun tv | isOverlappableTyVar tv = Skolem-                   | otherwise              = BindMe+instanceBindFun :: BindFun+instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = Apart+                           | otherwise              = BindMe    -- Note [Binding when looking up instances]  {-@@ -1020,20 +1060,28 @@ we are careful about multiple matches, as described above in Note [Overlapping instances] -The key_tys can contain skolem constants, and we can guarantee that those+The target tys can contain skolem constants. For existentials and instance variables,+we can guarantee that those are never going to be instantiated to anything, so we should not involve-them in the unification test.  Example:+them in the unification test. These are called "super skolems". Example:         class Foo a where { op :: a -> Int }         instance Foo a => Foo [a]       -- NB overlap         instance Foo [Int]              -- NB overlap         data T = forall a. Foo a => MkT a         f :: T -> Int         f (MkT x) = op [x,x]-The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd-complain, saying that the choice of instance depended on the instantiation-of 'a'; but of course it isn't *going* to be instantiated.+The op [x,x] means we need (Foo [a]). This `a` will never be instantiated, and+so it is a super skolem. (See the use of tcInstSuperSkolTyVarsX in+GHC.Tc.Gen.Pat.tcDataConPat.) Super skolems respond True to+isOverlappableTyVar, and the use of Apart in instanceBindFun, above, means+that these will be treated as fresh constants in the unification algorithm+during instance lookup. Without this treatment, GHC would complain, saying+that the choice of instance depended on the instantiation of 'a'; but of+course it isn't *going* to be instantiated. Note that it is necessary that+the unification algorithm returns SurelyApart for these super-skolems+for GHC to be able to commit to another instance. -We do this only for isOverlappableTyVar skolems.  For example we reject+We do this only for super skolems.  For example we reject         g :: forall a => [a] -> Int         g x = op x on the grounds that the correct instance depends on the instantiation of 'a'

GHC/Core/Lint.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998@@ -7,24 +12,27 @@ See Note [Core Lint guarantee]. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns, ScopedTypeVariables, DeriveFunctor, MultiWayIf #-}- module GHC.Core.Lint (     lintCoreBindings, lintUnfolding,     lintPassResult, lintInteractiveExpr, lintExpr,     lintAnnots, lintAxioms, +    interactiveInScope,+     -- ** Debug output     endPass, endPassIO,-    dumpPassResult,-    GHC.Core.Lint.dumpIfSet,+    displayLintResults, dumpPassResult,+    dumpIfSet,  ) where  #include "HsVersions.h"  import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Env+ import GHC.Core import GHC.Core.FVs import GHC.Core.Utils@@ -45,9 +53,9 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.Ppr-import GHC.Utils.Error import GHC.Core.Coercion import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Core.Type as Type import GHC.Core.Multiplicity import GHC.Core.UsageEnv@@ -60,19 +68,24 @@ import GHC.Core.Coercion.Axiom import GHC.Core.Unify import GHC.Types.Basic-import GHC.Utils.Error as Err+import GHC.Utils.Error+import qualified GHC.Utils.Error as Err+import GHC.Utils.Logger (Logger, putLogMsg, putDumpMsg, DumpFormat (..), getLogger)+import qualified GHC.Utils.Logger as Logger import GHC.Data.List.SetOps import GHC.Builtin.Names import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc import GHC.Core.InstEnv      ( instanceDFunId ) import GHC.Core.Coercion.Opt ( checkAxInstCo ) import GHC.Core.Opt.Arity    ( typeArity ) import GHC.Types.Demand      ( splitStrictSig, isDeadEndDiv )+import GHC.Types.TypeEnv+import GHC.Unit.Module.ModGuts+import GHC.Runtime.Context -import GHC.Driver.Types hiding (Usage)-import GHC.Driver.Session import Control.Monad import GHC.Utils.Monad import Data.Foldable      ( toList )@@ -176,7 +189,7 @@   might reject a correct program.  So we carry a type substitution (in   this example [a -> Bool]) and apply this substitution before   comparing types. In effect, in Lint, type equality is always-  equality-moduolo-le-subst.  This is in the le_subst field of+  equality-modulo-le-subst.  This is in the le_subst field of   LintEnv.  But nota bene:    (SI1) The le_subst substitution is applied to types and coercions only@@ -204,14 +217,14 @@ * Alas, when cloning a coercion variable we might choose a unique   that happens to clash with an inner Id, thus       \cv_66 -> let wild_X7 = blah in blah-  We decide to clone `cv_66` becuase it's already in scope.  Fine,+  We decide to clone `cv_66` because it's already in scope.  Fine,   choose a new unique.  Aha, X7 looks good.  So we check the lambda   body with le_subst of [cv_66 :-> cv_X7]    This is all fine, even though we use the same unique as wild_X7.   As (SI2) says, we do /not/ return a new lambda      (\cv_X7 -> let wild_X7 = blah in ...)-  We simply use the le_subst subsitution in types/coercions only, when+  We simply use the le_subst substitution in types/coercions only, when   checking for equality.  * We still need to check that Id occurrences are bound by some@@ -280,21 +293,23 @@           -> CoreToDo -> CoreProgram -> [CoreRule] -> IO () -- Used by the IO-is CorePrep too endPassIO hsc_env print_unqual pass binds rules-  = do { dumpPassResult dflags print_unqual mb_flag+  = do { dumpPassResult logger dflags print_unqual mb_flag                         (ppr pass) (pprPassDetails pass) binds rules        ; lintPassResult hsc_env pass binds }   where+    logger  = hsc_logger hsc_env     dflags  = hsc_dflags hsc_env     mb_flag = case coreDumpFlag pass of                 Just flag | dopt flag dflags                    -> Just flag                           | dopt Opt_D_verbose_core2core dflags -> Just flag                 _ -> Nothing -dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()-dumpIfSet dflags dump_me pass extra_info doc-  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc+dumpIfSet :: Logger -> DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()+dumpIfSet logger dflags dump_me pass extra_info doc+  = Logger.dumpIfSet logger dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc -dumpPassResult :: DynFlags+dumpPassResult :: Logger+               -> DynFlags                -> PrintUnqualified                -> Maybe DumpFlag        -- Just df => show details in a file whose                                         --            name is specified by df@@ -302,16 +317,16 @@                -> SDoc                  -- Extra info to appear after header                -> CoreProgram -> [CoreRule]                -> IO ()-dumpPassResult dflags unqual mb_flag hdr extra_info binds rules+dumpPassResult logger dflags unqual mb_flag hdr extra_info binds rules   = do { forM_ mb_flag $ \flag -> do            let sty = mkDumpStyle unqual-           dumpAction dflags sty (dumpOptionsFromFlag flag)+           putDumpMsg logger dflags sty flag               (showSDoc dflags hdr) FormatCore dump_doc           -- Report result size          -- This has the side effect of forcing the intermediate to be evaluated          -- if it's not already forced by a -ddump flag.-       ; Err.debugTraceMsg dflags 2 size_doc+       ; Err.debugTraceMsg logger dflags 2 size_doc        }    where@@ -347,6 +362,7 @@ coreDumpFlag CorePrep                 = Just Opt_D_dump_prep coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal +coreDumpFlag CoreAddCallerCcs         = Nothing coreDumpFlag CoreDoPrintCore          = Nothing coreDumpFlag (CoreDoRuleCheck {})     = Nothing coreDumpFlag CoreDoNothing            = Nothing@@ -365,36 +381,42 @@   | not (gopt Opt_DoCoreLinting dflags)   = return ()   | otherwise-  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds-       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)-       ; displayLintResults dflags pass warns errs binds  }+  = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds+       ; Err.showPass logger dflags ("Core Linted result of " ++ showPpr dflags pass)+       ; displayLintResults logger dflags (showLintWarnings pass) (ppr pass)+                            (pprCoreBindings binds) warns_and_errs }   where     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env -displayLintResults :: DynFlags -> CoreToDo-                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram+displayLintResults :: Logger+                   -> DynFlags+                   -> Bool -- ^ If 'True', display linter warnings.+                           --   If 'False', ignore linter warnings.+                   -> SDoc -- ^ The source of the linted program+                   -> SDoc -- ^ The linted program, pretty-printed+                   -> WarnsAndErrs                    -> IO ()-displayLintResults dflags pass warns errs binds+displayLintResults logger dflags display_warnings pp_what pp_pgm (warns, errs)   | not (isEmptyBag errs)-  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan+  = do { putLogMsg logger dflags NoReason Err.SevDump noSrcSpan            $ withPprStyle defaultDumpStyle-           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs+           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs                  , text "*** Offending Program ***"-                 , pprCoreBindings binds+                 , pp_pgm                  , text "*** End of Offense ***" ])-       ; Err.ghcExit dflags 1 }+       ; Err.ghcExit logger dflags 1 }    | not (isEmptyBag warns)   , not (hasNoDebugOutput dflags)-  , showLintWarnings pass+  , display_warnings   -- If the Core linter encounters an error, output to stderr instead of   -- stdout (#13342)-  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan+  = putLogMsg logger dflags NoReason Err.SevInfo noSrcSpan       $ withPprStyle defaultDumpStyle-        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))+        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))    | otherwise = return ()-  where  lint_banner :: String -> SDoc -> SDoc lint_banner string pass = text "*** Core Lint"      <+> text string@@ -407,33 +429,23 @@ showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False showLintWarnings _ = True -lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()+lintInteractiveExpr :: SDoc -- ^ The source of the linted expression+                    -> HscEnv -> CoreExpr -> IO () lintInteractiveExpr what hsc_env expr   | not (gopt Opt_DoCoreLinting dflags)   = return ()-  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr-  = do { display_lint_err err-       ; Err.ghcExit dflags 1 }+  | Just err <- lintExpr dflags (interactiveInScope $ hsc_IC hsc_env) expr+  = displayLintResults logger dflags False what (pprCoreExpr expr) (emptyBag, err)   | otherwise   = return ()   where     dflags = hsc_dflags hsc_env--    display_lint_err err-      = do { putLogMsg dflags NoReason Err.SevDump-               noSrcSpan-               $ withPprStyle defaultDumpStyle-               (vcat [ lint_banner "errors" (text what)-                     , err-                     , text "*** Offending Program ***"-                     , pprCoreExpr expr-                     , text "*** End of Offense ***" ])-           ; Err.ghcExit dflags 1 }+    logger = hsc_logger hsc_env -interactiveInScope :: HscEnv -> [Var]+interactiveInScope :: InteractiveContext -> [Var] -- In GHCi we may lint expressions, or bindings arising from 'deriving' -- clauses, that mention variables bound in the interactive context.--- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types).+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context). -- So we have to tell Lint about them, lest it reports them as out of scope. -- -- We do this by find local-named things that may appear free in interactive@@ -442,11 +454,10 @@ -- so this is a (cheap) no-op. -- -- See #8215 for an example-interactiveInScope hsc_env+interactiveInScope ictxt   = tyvars ++ ids   where     -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr-    ictxt                   = hsc_IC hsc_env     (cls_insts, _fam_insts) = ic_instances ictxt     te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)     te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)@@ -458,7 +469,7 @@               -- where t is a RuntimeUnk (see TcType)  -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].-lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs --   Returns (warnings, errors) -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism]@@ -479,7 +490,8 @@     flags = (defaultLintFlags dflags)                { lf_check_global_ids = check_globals                , lf_check_inline_loop_breakers = check_lbs-               , lf_check_static_ptrs = check_static_ptrs }+               , lf_check_static_ptrs = check_static_ptrs+               , lf_check_linearity = check_linearity }      -- See Note [Checking for global Ids]     check_globals = case pass of@@ -501,6 +513,12 @@                           CorePrep              -> AllowAtTopLevel                           _                     -> AllowAnywhere +    -- See Note [Linting linearity]+    check_linearity = gopt Opt_DoLinearCoreLinting dflags || (+                        case pass of+                          CoreDesugar -> True+                          _ -> False)+     (_, dups) = removeDups compare binders      -- dups_ext checks for names with different uniques@@ -534,16 +552,16 @@  -} -lintUnfolding :: Bool           -- True <=> is a compulsory unfolding+lintUnfolding :: Bool               -- True <=> is a compulsory unfolding               -> DynFlags               -> SrcLoc-              -> VarSet         -- Treat these as in scope+              -> VarSet             -- Treat these as in scope               -> CoreExpr-              -> Maybe MsgDoc   -- Nothing => OK+              -> Maybe (Bag SDoc) -- Nothing => OK  lintUnfolding is_compulsory dflags locn var_set expr   | isEmptyBag errs = Nothing-  | otherwise       = Just (pprMessageBag errs)+  | otherwise       = Just errs   where     vars = nonDetEltsUniqSet var_set     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $@@ -557,11 +575,11 @@ lintExpr :: DynFlags          -> [Var]               -- Treat these as in scope          -> CoreExpr-         -> Maybe MsgDoc        -- Nothing => OK+         -> Maybe (Bag SDoc)  -- Nothing => OK  lintExpr dflags vars expr   | isEmptyBag errs = Nothing-  | otherwise       = Just (pprMessageBag errs)+  | otherwise       = Just errs   where     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter     linter = addLoc TopLevelBindings $@@ -619,17 +637,10 @@        ; checkL ( isJoinId binder                || not (isUnliftedType binder_ty)                || (isNonRec rec_flag && exprOkForSpeculation rhs)+               || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed                || exprIsTickedString rhs)            (badBndrTyMsg binder (text "unlifted")) -        -- Check that if the binder is top-level or recursive, it's not-        -- demanded. Primitive string literals are exempt as there is no-        -- computation to perform, see Note [Core top-level string literals].-       ; checkL (not (isStrictId binder)-            || (isNonRec rec_flag && not (isTopLevel top_lvl))-            || exprIsTickedString rhs)-           (mkStrictMsg binder)-         -- Check that if the binder is at the top level and has type Addr#,         -- that it is a string literal, see         -- Note [Core top-level string literals].@@ -848,10 +859,10 @@  lintCoreExpr (Tick tickish expr)   = do case tickish of-         Breakpoint _ ids -> forM_ ids $ \id -> do-                               checkDeadIdOcc id-                               lookupIdInScope id-         _                -> return ()+         Breakpoint _ _ ids -> forM_ ids $ \id -> do+                                 checkDeadIdOcc id+                                 lookupIdInScope id+         _                  -> return ()        markAllJoinsBadIf block_joins $ lintCoreExpr expr   where     block_joins = not (tickish `tickishScopesLike` SoftScope)@@ -917,7 +928,7 @@        ; (fun_ty2, ue2) <- lintCoreArg fun_pair1      arg_ty2          -- See Note [Linting of runRW#]        ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)-             lintRunRWCont expr@(Lam _ _) = do+             lintRunRWCont expr@(Lam _ _) =                 lintJoinLams 1 (Just fun) expr              lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other              -- TODO: Look through ticks?@@ -1239,7 +1250,7 @@ ----------------- lintTyApp :: LintedType -> LintedType -> LintM LintedType lintTyApp fun_ty arg_ty-  | Just (tv,body_ty) <- splitForAllTy_maybe fun_ty+  | Just (tv,body_ty) <- splitForAllTyCoVar_maybe fun_ty   = do  { lintTyKind tv arg_ty         ; in_scope <- getInScope         -- substTy needs the set of tyvars in scope to avoid generating@@ -1310,8 +1321,8 @@      -- if there are any literal alternatives      -- See GHC.Core Note [Case expression invariants] item (5)      -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold-     ; let isLitPat (LitAlt _, _ , _) = True-           isLitPat _                 = False+     ; let isLitPat (Alt (LitAlt _) _  _) = True+           isLitPat _                     = False      ; checkL (not $ isFloatingTy scrut_ty && any isLitPat alts)          (ptext (sLit $ "Lint warning: Scrutinising floating-point " ++                         "expression with literal pattern in case " ++@@ -1376,8 +1387,8 @@     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest     increasing_tag _                         = True -    non_deflt (DEFAULT, _, _) = False-    non_deflt _               = True+    non_deflt (Alt DEFAULT _ _) = False+    non_deflt _                 = True      is_infinite_ty = case tyConAppTyCon_maybe ty of                         Nothing    -> False@@ -1398,11 +1409,11 @@             -> LintM UsageEnv -- If you edit this function, you may need to update the GHC formalism -- See Note [GHC Formalism]-lintCoreAlt _ _ _ alt_ty (DEFAULT, args, rhs) =+lintCoreAlt _ _ _ alt_ty (Alt DEFAULT args rhs) =   do { lintL (null args) (mkDefaultArgsMsg args)      ; lintAltExpr rhs alt_ty } -lintCoreAlt _case_bndr scrut_ty _ alt_ty (LitAlt lit, args, rhs)+lintCoreAlt _case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs)   | litIsLifted lit   = failWithL integerScrutinisedMsg   | otherwise@@ -1412,7 +1423,7 @@   where     lit_ty = literalType lit -lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(DataAlt con, args, rhs)+lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs)   | isNewTyCon (dataConTyCon con)   = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt)   | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty@@ -1422,10 +1433,10 @@         -- We've already check       lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)     ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys-          ; ex_tvs_n = length (dataConExTyCoVars con)-          -- See Note [Alt arg multiplicities]-          ; multiplicities = replicate ex_tvs_n Many ++-                             map scaledMult (dataConRepArgTys con) }+          ; binderMult (Named _)   = Many+          ; binderMult (Anon _ st) = scaledMult st+          -- See Note [Validating multiplicities in a case]+          ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }          -- And now bring the new binders into scope     ; lintBinders CasePatBind args $ \ args' -> do@@ -1439,6 +1450,22 @@   | otherwise   -- Scrut-ty is wrong shape   = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt) +{-+Note [Validating multiplicities in a case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'MkT :: a %m -> T m a'.+If we are validating 'case (x :: T Many a) of MkT y -> ...',+we have to substitute m := Many in the type of MkT - in particular,+y can be used Many times and that expression would still be linear in x.+We do this by looking at con_payload_ty, which is the type of the datacon+applied to the surrounding arguments.+Testcase: linear/should_compile/MultConstructor++Data constructors containing existential tyvars will then have+Named binders, which are always multiplicity Many.+Testcase: indexed-types/should_compile/GADT1+-}+ lintLinearBinder :: SDoc -> Mult -> Mult -> LintM () lintLinearBinder doc actual_usage described_usage   = ensureSubMult actual_usage described_usage err_msg@@ -1449,16 +1476,6 @@                 $$ text "Annotation:" <+> ppr described_usage)  {--Note [Alt arg multiplicities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is necessary to use `dataConRepArgTys` so you get the arg tys from-the wrapper if there is one.--You also need to add the existential ty vars as they are passed are arguments-but not returned by `dataConRepArgTys`. Without this the test `GADT1` fails.--}--{- ************************************************************************ *                                                                      * \subsection[lint-types]{Types}@@ -1773,6 +1790,7 @@   | otherwise = failWithL msg     where msg = text "Negative type literal:" <+> integer n lintTyLit (StrTyLit _) = return ()+lintTyLit (CharTyLit _) = return ()  lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM () -- (lint_app d fun_kind arg_tys)@@ -1862,14 +1880,14 @@ ~~~~~~~~~~~~~~~~~~~~~~~ It's very bad if simplifying a rule means that one of the template variables (ru_bndrs) that /is/ mentioned on the RHS becomes-not-mentioned in the LHS (ru_args).  How can that happen?  Well, in-#10602, SpecConstr stupidly constructed a rule like+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in #10602,+SpecConstr stupidly constructed a rule like    forall x,c1,c2.      f (x |> c1 |> c2) = .... -But simplExpr collapses those coercions into one.  (Indeed in-#10602, it collapsed to the identity and was removed altogether.)+But simplExpr collapses those coercions into one.  (Indeed in #10602,+it collapsed to the identity and was removed altogether.)  We don't have a great story for what to do here, but at least this check will nail it.@@ -2180,7 +2198,7 @@ lintCoercion the_co@(NthCo r0 n co)   = do { co' <- lintCoercion co        ; let (Pair s t, r) = coercionKindRole co'-       ; case (splitForAllTy_maybe s, splitForAllTy_maybe t) of+       ; case (splitForAllTyCoVar_maybe s, splitForAllTyCoVar_maybe t) of          { (Just _, Just _)              -- works for both tyvar and covar              | n == 0@@ -2222,7 +2240,7 @@         ; lintRole arg Nominal (coercionRole arg') -      ; case (splitForAllTy_ty_maybe t1, splitForAllTy_ty_maybe t2) of+      ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of          -- forall over tvar          { (Just (tv1,_), Just (tv2,_))              | typeKind s1 `eqType` tyVarKind tv1@@ -2231,7 +2249,7 @@              | otherwise              -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co) -         ; _ -> case (splitForAllTy_co_maybe t1, splitForAllTy_co_maybe t2) of+         ; _ -> case (splitForAllCoVar_maybe t1, splitForAllCoVar_maybe t2) of          -- forall over covar          { (Just (cv1, _), Just (cv2, _))              | typeKind s1 `eqType` varType cv1@@ -2297,6 +2315,7 @@            Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]            Just _  -> return (AxiomRuleCo ax cos') }   where+  err :: forall a. String -> [SDoc] -> LintM a   err m xs  = failWithL $               hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName ax) : xs) @@ -2327,14 +2346,17 @@ ************************************************************************ -} -lintAxioms :: DynFlags+lintAxioms :: Logger+           -> DynFlags+           -> SDoc -- ^ The source of the linted axioms            -> [CoAxiom Branched]-           -> WarnsAndErrs-lintAxioms dflags axioms-  = initL dflags (defaultLintFlags dflags) [] $-    do { mapM_ lint_axiom axioms-       ; let axiom_groups = groupWith coAxiomTyCon axioms-       ; mapM_ lint_axiom_group axiom_groups }+           -> IO ()+lintAxioms logger dflags what axioms =+  displayLintResults logger dflags True what (vcat $ map pprCoAxiom axioms) $+  initL dflags (defaultLintFlags dflags) [] $+  do { mapM_ lint_axiom axioms+     ; let axiom_groups = groupWith coAxiomTyCon axioms+     ; mapM_ lint_axiom_group axiom_groups }  lint_axiom :: CoAxiom Branched -> LintM () lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches@@ -2484,7 +2506,7 @@         lhs2'          = substTys subst lhs2         rhs2'          = substTy  subst rhs2     in-    case tcUnifyTys (const BindMe) lhs1 lhs2' of+    case tcUnifyTys alwaysBindFun lhs1 lhs2' of       Just unifying_subst -> substTy unifying_subst rhs1  `eqType`                              substTy unifying_subst rhs2'       Nothing             -> True@@ -2563,7 +2585,7 @@             (Maybe a, WarnsAndErrs) } -- Result and messages (if any)    deriving (Functor) -type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)+type WarnsAndErrs = (Bag SDoc, Bag SDoc)  {- Note [Checking for global Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2644,11 +2666,12 @@     in f True   uses 'x' linearly, but this is not seen by the linter.   Plan: make let-bound variables remember the usage environment.-  See test LinearLetRec and https://github.com/tweag/ghc/issues/405.+  See ticket #18694.  We plan to fix both of the issues in the very near future.-For now, linear Lint is disabled by default and-has to be enabled manually with -dlinear-core-lint.+For now, -dcore-lint enables only linting output of the desugarer,+and full Linear Lint has to be enabled separately with -dlinear-core-lint.+Ticket #19165 concerns enabling Linear Lint with -dcore-lint. -}  instance Applicative LintM where@@ -2722,31 +2745,31 @@ getLintFlags :: LintM LintFlags getLintFlags = LintM $ \ env errs -> (Just (le_flags env), errs) -checkL :: Bool -> MsgDoc -> LintM ()+checkL :: Bool -> SDoc -> LintM () checkL True  _   = return () checkL False msg = failWithL msg  -- like checkL, but relevant to type checking-lintL :: Bool -> MsgDoc -> LintM ()+lintL :: Bool -> SDoc -> LintM () lintL = checkL -checkWarnL :: Bool -> MsgDoc -> LintM ()+checkWarnL :: Bool -> SDoc -> LintM () checkWarnL True   _  = return () checkWarnL False msg = addWarnL msg -failWithL :: MsgDoc -> LintM a+failWithL :: SDoc -> LintM a failWithL msg = LintM $ \ env (warns,errs) ->                 (Nothing, (warns, addMsg True env errs msg)) -addErrL :: MsgDoc -> LintM ()+addErrL :: SDoc -> LintM () addErrL msg = LintM $ \ env (warns,errs) ->               (Just (), (warns, addMsg True env errs msg)) -addWarnL :: MsgDoc -> LintM ()+addWarnL :: SDoc -> LintM () addWarnL msg = LintM $ \ env (warns,errs) ->               (Just (), (addMsg False env warns msg, errs)) -addMsg :: Bool -> LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc+addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc addMsg is_error env msgs msg   = ASSERT2( notNull loc_msgs, msg )     msgs `snocBag` mk_msg msg@@ -2874,7 +2897,7 @@          Nothing -> unitUE id One          Just id_ue -> id_ue -ensureEqTys :: LintedType -> LintedType -> MsgDoc -> LintM ()+ensureEqTys :: LintedType -> LintedType -> SDoc -> LintM () -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have already had the substitution applied@@ -2948,10 +2971,10 @@ dumpLoc (AnExpr e)   = (noSrcLoc, text "In the expression:" <+> ppr e) -dumpLoc (CaseAlt (con, args, _))+dumpLoc (CaseAlt (Alt con args _))   = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args)) -dumpLoc (CasePat (con, args, _))+dumpLoc (CasePat (Alt con args _))   = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))  dumpLoc (CaseTy scrut)@@ -3008,36 +3031,36 @@ ------------------------------------------------------ --      Messages for case expressions -mkDefaultArgsMsg :: [Var] -> MsgDoc+mkDefaultArgsMsg :: [Var] -> SDoc mkDefaultArgsMsg args   = hang (text "DEFAULT case with binders")          4 (ppr args) -mkCaseAltMsg :: CoreExpr -> Type -> Type -> MsgDoc+mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc mkCaseAltMsg e ty1 ty2   = hang (text "Type of case alternatives not the same as the annotation on case:")          4 (vcat [ text "Actual type:" <+> ppr ty1,                    text "Annotation on case:" <+> ppr ty2,                    text "Alt Rhs:" <+> ppr e ]) -mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> MsgDoc+mkScrutMsg :: Id -> Type -> Type -> TCvSubst -> SDoc mkScrutMsg var var_ty scrut_ty subst   = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,           text "Result binder type:" <+> ppr var_ty,--(idType var),           text "Scrutinee type:" <+> ppr scrut_ty,      hsep [text "Current TCv subst", ppr subst]] -mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> MsgDoc+mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc mkNonDefltMsg e   = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e) mkNonIncreasingAltsMsg e   = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e) -nonExhaustiveAltsMsg :: CoreExpr -> MsgDoc+nonExhaustiveAltsMsg :: CoreExpr -> SDoc nonExhaustiveAltsMsg e   = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e) -mkBadConMsg :: TyCon -> DataCon -> MsgDoc+mkBadConMsg :: TyCon -> DataCon -> SDoc mkBadConMsg tycon datacon   = vcat [         text "In a case alternative, data constructor isn't in scrutinee type:",@@ -3045,7 +3068,7 @@         text "Data con:" <+> ppr datacon     ] -mkBadPatMsg :: Type -> Type -> MsgDoc+mkBadPatMsg :: Type -> Type -> SDoc mkBadPatMsg con_result_ty scrut_ty   = vcat [         text "In a case alternative, pattern result type doesn't match scrutinee type:",@@ -3053,17 +3076,17 @@         text "Scrutinee type:" <+> ppr scrut_ty     ] -integerScrutinisedMsg :: MsgDoc+integerScrutinisedMsg :: SDoc integerScrutinisedMsg   = text "In a LitAlt, the literal is lifted (probably Integer)" -mkBadAltMsg :: Type -> CoreAlt -> MsgDoc+mkBadAltMsg :: Type -> CoreAlt -> SDoc mkBadAltMsg scrut_ty alt   = vcat [ text "Data alternative when scrutinee is not a tycon application",            text "Scrutinee type:" <+> ppr scrut_ty,            text "Alternative:" <+> pprCoreAlt alt ] -mkNewTyDataConAltMsg :: Type -> CoreAlt -> MsgDoc+mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc mkNewTyDataConAltMsg scrut_ty alt   = vcat [ text "Data alternative for newtype datacon",            text "Scrutinee type:" <+> ppr scrut_ty,@@ -3073,21 +3096,21 @@ ------------------------------------------------------ --      Other error messages -mkAppMsg :: Type -> Type -> CoreExpr -> MsgDoc+mkAppMsg :: Type -> Type -> CoreExpr -> SDoc mkAppMsg fun_ty arg_ty arg   = vcat [text "Argument value doesn't match argument type:",               hang (text "Fun type:") 4 (ppr fun_ty),               hang (text "Arg type:") 4 (ppr arg_ty),               hang (text "Arg:") 4 (ppr arg)] -mkNonFunAppMsg :: Type -> Type -> CoreExpr -> MsgDoc+mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc mkNonFunAppMsg fun_ty arg_ty arg   = vcat [text "Non-function type in function position",               hang (text "Fun type:") 4 (ppr fun_ty),               hang (text "Arg type:") 4 (ppr arg_ty),               hang (text "Arg:") 4 (ppr arg)] -mkLetErr :: TyVar -> CoreExpr -> MsgDoc+mkLetErr :: TyVar -> CoreExpr -> SDoc mkLetErr bndr rhs   = vcat [text "Bad `let' binding:",           hang (text "Variable:")@@ -3095,7 +3118,7 @@           hang (text "Rhs:")                  4 (ppr rhs)] -mkTyAppMsg :: Type -> Type -> MsgDoc+mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty   = vcat [text "Illegal type application:",               hang (text "Exp type:")@@ -3103,10 +3126,10 @@               hang (text "Arg type:")                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -emptyRec :: CoreExpr -> MsgDoc+emptyRec :: CoreExpr -> SDoc emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e) -mkRhsMsg :: Id -> SDoc -> Type -> MsgDoc+mkRhsMsg :: Id -> SDoc -> Type -> SDoc mkRhsMsg binder what ty   = vcat     [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,@@ -3114,36 +3137,29 @@      hsep [text "Binder's type:", ppr (idType binder)],      hsep [text "Rhs type:", ppr ty]] -mkLetAppMsg :: CoreExpr -> MsgDoc+mkLetAppMsg :: CoreExpr -> SDoc mkLetAppMsg e   = hang (text "This argument does not satisfy the let/app invariant:")        2 (ppr e) -badBndrTyMsg :: Id -> SDoc -> MsgDoc+badBndrTyMsg :: Id -> SDoc -> SDoc badBndrTyMsg binder what   = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder          , text "Binder's type:" <+> ppr (idType binder) ] -mkStrictMsg :: Id -> MsgDoc-mkStrictMsg binder-  = vcat [hsep [text "Recursive or top-level binder has strict demand info:",-                     ppr binder],-              hsep [text "Binder's demand info:", ppr (idDemandInfo binder)]-             ]--mkNonTopExportedMsg :: Id -> MsgDoc+mkNonTopExportedMsg :: Id -> SDoc mkNonTopExportedMsg binder   = hsep [text "Non-top-level binder is marked as exported:", ppr binder] -mkNonTopExternalNameMsg :: Id -> MsgDoc+mkNonTopExternalNameMsg :: Id -> SDoc mkNonTopExternalNameMsg binder   = hsep [text "Non-top-level binder has an external name:", ppr binder] -mkTopNonLitStrMsg :: Id -> MsgDoc+mkTopNonLitStrMsg :: Id -> SDoc mkTopNonLitStrMsg binder   = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder] -mkKindErrMsg :: TyVar -> Type -> MsgDoc+mkKindErrMsg :: TyVar -> Type -> SDoc mkKindErrMsg tyvar arg_ty   = vcat [text "Kinds don't match in type application:",           hang (text "Type variable:")@@ -3151,10 +3167,10 @@           hang (text "Arg type:")                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] -mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> MsgDoc+mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc mkCastErr expr = mk_cast_err "expression" "type" (ppr expr) -mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> MsgDoc+mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)  mk_cast_err :: String -- ^ What sort of casted thing this is@@ -3162,7 +3178,7 @@             -> String -- ^ What sort of coercion is being used                       --   (\"type\" or \"kind\").             -> SDoc   -- ^ The thing being casted.-            -> Coercion -> Type -> Type -> MsgDoc+            -> Coercion -> Type -> Type -> SDoc mk_cast_err thing_str co_str pp_thing co from_ty thing_ty   = vcat [from_msg <+> text "of Cast differs from" <+> co_msg             <+> text "of" <+> enclosed_msg,@@ -3253,16 +3269,16 @@          , text "Join arity:" <+> ppr join_arity          , text "Rule:" <+> ppr rule ] -pprLeftOrRight :: LeftOrRight -> MsgDoc+pprLeftOrRight :: LeftOrRight -> SDoc pprLeftOrRight CLeft  = text "left" pprLeftOrRight CRight = text "right" -dupVars :: [NonEmpty Var] -> MsgDoc+dupVars :: [NonEmpty Var] -> SDoc dupVars vars   = hang (text "Duplicate variables brought into scope")        2 (ppr (map toList vars)) -dupExtVars :: [NonEmpty Name] -> MsgDoc+dupExtVars :: [NonEmpty Name] -> SDoc dupExtVars vars   = hang (text "Duplicate top-level variables with the same qualified name")        2 (ppr (map toList vars))@@ -3283,16 +3299,17 @@ lintAnnots pname pass guts = do   -- Run the pass as we normally would   dflags <- getDynFlags+  logger <- getLogger   when (gopt Opt_DoAnnotationLinting dflags) $-    liftIO $ Err.showPass dflags "Annotation linting - first run"+    liftIO $ Err.showPass logger dflags "Annotation linting - first run"   nguts <- pass guts   -- If appropriate re-run it without debug annotations to make sure   -- that they made no difference.   when (gopt Opt_DoAnnotationLinting dflags) $ do-    liftIO $ Err.showPass dflags "Annotation linting - second run"+    liftIO $ Err.showPass logger dflags "Annotation linting - second run"     nguts' <- withoutAnnots pass guts     -- Finally compare the resulting bindings-    liftIO $ Err.showPass dflags "Annotation linting - comparison"+    liftIO $ Err.showPass logger dflags "Annotation linting - comparison"     let binds = flattenBinds $ mg_binds nguts         binds' = flattenBinds $ mg_binds nguts'         (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'

GHC/Core/Make.hs view

@@ -41,6 +41,9 @@         mkNilExpr, mkConsExpr, mkListExpr,         mkFoldrExpr, mkBuildExpr, +        -- * Constructing non empty lists+        mkNonEmptyListExpr,+         -- * Constructing Maybe expressions         mkNothingExpr, mkJustExpr, @@ -55,36 +58,39 @@ #include "HsVersions.h"  import GHC.Prelude+import GHC.Platform  import GHC.Types.Id import GHC.Types.Var  ( EvVar, setTyVarUnique )+import GHC.Types.TyThing+import GHC.Types.Id.Info+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Name      hiding ( varName )+import GHC.Types.Literal+import GHC.Types.Unique.Supply+import GHC.Types.Basic  import GHC.Core import GHC.Core.Utils ( exprType, needsCaseBinding, mkSingleAltCase, bindNonRec )-import GHC.Types.Literal-import GHC.Driver.Types-import GHC.Platform--import GHC.Builtin.Types-import GHC.Builtin.Names--import GHC.Hs.Utils      ( mkChunkified, chunkify ) import GHC.Core.Type import GHC.Core.Coercion ( isCoVar ) import GHC.Core.DataCon  ( DataCon, dataConWorkId ) import GHC.Core.Multiplicity++import GHC.Hs.Utils      ( mkChunkified, chunkify )++import GHC.Builtin.Types+import GHC.Builtin.Names import GHC.Builtin.Types.Prim-import GHC.Types.Id.Info-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Types.Name      hiding ( varName )+ import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Types.Unique.Supply-import GHC.Types.Basic import GHC.Utils.Misc-import Data.List+import GHC.Utils.Panic +import GHC.Data.FastString++import Data.List        ( partition ) import Data.Char        ( ord )  infixl 4 `mkCoreApp`, `mkCoreApps`@@ -208,7 +214,7 @@ mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr -- Build a strict application (case e2 of x -> e1 x) mkStrictApp fun arg (Scaled w arg_ty) res_ty-  = Case arg arg_id res_ty [(DEFAULT,[],App fun (Var arg_id))]+  = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))]        -- mkDefaultCase looks attractive here, and would be sound.        -- But it uses (exprType alt_rhs) to compute the result type,        -- whereas here we already know that the result type is res_ty@@ -228,8 +234,8 @@ mkIfThenElse guard then_expr else_expr -- Not going to be refining, so okay to take the type of the "then" clause   = mkWildCase guard (linear boolTy) (exprType then_expr)-         [ (DataAlt falseDataCon, [], else_expr),       -- Increasing order of tag!-           (DataAlt trueDataCon,  [], then_expr) ]+         [ Alt (DataAlt falseDataCon) [] else_expr,       -- Increasing order of tag!+           Alt (DataAlt trueDataCon)  [] then_expr ]  castBottomExpr :: CoreExpr -> Type -> CoreExpr -- (castBottomExpr e ty), assuming that 'e' diverges,@@ -523,7 +529,7 @@ mkSmallTupleSelector1 vars the_var scrut_var scrut   = ASSERT( notNull vars )     Case scrut scrut_var (idType the_var)-         [(DataAlt (tupleDataCon Boxed (length vars)), vars, Var the_var)]+         [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)]  -- | A generalization of 'mkTupleSelector', allowing the body -- of the case to be an arbitrary expression.@@ -577,7 +583,7 @@ mkSmallTupleCase vars body scrut_var scrut -- One branch no refinement?   = Case scrut scrut_var (exprType body)-         [(DataAlt (tupleDataCon Boxed (length vars)), vars, body)]+         [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body]  {- ************************************************************************@@ -638,6 +644,9 @@ mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs +mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr+mkNonEmptyListExpr ty x xs = mkCoreConApps nonEmptyDataCon [Type ty, x, mkListExpr ty xs]+ -- | Make a fully applied 'foldr' expression mkFoldrExpr :: MonadThings m             => Type             -- ^ Element type of the list@@ -766,7 +775,6 @@ raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name  recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID-absentErrorName     = err_nm "absentError"     absentErrorIdKey     aBSENT_ERROR_ID runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_ERROR_ID recConErrorName     = err_nm "recConError"     recConErrorIdKey     rEC_CON_ERROR_ID patErrorName        = err_nm "patError"        patErrorIdKey        pAT_ERROR_ID@@ -857,6 +865,13 @@       absentSumFieldErrorIdKey       aBSENT_SUM_FIELD_ERROR_ID +absentErrorName+   = mkWiredInIdName+      gHC_PRIM_PANIC+      (fsLit "absentError")+      absentErrorIdKey+      aBSENT_ERROR_ID+ raiseOverflowName    = mkWiredInIdName       gHC_PRIM_EXCEPTION@@ -947,7 +962,7 @@     f x = (case x of (a,b) -> b) + 1::Int -The demand analyser figures ot that only the second component of x is+The demand analyser figures out that only the second component of x is used, and does a w/w split thus     f x = case x of (a,b) -> $wf b

− GHC/Core/Map.hs

@@ -1,835 +0,0 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module GHC.Core.Map (-   -- * Maps over Core expressions-   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,-   -- * Maps over 'Type's-   TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,-   LooseTypeMap,-   -- ** With explicit scoping-   CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,-   mkDeBruijnContext,-   -- * Maps over 'Maybe' values-   MaybeMap,-   -- * Maps over 'List' values-   ListMap,-   -- * Maps over 'Literal's-   LiteralMap,-   -- * Map for compressing leaves. See Note [Compressed TrieMap]-   GenMap,-   -- * 'TrieMap' class-   TrieMap(..), XT, insertTM, deleteTM,-   lkDFreeVar, xtDFreeVar,-   lkDNamed, xtDNamed,-   (>.>), (|>), (|>>),- ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Data.TrieMap-import GHC.Core-import GHC.Core.Coercion-import GHC.Types.Name-import GHC.Core.Type-import GHC.Core.TyCo.Rep-import GHC.Types.Var-import GHC.Data.FastString(FastString)-import GHC.Utils.Misc--import qualified Data.Map    as Map-import qualified Data.IntMap as IntMap-import GHC.Types.Var.Env-import GHC.Types.Name.Env-import GHC.Utils.Outputable-import Control.Monad( (>=>) )--{--This module implements TrieMaps over Core related data structures-like CoreExpr or Type. It is built on the Tries from the TrieMap-module.--The code is very regular and boilerplate-like, but there is-some neat handling of *binders*.  In effect they are deBruijn-numbered on the fly.----}--------------------------- Recall that---   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c---- NB: Be careful about RULES and type families (#5821).  So we should make sure--- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)---- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not--- known when defining GenMap so we can only specialize them here.--{-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}-{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}-{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}---{-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}-{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}-{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}--{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}-{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}-{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}--{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}-{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}-{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}---{--************************************************************************-*                                                                      *-                   CoreMap-*                                                                      *-************************************************************************--}--lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a-lkDNamed n env = lookupDNameEnv env (getName n)--xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a-xtDNamed tc f m = alterDNameEnv f m (getName tc)---{--Note [Binders]-~~~~~~~~~~~~~~- * In general we check binders as late as possible because types are-   less likely to differ than expression structure.  That's why-      cm_lam :: CoreMapG (TypeMapG a)-   rather than-      cm_lam :: TypeMapG (CoreMapG a)-- * We don't need to look at the type of some binders, notably-     - the case binder in (Case _ b _ _)-     - the binders in an alternative-   because they are totally fixed by the context--Note [Empty case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* For a key (Case e b ty (alt:alts))  we don't need to look the return type-  'ty', because every alternative has that type.--* For a key (Case e b ty []) we MUST look at the return type 'ty', because-  otherwise (Case (error () "urk") _ Int  []) would compare equal to-            (Case (error () "urk") _ Bool [])-  which is utterly wrong (#6097)--We could compare the return type regardless, but the wildly common case-is that it's unnecessary, so we have two fields (cm_case and cm_ecase)-for the two possibilities.  Only cm_ecase looks at the type.--See also Note [Empty case alternatives] in GHC.Core.--}---- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this--- is the type you want.-newtype CoreMap a = CoreMap (CoreMapG a)--instance TrieMap CoreMap where-    type Key CoreMap = CoreExpr-    emptyTM = CoreMap emptyTM-    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m-    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)-    foldTM k (CoreMap m) = foldTM k m-    mapTM f (CoreMap m) = CoreMap (mapTM f m)---- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended--- key makes it suitable for recursive traversal, since it can track binders,--- but it is strictly internal to this module.  If you are including a 'CoreMap'--- inside another 'TrieMap', this is the type you want.-type CoreMapG = GenMap CoreMapX---- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without--- the 'GenMap' optimization.-data CoreMapX a-  = CM { cm_var   :: VarMap a-       , cm_lit   :: LiteralMap a-       , cm_co    :: CoercionMapG a-       , cm_type  :: TypeMapG a-       , cm_cast  :: CoreMapG (CoercionMapG a)-       , cm_tick  :: CoreMapG (TickishMap a)-       , cm_app   :: CoreMapG (CoreMapG a)-       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]-       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))-       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))-       , cm_case  :: CoreMapG (ListMap AltMap a)-       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]-     }--instance Eq (DeBruijn CoreExpr) where-  D env1 e1 == D env2 e2 = go e1 e2 where-    go (Var v1) (Var v2)-      = case (lookupCME env1 v1, lookupCME env2 v2) of-                            (Just b1, Just b2) -> b1 == b2-                            (Nothing, Nothing) -> v1 == v2-                            _ -> False-    go (Lit lit1)    (Lit lit2)      = lit1 == lit2-    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2-    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2-    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2-    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2-    -- This seems a bit dodgy, see 'eqTickish'-    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2--    go (Lam b1 e1)  (Lam b2 e2)-      =  D env1 (varType b1) == D env2 (varType b2)-      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)-      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2--    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)-      =  go r1 r2-      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2--    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)-      = equalLength ps1 ps2-      && D env1' rs1 == D env2' rs2-      && D env1' e1  == D env2' e2-      where-        (bs1,rs1) = unzip ps1-        (bs2,rs2) = unzip ps2-        env1' = extendCMEs env1 bs1-        env2' = extendCMEs env2 bs2--    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)-      | null a1   -- See Note [Empty case alternatives]-      = null a2 && go e1 e2 && D env1 t1 == D env2 t2-      | otherwise-      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2--    go _ _ = False--emptyE :: CoreMapX a-emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM-            , cm_co = emptyTM, cm_type = emptyTM-            , cm_cast = emptyTM, cm_app = emptyTM-            , cm_lam = emptyTM, cm_letn = emptyTM-            , cm_letr = emptyTM, cm_case = emptyTM-            , cm_ecase = emptyTM, cm_tick = emptyTM }--instance TrieMap CoreMapX where-   type Key CoreMapX = DeBruijn CoreExpr-   emptyTM  = emptyE-   lookupTM = lkE-   alterTM  = xtE-   foldTM   = fdE-   mapTM    = mapE-----------------------------mapE :: (a->b) -> CoreMapX a -> CoreMapX b-mapE f (CM { cm_var = cvar, cm_lit = clit-           , cm_co = cco, cm_type = ctype-           , cm_cast = ccast , cm_app = capp-           , cm_lam = clam, cm_letn = cletn-           , cm_letr = cletr, cm_case = ccase-           , cm_ecase = cecase, cm_tick = ctick })-  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit-       , cm_co = mapTM f cco, cm_type = mapTM f ctype-       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp-       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn-       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase-       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }-----------------------------lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a-lookupCoreMap cm e = lookupTM e cm--extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a-extendCoreMap m e v = alterTM e (\_ -> Just v) m--foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b-foldCoreMap k z m = foldTM k m z--emptyCoreMap :: CoreMap a-emptyCoreMap = emptyTM--instance Outputable a => Outputable (CoreMap a) where-  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])----------------------------fdE :: (a -> b -> b) -> CoreMapX a -> b -> b-fdE k m-  = foldTM k (cm_var m)-  . foldTM k (cm_lit m)-  . foldTM k (cm_co m)-  . foldTM k (cm_type m)-  . foldTM (foldTM k) (cm_cast m)-  . foldTM (foldTM k) (cm_tick m)-  . foldTM (foldTM k) (cm_app m)-  . foldTM (foldTM k) (cm_lam m)-  . foldTM (foldTM (foldTM k)) (cm_letn m)-  . foldTM (foldTM (foldTM k)) (cm_letr m)-  . foldTM (foldTM k) (cm_case m)-  . foldTM (foldTM k) (cm_ecase m)---- lkE: lookup in trie for expressions-lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a-lkE (D env expr) cm = go expr cm-  where-    go (Var v)              = cm_var  >.> lkVar env v-    go (Lit l)              = cm_lit  >.> lookupTM l-    go (Type t)             = cm_type >.> lkG (D env t)-    go (Coercion c)         = cm_co   >.> lkG (D env c)-    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)-    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish-    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)-    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)-                              >=> lkBndr env v-    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)-                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b-    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs-                                  env1 = extendCMEs env bndrs-                              in cm_letr-                                 >.> lkList (lkG . D env1) rhss-                                 >=> lkG (D env1 e)-                                 >=> lkList (lkBndr env1) bndrs-    go (Case e b ty as)     -- See Note [Empty case alternatives]-               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)-               | otherwise  = cm_case >.> lkG (D env e)-                              >=> lkList (lkA (extendCME env b)) as--xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a-xtE (D env (Var v))              f m = m { cm_var  = cm_var m-                                                 |> xtVar env v f }-xtE (D env (Type t))             f m = m { cm_type = cm_type m-                                                 |> xtG (D env t) f }-xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m-                                                 |> xtG (D env c) f }-xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }-xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)-                                                 |>> xtG (D env c) f }-xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)-                                                 |>> xtTickish t f }-xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)-                                                 |>> xtG (D env e1) f }-xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m-                                                 |> xtG (D (extendCME env v) e)-                                                 |>> xtBndr env v f }-xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m-                                                 |> xtG (D (extendCME env b) e)-                                                 |>> xtG (D env r)-                                                 |>> xtBndr env b f }-xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =-                                              let (bndrs,rhss) = unzip prs-                                                  env1 = extendCMEs env bndrs-                                              in cm_letr m-                                                 |>  xtList (xtG . D env1) rhss-                                                 |>> xtG (D env1 e)-                                                 |>> xtList (xtBndr env1)-                                                            bndrs f }-xtE (D env (Case e b ty as))     f m-                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)-                                                 |>> xtG (D env ty) f }-                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)-                                                 |>> let env1 = extendCME env b-                                                     in xtList (xtA env1) as f }---- TODO: this seems a bit dodgy, see 'eqTickish'-type TickishMap a = Map.Map (Tickish Id) a-lkTickish :: Tickish Id -> TickishMap a -> Maybe a-lkTickish = lookupTM--xtTickish :: Tickish Id -> XT a -> TickishMap a -> TickishMap a-xtTickish = alterTM---------------------------data AltMap a   -- A single alternative-  = AM { am_deflt :: CoreMapG a-       , am_data  :: DNameEnv (CoreMapG a)-       , am_lit   :: LiteralMap (CoreMapG a) }--instance TrieMap AltMap where-   type Key AltMap = CoreAlt-   emptyTM  = AM { am_deflt = emptyTM-                 , am_data = emptyDNameEnv-                 , am_lit  = emptyTM }-   lookupTM = lkA emptyCME-   alterTM  = xtA emptyCME-   foldTM   = fdA-   mapTM    = mapA--instance Eq (DeBruijn CoreAlt) where-  D env1 a1 == D env2 a2 = go a1 a2 where-    go (DEFAULT, _, rhs1) (DEFAULT, _, rhs2)-        = D env1 rhs1 == D env2 rhs2-    go (LitAlt lit1, _, rhs1) (LitAlt lit2, _, rhs2)-        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2-    go (DataAlt dc1, bs1, rhs1) (DataAlt dc2, bs2, rhs2)-        = dc1 == dc2 &&-          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2-    go _ _ = False--mapA :: (a->b) -> AltMap a -> AltMap b-mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })-  = AM { am_deflt = mapTM f adeflt-       , am_data = mapTM (mapTM f) adata-       , am_lit = mapTM (mapTM f) alit }--lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a-lkA env (DEFAULT,    _, rhs)  = am_deflt >.> lkG (D env rhs)-lkA env (LitAlt lit, _, rhs)  = am_lit >.> lookupTM lit >=> lkG (D env rhs)-lkA env (DataAlt dc, bs, rhs) = am_data >.> lkDNamed dc-                                        >=> lkG (D (extendCMEs env bs) rhs)--xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a-xtA env (DEFAULT, _, rhs)    f m =-    m { am_deflt = am_deflt m |> xtG (D env rhs) f }-xtA env (LitAlt l, _, rhs)   f m =-    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }-xtA env (DataAlt d, bs, rhs) f m =-    m { am_data  = am_data m  |> xtDNamed d-                             |>> xtG (D (extendCMEs env bs) rhs) f }--fdA :: (a -> b -> b) -> AltMap a -> b -> b-fdA k m = foldTM k (am_deflt m)-        . foldTM (foldTM k) (am_data m)-        . foldTM (foldTM k) (am_lit m)--{--************************************************************************-*                                                                      *-                   Coercions-*                                                                      *-************************************************************************--}---- We should really never care about the contents of a coercion. Instead,--- just look up the coercion's type.-newtype CoercionMap a = CoercionMap (CoercionMapG a)--instance TrieMap CoercionMap where-   type Key CoercionMap = Coercion-   emptyTM                     = CoercionMap emptyTM-   lookupTM k  (CoercionMap m) = lookupTM (deBruijnize k) m-   alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)-   foldTM k    (CoercionMap m) = foldTM k m-   mapTM f     (CoercionMap m) = CoercionMap (mapTM f m)--type CoercionMapG = GenMap CoercionMapX-newtype CoercionMapX a = CoercionMapX (TypeMapX a)--instance TrieMap CoercionMapX where-  type Key CoercionMapX = DeBruijn Coercion-  emptyTM = CoercionMapX emptyTM-  lookupTM = lkC-  alterTM  = xtC-  foldTM f (CoercionMapX core_tm) = foldTM f core_tm-  mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM f core_tm)--instance Eq (DeBruijn Coercion) where-  D env1 co1 == D env2 co2-    = D env1 (coercionType co1) ==-      D env2 (coercionType co2)--lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a-lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co)-                                        core_tm--xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a-xtC (D env co) f (CoercionMapX m)-  = CoercionMapX (xtT (D env $ coercionType co) f m)--{--************************************************************************-*                                                                      *-                   Types-*                                                                      *-************************************************************************--}---- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@.  The extended--- key makes it suitable for recursive traversal, since it can track binders,--- but it is strictly internal to this module.  If you are including a 'TypeMap'--- inside another 'TrieMap', this is the type you want. Note that this--- lookup does not do a kind-check. Thus, all keys in this map must have--- the same kind. Also note that this map respects the distinction between--- @Type@ and @Constraint@, despite the fact that they are equivalent type--- synonyms in Core.-type TypeMapG = GenMap TypeMapX---- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the--- 'GenMap' optimization.-data TypeMapX a-  = TM { tm_var    :: VarMap a-       , tm_app    :: TypeMapG (TypeMapG a)-       , tm_tycon  :: DNameEnv a-       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders]-       , tm_tylit  :: TyLitMap a-       , tm_coerce :: Maybe a-       }-    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type---- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the--- last one? See Note [Equality on AppTys] in "GHC.Core.Type"------ Note, however, that we keep Constraint and Type apart here, despite the fact--- that they are both synonyms of TYPE 'LiftedRep (see #11715).-trieMapView :: Type -> Maybe Type-trieMapView ty-  -- First check for TyConApps that need to be expanded to-  -- AppTy chains.-  | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty-  = Just $ foldl' AppTy (TyConApp tc []) tys--  -- Then resolve any remaining nullary synonyms.-  | Just ty' <- tcView ty = Just ty'-trieMapView _ = Nothing--instance TrieMap TypeMapX where-   type Key TypeMapX = DeBruijn Type-   emptyTM  = emptyT-   lookupTM = lkT-   alterTM  = xtT-   foldTM   = fdT-   mapTM    = mapT--instance Eq (DeBruijn Type) where-  env_t@(D env t) == env_t'@(D env' t')-    | Just new_t  <- tcView t  = D env new_t == env_t'-    | Just new_t' <- tcView t' = env_t       == D env' new_t'-    | otherwise-    = case (t, t') of-        (CastTy t1 _, _)  -> D env t1 == D env t'-        (_, CastTy t1' _) -> D env t  == D env t1'--        (TyVarTy v, TyVarTy v')-            -> case (lookupCME env v, lookupCME env' v') of-                (Just bv, Just bv') -> bv == bv'-                (Nothing, Nothing)  -> v == v'-                _ -> False-                -- See Note [Equality on AppTys] in GHC.Core.Type-        (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s-            -> D env t1 == D env' t1' && D env t2 == D env' t2'-        (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s-            -> D env t1 == D env' t1' && D env t2 == D env' t2'-        (FunTy _ w1 t1 t2, FunTy _ w1' t1' t2')-            -> D env w1 == D env w1' && D env t1 == D env' t1' && D env t2 == D env' t2'-        (TyConApp tc tys, TyConApp tc' tys')-            -> tc == tc' && D env tys == D env' tys'-        (LitTy l, LitTy l')-            -> l == l'-        (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty')-            -> D env (varType tv)      == D env' (varType tv') &&-               D (extendCME env tv) ty == D (extendCME env' tv') ty'-        (CoercionTy {}, CoercionTy {})-            -> True-        _ -> False--instance {-# OVERLAPPING #-}-         Outputable a => Outputable (TypeMapG a) where-  ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])--emptyT :: TypeMapX a-emptyT = TM { tm_var  = emptyTM-            , tm_app  = emptyTM-            , tm_tycon  = emptyDNameEnv-            , tm_forall = emptyTM-            , tm_tylit  = emptyTyLitMap-            , tm_coerce = Nothing }--mapT :: (a->b) -> TypeMapX a -> TypeMapX b-mapT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon-           , tm_forall = tforall, tm_tylit = tlit-           , tm_coerce = tcoerce })-  = TM { tm_var    = mapTM f tvar-       , tm_app    = mapTM (mapTM f) tapp-       , tm_tycon  = mapTM f ttycon-       , tm_forall = mapTM (mapTM f) tforall-       , tm_tylit  = mapTM f tlit-       , tm_coerce = fmap f tcoerce }--------------------lkT :: DeBruijn Type -> TypeMapX a -> Maybe a-lkT (D env ty) m = go ty m-  where-    go ty | Just ty' <- trieMapView ty = go ty'-    go (TyVarTy v)                 = tm_var    >.> lkVar env v-    go (AppTy t1 t2)               = tm_app    >.> lkG (D env t1)-                                               >=> lkG (D env t2)-    go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc-    go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)-    go (LitTy l)                   = tm_tylit  >.> lkTyLit l-    go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)-                                               >=> lkBndr env tv-    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)-    go (CastTy t _)                = go t-    go (CoercionTy {})             = tm_coerce--------------------xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a-xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m--xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }-xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)-                                                            |>> xtG (D env t2) f }-xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }-xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }-xtT (D env (CastTy t _))      f m = xtT (D env t) f m-xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }-xtT (D env (ForAllTy (Bndr tv _) ty))  f m-  = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)-                                |>> xtBndr env tv f }-xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)-xtT (D _   ty@(FunTy {}))         _ _ = pprPanic "xtT FunTy" (ppr ty)--fdT :: (a -> b -> b) -> TypeMapX a -> b -> b-fdT k m = foldTM k (tm_var m)-        . foldTM (foldTM k) (tm_app m)-        . foldTM k (tm_tycon m)-        . foldTM (foldTM k) (tm_forall m)-        . foldTyLit k (tm_tylit m)-        . foldMaybe k (tm_coerce m)---------------------------data TyLitMap a = TLM { tlm_number :: Map.Map Integer a-                      , tlm_string :: Map.Map FastString a-                      }--instance TrieMap TyLitMap where-   type Key TyLitMap = TyLit-   emptyTM  = emptyTyLitMap-   lookupTM = lkTyLit-   alterTM  = xtTyLit-   foldTM   = foldTyLit-   mapTM    = mapTyLit--emptyTyLitMap :: TyLitMap a-emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = Map.empty }--mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b-mapTyLit f (TLM { tlm_number = tn, tlm_string = ts })-  = TLM { tlm_number = Map.map f tn, tlm_string = Map.map f ts }--lkTyLit :: TyLit -> TyLitMap a -> Maybe a-lkTyLit l =-  case l of-    NumTyLit n -> tlm_number >.> Map.lookup n-    StrTyLit n -> tlm_string >.> Map.lookup n--xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a-xtTyLit l f m =-  case l of-    NumTyLit n -> m { tlm_number = tlm_number m |> Map.alter f n }-    StrTyLit n -> m { tlm_string = tlm_string m |> Map.alter f n }--foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b-foldTyLit l m = flip (Map.foldr l) (tlm_string m)-              . flip (Map.foldr l) (tlm_number m)------------------------------------------------------ | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this--- is the type you want. The keys in this map may have different kinds.-newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))--lkTT :: DeBruijn Type -> TypeMap a -> Maybe a-lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m-                          >>= lkG (D env ty)--xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a-xtTT (D env ty) f (TypeMap m)-  = TypeMap (m |> xtG (D env $ typeKind ty)-               |>> xtG (D env ty) f)---- Below are some client-oriented functions which operate on 'TypeMap'.--instance TrieMap TypeMap where-    type Key TypeMap = Type-    emptyTM = TypeMap emptyTM-    lookupTM k m = lkTT (deBruijnize k) m-    alterTM k f m = xtTT (deBruijnize k) f m-    foldTM k (TypeMap m) = foldTM (foldTM k) m-    mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)--foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b-foldTypeMap k z m = foldTM k m z--emptyTypeMap :: TypeMap a-emptyTypeMap = emptyTM--lookupTypeMap :: TypeMap a -> Type -> Maybe a-lookupTypeMap cm t = lookupTM t cm--extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a-extendTypeMap m t v = alterTM t (const (Just v)) m--lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a-lookupTypeMapWithScope m cm t = lkTT (D cm t) m---- | Extend a 'TypeMap' with a type in the given context.--- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to--- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over--- multiple insertions.-extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a-extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m---- | Construct a deBruijn environment with the given variables in scope.--- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@-mkDeBruijnContext :: [Var] -> CmEnv-mkDeBruijnContext = extendCMEs emptyCME---- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),--- you'll find entries inserted under (t), even if (g) is non-reflexive.-newtype LooseTypeMap a-  = LooseTypeMap (TypeMapG a)--instance TrieMap LooseTypeMap where-  type Key LooseTypeMap = Type-  emptyTM = LooseTypeMap emptyTM-  lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m-  alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)-  foldTM f (LooseTypeMap m) = foldTM f m-  mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)--{--************************************************************************-*                                                                      *-                   Variables-*                                                                      *-************************************************************************--}--type BoundVar = Int  -- Bound variables are deBruijn numbered-type BoundVarMap a = IntMap.IntMap a--data CmEnv = CME { cme_next :: !BoundVar-                 , cme_env  :: VarEnv BoundVar }--emptyCME :: CmEnv-emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv }--extendCME :: CmEnv -> Var -> CmEnv-extendCME (CME { cme_next = bv, cme_env = env }) v-  = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }--extendCMEs :: CmEnv -> [Var] -> CmEnv-extendCMEs env vs = foldl' extendCME env vs--lookupCME :: CmEnv -> Var -> Maybe BoundVar-lookupCME (CME { cme_env = env }) v = lookupVarEnv env v---- | @DeBruijn a@ represents @a@ modulo alpha-renaming.  This is achieved--- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn--- numbering.  This allows us to define an 'Eq' instance for @DeBruijn a@, even--- if this was not (easily) possible for @a@.  Note: we purposely don't--- export the constructor.  Make a helper function if you find yourself--- needing it.-data DeBruijn a = D CmEnv a---- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no--- bound binders (an empty 'CmEnv').  This is usually what you want if there--- isn't already a 'CmEnv' in scope.-deBruijnize :: a -> DeBruijn a-deBruijnize = D emptyCME--instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where-    D _   []     == D _    []       = True-    D env (x:xs) == D env' (x':xs') = D env x  == D env' x' &&-                                      D env xs == D env' xs'-    _            == _               = False--instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where-    D _   Nothing  == D _    Nothing   = True-    D env (Just x) == D env' (Just x') = D env x  == D env' x'-    _              == _                = False----------- Variable binders ----------------- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between--- binding forms whose binders have different types.  For example,--- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should--- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@:--- we can disambiguate this by matching on the type (or kind, if this--- a binder in a type) of the binder.------ We also need to do the same for multiplicity! Which, since multiplicities are--- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries--- of pairs are composition.-data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))--instance TrieMap BndrMap where-   type Key BndrMap = Var-   emptyTM  = BndrMap emptyTM-   lookupTM = lkBndr emptyCME-   alterTM  = xtBndr emptyCME-   foldTM   = fdBndrMap-   mapTM    = mapBndrMap--mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b-mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)--fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b-fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm----- Note [Binders]--- ~~~~~~~~~~~~~~--- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all--- of these data types have binding forms.--lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a-lkBndr env v (BndrMap tymap) = do-  multmap <- lkG (D env (varType v)) tymap-  lookupTM (D env <$> varMultMaybe v) multmap---xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a-xtBndr env v xt (BndrMap tymap)  =-  BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))------------ Variable occurrence --------------data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable-                   , vm_fvar   :: DVarEnv a }      -- Free variable--instance TrieMap VarMap where-   type Key VarMap = Var-   emptyTM  = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }-   lookupTM = lkVar emptyCME-   alterTM  = xtVar emptyCME-   foldTM   = fdVar-   mapTM    = mapVar--mapVar :: (a->b) -> VarMap a -> VarMap b-mapVar f (VM { vm_bvar = bv, vm_fvar = fv })-  = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }--lkVar :: CmEnv -> Var -> VarMap a -> Maybe a-lkVar env v-  | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv-  | otherwise                  = vm_fvar >.> lkDFreeVar v--xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a-xtVar env v f m-  | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f }-  | otherwise                  = m { vm_fvar = vm_fvar m |> xtDFreeVar v f }--fdVar :: (a -> b -> b) -> VarMap a -> b -> b-fdVar k m = foldTM k (vm_bvar m)-          . foldTM k (vm_fvar m)--lkDFreeVar :: Var -> DVarEnv a -> Maybe a-lkDFreeVar var env = lookupDVarEnv env var--xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a-xtDFreeVar v f m = alterDVarEnv f m v

+ GHC/Core/Map/Expr.hs view

@@ -0,0 +1,393 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# OPTIONS_GHC -Wno-orphans #-}+ -- Eq (DeBruijn CoreExpr) and Eq (DeBruijn CoreAlt)++module GHC.Core.Map.Expr (+   -- * Maps over Core expressions+   CoreMap, emptyCoreMap, extendCoreMap, lookupCoreMap, foldCoreMap,+   -- * 'TrieMap' class reexports+   TrieMap(..), insertTM, deleteTM,+   lkDFreeVar, xtDFreeVar,+   lkDNamed, xtDNamed,+   (>.>), (|>), (|>>),+ ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Data.TrieMap+import GHC.Core.Map.Type+import GHC.Core+import GHC.Core.Type+import GHC.Types.Tickish+import GHC.Types.Var++import GHC.Utils.Misc+import GHC.Utils.Outputable++import qualified Data.Map    as Map+import GHC.Types.Name.Env+import Control.Monad( (>=>) )++{-+This module implements TrieMaps over Core related data structures+like CoreExpr or Type. It is built on the Tries from the TrieMap+module.++The code is very regular and boilerplate-like, but there is+some neat handling of *binders*.  In effect they are deBruijn+numbered on the fly.+++-}++----------------------+-- Recall that+--   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c++-- The CoreMap makes heavy use of GenMap. However the CoreMap Types are not+-- known when defining GenMap so we can only specialize them here.++{-# SPECIALIZE lkG :: Key CoreMapX     -> CoreMapG a     -> Maybe a #-}+{-# SPECIALIZE xtG :: Key CoreMapX     -> XT a -> CoreMapG a -> CoreMapG a #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoreMapG a     -> CoreMapG b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoreMapG a     -> b -> b #-}+++{-+************************************************************************+*                                                                      *+                   CoreMap+*                                                                      *+************************************************************************+-}++{-+Note [Binders]+~~~~~~~~~~~~~~+ * In general we check binders as late as possible because types are+   less likely to differ than expression structure.  That's why+      cm_lam :: CoreMapG (TypeMapG a)+   rather than+      cm_lam :: TypeMapG (CoreMapG a)++ * We don't need to look at the type of some binders, notably+     - the case binder in (Case _ b _ _)+     - the binders in an alternative+   because they are totally fixed by the context++Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* For a key (Case e b ty (alt:alts))  we don't need to look the return type+  'ty', because every alternative has that type.++* For a key (Case e b ty []) we MUST look at the return type 'ty', because+  otherwise (Case (error () "urk") _ Int  []) would compare equal to+            (Case (error () "urk") _ Bool [])+  which is utterly wrong (#6097)++We could compare the return type regardless, but the wildly common case+is that it's unnecessary, so we have two fields (cm_case and cm_ecase)+for the two possibilities.  Only cm_ecase looks at the type.++See also Note [Empty case alternatives] in GHC.Core.+-}++-- | @CoreMap a@ is a map from 'CoreExpr' to @a@.  If you are a client, this+-- is the type you want.+newtype CoreMap a = CoreMap (CoreMapG a)++instance TrieMap CoreMap where+    type Key CoreMap = CoreExpr+    emptyTM = CoreMap emptyTM+    lookupTM k (CoreMap m) = lookupTM (deBruijnize k) m+    alterTM k f (CoreMap m) = CoreMap (alterTM (deBruijnize k) f m)+    foldTM k (CoreMap m) = foldTM k m+    mapTM f (CoreMap m) = CoreMap (mapTM f m)+    filterTM f (CoreMap m) = CoreMap (filterTM f m)++-- | @CoreMapG a@ is a map from @DeBruijn CoreExpr@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'CoreMap'+-- inside another 'TrieMap', this is the type you want.+type CoreMapG = GenMap CoreMapX++-- | @CoreMapX a@ is the base map from @DeBruijn CoreExpr@ to @a@, but without+-- the 'GenMap' optimization.+data CoreMapX a+  = CM { cm_var   :: VarMap a+       , cm_lit   :: LiteralMap a+       , cm_co    :: CoercionMapG a+       , cm_type  :: TypeMapG a+       , cm_cast  :: CoreMapG (CoercionMapG a)+       , cm_tick  :: CoreMapG (TickishMap a)+       , cm_app   :: CoreMapG (CoreMapG a)+       , cm_lam   :: CoreMapG (BndrMap a)    -- Note [Binders]+       , cm_letn  :: CoreMapG (CoreMapG (BndrMap a))+       , cm_letr  :: ListMap CoreMapG (CoreMapG (ListMap BndrMap a))+       , cm_case  :: CoreMapG (ListMap AltMap a)+       , cm_ecase :: CoreMapG (TypeMapG a)    -- Note [Empty case alternatives]+     }++instance Eq (DeBruijn CoreExpr) where+  D env1 e1 == D env2 e2 = go e1 e2 where+    go (Var v1) (Var v2)+      = case (lookupCME env1 v1, lookupCME env2 v2) of+                            (Just b1, Just b2) -> b1 == b2+                            (Nothing, Nothing) -> v1 == v2+                            _ -> False+    go (Lit lit1)    (Lit lit2)      = lit1 == lit2+    go (Type t1)    (Type t2)        = D env1 t1 == D env2 t2+    go (Coercion co1) (Coercion co2) = D env1 co1 == D env2 co2+    go (Cast e1 co1) (Cast e2 co2) = D env1 co1 == D env2 co2 && go e1 e2+    go (App f1 a1)   (App f2 a2)   = go f1 f2 && go a1 a2+    -- This seems a bit dodgy, see 'eqTickish'+    go (Tick n1 e1)  (Tick n2 e2)  = n1 == n2 && go e1 e2++    go (Lam b1 e1)  (Lam b2 e2)+      =  D env1 (varType b1) == D env2 (varType b2)+      && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)+      && D (extendCME env1 b1) e1 == D (extendCME env2 b2) e2++    go (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2)+      =  go r1 r2+      && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2++    go (Let (Rec ps1) e1) (Let (Rec ps2) e2)+      = equalLength ps1 ps2+      && D env1' rs1 == D env2' rs2+      && D env1' e1  == D env2' e2+      where+        (bs1,rs1) = unzip ps1+        (bs2,rs2) = unzip ps2+        env1' = extendCMEs env1 bs1+        env2' = extendCMEs env2 bs2++    go (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+      | null a1   -- See Note [Empty case alternatives]+      = null a2 && go e1 e2 && D env1 t1 == D env2 t2+      | otherwise+      =  go e1 e2 && D (extendCME env1 b1) a1 == D (extendCME env2 b2) a2++    go _ _ = False++emptyE :: CoreMapX a+emptyE = CM { cm_var = emptyTM, cm_lit = emptyTM+            , cm_co = emptyTM, cm_type = emptyTM+            , cm_cast = emptyTM, cm_app = emptyTM+            , cm_lam = emptyTM, cm_letn = emptyTM+            , cm_letr = emptyTM, cm_case = emptyTM+            , cm_ecase = emptyTM, cm_tick = emptyTM }++instance TrieMap CoreMapX where+   type Key CoreMapX = DeBruijn CoreExpr+   emptyTM  = emptyE+   lookupTM = lkE+   alterTM  = xtE+   foldTM   = fdE+   mapTM    = mapE+   filterTM = ftE++--------------------------+mapE :: (a->b) -> CoreMapX a -> CoreMapX b+mapE f (CM { cm_var = cvar, cm_lit = clit+           , cm_co = cco, cm_type = ctype+           , cm_cast = ccast , cm_app = capp+           , cm_lam = clam, cm_letn = cletn+           , cm_letr = cletr, cm_case = ccase+           , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit+       , cm_co = mapTM f cco, cm_type = mapTM f ctype+       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp+       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn+       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase+       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }++ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a+ftE f (CM { cm_var = cvar, cm_lit = clit+          , cm_co = cco, cm_type = ctype+          , cm_cast = ccast , cm_app = capp+          , cm_lam = clam, cm_letn = cletn+          , cm_letr = cletr, cm_case = ccase+          , cm_ecase = cecase, cm_tick = ctick })+  = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit+       , cm_co = filterTM f cco, cm_type = filterTM f ctype+       , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp+       , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn+       , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase+       , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }++--------------------------+lookupCoreMap :: CoreMap a -> CoreExpr -> Maybe a+lookupCoreMap cm e = lookupTM e cm++extendCoreMap :: CoreMap a -> CoreExpr -> a -> CoreMap a+extendCoreMap m e v = alterTM e (\_ -> Just v) m++foldCoreMap :: (a -> b -> b) -> b -> CoreMap a -> b+foldCoreMap k z m = foldTM k m z++emptyCoreMap :: CoreMap a+emptyCoreMap = emptyTM++instance Outputable a => Outputable (CoreMap a) where+  ppr m = text "CoreMap elts" <+> ppr (foldTM (:) m [])++-------------------------+fdE :: (a -> b -> b) -> CoreMapX a -> b -> b+fdE k m+  = foldTM k (cm_var m)+  . foldTM k (cm_lit m)+  . foldTM k (cm_co m)+  . foldTM k (cm_type m)+  . foldTM (foldTM k) (cm_cast m)+  . foldTM (foldTM k) (cm_tick m)+  . foldTM (foldTM k) (cm_app m)+  . foldTM (foldTM k) (cm_lam m)+  . foldTM (foldTM (foldTM k)) (cm_letn m)+  . foldTM (foldTM (foldTM k)) (cm_letr m)+  . foldTM (foldTM k) (cm_case m)+  . foldTM (foldTM k) (cm_ecase m)++-- lkE: lookup in trie for expressions+lkE :: DeBruijn CoreExpr -> CoreMapX a -> Maybe a+lkE (D env expr) cm = go expr cm+  where+    go (Var v)              = cm_var  >.> lkVar env v+    go (Lit l)              = cm_lit  >.> lookupTM l+    go (Type t)             = cm_type >.> lkG (D env t)+    go (Coercion c)         = cm_co   >.> lkG (D env c)+    go (Cast e c)           = cm_cast >.> lkG (D env e) >=> lkG (D env c)+    go (Tick tickish e)     = cm_tick >.> lkG (D env e) >=> lkTickish tickish+    go (App e1 e2)          = cm_app  >.> lkG (D env e2) >=> lkG (D env e1)+    go (Lam v e)            = cm_lam  >.> lkG (D (extendCME env v) e)+                              >=> lkBndr env v+    go (Let (NonRec b r) e) = cm_letn >.> lkG (D env r)+                              >=> lkG (D (extendCME env b) e) >=> lkBndr env b+    go (Let (Rec prs) e)    = let (bndrs,rhss) = unzip prs+                                  env1 = extendCMEs env bndrs+                              in cm_letr+                                 >.> lkList (lkG . D env1) rhss+                                 >=> lkG (D env1 e)+                                 >=> lkList (lkBndr env1) bndrs+    go (Case e b ty as)     -- See Note [Empty case alternatives]+               | null as    = cm_ecase >.> lkG (D env e) >=> lkG (D env ty)+               | otherwise  = cm_case >.> lkG (D env e)+                              >=> lkList (lkA (extendCME env b)) as++xtE :: DeBruijn CoreExpr -> XT a -> CoreMapX a -> CoreMapX a+xtE (D env (Var v))              f m = m { cm_var  = cm_var m+                                                 |> xtVar env v f }+xtE (D env (Type t))             f m = m { cm_type = cm_type m+                                                 |> xtG (D env t) f }+xtE (D env (Coercion c))         f m = m { cm_co   = cm_co m+                                                 |> xtG (D env c) f }+xtE (D _   (Lit l))              f m = m { cm_lit  = cm_lit m  |> alterTM l f }+xtE (D env (Cast e c))           f m = m { cm_cast = cm_cast m |> xtG (D env e)+                                                 |>> xtG (D env c) f }+xtE (D env (Tick t e))           f m = m { cm_tick = cm_tick m |> xtG (D env e)+                                                 |>> xtTickish t f }+xtE (D env (App e1 e2))          f m = m { cm_app = cm_app m |> xtG (D env e2)+                                                 |>> xtG (D env e1) f }+xtE (D env (Lam v e))            f m = m { cm_lam = cm_lam m+                                                 |> xtG (D (extendCME env v) e)+                                                 |>> xtBndr env v f }+xtE (D env (Let (NonRec b r) e)) f m = m { cm_letn = cm_letn m+                                                 |> xtG (D (extendCME env b) e)+                                                 |>> xtG (D env r)+                                                 |>> xtBndr env b f }+xtE (D env (Let (Rec prs) e))    f m = m { cm_letr =+                                              let (bndrs,rhss) = unzip prs+                                                  env1 = extendCMEs env bndrs+                                              in cm_letr m+                                                 |>  xtList (xtG . D env1) rhss+                                                 |>> xtG (D env1 e)+                                                 |>> xtList (xtBndr env1)+                                                            bndrs f }+xtE (D env (Case e b ty as))     f m+                     | null as   = m { cm_ecase = cm_ecase m |> xtG (D env e)+                                                 |>> xtG (D env ty) f }+                     | otherwise = m { cm_case = cm_case m |> xtG (D env e)+                                                 |>> let env1 = extendCME env b+                                                     in xtList (xtA env1) as f }++-- TODO: this seems a bit dodgy, see 'eqTickish'+type TickishMap a = Map.Map CoreTickish a+lkTickish :: CoreTickish -> TickishMap a -> Maybe a+lkTickish = lookupTM++xtTickish :: CoreTickish -> XT a -> TickishMap a -> TickishMap a+xtTickish = alterTM++------------------------+data AltMap a   -- A single alternative+  = AM { am_deflt :: CoreMapG a+       , am_data  :: DNameEnv (CoreMapG a)+       , am_lit   :: LiteralMap (CoreMapG a) }++instance TrieMap AltMap where+   type Key AltMap = CoreAlt+   emptyTM  = AM { am_deflt = emptyTM+                 , am_data = emptyDNameEnv+                 , am_lit  = emptyTM }+   lookupTM = lkA emptyCME+   alterTM  = xtA emptyCME+   foldTM   = fdA+   mapTM    = mapA+   filterTM = ftA++instance Eq (DeBruijn CoreAlt) where+  D env1 a1 == D env2 a2 = go a1 a2 where+    go (Alt DEFAULT _ rhs1) (Alt DEFAULT _ rhs2)+        = D env1 rhs1 == D env2 rhs2+    go (Alt (LitAlt lit1) _ rhs1) (Alt (LitAlt lit2) _ rhs2)+        = lit1 == lit2 && D env1 rhs1 == D env2 rhs2+    go (Alt (DataAlt dc1) bs1 rhs1) (Alt (DataAlt dc2) bs2 rhs2)+        = dc1 == dc2 &&+          D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2+    go _ _ = False++mapA :: (a->b) -> AltMap a -> AltMap b+mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapTM f adeflt+       , am_data = mapTM (mapTM f) adata+       , am_lit = mapTM (mapTM f) alit }++ftA :: (a->Bool) -> AltMap a -> AltMap a+ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = filterTM f adeflt+       , am_data = mapTM (filterTM f) adata+       , am_lit = mapTM (filterTM f) alit }++lkA :: CmEnv -> CoreAlt -> AltMap a -> Maybe a+lkA env (Alt DEFAULT      _  rhs) = am_deflt >.> lkG (D env rhs)+lkA env (Alt (LitAlt lit) _  rhs) = am_lit >.> lookupTM lit >=> lkG (D env rhs)+lkA env (Alt (DataAlt dc) bs rhs) = am_data >.> lkDNamed dc+                                        >=> lkG (D (extendCMEs env bs) rhs)++xtA :: CmEnv -> CoreAlt -> XT a -> AltMap a -> AltMap a+xtA env (Alt DEFAULT _ rhs)      f m =+    m { am_deflt = am_deflt m |> xtG (D env rhs) f }+xtA env (Alt (LitAlt l) _ rhs)   f m =+    m { am_lit   = am_lit m   |> alterTM l |>> xtG (D env rhs) f }+xtA env (Alt (DataAlt d) bs rhs) f m =+    m { am_data  = am_data m  |> xtDNamed d+                             |>> xtG (D (extendCMEs env bs) rhs) f }++fdA :: (a -> b -> b) -> AltMap a -> b -> b+fdA k m = foldTM k (am_deflt m)+        . foldTM (foldTM k) (am_data m)+        . foldTM (foldTM k) (am_lit m)

+ GHC/Core/Map/Type.hs view

@@ -0,0 +1,562 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module GHC.Core.Map.Type (+     -- * Re-export generic interface+   TrieMap(..), XT,++     -- * Maps over 'Type's+   TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap, foldTypeMap,+   LooseTypeMap,+   -- ** With explicit scoping+   CmEnv, lookupCME, extendTypeMapWithScope, lookupTypeMapWithScope,+   mkDeBruijnContext, extendCME, extendCMEs, emptyCME,++   -- * Utilities for use by friends only+   TypeMapG, CoercionMapG,++   DeBruijn(..), deBruijnize,++   BndrMap, xtBndr, lkBndr,+   VarMap, xtVar, lkVar, lkDFreeVar, xtDFreeVar,++   xtDNamed, lkDNamed++   ) where++-- This module is separate from GHC.Core.Map.Expr to avoid a module loop+-- between GHC.Core.Unify (which depends on this module) and GHC.Core++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCo.Rep+import GHC.Data.TrieMap++import GHC.Data.FastString+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Unique.FM+import GHC.Utils.Outputable++import GHC.Data.Maybe+import GHC.Utils.Panic++import qualified Data.Map    as Map+import qualified Data.IntMap as IntMap++import Control.Monad ( (>=>) )++-- NB: Be careful about RULES and type families (#5821).  So we should make sure+-- to specify @Key TypeMapX@ (and not @DeBruijn Type@, the reduced form)++{-# SPECIALIZE lkG :: Key TypeMapX     -> TypeMapG a     -> Maybe a #-}+{-# SPECIALIZE lkG :: Key CoercionMapX -> CoercionMapG a -> Maybe a #-}++{-# SPECIALIZE xtG :: Key TypeMapX     -> XT a -> TypeMapG a -> TypeMapG a #-}+{-# SPECIALIZE xtG :: Key CoercionMapX -> XT a -> CoercionMapG a -> CoercionMapG a #-}++{-# SPECIALIZE mapG :: (a -> b) -> TypeMapG a     -> TypeMapG b #-}+{-# SPECIALIZE mapG :: (a -> b) -> CoercionMapG a -> CoercionMapG b #-}++{-# SPECIALIZE fdG :: (a -> b -> b) -> TypeMapG a     -> b -> b #-}+{-# SPECIALIZE fdG :: (a -> b -> b) -> CoercionMapG a -> b -> b #-}++{-+************************************************************************+*                                                                      *+                   Coercions+*                                                                      *+************************************************************************+-}++-- We should really never care about the contents of a coercion. Instead,+-- just look up the coercion's type.+newtype CoercionMap a = CoercionMap (CoercionMapG a)++instance TrieMap CoercionMap where+   type Key CoercionMap = Coercion+   emptyTM                     = CoercionMap emptyTM+   lookupTM k  (CoercionMap m) = lookupTM (deBruijnize k) m+   alterTM k f (CoercionMap m) = CoercionMap (alterTM (deBruijnize k) f m)+   foldTM k    (CoercionMap m) = foldTM k m+   mapTM f     (CoercionMap m) = CoercionMap (mapTM f m)+   filterTM f  (CoercionMap m) = CoercionMap (filterTM f m)++type CoercionMapG = GenMap CoercionMapX+newtype CoercionMapX a = CoercionMapX (TypeMapX a)++instance TrieMap CoercionMapX where+  type Key CoercionMapX = DeBruijn Coercion+  emptyTM = CoercionMapX emptyTM+  lookupTM = lkC+  alterTM  = xtC+  foldTM f (CoercionMapX core_tm) = foldTM f core_tm+  mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM f core_tm)+  filterTM f (CoercionMapX core_tm) = CoercionMapX (filterTM f core_tm)++instance Eq (DeBruijn Coercion) where+  D env1 co1 == D env2 co2+    = D env1 (coercionType co1) ==+      D env2 (coercionType co2)++lkC :: DeBruijn Coercion -> CoercionMapX a -> Maybe a+lkC (D env co) (CoercionMapX core_tm) = lkT (D env $ coercionType co)+                                        core_tm++xtC :: DeBruijn Coercion -> XT a -> CoercionMapX a -> CoercionMapX a+xtC (D env co) f (CoercionMapX m)+  = CoercionMapX (xtT (D env $ coercionType co) f m)++{-+************************************************************************+*                                                                      *+                   Types+*                                                                      *+************************************************************************+-}++-- | @TypeMapG a@ is a map from @DeBruijn Type@ to @a@.  The extended+-- key makes it suitable for recursive traversal, since it can track binders,+-- but it is strictly internal to this module.  If you are including a 'TypeMap'+-- inside another 'TrieMap', this is the type you want. Note that this+-- lookup does not do a kind-check. Thus, all keys in this map must have+-- the same kind. Also note that this map respects the distinction between+-- @Type@ and @Constraint@, despite the fact that they are equivalent type+-- synonyms in Core.+type TypeMapG = GenMap TypeMapX++-- | @TypeMapX a@ is the base map from @DeBruijn Type@ to @a@, but without the+-- 'GenMap' optimization.+data TypeMapX a+  = TM { tm_var    :: VarMap a+       , tm_app    :: TypeMapG (TypeMapG a)+       , tm_tycon  :: DNameEnv a++         -- only InvisArg arrows here+       , tm_funty  :: TypeMapG (TypeMapG (TypeMapG a))+                       -- keyed on the argument, result rep, and result+                       -- constraints are never linear-restricted and are always lifted++       , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr+       , tm_tylit  :: TyLitMap a+       , tm_coerce :: Maybe a+       }+    -- Note that there is no tyconapp case; see Note [Equality on AppTys] in GHC.Core.Type++-- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the+-- last one? See Note [Equality on AppTys] in GHC.Core.Type+--+-- Note, however, that we keep Constraint and Type apart here, despite the fact+-- that they are both synonyms of TYPE 'LiftedRep (see #11715).+--+-- We also keep (Eq a => a) as a FunTy, distinct from ((->) (Eq a) a).+trieMapView :: Type -> Maybe Type+trieMapView ty+  -- First check for TyConApps that need to be expanded to+  -- AppTy chains.+  | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty+  = Just $ foldl' AppTy (mkTyConTy tc) tys++  -- Then resolve any remaining nullary synonyms.+  | Just ty' <- tcView ty = Just ty'+trieMapView _ = Nothing++instance TrieMap TypeMapX where+   type Key TypeMapX = DeBruijn Type+   emptyTM  = emptyT+   lookupTM = lkT+   alterTM  = xtT+   foldTM   = fdT+   mapTM    = mapT+   filterTM = filterT++instance Eq (DeBruijn Type) where+  env_t@(D env t) == env_t'@(D env' t')+    | Just new_t  <- tcView t  = D env new_t == env_t'+    | Just new_t' <- tcView t' = env_t       == D env' new_t'+    | otherwise+    = case (t, t') of+        (CastTy t1 _, _)  -> D env t1 == D env t'+        (_, CastTy t1' _) -> D env t  == D env t1'++        (TyVarTy v, TyVarTy v')+            -> case (lookupCME env v, lookupCME env' v') of+                (Just bv, Just bv') -> bv == bv'+                (Nothing, Nothing)  -> v == v'+                _ -> False+                -- See Note [Equality on AppTys] in GHC.Core.Type+        (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (s, AppTy t1' t2') | Just (t1, t2) <- repSplitAppTy_maybe s+            -> D env t1 == D env' t1' && D env t2 == D env' t2'+        (FunTy v1 w1 t1 t2, FunTy v1' w1' t1' t2')+            -> v1 == v1' &&+               D env w1 == D env w1' &&+               D env t1 == D env' t1' &&+               D env t2 == D env' t2'+        (TyConApp tc tys, TyConApp tc' tys')+            -> tc == tc' && D env tys == D env' tys'+        (LitTy l, LitTy l')+            -> l == l'+        (ForAllTy (Bndr tv _) ty, ForAllTy (Bndr tv' _) ty')+            -> D env (varType tv)      == D env' (varType tv') &&+               D (extendCME env tv) ty == D (extendCME env' tv') ty'+        (CoercionTy {}, CoercionTy {})+            -> True+        _ -> False++instance {-# OVERLAPPING #-}+         Outputable a => Outputable (TypeMapG a) where+  ppr m = text "TypeMap elts" <+> ppr (foldTM (:) m [])++emptyT :: TypeMapX a+emptyT = TM { tm_var  = emptyTM+            , tm_app  = emptyTM+            , tm_tycon  = emptyDNameEnv+            , tm_funty  = emptyTM+            , tm_forall = emptyTM+            , tm_tylit  = emptyTyLitMap+            , tm_coerce = Nothing }++mapT :: (a->b) -> TypeMapX a -> TypeMapX b+mapT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+           , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit+           , tm_coerce = tcoerce })+  = TM { tm_var    = mapTM f tvar+       , tm_app    = mapTM (mapTM f) tapp+       , tm_tycon  = mapTM f ttycon+       , tm_funty  = mapTM (mapTM (mapTM f)) tfunty+       , tm_forall = mapTM (mapTM f) tforall+       , tm_tylit  = mapTM f tlit+       , tm_coerce = fmap f tcoerce }++-----------------+lkT :: DeBruijn Type -> TypeMapX a -> Maybe a+lkT (D env ty) m = go ty m+  where+    go ty | Just ty' <- trieMapView ty = go ty'+    go (TyVarTy v)                 = tm_var    >.> lkVar env v+    go (AppTy t1 t2)               = tm_app    >.> lkG (D env t1)+                                               >=> lkG (D env t2)+    go (TyConApp tc [])            = tm_tycon  >.> lkDNamed tc+    go ty@(TyConApp _ (_:_))       = pprPanic "lkT TyConApp" (ppr ty)+    go (LitTy l)                   = tm_tylit  >.> lkTyLit l+    go (ForAllTy (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)+                                               >=> lkBndr env tv+    go (FunTy InvisArg _ arg res)+      | Just res_rep <- getRuntimeRep_maybe res+                                   = tm_funty >.> lkG (D env arg)+                                              >=> lkG (D env res_rep)+                                              >=> lkG (D env res)+    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)+    go (CastTy t _)                = go t+    go (CoercionTy {})             = tm_coerce++-----------------+xtT :: DeBruijn Type -> XT a -> TypeMapX a -> TypeMapX a+xtT (D env ty) f m | Just ty' <- trieMapView ty = xtT (D env ty') f m++xtT (D env (TyVarTy v))       f m = m { tm_var    = tm_var m |> xtVar env v f }+xtT (D env (AppTy t1 t2))     f m = m { tm_app    = tm_app m |> xtG (D env t1)+                                                            |>> xtG (D env t2) f }+xtT (D _   (TyConApp tc []))  f m = m { tm_tycon  = tm_tycon m |> xtDNamed tc f }+xtT (D env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1)+                                                                    |>> xtG (D env t2_rep)+                                                                    |>> xtG (D env t2) f }+  where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2)+xtT (D _   (LitTy l))         f m = m { tm_tylit  = tm_tylit m |> xtTyLit l f }+xtT (D env (CastTy t _))      f m = xtT (D env t) f m+xtT (D _   (CoercionTy {}))   f m = m { tm_coerce = tm_coerce m |> f }+xtT (D env (ForAllTy (Bndr tv _) ty))  f m+  = m { tm_forall = tm_forall m |> xtG (D (extendCME env tv) ty)+                                |>> xtBndr env tv f }+xtT (D _   ty@(TyConApp _ (_:_))) _ _ = pprPanic "xtT TyConApp" (ppr ty)+xtT (D _   ty@(FunTy {}))         _ _ = pprPanic "xtT FunTy" (ppr ty)++fdT :: (a -> b -> b) -> TypeMapX a -> b -> b+fdT k m = foldTM k (tm_var m)+        . foldTM (foldTM k) (tm_app m)+        . foldTM k (tm_tycon m)+        . foldTM (foldTM (foldTM k)) (tm_funty m)+        . foldTM (foldTM k) (tm_forall m)+        . foldTyLit k (tm_tylit m)+        . foldMaybe k (tm_coerce m)++filterT :: (a -> Bool) -> TypeMapX a -> TypeMapX a+filterT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+              , tm_funty = tfunty, tm_forall = tforall, tm_tylit = tlit+              , tm_coerce = tcoerce })+  = TM { tm_var    = filterTM f tvar+       , tm_app    = mapTM (filterTM f) tapp+       , tm_tycon  = filterTM f ttycon+       , tm_funty  = mapTM (mapTM (filterTM f)) tfunty+       , tm_forall = mapTM (filterTM f) tforall+       , tm_tylit  = filterTM f tlit+       , tm_coerce = filterMaybe f tcoerce }++------------------------+data TyLitMap a = TLM { tlm_number :: Map.Map Integer a+                      , tlm_string :: UniqFM  FastString a+                      , tlm_char   :: Map.Map Char a+                      }++instance TrieMap TyLitMap where+   type Key TyLitMap = TyLit+   emptyTM  = emptyTyLitMap+   lookupTM = lkTyLit+   alterTM  = xtTyLit+   foldTM   = foldTyLit+   mapTM    = mapTyLit+   filterTM = filterTyLit++emptyTyLitMap :: TyLitMap a+emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty }++mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b+mapTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })+  = TLM { tlm_number = Map.map f tn, tlm_string = mapUFM f ts, tlm_char = Map.map f tc }++lkTyLit :: TyLit -> TyLitMap a -> Maybe a+lkTyLit l =+  case l of+    NumTyLit n -> tlm_number >.> Map.lookup n+    StrTyLit n -> tlm_string >.> (`lookupUFM` n)+    CharTyLit n -> tlm_char >.> Map.lookup n++xtTyLit :: TyLit -> XT a -> TyLitMap a -> TyLitMap a+xtTyLit l f m =+  case l of+    NumTyLit n ->  m { tlm_number = Map.alter f n (tlm_number m) }+    StrTyLit n ->  m { tlm_string = alterUFM  f (tlm_string m) n }+    CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }++foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b+foldTyLit l m = flip (foldUFM l) (tlm_string m)+              . flip (Map.foldr l) (tlm_number m)+              . flip (Map.foldr l) (tlm_char m)++filterTyLit :: (a -> Bool) -> TyLitMap a -> TyLitMap a+filterTyLit f (TLM { tlm_number = tn, tlm_string = ts, tlm_char = tc })+  = TLM { tlm_number = Map.filter f tn, tlm_string = filterUFM f ts, tlm_char = Map.filter f tc }++-------------------------------------------------+-- | @TypeMap a@ is a map from 'Type' to @a@.  If you are a client, this+-- is the type you want. The keys in this map may have different kinds.+newtype TypeMap a = TypeMap (TypeMapG (TypeMapG a))++lkTT :: DeBruijn Type -> TypeMap a -> Maybe a+lkTT (D env ty) (TypeMap m) = lkG (D env $ typeKind ty) m+                          >>= lkG (D env ty)++xtTT :: DeBruijn Type -> XT a -> TypeMap a -> TypeMap a+xtTT (D env ty) f (TypeMap m)+  = TypeMap (m |> xtG (D env $ typeKind ty)+               |>> xtG (D env ty) f)++-- Below are some client-oriented functions which operate on 'TypeMap'.++instance TrieMap TypeMap where+    type Key TypeMap = Type+    emptyTM = TypeMap emptyTM+    lookupTM k m = lkTT (deBruijnize k) m+    alterTM k f m = xtTT (deBruijnize k) f m+    foldTM k (TypeMap m) = foldTM (foldTM k) m+    mapTM f (TypeMap m) = TypeMap (mapTM (mapTM f) m)+    filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) m)++foldTypeMap :: (a -> b -> b) -> b -> TypeMap a -> b+foldTypeMap k z m = foldTM k m z++emptyTypeMap :: TypeMap a+emptyTypeMap = emptyTM++lookupTypeMap :: TypeMap a -> Type -> Maybe a+lookupTypeMap cm t = lookupTM t cm++extendTypeMap :: TypeMap a -> Type -> a -> TypeMap a+extendTypeMap m t v = alterTM t (const (Just v)) m++lookupTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> Maybe a+lookupTypeMapWithScope m cm t = lkTT (D cm t) m++-- | Extend a 'TypeMap' with a type in the given context.+-- @extendTypeMapWithScope m (mkDeBruijnContext [a,b,c]) t v@ is equivalent to+-- @extendTypeMap m (forall a b c. t) v@, but allows reuse of the context over+-- multiple insertions.+extendTypeMapWithScope :: TypeMap a -> CmEnv -> Type -> a -> TypeMap a+extendTypeMapWithScope m cm t v = xtTT (D cm t) (const (Just v)) m++-- | Construct a deBruijn environment with the given variables in scope.+-- e.g. @mkDeBruijnEnv [a,b,c]@ constructs a context @forall a b c.@+mkDeBruijnContext :: [Var] -> CmEnv+mkDeBruijnContext = extendCMEs emptyCME++-- | A 'LooseTypeMap' doesn't do a kind-check. Thus, when lookup up (t |> g),+-- you'll find entries inserted under (t), even if (g) is non-reflexive.+newtype LooseTypeMap a+  = LooseTypeMap (TypeMapG a)++instance TrieMap LooseTypeMap where+  type Key LooseTypeMap = Type+  emptyTM = LooseTypeMap emptyTM+  lookupTM k (LooseTypeMap m) = lookupTM (deBruijnize k) m+  alterTM k f (LooseTypeMap m) = LooseTypeMap (alterTM (deBruijnize k) f m)+  foldTM f (LooseTypeMap m) = foldTM f m+  mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)+  filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)++{-+************************************************************************+*                                                                      *+                   Variables+*                                                                      *+************************************************************************+-}++type BoundVar = Int  -- Bound variables are deBruijn numbered+type BoundVarMap a = IntMap.IntMap a++data CmEnv = CME { cme_next :: !BoundVar+                 , cme_env  :: VarEnv BoundVar }++emptyCME :: CmEnv+emptyCME = CME { cme_next = 0, cme_env = emptyVarEnv }++extendCME :: CmEnv -> Var -> CmEnv+extendCME (CME { cme_next = bv, cme_env = env }) v+  = CME { cme_next = bv+1, cme_env = extendVarEnv env v bv }++extendCMEs :: CmEnv -> [Var] -> CmEnv+extendCMEs env vs = foldl' extendCME env vs++lookupCME :: CmEnv -> Var -> Maybe BoundVar+lookupCME (CME { cme_env = env }) v = lookupVarEnv env v++-- | @DeBruijn a@ represents @a@ modulo alpha-renaming.  This is achieved+-- by equipping the value with a 'CmEnv', which tracks an on-the-fly deBruijn+-- numbering.  This allows us to define an 'Eq' instance for @DeBruijn a@, even+-- if this was not (easily) possible for @a@.  Note: we purposely don't+-- export the constructor.  Make a helper function if you find yourself+-- needing it.+data DeBruijn a = D CmEnv a++-- | Synthesizes a @DeBruijn a@ from an @a@, by assuming that there are no+-- bound binders (an empty 'CmEnv').  This is usually what you want if there+-- isn't already a 'CmEnv' in scope.+deBruijnize :: a -> DeBruijn a+deBruijnize = D emptyCME++instance Eq (DeBruijn a) => Eq (DeBruijn [a]) where+    D _   []     == D _    []       = True+    D env (x:xs) == D env' (x':xs') = D env x  == D env' x' &&+                                      D env xs == D env' xs'+    _            == _               = False++instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where+    D _   Nothing  == D _    Nothing   = True+    D env (Just x) == D env' (Just x') = D env x  == D env' x'+    _              == _                = False++--------- Variable binders -------------++-- | A 'BndrMap' is a 'TypeMapG' which allows us to distinguish between+-- binding forms whose binders have different types.  For example,+-- if we are doing a 'TrieMap' lookup on @\(x :: Int) -> ()@, we should+-- not pick up an entry in the 'TrieMap' for @\(x :: Bool) -> ()@:+-- we can disambiguate this by matching on the type (or kind, if this+-- a binder in a type) of the binder.+--+-- We also need to do the same for multiplicity! Which, since multiplicities are+-- encoded simply as a 'Type', amounts to have a Trie for a pair of types. Tries+-- of pairs are composition.+data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))++instance TrieMap BndrMap where+   type Key BndrMap = Var+   emptyTM  = BndrMap emptyTM+   lookupTM = lkBndr emptyCME+   alterTM  = xtBndr emptyCME+   foldTM   = fdBndrMap+   mapTM    = mapBndrMap+   filterTM = ftBndrMap++mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b+mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)++fdBndrMap :: (a -> b -> b) -> BndrMap a -> b -> b+fdBndrMap f (BndrMap tm) = foldTM (foldTM f) tm+++-- We need to use 'BndrMap' for 'Coercion', 'CoreExpr' AND 'Type', since all+-- of these data types have binding forms.++lkBndr :: CmEnv -> Var -> BndrMap a -> Maybe a+lkBndr env v (BndrMap tymap) = do+  multmap <- lkG (D env (varType v)) tymap+  lookupTM (D env <$> varMultMaybe v) multmap+++xtBndr :: forall a . CmEnv -> Var -> XT a -> BndrMap a -> BndrMap a+xtBndr env v xt (BndrMap tymap)  =+  BndrMap (tymap |> xtG (D env (varType v)) |>> (alterTM (D env <$> varMultMaybe v) xt))++ftBndrMap :: (a -> Bool) -> BndrMap a -> BndrMap a+ftBndrMap f (BndrMap tm) = BndrMap (mapTM (filterTM f) tm)++--------- Variable occurrence -------------+data VarMap a = VM { vm_bvar   :: BoundVarMap a  -- Bound variable+                   , vm_fvar   :: DVarEnv a }      -- Free variable++instance TrieMap VarMap where+   type Key VarMap = Var+   emptyTM  = VM { vm_bvar = IntMap.empty, vm_fvar = emptyDVarEnv }+   lookupTM = lkVar emptyCME+   alterTM  = xtVar emptyCME+   foldTM   = fdVar+   mapTM    = mapVar+   filterTM = ftVar++mapVar :: (a->b) -> VarMap a -> VarMap b+mapVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = mapTM f bv, vm_fvar = mapTM f fv }++lkVar :: CmEnv -> Var -> VarMap a -> Maybe a+lkVar env v+  | Just bv <- lookupCME env v = vm_bvar >.> lookupTM bv+  | otherwise                  = vm_fvar >.> lkDFreeVar v++xtVar :: CmEnv -> Var -> XT a -> VarMap a -> VarMap a+xtVar env v f m+  | Just bv <- lookupCME env v = m { vm_bvar = vm_bvar m |> alterTM bv f }+  | otherwise                  = m { vm_fvar = vm_fvar m |> xtDFreeVar v f }++fdVar :: (a -> b -> b) -> VarMap a -> b -> b+fdVar k m = foldTM k (vm_bvar m)+          . foldTM k (vm_fvar m)++lkDFreeVar :: Var -> DVarEnv a -> Maybe a+lkDFreeVar var env = lookupDVarEnv env var++xtDFreeVar :: Var -> XT a -> DVarEnv a -> DVarEnv a+xtDFreeVar v f m = alterDVarEnv f m v++ftVar :: (a -> Bool) -> VarMap a -> VarMap a+ftVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv }++-------------------------------------------------+lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a+lkDNamed n env = lookupDNameEnv env (getName n)++xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a+xtDNamed tc f m = alterDNameEnv f m (getName tc)

GHC/Core/Multiplicity.hs view

@@ -1,5 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE PatternSynonyms    #-}  {-| This module defines the semi-ring of multiplicities, and associated functions.

GHC/Core/Opt/Arity.hs view

@@ -15,1305 +15,1931 @@    ( manifestArity, joinRhsArity, exprArity, typeArity    , exprEtaExpandArity, findRhsArity    , etaExpand, etaExpandAT-   , etaExpandToJoinPoint, etaExpandToJoinPointRule-   , exprBotStrictness_maybe-   , ArityType(..), expandableArityType, arityTypeArity-   , maxWithArity, isBotArityType, idArityType-   )-where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils-import GHC.Core.Subst-import GHC.Types.Demand-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Id-import GHC.Core.Type as Type-import GHC.Core.TyCon     ( initRecTc, checkRecTc )-import GHC.Core.Predicate ( isDictTy )-import GHC.Core.Coercion as Coercion-import GHC.Core.Multiplicity-import GHC.Types.Var.Set-import GHC.Types.Basic-import GHC.Types.Unique-import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Utils.Misc     ( lengthAtLeast )--{--************************************************************************-*                                                                      *-              manifestArity and exprArity-*                                                                      *-************************************************************************--exprArity is a cheap-and-cheerful version of exprEtaExpandArity.-It tells how many things the expression can be applied to before doing-any work.  It doesn't look inside cases, lets, etc.  The idea is that-exprEtaExpandArity will do the hard work, leaving something that's easy-for exprArity to grapple with.  In particular, Simplify uses exprArity to-compute the ArityInfo for the Id.--Originally I thought that it was enough just to look for top-level lambdas, but-it isn't.  I've seen this--        foo = PrelBase.timesInt--We want foo to get arity 2 even though the eta-expander will leave it-unchanged, in the expectation that it'll be inlined.  But occasionally it-isn't, because foo is blacklisted (used in a rule).--Similarly, see the ok_note check in exprEtaExpandArity.  So-        f = __inline_me (\x -> e)-won't be eta-expanded.--And in any case it seems more robust to have exprArity be a bit more intelligent.-But note that   (\x y z -> f x y z)-should have arity 3, regardless of f's arity.--}--manifestArity :: CoreExpr -> Arity--- ^ manifestArity sees how many leading value lambdas there are,---   after looking through casts-manifestArity (Lam v e) | isId v        = 1 + manifestArity e-                        | otherwise     = manifestArity e-manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e-manifestArity (Cast e _)                = manifestArity e-manifestArity _                         = 0--joinRhsArity :: CoreExpr -> JoinArity--- Join points are supposed to have manifestly-visible--- lambdas at the top: no ticks, no casts, nothing--- Moreover, type lambdas count in JoinArity-joinRhsArity (Lam _ e) = 1 + joinRhsArity e-joinRhsArity _         = 0-------------------exprArity :: CoreExpr -> Arity--- ^ An approximate, fast, version of 'exprEtaExpandArity'-exprArity e = go e-  where-    go (Var v)                     = idArity v-    go (Lam x e) | isId x          = go e + 1-                 | otherwise       = go e-    go (Tick t e) | not (tickishIsCode t) = go e-    go (Cast e co)                 = trim_arity (go e) (coercionRKind co)-                                        -- Note [exprArity invariant]-    go (App e (Type _))            = go e-    go (App f a) | exprIsTrivial a = (go f - 1) `max` 0-        -- See Note [exprArity for applications]-        -- NB: coercions count as a value argument--    go _                           = 0--    trim_arity :: Arity -> Type -> Arity-    trim_arity arity ty = arity `min` length (typeArity ty)------------------typeArity :: Type -> [OneShotInfo]--- How many value arrows are visible in the type?--- We look through foralls, and newtypes--- See Note [exprArity invariant]-typeArity ty-  = go initRecTc ty-  where-    go rec_nts ty-      | Just (_, ty')  <- splitForAllTy_maybe ty-      = go rec_nts ty'--      | Just (_,arg,res) <- splitFunTy_maybe ty-      = typeOneShot arg : go rec_nts res--      | Just (tc,tys) <- splitTyConApp_maybe ty-      , Just (ty', _) <- instNewTyCon_maybe tc tys-      , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]-                                                -- in GHC.Core.TyCon---   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes---                              -- See Note [Newtype classes and eta expansion]---                              (no longer required)-      = go rec_nts' ty'-        -- Important to look through non-recursive newtypes, so that, eg-        --      (f x)   where f has arity 2, f :: Int -> IO ()-        -- Here we want to get arity 1 for the result!-        ---        -- AND through a layer of recursive newtypes-        -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))--      | otherwise-      = []------------------exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)--- A cheap and cheerful function that identifies bottoming functions--- and gives them a suitable strictness signatures.  It's used during--- float-out-exprBotStrictness_maybe e-  = case getBotArity (arityType env e) of-        Nothing -> Nothing-        Just ar -> Just (ar, sig ar)-  where-    env    = AE { ae_ped_bot = True-                , ae_cheap_fn = \ _ _ -> False-                , ae_joins = emptyVarSet }-    sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv--{--Note [exprArity invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~-exprArity has the following invariants:--  (1) If typeArity (exprType e) = n,-      then manifestArity (etaExpand e n) = n--      That is, etaExpand can always expand as much as typeArity says-      So the case analysis in etaExpand and in typeArity must match--  (2) exprArity e <= typeArity (exprType e)--  (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n--      That is, if exprArity says "the arity is n" then etaExpand really-      can get "n" manifest lambdas to the top.--Why is this important?  Because-  - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of-    each top-level Id, and in-  - In CorePrep we use etaExpand on each rhs, so that the visible lambdas-    actually match that arity, which in turn means-    that the StgRhs has the right number of lambdas--An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least-for top-level bindings, in which case we would not need the trim_arity-in exprArity.  That is a less local change, so I'm going to leave it for today!--Note [Newtype classes and eta expansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    NB: this nasty special case is no longer required, because-    for newtype classes we don't use the class-op rule mechanism-    at all.  See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013---------- Old out of date comments, just for interest ------------We have to be careful when eta-expanding through newtypes.  In general-it's a good idea, but annoyingly it interacts badly with the class-op-rule mechanism.  Consider--   class C a where { op :: a -> a }-   instance C b => C [b] where-     op x = ...--These translate to--   co :: forall a. (a->a) ~ C a--   $copList :: C b -> [b] -> [b]-   $copList d x = ...--   $dfList :: C b -> C [b]-   {-# DFunUnfolding = [$copList] #-}-   $dfList d = $copList d |> co@[b]--Now suppose we have:--   dCInt :: C Int--   blah :: [Int] -> [Int]-   blah = op ($dfList dCInt)--Now we want the built-in op/$dfList rule will fire to give-   blah = $copList dCInt--But with eta-expansion 'blah' might (and in #3772, which is-slightly more complicated, does) turn into--   blah = op (\eta. ($dfList dCInt |> sym co) eta)--and now it is *much* harder for the op/$dfList rule to fire, because-exprIsConApp_maybe won't hold of the argument to op.  I considered-trying to *make* it hold, but it's tricky and I gave up.--The test simplCore/should_compile/T3722 is an excellent example.--------- End of old out of date comments, just for interest --------------Note [exprArity for applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we come to an application we check that the arg is trivial.-   eg  f (fac x) does not have arity 2,-                 even if f has arity 3!--* We require that is trivial rather merely cheap.  Suppose f has arity 2.-  Then    f (Just y)-  has arity 0, because if we gave it arity 1 and then inlined f we'd get-          let v = Just y in \w. <f-body>-  which has arity 0.  And we try to maintain the invariant that we don't-  have arity decreases.--*  The `max 0` is important!  (\x y -> f x) has arity 2, even if f is-   unknown, hence arity 0---************************************************************************-*                                                                      *-           Computing the "arity" of an expression-*                                                                      *-************************************************************************--Note [Definition of arity]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The "arity" of an expression 'e' is n if-   applying 'e' to *fewer* than n *value* arguments-   converges rapidly--Or, to put it another way--   there is no work lost in duplicating the partial-   application (e x1 .. x(n-1))--In the divergent case, no work is lost by duplicating because if the thing-is evaluated once, that's the end of the program.--Or, to put it another way, in any context C--   C[ (\x1 .. xn. e x1 .. xn) ]-         is as efficient as-   C[ e ]--It's all a bit more subtle than it looks:--Note [One-shot lambdas]-~~~~~~~~~~~~~~~~~~~~~~~-Consider one-shot lambdas-                let x = expensive in \y z -> E-We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.--Note [Dealing with bottom]-~~~~~~~~~~~~~~~~~~~~~~~~~~-A Big Deal with computing arities is expressions like--   f = \x -> case x of-               True  -> \s -> e1-               False -> \s -> e2--This happens all the time when f :: Bool -> IO ()-In this case we do eta-expand, in order to get that \s to the-top, and give f arity 2.--This isn't really right in the presence of seq.  Consider-        (f bot) `seq` 1--This should diverge!  But if we eta-expand, it won't.  We ignore this-"problem" (unless -fpedantic-bottoms is on), because being scrupulous-would lose an important transformation for many programs. (See-#5587 for an example.)--Consider also-        f = \x -> error "foo"-Here, arity 1 is fine.  But if it is-        f = \x -> case x of-                        True  -> error "foo"-                        False -> \y -> x+y-then we want to get arity 2.  Technically, this isn't quite right, because-        (f True) `seq` 1-should diverge, but it'll converge if we eta-expand f.  Nevertheless, we-do so; it improves some programs significantly, and increasing convergence-isn't a bad thing.  Hence the ABot/ATop in ArityType.--So these two transformations aren't always the Right Thing, and we-have several tickets reporting unexpected behaviour resulting from-this transformation.  So we try to limit it as much as possible:-- (1) Do NOT move a lambda outside a known-bottom case expression-       case undefined of { (a,b) -> \y -> e }-     This showed up in #5557-- (2) Do NOT move a lambda outside a case if all the branches of-     the case are known to return bottom.-        case x of { (a,b) -> \y -> error "urk" }-     This case is less important, but the idea is that if the fn is-     going to diverge eventually anyway then getting the best arity-     isn't an issue, so we might as well play safe-- (3) Do NOT move a lambda outside a case unless-     (a) The scrutinee is ok-for-speculation, or-     (b) more liberally: the scrutinee is cheap (e.g. a variable), and-         -fpedantic-bottoms is not enforced (see #2915 for an example)--Of course both (1) and (2) are readily defeated by disguising the bottoms.--4. Note [Newtype arity]-~~~~~~~~~~~~~~~~~~~~~~~~-Non-recursive newtypes are transparent, and should not get in the way.-We do (currently) eta-expand recursive newtypes too.  So if we have, say--        newtype T = MkT ([T] -> Int)--Suppose we have-        e = coerce T f-where f has arity 1.  Then: etaExpandArity e = 1;-that is, etaExpandArity looks through the coerce.--When we eta-expand e to arity 1: eta_expand 1 e T-we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)--  HOWEVER, note that if you use coerce bogusly you can ge-        coerce Int negate-  And since negate has arity 2, you might try to eta expand.  But you can't-  decompose Int to a function type.   Hence the final case in eta_expand.--Note [The state-transformer hack]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-        f = e-where e has arity n.  Then, if we know from the context that f has-a usage type like-        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...-then we can expand the arity to m.  This usage type says that-any application (x e1 .. en) will be applied to uniquely to (m-n) more args-Consider f = \x. let y = <expensive>-                 in case x of-                      True  -> foo-                      False -> \(s:RealWorld) -> e-where foo has arity 1.  Then we want the state hack to-apply to foo too, so we can eta expand the case.--Then we expect that if f is applied to one arg, it'll be applied to two-(that's the hack -- we don't really know, and sometimes it's false)-See also Id.isOneShotBndr.--Note [State hack and bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's a terrible idea to use the state hack on a bottoming function.-Here's what happens (#2861):--  f :: String -> IO T-  f = \p. error "..."--Eta-expand, using the state hack:--  f = \p. (\s. ((error "...") |> g1) s) |> g2-  g1 :: IO T ~ (S -> (S,T))-  g2 :: (S -> (S,T)) ~ IO T--Extrude the g2--  f' = \p. \s. ((error "...") |> g1) s-  f = f' |> (String -> g2)--Discard args for bottomming function--  f' = \p. \s. ((error "...") |> g1 |> g3-  g3 :: (S -> (S,T)) ~ (S,T)--Extrude g1.g3--  f'' = \p. \s. (error "...")-  f' = f'' |> (String -> S -> g1.g3)--And now we can repeat the whole loop.  Aargh!  The bug is in applying the-state hack to a function which then swallows the argument.--This arose in another guise in #3959.  Here we had--     catch# (throw exn >> return ())--Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].-After inlining (>>) we get--     catch# (\_. throw {IO ()} exn)--We must *not* eta-expand to--     catch# (\_ _. throw {...} exn)--because 'catch#' expects to get a (# _,_ #) after applying its argument to-a State#, not another function!--In short, we use the state hack to allow us to push let inside a lambda,-but not to introduce a new lambda.---Note [ArityType]-~~~~~~~~~~~~~~~~-ArityType is the result of a compositional analysis on expressions,-from which we can decide the real arity of the expression (extracted-with function exprEtaExpandArity).--Here is what the fields mean. If an arbitrary expression 'f' has-ArityType 'at', then-- * If at = ABot n, then (f x1..xn) definitely diverges. Partial-   applications to fewer than n args may *or may not* diverge.--   We allow ourselves to eta-expand bottoming functions, even-   if doing so may lose some `seq` sharing,-       let x = <expensive> in \y. error (g x y)-       ==> \y. let x = <expensive> in error (g x y)-- * If at = ATop as, and n=length as,-   then expanding 'f' to (\x1..xn. f x1 .. xn) loses no sharing,-   assuming the calls of f respect the one-shot-ness of-   its definition.--   NB 'f' is an arbitrary expression, eg (f = g e1 e2).  This 'f'-   can have ArityType as ATop, with length as > 0, only if e1 e2 are-   themselves.-- * In both cases, f, (f x1), ... (f x1 ... f(n-1)) are definitely-   really functions, or bottom, but *not* casts from a data type, in-   at least one case branch.  (If it's a function in one case branch but-   an unsafe cast from a data type in another, the program is bogus.)-   So eta expansion is dynamically ok; see Note [State hack and-   bottoming functions], the part about catch#--Example:-      f = \x\y. let v = <expensive> in-          \s(one-shot) \t(one-shot). blah-      'f' has ArityType [ManyShot,ManyShot,OneShot,OneShot]-      The one-shot-ness means we can, in effect, push that-      'let' inside the \st.---Suppose f = \xy. x+y-Then  f             :: AT [False,False] ATop-      f v           :: AT [False]       ATop-      f <expensive> :: AT []            ATop---------------------- Main arity code ------------------------------}---data ArityType   -- See Note [ArityType]-  = ATop [OneShotInfo]-  | ABot Arity-  deriving( Eq )-     -- There is always an explicit lambda-     -- to justify the [OneShot], or the Arity--instance Outputable ArityType where-  ppr (ATop os) = text "ATop" <> parens (ppr (length os))-  ppr (ABot n)  = text "ABot" <> parens (ppr n)--arityTypeArity :: ArityType -> Arity--- The number of value args for the arity type-arityTypeArity (ATop oss) = length oss-arityTypeArity (ABot ar)  = ar--expandableArityType :: ArityType -> Bool--- True <=> eta-expansion will add at least one lambda-expandableArityType (ATop oss) = not (null oss)-expandableArityType (ABot ar)  = ar /= 0--isBotArityType :: ArityType -> Bool-isBotArityType (ABot {}) = True-isBotArityType (ATop {}) = False--arityTypeOneShots :: ArityType -> [OneShotInfo]-arityTypeOneShots (ATop oss) = oss-arityTypeOneShots (ABot ar)  = replicate ar OneShotLam-   -- If we are diveging or throwing an exception anyway-   -- it's fine to push redexes inside the lambdas--botArityType :: ArityType-botArityType = ABot 0   -- Unit for andArityType--maxWithArity :: ArityType -> Arity -> ArityType-maxWithArity at@(ABot {}) _   = at-maxWithArity at@(ATop oss) ar-     | oss `lengthAtLeast` ar = at-     | otherwise              = ATop (take ar (oss ++ repeat NoOneShotInfo))--vanillaArityType :: ArityType-vanillaArityType = ATop []      -- Totally uninformative---- ^ The Arity returned is the number of value args the--- expression can be applied to without doing much work-exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType--- exprEtaExpandArity is used when eta expanding---      e  ==>  \xy -> e x y-exprEtaExpandArity dflags e-  = arityType env e-  where-    env = AE { ae_cheap_fn = mk_cheap_fn dflags isCheapApp-             , ae_ped_bot  = gopt Opt_PedanticBottoms dflags-             , ae_joins    = emptyVarSet }--getBotArity :: ArityType -> Maybe Arity--- Arity of a divergent function-getBotArity (ABot n) = Just n-getBotArity _        = Nothing--mk_cheap_fn :: DynFlags -> CheapAppFun -> CheapFun-mk_cheap_fn dflags cheap_app-  | not (gopt Opt_DictsCheap dflags)-  = \e _     -> exprIsCheapX cheap_app e-  | otherwise-  = \e mb_ty -> exprIsCheapX cheap_app e-             || case mb_ty of-                  Nothing -> False-                  Just ty -> isDictTy ty--------------------------findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType--- This implements the fixpoint loop for arity analysis--- See Note [Arity analysis]--- If findRhsArity e = (n, is_bot) then---  (a) any application of e to <n arguments will not do much work,---      so it is safe to expand e  ==>  (\x1..xn. e x1 .. xn)---  (b) if is_bot=True, then e applied to n args is guaranteed bottom-findRhsArity dflags bndr rhs old_arity-  = go (get_arity init_cheap_app)-       -- We always call exprEtaExpandArity once, but usually-       -- that produces a result equal to old_arity, and then-       -- we stop right away (since arities should not decrease)-       -- Result: the common case is that there is just one iteration-  where-    init_cheap_app :: CheapAppFun-    init_cheap_app fn n_val_args-      | fn == bndr = True   -- On the first pass, this binder gets infinite arity-      | otherwise  = isCheapApp fn n_val_args--    go :: ArityType -> ArityType-    go cur_atype-      | cur_arity <= old_arity = cur_atype-      | new_atype == cur_atype = cur_atype-      | otherwise =-#if defined(DEBUG)-                    pprTrace "Exciting arity"-                       (vcat [ ppr bndr <+> ppr cur_atype <+> ppr new_atype-                             , ppr rhs])-#endif-                    go new_atype-      where-        new_atype = get_arity cheap_app--        cur_arity = arityTypeArity cur_atype-        cheap_app :: CheapAppFun-        cheap_app fn n_val_args-          | fn == bndr = n_val_args < cur_arity-          | otherwise  = isCheapApp fn n_val_args--    get_arity :: CheapAppFun -> ArityType-    get_arity cheap_app = arityType env rhs-      where-         env = AE { ae_cheap_fn = mk_cheap_fn dflags cheap_app-                  , ae_ped_bot  = gopt Opt_PedanticBottoms dflags-                  , ae_joins    = emptyVarSet }--{--Note [Arity analysis]-~~~~~~~~~~~~~~~~~~~~~-The motivating example for arity analysis is this:--  f = \x. let g = f (x+1)-          in \y. ...g...--What arity does f have?  Really it should have arity 2, but a naive-look at the RHS won't see that.  You need a fixpoint analysis which-says it has arity "infinity" the first time round.--This example happens a lot; it first showed up in Andy Gill's thesis,-fifteen years ago!  It also shows up in the code for 'rnf' on lists-in #4138.--The analysis is easy to achieve because exprEtaExpandArity takes an-argument-     type CheapFun = CoreExpr -> Maybe Type -> Bool-used to decide if an expression is cheap enough to push inside a-lambda.  And exprIsCheapX in turn takes an argument-     type CheapAppFun = Id -> Int -> Bool-which tells when an application is cheap. This makes it easy to-write the analysis loop.--The analysis is cheap-and-cheerful because it doesn't deal with-mutual recursion.  But the self-recursive case is the important one.--Note [Eta expanding through dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the experimental -fdicts-cheap flag is on, we eta-expand through-dictionary bindings.  This improves arities. Thereby, it also-means that full laziness is less prone to floating out the-application of a function to its dictionary arguments, which-can thereby lose opportunities for fusion.  Example:-        foo :: Ord a => a -> ...-     foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....-        -- So foo has arity 1--     f = \x. foo dInt $ bar x--The (foo DInt) is floated out, and makes ineffective a RULE-     foo (bar x) = ...--One could go further and make exprIsCheap reply True to any-dictionary-typed expression, but that's more work.--}--arityLam :: Id -> ArityType -> ArityType-arityLam id (ATop as) = ATop (idStateHackOneShotInfo id : as)-arityLam _  (ABot n)  = ABot (n+1)--floatIn :: Bool -> ArityType -> ArityType--- We have something like (let x = E in b),--- where b has the given arity type.-floatIn _     (ABot n)  = ABot n-floatIn True  (ATop as) = ATop as-floatIn False (ATop as) = ATop (takeWhile isOneShotInfo as)-   -- If E is not cheap, keep arity only for one-shots--arityApp :: ArityType -> Bool -> ArityType--- Processing (fun arg) where at is the ArityType of fun,--- Knock off an argument and behave like 'let'-arityApp (ABot 0)      _     = ABot 0-arityApp (ABot n)      _     = ABot (n-1)-arityApp (ATop [])     _     = ATop []-arityApp (ATop (_:as)) cheap = floatIn cheap (ATop as)--andArityType :: ArityType -> ArityType -> ArityType   -- Used for branches of a 'case'--- This is least upper bound in the ArityType lattice-andArityType (ABot n1) (ABot n2)  = ABot (n1 `max` n2) -- Note [ABot branches: use max]-andArityType (ATop as)  (ABot _)  = ATop as-andArityType (ABot _)   (ATop bs) = ATop bs-andArityType (ATop as)  (ATop bs) = ATop (as `combine` bs)-  where      -- See Note [Combining case branches]-    combine (a:as) (b:bs) = (a `bestOneShot` b) : combine as bs-    combine []     bs     = takeWhile isOneShotInfo bs-    combine as     []     = takeWhile isOneShotInfo as--{- Note [ABot branches: use max]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   case x of-             True  -> \x.  error "urk"-             False -> \xy. error "urk2"--Remember: ABot n means "if you apply to n args, it'll definitely diverge".-So we need (ABot 2) for the whole thing, the /max/ of the ABot arities.--Note [Combining case branches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  go = \x. let z = go e0-               go2 = \x. case x of-                           True  -> z-                           False -> \s(one-shot). e1-           in go2 x-We *really* want to eta-expand go and go2.-When combining the branches of the case we have-     ATop [] `andAT` ATop [OneShotLam]-and we want to get ATop [OneShotLam].  But if the inner-lambda wasn't one-shot we don't want to do this.-(We need a proper arity analysis to justify that.)--So we combine the best of the two branches, on the (slightly dodgy)-basis that if we know one branch is one-shot, then they all must be.--Note [Arity trimming]-~~~~~~~~~~~~~~~~~~~~~-Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and-F is some type family.--Because of Note [exprArity invariant], item (2), we must return with arity at-most 1, because typeArity (Int -> F a) = 1.  So we have to trim the result of-calling arityType on (\x y. blah).  Failing to do so, and hence breaking the-exprArity invariant, led to #5441.--How to trim?  For ATop, it's easy.  But we must take great care with ABot.-Suppose the expression was (\x y. error "urk"), we'll get (ABot 2).  We-absolutely must not trim that to (ABot 1), because that claims that-((\x y. error "urk") |> co) diverges when given one argument, which it-absolutely does not. And Bad Things happen if we think something returns bottom-when it doesn't (#16066).--So, do not reduce the 'n' in (ABot n); rather, switch (conservatively) to ATop.--Historical note: long ago, we unconditionally switched to ATop when we-encountered a cast, but that is far too conservative: see #5475--}------------------------------type CheapFun = CoreExpr -> Maybe Type -> Bool-        -- How to decide if an expression is cheap-        -- If the Maybe is Just, the type is the type-        -- of the expression; Nothing means "don't know"--data ArityEnv-  = AE { ae_cheap_fn :: CheapFun-       , ae_ped_bot  :: Bool       -- True <=> be pedantic about bottoms-       , ae_joins    :: IdSet      -- In-scope join points-                                   -- See Note [Eta-expansion and join points]-  }--extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv-extendJoinEnv env@(AE { ae_joins = joins }) join_ids-  = env { ae_joins = joins `extendVarSetList` join_ids }-------------------arityType :: ArityEnv -> CoreExpr -> ArityType--arityType env (Cast e co)-  = case arityType env e of-      ATop os -> ATop (take co_arity os)  -- See Note [Arity trimming]-      ABot n | co_arity < n -> ATop (replicate co_arity noOneShotInfo)-             | otherwise    -> ABot n-  where-    co_arity = length (typeArity (coercionRKind co))-    -- See Note [exprArity invariant] (2); must be true of-    -- arityType too, since that is how we compute the arity-    -- of variables, and they in turn affect result of exprArity-    -- #5441 is a nice demo-    -- However, do make sure that ATop -> ATop and ABot -> ABot!-    --   Casts don't affect that part. Getting this wrong provoked #5475--arityType env (Var v)-  | v `elemVarSet` ae_joins env-  = botArityType  -- See Note [Eta-expansion and join points]-  | otherwise-  = idArityType v--        -- Lambdas; increase arity-arityType env (Lam x e)-  | isId x    = arityLam x (arityType env e)-  | otherwise = arityType env e--        -- Applications; decrease arity, except for types-arityType env (App fun (Type _))-   = arityType env fun-arityType env (App fun arg )-   = arityApp (arityType env fun) (ae_cheap_fn env arg Nothing)--        -- Case/Let; keep arity if either the expression is cheap-        -- or it's a 1-shot lambda-        -- The former is not really right for Haskell-        --      f x = case x of { (a,b) -> \y. e }-        --  ===>-        --      f x y = case x of { (a,b) -> e }-        -- The difference is observable using 'seq'-        ---arityType env (Case scrut _ _ alts)-  | exprIsDeadEnd scrut || null alts-  = botArityType    -- Do not eta expand-                    -- See Note [Dealing with bottom (1)]-  | otherwise-  = case alts_type of-     ABot n  | n>0       -> ATop []       -- Don't eta expand-             | otherwise -> botArityType  -- if RHS is bottomming-                                          -- See Note [Dealing with bottom (2)]--     ATop as | not (ae_ped_bot env)    -- See Note [Dealing with bottom (3)]-             , ae_cheap_fn env scrut Nothing -> ATop as-             | exprOkForSpeculation scrut    -> ATop as-             | otherwise                     -> ATop (takeWhile isOneShotInfo as)-  where-    alts_type = foldr1 andArityType [arityType env rhs | (_,_,rhs) <- alts]--arityType env (Let (NonRec j rhs) body)-  | Just join_arity <- isJoinId_maybe j-  , (_, rhs_body)   <- collectNBinders join_arity rhs-  = -- See Note [Eta-expansion and join points]-    andArityType (arityType env rhs_body)-                 (arityType env' body)-  where-     env' = extendJoinEnv env [j]--arityType env (Let (Rec pairs) body)-  | ((j,_):_) <- pairs-  , isJoinId j-  = -- See Note [Eta-expansion and join points]-    foldr (andArityType . do_one) (arityType env' body) pairs-  where-    env' = extendJoinEnv env (map fst pairs)-    do_one (j,rhs)-      | Just arity <- isJoinId_maybe j-      = arityType env' $ snd $ collectNBinders arity rhs-      | otherwise-      = pprPanic "arityType:joinrec" (ppr pairs)--arityType env (Let b e)-  = floatIn (cheap_bind b) (arityType env e)-  where-    cheap_bind (NonRec b e) = is_cheap (b,e)-    cheap_bind (Rec prs)    = all is_cheap prs-    is_cheap (b,e) = ae_cheap_fn env e (Just (idType b))--arityType env (Tick t e)-  | not (tickishIsCode t)     = arityType env e--arityType _ _ = vanillaArityType--{- Note [Eta-expansion and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#18328)--  f x = join j y = case y of-                      True -> \a. blah-                      False -> \b. blah-        in case x of-              A -> j True-              B -> \c. blah-              C -> j False--and suppose the join point is too big to inline.  Now, what is the-arity of f?  If we inlined the join point, we'd definitely say "arity-2" because we are prepared to push case-scrutinisation inside a-lambda.  But currently the join point totally messes all that up,-because (thought of as a vanilla let-binding) the arity pinned on 'j'-is just 1.--Why don't we eta-expand j?  Because of-Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils--Even if we don't eta-expand j, why is its arity only 1?-See invariant 2b in Note [Invariants on join points] in GHC.Core.--So we do this:--* Treat the RHS of a join-point binding, /after/ stripping off-  join-arity lambda-binders, as very like the body of the let.-  More precisely, do andArityType with the arityType from the-  body of the let.--* Dually, when we come to a /call/ of a join point, just no-op-  by returning botArityType, the bottom element of ArityType,-  which so that: bot `andArityType` x = x--* This works if the join point is bound in the expression we are-  taking the arityType of.  But if it's bound further out, it makes-  no sense to say that (say) the arityType of (j False) is ABot 0.-  Bad things happen.  So we keep track of the in-scope join-point Ids-  in ae_join.--This will make f, above, have arity 2. Then, we'll eta-expand it thus:--  f x eta = (join j y = ... in case x of ...) eta--and the Simplify will automatically push that application of eta into-the join points.--An alternative (roughly equivalent) idea would be to carry an-environment mapping let-bound Ids to their ArityType.--}--idArityType :: Id -> ArityType-idArityType v-  | strict_sig <- idStrictness v-  , not $ isTopSig strict_sig-  , (ds, res) <- splitStrictSig strict_sig-  , let arity = length ds-  = if isDeadEndDiv res then ABot arity-                        else ATop (take arity one_shots)-  | otherwise-  = ATop (take (idArity v) one_shots)-  where-    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type-    one_shots = typeArity (idType v)--{--%************************************************************************-%*                                                                      *-              The main eta-expander-%*                                                                      *-%************************************************************************--We go for:-   f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym-                                 (n >= 0)--where (in both cases)--        * The xi can include type variables--        * The yi are all value variables--        * N is a NORMAL FORM (i.e. no redexes anywhere)-          wanting a suitable number of extra args.--The biggest reason for doing this is for cases like--        f = \x -> case x of-                    True  -> \y -> e1-                    False -> \y -> e2--Here we want to get the lambdas together.  A good example is the nofib-program fibheaps, which gets 25% more allocation if you don't do this-eta-expansion.--We may have to sandwich some coerces between the lambdas-to make the types work.   exprEtaExpandArity looks through coerces-when computing arity; and etaExpand adds the coerces as necessary when-actually computing the expansion.--Note [No crap in eta-expanded code]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The eta expander is careful not to introduce "crap".  In particular,-given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it-returns a CoreExpr satisfying the same invariant. See Note [Eta-expansion and the CorePrep invariants] in CorePrep.--This means the eta-expander has to do a bit of on-the-fly-simplification but it's not too hard.  The alternative, of relying on-a subsequent clean-up phase of the Simplifier to de-crapify the result,-means you can't really use it in CorePrep, which is painful.--Note [Eta expansion for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The no-crap rule is very tiresome to guarantee when-we have join points. Consider eta-expanding-   let j :: Int -> Int -> Bool-       j x = e-   in b--The simple way is-  \(y::Int). (let j x = e in b) y--The no-crap way is-  \(y::Int). let j' :: Int -> Bool-                 j' x = e y-             in b[j'/j] y-where I have written to stress that j's type has-changed.  Note that (of course!) we have to push the application-inside the RHS of the join as well as into the body.  AND if j-has an unfolding we have to push it into there too.  AND j might-be recursive...--So for now I'm abandoning the no-crap rule in this case. I think-that for the use in CorePrep it really doesn't matter; and if-it does, then CoreToStg.myCollectArgs will fall over.--(Moreover, I think that casts can make the no-crap rule fail too.)--Note [Eta expansion and SCCs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note that SCCs are not treated specially by etaExpand.  If we have-        etaExpand 2 (\x -> scc "foo" e)-        = (\xy -> (scc "foo" e) y)-So the costs of evaluating 'e' (not 'e y') are attributed to "foo"--Note [Eta expansion and source notes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-CorePrep puts floatable ticks outside of value applications, but not-type applications. As a result we might be trying to eta-expand an-expression like--  (src<...> v) @a--which we want to lead to code like--  \x -> src<...> v @a x--This means that we need to look through type applications and be ready-to re-add floats on the top.--Note [Eta expansion with ArityType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The etaExpandAT function takes an ArityType (not just an Arity) to-guide eta-expansion.  Why? Because we want to preserve one-shot info.-Consider-  foo = \x. case x of-              True  -> (\s{os}. blah) |> co-              False -> wubble-We'll get an ArityType for foo of (ATop [NoOneShot,OneShot]).--Then we want to eta-expand to-  foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co--That 'eta' binder is fresh, and we really want it to have the-one-shot flag from the inner \s{osf}.  By expanding with the-ArityType gotten from analysing the RHS, we achieve this neatly.--This makes a big difference to the one-shot monad trick;-see Note [The one-shot state monad trick] in GHC.Core.Unify.--}---- | @etaExpand n e@ returns an expression with--- the same meaning as @e@, but with arity @n@.------ Given:------ > e' = etaExpand n e------ We should have that:------ > ty = exprType e = exprType e'-etaExpand   :: Arity     -> CoreExpr -> CoreExpr-etaExpandAT :: ArityType -> CoreExpr -> CoreExpr--etaExpand   n  orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr-etaExpandAT at orig_expr = eta_expand (arityTypeOneShots at)      orig_expr-                           -- See Note [Eta expansion with ArityType]---- etaExpand arity e = res--- Then 'res' has at least 'arity' lambdas at the top--- See Note [Eta expansion with ArityType]------ etaExpand deals with for-alls. For example:---              etaExpand 1 E--- where  E :: forall a. a -> a--- would return---      (/\b. \y::a -> E b y)------ It deals with coerces too, though they are now rare--- so perhaps the extra code isn't worth it--eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr-eta_expand one_shots orig_expr-  = go one_shots orig_expr-  where-      -- Strip off existing lambdas and casts before handing off to mkEtaWW-      -- Note [Eta expansion and SCCs]-    go [] expr = expr-    go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss  body)-                                 | otherwise = Lam v (go oss1 body)-    go oss (Cast expr co) = Cast (go oss expr) co--    go oss expr-      = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $-        retick $ etaInfoAbs etas (etaInfoApp subst' sexpr etas)-      where-          in_scope = mkInScopeSet (exprFreeVars expr)-          (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)-          subst' = mkEmptySubst in_scope'--          -- Find ticks behind type apps.-          -- See Note [Eta expansion and source notes]-          (expr', args) = collectArgs expr-          (ticks, expr'') = stripTicksTop tickishFloatable expr'-          sexpr = foldl' App expr'' args-          retick expr = foldr mkTick expr ticks--                                -- Abstraction    Application----------------data EtaInfo = EtaVar Var       -- /\a. []        [] a-                                -- \x.  []        [] x-             | EtaCo Coercion   -- [] |> sym co   [] |> co--instance Outputable EtaInfo where-   ppr (EtaVar v) = text "EtaVar" <+> ppr v-   ppr (EtaCo co) = text "EtaCo"  <+> ppr co--pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]-pushCoercion co1 (EtaCo co2 : eis)-  | isReflCo co = eis-  | otherwise   = EtaCo co : eis-  where-    co = co1 `mkTransCo` co2--pushCoercion co eis = EtaCo co : eis-----------------etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr-etaInfoAbs []               expr = expr-etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)-etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)-----------------etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr--- (etaInfoApp s e eis) returns something equivalent to---             ((substExpr s e) `appliedto` eis)--etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis)-  = etaInfoApp (GHC.Core.Subst.extendSubstWithVar subst v1 v2) e eis--etaInfoApp subst (Cast e co1) eis-  = etaInfoApp subst e (pushCoercion co' eis)-  where-    co' = GHC.Core.Subst.substCo subst co1--etaInfoApp subst (Case e b ty alts) eis-  = Case (subst_expr subst e) b1 ty' alts'-  where-    (subst1, b1) = substBndr subst b-    alts' = map subst_alt alts-    ty'   = etaInfoAppTy (GHC.Core.Subst.substTy subst ty) eis-    subst_alt (con, bs, rhs) = (con, bs', etaInfoApp subst2 rhs eis)-              where-                 (subst2,bs') = substBndrs subst1 bs--etaInfoApp subst (Let b e) eis-  | not (isJoinBind b)-    -- See Note [Eta expansion for join points]-  = Let b' (etaInfoApp subst' e eis)-  where-    (subst', b') = substBindSC subst b--etaInfoApp subst (Tick t e) eis-  = Tick (substTickish subst t) (etaInfoApp subst e eis)--etaInfoApp subst expr _-  | (Var fun, _) <- collectArgs expr-  , Var fun' <- lookupIdSubst subst fun-  , isJoinId fun'-  = subst_expr subst expr--etaInfoApp subst e eis-  = go (subst_expr subst e) eis-  where-    go e []                  = e-    go e (EtaVar v    : eis) = go (App e (varToCoreExpr v)) eis-    go e (EtaCo co    : eis) = go (Cast e co) eis------------------etaInfoAppTy :: Type -> [EtaInfo] -> Type--- If                    e :: ty--- then   etaInfoApp e eis :: etaInfoApp ty eis-etaInfoAppTy ty []               = ty-etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis-etaInfoAppTy _  (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis------------------- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding--- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the--- free variables of @e@.------ Note that this function is entirely unconcerned about cost centres and other--- semantically-irrelevant source annotations, so call sites must take care to--- preserve that info. See Note [Eta expansion and SCCs].-mkEtaWW-  :: [OneShotInfo]-  -- ^ How many value arguments to eta-expand-  -> SDoc-  -- ^ The pretty-printed original expression, for warnings.-  -> InScopeSet-  -- ^ A super-set of the free vars of the expression to eta-expand.-  -> Type-  -> (InScopeSet, [EtaInfo])-  -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'.-  -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the-  -- fresh variables in 'EtaInfo'.--mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty-  = go 0 orig_oss empty_subst orig_ty []-  where-    empty_subst = mkEmptyTCvSubst in_scope--    go :: Int                -- For fresh names-       -> [OneShotInfo]      -- Number of value args to expand to-       -> TCvSubst -> Type   -- We are really looking at subst(ty)-       -> [EtaInfo]          -- Accumulating parameter-       -> (InScopeSet, [EtaInfo])-    go _ [] subst _ eis       -- See Note [exprArity invariant]-       ----------- Done!  No more expansion needed-       = (getTCvInScope subst, reverse eis)--    go n oss@(one_shot:oss1) subst ty eis       -- See Note [exprArity invariant]-       ----------- Forall types  (forall a. ty)-       | Just (tcv,ty') <- splitForAllTy_maybe ty-       , (subst', tcv') <- Type.substVarBndr subst tcv-       , let oss' | isTyVar tcv = oss-                  | otherwise   = oss1-         -- A forall can bind a CoVar, in which case-         -- we consume one of the [OneShotInfo]-       = go n oss' subst' ty' (EtaVar tcv' : eis)--       ----------- Function types  (t1 -> t2)-       | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty-       , not (isTypeLevPoly arg_ty)-          -- See Note [Levity polymorphism invariants] in GHC.Core-          -- See also test case typecheck/should_run/EtaExpandLevPoly--       , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)-          -- Avoid free vars of the original expression--       , let eta_id' = eta_id `setIdOneShotInfo` one_shot-       = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis)--       ----------- Newtypes-       -- Given this:-       --      newtype T = MkT ([T] -> Int)-       -- Consider eta-expanding this-       --      eta_expand 1 e T-       -- We want to get-       --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)-       | Just (co, ty') <- topNormaliseNewType_maybe ty-       , let co' = Coercion.substCo subst co-             -- Remember to apply the substitution to co (#16979)-             -- (or we could have applied to ty, but then-             --  we'd have had to zap it for the recursive call)-       = go n oss subst ty' (pushCoercion co' eis)--       | otherwise       -- We have an expression of arity > 0,-                         -- but its type isn't a function, or a binder-                         -- is levity-polymorphic-       = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )-         (getTCvInScope subst, reverse eis)-        -- This *can* legitimately happen:-        -- e.g.  coerce Int (\x. x) Essentially the programmer is-        -- playing fast and loose with types (Happy does this a lot).-        -- So we simply decline to eta-expand.  Otherwise we'd end up-        -- with an explicit lambda having a non-function type-----------------subst_expr :: Subst -> CoreExpr -> CoreExpr--- Apply a substitution to an expression.  We use substExpr--- not substExprSC (short-cutting substitution) because--- we may be changing the types of join points, so applying--- the in-scope set is necessary.------ ToDo: we could instead check if we actually *are*--- changing any join points' types, and if not use substExprSC.-subst_expr = substExpr--------------------- | Split an expression into the given number of binders and a body,--- eta-expanding if necessary. Counts value *and* type binders.-etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)-etaExpandToJoinPoint join_arity expr-  = go join_arity [] expr-  where-    go 0 rev_bs e         = (reverse rev_bs, e)-    go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e-    go n rev_bs e         = case etaBodyForJoinPoint n e of-                              (bs, e') -> (reverse rev_bs ++ bs, e')--etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule-etaExpandToJoinPointRule _ rule@(BuiltinRule {})-  = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))-      -- How did a local binding get a built-in rule anyway? Probably a plugin.-    rule-etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs-                                               , ru_args  = args })-  | need_args == 0-  = rule-  | need_args < 0-  = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)-  | otherwise-  = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args-         , ru_rhs = new_rhs }-  where-    need_args = join_arity - length args-    (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs-    new_args = varsToCoreExprs new_bndrs---- Adds as many binders as asked for; assumes expr is not a lambda-etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)-etaBodyForJoinPoint need_args body-  = go need_args (exprType body) (init_subst body) [] body-  where-    go 0 _  _     rev_bs e-      = (reverse rev_bs, e)-    go n ty subst rev_bs e-      | Just (tv, res_ty) <- splitForAllTy_maybe ty-      , let (subst', tv') = Type.substVarBndr subst tv-      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')-      | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty-      , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty)-      = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)-      | otherwise-      = pprPanic "etaBodyForJoinPoint" $ int need_args $$-                                         ppr body $$ ppr (exprType body)--    init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e))+   , exprBotStrictness_maybe++   -- ** ArityType+   , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType+   , arityTypeArity, maxWithArity, idArityType++   -- ** Join points+   , etaExpandToJoinPoint, etaExpandToJoinPointRule++   -- ** Coercions and casts+   , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg+   , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo+   )+where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Ppr++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Id++-- We have two sorts of substitution:+--   GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst+-- Both have substTy, substCo  Hence need for qualification+import GHC.Core.Subst    as Core+import GHC.Core.Type     as Type+import GHC.Core.Coercion as Type++import GHC.Core.DataCon+import GHC.Core.TyCon     ( tyConArity )+import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )+import GHC.Core.Predicate ( isDictTy )+import GHC.Core.Multiplicity+import GHC.Types.Var.Set+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Builtin.Uniques+import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Data.Pair+import GHC.Utils.Misc++{-+************************************************************************+*                                                                      *+              manifestArity and exprArity+*                                                                      *+************************************************************************++exprArity is a cheap-and-cheerful version of exprEtaExpandArity.+It tells how many things the expression can be applied to before doing+any work.  It doesn't look inside cases, lets, etc.  The idea is that+exprEtaExpandArity will do the hard work, leaving something that's easy+for exprArity to grapple with.  In particular, Simplify uses exprArity to+compute the ArityInfo for the Id.++Originally I thought that it was enough just to look for top-level lambdas, but+it isn't.  I've seen this++        foo = PrelBase.timesInt++We want foo to get arity 2 even though the eta-expander will leave it+unchanged, in the expectation that it'll be inlined.  But occasionally it+isn't, because foo is blacklisted (used in a rule).++Similarly, see the ok_note check in exprEtaExpandArity.  So+        f = __inline_me (\x -> e)+won't be eta-expanded.++And in any case it seems more robust to have exprArity be a bit more intelligent.+But note that   (\x y z -> f x y z)+should have arity 3, regardless of f's arity.+-}++manifestArity :: CoreExpr -> Arity+-- ^ manifestArity sees how many leading value lambdas there are,+--   after looking through casts+manifestArity (Lam v e) | isId v        = 1 + manifestArity e+                        | otherwise     = manifestArity e+manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e+manifestArity (Cast e _)                = manifestArity e+manifestArity _                         = 0++joinRhsArity :: CoreExpr -> JoinArity+-- Join points are supposed to have manifestly-visible+-- lambdas at the top: no ticks, no casts, nothing+-- Moreover, type lambdas count in JoinArity+joinRhsArity (Lam _ e) = 1 + joinRhsArity e+joinRhsArity _         = 0+++---------------+exprArity :: CoreExpr -> Arity+-- ^ An approximate, fast, version of 'exprEtaExpandArity'+exprArity e = go e+  where+    go (Var v)                     = idArity v+    go (Lam x e) | isId x          = go e + 1+                 | otherwise       = go e+    go (Tick t e) | not (tickishIsCode t) = go e+    go (Cast e co)                 = trim_arity (go e) (coercionRKind co)+                                        -- Note [exprArity invariant]+    go (App e (Type _))            = go e+    go (App f a) | exprIsTrivial a = (go f - 1) `max` 0+        -- See Note [exprArity for applications]+        -- NB: coercions count as a value argument++    go _                           = 0++    trim_arity :: Arity -> Type -> Arity+    trim_arity arity ty = arity `min` length (typeArity ty)++---------------+typeArity :: Type -> [OneShotInfo]+-- How many value arrows are visible in the type?+-- We look through foralls, and newtypes+-- See Note [exprArity invariant]+typeArity ty+  = go initRecTc ty+  where+    go rec_nts ty+      | Just (_, ty')  <- splitForAllTyCoVar_maybe ty+      = go rec_nts ty'++      | Just (_,arg,res) <- splitFunTy_maybe ty+      = typeOneShot arg : go rec_nts res++      | Just (tc,tys) <- splitTyConApp_maybe ty+      , Just (ty', _) <- instNewTyCon_maybe tc tys+      , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes]+                                                -- in GHC.Core.TyCon+--   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes+--                              -- See Note [Newtype classes and eta expansion]+--                              (no longer required)+      = go rec_nts' ty'+        -- Important to look through non-recursive newtypes, so that, eg+        --      (f x)   where f has arity 2, f :: Int -> IO ()+        -- Here we want to get arity 1 for the result!+        --+        -- AND through a layer of recursive newtypes+        -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))++      | otherwise+      = []++---------------+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, StrictSig)+-- A cheap and cheerful function that identifies bottoming functions+-- and gives them a suitable strictness signatures.  It's used during+-- float-out+exprBotStrictness_maybe e+  = case getBotArity (arityType botStrictnessArityEnv e) of+        Nothing -> Nothing+        Just ar -> Just (ar, sig ar)+  where+    sig ar = mkClosedStrictSig (replicate ar topDmd) botDiv++{-+Note [exprArity invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~+exprArity has the following invariants:++  (1) If typeArity (exprType e) = n,+      then manifestArity (etaExpand e n) = n++      That is, etaExpand can always expand as much as typeArity says+      So the case analysis in etaExpand and in typeArity must match++  (2) exprArity e <= typeArity (exprType e)++  (3) Hence if (exprArity e) = n, then manifestArity (etaExpand e n) = n++      That is, if exprArity says "the arity is n" then etaExpand really+      can get "n" manifest lambdas to the top.++Why is this important?  Because+  - In GHC.Iface.Tidy we use exprArity to fix the *final arity* of+    each top-level Id, and in+  - In CorePrep we use etaExpand on each rhs, so that the visible lambdas+    actually match that arity, which in turn means+    that the StgRhs has the right number of lambdas++An alternative would be to do the eta-expansion in GHC.Iface.Tidy, at least+for top-level bindings, in which case we would not need the trim_arity+in exprArity.  That is a less local change, so I'm going to leave it for today!++Note [Newtype classes and eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    NB: this nasty special case is no longer required, because+    for newtype classes we don't use the class-op rule mechanism+    at all.  See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013++-------- Old out of date comments, just for interest -----------+We have to be careful when eta-expanding through newtypes.  In general+it's a good idea, but annoyingly it interacts badly with the class-op+rule mechanism.  Consider++   class C a where { op :: a -> a }+   instance C b => C [b] where+     op x = ...++These translate to++   co :: forall a. (a->a) ~ C a++   $copList :: C b -> [b] -> [b]+   $copList d x = ...++   $dfList :: C b -> C [b]+   {-# DFunUnfolding = [$copList] #-}+   $dfList d = $copList d |> co@[b]++Now suppose we have:++   dCInt :: C Int++   blah :: [Int] -> [Int]+   blah = op ($dfList dCInt)++Now we want the built-in op/$dfList rule will fire to give+   blah = $copList dCInt++But with eta-expansion 'blah' might (and in #3772, which is+slightly more complicated, does) turn into++   blah = op (\eta. ($dfList dCInt |> sym co) eta)++and now it is *much* harder for the op/$dfList rule to fire, because+exprIsConApp_maybe won't hold of the argument to op.  I considered+trying to *make* it hold, but it's tricky and I gave up.++The test simplCore/should_compile/T3722 is an excellent example.+-------- End of old out of date comments, just for interest -----------+++Note [exprArity for applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come to an application we check that the arg is trivial.+   eg  f (fac x) does not have arity 2,+                 even if f has arity 3!++* We require that is trivial rather merely cheap.  Suppose f has arity 2.+  Then    f (Just y)+  has arity 0, because if we gave it arity 1 and then inlined f we'd get+          let v = Just y in \w. <f-body>+  which has arity 0.  And we try to maintain the invariant that we don't+  have arity decreases.++*  The `max 0` is important!  (\x y -> f x) has arity 2, even if f is+   unknown, hence arity 0+++************************************************************************+*                                                                      *+           Computing the "arity" of an expression+*                                                                      *+************************************************************************++Note [Definition of arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The "arity" of an expression 'e' is n if+   applying 'e' to *fewer* than n *value* arguments+   converges rapidly++Or, to put it another way++   there is no work lost in duplicating the partial+   application (e x1 .. x(n-1))++In the divergent case, no work is lost by duplicating because if the thing+is evaluated once, that's the end of the program.++Or, to put it another way, in any context C++   C[ (\x1 .. xn. e x1 .. xn) ]+         is as efficient as+   C[ e ]++It's all a bit more subtle than it looks:++Note [One-shot lambdas]+~~~~~~~~~~~~~~~~~~~~~~~+Consider one-shot lambdas+                let x = expensive in \y z -> E+We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.++Note [Dealing with bottom]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A Big Deal with computing arities is expressions like++   f = \x -> case x of+               True  -> \s -> e1+               False -> \s -> e2++This happens all the time when f :: Bool -> IO ()+In this case we do eta-expand, in order to get that \s to the+top, and give f arity 2.++This isn't really right in the presence of seq.  Consider+        (f bot) `seq` 1++This should diverge!  But if we eta-expand, it won't.  We ignore this+"problem" (unless -fpedantic-bottoms is on), because being scrupulous+would lose an important transformation for many programs. (See+#5587 for an example.)++Consider also+        f = \x -> error "foo"+Here, arity 1 is fine.  But if it is+        f = \x -> case x of+                        True  -> error "foo"+                        False -> \y -> x+y+then we want to get arity 2.  Technically, this isn't quite right, because+        (f True) `seq` 1+should diverge, but it'll converge if we eta-expand f.  Nevertheless, we+do so; it improves some programs significantly, and increasing convergence+isn't a bad thing.  Hence the ABot/ATop in ArityType.++So these two transformations aren't always the Right Thing, and we+have several tickets reporting unexpected behaviour resulting from+this transformation.  So we try to limit it as much as possible:++ (1) Do NOT move a lambda outside a known-bottom case expression+       case undefined of { (a,b) -> \y -> e }+     This showed up in #5557++ (2) Do NOT move a lambda outside a case unless+     (a) The scrutinee is ok-for-speculation, or+     (b) more liberally: the scrutinee is cheap (e.g. a variable), and+         -fpedantic-bottoms is not enforced (see #2915 for an example)++Of course both (1) and (2) are readily defeated by disguising the bottoms.++4. Note [Newtype arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Non-recursive newtypes are transparent, and should not get in the way.+We do (currently) eta-expand recursive newtypes too.  So if we have, say++        newtype T = MkT ([T] -> Int)++Suppose we have+        e = coerce T f+where f has arity 1.  Then: etaExpandArity e = 1;+that is, etaExpandArity looks through the coerce.++When we eta-expand e to arity 1: eta_expand 1 e T+we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)++  HOWEVER, note that if you use coerce bogusly you can ge+        coerce Int negate+  And since negate has arity 2, you might try to eta expand.  But you can't+  decompose Int to a function type.   Hence the final case in eta_expand.++Note [The state-transformer hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+        f = e+where e has arity n.  Then, if we know from the context that f has+a usage type like+        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...+then we can expand the arity to m.  This usage type says that+any application (x e1 .. en) will be applied to uniquely to (m-n) more args+Consider f = \x. let y = <expensive>+                 in case x of+                      True  -> foo+                      False -> \(s:RealWorld) -> e+where foo has arity 1.  Then we want the state hack to+apply to foo too, so we can eta expand the case.++Then we expect that if f is applied to one arg, it'll be applied to two+(that's the hack -- we don't really know, and sometimes it's false)+See also Id.isOneShotBndr.++Note [State hack and bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's a terrible idea to use the state hack on a bottoming function.+Here's what happens (#2861):++  f :: String -> IO T+  f = \p. error "..."++Eta-expand, using the state hack:++  f = \p. (\s. ((error "...") |> g1) s) |> g2+  g1 :: IO T ~ (S -> (S,T))+  g2 :: (S -> (S,T)) ~ IO T++Extrude the g2++  f' = \p. \s. ((error "...") |> g1) s+  f = f' |> (String -> g2)++Discard args for bottomming function++  f' = \p. \s. ((error "...") |> g1 |> g3+  g3 :: (S -> (S,T)) ~ (S,T)++Extrude g1.g3++  f'' = \p. \s. (error "...")+  f' = f'' |> (String -> S -> g1.g3)++And now we can repeat the whole loop.  Aargh!  The bug is in applying the+state hack to a function which then swallows the argument.++This arose in another guise in #3959.  Here we had++     catch# (throw exn >> return ())++Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].+After inlining (>>) we get++     catch# (\_. throw {IO ()} exn)++We must *not* eta-expand to++     catch# (\_ _. throw {...} exn)++because 'catch#' expects to get a (# _,_ #) after applying its argument to+a State#, not another function!++In short, we use the state hack to allow us to push let inside a lambda,+but not to introduce a new lambda.+++Note [ArityType]+~~~~~~~~~~~~~~~~+ArityType is the result of a compositional analysis on expressions,+from which we can decide the real arity of the expression (extracted+with function exprEtaExpandArity).++We use the following notation:+  at  ::= \o1..on.div+  div ::= T | x | ⊥+  o   ::= ? | 1+And omit the \. if n = 0. Examples:+  \?11.T stands for @AT [NoOneShotInfo,OneShotLam,OneShotLam] topDiv@+  ⊥      stands for @AT [] botDiv@+See the 'Outputable' instance for more information. It's pretty simple.++Here is what the fields mean. If an arbitrary expression 'f' has+ArityType 'at', then++ * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@+   definitely diverges. Partial applications to fewer than n args may *or+   may not* diverge.++   We allow ourselves to eta-expand bottoming functions, even+   if doing so may lose some `seq` sharing,+       let x = <expensive> in \y. error (g x y)+       ==> \y. let x = <expensive> in error (g x y)++ * If @at = AT [o1,..,on] topDiv@ (notation: \o1..on.T), then expanding 'f'+   to @\x1..xn. f x1..xn@ loses no sharing, assuming the calls of f respect+   the one-shot-ness o1..on of its definition.++   NB 'f' is an arbitrary expression, eg @f = g e1 e2@.  This 'f' can have+   arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves+   cheap.++ * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely+   really functions, or bottom, but *not* casts from a data type, in+   at least one case branch.  (If it's a function in one case branch but+   an unsafe cast from a data type in another, the program is bogus.)+   So eta expansion is dynamically ok; see Note [State hack and+   bottoming functions], the part about catch#++Example:+      f = \x\y. let v = <expensive> in+          \s(one-shot) \t(one-shot). blah+      'f' has arity type \??11.T+      The one-shot-ness means we can, in effect, push that+      'let' inside the \st.+++Suppose f = \xy. x+y+Then  f             :: \??.T+      f v           :: \?.T+      f <expensive> :: T+-}+++-- | The analysis lattice of arity analysis. It is isomorphic to+--+-- @+--    data ArityType'+--      = AEnd Divergence+--      | ALam OneShotInfo ArityType'+-- @+--+-- Which is easier to display the Hasse diagram for:+--+-- @+--  ALam OneShotLam at+--          |+--      AEnd topDiv+--          |+--  ALam NoOneShotInfo at+--          |+--      AEnd exnDiv+--          |+--      AEnd botDiv+-- @+--+-- where the @at@ fields of @ALam@ are inductively subject to the same order.+-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@.+--+-- Why the strange Top element? See Note [Combining case branches].+--+-- We rely on this lattice structure for fixed-point iteration in+-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].+data ArityType+  = AT ![OneShotInfo] !Divergence+  -- ^ @AT oss div@ means this value can safely be eta-expanded @length oss@+  -- times, provided use sites respect the 'OneShotInfo's in @oss@.+  -- A 'OneShotLam' annotation can come from two sources:+  --     * The user annotated a lambda as one-shot with 'GHC.Exts.oneShot'+  --     * It's from a lambda binder of a type affected by `-fstate-hack`.+  --       See 'idStateHackOneShotInfo'.+  -- In both cases, 'OneShotLam' should win over 'NoOneShotInfo', see+  -- Note [Combining case branches].+  --+  -- If @div@ is dead-ending ('isDeadEndDiv'), then application to+  -- @length os@ arguments will surely diverge, similar to the situation+  -- with 'DmdType'.+  deriving Eq++-- | This is the BNF of the generated output:+--+-- @+-- @+--+-- We format+-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and+-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively.+-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@.+-- If the one-shot info is empty, we omit the leading @\.@.+instance Outputable ArityType where+  ppr (AT oss div)+    | null oss  = pp_div div+    | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div+    where+      pp_div Diverges = char '⊥'+      pp_div ExnOrDiv = char 'x'+      pp_div Dunno    = char 'T'+      pp_os OneShotLam    = char '1'+      pp_os NoOneShotInfo = char '?'++mkBotArityType :: [OneShotInfo] -> ArityType+mkBotArityType oss = AT oss botDiv++botArityType :: ArityType+botArityType = mkBotArityType []++mkTopArityType :: [OneShotInfo] -> ArityType+mkTopArityType oss = AT oss topDiv++topArityType :: ArityType+topArityType = mkTopArityType []++-- | The number of value args for the arity type+arityTypeArity :: ArityType -> Arity+arityTypeArity (AT oss _) = length oss++-- | True <=> eta-expansion will add at least one lambda+expandableArityType :: ArityType -> Bool+expandableArityType at = arityTypeArity at /= 0++-- | See Note [Dead ends] in "GHC.Types.Demand".+-- Bottom implies a dead end.+isDeadEndArityType :: ArityType -> Bool+isDeadEndArityType (AT _ div) = isDeadEndDiv div++-- | Expand a non-bottoming arity type so that it has at least the given arity.+maxWithArity :: ArityType -> Arity -> ArityType+maxWithArity at@(AT oss div) !ar+  | isDeadEndArityType at    = at+  | oss `lengthAtLeast` ar   = at+  | otherwise                = AT (take ar $ oss ++ repeat NoOneShotInfo) div++-- | Trim an arity type so that it has at most the given arity.+-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if they end in+-- 'ABot'.+minWithArity :: ArityType -> Arity -> ArityType+minWithArity at@(AT oss _) ar+  | oss `lengthAtMost` ar = at+  | otherwise             = AT (take ar oss) topDiv++takeWhileOneShot :: ArityType -> ArityType+takeWhileOneShot (AT oss div)+  | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv+  | otherwise        = AT (takeWhile isOneShotInfo oss) div++-- | The Arity returned is the number of value args the+-- expression can be applied to without doing much work+exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType+-- exprEtaExpandArity is used when eta expanding+--      e  ==>  \xy -> e x y+exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e++getBotArity :: ArityType -> Maybe Arity+-- Arity of a divergent function+getBotArity (AT oss div)+  | isDeadEndDiv div = Just $ length oss+  | otherwise        = Nothing++----------------------+findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType+-- This implements the fixpoint loop for arity analysis+-- See Note [Arity analysis]+-- If findRhsArity e = (n, is_bot) then+--  (a) any application of e to <n arguments will not do much work,+--      so it is safe to expand e  ==>  (\x1..xn. e x1 .. xn)+--  (b) if is_bot=True, then e applied to n args is guaranteed bottom+findRhsArity dflags bndr rhs old_arity+  = go 0 botArityType+      -- We always do one step, but usually that produces a result equal to+      -- old_arity, and then we stop right away, because old_arity is assumed+      -- to be sound. In other words, arities should never decrease.+      -- Result: the common case is that there is just one iteration+  where+    go :: Int -> ArityType -> ArityType+    go !n cur_at@(AT oss div)+      | not (isDeadEndDiv div)           -- the "stop right away" case+      , length oss <= old_arity = cur_at -- from above+      | next_at == cur_at       = cur_at+      | otherwise               =+         -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]+         WARN( debugIsOn && n > 2, text "Exciting arity"+                                   $$ nest 2 (+                                        ppr bndr <+> ppr cur_at <+> ppr next_at+                                        $$ ppr rhs) )+         go (n+1) next_at+      where+        next_at = step cur_at++    step :: ArityType -> ArityType+    step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $+              arityType env rhs+      where+        env = extendSigEnv (findRhsArityEnv dflags) bndr at++{-+Note [Arity analysis]+~~~~~~~~~~~~~~~~~~~~~+The motivating example for arity analysis is this:++  f = \x. let g = f (x+1)+          in \y. ...g...++What arity does f have?  Really it should have arity 2, but a naive+look at the RHS won't see that.  You need a fixpoint analysis which+says it has arity "infinity" the first time round.++This example happens a lot; it first showed up in Andy Gill's thesis,+fifteen years ago!  It also shows up in the code for 'rnf' on lists+in #4138.++We do the necessary, quite simple fixed-point iteration in 'findRhsArity',+which assumes for a single binding 'ABot' on the first run and iterates+until it finds a stable arity type. Two wrinkles++* We often have to ask (see the Case or Let case of 'arityType') whether some+  expression is cheap. In the case of an application, that depends on the arity+  of the application head! That's why we have our own version of 'exprIsCheap',+  'myExprIsCheap', that will integrate the optimistic arity types we have on+  f and g into the cheapness check.++* Consider this (#18793)++    go = \ds. case ds of+           []     -> id+           (x:ys) -> let acc = go ys in+                     case blah of+                       True  -> acc+                       False -> \ x1 -> acc (negate x1)++  We must propagate go's optimistically large arity to @acc@, so that the+  tail call to @acc@ in the True branch has sufficient arity.  This is done+  by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case+  of 'arityType'.++Note [Exciting Arity]+~~~~~~~~~~~~~~~~~~~~~+The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost+all cases. To get notified of cases where we need an usual number of iterations,+we emit a warning in debug mode, so that we can investigate and make sure that+we really can't do better. It's a gross hack, but catches real bugs (#18870).++Now, which number is "unusual"? We pick n > 2. Here's a pretty common and+expected example that takes two iterations and would ruin the specificity+of the warning (from T18937):++  f :: [Int] -> Int -> Int+  f []     = id+  f (x:xs) = let y = sum [0..x]+             in \z -> f xs (y + z)++Fixed-point iteration starts with arity type ⊥ for f. After the first+iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally+'floatIn' the let-binding (see its bottom case).  After the second iteration,+we get arity type \?.T, e.g. arity 1, because now we are no longer allowed+to floatIn the non-cheap let-binding.  Which is all perfectly benign, but+means we do two iterations (well, actually 3 'step's to detect we are stable)+and don't want to emit the warning.++Note [Eta expanding through dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the experimental -fdicts-cheap flag is on, we eta-expand through+dictionary bindings.  This improves arities. Thereby, it also+means that full laziness is less prone to floating out the+application of a function to its dictionary arguments, which+can thereby lose opportunities for fusion.  Example:+        foo :: Ord a => a -> ...+     foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....+        -- So foo has arity 1++     f = \x. foo dInt $ bar x++The (foo DInt) is floated out, and makes ineffective a RULE+     foo (bar x) = ...++One could go further and make exprIsCheap reply True to any+dictionary-typed expression, but that's more work.+-}++arityLam :: Id -> ArityType -> ArityType+arityLam id (AT oss div) = AT (idStateHackOneShotInfo id : oss) div++floatIn :: Bool -> ArityType -> ArityType+-- We have something like (let x = E in b),+-- where b has the given arity type.+floatIn cheap at+  | isDeadEndArityType at || cheap = at+  -- If E is not cheap, keep arity only for one-shots+  | otherwise                      = takeWhileOneShot at++arityApp :: ArityType -> Bool -> ArityType+-- Processing (fun arg) where at is the ArityType of fun,+-- Knock off an argument and behave like 'let'+arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div)+arityApp at               _     = at++-- | Least upper bound in the 'ArityType' lattice.+-- See the haddocks on 'ArityType' for the lattice.+--+-- Used for branches of a @case@.+andArityType :: ArityType -> ArityType -> ArityType+andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2)+  | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2)+  = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches]+andArityType (AT []         div1) at2+  | isDeadEndDiv div1 = at2                  -- Note [ABot branches: max arity wins]+  | otherwise         = takeWhileOneShot at2 -- See Note [Combining case branches]+andArityType at1                  (AT []         div2)+  | isDeadEndDiv div2 = at1                  -- Note [ABot branches: max arity wins]+  | otherwise         = takeWhileOneShot at1 -- See Note [Combining case branches]++{- Note [ABot branches: max arity wins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   case x of+             True  -> \x.  error "urk"+             False -> \xy. error "urk2"++Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely diverge".+So we need \??.⊥ for the whole thing, the /max/ of both arities.++Note [Combining case branches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  go = \x. let z = go e0+               go2 = \x. case x of+                           True  -> z+                           False -> \s(one-shot). e1+           in go2 x+We *really* want to respect the one-shot annotation provided by the+user and eta-expand go and go2.+When combining the branches of the case we have+     T `andAT` \1.T+and we want to get \1.T.+But if the inner lambda wasn't one-shot (\?.T) we don't want to do this.+(We need a usage analysis to justify that.)++So we combine the best of the two branches, on the (slightly dodgy)+basis that if we know one branch is one-shot, then they all must be.+Surprisingly, this means that the one-shot arity type is effectively the top+element of the lattice.++Note [Arity trimming]+~~~~~~~~~~~~~~~~~~~~~+Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and+F is some type family.++Because of Note [exprArity invariant], item (2), we must return with arity at+most 1, because typeArity (Int -> F a) = 1.  So we have to trim the result of+calling arityType on (\x y. blah).  Failing to do so, and hence breaking the+exprArity invariant, led to #5441.++How to trim?  If we end in topDiv, it's easy.  But we must take great care with+dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"),+we'll get \??.⊥.  We absolutely must not trim that to \?.⊥, because that+claims that ((\x y. error "urk") |> co) diverges when given one argument,+which it absolutely does not. And Bad Things happen if we think something+returns bottom when it doesn't (#16066).++So, if we need to trim a dead-ending arity type, switch (conservatively) to+topDiv.++Historical note: long ago, we unconditionally switched to topDiv when we+encountered a cast, but that is far too conservative: see #5475+-}++---------------------------++-- | Each of the entry-points of the analyser ('arityType') has different+-- requirements. The entry-points are+--+--   1. 'exprBotStrictness_maybe'+--   2. 'exprEtaExpandArity'+--   3. 'findRhsArity'+--+-- For each of the entry-points, there is a separate mode that governs+--+--   1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'.+--   2. Whether we store arity signatures for non-recursive let-bindings,+--      accessed in 'extendSigEnv'/'lookupSigEnv'.+--      See Note [Arity analysis] why that's important.+--   3. Which expressions we consider cheap to float inside a lambda,+--      in 'myExprIsCheap'.+data AnalysisMode+  = BotStrictness+  -- ^ Used during 'exprBotStrictness_maybe'.+  | EtaExpandArity { am_ped_bot :: !Bool+                   , am_dicts_cheap :: !Bool }+  -- ^ Used for finding an expression's eta-expanding arity quickly, without+  -- fixed-point iteration ('exprEtaExpandArity').+  | FindRhsArity { am_ped_bot :: !Bool+                 , am_dicts_cheap :: !Bool+                 , am_sigs :: !(IdEnv ArityType) }+  -- ^ Used for regular, fixed-point arity analysis ('findRhsArity').+  --   See Note [Arity analysis] for details about fixed-point iteration.+  --   INVARIANT: Disjoint with 'ae_joins'.++data ArityEnv+  = AE+  { ae_mode   :: !AnalysisMode+  -- ^ The analysis mode. See 'AnalysisMode'.+  , ae_joins  :: !IdSet+  -- ^ In-scope join points. See Note [Eta-expansion and join points]+  --   INVARIANT: Disjoint with the domain of 'am_sigs' (if present).+  }++-- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms+-- and no application is ever considered cheap.+botStrictnessArityEnv :: ArityEnv+botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }++-- | The @ArityEnv@ used by 'exprEtaExpandArity'.+etaExpandArityEnv :: DynFlags -> ArityEnv+etaExpandArityEnv dflags+  = AE { ae_mode  = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags+                                   , am_dicts_cheap = gopt Opt_DictsCheap dflags }+       , ae_joins = emptyVarSet }++-- | The @ArityEnv@ used by 'findRhsArity'.+findRhsArityEnv :: DynFlags -> ArityEnv+findRhsArityEnv dflags+  = AE { ae_mode  = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags+                                 , am_dicts_cheap = gopt Opt_DictsCheap dflags+                                 , am_sigs = emptyVarEnv }+       , ae_joins = emptyVarSet }++-- First some internal functions in snake_case for deleting in certain VarEnvs+-- of the ArityType. Don't call these; call delInScope* instead!++modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv+modifySigEnv f env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } =+  env { ae_mode = am { am_sigs = f sigs } }+modifySigEnv _ env = env+{-# INLINE modifySigEnv #-}++del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal!+del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id)+{-# INLINE del_sig_env #-}++del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal!+del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids)+{-# INLINE del_sig_env_list #-}++del_join_env :: JoinId -> ArityEnv -> ArityEnv -- internal!+del_join_env id env@(AE { ae_joins = joins })+  = env { ae_joins = delVarSet joins id }+{-# INLINE del_join_env #-}++del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv -- internal!+del_join_env_list ids env@(AE { ae_joins = joins })+  = env { ae_joins = delVarSetList joins ids }+{-# INLINE del_join_env_list #-}++-- end of internal deletion functions++extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv+extendJoinEnv env@(AE { ae_joins = joins }) join_ids+  = del_sig_env_list join_ids+  $ env { ae_joins = joins `extendVarSetList` join_ids }++extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv+extendSigEnv env id ar_ty+  = del_join_env id (modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env)++delInScope :: ArityEnv -> Id -> ArityEnv+delInScope env id = del_join_env id $ del_sig_env id env++delInScopeList :: ArityEnv -> [Id] -> ArityEnv+delInScopeList env ids = del_join_env_list ids $ del_sig_env_list ids env++lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType+lookupSigEnv AE{ ae_mode = mode } id = case mode of+  BotStrictness                  -> Nothing+  EtaExpandArity{}               -> Nothing+  FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id++-- | Whether the analysis should be pedantic about bottoms.+-- 'exprBotStrictness_maybe' always is.+pedanticBottoms :: ArityEnv -> Bool+pedanticBottoms AE{ ae_mode = mode } = case mode of+  BotStrictness                          -> True+  EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot+  FindRhsArity{ am_ped_bot = ped_bot }   -> ped_bot++-- | A version of 'exprIsCheap' that considers results from arity analysis+-- and optionally the expression's type.+-- Under 'exprBotStrictness_maybe', no expressions are cheap.+myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool+myExprIsCheap AE{ae_mode = mode} e mb_ty = case mode of+  BotStrictness -> False+  _             -> cheap_dict || cheap_fun e+    where+      cheap_dict = am_dicts_cheap mode && fmap isDictTy mb_ty == Just True+      cheap_fun e = case mode of+#if __GLASGOW_HASKELL__ <= 900+        BotStrictness                -> panic "impossible"+#endif+        EtaExpandArity{}             -> exprIsCheap e+        FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) e++-- | A version of 'isCheapApp' that considers results from arity analysis.+-- See Note [Arity analysis] for what's in the signature environment and why+-- it's important.+myIsCheapApp :: IdEnv ArityType -> CheapAppFun+myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of+  -- Nothing means not a local function, fall back to regular+  -- 'GHC.Core.Utils.isCheapApp'+  Nothing         -> isCheapApp fn n_val_args+  -- @Just at@ means local function with @at@ as current ArityType.+  -- Roughly approximate what 'isCheapApp' is doing.+  Just (AT oss div)+    | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils+    | n_val_args < length oss -> True -- Essentially isWorkFreeApp+    | otherwise -> False++----------------+arityType :: ArityEnv -> CoreExpr -> ArityType++arityType env (Cast e co)+  = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]+  where+    co_arity = length (typeArity (coercionRKind co))+    -- See Note [exprArity invariant] (2); must be true of+    -- arityType too, since that is how we compute the arity+    -- of variables, and they in turn affect result of exprArity+    -- #5441 is a nice demo++arityType env (Var v)+  | v `elemVarSet` ae_joins env+  = botArityType  -- See Note [Eta-expansion and join points]+  | Just at <- lookupSigEnv env v -- Local binding+  = at+  | otherwise+  = idArityType v++        -- Lambdas; increase arity+arityType env (Lam x e)+  | isId x    = arityLam x (arityType env' e)+  | otherwise = arityType env' e+  where+    env' = delInScope env x++        -- Applications; decrease arity, except for types+arityType env (App fun (Type _))+   = arityType env fun+arityType env (App fun arg )+   = arityApp (arityType env fun) (myExprIsCheap env arg Nothing)++        -- Case/Let; keep arity if either the expression is cheap+        -- or it's a 1-shot lambda+        -- The former is not really right for Haskell+        --      f x = case x of { (a,b) -> \y. e }+        --  ===>+        --      f x y = case x of { (a,b) -> e }+        -- The difference is observable using 'seq'+        --+arityType env (Case scrut bndr _ alts)+  | exprIsDeadEnd scrut || null alts+  = botArityType    -- Do not eta expand. See Note [Dealing with bottom (1)]+  | not (pedanticBottoms env)  -- See Note [Dealing with bottom (2)]+  , myExprIsCheap env scrut (Just (idType bndr))+  = alts_type+  | exprOkForSpeculation scrut+  = alts_type++  | otherwise                  -- In the remaining cases we may not push+  = takeWhileOneShot alts_type -- evaluation of the scrutinee in+  where+    env' = delInScope env bndr+    arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs+    alts_type = foldr1 andArityType (map arity_type_alt alts)++arityType env (Let (NonRec j rhs) body)+  | Just join_arity <- isJoinId_maybe j+  , (_, rhs_body)   <- collectNBinders join_arity rhs+  = -- See Note [Eta-expansion and join points]+    andArityType (arityType env rhs_body)+                 (arityType env' body)+  where+     env' = extendJoinEnv env [j]++arityType env (Let (Rec pairs) body)+  | ((j,_):_) <- pairs+  , isJoinId j+  = -- See Note [Eta-expansion and join points]+    foldr (andArityType . do_one) (arityType env' body) pairs+  where+    env' = extendJoinEnv env (map fst pairs)+    do_one (j,rhs)+      | Just arity <- isJoinId_maybe j+      = arityType env' $ snd $ collectNBinders arity rhs+      | otherwise+      = pprPanic "arityType:joinrec" (ppr pairs)++arityType env (Let (NonRec b r) e)+  = floatIn cheap_rhs (arityType env' e)+  where+    cheap_rhs = myExprIsCheap env r (Just (idType b))+    env'      = extendSigEnv env b (arityType env r)++arityType env (Let (Rec prs) e)+  = floatIn (all is_cheap prs) (arityType env' e)+  where+    env'           = delInScopeList env (map fst prs)+    is_cheap (b,e) = myExprIsCheap env' e (Just (idType b))++arityType env (Tick t e)+  | not (tickishIsCode t)     = arityType env e++arityType _ _ = topArityType++{- Note [Eta-expansion and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#18328)++  f x = join j y = case y of+                      True -> \a. blah+                      False -> \b. blah+        in case x of+              A -> j True+              B -> \c. blah+              C -> j False++and suppose the join point is too big to inline.  Now, what is the+arity of f?  If we inlined the join point, we'd definitely say "arity+2" because we are prepared to push case-scrutinisation inside a+lambda.  But currently the join point totally messes all that up,+because (thought of as a vanilla let-binding) the arity pinned on 'j'+is just 1.++Why don't we eta-expand j?  Because of+Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils++Even if we don't eta-expand j, why is its arity only 1?+See invariant 2b in Note [Invariants on join points] in GHC.Core.++So we do this:++* Treat the RHS of a join-point binding, /after/ stripping off+  join-arity lambda-binders, as very like the body of the let.+  More precisely, do andArityType with the arityType from the+  body of the let.++* Dually, when we come to a /call/ of a join point, just no-op+  by returning ABot, the bottom element of ArityType,+  which so that: bot `andArityType` x = x++* This works if the join point is bound in the expression we are+  taking the arityType of.  But if it's bound further out, it makes+  no sense to say that (say) the arityType of (j False) is ABot.+  Bad things happen.  So we keep track of the in-scope join-point Ids+  in ae_join.++This will make f, above, have arity 2. Then, we'll eta-expand it thus:++  f x eta = (join j y = ... in case x of ...) eta++and the Simplify will automatically push that application of eta into+the join points.++An alternative (roughly equivalent) idea would be to carry an+environment mapping let-bound Ids to their ArityType.+-}++idArityType :: Id -> ArityType+idArityType v+  | strict_sig <- idStrictness v+  , not $ isTopSig strict_sig+  , (ds, div) <- splitStrictSig strict_sig+  , let arity = length ds+  -- Every strictness signature admits an arity signature!+  = AT (take arity one_shots) div+  | otherwise+  = AT (take (idArity v) one_shots) topDiv+  where+    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type+    one_shots = typeArity (idType v)++{-+%************************************************************************+%*                                                                      *+              The main eta-expander+%*                                                                      *+%************************************************************************++We go for:+   f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym+                                 (n >= 0)++where (in both cases)++        * The xi can include type variables++        * The yi are all value variables++        * N is a NORMAL FORM (i.e. no redexes anywhere)+          wanting a suitable number of extra args.++The biggest reason for doing this is for cases like++        f = \x -> case x of+                    True  -> \y -> e1+                    False -> \y -> e2++Here we want to get the lambdas together.  A good example is the nofib+program fibheaps, which gets 25% more allocation if you don't do this+eta-expansion.++We may have to sandwich some coerces between the lambdas+to make the types work.   exprEtaExpandArity looks through coerces+when computing arity; and etaExpand adds the coerces as necessary when+actually computing the expansion.++Note [No crap in eta-expanded code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The eta expander is careful not to introduce "crap".  In particular,+given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it+returns a CoreExpr satisfying the same invariant. See Note [Eta+expansion and the CorePrep invariants] in CorePrep.++This means the eta-expander has to do a bit of on-the-fly+simplification but it's not too hard.  The alternative, of relying on+a subsequent clean-up phase of the Simplifier to de-crapify the result,+means you can't really use it in CorePrep, which is painful.++Note [Eta expansion for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The no-crap rule is very tiresome to guarantee when+we have join points. Consider eta-expanding+   let j :: Int -> Int -> Bool+       j x = e+   in b++The simple way is+  \(y::Int). (let j x = e in b) y++The no-crap way is+  \(y::Int). let j' :: Int -> Bool+                 j' x = e y+             in b[j'/j] y+where I have written to stress that j's type has+changed.  Note that (of course!) we have to push the application+inside the RHS of the join as well as into the body.  AND if j+has an unfolding we have to push it into there too.  AND j might+be recursive...++So for now I'm abandoning the no-crap rule in this case. I think+that for the use in CorePrep it really doesn't matter; and if+it does, then CoreToStg.myCollectArgs will fall over.++(Moreover, I think that casts can make the no-crap rule fail too.)++Note [Eta expansion and SCCs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that SCCs are not treated specially by etaExpand.  If we have+        etaExpand 2 (\x -> scc "foo" e)+        = (\xy -> (scc "foo" e) y)+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"++Note [Eta expansion and source notes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrep puts floatable ticks outside of value applications, but not+type applications. As a result we might be trying to eta-expand an+expression like++  (src<...> v) @a++which we want to lead to code like++  \x -> src<...> v @a x++This means that we need to look through type applications and be ready+to re-add floats on the top.++Note [Eta expansion with ArityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The etaExpandAT function takes an ArityType (not just an Arity) to+guide eta-expansion.  Why? Because we want to preserve one-shot info.+Consider+  foo = \x. case x of+              True  -> (\s{os}. blah) |> co+              False -> wubble+We'll get an ArityType for foo of \?1.T.++Then we want to eta-expand to+  foo = \x. (\eta{os}. (case x of ...as before...) eta) |> some_co++That 'eta' binder is fresh, and we really want it to have the+one-shot flag from the inner \s{os}.  By expanding with the+ArityType gotten from analysing the RHS, we achieve this neatly.++This makes a big difference to the one-shot monad trick;+see Note [The one-shot state monad trick] in GHC.Utils.Monad.+-}++-- | @etaExpand n e@ returns an expression with+-- the same meaning as @e@, but with arity @n@.+--+-- Given:+--+-- > e' = etaExpand n e+--+-- We should have that:+--+-- > ty = exprType e = exprType e'+etaExpand   :: Arity     -> CoreExpr -> CoreExpr+etaExpandAT :: ArityType -> CoreExpr -> CoreExpr++etaExpand   n          orig_expr = eta_expand (replicate n NoOneShotInfo) orig_expr+etaExpandAT (AT oss _) orig_expr = eta_expand oss                         orig_expr+                           -- See Note [Eta expansion with ArityType]++-- etaExpand arity e = res+-- Then 'res' has at least 'arity' lambdas at the top+-- See Note [Eta expansion with ArityType]+--+-- etaExpand deals with for-alls. For example:+--              etaExpand 1 E+-- where  E :: forall a. a -> a+-- would return+--      (/\b. \y::a -> E b y)+--+-- It deals with coerces too, though they are now rare+-- so perhaps the extra code isn't worth it++eta_expand :: [OneShotInfo] -> CoreExpr -> CoreExpr+eta_expand one_shots orig_expr+  = go one_shots orig_expr+  where+      -- Strip off existing lambdas and casts before handing off to mkEtaWW+      -- Note [Eta expansion and SCCs]+    go [] expr = expr+    go oss@(_:oss1) (Lam v body) | isTyVar v = Lam v (go oss  body)+                                 | otherwise = Lam v (go oss1 body)+    go oss (Cast expr co) = Cast (go oss expr) co++    go oss expr+      = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, pprEtaInfos etas]) $+        retick $ etaInfoAbs etas (etaInfoApp in_scope' sexpr etas)+      where+          in_scope = mkInScopeSet (exprFreeVars expr)+          (in_scope', etas) = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)++          -- Find ticks behind type apps.+          -- See Note [Eta expansion and source notes]+          (expr', args) = collectArgs expr+          (ticks, expr'') = stripTicksTop tickishFloatable expr'+          sexpr = foldl' App expr'' args+          retick expr = foldr mkTick expr ticks++{- *********************************************************************+*                                                                      *+              The EtaInfo mechanism+          mkEtaWW, etaInfoAbs, etaInfoApp+*                                                                      *+********************************************************************* -}++{- Note [The EtaInfo mechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (e :: ty) and we want to eta-expand it to arity N.+This what eta_expand does.  We do it in two steps:++1.  mkEtaWW: from 'ty' and 'N' build a [EtaInfo] which describes+    the shape of the expansion necessary to expand to arity N.++2.  Build the term+       \ v1..vn.  e v1 .. vn+    where those abstractions and applications are described by+    the same [EtaInfo].  Specifically we build the term++       etaInfoAbs etas (etaInfoApp in_scope e etas)++   where etas :: [EtaInfo]#+         etaInfoAbs builds the lambdas+         etaInfoApp builds the applictions++   Note that the /same/ [EtaInfo] drives both etaInfoAbs and etaInfoApp++To a first approximation [EtaInfo] is just [Var].  But+casts complicate the question.  If we have+   newtype N a = MkN (S -> a)+and+   ty = N (N Int)+then the eta-expansion must look like+        (\x (\y. ((e |> co1) x) |> co2) y)+           |> sym co2)+        |> sym co1+where+  co1 :: N (N Int) ~ S -> N Int+  co2 :: N Int     ~ S -> Int++Blimey!  Look at all those casts.  Moreover, if the type+is very deeply nested (as happens in #18223), the repetition+of types can make the overall term very large.  So there is a big+payoff in cancelling out casts aggressively wherever possible.+(See also Note [No crap in eta-expanded code].)++This matters a lot in etaEInfoApp, where we+* Do beta-reduction on the fly+* Use getARg_mabye to get a cast out of the way,+  so that we can do beta reduction+Together this makes a big difference.  Consider when e is+   case x of+      True  -> (\x -> e1) |> c1+      False -> (\p -> e2) |> c2++When we eta-expand this to arity 1, say, etaInfoAbs will wrap+a (\eta) around the outside and use etaInfoApp to apply each+alternative to 'eta'.  We want to beta-reduce all that junk+away.++#18223 was a dramatic example in which the intermediate term was+grotesquely huge, even though the next Simplifier iteration squashed+it.  Better to kill it at birth.+-}++--------------+data EtaInfo            -- Abstraction      Application+  = EtaVar Var          -- /\a. []         [] a+                        -- (\x. [])        [] x+  | EtaCo CoercionR     -- [] |> sym co    [] |> co++instance Outputable EtaInfo where+   ppr (EtaVar v) = text "EtaVar" <+> ppr v  <+> dcolon <+> ppr (idType v)+   ppr (EtaCo co) = text "EtaCo"  <+> hang (ppr co) 2 (dcolon <+> ppr (coercionType co))++-- Used in debug-printing+-- pprEtaInfos :: [EtaInfo] -> SDoc+-- pprEtaInfos eis = brackets $ vcat $ punctuate comma $ map ppr eis++pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]+-- Puts a EtaCo on the front of a [EtaInfo], but combining+-- with an existing EtaCo if possible+-- A minor improvement+pushCoercion co1 (EtaCo co2 : eis)+  | isReflCo co = eis+  | otherwise   = EtaCo co : eis+  where+    co = co1 `mkTransCo` co2++pushCoercion co eis+  = EtaCo co : eis++getArg_maybe :: [EtaInfo] -> Maybe (CoreArg, [EtaInfo])+-- Get an argument to the front of the [EtaInfo], if possible,+-- by pushing any EtaCo through the argument+getArg_maybe eis = go MRefl eis+  where+    go :: MCoercion -> [EtaInfo] -> Maybe (CoreArg, [EtaInfo])+    go _         []                = Nothing+    go mco       (EtaCo co2 : eis) = go (mkTransMCoL mco co2) eis+    go MRefl     (EtaVar v : eis)  = Just (varToCoreExpr v, eis)+    go (MCo co)  (EtaVar v : eis)+      | Just (arg, mco) <- pushCoArg co (varToCoreExpr v)+      = case mco of+           MRefl  -> Just (arg, eis)+           MCo co -> Just (arg, pushCoercion co eis)+      | otherwise+      = Nothing++mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr+mkCastMCo e MRefl    = e+mkCastMCo e (MCo co) = Cast e co+  -- We are careful to use (MCo co) only when co is not reflexive+  -- Hence (Cast e co) rather than (mkCast e co)++mkPiMCo :: Var -> MCoercionR -> MCoercionR+mkPiMCo _  MRefl   = MRefl+mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)++--------------+etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr+-- See Note [The EtaInfo mechanism]+etaInfoAbs eis expr+  | null eis  = expr+  | otherwise = case final_mco of+                   MRefl  -> expr'+                   MCo co -> mkCast expr' co+  where+     (expr', final_mco) = foldr do_one (split_cast expr) eis++     do_one :: EtaInfo -> (CoreExpr, MCoercion) -> (CoreExpr, MCoercion)+     -- Implements the "Abstraction" column in the comments for data EtaInfo+     -- In both argument and result the pair (e,mco) denotes (e |> mco)+     do_one (EtaVar v) (expr, mco) = (Lam v expr, mkPiMCo v mco)+     do_one (EtaCo co) (expr, mco) = (expr, mco `mkTransMCoL` mkSymCo co)++     split_cast :: CoreExpr -> (CoreExpr, MCoercion)+     split_cast (Cast e co) = (e, MCo co)+     split_cast e           = (e, MRefl)+     -- We could look in the body of lets, and the branches of a case+     -- But then we would have to worry about whether the cast mentioned+     -- any of the bound variables, which is tiresome. Later maybe.+     -- Result: we may end up with+     --     (\(x::Int). case x of { DEFAULT -> e1 |> co }) |> sym (<Int>->co)+     -- and fail to optimise it away++--------------+etaInfoApp :: InScopeSet -> CoreExpr -> [EtaInfo] -> CoreExpr+-- (etaInfoApp s e eis) returns something equivalent to+--             (substExpr s e `appliedto` eis)+-- See Note [The EtaInfo mechanism]++etaInfoApp in_scope expr eis+  = go (mkEmptySubst in_scope) expr eis+  where+    go :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr+    -- 'go' pushed down the eta-infos into the branch of a case+    -- and the body of a let; and does beta-reduction if possible+    go subst (Tick t e) eis+      = Tick (substTickish subst t) (go subst e eis)+    go subst (Cast e co) eis+      = go subst e (pushCoercion (Core.substCo subst co) eis)+    go subst (Case e b ty alts) eis+      = Case (Core.substExprSC subst e) b1 ty' alts'+      where+        (subst1, b1) = Core.substBndr subst b+        alts' = map subst_alt alts+        ty'   = etaInfoAppTy (Core.substTy subst ty) eis+        subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis)+                 where+                    (subst2,bs') = Core.substBndrs subst1 bs+    go subst (Let b e) eis+      | not (isJoinBind b) -- See Note [Eta expansion for join points]+      = Let b' (go subst' e eis)+      where+        (subst', b') = Core.substBindSC subst b++    -- Beta-reduction if possible, using getArg_maybe to push+    -- any intervening casts past the argument+    -- See Note [The EtaInfo mechansim]+    go subst (Lam v e) eis+      | Just (arg, eis') <- getArg_maybe eis+      = go (Core.extendSubst subst v arg) e eis'++    -- Stop pushing down; just wrap the expression up+    go subst e eis = wrap (Core.substExprSC subst e) eis++    wrap e []               = e+    wrap e (EtaVar v : eis) = wrap (App e (varToCoreExpr v)) eis+    wrap e (EtaCo co : eis) = wrap (Cast e co) eis+++--------------+etaInfoAppTy :: Type -> [EtaInfo] -> Type+-- If                    e :: ty+-- then   etaInfoApp e eis :: etaInfoApp ty eis+etaInfoAppTy ty []               = ty+etaInfoAppTy ty (EtaVar v : eis) = etaInfoAppTy (applyTypeToArg ty (varToCoreExpr v)) eis+etaInfoAppTy _  (EtaCo co : eis) = etaInfoAppTy (coercionRKind co) eis++--------------+-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding+-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the+-- free variables of @e@.+--+-- Note that this function is entirely unconcerned about cost centres and other+-- semantically-irrelevant source annotations, so call sites must take care to+-- preserve that info. See Note [Eta expansion and SCCs].+mkEtaWW+  :: [OneShotInfo]+  -- ^ How many value arguments to eta-expand+  -> SDoc+  -- ^ The pretty-printed original expression, for warnings.+  -> InScopeSet+  -- ^ A super-set of the free vars of the expression to eta-expand.+  -> Type+  -> (InScopeSet, [EtaInfo])+  -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'.+  -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the+  -- fresh variables in 'EtaInfo'.++mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty+  = go 0 orig_oss empty_subst orig_ty []+  where+    empty_subst = mkEmptyTCvSubst in_scope++    go :: Int                -- For fresh names+       -> [OneShotInfo]      -- Number of value args to expand to+       -> TCvSubst -> Type   -- We are really looking at subst(ty)+       -> [EtaInfo]          -- Accumulating parameter+       -> (InScopeSet, [EtaInfo])+    go _ [] subst _ eis       -- See Note [exprArity invariant]+       ----------- Done!  No more expansion needed+       = (getTCvInScope subst, reverse eis)++    go n oss@(one_shot:oss1) subst ty eis       -- See Note [exprArity invariant]+       ----------- Forall types  (forall a. ty)+       | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty+       , (subst', tcv') <- Type.substVarBndr subst tcv+       , let oss' | isTyVar tcv = oss+                  | otherwise   = oss1+         -- A forall can bind a CoVar, in which case+         -- we consume one of the [OneShotInfo]+       = go n oss' subst' ty' (EtaVar tcv' : eis)++       ----------- Function types  (t1 -> t2)+       | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty+       , not (isTypeLevPoly arg_ty)+          -- See Note [Levity polymorphism invariants] in GHC.Core+          -- See also test case typecheck/should_run/EtaExpandLevPoly++       , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)+          -- Avoid free vars of the original expression++       , let eta_id' = eta_id `setIdOneShotInfo` one_shot+       = go (n+1) oss1 subst' res_ty (EtaVar eta_id' : eis)++       ----------- Newtypes+       -- Given this:+       --      newtype T = MkT ([T] -> Int)+       -- Consider eta-expanding this+       --      eta_expand 1 e T+       -- We want to get+       --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)+       | Just (co, ty') <- topNormaliseNewType_maybe ty+       , let co' = Type.substCo subst co+             -- Remember to apply the substitution to co (#16979)+             -- (or we could have applied to ty, but then+             --  we'd have had to zap it for the recursive call)+       = go n oss subst ty' (pushCoercion co' eis)++       | otherwise       -- We have an expression of arity > 0,+                         -- but its type isn't a function, or a binder+                         -- is levity-polymorphic+       = WARN( True, (ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr )+         (getTCvInScope subst, reverse eis)+        -- This *can* legitimately happen:+        -- e.g.  coerce Int (\x. x) Essentially the programmer is+        -- playing fast and loose with types (Happy does this a lot).+        -- So we simply decline to eta-expand.  Otherwise we'd end up+        -- with an explicit lambda having a non-function type+++{- *********************************************************************+*                                                                      *+              The "push rules"+*                                                                      *+************************************************************************++Here we implement the "push rules" from FC papers:++* The push-argument rules, where we can move a coercion past an argument.+  We have+      (fun |> co) arg+  and we want to transform it to+    (fun arg') |> co'+  for some suitable co' and transformed arg'.++* The PushK rule for data constructors.  We have+       (K e1 .. en) |> co+  and we want to transform to+       (K e1' .. en')+  by pushing the coercion into the arguments+-}++pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)+pushCoArgs co []         = return ([], MCo co)+pushCoArgs co (arg:args) = do { (arg',  m_co1) <- pushCoArg  co  arg+                              ; case m_co1 of+                                  MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args+                                                 ; return (arg':args', m_co2) }+                                  MRefl  -> return (arg':args, MRefl) }++pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)+-- We have (fun |> co) arg, and we want to transform it to+--         (fun arg) |> co+-- This may fail, e.g. if (fun :: N) where N is a newtype+-- C.f. simplCast in GHC.Core.Opt.Simplify+-- 'co' is always Representational+-- If the returned coercion is Nothing, then it would have been reflexive+pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty+                            ; return (Type ty', m_co') }+pushCoArg co val_arg   = do { (arg_co, m_co') <- pushCoValArg co+                            ; return (val_arg `mkCastMCo` arg_co, m_co') }++pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)+-- We have (fun |> co) @ty+-- Push the coercion through to return+--         (fun @ty') |> co'+-- 'co' is always Representational+-- If the returned coercion is Nothing, then it would have been reflexive;+-- it's faster not to compute it, though.+pushCoTyArg co ty+  -- The following is inefficient - don't do `eqType` here, the coercion+  -- optimizer will take care of it. See #14737.+  -- -- | tyL `eqType` tyR+  -- -- = Just (ty, Nothing)++  | isReflCo co+  = Just (ty, MRefl)++  | isForAllTy_ty tyL+  = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )+    Just (ty `mkCastTy` co1, MCo co2)++  | otherwise+  = Nothing+  where+    Pair tyL tyR = coercionKind co+       -- co :: tyL ~ tyR+       -- tyL = forall (a1 :: k1). ty1+       -- tyR = forall (a2 :: k2). ty2++    co1 = mkSymCo (mkNthCo Nominal 0 co)+       -- co1 :: k2 ~N k1+       -- Note that NthCo can extract a Nominal equality between the+       -- kinds of the types related by a coercion between forall-types.+       -- See the NthCo case in GHC.Core.Lint.++    co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)+        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]+        -- Arg of mkInstCo is always nominal, hence mkNomReflCo++pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)+-- We have (fun |> co) arg+-- Push the coercion through to return+--         (fun (arg |> co_arg)) |> co_res+-- 'co' is always Representational+-- If the second returned Coercion is actually Nothing, then no cast is necessary;+-- the returned coercion would have been reflexive.+pushCoValArg co+  -- The following is inefficient - don't do `eqType` here, the coercion+  -- optimizer will take care of it. See #14737.+  -- -- | tyL `eqType` tyR+  -- -- = Just (mkRepReflCo arg, Nothing)++  | isReflCo co+  = Just (MRefl, MRefl)++  | isFunTy tyL+  , (co_mult, co1, co2) <- decomposeFunCo Representational co+  , isReflexiveCo co_mult+    -- We can't push the coercion in the case where co_mult isn't reflexivity:+    -- it could be an unsafe axiom, and losing this information could yield+    -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x)+    -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int+    -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed++              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)+              -- then co1 :: tyL1 ~ tyR1+              --      co2 :: tyL2 ~ tyR2+  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )+    Just (coToMCo (mkSymCo co1), coToMCo co2)+    -- Critically, coToMCo to checks for ReflCo; the whole coercion may not+    -- be reflexive, but either of its components might be+    -- We could use isReflexiveCo, but it's not clear if the benefit+    -- is worth the cost, and it makes no difference in #18223++  | otherwise+  = Nothing+  where+    arg = funArgTy tyR+    Pair tyL tyR = coercionKind co++pushCoercionIntoLambda+    :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)+-- This implements the Push rule from the paper on coercions+--    (\x. e) |> co+-- ===>+--    (\x'. e |> co')+pushCoercionIntoLambda in_scope x e co+    | ASSERT(not (isTyVar x) && not (isCoVar x)) True+    , Pair s1s2 t1t2 <- coercionKind co+    , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2+    , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2+    , (co_mult, co1, co2) <- decomposeFunCo Representational co+    , isReflexiveCo co_mult+      -- We can't push the coercion in the case where co_mult isn't+      -- reflexivity. See pushCoValArg for more details.+    = let+          -- Should we optimize the coercions here?+          -- Otherwise they might not match too well+          x' = x `setIdType` t1 `setIdMult` w1+          in_scope' = in_scope `extendInScopeSet` x'+          subst = extendIdSubst (mkEmptySubst in_scope')+                                x+                                (mkCast (Var x') co1)+      in Just (x', substExpr subst e `mkCast` co2)+    | otherwise+    = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))+      Nothing++pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion+              -> Maybe (DataCon+                       , [Type]      -- Universal type args+                       , [CoreExpr]) -- All other args incl existentials+-- Implement the KPush reduction rule as described in "Down with kinds"+-- The transformation applies iff we have+--      (C e1 ... en) `cast` co+-- where co :: (T t1 .. tn) ~ to_ty+-- The left-hand one must be a T, because exprIsConApp returned True+-- but the right-hand one might not be.  (Though it usually will.)+pushCoDataCon dc dc_args co+  | isReflCo co || from_ty `eqType` to_ty  -- try cheap test first+  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args+  = Just (dc, map exprToType univ_ty_args, rest_args)++  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty+  , to_tc == dataConTyCon dc+        -- These two tests can fail; we might see+        --      (C x y) `cast` (g :: T a ~ S [a]),+        -- where S is a type function.  In fact, exprIsConApp+        -- will probably not be called in such circumstances,+        -- but there's nothing wrong with it++  = let+        tc_arity       = tyConArity to_tc+        dc_univ_tyvars = dataConUnivTyVars dc+        dc_ex_tcvars   = dataConExTyCoVars dc+        arg_tys        = dataConRepArgTys dc++        non_univ_args  = dropList dc_univ_tyvars dc_args+        (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args++        -- Make the "Psi" from the paper+        omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc)+        (psi_subst, to_ex_arg_tys)+          = liftCoSubstWithEx Representational+                              dc_univ_tyvars+                              omegas+                              dc_ex_tcvars+                              (map exprToType ex_args)++          -- Cast the value arguments (which include dictionaries)+        new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args+        cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)++        to_ex_args = map Type to_ex_arg_tys++        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tcvars,+                         ppr arg_tys, ppr dc_args,+                         ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc+                         , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]+    in+    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )+    ASSERT2( equalLength val_args arg_tys, dump_doc )+    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)++  | otherwise+  = Nothing++  where+    Pair from_ty to_ty = coercionKind co++collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)+-- Collect lambda binders, pushing coercions inside if possible+-- E.g.   (\x.e) |> g         g :: <Int> -> blah+--        = (\x. e |> Nth 1 g)+--+-- That is,+--+-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)+collectBindersPushingCo e+  = go [] e+  where+    -- Peel off lambdas until we hit a cast.+    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)+    -- The accumulator is in reverse order+    go bs (Lam b e)   = go (b:bs) e+    go bs (Cast e co) = go_c bs e co+    go bs e           = (reverse bs, e)++    -- We are in a cast; peel off casts until we hit a lambda.+    go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)+    -- (go_c bs e c) is same as (go bs e (e |> c))+    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)+    go_c bs (Lam b e)    co  = go_lam bs b e co+    go_c bs e            co  = (reverse bs, mkCast e co)++    -- We are in a lambda under a cast; peel off lambdas and build a+    -- new coercion for the body.+    go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)+    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)+    go_lam bs b e co+      | isTyVar b+      , let Pair tyL tyR = coercionKind co+      , ASSERT( isForAllTy_ty tyL )+        isForAllTy_ty tyR+      , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))++      | isCoVar b+      , let Pair tyL tyR = coercionKind co+      , ASSERT( isForAllTy_co tyL )+        isForAllTy_co tyR+      , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]+      , let cov = mkCoVarCo b+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))++      | isId b+      , let Pair tyL tyR = coercionKind co+      , ASSERT( isFunTy tyL) isFunTy tyR+      , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co+      , isReflCo co_mult -- See Note [collectBindersPushingCo]+      , isReflCo co_arg  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e co_res++      | otherwise = (reverse bs, mkCast (Lam b e) co)++{-++Note [collectBindersPushingCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We just look for coercions of form+   <type> # w -> blah+(and similarly for foralls) to keep this function simple.  We could do+more elaborate stuff, but it'd involve substitution etc.++-}++{- *********************************************************************+*                                                                      *+                Join points+*                                                                      *+********************************************************************* -}++-------------------+-- | Split an expression into the given number of binders and a body,+-- eta-expanding if necessary. Counts value *and* type binders.+etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)+etaExpandToJoinPoint join_arity expr+  = go join_arity [] expr+  where+    go 0 rev_bs e         = (reverse rev_bs, e)+    go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e+    go n rev_bs e         = case etaBodyForJoinPoint n e of+                              (bs, e') -> (reverse rev_bs ++ bs, e')++etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule+etaExpandToJoinPointRule _ rule@(BuiltinRule {})+  = WARN(True, (sep [text "Can't eta-expand built-in rule:", ppr rule]))+      -- How did a local binding get a built-in rule anyway? Probably a plugin.+    rule+etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs+                                               , ru_args  = args })+  | need_args == 0+  = rule+  | need_args < 0+  = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)+  | otherwise+  = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args+         , ru_rhs = new_rhs }+  where+    need_args = join_arity - length args+    (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs+    new_args = varsToCoreExprs new_bndrs++-- Adds as many binders as asked for; assumes expr is not a lambda+etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)+etaBodyForJoinPoint need_args body+  = go need_args (exprType body) (init_subst body) [] body+  where+    go 0 _  _     rev_bs e+      = (reverse rev_bs, e)+    go n ty subst rev_bs e+      | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty+      , let (subst', tv') = substVarBndr subst tv+      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')+      | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty+      , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty)+      = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)+      | otherwise+      = pprPanic "etaBodyForJoinPoint" $ int need_args $$+                                         ppr body $$ ppr (exprType body)++    init_subst e = mkEmptyTCvSubst (mkInScopeSet (exprFreeVars e))++  -------------- freshEtaId :: Int -> TCvSubst -> Scaled Type -> (TCvSubst, Id)

GHC/Core/Opt/CSE.hs view

@@ -18,7 +18,7 @@ import GHC.Core.Subst import GHC.Types.Var    ( Var ) import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Id     ( Id, idType, idHasRules+import GHC.Types.Id     ( Id, idType, idHasRules, zapStableUnfolding                         , idInlineActivation, setInlineActivation                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma                         , isJoinId, isJoinId_maybe )@@ -30,8 +30,10 @@ import GHC.Core import GHC.Utils.Outputable import GHC.Types.Basic-import GHC.Core.Map+import GHC.Types.Tickish+import GHC.Core.Map.Expr import GHC.Utils.Misc   ( filterOut, equalLength, debugIsOn )+import GHC.Utils.Panic import Data.List        ( mapAccumL )  {-@@ -235,8 +237,8 @@  Nor do we want to change the reverse mapping. Suppose we have -   {-# Unf = Stable (\pq. build blah) #-}-   foo = <expr>+   foo {-# Unf = Stable (\pq. build blah) #-}+       = <expr>    bar = <expr>  There could conceivably be merit in rewriting the RHS of bar:@@ -249,6 +251,23 @@ In this case we still want to do CSE (#13340). Hence the use of isAnyInlinePragma rather than isStableUnfolding. +Now consider+   foo = <expr>+   bar {-# Unf = Stable ... #-}+      = <expr>++where the unfolding was added by strictness analysis, say.  Then+CSE goes ahead, so we get+   bar = foo+and probably use SUBSTITUTE that will make 'bar' dead.  But just+possibly not -- see Note [Dealing with ticks].  In that case we might+be left with+   bar = tick t1 (tick t2 foo)+in which case we would really like to get rid of the stable unfolding+(generated by the strictness analyser, say).  Hence the zapStableUnfolding+in cse_bind.  Not a big deal, and only makes a difference when ticks+get into the picture.+ Note [Corner case for case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is another reason that we do not use SUBSTITUTE for@@ -388,9 +407,10 @@   | otherwise   = (env', (out_id'', out_rhs))   where-    (env', out_id') = addBinding env in_id out_id out_rhs-    (cse_done, out_rhs) = try_for_cse env in_rhs-    out_id'' | cse_done  = delayInlining toplevel out_id'+    (env', out_id') = addBinding env in_id out_id out_rhs cse_done+    (cse_done, out_rhs)  = try_for_cse env in_rhs+    out_id'' | cse_done  = zapStableUnfolding $+                           delayInlining toplevel out_id'              | otherwise = out_id'  delayInlining :: TopLevelFlag -> Id -> Id@@ -408,19 +428,23 @@   | otherwise   = bndr -addBinding :: CSEnv                      -- Includes InId->OutId cloning-           -> InVar                      -- Could be a let-bound type-           -> OutId -> OutExpr           -- Processed binding-           -> (CSEnv, OutId)             -- Final env, final bndr+addBinding :: CSEnv            -- Includes InId->OutId cloning+           -> InVar            -- Could be a let-bound type+           -> OutId -> OutExpr -- Processed binding+           -> Bool             -- True <=> RHS was CSE'd and is a variable+                               --          or maybe (Tick t variable)+           -> (CSEnv, OutId)   -- Final env, final bndr -- Extend the CSE env with a mapping [rhs -> out-id] -- unless we can instead just substitute [in-id -> rhs] -- -- It's possible for the binder to be a type variable (see -- Note [Type-let] in GHC.Core), in which case we can just substitute.-addBinding env in_id out_id rhs'+addBinding env in_id out_id rhs' cse_done   | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)   | noCSE in_id      = (env,                              out_id)   | use_subst        = (extendCSSubst env in_id rhs',     out_id)+  | cse_done         = (env,                              out_id)+                       -- See Note [Dealing with ticks]   | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)   where     id_expr'  = varToCoreExpr out_id@@ -437,9 +461,8 @@      -- Should we use SUBSTITUTE or EXTEND?     -- See Note [CSE for bindings]-    use_subst = case rhs' of-                   Var {} -> True-                   _      -> False+    use_subst | Var {} <- rhs' = True+              | otherwise      = False  -- | Given a binder `let x = e`, this function -- determines whether we should add `e -> x` to the cs_map@@ -486,6 +509,38 @@  This is done by cse_bind.  I got it wrong the first time (#13367). +Note [Dealing with ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~+Ticks complicate CSE a bit, as I discovered in the fallout from+fixing #19360.++* To get more CSE-ing, we strip all the tickishFloatable ticks from+  an expression+  - when inserting into the cs_map (see extendCSEnv)+  - when looking up in the cs_map (see call to lookupCSEnv in try_for_cse)+  Quite why only the tickishFloatble ticks, I'm not quite sure.++* If we get a hit in cs_map, we wrap the result in the ticks from the+  thing we are looking up (see try_for_cse)++Net result: if we get a hit, we might replace+  let x = tick t1 (tick t2 e)+with+  let x = tick t1 (tick t2 y)+where 'y' is the variable that 'e' maps to.  Now consider addBinding for+the binding for 'x':++* We can't use SUBSTITUTE because those ticks might not be trivial (we+  use tickishIsCode in exprIsTrivial)++* We should not use EXTEND, because we definitely don't want to+  add  (tick t1 (tick t2 y)) :-> x+  to the cs_map. Remember we strip off the ticks, so that would amount+  to adding y :-> x, very silly.++TL;DR: we do neither; hence the cse_done case in addBinding.++ Note [Delay inlining after CSE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (#15445) we have@@ -602,14 +657,14 @@     combineAlts alt_env (map cse_alt alts)   where     ty' = substTy (csEnvSubst env) ty-    scrut1 = tryForCSE env scrut+    (cse_done, scrut1) = try_for_cse env scrut      bndr1 = zapIdOccInfo bndr       -- Zapping the OccInfo is needed because the extendCSEnv       -- in cse_alt may mean that a dead case binder       -- becomes alive, and Lint rejects that     (env1, bndr2)    = addBinder env bndr1-    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1 cse_done          -- addBinding: see Note [CSE for case expressions]      con_target :: OutExpr@@ -619,15 +674,15 @@     arg_tys = tyConAppArgs (idType bndr3)      -- See Note [CSE for case alternatives]-    cse_alt (DataAlt con, args, rhs)-        = (DataAlt con, args', tryForCSE new_env rhs)+    cse_alt (Alt (DataAlt con) args rhs)+        = Alt (DataAlt con) args' (tryForCSE new_env rhs)         where           (env', args') = addBinders alt_env args           new_env       = extendCSEnv env' con_expr con_target           con_expr      = mkAltExpr (DataAlt con) args' arg_tys -    cse_alt (con, args, rhs)-        = (con, args', tryForCSE env' rhs)+    cse_alt (Alt con args rhs)+        = Alt con args' (tryForCSE env' rhs)         where           (env', args') = addBinders alt_env args @@ -635,11 +690,11 @@ -- See Note [Combine case alternatives] combineAlts env alts   | (Just alt1, rest_alts) <- find_bndr_free_alt alts-  , (_,bndrs1,rhs1) <- alt1+  , Alt _ bndrs1 rhs1 <- alt1   , let filtered_alts = filterOut (identical_alt rhs1) rest_alts   , not (equalLength rest_alts filtered_alts)   = ASSERT2( null bndrs1, ppr alts )-    (DEFAULT, [], rhs1) : filtered_alts+    Alt DEFAULT [] rhs1 : filtered_alts    | otherwise   = alts@@ -651,12 +706,12 @@        -- See Note [Combine case alts: awkward corner]     find_bndr_free_alt []       = (Nothing, [])-    find_bndr_free_alt (alt@(_,bndrs,_) : alts)+    find_bndr_free_alt (alt@(Alt _ bndrs _) : alts)       | null bndrs = (Just alt, alts)       | otherwise  = case find_bndr_free_alt alts of                        (mb_bf, alts) -> (mb_bf, alt:alts) -    identical_alt rhs1 (_,_,rhs) = eqExpr in_scope rhs1 rhs+    identical_alt rhs1 (Alt _ _ rhs) = eqExpr in_scope rhs1 rhs        -- Even if this alt has binders, they will have been cloned        -- If any of these binders are mentioned in 'rhs', then        -- 'rhs' won't compare equal to 'rhs1' (which is from an

GHC/Core/Opt/CallArity.hs view

@@ -2,6 +2,8 @@ -- Copyright (c) 2014 Joachim Breitner -- +{-# LANGUAGE BangPatterns #-}+ module GHC.Core.Opt.CallArity     ( callArityAnalProgram     , callArityRHS -- for testing@@ -35,7 +37,7 @@ Note [Call Arity: The goal] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The goal of this analysis is to find out if we can eta-expand a local function,+The goal of this analysis is to find out if we can eta-expand a local function based on how it is being called. The motivating example is this code, which comes up when we implement foldl using foldr, and do list fusion: @@ -67,11 +69,11 @@  For every let-bound variable we'd like to know:   1. A lower bound on the arity of all calls to the variable, and-  2. whether the variable is being called at most once or possible multiple+  2. whether the variable is being called at most once or possibly multiple      times. -It is always ok to lower the arity, or pretend that there are multiple calls.-In particular, "Minimum arity 0 and possible called multiple times" is always+It is always okay to lower the arity, or pretend that there are multiple calls.+In particular, "Minimum arity 0 and possibly called multiple times" is always correct.  @@ -83,12 +85,12 @@   I.  The arity analysis:      For every variable, whether it is absent, or called,-     and if called, which what arity.+     and if called, with what arity.   II. The Co-Called analysis:      For every two variables, whether there is a possibility that both are being      called.-     We obtain as a special case: For every variables, whether there is a+     We obtain as a special case: For every variable, whether there is a      possibility that it is being called twice.  For efficiency reasons, we gather this information only for a set of@@ -100,16 +102,16 @@ Note [Analysis I: The arity analysis] ------------------------------------ -The arity analysis is quite straight forward: The information about an+The arity analysis is quite straightforward: The information about an expression is an     VarEnv Arity where absent variables are bound to Nothing and otherwise to a lower bound to their arity.  When we analyze an expression, we analyze it with a given context arity.-Lambdas decrease and applications increase the incoming arity. Analysizing a-variable will put that arity in the environment. In lets or cases all the-results from the various subexpressions are lubed, which takes the point-wise+Lambdas decrease and applications increase the incoming arity. Analysing a+variable will put that arity in the environment. In `let`s or `case`s all the+results from the various subexpressions are lub'd, which takes the point-wise minimum (considering Nothing an infinity).  @@ -524,8 +526,8 @@       (final_ae, Case scrut' bndr ty alts')   where     (alt_aes, alts') = unzip $ map go alts-    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e-                        in  (ae, (dc, bndrs, e'))+    go (Alt dc bndrs e) = let (ae, e') = callArityAnal arity int e+                          in  (ae, Alt dc bndrs e')     alt_ae = lubRess alt_aes     (scrut_ae, scrut') = callArityAnal 0 int scrut     final_ae = scrut_ae `both` alt_ae@@ -722,10 +724,10 @@ unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)  resDelList :: [Var] -> CallArityRes -> CallArityRes-resDelList vs ae = foldr resDel ae vs+resDelList vs ae = foldl' (flip resDel) ae vs  resDel :: Var -> CallArityRes -> CallArityRes-resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)+resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v)  domRes :: CallArityRes -> UnVarSet domRes (_, ae) = varEnvDom ae

+ GHC/Core/Opt/CallerCC.hs view

@@ -0,0 +1,224 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE TupleSections #-}++-- | Adds cost-centers to call sites selected with the @-fprof-caller=...@+-- flag.+module GHC.Core.Opt.CallerCC+    ( addCallerCostCentres+    , CallerCcFilter+    , parseCallerCcFilter+    ) where++import Data.Bifunctor+import Data.Word (Word8)+import Data.Maybe+import qualified Text.Parsec as P++import Control.Applicative+import Control.Monad.Trans.State.Strict+import Data.Either+import Control.Monad++import GHC.Prelude+import GHC.Utils.Outputable as Outputable+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.Name hiding (varName)+import GHC.Types.Tickish+import GHC.Unit.Module.Name+import GHC.Unit.Module.ModGuts+import GHC.Types.SrcLoc+import GHC.Types.Var+import GHC.Unit.Types+import GHC.Data.FastString+import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Utils.Panic+import qualified GHC.Utils.Binary as B++addCallerCostCentres :: ModGuts -> CoreM ModGuts+addCallerCostCentres guts = do+  dflags <- getDynFlags+  let filters = callerCcFilters dflags+  let env :: Env+      env = Env+        { thisModule = mg_module guts+        , ccState = newCostCentreState+        , dflags = dflags+        , revParents = []+        , filters = filters+        }+  let guts' = guts { mg_binds = doCoreProgram env (mg_binds guts)+                   }+  return guts'++doCoreProgram :: Env -> CoreProgram -> CoreProgram+doCoreProgram env binds = flip evalState newCostCentreState $ do+    mapM (doBind env) binds++doBind :: Env -> CoreBind -> M CoreBind+doBind env (NonRec b rhs) = NonRec b <$> doExpr (addParent b env) rhs+doBind env (Rec bs) = Rec <$> mapM doPair bs+  where+    doPair (b,rhs) = (b,) <$> doExpr (addParent b env) rhs++doExpr :: Env -> CoreExpr -> M CoreExpr+doExpr env e@(Var v)+  | needsCallSiteCostCentre env v = do+    let nameDoc :: SDoc+        nameDoc = withUserStyle alwaysQualify DefaultDepth $+          hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v)++        ccName :: CcName+        ccName = mkFastString $ showSDoc (dflags env) nameDoc+    ccIdx <- getCCIndex' ccName+    let span = case revParents env of+          top:_ -> nameSrcSpan $ varName top+          _     -> noSrcSpan+        cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span+        tick :: CoreTickish+        tick = ProfNote cc True True+    pure $ Tick tick e+  | otherwise = pure e+doExpr _env e@(Lit _)       = pure e+doExpr env (f `App` x)      = App <$> doExpr env f <*> doExpr env x+doExpr env (Lam b x)        = Lam b <$> doExpr env x+doExpr env (Let b rhs)      = Let <$> doBind env b <*> doExpr env rhs+doExpr env (Case scrut b ty alts) =+    Case <$> doExpr env scrut <*> pure b <*> pure ty <*> mapM doAlt alts+  where+    doAlt (Alt con bs rhs)  = Alt con bs <$> doExpr env rhs+doExpr env (Cast expr co)   = Cast <$> doExpr env expr <*> pure co+doExpr env (Tick t e)       = Tick t <$> doExpr env e+doExpr _env e@(Type _)      = pure e+doExpr _env e@(Coercion _)  = pure e++type M = State CostCentreState++getCCIndex' :: FastString -> M CostCentreIndex+getCCIndex' name = state (getCCIndex name)++data Env = Env+  { thisModule  :: Module+  , dflags      :: DynFlags+  , ccState     :: CostCentreState+  , revParents  :: [Id]+  , filters     :: [CallerCcFilter]+  }++addParent :: Id -> Env -> Env+addParent i env = env { revParents = i : revParents env }++parents :: Env -> [Id]+parents env = reverse (revParents env)++needsCallSiteCostCentre :: Env -> Id -> Bool+needsCallSiteCostCentre env i =+    any matches (filters env)+  where+    matches :: CallerCcFilter -> Bool+    matches ccf =+        checkModule && checkFunc+      where+        checkModule =+          case ccfModuleName ccf of+            Just modFilt+              | Just iMod <- nameModule_maybe (varName i)+              -> moduleName iMod == modFilt+              | otherwise -> False+            Nothing -> True+        checkFunc =+            occNameMatches (ccfFuncName ccf) (getOccName i)++data NamePattern+    = PChar Char NamePattern+    | PWildcard NamePattern+    | PEnd++instance Outputable NamePattern where+  ppr (PChar c rest) = char c <> ppr rest+  ppr (PWildcard rest) = char '*' <> ppr rest+  ppr PEnd = Outputable.empty++instance B.Binary NamePattern where+  get bh = do+    tag <- B.get bh+    case tag :: Word8 of+      0 -> PChar <$> B.get bh <*> B.get bh+      1 -> PWildcard <$> B.get bh+      2 -> pure PEnd+      _ -> panic "Binary(NamePattern): Invalid tag"+  put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y+  put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x+  put_ bh PEnd = B.put_ bh (2 :: Word8)++occNameMatches :: NamePattern -> OccName -> Bool+occNameMatches pat = go pat . occNameString+  where+    go :: NamePattern -> String -> Bool+    go PEnd "" = True+    go (PChar c rest) (d:s)+      = d == c && go rest s+    go (PWildcard rest) s+      = go rest s || go (PWildcard rest) (tail s)+    go _ _  = False++type Parser = P.Parsec String ()++parseNamePattern :: Parser NamePattern+parseNamePattern = pattern+  where+    pattern = star <|> wildcard <|> char <|> end+    star = PChar '*' <$ P.string "\\*" <*> pattern+    wildcard = do+      void $ P.char '*'+      PWildcard <$> pattern+    char = PChar <$> P.anyChar <*> pattern+    end = PEnd <$ P.eof++data CallerCcFilter+    = CallerCcFilter { ccfModuleName  :: Maybe ModuleName+                     , ccfFuncName    :: NamePattern+                     }++instance Outputable CallerCcFilter where+  ppr ccf =+    maybe (char '*') ppr (ccfModuleName ccf)+    <> char '.'+    <> ppr (ccfFuncName ccf)++instance B.Binary CallerCcFilter where+  get bh = CallerCcFilter <$> B.get bh <*> B.get bh+  put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y++parseCallerCcFilter :: String -> Either String CallerCcFilter+parseCallerCcFilter =+    first show . P.parse parseCallerCcFilter' "caller-CC filter"++parseCallerCcFilter' :: Parser CallerCcFilter+parseCallerCcFilter' =+  CallerCcFilter+    <$> moduleFilter+    <*  P.char '.'+    <*> parseNamePattern+  where+    moduleFilter :: Parser (Maybe ModuleName)+    moduleFilter =+      (Just . mkModuleName <$> moduleName)+      <|>+      (Nothing <$ P.char '*')++    moduleName :: Parser String+    moduleName = do+      c <- P.upper+      cs <- some $ P.upper <|> P.lower <|> P.digit <|> P.oneOf "_"+      rest <- optional $ P.try $ P.char '.' >> fmap ('.':) moduleName+      return $ c : (cs ++ fromMaybe "" rest)+

+ GHC/Core/Opt/CallerCC.hs-boot view

@@ -0,0 +1,8 @@+module GHC.Core.Opt.CallerCC where++import GHC.Prelude++-- Necessary due to import in GHC.Driver.Session.+data CallerCcFilter++parseCallerCcFilter :: String -> Either String CallerCcFilter

GHC/Core/Opt/ConstantFold.hs view

@@ -1,2339 +1,3323 @@ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[ConFold]{Constant Folder}--Conceptually, constant folding should be parameterized with the kind-of target machine to get identical behaviour during compilation time-and runtime. We cheat a little bit here...--ToDo:-   check boundaries before folding, e.g. we can fold the Float addition-   (i1 + i2) only if it results in a valid Float.--}--{-# LANGUAGE CPP, RankNTypes, PatternSynonyms, ViewPatterns, RecordWildCards,-    DeriveFunctor, LambdaCase, TypeApplications, MultiWayIf #-}-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}--module GHC.Core.Opt.ConstantFold-   ( primOpRules-   , builtinRules-   , caseRules-   , EnableBignumRules (..)-   )-where--#include "HsVersions.h"--import GHC.Prelude--import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId )--import GHC.Core-import GHC.Core.Make-import GHC.Types.Id-import GHC.Types.Literal-import GHC.Core.SimpleOpt ( exprIsLiteral_maybe )-import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim-import GHC.Core.TyCon-   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon-   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons-   , tyConFamilySize )-import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )-import GHC.Core.Utils  ( eqExpr, cheapEqExpr, exprIsHNF, exprType-                       , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE )-import GHC.Core.Unfold ( exprIsConApp_maybe )-import GHC.Core.Multiplicity-import GHC.Core.FVs-import GHC.Core.Type-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Name.Occurrence ( occNameFS )-import GHC.Builtin.Names-import GHC.Data.Maybe      ( orElse )-import GHC.Types.Name ( Name, nameOccName )-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Types.Basic-import GHC.Platform-import GHC.Utils.Misc-import GHC.Core.Coercion   (mkUnbranchedAxInstCo,mkSymCo,Role(..))--import Control.Applicative ( Alternative(..) )--import Control.Monad-import Data.Bits as Bits-import qualified Data.ByteString as BS-import Data.Int-import Data.Ratio-import Data.Word-import Data.Maybe (fromMaybe)--{--Note [Constant folding]-~~~~~~~~~~~~~~~~~~~~~~~-primOpRules generates a rewrite rule for each primop-These rules do what is often called "constant folding"-E.g. the rules for +# might say-        4 +# 5 = 9-Well, of course you'd need a lot of rules if you did it-like that, so we use a BuiltinRule instead, so that we-can match in any two literal values.  So the rule is really-more like-        (Lit x) +# (Lit y) = Lit (x+#y)-where the (+#) on the rhs is done at compile time--That is why these rules are built in here.--}--primOpRules ::  Name -> PrimOp -> Maybe CoreRule-primOpRules nm = \case-   TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]-   DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]--   -- Int operations-   IntAddOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))-                                    , identityPlatform zeroi-                                    , numFoldingRules IntAddOp intPrimOps-                                    ]-   IntSubOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))-                                    , rightIdentityPlatform zeroi-                                    , equalArgs >> retLit zeroi-                                    , numFoldingRules IntSubOp intPrimOps-                                    ]-   IntAddCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))-                                    , identityCPlatform zeroi ]-   IntSubCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))-                                    , rightIdentityCPlatform zeroi-                                    , equalArgs >> retLitNoC zeroi ]-   IntMulOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))-                                    , zeroElem zeroi-                                    , identityPlatform onei-                                    , numFoldingRules IntMulOp intPrimOps-                                    ]-   IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)-                                    , leftZero zeroi-                                    , rightIdentityPlatform onei-                                    , equalArgs >> retLit onei ]-   IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)-                                    , leftZero zeroi-                                    , do l <- getLiteral 1-                                         platform <- getPlatform-                                         guard (l == onei platform)-                                         retLit zeroi-                                    , equalArgs >> retLit zeroi-                                    , equalArgs >> retLit zeroi ]-   AndIOp      -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))-                                    , idempotent-                                    , zeroElem zeroi ]-   OrIOp       -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))-                                    , idempotent-                                    , identityPlatform zeroi ]-   XorIOp      -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)-                                    , identityPlatform zeroi-                                    , equalArgs >> retLit zeroi ]-   NotIOp      -> mkPrimOpRule nm 1 [ unaryLit complementOp-                                    , inversePrimOp NotIOp ]-   IntNegOp    -> mkPrimOpRule nm 1 [ unaryLit negOp-                                    , inversePrimOp IntNegOp ]-   ISllOp      -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftL)-                                    , rightIdentityPlatform zeroi ]-   ISraOp      -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const Bits.shiftR)-                                    , rightIdentityPlatform zeroi ]-   ISrlOp      -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogical-                                    , rightIdentityPlatform zeroi ]--   -- Word operations-   WordAddOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))-                                    , identityPlatform zerow-                                    , numFoldingRules WordAddOp wordPrimOps-                                    ]-   WordSubOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))-                                    , rightIdentityPlatform zerow-                                    , equalArgs >> retLit zerow-                                    , numFoldingRules WordSubOp wordPrimOps-                                    ]-   WordAddCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))-                                    , identityCPlatform zerow ]-   WordSubCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))-                                    , rightIdentityCPlatform zerow-                                    , equalArgs >> retLitNoC zerow ]-   WordMulOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))-                                    , identityPlatform onew-                                    , numFoldingRules WordMulOp wordPrimOps-                                    ]-   WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)-                                    , rightIdentityPlatform onew ]-   WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)-                                    , leftZero zerow-                                    , do l <- getLiteral 1-                                         platform <- getPlatform-                                         guard (l == onew platform)-                                         retLit zerow-                                    , equalArgs >> retLit zerow ]-   AndOp       -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))-                                    , idempotent-                                    , zeroElem zerow ]-   OrOp        -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))-                                    , idempotent-                                    , identityPlatform zerow ]-   XorOp       -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)-                                    , identityPlatform zerow-                                    , equalArgs >> retLit zerow ]-   NotOp       -> mkPrimOpRule nm 1 [ unaryLit complementOp-                                    , inversePrimOp NotOp ]-   SllOp       -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const Bits.shiftL) ]-   SrlOp       -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogical ]--   -- coercions-   Word2IntOp     -> mkPrimOpRule nm 1 [ liftLitPlatform word2IntLit-                                       , inversePrimOp Int2WordOp ]-   Int2WordOp     -> mkPrimOpRule nm 1 [ liftLitPlatform int2WordLit-                                       , inversePrimOp Word2IntOp ]-   Narrow8IntOp   -> mkPrimOpRule nm 1 [ liftLit narrow8IntLit-                                       , subsumedByPrimOp Narrow8IntOp-                                       , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp-                                       , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp-                                       , narrowSubsumesAnd AndIOp Narrow8IntOp 8 ]-   Narrow16IntOp  -> mkPrimOpRule nm 1 [ liftLit narrow16IntLit-                                       , subsumedByPrimOp Narrow8IntOp-                                       , subsumedByPrimOp Narrow16IntOp-                                       , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp-                                       , narrowSubsumesAnd AndIOp Narrow16IntOp 16 ]-   Narrow32IntOp  -> mkPrimOpRule nm 1 [ liftLit narrow32IntLit-                                       , subsumedByPrimOp Narrow8IntOp-                                       , subsumedByPrimOp Narrow16IntOp-                                       , subsumedByPrimOp Narrow32IntOp-                                       , removeOp32-                                       , narrowSubsumesAnd AndIOp Narrow32IntOp 32 ]-   Narrow8WordOp  -> mkPrimOpRule nm 1 [ liftLit narrow8WordLit-                                       , subsumedByPrimOp Narrow8WordOp-                                       , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp-                                       , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp-                                       , narrowSubsumesAnd AndOp Narrow8WordOp 8 ]-   Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLit narrow16WordLit-                                       , subsumedByPrimOp Narrow8WordOp-                                       , subsumedByPrimOp Narrow16WordOp-                                       , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp-                                       , narrowSubsumesAnd AndOp Narrow16WordOp 16 ]-   Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLit narrow32WordLit-                                       , subsumedByPrimOp Narrow8WordOp-                                       , subsumedByPrimOp Narrow16WordOp-                                       , subsumedByPrimOp Narrow32WordOp-                                       , removeOp32-                                       , narrowSubsumesAnd AndOp Narrow32WordOp 32 ]-   OrdOp          -> mkPrimOpRule nm 1 [ liftLit char2IntLit-                                       , inversePrimOp ChrOp ]-   ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs-                                            guard (litFitsInChar lit)-                                            liftLit int2CharLit-                                       , inversePrimOp OrdOp ]-   Float2IntOp    -> mkPrimOpRule nm 1 [ liftLit float2IntLit ]-   Int2FloatOp    -> mkPrimOpRule nm 1 [ liftLit int2FloatLit ]-   Double2IntOp   -> mkPrimOpRule nm 1 [ liftLit double2IntLit ]-   Int2DoubleOp   -> mkPrimOpRule nm 1 [ liftLit int2DoubleLit ]-   -- SUP: Not sure what the standard says about precision in the following 2 cases-   Float2DoubleOp -> mkPrimOpRule nm 1 [ liftLit float2DoubleLit ]-   Double2FloatOp -> mkPrimOpRule nm 1 [ liftLit double2FloatLit ]--   -- Float-   FloatAddOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))-                                          , identity zerof ]-   FloatSubOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))-                                          , rightIdentity zerof ]-   FloatMulOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))-                                          , identity onef-                                          , strengthReduction twof FloatAddOp  ]-             -- zeroElem zerof doesn't hold because of NaN-   FloatDivOp        -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))-                                          , rightIdentity onef ]-   FloatNegOp        -> mkPrimOpRule nm 1 [ unaryLit negOp-                                          , inversePrimOp FloatNegOp ]-   FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]--   -- Double-   DoubleAddOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))-                                             , identity zerod ]-   DoubleSubOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))-                                             , rightIdentity zerod ]-   DoubleMulOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))-                                             , identity oned-                                             , strengthReduction twod DoubleAddOp  ]-              -- zeroElem zerod doesn't hold because of NaN-   DoubleDivOp          -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))-                                             , rightIdentity oned ]-   DoubleNegOp          -> mkPrimOpRule nm 1 [ unaryLit negOp-                                             , inversePrimOp DoubleNegOp ]-   DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]--   -- Relational operators--   IntEqOp    -> mkRelOpRule nm (==) [ litEq True ]-   IntNeOp    -> mkRelOpRule nm (/=) [ litEq False ]-   CharEqOp   -> mkRelOpRule nm (==) [ litEq True ]-   CharNeOp   -> mkRelOpRule nm (/=) [ litEq False ]--   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]-   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]-   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]-   IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp Lt ]--   CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]-   CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]-   CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]-   CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]--   FloatGtOp  -> mkFloatingRelOpRule nm (>)-   FloatGeOp  -> mkFloatingRelOpRule nm (>=)-   FloatLeOp  -> mkFloatingRelOpRule nm (<=)-   FloatLtOp  -> mkFloatingRelOpRule nm (<)-   FloatEqOp  -> mkFloatingRelOpRule nm (==)-   FloatNeOp  -> mkFloatingRelOpRule nm (/=)--   DoubleGtOp -> mkFloatingRelOpRule nm (>)-   DoubleGeOp -> mkFloatingRelOpRule nm (>=)-   DoubleLeOp -> mkFloatingRelOpRule nm (<=)-   DoubleLtOp -> mkFloatingRelOpRule nm (<)-   DoubleEqOp -> mkFloatingRelOpRule nm (==)-   DoubleNeOp -> mkFloatingRelOpRule nm (/=)--   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]-   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]-   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]-   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]-   WordEqOp   -> mkRelOpRule nm (==) [ litEq True ]-   WordNeOp   -> mkRelOpRule nm (/=) [ litEq False ]--   AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]--   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]-   SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]--   _          -> Nothing--{--************************************************************************-*                                                                      *-\subsection{Doing the business}-*                                                                      *-************************************************************************--}---- useful shorthands-mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule-mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)--mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)-            -> [RuleM CoreExpr] -> Maybe CoreRule-mkRelOpRule nm cmp extra-  = mkPrimOpRule nm 2 $-    binaryCmpLit cmp : equal_rule : extra-  where-        -- x `cmp` x does not depend on x, so-        -- compute it for the arbitrary value 'True'-        -- and use that result-    equal_rule = do { equalArgs-                    ; platform <- getPlatform-                    ; return (if cmp True True-                              then trueValInt  platform-                              else falseValInt platform) }--{- Note [Rules for floating-point comparisons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need different rules for floating-point values because for floats-it is not true that x = x (for NaNs); so we do not want the equal_rule-rule that mkRelOpRule uses.--Note also that, in the case of equality/inequality, we do /not/-want to switch to a case-expression.  For example, we do not want-to convert-   case (eqFloat# x 3.8#) of-     True -> this-     False -> that-to-  case x of-    3.8#::Float# -> this-    _            -> that-See #9238.  Reason: comparing floating-point values for equality-delicate, and we don't want to implement that delicacy in the code for-case expressions.  So we make it an invariant of Core that a case-expression never scrutinises a Float# or Double#.--This transformation is what the litEq rule does;-see Note [The litEq rule: converting equality to case].-So we /refrain/ from using litEq for mkFloatingRelOpRule.--}--mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)-                    -> Maybe CoreRule--- See Note [Rules for floating-point comparisons]-mkFloatingRelOpRule nm cmp-  = mkPrimOpRule nm 2 [binaryCmpLit cmp]---- common constants-zeroi, onei, zerow, onew :: Platform -> Literal-zeroi platform = mkLitInt  platform 0-onei  platform = mkLitInt  platform 1-zerow platform = mkLitWord platform 0-onew  platform = mkLitWord platform 1--zerof, onef, twof, zerod, oned, twod :: Literal-zerof = mkLitFloat 0.0-onef  = mkLitFloat 1.0-twof  = mkLitFloat 2.0-zerod = mkLitDouble 0.0-oned  = mkLitDouble 1.0-twod  = mkLitDouble 2.0--cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool)-      -> Literal -> Literal -> Maybe CoreExpr-cmpOp platform cmp = go-  where-    done True  = Just $ trueValInt  platform-    done False = Just $ falseValInt platform--    -- These compares are at different types-    go (LitChar i1)   (LitChar i2)   = done (i1 `cmp` i2)-    go (LitFloat i1)  (LitFloat i2)  = done (i1 `cmp` i2)-    go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)-    go (LitNumber nt1 i1) (LitNumber nt2 i2)-      | nt1 /= nt2 = Nothing-      | otherwise  = done (i1 `cmp` i2)-    go _               _               = Nothing------------------------------negOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Negate-negOp env = \case-   (LitFloat 0.0)  -> Nothing  -- can't represent -0.0 as a Rational-   (LitFloat f)    -> Just (mkFloatVal env (-f))-   (LitDouble 0.0) -> Nothing-   (LitDouble d)   -> Just (mkDoubleVal env (-d))-   (LitNumber nt i)-      | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i)))-   _ -> Nothing--complementOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Binary complement-complementOp env (LitNumber nt i) =-   Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i)))-complementOp _      _            = Nothing--intOp2 :: (Integral a, Integral b)-       => (a -> b -> Integer)-       -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr-intOp2 = intOp2' . const--intOp2' :: (Integral a, Integral b)-        => (RuleOpts -> a -> b -> Integer)-        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr-intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =-  let o = op env-  in  intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2)-intOp2' _ _ _ _ = Nothing--intOpC2 :: (Integral a, Integral b)-        => (a -> b -> Integer)-        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr-intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) = do-  intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2)-intOpC2 _ _ _ _ = Nothing--shiftRightLogical :: Platform -> Integer -> Int -> Integer--- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do--- Do this by converting to Word and back.  Obviously this won't work for big--- values, but its ok as we use it here-shiftRightLogical platform x n =-    case platformWordSize platform of-      PW4 -> fromIntegral (fromInteger x `shiftR` n :: Word32)-      PW8 -> fromIntegral (fromInteger x `shiftR` n :: Word64)-----------------------------retLit :: (Platform -> Literal) -> RuleM CoreExpr-retLit l = do platform <- getPlatform-              return $ Lit $ l platform--retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr-retLitNoC l = do platform <- getPlatform-                 let lit = l platform-                 let ty = literalType lit-                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)]--wordOp2 :: (Integral a, Integral b)-        => (a -> b -> Integer)-        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr-wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2)-    = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)-wordOp2 _ _ _ _ = Nothing--wordOpC2 :: (Integral a, Integral b)-        => (a -> b -> Integer)-        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr-wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) =-  wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)-wordOpC2 _ _ _ _ = Nothing--shiftRule :: LitNumType  -- Type of the result, either LitNumInt or LitNumWord-          -> (Platform -> Integer -> Int -> Integer)-          -> RuleM CoreExpr--- Shifts take an Int; hence third arg of op is Int--- Used for shift primops---    ISllOp, ISraOp, ISrlOp :: Int#  -> Int#  -> Int#---    SllOp, SrlOp           :: Word# -> Int# -> Word#-shiftRule lit_num_ty shift_op-  = do { platform <- getPlatform-       ; [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs-       ; case e1 of-           _ | shift_len == 0-             -> return e1-             -- See Note [Guarding against silly shifts]-             | shift_len < 0 || shift_len > toInteger (platformWordSizeInBits platform)-             -> return $ Lit $ mkLitNumberWrap platform lit_num_ty 0-                -- Be sure to use lit_num_ty here, so we get a correctly typed zero-                -- of type Int# or Word# resp.  See #18589--           -- Do the shift at type Integer, but shift length is Int-           Lit (LitNumber nt x)-             | 0 < shift_len-             , shift_len <= toInteger (platformWordSizeInBits platform)-             -> let op = shift_op platform-                    y  = x `op` fromInteger shift_len-                in  liftMaybe $ Just (Lit (mkLitNumberWrap platform nt y))--           _ -> mzero }-----------------------------floatOp2 :: (Rational -> Rational -> Rational)-         -> RuleOpts -> Literal -> Literal-         -> Maybe (Expr CoreBndr)-floatOp2 op env (LitFloat f1) (LitFloat f2)-  = Just (mkFloatVal env (f1 `op` f2))-floatOp2 _ _ _ _ = Nothing-----------------------------floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr-floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))-  = Just $ mkCoreUbxTup [intPrimTy, intPrimTy]-                        [ mkIntVal (roPlatform env) (toInteger m)-                        , mkIntVal (roPlatform env) (toInteger e) ]-floatDecodeOp _   _-  = Nothing-----------------------------doubleOp2 :: (Rational -> Rational -> Rational)-          -> RuleOpts -> Literal -> Literal-          -> Maybe (Expr CoreBndr)-doubleOp2 op env (LitDouble f1) (LitDouble f2)-  = Just (mkDoubleVal env (f1 `op` f2))-doubleOp2 _ _ _ _ = Nothing-----------------------------doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr-doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))-  = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]-                        [ Lit (mkLitINT64 (roPlatform env) (toInteger m))-                        , mkIntVal platform (toInteger e) ]-  where-    platform = roPlatform env-    (iNT64Ty, mkLitINT64)-      | platformWordSizeInBits platform < 64-      = (int64PrimTy, mkLitInt64Wrap)-      | otherwise-      = (intPrimTy  , mkLitIntWrap)-doubleDecodeOp _   _-  = Nothing-----------------------------{- Note [The litEq rule: converting equality to case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This stuff turns-     n ==# 3#-into-     case n of-       3# -> True-       m  -> False--This is a Good Thing, because it allows case-of case things-to happen, and case-default absorption to happen.  For-example:--     if (n ==# 3#) || (n ==# 4#) then e1 else e2-will transform to-     case n of-       3# -> e1-       4# -> e1-       m  -> e2-(modulo the usual precautions to avoid duplicating e1)--}--litEq :: Bool  -- True <=> equality, False <=> inequality-      -> RuleM CoreExpr-litEq is_eq = msum-  [ do [Lit lit, expr] <- getArgs-       platform <- getPlatform-       do_lit_eq platform lit expr-  , do [expr, Lit lit] <- getArgs-       platform <- getPlatform-       do_lit_eq platform lit expr ]-  where-    do_lit_eq platform lit expr = do-      guard (not (litIsLifted lit))-      return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy-                    [(DEFAULT,    [], val_if_neq),-                     (LitAlt lit, [], val_if_eq)])-      where-        val_if_eq  | is_eq     = trueValInt  platform-                   | otherwise = falseValInt platform-        val_if_neq | is_eq     = falseValInt platform-                   | otherwise = trueValInt  platform----- | Check if there is comparison with minBound or maxBound, that is--- always true or false. For instance, an Int cannot be smaller than its--- minBound, so we can replace such comparison with False.-boundsCmp :: Comparison -> RuleM CoreExpr-boundsCmp op = do-  platform <- getPlatform-  [a, b] <- getArgs-  liftMaybe $ mkRuleFn platform op a b--data Comparison = Gt | Ge | Lt | Le--mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr-mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform-mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt  platform-mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt  platform-mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform-mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt  platform-mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform-mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform-mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt  platform-mkRuleFn _ _ _ _                                           = Nothing--isMinBound :: Platform -> Literal -> Bool-isMinBound _        (LitChar c)        = c == minBound-isMinBound platform (LitNumber nt i)   = case nt of-   LitNumInt     -> i == platformMinInt platform-   LitNumInt64   -> i == toInteger (minBound :: Int64)-   LitNumWord    -> i == 0-   LitNumWord64  -> i == 0-   LitNumNatural -> i == 0-   LitNumInteger -> False-isMinBound _        _                  = False--isMaxBound :: Platform -> Literal -> Bool-isMaxBound _        (LitChar c)        = c == maxBound-isMaxBound platform (LitNumber nt i)   = case nt of-   LitNumInt     -> i == platformMaxInt platform-   LitNumInt64   -> i == toInteger (maxBound :: Int64)-   LitNumWord    -> i == platformMaxWord platform-   LitNumWord64  -> i == toInteger (maxBound :: Word64)-   LitNumNatural -> False-   LitNumInteger -> False-isMaxBound _        _                  = False---- | Create an Int literal expression while ensuring the given Integer is in the--- target Int range-intResult :: Platform -> Integer -> Maybe CoreExpr-intResult platform result = Just (intResult' platform result)--intResult' :: Platform -> Integer -> CoreExpr-intResult' platform result = Lit (mkLitIntWrap platform result)---- | Create an unboxed pair of an Int literal expression, ensuring the given--- Integer is in the target Int range and the corresponding overflow flag--- (@0#@/@1#@) if it wasn't.-intCResult :: Platform -> Integer -> Maybe CoreExpr-intCResult platform result = Just (mkPair [Lit lit, Lit c])-  where-    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]-    (lit, b) = mkLitIntWrapC platform result-    c = if b then onei platform else zeroi platform---- | Create a Word literal expression while ensuring the given Integer is in the--- target Word range-wordResult :: Platform -> Integer -> Maybe CoreExpr-wordResult platform result = Just (wordResult' platform result)--wordResult' :: Platform -> Integer -> CoreExpr-wordResult' platform result = Lit (mkLitWordWrap platform result)---- | Create an unboxed pair of a Word literal expression, ensuring the given--- Integer is in the target Word range and the corresponding carry flag--- (@0#@/@1#@) if it wasn't.-wordCResult :: Platform -> Integer -> Maybe CoreExpr-wordCResult platform result = Just (mkPair [Lit lit, Lit c])-  where-    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]-    (lit, b) = mkLitWordWrapC platform result-    c = if b then onei platform else zeroi platform--inversePrimOp :: PrimOp -> RuleM CoreExpr-inversePrimOp primop = do-  [Var primop_id `App` e] <- getArgs-  matchPrimOpId primop primop_id-  return e--subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr-this `subsumesPrimOp` that = do-  [Var primop_id `App` e] <- getArgs-  matchPrimOpId that primop_id-  return (Var (mkPrimOpId this) `App` e)--subsumedByPrimOp :: PrimOp -> RuleM CoreExpr-subsumedByPrimOp primop = do-  [e@(Var primop_id `App` _)] <- getArgs-  matchPrimOpId primop primop_id-  return e---- | narrow subsumes bitwise `and` with full mask (cf #16402):------       narrowN (x .&. m)---       m .&. (2^N-1) = 2^N-1---       ==> narrowN x------ e.g.  narrow16 (x .&. 0xFFFF)---       ==> narrow16 x----narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr-narrowSubsumesAnd and_primop narrw n = do-  [Var primop_id `App` x `App` y] <- getArgs-  matchPrimOpId and_primop primop_id-  let mask = bit n -1-      g v (Lit (LitNumber _ m)) = do-         guard (m .&. mask == mask)-         return (Var (mkPrimOpId narrw) `App` v)-      g _ _ = mzero-  g x y <|> g y x--idempotent :: RuleM CoreExpr-idempotent = do [e1, e2] <- getArgs-                guard $ cheapEqExpr e1 e2-                return e1--{--Note [Guarding against silly shifts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this code:--  import Data.Bits( (.|.), shiftL )-  chunkToBitmap :: [Bool] -> Word32-  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]--This optimises to:-Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->-    case w1_sCT of _ {-      [] -> 0##;-      : x_aAW xs_aAX ->-        case x_aAW of _ {-          GHC.Types.False ->-            case w_sCS of wild2_Xh {-              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;-              9223372036854775807 -> 0## };-          GHC.Types.True ->-            case GHC.Prim.>=# w_sCS 64 of _ {-              GHC.Types.False ->-                case w_sCS of wild3_Xh {-                  __DEFAULT ->-                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->-                      GHC.Prim.or# (GHC.Prim.narrow32Word#-                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))-                                   ww_sCW-                     };-                  9223372036854775807 ->-                    GHC.Prim.narrow32Word#-!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)-                };-              GHC.Types.True ->-                case w_sCS of wild3_Xh {-                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;-                  9223372036854775807 -> 0##-                } } } }--Note the massive shift on line "!!!!".  It can't happen, because we've checked-that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!-Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we-can't constant fold it, but if it gets to the assembler we get-     Error: operand type mismatch for `shl'--So the best thing to do is to rewrite the shift with a call to error,-when the second arg is large. However, in general we cannot do this; consider-this case--    let x = I# (uncheckedIShiftL# n 80)-    in ...--Here x contains an invalid shift and consequently we would like to rewrite it-as follows:--    let x = I# (error "invalid shift)-    in ...--This was originally done in the fix to #16449 but this breaks the let/app-invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.-For the reasons discussed in Note [Checking versus non-checking primops] (in-the PrimOp module) there is no safe way rewrite the argument of I# such that-it bottoms.--Consequently we instead take advantage of the fact that large shifts are-undefined behavior (see associated documentation in primops.txt.pp) and-transform the invalid shift into an "obviously incorrect" value.--There are two cases:--- Shifting fixed-width things: the primops ISll, Sll, etc-  These are handled by shiftRule.--  We are happy to shift by any amount up to wordSize but no more.--- Shifting Bignums (Integer, Natural): these are handled by bignum_shift.--  Here we could in principle shift by any amount, but we arbitrary-  limit the shift to 4 bits; in particular we do not want shift by a-  huge amount, which can happen in code like that above.--The two cases are more different in their code paths that is comfortable,-but that is only a historical accident.---************************************************************************-*                                                                      *-\subsection{Vaguely generic functions}-*                                                                      *-************************************************************************--}--mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule--- Gives the Rule the same name as the primop itself-mkBasicRule op_name n_args rm-  = BuiltinRule { ru_name  = occNameFS (nameOccName op_name),-                  ru_fn    = op_name,-                  ru_nargs = n_args,-                  ru_try   = runRuleM rm }--newtype RuleM r = RuleM-  { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }-  deriving (Functor)--instance Applicative RuleM where-    pure x = RuleM $ \_ _ _ _ -> Just x-    (<*>) = ap--instance Monad RuleM where-  RuleM f >>= g-    = RuleM $ \env iu fn args ->-              case f env iu fn args of-                Nothing -> Nothing-                Just r  -> runRuleM (g r) env iu fn args--instance MonadFail RuleM where-    fail _ = mzero--instance Alternative RuleM where-  empty = RuleM $ \_ _ _ _ -> Nothing-  RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args ->-    f1 env iu fn args <|> f2 env iu fn args--instance MonadPlus RuleM--getPlatform :: RuleM Platform-getPlatform = roPlatform <$> getEnv--getEnv :: RuleM RuleOpts-getEnv = RuleM $ \env _ _ _ -> Just env--liftMaybe :: Maybe a -> RuleM a-liftMaybe Nothing = mzero-liftMaybe (Just x) = return x--liftLit :: (Literal -> Literal) -> RuleM CoreExpr-liftLit f = liftLitPlatform (const f)--liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr-liftLitPlatform f = do-  platform <- getPlatform-  [Lit lit] <- getArgs-  return $ Lit (f platform lit)--removeOp32 :: RuleM CoreExpr-removeOp32 = do-  platform <- getPlatform-  case platformWordSize platform of-    PW4 -> do-      [e] <- getArgs-      return e-    PW8 ->-      mzero--getArgs :: RuleM [CoreExpr]-getArgs = RuleM $ \_ _ _ args -> Just args--getInScopeEnv :: RuleM InScopeEnv-getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu--getFunction :: RuleM Id-getFunction = RuleM $ \_ _ fn _ -> Just fn--isLiteral :: CoreExpr -> RuleM Literal-isLiteral e = do-    env <- getInScopeEnv-    case exprIsLiteral_maybe env e of-        Nothing -> mzero-        Just l  -> pure l--isNumberLiteral :: CoreExpr -> RuleM Integer-isNumberLiteral e = isLiteral e >>= \case-  LitNumber _ x -> pure x-  _             -> mzero--isIntegerLiteral :: CoreExpr -> RuleM Integer-isIntegerLiteral e = isLiteral e >>= \case-  LitNumber LitNumInteger x -> pure x-  _                         -> mzero--isNaturalLiteral :: CoreExpr -> RuleM Integer-isNaturalLiteral e = isLiteral e >>= \case-  LitNumber LitNumNatural x -> pure x-  _                         -> mzero--isWordLiteral :: CoreExpr -> RuleM Integer-isWordLiteral e = isLiteral e >>= \case-  LitNumber LitNumWord x -> pure x-  _                      -> mzero--isIntLiteral :: CoreExpr -> RuleM Integer-isIntLiteral e = isLiteral e >>= \case-  LitNumber LitNumInt x -> pure x-  _                     -> mzero---- return the n-th argument of this rule, if it is a literal--- argument indices start from 0-getLiteral :: Int -> RuleM Literal-getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of-  (Lit l:_) -> Just l-  _ -> Nothing--unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr-unaryLit op = do-  env <- getEnv-  [Lit l] <- getArgs-  liftMaybe $ op env (convFloating env l)--binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr-binaryLit op = do-  env <- getEnv-  [Lit l1, Lit l2] <- getArgs-  liftMaybe $ op env (convFloating env l1) (convFloating env l2)--binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr-binaryCmpLit op = do-  platform <- getPlatform-  binaryLit (\_ -> cmpOp platform op)--leftIdentity :: Literal -> RuleM CoreExpr-leftIdentity id_lit = leftIdentityPlatform (const id_lit)--rightIdentity :: Literal -> RuleM CoreExpr-rightIdentity id_lit = rightIdentityPlatform (const id_lit)--identity :: Literal -> RuleM CoreExpr-identity lit = leftIdentity lit `mplus` rightIdentity lit--leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr-leftIdentityPlatform id_lit = do-  platform <- getPlatform-  [Lit l1, e2] <- getArgs-  guard $ l1 == id_lit platform-  return e2---- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in--- addition to the result, we have to indicate that no carry/overflow occurred.-leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr-leftIdentityCPlatform id_lit = do-  platform <- getPlatform-  [Lit l1, e2] <- getArgs-  guard $ l1 == id_lit platform-  let no_c = Lit (zeroi platform)-  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])--rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr-rightIdentityPlatform id_lit = do-  platform <- getPlatform-  [e1, Lit l2] <- getArgs-  guard $ l2 == id_lit platform-  return e1---- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in--- addition to the result, we have to indicate that no carry/overflow occurred.-rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr-rightIdentityCPlatform id_lit = do-  platform <- getPlatform-  [e1, Lit l2] <- getArgs-  guard $ l2 == id_lit platform-  let no_c = Lit (zeroi platform)-  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])--identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr-identityPlatform lit =-  leftIdentityPlatform lit `mplus` rightIdentityPlatform lit---- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition--- to the result, we have to indicate that no carry/overflow occurred.-identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr-identityCPlatform lit =-  leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit--leftZero :: (Platform -> Literal) -> RuleM CoreExpr-leftZero zero = do-  platform <- getPlatform-  [Lit l1, _] <- getArgs-  guard $ l1 == zero platform-  return $ Lit l1--rightZero :: (Platform -> Literal) -> RuleM CoreExpr-rightZero zero = do-  platform <- getPlatform-  [_, Lit l2] <- getArgs-  guard $ l2 == zero platform-  return $ Lit l2--zeroElem :: (Platform -> Literal) -> RuleM CoreExpr-zeroElem lit = leftZero lit `mplus` rightZero lit--equalArgs :: RuleM ()-equalArgs = do-  [e1, e2] <- getArgs-  guard $ e1 `cheapEqExpr` e2--nonZeroLit :: Int -> RuleM ()-nonZeroLit n = getLiteral n >>= guard . not . isZeroLit---- When excess precision is not requested, cut down the precision of the--- Rational value to that of Float/Double. We confuse host architecture--- and target architecture here, but it's convenient (and wrong :-).-convFloating :: RuleOpts -> Literal -> Literal-convFloating env (LitFloat  f) | not (roExcessRationalPrecision env) =-   LitFloat  (toRational (fromRational f :: Float ))-convFloating env (LitDouble d) | not (roExcessRationalPrecision env) =-   LitDouble (toRational (fromRational d :: Double))-convFloating _ l = l--guardFloatDiv :: RuleM ()-guardFloatDiv = do-  [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs-  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]-       && f2 /= 0            -- avoid NaN and Infinity/-Infinity--guardDoubleDiv :: RuleM ()-guardDoubleDiv = do-  [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs-  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]-       && d2 /= 0            -- avoid NaN and Infinity/-Infinity--- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to--- zero, but we might want to preserve the negative zero here which--- is representable in Float/Double but not in (normalised)--- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?--strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr-strengthReduction two_lit add_op = do -- Note [Strength reduction]-  arg <- msum [ do [arg, Lit mult_lit] <- getArgs-                   guard (mult_lit == two_lit)-                   return arg-              , do [Lit mult_lit, arg] <- getArgs-                   guard (mult_lit == two_lit)-                   return arg ]-  return $ Var (mkPrimOpId add_op) `App` arg `App` arg---- Note [Strength reduction]--- ~~~~~~~~~~~~~~~~~~~~~~~~~------ This rule turns floating point multiplications of the form 2.0 * x and--- x * 2.0 into x + x addition, because addition costs less than multiplication.--- See #7116---- Note [What's true and false]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ trueValInt and falseValInt represent true and false values returned by--- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.--- True is represented as an unboxed 1# literal, while false is represented--- as 0# literal.--- We still need Bool data constructors (True and False) to use in a rule--- for constant folding of equal Strings--trueValInt, falseValInt :: Platform -> Expr CoreBndr-trueValInt  platform = Lit $ onei  platform -- see Note [What's true and false]-falseValInt platform = Lit $ zeroi platform--trueValBool, falseValBool :: Expr CoreBndr-trueValBool   = Var trueDataConId -- see Note [What's true and false]-falseValBool  = Var falseDataConId--ltVal, eqVal, gtVal :: Expr CoreBndr-ltVal = Var ordLTDataConId-eqVal = Var ordEQDataConId-gtVal = Var ordGTDataConId--mkIntVal :: Platform -> Integer -> Expr CoreBndr-mkIntVal platform i = Lit (mkLitInt platform i)-mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr-mkFloatVal env f = Lit (convFloating env (LitFloat  f))-mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr-mkDoubleVal env d = Lit (convFloating env (LitDouble d))--matchPrimOpId :: PrimOp -> Id -> RuleM ()-matchPrimOpId op id = do-  op' <- liftMaybe $ isPrimOpId_maybe id-  guard $ op == op'--{--************************************************************************-*                                                                      *-\subsection{Special rules for seq, tagToEnum, dataToTag}-*                                                                      *-************************************************************************--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 but it works.--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--We used to make this check in the type inference engine, but it's quite-ugly to do so, because the delayed constraint solving means that we don't-really know what's going on until the end. It's very much a corner case-because we don't expect the user to call tagToEnum# at all; we merely-generate calls in derived instances of Enum.  So we compromise: a-rewrite rule rewrites a bad instance of tagToEnum# to an error call,-and emits a warning.--}--tagToEnumRule :: RuleM CoreExpr--- If     data T a = A | B | C--- then   tagToEnum# (T ty) 2# -->  B ty-tagToEnumRule = do-  [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs-  case splitTyConApp_maybe ty of-    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do-      let tag = fromInteger i-          correct_tag dc = (dataConTagZ dc) == tag-      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])-      ASSERT(null rest) return ()-      return $ mkTyApps (Var (dataConWorkId dc)) tc_args--    -- See Note [tagToEnum#]-    _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )-         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"---------------------------------dataToTagRule :: RuleM CoreExpr--- See Note [dataToTag#] in primops.txt.pp-dataToTagRule = a `mplus` b-  where-    -- dataToTag (tagToEnum x)   ==>   x-    a = do-      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs-      guard $ tag_to_enum `hasKey` tagToEnumKey-      guard $ ty1 `eqType` ty2-      return tag--    -- dataToTag (K e1 e2)  ==>   tag-of K-    -- This also works (via exprIsConApp_maybe) for-    --   dataToTag x-    -- where x's unfolding is a constructor application-    b = do-      dflags <- getPlatform-      [_, val_arg] <- getArgs-      in_scope <- getInScopeEnv-      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg-      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()-      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))--{- Note [dataToTag# magic]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The primop dataToTag# is unusual because it evaluates its argument.-Only `SeqOp` shares that property.  (Other primops do not do anything-as fancy as argument evaluation.)  The special handling for dataToTag#-is:--* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,-  (actually in app_ok).  Most primops with lifted arguments do not-  evaluate those arguments, but DataToTagOp and SeqOp are two-  exceptions.  We say that they are /never/ ok-for-speculation,-  regardless of the evaluated-ness of their argument.-  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]--* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,-  that evaluates its argument and then extracts the tag from-  the returned value.--* An application like (dataToTag# (Just x)) is optimised by-  dataToTagRule in GHC.Core.Opt.ConstantFold.--* A case expression like-     case (dataToTag# e) of <alts>-  gets transformed t-     case e of <transformed alts>-  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]--See #15696 for a long saga.--}--{- *********************************************************************-*                                                                      *-             unsafeEqualityProof-*                                                                      *-********************************************************************* -}---- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)--- That is, if the two types are equal, it's not unsafe!--unsafeEqualityProofRule :: RuleM CoreExpr-unsafeEqualityProofRule-  = do { [Type rep, Type t1, Type t2] <- getArgs-       ; guard (t1 `eqType` t2)-       ; fn <- getFunction-       ; let (_, ue) = splitForAllTys (idType fn)-             tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality-             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl-             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).-             --               UnsafeEquality r a a-       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }---{- *********************************************************************-*                                                                      *-             Rules for seq# and spark#-*                                                                      *-********************************************************************* -}--{- Note [seq# magic]-~~~~~~~~~~~~~~~~~~~~-The primop-   seq# :: forall a s . a -> State# s -> (# State# s, a #)--is /not/ the same as the Prelude function seq :: a -> b -> b-as you can see from its type.  In fact, seq# is the implementation-mechanism for 'evaluate'--   evaluate :: a -> IO a-   evaluate a = IO $ \s -> seq# a s--The semantics of seq# is-  * evaluate its first argument-  * and return it--Things to note--* Why do we need a primop at all?  That is, instead of-      case seq# x s of (# x, s #) -> blah-  why not instead say this?-      case x of { DEFAULT -> blah)--  Reason (see #5129): if we saw-    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler--  then we'd drop the 'case x' because the body of the case is bottom-  anyway. But we don't want to do that; the whole /point/ of-  seq#/evaluate is to evaluate 'x' first in the IO monad.--  In short, we /always/ evaluate the first argument and never-  just discard it.--* Why return the value?  So that we can control sharing of seq'd-  values: in-     let x = e in x `seq` ... x ...-  We don't want to inline x, so better to represent it as-       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...-  also it matches the type of rseq in the Eval monad.--Implementing seq#.  The compiler has magic for SeqOp in--- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)--- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#--- GHC.Core.Utils.exprOkForSpeculation;-  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils--- Simplify.addEvals records evaluated-ness for the result; see-  Note [Adding evaluatedness info to pattern-bound variables]-  in GHC.Core.Opt.Simplify--}--seqRule :: RuleM CoreExpr-seqRule = do-  [Type ty_a, Type _ty_s, a, s] <- getArgs-  guard $ exprIsHNF a-  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]---- spark# :: forall a s . a -> State# s -> (# State# s, a #)-sparkRule :: RuleM CoreExpr-sparkRule = seqRule -- reduce on HNF, just the same-  -- XXX perhaps we shouldn't do this, because a spark eliminated by-  -- this rule won't be counted as a dud at runtime?--{--************************************************************************-*                                                                      *-\subsection{Built in rules}-*                                                                      *-************************************************************************--Note [Scoping for Builtin rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When compiling a (base-package) module that defines one of the-functions mentioned in the RHS of a built-in rule, there's a danger-that we'll see--        f = ...(eq String x)....--        ....and lower down...--        eqString = ...--Then a rewrite would give--        f = ...(eqString x)...-        ....and lower down...-        eqString = ...--and lo, eqString is not in scope.  This only really matters when we-get to code generation.  But the occurrence analyser does a GlomBinds-step when necessary, that does a new SCC analysis on the whole set of-bindings (see occurAnalysePgm), which sorts out the dependency, so all-is fine.--}--newtype EnableBignumRules = EnableBignumRules Bool--builtinRules :: EnableBignumRules -> [CoreRule]--- Rules for non-primops that can't be expressed using a RULE pragma-builtinRules enableBignumRules-  = [BuiltinRule { ru_name = fsLit "AppendLitString",-                   ru_fn = unpackCStringFoldrName,-                   ru_nargs = 4, ru_try = match_append_lit_C },-     BuiltinRule { ru_name = fsLit "AppendLitStringUtf8",-                   ru_fn = unpackCStringFoldrUtf8Name,-                   ru_nargs = 4, ru_try = match_append_lit_utf8 },-     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,-                   ru_nargs = 2, ru_try = match_eq_string },-     BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName,-                   ru_nargs = 1, ru_try = match_cstring_length },-     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,-                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },-     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,-                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },--     mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,--     mkBasicRule divIntName 2 $ msum-        [ nonZeroLit 1 >> binaryLit (intOp2 div)-        , leftZero zeroi-        , do-          [arg, Lit (LitNumber LitNumInt d)] <- getArgs-          Just n <- return $ exactLog2 d-          platform <- getPlatform-          return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal platform n-        ],--     mkBasicRule modIntName 2 $ msum-        [ nonZeroLit 1 >> binaryLit (intOp2 mod)-        , leftZero zeroi-        , do-          [arg, Lit (LitNumber LitNumInt d)] <- getArgs-          Just _ <- return $ exactLog2 d-          platform <- getPlatform-          return $ Var (mkPrimOpId AndIOp)-            `App` arg `App` mkIntVal platform (d - 1)-        ]-     ]- ++ builtinBignumRules enableBignumRules-{-# NOINLINE builtinRules #-}--- there is no benefit to inlining these yet, despite this, GHC produces--- unfoldings for this regardless since the floated list entries look small.--builtinBignumRules :: EnableBignumRules -> [CoreRule]-builtinBignumRules (EnableBignumRules False) = []-builtinBignumRules _ =-  [ -- conversions-    lit_to_integer "Word# -> Integer"   integerFromWordName-  , lit_to_integer "Int64# -> Integer"  integerFromInt64Name-  , lit_to_integer "Word64# -> Integer" integerFromWord64Name-  , lit_to_integer "Natural -> Integer" integerFromNaturalName--  , integer_to_lit "Integer -> Word# (wrap)"   integerToWordName   mkWordLitWrap-  , integer_to_lit "Integer -> Int# (wrap)"    integerToIntName    mkIntLitWrap-  , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger)-  , integer_to_lit "Integer -> Int64# (wrap)"  integerToInt64Name  (\_ -> mkInt64LitInt64 . fromInteger)-  , integer_to_lit "Integer -> Float#"         integerToFloatName  (\_ -> mkFloatLitFloat . fromInteger)-  , integer_to_lit "Integer -> Double#"        integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger)--  , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True-  , integer_to_natural "Integer -> Natural (wrap)"  integerToNaturalName      False False-  , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False--  , lit_to_natural  "Word# -> Natural"         naturalNSName-  , natural_to_word "Natural -> Word# (wrap)"  naturalToWordName      False-  , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True--    -- comparisons (return an unlifted Int#)-  , integer_cmp "integerEq#" integerEqName (==)-  , integer_cmp "integerNe#" integerNeName (/=)-  , integer_cmp "integerLe#" integerLeName (<=)-  , integer_cmp "integerGt#" integerGtName (>)-  , integer_cmp "integerLt#" integerLtName (<)-  , integer_cmp "integerGe#" integerGeName (>=)--  , natural_cmp "naturalEq#" naturalEqName (==)-  , natural_cmp "naturalNe#" naturalNeName (/=)-  , natural_cmp "naturalLe#" naturalLeName (<=)-  , natural_cmp "naturalGt#" naturalGtName (>)-  , natural_cmp "naturalLt#" naturalLtName (<)-  , natural_cmp "naturalGe#" naturalGeName (>=)--    -- comparisons (return an Ordering)-  , bignum_compare "integerCompare" integerCompareName-  , bignum_compare "naturalCompare" naturalCompareName--    -- binary operations-  , integer_binop "integerAdd" integerAddName (+)-  , integer_binop "integerSub" integerSubName (-)-  , integer_binop "integerMul" integerMulName (*)-  , integer_binop "integerGcd" integerGcdName gcd-  , integer_binop "integerLcm" integerLcmName lcm-  , integer_binop "integerAnd" integerAndName (.&.)-  , integer_binop "integerOr"  integerOrName  (.|.)-  , integer_binop "integerXor" integerXorName xor--  , natural_binop "naturalAdd" naturalAddName (+)-  , natural_binop "naturalMul" naturalMulName (*)-  , natural_binop "naturalGcd" naturalGcdName gcd-  , natural_binop "naturalLcm" naturalLcmName lcm-  , natural_binop "naturalAnd" naturalAndName (.&.)-  , natural_binop "naturalOr"  naturalOrName  (.|.)-  , natural_binop "naturalXor" naturalXorName xor--    -- Natural subtraction: it's a binop but it can fail because of underflow so-    -- we have several primitives to handle here.-  , natural_sub "naturalSubUnsafe" naturalSubUnsafeName-  , natural_sub "naturalSubThrow"  naturalSubThrowName-  , mkRule "naturalSub" naturalSubName 2 $ do-        [a0,a1] <- getArgs-        x <- isNaturalLiteral a0-        y <- isNaturalLiteral a1-        -- return an unboxed sum: (# (# #) | Natural #)-        let ret n v = pure $ mkCoreUbxSum 2 n [voidPrimTy,naturalTy] v-        if x < y-            then ret 1 $ Var voidPrimId-            else ret 2 $ Lit (mkLitNatural (x - y))--    -- unary operations-  , bignum_unop "integerNegate"     integerNegateName     mkLitInteger negate-  , bignum_unop "integerAbs"        integerAbsName        mkLitInteger abs-  , bignum_unop "integerSignum"     integerSignumName     mkLitInteger signum-  , bignum_unop "integerComplement" integerComplementName mkLitInteger complement--  , bignum_unop "naturalSignum"     naturalSignumName     mkLitNatural signum--  , mkRule "naturalNegate" naturalNegateName 1 $ do-        [a0] <- getArgs-        x <- isNaturalLiteral a0-        guard (x == 0) -- negate is only valid for (0 :: Natural)-        pure a0--  , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap-  , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap--    -- identity passthrough-  , id_passthrough "Int# -> Integer -> Int#"       integerToIntName    integerISName-  , id_passthrough "Word# -> Integer -> Word#"     integerToWordName   integerFromWordName-  , id_passthrough "Int64# -> Integer -> Int64#"   integerToInt64Name  integerFromInt64Name-  , id_passthrough "Word64# -> Integer -> Word64#" integerToWord64Name integerFromWord64Name-  , id_passthrough "Word# -> Natural -> Word#"     naturalToWordName   naturalNSName--    -- identity passthrough with a conversion that can be done directly instead-  , small_passthrough "Int# -> Integer -> Word#"-        integerISName integerToWordName   (mkPrimOpId Int2WordOp)-  , small_passthrough "Int# -> Integer -> Float#"-        integerISName integerToFloatName  (mkPrimOpId Int2FloatOp)-  , small_passthrough "Int# -> Integer -> Double#"-        integerISName integerToDoubleName (mkPrimOpId Int2DoubleOp)-  , small_passthrough "Word# -> Natural -> Int#"-        naturalNSName naturalToWordName   (mkPrimOpId Word2IntOp)--    -- Bits.bit-  , bignum_bit "integerBit" integerBitName mkLitInteger-  , bignum_bit "naturalBit" naturalBitName mkLitNatural--    -- Bits.testBit-  , bignum_testbit "integerTestBit" integerTestBitName-  , bignum_testbit "naturalTestBit" naturalTestBitName--    -- Bits.shift-  , bignum_shift "integerShiftL" integerShiftLName shiftL mkLitInteger-  , bignum_shift "integerShiftR" integerShiftRName shiftR mkLitInteger-  , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkLitNatural-  , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkLitNatural--    -- division-  , divop_one  "integerQuot"    integerQuotName    quot    mkLitInteger-  , divop_one  "integerRem"     integerRemName     rem     mkLitInteger-  , divop_one  "integerDiv"     integerDivName     div     mkLitInteger-  , divop_one  "integerMod"     integerModName     mod     mkLitInteger-  , divop_both "integerDivMod"  integerDivModName  divMod  mkLitInteger integerTy-  , divop_both "integerQuotRem" integerQuotRemName quotRem mkLitInteger integerTy--  , divop_one  "naturalQuot"    naturalQuotName    quot    mkLitNatural-  , divop_one  "naturalRem"     naturalRemName     rem     mkLitNatural-  , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy--    -- conversions from Rational for Float/Double literals-  , rational_to "rationalToFloat"  rationalToFloatName  mkFloatExpr-  , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr--    -- conversions from Integer for Float/Double literals-  , integer_encode_float "integerEncodeFloat"  integerEncodeFloatName  mkFloatLitFloat-  , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble-  ]-  where-    -- The rule is matching against an occurrence of a data constructor in a-    -- Core expression. It must match either its worker name or its wrapper-    -- name, /not/ the DataCon name itself, which is different.-    -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892-    ---    -- But data constructor wrappers deliberately inline late; See Note-    -- [Activation for data constructor wrappers] in GHC.Types.Id.Make.-    -- Suppose there is a wrapper and the rule matches on the worker: the-    -- wrapper won't be inlined until rules have finished firing and the rule-    -- will never fire.-    ---    -- Hence the rule must match on the wrapper, if there is one, otherwise on-    -- the worker. That is exactly the dataConWrapId for the data constructor.-    -- The data constructor may or may not have a wrapper, but if not-    -- dataConWrapId will return the worker-    ---    integerISName = idName (dataConWrapId integerISDataCon)-    naturalNSName = idName (dataConWrapId naturalNSDataCon)--    mkRule str name nargs f = BuiltinRule-      { ru_name = fsLit str-      , ru_fn = name-      , ru_nargs = nargs-      , ru_try = runRuleM f-      }--    integer_to_lit str name convert = mkRule str name 1 $ do-      [a0] <- getArgs-      platform <- getPlatform-      x <- isIntegerLiteral a0-      pure (convert platform x)--    natural_to_word str name clamp = mkRule str name 1 $ do-      [a0] <- getArgs-      n <- isNaturalLiteral a0-      platform <- getPlatform-      if clamp && not (platformInWordRange platform n)-          then pure (Lit (mkLitWord platform (platformMaxWord platform)))-          else pure (Lit (mkLitWordWrap platform n))--    integer_to_natural str name thrw clamp = mkRule str name 1 $ do-      [a0] <- getArgs-      x <- isIntegerLiteral a0-      if | x >= 0    -> pure $ Lit $ mkLitNatural x-         | thrw      -> mzero-         | clamp     -> pure $ Lit $ mkLitNatural 0       -- clamp to 0-         | otherwise -> pure $ Lit $ mkLitNatural (abs x) -- negate/wrap--    lit_to_integer str name = mkRule str name 1 $ do-      [a0] <- getArgs-      isLiteral a0 >>= \case-        -- convert any numeric literal into an Integer literal-        LitNumber _ i -> pure (Lit (mkLitInteger i))-        _             -> mzero--    lit_to_natural str name = mkRule str name 1 $ do-      [a0] <- getArgs-      isLiteral a0 >>= \case-        -- convert any *positive* numeric literal into a Natural literal-        LitNumber _ i | i >= 0 -> pure (Lit (mkLitNatural i))-        _                      -> mzero--    integer_binop str name op = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isIntegerLiteral a0-      y <- isIntegerLiteral a1-      pure (Lit (mkLitInteger (x `op` y)))--    natural_binop str name op = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isNaturalLiteral a0-      y <- isNaturalLiteral a1-      pure (Lit (mkLitNatural (x `op` y)))--    natural_sub str name = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isNaturalLiteral a0-      y <- isNaturalLiteral a1-      guard (x >= y)-      pure (Lit (mkLitNatural (x - y)))--    integer_cmp str name op = mkRule str name 2 $ do-      platform <- getPlatform-      [a0,a1] <- getArgs-      x <- isIntegerLiteral a0-      y <- isIntegerLiteral a1-      pure $ if x `op` y-              then trueValInt platform-              else falseValInt platform--    natural_cmp str name op = mkRule str name 2 $ do-      platform <- getPlatform-      [a0,a1] <- getArgs-      x <- isNaturalLiteral a0-      y <- isNaturalLiteral a1-      pure $ if x `op` y-              then trueValInt platform-              else falseValInt platform--    bignum_compare str name = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isNumberLiteral a0-      y <- isNumberLiteral a1-      pure $ case x `compare` y of-              LT -> ltVal-              EQ -> eqVal-              GT -> gtVal--    bignum_unop str name mk_lit op = mkRule str name 1 $ do-      [a0] <- getArgs-      x <- isNumberLiteral a0-      pure $ Lit (mk_lit (op x))--    bignum_popcount str name mk_lit = mkRule str name 1 $ do-      platform <- getPlatform-      -- We use a host Int to compute the popCount. If we compile on a 32-bit-      -- host for a 64-bit target, the result may be different than if computed-      -- by the target. So we disable this rule if sizes don't match.-      guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word))-      [a0] <- getArgs-      x <- isNumberLiteral a0-      pure $ Lit (mk_lit platform (fromIntegral (popCount x)))--    id_passthrough str to_x from_x = mkRule str to_x 1 $ do-      [App (Var f) x] <- getArgs-      guard (idName f == from_x)-      pure x--    small_passthrough str from_x to_y x_to_y = mkRule str to_y 1 $ do-      [App (Var f) x] <- getArgs-      guard (idName f == from_x)-      pure $ App (Var x_to_y) x--    bignum_bit str name mk_lit = mkRule str name 1 $ do-      [a0] <- getArgs-      platform <- getPlatform-      n <- isNumberLiteral a0-      -- Make sure n is positive and small enough to yield a decently-      -- small number. Attempting to construct the Integer for-      --    (integerBit 9223372036854775807#)-      -- would be a bad idea (#14959)-      guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform))-      -- it's safe to convert a target Int value into a host Int value-      -- to perform the "bit" operation because n is very small (<= 64).-      pure $ Lit (mk_lit (bit (fromIntegral n)))--    bignum_testbit str name = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      platform <- getPlatform-      x <- isNumberLiteral a0-      n <- isNumberLiteral a1-      -- ensure that we can store 'n' in a host Int-      guard (n >= 0 && n <= fromIntegral (maxBound :: Int))-      pure $ if testBit x (fromIntegral n)-              then trueValInt platform-              else falseValInt platform--    bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isNumberLiteral a0-      n <- isWordLiteral a1-      -- See Note [Guarding against silly shifts]-      -- Restrict constant-folding of shifts on Integers, somewhat arbitrary.-      -- We can get huge shifts in inaccessible code (#15673)-      guard (n <= 4)-      pure $ Lit (mk_lit (x `shift_op` fromIntegral n))--    divop_one str name divop mk_lit = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      n <- isNumberLiteral a0-      d <- isNumberLiteral a1-      guard (d /= 0)-      pure $ Lit (mk_lit (n `divop` d))--    divop_both str name divop mk_lit ty = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      n <- isNumberLiteral a0-      d <- isNumberLiteral a1-      guard (d /= 0)-      let (r,s) = n `divop` d-      pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit s)]--    integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule-    integer_encode_float str name mk_lit = mkRule str name 2 $ do-      [a0,a1] <- getArgs-      x <- isIntegerLiteral a0-      y <- isIntLiteral a1-      -- check that y (a target Int) is in the host Int range-      guard (y <= fromIntegral (maxBound :: Int))-      pure (mk_lit $ encodeFloat x (fromInteger y))--    rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule-    rational_to str name mk_lit = mkRule str name 2 $ do-      -- This turns `rationalToFloat n d` where `n` and `d` are literals into-      -- a literal Float (and similarly for Double).-      [a0,a1] <- getArgs-      n <- isIntegerLiteral a0-      d <- isIntegerLiteral a1-      -- it's important to not match d == 0, because that may represent a-      -- literal "0/0" or similar, and we can't produce a literal value for-      -- NaN or +-Inf-      guard (d /= 0)-      pure $ mk_lit (fromRational (n % d))--------------------------------------------------------- The rule is this:---      unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n)---      =  unpackFoldrCString*# "foobaz"# c n------ See also Note [String literals in GHC] in CString.hs---- CString version-match_append_lit_C :: RuleFun-match_append_lit_C = match_append_lit unpackCStringFoldrIdKey---- CStringUTF8 version-match_append_lit_utf8 :: RuleFun-match_append_lit_utf8 = match_append_lit unpackCStringFoldrUtf8IdKey--{-# INLINE match_append_lit #-}-match_append_lit :: Unique -> RuleFun-match_append_lit foldVariant _ id_unf _-        [ Type ty1-        , lit1-        , c1-        , e2-        ]-  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the-  -- `lit` and `c` arguments, lest this may fail to fire when building with-  -- -g3. See #16740.-  | (strTicks, Var unpk `App` Type ty2-                        `App` lit2-                        `App` c2-                        `App` n) <- stripTicksTop tickishFloatable e2-  , unpk `hasKey` foldVariant-  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2-  , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2))-    in eqExpr freeVars c1 c2-  , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1-  , c2Ticks <- stripTicksTopT tickishFloatable c2-  = ASSERT( ty1 `eqType` ty2 )-    Just $ mkTicks strTicks-         $ Var unpk `App` Type ty1-                    `App` Lit (LitString (s1 `BS.append` s2))-                    `App` mkTicks (c1Ticks ++ c2Ticks) c1'-                    `App` n--match_append_lit _ _ _ _ _ = Nothing-------------------------------------------------------- The rule is this:---      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2--- Also  matches unpackCStringUtf8#--match_eq_string :: RuleFun-match_eq_string _ id_unf _-        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]-  | unpk_key1 <- getUnique unpk1-  , unpk_key2 <- getUnique unpk2-  , unpk_key1 == unpk_key2-  -- For now we insist the literals have to agree in their encoding-  -- to keep the rule simple. But we could check if the decoded strings-  -- compare equal in here as well.-  , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey]-  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1-  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2-  = Just (if s1 == s2 then trueValBool else falseValBool)--match_eq_string _ _ _ _ = Nothing---------------------------------------------------------------------------- Illustration of this rule:------ cstringLength# "foobar"# --> 6--- cstringLength# "fizz\NULzz"# --> 4------ Nota bene: Addr# literals are suffixed by a NUL byte when they are--- compiled to read-only data sections. That's why cstringLength# is--- well defined on Addr# literals that do not explicitly have an embedded--- NUL byte.------ See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly--- helpful when using OverloadedStrings to create a ByteString since the--- function computing the length of such ByteStrings can often be constant--- folded.-match_cstring_length :: RuleFun-match_cstring_length env id_unf _ [lit1]-  | Just (LitString str) <- exprIsLiteral_maybe id_unf lit1-    -- If elemIndex returns Just, it has the index of the first embedded NUL-    -- in the string. If no NUL bytes are present (the common case) then use-    -- full length of the byte string.-  = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str)-     in Just (Lit (mkLitInt (roPlatform env) (fromIntegral len)))-match_cstring_length _ _ _ _ = Nothing------------------------------------------------------{- Note [inlineId magic]-~~~~~~~~~~~~~~~~~~~~~~~~-The call 'inline f' arranges that 'f' is inlined, regardless of-its size. More precisely, the call 'inline f' rewrites to the-right-hand side of 'f's definition. This allows the programmer to-control inlining from a particular call site rather than the-definition site of the function.--The moving parts are simple:--* A very simple definition in the library base:GHC.Magic-     {-# NOINLINE[0] inline #-}-     inline :: a -> a-     inline x = x-  So in phase 0, 'inline' will be inlined, so its use imposes-  no overhead.--* A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes-  (inline f) inline, implemented by match_inline.-  The rule for the 'inline' function is this:-     inline f_ty (f a b c) = <f's unfolding> a b c-  (if f has an unfolding, EVEN if it's a loop breaker)--  It's important to allow the argument to 'inline' to have args itself-  (a) because its more forgiving to allow the programmer to write-      either  inline f a b c-      or      inline (f a b c)-  (b) because a polymorphic f wll get a type argument that the-      programmer can't avoid, so the call may look like-        inline (map @Int @Bool) g xs--  Also, don't forget about 'inline's type argument!--}--match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_inline (Type _ : e : _)-  | (Var f, args1) <- collectArgs e,-    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)-             -- Ignore the IdUnfoldingFun here!-  = Just (mkApps unf args1)--match_inline _ = Nothing-------------------------------------------------------- See Note [magicDictId magic] in "GHC.Types.Id.Make"--- for a description of what is going on here.-match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)-match_magicDict [Type _, (stripTicksE (const True) -> (Var wrap `App` Type a `App` Type _ `App` f)), x, y ]-  | Just (_, fieldTy, _)  <- splitFunTy_maybe $ dropForAlls $ idType wrap-  , Just (_, dictTy, _)   <- splitFunTy_maybe fieldTy-  , Just dictTc           <- tyConAppTyCon_maybe dictTy-  , Just (_,_,co)         <- unwrapNewTyCon_maybe dictTc-  = Just-  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))-      `App` y--match_magicDict _ = Nothing------------------------------------------------------------- Note [Constant folding through nested expressions]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ We use rewrites rules to perform constant folding. It means that we don't--- have a global view of the expression we are trying to optimise. As a--- consequence we only perform local (small-step) transformations that either:---    1) reduce the number of operations---    2) rearrange the expression to increase the odds that other rules will---    match------ We don't try to handle more complex expression optimisation cases that would--- require a global view. For example, rewriting expressions to increase--- sharing (e.g., Horner's method); optimisations that require local--- transformations increasing the number of operations; rearrangements to--- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).------ We already have rules to perform constant folding on expressions with the--- following shape (where a and/or b are literals):------          D)    op---                /\---               /  \---              /    \---             a      b------ To support nested expressions, we match three other shapes of expression--- trees:------ A)   op1          B)       op1       C)       op1---      /\                    /\                 /\---     /  \                  /  \               /  \---    /    \                /    \             /    \---   a     op2            op2     c          op2    op3---          /\            /\                 /\      /\---         /  \          /  \               /  \    /  \---        b    c        a    b             a    b  c    d--------- R1) +/- simplification:---    ops = + or -, two literals (not siblings)------    Examples:---       A: 5 + (10-x)  ==> 15-x---       B: (10+x) + 5  ==> 15+x---       C: (5+a)-(5-b) ==> 0+(a+b)------ R2) * simplification---    ops = *, two literals (not siblings)------    Examples:---       A: 5 * (10*x)  ==> 50*x---       B: (10*x) * 5  ==> 50*x---       C: (5*a)*(5*b) ==> 25*(a*b)------ R3) * distribution over +/----    op1 = *, op2 = + or -, two literals (not siblings)------    This transformation doesn't reduce the number of operations but switches---    the outer and the inner operations so that the outer is (+) or (-) instead---    of (*). It increases the odds that other rules will match after this one.------    Examples:---       A: 5 * (10-x)  ==> 50 - (5*x)---       B: (10+x) * 5  ==> 50 + (5*x)---       C: Not supported as it would increase the number of operations:---          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b------ R4) Simple factorization------    op1 = + or -, op2/op3 = *,---    one literal for each innermost * operation (except in the D case),---    the two other terms are equals------    Examples:---       A: x - (10*x)  ==> (-9)*x---       B: (10*x) + x  ==> 11*x---       C: (5*x)-(x*3) ==> 2*x---       D: x+x         ==> 2*x------ R5) +/- propagation------    ops = + or -, one literal------    This transformation doesn't reduce the number of operations but propagates---    the constant to the outer level. It increases the odds that other rules---    will match after this one.------    Examples:---       A: x - (10-y)  ==> (x+y) - 10---       B: (10+x) - y  ==> 10 + (x-y)---       C: N/A (caught by the A and B cases)---------------------------------------------------------------- | Rules to perform constant folding into nested expressions------See Note [Constant folding through nested expressions]-numFoldingRules :: PrimOp -> (Platform -> PrimOps) -> RuleM CoreExpr-numFoldingRules op dict = do-  env <- getEnv-  if not (roNumConstantFolding env)-   then mzero-   else do-    [e1,e2] <- getArgs-    platform <- getPlatform-    let PrimOps{..} = dict platform-    case BinOpApp e1 op e2 of-     -- R1) +/- simplification-     x    :++: (y :++: v)          -> return $ mkL (x+y)   `add` v-     x    :++: (L y :-: v)         -> return $ mkL (x+y)   `sub` v-     x    :++: (v   :-: L y)       -> return $ mkL (x-y)   `add` v-     L x  :-:  (y :++: v)          -> return $ mkL (x-y)   `sub` v-     L x  :-:  (L y :-: v)         -> return $ mkL (x-y)   `add` v-     L x  :-:  (v   :-: L y)       -> return $ mkL (x+y)   `sub` v--     (y :++: v)    :-: L x         -> return $ mkL (y-x)   `add` v-     (L y :-: v)   :-: L x         -> return $ mkL (y-x)   `sub` v-     (v   :-: L y) :-: L x         -> return $ mkL (0-y-x) `add` v--     (x :++: w)  :+: (y :++: v)    -> return $ mkL (x+y)   `add` (w `add` v)-     (w :-: L x) :+: (L y :-: v)   -> return $ mkL (y-x)   `add` (w `sub` v)-     (w :-: L x) :+: (v   :-: L y) -> return $ mkL (0-x-y) `add` (w `add` v)-     (L x :-: w) :+: (L y :-: v)   -> return $ mkL (x+y)   `sub` (w `add` v)-     (L x :-: w) :+: (v   :-: L y) -> return $ mkL (x-y)   `add` (v `sub` w)-     (w :-: L x) :+: (y :++: v)    -> return $ mkL (y-x)   `add` (w `add` v)-     (L x :-: w) :+: (y :++: v)    -> return $ mkL (x+y)   `add` (v `sub` w)-     (y :++: v)  :+: (w :-: L x)   -> return $ mkL (y-x)   `add` (w `add` v)-     (y :++: v)  :+: (L x :-: w)   -> return $ mkL (x+y)   `add` (v `sub` w)--     (v   :-: L y) :-: (w :-: L x) -> return $ mkL (x-y)   `add` (v `sub` w)-     (v   :-: L y) :-: (L x :-: w) -> return $ mkL (0-x-y) `add` (v `add` w)-     (L y :-:   v) :-: (w :-: L x) -> return $ mkL (x+y)   `sub` (v `add` w)-     (L y :-:   v) :-: (L x :-: w) -> return $ mkL (y-x)   `add` (w `sub` v)-     (x :++: w)    :-: (y :++: v)  -> return $ mkL (x-y)   `add` (w `sub` v)-     (w :-: L x)   :-: (y :++: v)  -> return $ mkL (0-y-x) `add` (w `sub` v)-     (L x :-: w)   :-: (y :++: v)  -> return $ mkL (x-y)   `sub` (v `add` w)-     (y :++: v)    :-: (w :-: L x) -> return $ mkL (y+x)   `add` (v `sub` w)-     (y :++: v)    :-: (L x :-: w) -> return $ mkL (y-x)   `add` (v `add` w)--     -- R2) * simplification-     x :**: (y :**: v)             -> return $ mkL (x*y)   `mul` v-     (x :**: w) :*: (y :**: v)     -> return $ mkL (x*y)   `mul` (w `mul` v)--     -- R3) * distribution over +/--     x :**: (y :++: v)             -> return $ mkL (x*y)   `add` (mkL x `mul` v)-     x :**: (L y :-: v)            -> return $ mkL (x*y)   `sub` (mkL x `mul` v)-     x :**: (v   :-: L y)          -> return $ (mkL x `mul` v) `sub` mkL (x*y)--     -- R4) Simple factorization-     v :+: w-      | w `cheapEqExpr` v          -> return $ mkL 2       `mul` v-     w :+: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (1+y)   `mul` v-     w :-: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (1-y)   `mul` v-     (y :**: v) :+: w-      | w `cheapEqExpr` v          -> return $ mkL (y+1)   `mul` v-     (y :**: v) :-: w-      | w `cheapEqExpr` v          -> return $ mkL (y-1)   `mul` v-     (x :**: w) :+: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (x+y)   `mul` v-     (x :**: w) :-: (y :**: v)-      | w `cheapEqExpr` v          -> return $ mkL (x-y)   `mul` v--     -- R5) +/- propagation-     w  :+: (y :++: v)             -> return $ mkL y `add` (w `add` v)-     (y :++: v) :+: w              -> return $ mkL y       `add` (w `add` v)-     w  :-: (y :++: v)             -> return $ (w `sub` v) `sub` mkL y-     (y :++: v) :-: w              -> return $ mkL y       `add` (v `sub` w)-     w    :-: (L y :-: v)          -> return $ (w `add` v) `sub` mkL y-     (L y :-: v) :-: w             -> return $ mkL y       `sub` (w `add` v)-     w    :+: (L y :-: v)          -> return $ mkL y       `add` (w `sub` v)-     w    :+: (v :-: L y)          -> return $ (w `add` v) `sub` mkL y-     (L y :-: v) :+: w             -> return $ mkL y       `add` (w `sub` v)-     (v :-: L y) :+: w             -> return $ (w `add` v) `sub` mkL y--     _                             -> mzero------ | Match the application of a binary primop-pattern BinOpApp  :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr-pattern BinOpApp  x op y =  OpVal op `App` x `App` y---- | Match a primop-pattern OpVal   :: PrimOp  -> Arg CoreBndr-pattern OpVal   op     <- Var (isPrimOpId_maybe -> Just op) where-   OpVal op = Var (mkPrimOpId op)------ | Match a literal-pattern L :: Integer -> Arg CoreBndr-pattern L l <- Lit (isLitValue_maybe -> Just l)---- | Match an addition-pattern (:+:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :+: y <- BinOpApp x (isAddOp -> True) y---- | Match an addition with a literal (handle commutativity)-pattern (:++:) :: Integer -> Arg CoreBndr -> CoreExpr-pattern l :++: x <- (isAdd -> Just (l,x))--isAdd :: CoreExpr -> Maybe (Integer,CoreExpr)-isAdd e = case e of-   L l :+: x   -> Just (l,x)-   x   :+: L l -> Just (l,x)-   _           -> Nothing---- | Match a multiplication-pattern (:*:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :*: y <- BinOpApp x (isMulOp -> True) y---- | Match a multiplication with a literal (handle commutativity)-pattern (:**:) :: Integer -> Arg CoreBndr -> CoreExpr-pattern l :**: x <- (isMul -> Just (l,x))--isMul :: CoreExpr -> Maybe (Integer,CoreExpr)-isMul e = case e of-   L l :*: x   -> Just (l,x)-   x   :*: L l -> Just (l,x)-   _           -> Nothing----- | Match a subtraction-pattern (:-:) :: Arg CoreBndr -> Arg CoreBndr -> CoreExpr-pattern x :-: y <- BinOpApp x (isSubOp -> True) y--isSubOp :: PrimOp -> Bool-isSubOp IntSubOp  = True-isSubOp WordSubOp = True-isSubOp _         = False--isAddOp :: PrimOp -> Bool-isAddOp IntAddOp  = True-isAddOp WordAddOp = True-isAddOp _         = False--isMulOp :: PrimOp -> Bool-isMulOp IntMulOp  = True-isMulOp WordMulOp = True-isMulOp _         = False---- | Explicit "type-class"-like dictionary for numeric primops------ Depends on Platform because creating a literal value depends on Platform-data PrimOps = PrimOps-   { add :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Add two numbers-   , sub :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Sub two numbers-   , mul :: CoreExpr -> CoreExpr -> CoreExpr -- ^ Multiply two numbers-   , mkL :: Integer -> CoreExpr              -- ^ Create a literal value-   }--intPrimOps :: Platform -> PrimOps-intPrimOps platform = PrimOps-   { add = \x y -> BinOpApp x IntAddOp y-   , sub = \x y -> BinOpApp x IntSubOp y-   , mul = \x y -> BinOpApp x IntMulOp y-   , mkL = intResult' platform-   }--wordPrimOps :: Platform -> PrimOps-wordPrimOps platform = PrimOps-   { add = \x y -> BinOpApp x WordAddOp y-   , sub = \x y -> BinOpApp x WordSubOp y-   , mul = \x y -> BinOpApp x WordMulOp y-   , mkL = wordResult' platform-   }-------------------------------------------------------------- Constant folding through case-expressions------ cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils------------------------------------------------------------- | Match the scrutinee of a case and potentially return a new scrutinee and a--- function to apply to each literal alternative.-caseRules :: Platform-          -> CoreExpr                       -- Scrutinee-          -> Maybe ( CoreExpr               -- New scrutinee-                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern-                                            --   Nothing <=> Unreachable-                                            -- See Note [Unreachable caseRules alternatives]-                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee-                                            -- from the new case-binder--- e.g  case e of b {---         ...;---         con bs -> rhs;---         ... }---  ==>---      case e' of b' {---         ...;---         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;---         ... }--caseRules platform (App (App (Var f) v) (Lit l))   -- v `op` x#-  | Just op <- isPrimOpId_maybe f-  , Just x  <- isLitValue_maybe l-  , Just adjust_lit <- adjustDyadicRight op x-  = Just (v, tx_lit_con platform adjust_lit-           , \v -> (App (App (Var f) (Var v)) (Lit l)))--caseRules platform (App (App (Var f) (Lit l)) v)   -- x# `op` v-  | Just op <- isPrimOpId_maybe f-  , Just x  <- isLitValue_maybe l-  , Just adjust_lit <- adjustDyadicLeft x op-  = Just (v, tx_lit_con platform adjust_lit-           , \v -> (App (App (Var f) (Lit l)) (Var v)))---caseRules platform (App (Var f) v              )   -- op v-  | Just op <- isPrimOpId_maybe f-  , Just adjust_lit <- adjustUnary op-  = Just (v, tx_lit_con platform adjust_lit-           , \v -> App (Var f) (Var v))---- See Note [caseRules for tagToEnum]-caseRules platform (App (App (Var f) type_arg) v)-  | Just TagToEnumOp <- isPrimOpId_maybe f-  = Just (v, tx_con_tte platform-           , \v -> (App (App (Var f) type_arg) (Var v)))---- See Note [caseRules for dataToTag]-caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x-  | Just DataToTagOp <- isPrimOpId_maybe f-  , Just (tc, _) <- tcSplitTyConApp_maybe ty-  , isAlgTyCon tc-  = Just (v, tx_con_dtt ty-           , \v -> App (App (Var f) (Type ty)) (Var v))--caseRules _ _ = Nothing---tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon-tx_lit_con _        _      DEFAULT    = Just DEFAULT-tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)-tx_lit_con _        _      alt        = pprPanic "caseRules" (ppr alt)-   -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the-   -- literal alternatives remain in Word/Int target ranges-   -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172).--adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)--- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x-adjustDyadicRight op lit-  = case op of-         WordAddOp -> Just (\y -> y-lit      )-         IntAddOp  -> Just (\y -> y-lit      )-         WordSubOp -> Just (\y -> y+lit      )-         IntSubOp  -> Just (\y -> y+lit      )-         XorOp     -> Just (\y -> y `xor` lit)-         XorIOp    -> Just (\y -> y `xor` lit)-         _         -> Nothing--adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)--- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x-adjustDyadicLeft lit op-  = case op of-         WordAddOp -> Just (\y -> y-lit      )-         IntAddOp  -> Just (\y -> y-lit      )-         WordSubOp -> Just (\y -> lit-y      )-         IntSubOp  -> Just (\y -> lit-y      )-         XorOp     -> Just (\y -> y `xor` lit)-         XorIOp    -> Just (\y -> y `xor` lit)-         _         -> Nothing---adjustUnary :: PrimOp -> Maybe (Integer -> Integer)--- Given (op x) return a function 'f' s.t.  f (op x) = x-adjustUnary op-  = case op of-         NotOp     -> Just (\y -> complement y)-         NotIOp    -> Just (\y -> complement y)-         IntNegOp  -> Just (\y -> negate y    )-         _         -> Nothing--tx_con_tte :: Platform -> AltCon -> Maybe AltCon-tx_con_tte _        DEFAULT         = Just DEFAULT-tx_con_tte _        alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)-tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]-  = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc--tx_con_dtt :: Type -> AltCon -> Maybe AltCon-tx_con_dtt _  DEFAULT = Just DEFAULT-tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))-   | tag >= 0-   , tag < n_data_cons-   = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)-   | otherwise-   = Nothing-   where-     tag         = fromInteger i :: ConTagZ-     tc          = tyConAppTyCon ty-     n_data_cons = tyConFamilySize tc-     data_cons   = tyConDataCons tc--tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)---{- Note [caseRules for tagToEnum]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We want to transform-   case tagToEnum x of-     False -> e1-     True  -> e2-into-   case x of-     0# -> e1-     1# -> e2--This rule eliminates a lot of boilerplate. For-  if (x>y) then e2 else e1-we generate-  case tagToEnum (x ># y) of-    False -> e1-    True  -> e2-and it is nice to then get rid of the tagToEnum.--Beware (#14768): avoid the temptation to map constructor 0 to-DEFAULT, in the hope of getting this-  case (x ># y) of-    DEFAULT -> e1-    1#      -> e2-That fails utterly in the case of-   data Colour = Red | Green | Blue-   case tagToEnum x of-      DEFAULT -> e1-      Red     -> e2--We don't want to get this!-   case x of-      DEFAULT -> e1-      DEFAULT -> e2--Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils-(add_default in mkCase3).--Note [caseRules for dataToTag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [dataToTag#] in primpops.txt.pp--We want to transform-  case dataToTag x of-    DEFAULT -> e1-    1# -> e2-into-  case x of-    DEFAULT -> e1-    (:) _ _ -> e2--Note the need for some wildcard binders in-the 'cons' case.--For the time, we only apply this transformation when the type of `x` is a type-headed by a normal tycon. In particular, we do not apply this in the case of a-data family tycon, since that would require carefully applying coercion(s)-between the data family and the data family instance's representation type,-which caseRules isn't currently engineered to handle (#14680).--Note [Unreachable caseRules alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Take care if we see something like-  case dataToTag x of-    DEFAULT -> e1-    -1# -> e2-    100 -> e3-because there isn't a data constructor with tag -1 or 100. In this case the-out-of-range alternative is dead code -- we know the range of tags for x.--Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating-an alternative that is unreachable.--You may wonder how this can happen: check out #15436.+Conceptually, constant folding should be parameterized with the kind+of target machine to get identical behaviour during compilation time+and runtime. We cheat a little bit here...++ToDo:+   check boundaries before folding, e.g. we can fold the Float addition+   (i1 + i2) only if it results in a valid Float.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}++-- | Constant Folder+module GHC.Core.Opt.ConstantFold+   ( primOpRules+   , builtinRules+   , caseRules+   )+where++#include "HsVersions.h"+#include "MachDeps.h"++import GHC.Prelude++import GHC.Driver.Ppr++import {-# SOURCE #-} GHC.Types.Id.Make ( mkPrimOpId, magicDictId, voidPrimId )++import GHC.Core+import GHC.Core.Make+import GHC.Types.Id+import GHC.Types.Literal+import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe )+import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Core.TyCon+   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon+   , isNewTyCon, unwrapNewTyCon_maybe, tyConDataCons+   , tyConFamilySize )+import GHC.Core.DataCon ( dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )+import GHC.Core.Utils  ( eqExpr, cheapEqExpr, exprIsHNF, exprType+                       , stripTicksTop, stripTicksTopT, mkTicks, stripTicksE )+import GHC.Core.Multiplicity+import GHC.Core.FVs+import GHC.Core.Type+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Name.Occurrence ( occNameFS )+import GHC.Types.Tickish+import GHC.Builtin.Names+import GHC.Data.Maybe      ( orElse )+import GHC.Types.Name ( Name, nameOccName )+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Types.Basic+import GHC.Platform+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Core.Coercion   (mkUnbranchedAxInstCo,mkSymCo,Role(..))++import Control.Applicative ( Alternative(..) )++import Control.Monad+import Data.Functor (($>))+import qualified Data.ByteString as BS+import Data.Ratio+import Data.Word+import Data.Maybe (fromMaybe)++{-+Note [Constant folding]+~~~~~~~~~~~~~~~~~~~~~~~+primOpRules generates a rewrite rule for each primop+These rules do what is often called "constant folding"+E.g. the rules for +# might say+        4 +# 5 = 9+Well, of course you'd need a lot of rules if you did it+like that, so we use a BuiltinRule instead, so that we+can match in any two literal values.  So the rule is really+more like+        (Lit x) +# (Lit y) = Lit (x+#y)+where the (+#) on the rhs is done at compile time++That is why these rules are built in here.+-}++primOpRules ::  Name -> PrimOp -> Maybe CoreRule+primOpRules nm = \case+   TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]+   DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]++   -- Int8 operations+   Int8AddOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))+                                    , identity zeroI8+                                    , addFoldingRules Int8AddOp int8Ops+                                    ]+   Int8SubOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (-))+                                    , rightIdentity zeroI8+                                    , equalArgs $> Lit zeroI8+                                    , subFoldingRules Int8SubOp int8Ops+                                    ]+   Int8MulOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (*))+                                    , zeroElem+                                    , identity oneI8+                                    , mulFoldingRules Int8MulOp int8Ops+                                    ]+   Int8QuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI8+                                    , equalArgs $> Lit oneI8 ]+   Int8RemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI8+                                    , equalArgs $> Lit zeroI8 ]+   Int8NegOp   -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int8NegOp ]+   Int8SllOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftL)+                                    , rightIdentity zeroI8 ]+   Int8SraOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 (const shiftR)+                                    , rightIdentity zeroI8 ]+   Int8SrlOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumInt8 $ const $ shiftRightLogical @Word8+                                    , rightIdentity zeroI8 ]++   -- Word8 operations+   Word8AddOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (+))+                                    , identity zeroW8+                                    , addFoldingRules Word8AddOp word8Ops+                                    ]+   Word8SubOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (-))+                                    , rightIdentity zeroW8+                                    , equalArgs $> Lit zeroW8+                                    , subFoldingRules Word8SubOp word8Ops+                                    ]+   Word8MulOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (*))+                                    , identity oneW8+                                    , mulFoldingRules Word8MulOp word8Ops+                                    ]+   Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot)+                                    , rightIdentity oneW8 ]+   Word8RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW8+                                    , equalArgs $> Lit zeroW8 ]+   Word8AndOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , sameArgIdempotentCommut Word8AndOp+                                    ]+   Word8OrOp   -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 (.|.))+                                    , idempotent+                                    , identity zeroW8+                                    , sameArgIdempotentCommut Word8OrOp+                                    ]+   Word8XorOp  -> mkPrimOpRule nm 2 [ binaryLit (word8Op2 xor)+                                    , identity zeroW8+                                    , equalArgs $> Lit zeroW8 ]+   Word8NotOp  -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word8NotOp ]+   Word8SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]+   Word8SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word8 ]+++   -- Int16 operations+   Int16AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (+))+                                    , identity zeroI16+                                    , addFoldingRules Int16AddOp int16Ops+                                    ]+   Int16SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (-))+                                    , rightIdentity zeroI16+                                    , equalArgs $> Lit zeroI16+                                    , subFoldingRules Int16SubOp int16Ops+                                    ]+   Int16MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int16Op2 (*))+                                    , zeroElem+                                    , identity oneI16+                                    , mulFoldingRules Int16MulOp int16Ops+                                    ]+   Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI16+                                    , equalArgs $> Lit oneI16 ]+   Int16RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI16+                                    , equalArgs $> Lit zeroI16 ]+   Int16NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int16NegOp ]+   Int16SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftL)+                                    , rightIdentity zeroI16 ]+   Int16SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 (const shiftR)+                                    , rightIdentity zeroI16 ]+   Int16SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt16 $ const $ shiftRightLogical @Word16+                                    , rightIdentity zeroI16 ]++   -- Word16 operations+   Word16AddOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (+))+                                    , identity zeroW16+                                    , addFoldingRules Word16AddOp word16Ops+                                    ]+   Word16SubOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (-))+                                    , rightIdentity zeroW16+                                    , equalArgs $> Lit zeroW16+                                    , subFoldingRules Word16SubOp word16Ops+                                    ]+   Word16MulOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (*))+                                    , identity oneW16+                                    , mulFoldingRules Word16MulOp word16Ops+                                    ]+   Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot)+                                    , rightIdentity oneW16 ]+   Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW16+                                    , equalArgs $> Lit zeroW16 ]+   Word16AndOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , sameArgIdempotentCommut Word16AndOp+                                    ]+   Word16OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 (.|.))+                                    , idempotent+                                    , identity zeroW16+                                    , sameArgIdempotentCommut Word16OrOp+                                    ]+   Word16XorOp -> mkPrimOpRule nm 2 [ binaryLit (word16Op2 xor)+                                    , identity zeroW16+                                    , equalArgs $> Lit zeroW16 ]+   Word16NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word16NotOp ]+   Word16SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]+   Word16SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word16 ]+++   -- Int32 operations+   Int32AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (+))+                                    , identity zeroI32+                                    , addFoldingRules Int32AddOp int32Ops+                                    ]+   Int32SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (-))+                                    , rightIdentity zeroI32+                                    , equalArgs $> Lit zeroI32+                                    , subFoldingRules Int32SubOp int32Ops+                                    ]+   Int32MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int32Op2 (*))+                                    , zeroElem+                                    , identity oneI32+                                    , mulFoldingRules Int32MulOp int32Ops+                                    ]+   Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI32+                                    , equalArgs $> Lit oneI32 ]+   Int32RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI32+                                    , equalArgs $> Lit zeroI32 ]+   Int32NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int32NegOp ]+   Int32SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftL)+                                    , rightIdentity zeroI32 ]+   Int32SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 (const shiftR)+                                    , rightIdentity zeroI32 ]+   Int32SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt32 $ const $ shiftRightLogical @Word32+                                    , rightIdentity zeroI32 ]++   -- Word32 operations+   Word32AddOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (+))+                                    , identity zeroW32+                                    , addFoldingRules Word32AddOp word32Ops+                                    ]+   Word32SubOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (-))+                                    , rightIdentity zeroW32+                                    , equalArgs $> Lit zeroW32+                                    , subFoldingRules Word32SubOp word32Ops+                                    ]+   Word32MulOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (*))+                                    , identity oneW32+                                    , mulFoldingRules Word32MulOp word32Ops+                                    ]+   Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot)+                                    , rightIdentity oneW32 ]+   Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW32+                                    , equalArgs $> Lit zeroW32 ]+   Word32AndOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , sameArgIdempotentCommut Word32AndOp+                                    ]+   Word32OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 (.|.))+                                    , idempotent+                                    , identity zeroW32+                                    , sameArgIdempotentCommut Word32OrOp+                                    ]+   Word32XorOp -> mkPrimOpRule nm 2 [ binaryLit (word32Op2 xor)+                                    , identity zeroW32+                                    , equalArgs $> Lit zeroW32 ]+   Word32NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word32NotOp ]+   Word32SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]+   Word32SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord $ const $ shiftRightLogical @Word32 ]++#if WORD_SIZE_IN_BITS < 64+   -- Int64 operations+   Int64AddOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (+))+                                    , identity zeroI64+                                    , addFoldingRules Int64AddOp int64Ops+                                    ]+   Int64SubOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (-))+                                    , rightIdentity zeroI64+                                    , equalArgs $> Lit zeroI64+                                    , subFoldingRules Int64SubOp int64Ops+                                    ]+   Int64MulOp  -> mkPrimOpRule nm 2 [ binaryLit (int64Op2 (*))+                                    , zeroElem+                                    , identity oneI64+                                    , mulFoldingRules Int64MulOp int64Ops+                                    ]+   Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot)+                                    , leftZero+                                    , rightIdentity oneI64+                                    , equalArgs $> Lit oneI64 ]+   Int64RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroI64+                                    , equalArgs $> Lit zeroI64 ]+   Int64NegOp  -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp Int64NegOp ]+   Int64SllOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftL)+                                    , rightIdentity zeroI64 ]+   Int64SraOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 (const shiftR)+                                    , rightIdentity zeroI64 ]+   Int64SrlOp  -> mkPrimOpRule nm 2 [ shiftRule LitNumInt64 $ const $ shiftRightLogical @Word64+                                    , rightIdentity zeroI64 ]++   -- Word64 operations+   Word64AddOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (+))+                                    , identity zeroW64+                                    , addFoldingRules Word64AddOp word64Ops+                                    ]+   Word64SubOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (-))+                                    , rightIdentity zeroW64+                                    , equalArgs $> Lit zeroW64+                                    , subFoldingRules Word64SubOp word64Ops+                                    ]+   Word64MulOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (*))+                                    , identity oneW64+                                    , mulFoldingRules Word64MulOp word64Ops+                                    ]+   Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot)+                                    , rightIdentity oneW64 ]+   Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem)+                                    , leftZero+                                    , oneLit 1 $> Lit zeroW64+                                    , equalArgs $> Lit zeroW64 ]+   Word64AndOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , sameArgIdempotentCommut Word64AndOp+                                    ]+   Word64OrOp  -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 (.|.))+                                    , idempotent+                                    , identity zeroW64+                                    , sameArgIdempotentCommut Word64OrOp+                                    ]+   Word64XorOp -> mkPrimOpRule nm 2 [ binaryLit (word64Op2 xor)+                                    , identity zeroW64+                                    , equalArgs $> Lit zeroW64 ]+   Word64NotOp -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp Word64NotOp ]+   Word64SllOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 (const shiftL) ]+   Word64SrlOp -> mkPrimOpRule nm 2 [ shiftRule LitNumWord64 $ const $ shiftRightLogical @Word64 ]+#endif++   -- Int operations+   IntAddOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (+))+                                    , identityPlatform zeroi+                                    , addFoldingRules IntAddOp intOps+                                    ]+   IntSubOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (-))+                                    , rightIdentityPlatform zeroi+                                    , equalArgs >> retLit zeroi+                                    , subFoldingRules IntSubOp intOps+                                    ]+   IntAddCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (+))+                                    , identityCPlatform zeroi ]+   IntSubCOp   -> mkPrimOpRule nm 2 [ binaryLit (intOpC2 (-))+                                    , rightIdentityCPlatform zeroi+                                    , equalArgs >> retLitNoC zeroi ]+   IntMulOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (*))+                                    , zeroElem+                                    , identityPlatform onei+                                    , mulFoldingRules IntMulOp intOps+                                    ]+   IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)+                                    , leftZero+                                    , rightIdentityPlatform onei+                                    , equalArgs >> retLit onei ]+   IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)+                                    , leftZero+                                    , oneLit 1 >> retLit zeroi+                                    , equalArgs >> retLit zeroi ]+   IntAndOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , sameArgIdempotentCommut IntAndOp+                                    ]+   IntOrOp     -> mkPrimOpRule nm 2 [ binaryLit (intOp2 (.|.))+                                    , idempotent+                                    , identityPlatform zeroi+                                    , sameArgIdempotentCommut IntOrOp+                                    ]+   IntXorOp    -> mkPrimOpRule nm 2 [ binaryLit (intOp2 xor)+                                    , identityPlatform zeroi+                                    , equalArgs >> retLit zeroi ]+   IntNotOp    -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp IntNotOp ]+   IntNegOp    -> mkPrimOpRule nm 1 [ unaryLit negOp+                                    , semiInversePrimOp IntNegOp ]+   IntSllOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftL)+                                    , rightIdentityPlatform zeroi ]+   IntSraOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt (const shiftR)+                                    , rightIdentityPlatform zeroi ]+   IntSrlOp    -> mkPrimOpRule nm 2 [ shiftRule LitNumInt shiftRightLogicalNative+                                    , rightIdentityPlatform zeroi ]++   -- Word operations+   WordAddOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (+))+                                    , identityPlatform zerow+                                    , addFoldingRules WordAddOp wordOps+                                    ]+   WordSubOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (-))+                                    , rightIdentityPlatform zerow+                                    , equalArgs >> retLit zerow+                                    , subFoldingRules WordSubOp wordOps+                                    ]+   WordAddCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (+))+                                    , identityCPlatform zerow ]+   WordSubCOp  -> mkPrimOpRule nm 2 [ binaryLit (wordOpC2 (-))+                                    , rightIdentityCPlatform zerow+                                    , equalArgs >> retLitNoC zerow ]+   WordMulOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (*))+                                    , identityPlatform onew+                                    , mulFoldingRules WordMulOp wordOps+                                    ]+   WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)+                                    , rightIdentityPlatform onew ]+   WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)+                                    , leftZero+                                    , oneLit 1 >> retLit zerow+                                    , equalArgs >> retLit zerow ]+   WordAndOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.&.))+                                    , idempotent+                                    , zeroElem+                                    , sameArgIdempotentCommut WordAndOp+                                    ]+   WordOrOp    -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 (.|.))+                                    , idempotent+                                    , identityPlatform zerow+                                    , sameArgIdempotentCommut WordOrOp+                                    ]+   WordXorOp   -> mkPrimOpRule nm 2 [ binaryLit (wordOp2 xor)+                                    , identityPlatform zerow+                                    , equalArgs >> retLit zerow ]+   WordNotOp   -> mkPrimOpRule nm 1 [ unaryLit complementOp+                                    , semiInversePrimOp WordNotOp ]+   WordSllOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumWord (const shiftL) ]+   WordSrlOp   -> mkPrimOpRule nm 2 [ shiftRule LitNumWord shiftRightLogicalNative ]++   -- coercions++   Int8ToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]+   Int16ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]+   Int32ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]+#if WORD_SIZE_IN_BITS < 64+   Int64ToIntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform extendIntLit ]+#endif+   IntToInt8Op    -> mkPrimOpRule nm 1 [ liftLit narrowInt8Lit+                                       , semiInversePrimOp Int8ToIntOp+                                       , narrowSubsumesAnd IntAndOp IntToInt8Op 8 ]+   IntToInt16Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt16Lit+                                       , semiInversePrimOp Int16ToIntOp+                                       , narrowSubsumesAnd IntAndOp IntToInt16Op 16 ]+   IntToInt32Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt32Lit+                                       , semiInversePrimOp Int32ToIntOp+                                       , narrowSubsumesAnd IntAndOp IntToInt32Op 32 ]+#if WORD_SIZE_IN_BITS < 64+   IntToInt64Op   -> mkPrimOpRule nm 1 [ liftLit narrowInt64Lit ]+#endif++   Word8ToWordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit+                                       , extendNarrowPassthrough WordToWord8Op 0xFF+                                       ]+   Word16ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit+                                       , extendNarrowPassthrough WordToWord16Op 0xFFFF+                                       ]+   Word32ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit+                                       , extendNarrowPassthrough WordToWord32Op 0xFFFFFFFF+                                       ]+#if WORD_SIZE_IN_BITS < 64+   Word64ToWordOp -> mkPrimOpRule nm 1 [ liftLitPlatform extendWordLit ]+#endif++   WordToWord8Op  -> mkPrimOpRule nm 1 [ liftLit narrowWord8Lit+                                       , semiInversePrimOp Word8ToWordOp+                                       , narrowSubsumesAnd WordAndOp WordToWord8Op 8 ]+   WordToWord16Op -> mkPrimOpRule nm 1 [ liftLit narrowWord16Lit+                                       , semiInversePrimOp Word16ToWordOp+                                       , narrowSubsumesAnd WordAndOp WordToWord16Op 16 ]+   WordToWord32Op -> mkPrimOpRule nm 1 [ liftLit narrowWord32Lit+                                       , semiInversePrimOp Word32ToWordOp+                                       , narrowSubsumesAnd WordAndOp WordToWord32Op 32 ]+#if WORD_SIZE_IN_BITS < 64+   WordToWord64Op -> mkPrimOpRule nm 1 [ liftLit narrowWord64Lit ]+#endif++   Word8ToInt8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt8)+                                       , semiInversePrimOp Int8ToWord8Op ]+   Int8ToWord8Op  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord8)+                                       , semiInversePrimOp Word8ToInt8Op ]+   Word16ToInt16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt16)+                                       , semiInversePrimOp Int16ToWord16Op ]+   Int16ToWord16Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord16)+                                       , semiInversePrimOp Word16ToInt16Op ]+   Word32ToInt32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt32)+                                       , semiInversePrimOp Int32ToWord32Op ]+   Int32ToWord32Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord32)+                                       , semiInversePrimOp Word32ToInt32Op ]+#if WORD_SIZE_IN_BITS < 64+   Word64ToInt64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt64)+                                       , semiInversePrimOp Int64ToWord64Op ]+   Int64ToWord64Op-> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord64)+                                       , semiInversePrimOp Word64ToInt64Op ]+#endif++   WordToIntOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumInt)+                                       , semiInversePrimOp IntToWordOp ]+   IntToWordOp    -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumCoerce LitNumWord)+                                       , semiInversePrimOp WordToIntOp ]++   Narrow8IntOp   -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt8)+                                       , subsumedByPrimOp Narrow8IntOp+                                       , Narrow8IntOp `subsumesPrimOp` Narrow16IntOp+                                       , Narrow8IntOp `subsumesPrimOp` Narrow32IntOp+                                       , narrowSubsumesAnd IntAndOp Narrow8IntOp 8 ]+   Narrow16IntOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt16)+                                       , subsumedByPrimOp Narrow8IntOp+                                       , subsumedByPrimOp Narrow16IntOp+                                       , Narrow16IntOp `subsumesPrimOp` Narrow32IntOp+                                       , narrowSubsumesAnd IntAndOp Narrow16IntOp 16 ]+   Narrow32IntOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumInt32)+                                       , subsumedByPrimOp Narrow8IntOp+                                       , subsumedByPrimOp Narrow16IntOp+                                       , subsumedByPrimOp Narrow32IntOp+                                       , removeOp32+                                       , narrowSubsumesAnd IntAndOp Narrow32IntOp 32 ]+   Narrow8WordOp  -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord8)+                                       , subsumedByPrimOp Narrow8WordOp+                                       , Narrow8WordOp `subsumesPrimOp` Narrow16WordOp+                                       , Narrow8WordOp `subsumesPrimOp` Narrow32WordOp+                                       , narrowSubsumesAnd WordAndOp Narrow8WordOp 8 ]+   Narrow16WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord16)+                                       , subsumedByPrimOp Narrow8WordOp+                                       , subsumedByPrimOp Narrow16WordOp+                                       , Narrow16WordOp `subsumesPrimOp` Narrow32WordOp+                                       , narrowSubsumesAnd WordAndOp Narrow16WordOp 16 ]+   Narrow32WordOp -> mkPrimOpRule nm 1 [ liftLitPlatform (litNumNarrow LitNumWord32)+                                       , subsumedByPrimOp Narrow8WordOp+                                       , subsumedByPrimOp Narrow16WordOp+                                       , subsumedByPrimOp Narrow32WordOp+                                       , removeOp32+                                       , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ]++   OrdOp          -> mkPrimOpRule nm 1 [ liftLit charToIntLit+                                       , semiInversePrimOp ChrOp ]+   ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs+                                            guard (litFitsInChar lit)+                                            liftLit intToCharLit+                                       , semiInversePrimOp OrdOp ]+   FloatToIntOp    -> mkPrimOpRule nm 1 [ liftLit floatToIntLit ]+   IntToFloatOp    -> mkPrimOpRule nm 1 [ liftLit intToFloatLit ]+   DoubleToIntOp   -> mkPrimOpRule nm 1 [ liftLit doubleToIntLit ]+   IntToDoubleOp   -> mkPrimOpRule nm 1 [ liftLit intToDoubleLit ]+   -- SUP: Not sure what the standard says about precision in the following 2 cases+   FloatToDoubleOp -> mkPrimOpRule nm 1 [ liftLit floatToDoubleLit ]+   DoubleToFloatOp -> mkPrimOpRule nm 1 [ liftLit doubleToFloatLit ]++   -- Float+   FloatAddOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (+))+                                          , identity zerof ]+   FloatSubOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (-))+                                          , rightIdentity zerof ]+   FloatMulOp        -> mkPrimOpRule nm 2 [ binaryLit (floatOp2 (*))+                                          , identity onef+                                          , strengthReduction twof FloatAddOp  ]+             -- zeroElem zerof doesn't hold because of NaN+   FloatDivOp        -> mkPrimOpRule nm 2 [ guardFloatDiv >> binaryLit (floatOp2 (/))+                                          , rightIdentity onef ]+   FloatNegOp        -> mkPrimOpRule nm 1 [ unaryLit negOp+                                          , semiInversePrimOp FloatNegOp ]+   FloatDecode_IntOp -> mkPrimOpRule nm 1 [ unaryLit floatDecodeOp ]++   -- Double+   DoubleAddOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (+))+                                             , identity zerod ]+   DoubleSubOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (-))+                                             , rightIdentity zerod ]+   DoubleMulOp          -> mkPrimOpRule nm 2 [ binaryLit (doubleOp2 (*))+                                             , identity oned+                                             , strengthReduction twod DoubleAddOp  ]+              -- zeroElem zerod doesn't hold because of NaN+   DoubleDivOp          -> mkPrimOpRule nm 2 [ guardDoubleDiv >> binaryLit (doubleOp2 (/))+                                             , rightIdentity oned ]+   DoubleNegOp          -> mkPrimOpRule nm 1 [ unaryLit negOp+                                             , semiInversePrimOp DoubleNegOp ]+   DoubleDecode_Int64Op -> mkPrimOpRule nm 1 [ unaryLit doubleDecodeOp ]++   -- Relational operators++   IntEqOp    -> mkRelOpRule nm (==) [ litEq True ]+   IntNeOp    -> mkRelOpRule nm (/=) [ litEq False ]+   CharEqOp   -> mkRelOpRule nm (==) [ litEq True ]+   CharNeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   IntGtOp    -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   IntGeOp    -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   IntLeOp    -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   IntLtOp    -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   CharGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   CharGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   CharLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   CharLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]++   FloatGtOp  -> mkFloatingRelOpRule nm (>)+   FloatGeOp  -> mkFloatingRelOpRule nm (>=)+   FloatLeOp  -> mkFloatingRelOpRule nm (<=)+   FloatLtOp  -> mkFloatingRelOpRule nm (<)+   FloatEqOp  -> mkFloatingRelOpRule nm (==)+   FloatNeOp  -> mkFloatingRelOpRule nm (/=)++   DoubleGtOp -> mkFloatingRelOpRule nm (>)+   DoubleGeOp -> mkFloatingRelOpRule nm (>=)+   DoubleLeOp -> mkFloatingRelOpRule nm (<=)+   DoubleLtOp -> mkFloatingRelOpRule nm (<)+   DoubleEqOp -> mkFloatingRelOpRule nm (==)+   DoubleNeOp -> mkFloatingRelOpRule nm (/=)++   WordGtOp   -> mkRelOpRule nm (>)  [ boundsCmp Gt ]+   WordGeOp   -> mkRelOpRule nm (>=) [ boundsCmp Ge ]+   WordLeOp   -> mkRelOpRule nm (<=) [ boundsCmp Le ]+   WordLtOp   -> mkRelOpRule nm (<)  [ boundsCmp Lt ]+   WordEqOp   -> mkRelOpRule nm (==) [ litEq True ]+   WordNeOp   -> mkRelOpRule nm (/=) [ litEq False ]++   AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ]++   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]+   SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]++   _          -> Nothing++{-+************************************************************************+*                                                                      *+\subsection{Doing the business}+*                                                                      *+************************************************************************+-}++-- useful shorthands+mkPrimOpRule :: Name -> Int -> [RuleM CoreExpr] -> Maybe CoreRule+mkPrimOpRule nm arity rules = Just $ mkBasicRule nm arity (msum rules)++mkRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+            -> [RuleM CoreExpr] -> Maybe CoreRule+mkRelOpRule nm cmp extra+  = mkPrimOpRule nm 2 $+    binaryCmpLit cmp : equal_rule : extra+  where+        -- x `cmp` x does not depend on x, so+        -- compute it for the arbitrary value 'True'+        -- and use that result+    equal_rule = do { equalArgs+                    ; platform <- getPlatform+                    ; return (if cmp True True+                              then trueValInt  platform+                              else falseValInt platform) }++{- Note [Rules for floating-point comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need different rules for floating-point values because for floats+it is not true that x = x (for NaNs); so we do not want the equal_rule+rule that mkRelOpRule uses.++Note also that, in the case of equality/inequality, we do /not/+want to switch to a case-expression.  For example, we do not want+to convert+   case (eqFloat# x 3.8#) of+     True -> this+     False -> that+to+  case x of+    3.8#::Float# -> this+    _            -> that+See #9238.  Reason: comparing floating-point values for equality+delicate, and we don't want to implement that delicacy in the code for+case expressions.  So we make it an invariant of Core that a case+expression never scrutinises a Float# or Double#.++This transformation is what the litEq rule does;+see Note [The litEq rule: converting equality to case].+So we /refrain/ from using litEq for mkFloatingRelOpRule.+-}++mkFloatingRelOpRule :: Name -> (forall a . Ord a => a -> a -> Bool)+                    -> Maybe CoreRule+-- See Note [Rules for floating-point comparisons]+mkFloatingRelOpRule nm cmp+  = mkPrimOpRule nm 2 [binaryCmpLit cmp]++-- common constants+zeroi, onei, zerow, onew :: Platform -> Literal+zeroi platform = mkLitInt  platform 0+onei  platform = mkLitInt  platform 1+zerow platform = mkLitWord platform 0+onew  platform = mkLitWord platform 1++zeroI8, oneI8, zeroW8, oneW8 :: Literal+zeroI8 = mkLitInt8  0+oneI8  = mkLitInt8  1+zeroW8 = mkLitWord8 0+oneW8  = mkLitWord8 1++zeroI16, oneI16, zeroW16, oneW16 :: Literal+zeroI16 = mkLitInt16  0+oneI16  = mkLitInt16  1+zeroW16 = mkLitWord16 0+oneW16  = mkLitWord16 1++zeroI32, oneI32, zeroW32, oneW32 :: Literal+zeroI32 = mkLitInt32  0+oneI32  = mkLitInt32  1+zeroW32 = mkLitWord32 0+oneW32  = mkLitWord32 1++#if WORD_SIZE_IN_BITS < 64+zeroI64, oneI64, zeroW64, oneW64 :: Literal+zeroI64 = mkLitInt64  0+oneI64  = mkLitInt64  1+zeroW64 = mkLitWord64 0+oneW64  = mkLitWord64 1+#endif++zerof, onef, twof, zerod, oned, twod :: Literal+zerof = mkLitFloat 0.0+onef  = mkLitFloat 1.0+twof  = mkLitFloat 2.0+zerod = mkLitDouble 0.0+oned  = mkLitDouble 1.0+twod  = mkLitDouble 2.0++cmpOp :: Platform -> (forall a . Ord a => a -> a -> Bool)+      -> Literal -> Literal -> Maybe CoreExpr+cmpOp platform cmp = go+  where+    done True  = Just $ trueValInt  platform+    done False = Just $ falseValInt platform++    -- These compares are at different types+    go (LitChar i1)   (LitChar i2)   = done (i1 `cmp` i2)+    go (LitFloat i1)  (LitFloat i2)  = done (i1 `cmp` i2)+    go (LitDouble i1) (LitDouble i2) = done (i1 `cmp` i2)+    go (LitNumber nt1 i1) (LitNumber nt2 i2)+      | nt1 /= nt2 = Nothing+      | otherwise  = done (i1 `cmp` i2)+    go _               _               = Nothing++--------------------------++negOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Negate+negOp env = \case+   (LitFloat 0.0)  -> Nothing  -- can't represent -0.0 as a Rational+   (LitFloat f)    -> Just (mkFloatVal env (-f))+   (LitDouble 0.0) -> Nothing+   (LitDouble d)   -> Just (mkDoubleVal env (-d))+   (LitNumber nt i)+      | litNumIsSigned nt -> Just (Lit (mkLitNumberWrap (roPlatform env) nt (-i)))+   _ -> Nothing++complementOp :: RuleOpts -> Literal -> Maybe CoreExpr  -- Binary complement+complementOp env (LitNumber nt i) =+   Just (Lit (mkLitNumberWrap (roPlatform env) nt (complement i)))+complementOp _      _            = Nothing++int8Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int8Op2 op _ (LitNumber LitNumInt8 i1) (LitNumber LitNumInt8 i2) =+  int8Result (fromInteger i1 `op` fromInteger i2)+int8Op2 _ _ _ _ = Nothing++int16Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int16Op2 op _ (LitNumber LitNumInt16 i1) (LitNumber LitNumInt16 i2) =+  int16Result (fromInteger i1 `op` fromInteger i2)+int16Op2 _ _ _ _ = Nothing++int32Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int32Op2 op _ (LitNumber LitNumInt32 i1) (LitNumber LitNumInt32 i2) =+  int32Result (fromInteger i1 `op` fromInteger i2)+int32Op2 _ _ _ _ = Nothing++#if WORD_SIZE_IN_BITS < 64+int64Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+int64Op2 op _ (LitNumber LitNumInt64 i1) (LitNumber LitNumInt64 i2) =+  int64Result (fromInteger i1 `op` fromInteger i2)+int64Op2 _ _ _ _ = Nothing+#endif++intOp2 :: (Integral a, Integral b)+       => (a -> b -> Integer)+       -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOp2 = intOp2' . const++intOp2' :: (Integral a, Integral b)+        => (RuleOpts -> a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOp2' op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =+  let o = op env+  in  intResult (roPlatform env) (fromInteger i1 `o` fromInteger i2)+intOp2' _ _ _ _ = Nothing++intOpC2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+intOpC2 op env (LitNumber LitNumInt i1) (LitNumber LitNumInt i2) =+  intCResult (roPlatform env) (fromInteger i1 `op` fromInteger i2)+intOpC2 _ _ _ _ = Nothing++shiftRightLogical :: forall t. (Integral t, Bits t) => Integer -> Int -> Integer+shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: t)++-- | Shift right, putting zeros in rather than sign-propagating as+-- 'Bits.shiftR' would do. Do this by converting to the appropriate Word+-- and back. Obviously this won't work for too-big values, but its ok as+-- we use it here.+shiftRightLogicalNative :: Platform -> Integer -> Int -> Integer+shiftRightLogicalNative platform =+    case platformWordSize platform of+      PW4 -> shiftRightLogical @Word32+      PW8 -> shiftRightLogical @Word64++--------------------------+retLit :: (Platform -> Literal) -> RuleM CoreExpr+retLit l = do platform <- getPlatform+              return $ Lit $ l platform++retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr+retLitNoC l = do platform <- getPlatform+                 let lit = l platform+                 let ty = literalType lit+                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)]++word8Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word8Op2 op _ (LitNumber LitNumWord8 i1) (LitNumber LitNumWord8 i2) =+  word8Result (fromInteger i1 `op` fromInteger i2)+word8Op2 _ _ _ _ = Nothing++word16Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word16Op2 op _ (LitNumber LitNumWord16 i1) (LitNumber LitNumWord16 i2) =+  word16Result (fromInteger i1 `op` fromInteger i2)+word16Op2 _ _ _ _ = Nothing++word32Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word32Op2 op _ (LitNumber LitNumWord32 i1) (LitNumber LitNumWord32 i2) =+  word32Result (fromInteger i1 `op` fromInteger i2)+word32Op2 _ _ _ _ = Nothing++#if WORD_SIZE_IN_BITS < 64+word64Op2+  :: (Integral a, Integral b)+  => (a -> b -> Integer)+  -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+word64Op2 op _ (LitNumber LitNumWord64 i1) (LitNumber LitNumWord64 i2) =+  word64Result (fromInteger i1 `op` fromInteger i2)+word64Op2 _ _ _ _ = Nothing+#endif++wordOp2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+wordOp2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2)+    = wordResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)+wordOp2 _ _ _ _ = Nothing++wordOpC2 :: (Integral a, Integral b)+        => (a -> b -> Integer)+        -> RuleOpts -> Literal -> Literal -> Maybe CoreExpr+wordOpC2 op env (LitNumber LitNumWord w1) (LitNumber LitNumWord w2) =+  wordCResult (roPlatform env) (fromInteger w1 `op` fromInteger w2)+wordOpC2 _ _ _ _ = Nothing++shiftRule :: LitNumType+          -> (Platform -> Integer -> Int -> Integer)+          -> RuleM CoreExpr+-- Shifts take an Int; hence third arg of op is Int+-- Used for shift primops+--    IntSllOp, IntSraOp, IntSrlOp :: Int# -> Int# -> Int#+--    SllOp, SrlOp                 :: Word# -> Int# -> Word#+shiftRule lit_num_ty shift_op = do+  platform <- getPlatform+  [e1, Lit (LitNumber LitNumInt shift_len)] <- getArgs++  bit_size <- case litNumBitSize platform lit_num_ty of+   Nothing -> mzero+   Just bs -> pure (toInteger bs)++  case e1 of+    _ | shift_len == 0 -> pure e1++      -- See Note [Guarding against silly shifts]+    _ | shift_len < 0 || shift_len > bit_size+      -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0+           -- Be sure to use lit_num_ty here, so we get a correctly typed zero.+           -- See #18589++    Lit (LitNumber nt x)+       | 0 < shift_len && shift_len <= bit_size+       -> ASSERT(nt == lit_num_ty)+          let op = shift_op platform+              -- Do the shift at type Integer, but shift length is Int.+              -- Using host's Int is ok even if target's Int has a different size+              -- because we test that shift_len <= bit_size (which is at most 64)+              y  = x `op` fromInteger shift_len+          in pure $ Lit $ mkLitNumberWrap platform nt y++    _ -> mzero++--------------------------+floatOp2 :: (Rational -> Rational -> Rational)+         -> RuleOpts -> Literal -> Literal+         -> Maybe (Expr CoreBndr)+floatOp2 op env (LitFloat f1) (LitFloat f2)+  = Just (mkFloatVal env (f1 `op` f2))+floatOp2 _ _ _ _ = Nothing++--------------------------+floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr+floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))+  = Just $ mkCoreUbxTup [intPrimTy, intPrimTy]+                        [ mkIntVal (roPlatform env) (toInteger m)+                        , mkIntVal (roPlatform env) (toInteger e) ]+floatDecodeOp _   _+  = Nothing++--------------------------+doubleOp2 :: (Rational -> Rational -> Rational)+          -> RuleOpts -> Literal -> Literal+          -> Maybe (Expr CoreBndr)+doubleOp2 op env (LitDouble f1) (LitDouble f2)+  = Just (mkDoubleVal env (f1 `op` f2))+doubleOp2 _ _ _ _ = Nothing++--------------------------+doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr+doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))+  = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]+                        [ Lit (mkLitINT64 (toInteger m))+                        , mkIntVal platform (toInteger e) ]+  where+    platform = roPlatform env+    (iNT64Ty, mkLitINT64)+      | platformWordSizeInBits platform < 64+      = (int64PrimTy, mkLitInt64Wrap)+      | otherwise+      = (intPrimTy  , mkLitIntWrap platform)+doubleDecodeOp _   _+  = Nothing++--------------------------+{- Note [The litEq rule: converting equality to case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This stuff turns+     n ==# 3#+into+     case n of+       3# -> True+       m  -> False++This is a Good Thing, because it allows case-of case things+to happen, and case-default absorption to happen.  For+example:++     if (n ==# 3#) || (n ==# 4#) then e1 else e2+will transform to+     case n of+       3# -> e1+       4# -> e1+       m  -> e2+(modulo the usual precautions to avoid duplicating e1)+-}++litEq :: Bool  -- True <=> equality, False <=> inequality+      -> RuleM CoreExpr+litEq is_eq = msum+  [ do [Lit lit, expr] <- getArgs+       platform <- getPlatform+       do_lit_eq platform lit expr+  , do [expr, Lit lit] <- getArgs+       platform <- getPlatform+       do_lit_eq platform lit expr ]+  where+    do_lit_eq platform lit expr = do+      guard (not (litIsLifted lit))+      return (mkWildCase expr (unrestricted $ literalType lit) intPrimTy+                    [ Alt DEFAULT      [] val_if_neq+                    , Alt (LitAlt lit) [] val_if_eq])+      where+        val_if_eq  | is_eq     = trueValInt  platform+                   | otherwise = falseValInt platform+        val_if_neq | is_eq     = falseValInt platform+                   | otherwise = trueValInt  platform+++-- | Check if there is comparison with minBound or maxBound, that is+-- always true or false. For instance, an Int cannot be smaller than its+-- minBound, so we can replace such comparison with False.+boundsCmp :: Comparison -> RuleM CoreExpr+boundsCmp op = do+  platform <- getPlatform+  [a, b] <- getArgs+  liftMaybe $ mkRuleFn platform op a b++data Comparison = Gt | Ge | Lt | Le++mkRuleFn :: Platform -> Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr+mkRuleFn platform Gt (Lit lit) _ | isMinBound platform lit = Just $ falseValInt platform+mkRuleFn platform Le (Lit lit) _ | isMinBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Ge _ (Lit lit) | isMinBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Lt _ (Lit lit) | isMinBound platform lit = Just $ falseValInt platform+mkRuleFn platform Ge (Lit lit) _ | isMaxBound platform lit = Just $ trueValInt  platform+mkRuleFn platform Lt (Lit lit) _ | isMaxBound platform lit = Just $ falseValInt platform+mkRuleFn platform Gt _ (Lit lit) | isMaxBound platform lit = Just $ falseValInt platform+mkRuleFn platform Le _ (Lit lit) | isMaxBound platform lit = Just $ trueValInt  platform+mkRuleFn _ _ _ _                                           = Nothing++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+int8Result :: Integer -> Maybe CoreExpr+int8Result result = Just (int8Result' result)++int8Result' :: Integer -> CoreExpr+int8Result' result = Lit (mkLitInt8Wrap result)++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+int16Result :: Integer -> Maybe CoreExpr+int16Result result = Just (int16Result' result)++int16Result' :: Integer -> CoreExpr+int16Result' result = Lit (mkLitInt16Wrap result)++-- | Create an Int literal expression while ensuring the given Integer is in the+-- target Int range+int32Result :: Integer -> Maybe CoreExpr+int32Result result = Just (int32Result' result)++int32Result' :: Integer -> CoreExpr+int32Result' result = Lit (mkLitInt32Wrap result)++intResult :: Platform -> Integer -> Maybe CoreExpr+intResult platform result = Just (intResult' platform result)++intResult' :: Platform -> Integer -> CoreExpr+intResult' platform result = Lit (mkLitIntWrap platform result)++-- | Create an unboxed pair of an Int literal expression, ensuring the given+-- Integer is in the target Int range and the corresponding overflow flag+-- (@0#@/@1#@) if it wasn't.+intCResult :: Platform -> Integer -> Maybe CoreExpr+intCResult platform result = Just (mkPair [Lit lit, Lit c])+  where+    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]+    (lit, b) = mkLitIntWrapC platform result+    c = if b then onei platform else zeroi platform++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+word8Result :: Integer -> Maybe CoreExpr+word8Result result = Just (word8Result' result)++word8Result' :: Integer -> CoreExpr+word8Result' result = Lit (mkLitWord8Wrap result)++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+word16Result :: Integer -> Maybe CoreExpr+word16Result result = Just (word16Result' result)++word16Result' :: Integer -> CoreExpr+word16Result' result = Lit (mkLitWord16Wrap result)++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+word32Result :: Integer -> Maybe CoreExpr+word32Result result = Just (word32Result' result)++word32Result' :: Integer -> CoreExpr+word32Result' result = Lit (mkLitWord32Wrap result)++-- | Create a Word literal expression while ensuring the given Integer is in the+-- target Word range+wordResult :: Platform -> Integer -> Maybe CoreExpr+wordResult platform result = Just (wordResult' platform result)++wordResult' :: Platform -> Integer -> CoreExpr+wordResult' platform result = Lit (mkLitWordWrap platform result)++-- | Create an unboxed pair of a Word literal expression, ensuring the given+-- Integer is in the target Word range and the corresponding carry flag+-- (@0#@/@1#@) if it wasn't.+wordCResult :: Platform -> Integer -> Maybe CoreExpr+wordCResult platform result = Just (mkPair [Lit lit, Lit c])+  where+    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]+    (lit, b) = mkLitWordWrapC platform result+    c = if b then onei platform else zeroi platform++#if WORD_SIZE_IN_BITS < 64+int64Result :: Integer -> Maybe CoreExpr+int64Result result = Just (int64Result' result)++int64Result' :: Integer -> CoreExpr+int64Result' result = Lit (mkLitInt64Wrap result)++word64Result :: Integer -> Maybe CoreExpr+word64Result result = Just (word64Result' result)++word64Result' :: Integer -> CoreExpr+word64Result' result = Lit (mkLitWord64Wrap result)+#endif+++-- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'.+semiInversePrimOp :: PrimOp -> RuleM CoreExpr+semiInversePrimOp primop = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId primop primop_id+  return e++subsumesPrimOp :: PrimOp -> PrimOp -> RuleM CoreExpr+this `subsumesPrimOp` that = do+  [Var primop_id `App` e] <- getArgs+  matchPrimOpId that primop_id+  return (Var (mkPrimOpId this) `App` e)++subsumedByPrimOp :: PrimOp -> RuleM CoreExpr+subsumedByPrimOp primop = do+  [e@(Var primop_id `App` _)] <- getArgs+  matchPrimOpId primop primop_id+  return e++-- | Transform `extendWordN (narrowWordN x)` into `x .&. 0xFF..FF`+extendNarrowPassthrough :: PrimOp -> Integer -> RuleM CoreExpr+extendNarrowPassthrough narrow_primop n = do+  [Var primop_id `App` x] <- getArgs+  matchPrimOpId narrow_primop primop_id+  return (Var (mkPrimOpId WordAndOp) `App` x `App` Lit (LitNumber LitNumWord n))++-- | narrow subsumes bitwise `and` with full mask (cf #16402):+--+--       narrowN (x .&. m)+--       m .&. (2^N-1) = 2^N-1+--       ==> narrowN x+--+-- e.g.  narrow16 (x .&. 0xFFFF)+--       ==> narrow16 x+--+narrowSubsumesAnd :: PrimOp -> PrimOp -> Int -> RuleM CoreExpr+narrowSubsumesAnd and_primop narrw n = do+  [Var primop_id `App` x `App` y] <- getArgs+  matchPrimOpId and_primop primop_id+  let mask = bit n -1+      g v (Lit (LitNumber _ m)) = do+         guard (m .&. mask == mask)+         return (Var (mkPrimOpId narrw) `App` v)+      g _ _ = mzero+  g x y <|> g y x++idempotent :: RuleM CoreExpr+idempotent = do [e1, e2] <- getArgs+                guard $ cheapEqExpr e1 e2+                return e1++-- | Match+--       (op (op v e) e)+--    or (op e (op v e))+--    or (op (op e v) e)+--    or (op e (op e v))+--  and return the innermost (op v e) or (op e v).+sameArgIdempotentCommut :: PrimOp -> RuleM CoreExpr+sameArgIdempotentCommut op = do+  let is_op = \case+        BinOpApp v op' e | op == op' -> Just (v,e)+        _                            -> Nothing+  [a,b] <- getArgs+  case (a,b) of+    (is_op -> Just (e1,e2), e3)+      | cheapEqExpr e2 e3 -> return a+      | cheapEqExpr e1 e3 -> return a+    (e3, is_op -> Just (e1,e2))+      | cheapEqExpr e2 e3 -> return b+      | cheapEqExpr e1 e3 -> return b+    _ -> mzero++{-+Note [Guarding against silly shifts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this code:++  import Data.Bits( (.|.), shiftL )+  chunkToBitmap :: [Bool] -> Word32+  chunkToBitmap chunk = foldr (.|.) 0 [ 1 `shiftL` n | (True,n) <- zip chunk [0..] ]++This optimises to:+Shift.$wgo = \ (w_sCS :: GHC.Prim.Int#) (w1_sCT :: [GHC.Types.Bool]) ->+    case w1_sCT of _ {+      [] -> 0##;+      : x_aAW xs_aAX ->+        case x_aAW of _ {+          GHC.Types.False ->+            case w_sCS of wild2_Xh {+              __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild2_Xh 1) xs_aAX;+              9223372036854775807 -> 0## };+          GHC.Types.True ->+            case GHC.Prim.>=# w_sCS 64 of _ {+              GHC.Types.False ->+                case w_sCS of wild3_Xh {+                  __DEFAULT ->+                    case Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX of ww_sCW { __DEFAULT ->+                      GHC.Prim.or# (GHC.Prim.narrow32Word#+                                      (GHC.Prim.uncheckedShiftL# 1## wild3_Xh))+                                   ww_sCW+                     };+                  9223372036854775807 ->+                    GHC.Prim.narrow32Word#+!!!!-->                  (GHC.Prim.uncheckedShiftL# 1## 9223372036854775807)+                };+              GHC.Types.True ->+                case w_sCS of wild3_Xh {+                  __DEFAULT -> Shift.$wgo (GHC.Prim.+# wild3_Xh 1) xs_aAX;+                  9223372036854775807 -> 0##+                } } } }++Note the massive shift on line "!!!!".  It can't happen, because we've checked+that w < 64, but the optimiser didn't spot that. We DO NOT want to constant-fold this!+Moreover, if the programmer writes (n `uncheckedShiftL` 9223372036854775807), we+can't constant fold it, but if it gets to the assembler we get+     Error: operand type mismatch for `shl'++So the best thing to do is to rewrite the shift with a call to error,+when the second arg is large. However, in general we cannot do this; consider+this case++    let x = I# (uncheckedIShiftL# n 80)+    in ...++Here x contains an invalid shift and consequently we would like to rewrite it+as follows:++    let x = I# (error "invalid shift)+    in ...++This was originally done in the fix to #16449 but this breaks the let/app+invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.+For the reasons discussed in Note [Checking versus non-checking primops] (in+the PrimOp module) there is no safe way rewrite the argument of I# such that+it bottoms.++Consequently we instead take advantage of the fact that large shifts are+undefined behavior (see associated documentation in primops.txt.pp) and+transform the invalid shift into an "obviously incorrect" value.++There are two cases:++- Shifting fixed-width things: the primops IntSll, Sll, etc+  These are handled by shiftRule.++  We are happy to shift by any amount up to wordSize but no more.++- Shifting Bignums (Integer, Natural): these are handled by bignum_shift.++  Here we could in principle shift by any amount, but we arbitrary+  limit the shift to 4 bits; in particular we do not want shift by a+  huge amount, which can happen in code like that above.++The two cases are more different in their code paths that is comfortable,+but that is only a historical accident.+++************************************************************************+*                                                                      *+\subsection{Vaguely generic functions}+*                                                                      *+************************************************************************+-}++mkBasicRule :: Name -> Int -> RuleM CoreExpr -> CoreRule+-- Gives the Rule the same name as the primop itself+mkBasicRule op_name n_args rm+  = BuiltinRule { ru_name  = occNameFS (nameOccName op_name),+                  ru_fn    = op_name,+                  ru_nargs = n_args,+                  ru_try   = runRuleM rm }++newtype RuleM r = RuleM+  { runRuleM :: RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe r }+  deriving (Functor)++instance Applicative RuleM where+    pure x = RuleM $ \_ _ _ _ -> Just x+    (<*>) = ap++instance Monad RuleM where+  RuleM f >>= g+    = RuleM $ \env iu fn args ->+              case f env iu fn args of+                Nothing -> Nothing+                Just r  -> runRuleM (g r) env iu fn args++instance MonadFail RuleM where+    fail _ = mzero++instance Alternative RuleM where+  empty = RuleM $ \_ _ _ _ -> Nothing+  RuleM f1 <|> RuleM f2 = RuleM $ \env iu fn args ->+    f1 env iu fn args <|> f2 env iu fn args++instance MonadPlus RuleM++getPlatform :: RuleM Platform+getPlatform = roPlatform <$> getRuleOpts++getRuleOpts :: RuleM RuleOpts+getRuleOpts = RuleM $ \rule_opts _ _ _ -> Just rule_opts++getEnv :: RuleM InScopeEnv+getEnv = RuleM $ \_ env _ _ -> Just env++liftMaybe :: Maybe a -> RuleM a+liftMaybe Nothing = mzero+liftMaybe (Just x) = return x++liftLit :: (Literal -> Literal) -> RuleM CoreExpr+liftLit f = liftLitPlatform (const f)++liftLitPlatform :: (Platform -> Literal -> Literal) -> RuleM CoreExpr+liftLitPlatform f = do+  platform <- getPlatform+  [Lit lit] <- getArgs+  return $ Lit (f platform lit)++removeOp32 :: RuleM CoreExpr+removeOp32 = do+  platform <- getPlatform+  case platformWordSize platform of+    PW4 -> do+      [e] <- getArgs+      return e+    PW8 ->+      mzero++getArgs :: RuleM [CoreExpr]+getArgs = RuleM $ \_ _ _ args -> Just args++getInScopeEnv :: RuleM InScopeEnv+getInScopeEnv = RuleM $ \_ iu _ _ -> Just iu++getFunction :: RuleM Id+getFunction = RuleM $ \_ _ fn _ -> Just fn++exprIsVarApp_maybe :: InScopeEnv -> CoreExpr -> Maybe (Id,CoreArg)+exprIsVarApp_maybe env@(_, id_unf) e = case e of+  App (Var f) a -> Just (f, a)+  Var v+    | Just rhs <- expandUnfolding_maybe (id_unf v)+    -> exprIsVarApp_maybe env rhs+  _ -> Nothing++-- | Looks into the expression or its unfolding to find "App (Var f) x"+isVarApp :: InScopeEnv -> CoreExpr -> RuleM (Id,CoreArg)+isVarApp env e = case exprIsVarApp_maybe env e of+  Nothing -> mzero+  Just r  -> pure r++isLiteral :: CoreExpr -> RuleM Literal+isLiteral e = do+    env <- getInScopeEnv+    case exprIsLiteral_maybe env e of+        Nothing -> mzero+        Just l  -> pure l++isNumberLiteral :: CoreExpr -> RuleM Integer+isNumberLiteral e = isLiteral e >>= \case+  LitNumber _ x -> pure x+  _             -> mzero++isIntegerLiteral :: CoreExpr -> RuleM Integer+isIntegerLiteral e = isLiteral e >>= \case+  LitNumber LitNumInteger x -> pure x+  _                         -> mzero++isNaturalLiteral :: CoreExpr -> RuleM Integer+isNaturalLiteral e = isLiteral e >>= \case+  LitNumber LitNumNatural x -> pure x+  _                         -> mzero++isWordLiteral :: CoreExpr -> RuleM Integer+isWordLiteral e = isLiteral e >>= \case+  LitNumber LitNumWord x -> pure x+  _                      -> mzero++isIntLiteral :: CoreExpr -> RuleM Integer+isIntLiteral e = isLiteral e >>= \case+  LitNumber LitNumInt x -> pure x+  _                     -> mzero++-- return the n-th argument of this rule, if it is a literal+-- argument indices start from 0+getLiteral :: Int -> RuleM Literal+getLiteral n = RuleM $ \_ _ _ exprs -> case drop n exprs of+  (Lit l:_) -> Just l+  _ -> Nothing++unaryLit :: (RuleOpts -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+unaryLit op = do+  env <- getRuleOpts+  [Lit l] <- getArgs+  liftMaybe $ op env (convFloating env l)++binaryLit :: (RuleOpts -> Literal -> Literal -> Maybe CoreExpr) -> RuleM CoreExpr+binaryLit op = do+  env <- getRuleOpts+  [Lit l1, Lit l2] <- getArgs+  liftMaybe $ op env (convFloating env l1) (convFloating env l2)++binaryCmpLit :: (forall a . Ord a => a -> a -> Bool) -> RuleM CoreExpr+binaryCmpLit op = do+  platform <- getPlatform+  binaryLit (\_ -> cmpOp platform op)++leftIdentity :: Literal -> RuleM CoreExpr+leftIdentity id_lit = leftIdentityPlatform (const id_lit)++rightIdentity :: Literal -> RuleM CoreExpr+rightIdentity id_lit = rightIdentityPlatform (const id_lit)++identity :: Literal -> RuleM CoreExpr+identity lit = leftIdentity lit `mplus` rightIdentity lit++leftIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+leftIdentityPlatform id_lit = do+  platform <- getPlatform+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit platform+  return e2++-- | Left identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in+-- addition to the result, we have to indicate that no carry/overflow occurred.+leftIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+leftIdentityCPlatform id_lit = do+  platform <- getPlatform+  [Lit l1, e2] <- getArgs+  guard $ l1 == id_lit platform+  let no_c = Lit (zeroi platform)+  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])++rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+rightIdentityPlatform id_lit = do+  platform <- getPlatform+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit platform+  return e1++-- | Right identity rule for PrimOps like 'IntSubC' and 'WordSubC', where, in+-- addition to the result, we have to indicate that no carry/overflow occurred.+rightIdentityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+rightIdentityCPlatform id_lit = do+  platform <- getPlatform+  [e1, Lit l2] <- getArgs+  guard $ l2 == id_lit platform+  let no_c = Lit (zeroi platform)+  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])++identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr+identityPlatform lit =+  leftIdentityPlatform lit `mplus` rightIdentityPlatform lit++-- | Identity rule for PrimOps like 'IntAddC' and 'WordAddC', where, in addition+-- to the result, we have to indicate that no carry/overflow occurred.+identityCPlatform :: (Platform -> Literal) -> RuleM CoreExpr+identityCPlatform lit =+  leftIdentityCPlatform lit `mplus` rightIdentityCPlatform lit++leftZero :: RuleM CoreExpr+leftZero = do+  [Lit l1, _] <- getArgs+  guard $ isZeroLit l1+  return $ Lit l1++rightZero :: RuleM CoreExpr+rightZero = do+  [_, Lit l2] <- getArgs+  guard $ isZeroLit l2+  return $ Lit l2++zeroElem :: RuleM CoreExpr+zeroElem = leftZero `mplus` rightZero++equalArgs :: RuleM ()+equalArgs = do+  [e1, e2] <- getArgs+  guard $ e1 `cheapEqExpr` e2++nonZeroLit :: Int -> RuleM ()+nonZeroLit n = getLiteral n >>= guard . not . isZeroLit++oneLit :: Int -> RuleM ()+oneLit n = getLiteral n >>= guard . isOneLit++-- When excess precision is not requested, cut down the precision of the+-- Rational value to that of Float/Double. We confuse host architecture+-- and target architecture here, but it's convenient (and wrong :-).+convFloating :: RuleOpts -> Literal -> Literal+convFloating env (LitFloat  f) | not (roExcessRationalPrecision env) =+   LitFloat  (toRational (fromRational f :: Float ))+convFloating env (LitDouble d) | not (roExcessRationalPrecision env) =+   LitDouble (toRational (fromRational d :: Double))+convFloating _ l = l++guardFloatDiv :: RuleM ()+guardFloatDiv = do+  [Lit (LitFloat f1), Lit (LitFloat f2)] <- getArgs+  guard $ (f1 /=0 || f2 > 0) -- see Note [negative zero]+       && f2 /= 0            -- avoid NaN and Infinity/-Infinity++guardDoubleDiv :: RuleM ()+guardDoubleDiv = do+  [Lit (LitDouble d1), Lit (LitDouble d2)] <- getArgs+  guard $ (d1 /=0 || d2 > 0) -- see Note [negative zero]+       && d2 /= 0            -- avoid NaN and Infinity/-Infinity+-- Note [negative zero] Avoid (0 / -d), otherwise 0/(-1) reduces to+-- zero, but we might want to preserve the negative zero here which+-- is representable in Float/Double but not in (normalised)+-- Rational. (#3676) Perhaps we should generate (0 :% (-1)) instead?++strengthReduction :: Literal -> PrimOp -> RuleM CoreExpr+strengthReduction two_lit add_op = do -- Note [Strength reduction]+  arg <- msum [ do [arg, Lit mult_lit] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg+              , do [Lit mult_lit, arg] <- getArgs+                   guard (mult_lit == two_lit)+                   return arg ]+  return $ Var (mkPrimOpId add_op) `App` arg `App` arg++-- Note [Strength reduction]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- This rule turns floating point multiplications of the form 2.0 * x and+-- x * 2.0 into x + x addition, because addition costs less than multiplication.+-- See #7116++-- Note [What's true and false]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- trueValInt and falseValInt represent true and false values returned by+-- comparison primops for Char, Int, Word, Integer, Double, Float and Addr.+-- True is represented as an unboxed 1# literal, while false is represented+-- as 0# literal.+-- We still need Bool data constructors (True and False) to use in a rule+-- for constant folding of equal Strings++trueValInt, falseValInt :: Platform -> Expr CoreBndr+trueValInt  platform = Lit $ onei  platform -- see Note [What's true and false]+falseValInt platform = Lit $ zeroi platform++trueValBool, falseValBool :: Expr CoreBndr+trueValBool   = Var trueDataConId -- see Note [What's true and false]+falseValBool  = Var falseDataConId++ltVal, eqVal, gtVal :: Expr CoreBndr+ltVal = Var ordLTDataConId+eqVal = Var ordEQDataConId+gtVal = Var ordGTDataConId++mkIntVal :: Platform -> Integer -> Expr CoreBndr+mkIntVal platform i = Lit (mkLitInt platform i)+mkFloatVal :: RuleOpts -> Rational -> Expr CoreBndr+mkFloatVal env f = Lit (convFloating env (LitFloat  f))+mkDoubleVal :: RuleOpts -> Rational -> Expr CoreBndr+mkDoubleVal env d = Lit (convFloating env (LitDouble d))++matchPrimOpId :: PrimOp -> Id -> RuleM ()+matchPrimOpId op id = do+  op' <- liftMaybe $ isPrimOpId_maybe id+  guard $ op == op'++{-+************************************************************************+*                                                                      *+\subsection{Special rules for seq, tagToEnum, dataToTag}+*                                                                      *+************************************************************************++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 but it works.++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++We used to make this check in the type inference engine, but it's quite+ugly to do so, because the delayed constraint solving means that we don't+really know what's going on until the end. It's very much a corner case+because we don't expect the user to call tagToEnum# at all; we merely+generate calls in derived instances of Enum.  So we compromise: a+rewrite rule rewrites a bad instance of tagToEnum# to an error call,+and emits a warning.+-}++tagToEnumRule :: RuleM CoreExpr+-- If     data T a = A | B | C+-- then   tagToEnum# (T ty) 2# -->  B ty+tagToEnumRule = do+  [Type ty, Lit (LitNumber LitNumInt i)] <- getArgs+  case splitTyConApp_maybe ty of+    Just (tycon, tc_args) | isEnumerationTyCon tycon -> do+      let tag = fromInteger i+          correct_tag dc = (dataConTagZ dc) == tag+      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])+      ASSERT(null rest) return ()+      return $ mkTyApps (Var (dataConWorkId dc)) tc_args++    -- See Note [tagToEnum#]+    _ -> WARN( True, text "tagToEnum# on non-enumeration type" <+> ppr ty )+         return $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"++------------------------------+dataToTagRule :: RuleM CoreExpr+-- See Note [dataToTag#] in primops.txt.pp+dataToTagRule = a `mplus` b+  where+    -- dataToTag (tagToEnum x)   ==>   x+    a = do+      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      guard $ tag_to_enum `hasKey` tagToEnumKey+      guard $ ty1 `eqType` ty2+      return tag++    -- dataToTag (K e1 e2)  ==>   tag-of K+    -- This also works (via exprIsConApp_maybe) for+    --   dataToTag x+    -- where x's unfolding is a constructor application+    b = do+      dflags <- getPlatform+      [_, val_arg] <- getArgs+      in_scope <- getInScopeEnv+      (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg+      ASSERT( not (isNewTyCon (dataConTyCon dc)) ) return ()+      return $ wrapFloats floats (mkIntVal dflags (toInteger (dataConTagZ dc)))++{- Note [dataToTag# magic]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The primop dataToTag# is unusual because it evaluates its argument.+Only `SeqOp` shares that property.  (Other primops do not do anything+as fancy as argument evaluation.)  The special handling for dataToTag#+is:++* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,+  (actually in app_ok).  Most primops with lifted arguments do not+  evaluate those arguments, but DataToTagOp and SeqOp are two+  exceptions.  We say that they are /never/ ok-for-speculation,+  regardless of the evaluated-ness of their argument.+  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]++* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,+  that evaluates its argument and then extracts the tag from+  the returned value.++* An application like (dataToTag# (Just x)) is optimised by+  dataToTagRule in GHC.Core.Opt.ConstantFold.++* A case expression like+     case (dataToTag# e) of <alts>+  gets transformed t+     case e of <transformed alts>+  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]++See #15696 for a long saga.+-}++{- *********************************************************************+*                                                                      *+             unsafeEqualityProof+*                                                                      *+********************************************************************* -}++-- unsafeEqualityProof k t t  ==>  UnsafeRefl (Refl t)+-- That is, if the two types are equal, it's not unsafe!++unsafeEqualityProofRule :: RuleM CoreExpr+unsafeEqualityProofRule+  = do { [Type rep, Type t1, Type t2] <- getArgs+       ; guard (t1 `eqType` t2)+       ; fn <- getFunction+       ; let (_, ue) = splitForAllTyCoVars (idType fn)+             tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality+             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl+             -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).+             --               UnsafeEquality r a a+       ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }+++{- *********************************************************************+*                                                                      *+             Rules for seq# and spark#+*                                                                      *+********************************************************************* -}++{- Note [seq# magic]+~~~~~~~~~~~~~~~~~~~~+The primop+   seq# :: forall a s . a -> State# s -> (# State# s, a #)++is /not/ the same as the Prelude function seq :: a -> b -> b+as you can see from its type.  In fact, seq# is the implementation+mechanism for 'evaluate'++   evaluate :: a -> IO a+   evaluate a = IO $ \s -> seq# a s++The semantics of seq# is+  * evaluate its first argument+  * and return it++Things to note++* Why do we need a primop at all?  That is, instead of+      case seq# x s of (# x, s #) -> blah+  why not instead say this?+      case x of { DEFAULT -> blah)++  Reason (see #5129): if we saw+    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler++  then we'd drop the 'case x' because the body of the case is bottom+  anyway. But we don't want to do that; the whole /point/ of+  seq#/evaluate is to evaluate 'x' first in the IO monad.++  In short, we /always/ evaluate the first argument and never+  just discard it.++* Why return the value?  So that we can control sharing of seq'd+  values: in+     let x = e in x `seq` ... x ...+  We don't want to inline x, so better to represent it as+       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...+  also it matches the type of rseq in the Eval monad.++Implementing seq#.  The compiler has magic for SeqOp in++- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)++- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#++- GHC.Core.Utils.exprOkForSpeculation;+  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils++- Simplify.addEvals records evaluated-ness for the result; see+  Note [Adding evaluatedness info to pattern-bound variables]+  in GHC.Core.Opt.Simplify+-}++seqRule :: RuleM CoreExpr+seqRule = do+  [Type ty_a, Type _ty_s, a, s] <- getArgs+  guard $ exprIsHNF a+  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]++-- spark# :: forall a s . a -> State# s -> (# State# s, a #)+sparkRule :: RuleM CoreExpr+sparkRule = seqRule -- reduce on HNF, just the same+  -- XXX perhaps we shouldn't do this, because a spark eliminated by+  -- this rule won't be counted as a dud at runtime?++{-+************************************************************************+*                                                                      *+\subsection{Built in rules}+*                                                                      *+************************************************************************++Note [Scoping for Builtin rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When compiling a (base-package) module that defines one of the+functions mentioned in the RHS of a built-in rule, there's a danger+that we'll see++        f = ...(eq String x)....++        ....and lower down...++        eqString = ...++Then a rewrite would give++        f = ...(eqString x)...+        ....and lower down...+        eqString = ...++and lo, eqString is not in scope.  This only really matters when we+get to code generation.  But the occurrence analyser does a GlomBinds+step when necessary, that does a new SCC analysis on the whole set of+bindings (see occurAnalysePgm), which sorts out the dependency, so all+is fine.+-}++builtinRules :: [CoreRule]+-- Rules for non-primops that can't be expressed using a RULE pragma+builtinRules+  = [BuiltinRule { ru_name = fsLit "AppendLitString",+                   ru_fn = unpackCStringFoldrName,+                   ru_nargs = 4, ru_try = match_append_lit_C },+     BuiltinRule { ru_name = fsLit "AppendLitStringUtf8",+                   ru_fn = unpackCStringFoldrUtf8Name,+                   ru_nargs = 4, ru_try = match_append_lit_utf8 },+     BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,+                   ru_nargs = 2, ru_try = match_eq_string },+     BuiltinRule { ru_name = fsLit "CStringLength", ru_fn = cstringLengthName,+                   ru_nargs = 1, ru_try = match_cstring_length },+     BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,+                   ru_nargs = 2, ru_try = \_ _ _ -> match_inline },+     BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,+                   ru_nargs = 4, ru_try = \_ _ _ -> match_magicDict },++     mkBasicRule unsafeEqualityProofName 3 unsafeEqualityProofRule,++     mkBasicRule divIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 div)+        , leftZero+        , do+          [arg, Lit (LitNumber LitNumInt d)] <- getArgs+          Just n <- return $ exactLog2 d+          platform <- getPlatform+          return $ Var (mkPrimOpId IntSraOp) `App` arg `App` mkIntVal platform n+        ],++     mkBasicRule modIntName 2 $ msum+        [ nonZeroLit 1 >> binaryLit (intOp2 mod)+        , leftZero+        , do+          [arg, Lit (LitNumber LitNumInt d)] <- getArgs+          Just _ <- return $ exactLog2 d+          platform <- getPlatform+          return $ Var (mkPrimOpId IntAndOp)+            `App` arg `App` mkIntVal platform (d - 1)+        ]+     ]+ ++ builtinBignumRules+{-# NOINLINE builtinRules #-}+-- there is no benefit to inlining these yet, despite this, GHC produces+-- unfoldings for this regardless since the floated list entries look small.++builtinBignumRules :: [CoreRule]+builtinBignumRules =+  [ -- conversions+    lit_to_integer "Word# -> Integer"   integerFromWordName+  , lit_to_integer "Int64# -> Integer"  integerFromInt64Name+  , lit_to_integer "Word64# -> Integer" integerFromWord64Name+  , lit_to_integer "Natural -> Integer" integerFromNaturalName++  , integer_to_lit "Integer -> Word# (wrap)"   integerToWordName   mkWordLitWrap+  , integer_to_lit "Integer -> Int# (wrap)"    integerToIntName    mkIntLitWrap+  , integer_to_lit "Integer -> Word64# (wrap)" integerToWord64Name (\_ -> mkWord64LitWord64 . fromInteger)+  , integer_to_lit "Integer -> Int64# (wrap)"  integerToInt64Name  (\_ -> mkInt64LitInt64 . fromInteger)+  , integer_to_lit "Integer -> Float#"         integerToFloatName  (\_ -> mkFloatLitFloat . fromInteger)+  , integer_to_lit "Integer -> Double#"        integerToDoubleName (\_ -> mkDoubleLitDouble . fromInteger)++  , integer_to_natural "Integer -> Natural (clamp)" integerToNaturalClampName False True+  , integer_to_natural "Integer -> Natural (wrap)"  integerToNaturalName      False False+  , integer_to_natural "Integer -> Natural (throw)" integerToNaturalThrowName True False++  , lit_to_natural  "Word# -> Natural"         naturalNSName+  , natural_to_word "Natural -> Word# (wrap)"  naturalToWordName      False+  , natural_to_word "Natural -> Word# (clamp)" naturalToWordClampName True++    -- comparisons (return an unlifted Int#)+  , integer_cmp "integerEq#" integerEqName (==)+  , integer_cmp "integerNe#" integerNeName (/=)+  , integer_cmp "integerLe#" integerLeName (<=)+  , integer_cmp "integerGt#" integerGtName (>)+  , integer_cmp "integerLt#" integerLtName (<)+  , integer_cmp "integerGe#" integerGeName (>=)++  , natural_cmp "naturalEq#" naturalEqName (==)+  , natural_cmp "naturalNe#" naturalNeName (/=)+  , natural_cmp "naturalLe#" naturalLeName (<=)+  , natural_cmp "naturalGt#" naturalGtName (>)+  , natural_cmp "naturalLt#" naturalLtName (<)+  , natural_cmp "naturalGe#" naturalGeName (>=)++    -- comparisons (return an Ordering)+  , bignum_compare "integerCompare" integerCompareName+  , bignum_compare "naturalCompare" naturalCompareName++    -- binary operations+  , integer_binop "integerAdd" integerAddName (+)+  , integer_binop "integerSub" integerSubName (-)+  , integer_binop "integerMul" integerMulName (*)+  , integer_binop "integerGcd" integerGcdName gcd+  , integer_binop "integerLcm" integerLcmName lcm+  , integer_binop "integerAnd" integerAndName (.&.)+  , integer_binop "integerOr"  integerOrName  (.|.)+  , integer_binop "integerXor" integerXorName xor++  , natural_binop "naturalAdd" naturalAddName (+)+  , natural_binop "naturalMul" naturalMulName (*)+  , natural_binop "naturalGcd" naturalGcdName gcd+  , natural_binop "naturalLcm" naturalLcmName lcm+  , natural_binop "naturalAnd" naturalAndName (.&.)+  , natural_binop "naturalOr"  naturalOrName  (.|.)+  , natural_binop "naturalXor" naturalXorName xor++    -- Natural subtraction: it's a binop but it can fail because of underflow so+    -- we have several primitives to handle here.+  , natural_sub "naturalSubUnsafe" naturalSubUnsafeName+  , natural_sub "naturalSubThrow"  naturalSubThrowName+  , mkRule "naturalSub" naturalSubName 2 $ do+        [a0,a1] <- getArgs+        x <- isNaturalLiteral a0+        y <- isNaturalLiteral a1+        -- return an unboxed sum: (# (# #) | Natural #)+        let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v+        if x < y+            then ret 1 $ Var voidPrimId+            else ret 2 $ Lit (mkLitNatural (x - y))++    -- unary operations+  , bignum_unop "integerNegate"     integerNegateName     mkLitInteger negate+  , bignum_unop "integerAbs"        integerAbsName        mkLitInteger abs+  , bignum_unop "integerSignum"     integerSignumName     mkLitInteger signum+  , bignum_unop "integerComplement" integerComplementName mkLitInteger complement++  , bignum_unop "naturalSignum"     naturalSignumName     mkLitNatural signum++  , mkRule "naturalNegate" naturalNegateName 1 $ do+        [a0] <- getArgs+        x <- isNaturalLiteral a0+        guard (x == 0) -- negate is only valid for (0 :: Natural)+        pure a0++  , bignum_popcount "integerPopCount" integerPopCountName mkLitIntWrap+  , bignum_popcount "naturalPopCount" naturalPopCountName mkLitWordWrap++  ------------------------------------------------------------+  -- The following `small_passthough_*` rules are used to optimise conversions+  -- between numeric types by avoiding passing through "small" constructors of+  -- Integer and Natural.+  --+  -- See Note [Optimising conversions between numeric types]+  --++  , small_passthrough_id "Word# -> Natural -> Word#"+      naturalNSName naturalToWordName+  , small_passthrough_id "Word# -> Natural -> Word# (clamp)"+      naturalNSName naturalToWordClampName++  , small_passthrough_id "Int# -> Integer -> Int#"+      integerISName integerToIntName+  , small_passthrough_id "Word# -> Integer -> Word#"+      integerFromWordName integerToWordName+  , small_passthrough_id "Int64# -> Integer -> Int64#"+      integerFromInt64Name integerToInt64Name+  , small_passthrough_id "Word64# -> Integer -> Word64#"+      integerFromWord64Name integerToWord64Name+  , small_passthrough_id "Natural -> Integer -> Natural (wrap)"+      integerFromNaturalName integerToNaturalName+  , small_passthrough_id "Natural -> Integer -> Natural (throw)"+      integerFromNaturalName integerToNaturalThrowName+  , small_passthrough_id "Natural -> Integer -> Natural (clamp)"+      integerFromNaturalName integerToNaturalClampName++  , small_passthrough_app "Int# -> Integer -> Word#"+        integerISName integerToWordName   (mkPrimOpId IntToWordOp)+  , small_passthrough_app "Int# -> Integer -> Float#"+        integerISName integerToFloatName  (mkPrimOpId IntToFloatOp)+  , small_passthrough_app "Int# -> Integer -> Double#"+        integerISName integerToDoubleName (mkPrimOpId IntToDoubleOp)++  , small_passthrough_app "Word# -> Integer -> Int#"+        integerFromWordName integerToIntName (mkPrimOpId WordToIntOp)+  , small_passthrough_app "Word# -> Integer -> Float#"+        integerFromWordName integerToFloatName (mkPrimOpId WordToFloatOp)+  , small_passthrough_app "Word# -> Integer -> Double#"+        integerFromWordName integerToDoubleName (mkPrimOpId WordToDoubleOp)+  , small_passthrough_app "Word# -> Integer -> Natural (wrap)"+        integerFromWordName integerToNaturalName naturalNSId+  , small_passthrough_app "Word# -> Integer -> Natural (throw)"+        integerFromWordName integerToNaturalThrowName naturalNSId+  , small_passthrough_app "Word# -> Integer -> Natural (clamp)"+        integerFromWordName integerToNaturalClampName naturalNSId++  , small_passthrough_app "Word# -> Natural -> Float#"+        naturalNSName naturalToFloatName  (mkPrimOpId WordToFloatOp)+  , small_passthrough_app "Word# -> Natural -> Double#"+        naturalNSName naturalToDoubleName (mkPrimOpId WordToDoubleOp)++#if WORD_SIZE_IN_BITS < 64+  , small_passthrough_id "Int64# -> Integer -> Int64#"+      integerFromInt64Name integerToInt64Name+  , small_passthrough_id "Word64# -> Integer -> Word64#"+      integerFromWord64Name integerToWord64Name++  , small_passthrough_app "Int64# -> Integer -> Word64#"+        integerFromInt64Name integerToWord64Name   (mkPrimOpId Int64ToWord64Op)+  , small_passthrough_app "Word64# -> Integer -> Int64#"+        integerFromWord64Name integerToInt64Name   (mkPrimOpId Word64ToInt64Op)++  , small_passthrough_app "Word# -> Integer -> Word64#"+        integerFromWordName integerToWord64Name (mkPrimOpId WordToWord64Op)+  , small_passthrough_app "Word64# -> Integer -> Word#"+        integerFromWord64Name integerToWordName (mkPrimOpId Word64ToWordOp)+  , small_passthrough_app "Int# -> Integer -> Int64#"+        integerISName integerToInt64Name (mkPrimOpId IntToInt64Op)+  , small_passthrough_app "Int64# -> Integer -> Int#"+        integerFromInt64Name integerToIntName (mkPrimOpId Int64ToIntOp)++  , small_passthrough_custom "Int# -> Integer -> Word64#"+        integerISName integerToWord64Name+          (\x -> Var (mkPrimOpId Int64ToWord64Op) `App` (Var (mkPrimOpId IntToInt64Op) `App` x))+  , small_passthrough_custom "Word64# -> Integer -> Int#"+        integerFromWord64Name integerToIntName+          (\x -> Var (mkPrimOpId WordToIntOp) `App` (Var (mkPrimOpId Word64ToWordOp) `App` x))+  , small_passthrough_custom "Word# -> Integer -> Int64#"+        integerFromWordName integerToInt64Name+          (\x -> Var (mkPrimOpId Word64ToInt64Op) `App` (Var (mkPrimOpId WordToWord64Op) `App` x))+  , small_passthrough_custom "Int64# -> Integer -> Word#"+        integerFromInt64Name integerToWordName+          (\x -> Var (mkPrimOpId IntToWordOp) `App` (Var (mkPrimOpId Int64ToIntOp) `App` x))+#endif++    -- Bits.bit+  , bignum_bit "integerBit" integerBitName mkLitInteger+  , bignum_bit "naturalBit" naturalBitName mkLitNatural++    -- Bits.testBit+  , bignum_testbit "integerTestBit" integerTestBitName+  , bignum_testbit "naturalTestBit" naturalTestBitName++    -- Bits.shift+  , bignum_shift "integerShiftL" integerShiftLName shiftL mkLitInteger+  , bignum_shift "integerShiftR" integerShiftRName shiftR mkLitInteger+  , bignum_shift "naturalShiftL" naturalShiftLName shiftL mkLitNatural+  , bignum_shift "naturalShiftR" naturalShiftRName shiftR mkLitNatural++    -- division+  , divop_one  "integerQuot"    integerQuotName    quot    mkLitInteger+  , divop_one  "integerRem"     integerRemName     rem     mkLitInteger+  , divop_one  "integerDiv"     integerDivName     div     mkLitInteger+  , divop_one  "integerMod"     integerModName     mod     mkLitInteger+  , divop_both "integerDivMod"  integerDivModName  divMod  mkLitInteger integerTy+  , divop_both "integerQuotRem" integerQuotRemName quotRem mkLitInteger integerTy++  , divop_one  "naturalQuot"    naturalQuotName    quot    mkLitNatural+  , divop_one  "naturalRem"     naturalRemName     rem     mkLitNatural+  , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkLitNatural naturalTy++    -- conversions from Rational for Float/Double literals+  , rational_to "rationalToFloat"  rationalToFloatName  mkFloatExpr+  , rational_to "rationalToDouble" rationalToDoubleName mkDoubleExpr++    -- conversions from Integer for Float/Double literals+  , integer_encode_float "integerEncodeFloat"  integerEncodeFloatName  mkFloatLitFloat+  , integer_encode_float "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble+  ]+  where+    -- The rule is matching against an occurrence of a data constructor in a+    -- Core expression. It must match either its worker name or its wrapper+    -- name, /not/ the DataCon name itself, which is different.+    -- See Note [Data Constructor Naming] in GHC.Core.DataCon and #19892+    --+    -- But data constructor wrappers deliberately inline late; See Note+    -- [Activation for data constructor wrappers] in GHC.Types.Id.Make.+    -- Suppose there is a wrapper and the rule matches on the worker: the+    -- wrapper won't be inlined until rules have finished firing and the rule+    -- will never fire.+    --+    -- Hence the rule must match on the wrapper, if there is one, otherwise on+    -- the worker. That is exactly the dataConWrapId for the data constructor.+    -- The data constructor may or may not have a wrapper, but if not+    -- dataConWrapId will return the worker+    --+    integerISId   = dataConWrapId integerISDataCon+    naturalNSId   = dataConWrapId naturalNSDataCon+    integerISName = idName integerISId+    naturalNSName = idName naturalNSId++    mkRule str name nargs f = BuiltinRule+      { ru_name = fsLit str+      , ru_fn = name+      , ru_nargs = nargs+      , ru_try = runRuleM $ do+          env <- getRuleOpts+          guard (roBignumRules env)+          f+      }++    integer_to_lit str name convert = mkRule str name 1 $ do+      [a0] <- getArgs+      platform <- getPlatform+      x <- isIntegerLiteral a0+      pure (convert platform x)++    natural_to_word str name clamp = mkRule str name 1 $ do+      [a0] <- getArgs+      n <- isNaturalLiteral a0+      platform <- getPlatform+      if clamp && not (platformInWordRange platform n)+          then pure (Lit (mkLitWord platform (platformMaxWord platform)))+          else pure (Lit (mkLitWordWrap platform n))++    integer_to_natural str name thrw clamp = mkRule str name 1 $ do+      [a0] <- getArgs+      x <- isIntegerLiteral a0+      if | x >= 0    -> pure $ Lit $ mkLitNatural x+         | thrw      -> mzero+         | clamp     -> pure $ Lit $ mkLitNatural 0       -- clamp to 0+         | otherwise -> pure $ Lit $ mkLitNatural (abs x) -- negate/wrap++    lit_to_integer str name = mkRule str name 1 $ do+      [a0] <- getArgs+      isLiteral a0 >>= \case+        -- convert any numeric literal into an Integer literal+        LitNumber _ i -> pure (Lit (mkLitInteger i))+        _             -> mzero++    lit_to_natural str name = mkRule str name 1 $ do+      [a0] <- getArgs+      isLiteral a0 >>= \case+        -- convert any *positive* numeric literal into a Natural literal+        LitNumber _ i | i >= 0 -> pure (Lit (mkLitNatural i))+        _                      -> mzero++    integer_binop str name op = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isIntegerLiteral a0+      y <- isIntegerLiteral a1+      pure (Lit (mkLitInteger (x `op` y)))++    natural_binop str name op = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isNaturalLiteral a0+      y <- isNaturalLiteral a1+      pure (Lit (mkLitNatural (x `op` y)))++    natural_sub str name = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isNaturalLiteral a0+      y <- isNaturalLiteral a1+      guard (x >= y)+      pure (Lit (mkLitNatural (x - y)))++    integer_cmp str name op = mkRule str name 2 $ do+      platform <- getPlatform+      [a0,a1] <- getArgs+      x <- isIntegerLiteral a0+      y <- isIntegerLiteral a1+      pure $ if x `op` y+              then trueValInt platform+              else falseValInt platform++    natural_cmp str name op = mkRule str name 2 $ do+      platform <- getPlatform+      [a0,a1] <- getArgs+      x <- isNaturalLiteral a0+      y <- isNaturalLiteral a1+      pure $ if x `op` y+              then trueValInt platform+              else falseValInt platform++    bignum_compare str name = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isNumberLiteral a0+      y <- isNumberLiteral a1+      pure $ case x `compare` y of+              LT -> ltVal+              EQ -> eqVal+              GT -> gtVal++    bignum_unop str name mk_lit op = mkRule str name 1 $ do+      [a0] <- getArgs+      x <- isNumberLiteral a0+      pure $ Lit (mk_lit (op x))++    bignum_popcount str name mk_lit = mkRule str name 1 $ do+      platform <- getPlatform+      -- We use a host Int to compute the popCount. If we compile on a 32-bit+      -- host for a 64-bit target, the result may be different than if computed+      -- by the target. So we disable this rule if sizes don't match.+      guard (platformWordSizeInBits platform == finiteBitSize (0 :: Word))+      [a0] <- getArgs+      x <- isNumberLiteral a0+      pure $ Lit (mk_lit platform (fromIntegral (popCount x)))++    small_passthrough_id str from_x to_x =+      small_passthrough_custom str from_x to_x id++    small_passthrough_app str from_x to_y x_to_y =+      small_passthrough_custom str from_x to_y (App (Var x_to_y))++    small_passthrough_custom str from_x to_y x_to_y = mkRule str to_y 1 $ do+      [a0] <- getArgs+      env <- getEnv+      (f,x) <- isVarApp env a0+      guard (idName f == from_x)+      pure $ x_to_y x++    bignum_bit str name mk_lit = mkRule str name 1 $ do+      [a0] <- getArgs+      platform <- getPlatform+      n <- isNumberLiteral a0+      -- Make sure n is positive and small enough to yield a decently+      -- small number. Attempting to construct the Integer for+      --    (integerBit 9223372036854775807#)+      -- would be a bad idea (#14959)+      guard (n >= 0 && n <= fromIntegral (platformWordSizeInBits platform))+      -- it's safe to convert a target Int value into a host Int value+      -- to perform the "bit" operation because n is very small (<= 64).+      pure $ Lit (mk_lit (bit (fromIntegral n)))++    bignum_testbit str name = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      platform <- getPlatform+      x <- isNumberLiteral a0+      n <- isNumberLiteral a1+      -- ensure that we can store 'n' in a host Int+      guard (n >= 0 && n <= fromIntegral (maxBound :: Int))+      pure $ if testBit x (fromIntegral n)+              then trueValInt platform+              else falseValInt platform++    bignum_shift str name shift_op mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isNumberLiteral a0+      n <- isWordLiteral a1+      -- See Note [Guarding against silly shifts]+      -- Restrict constant-folding of shifts on Integers, somewhat arbitrary.+      -- We can get huge shifts in inaccessible code (#15673)+      guard (n <= 4)+      pure $ Lit (mk_lit (x `shift_op` fromIntegral n))++    divop_one str name divop mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      n <- isNumberLiteral a0+      d <- isNumberLiteral a1+      guard (d /= 0)+      pure $ Lit (mk_lit (n `divop` d))++    divop_both str name divop mk_lit ty = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      n <- isNumberLiteral a0+      d <- isNumberLiteral a1+      guard (d /= 0)+      let (r,s) = n `divop` d+      pure $ mkCoreUbxTup [ty,ty] [Lit (mk_lit r), Lit (mk_lit s)]++    integer_encode_float :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule+    integer_encode_float str name mk_lit = mkRule str name 2 $ do+      [a0,a1] <- getArgs+      x <- isIntegerLiteral a0+      y <- isIntLiteral a1+      -- check that y (a target Int) is in the host Int range+      guard (y <= fromIntegral (maxBound :: Int))+      pure (mk_lit $ encodeFloat x (fromInteger y))++    rational_to :: RealFloat a => String -> Name -> (a -> CoreExpr) -> CoreRule+    rational_to str name mk_lit = mkRule str name 2 $ do+      -- This turns `rationalToFloat n d` where `n` and `d` are literals into+      -- a literal Float (and similarly for Double).+      [a0,a1] <- getArgs+      n <- isIntegerLiteral a0+      d <- isIntegerLiteral a1+      -- it's important to not match d == 0, because that may represent a+      -- literal "0/0" or similar, and we can't produce a literal value for+      -- NaN or +-Inf+      guard (d /= 0)+      pure $ mk_lit (fromRational (n % d))++++---------------------------------------------------+-- The rule is this:+--      unpackFoldrCString*# "foo"# c (unpackFoldrCString*# "baz"# c n)+--      =  unpackFoldrCString*# "foobaz"# c n+--+-- See also Note [String literals in GHC] in CString.hs++-- CString version+match_append_lit_C :: RuleFun+match_append_lit_C = match_append_lit unpackCStringFoldrIdKey++-- CStringUTF8 version+match_append_lit_utf8 :: RuleFun+match_append_lit_utf8 = match_append_lit unpackCStringFoldrUtf8IdKey++{-# INLINE match_append_lit #-}+match_append_lit :: Unique -> RuleFun+match_append_lit foldVariant _ id_unf _+        [ Type ty1+        , lit1+        , c1+        , e2+        ]+  -- N.B. Ensure that we strip off any ticks (e.g. source notes) from the+  -- `lit` and `c` arguments, lest this may fail to fire when building with+  -- -g3. See #16740.+  | (strTicks, Var unpk `App` Type ty2+                        `App` lit2+                        `App` c2+                        `App` n) <- stripTicksTop tickishFloatable e2+  , unpk `hasKey` foldVariant+  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1+  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2+  , let freeVars = (mkInScopeSet (exprFreeVars c1 `unionVarSet` exprFreeVars c2))+    in eqExpr freeVars c1 c2+  , (c1Ticks, c1') <- stripTicksTop tickishFloatable c1+  , c2Ticks <- stripTicksTopT tickishFloatable c2+  = ASSERT( ty1 `eqType` ty2 )+    Just $ mkTicks strTicks+         $ Var unpk `App` Type ty1+                    `App` Lit (LitString (s1 `BS.append` s2))+                    `App` mkTicks (c1Ticks ++ c2Ticks) c1'+                    `App` n++match_append_lit _ _ _ _ _ = Nothing++---------------------------------------------------+-- The rule is this:+--      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2)) = s1==s2+-- Also  matches unpackCStringUtf8#++match_eq_string :: RuleFun+match_eq_string _ id_unf _+        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]+  | unpk_key1 <- getUnique unpk1+  , unpk_key2 <- getUnique unpk2+  , unpk_key1 == unpk_key2+  -- For now we insist the literals have to agree in their encoding+  -- to keep the rule simple. But we could check if the decoded strings+  -- compare equal in here as well.+  , unpk_key1 `elem` [unpackCStringUtf8IdKey, unpackCStringIdKey]+  , Just (LitString s1) <- exprIsLiteral_maybe id_unf lit1+  , Just (LitString s2) <- exprIsLiteral_maybe id_unf lit2+  = Just (if s1 == s2 then trueValBool else falseValBool)++match_eq_string _ _ _ _ = Nothing++-----------------------------------------------------------------------+-- Illustration of this rule:+--+-- cstringLength# "foobar"# --> 6+-- cstringLength# "fizz\NULzz"# --> 4+--+-- Nota bene: Addr# literals are suffixed by a NUL byte when they are+-- compiled to read-only data sections. That's why cstringLength# is+-- well defined on Addr# literals that do not explicitly have an embedded+-- NUL byte.+--+-- See GHC issue #5218, MR 2165, and bytestring PR 191. This is particularly+-- helpful when using OverloadedStrings to create a ByteString since the+-- function computing the length of such ByteStrings can often be constant+-- folded.+match_cstring_length :: RuleFun+match_cstring_length env id_unf _ [lit1]+  | Just (LitString str) <- exprIsLiteral_maybe id_unf lit1+    -- If elemIndex returns Just, it has the index of the first embedded NUL+    -- in the string. If no NUL bytes are present (the common case) then use+    -- full length of the byte string.+  = let len = fromMaybe (BS.length str) (BS.elemIndex 0 str)+     in Just (Lit (mkLitInt (roPlatform env) (fromIntegral len)))+match_cstring_length _ _ _ _ = Nothing++---------------------------------------------------+{- Note [inlineId magic]+~~~~~~~~~~~~~~~~~~~~~~~~+The call 'inline f' arranges that 'f' is inlined, regardless of+its size. More precisely, the call 'inline f' rewrites to the+right-hand side of 'f's definition. This allows the programmer to+control inlining from a particular call site rather than the+definition site of the function.++The moving parts are simple:++* A very simple definition in the library base:GHC.Magic+     {-# NOINLINE[0] inline #-}+     inline :: a -> a+     inline x = x+  So in phase 0, 'inline' will be inlined, so its use imposes+  no overhead.++* A rewrite rule, in GHC.Core.Opt.ConstantFold, which makes+  (inline f) inline, implemented by match_inline.+  The rule for the 'inline' function is this:+     inline f_ty (f a b c) = <f's unfolding> a b c+  (if f has an unfolding, EVEN if it's a loop breaker)++  It's important to allow the argument to 'inline' to have args itself+  (a) because its more forgiving to allow the programmer to write+      either  inline f a b c+      or      inline (f a b c)+  (b) because a polymorphic f wll get a type argument that the+      programmer can't avoid, so the call may look like+        inline (map @Int @Bool) g xs++  Also, don't forget about 'inline's type argument!+-}++match_inline :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_inline (Type _ : e : _)+  | (Var f, args1) <- collectArgs e,+    Just unf <- maybeUnfoldingTemplate (realIdUnfolding f)+             -- Ignore the IdUnfoldingFun here!+  = Just (mkApps unf args1)++match_inline _ = Nothing++---------------------------------------------------+-- See Note [magicDictId magic] in "GHC.Types.Id.Make"+-- for a description of what is going on here.+match_magicDict :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)+match_magicDict [Type _, (stripTicksE (const True) -> (Var wrap `App` Type a `App` Type _ `App` f)), x, y ]+  | Just (_, fieldTy, _)  <- splitFunTy_maybe $ dropForAlls $ idType wrap+  , Just (_, dictTy, _)   <- splitFunTy_maybe fieldTy+  , Just dictTc           <- tyConAppTyCon_maybe dictTy+  , Just (_,_,co)         <- unwrapNewTyCon_maybe dictTc+  = Just+  $ f `App` Cast x (mkSymCo (mkUnbranchedAxInstCo Representational co [a] []))+      `App` y++match_magicDict _ = Nothing++--------------------------------------------------------+-- Note [Constant folding through nested expressions]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We use rewrites rules to perform constant folding. It means that we don't+-- have a global view of the expression we are trying to optimise. As a+-- consequence we only perform local (small-step) transformations that either:+--    1) reduce the number of operations+--    2) rearrange the expression to increase the odds that other rules will+--    match+--+-- We don't try to handle more complex expression optimisation cases that would+-- require a global view. For example, rewriting expressions to increase+-- sharing (e.g., Horner's method); optimisations that require local+-- transformations increasing the number of operations; rearrangements to+-- cancel/factorize terms (e.g., (a+b-a-b) isn't rearranged to reduce to 0).+--+-- We already have rules to perform constant folding on expressions with the+-- following shape (where a and/or b are literals):+--+--          D)    op+--                /\+--               /  \+--              /    \+--             a      b+--+-- To support nested expressions, we match three other shapes of expression+-- trees:+--+-- A)   op1          B)       op1       C)       op1+--      /\                    /\                 /\+--     /  \                  /  \               /  \+--    /    \                /    \             /    \+--   a     op2            op2     c          op2    op3+--          /\            /\                 /\      /\+--         /  \          /  \               /  \    /  \+--        b    c        a    b             a    b  c    d+--+--+-- R1) +/- simplification:+--    ops = + or -, two literals (not siblings)+--+--    Examples:+--       A: 5 + (10-x)  ==> 15-x+--       B: (10+x) + 5  ==> 15+x+--       C: (5+a)-(5-b) ==> 0+(a+b)+--+-- R2) * simplification+--    ops = *, two literals (not siblings)+--+--    Examples:+--       A: 5 * (10*x)  ==> 50*x+--       B: (10*x) * 5  ==> 50*x+--       C: (5*a)*(5*b) ==> 25*(a*b)+--+-- R3) * distribution over +/-+--    op1 = *, op2 = + or -, two literals (not siblings)+--+--    This transformation doesn't reduce the number of operations but switches+--    the outer and the inner operations so that the outer is (+) or (-) instead+--    of (*). It increases the odds that other rules will match after this one.+--+--    Examples:+--       A: 5 * (10-x)  ==> 50 - (5*x)+--       B: (10+x) * 5  ==> 50 + (5*x)+--       C: Not supported as it would increase the number of operations:+--          (5+a)*(5-b) ==> 25 - 5*b + 5*a - a*b+--+-- R4) Simple factorization+--+--    op1 = + or -, op2/op3 = *,+--    one literal for each innermost * operation (except in the D case),+--    the two other terms are equals+--+--    Examples:+--       A: x - (10*x)  ==> (-9)*x+--       B: (10*x) + x  ==> 11*x+--       C: (5*x)-(x*3) ==> 2*x+--       D: x+x         ==> 2*x+--+-- R5) +/- propagation+--+--    ops = + or -, one literal+--+--    This transformation doesn't reduce the number of operations but propagates+--    the constant to the outer level. It increases the odds that other rules+--    will match after this one.+--+--    Examples:+--       A: x - (10-y)  ==> (x+y) - 10+--       B: (10+x) - y  ==> 10 + (x-y)+--       C: N/A (caught by the A and B cases)+--+--------------------------------------------------------++-- Rules to perform constant folding into nested expressions+--+--See Note [Constant folding through nested expressions]++addFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+addFoldingRules op num_ops = do+   ASSERT(op == numAdd num_ops) return ()+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe+      -- commutativity for + is handled here+      (addFoldingRules' platform arg1 arg2 num_ops+       <|> addFoldingRules' platform arg2 arg1 num_ops)++subFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+subFoldingRules op num_ops = do+   ASSERT(op == numSub num_ops) return ()+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe (subFoldingRules' platform arg1 arg2 num_ops)++mulFoldingRules :: PrimOp -> NumOps -> RuleM CoreExpr+mulFoldingRules op num_ops = do+   ASSERT(op == numMul num_ops) return ()+   env <- getRuleOpts+   guard (roNumConstantFolding env)+   [arg1,arg2] <- getArgs+   platform <- getPlatform+   liftMaybe+      -- commutativity for * is handled here+      (mulFoldingRules' platform arg1 arg2 num_ops+       <|> mulFoldingRules' platform arg2 arg1 num_ops)+++addFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+addFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of+      -- R1) +/- simplification++      -- l1 + (l2 + x) ==> (l1+l2) + x+      (L l1, is_lit_add num_ops -> Just (l2,x))+         -> Just (mkL (l1+l2) `add` x)++      -- l1 + (l2 - x) ==> (l1+l2) - x+      (L l1, is_sub num_ops -> Just (L l2,x))+         -> Just (mkL (l1+l2) `sub` x)++      -- l1 + (x - l2) ==> (l1-l2) + x+      (L l1, is_sub num_ops -> Just (x,L l2))+         -> Just (mkL (l1-l2) `add` x)++      -- (l1 + x) + (l2 + y) ==> (l1+l2) + (x+y)+      (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (l1+l2) `add` (x `add` y))++      -- (l1 + x) + (l2 - y) ==> (l1+l2) + (x-y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1+l2) `add` (x `sub` y))++      -- (l1 + x) + (y - l2) ==> (l1-l2) + (x+y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1-l2) `add` (x `add` y))++      -- (l1 - x) + (l2 - y) ==> (l1+l2) - (x+y)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1+l2) `sub` (x `add` y))++      -- (l1 - x) + (y - l2) ==> (l1-l2) + (y-x)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1-l2) `add` (y `sub` x))++      -- (x - l1) + (y - l2) ==> (0-l1-l2) + (x+y)+      (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (0-l1-l2) `add` (x `add` y))++      -- R4) Simple factorization++      -- x + x ==> 2 * x+      _ | Just l1 <- is_expr_mul num_ops arg1 arg2+        -> Just (mkL (l1+1) `mul` arg1)++      -- (l1 * x) + x ==> (l1+1) * x+      _ | Just l1 <- is_expr_mul num_ops arg2 arg1+        -> Just (mkL (l1+1) `mul` arg2)++      -- (l1 * x) + (l2 * x) ==> (l1+l2) * x+      (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)+         -> Just (mkL (l1+l2) `mul` x)++      -- R5) +/- propagation: these transformations push literals outwards+      -- with the hope that other rules can then be applied.++      -- In the following rules, x can't be a literal otherwise another+      -- rule would have combined it with the other literal in arg2. So we+      -- don't have to check this to avoid loops here.++      -- x + (l1 + y) ==> l1 + (x + y)+      (_, is_lit_add num_ops -> Just (l1,y))+         -> Just (mkL l1 `add` (arg1 `add` y))++      -- x + (l1 - y) ==> l1 + (x - y)+      (_, is_sub num_ops -> Just (L l1,y))+         -> Just (mkL l1 `add` (arg1 `sub` y))++      -- x + (y - l1) ==> (x + y) - l1+      (_, is_sub num_ops -> Just (y,L l1))+         -> Just ((arg1 `add` y) `sub` mkL l1)++      _ -> Nothing++   where+      mkL = Lit . mkNumLiteral platform num_ops+      add x y = BinOpApp x (numAdd num_ops) y+      sub x y = BinOpApp x (numSub num_ops) y+      mul x y = BinOpApp x (numMul num_ops) y++subFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+subFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+      -- R1) +/- simplification++      -- l1 - (l2 + x) ==> (l1-l2) - x+      (L l1, is_lit_add num_ops -> Just (l2,x))+         -> Just (mkL (l1-l2) `sub` x)++      -- l1 - (l2 - x) ==> (l1-l2) + x+      (L l1, is_sub num_ops -> Just (L l2,x))+         -> Just (mkL (l1-l2) `add` x)++      -- l1 - (x - l2) ==> (l1+l2) - x+      (L l1, is_sub num_ops -> Just (x, L l2))+         -> Just (mkL (l1+l2) `sub` x)++      -- (l1 + x) - l2 ==> (l1-l2) + x+      (is_lit_add num_ops -> Just (l1,x), L l2)+         -> Just (mkL (l1-l2) `add` x)++      -- (l1 - x) - l2 ==> (l1-l2) - x+      (is_sub num_ops -> Just (L l1,x), L l2)+         -> Just (mkL (l1-l2) `sub` x)++      -- (x - l1) - l2 ==> x - (l1+l2)+      (is_sub num_ops -> Just (x,L l1), L l2)+         -> Just (x `sub` mkL (l1+l2))+++      -- (l1 + x) - (l2 + y) ==> (l1-l2) + (x-y)+      (is_lit_add num_ops -> Just (l1,x), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (l1-l2) `add` (x `sub` y))++      -- (l1 + x) - (l2 - y) ==> (l1-l2) + (x+y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1-l2) `add` (x `add` y))++      -- (l1 + x) - (y - l2) ==> (l1+l2) + (x-y)+      (is_lit_add num_ops -> Just (l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1+l2) `add` (x `sub` y))++      -- (l1 - x) - (l2 + y) ==> (l1-l2) - (x+y)+      (is_sub num_ops -> Just (L l1,x), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (l1-l2) `sub` (x `add` y))++      -- (x - l1) - (l2 + y) ==> (0-l1-l2) + (x-y)+      (is_sub num_ops -> Just (x,L l1), is_lit_add num_ops -> Just (l2,y))+         -> Just (mkL (0-l1-l2) `add` (x `sub` y))++      -- (l1 - x) - (l2 - y) ==> (l1-l2) + (y-x)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (l1-l2) `add` (y `sub` x))++      -- (l1 - x) - (y - l2) ==> (l1+l2) - (x+y)+      (is_sub num_ops -> Just (L l1,x), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l1+l2) `sub` (x `add` y))++      -- (x - l1) - (l2 - y) ==> (0-l1-l2) + (x+y)+      (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (L l2,y))+         -> Just (mkL (0-l1-l2) `add` (x `add` y))++      -- (x - l1) - (y - l2) ==> (l2-l1) + (x-y)+      (is_sub num_ops -> Just (x,L l1), is_sub num_ops -> Just (y,L l2))+         -> Just (mkL (l2-l1) `add` (x `sub` y))++       -- R4) Simple factorization++      -- x - (l1 * x) ==> (1-l1) * x+      _ | Just l1 <- is_expr_mul num_ops arg1 arg2+        -> Just (mkL (1-l1) `mul` arg1)++      -- (l1 * x) - x ==> (l1-1) * x+      _ | Just l1 <- is_expr_mul num_ops arg2 arg1+        -> Just (mkL (l1-1) `mul` arg2)++      -- (l1 * x) - (l2 * x) ==> (l1-l2) * x+      (is_lit_mul num_ops -> Just (l1,x), is_expr_mul num_ops x -> Just l2)+         -> Just (mkL (l1-l2) `mul` x)++      -- R5) +/- propagation: these transformations push literals outwards+      -- with the hope that other rules can then be applied.++      -- In the following rules, x can't be a literal otherwise another+      -- rule would have combined it with the other literal in arg2. So we+      -- don't have to check this to avoid loops here.++      -- x - (l1 + y) ==> (x - y) - l1+      (_, is_lit_add num_ops -> Just (l1,y))+         -> Just ((arg1 `sub` y) `sub` mkL l1)++      -- (l1 + x) - y ==> l1 + (x - y)+      (is_lit_add num_ops -> Just (l1,x), _)+         -> Just (mkL l1 `add` (x `sub` arg2))++      -- x - (l1 - y) ==> (x + y) - l1+      (_, is_sub num_ops -> Just (L l1,y))+         -> Just ((arg1 `add` y) `sub` mkL l1)++      -- x - (y - l1) ==> l1 + (x - y)+      (_, is_sub num_ops -> Just (y,L l1))+         -> Just (mkL l1 `add` (arg1 `sub` y))++      -- (l1 - x) - y ==> l1 - (x + y)+      (is_sub num_ops -> Just (L l1,x), _)+         -> Just (mkL l1 `sub` (x `add` arg2))++      -- (x - l1) - y ==> (x - y) - l1+      (is_sub num_ops -> Just (x,L l1), _)+         -> Just ((x `sub` arg2) `sub` mkL l1)++      _ -> Nothing+   where+      mkL = Lit . mkNumLiteral platform num_ops+      add x y = BinOpApp x (numAdd num_ops) y+      sub x y = BinOpApp x (numSub num_ops) y+      mul x y = BinOpApp x (numMul num_ops) y++mulFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr+mulFoldingRules' platform arg1 arg2 num_ops = case (arg1,arg2) of+   -- l1 * (l2 * x) ==> (l1*l2) * x+   (L l1, is_lit_mul num_ops -> Just (l2,x))+      -> Just (mkL (l1*l2) `mul` x)++   -- l1 * (l2 + x) ==> (l1*l2) + (l1 * x)+   (L l1, is_lit_add num_ops -> Just (l2,x))+      -> Just (mkL (l1*l2) `add` (arg1 `mul` x))++   -- l1 * (l2 - x) ==> (l1*l2) - (l1 * x)+   (L l1, is_sub num_ops -> Just (L l2,x))+      -> Just (mkL (l1*l2) `sub` (arg1 `mul` x))++   -- l1 * (x - l2) ==> (l1 * x) - (l1*l2)+   (L l1, is_sub num_ops -> Just (x, L l2))+      -> Just ((arg1 `mul` x) `sub` mkL (l1*l2))++   -- (l1 * x) * (l2 * y) ==> (l1*l2) * (x * y)+   (is_lit_mul num_ops -> Just (l1,x), is_lit_mul num_ops -> Just (l2,y))+      -> Just (mkL (l1*l2) `mul` (x `mul` y))++   _ -> Nothing+   where+      mkL = Lit . mkNumLiteral platform num_ops+      add x y = BinOpApp x (numAdd num_ops) y+      sub x y = BinOpApp x (numSub num_ops) y+      mul x y = BinOpApp x (numMul num_ops) y++is_op :: PrimOp -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_op op e = case e of+ BinOpApp x op' y | op == op' -> Just (x,y)+ _                            -> Nothing++is_add, is_sub, is_mul :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_add num_ops = is_op (numAdd num_ops)+is_sub num_ops = is_op (numSub num_ops)+is_mul num_ops = is_op (numMul num_ops)++-- match addition with a literal (handles commutativity)+is_lit_add :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit_add num_ops e = case is_add num_ops e of+   Just (L l, x  ) -> Just (l,x)+   Just (x  , L l) -> Just (l,x)+   _               -> Nothing++-- match multiplication with a literal (handles commutativity)+is_lit_mul :: NumOps -> CoreExpr -> Maybe (Integer, Arg CoreBndr)+is_lit_mul num_ops e = case is_mul num_ops e of+   Just (L l, x  ) -> Just (l,x)+   Just (x  , L l) -> Just (l,x)+   _               -> Nothing++-- match given "x": return 1+-- match "lit * x": return lit value (handles commutativity)+is_expr_mul :: NumOps -> Expr CoreBndr -> Expr CoreBndr -> Maybe Integer+is_expr_mul num_ops x e = if+   | x `cheapEqExpr` e+   -> Just 1+   | Just (k,x') <- is_lit_mul num_ops e+   , x `cheapEqExpr` x'+   -> return k+   | otherwise+   -> Nothing+++-- | Match the application of a binary primop+pattern BinOpApp :: Arg CoreBndr -> PrimOp -> Arg CoreBndr -> CoreExpr+pattern BinOpApp x op y = OpVal op `App` x `App` y++-- | Match a primop+pattern OpVal:: PrimOp  -> Arg CoreBndr+pattern OpVal op <- Var (isPrimOpId_maybe -> Just op) where+   OpVal op = Var (mkPrimOpId op)++-- | Match a literal+pattern L :: Integer -> Arg CoreBndr+pattern L i <- Lit (LitNumber _ i)++-- | Explicit "type-class"-like dictionary for numeric primops+data NumOps = NumOps+   { numAdd     :: !PrimOp     -- ^ Add two numbers+   , numSub     :: !PrimOp     -- ^ Sub two numbers+   , numMul     :: !PrimOp     -- ^ Multiply two numbers+   , numLitType :: !LitNumType -- ^ Literal type+   }++-- | Create a numeric literal+mkNumLiteral :: Platform -> NumOps -> Integer -> Literal+mkNumLiteral platform ops i = mkLitNumberWrap platform (numLitType ops) i++int8Ops :: NumOps+int8Ops = NumOps+   { numAdd     = Int8AddOp+   , numSub     = Int8SubOp+   , numMul     = Int8MulOp+   , numLitType = LitNumInt8+   }++word8Ops :: NumOps+word8Ops = NumOps+   { numAdd     = Word8AddOp+   , numSub     = Word8SubOp+   , numMul     = Word8MulOp+   , numLitType = LitNumWord8+   }++int16Ops :: NumOps+int16Ops = NumOps+   { numAdd     = Int16AddOp+   , numSub     = Int16SubOp+   , numMul     = Int16MulOp+   , numLitType = LitNumInt16+   }++word16Ops :: NumOps+word16Ops = NumOps+   { numAdd     = Word16AddOp+   , numSub     = Word16SubOp+   , numMul     = Word16MulOp+   , numLitType = LitNumWord16+   }++int32Ops :: NumOps+int32Ops = NumOps+   { numAdd     = Int32AddOp+   , numSub     = Int32SubOp+   , numMul     = Int32MulOp+   , numLitType = LitNumInt32+   }++word32Ops :: NumOps+word32Ops = NumOps+   { numAdd     = Word32AddOp+   , numSub     = Word32SubOp+   , numMul     = Word32MulOp+   , numLitType = LitNumWord32+   }++#if WORD_SIZE_IN_BITS < 64+int64Ops :: NumOps+int64Ops = NumOps+   { numAdd     = Int64AddOp+   , numSub     = Int64SubOp+   , numMul     = Int64MulOp+   , numLitType = LitNumInt64+   }++word64Ops :: NumOps+word64Ops = NumOps+   { numAdd     = Word64AddOp+   , numSub     = Word64SubOp+   , numMul     = Word64MulOp+   , numLitType = LitNumWord64+   }+#endif++intOps :: NumOps+intOps = NumOps+   { numAdd     = IntAddOp+   , numSub     = IntSubOp+   , numMul     = IntMulOp+   , numLitType = LitNumInt+   }++wordOps :: NumOps+wordOps = NumOps+   { numAdd     = WordAddOp+   , numSub     = WordSubOp+   , numMul     = WordMulOp+   , numLitType = LitNumWord+   }++--------------------------------------------------------+-- Constant folding through case-expressions+--+-- cf Scrutinee Constant Folding in simplCore/GHC.Core.Opt.Simplify.Utils+--------------------------------------------------------++-- | Match the scrutinee of a case and potentially return a new scrutinee and a+-- function to apply to each literal alternative.+caseRules :: Platform+          -> CoreExpr                       -- Scrutinee+          -> Maybe ( CoreExpr               -- New scrutinee+                   , AltCon -> Maybe AltCon -- How to fix up the alt pattern+                                            --   Nothing <=> Unreachable+                                            -- See Note [Unreachable caseRules alternatives]+                   , Id -> CoreExpr)        -- How to reconstruct the original scrutinee+                                            -- from the new case-binder+-- e.g  case e of b {+--         ...;+--         con bs -> rhs;+--         ... }+--  ==>+--      case e' of b' {+--         ...;+--         fixup_altcon[con] bs -> let b = mk_orig[b] in rhs;+--         ... }++caseRules platform (App (App (Var f) v) (Lit l))   -- v `op` x#+  | Just op <- isPrimOpId_maybe f+  , LitNumber _ x <- l+  , Just adjust_lit <- adjustDyadicRight op x+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> (App (App (Var f) (Var v)) (Lit l)))++caseRules platform (App (App (Var f) (Lit l)) v)   -- x# `op` v+  | Just op <- isPrimOpId_maybe f+  , LitNumber _ x <- l+  , Just adjust_lit <- adjustDyadicLeft x op+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> (App (App (Var f) (Lit l)) (Var v)))+++caseRules platform (App (Var f) v              )   -- op v+  | Just op <- isPrimOpId_maybe f+  , Just adjust_lit <- adjustUnary op+  = Just (v, tx_lit_con platform adjust_lit+           , \v -> App (Var f) (Var v))++-- See Note [caseRules for tagToEnum]+caseRules platform (App (App (Var f) type_arg) v)+  | Just TagToEnumOp <- isPrimOpId_maybe f+  = Just (v, tx_con_tte platform+           , \v -> (App (App (Var f) type_arg) (Var v)))++-- See Note [caseRules for dataToTag]+caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x+  | Just DataToTagOp <- isPrimOpId_maybe f+  , Just (tc, _) <- tcSplitTyConApp_maybe ty+  , isAlgTyCon tc+  = Just (v, tx_con_dtt ty+           , \v -> App (App (Var f) (Type ty)) (Var v))++caseRules _ _ = Nothing+++tx_lit_con :: Platform -> (Integer -> Integer) -> AltCon -> Maybe AltCon+tx_lit_con _        _      DEFAULT    = Just DEFAULT+tx_lit_con platform adjust (LitAlt l) = Just $ LitAlt (mapLitValue platform adjust l)+tx_lit_con _        _      alt        = pprPanic "caseRules" (ppr alt)+   -- NB: mapLitValue uses mkLitIntWrap etc, to ensure that the+   -- literal alternatives remain in Word/Int target ranges+   -- (See Note [Word/Int underflow/overflow] in GHC.Types.Literal and #13172).++adjustDyadicRight :: PrimOp -> Integer -> Maybe (Integer -> Integer)+-- Given (x `op` lit) return a function 'f' s.t.  f (x `op` lit) = x+adjustDyadicRight op lit+  = case op of+         WordAddOp -> Just (\y -> y-lit      )+         IntAddOp  -> Just (\y -> y-lit      )+         WordSubOp -> Just (\y -> y+lit      )+         IntSubOp  -> Just (\y -> y+lit      )+         WordXorOp -> Just (\y -> y `xor` lit)+         IntXorOp  -> Just (\y -> y `xor` lit)+         _         -> Nothing++adjustDyadicLeft :: Integer -> PrimOp -> Maybe (Integer -> Integer)+-- Given (lit `op` x) return a function 'f' s.t.  f (lit `op` x) = x+adjustDyadicLeft lit op+  = case op of+         WordAddOp -> Just (\y -> y-lit      )+         IntAddOp  -> Just (\y -> y-lit      )+         WordSubOp -> Just (\y -> lit-y      )+         IntSubOp  -> Just (\y -> lit-y      )+         WordXorOp -> Just (\y -> y `xor` lit)+         IntXorOp  -> Just (\y -> y `xor` lit)+         _         -> Nothing+++adjustUnary :: PrimOp -> Maybe (Integer -> Integer)+-- Given (op x) return a function 'f' s.t.  f (op x) = x+adjustUnary op+  = case op of+         WordNotOp -> Just (\y -> complement y)+         IntNotOp  -> Just (\y -> complement y)+         IntNegOp  -> Just (\y -> negate y    )+         _         -> Nothing++tx_con_tte :: Platform -> AltCon -> Maybe AltCon+tx_con_tte _        DEFAULT         = Just DEFAULT+tx_con_tte _        alt@(LitAlt {}) = pprPanic "caseRules" (ppr alt)+tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]+  = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc++tx_con_dtt :: Type -> AltCon -> Maybe AltCon+tx_con_dtt _  DEFAULT = Just DEFAULT+tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))+   | tag >= 0+   , tag < n_data_cons+   = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)+   | otherwise+   = Nothing+   where+     tag         = fromInteger i :: ConTagZ+     tc          = tyConAppTyCon ty+     n_data_cons = tyConFamilySize tc+     data_cons   = tyConDataCons tc++tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)+++{- Note [caseRules for tagToEnum]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to transform+   case tagToEnum x of+     False -> e1+     True  -> e2+into+   case x of+     0# -> e1+     1# -> e2++This rule eliminates a lot of boilerplate. For+  if (x>y) then e2 else e1+we generate+  case tagToEnum (x ># y) of+    False -> e1+    True  -> e2+and it is nice to then get rid of the tagToEnum.++Beware (#14768): avoid the temptation to map constructor 0 to+DEFAULT, in the hope of getting this+  case (x ># y) of+    DEFAULT -> e1+    1#      -> e2+That fails utterly in the case of+   data Colour = Red | Green | Blue+   case tagToEnum x of+      DEFAULT -> e1+      Red     -> e2++We don't want to get this!+   case x of+      DEFAULT -> e1+      DEFAULT -> e2++Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils+(add_default in mkCase3).++Note [caseRules for dataToTag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [dataToTag#] in primpops.txt.pp++We want to transform+  case dataToTag x of+    DEFAULT -> e1+    1# -> e2+into+  case x of+    DEFAULT -> e1+    (:) _ _ -> e2++Note the need for some wildcard binders in+the 'cons' case.++For the time, we only apply this transformation when the type of `x` is a type+headed by a normal tycon. In particular, we do not apply this in the case of a+data family tycon, since that would require carefully applying coercion(s)+between the data family and the data family instance's representation type,+which caseRules isn't currently engineered to handle (#14680).++Note [Unreachable caseRules alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Take care if we see something like+  case dataToTag x of+    DEFAULT -> e1+    -1# -> e2+    100 -> e3+because there isn't a data constructor with tag -1 or 100. In this case the+out-of-range alternative is dead code -- we know the range of tags for x.++Hence caseRules returns (AltCon -> Maybe AltCon), with Nothing indicating+an alternative that is unreachable.++You may wonder how this can happen: check out #15436.+++Note [Optimising conversions between numeric types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Converting between numeric types is very common in Haskell codes.  Suppose that+we have N inter-convertible numeric types (Word, Word8, Int, Integer, etc.).++- We don't want to have to use one conversion function per pair of types as that+would require N^2 functions: wordToWord8, wordToInt, wordToInteger...++- The following kind of class would allow us to have a single conversion+function at the price of N^2 instances and of the use of MultiParamTypeClasses+extension.++    class Convert a b where+      convert :: a -> b++What we do instead is that we use the Integer type (signed, unbounded) as a+passthrough type to perform every conversion. Hence we only need to define two+functions per numeric type:++  class Integral a where+    toInteger :: a -> Integer++  class Num a where+    fromInteger :: Integer -> a++These classes have a single parameter and can be derived automatically (e.g. for+newtypes). So we don't even have to define 2*N instances.++fromIntegral+------------++We can now define a generic conversion function:++  -- in the Prelude+  fromIntegral :: (Integral a, Num b) => a -> b+  fromIntegral = fromInteger . toInteger++The trouble with this approach is that performance might be terrible. E.g.+converting an Int into a Word, which is a no-op at the machine level, becomes+costly when performed via `fromIntegral` because an Integer has to be allocated.++To alleviate this:++- first `fromIntegral` was specialized (SPECIALIZE pragma). However it would+need N^2 pragmas to cover every case and it wouldn't cover user defined numeric+types which don't belong to base.++- while writing this note I discovered that we have a `-fwarn-identities` warning+to detect useless conversions (since 0656c72a8f):++  > fromIntegral (1 :: Int) :: Int++  <interactive>:3:21: warning: [-Widentities]+      Call of fromIntegral :: Int -> Int+        can probably be omitted++- but more importantly, many rules were added (e.g. in e0c787c10f):++    "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8+    "fromIntegral/a->Int8"    fromIntegral = \x -> case fromIntegral x of I# x# -> I8# (intToInt8# x#)+    "fromIntegral/Int8->a"    fromIntegral = \(I8# x#) -> fromIntegral (I# x#)++  The idea was to ensure that only cheap conversions ended up being used. E.g.:++      foo :: Int8 --> {- Integer -> -} -> Word8+      foo = fromIntegral++    ====> {Some fromIntegral rule for Int8}++      foo :: Int8 -> {- Int -> Integer -} -> Word8+      foo = fromIntegral . int8ToInt++    ====> {Some fromIntegral rule for Word8}++      foo :: Int8 -> {- Int -> Integer -> Word -} -> Word8+      foo = wordToWord8 . fromIntegral . int8ToInt++    ====> {Some fromIntegral rule for Int/Word}++      foo :: Int8 -> {- Int -> Word -} -> Word8+      foo = wordToWord8 . intToWord . int8ToInt+      -- not passing through Integer anymore!+++It worked but there were still some issues with this approach:++1. These rules only work for `fromIntegral`. If we wanted to define our own+   similar function (e.g. using other type-classes), we would also have to redefine+   all the rules to get similar performance.++2. `fromIntegral` had to be marked `NOINLINE [1]`:+    - NOINLINE to allow rules to match+    - [1] to allow inlining in later phases to avoid incurring a function call+      overhead for such a trivial operation++   Users of the function had to be careful because a simple helper without an+   INLINE pragma like:++      toInt :: Integral a => a -> Int+      toInt = fromIntegral++   has the following unfolding:++      toInt = integerToInt . toInteger++   which doesn't mention `fromIntegral` anymore. Hence `fromIntegral` rules+   wouldn't be triggered for any user of `toInt`. For this reason, we also have+   a bunch of rules for bignum primitives such as `integerToInt`.++3. These rewrite rules are tedious to write and error-prone (cf #19345).+++For these reasons, it is simpler to only rely on built-in rewrite rules for+bignum primitives. There aren't so many conversion primitives:+  - Natural <-> Word+  - Integer <-> Int/Word/Natural (+ Int64/Word64 on 32-bit arch)++All the built-in "small_passthrough_*" rules are used to avoid passing through+Integer/Natural. We now always inline `fromIntegral`.+ -}

GHC/Core/Opt/CprAnal.hs view

@@ -22,21 +22,26 @@ import GHC.Builtin.Names ( runRWKey ) import GHC.Types.Var.Env import GHC.Types.Basic-import GHC.Core.DataCon import GHC.Types.Id import GHC.Types.Id.Info+import GHC.Core.DataCon+import GHC.Core.Multiplicity import GHC.Core.Utils   ( exprIsHNF, dumpIdInfoOfProgram )-import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc-import GHC.Utils.Error  ( dumpIfSet_dyn, DumpFormat (..) )-import GHC.Data.Maybe   ( isJust, isNothing )+import GHC.Utils.Panic+import GHC.Utils.Logger  ( Logger, dumpIfSet_dyn, DumpFormat (..) )+import GHC.Data.Graph.UnVar -- for UnVarSet+import GHC.Data.Maybe   ( isNothing )  import Control.Monad ( guard )-import Data.List+import Data.List ( mapAccumL ) +import GHC.Driver.Ppr+_ = pprTrace -- Tired of commenting out the import all the time+ {- Note [Constructed Product Result] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The goal of Constructed Product Result analysis is to identify functions that@@ -91,8 +96,8 @@ 4. worker/wrapper (for CPR)  Currently, we omit 2. and anticipate the results of worker/wrapper.-See Note [CPR in a DataAlt case alternative]-and Note [CPR for binders that will be unboxed].+See Note [CPR for binders that will be unboxed]+and Note [Optimistic field binder CPR]. An additional w/w pass would simplify things, but probably add slight overhead. So currently we have @@ -105,11 +110,11 @@ -- * Analysing programs -- -cprAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-cprAnalProgram dflags fam_envs binds = do+cprAnalProgram :: Logger -> DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram+cprAnalProgram logger dflags fam_envs binds = do   let env            = emptyAnalEnv fam_envs   let binds_plus_cpr = snd $ mapAccumL cprAnalTopBind env binds-  dumpIfSet_dyn dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $+  dumpIfSet_dyn logger dflags Opt_D_dump_cpr_signatures "Cpr signatures" FormatText $     dumpIdInfoOfProgram (ppr . cprInfo) binds_plus_cpr   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_cpr `seq` return binds_plus_cpr@@ -168,18 +173,18 @@   | otherwise   = (lam_ty, Lam var body')   where-    env'             = extendSigEnvForDemand env var (idDemandInfo var)+    -- See Note [CPR for binders that will be unboxed]+    env'             = extendSigEnvForArg env var     (body_ty, body') = cprAnal env' body     lam_ty           = abstractCprTy body_ty  cprAnal' env (Case scrut case_bndr ty alts)   = (res_ty, Case scrut' case_bndr ty alts')   where-    (_, scrut')      = cprAnal env scrut-    -- Regardless whether scrut had the CPR property or not, the case binder-    -- certainly has it. See 'extendEnvForDataAlt'.-    (alt_tys, alts') = mapAndUnzip (cprAnalAlt env scrut case_bndr) alts-    res_ty           = foldl' lubCprType botCprType alt_tys+    (scrut_ty, scrut') = cprAnal env scrut+    env'               = extendSigEnv env case_bndr (CprSig scrut_ty)+    (alt_tys, alts')   = mapAndUnzip (cprAnalAlt env' scrut_ty) alts+    res_ty             = foldl' lubCprType botCprType alt_tys  cprAnal' env (Let (NonRec id rhs) body)   = (body_ty, Let (NonRec id' rhs') body')@@ -195,20 +200,27 @@  cprAnalAlt   :: AnalEnv-  -> CoreExpr -- ^ scrutinee-  -> Id       -- ^ case binder-  -> Alt Var  -- ^ current alternative+  -> CprType -- ^ CPR type of the scrutinee+  -> Alt Var -- ^ current alternative   -> (CprType, Alt Var)-cprAnalAlt env scrut case_bndr (con@(DataAlt dc),bndrs,rhs)-  -- See 'extendEnvForDataAlt' and Note [CPR in a DataAlt case alternative]-  = (rhs_ty, (con, bndrs, rhs'))+cprAnalAlt env scrut_ty (Alt con bndrs rhs)+  = (rhs_ty, Alt con bndrs rhs')   where-    env_alt        = extendEnvForDataAlt env scrut case_bndr dc bndrs+    env_alt+      | DataAlt dc <- con+      , let ids = filter isId bndrs+      , CprType arity cpr <- scrut_ty+      , ASSERT( arity == 0 ) True+      = case unpackConFieldsCpr dc cpr of+          AllFieldsSame field_cpr+            | let sig = mkCprSig 0 field_cpr+            -> extendSigEnvAllSame env ids sig+          ForeachField field_cprs+            | let sigs = zipWith (mkCprSig . idArity) ids field_cprs+            -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs)+      | otherwise+      = env     (rhs_ty, rhs') = cprAnal env_alt rhs-cprAnalAlt env _ _ (con,bndrs,rhs)-  = (rhs_ty, (con, bndrs, rhs'))-  where-    (rhs_ty, rhs') = cprAnal env rhs  -- -- * CPR transformer@@ -284,7 +296,7 @@     orig_virgin = ae_virgin orig_env     init_pairs | orig_virgin  = [(setIdCprInfo id (init_sig id rhs), rhs) | (id, rhs) <- orig_pairs ]                | otherwise    = orig_pairs-    init_env = extendSigEnvList orig_env (map fst init_pairs)+    init_env = extendSigEnvFromIds orig_env (map fst init_pairs)      -- The fixed-point varies the idCprInfo field of the binders and and their     -- entries in the AnalEnv, and terminates if that annotation does not change@@ -339,10 +351,10 @@     -- See Note [CPR for thunks]     stays_thunk = is_thunk && not_strict     is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)-    not_strict  = not (isStrictDmd (idDemandInfo id))+    not_strict  = not (isStrUsedDmd (idDemandInfo id))     -- See Note [CPR for sum types]     (_, ret_ty) = splitPiTys (idType id)-    not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)+    not_a_prod  = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty)     returns_sum = not (isTopLevel top_lvl) && not_a_prod  isDataStructure :: Id -> CoreExpr -> Bool@@ -404,36 +416,69 @@   -- ^ Needed when expanding type families and synonyms of product types.   } -type SigEnv = VarEnv CprSig- instance Outputable AnalEnv where   ppr (AE { ae_sigs = env, ae_virgin = virgin })     = text "AE" <+> braces (vcat          [ text "ae_virgin =" <+> ppr virgin          , text "ae_sigs =" <+> ppr env ]) +-- | An environment storing 'CprSig's for local Ids.+-- Puts binders with 'topCprSig' in a space-saving 'IntSet'.+-- See Note [Efficient Top sigs in SigEnv].+data SigEnv+  = SE+  { se_tops :: !UnVarSet+  -- ^ All these Ids have 'topCprSig'. Like a 'VarSet', but more efficient.+  , se_sigs :: !(VarEnv CprSig)+  -- ^ Ids that have something other than 'topCprSig'.+  }++instance Outputable SigEnv where+  ppr (SE { se_tops = tops, se_sigs = sigs })+    = text "SE" <+> braces (vcat+         [ text "se_tops =" <+> ppr tops+         , text "se_sigs =" <+> ppr sigs ])+ emptyAnalEnv :: FamInstEnvs -> AnalEnv emptyAnalEnv fam_envs   = AE-  { ae_sigs = emptyVarEnv+  { ae_sigs = SE emptyUnVarSet emptyVarEnv   , ae_virgin = True   , ae_fam_envs = fam_envs   } --- | Extend an environment with the CPR sigs attached to the id-extendSigEnvList :: AnalEnv -> [Id] -> AnalEnv-extendSigEnvList env ids-  = env { ae_sigs = sigs' }-  where-    sigs' = extendVarEnvList (ae_sigs env) [ (id, idCprInfo id) | id <- ids ]+modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv+modifySigEnv f env = env { ae_sigs = f (ae_sigs env) } +lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig+-- See Note [Efficient Top sigs in SigEnv]+lookupSigEnv AE{ae_sigs = SE tops sigs} id+  | id `elemUnVarSet` tops = Just topCprSig+  | otherwise              = lookupVarEnv sigs id+ extendSigEnv :: AnalEnv -> Id -> CprSig -> AnalEnv+-- See Note [Efficient Top sigs in SigEnv] extendSigEnv env id sig-  = env { ae_sigs = extendVarEnv (ae_sigs env) id sig }+  | isTopCprSig sig+  = modifySigEnv (\se -> se{se_tops = extendUnVarSet id (se_tops se)}) env+  | otherwise+  = modifySigEnv (\se -> se{se_sigs = extendVarEnv (se_sigs se) id sig}) env -lookupSigEnv :: AnalEnv -> Id -> Maybe CprSig-lookupSigEnv env id = lookupVarEnv (ae_sigs env) id+-- | Extend an environment with the (Id, CPR sig) pairs+extendSigEnvList :: AnalEnv -> [(Id, CprSig)] -> AnalEnv+extendSigEnvList env ids_cprs+  = foldl' (\env (id, sig) -> extendSigEnv env id sig) env ids_cprs +-- | Extend an environment with the CPR sigs attached to the ids+extendSigEnvFromIds :: AnalEnv -> [Id] -> AnalEnv+extendSigEnvFromIds env ids+  = foldl' (\env id -> extendSigEnv env id (idCprInfo id)) env ids++-- | Extend an environment with the same CPR sig for all ids+extendSigEnvAllSame :: AnalEnv -> [Id] -> CprSig -> AnalEnv+extendSigEnvAllSame env ids sig+  = foldl' (\env id -> extendSigEnv env id sig) env ids+ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -442,116 +487,62 @@ -- In this case, we can still look at their demand to attach CPR signatures -- anticipating the unboxing done by worker/wrapper. -- See Note [CPR for binders that will be unboxed].-extendSigEnvForDemand :: AnalEnv -> Id -> Demand -> AnalEnv-extendSigEnvForDemand env id dmd-  | isId id-  , Just (_, DataConAppContext { dcac_dc = dc })-      <- wantToUnbox (ae_fam_envs env) has_inlineable_prag (idType id) dmd-  = extendSigEnv env id (CprSig (conCprType (dataConTag dc)))-  | otherwise-  = env+extendSigEnvForArg :: AnalEnv -> Id -> AnalEnv+extendSigEnvForArg env id+  = extendSigEnv env id (CprSig (argCprType env (idType id) (idDemandInfo id)))++-- | Produces a 'CprType' according to how a strict argument will be unboxed.+-- Examples:+--+--   * A head-strict demand @1L@ on @Int@ would translate to @1@+--   * A product demand @1P(1L,L)@ on @(Int, Bool)@ would translate to @1(1,)@+--   * A product demand @1P(1L,L)@ on @(a , Bool)@ would translate to @1(,)@,+--     because the unboxing strategy would not unbox the @a@.+argCprType :: AnalEnv -> Type -> Demand -> CprType+argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd)   where+    go ty dmd+      | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds+          <- wantToUnbox (ae_fam_envs env) no_inlineable_prag ty dmd+      -- No existentials; see Note [Which types are unboxed?])+      -- Otherwise we'd need to call dataConRepInstPat here and thread a+      -- UniqSupply. So argCprType is a bit less aggressive than it could+      -- be, for the sake of coding convenience.+      , null (dataConExTyCoVars dc)+      , let arg_tys = map scaledThing (dataConInstArgTys dc tc_args)+      = ConCpr (dataConTag dc) (zipWith go arg_tys ds)+      | otherwise+      = topCpr     -- Rather than maintaining in AnalEnv whether we are in an INLINEABLE     -- function, we just assume that we aren't. That flag is only relevant     -- to Note [Do not unpack class dictionaries], the few unboxing     -- opportunities on dicts it prohibits are probably irrelevant to CPR.-    has_inlineable_prag = False--extendEnvForDataAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv--- See Note [CPR in a DataAlt case alternative]-extendEnvForDataAlt env scrut case_bndr dc bndrs-  = foldl' do_con_arg env' ids_w_strs-  where-    env' = extendSigEnv env case_bndr (CprSig case_bndr_ty)--    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc--    tycon          = dataConTyCon dc-    is_product     = isJust (isDataProductTyCon_maybe tycon)-    is_sum         = isJust (isDataSumTyCon_maybe tycon)-    case_bndr_ty-      | is_product || is_sum = conCprType  (dataConTag dc)-      -- Any of the constructors had existentials. This is a little too-      -- conservative (after all, we only care about the particular data con),-      -- but there is no easy way to write is_sum and this won't happen much.-      | otherwise            = topCprType--    -- We could have much deeper CPR info here with Nested CPR, which could-    -- propagate available unboxed things from the scrutinee, getting rid of-    -- the is_var_scrut heuristic. See Note [CPR in a DataAlt case alternative].-    -- Giving strict binders the CPR property only makes sense for products, as-    -- the arguments in Note [CPR for binders that will be unboxed] don't apply-    -- to sums (yet); we lack WW for strict binders of sum type.-    do_con_arg env (id, str)-       | is_var scrut-       -- See Note [Add demands for strict constructors] in GHC.Core.Opt.WorkWrap.Utils-       , let dmd = applyWhen (isMarkedStrict str) strictifyDmd (idDemandInfo id)-       = extendSigEnvForDemand env id dmd-       | otherwise-       = env--    is_var (Cast e _) = is_var e-    is_var (Var v)    = isLocalId v-    is_var _          = False+    no_inlineable_prag = False  {- Note [Safe abortion in the fixed-point iteration] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- Fixed-point iteration may fail to terminate. But we cannot simply give up and return the environment and code unchanged! We still need to do one additional round, to ensure that all expressions have been traversed at least once, and any unsound CPR annotations have been updated. -Note [CPR in a DataAlt case alternative]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a case alternative, we want to give some of the binders the CPR property.-Specifically-- * The case binder; inside the alternative, the case binder always has-   the CPR property, meaning that a case on it will successfully cancel.-   Example:-        f True  x = case x of y { I# x' -> if x' ==# 3-                                           then y-                                           else I# 8 }-        f False x = I# 3--   By giving 'y' the CPR property, we ensure that 'f' does too, so we get-        f b x = case fw b x of { r -> I# r }-        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }-        fw False x = 3--   Of course there is the usual risk of re-boxing: we have 'x' available-   boxed and unboxed, but we return the unboxed version for the wrapper to-   box.  If the wrapper doesn't cancel with its caller, we'll end up-   re-boxing something that we did have available in boxed form.-- * Any strict binders with product type, can use-   Note [CPR for binders that will be unboxed]-   to anticipate worker/wrappering for strictness info.-   But we can go a little further. Consider--      data T = MkT !Int Int--      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))-                   | otherwise = x--   For $wf2 we are going to unbox the MkT *and*, since it is strict, the-   first argument of the MkT; see Note [Add demands for strict constructors].-   But then we don't want box it up again when returning it!  We want-   'f2' to have the CPR property, so we give 'x' the CPR property.+Note [Efficient Top sigs in SigEnv]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's pretty common for binders in the SigEnv to have a 'topCprSig'.+Wide records with 100 fields like in T9675 even will generate code where the+majority of binders has Top signature. To save some allocations, we store+those binders with a Top signature in a separate UnVarSet (which is an IntSet+with a convenient Var-tailored API). - * It's a bit delicate because we're brittly anticipating worker/wrapper here.-   If the case above is scrutinising something other than an argument the-   original function, we really don't have the unboxed version available.  E.g-      g v = case foo v of-              MkT x y | y>0       -> ...-                      | otherwise -> x-   Here we don't have the unboxed 'x' available.  Hence the-   is_var_scrut test when making use of the strictness annotation.-   Slightly ad-hoc, because even if the scrutinee *is* a variable it-   might not be a onre of the arguments to the original function, or a-   sub-component thereof.  But it's simple, and nothing terrible-   happens if we get it wrong.  e.g. Trac #10694.+Why store top signatures at all in the SigEnv? After all, when 'cprTransform'+encounters a locally-bound Id without an entry in the SigEnv, it should behave+as if that binder has a Top signature!+Well, the problem is when case binders should have a Top signatures. They always+have an unfolding and thus look to 'cprTransform' as if they bind a data+structure, Note [CPR for data structures], and thus would always have the CPR+property. So we need some mechanism to separate data structures from case+binders with a Top signature, and the UnVarSet provides that in the least+convoluted way I can think of.  Note [CPR for binders that will be unboxed] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -575,17 +566,110 @@ f1, and so the boxed version *won't* be available; in that case it's very helpful to give 'x' the CPR property. +This is all done in 'extendSigEnvForArg'.+ Note that -  * We only want to do this for something that definitely-    has product type, else we may get over-optimistic CPR results-    (e.g. from \x -> x!).+  * Whether or not something unboxes is decided by 'wantToUnbox', else we may+    get over-optimistic CPR results (e.g., from \(x :: a) -> x!). -  * This also (approximately) applies to DataAlt field binders;-    See Note [CPR in a DataAlt case alternative].+  * If the demand unboxes deeply, we can give the binder a /nested/ CPR+    property, e.g. +      g :: (Int, Int) -> Int+      g p = case p of+        (x, y) | x < 0     -> 0+               | otherwise -> x++    `x` should have the CPR property because it will be unboxed. We do so+    by giving `p` the Nested CPR property `1(1,)`, indicating that we not only+    have `p` available unboxed, but also its field `x`. Analysis of the Case+    will then transfer the CPR property to `x`.++    Before we were able to express Nested CPR, we used to guess which field+    binders should get the CPR property.+    See Historic Note [Optimistic field binder CPR].+   * See Note [CPR examples] +Historic Note [Optimistic field binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes how we used to guess whether fields have the CPR property+before we were able to express Nested CPR for arguments.++Consider++  data T a = MkT a+  f :: T Int -> Int+  f x = ... (case x of+    MkT y -> y) ...++And assume we know from strictness analysis that `f` is strict in `x` and its+field `y` and we unbox both. Then we give `x` the CPR property according+to Note [CPR for binders that will be unboxed]. But `x`'s sole field `y`+likewise will be unboxed and it should also get the CPR property. We'd+need a *nested* CPR property here for `x` to express that and unwrap one level+when we analyse the Case to give the CPR property to `y`.++Lacking Nested CPR, we have to guess a bit, by looking for++  (A) Flat CPR on the scrutinee+  (B) A variable scrutinee. Otherwise surely it can't be a parameter.+  (C) Strict demand on the field binder `y` (or it binds a strict field)++While (A) is a necessary condition to give a field the CPR property, there are+ways in which (B) and (C) are too lax, leading to unsound analysis results and+thus reboxing in the wrapper:++  (b) We could scrutinise some other variable than a parameter, like in++        g :: T Int -> Int+        g x = let z = foo x in -- assume `z` has CPR property+              case z of MkT y -> y++      Lacking Nested CPR and multiple levels of unboxing, only the outer box+      of `z` will be available and a case on `y` won't actually cancel away.+      But it's simple, and nothing terrible happens if we get it wrong. e.g.+      #10694.++  (c) A strictly used field binder doesn't mean the function is strict in it.++        h :: T Int -> Int -> Int+        h !x 0 = 0+        h  x 0 = case x of MkT y -> y++      Here, `y` is used strictly, but the field of `x` certainly is not and+      consequently will not be available unboxed.+      Why not look at the demand of `x` instead to determine whether `y` is+      unboxed? Because the 'idDemandInfo' on `x` will not have been propagated+      to its occurrence in the scrutinee when CprAnal runs directly after+      DmdAnal.++We used to give the case binder the CPR property unconditionally instead of+deriving it from the case scrutinee.+See Historical Note [Optimistic case binder CPR].++Historical Note [Optimistic case binder CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to give the case binder the CPR property unconditionally, which is too+optimistic (#19232). Here are the details:++Inside the alternative, the case binder always has the CPR property, meaning+that a case on it will successfully cancel.+Example:+  f True  x = case x of y { I# x' -> if x' ==# 3+                                     then y+                                     else I# 8 }+  f False x = I# 3+By giving 'y' the CPR property, we ensure that 'f' does too, so we get+  f b x = case fw b x of { r -> I# r }+  fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }+  fw False x = 3+Of course there is the usual risk of re-boxing: we have 'x' available boxed+and unboxed, but we return the unboxed version for the wrapper to box. If the+wrapper doesn't cancel with its caller, we'll end up re-boxing something that+we did have available in boxed form.+ Note [CPR for sum types] ~~~~~~~~~~~~~~~~~~~~~~~~ At the moment we do not do CPR for let-bindings that@@ -741,7 +825,7 @@ Note [CPR examples] ~~~~~~~~~~~~~~~~~~~~ Here are some examples (stranal/should_compile/T10482a) of the-usefulness of Note [CPR in a DataAlt case alternative].  The main+usefulness of Note [Optimistic field binder CPR].  The main point: all of these functions can have the CPR property.      ------- f1 -----------

GHC/Core/Opt/DmdAnal.hs view

@@ -9,18 +9,20 @@  {-# LANGUAGE CPP #-} -module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where+module GHC.Core.Opt.DmdAnal+   ( DmdAnalOpts(..)+   , dmdAnalProgram+   )+where  #include "HsVersions.h"  import GHC.Prelude -import GHC.Driver.Session import GHC.Core.Opt.WorkWrap.Utils import GHC.Types.Demand   -- All of it import GHC.Core import GHC.Core.Multiplicity ( scaledThing )-import GHC.Core.Seq     ( seqBinds ) import GHC.Utils.Outputable import GHC.Types.Var.Env import GHC.Types.Var.Set@@ -29,20 +31,22 @@ import GHC.Core.DataCon import GHC.Types.ForeignCall ( isSafeForeignCall ) import GHC.Types.Id-import GHC.Types.Id.Info import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type-import GHC.Core.FVs      ( exprFreeIds, ruleRhsFreeIds )+import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) import GHC.Core.Coercion ( Coercion, coVarsOfCo ) import GHC.Core.FamInstEnv+import GHC.Core.Opt.Arity ( typeArity ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Maybe         ( isJust ) import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )-import GHC.Utils.Error        ( dumpIfSet_dyn, DumpFormat (..) ) import GHC.Types.Unique.Set +-- import GHC.Driver.Ppr+ {- ************************************************************************ *                                                                      *@@ -51,32 +55,66 @@ ************************************************************************ -} -dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram-dmdAnalProgram dflags fam_envs binds = do-  let env             = emptyAnalEnv dflags fam_envs-  let binds_plus_dmds = snd $ mapAccumL dmdAnalTopBind env binds-  dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $-    dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds-  -- See Note [Stamp out space leaks in demand analysis]-  seqBinds binds_plus_dmds `seq` return binds_plus_dmds+-- | Options for the demand analysis+newtype DmdAnalOpts = DmdAnalOpts+   { dmd_strict_dicts :: Bool -- ^ Use strict dictionaries+   } --- Analyse a (group of) top-level binding(s)-dmdAnalTopBind :: AnalEnv-               -> CoreBind-               -> (AnalEnv, CoreBind)-dmdAnalTopBind env (NonRec id rhs)-  = ( extendAnalEnv TopLevel env id sig-    , NonRec (setIdStrictness id sig) rhs')+-- | Outputs a new copy of the Core program in which binders have been annotated+-- with demand and strictness information.+--+-- Note: use `seqBinds` on the result to avoid leaks due to lazyness (cf Note+-- [Stamp out space leaks in demand analysis])+dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram+dmdAnalProgram opts fam_envs rules binds+  = snd $ go (emptyAnalEnv opts fam_envs) binds   where-    ( _, sig, rhs') = dmdAnalRhsLetDown Nothing env cleanEvalDmd id rhs+    -- See Note [Analysing top-level bindings]+    -- and Note [Why care for top-level demand annotations?]+    go _   []     = (nopDmdType, [])+    go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body+      where+        anal_body env'+          | (body_ty, bs') <- go env' bs+          = (add_exported_uses env' body_ty (bindersOf b), bs') -dmdAnalTopBind env (Rec pairs)-  = (env', Rec pairs')-  where-    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs-                -- We get two iterations automatically-                -- c.f. the NonRec case above+    cons_up :: (a, b, [b]) -> (a, [b])+    cons_up (dmd_ty, b', bs') = (dmd_ty, b':bs') +    add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType+    add_exported_uses env = foldl' (add_exported_use env)++    -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@+    -- corresponds to the demand type of @(id, e)@, but is a lot more direct.+    -- See Note [Analysing top-level bindings].+    add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType+    add_exported_use env dmd_ty id+      | isExportedId id || elemVarSet id rule_fvs+      -- See Note [Absence analysis for stable unfoldings and RULES]+      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))+      | otherwise+      = dmd_ty++    rule_fvs :: IdSet+    rule_fvs = rulesRhsFreeIds rules++-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings+-- that satisfy this function.+--+-- Basically, we want to know how top-level *functions* are *used*+-- (e.g. called). The information will always be lazy.+-- Any other top-level bindings are boring.+--+-- See also Note [Why care for top-level demand annotations?].+isInterestingTopLevelFn :: Id -> Bool+-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642+-- (which is dominated by the Simplifier) at no gain in analysis precision.+-- If there was a gain, that regression might be acceptable.+-- Plus, we could use LetUp for thunks and share some code with local let+-- bindings.+isInterestingTopLevelFn id =+  typeArity (idType id) `lengthExceeds` 0+ {- Note [Stamp out space leaks in demand analysis] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The demand analysis pass outputs a new copy of the Core program in@@ -95,33 +133,186 @@ unforced thunks in demand or strictness information; and it is the most memory-intensive part of the compilation process, so this added seqBinds makes a big difference in peak memory usage.--} +Note [Analysing top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a CoreProgram like+  e1 = ...+  n1 = ...+  e2 = \a b -> ... fst (n1 a b) ...+  n2 = \c d -> ... snd (e2 c d) ...+  ...+where e* are exported, but n* are not.+Intuitively, we can see that @n1@ is only ever called with two arguments+and in every call site, the first component of the result of the call+is evaluated. Thus, we'd like it to have idDemandInfo @LCL(CM(P(1L,A))@.+NB: We may *not* give e2 a similar annotation, because it is exported and+external callers might use it in arbitrary ways, expressed by 'topDmd'.+This can then be exploited by Nested CPR and eta-expansion,+see Note [Why care for top-level demand annotations?]. +How do we get this result? Answer: By analysing the program as if it was a let+expression of this form:+  let e1 = ... in+  let n1 = ... in+  let e2 = ... in+  let n2 = ... in+  (e1,e2, ...)+E.g. putting all bindings in nested lets and returning all exported binders in a tuple.+Of course, we will not actually build that CoreExpr! Instead we faithfully+simulate analysis of said expression by adding the free variable 'DmdEnv'+of @e*@'s strictness signatures to the 'DmdType' we get from analysing the+nested bindings.++And even then the above form blows up analysis performance in T10370:+If @e1@ uses many free variables, we'll unnecessarily carry their demands around+with us from the moment we analyse the pair to the moment we bubble back up to+the binding for @e1@. So instead we analyse as if we had+  let e1 = ... in+  (e1, let n1 = ... in+  (    let e2 = ... in+  (e2, let n2 = ... in+  (    ...))))+That is, a series of right-nested pairs, where the @fst@ are the exported+binders of the last enclosing let binding and @snd@ continues the nested+lets.++Variables occurring free in RULE RHSs are to be handled the same as exported Ids.+See also Note [Absence analysis for stable unfoldings and RULES].++Note [Why care for top-level demand annotations?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Reading Note [Analysing top-level bindings], you might think that we go through+quite some trouble to get useful demands for top-level bindings. They can never+be strict, for example, so why bother?++First, we get to eta-expand top-level bindings that we weren't able to+eta-expand before without Call Arity. From T18894b:+  module T18894b (f) where+  eta :: Int -> Int -> Int+  eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ...+  f m = ... eta m 2 ... eta 2 m ...+Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to+arity 2.++The call demands we get for some top-level bindings will also allow Nested CPR+to unbox deeper. From T18894:+  module T18894 (h) where+  g m n = (2 * m, 2 `div` n)+  {-# NOINLINE g #-}+  h :: Int -> Int+  h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ...+Only @h@ is exported, hence we see that @g@ is always called in contexts were we+also force the division in the second component of the pair returned by @g@.+This allows Nested CPR to evaluate the division eagerly and return an I# in its+position.+-}+ {- ************************************************************************ *                                                                      * \subsection{The analyser itself} *                                                                      * ************************************************************************--Note [Ensure demand is strict]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important not to analyse e with a lazy demand because-a) When we encounter   case s of (a,b) ->-        we demand s with U(d1d2)... but if the overall demand is lazy-        that is wrong, and we'd need to reduce the demand on s,-        which is inconvenient-b) More important, consider-        f (let x = R in x+x), where f is lazy-   We still want to mark x as demanded, because it will be when we-   enter the let.  If we analyse f's arg with a Lazy demand, we'll-   just mark x as Lazy-c) The application rule wouldn't be right either-   Evaluating (f x) in a L demand does *not* cause-   evaluation of f in a C(L) demand! -} +-- | Analyse a binding group and its \"body\", e.g. where it is in scope.+--+-- It calls a function that knows how to analyse this \"body\" given+-- an 'AnalEnv' with updated demand signatures for the binding group+-- (reflecting their 'idStrictnessInfo') and expects to receive a+-- 'DmdType' in return, which it uses to annotate the binding group with their+-- 'idDemandInfo'.+dmdAnalBind+  :: TopLevelFlag+  -> AnalEnv+  -> SubDemand                 -- ^ Demand put on the "body"+                               --   (important for join points)+  -> CoreBind+  -> (AnalEnv -> (DmdType, a)) -- ^ How to analyse the "body", e.g.+                               --   where the binding is in scope+  -> (DmdType, CoreBind, a)+dmdAnalBind top_lvl env dmd bind anal_body = case bind of+  NonRec id rhs+    | useLetUp top_lvl id+    -> dmdAnalBindLetUp   top_lvl env     id rhs anal_body+  _ -> dmdAnalBindLetDown top_lvl env dmd bind   anal_body++-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')+-- with 'topDmd', the rest with the given demand.+setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id+setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of+  TopLevel | not (isInterestingTopLevelFn id) -> topDmd+  _                                           -> dmd++-- | Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- This function handles the up variant.+--+-- It is very simple. For  let x = rhs in body+--   * Demand-analyse 'body' in the current environment+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'+--   * Demand-analyse 'rhs' in 'rhs_dmd'+--+-- This is used for a non-recursive local let without manifest lambdas (see+-- 'useLetUp').+--+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalBindLetUp :: TopLevelFlag -> AnalEnv -> Id -> CoreExpr -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)+dmdAnalBindLetUp top_lvl env id rhs anal_body = (final_ty, NonRec id' rhs', body')+  where+    (body_ty, body')   = anal_body env+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id+    id'                = setBindIdDemandInfo top_lvl id id_dmd+    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs++    -- See Note [Absence analysis for stable unfoldings and RULES]+    rule_fvs           = bndrRuleAndUnfoldingIds id+    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs++-- | Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- This function handles the down variant.+--+-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses+-- that at call sites in the body.+--+-- It is used for toplevel definitions, recursive definitions and local+-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp').+-- Local non-recursive definitions without a lambda are handled with LetUp.+--+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> (DmdType, a)) -> (DmdType, CoreBind, a)+dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of+  NonRec id rhs+    | (env', lazy_fv, id1, rhs1) <-+        dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs+    -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)+  Rec pairs+    | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs+    -> do_rest env' lazy_fv pairs' Rec+  where+    do_rest env' lazy_fv pairs1 build_bind = (final_ty, build_bind pairs2, body')+      where+        (body_ty, body')        = anal_body env'+        -- see Note [Lazy and unleashable free variables]+        dmd_ty                  = addLazyFVs body_ty lazy_fv+        (!final_ty, id_dmds)    = findBndrsDmds env' dmd_ty (map fst pairs1)+        pairs2                  = zipWith do_one pairs1 id_dmds+        do_one (id', rhs') dmd  = (setBindIdDemandInfo top_lvl id' dmd, rhs')+        -- If the actual demand is better than the vanilla call+        -- demand, you might think that we might do better to re-analyse+        -- the RHS with the stronger demand.+        -- But (a) That seldom happens, because it means that *every* path in+        --         the body of the let has to use that stronger demand+        -- (b) It often happens temporarily in when fixpointing, because+        --     the recursive function at first seems to place a massive demand.+        --     But we don't want to go to extra work when the function will+        --     probably iterate to something less demanding.+        -- In practice, all the times the actual demand on id2 is more than+        -- the vanilla call demand seem to be due to (b).  So we don't+        -- bother to re-analyse the RHS.+ -- If e is complicated enough to become a thunk, its contents will be evaluated -- at most once, so oneify it. dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand@@ -135,23 +326,19 @@ dmdAnalStar :: AnalEnv             -> Demand   -- This one takes a *Demand*             -> CoreExpr -- Should obey the let/app invariant-            -> (BothDmdArg, CoreExpr)-dmdAnalStar env dmd e-  | (dmd_shell, cd) <- toCleanDmd dmd-  , (dmd_ty, e')    <- dmdAnal env cd e+            -> (PlusDmdArg, CoreExpr)+dmdAnalStar env (n :* cd) e+  | (dmd_ty, e')    <- dmdAnal env cd e   = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )     -- The argument 'e' should satisfy the let/app invariant     -- See Note [Analysing with absent demand] in GHC.Types.Demand-    (postProcessDmdType dmd_shell dmd_ty, e')+    (toPlusDmdArg $ multDmdType n dmd_ty, e')  -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv-        -> CleanDemand         -- The main one takes a *CleanDemand*+        -> SubDemand         -- The main one takes a *SubDemand*         -> CoreExpr -> (DmdType, CoreExpr) --- The CleanDemand is always strict and not absent---    See Note [Ensure demand is strict]- dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $                   dmdAnal' env d e @@ -164,7 +351,7 @@   = (dmdTransform env var dmd, Var var)  dmdAnal' env dmd (Cast e co)-  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)+  = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co)   where     (dmd_ty, e') = dmdAnal env dmd e @@ -185,7 +372,7 @@     -- Crucially, coercions /are/ handled here, because they are     -- value arguments (#10288)     let-        call_dmd          = mkCallDmd dmd+        call_dmd          = mkCalledOnceDmd dmd         (fun_ty, fun')    = dmdAnal env call_dmd fun         (arg_dmd, res_ty) = splitDmdTy fun_ty         (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg@@ -198,7 +385,7 @@ --         , text "arg dmd_ty =" <+> ppr arg_ty --         , text "res dmd_ty =" <+> ppr res_ty --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])-    (res_ty `bothDmdType` arg_ty, App fun' arg')+    (res_ty `plusDmdType` arg_ty, App fun' arg')  dmdAnal' env dmd (Lam var body)   | isTyVar var@@ -208,23 +395,35 @@     (body_ty, Lam var body')    | otherwise-  = let (body_dmd, defer_and_use) = peelCallDmd dmd+  = let (n, body_dmd)    = peelCallDmd dmd           -- body_dmd: a demand to analyze the body          (body_ty, body') = dmdAnal env body_dmd body         (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var     in-    (postProcessUnsat defer_and_use lam_ty, Lam var' body')+    (multDmdType n lam_ty, Lam var' body') -dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])-  -- Only one alternative with a product constructor-  | let tycon = dataConTyCon dc-  , isJust (isDataProductTyCon_maybe tycon)+dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])+  -- Only one alternative.+  -- If it's a DataAlt, it should be the only constructor of the type.+  | is_single_data_alt alt   = let         (rhs_ty, rhs')           = dmdAnal env dmd rhs         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs         (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr-        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds+        -- Evaluation cardinality on the case binder is irrelevant and a no-op.+        -- What matters is its nested sub-demand!+        (_ :* case_bndr_sd)      = case_bndr_dmd+        -- Compute demand on the scrutinee+        (bndrs', scrut_sd)+          | DataAlt _ <- alt+          , id_dmds <- addCaseBndrDmd case_bndr_sd dmds+          -- See Note [Demand on scrutinee of a product case]+          = (setBndrsDemandInfo bndrs id_dmds, mkProd id_dmds)+          | otherwise+          -- __DEFAULT and literal alts. Simply add demands and discard the+          -- evaluation cardinality, as we evaluate the scrutinee exactly once.+          = ASSERT( null bndrs ) (bndrs, case_bndr_sd)         fam_envs                 = ae_fam_envs env         alt_ty3           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"@@ -233,28 +432,26 @@           | otherwise           = alt_ty2 -        -- Compute demand on the scrutinee-        -- See Note [Demand on scrutinee of a product case]-        scrut_dmd          = mkProdDmd id_dmds-        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut-        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty+        (scrut_ty, scrut') = dmdAnal env scrut_sd scrut+        res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty         case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd-        bndrs'             = setBndrsDemandInfo bndrs id_dmds     in --    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut --                                   , text "dmd" <+> ppr dmd --                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')---                                   , text "id_dmds" <+> ppr id_dmds---                                   , text "scrut_dmd" <+> ppr scrut_dmd+--                                   , text "scrut_sd" <+> ppr scrut_sd --                                   , text "scrut_ty" <+> ppr scrut_ty --                                   , text "alt_ty" <+> ppr alt_ty2 --                                   , text "res_ty" <+> ppr res_ty ]) $-    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])+    (res_ty, Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])+    where+      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc+      is_single_data_alt _            = True  dmdAnal' env dmd (Case scrut case_bndr ty alts)   = let      -- Case expression with multiple alternatives-        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts-        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut+        (alt_tys, alts')     = mapAndUnzip (dmdAnalSumAlt env dmd case_bndr) alts+        (scrut_ty, scrut')   = dmdAnal env topSubDmd scrut         (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr                                -- NB: Base case is botDmdType, for empty case alternatives                                --     This is a unit for lubDmdType, and the right result@@ -266,7 +463,7 @@           = deferAfterPreciseException alt_ty           | otherwise           = alt_ty-        res_ty               = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty+        res_ty               = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty      in --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut@@ -276,64 +473,11 @@ --                                   , text "res_ty" <+> ppr res_ty ]) $     (res_ty, Case scrut' case_bndr' ty alts') --- Let bindings can be processed in two ways:--- Down (RHS before body) or Up (body before RHS).--- The following case handle the up variant.------ It is very simple. For  let x = rhs in body---   * Demand-analyse 'body' in the current environment---   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'---   * Demand-analyse 'rhs' in 'rhs_dmd'------ This is used for a non-recursive local let without manifest lambdas.--- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnal' env dmd (Let (NonRec id rhs) body)-  | useLetUp id-  = (final_ty, Let (NonRec id' rhs') body')-  where-    (body_ty, body')   = dmdAnal env dmd body-    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id-    id'                = setIdDemandInfo id id_dmd--    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs-    final_ty           = body_ty' `bothDmdType` rhs_ty--dmdAnal' env dmd (Let (NonRec id rhs) body)-  = (body_ty2, Let (NonRec id2 rhs') body')+dmdAnal' env dmd (Let bind body)+  = (final_ty, Let bind' body')   where-    (lazy_fv, sig, rhs') = dmdAnalRhsLetDown Nothing env dmd id rhs-    id1                  = setIdStrictness id sig-    env1                 = extendAnalEnv NotTopLevel env id sig-    (body_ty, body')     = dmdAnal env1 dmd body-    (body_ty1, id2)      = annotateBndr env body_ty id1-    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]--        -- If the actual demand is better than the vanilla call-        -- demand, you might think that we might do better to re-analyse-        -- the RHS with the stronger demand.-        -- But (a) That seldom happens, because it means that *every* path in-        --         the body of the let has to use that stronger demand-        -- (b) It often happens temporarily in when fixpointing, because-        --     the recursive function at first seems to place a massive demand.-        --     But we don't want to go to extra work when the function will-        --     probably iterate to something less demanding.-        -- In practice, all the times the actual demand on id2 is more than-        -- the vanilla call demand seem to be due to (b).  So we don't-        -- bother to re-analyse the RHS.--dmdAnal' env dmd (Let (Rec pairs) body)-  = let-        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs-        (body_ty, body')        = dmdAnal env' dmd body-        body_ty1                = deleteFVs body_ty (map fst pairs)-        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]-    in-    body_ty2 `seq`-    (body_ty2,  Let (Rec pairs') body')--deleteFVs :: DmdType -> [Var] -> DmdType-deleteFVs (DmdType fvs dmds res) bndrs-  = DmdType (delVarEnvList fvs bndrs) dmds res+    (final_ty, bind', body') = dmdAnalBind NotTopLevel env dmd bind go'+    go' env'                 = dmdAnal env' dmd body  -- | A simple, syntactic analysis of whether an expression MAY throw a precise -- exception when evaluated. It's always sound to return 'True'.@@ -362,28 +506,85 @@ forcesRealWorld fam_envs ty   | ty `eqType` realWorldStatePrimTy   = True-  | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }-      <- deepSplitProductType_maybe fam_envs ty-  , isUnboxedTupleCon dc-  = any (\(ty,_) -> scaledThing ty `eqType` realWorldStatePrimTy) field_tys+  | Just DataConPatContext{ dcpc_dc = dc, dcpc_tc_args = tc_args }+      <- splitArgType_maybe fam_envs ty+  , isUnboxedTupleDataCon dc+  , let field_tys = dataConInstArgTys dc tc_args+  = any (eqType realWorldStatePrimTy . scaledThing) field_tys   | otherwise   = False -dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)-dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)-  | null bndrs    -- Literals, DEFAULT, and nullary constructors-  , (rhs_ty, rhs') <- dmdAnal env dmd rhs-  = (rhs_ty, (con, [], rhs'))--  | otherwise     -- Non-nullary data constructors-  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)+  | (rhs_ty, rhs') <- dmdAnal env dmd rhs   , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs-  , let case_bndr_dmd = findIdDemand alt_ty case_bndr-        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds-  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))+  , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr+        -- See Note [Demand on scrutinee of a product case]+        id_dmds             = addCaseBndrDmd case_bndr_sd dmds+  = (alt_ty, Alt con (setBndrsDemandInfo bndrs id_dmds) rhs') -{- Note [Which scrutinees may throw precise exceptions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{-+Note [Analysing with absent demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we analyse an expression with demand A.  The "A" means+"absent", so this expression will never be needed.  What should happen?+There are several wrinkles:++* We *do* want to analyse the expression regardless.+  Reason: Note [Always analyse in virgin pass]++  But we can post-process the results to ignore all the usage+  demands coming back. This is done by multDmdType.++* In a previous incarnation of GHC we needed to be extra careful in the+  case of an *unlifted type*, because unlifted values are evaluated+  even if they are not used.  Example (see #9254):+     f :: (() -> (# Int#, () #)) -> ()+          -- Strictness signature is+          --    <CS(S(A,SU))>+          -- I.e. calls k, but discards first component of result+     f k = case k () of (# _, r #) -> r++     g :: Int -> ()+     g y = f (\n -> (# case y of I# y2 -> y2, n #))++  Here f's strictness signature says (correctly) that it calls its+  argument function and ignores the first component of its result.+  This is correct in the sense that it'd be fine to (say) modify the+  function so that always returned 0# in the first component.++  But in function g, we *will* evaluate the 'case y of ...', because+  it has type Int#.  So 'y' will be evaluated.  So we must record this+  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that+  'y' is bound to an aBSENT_ERROR thunk.++  However, the argument of toSubDmd always satisfies the let/app+  invariant; so if it is unlifted it is also okForSpeculation, and so+  can be evaluated in a short finite time -- and that rules out nasty+  cases like the one above.  (I'm not quite sure why this was a+  problem in an earlier version of GHC, but it isn't now.)++Note [Always analyse in virgin pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tricky point: make sure that we analyse in the 'virgin' pass. Consider+   rec { f acc x True  = f (...rec { g y = ...g... }...)+         f acc x False = acc }+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.+That might mean that we analyse the sub-expression containing the+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*+E, but just returned botType.++Then in the *next* (non-virgin) iteration for 'f', we might analyse E+in a weaker demand, and that will trigger doing a fixpoint iteration+for g.  But *because it's not the virgin pass* we won't start g's+iteration at bottom.  Disaster.  (This happened in $sfibToList' of+nofib/spectral/fibheaps.)++So in the virgin pass we make sure that we do analyse the expression+at least once, to initialise its signatures.++Note [Which scrutinees may throw precise exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This is the specification of 'exprMayThrowPreciseExceptions', which is important for Scenario 2 of Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.@@ -427,13 +628,16 @@ see Note [Demand on case-alternative binders] in GHC.Types.Demand. This is crucial. Example:    f x = case x of y { (a,b) -> k y a }-If we just take scrut_demand = U(L,A), then we won't pass x to the+If we just take scrut_demand = 1P(L,A), then we won't pass x to the worker, so the worker will rebuild      x = (a, absent-error) and that'll crash.  Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+FIXME: This Note should be named [LetUp vs. LetDown] and probably predates+said separation. SG+ We use different strategies for strictness and usage/cardinality to "unleash" demands captured on free variables by bindings. Let us consider the example:@@ -480,21 +684,24 @@ ************************************************************************ -} -dmdTransform :: AnalEnv         -- The strictness environment-             -> Id              -- The function-             -> CleanDemand     -- The demand on the function-             -> DmdType         -- The demand type of the function in this context-        -- Returned DmdEnv includes the demand on-        -- this function plus demand on its free variables+dmdTransform :: AnalEnv         -- ^ The strictness environment+             -> Id              -- ^ The function+             -> SubDemand       -- ^ The demand on the function+             -> DmdType         -- ^ The demand type of the function in this context+                                -- Returned DmdEnv includes the demand on+                                -- this function plus demand on its free variables +-- See Note [What are demand signatures?] in "GHC.Types.Demand" dmdTransform env var dmd   -- Data constructors   | isDataConWorkId var   = dmdTransformDataConSig (idArity var) dmd   -- Dictionary component selectors-  | gopt Opt_DmdTxDictSel (ae_dflags env),-    Just _ <- isClassOpId_maybe var-  = dmdTransformDictSelSig (idStrictness var) dmd+  -- Used to be controlled by a flag.+  -- See #18429 for some perf measurements.+  | Just _ <- isClassOpId_maybe var+  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $+    dmdTransformDictSelSig (idStrictness var) dmd   -- Imported functions   | isGlobalId var   , let res = dmdTransformSig (idStrictness var) dmd@@ -505,16 +712,24 @@   | Just (sig, top_lvl) <- lookupSigEnv env var   , let fn_ty = dmdTransformSig sig dmd   = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $-    if isTopLevel top_lvl-    then fn_ty   -- Don't record demand on top-level things-    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)+    case top_lvl of+      NotTopLevel -> addVarDmd fn_ty var (C_11 :* dmd)+      TopLevel+        | isInterestingTopLevelFn var+        -- Top-level things will be used multiple times or not at+        -- all anyway, hence the multDmd below: It means we don't+        -- have to track whether @var@ is used strictly or at most+        -- once, because ultimately it never will.+        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* dmd)) -- discard strictness+        | otherwise+        -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later   -- Everything else:   --   * Local let binders for which we use LetUp (cf. 'useLetUp')   --   * Lambda binders   --   * Case and constructor field binders   | otherwise   = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $-    unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))+    unitDmdType (unitVarEnv var (C_11 :* dmd))  {- ********************************************************************* *                                                                      *@@ -522,76 +737,70 @@ *                                                                      * ********************************************************************* -} --- Let bindings can be processed in two ways:--- Down (RHS before body) or Up (body before RHS).--- dmdAnalRhsLetDown implements the Down variant:---  * assuming a demand of <L,U>+-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature+-- for the LetDown rule. It works as follows:+--+--  * assuming the weakest possible body sub-demand, L --  * looking at the definition --  * determining a strictness signature ----- It is used for toplevel definition, recursive definitions and local--- non-recursive definitions that have manifest lambdas.--- Local non-recursive definitions without a lambda are handled with LetUp.------ This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.-dmdAnalRhsLetDown-  :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive-  -> AnalEnv -> CleanDemand+-- Since it assumed a body sub-demand of L, the resulting signature is+-- applicable at any call site.+dmdAnalRhsSig+  :: TopLevelFlag+  -> RecFlag+  -> AnalEnv -> SubDemand   -> Id -> CoreExpr-  -> (DmdEnv, StrictSig, CoreExpr)+  -> (AnalEnv, DmdEnv, Id, CoreExpr) -- Process the RHS of the binding, add the strictness signature -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness]-dmdAnalRhsLetDown rec_flag env let_dmd id rhs-  = (lazy_fv, sig, rhs')+dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $+    (env', lazy_fv, id', rhs')   where     rhs_arity = idArity id+    -- See Note [Demand signatures are computed for a threshold demand based on idArity]     rhs_dmd -- See Note [Demand analysis for join points]             -- See Note [Invariants on join points] invariant 2b, in GHC.Core             --     rhs_arity matches the join arity of the join point             | isJoinId id-            = mkCallDmds rhs_arity let_dmd+            = mkCalledOnceDmds rhs_arity let_dmd             | otherwise-            -- NB: rhs_arity-            -- See Note [Demand signatures are computed for a threshold demand based on idArity]-            = mkRhsDmd env rhs_arity rhs+            = mkCalledOnceDmds rhs_arity topSubDmd      (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) +    id' = id `setIdStrictness` sig+    env' = extendAnalEnv top_lvl env id' sig+     -- See Note [Aggregated demand for cardinality]+    -- FIXME: That Note doesn't explain the following lines at all. The reason+    --        is really much different: When we have a recursive function, we'd+    --        have to also consider the free vars of the strictness signature+    --        when checking whether we found a fixed-point. That is expensive;+    --        we only want to check whether argument demands of the sig changed.+    --        reuseEnv makes it so that the FV results are stable as long as the+    --        last argument demands were. Strictness won't change. But used-once+    --        might turn into used-many even if the signature was stable and+    --        we'd have to do an additional iteration. reuseEnv makes sure that+    --        we never get used-once info for FVs of recursive functions.     rhs_fv1 = case rec_flag of-                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_fv2-    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)+                Recursive    -> reuseEnv rhs_fv+                NonRecursive -> rhs_fv -    -- 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+    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id --- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for--- unleashing on the given function's @rhs@, by creating--- a call demand of @rhs_arity@--- See Historical Note [Product demands for function body]-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand-mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd+    -- See Note [Lazy and unleashable free variables]+    (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 --- | If given the let-bound 'Id', 'useLetUp' determines whether we should--- process the binding up (body before rhs) or down (rhs before body).+-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines+-- whether we should process the binding up (body before rhs) or down (rhs+-- before body). -- -- We use LetDown if there is a chance to get a useful strictness signature to -- unleash at call sites. LetDown is generally more precise than LetUp if we can@@ -633,8 +842,8 @@ --   * For a more convincing example with join points, see Note [Demand analysis --     for join points]. ---useLetUp :: Var -> Bool-useLetUp f = idArity f == 0 && not (isJoinId f)+useLetUp :: TopLevelFlag -> Var -> Bool+useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f)  {- Note [Demand analysis for join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -676,10 +885,10 @@     (     B -> j 4             )     (     C -> \y. blah        ) -The entire thing is in a C(S) context, so j's strictness signature+The entire thing is in a C1(L) context, so j's strictness signature will be    [A]b meaning one absent argument, returns bottom.  That seems odd because-there's a \y inside.  But it's right because when consumed in a C(1)+there's a \y inside.  But it's right because when consumed in a C1(L) context the RHS of the join point is indeed bottom.  Note [Demand signatures are computed for a threshold demand based on idArity]@@ -689,12 +898,14 @@ is /at least/ the number of manifest lambdas, but might be higher for PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]). -Because idArity of a function varies independently of its cardinality properties-(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode-the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'-(cf. Note [Understanding DmdType and StrictSig] in GHC.Types.Demand). It is unsound to-unleash a demand signature when the incoming number of arguments is less than-that. See Note [What are demand signatures?] for more details on soundness.+Because idArity of a function varies independently of its cardinality+properties (cf. Note [idArity varies independently of dmdTypeDepth]), we+implicitly encode the arity for when a demand signature is sound to unleash+in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and StrictSig] in+GHC.Types.Demand). It is unsound to unleash a demand signature when the+incoming number of arguments is less than that.+See Note [What are demand signatures?] in GHC.Types.Demand for more details+on soundness.  Why idArity arguments? Because that's a conservative estimate of how many arguments we must feed a function before it does anything interesting with them.@@ -708,12 +919,12 @@       then \y -> ... y ...       else \y -> ... y ... -We'd analyse `f` under a unary call demand C(S), corresponding to idArity+We'd analyse `f` under a unary call demand C1(L), corresponding to idArity being 1. That's enough to look under the manifest lambda and find out how a unary call would use `x`, but not enough to look into the lambdas in the if branches. -On the other hand, if we analysed for call demand C(C(S)), we'd get useful+On the other hand, if we analysed for call demand C1(C1(L)), we'd get useful strictness info for `y` (and more precise info on `x`) and possibly CPR information, but @@ -745,7 +956,7 @@      (let go x y = `x` seq ... in go) |> co -`go` might have a strictness signature of `<S><L>`. The simplifier will identify+`go` might have a strictness signature of `<1L><L>`. The simplifier will identify `go` as a nullary join point through `joinPointBinding_maybe` and float the coercion into the binding, leading to an arity decrease: @@ -754,57 +965,6 @@ With the CoreLint check, we would have to zap `go`'s perfectly viable strictness signature. -Note [What are demand signatures?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand analysis interprets expressions in the abstract domain of demand-transformers. Given an incoming demand we put an expression under, its abstract-transformer gives us back a demand type denoting how other things (like-arguments and free vars) were used when the expression was evaluated.-Here's an example:--  f x y =-    if x + expensive-      then \z -> z + y * ...-      else \z -> z * ...--The abstract transformer (let's call it F_e) of the if expression (let's call it-e) would transform an incoming head demand <S,HU> into a demand type like-{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:--     Demand ---F_e---> DmdType-     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>--Let's assume that the demand transformers we compute for an expression are-correct wrt. to some concrete semantics for Core. How do demand signatures fit-in? They are strange beasts, given that they come with strict rules when to-it's sound to unleash them.--Fortunately, we can formalise the rules with Galois connections. Consider-f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of-the actual abstract transformer of f's RHS for arity 2. So, what happens is that-we abstract *once more* from the abstract domain we already are in, replacing-the incoming Demand by a simple lattice with two elements denoting incoming-arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom-element). Here's the diagram:--     A_2 -----f_f----> DmdType-      ^                   |-      | α               γ |-      |                   v-     Demand ---F_f---> DmdType--With-  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness-  α(_)         =  <2-  γ(ty)        =  ty-and F_f being the abstract transformer of f's RHS and f_f being the abstracted-abstract transformer computable from our demand signature simply by--  f_f(>=2) = {}<S,1*U><L,U>-  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>--where postProcessUnsat makes a proper top element out of the given demand type.- Note [Demand analysis for trivial right-hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -877,11 +1037,11 @@ the Nil case.  Partly the Nil case is not a hot path.  But more specifically, the whole function gets the CPR property if we do. -That motivated using a demand of C(C(C(S(L,L)))) for the RHS, where+That motivated using a demand of C1(C1(C1(P(L,L)))) for the RHS, where (solely because the result was a product) we used a product demand (albeit with lazy components) for the body. But that gives very silly behaviour -- see #17932.   Happily it turns out now to be entirely-unnecessary: we get good results with C(C(C(S))).   So I simply+unnecessary: we get good results with C1(C1(C1(L))).   So I simply deleted the special case. -} @@ -894,15 +1054,13 @@ -- Recursive bindings dmdFix :: TopLevelFlag        -> AnalEnv                            -- Does not include bindings for this binding-       -> CleanDemand+       -> SubDemand        -> [(Id,CoreExpr)]        -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info  dmdFix top_lvl env let_dmd orig_pairs   = loop 1 initial_pairs   where-    bndrs = map fst orig_pairs-     -- See Note [Initialising strictness]     initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]                   | otherwise     = orig_pairs@@ -949,12 +1107,11 @@                 -- so this can significantly reduce the number of iterations needed          my_downRhs (env, lazy_fv) (id,rhs)-          = ((env', lazy_fv'), (id', rhs'))+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $+            ((env', lazy_fv'), (id', rhs'))           where-            (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs-            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1-            env'                  = extendAnalEnv top_lvl env id sig-            id'                   = setIdStrictness id sig+            (env', lazy_fv1, id', rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+            lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1      zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]     zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]@@ -991,7 +1148,7 @@           A g1 -> case (x |> g1) of (p,q) -> ...           B    -> error "urk" -where A,B are the constructors of a GADT.  We'll get a U(U,U) demand+where A,B are the constructors of a GADT.  We'll get a 1P(L,L) demand on x from the A branch, but that's a stupid demand for x itself, which has type 'a'. Indeed we get ASSERTs going off (notably in splitUseProdDmd, #8569).@@ -1002,8 +1159,8 @@   f 0 _         = 0   f _ (MkT n t) = f n t -Here f is lazy in T, but its *usage* is infinite: U(U,U(U,U(U, ...))).-Notice that this happens becuase T is a product type, and is recrusive.+Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))).+Notice that this happens because T is a product type, and is recrusive. If we are not careful, we'll fail to iterate to a fixpoint in dmdFix, and bale out entirely, which is inefficient and over-conservative. @@ -1038,20 +1195,20 @@  addVarDmd :: DmdType -> Var -> Demand -> DmdType addVarDmd (DmdType fv ds res) var dmd-  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res+  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res  addLazyFVs :: DmdType -> DmdEnv -> DmdType addLazyFVs dmd_ty lazy_fvs-  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs-        -- Using bothDmdType (rather than just both'ing the envs)+  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs+        -- Using plusDmdType (rather than just plus'ing the envs)         -- is vital.  Consider         --      let f = \x -> (x,y)         --      in  error (f 3)-        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L+        -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L         -- demand with the bottom coming up from 'error'         --         -- I got a loop in the fixpointer without this, due to an interaction-        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was+        -- with the lazy_fv filtering in dmdAnalRhsSig.  Roughly, it was         --      letrec f n x         --          = letrec g y = x `fatbar`         --                         letrec h z = z + ...g...@@ -1078,10 +1235,7 @@ setBndrsDemandInfo :: [Var] -> [Demand] -> [Var] setBndrsDemandInfo (b:bs) ds   | isTyVar b = b : setBndrsDemandInfo bs ds-setBndrsDemandInfo (b:bs) (d:ds) =-    let !new_info = setIdDemandInfo b d-        !vars = setBndrsDemandInfo bs ds-    in new_info : vars+setBndrsDemandInfo (b:bs) (d:ds) = setIdDemandInfo b d : setBndrsDemandInfo bs ds setBndrsDemandInfo [] ds = ASSERT( null ds ) [] setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs) @@ -1107,13 +1261,13 @@ -- For lambdas we add the demand to the argument demands -- Only called for Ids   = ASSERT( isId id )-    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $     (final_ty, setIdDemandInfo id dmd)   where       -- Watch out!  See note [Lambda-bound unfoldings]     final_ty = case maybeUnfoldingTemplate (idUnfolding id) of                  Nothing  -> main_ty-                 Just unf -> main_ty `bothDmdType` unf_ty+                 Just unf -> main_ty `plusDmdType` unf_ty                           where                              (unf_ty, _) = dmdAnalStar env dmd unf @@ -1210,31 +1364,13 @@ notArgOfDfun :: DFunFlag notArgOfDfun = False -{-  Note [dmdAnalEnv performance]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It's tempting to think that removing the dynflags from AnalEnv would improve-performance. After all when analysing recursive groups we end up allocating-a lot of environments. However this is not the case.--We do get some performance by making AnalEnv smaller. However very often we-defer computation which means we have to capture the dynflags in the thunks-we allocate. Doing this naively in practice causes more allocation than the-removal of DynFlags saves us.--In theory it should be possible to make this better if we are stricter in-the analysis and therefore allocate fewer thunks. But I couldn't get there-in a few hours and overall the impact on GHC here is small, and there are-bigger fish to fry. So for new the env will keep a reference to the flags.--}--data AnalEnv-  = AE { ae_dflags :: DynFlags -- See Note [dmdAnalEnv performance]-       , ae_sigs   :: SigEnv-       , ae_virgin :: Bool    -- True on first iteration only+data AnalEnv = AE+   { ae_strict_dicts :: !Bool -- ^ Enable strict dict+   , ae_sigs         :: !SigEnv+   , ae_virgin       :: !Bool -- ^ True on first iteration only                               -- See Note [Initialising strictness]-       , ae_fam_envs :: FamInstEnvs- }+   , ae_fam_envs     :: !FamInstEnvs+   }          -- We use the se_env to tell us whether to         -- record info about a variable in the DmdEnv@@ -1246,17 +1382,18 @@ type SigEnv = VarEnv (StrictSig, TopLevelFlag)  instance Outputable AnalEnv where-  ppr (AE { ae_sigs = env, ae_virgin = virgin })-    = text "AE" <+> braces (vcat-         [ text "ae_virgin =" <+> ppr virgin-         , text "ae_sigs =" <+> ppr env ])+  ppr env = text "AE" <+> braces (vcat+         [ text "ae_virgin =" <+> ppr (ae_virgin env)+         , text "ae_strict_dicts =" <+> ppr (ae_strict_dicts env)+         , text "ae_sigs =" <+> ppr (ae_sigs env)+         ]) -emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv-emptyAnalEnv dflags fam_envs-    = AE { ae_dflags = dflags-         , ae_sigs = emptySigEnv-         , ae_virgin = True-         , ae_fam_envs = fam_envs+emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv+emptyAnalEnv opts fam_envs+    = AE { ae_strict_dicts = dmd_strict_dicts opts+         , ae_sigs         = emptySigEnv+         , ae_virgin       = True+         , ae_fam_envs     = fam_envs          }  emptySigEnv :: SigEnv@@ -1299,7 +1436,8 @@ findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand) -- See Note [Trimming a demand to a type] findBndrDmd env arg_of_dfun dmd_ty id-  = (dmd_ty', dmd')+  = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $+    (dmd_ty', dmd')   where     dmd' = strictify $            trimToType starting_dmd (findTypeShape fam_envs id_ty)@@ -1309,7 +1447,7 @@     id_ty = idType id      strictify dmd-      | gopt Opt_DictsStrict (ae_dflags env)+      | ae_strict_dicts env              -- We never want to strictify a recursive let. At the moment              -- annotateBndr is only call for non-recursive lets; if that              -- changes, we need a RecFlag parameter and another guard here.@@ -1362,10 +1500,10 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some of the information that the demand analyser determines is not always preserved by the simplifier.  For example, the simplifier will happily rewrite-  \y [Demand=1*U] let x = y in x + x+  \y [Demand=MU] let x = y in x + x to-  \y [Demand=1*U] y + y-which is quite a lie.+  \y [Demand=MU] y + y+which is quite a lie: Now y occurs more than just once.  The once-used information is (currently) only used by the code generator, though.  So:@@ -1382,7 +1520,7 @@    This way, correct information finds its way into the module interface    (strictness signatures!) and the code generator (single-entry thunks!) -Note that, in contrast, the single-call information (C1(..)) /can/ be+Note that, in contrast, the single-call information (CM(..)) /can/ be relied upon, as the simplifier tends to be very careful about not duplicating actual function calls.

GHC/Core/Opt/Exitify.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE PatternSynonyms #-}- module GHC.Core.Opt.Exitify ( exitifyProgram ) where  {-@@ -44,7 +42,7 @@ import GHC.Core import GHC.Core.Utils import GHC.Utils.Monad.State-import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Core.FVs@@ -83,7 +81,7 @@       = Case (go in_scope scrut) bndr ty (map go_alt alts)       where         in_scope1 = in_scope `extendInScopeSet` bndr-        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)+        go_alt (Alt dc pats rhs) = Alt dc pats (go in_scope' rhs)            where in_scope' = in_scope1 `extendInScopeSetList` pats      go in_scope (Let (NonRec bndr rhs) body)@@ -118,7 +116,7 @@     -- Which are the recursive calls?     recursive_calls = mkVarSet $ map fst pairs -    (pairs',exits) = (`runState` []) $ do+    (pairs',exits) = (`runState` []) $         forM ann_pairs $ \(x,rhs) -> do             -- go past the lambdas of the join point             let (args, body) = collectNAnnBndrs (idJoinArity x) rhs@@ -154,9 +152,9 @@      -- Case right hand sides are in tail-call position     go captured (_, AnnCase scrut bndr ty alts) = do-        alts' <- forM alts $ \(dc, pats, rhs) -> do+        alts' <- forM alts $ \(AnnAlt dc pats rhs) -> do             rhs' <- go (captured ++ [bndr] ++ pats) rhs-            return (dc, pats, rhs')+            return (Alt dc pats rhs')         return $ Case (deAnnotate scrut) bndr ty alts'      go captured (_, AnnLet ann_bind body)

GHC/Core/Opt/FloatIn.hs view

@@ -23,20 +23,25 @@ import GHC.Prelude import GHC.Platform +import GHC.Driver.Session+ import GHC.Core import GHC.Core.Make hiding ( wrapFloats )-import GHC.Driver.Types     ( ModGuts(..) ) import GHC.Core.Utils import GHC.Core.FVs-import GHC.Core.Opt.Monad    ( CoreM )+import GHC.Core.Opt.Monad   ( CoreM )+import GHC.Core.Type++import GHC.Types.Basic      ( RecFlag(..), isRec ) import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+import GHC.Types.Tickish import GHC.Types.Var-import GHC.Core.Type import GHC.Types.Var.Set++import GHC.Unit.Module.ModGuts+ import GHC.Utils.Misc-import GHC.Driver.Session-import GHC.Utils.Outputable-import GHC.Types.Basic      ( RecFlag(..), isRec )+import GHC.Utils.Panic  {- Top-level interface function, @floatInwards@.  Note that we do not@@ -450,7 +455,7 @@  -} -fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])+fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])   | isUnliftedType (idType case_bndr)   , exprOkForSideEffects (deAnnotate scrut)       -- See Note [Floating primops]@@ -489,12 +494,12 @@     scrut_fvs    = freeVarsOf scrut     alts_fvs     = map alt_fvs alts     all_alts_fvs = unionDVarSets alts_fvs-    alt_fvs (_con, args, rhs)+    alt_fvs (AnnAlt _con args rhs)       = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)            -- Delete case_bndr and args from free vars of rhs            -- to get free vars of alt -    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr platform to_drop rhs)+    fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs)  ------------------ fiBind :: Platform

GHC/Core/Opt/FloatOut.hs view

@@ -19,15 +19,17 @@ import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )  import GHC.Driver.Session-import GHC.Utils.Error   ( dumpIfSet_dyn, DumpFormat (..) )+import GHC.Utils.Logger  ( dumpIfSet_dyn, DumpFormat (..), Logger ) import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,                            isJoinId, isJoinId_maybe )+import GHC.Types.Tickish import GHC.Core.Opt.SetLevels import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Data.Bag import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.Type import qualified Data.IntMap as M @@ -162,24 +164,25 @@ ************************************************************************ -} -floatOutwards :: FloatOutSwitches+floatOutwards :: Logger+              -> FloatOutSwitches               -> DynFlags               -> UniqSupply               -> CoreProgram -> IO CoreProgram -floatOutwards float_sws dflags us pgm+floatOutwards logger float_sws dflags us pgm   = do {         let { annotated_w_levels = setLevels float_sws pgm us ;               (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)             } ; -        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"+        dumpIfSet_dyn logger dflags Opt_D_verbose_core2core "Levels added:"                   FormatCore                   (vcat (map ppr annotated_w_levels));          let { (tlets, ntlets, lams) = get_stats (sum_stats fss) }; -        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"+        dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats "FloatOut stats:"                 FormatText                 (hcat [ int tlets,  text " Lets floated to top level; ",                         int ntlets, text " Lets floated elsewhere; from ",@@ -467,7 +470,7 @@ floatExpr (Case scrut (TB case_bndr case_spec) ty alts)   = case case_spec of       FloatMe dest_lvl  -- Case expression moves-        | [(con@(DataAlt {}), bndrs, rhs)] <- alts+        | [Alt con@(DataAlt {}) bndrs rhs] <- alts         -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->            case                 floatExpr rhs   of { (fsb, fdb, rhs') ->            let@@ -484,9 +487,9 @@            (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')            }}   where-    float_alt bind_lvl (con, bs, rhs)+    float_alt bind_lvl (Alt con bs rhs)         = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->-          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }+          (fs, rhs_floats, Alt con [b | TB b _ <- bs] rhs') }  floatRhs :: CoreBndr          -> LevelledExpr@@ -736,7 +739,7 @@   where     (floats', ceils) = partitionAtJoinCeiling floats -wrapTick :: Tickish Id -> FloatBinds -> FloatBinds+wrapTick :: CoreTickish -> FloatBinds -> FloatBinds wrapTick t (FB tops ceils defns)   = FB (mapBag wrap_bind tops) (wrap_defns ceils)        (M.map (M.map wrap_defns) defns)

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,_)@@ -244,9 +255,8 @@     mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]     mk_alt_env _               = env -libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)-                         -> (AltCon, [CoreBndr], CoreExpr)-libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)+libCaseAlt :: LibCaseEnv -> Alt CoreBndr -> Alt CoreBndr+libCaseAlt env (Alt con args rhs) = Alt con args (libCase (addBinders env args) rhs)  {- Ids@@ -392,23 +402,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 +441,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

GHC/Core/Opt/Monad.hs view

@@ -50,25 +50,33 @@  import GHC.Prelude hiding ( read ) -import GHC.Core-import GHC.Driver.Types-import GHC.Unit.Module import GHC.Driver.Session+import GHC.Driver.Env++import GHC.Core+import GHC.Core.Unfold+ import GHC.Types.Basic  ( CompilerPhase(..) ) import GHC.Types.Annotations--import GHC.Data.IOEnv hiding     ( liftIO, failM, failWithM )-import qualified GHC.Data.IOEnv  as IOEnv import GHC.Types.Var-import GHC.Utils.Outputable as Outputable-import GHC.Data.FastString-import GHC.Utils.Error( Severity(..), DumpFormat (..), dumpOptionsFromFlag ) import GHC.Types.Unique.Supply-import GHC.Utils.Monad import GHC.Types.Name.Env import GHC.Types.SrcLoc++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Logger ( HasLogger (..), DumpFormat (..), putLogMsg, putDumpMsg, Logger )+import GHC.Utils.Error ( Severity(..) )+import GHC.Utils.Monad++import GHC.Data.FastString+import GHC.Data.IOEnv hiding     ( liftIO, failM, failWithM )+import qualified GHC.Data.IOEnv  as IOEnv++import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.External+ import Data.Bifunctor ( bimap )-import GHC.Utils.Error (dumpAction) import Data.List (intersperse, groupBy, sortBy) import Data.Ord import Data.Dynamic@@ -78,7 +86,7 @@ import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) )-import GHC.Utils.Panic (throwGhcException, GhcException(..))+import GHC.Utils.Panic (throwGhcException, GhcException(..), panic)  {- ************************************************************************@@ -121,6 +129,7 @@    | CoreTidy   | CorePrep+  | CoreAddCallerCcs   | CoreOccurAnal  instance Outputable CoreToDo where@@ -141,6 +150,7 @@   ppr CoreDesugar              = text "Desugar (before optimization)"   ppr CoreDesugarOpt           = text "Desugar (after optimization)"   ppr CoreTidy                 = text "Tidy Core"+  ppr CoreAddCallerCcs         = text "Add caller cost-centres"   ppr CorePrep                 = text "CorePrep"   ppr CoreOccurAnal            = text "Occurrence analysis"   ppr CoreDoPrintCore          = text "Print core"@@ -155,14 +165,24 @@  data SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad   = SimplMode-        { sm_names      :: [String] -- Name(s) of the phase+        { sm_names      :: [String]       -- ^ Name(s) of the phase         , sm_phase      :: CompilerPhase-        , sm_dflags     :: DynFlags -- Just for convenient non-monadic-                                    -- access; we don't override these-        , sm_rules      :: Bool     -- Whether RULES are enabled-        , sm_inline     :: Bool     -- Whether inlining is enabled-        , sm_case_case  :: Bool     -- Whether case-of-case is enabled-        , sm_eta_expand :: Bool     -- Whether eta-expansion is enabled+        , sm_uf_opts    :: !UnfoldingOpts -- ^ Unfolding options+        , sm_rules      :: !Bool          -- ^ Whether RULES are enabled+        , sm_inline     :: !Bool          -- ^ Whether inlining is enabled+        , sm_case_case  :: !Bool          -- ^ Whether case-of-case is enabled+        , sm_eta_expand :: !Bool          -- ^ Whether eta-expansion is enabled+        , sm_pre_inline :: !Bool          -- ^ Whether pre-inlining is enabled+        , sm_logger     :: !Logger+        , sm_dflags     :: DynFlags+            -- Just for convenient non-monadic access; we don't override these.+            --+            -- Used for:+            --    - target platform (for `exprIsDupable` and `mkDupableAlt`)+            --    - Opt_DictsCheap and Opt_PedanticBottoms general flags+            --    - rules options (initRuleOpts)+            --    - verbose_core2core, dump_inlinings, dump_rule_rewrites/firings+            --    - inlineCheck         }  instance Outputable SimplMode where@@ -527,7 +547,7 @@ cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b-cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `compare` b+cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `uniqCompareFS` b cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b@@ -703,6 +723,9 @@ instance HasDynFlags CoreM where     getDynFlags = fmap hsc_dflags getHscEnv +instance HasLogger CoreM where+    getLogger = fmap hsc_logger getHscEnv+ instance HasModule CoreM where     getModule = read cr_module @@ -769,19 +792,20 @@ -}  msg :: Severity -> WarnReason -> SDoc -> CoreM ()-msg sev reason doc-  = do { dflags <- getDynFlags-       ; loc    <- getSrcSpanM-       ; unqual <- getPrintUnqualified-       ; let sty = case sev of-                     SevError   -> err_sty-                     SevWarning -> err_sty-                     SevDump    -> dump_sty-                     _          -> user_sty-             err_sty  = mkErrStyle unqual-             user_sty = mkUserStyle unqual AllTheWay-             dump_sty = mkDumpStyle unqual-       ; liftIO $ putLogMsg dflags reason sev loc (withPprStyle sty doc) }+msg sev reason doc = do+    dflags <- getDynFlags+    logger <- getLogger+    loc    <- getSrcSpanM+    unqual <- getPrintUnqualified+    let sty = case sev of+                SevError   -> err_sty+                SevWarning -> err_sty+                SevDump    -> dump_sty+                _          -> user_sty+        err_sty  = mkErrStyle unqual+        user_sty = mkUserStyle unqual AllTheWay+        dump_sty = mkDumpStyle unqual+    liftIO $ putLogMsg logger dflags reason sev loc (withPprStyle sty doc)  -- | Output a String message to the screen putMsgS :: String -> CoreM ()@@ -820,9 +844,10 @@  -- | Show some labelled 'SDoc' if a particular flag is set or at a verbosity level of @-v -ddump-most@ or higher dumpIfSet_dyn :: DumpFlag -> String -> DumpFormat -> SDoc -> CoreM ()-dumpIfSet_dyn flag str fmt doc-  = do { dflags <- getDynFlags-       ; unqual <- getPrintUnqualified-       ; when (dopt flag dflags) $ liftIO $ do-         let sty = mkDumpStyle unqual-         dumpAction dflags sty (dumpOptionsFromFlag flag) str fmt doc }+dumpIfSet_dyn flag str fmt doc = do+    dflags <- getDynFlags+    logger <- getLogger+    unqual <- getPrintUnqualified+    when (dopt flag dflags) $ liftIO $ do+        let sty = mkDumpStyle unqual+        putDumpMsg logger dflags sty flag str fmt doc

GHC/Core/Opt/OccurAnal.hs view

@@ -1,2868 +1,3048 @@-{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--************************************************************************-*                                                                      *-\section[OccurAnal]{Occurrence analysis pass}-*                                                                      *-************************************************************************--The occurrence analyser re-typechecks a core expression, returning a new-core expression with (hopefully) improved usage information.--}--{-# LANGUAGE CPP, BangPatterns, MultiWayIf, ViewPatterns  #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,-                          stripTicksTopE, mkTicks )-import GHC.Core.Opt.Arity   ( joinRhsArity )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Basic-import GHC.Unit.Module( Module )-import GHC.Core.Coercion-import GHC.Core.Type-import GHC.Core.TyCo.FVs( tyCoVarsOfMCo )--import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Var-import GHC.Types.Demand ( argOneShots, argsOneShots )-import GHC.Data.Graph.Directed ( SCC(..), Node(..)-                               , stronglyConnCompFromEdgedVerticesUniq-                               , stronglyConnCompFromEdgedVerticesUniqR )-import GHC.Builtin.Names( runRWKey )-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Utils.Misc-import GHC.Data.Maybe( isJust )-import GHC.Utils.Outputable-import Data.List--{--************************************************************************-*                                                                      *-    occurAnalysePgm, occurAnalyseExpr-*                                                                      *-************************************************************************--Here's the externally-callable interface:--}--occurAnalysePgm :: Module         -- Used only in debug output-                -> (Id -> Bool)         -- Active unfoldings-                -> (Activation -> Bool) -- Active rules-                -> [CoreRule]-                -> CoreProgram -> CoreProgram-occurAnalysePgm this_mod active_unf active_rule imp_rules binds-  | isEmptyDetails final_usage-  = occ_anald_binds--  | otherwise   -- See Note [Glomming]-  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)-                   2 (ppr final_usage ) )-    occ_anald_glommed_binds-  where-    init_env = initOccEnv { occ_rule_act = active_rule-                          , occ_unf_act  = active_unf }--    (final_usage, occ_anald_binds) = go init_env binds-    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel-                                                    imp_rule_edges-                                                    (flattenBinds binds)-                                                    initial_uds-          -- It's crucial to re-analyse the glommed-together bindings-          -- so that we establish the right loop breakers. Otherwise-          -- we can easily create an infinite loop (#9583 is an example)-          ---          -- Also crucial to re-analyse the /original/ bindings-          -- in case the first pass accidentally discarded as dead code-          -- a binding that was actually needed (albeit before its-          -- definition site).  #17724 threw this up.--    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)-    -- The RULES declarations keep things alive!--    -- Note [Preventing loops due to imported functions rules]-    imp_rule_edges = foldr (plusVarEnv_C unionVarSet) emptyVarEnv-                            [ mapVarEnv (const maps_to) $-                                getUniqSet (exprFreeIds arg `delVarSetList` ru_bndrs imp_rule)-                            | imp_rule <- imp_rules-                            , not (isBuiltinRule imp_rule)  -- See Note [Plugin rules]-                            , let maps_to = exprFreeIds (ru_rhs imp_rule)-                                             `delVarSetList` ru_bndrs imp_rule-                            , arg <- ru_args imp_rule ]--    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])-    go _ []-        = (initial_uds, [])-    go env (bind:binds)-        = (final_usage, bind' ++ binds')-        where-           (bs_usage, binds')   = go env binds-           (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind-                                              bs_usage--occurAnalyseExpr :: CoreExpr -> CoreExpr--- Do occurrence analysis, and discard occurrence info returned-occurAnalyseExpr expr-  = snd (occAnal initOccEnv expr)--{- Note [Plugin rules]-~~~~~~~~~~~~~~~~~~~~~~-Conal Elliott (#11651) built a GHC plugin that added some-BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to-do some domain-specific transformations that could not be expressed-with an ordinary pattern-matching CoreRule.  But then we can't extract-the dependencies (in imp_rule_edges) from ru_rhs etc, because a-BuiltinRule doesn't have any of that stuff.--So we simply assume that BuiltinRules have no dependencies, and filter-them out from the imp_rule_edges comprehension.--}--{--************************************************************************-*                                                                      *-                Bindings-*                                                                      *-************************************************************************--Note [Recursive bindings: the grand plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we come across a binding group-  Rec { x1 = r1; ...; xn = rn }-we treat it like this (occAnalRecBind):--1. Occurrence-analyse each right hand side, and build a-   "Details" for each binding to capture the results.--   Wrap the details in a Node (details, node-id, dep-node-ids),-   where node-id is just the unique of the binder, and-   dep-node-ids lists all binders on which this binding depends.-   We'll call these the "scope edges".-   See Note [Forming the Rec groups].--   All this is done by makeNode.--2. Do SCC-analysis on these Nodes.  Each SCC will become a new Rec or-   NonRec.  The key property is that every free variable of a binding-   is accounted for by the scope edges, so that when we are done-   everything is still in scope.--3. For each Cyclic SCC of the scope-edge SCC-analysis in (2), we-   identify suitable loop-breakers to ensure that inlining terminates.-   This is done by occAnalRec.--4. To do so we form a new set of Nodes, with the same details, but-   different edges, the "loop-breaker nodes". The loop-breaker nodes-   have both more and fewer dependencies than the scope edges-   (see Note [Choosing loop breakers])--   More edges: if f calls g, and g has an active rule that mentions h-               then we add an edge from f -> h--   Fewer edges: we only include dependencies on active rules, on rule-                RHSs (not LHSs) and if there is an INLINE pragma only-                on the stable unfolding (and vice versa).  The scope-                edges must be much more inclusive.--5.  The "weak fvs" of a node are, by definition:-       the scope fvs - the loop-breaker fvs-    See Note [Weak loop breakers], and the nd_weak field of Details--6.  Having formed the loop-breaker nodes--Note [Dead code]-~~~~~~~~~~~~~~~~-Dropping dead code for a cyclic Strongly Connected Component is done-in a very simple way:--        the entire SCC is dropped if none of its binders are mentioned-        in the body; otherwise the whole thing is kept.--The key observation is that dead code elimination happens after-dependency analysis: so 'occAnalBind' processes SCCs instead of the-original term's binding groups.--Thus 'occAnalBind' does indeed drop 'f' in an example like--        letrec f = ...g...-               g = ...(...g...)...-        in-           ...g...--when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in-'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes-'AcyclicSCC f', where 'body_usage' won't contain 'f'.---------------------------------------------------------------Note [Forming Rec groups]-~~~~~~~~~~~~~~~~~~~~~~~~~-We put bindings {f = ef; g = eg } in a Rec group if "f uses g"-and "g uses f", no matter how indirectly.  We do a SCC analysis-with an edge f -> g if "f uses g".--More precisely, "f uses g" iff g should be in scope wherever f is.-That is, g is free in:-  a) the rhs 'ef'-  b) or the RHS of a rule for f (Note [Rules are extra RHSs])-  c) or the LHS or a rule for f (Note [Rule dependency info])--These conditions apply regardless of the activation of the RULE (eg it might be-inactive in this phase but become active later).  Once a Rec is broken up-it can never be put back together, so we must be conservative.--The principle is that, regardless of rule firings, every variable is-always in scope.--  * Note [Rules are extra RHSs]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"-    keeps the specialised "children" alive.  If the parent dies-    (because it isn't referenced any more), then the children will die-    too (unless they are already referenced directly).--    To that end, we build a Rec group for each cyclic strongly-    connected component,-        *treating f's rules as extra RHSs for 'f'*.-    More concretely, the SCC analysis runs on a graph with an edge-    from f -> g iff g is mentioned in-        (a) f's rhs-        (b) f's RULES-    These are rec_edges.--    Under (b) we include variables free in *either* LHS *or* RHS of-    the rule.  The former might seems silly, but see Note [Rule-    dependency info].  So in Example [eftInt], eftInt and eftIntFB-    will be put in the same Rec, even though their 'main' RHSs are-    both non-recursive.--  * Note [Rule dependency info]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    The VarSet in a RuleInfo is used for dependency analysis in the-    occurrence analyser.  We must track free vars in *both* lhs and rhs.-    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.-    Why both? Consider-        x = y-        RULE f x = v+4-    Then if we substitute y for x, we'd better do so in the-    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'-    as well as 'v'--  * Note [Rules are visible in their own rec group]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    We want the rules for 'f' to be visible in f's right-hand side.-    And we'd like them to be visible in other functions in f's Rec-    group.  E.g. in Note [Specialisation rules] we want f' rule-    to be visible in both f's RHS, and fs's RHS.--    This means that we must simplify the RULEs first, before looking-    at any of the definitions.  This is done by Simplify.simplRecBind,-    when it calls addLetIdInfo.---------------------------------------------------------------Note [Choosing loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Loop breaking is surprisingly subtle.  First read the section 4 of-"Secrets of the GHC inliner".  This describes our basic plan.-We avoid infinite inlinings by choosing loop breakers, and-ensuring that a loop breaker cuts each loop.--See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which-deals with a closely related source of infinite loops.--Fundamentally, we do SCC analysis on a graph.  For each recursive-group we choose a loop breaker, delete all edges to that node,-re-analyse the SCC, and iterate.--But what is the graph?  NOT the same graph as was used for Note-[Forming Rec groups]!  In particular, a RULE is like an equation for-'f' that is *always* inlined if it is applicable.  We do *not* disable-rules for loop-breakers.  It's up to whoever makes the rules to make-sure that the rules themselves always terminate.  See Note [Rules for-recursive functions] in GHC.Core.Opt.Simplify--Hence, if-    f's RHS (or its INLINE template if it has one) mentions g, and-    g has a RULE that mentions h, and-    h has a RULE that mentions f--then we *must* choose f to be a loop breaker.  Example: see Note-[Specialisation rules].--In general, take the free variables of f's RHS, and augment it with-all the variables reachable by RULES from those starting points.  That-is the whole reason for computing rule_fv_env in occAnalBind.  (Of-course we only consider free vars that are also binders in this Rec-group.)  See also Note [Finding rule RHS free vars]--Note that when we compute this rule_fv_env, we only consider variables-free in the *RHS* of the rule, in contrast to the way we build the-Rec group in the first place (Note [Rule dependency info])--Note that if 'g' has RHS that mentions 'w', we should add w to-g's loop-breaker edges.  More concretely there is an edge from f -> g-iff-        (a) g is mentioned in f's RHS `xor` f's INLINE rhs-            (see Note [Inline rules])-        (b) or h is mentioned in f's RHS, and-            g appears in the RHS of an active RULE of h-            or a transitive sequence of active rules starting with h--Why "active rules"?  See Note [Finding rule RHS free vars]--Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is-chosen as a loop breaker, because their RHSs don't mention each other.-And indeed both can be inlined safely.--Note again that the edges of the graph we use for computing loop breakers-are not the same as the edges we use for computing the Rec blocks.-That's why we compute--- rec_edges          for the Rec block analysis-- loop_breaker_nodes for the loop breaker analysis--  * Note [Finding rule RHS free vars]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    Consider this real example from Data Parallel Haskell-         tagZero :: Array Int -> Array Tag-         {-# INLINE [1] tagZeroes #-}-         tagZero xs = pmap (\x -> fromBool (x==0)) xs--         {-# RULES "tagZero" [~1] forall xs n.-             pmap fromBool <blah blah> = tagZero xs #-}-    So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.-    However, tagZero can only be inlined in phase 1 and later, while-    the RULE is only active *before* phase 1.  So there's no problem.--    To make this work, we look for the RHS free vars only for-    *active* rules. That's the reason for the occ_rule_act field-    of the OccEnv.--  * Note [Weak loop breakers]-    ~~~~~~~~~~~~~~~~~~~~~~~~~-    There is a last nasty wrinkle.  Suppose we have--        Rec { f = f_rhs-              RULE f [] = g--              h = h_rhs-              g = h-              ...more...-        }--    Remember that we simplify the RULES before any RHS (see Note-    [Rules are visible in their own rec group] above).--    So we must *not* postInlineUnconditionally 'g', even though-    its RHS turns out to be trivial.  (I'm assuming that 'g' is-    not chosen as a loop breaker.)  Why not?  Because then we-    drop the binding for 'g', which leaves it out of scope in the-    RULE!--    Here's a somewhat different example of the same thing-        Rec { g = h-            ; h = ...f...-            ; f = f_rhs-              RULE f [] = g }-    Here the RULE is "below" g, but we *still* can't postInlineUnconditionally-    g, because the RULE for f is active throughout.  So the RHS of h-    might rewrite to     h = ...g...-    So g must remain in scope in the output program!--    We "solve" this by:--        Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True)-        iff g is a "missing free variable" of the Rec group--    A "missing free variable" x is one that is mentioned in an RHS or-    INLINE or RULE of a binding in the Rec group, but where the-    dependency on x may not show up in the loop_breaker_nodes (see-    note [Choosing loop breakers} above).--    A normal "strong" loop breaker has IAmLoopBreaker False.  So--                                    Inline  postInlineUnconditionally-   strong   IAmLoopBreaker False    no      no-   weak     IAmLoopBreaker True     yes     no-            other                   yes     yes--    The **sole** reason for this kind of loop breaker is so that-    postInlineUnconditionally does not fire.  Ugh.  (Typically it'll-    inline via the usual callSiteInline stuff, so it'll be dead in the-    next pass, so the main Ugh is the tiresome complication.)--Note [Rules for imported functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   f = /\a. B.g a-   RULE B.g Int = 1 + f Int-Note that-  * The RULE is for an imported function.-  * f is non-recursive-Now we-can get-   f Int --> B.g Int      Inlining f-         --> 1 + f Int    Firing RULE-and so the simplifier goes into an infinite loop. This-would not happen if the RULE was for a local function,-because we keep track of dependencies through rules.  But-that is pretty much impossible to do for imported Ids.  Suppose-f's definition had been-   f = /\a. C.h a-where (by some long and devious process), C.h eventually inlines to-B.g.  We could only spot such loops by exhaustively following-unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)-f.--Note that RULES for imported functions are important in practice; they-occur a lot in the libraries.--We regard this potential infinite loop as a *programmer* error.-It's up the programmer not to write silly rules like-     RULE f x = f x-and the example above is just a more complicated version.--Note [Preventing loops due to imported functions rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-  import GHC.Base (foldr)--  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}-  filter p xs = build (\c n -> foldr (filterFB c p) n xs)-  filterFB c p = ...--  f = filter p xs--Note that filter is not a loop-breaker, so what happens is:-  f =          filter p xs-    = {inline} build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--We are in an infinite loop.--A more elaborate example (that I actually saw in practice when I went to-mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:-  {-# LANGUAGE RankNTypes #-}-  module GHCList where--  import Prelude hiding (filter)-  import GHC.Base (build)--  {-# INLINABLE filter #-}-  filter :: (a -> Bool) -> [a] -> [a]-  filter p [] = []-  filter p (x:xs) = if p x then x : filter p xs else filter p xs--  {-# NOINLINE [0] filterFB #-}-  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b-  filterFB c p x r | p x       = x `c` r-                   | otherwise = r--  {-# RULES-  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr-  (filterFB c p) n xs)-  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p-   #-}--Then (because RULES are applied inside INLINABLE unfoldings, but inlinings-are not), the unfolding given to "filter" in the interface file will be:-  filter p []     = []-  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                           else     build (\c n -> foldr (filterFB c p) n xs--Note that because this unfolding does not mention "filter", filter is not-marked as a strong loop breaker. Therefore at a use site in another module:-  filter p xs-    = {inline}-      case xs of []     -> []-                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                                  else     build (\c n -> foldr (filterFB c p) n xs)--  build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--And we are in an infinite loop again, except that this time the loop is producing an-infinitely large *term* (an unrolling of filter) and so the simplifier finally-dies with "ticks exhausted"--Because of this problem, we make a small change in the occurrence analyser-designed to mark functions like "filter" as strong loop breakers on the basis that:-  1. The RHS of filter mentions the local function "filterFB"-  2. We have a rule which mentions "filterFB" on the LHS and "filter" on the RHS--So for each RULE for an *imported* function we are going to add-dependency edges between the *local* FVS of the rule LHS and the-*local* FVS of the rule RHS. We don't do anything special for RULES on-local functions because the standard occurrence analysis stuff is-pretty good at getting loop-breakerness correct there.--It is important to note that even with this extra hack we aren't always going to get-things right. For example, it might be that the rule LHS mentions an imported Id,-and another module has a RULE that can rewrite that imported Id to one of our local-Ids.--Note [Specialising imported functions] (referred to from Specialise)-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-BUT for *automatically-generated* rules, the programmer can't be-responsible for the "programmer error" in Note [Rules for imported-functions].  In particular, consider specialising a recursive function-defined in another module.  If we specialise a recursive function B.g,-we get-         g_spec = .....(B.g Int).....-         RULE B.g Int = g_spec-Here, g_spec doesn't look recursive, but when the rule fires, it-becomes so.  And if B.g was mutually recursive, the loop might-not be as obvious as it is here.--To avoid this,- * When specialising a function that is a loop breaker,-   give a NOINLINE pragma to the specialised function--Note [Glomming]-~~~~~~~~~~~~~~~-RULES for imported Ids can make something at the top refer to something at the bottom:-        f = \x -> B.g (q x)-        h = \y -> 3--        RULE:  B.g (q x) = h x--Applying this rule makes f refer to h, although f doesn't appear to-depend on h.  (And, as in Note [Rules for imported functions], the-dependency might be more indirect. For example, f might mention C.t-rather than B.g, where C.t eventually inlines to B.g.)--NOTICE that this cannot happen for rules whose head is a-locally-defined function, because we accurately track dependencies-through RULES.  It only happens for rules whose head is an imported-function (B.g in the example above).--Solution:-  - When simplifying, bring all top level identifiers into-    scope at the start, ignoring the Rec/NonRec structure, so-    that when 'h' pops up in f's rhs, we find it in the in-scope set-    (as the simplifier generally expects). This happens in simplTopBinds.--  - In the occurrence analyser, if there are any out-of-scope-    occurrences that pop out of the top, which will happen after-    firing the rule:      f = \x -> h x-                          h = \y -> 3-    then just glom all the bindings into a single Rec, so that-    the *next* iteration of the occurrence analyser will sort-    them all out.   This part happens in occurAnalysePgm.---------------------------------------------------------------Note [Inline rules]-~~~~~~~~~~~~~~~~~~~-None of the above stuff about RULES applies to Inline Rules,-stored in a CoreUnfolding.  The unfolding, if any, is simplified-at the same time as the regular RHS of the function (ie *not* like-Note [Rules are visible in their own rec group]), so it should be-treated *exactly* like an extra RHS.--Or, rather, when computing loop-breaker edges,-  * If f has an INLINE pragma, and it is active, we treat the-    INLINE rhs as f's rhs-  * If it's inactive, we treat f as having no rhs-  * If it has no INLINE pragma, we look at f's actual rhs---There is a danger that we'll be sub-optimal if we see this-     f = ...f...-     [INLINE f = ..no f...]-where f is recursive, but the INLINE is not. This can just about-happen with a sufficiently odd set of rules; eg--        foo :: Int -> Int-        {-# INLINE [1] foo #-}-        foo x = x+1--        bar :: Int -> Int-        {-# INLINE [1] bar #-}-        bar x = foo x + 1--        {-# RULES "foo" [~1] forall x. foo x = bar x #-}--Here the RULE makes bar recursive; but it's INLINE pragma remains-non-recursive. It's tempting to then say that 'bar' should not be-a loop breaker, but an attempt to do so goes wrong in two ways:-   a) We may get-         $df = ...$cfoo...-         $cfoo = ...$df....-         [INLINE $cfoo = ...no-$df...]-      But we want $cfoo to depend on $df explicitly so that we-      put the bindings in the right order to inline $df in $cfoo-      and perhaps break the loop altogether.  (Maybe this-   b)---Example [eftInt]-~~~~~~~~~~~~~~~-Example (from GHC.Enum):--  eftInt :: Int# -> Int# -> [Int]-  eftInt x y = ...(non-recursive)...--  {-# INLINE [0] eftIntFB #-}-  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r-  eftIntFB c n x y = ...(non-recursive)...--  {-# RULES-  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)-  "eftIntList"  [1] eftIntFB  (:) [] = eftInt-   #-}--Note [Specialisation rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this group, which is typical of what SpecConstr builds:--   fs a = ....f (C a)....-   f  x = ....f (C a)....-   {-# RULE f (C a) = fs a #-}--So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).--But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:-  - the RULE is applied in f's RHS (see Note [Self-recursive rules] in GHC.Core.Opt.Simplify-  - fs is inlined (say it's small)-  - now there's another opportunity to apply the RULE--This showed up when compiling Control.Concurrent.Chan.getChanContents.---------------------------------------------------------------Note [Finding join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It's the occurrence analyser's job to find bindings that we can turn into join-points, but it doesn't perform that transformation right away. Rather, it marks-the eligible bindings as part of their occurrence data, leaving it to the-simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.-The simplifier then eta-expands the RHS if needed and then updates the-occurrence sites. Dividing the work this way means that the occurrence analyser-still only takes one pass, yet one can always tell the difference between a-function call and a jump by looking at the occurrence (because the same pass-changes the 'IdDetails' and propagates the binders to their occurrence sites).--To track potential join points, we use the 'occ_tail' field of OccInfo. A value-of `AlwaysTailCalled n` indicates that every occurrence of the variable is a-tail call with `n` arguments (counting both value and type arguments). Otherwise-'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the-rest of 'OccInfo' until it goes on the binder.--Note [Join points and unfoldings/rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   let j2 y = blah-   let j x = j2 (x+x)-       {-# INLINE [2] j #-}-   in case e of { A -> j 1; B -> ...; C -> j 2 }--Before j is inlined, we'll have occurrences of j2 in-both j's RHS and in its stable unfolding.  We want to discover-j2 as a join point.  So we must do the adjustRhsUsage thing-on j's RHS.  That's why we pass mb_join_arity to calcUnfolding.--Aame with rules. Suppose we have:--  let j :: Int -> Int-      j y = 2 * y-  let k :: Int -> Int -> Int-      {-# RULES "SPEC k 0" k 0 y = j y #-}-      k x y = x + 2 * y-  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }--We identify k as a join point, and we want j to be a join point too.-Without the RULE it would be, and we don't want the RULE to mess it-up.  So provided the join-point arity of k matches the args of the-rule we can allow the tail-cal info from the RHS of the rule to-propagate.--* Wrinkle for Rec case. In the recursive case we don't know the-  join-point arity in advance, when calling occAnalUnfolding and-  occAnalRules.  (See makeNode.)  We don't want to pass Nothing,-  because then a recursive joinrec might lose its join-poin-hood-  when SpecConstr adds a RULE.  So we just make do with the-  *current* join-poin-hood, stored in the Id.--  In the non-recursive case things are simple: see occAnalNonRecBind--* Wrinkle for RULES.  Suppose the example was a bit different:-      let j :: Int -> Int-          j y = 2 * y-          k :: Int -> Int -> Int-          {-# RULES "SPEC k 0" k 0 = j #-}-          k x y = x + 2 * y-      in ...-  If we eta-expanded the rule all woudl be well, but as it stands the-  one arg of the rule don't match the join-point arity of 2.--  Conceivably we could notice that a potential join point would have-  an "undersaturated" rule and account for it. This would mean we-  could make something that's been specialised a join point, for-  instance. But local bindings are rarely specialised, and being-  overly cautious about rules only costs us anything when, for some `j`:--  * Before specialisation, `j` has non-tail calls, so it can't be a join point.-  * During specialisation, `j` gets specialised and thus acquires rules.-  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),-    and so now `j` *could* become a join point.--  This appears to be very rare in practice. TODO Perhaps we should gather-  statistics to be sure.---------------------------------------------------------------Note [Adjusting right-hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's a bit of a dance we need to do after analysing a lambda expression or-a right-hand side. In particular, we need to--  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot-     lambda, or a non-recursive join point; and-  b) call 'markAllNonTail' *unless* the binding is for a join point.--Some examples, with how the free occurrences in e (assumed not to be a value-lambda) get marked:--                             inside lam    non-tail-called-  -------------------------------------------------------------  let x = e                  No            Yes-  let f = \x -> e            Yes           Yes-  let f = \x{OneShot} -> e   No            Yes-  \x -> e                    Yes           Yes-  join j x = e               No            No-  joinrec j x = e            Yes           No--There are a few other caveats; most importantly, if we're marking a binding as-'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so-that the effect cascades properly. Consequently, at the time the RHS is-analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must-return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once-join-point-hood has been decided.--Thus the overall sequence taking place in 'occAnalNonRecBind' and-'occAnalRecBind' is as follows:--  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.-  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make-     the binding a join point.-  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when-     recursive.)--(In the recursive case, this logic is spread between 'makeNode' and-'occAnalRec'.)--}-----------------------------------------------------------------------                 occAnalBind---------------------------------------------------------------------occAnalBind :: OccEnv           -- The incoming OccEnv-            -> TopLevelFlag-            -> ImpRuleEdges-            -> CoreBind-            -> UsageDetails             -- Usage details of scope-            -> (UsageDetails,           -- Of the whole let(rec)-                [CoreBind])--occAnalBind env lvl top_env (NonRec binder rhs) body_usage-  = occAnalNonRecBind env lvl top_env binder rhs body_usage-occAnalBind env lvl top_env (Rec pairs) body_usage-  = occAnalRecBind env lvl top_env pairs body_usage--------------------occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr-                  -> UsageDetails -> (UsageDetails, [CoreBind])-occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage-  | isTyVar bndr      -- A type let; we don't gather usage info-  = (body_usage, [NonRec bndr rhs])--  | not (bndr `usedIn` body_usage)    -- It's not mentioned-  = (body_usage, [])--  | otherwise                   -- It's mentioned in the body-  = (body_usage' `andUDs` rhs_usage4, [NonRec final_bndr rhs'])-  where-    (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr-    occ                        = idOccInfo tagged_bndr--    -- Get the join info from the *new* decision-    -- See Note [Join points and unfoldings/rules]-    mb_join_arity = willBeJoinId_maybe tagged_bndr-    is_join_point = isJust mb_join_arity--    final_bndr = tagged_bndr `setIdUnfolding` unf'-                             `setIdSpecialisation` mkRuleInfo rules'--    env1 | is_join_point    = env  -- See Note [Join point RHSs]-         | certainly_inline = env  -- See Note [Cascading inlines]-         | otherwise        = rhsCtxt env--    -- See Note [Sources of one-shot information]-    rhs_env = env1 { occ_one_shots = argOneShots dmd }--    (rhs_usage1, rhs') = occAnalRhs rhs_env mb_join_arity rhs--    -- Unfoldings-    -- See Note [Unfoldings and join points]-    unf = idUnfolding bndr-    (unf_usage, unf') = occAnalUnfolding rhs_env mb_join_arity unf-    rhs_usage2 = rhs_usage1 `andUDs` unf_usage--    -- Rules-    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]-    rules_w_uds = occAnalRules rhs_env mb_join_arity bndr-    rule_uds    = map (\(_, l, r) -> l `andUDs` r) rules_w_uds-    rules'      = map fstOf3 rules_w_uds-    rhs_usage3 = foldr andUDs rhs_usage2 rule_uds-    rhs_usage4 = case lookupVarEnv imp_rule_edges bndr of-                   Nothing -> rhs_usage3-                   Just vs -> addManyOccs rhs_usage3 vs-       -- See Note [Preventing loops due to imported functions rules]--    certainly_inline -- See Note [Cascading inlines]-      = case occ of-          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }-            -> active && not_stable-          _ -> False--    dmd        = idDemandInfo bndr-    active     = isAlwaysActive (idInlineActivation bndr)-    not_stable = not (isStableUnfolding (idUnfolding bndr))--------------------occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]-               -> UsageDetails -> (UsageDetails, [CoreBind])-occAnalRecBind env lvl imp_rule_edges pairs body_usage-  = foldr (occAnalRec rhs_env lvl) (body_usage, []) sccs-        -- For a recursive group, we-        --      * occ-analyse all the RHSs-        --      * compute strongly-connected components-        --      * feed those components to occAnalRec-        -- See Note [Recursive bindings: the grand plan]-  where-    sccs :: [SCC Details]-    sccs = {-# SCC "occAnalBind.scc" #-}-           stronglyConnCompFromEdgedVerticesUniq nodes--    nodes :: [LetrecNode]-    nodes = {-# SCC "occAnalBind.assoc" #-}-            map (makeNode rhs_env imp_rule_edges bndr_set) pairs--    bndrs    = map fst pairs-    bndr_set = mkVarSet bndrs-    rhs_env  = env `addInScope` bndrs--{--Note [Unfoldings and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We assume that anything in an unfolding occurs multiple times, since unfoldings-are often copied (that's the whole point!). But we still need to track tail-calls for the purpose of finding join points.--}--------------------------------occAnalRec :: OccEnv -> TopLevelFlag-           -> SCC Details-           -> (UsageDetails, [CoreBind])-           -> (UsageDetails, [CoreBind])--        -- The NonRec case is just like a Let (NonRec ...) above-occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs-                                 , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))-           (body_uds, binds)-  | not (bndr `usedIn` body_uds)-  = (body_uds, binds)           -- See Note [Dead code]--  | otherwise                   -- It's mentioned in the body-  = (body_uds' `andUDs` rhs_uds',-     NonRec tagged_bndr rhs : binds)-  where-    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr-    rhs_uds' = adjustRhsUsage (willBeJoinId_maybe tagged_bndr) NonRecursive-                              rhs_bndrs rhs_uds--        -- The Rec case is the interesting one-        -- See Note [Recursive bindings: the grand plan]-        -- See Note [Loop breaking]-occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds)-  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds-  = (body_uds, binds)                   -- See Note [Dead code]--  | otherwise   -- At this point we always build a single Rec-  = -- pprTrace "occAnalRec" (vcat-    --   [ text "weak_fvs" <+> ppr weak_fvs-    --   , text "lb nodes" <+> ppr loop_breaker_nodes])-    (final_uds, Rec pairs : binds)--  where-    bndrs    = map nd_bndr details_s-    bndr_set = mkVarSet bndrs--    -------------------------------        -- See Note [Choosing loop breakers] for loop_breaker_nodes-    final_uds :: UsageDetails-    loop_breaker_nodes :: [LetrecNode]-    (final_uds, loop_breaker_nodes)-      = mkLoopBreakerNodes env lvl bndr_set body_uds details_s--    -------------------------------    weak_fvs :: VarSet-    weak_fvs = mapUnionVarSet nd_weak details_s--    ----------------------------    -- Now reconstruct the cycle-    pairs :: [(Id,CoreExpr)]-    pairs | isEmptyVarSet weak_fvs = reOrderNodes   0 bndr_set weak_fvs loop_breaker_nodes []-          | otherwise              = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_nodes []-          -- If weak_fvs is empty, the loop_breaker_nodes will include-          -- all the edges in the original scope edges [remember,-          -- weak_fvs is the difference between scope edges and-          -- lb-edges], so a fresh SCC computation would yield a-          -- single CyclicSCC result; and reOrderNodes deals with-          -- exactly that case------------------------------------------------------------------------                 Loop breaking---------------------------------------------------------------------type Binding = (Id,CoreExpr)--loopBreakNodes :: Int-               -> VarSet        -- All binders-               -> VarSet        -- Binders whose dependencies may be "missing"-                                -- See Note [Weak loop breakers]-               -> [LetrecNode]-               -> [Binding]             -- Append these to the end-               -> [Binding]-{--loopBreakNodes is applied to the list of nodes for a cyclic strongly-connected component (there's guaranteed to be a cycle).  It returns-the same nodes, but-        a) in a better order,-        b) with some of the Ids having a IAmALoopBreaker pragma--The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means-that the simplifier can guarantee not to loop provided it never records an inlining-for these no-inline guys.--Furthermore, the order of the binds is such that if we neglect dependencies-on the no-inline Ids then the binds are topologically sorted.  This means-that the simplifier will generally do a good job if it works from top bottom,-recording inlinings for any Ids which aren't marked as "no-inline" as it goes.--}---- Return the bindings sorted into a plausible order, and marked with loop breakers.-loopBreakNodes depth bndr_set weak_fvs nodes binds-  = -- pprTrace "loopBreakNodes" (ppr nodes) $-    go (stronglyConnCompFromEdgedVerticesUniqR nodes)-  where-    go []         = binds-    go (scc:sccs) = loop_break_scc scc (go sccs)--    loop_break_scc scc binds-      = case scc of-          AcyclicSCC node  -> mk_non_loop_breaker weak_fvs node : binds-          CyclicSCC nodes  -> reOrderNodes depth bndr_set weak_fvs nodes binds-------------------------------------reOrderNodes :: Int -> VarSet -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]-    -- Choose a loop breaker, mark it no-inline,-    -- and call loopBreakNodes on the rest-reOrderNodes _ _ _ []     _     = panic "reOrderNodes"-reOrderNodes _ _ _ [node] binds = mk_loop_breaker node : binds-reOrderNodes depth bndr_set weak_fvs (node : nodes) binds-  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen-    --                               , text "chosen" <+> ppr chosen_nodes ]) $-    loopBreakNodes new_depth bndr_set weak_fvs unchosen $-    (map mk_loop_breaker chosen_nodes ++ binds)-  where-    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb-                                                 (nd_score (node_payload node))-                                                 [node] [] nodes--    approximate_lb = depth >= 2-    new_depth | approximate_lb = 0-              | otherwise      = depth+1-        -- After two iterations (d=0, d=1) give up-        -- and approximate, returning to d=0--mk_loop_breaker :: LetrecNode -> Binding-mk_loop_breaker (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})-  = (bndr `setIdOccInfo` strongLoopBreaker { occ_tail = tail_info }, rhs)-  where-    tail_info = tailCallInfo (idOccInfo bndr)--mk_non_loop_breaker :: VarSet -> LetrecNode -> Binding--- See Note [Weak loop breakers]-mk_non_loop_breaker weak_fvs (node_payload -> ND { nd_bndr = bndr-                                                 , nd_rhs = rhs})-  | bndr `elemVarSet` weak_fvs = (setIdOccInfo bndr occ', rhs)-  | otherwise                  = (bndr, rhs)-  where-    occ' = weakLoopBreaker { occ_tail = tail_info }-    tail_info = tailCallInfo (idOccInfo bndr)-------------------------------------chooseLoopBreaker :: Bool             -- True <=> Too many iterations,-                                      --          so approximate-                  -> NodeScore            -- Best score so far-                  -> [LetrecNode]       -- Nodes with this score-                  -> [LetrecNode]       -- Nodes with higher scores-                  -> [LetrecNode]       -- Unprocessed nodes-                  -> ([LetrecNode], [LetrecNode])-    -- This loop looks for the bind with the lowest score-    -- to pick as the loop  breaker.  The rest accumulate in-chooseLoopBreaker _ _ loop_nodes acc []-  = (loop_nodes, acc)        -- Done--    -- If approximate_loop_breaker is True, we pick *all*-    -- nodes with lowest score, else just one-    -- See Note [Complexity of loop breaking]-chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)-  | approx_lb-  , rank sc == rank loop_sc-  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes--  | sc `betterLB` loop_sc  -- Better score so pick this new one-  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes--  | otherwise              -- Worse score so don't pick it-  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes-  where-    sc = nd_score (node_payload node)--{--Note [Complexity of loop breaking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The loop-breaking algorithm knocks out one binder at a time, and-performs a new SCC analysis on the remaining binders.  That can-behave very badly in tightly-coupled groups of bindings; in the-worst case it can be (N**2)*log N, because it does a full SCC-on N, then N-1, then N-2 and so on.--To avoid this, we switch plans after 2 (or whatever) attempts:-  Plan A: pick one binder with the lowest score, make it-          a loop breaker, and try again-  Plan B: pick *all* binders with the lowest score, make them-          all loop breakers, and try again-Since there are only a small finite number of scores, this will-terminate in a constant number of iterations, rather than O(N)-iterations.--You might thing that it's very unlikely, but RULES make it much-more likely.  Here's a real example from #1969:-  Rec { $dm = \d.\x. op d-        {-# RULES forall d. $dm Int d  = $s$dm1-                  forall d. $dm Bool d = $s$dm2 #-}--        dInt = MkD .... opInt ...-        dInt = MkD .... opBool ...-        opInt  = $dm dInt-        opBool = $dm dBool--        $s$dm1 = \x. op dInt-        $s$dm2 = \x. op dBool }-The RULES stuff means that we can't choose $dm as a loop breaker-(Note [Choosing loop breakers]), so we must choose at least (say)-opInt *and* opBool, and so on.  The number of loop breakders is-linear in the number of instance declarations.--Note [Loop breakers and INLINE/INLINABLE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Avoid choosing a function with an INLINE pramga as the loop breaker!-If such a function is mutually-recursive with a non-INLINE thing,-then the latter should be the loop-breaker.--It's vital to distinguish between INLINE and INLINABLE (the-Bool returned by hasStableCoreUnfolding_maybe).  If we start with-   Rec { {-# INLINABLE f #-}-         f x = ...f... }-and then worker/wrapper it through strictness analysis, we'll get-   Rec { {-# INLINABLE $wf #-}-         $wf p q = let x = (p,q) in ...f...--         {-# INLINE f #-}-         f x = case x of (p,q) -> $wf p q }--Now it is vital that we choose $wf as the loop breaker, so we can-inline 'f' in '$wf'.--Note [DFuns should not be loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's particularly bad to make a DFun into a loop breaker.  See-Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance--We give DFuns a higher score than ordinary CONLIKE things because-if there's a choice we want the DFun to be the non-loop breaker. Eg--rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)--      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)-      {-# DFUN #-}-      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)-    }--Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it-if we can't unravel the DFun first.--Note [Constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really really important to inline dictionaries.  Real-example (the Enum Ordering instance from GHC.Base):--     rec     f = \ x -> case d of (p,q,r) -> p x-             g = \ x -> case d of (p,q,r) -> q x-             d = (v, f, g)--Here, f and g occur just once; but we can't inline them into d.-On the other hand we *could* simplify those case expressions if-we didn't stupidly choose d as the loop breaker.-But we won't because constructor args are marked "Many".-Inlining dictionaries is really essential to unravelling-the loops in static numeric dictionaries, see GHC.Float.--Note [Closure conversion]-~~~~~~~~~~~~~~~~~~~~~~~~~-We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.-The immediate motivation came from the result of a closure-conversion transformation-which generated code like this:--    data Clo a b = forall c. Clo (c -> a -> b) c--    ($:) :: Clo a b -> a -> b-    Clo f env $: x = f env x--    rec { plus = Clo plus1 ()--        ; plus1 _ n = Clo plus2 n--        ; plus2 Zero     n = n-        ; plus2 (Succ m) n = Succ (plus $: m $: n) }--If we inline 'plus' and 'plus1', everything unravels nicely.  But if-we choose 'plus1' as the loop breaker (which is entirely possible-otherwise), the loop does not unravel nicely.---@occAnalUnfolding@ deals with the question of bindings where the Id is marked-by an INLINE pragma.  For these we record that anything which occurs-in its RHS occurs many times.  This pessimistically assumes that this-inlined binder also occurs many times in its scope, but if it doesn't-we'll catch it next time round.  At worst this costs an extra simplifier pass.-ToDo: try using the occurrence info for the inline'd binder.--[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.-[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.---************************************************************************-*                                                                      *-                   Making nodes-*                                                                      *-************************************************************************--}--type ImpRuleEdges = IdEnv IdSet     -- Mapping from FVs of imported RULE LHSs to RHS FVs--noImpRuleEdges :: ImpRuleEdges-noImpRuleEdges = emptyVarEnv--type LetrecNode = Node Unique Details  -- Node comes from Digraph-                                       -- The Unique key is gotten from the Id-data Details-  = ND { nd_bndr :: Id          -- Binder--       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed--       , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS-                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==-                                    --              collectBinders (nd_rhs nd)--       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings-                                  -- ignoring phase (ie assuming all are active)-                                  -- See Note [Forming Rec groups]--       , nd_inl  :: IdSet       -- Free variables of-                                --   the stable unfolding (if present and active)-                                --   or the RHS (if not)-                                -- but excluding any RULES-                                -- This is the IdSet that may be used if the Id is inlined--       , nd_weak :: IdSet       -- Binders of this Rec that are mentioned in nd_uds-                                -- but are *not* in nd_inl.  These are the ones whose-                                -- dependencies might not be respected by loop_breaker_nodes-                                -- See Note [Weak loop breakers]--       , nd_active_rule_fvs :: IdSet   -- Free variables of the RHS of active RULES--       , nd_score :: NodeScore-  }--instance Outputable Details where-   ppr nd = text "ND" <> braces-             (sep [ text "bndr =" <+> ppr (nd_bndr nd)-                  , text "uds =" <+> ppr (nd_uds nd)-                  , text "inl =" <+> ppr (nd_inl nd)-                  , text "weak =" <+> ppr (nd_weak nd)-                  , text "rule =" <+> ppr (nd_active_rule_fvs nd)-                  , text "score =" <+> ppr (nd_score nd)-             ])---- The NodeScore is compared lexicographically;---      e.g. lower rank wins regardless of size-type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker-                 , Int     -- Size of rhs: higher => more likely to be picked as LB-                           -- Maxes out at maxExprSize; we just use it to prioritise-                           -- small functions-                 , Bool )  -- Was it a loop breaker before?-                           -- True => more likely to be picked-                           -- Note [Loop breakers, node scoring, and stability]--rank :: NodeScore -> Int-rank (r, _, _) = r--makeNode :: OccEnv -> ImpRuleEdges -> VarSet-         -> (Var, CoreExpr) -> LetrecNode--- See Note [Recursive bindings: the grand plan]-makeNode env imp_rule_edges bndr_set (bndr, rhs)-  = DigraphNode details (varUnique bndr) (nonDetKeysUniqSet node_fvs)-    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR-    -- is still deterministic with edges in nondeterministic order as-    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.-  where-    details = ND { nd_bndr            = bndr'-                 , nd_rhs             = rhs'-                 , nd_rhs_bndrs       = bndrs'-                 , nd_uds             = rhs_usage3-                 , nd_inl             = inl_fvs-                 , nd_weak            = node_fvs `minusVarSet` inl_fvs-                 , nd_active_rule_fvs = active_rule_fvs-                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }--    bndr' = bndr `setIdUnfolding`      unf'-                 `setIdSpecialisation` mkRuleInfo rules'--    -- Get join point info from the *current* decision-    -- We don't know what the new decision will be!-    -- Using the old decision at least allows us to-    -- preserve existing join point, even RULEs are added-    -- See Note [Join points and unfoldings/rules]-    mb_join_arity = isJoinId_maybe bndr--    -- Constructing the edges for the main Rec computation-    -- See Note [Forming Rec groups]-    (bndrs, body) = collectBinders rhs-    rhs_env       = rhsCtxt env-    (rhs_usage1, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body-    rhs'       = mkLams bndrs' body'-    rhs_usage3 = foldr andUDs rhs_usage1 rule_uds-                 `andUDs` unf_uds-                   -- Note [Rules are extra RHSs]-                   -- Note [Rule dependency info]-    node_fvs   = udFreeVars bndr_set rhs_usage3--    -- Finding the free variables of the rules-    is_active = occ_rule_act env :: Activation -> Bool--    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]-    rules_w_uds = occAnalRules rhs_env mb_join_arity bndr--    rules' = map fstOf3 rules_w_uds--    rules_w_rhs_fvs :: [(Activation, VarSet)]    -- Find the RHS fvs-    rules_w_rhs_fvs = maybe id (\ids -> ((AlwaysActive, ids):))-                               (lookupVarEnv imp_rule_edges bndr)-      -- See Note [Preventing loops due to imported functions rules]-                      [ (ru_act rule, udFreeVars bndr_set rhs_uds)-                      | (rule, _, rhs_uds) <- rules_w_uds ]-    rule_uds = map (\(_, l, r) -> l `andUDs` r) rules_w_uds-    active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_rhs_fvs-                                        , is_active a]--    -- Finding the usage details of the INLINE pragma (if any)-    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness-                               -- here because that is what we are setting!-    (unf_uds, unf') = occAnalUnfolding rhs_env mb_join_arity unf--    -- Find the "nd_inl" free vars; for the loop-breaker phase-    -- These are the vars that would become free if the function-    -- was inlinined; usually that means the RHS, unless the-    -- unfolding is a stable one.-    -- Note: We could do this only for functions with an *active* unfolding-    --       (returning emptyVarSet for an inactive one), but is_active-    --       isn't the right thing (it tells about RULE activation),-    --       so we'd need more plumbing-    inl_fvs | isStableUnfolding unf = udFreeVars bndr_set unf_uds-            | otherwise             = udFreeVars bndr_set rhs_usage1--mkLoopBreakerNodes :: OccEnv -> TopLevelFlag-                   -> VarSet-                   -> UsageDetails   -- for BODY of let-                   -> [Details]-                   -> (UsageDetails, -- adjusted-                       [LetrecNode])--- Does four things---   a) tag each binder with its occurrence info---   b) add a NodeScore to each node---   c) make a Node with the right dependency edges for---      the loop-breaker SCC analysis---   d) adjust each RHS's usage details according to---      the binder's (new) shotness and join-point-hood-mkLoopBreakerNodes env lvl bndr_set body_uds details_s-  = (final_uds, zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')-  where-    (final_uds, bndrs')-       = tagRecBinders lvl body_uds-            [ (bndr, uds, rhs_bndrs)-            | ND { nd_bndr = bndr, nd_uds = uds, nd_rhs_bndrs = rhs_bndrs }-                 <- details_s ]--    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr-      = DigraphNode nd' (varUnique old_bndr) (nonDetKeysUniqSet lb_deps)-              -- It's OK to use nonDetKeysUniqSet here as-              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges-              -- in nondeterministic order as explained in-              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-      where-        nd'     = nd { nd_bndr = new_bndr, nd_score = score }-        score   = nodeScore env new_bndr lb_deps nd-        lb_deps = extendFvs_ rule_fv_env inl_fvs---    rule_fv_env :: IdEnv IdSet-        -- Maps a variable f to the variables from this group-        --      mentioned in RHS of active rules for f-        -- Domain is *subset* of bound vars (others have no rule fvs)-    rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs)-    init_rule_fvs   -- See Note [Finding rule RHS free vars]-      = [ (b, trimmed_rule_fvs)-        | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s-        , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set-        , not (isEmptyVarSet trimmed_rule_fvs) ]----------------------------------------------nodeScore :: OccEnv-          -> Id        -- Binder with new occ-info-          -> VarSet    -- Loop-breaker dependencies-          -> Details-          -> NodeScore-nodeScore env new_bndr lb_deps-          (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })--  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker-  = (100, 0, False)--  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers-  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]--  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has-  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker--  | exprIsTrivial rhs-  = mk_score 10  -- Practically certain to be inlined-    -- Used to have also: && not (isExportedId bndr)-    -- But I found this sometimes cost an extra iteration when we have-    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }-    -- where df is the exported dictionary. Then df makes a really-    -- bad choice for loop breaker--  | DFunUnfolding { df_args = args } <- old_unf-    -- Never choose a DFun as a loop breaker-    -- Note [DFuns should not be loop breakers]-  = (9, length args, is_lb)--    -- Data structures are more important than INLINE pragmas-    -- so that dictionary/method recursion unravels--  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf-  = mk_score 6--  | is_con_app rhs   -- Data types help with cases:-  = mk_score 5       -- Note [Constructor applications]--  | isStableUnfolding old_unf-  , can_unfold-  = mk_score 3--  | isOneOcc (idOccInfo new_bndr)-  = mk_score 2  -- Likely to be inlined--  | can_unfold  -- The Id has some kind of unfolding-  = mk_score 1--  | otherwise-  = (0, 0, is_lb)--  where-    mk_score :: Int -> NodeScore-    mk_score rank = (rank, rhs_size, is_lb)--    -- is_lb: see Note [Loop breakers, node scoring, and stability]-    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)--    old_unf = realIdUnfolding old_bndr-    can_unfold = canUnfold old_unf-    rhs        = case old_unf of-                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }-                     | isStableSource src-                     -> unf_rhs-                   _ -> bind_rhs-       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding-    rhs_size = case old_unf of-                 CoreUnfolding { uf_guidance = guidance }-                    | UnfIfGoodArgs { ug_size = size } <- guidance-                    -> size-                 _  -> cheapExprSize rhs---        -- Checking for a constructor application-        -- Cheap and cheerful; the simplifier moves casts out of the way-        -- The lambda case is important to spot x = /\a. C (f a)-        -- which comes up when C is a dictionary constructor and-        -- f is a default method.-        -- Example: the instance for Show (ST s a) in GHC.ST-        ---        -- However we *also* treat (\x. C p q) as a con-app-like thing,-        --      Note [Closure conversion]-    is_con_app (Var v)    = isConLikeId v-    is_con_app (App f _)  = is_con_app f-    is_con_app (Lam _ e)  = is_con_app e-    is_con_app (Tick _ e) = is_con_app e-    is_con_app _          = False--maxExprSize :: Int-maxExprSize = 20  -- Rather arbitrary--cheapExprSize :: CoreExpr -> Int--- Maxes out at maxExprSize-cheapExprSize e-  = go 0 e-  where-    go n e | n >= maxExprSize = n-           | otherwise        = go1 n e--    go1 n (Var {})        = n+1-    go1 n (Lit {})        = n+1-    go1 n (Type {})       = n-    go1 n (Coercion {})   = n-    go1 n (Tick _ e)      = go1 n e-    go1 n (Cast e _)      = go1 n e-    go1 n (App f a)       = go (go1 n f) a-    go1 n (Lam b e)-      | isTyVar b         = go1 n e-      | otherwise         = go (n+1) e-    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)-    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)--    gos n [] = n-    gos n (e:es) | n >= maxExprSize = n-                 | otherwise        = gos (go1 n e) es--betterLB :: NodeScore -> NodeScore -> Bool--- If  n1 `betterLB` n2  then choose n1 as the loop breaker-betterLB (rank1, size1, lb1) (rank2, size2, _)-  | rank1 < rank2 = True-  | rank1 > rank2 = False-  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker-  | size1 > size2 = True-  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it-  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]--{- Note [Self-recursion and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   rec { f = ...f...g...-       ; g = .....f...   }-then 'f' has to be a loop breaker anyway, so we may as well choose it-right away, so that g can inline freely.--This is really just a cheap hack. Consider-   rec { f = ...g...-       ; g = ..f..h...-      ;  h = ...f....}-Here f or g are better loop breakers than h; but we might accidentally-choose h.  Finding the minimal set of loop breakers is hard.--Note [Loop breakers, node scoring, and stability]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To choose a loop breaker, we give a NodeScore to each node in the SCC,-and pick the one with the best score (according to 'betterLB').--We need to be jolly careful (#12425, #12234) about the stability-of this choice. Suppose we have--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...f..-      False -> ..f...--In each iteration of the simplifier the occurrence analyser OccAnal-chooses a loop breaker. Suppose in iteration 1 it choose g as the loop-breaker. That means it is free to inline f.--Suppose that GHC decides to inline f in the branches of the case, but-(for some reason; eg it is not saturated) in the rhs of g. So we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...g...g.....-      False -> ..g..g....--Now suppose that, for some reason, in the next iteration the occurrence-analyser chooses f as the loop breaker, so it can freely inline g. And-again for some reason the simplifier inlines g at its calls in the case-branches, but not in the RHS of f. Then we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...(...f...f...)...(...f..f..).....-      False -> ..(...f...f...)...(..f..f...)....--You can see where this is going! Each iteration of the simplifier-doubles the number of calls to f or g. No wonder GHC is slow!--(In the particular example in comment:3 of #12425, f and g are the two-mutually recursive fmap instances for CondT and Result. They are both-marked INLINE which, oddly, is why they don't inline in each other's-RHS, because the call there is not saturated.)--The root cause is that we flip-flop on our choice of loop breaker. I-always thought it didn't matter, and indeed for any single iteration-to terminate, it doesn't matter. But when we iterate, it matters a-lot!!--So The Plan is this:-   If there is a tie, choose the node that-   was a loop breaker last time round--Hence the is_lb field of NodeScore--************************************************************************-*                                                                      *-                   Right hand sides-*                                                                      *-************************************************************************--}--occAnalRhs :: OccEnv -> Maybe JoinArity-           -> CoreExpr   -- RHS-           -> (UsageDetails, CoreExpr)-occAnalRhs env mb_join_arity rhs-  = case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') ->-    let rhs' = mkLams (markJoinOneShots mb_join_arity bndrs') body'-               -- For a /non-recursive/ join point we can mark all-               -- its join-lambda as one-shot; and it's a good idea to do so--        -- Final adjustment-        rhs_usage = adjustRhsUsage mb_join_arity NonRecursive bndrs' body_usage--    in (rhs_usage, rhs') }-  where-    (bndrs, body) = collectBinders rhs--occAnalUnfolding :: OccEnv-                 -> Maybe JoinArity   -- See Note [Join points and unfoldings/rules]-                 -> Unfolding-                 -> (UsageDetails, Unfolding)--- Occurrence-analyse a stable unfolding;--- discard a non-stable one altogether.-occAnalUnfolding env mb_join_arity unf-  = case unf of-      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })-        | isStableSource src -> (usage,        unf')-        | otherwise          -> (emptyDetails, unf)-        where -- For non-Stable unfoldings we leave them undisturbed, but-              -- don't count their usage because the simplifier will discard them.-              -- We leave them undisturbed because nodeScore uses their size info-              -- to guide its decisions.  It's ok to leave un-substituted-              -- expressions in the tree because all the variables that were in-              -- scope remain in scope; there is no cloning etc.-          (usage, rhs') = occAnalRhs env mb_join_arity rhs--          unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]-               | otherwise         = unf { uf_tmpl = rhs' }--      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-        -> ( final_usage, unf { df_args = args' } )-        where-          env'            = env `addInScope` bndrs-          (usage, args')  = occAnalList env' args-          final_usage     = markAllManyNonTail (delDetailsList usage bndrs)--      unf -> (emptyDetails, unf)--occAnalRules :: OccEnv-             -> Maybe JoinArity  -- See Note [Join points and unfoldings/rules]-             -> Id               -- Get rules from here-             -> [(CoreRule,      -- Each (non-built-in) rule-                  UsageDetails,  -- Usage details for LHS-                  UsageDetails)] -- Usage details for RHS-occAnalRules env mb_join_arity bndr-  = map occ_anal_rule (idCoreRules bndr)-  where-    occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })-      = (rule', lhs_uds', rhs_uds')-      where-        env' = env `addInScope` bndrs-        rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]-              | otherwise         = rule { ru_args = args', ru_rhs = rhs' }--        (lhs_uds, args') = occAnalList env' args-        lhs_uds'         = markAllManyNonTail $-                           lhs_uds `delDetailsList` bndrs--        (rhs_uds, rhs') = occAnal env' rhs-                            -- Note [Rules are extra RHSs]-                            -- Note [Rule dependency info]-        rhs_uds' = markAllNonTailIf (not exact_join) $-                   markAllMany                             $-                   rhs_uds `delDetailsList` bndrs--        exact_join = exactJoin mb_join_arity args-                     -- See Note [Join points and unfoldings/rules]--    occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails)--{- Note [Join point RHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   x = e-   join j = Just x--We want to inline x into j right away, so we don't want to give-the join point a RhsCtxt (#14137).  It's not a huge deal, because-the FloatIn pass knows to float into join point RHSs; and the simplifier-does not float things out of join point RHSs.  But it's a simple, cheap-thing to do.  See #14137.--Note [Unfoldings and rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally unfoldings and rules are already occurrence-analysed, so we-don't want to reconstruct their trees; we just want to analyse them to-find how they use their free variables.--EXCEPT if there is a binder-swap going on, in which case we do want to-produce a new tree.--So we have a fast-path that keeps the old tree if the occ_bs_env is-empty.   This just saves a bit of allocation and reconstruction; not-a big deal.--Note [Cascading inlines]-~~~~~~~~~~~~~~~~~~~~~~~~-By default we use an rhsCtxt for the RHS of a binding.  This tells the-occ anal n that it's looking at an RHS, which has an effect in-occAnalApp.  In particular, for constructor applications, it makes-the arguments appear to have NoOccInfo, so that we don't inline into-them. Thus    x = f y-              k = Just x-we do not want to inline x.--But there's a problem.  Consider-     x1 = a0 : []-     x2 = a1 : x1-     x3 = a2 : x2-     g  = f x3-First time round, it looks as if x1 and x2 occur as an arg of a-let-bound constructor ==> give them a many-occurrence.-But then x3 is inlined (unconditionally as it happens) and-next time round, x2 will be, and the next time round x1 will be-Result: multiple simplifier iterations.  Sigh.--So, when analysing the RHS of x3 we notice that x3 will itself-definitely inline the next time round, and so we analyse x3's rhs in-an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.--Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.-If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and-   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"-then the simplifier iterates indefinitely:-        x = f y-        k = Just x   -- We decide that k is 'certainly_inline'-        v = ...k...  -- but preInlineUnconditionally doesn't inline it-inline ==>-        k = Just (f y)-        v = ...k...-float ==>-        x1 = f y-        k = Just x1-        v = ...k...--This is worse than the slow cascade, so we only want to say "certainly_inline"-if it really is certain.  Look at the note with preInlineUnconditionally-for the various clauses.---************************************************************************-*                                                                      *-                Expressions-*                                                                      *-************************************************************************--}--occAnalList :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])-occAnalList _   []     = (emptyDetails, [])-occAnalList env (e:es) = case occAnal env e      of { (uds1, e')  ->-                         case occAnalList env es of { (uds2, es') ->-                         (uds1 `andUDs` uds2, e' : es') } }--occAnal :: OccEnv-        -> CoreExpr-        -> (UsageDetails,       -- Gives info only about the "interesting" Ids-            CoreExpr)--occAnal _   expr@(Type _) = (emptyDetails,         expr)-occAnal _   expr@(Lit _)  = (emptyDetails,         expr)-occAnal env expr@(Var _)  = occAnalApp env (expr, [], [])-    -- At one stage, I gathered the idRuleVars for the variable here too,-    -- which in a way is the right thing to do.-    -- But that went wrong right after specialisation, when-    -- the *occurrences* of the overloaded function didn't have any-    -- rules in them, so the *specialised* versions looked as if they-    -- weren't used at all.--occAnal _ (Coercion co)-  = (addManyOccs emptyDetails (coVarsOfCo co), Coercion co)-        -- See Note [Gather occurrences of coercion variables]--{--Note [Gather occurrences of coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to gather info about what coercion variables appear, so that-we can sort them into the right place when doing dependency analysis.--}--occAnal env (Tick tickish body)-  | SourceNote{} <- tickish-  = (usage, Tick tickish body')-                  -- SourceNotes are best-effort; so we just proceed as usual.-                  -- If we drop a tick due to the issues described below it's-                  -- not the end of the world.--  | tickish `tickishScopesLike` SoftScope-  = (markAllNonTail usage, Tick tickish body')--  | Breakpoint _ ids <- tickish-  = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body')-    -- never substitute for any of the Ids in a Breakpoint--  | otherwise-  = (usage_lam, Tick tickish body')-  where-    !(usage,body') = occAnal env body-    -- for a non-soft tick scope, we can inline lambdas only-    usage_lam = markAllNonTail (markAllInsideLam usage)-                  -- TODO There may be ways to make ticks and join points play-                  -- nicer together, but right now there are problems:-                  --   let j x = ... in tick<t> (j 1)-                  -- Making j a join point may cause the simplifier to drop t-                  -- (if the tick is put into the continuation). So we don't-                  -- count j 1 as a tail call.-                  -- See #14242.--occAnal env (Cast expr co)-  = case occAnal env expr of { (usage, expr') ->-    let usage1 = markAllManyNonTailIf (isRhsEnv env) usage-          -- usage1: if we see let x = y `cast` co-          -- then mark y as 'Many' so that we don't-          -- immediately inline y again.-        usage2 = addManyOccs usage1 (coVarsOfCo co)-          -- usage2: see Note [Gather occurrences of coercion variables]-    in (markAllNonTail usage2, Cast expr' co)-    }--occAnal env app@(App _ _)-  = occAnalApp env (collectArgsTicks tickishFloatable app)---- Ignore type variables altogether---   (a) occurrences inside type lambdas only not marked as InsideLam---   (b) type variables not in environment--occAnal env (Lam x body)-  | isTyVar x-  = case occAnal env body of { (body_usage, body') ->-    (markAllNonTail body_usage, Lam x body')-    }---- For value lambdas we do a special hack.  Consider---      (\x. \y. ...x...)--- If we did nothing, x is used inside the \y, so would be marked--- as dangerous to dup.  But in the common case where the abstraction--- is applied to two arguments this is over-pessimistic.--- So instead, we just mark each binder with its occurrence--- info in the *body* of the multiple lambda.--- Then, the simplifier is careful when partially applying lambdas.--occAnal env expr@(Lam _ _)-  = case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->-    let-        expr'       = mkLams tagged_bndrs body'-        usage1      = markAllNonTail usage-        one_shot_gp = all isOneShotBndr tagged_bndrs-        final_usage = markAllInsideLamIf (not one_shot_gp) usage1-    in-    (final_usage, expr') }-  where-    (bndrs, body) = collectBinders expr--occAnal env (Case scrut bndr ty alts)-  = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') ->-    let alt_env = addBndrSwap scrut' bndr $-                  env { occ_encl = OccVanilla } `addInScope` [bndr]-    in-    case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts')   ->-    let-        alts_usage  = foldr orUDs emptyDetails alts_usage_s-        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr-        total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1-                        -- Alts can have tail calls, but the scrutinee can't-    in-    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}--occAnal env (Let bind body)-  = case occAnal (env `addInScope` bindersOf bind)-                 body                    of { (body_usage, body') ->-    case occAnalBind env NotTopLevel-                     noImpRuleEdges bind-                     body_usage          of { (final_usage, new_binds) ->-       (final_usage, mkLets new_binds body') }}--occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])-occAnalArgs _ [] _-  = (emptyDetails, [])--occAnalArgs env (arg:args) one_shots-  | isTypeArg arg-  = case occAnalArgs env args one_shots of { (uds, args') ->-    (uds, arg:args') }--  | otherwise-  = case argCtxt env one_shots           of { (arg_env, one_shots') ->-    case occAnal arg_env arg             of { (uds1, arg') ->-    case occAnalArgs env args one_shots' of { (uds2, args') ->-    (uds1 `andUDs` uds2, arg':args') }}}--{--Applications are dealt with specially because we want-the "build hack" to work.--Note [Arguments of let-bound constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    f x = let y = expensive x in-          let z = (True,y) in-          (case z of {(p,q)->q}, case z of {(p,q)->q})-We feel free to duplicate the WHNF (True,y), but that means-that y may be duplicated thereby.--If we aren't careful we duplicate the (expensive x) call!-Constructors are rather like lambdas in this way.--}--occAnalApp :: OccEnv-           -> (Expr CoreBndr, [Arg CoreBndr], [Tickish Id])-           -> (UsageDetails, Expr CoreBndr)--- Naked variables (not applied) end up here too-occAnalApp env (Var fun, args, ticks)-  -- Account for join arity of runRW# continuation-  -- See Note [Simplification of runRW#]-  ---  -- NB: Do not be tempted to make the next (Var fun, args, tick)-  --     equation into an 'otherwise' clause for this equation-  --     The former has a bang-pattern to occ-anal the args, and-  --     we don't want to occ-anal them twice in the runRW# case!-  --     This caused #18296-  | fun `hasKey` runRWKey-  , [t1, t2, arg]  <- args-  , let (usage, arg') = occAnalRhs env (Just 1) arg-  = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])--occAnalApp env (Var fun_id, args, ticks)-  = (all_uds, mkTicks ticks $ mkApps fun' args')-  where-    (fun', fun_id') = lookupBndrSwap env fun_id--    fun_uds = mkOneOcc fun_id' int_cxt n_args-       -- NB: fun_uds is computed for fun_id', not fun_id-       -- See (BS1) in Note [The binder-swap substitution]--    all_uds = fun_uds `andUDs` final_args_uds--    !(args_uds, args') = occAnalArgs env args one_shots-    !final_args_uds = markAllNonTail                        $-                      markAllInsideLamIf (isRhsEnv env && is_exp) $-                      args_uds-       -- We mark the free vars of the argument of a constructor or PAP-       -- as "inside-lambda", if it is the RHS of a let(rec).-       -- This means that nothing gets inlined into a constructor or PAP-       -- argument position, which is what we want.  Typically those-       -- constructor arguments are just variables, or trivial expressions.-       -- We use inside-lam because it's like eta-expanding the PAP.-       ---       -- This is the *whole point* of the isRhsEnv predicate-       -- See Note [Arguments of let-bound constructors]--    n_val_args = valArgCount args-    n_args     = length args-    int_cxt    = case occ_encl env of-                   OccScrut -> IsInteresting-                   _other   | n_val_args > 0 -> IsInteresting-                            | otherwise      -> NotInteresting--    is_exp     = isExpandableApp fun_id n_val_args-        -- See Note [CONLIKE pragma] in GHC.Types.Basic-        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs--    one_shots  = argsOneShots (idStrictness fun_id) guaranteed_val_args-    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo-                                                         (occ_one_shots env))-        -- See Note [Sources of one-shot information], bullet point A']--occAnalApp env (fun, args, ticks)-  = (markAllNonTail (fun_uds `andUDs` args_uds),-     mkTicks ticks $ mkApps fun' args')-  where-    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun-        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier-        -- often leaves behind beta redexs like-        --      (\x y -> e) a1 a2-        -- Here we would like to mark x,y as one-shot, and treat the whole-        -- thing much like a let.  We do this by pushing some True items-        -- onto the context stack.-    !(args_uds, args') = occAnalArgs env args []---{--Note [Sources of one-shot information]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The occurrence analyser obtains one-shot-lambda information from two sources:--A:  Saturated applications:  eg   f e1 .. en--    In general, given a call (f e1 .. en) we can propagate one-shot info from-    f's strictness signature into e1 .. en, but /only/ if n is enough to-    saturate the strictness signature. A strictness signature like--          f :: C1(C1(L))LS--    means that *if f is applied to three arguments* then it will guarantee to-    call its first argument at most once, and to call the result of that at-    most once. But if f has fewer than three arguments, all bets are off; e.g.--          map (f (\x y. expensive) e2) xs--    Here the \x y abstraction may be called many times (once for each element of-    xs) so we should not mark x and y as one-shot. But if it was--          map (f (\x y. expensive) 3 2) xs--    then the first argument of f will be called at most once.--    The one-shot info, derived from f's strictness signature, is-    computed by 'argsOneShots', called in occAnalApp.--A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))-    where f is as above.--    In this case, f is only manifestly applied to one argument, so it does not-    look saturated. So by the previous point, we should not use its strictness-    signature to learn about the one-shotness of \x y. But in this case we can:-    build is fully applied, so we may use its strictness signature; and from-    that we learn that build calls its argument with two arguments *at most once*.--    So there is really only one call to f, and it will have three arguments. In-    that sense, f is saturated, and we may proceed as described above.--    Hence the computation of 'guaranteed_val_args' in occAnalApp, using-    '(occ_one_shots env)'.  See also #13227, comment:9--B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah-                        in (build f, build f)--    Propagate one-shot info from the demanand-info on 'f' to the-    lambdas in its RHS (which may not be syntactically at the top)--    This information must have come from a previous run of the demanand-    analyser.--Previously, the demand analyser would *also* set the one-shot information, but-that code was buggy (see #11770), so doing it only in on place, namely here, is-saner.--Note [OneShots]-~~~~~~~~~~~~~~~-When analysing an expression, the occ_one_shots argument contains information-about how the function is being used. The length of the list indicates-how many arguments will eventually be passed to the analysed expression,-and the OneShotInfo indicates whether this application is once or multiple times.--Example:-- Context of f                occ_one_shots when analysing f-- f 1 2                       [OneShot, OneShot]- map (f 1)                   [OneShot, NoOneShotInfo]- build f                     [OneShot, OneShot]- f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]--Note [Binders in case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    case x of y { (a,b) -> f y }-We treat 'a', 'b' as dead, because they don't physically occur in the-case alternative.  (Indeed, a variable is dead iff it doesn't occur in-its scope in the output of OccAnal.)  It really helps to know when-binders are unused.  See esp the call to isDeadBinder in-Simplify.mkDupableAlt--In this example, though, the Simplifier will bring 'a' and 'b' back to-life, because it binds 'y' to (a,b) (imagine got inlined and-scrutinised y).--}--occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr-                -> (UsageDetails, [CoreBndr], CoreExpr)--- Tags the returned binders with their OccInfo, but does--- not do any markInsideLam to the returned usage details-occAnalLamOrRhs env [] body-  = case occAnal env body of (body_usage, body') -> (body_usage, [], body')-      -- RHS of thunk or nullary join point--occAnalLamOrRhs env (bndr:bndrs) body-  | isTyVar bndr-  = -- Important: Keep the environment so that we don't inline into an RHS like-    --   \(@ x) -> C @x (f @x)-    -- (see the beginning of Note [Cascading inlines]).-    case occAnalLamOrRhs env bndrs body of-      (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')--occAnalLamOrRhs env binders body-  = case occAnal env_body body of { (body_usage, body') ->-    let-        (final_usage, tagged_binders) = tagLamBinders body_usage binders'-                      -- Use binders' to put one-shot info on the lambdas-    in-    (final_usage, tagged_binders, body') }-  where-    env1 = env `addInScope` binders-    (env_body, binders') = oneShotGroup env1 binders--occAnalAlt :: OccEnv-           -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo)-occAnalAlt env (con, bndrs, rhs)-  = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) ->-    let-      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs-    in                          -- See Note [Binders in case alternatives]-    (alt_usg, (con, tagged_bndrs, rhs1)) }--{--************************************************************************-*                                                                      *-                    OccEnv-*                                                                      *-************************************************************************--}--data OccEnv-  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information-           , occ_one_shots  :: !OneShots     -- See Note [OneShots]-           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active-           , occ_rule_act   :: Activation -> Bool  -- Which rules are active-             -- See Note [Finding rule RHS free vars]--           -- See Note [The binder-swap substitution]-           -- If  x :-> (y, co)  is in the env,-           -- then please replace x by (y |> sym mco)-           -- Invariant of course: idType x = exprType (y |> sym mco)-           , occ_bs_env  :: VarEnv (OutId, MCoercion)-           , occ_bs_rng  :: VarSet   -- Vars free in the range of occ_bs_env-                   -- Domain is Global and Local Ids-                   -- Range is just Local Ids-    }----------------------------------- OccEncl is used to control whether to inline into constructor arguments--- For example:---      x = (p,q)               -- Don't inline p or q---      y = /\a -> (p a, q a)   -- Still don't inline p or q---      z = f (p,q)             -- Do inline p,q; it may make a rule fire--- So OccEncl tells enough about the context to know what to do when--- we encounter a constructor application or PAP.------ OccScrut is used to set the "interesting context" field of OncOcc--data OccEncl-  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda-                   -- Don't inline into constructor args here--  | OccScrut       -- Scrutintee of a case-                   -- Can inline into constructor args--  | OccVanilla     -- Argument of function, body of lambda, etc-                   -- Do inline into constructor args here--instance Outputable OccEncl where-  ppr OccRhs     = text "occRhs"-  ppr OccScrut   = text "occScrut"-  ppr OccVanilla = text "occVanilla"---- See note [OneShots]-type OneShots = [OneShotInfo]--initOccEnv :: OccEnv-initOccEnv-  = OccEnv { occ_encl      = OccVanilla-           , occ_one_shots = []--                 -- To be conservative, we say that all-                 -- inlines and rules are active-           , occ_unf_act   = \_ -> True-           , occ_rule_act  = \_ -> True--           , occ_bs_env = emptyVarEnv-           , occ_bs_rng = emptyVarSet }--noBinderSwaps :: OccEnv -> Bool-noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env--scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv-scrutCtxt env alts-  | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }-  | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }-  where-    interesting_alts = case alts of-                         []    -> False-                         [alt] -> not (isDefaultAlt alt)-                         _     -> True-     -- 'interesting_alts' is True if the case has at least one-     -- non-default alternative.  That in turn influences-     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!--rhsCtxt :: OccEnv -> OccEnv-rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }--argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])-argCtxt env []-  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])-argCtxt env (one_shots:one_shots_s)-  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)--isRhsEnv :: OccEnv -> Bool-isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of-                                          OccRhs -> True-                                          _      -> False--addInScope :: OccEnv -> [Var] -> OccEnv--- See Note [The binder-swap substitution]-addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs-  | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }--oneShotGroup :: OccEnv -> [CoreBndr]-             -> ( OccEnv-                , [CoreBndr] )-        -- The result binders have one-shot-ness set that they might not have had originally.-        -- This happens in (build (\c n -> e)).  Here the occurrence analyser-        -- linearity context knows that c,n are one-shot, and it records that fact in-        -- the binder. This is useful to guide subsequent float-in/float-out transformations--oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs-  = go ctxt bndrs []-  where-    go ctxt [] rev_bndrs-      = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }-        , reverse rev_bndrs )--    go [] bndrs rev_bndrs-      = ( env { occ_one_shots = [], occ_encl = OccVanilla }-        , reverse rev_bndrs ++ bndrs )--    go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs-      | isId bndr = go ctxt' bndrs (bndr': rev_bndrs)-      | otherwise = go ctxt  bndrs (bndr : rev_bndrs)-      where-        bndr' = updOneShotInfo bndr one_shot-               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing-               -- one-shot info might be better than what we can infer, e.g.-               -- due to explicit use of the magic 'oneShot' function.-               -- See Note [The oneShot function]---markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]--- Mark the lambdas of a non-recursive join point as one-shot.--- This is good to prevent gratuitous float-out etc-markJoinOneShots mb_join_arity bndrs-  = case mb_join_arity of-      Nothing -> bndrs-      Just n  -> go n bndrs- where-   go 0 bndrs  = bndrs-   go _ []     = [] -- This can legitimately happen.-                    -- e.g.    let j = case ... in j True-                    -- This will become an arity-1 join point after the-                    -- simplifier has eta-expanded it; but it may not have-                    -- enough lambdas /yet/. (Lint checks that JoinIds do-                    -- have enough lambdas.)-   go n (b:bs) = b' : go (n-1) bs-     where-       b' | isId b    = setOneShotLambda b-          | otherwise = b--addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv-addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args-  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }--transClosureFV :: VarEnv VarSet -> VarEnv VarSet--- If (f,g), (g,h) are in the input, then (f,h) is in the output---                                   as well as (f,g), (g,h)-transClosureFV env-  | no_change = env-  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)-  where-    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)-      -- It's OK to use nonDetUFMToList here because we'll forget the-      -- ordering by creating a new set with listToUFM-    bump no_change (b,fvs)-      | no_change_here = (no_change, (b,fvs))-      | otherwise      = (False,     (b,new_fvs))-      where-        (new_fvs, no_change_here) = extendFvs env fvs----------------extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet-extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag--extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)--- (extendFVs env s) returns---     (s `union` env(s), env(s) `subset` s)-extendFvs env s-  | isNullUFM env-  = (s, True)-  | otherwise-  = (s `unionVarSet` extras, extras `subVarSet` s)-  where-    extras :: VarSet    -- env(s)-    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $-      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes-             intersectUFM_C (\x _ -> x) env (getUniqSet s)--{--************************************************************************-*                                                                      *-                    Binder swap-*                                                                      *-************************************************************************--Note [Binder swap]-~~~~~~~~~~~~~~~~~~-The "binder swap" transformation swaps occurrence of the-scrutinee of a case for occurrences of the case-binder:-- (1)  case x of b { pi -> ri }-         ==>-      case x of b { pi -> ri[b/x] }-- (2)  case (x |> co) of b { pi -> ri }-        ==>-      case (x |> co) of b { pi -> ri[b |> sym co/x] }--The substitution ri[b/x] etc is done by the occurrence analyser.-See Note [The binder-swap substitution].--There are two reasons for making this swap:--(A) It reduces the number of occurrences of the scrutinee, x.-    That in turn might reduce its occurrences to one, so we-    can inline it and save an allocation.  E.g.-      let x = factorial y in case x of b { I# v -> ...x... }-    If we replace 'x' by 'b' in the alternative we get-      let x = factorial y in case x of b { I# v -> ...b... }-    and now we can inline 'x', thus-      case (factorial y) of b { I# v -> ...b... }--(B) The case-binder b has unfolding information; in the-    example above we know that b = I# v. That in turn allows-    nested cases to simplify.  Consider-       case x of b { I# v ->-       ...(case x of b2 { I# v2 -> rhs })...-    If we replace 'x' by 'b' in the alternative we get-       case x of b { I# v ->-       ...(case b of b2 { I# v2 -> rhs })...-    and now it is trivial to simplify the inner case:-       case x of b { I# v ->-       ...(let b2 = b in rhs)...--    The same can happen even if the scrutinee is a variable-    with a cast: see Note [Case of cast]--The reason for doing these transformations /here in the occurrence-analyser/ is because it allows us to adjust the OccInfo for 'x' and-'b' as we go.--  * Suppose the only occurrences of 'x' are the scrutinee and in the-    ri; then this transformation makes it occur just once, and hence-    get inlined right away.--  * If instead the Simplifier replaces occurrences of x with-    occurrences of b, that will mess up b's occurrence info. That in-    turn might have consequences.--There is a danger though.  Consider-      let v = x +# y-      in case (f v) of w -> ...v...v...-And suppose that (f v) expands to just v.  Then we'd like to-use 'w' instead of 'v' in the alternative.  But it may be too-late; we may have substituted the (cheap) x+#y for v in the-same simplifier pass that reduced (f v) to v.--I think this is just too bad.  CSE will recover some of it.--Note [The binder-swap substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The binder-swap is implemented by the occ_bs_env field of OccEnv.-There are two main pieces:--* Given    case x |> co of b { alts }-  we add [x :-> (b, co)] to the occ_bs_env environment; this is-  done by addBndrSwap.--* Then, at an occurrence of a variable, we look up in the occ_bs_env-  to perform the swap. This is done by lookupBndrSwap.--Some tricky corners:--(BS1) We do the substitution before gathering occurrence info. So in-      the above example, an occurrence of x turns into an occurrence-      of b, and that's what we gather in the UsageDetails.  It's as-      if the binder-swap occurred before occurrence analysis. See-      the computation of fun_uds in occAnalApp.--(BS2) When doing a lookup in occ_bs_env, we may need to iterate,-      as you can see implemented in lookupBndrSwap.  Why?-      Consider   case x of a { 1# -> e1; DEFAULT ->-                 case x of b { 2# -> e2; DEFAULT ->-                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}-      At the first case addBndrSwap will extend occ_bs_env with-          [x :-> a]-      At the second case we occ-anal the scrutinee 'x', which looks up-        'x in occ_bs_env, returning 'a', as it should.-      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding-         occ_bs_env = [x :-> a, a :-> b]-      At the third case we'll again look up 'x' which returns 'a'.-      But we don't want to stop the lookup there, else we'll end up with-                 case x of a { 1# -> e1; DEFAULT ->-                 case a of b { 2# -> e2; DEFAULT ->-                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}-      Instead, we want iterate the lookup in addBndrSwap, to give-                 case x of a { 1# -> e1; DEFAULT ->-                 case a of b { 2# -> e2; DEFAULT ->-                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}-      This makes a particular difference for case-merge, which works-      only if the scrutinee is the case-binder of the immediately enclosing-      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils-      See #19581 for the bug report that showed this up.--(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,-      and we encounter:-         - \x. blah-           Here we want to delete the x-binding from occ_bs_env--         - \b. blah-           This is harder: we really want to delete all bindings that-           have 'b' free in the range.  That is a bit tiresome to implement,-           so we compromise.  We keep occ_bs_rng, which is the set of-           free vars of rng(occc_bs_env).  If a binder shadows any of these-           variables, we discard all of occ_bs_env.  Safe, if a bit-           brutal.  NB, however: the simplifer de-shadows the code, so the-           next time around this won't happen.--      These checks are implemented in addInScope.--      The occurrence analyser itself does /not/ do cloning. It could, in-      principle, but it'd make it a bit more complicated and there is no-      great benefit. The simplifer uses cloning to get a no-shadowing-      situation, the care-when-shadowing behaviour above isn't needed for-      long.--(BS4) The domain of occ_bs_env can include GlobaIds.  Eg-         case M.foo of b { alts }-      We extend occ_bs_env with [M.foo :-> b].  That's fine.--(BS5) We have to apply the occ_bs_env substitution uniformly,-      including to (local) rules and unfoldings.--Historical note-----------------We used to do the binder-swap transformation by introducing-a proxy let-binding, thus;--   case x of b { pi -> ri }-      ==>-   case x of b { pi -> let x = b in ri }--But that had two problems:--1. If 'x' is an imported GlobalId, we'd end up with a GlobalId-   on the LHS of a let-binding which isn't allowed.  We worked-   around this for a while by "localising" x, but it turned-   out to be very painful #16296,--2. In CorePrep we use the occurrence analyser to do dead-code-   elimination (see Note [Dead code in CorePrep]).  But that-   occasionally led to an unlifted let-binding-       case x of b { DEFAULT -> let x::Int# = b in ... }-   which disobeys one of CorePrep's output invariants (no unlifted-   let-bindings) -- see #5433.--Doing a substitution (via occ_bs_env) is much better.--Note [Case of cast]-~~~~~~~~~~~~~~~~~~~-Consider        case (x `cast` co) of b { I# ->-                ... (case (x `cast` co) of {...}) ...-We'd like to eliminate the inner case.  That is the motivation for-equation (2) in Note [Binder swap].  When we get to the inner case, we-inline x, cancel the casts, and away we go.--Note [Zap case binders in proxy bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-From the original-     case x of cb(dead) { p -> ...x... }-we will get-     case x of cb(live) { p -> ...cb... }--Core Lint never expects to find an *occurrence* of an Id marked-as Dead, so we must zap the OccInfo on cb before making the-binding x = cb.  See #5028.--NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier-doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.--Historical note [no-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We *used* to suppress the binder-swap in case expressions when--fno-case-of-case is on.  Old remarks:-    "This happens in the first simplifier pass,-    and enhances full laziness.  Here's the bad case:-            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )-    If we eliminate the inner case, we trap it inside the I# v -> arm,-    which might prevent some full laziness happening.  I've seen this-    in action in spectral/cichelli/Prog.hs:-             [(m,n) | m <- [1..max], n <- [1..max]]-    Hence the check for NoCaseOfCase."-However, now the full-laziness pass itself reverses the binder-swap, so this-check is no longer necessary.--Historical note [Suppressing the case binder-swap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This old note describes a problem that is also fixed by doing the-binder-swap in OccAnal:--    There is another situation when it might make sense to suppress the-    case-expression binde-swap. If we have--        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    We'll perform the binder-swap for the outer case, giving--        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    But there is no point in doing it for the inner case, because w1 can't-    be inlined anyway.  Furthermore, doing the case-swapping involves-    zapping w2's occurrence info (see paragraphs that follow), and that-    forces us to bind w2 when doing case merging.  So we get--        case x of w1 { A -> let w2 = w1 in e1-                       B -> let w2 = w1 in e2-                       ...other cases .... }--    This is plain silly in the common case where w2 is dead.--    Even so, I can't see a good way to implement this idea.  I tried-    not doing the binder-swap if the scrutinee was already evaluated-    but that failed big-time:--            data T = MkT !Int--            case v of w  { MkT x ->-            case x of x1 { I# y1 ->-            case x of x2 { I# y2 -> ...--    Notice that because MkT is strict, x is marked "evaluated".  But to-    eliminate the last case, we must either make sure that x (as well as-    x1) has unfolding MkT y1.  The straightforward thing to do is to do-    the binder-swap.  So this whole note is a no-op.--It's fixed by doing the binder-swap in OccAnal because we can do the-binder-swap unconditionally and still get occurrence analysis-information right.--}--addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv--- See Note [The binder-swap substitution]-addBndrSwap scrut case_bndr-            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })-  | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) scrut)-  , scrut_var /= case_bndr-      -- Consider: case x of x { ... }-      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop-  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)-        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'-                       `unionVarSet` tyCoVarsOfMCo mco }--  | otherwise-  = env-  where-    get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion)-    get_scrut_var (Var v)           = Just (v, MRefl)-    get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast]-    get_scrut_var _                 = Nothing--    case_bndr' = zapIdOccInfo case_bndr-                 -- See Note [Zap case binders in proxy bindings]--lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)--- See Note [The binder-swap substitution]--- Returns an expression of the same type as Id-lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr-  = case lookupVarEnv bs_env bndr of {-       Nothing           -> (Var bndr, bndr) ;-       Just (bndr1, mco) ->--    -- Why do we iterate here?-    -- See (BS2) in Note [The binder-swap substitution]-    case lookupBndrSwap env bndr1 of-      (fun, fun_id) -> (add_cast fun mco, fun_id) }--  where-    add_cast fun MRefl    = fun-    add_cast fun (MCo co) = Cast fun (mkSymCo co)-    -- We must switch that 'co' to 'sym co';-    -- see the comment with occ_bs_env-    -- No need to test for isReflCo, because 'co' came from-    -- a (Cast e co) and hence is unlikely to be Refl--{--************************************************************************-*                                                                      *-\subsection[OccurAnal-types]{OccEnv}-*                                                                      *-************************************************************************--Note [UsageDetails and zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On many occasions, we must modify all gathered occurrence data at once. For-instance, all occurrences underneath a (non-one-shot) lambda set the-'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but-that takes O(n) time and we will do this often---in particular, there are many-places where tail calls are not allowed, and each of these causes all variables-to get marked with 'NoTailCallInfo'.--Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along-with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"-recording which variables have been zapped in some way. Zapping all occurrence-info then simply means setting the corresponding zapped set to the whole-'OccInfoEnv', a fast O(1) operation.--}--type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage-                -- INVARIANT: never IAmDead-                -- (Deadness is signalled by not being in the map at all)--type ZappedSet = OccInfoEnv -- Values are ignored--data UsageDetails-  = UD { ud_env       :: !OccInfoEnv-       , ud_z_many    :: ZappedSet   -- apply 'markMany' to these-       , ud_z_in_lam  :: ZappedSet   -- apply 'markInsideLam' to these-       , ud_z_no_tail :: ZappedSet } -- apply 'markNonTail' to these-  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv--instance Outputable UsageDetails where-  ppr ud = ppr (ud_env (flattenUsageDetails ud))------------------------ UsageDetails API--andUDs, orUDs-        :: UsageDetails -> UsageDetails -> UsageDetails-andUDs = combineUsageDetailsWith addOccInfo-orUDs  = combineUsageDetailsWith orOccInfo--mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails-mkOneOcc id int_cxt arity-  | isLocalId id-  = emptyDetails { ud_env = unitVarEnv id occ_info }-  | otherwise-  = emptyDetails-  where-    occ_info = OneOcc { occ_in_lam  = NotInsideLam-                      , occ_n_br    = oneBranch-                      , occ_int_cxt = int_cxt-                      , occ_tail    = AlwaysTailCalled arity }--addManyOccId :: UsageDetails -> Id -> UsageDetails--- Add the non-committal (id :-> noOccInfo) to the usage details-addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }---- Add several occurrences, assumed not to be tail calls-addManyOcc :: Var -> UsageDetails -> UsageDetails-addManyOcc v u | isId v    = addManyOccId u v-               | otherwise = u-        -- Give a non-committal binder info (i.e noOccInfo) because-        --   a) Many copies of the specialised thing can appear-        --   b) We don't want to substitute a BIG expression inside a RULE-        --      even if that's the only occurrence of the thing-        --      (Same goes for INLINE.)--addManyOccs :: UsageDetails -> VarSet -> UsageDetails-addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set-  -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes--delDetails :: UsageDetails -> Id -> UsageDetails-delDetails ud bndr-  = ud `alterUsageDetails` (`delVarEnv` bndr)--delDetailsList :: UsageDetails -> [Id] -> UsageDetails-delDetailsList ud bndrs-  = ud `alterUsageDetails` (`delVarEnvList` bndrs)--emptyDetails :: UsageDetails-emptyDetails = UD { ud_env       = emptyVarEnv-                  , ud_z_many    = emptyVarEnv-                  , ud_z_in_lam  = emptyVarEnv-                  , ud_z_no_tail = emptyVarEnv }--isEmptyDetails :: UsageDetails -> Bool-isEmptyDetails = isEmptyVarEnv . ud_env--markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail-  :: UsageDetails -> UsageDetails-markAllMany          ud = ud { ud_z_many    = ud_env ud }-markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }--markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails--markAllInsideLamIf  True  ud = markAllInsideLam ud-markAllInsideLamIf  False ud = ud--markAllNonTailIf True  ud = markAllNonTail ud-markAllNonTailIf False ud = ud---markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo--markAllManyNonTailIf :: Bool              -- If this is true-             -> UsageDetails      -- Then do markAllManyNonTail on this-             -> UsageDetails-markAllManyNonTailIf True  uds = markAllManyNonTail uds-markAllManyNonTailIf False uds = uds--lookupDetails :: UsageDetails -> Id -> OccInfo-lookupDetails ud id-  | isCoVar id  -- We do not currently gather occurrence info (from types)-  = noOccInfo   -- for CoVars, so we must conservatively mark them as used-                -- See Note [DoO not mark CoVars as dead]-  | otherwise-  = case lookupVarEnv (ud_env ud) id of-      Just occ -> doZapping ud id occ-      Nothing  -> IAmDead--usedIn :: Id -> UsageDetails -> Bool-v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud--udFreeVars :: VarSet -> UsageDetails -> VarSet--- Find the subset of bndrs that are mentioned in uds-udFreeVars bndrs ud = restrictUniqSetToUFM bndrs (ud_env ud)--{- Note [Do not mark CoVars as dead]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's obviously wrong to mark CoVars as dead if they are used.-Currently we don't traverse types to gather usase info for CoVars,-so we had better treat them as having noOccInfo.--This showed up in #15696 we had something like-  case eq_sel d of co -> ...(typeError @(...co...) "urk")...--Then 'd' was substituted by a dictionary, so the expression-simpified to-  case (Coercion <blah>) of co -> ...(typeError @(...co...) "urk")...--But then the "drop the case altogether" equation of rebuildCase-thought that 'co' was dead, and discarded the entire case. Urk!--I have no idea how we managed to avoid this pitfall for so long!--}------------------------ Auxiliary functions for UsageDetails implementation--combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)-                        -> UsageDetails -> UsageDetails -> UsageDetails-combineUsageDetailsWith plus_occ_info ud1 ud2-  | isEmptyDetails ud1 = ud2-  | isEmptyDetails ud2 = ud1-  | otherwise-  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)-       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)-       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)-       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }--doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo-doZapping ud var occ-  = doZappingByUnique ud (varUnique var) occ--doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo-doZappingByUnique (UD { ud_z_many = many-                      , ud_z_in_lam = in_lam-                      , ud_z_no_tail = no_tail })-                  uniq occ-  = occ2-  where-    occ1 | uniq `elemVarEnvByKey` many    = markMany occ-         | uniq `elemVarEnvByKey` in_lam  = markInsideLam occ-         | otherwise                      = occ-    occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1-         | otherwise                      = occ1--alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails-alterZappedSets ud f-  = ud { ud_z_many    = f (ud_z_many    ud)-       , ud_z_in_lam  = f (ud_z_in_lam  ud)-       , ud_z_no_tail = f (ud_z_no_tail ud) }--alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails-alterUsageDetails ud f-  = ud { ud_env = f (ud_env ud) } `alterZappedSets` f--flattenUsageDetails :: UsageDetails -> UsageDetails-flattenUsageDetails ud-  = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) }-      `alterZappedSets` const emptyVarEnv------------------------ See Note [Adjusting right-hand sides]-adjustRhsUsage :: Maybe JoinArity -> RecFlag-               -> [CoreBndr]     -- Outer lambdas, AFTER occ anal-               -> UsageDetails   -- From body of lambda-               -> UsageDetails-adjustRhsUsage mb_join_arity rec_flag bndrs usage-  = markAllInsideLamIf     (not one_shot)   $-    markAllNonTailIf (not exact_join) $-    usage-  where-    one_shot = case mb_join_arity of-                 Just join_arity-                   | isRec rec_flag -> False-                   | otherwise      -> all isOneShotBndr (drop join_arity bndrs)-                 Nothing            -> all isOneShotBndr bndrs--    exact_join = exactJoin mb_join_arity bndrs--exactJoin :: Maybe JoinArity -> [a] -> Bool-exactJoin Nothing           _    = False-exactJoin (Just join_arity) args = args `lengthIs` join_arity-  -- Remember join_arity includes type binders--type IdWithOccInfo = Id--tagLamBinders :: UsageDetails          -- Of scope-              -> [Id]                  -- Binders-              -> (UsageDetails,        -- Details with binders removed-                 [IdWithOccInfo])    -- Tagged binders-tagLamBinders usage binders-  = usage' `seq` (usage', bndrs')-  where-    (usage', bndrs') = mapAccumR tagLamBinder usage binders--tagLamBinder :: UsageDetails       -- Of scope-             -> Id                 -- Binder-             -> (UsageDetails,     -- Details with binder removed-                 IdWithOccInfo)    -- Tagged binders--- Used for lambda and case binders--- It copes with the fact that lambda bindings can have a--- stable unfolding, used for join points-tagLamBinder usage bndr-  = (usage2, bndr')-  where-        occ    = lookupDetails usage bndr-        bndr'  = setBinderOcc (markNonTail occ) bndr-                   -- Don't try to make an argument into a join point-        usage1 = usage `delDetails` bndr-        usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)-                               -- This is effectively the RHS of a-                               -- non-join-point binding, so it's okay to use-                               -- addManyOccsSet, which assumes no tail calls-               | otherwise = usage1--tagNonRecBinder :: TopLevelFlag           -- At top level?-                -> UsageDetails           -- Of scope-                -> CoreBndr               -- Binder-                -> (UsageDetails,         -- Details with binder removed-                    IdWithOccInfo)        -- Tagged binder--tagNonRecBinder lvl usage binder- = let-     occ     = lookupDetails usage binder-     will_be_join = decideJoinPointHood lvl usage [binder]-     occ'    | will_be_join = -- must already be marked AlwaysTailCalled-                              ASSERT(isAlwaysTailCalled occ) occ-             | otherwise    = markNonTail occ-     binder' = setBinderOcc occ' binder-     usage'  = usage `delDetails` binder-   in-   usage' `seq` (usage', binder')--tagRecBinders :: TopLevelFlag           -- At top level?-              -> UsageDetails           -- Of body of let ONLY-              -> [(CoreBndr,            -- Binder-                   UsageDetails,        -- RHS usage details-                   [CoreBndr])]         -- Lambdas in new RHS-              -> (UsageDetails,         -- Adjusted details for whole scope,-                                        -- with binders removed-                  [IdWithOccInfo])      -- Tagged binders--- Substantially more complicated than non-recursive case. Need to adjust RHS--- details *before* tagging binders (because the tags depend on the RHSes).-tagRecBinders lvl body_uds triples- = let-     (bndrs, rhs_udss, _) = unzip3 triples--     -- 1. Determine join-point-hood of whole group, as determined by-     --    the *unadjusted* usage details-     unadj_uds     = foldr andUDs body_uds rhs_udss-     will_be_joins = decideJoinPointHood lvl unadj_uds bndrs--     -- 2. Adjust usage details of each RHS, taking into account the-     --    join-point-hood decision-     rhs_udss' = map adjust triples-     adjust (bndr, rhs_uds, rhs_bndrs)-       = adjustRhsUsage mb_join_arity Recursive rhs_bndrs rhs_uds+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++module GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Ppr++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          stripTicksTopE, mkTicks )+import GHC.Core.Opt.Arity   ( joinRhsArity )+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Unit.Module( Module )+import GHC.Core.Coercion+import GHC.Core.Type+import GHC.Core.TyCo.FVs( tyCoVarsOfMCo )++import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Demand ( argOneShots, argsOneShots )+import GHC.Data.Graph.Directed ( SCC(..), Node(..)+                               , stronglyConnCompFromEdgedVerticesUniq+                               , stronglyConnCompFromEdgedVerticesUniqR )+import GHC.Builtin.Names( runRWKey )+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Utils.Misc+import GHC.Data.Maybe( isJust )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import Data.List (mapAccumL, mapAccumR)++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++occurAnalyseExpr :: CoreExpr -> CoreExpr+-- Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr expr+  = snd (occAnal initOccEnv expr)++occurAnalysePgm :: Module         -- Used only in debug output+                -> (Id -> Bool)         -- Active unfoldings+                -> (Activation -> Bool) -- Active rules+                -> [CoreRule]           -- Local rules for imported Ids+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_unf active_rule imp_rules binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon)+                   2 (ppr final_usage ) )+    occ_anald_glommed_binds+  where+    init_env = initOccEnv { occ_rule_act = active_rule+                          , occ_unf_act  = active_unf }++    (final_usage, occ_anald_binds) = go init_env binds+    (_, occ_anald_glommed_binds)   = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.++    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)+    -- The RULES declarations keep things alive!++    -- imp_rule_edges maps a top-level local binder 'f' to the+    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,+    -- where 'f' appears on the LHS+    --   e.g.  RULE foldr f = blah+    --         imp_rule_edges contains f :-> fvs(blah)+    -- We treat such RULES as extra rules for 'f'+    -- See Note [Preventing loops due to imported functions rules]+    imp_rule_edges :: ImpRuleEdges+    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv+                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $+                             exprsFreeIds args `delVarSetList` bndrs+                           | Rule { ru_act = act, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs } <- imp_rules+                                   -- Not BuiltinRules; see Note [Plugin rules]+                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]++    go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])+    go _ []+        = (initial_uds, [])+    go env (bind:binds)+        = (final_usage, bind' ++ binds')+        where+           (bs_usage, binds')   = go env binds+           (final_usage, bind') = occAnalBind env TopLevel imp_rule_edges bind+                                              bs_usage++{- *********************************************************************+*                                                                      *+                IMP-RULES+         Local rules for imported functions+*                                                                      *+********************************************************************* -}++type ImpRuleEdges = IdEnv [(Activation, VarSet)]+    -- Mapping from a local Id 'f' to info about its IMP-RULES,+    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS+    -- We record (a) its Activation and (b) the RHS free vars+    -- See Note [IMP-RULES: local rules for imported functions]++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]+lookupImpRules imp_rule_edges bndr+  = case lookupVarEnv imp_rule_edges bndr of+      Nothing -> []+      Just vs -> vs++impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails+-- Variable mentioned in RHS of an IMP-RULE for the bndr,+-- whether active or not+impRulesScopeUsage imp_rules_info+  = foldr add emptyDetails imp_rules_info+  where+    add (_,vs) usage = addManyOccs usage vs++impRulesActiveFvs :: (Activation -> Bool) -> VarSet+                  -> [(Activation,VarSet)] -> VarSet+impRulesActiveFvs is_active bndr_set vs+  = foldr add emptyVarSet vs `intersectVarSet` bndr_set+  where+    add (act,vs) acc | is_active act = vs `unionVarSet` acc+                     | otherwise     = acc++{- Note [IMP-RULES: local rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We quite often have+  * A /local/ rule+  * for an /imported/ function+like this:+  foo x = blah+  {-# RULE "map/foo" forall xs. map foo xs = xs #-}+We call them IMP-RULES.  They are important in practice, and occur a+lot in the libraries.++IMP-RULES are held in mg_rules of ModGuts, and passed in to+occurAnalysePgm.++Main Invariant:++* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS+  just like a RULE for f.++Note [IMP-RULES: unavoidable loops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [IMP-RULES: unavoidable+loops].  In particular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+  g_spec = .....(B.g Int).....+  RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might not be+as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'+because it mentions 'filterFB' on the LHS.  This is the Main Invariant+in Note [IMP-RULES: local rules for imported functions].++So, during loop-breaker analysis:++- for each active RULE for a local function 'f' we add an edge between+  'f' and the local FVs of the rule RHS++- for each active RULE for an *imported* function we add dependency+  edges between the *local* FVS of the rule LHS and the *local* FVS of+  the rule RHS.++Even with this extra hack we aren't always going to get things+right. For example, it might be that the rule LHS mentions an imported+Id, and another module has a RULE that can rewrite that imported Id to+one of our local Ids.++Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~+Conal Elliott (#11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to+something at the bottom:++        foo = ...(B.f @Int)...+        $sf = blah+        RULE:  B.f @Int = $sf++Applying this rule makes foo refer to $sf, although foo doesn't appear to+depend on $sf.  (And, as in Note [Rules for imported functions], the+dependency might be more indirect. For example, foo might mention C.t+rather than B.f, where C.t eventually inlines to B.f.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.f in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.  We+avoid infinite inlinings by choosing loop breakers, and ensuring that+a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which+deals with a closely related source of infinite loops.++When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Note [Forming Rec groups]+   Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.+   Wrap the details in a LetrecNode, ready for SCC analysis.+   All this is done by makeNode.++   The edges of this graph are the "scope edges".++2. Do SCC-analysis on these Nodes:+   - Each CyclicSCC will become a new Rec+   - Each AcyclicSCC will become a new NonRec++   The key property is that every free variable of a binding is+   accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each AcyclicSCC, just make a NonRec binding.++4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++   To do so, form the loop-breaker graph, do SCC analysis. For each+   CyclicSCC we choose a loop breaker, delete all edges to that node,+   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]+   for the details+++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+The key point about the "Forming Rec groups" step is that it /preserves+scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if+we start with+  Rec { f = ...h...+      ; g = ...f...+      ; h = ...f... }+we can split into SCCs+  Rec { f = ...h...+      ; h = ..f... }+  NonRec { g = ...f... }++We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g+uses f", no matter how indirectly.  We do a SCC analysis with an edge+f -> g if "f mentions g". That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f, whether active or inactive+       Note [Rules are extra RHSs]+  c) or the LHS or a rule for f, whether active or inactive+       Note [Rule dependency info]+  d) the RHS of an /active/ local IMP-RULE+       Note [IMP-RULES: local rules for imported functions]++(b) and (c) apply regardless of the activation of the RULE, because even if+the rule is inactive its free variables must be bound.  But (d) doesn't need+to worry about this because IMP-RULES are always notionally at the bottom+of the file.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    So in Example [eftInt], eftInt and eftIntFB will be put in the+    same Rec, even though their 'main' RHSs are both non-recursive.++    We must also include inactive rules, so that their free vars+    remain in scope.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to a stable unfolding+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Self-recursive rules] in GHC.Core.Opt.Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.+Hence the transitive rule_fv_env stuff described in+Note [Rules and  loop breakers].++------------------------------------------------------------+Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Join points and unfoldings/rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let j2 y = blah+   let j x = j2 (x+x)+       {-# INLINE [2] j #-}+   in case e of { A -> j 1; B -> ...; C -> j 2 }++Before j is inlined, we'll have occurrences of j2 in+both j's RHS and in its stable unfolding.  We want to discover+j2 as a join point.  So we must do the adjustRhsUsage thing+on j's RHS.  That's why we pass mb_join_arity to calcUnfolding.++Aame with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+  let k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 y = j y #-}+      k x y = x + 2 * y+  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }++We identify k as a join point, and we want j to be a join point too.+Without the RULE it would be, and we don't want the RULE to mess it+up.  So provided the join-point arity of k matches the args of the+rule we can allow the tail-cal info from the RHS of the rule to+propagate.++* Wrinkle for Rec case. In the recursive case we don't know the+  join-point arity in advance, when calling occAnalUnfolding and+  occAnalRules.  (See makeNode.)  We don't want to pass Nothing,+  because then a recursive joinrec might lose its join-poin-hood+  when SpecConstr adds a RULE.  So we just make do with the+  *current* join-poin-hood, stored in the Id.++  In the non-recursive case things are simple: see occAnalNonRecBind++* Wrinkle for RULES.  Suppose the example was a bit different:+      let j :: Int -> Int+          j y = 2 * y+          k :: Int -> Int -> Int+          {-# RULES "SPEC k 0" k 0 = j #-}+          k x y = x + 2 * y+      in ...+  If we eta-expanded the rule all would be well, but as it stands the+  one arg of the rule don't match the join-point arity of 2.++  Conceivably we could notice that a potential join point would have+  an "undersaturated" rule and account for it. This would mean we+  could make something that's been specialised a join point, for+  instance. But local bindings are rarely specialised, and being+  overly cautious about rules only costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++  This appears to be very rare in practice. TODO Perhaps we should gather+  statistics to be sure.++Note [Unfoldings and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We assume that anything in an unfolding occurs multiple times, since+unfoldings are often copied (that's the whole point!). But we still+need to track tail calls for the purpose of finding join points.+++------------------------------------------------------------+Note [Adjusting right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point; and+  b) call 'markAllNonTail' *unless* the binding is for a join point.++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamOrRhs' must+return the unadjusted 'UsageDetails', to be adjusted by 'adjustRhsUsage' once+join-point-hood has been decided.++Thus the overall sequence taking place in 'occAnalNonRecBind' and+'occAnalRecBind' is as follows:++  1. Call 'occAnalLamOrRhs' to find usage information for the RHS.+  2. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+  3. Call 'adjustRhsUsage' accordingly. (Done as part of 'tagRecBinders' when+     recursive.)++(In the recursive case, this logic is spread between 'makeNode' and+'occAnalRec'.)+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind :: OccEnv           -- The incoming OccEnv+            -> TopLevelFlag+            -> ImpRuleEdges+            -> CoreBind+            -> UsageDetails             -- Usage details of scope+            -> (UsageDetails,           -- Of the whole let(rec)+                [CoreBind])++occAnalBind env lvl top_env (NonRec binder rhs) body_usage+  = occAnalNonRecBind env lvl top_env binder rhs body_usage+occAnalBind env lvl top_env (Rec pairs) body_usage+  = occAnalRecBind env lvl top_env pairs body_usage++-----------------+occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr+                  -> UsageDetails -> (UsageDetails, [CoreBind])+occAnalNonRecBind env lvl imp_rule_edges bndr rhs body_usage+  | isTyVar bndr      -- A type let; we don't gather usage info+  = (body_usage, [NonRec bndr rhs])++  | not (bndr `usedIn` body_usage)    -- It's not mentioned+  = (body_usage, [])++  | otherwise                   -- It's mentioned in the body+  = (body_usage' `andUDs` rhs_usage, [NonRec final_bndr rhs'])+  where+    (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr+    final_bndr = tagged_bndr `setIdUnfolding` unf'+                             `setIdSpecialisation` mkRuleInfo rules'+    rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds++    -- Get the join info from the *new* decision+    -- See Note [Join points and unfoldings/rules]+    mb_join_arity = willBeJoinId_maybe tagged_bndr+    is_join_point = isJust mb_join_arity++    --------- Right hand side ---------+    env1 | is_join_point    = env  -- See Note [Join point RHSs]+         | certainly_inline = env  -- See Note [Cascading inlines]+         | otherwise        = rhsCtxt env++    -- See Note [Sources of one-shot information]+    rhs_env = env1 { occ_one_shots = argOneShots dmd }+    (rhs_uds, rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs++    --------- Unfolding ---------+    -- See Note [Unfoldings and join points]+    unf = idUnfolding bndr+    (unf_uds, unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf++    --------- Rules ---------+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    rules_w_uds  = occAnalRules rhs_env mb_join_arity bndr+    rules'       = map fstOf3 rules_w_uds+    imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)+         -- imp_rule_uds: consider+         --     h = ...+         --     g = ...+         --     RULE map g = h+         -- Then we want to ensure that h is in scope everwhere+         -- that g is (since the RULE might turn g into h), so+         -- we make g mention h.++    rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds++    ----------+    occ = idOccInfo tagged_bndr+    certainly_inline -- See Note [Cascading inlines]+      = case occ of+          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }+            -> active && not_stable+          _ -> False++    dmd        = idDemandInfo bndr+    active     = isAlwaysActive (idInlineActivation bndr)+    not_stable = not (isStableUnfolding (idUnfolding bndr))++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> (UsageDetails, [CoreBind])+-- For a recursive group, we+--      * occ-analyse all the RHSs+--      * compute strongly-connected components+--      * feed those components to occAnalRec+-- See Note [Recursive bindings: the grand plan]+occAnalRecBind env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec rhs_env lvl) (body_usage, []) sccs+  where+    sccs :: [SCC Details]+    sccs = {-# SCC "occAnalBind.scc" #-}+           stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = {-# SCC "occAnalBind.assoc" #-}+            map (makeNode rhs_env imp_rule_edges bndr_set) pairs++    bndrs    = map fst pairs+    bndr_set = mkVarSet bndrs+    rhs_env  = env `addInScope` bndrs+++-----------------------------+occAnalRec :: OccEnv -> TopLevelFlag+           -> SCC Details+           -> (UsageDetails, [CoreBind])+           -> (UsageDetails, [CoreBind])++        -- The NonRec case is just like a Let (NonRec ...) above+occAnalRec _ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs+                                 , nd_uds = rhs_uds, nd_rhs_bndrs = rhs_bndrs }))+           (body_uds, binds)+  | not (bndr `usedIn` body_uds)+  = (body_uds, binds)           -- See Note [Dead code]++  | otherwise                   -- It's mentioned in the body+  = (body_uds' `andUDs` rhs_uds',+     NonRec tagged_bndr rhs : binds)+  where+    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr+    rhs_uds'   = adjustRhsUsage NonRecursive (willBeJoinId_maybe tagged_bndr)+                                rhs_bndrs rhs_uds++        -- The Rec case is the interesting one+        -- See Note [Recursive bindings: the grand plan]+        -- See Note [Loop breaking]+occAnalRec env lvl (CyclicSCC details_s) (body_uds, binds)+  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds+  = (body_uds, binds)                   -- See Note [Dead code]++  | otherwise   -- At this point we always build a single Rec+  = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)+    (final_uds, Rec pairs : binds)++  where+    bndrs      = map nd_bndr details_s+    all_simple = all nd_simple details_s++    ------------------------------+    -- Make the nodes for the loop-breaker analysis+    -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LetrecNode]+    (final_uds, loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s++    ------------------------------+    active_rule_fvs :: VarSet+    active_rule_fvs = mapUnionVarSet nd_active_rule_fvs details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | all_simple = reOrderNodes   0 active_rule_fvs loop_breaker_nodes []+          | otherwise  = loopBreakNodes 0 active_rule_fvs loop_breaker_nodes []+          -- In the common case when all are "simple" (no rules at all)+          -- the loop_breaker_nodes will include all the scope edges+          -- so a SCC computation would yield a single CyclicSCC result;+          -- and reOrderNodes deals with exactly that case.+          -- Saves a SCC analysis in a common case+++{- *********************************************************************+*                                                                      *+                Loop breaking+*                                                                      *+********************************************************************* -}++{- Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does+loop-breaking on each CyclicSCC of the original program:++* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC++* loopBreakNodes: Do SCC analysis on it++* reOrderNodes: For each CyclicSCC, pick a loop breaker+    * Delete edges to that loop breaker+    * Do another SCC analysis on that reduced SCC+    * Repeat++To form the loop-breaker graph, we construct a new set of Nodes, the+"loop-breaker nodes", with the same details but different edges, the+"loop-breaker edges".  The loop-breaker nodes have both more and fewer+dependencies than the scope edges:++  More edges:+     If f calls g, and g has an active rule that mentions h then+     we add an edge from f -> h.  See Note [Rules and loop breakers].++  Fewer edges: we only include dependencies+     * only on /active/ rules,+     * on rule /RHSs/ (not LHSs)++The scope edges, by contrast, must be much more inclusive.++The nd_simple flag tracks the common case when a binding has no RULES+at all, in which case the loop-breaker edges will be identical to the+scope edges.++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note [inl_fvs]+~~~~~~~~~~~~~~+Note that the loop-breaker graph includes edges for occurrences in+/both/ the RHS /and/ the stable unfolding.  Consider this, which actually+occurred when compiling BooleanFormula.hs in GHC:++  Rec { lvl1 = go+      ; lvl2[StableUnf = go] = lvl1+      ; go = ...go...lvl2... }++From the point of view of infinite inlining, we need only these edges:+   lvl1 :-> go+   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining+   go   :-> go, lvl2++But the danger is that, lacking any edge to lvl1, we'll put it at the+end thus+  Rec { lvl2[ StableUnf = go] = lvl1+      ; go[LoopBreaker] = ...go...lvl2... }+      ; lvl1[Occ=Once]  = go }++And now the Simplifer will try to use PreInlineUnconditionally on lvl1+(which occurs just once), but because it is last we won't actually+substitute in lvl2.  Sigh.++To avoid this possiblity, we include edges from lvl2 to /both/ its+stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in+makeNode.  Maybe we could be more clever, but it's very much a corner+case.++Note [Weak loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is a last nasty wrinkle.  Suppose we have++    Rec { f = f_rhs+          RULE f [] = g++          h = h_rhs+          g = h+          ...more...+    }++Remember that we simplify the RULES before any RHS (see Note+[Rules are visible in their own rec group] above).++So we must *not* postInlineUnconditionally 'g', even though+its RHS turns out to be trivial.  (I'm assuming that 'g' is+not chosen as a loop breaker.)  Why not?  Because then we+drop the binding for 'g', which leaves it out of scope in the+RULE!++Here's a somewhat different example of the same thing+    Rec { q = r+        ; r = ...p...+        ; p = p_rhs+          RULE p [] = q }+Here the RULE is "below" q, but we *still* can't postInlineUnconditionally+q, because the RULE for p is active throughout.  So the RHS of r+might rewrite to     r = ...q...+So q must remain in scope in the output program!++We "solve" this by:++    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+    iff q is a mentioned in the RHS of an active RULE in the Rec group++A normal "strong" loop breaker has IAmLoopBreaker False.  So:++                                Inline  postInlineUnconditionally+strong   IAmLoopBreaker False    no      no+weak     IAmLoopBreaker True     yes     no+         other                   yes     yes++The **sole** reason for this kind of loop breaker is so that+postInlineUnconditionally does not fire.  Ugh.++Annoyingly, since we simplify the rules *first* we'll never inline+q into p's RULE.  That trivial binding for q will hang around until+we discard the rule.  Yuk.  But it's rare.++ Note [Rules and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we form the loop-breaker graph (Step 4 in Note [Recursive+bindings: the grand plan]), we must be careful about RULEs.++For a start, we want a loop breaker to cut every cycle, so inactive+rules play no part; we need only consider /active/ rules.+See Note [Finding rule RHS free vars]++The second point is more subtle.  A RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in GHC.Core.Opt.Simplify++Hence, if+    f's RHS (or its stable unfolding if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules]. So out plan is this:++   Take the free variables of f's RHS, and augment it with all the+   variables reachable by a transitive sequence RULES from those+   starting points.++That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.+Wrinkles:++* We only consider /active/ rules. See Note [Finding rule RHS free vars]++* We need only consider free vars that are also binders in this Rec+  group.  See also Note [Finding rule RHS free vars]++* We only consider variables free in the *RHS* of the rule, in+  contrast to the way we build the Rec group in the first place (Note+  [Rule dependency info])++* Why "transitive sequence of rules"?  Because active rules apply+  unconditionally, without checking loop-breaker-ness.+ See Note [Loop breaker dependencies].++Note [Finding rule RHS free vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this real example from Data Parallel Haskell+     tagZero :: Array Int -> Array Tag+     {-# INLINE [1] tagZeroes #-}+     tagZero xs = pmap (\x -> fromBool (x==0)) xs++     {-# RULES "tagZero" [~1] forall xs n.+         pmap fromBool <blah blah> = tagZero xs #-}+So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.+However, tagZero can only be inlined in phase 1 and later, while+the RULE is only active *before* phase 1.  So there's no problem.++To make this work, we look for the RHS free vars only for+*active* rules. That's the reason for the occ_rule_act field+of the OccEnv.++Note [loopBreakNodes]+~~~~~~~~~~~~~~~~~~~~~+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++type Binding = (Id,CoreExpr)++-- See Note [loopBreakNodes]+loopBreakNodes :: Int+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LetrecNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+-- See Note [loopBreakNodes]+loopBreakNodes depth weak_fvs nodes binds+  = -- pprTrace "loopBreakNodes" (ppr nodes) $+    go (stronglyConnCompFromEdgedVerticesUniqR nodes)+  where+    go []         = binds+    go (scc:sccs) = loop_break_scc scc (go sccs)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds+          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> [LetrecNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds+reOrderNodes depth weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen+    --                               , text "chosen" <+> ppr chosen_nodes ]) $+    loopBreakNodes new_depth weak_fvs unchosen $+    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (nd_score (node_payload node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++nodeBinding :: (Id -> Id) -> LetrecNode -> Binding+nodeBinding set_id_occ (node_payload -> ND { nd_bndr = bndr, nd_rhs = rhs})+  = (set_id_occ bndr, rhs)++mk_loop_breaker :: Id -> Id+mk_loop_breaker bndr+  = bndr `setIdOccInfo` occ'+  where+    occ'      = strongLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> Id -> Id+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs bndr+  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'+  | otherwise                  = bndr+  where+    occ'      = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool             -- True <=> Too many iterations,+                                      --          so approximate+                  -> NodeScore            -- Best score so far+                  -> [LetrecNode]       -- Nodes with this score+                  -> [LetrecNode]       -- Nodes with higher scores+                  -> [LetrecNode]       -- Unprocessed nodes+                  -> ([LetrecNode], [LetrecNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = nd_score (node_payload node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakders is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++type LetrecNode = Node Unique Details  -- Node comes from Digraph+                                       -- The Unique key is gotten from the Id+data Details+  = ND { nd_bndr :: Id          -- Binder++       , nd_rhs  :: CoreExpr    -- RHS, already occ-analysed++       , nd_rhs_bndrs :: [CoreBndr] -- Outer lambdas of RHS+                                    -- INVARIANT: (nd_rhs_bndrs nd, _) ==+                                    --              collectBinders (nd_rhs nd)++       , nd_uds  :: UsageDetails  -- Usage from RHS, and RULES, and stable unfoldings+                                  -- ignoring phase (ie assuming all are active)+                                  -- See Note [Forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_simple :: Bool      -- True iff this binding has no local RULES+                                -- If all nodes are simple we don't need a loop-breaker+                                -- dep-anal before reconstructing.++       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                        -- in the RHS of an active rule for this bndr++       , nd_score :: NodeScore+  }++instance Outputable Details where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr (nd_uds nd)+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "simple =" <+> ppr (nd_simple nd)+                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)+                  , text "score =" <+> ppr (nd_score nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode env imp_rule_edges bndr_set (bndr, rhs)+  = DigraphNode { node_payload      = details+                , node_key          = varUnique bndr+                , node_dependencies = nonDetKeysUniqSet scope_fvs }+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.+  where+    details = ND { nd_bndr            = bndr'+                 , nd_rhs             = rhs'+                 , nd_rhs_bndrs       = bndrs'+                 , nd_uds             = scope_uds+                 , nd_inl             = inl_fvs+                 , nd_simple          = null rules_w_uds && null imp_rule_info+                 , nd_active_rule_fvs = active_rule_fvs+                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }++    bndr' = bndr `setIdUnfolding`      unf'+                 `setIdSpecialisation` mkRuleInfo rules'++    inl_uds = rhs_uds `andUDs` unf_uds+    scope_uds = inl_uds `andUDs` rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    scope_fvs = udFreeVars bndr_set scope_uds+    -- scope_fvs: all occurrences from this binder: RHS, unfolding,+    --            and RULES, both LHS and RHS thereof, active or inactive++    inl_fvs  = udFreeVars bndr_set inl_uds+    -- inl_fvs: vars that would become free if the function was inlined.+    -- We conservatively approximate that by thefree vars from the RHS+    -- and the unfolding together.+    -- See Note [inl_fvs]++    mb_join_arity = isJoinId_maybe bndr+    -- Get join point info from the *current* decision+    -- We don't know what the new decision will be!+    -- Using the old decision at least allows us to+    -- preserve existing join point, even RULEs are added+    -- See Note [Join points and unfoldings/rules]++    --------- Right hand side ---------+    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    -- Do not use occAnalRhs because we don't yet know+    -- the final answer for mb_join_arity+    (bndrs, body)            = collectBinders rhs+    rhs_env                  = rhsCtxt env+    (rhs_uds, bndrs', body') = occAnalLamOrRhs rhs_env bndrs body+    rhs'                     = mkLams bndrs' body'++    --------- Unfolding ---------+    -- See Note [Unfoldings and join points]+    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness+                               -- here because that is what we are setting!+    (unf_uds, unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf++    --------- IMP-RULES --------+    is_active     = occ_rule_act env :: Activation -> Bool+    imp_rule_info = lookupImpRules imp_rule_edges bndr+    imp_rule_uds  = impRulesScopeUsage imp_rule_info+    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info++    --------- All rules --------+    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = occAnalRules rhs_env mb_join_arity bndr+    rules'      = map fstOf3 rules_w_uds++    rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds++    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds+    add_active_rule (rule, _, rhs_uds) fvs+      | is_active (ruleActivation rule)+      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs+      | otherwise+      = fvs+++mkLoopBreakerNodes :: OccEnv -> TopLevelFlag+                   -> UsageDetails   -- for BODY of let+                   -> [Details]+                   -> (UsageDetails, -- adjusted+                       [LetrecNode])+-- See Note [Choosing loop breakers]+-- This function primarily creates the Nodes for the+-- loop-breaker SCC analysis.  More specifically:+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   d) adjust each RHS's usage details according to+--      the binder's (new) shotness and join-point-hood+mkLoopBreakerNodes env lvl body_uds details_s+  = (final_uds, zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')+  where+    (final_uds, bndrs')+       = tagRecBinders lvl body_uds+            [ (bndr, uds, rhs_bndrs)+            | ND { nd_bndr = bndr, nd_uds = uds, nd_rhs_bndrs = rhs_bndrs }+                 <- details_s ]++    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr+      = DigraphNode { node_payload      = new_nd+                    , node_key          = varUnique old_bndr+                    , node_dependencies = nonDetKeysUniqSet lb_deps }+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+      where+        new_nd = nd { nd_bndr = new_bndr, nd_score = score }+        score  = nodeScore env new_bndr lb_deps nd+        lb_deps = extendFvs_ rule_fv_env inl_fvs+        -- See Note [Loop breaker dependencies]++    rule_fv_env :: IdEnv IdSet+    -- Maps a variable f to the variables from this group+    --      reachable by a sequence of RULES starting with f+    -- Domain is *subset* of bound vars (others have no rule fvs)+    -- See Note [Finding rule RHS free vars]+    -- Why transClosureFV?  See Note [Loop breaker dependencies]+    rule_fv_env = transClosureFV $ mkVarEnv $+                  [ (b, rule_fvs)+                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+                  , not (isEmptyVarSet rule_fvs) ]++{- Note [Loop breaker dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop breaker dependencies of x in a recursive+group { f1 = e1; ...; fn = en } are:++- The "inline free variables" of f: the fi free in+  f's stable unfolding and RHS; see Note [inl_fvs]++- Any fi reachable from those inline free variables by a sequence+  of RULE rewrites.  Remember, rule rewriting is not affected+  by fi being a loop breaker, so we have to take the transitive+  closure in case f is the only possible loop breaker in the loop.++  Hence rule_fv_env.  We need only account for /active/ rules.+-}++------------------------------------------+nodeScore :: OccEnv+          -> Id        -- Binder with new occ-info+          -> VarSet    -- Loop-breaker dependencies+          -> Details+          -> NodeScore+nodeScore env new_bndr lb_deps+          (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })++  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has+  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- old_unf+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding old_unf+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    -- is_lb: see Note [Loop breakers, node scoring, and stability]+    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)++    old_unf = realIdUnfolding old_bndr+    can_unfold = canUnfold old_unf+    rhs        = case old_unf of+                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                     | isStableSource src+                     -> unf_rhs+                   _ -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case old_unf of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs+++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app _          = False++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (#12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore++************************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+************************************************************************+-}++occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity+           -> CoreExpr   -- RHS+           -> (UsageDetails, CoreExpr)+occAnalRhs env is_rec mb_join_arity rhs+  = case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') ->+    let final_bndrs | isRec is_rec = bndrs'+                    | otherwise    = markJoinOneShots mb_join_arity bndrs'+               -- For a /non-recursive/ join point we can mark all+               -- its join-lambda as one-shot; and it's a good idea to do so++        -- Final adjustment+        rhs_usage = adjustRhsUsage is_rec mb_join_arity final_bndrs body_usage++    in (rhs_usage, mkLams final_bndrs body') }+  where+    (bndrs, body) = collectBinders rhs++occAnalUnfolding :: OccEnv+                 -> RecFlag+                 -> Maybe JoinArity   -- See Note [Join points and unfoldings/rules]+                 -> Unfolding+                 -> (UsageDetails, Unfolding)+-- Occurrence-analyse a stable unfolding;+-- discard a non-stable one altogether.+occAnalUnfolding env is_rec mb_join_arity unf+  = case unf of+      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })+        | isStableSource src -> (markAllMany usage, unf')+              -- markAllMany: see Note [Occurrences in stable unfoldings]+        | otherwise          -> (emptyDetails,      unf)+              -- For non-Stable unfoldings we leave them undisturbed, but+              -- don't count their usage because the simplifier will discard them.+              -- We leave them undisturbed because nodeScore uses their size info+              -- to guide its decisions.  It's ok to leave un-substituted+              -- expressions in the tree because all the variables that were in+              -- scope remain in scope; there is no cloning etc.+        where+          (usage, rhs') = occAnalRhs env is_rec mb_join_arity rhs++          unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]+               | otherwise         = unf { uf_tmpl = rhs' }++      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+        -> ( final_usage, unf { df_args = args' } )+        where+          env'            = env `addInScope` bndrs+          (usage, args')  = occAnalList env' args+          final_usage     = markAllManyNonTail (delDetailsList usage bndrs)++      unf -> (emptyDetails, unf)++occAnalRules :: OccEnv+             -> Maybe JoinArity  -- See Note [Join points and unfoldings/rules]+             -> Id               -- Get rules from here+             -> [(CoreRule,      -- Each (non-built-in) rule+                  UsageDetails,  -- Usage details for LHS+                  UsageDetails)] -- Usage details for RHS+occAnalRules env mb_join_arity bndr+  = map occ_anal_rule (idCoreRules bndr)+  where+    occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+      = (rule', lhs_uds', rhs_uds')+      where+        env' = env `addInScope` bndrs+        rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]+              | otherwise         = rule { ru_args = args', ru_rhs = rhs' }++        (lhs_uds, args') = occAnalList env' args+        lhs_uds'         = markAllManyNonTail $+                           lhs_uds `delDetailsList` bndrs++        (rhs_uds, rhs') = occAnal env' rhs+                            -- Note [Rules are extra RHSs]+                            -- Note [Rule dependency info]+        rhs_uds' = markAllNonTailIf (not exact_join) $+                   markAllMany                             $+                   rhs_uds `delDetailsList` bndrs++        exact_join = exactJoin mb_join_arity args+                     -- See Note [Join points and unfoldings/rules]++    occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails)++{- Note [Join point RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   x = e+   join j = Just x++We want to inline x into j right away, so we don't want to give+the join point a RhsCtxt (#14137).  It's not a huge deal, because+the FloatIn pass knows to float into join point RHSs; and the simplifier+does not float things out of join point RHSs.  But it's a simple, cheap+thing to do.  See #14137.++Note [Occurrences in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f p = BIG+    {-# INLINE g #-}+    g y = not (f y)+where this is the /only/ occurrence of 'f'.  So 'g' will get a stable+unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule+or inlining f) so that it doesn't mention 'f' any more.  Now the last+remaining call to f is in g's Stable unfolding. But, even though there+is only one syntactic occurrence of f, we do /not/ want to do+preinlineUnconditionally here!++The INLINE pragma says "inline exactly this RHS"; perhaps the+programmer wants to expose that 'not', say. If we inline f that will make+the Stable unfoldign big, and that wasn't what the programmer wanted.++Another way to think about it: if we inlined g as-is into multiple+call sites, now there's be multiple calls to f.++Bottom line: treat all occurrences in a stable unfolding as "Many".++Note [Unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally unfoldings and rules are already occurrence-analysed, so we+don't want to reconstruct their trees; we just want to analyse them to+find how they use their free variables.++EXCEPT if there is a binder-swap going on, in which case we do want to+produce a new tree.++So we have a fast-path that keeps the old tree if the occ_bs_env is+empty.   This just saves a bit of allocation and reconstruction; not+a big deal.++Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an rhsCtxt for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"+then the simplifier iterates indefinitely:+        x = f y+        k = Just x   -- We decide that k is 'certainly_inline'+        v = ...k...  -- but preInlineUnconditionally doesn't inline it+inline ==>+        k = Just (f y)+        v = ...k...+float ==>+        x1 = f y+        k = Just x1+        v = ...k...++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnalList :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])+occAnalList _   []     = (emptyDetails, [])+occAnalList env (e:es) = case occAnal env e      of { (uds1, e')  ->+                         case occAnalList env es of { (uds2, es') ->+                         (uds1 `andUDs` uds2, e' : es') } }++occAnal :: OccEnv+        -> CoreExpr+        -> (UsageDetails,       -- Gives info only about the "interesting" Ids+            CoreExpr)++occAnal _   expr@(Type _) = (emptyDetails,         expr)+occAnal _   expr@(Lit _)  = (emptyDetails,         expr)+occAnal env expr@(Var _)  = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ (Coercion co)+  = (addManyOccs emptyDetails (coVarsOfCo co), Coercion co)+        -- See Note [Gather occurrences of coercion variables]++{-+Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, so that+we can sort them into the right place when doing dependency analysis.+-}++occAnal env (Tick tickish body)+  | SourceNote{} <- tickish+  = (usage, Tick tickish body')+                  -- SourceNotes are best-effort; so we just proceed as usual.+                  -- If we drop a tick due to the issues described below it's+                  -- not the end of the world.++  | tickish `tickishScopesLike` SoftScope+  = (markAllNonTail usage, Tick tickish body')++  | Breakpoint _ _ ids <- tickish+  = (usage_lam `andUDs` foldr addManyOcc emptyDetails ids, Tick tickish body')+    -- never substitute for any of the Ids in a Breakpoint++  | otherwise+  = (usage_lam, Tick tickish body')+  where+    !(usage,body') = occAnal env body+    -- for a non-soft tick scope, we can inline lambdas only+    usage_lam = markAllNonTail (markAllInsideLam usage)+                  -- TODO There may be ways to make ticks and join points play+                  -- nicer together, but right now there are problems:+                  --   let j x = ... in tick<t> (j 1)+                  -- Making j a join point may cause the simplifier to drop t+                  -- (if the tick is put into the continuation). So we don't+                  -- count j 1 as a tail call.+                  -- See #14242.++occAnal env (Cast expr co)+  = case occAnal env expr of { (usage, expr') ->+    let usage1 = markAllManyNonTailIf (isRhsEnv env) usage+          -- usage1: if we see let x = y `cast` co+          -- then mark y as 'Many' so that we don't+          -- immediately inline y again.+        usage2 = addManyOccs usage1 (coVarsOfCo co)+          -- usage2: see Note [Gather occurrences of coercion variables]+    in (markAllNonTail usage2, Cast expr' co)+    }++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++-- Ignore type variables altogether+--   (a) occurrences inside type lambdas only not marked as InsideLam+--   (b) type variables not in environment++occAnal env (Lam x body)+  | isTyVar x+  = case occAnal env body of { (body_usage, body') ->+    (markAllNonTail body_usage, Lam x body')+    }++{- Note [Occurrence analysis for lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For value lambdas we do a special hack.  Consider+     (\x. \y. ...x...)+If we did nothing, x is used inside the \y, so would be marked+as dangerous to dup.  But in the common case where the abstraction+is applied to two arguments this is over-pessimistic, which delays+inlining x, which forces more simplifier iterations.++So instead, we just mark each binder with its occurrence info in the+*body* of the multiple lambda.  Then, the simplifier is careful when+partially applying lambdas. See the calls to zapLamBndrs in+  GHC.Core.Opt.Simplify.simplExprF1+  GHC.Core.SimpleOpt.simple_app+-}++occAnal env expr@(Lam _ _)+  = -- See Note [Occurrence analysis for lambda binders]+    case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->+    let+        expr'       = mkLams tagged_bndrs body'+        usage1      = markAllNonTail usage+        one_shot_gp = all isOneShotBndr tagged_bndrs+        final_usage = markAllInsideLamIf (not one_shot_gp) usage1+    in+    (final_usage, expr') }+  where+    (bndrs, body) = collectBinders expr++occAnal env (Case scrut bndr ty alts)+  = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') ->+    let alt_env = addBndrSwap scrut' bndr $+                  env { occ_encl = OccVanilla } `addInScope` [bndr]+    in+    case mapAndUnzip (occAnalAlt alt_env) alts of { (alts_usage_s, alts')   ->+    let+        alts_usage  = foldr orUDs emptyDetails alts_usage_s+        (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr+        total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1+                        -- Alts can have tail calls, but the scrutinee can't+    in+    total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}++occAnal env (Let bind body)+  = case occAnal (env `addInScope` bindersOf bind)+                 body                    of { (body_usage, body') ->+    case occAnalBind env NotTopLevel+                     noImpRuleEdges bind+                     body_usage          of { (final_usage, new_binds) ->+       (final_usage, mkLets new_binds body') }}++occAnalArgs :: OccEnv -> [CoreExpr] -> [OneShots] -> (UsageDetails, [CoreExpr])+occAnalArgs _ [] _+  = (emptyDetails, [])++occAnalArgs env (arg:args) one_shots+  | isTypeArg arg+  = case occAnalArgs env args one_shots of { (uds, args') ->+    (uds, arg:args') }++  | otherwise+  = case argCtxt env one_shots           of { (arg_env, one_shots') ->+    case occAnal arg_env arg             of { (uds1, arg') ->+    case occAnalArgs env args one_shots' of { (uds2, args') ->+    (uds1 `andUDs` uds2, arg':args') }}}++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])+           -> (UsageDetails, Expr CoreBndr)+-- Naked variables (not applied) end up here too+occAnalApp env (Var fun, args, ticks)+  -- Account for join arity of runRW# continuation+  -- See Note [Simplification of runRW#]+  --+  -- NB: Do not be tempted to make the next (Var fun, args, tick)+  --     equation into an 'otherwise' clause for this equation+  --     The former has a bang-pattern to occ-anal the args, and+  --     we don't want to occ-anal them twice in the runRW# case!+  --     This caused #18296+  | fun `hasKey` runRWKey+  , [t1, t2, arg]  <- args+  , let (usage, arg') = occAnalRhs env NonRecursive (Just 1) arg+  = (usage, mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])++occAnalApp env (Var fun_id, args, ticks)+  = (all_uds, mkTicks ticks $ mkApps fun' args')+  where+    (fun', fun_id') = lookupBndrSwap env fun_id++    fun_uds = mkOneOcc fun_id' int_cxt n_args+       -- NB: fun_uds is computed for fun_id', not fun_id+       -- See (BS1) in Note [The binder-swap substitution]++    all_uds = fun_uds `andUDs` final_args_uds++    !(args_uds, args') = occAnalArgs env args one_shots+    !final_args_uds = markAllNonTail                        $+                      markAllInsideLamIf (isRhsEnv env && is_exp) $+                      args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    n_val_args = valArgCount args+    n_args     = length args+    int_cxt    = case occ_encl env of+                   OccScrut -> IsInteresting+                   _other   | n_val_args > 0 -> IsInteresting+                            | otherwise      -> NotInteresting++    is_exp     = isExpandableApp fun_id n_val_args+        -- See Note [CONLIKE pragma] in GHC.Types.Basic+        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs++    one_shots  = argsOneShots (idStrictness fun_id) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = (markAllNonTail (fun_uds `andUDs` args_uds),+     mkTicks ticks $ mkApps fun' args')+  where+    !(fun_uds, fun') = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexs like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some True items+        -- onto the context stack.+    !(args_uds, args') = occAnalArgs env args []+++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C1(C1(L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demanand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demanand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, because it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++occAnalLamOrRhs :: OccEnv -> [CoreBndr] -> CoreExpr+                -> (UsageDetails, [CoreBndr], CoreExpr)+-- Tags the returned binders with their OccInfo, but does+-- not do any markInsideLam to the returned usage details+occAnalLamOrRhs env [] body+  = case occAnal env body of (body_usage, body') -> (body_usage, [], body')+      -- RHS of thunk or nullary join point++occAnalLamOrRhs env (bndr:bndrs) body+  | isTyVar bndr+  = -- Important: Keep the environment so that we don't inline into an RHS like+    --   \(@ x) -> C @x (f @x)+    -- (see the beginning of Note [Cascading inlines]).+    case occAnalLamOrRhs env bndrs body of+      (body_usage, bndrs', body') -> (body_usage, bndr:bndrs', body')++occAnalLamOrRhs env binders body+  = case occAnal env_body body of { (body_usage, body') ->+    let+        (final_usage, tagged_binders) = tagLamBinders body_usage binders'+                      -- Use binders' to put one-shot info on the lambdas+    in+    (final_usage, tagged_binders, body') }+  where+    env1 = env `addInScope` binders+    (env_body, binders') = oneShotGroup env1 binders++occAnalAlt :: OccEnv+           -> CoreAlt -> (UsageDetails, Alt IdWithOccInfo)+occAnalAlt env (Alt con bndrs rhs)+  = case occAnal (env `addInScope` bndrs) rhs of { (rhs_usage1, rhs1) ->+    let+      (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs+    in                          -- See Note [Binders in case alternatives]+    (alt_usg, Alt con tagged_bndrs rhs1) }++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active+           , occ_rule_act   :: Activation -> Bool  -- Which rules are active+             -- See Note [Finding rule RHS free vars]++           -- See Note [The binder-swap substitution]+           -- If  x :-> (y, co)  is in the env,+           -- then please replace x by (y |> sym mco)+           -- Invariant of course: idType x = exprType (y |> sym mco)+           , occ_bs_env  :: VarEnv (OutId, MCoercion)+           , occ_bs_rng  :: VarSet   -- Vars free in the range of occ_bs_env+                   -- Domain is Global and Local Ids+                   -- Range is just Local Ids+    }+++-----------------------------+-- OccEncl is used to control whether to inline into constructor arguments+-- For example:+--      x = (p,q)               -- Don't inline p or q+--      y = /\a -> (p a, q a)   -- Still don't inline p or q+--      z = f (p,q)             -- Do inline p,q; it may make a rule fire+-- So OccEncl tells enough about the context to know what to do when+-- we encounter a constructor application or PAP.+--+-- OccScrut is used to set the "interesting context" field of OncOcc++data OccEncl+  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda+                   -- Don't inline into constructor args here++  | OccScrut       -- Scrutintee of a case+                   -- Can inline into constructor args++  | OccVanilla     -- Argument of function, body of lambda, etc+                   -- Do inline into constructor args here++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccScrut   = text "occScrut"+  ppr OccVanilla = text "occVanilla"++-- See note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: OccEnv+initOccEnv+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []++                 -- To be conservative, we say that all+                 -- inlines and rules are active+           , occ_unf_act   = \_ -> True+           , occ_rule_act  = \_ -> True++           , occ_bs_env = emptyVarEnv+           , occ_bs_rng = emptyVarSet }++noBinderSwaps :: OccEnv -> Bool+noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env++scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv+scrutCtxt env alts+  | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }+  | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }+  where+    interesting_alts = case alts of+                         []    -> False+                         [alt] -> not (isDefaultAlt alt)+                         _     -> True+     -- 'interesting_alts' is True if the case has at least one+     -- non-default alternative.  That in turn influences+     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!++rhsCtxt :: OccEnv -> OccEnv+rhsCtxt env = env { occ_encl = OccRhs, occ_one_shots = [] }++argCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])+argCtxt env []+  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])+argCtxt env (one_shots:one_shots_s)+  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of+                                          OccRhs -> True+                                          _      -> False++addInScope :: OccEnv -> [Var] -> OccEnv+-- See Note [The binder-swap substitution]+addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs+  | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }+  | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }++oneShotGroup :: OccEnv -> [CoreBndr]+             -> ( OccEnv+                , [CoreBndr] )+        -- The result binders have one-shot-ness set that they might not have had originally.+        -- This happens in (build (\c n -> e)).  Here the occurrence analyser+        -- linearity context knows that c,n are one-shot, and it records that fact in+        -- the binder. This is useful to guide subsequent float-in/float-out transformations++oneShotGroup env@(OccEnv { occ_one_shots = ctxt }) bndrs+  = go ctxt bndrs []+  where+    go ctxt [] rev_bndrs+      = ( env { occ_one_shots = ctxt, occ_encl = OccVanilla }+        , reverse rev_bndrs )++    go [] bndrs rev_bndrs+      = ( env { occ_one_shots = [], occ_encl = OccVanilla }+        , reverse rev_bndrs ++ bndrs )++    go ctxt@(one_shot : ctxt') (bndr : bndrs) rev_bndrs+      | isId bndr = go ctxt' bndrs (bndr': rev_bndrs)+      | otherwise = go ctxt  bndrs (bndr : rev_bndrs)+      where+        bndr' = updOneShotInfo bndr one_shot+               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+               -- one-shot info might be better than what we can infer, e.g.+               -- due to explicit use of the magic 'oneShot' function.+               -- See Note [The oneShot function]+++markJoinOneShots :: Maybe JoinArity -> [Var] -> [Var]+-- Mark the lambdas of a non-recursive join point as one-shot.+-- This is good to prevent gratuitous float-out etc+markJoinOneShots mb_join_arity bndrs+  = case mb_join_arity of+      Nothing -> bndrs+      Just n  -> go n bndrs+ where+   go 0 bndrs  = bndrs+   go _ []     = [] -- This can legitimately happen.+                    -- e.g.    let j = case ... in j True+                    -- This will become an arity-1 join point after the+                    -- simplifier has eta-expanded it; but it may not have+                    -- enough lambdas /yet/. (Lint checks that JoinIds do+                    -- have enough lambdas.)+   go n (b:bs) = b' : go (n-1) bs+     where+       b' | isId b    = setOneShotLambda b+          | otherwise = b++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  = env { occ_one_shots = replicate (valArgCount args) OneShotLam ++ ctxt }++--------------------+transClosureFV :: VarEnv VarSet -> VarEnv VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+The "binder swap" transformation swaps occurrence of the+scrutinee of a case for occurrences of the case-binder:++ (1)  case x of b { pi -> ri }+         ==>+      case x of b { pi -> ri[b/x] }++ (2)  case (x |> co) of b { pi -> ri }+        ==>+      case (x |> co) of b { pi -> ri[b |> sym co/x] }++The substitution ri[b/x] etc is done by the occurrence analyser.+See Note [The binder-swap substitution].++There are two reasons for making this swap:++(A) It reduces the number of occurrences of the scrutinee, x.+    That in turn might reduce its occurrences to one, so we+    can inline it and save an allocation.  E.g.+      let x = factorial y in case x of b { I# v -> ...x... }+    If we replace 'x' by 'b' in the alternative we get+      let x = factorial y in case x of b { I# v -> ...b... }+    and now we can inline 'x', thus+      case (factorial y) of b { I# v -> ...b... }++(B) The case-binder b has unfolding information; in the+    example above we know that b = I# v. That in turn allows+    nested cases to simplify.  Consider+       case x of b { I# v ->+       ...(case x of b2 { I# v2 -> rhs })...+    If we replace 'x' by 'b' in the alternative we get+       case x of b { I# v ->+       ...(case b of b2 { I# v2 -> rhs })...+    and now it is trivial to simplify the inner case:+       case x of b { I# v ->+       ...(let b2 = b in rhs)...++    The same can happen even if the scrutinee is a variable+    with a cast: see Note [Case of cast]++The reason for doing these transformations /here in the occurrence+analyser/ is because it allows us to adjust the OccInfo for 'x' and+'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If instead the Simplifier replaces occurrences of x with+    occurrences of b, that will mess up b's occurrence info. That in+    turn might have consequences.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [The binder-swap substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The binder-swap is implemented by the occ_bs_env field of OccEnv.+There are two main pieces:++* Given    case x |> co of b { alts }+  we add [x :-> (b, co)] to the occ_bs_env environment; this is+  done by addBndrSwap.++* Then, at an occurrence of a variable, we look up in the occ_bs_env+  to perform the swap. This is done by lookupBndrSwap.++Some tricky corners:++(BS1) We do the substitution before gathering occurrence info. So in+      the above example, an occurrence of x turns into an occurrence+      of b, and that's what we gather in the UsageDetails.  It's as+      if the binder-swap occurred before occurrence analysis. See+      the computation of fun_uds in occAnalApp.++(BS2) When doing a lookup in occ_bs_env, we may need to iterate,+      as you can see implemented in lookupBndrSwap.  Why?+      Consider   case x of a { 1# -> e1; DEFAULT ->+                 case x of b { 2# -> e2; DEFAULT ->+                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}+      At the first case addBndrSwap will extend occ_bs_env with+          [x :-> a]+      At the second case we occ-anal the scrutinee 'x', which looks up+        'x in occ_bs_env, returning 'a', as it should.+      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding+         occ_bs_env = [x :-> a, a :-> b]+      At the third case we'll again look up 'x' which returns 'a'.+      But we don't want to stop the lookup there, else we'll end up with+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}+      Instead, we want iterate the lookup in addBndrSwap, to give+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}+      This makes a particular difference for case-merge, which works+      only if the scrutinee is the case-binder of the immediately enclosing+      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils+      See #19581 for the bug report that showed this up.++(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,+      and we encounter:+         - \x. blah+           Here we want to delete the x-binding from occ_bs_env++         - \b. blah+           This is harder: we really want to delete all bindings that+           have 'b' free in the range.  That is a bit tiresome to implement,+           so we compromise.  We keep occ_bs_rng, which is the set of+           free vars of rng(occc_bs_env).  If a binder shadows any of these+           variables, we discard all of occ_bs_env.  Safe, if a bit+           brutal.  NB, however: the simplifer de-shadows the code, so the+           next time around this won't happen.++      These checks are implemented in addInScope.++      The occurrence analyser itself does /not/ do cloning. It could, in+      principle, but it'd make it a bit more complicated and there is no+      great benefit. The simplifer uses cloning to get a no-shadowing+      situation, the care-when-shadowing behaviour above isn't needed for+      long.++(BS4) The domain of occ_bs_env can include GlobaIds.  Eg+         case M.foo of b { alts }+      We extend occ_bs_env with [M.foo :-> b].  That's fine.++(BS5) We have to apply the occ_bs_env substitution uniformly,+      including to (local) rules and unfoldings.++Historical note+---------------+We used to do the binder-swap transformation by introducing+a proxy let-binding, thus;++   case x of b { pi -> ri }+      ==>+   case x of b { pi -> let x = b in ri }++But that had two problems:++1. If 'x' is an imported GlobalId, we'd end up with a GlobalId+   on the LHS of a let-binding which isn't allowed.  We worked+   around this for a while by "localising" x, but it turned+   out to be very painful #16296,++2. In CorePrep we use the occurrence analyser to do dead-code+   elimination (see Note [Dead code in CorePrep]).  But that+   occasionally led to an unlifted let-binding+       case x of b { DEFAULT -> let x::Int# = b in ... }+   which disobeys one of CorePrep's output invariants (no unlifted+   let-bindings) -- see #5433.++Doing a substitution (via occ_bs_env) is much better.++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++Note [Zap case binders in proxy bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From the original+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> ...cb... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See #5028.++NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier+doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.++Historical note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+-}++addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv+-- See Note [The binder-swap substitution]+addBndrSwap scrut case_bndr+            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })+  | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) scrut)+  , scrut_var /= case_bndr+      -- Consider: case x of x { ... }+      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop+  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)+        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'+                       `unionVarSet` tyCoVarsOfMCo mco }++  | otherwise+  = env+  where+    get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion)+    get_scrut_var (Var v)           = Just (v, MRefl)+    get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast]+    get_scrut_var _                 = Nothing++    case_bndr' = zapIdOccInfo case_bndr+                 -- See Note [Zap case binders in proxy bindings]++lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)+-- See Note [The binder-swap substitution]+-- Returns an expression of the same type as Id+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr+  = case lookupVarEnv bs_env bndr of {+       Nothing           -> (Var bndr, bndr) ;+       Just (bndr1, mco) ->++    -- Why do we iterate here?+    -- See (BS2) in Note [The binder-swap substitution]+    case lookupBndrSwap env bndr1 of+      (fun, fun_id) -> (add_cast fun mco, fun_id) }++  where+    add_cast fun MRefl    = fun+    add_cast fun (MCo co) = Cast fun (mkSymCo co)+    -- We must switch that 'co' to 'sym co';+    -- see the comment with occ_bs_env+    -- No need to test for isReflCo, because 'co' came from+    -- a (Cast e co) and hence is unlikely to be Refl++{-+************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.+-}++type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage+                -- INVARIANT: never IAmDead+                -- (Deadness is signalled by not being in the map at all)++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_no_tail :: ZappedSet } -- apply 'markNonTail' to these+  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv++instance Outputable UsageDetails where+  ppr ud = ppr (ud_env (flattenUsageDetails ud))++-------------------+-- UsageDetails API++andUDs, orUDs+        :: UsageDetails -> UsageDetails -> UsageDetails+andUDs = combineUsageDetailsWith addOccInfo+orUDs  = combineUsageDetailsWith orOccInfo++mkOneOcc ::Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc id int_cxt arity+  | isLocalId id+  = emptyDetails { ud_env = unitVarEnv id occ_info }+  | otherwise+  = emptyDetails+  where+    occ_info = OneOcc { occ_in_lam  = NotInsideLam+                      , occ_n_br    = oneBranch+                      , occ_int_cxt = int_cxt+                      , occ_tail    = AlwaysTailCalled arity }++addManyOccId :: UsageDetails -> Id -> UsageDetails+-- Add the non-committal (id :-> noOccInfo) to the usage details+addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }++-- Add several occurrences, assumed not to be tail calls+addManyOcc :: Var -> UsageDetails -> UsageDetails+addManyOcc v u | isId v    = addManyOccId u v+               | otherwise = u+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++addManyOccs :: UsageDetails -> VarSet -> UsageDetails+addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set+  -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes++delDetails :: UsageDetails -> Id -> UsageDetails+delDetails ud bndr+  = ud `alterUsageDetails` (`delVarEnv` bndr)++delDetailsList :: UsageDetails -> [Id] -> UsageDetails+delDetailsList ud bndrs+  = ud `alterUsageDetails` (`delVarEnvList` bndrs)++emptyDetails :: UsageDetails+emptyDetails = UD { ud_env       = emptyVarEnv+                  , ud_z_many    = emptyVarEnv+                  , ud_z_in_lam  = emptyVarEnv+                  , ud_z_no_tail = emptyVarEnv }++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails = isEmptyVarEnv . ud_env++markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail+  :: UsageDetails -> UsageDetails+markAllMany          ud = ud { ud_z_many    = ud_env ud }+markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }+markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }++markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails++markAllInsideLamIf  True  ud = markAllInsideLam ud+markAllInsideLamIf  False ud = ud++markAllNonTailIf True  ud = markAllNonTail ud+markAllNonTailIf False ud = ud+++markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo++markAllManyNonTailIf :: Bool              -- If this is true+             -> UsageDetails      -- Then do markAllManyNonTail on this+             -> UsageDetails+markAllManyNonTailIf True  uds = markAllManyNonTail uds+markAllManyNonTailIf False uds = uds++lookupDetails :: UsageDetails -> Id -> OccInfo+lookupDetails ud id+  | isCoVar id  -- We do not currently gather occurrence info (from types)+  = noOccInfo   -- for CoVars, so we must conservatively mark them as used+                -- See Note [DoO not mark CoVars as dead]+  | otherwise+  = case lookupVarEnv (ud_env ud) id of+      Just occ -> doZapping ud id occ+      Nothing  -> IAmDead++usedIn :: Id -> UsageDetails -> Bool+v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud)++restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet+restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs++{- Note [Do not mark CoVars as dead]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's obviously wrong to mark CoVars as dead if they are used.+Currently we don't traverse types to gather usase info for CoVars,+so we had better treat them as having noOccInfo.++This showed up in #15696 we had something like+  case eq_sel d of co -> ...(typeError @(...co...) "urk")...++Then 'd' was substituted by a dictionary, so the expression+simpified to+  case (Coercion <blah>) of co -> ...(typeError @(...co...) "urk")...++But then the "drop the case altogether" equation of rebuildCase+thought that 'co' was dead, and discarded the entire case. Urk!++I have no idea how we managed to avoid this pitfall for so long!+-}++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)+                        -> UsageDetails -> UsageDetails -> UsageDetails+combineUsageDetailsWith plus_occ_info ud1 ud2+  | isEmptyDetails ud1 = ud2+  | isEmptyDetails ud2 = ud1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)+       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)+       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)+       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }++doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo+doZapping ud var occ+  = doZappingByUnique ud (varUnique var) occ++doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo+doZappingByUnique (UD { ud_z_many = many+                      , ud_z_in_lam = in_lam+                      , ud_z_no_tail = no_tail })+                  uniq occ+  = occ2+  where+    occ1 | uniq `elemVarEnvByKey` many    = markMany occ+         | uniq `elemVarEnvByKey` in_lam  = markInsideLam occ+         | otherwise                      = occ+    occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1+         | otherwise                      = occ1++alterZappedSets :: UsageDetails -> (ZappedSet -> ZappedSet) -> UsageDetails+alterZappedSets ud f+  = ud { ud_z_many    = f (ud_z_many    ud)+       , ud_z_in_lam  = f (ud_z_in_lam  ud)+       , ud_z_no_tail = f (ud_z_no_tail ud) }++alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails+alterUsageDetails ud f+  = ud { ud_env = f (ud_env ud) } `alterZappedSets` f++flattenUsageDetails :: UsageDetails -> UsageDetails+flattenUsageDetails ud+  = ud { ud_env = mapUFM_Directly (doZappingByUnique ud) (ud_env ud) }+      `alterZappedSets` const emptyVarEnv++-------------------+-- See Note [Adjusting right-hand sides]+adjustRhsUsage :: RecFlag -> Maybe JoinArity+               -> [CoreBndr]     -- Outer lambdas, AFTER occ anal+               -> UsageDetails   -- From body of lambda+               -> UsageDetails+adjustRhsUsage is_rec mb_join_arity bndrs usage+  = markAllInsideLamIf (not one_shot) $+    markAllNonTailIf (not exact_join) $+    usage+  where+    one_shot = case mb_join_arity of+                 Just join_arity+                   | isRec is_rec -> False+                   | otherwise    -> all isOneShotBndr (drop join_arity bndrs)+                 Nothing          -> all isOneShotBndr bndrs++    exact_join = exactJoin mb_join_arity bndrs++exactJoin :: Maybe JoinArity -> [a] -> Bool+exactJoin Nothing           _    = False+exactJoin (Just join_arity) args = args `lengthIs` join_arity+  -- Remember join_arity includes type binders++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails          -- Of scope+              -> [Id]                  -- Binders+              -> (UsageDetails,        -- Details with binders removed+                 [IdWithOccInfo])    -- Tagged binders+tagLamBinders usage binders+  = usage' `seq` (usage', bndrs')+  where+    (usage', bndrs') = mapAccumR tagLamBinder usage binders++tagLamBinder :: UsageDetails       -- Of scope+             -> Id                 -- Binder+             -> (UsageDetails,     -- Details with binder removed+                 IdWithOccInfo)    -- Tagged binders+-- Used for lambda and case binders+-- It copes with the fact that lambda bindings can have a+-- stable unfolding, used for join points+tagLamBinder usage bndr+  = (usage2, bndr')+  where+        occ    = lookupDetails usage bndr+        bndr'  = setBinderOcc (markNonTail occ) bndr+                   -- Don't try to make an argument into a join point+        usage1 = usage `delDetails` bndr+        usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)+                               -- This is effectively the RHS of a+                               -- non-join-point binding, so it's okay to use+                               -- addManyOccsSet, which assumes no tail calls+               | otherwise = usage1++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> UsageDetails           -- Of scope+                -> CoreBndr               -- Binder+                -> (UsageDetails,         -- Details with binder removed+                    IdWithOccInfo)        -- Tagged binder++tagNonRecBinder lvl usage binder+ = let+     occ     = lookupDetails usage binder+     will_be_join = decideJoinPointHood lvl usage [binder]+     occ'    | will_be_join = -- must already be marked AlwaysTailCalled+                              ASSERT(isAlwaysTailCalled occ) occ+             | otherwise    = markNonTail occ+     binder' = setBinderOcc occ' binder+     usage'  = usage `delDetails` binder+   in+   usage' `seq` (usage', binder')++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [(CoreBndr,            -- Binder+                   UsageDetails,        -- RHS usage details+                   [CoreBndr])]         -- Lambdas in new RHS+              -> (UsageDetails,         -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo])      -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds triples+ = let+     (bndrs, rhs_udss, _) = unzip3 triples++     -- 1. Determine join-point-hood of whole group, as determined by+     --    the *unadjusted* usage details+     unadj_uds     = foldr andUDs body_uds rhs_udss+     will_be_joins = decideJoinPointHood lvl unadj_uds bndrs++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = map adjust triples+     adjust (bndr, rhs_uds, rhs_bndrs)+       = adjustRhsUsage Recursive mb_join_arity rhs_bndrs rhs_uds        where          -- Can't use willBeJoinId_maybe here because we haven't tagged the          -- binder yet (the tag depends on these adjustments!)

GHC/Core/Opt/Pipeline.hs view

@@ -13,17 +13,20 @@ import GHC.Prelude  import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Plugins ( withPlugins, installCoreToDos )+import GHC.Driver.Env+import GHC.Platform.Ways  ( hasWay, Way(WayProf) )+ import GHC.Core-import GHC.Driver.Types import GHC.Core.Opt.CSE  ( cseProgram ) import GHC.Core.Rules   ( mkRuleBase, unionRuleBase,                           extendRuleBaseList, ruleCheckProgram, addRuleInfo,                           getRules, initRuleOpts ) import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr ) import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )-import GHC.Types.Id.Info import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )-import GHC.Core.Utils   ( mkTicks, stripTicksTop )+import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,                           lintAnnots ) import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplRules )@@ -31,33 +34,47 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad-import qualified GHC.Utils.Error as Err-import GHC.Core.Opt.FloatIn  ( floatInwards )-import GHC.Core.Opt.FloatOut ( floatOutwards )-import GHC.Core.FamInstEnv-import GHC.Types.Id-import GHC.Utils.Error  ( withTiming, withTimingD, DumpFormat (..) )-import GHC.Types.Basic-import GHC.Types.Var.Set-import GHC.Types.Var.Env+import GHC.Core.Opt.FloatIn      ( floatInwards )+import GHC.Core.Opt.FloatOut     ( floatOutwards ) import GHC.Core.Opt.LiberateCase ( liberateCase ) import GHC.Core.Opt.StaticArgs   ( doStaticArgs ) import GHC.Core.Opt.Specialise   ( specProgram) import GHC.Core.Opt.SpecConstr   ( specConstrProgram)-import GHC.Core.Opt.DmdAnal      ( dmdAnalProgram )+import GHC.Core.Opt.DmdAnal import GHC.Core.Opt.CprAnal      ( cprAnalProgram ) import GHC.Core.Opt.CallArity    ( callArityAnalProgram ) import GHC.Core.Opt.Exitify      ( exitifyProgram ) import GHC.Core.Opt.WorkWrap     ( wwTopBinds )-import GHC.Types.SrcLoc+import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )+import GHC.Core.Seq (seqBinds)+import GHC.Core.FamInstEnv++import qualified GHC.Utils.Error as Err+import GHC.Utils.Error  ( withTiming )+import GHC.Utils.Logger as Logger import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Unit.External import GHC.Unit.Module.Env-import GHC.Driver.Plugins ( withPlugins, installCoreToDos )-import GHC.Runtime.Loader -- ( initializePlugins )+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.Deps -import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )+import GHC.Runtime.Context++import GHC.Types.SrcLoc+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Demand ( zapDmdEnvSig )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Tickish+import GHC.Types.Unique.Supply ( UniqSupply ) import GHC.Types.Unique.FM-import GHC.Utils.Outputable+import GHC.Types.Name.Ppr+ import Control.Monad import qualified GHC.LanguageExtensions as LangExt {-@@ -73,33 +90,30 @@                                 , mg_loc     = loc                                 , mg_deps    = deps                                 , mg_rdr_env = rdr_env })-  = do { -- make sure all plugins are loaded--       ; let builtin_passes = getCoreToDo dflags+  = do { let builtin_passes = getCoreToDo logger dflags              orph_mods = mkModuleSet (mod : dep_orphs deps)              uniq_mask = 's'        ;        ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod                                     orph_mods print_unqual loc $                            do { hsc_env' <- getHscEnv-                              ; dflags' <- liftIO $ initializePlugins hsc_env'-                                                      (hsc_dflags hsc_env')-                              ; all_passes <- withPlugins dflags'+                              ; all_passes <- withPlugins hsc_env'                                                 installCoreToDos                                                 builtin_passes                               ; runCorePasses all_passes guts } -       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats+       ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_stats              "Grand total simplifier statistics"              FormatText              (pprSimplCount stats)         ; return guts2 }   where+    logger         = hsc_logger hsc_env     dflags         = hsc_dflags hsc_env     home_pkg_rules = hptRules hsc_env (dep_mods deps)     hpt_rule_base  = mkRuleBase home_pkg_rules-    print_unqual   = mkPrintUnqualified dflags rdr_env+    print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.     -- This is very convienent for the users of the monad (e.g. plugins do not have to     -- consume the ModGuts to find the module) but somewhat ugly because mg_module may@@ -114,8 +128,8 @@ ************************************************************************ -} -getCoreToDo :: DynFlags -> [CoreToDo]-getCoreToDo dflags+getCoreToDo :: Logger -> DynFlags -> [CoreToDo]+getCoreToDo logger dflags   = flatten_todos core_todo   where     opt_level     = optLevel           dflags@@ -136,8 +150,10 @@     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+    profiling     = ways dflags `hasWay` WayProf      maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) @@ -149,10 +165,14 @@     base_mode = SimplMode { sm_phase      = panic "base_mode"                           , sm_names      = []                           , sm_dflags     = dflags+                          , sm_logger     = logger+                          , 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@@ -201,12 +221,16 @@           }         ] +    add_caller_ccs =+        runWhen (profiling && not (null $ callerCcFilters dflags)) CoreAddCallerCcs+     core_todo =      if opt_level == 0 then        [ static_ptrs_float_outwards,          CoreDoSimplify max_iter              (base_mode { sm_phase = FinalPhase                         , sm_names = ["Non-opt simplification"] })+       , add_caller_ccs        ]       else {- opt_level >= 1 -} [@@ -306,33 +330,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"]@@ -345,7 +374,9 @@         -- can become /exponentially/ more expensive. See #11731, #12996.         runWhen (strictness || late_dmd_anal) CoreDoDemand, -        maybe_rule_check FinalPhase+        maybe_rule_check FinalPhase,++        add_caller_ccs      ]      -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.@@ -401,6 +432,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.++ ************************************************************************ *                                                                      *                   The CoreToDo interpreter@@ -415,67 +467,76 @@     do_pass guts CoreDoNothing = return guts     do_pass guts (CoreDoPasses ps) = runCorePasses ps guts     do_pass guts pass = do-       withTimingD (ppr pass <+> brackets (ppr mod))+      dflags <- getDynFlags+      logger <- getLogger+      withTiming logger dflags (ppr pass <+> brackets (ppr mod))                    (const ()) $ do-            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts-            ; endPass pass (mg_binds guts') (mg_rules guts')-            ; return guts' }+            guts' <- lintAnnots (ppr pass) (doCorePass pass) guts+            endPass pass (mg_binds guts') (mg_rules guts')+            return guts'      mod = mg_module guts  doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts-doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}-                                       simplifyPgm pass+doCorePass pass guts = do+  logger <- getLogger+  case pass of+    CoreDoSimplify {}         -> {-# SCC "Simplify" #-}+                                 simplifyPgm pass guts -doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}-                                       doPass cseProgram+    CoreCSE                   -> {-# SCC "CommonSubExpr" #-}+                                 doPass cseProgram guts -doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}-                                       doPassD liberateCase+    CoreLiberateCase          -> {-# SCC "LiberateCase" #-}+                                 doPassD liberateCase guts -doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}-                                       floatInwards+    CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}+                                 floatInwards guts -doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}-                                       doPassDUM (floatOutwards f)+    CoreDoFloatOutwards f     -> {-# SCC "FloatOutwards" #-}+                                 doPassDUM (floatOutwards logger f) guts -doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}-                                       doPassU doStaticArgs+    CoreDoStaticArgs          -> {-# SCC "StaticArgs" #-}+                                 doPassU doStaticArgs guts -doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}-                                       doPassD callArityAnalProgram+    CoreDoCallArity           -> {-# SCC "CallArity" #-}+                                 doPassD callArityAnalProgram guts -doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}-                                       doPass exitifyProgram+    CoreDoExitify             -> {-# SCC "Exitify" #-}+                                 doPass exitifyProgram guts -doCorePass CoreDoDemand              = {-# SCC "DmdAnal" #-}-                                       doPassDFM dmdAnalProgram+    CoreDoDemand              -> {-# SCC "DmdAnal" #-}+                                 doPassDFRM (dmdAnal logger) guts -doCorePass CoreDoCpr                 = {-# SCC "CprAnal" #-}-                                       doPassDFM cprAnalProgram+    CoreDoCpr                 -> {-# SCC "CprAnal" #-}+                                 doPassDFM (cprAnalProgram logger) guts -doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}-                                       doPassDFU wwTopBinds+    CoreDoWorkerWrapper       -> {-# SCC "WorkWrap" #-}+                                 doPassDFU wwTopBinds guts -doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}-                                       specProgram+    CoreDoSpecialising        -> {-# SCC "Specialise" #-}+                                 specProgram guts -doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}-                                       specConstrProgram+    CoreDoSpecConstr          -> {-# SCC "SpecConstr" #-}+                                 specConstrProgram guts -doCorePass CoreDoPrintCore              = observe   printCore-doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat-doCorePass CoreDoNothing                = return-doCorePass (CoreDoPasses passes)        = runCorePasses passes+    CoreAddCallerCcs          -> {-# SCC "AddCallerCcs" #-}+                                 addCallerCostCentres guts -doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass+    CoreDoPrintCore           -> observe (printCore logger) guts -doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)-doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)+    CoreDoRuleCheck phase pat -> ruleCheckPass phase pat guts+    CoreDoNothing             -> return guts+    CoreDoPasses passes       -> runCorePasses passes guts +    CoreDoPluginPass _ p      -> {-# SCC "Plugin" #-} p guts++    CoreDesugar               -> pprPanic "doCorePass" (ppr pass)+    CoreDesugarOpt            -> pprPanic "doCorePass" (ppr pass)+    CoreTidy                  -> pprPanic "doCorePass" (ppr pass)+    CorePrep                  -> pprPanic "doCorePass" (ppr pass)+    CoreOccurAnal             -> pprPanic "doCorePass" (ppr pass)+ {- ************************************************************************ *                                                                      *@@ -484,25 +545,26 @@ ************************************************************************ -} -printCore :: DynFlags -> CoreProgram -> IO ()-printCore dflags binds-    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)+printCore :: Logger -> DynFlags -> CoreProgram -> IO ()+printCore logger dflags binds+    = Logger.dumpIfSet logger dflags True "Print Core" (pprCoreBindings binds)  ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts-ruleCheckPass current_phase pat guts =-    withTimingD (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+ruleCheckPass current_phase pat guts = do+    dflags <- getDynFlags+    logger <- getLogger+    withTiming logger dflags (text "RuleCheck"<+>brackets (ppr $ mg_module guts))                 (const ()) $ do-    { rb <- getRuleBase-    ; dflags <- getDynFlags-    ; vis_orphs <- getVisibleOrphanMods-    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn-                        ++ (mg_rules guts)-    ; let ropts = initRuleOpts dflags-    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan-                   $ withPprStyle defaultDumpStyle-                   (ruleCheckProgram ropts current_phase pat-                      rule_fn (mg_binds guts))-    ; return guts }+        rb <- getRuleBase+        vis_orphs <- getVisibleOrphanMods+        let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+                          ++ (mg_rules guts)+        let ropts = initRuleOpts dflags+        liftIO $ putLogMsg logger dflags NoReason Err.SevDump noSrcSpan+                     $ withPprStyle defaultDumpStyle+                     (ruleCheckProgram ropts current_phase pat+                        rule_fn (mg_binds guts))+        return guts  doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts doPassDUM do_pass = doPassM $ \binds -> do@@ -529,6 +591,13 @@     let fam_envs = (p_fam_env, mg_fam_inst_env guts)     doPassM (liftIO . do_pass dflags fam_envs) guts +doPassDFRM :: (DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFRM do_pass guts = do+    dflags <- getDynFlags+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPassM (liftIO . do_pass dflags fam_envs (mg_rules guts)) guts+ doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts doPassDFU do_pass guts = do     dflags <- getDynFlags@@ -568,24 +637,23 @@ -- simplifyExpr is called by the driver to simplify an -- expression typed in at the interactive prompt simplifyExpr hsc_env expr-  = withTiming dflags (text "Simplify [expr]") (const ()) $+  = withTiming logger dflags (text "Simplify [expr]") (const ()) $     do  { eps <- hscEPS hsc_env ;         ; let rule_env  = mkRuleEnv (eps_rule_base eps) []               fi_env    = ( eps_fam_inst_env eps                           , extendFamInstEnvList emptyFamInstEnv $                             snd $ ic_instances $ hsc_IC hsc_env )-              simpl_env = simplEnvForGHCi dflags+              simpl_env = simplEnvForGHCi logger dflags -        ; us <-  mkSplitUniqSupply 's'         ; let sz = exprSize expr -        ; (expr', counts) <- initSmpl dflags rule_env fi_env us sz $+        ; (expr', counts) <- initSmpl logger dflags rule_env fi_env sz $                              simplExprGently simpl_env expr -        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)+        ; Logger.dumpIfSet logger dflags (dopt Opt_D_dump_simpl_stats dflags)                   "Simplifier statistics" (pprSimplCount counts) -        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"+        ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl "Simplified expression"                         FormatCore                         (pprCoreExpr expr') @@ -593,6 +661,7 @@         }   where     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env  simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr -- Simplifies an expression@@ -627,29 +696,27 @@ simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts simplifyPgm pass guts   = do { hsc_env <- getHscEnv-       ; us <- getUniqueSupplyM        ; rb <- getRuleBase        ; liftIOWithCount $-         simplifyPgmIO pass hsc_env us rb guts }+         simplifyPgmIO pass hsc_env rb guts }  simplifyPgmIO :: CoreToDo               -> HscEnv-              -> UniqSupply               -> RuleBase               -> ModGuts               -> IO (SimplCount, ModGuts)  -- New bindings  simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)-              hsc_env us hpt_rule_base+              hsc_env hpt_rule_base               guts@(ModGuts { mg_module = this_mod                             , mg_rdr_env = rdr_env                             , mg_deps = deps                             , mg_binds = binds, mg_rules = rules                             , mg_fam_inst_env = fam_inst_env })   = do { (termination_msg, it_count, counts_out, guts')-           <- do_iteration us 1 [] binds rules+           <- do_iteration 1 [] binds rules -        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&+        ; Logger.dumpIfSet logger dflags (dopt Opt_D_verbose_core2core dflags &&                                 dopt Opt_D_dump_simpl_stats  dflags)                   "Simplifier statistics for following pass"                   (vcat [text termination_msg <+> text "after" <+> ppr it_count@@ -661,19 +728,20 @@     }   where     dflags       = hsc_dflags hsc_env-    print_unqual = mkPrintUnqualified dflags rdr_env+    logger       = hsc_logger hsc_env+    print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env     simpl_env    = mkSimplEnv mode     active_rule  = activeRule mode     active_unf   = activeUnfolding mode -    do_iteration :: UniqSupply-                 -> Int          -- Counts iterations+    do_iteration :: Int --UniqSupply+                --  -> Int          -- Counts iterations                  -> [SimplCount] -- Counts from earlier iterations, reversed                  -> CoreProgram  -- Bindings in                  -> [CoreRule]   -- and orphan rules                  -> IO (String, Int, SimplCount, ModGuts) -    do_iteration us iteration_no counts_so_far binds rules+    do_iteration iteration_no counts_so_far binds rules         -- iteration_no is the number of the iteration we are         -- about to begin, with '1' for the first       | iteration_no > max_iterations   -- Stop if we've run out of iterations@@ -700,7 +768,7 @@                      occurAnalysePgm this_mod active_unf active_rule rules                                      binds                } ;-           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+           Logger.dumpIfSet_dyn logger dflags Opt_D_dump_occur_anal "Occurrence analysis"                      FormatCore                      (pprCoreBindings tagged_binds); @@ -718,7 +786,7 @@                  -- Simplify the program            ((binds1, rules1), counts1) <--             initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $+             initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $                do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}                                       simplTopBinds simpl_env tagged_binds @@ -748,30 +816,28 @@            let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;                  -- Dump the result of this iteration-           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;+           dump_end_iteration logger dflags print_unqual iteration_no counts1 binds2 rules1 ;            lintPassResult hsc_env pass binds2 ;                  -- Loop-           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+           do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1            } } #if __GLASGOW_HASKELL__ <= 810       | otherwise = panic "do_iteration" #endif       where-        (us1, us2) = splitUniqSupply us-         -- Remember the counts_so_far are reversed         totalise :: [SimplCount] -> SimplCount         totalise = foldr (\c acc -> acc `plusSimplCount` c)                          (zeroSimplCount dflags) -simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"+simplifyPgmIO _ _ _ _ = panic "simplifyPgmIO"  --------------------dump_end_iteration :: DynFlags -> PrintUnqualified -> Int+dump_end_iteration :: Logger -> DynFlags -> PrintUnqualified -> Int                    -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration dflags print_unqual iteration_no counts binds rules-  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules+dump_end_iteration logger dflags print_unqual iteration_no counts binds rules+  = dumpPassResult logger dflags print_unqual mb_flag hdr pp_counts binds rules   where     mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations             | otherwise                               = Nothing@@ -848,7 +914,7 @@         of iterateList in the first place  But in principle the user *might* want rules that only apply to the Id-he says.  And inline pragmas are similar+they say.  And inline pragmas are similar    {-# NOINLINE f #-}    f = local    local = <stuff>@@ -916,7 +982,7 @@ x_exported, and therefore carry the tick anyway. -} -type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks+type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks  shortOutIndirections :: CoreProgram -> CoreProgram shortOutIndirections binds@@ -1039,3 +1105,16 @@                                (ruleInfo local_info)         -- Remember to set the function-name field of the         -- rules as we transfer them from one function to another++++dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram+dmdAnal logger dflags fam_envs rules binds = do+  let !opts = DmdAnalOpts+               { dmd_strict_dicts = gopt Opt_DictsStrict dflags+               }+      binds_plus_dmds = dmdAnalProgram opts fam_envs rules binds+  Logger.dumpIfSet_dyn logger dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $+    dumpIdInfoOfProgram (ppr . zapDmdEnvSig . strictnessInfo) binds_plus_dmds+  -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal+  seqBinds binds_plus_dmds `seq` return binds_plus_dmds

GHC/Core/Opt/SetLevels.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE PatternSynonyms #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -60,9 +65,6 @@   identity. -} -{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.SetLevels (         setLevels, @@ -77,6 +79,8 @@  import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) import GHC.Core.Utils   ( exprType, exprIsHNF@@ -99,11 +103,12 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig )+import GHC.Types.Demand       ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig ) import GHC.Types.Cpr          ( mkCprSig, botCpr ) import GHC.Types.Name         ( getOccName, mkSystemVarName ) import GHC.Types.Name.Occurrence ( occNameString ) import GHC.Types.Unique       ( hasKey )+import GHC.Types.Tickish      ( tickishIsCode ) import GHC.Core.Type    ( Type, splitTyConApp_maybe, tyCoVarsOfType                         , mightBeUnliftedType, closeOverKindsDSet ) import GHC.Core.Multiplicity     ( pattern Many )@@ -114,6 +119,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.DFM import GHC.Utils.FV@@ -464,7 +470,7 @@     lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)     lvl_arg strs arg | (str1 : strs') <- strs                      , is_val_arg arg-                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg+                     = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg                           ; return (strs', arg') }                      | otherwise                      = do { arg' <- lvlMFE env False arg@@ -486,7 +492,7 @@         -> LvlM LevelledExpr    -- Result expression lvlCase env scrut_fvs scrut' case_bndr ty alts   -- See Note [Floating single-alternative cases]-  | [(con@(DataAlt {}), bs, body)] <- alts+  | [AnnAlt con@(DataAlt {}) bs body] <- alts   , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]   , not (isTopLvl dest_lvl)       -- Can't have top-level cases   , not (floatTopLvlOnly env)     -- Can float anywhere@@ -496,7 +502,7 @@     do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)        ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'        ; body' <- lvlMFE rhs_env True body-       ; let alt' = (con, map (stayPut dest_lvl) bs', body')+       ; let alt' = Alt con (map (stayPut dest_lvl) bs') body'        ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }    | otherwise     -- Stays put@@ -511,9 +517,9 @@     dest_lvl = maxFvLevel (const True) env scrut_fvs             -- Don't abstract over type variables, hence const True -    lvl_alt alts_env (con, bs, rhs)+    lvl_alt alts_env (AnnAlt con bs rhs)       = do { rhs' <- lvlMFE new_env True rhs-           ; return (con, bs', rhs') }+           ; return (Alt con bs' rhs') }       where         (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs @@ -696,13 +702,13 @@        ; let l1r       = incMinorLvlFrom rhs_env              float_rhs = mkLams abs_vars_w_lvls $                          Case expr1 (stayPut l1r ubx_bndr) dc_res_ty-                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]+                             [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])]         ; var <- newLvlVar float_rhs Nothing is_mk_static        ; let l1u      = incMinorLvlFrom env              use_expr = Case (mkVarApps (Var var) abs_vars)                              (stayPut l1u bx_bndr) expr_ty-                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]+                             [Alt (DataAlt dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]        ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)                      use_expr) } @@ -879,9 +885,8 @@ and replace the original (f x) with    case (case y of I# r -> r) of r -> blah -Being able to float unboxed expressions is sometimes important; see-#12603.  I'm not sure how /often/ it is important, but it's-not hard to achieve.+Being able to float unboxed expressions is sometimes important; see #12603.+I'm not sure how /often/ it is important, but it's not hard to achieve.  We only do it for a fixed collection of types for which we have a convenient boxing constructor (see boxingDataCon_maybe).  In

GHC/Core/Opt/Simplify.hs view

@@ -5,6 +5,7 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where@@ -15,13 +16,15 @@  import GHC.Platform import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config import GHC.Core.Opt.Simplify.Monad import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Utils import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-import GHC.Core.FamInstEnv ( FamInstEnv ) import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326+import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Id.Make   ( seqId ) import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )@@ -30,37 +33,40 @@ import GHC.Types.Name           ( mkSystemVarName, isExternalName, getOccFS ) import GHC.Core.Coercion hiding ( substCo, substCoVar ) import GHC.Core.Coercion.Opt    ( optCoercion )-import GHC.Core.FamInstEnv      ( topNormaliseType_maybe )+import GHC.Core.FamInstEnv      ( 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 import GHC.Builtin.Types.Prim( realWorldStatePrimTy ) import GHC.Builtin.Names( runRWKey )-import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd-                        , mkClosedStrictSig, topDmd, seqDmd, botDiv )+import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd+                        , mkClosedStrictSig, topDmd, seqDmd, isDeadEndDiv ) import GHC.Types.Cpr    ( mkCprSig, botCpr ) 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+import GHC.Core.Opt.Arity ( ArityType(..)+                          , pushCoTyArg, pushCoValArg                           , idArityType, etaExpandAT )-import GHC.Core.SimpleOpt ( pushCoTyArg, pushCoValArg-                          , joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe ) import GHC.Core.FVs     ( mkRuleInfo ) import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts ) import GHC.Types.Basic import GHC.Utils.Monad  ( mapAccumLM, liftIO )+import GHC.Utils.Logger+import GHC.Types.Tickish import GHC.Types.Var    ( isTyCoVar )-import GHC.Data.Maybe   ( orElse, isNothing )+import GHC.Data.Maybe   ( isNothing, orElse ) import Control.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc-import GHC.Utils.Error import GHC.Unit.Module ( moduleName, pprModuleName ) import GHC.Core.Multiplicity import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )@@ -161,6 +167,38 @@ the time: every update to a binder is automatically reflected to its bound occurrences. +Note [Bangs in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both SimplFloats and SimplEnv do *not* generally benefit from making+their fields strict. I don't know if this is because of good use of+laziness or unintended side effects like closures capturing more variables+after WW has run.++But the end result is that we keep these lazy, but force them in some places+where we know it's beneficial to the compiler.++Similarly environments returned from functions aren't *always* beneficial to+force. In some places they would never be demanded so forcing them early+increases allocation. In other places they almost always get demanded so+it's worthwhile to force them early.++Would it be better to through every allocation of e.g. SimplEnv and decide+wether or not to make this one strict? Absolutely! Would be a good use of+someones time? Absolutely not! I made these strict that showed up during+a profiled build or which I noticed while looking at core for one reason+or another.++The result sadly is that we end up with "random" bangs in the simplifier+where we sometimes force e.g. the returned environment from a function and+sometimes we don't for the same function. Depending on the context around+the call. The treatment is also not very consistent. I only added bangs+where I saw it making a difference either in the core or benchmarks. Some+patterns where it would be beneficial aren't convered as a consequence as+I neither have the time to go through all of the core and some cases are+too small to show up in benchmarks.+++ ************************************************************************ *                                                                      * \subsection{Bindings}@@ -176,7 +214,8 @@                 -- anything into scope, then we don't get a complaint about that.                 -- It's rather as if the top-level binders were imported.                 -- See note [Glomming] in "GHC.Core.Opt.OccurAnal".-        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        -- See Note [Bangs in the Simplifier]+        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)         ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0         ; freeTick SimplifierDone         ; return (floats, env2) }@@ -189,7 +228,9 @@     simpl_binds env []           = return (emptyFloats env, env)     simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind                                       ; (floats, env2) <- simpl_binds env1 binds-                                      ; return (float `addFloats` floats, env2) }+                                      -- See Note [Bangs in the Simplifier]+                                      ; let !floats1 = float `addFloats` floats+                                      ; return (floats1, env2) }      simpl_bind env (Rec pairs)       = simplRecBind env TopLevel Nothing pairs@@ -263,6 +304,7 @@    where     dflags = seDynFlags env+    logger = seLogger env      -- trace_bind emits a trace for each top-level binding, which     -- helps to locate the tracing for inlining and rule firing@@ -270,7 +312,7 @@       | not (dopt Opt_D_verbose_core2core dflags)       = thing_inside       | otherwise-      = traceAction dflags ("SimplBind " ++ what)+      = putTraceMsg logger dflags ("SimplBind " ++ what)          (ppr old_bndr) thing_inside  --------------------------@@ -289,7 +331,7 @@   = ASSERT( isId bndr )     ASSERT2( not (isJoinId bndr), ppr bndr )     -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   rhs_env     = rhs_se `setInScopeFromE` env+    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]                 (tvs, body) = case collectTyAndValBinders rhs of                                 (tvs, [], body)                                   | surely_not_lam body -> (tvs, body)@@ -313,7 +355,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@@ -339,7 +381,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@@ -383,8 +425,13 @@    | otherwise   = do  { (env', bndr') <- simplBinder env bndr-        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }-                -- simplNonRecX is only used for NotTopLevel things+        ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs }+          -- NotTopLevel: simplNonRecX is only used for NotTopLevel things+          --+          -- isStrictId: use bndr' because in a levity-polymorphic setting+          -- the InId bndr might have a levity-polymorphic type, which+          -- which isStrictId doesn't expect+          -- c.f. Note [Dark corner with levity polymorphism]  -------------------------- completeNonRecX :: TopLevelFlag -> SimplEnv@@ -544,7 +591,7 @@ -- See Note [Cast wrappers] mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })   = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInline -- See Note [Wrapper NoUserInline]+                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]                  , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap                  , inl_act    = wrap_act     -- See Note [Wrapper activation]                  , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap@@ -673,7 +720,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@@ -792,8 +839,8 @@ addLetBndrInfo new_bndr new_arity_type new_unf   = new_bndr `setIdInfo` info5   where-    new_arity = arityTypeArity new_arity_type-    is_bot    = isBotArityType new_arity_type+    AT oss div = new_arity_type+    new_arity  = length oss      info1 = idInfo new_bndr `setArityInfo` new_arity @@ -812,11 +859,11 @@           = info2      -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | is_bot    = info3 `setStrictnessInfo` bot_sig-                              `setCprInfo`        bot_cpr-          | otherwise = info3+    info4 | isDeadEndDiv div = info3 `setStrictnessInfo` bot_sig+                                     `setCprInfo`        bot_cpr+          | otherwise        = info3 -    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) botDiv+    bot_sig = mkClosedStrictSig (replicate new_arity topDmd) div     bot_cpr = mkCprSig new_arity botCpr       -- Zap call arity info. We have used it by now (via@@ -930,7 +977,7 @@ -}  simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr env (Type ty)+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]   = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]        ; return (Type ty') } @@ -961,7 +1008,7 @@            -> SimplCont            -> SimplM (SimplFloats, OutExpr) -simplExprF env e cont+simplExprF !env e !cont -- See Note [Bangs in the Simplifier]   = {- pprTrace "simplExprF" (vcat       [ ppr e       , text "cont =" <+> ppr cont@@ -1028,18 +1075,11 @@         -- occ-info, UNLESS the remaining binders are one-shot   where     (bndrs, body) = collectBinders expr-    zapped_bndrs | need_to_zap = map zap bndrs-                 | otherwise   = bndrs--    need_to_zap = any zappable_bndr (drop n_args bndrs)+    zapped_bndrs = zapLamBndrs n_args bndrs     n_args = countArgs cont         -- NB: countArgs counts all the args (incl type args)         -- and likewise drop counts all binders (incl type lambdas) -    zappable_bndr b = isId b && not (isOneShotBndr b)-    zap b | isTyVar b = b-          | otherwise = zapLamIdInfo b- simplExprF1 env (Case scrut bndr _ alts) cont   = {-#SCC "simplExprF1-Case" #-}     simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr@@ -1148,8 +1188,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 }  -----------------------------------@@ -1157,7 +1197,7 @@ -- long as this is a non-scoping tick, to let case and application -- optimisations apply. -simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont+simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont           -> SimplM (SimplFloats, OutExpr) simplTick env tickish expr cont   -- A scoped tick turns into a continuation, so that we can spot@@ -1218,7 +1258,7 @@          tickScrut e    = foldr mkTick e ticks          -- Alternatives get annotated with all ticks that scope in some way,          -- but we don't want to count entries.-         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)+         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)          ts_scope         = map mkNoCount $                             filter (not . (`tickishScopesLike` NoScope)) ticks @@ -1251,8 +1291,8 @@     simplTickish env tickish-    | Breakpoint n ids <- tickish-          = Breakpoint n (map (getDoneId . substId env) ids)+    | Breakpoint ext n ids <- tickish+          = Breakpoint ext n (map (getDoneId . substId env) ids)     | otherwise = tickish    -- Push type application and coercion inside a tick@@ -1409,25 +1449,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.@@ -1437,7 +1475,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@@ -1445,6 +1483,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@@ -1564,21 +1609,22 @@        ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $          simplLam env' bndrs body cont } -  -- Deal with strict bindings-  | isStrictId bndr          -- Includes coercions, and unlifted types-  , sm_case_case (getMode env)-  = simplExprF (rhs_se `setInScopeFromE` env) rhs-               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body-                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })--  -- Deal with lazy bindings   | otherwise-  = ASSERT( not (isTyVar bndr) )-    do { (env1, bndr1) <- simplNonRecBndr env bndr-       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing+  = do { (env1, bndr1) <- simplNonRecBndr env bndr++       -- Deal with strict bindings+       -- See Note [Dark corner with levity polymorphism]+       ; if isStrictId bndr1 && sm_case_case (getMode env)+         then simplExprF (rhs_se `setInScopeFromE` env) rhs+                   (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body+                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })++       -- Deal with lazy bindings+         else do+       { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing        ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se        ; (floats2, expr') <- simplLam env3 bndrs body cont-       ; return (floats1 `addFloats` floats2, expr') }+       ; return (floats1 `addFloats` floats2, expr') } }  ------------------ simplRecE :: SimplEnv@@ -1599,7 +1645,26 @@         ; (floats2, expr') <- simplExprF env2 body cont         ; return (floats1 `addFloats` floats2, expr') } -{- Note [Avoiding exponential behaviour]+{- Note [Dark corner with levity polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `simplNonRecE`, the call to `isStrictId` will fail if the binder+has a levity-polymorphic type, of kind (TYPE r).  So we are careful to+call `isStrictId` on the OutId, not the InId, in case we have+     ((\(r::RuntimeRep) \(x::Type r). blah) Lifted arg)+That will lead to `simplNonRecE env (x::Type r) arg`, and we can't tell+if x is lifted or unlifted from that.++We only get such redexes from the compulsory inlining of a wired-in,+levity-polymorphic function like `rightSection` (see+GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined+such compulsory inlinings already, but belt and braces does no harm.++Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the+Simplifier without first calling SimpleOpt, so anything involving+GHCi or TH and operator sections will fall over if we don't take+care here.++Note [Avoiding exponential behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ One way in which we can get exponential behaviour is if we simplify a big expression, and the re-simplify it -- and then this happens in a@@ -1840,24 +1905,33 @@ simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var-  | isTyVar var = return (Type (substTyVar env var))-  | isCoVar var = return (Coercion (substCoVar env var))+  -- Why $! ? See Note [Bangs in the Simplifier]+  | isTyVar var = return $! Type $! (substTyVar env var)+  | isCoVar var = return $! Coercion $! (substCoVar env var)   | otherwise   = case substId env var of-        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e+        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids+                                in simplExpr env' e         DoneId var1          -> return (Var var1)         DoneEx e _           -> return e  simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr) simplIdF env var cont   = case substId env var of-      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont-                                -- Don't trim; haven't already simplified e,-                                -- so the cont is not embodied in e+      ContEx tvs cvs ids e ->+          let env' = setSubstEnv env tvs cvs ids+          in simplExprF env' e cont+          -- Don't trim; haven't already simplified e,+          -- so the cont is not embodied in e -      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)+      DoneId var1 ->+          let cont' = trimJoinCont var (isJoinId_maybe var1) cont+          in completeCall env var1 cont' -      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)+      DoneEx e mb_join ->+          let env' = zapSubstEnv env+              cont' = trimJoinCont var mb_join cont+          in simplExprF env' e cont'               -- Note [zapSubstEnv]               -- The template is already simplified, so don't re-substitute.               -- This is VITAL.  Consider@@ -1873,31 +1947,35 @@  completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr) completeCall env var cont-  | Just expr <- callSiteInline dflags var active_unf+  | Just expr <- callSiteInline logger dflags case_depth var active_unf                                 lone_variable arg_infos interesting_cont   -- Inline the variable's RHS   = do { checkedTick (UnfoldingDone var)        ; dump_inline expr cont-       ; simplExprF (zapSubstEnv env) expr cont }+       ; let env1 = zapSubstEnv env+       ; simplExprF env1 expr cont }    | otherwise   -- Don't inline; instead rebuild the call   = do { rule_base <- getSimplRules-       ; let info = mkArgInfo env var (getRules rule_base var)+       ; let rules = getRules rule_base var+             info = mkArgInfo env var rules                               n_val_args call_cont        ; rebuildCall env info cont }    where-    dflags = seDynFlags env+    dflags     = seDynFlags env+    case_depth = seCaseDepth env+    logger     = seLogger env     (lone_variable, arg_infos, call_cont) = contArgs cont     n_val_args       = length arg_infos     interesting_cont = interestingCallContext env call_cont     active_unf       = activeUnfolding (getMode env) var      log_inlining doc-      = liftIO $ dumpAction dflags+      = liftIO $ putDumpMsg logger dflags            (mkDumpStyle alwaysQualify)-           (dumpOptionsFromFlag Opt_D_dump_inlinings)+           Opt_D_dump_inlinings            "" FormatText doc      dump_inline unfolding cont@@ -1907,7 +1985,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])]@@ -2160,6 +2238,7 @@   where     ropts      = initRuleOpts dflags     dflags     = seDynFlags env+    logger     = seLogger env     zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]      printRuleModule rule@@ -2187,21 +2266,21 @@      nodump       | dopt Opt_D_dump_rule_rewrites dflags-      = liftIO $ do-         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_rewrites)+      = liftIO $+          touchDumpFile logger dflags Opt_D_dump_rule_rewrites        | dopt Opt_D_dump_rule_firings dflags-      = liftIO $ do-         touchDumpFile dflags (dumpOptionsFromFlag Opt_D_dump_rule_firings)+      = liftIO $+          touchDumpFile logger dflags Opt_D_dump_rule_firings        | otherwise       = return ()      log_rule dflags flag hdr details       = liftIO $ do-         let sty = mkDumpStyle alwaysQualify-         dumpAction dflags sty (dumpOptionsFromFlag flag) "" FormatText $-           sep [text hdr, nest 4 details]+          let sty = mkDumpStyle alwaysQualify+          putDumpMsg logger dflags sty flag "" FormatText $+              sep [text hdr, nest 4 details]  trySeqRules :: SimplEnv             -> OutExpr -> InExpr   -- Scrutinee and RHS@@ -2473,7 +2552,7 @@      scrut_is_demanded_var :: CoreExpr -> Bool     scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s-    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)     scrut_is_demanded_var _          = False    This only fired if the scrutinee was a /variable/, which seems@@ -2577,8 +2656,8 @@   , not (litIsLifted lit)   = do  { tick (KnownBranch case_bndr)         ; case findAlt (LitAlt lit) alts of-            Nothing           -> missingAlt env case_bndr alts cont-            Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs }+            Nothing             -> missingAlt env case_bndr alts cont+            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }    | Just (in_scope', wfloats, con, ty_args, other_args)       <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut@@ -2589,12 +2668,12 @@         ; let scaled_wfloats = map scale_float wfloats         ; case findAlt (DataAlt con) alts of             Nothing  -> missingAlt env0 case_bndr alts cont-            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)+            Just (Alt DEFAULT bs rhs) -> let con_app = Var (dataConWorkId con)                                                  `mkTyApps` ty_args                                                  `mkApps`   other_args-                                       in simple_rhs env0 scaled_wfloats con_app bs rhs-            Just (_, bs, rhs)       -> knownCon env0 scrut scaled_wfloats con ty_args other_args-                                                case_bndr bs rhs cont+                                         in simple_rhs env0 scaled_wfloats con_app bs rhs+            Just (Alt _ bs rhs)       -> knownCon env0 scrut scaled_wfloats con ty_args other_args+                                                  case_bndr bs rhs cont         }   where     simple_rhs env wfloats scrut' bs rhs =@@ -2641,7 +2720,7 @@ --      2. Eliminate the case if scrutinee is evaluated -------------------------------------------------- -rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont+rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont   -- See if we can get rid of the case altogether   -- See Note [Case elimination]   -- mkCase made sure that if all the alternatives are equal,@@ -2701,7 +2780,7 @@    | otherwise  -- Scrut has a lifted type   = exprIsHNF scrut-    || isStrictDmd (idDemandInfo case_bndr)+    || isStrUsedDmd (idDemandInfo case_bndr)     -- See Note [Case-to-let for strictly-used binders]  --------------------------------------------------@@ -2715,9 +2794,11 @@        ; rebuild env case_expr cont }    | otherwise-  = do { (floats, cont') <- mkDupableCaseCont env alts cont-       ; case_expr <- simplAlts (env `setInScopeFromF` floats)-                                scrut (scaleIdBy holeScaling case_bndr) (scaleAltsBy holeScaling alts) cont'+  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts env' scrut+                                (scaleIdBy holeScaling case_bndr)+                                (scaleAltsBy holeScaling alts)+                                cont'        ; return (floats, case_expr) }   where     holeScaling = contHoleScaling cont@@ -2873,7 +2954,7 @@            -> OutExpr -> InId -> OutId -> [InAlt]            -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]+improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]   | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)   = do { case_bndr2 <- newId (fsLit "nt") Many ty2         ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing@@ -2894,21 +2975,21 @@          -> InAlt          -> SimplM OutAlt -simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)+simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)   = ASSERT( null bndrs )     do  { let env' = addBinderUnfolding env case_bndr'                                         (mkOtherCon imposs_deflt_cons)                 -- Record the constructors that the case-binder *can't* be.         ; rhs' <- simplExprC env' rhs cont'-        ; return (DEFAULT, [], rhs') }+        ; return (Alt DEFAULT [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)+simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)   = ASSERT( null bndrs )     do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)         ; rhs' <- simplExprC env' rhs cont'-        ; return (LitAlt lit, [], rhs') }+        ; return (Alt (LitAlt lit) [] rhs') } -simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)+simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)   = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]           let vs_with_evals = addEvals scrut' con vs         ; (env', vs') <- simplLamBndrs env vs_with_evals@@ -2920,7 +3001,7 @@          ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app         ; rhs' <- simplExprC env'' rhs cont'-        ; return (DataAlt con, vs', rhs') }+        ; return (Alt (DataAlt con) vs' rhs') }  {- Note [Adding evaluatedness info to pattern-bound variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2956,7 +3037,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.@@ -3007,7 +3088,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@@ -3110,7 +3191,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             [] ->@@ -3225,10 +3306,15 @@  -------------------- mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont-                  -> SimplM (SimplFloats, SimplCont)+                  -> SimplM ( SimplFloats  -- Join points (if any)+                            , SimplEnv     -- Use this for the alts+                            , SimplCont) mkDupableCaseCont env alts cont-  | altsWouldDup alts = mkDupableCont env cont-  | otherwise         = return (emptyFloats env, cont)+  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont+                           ; let env' = bumpCaseDepth $+                                        env `setInScopeFromF` floats+                           ; return (floats, env', cont) }+  | otherwise         = return (emptyFloats env, env, cont)  altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative altsWouldDup []  = False        -- See Note [Bottom alternatives]@@ -3236,8 +3322,9 @@ 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+    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs  ------------------------- mkDupableCont :: SimplEnv@@ -3361,12 +3448,11 @@         --              in case [...hole...] of { pi -> ji xij }         -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable     do  { tick (CaseOfCase case_bndr)-        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont+        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont                 -- NB: We call mkDupableCaseCont here to make cont duplicable                 --     (if necessary, depending on the number of alts)                 -- And this is important: see Note [Fusing case continuations] -        ; let alt_env = se `setInScopeFromF` floats         ; let cont_scaling = contHoleScaling cont           -- See Note [Scaling in case-of-case]         ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)@@ -3426,12 +3512,13 @@ mkDupableAlt :: Platform -> OutId              -> JoinFloats -> OutAlt              -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (con, bndrs', rhs')+mkDupableAlt _platform case_bndr jfloats (Alt con bndrs' rhs')   | exprIsTrivial rhs'   -- See point (2) of Note [Duplicating join points]-  = return (jfloats, (con, bndrs', rhs'))+  = return (jfloats, Alt 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 +3526,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"@@ -3471,7 +3558,7 @@         ; join_bndr <- newJoinId final_bndrs' rhs_ty'          ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = (con, bndrs', join_call)+              alt'      = Alt con bndrs' join_call          ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)                  , alt') }@@ -3580,12 +3667,8 @@ point for data constructors in mkDupalbleALt (point 2); that is the whole point of #19996 described above. -Historical Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: this entire Note is now irrelevant.  In Jun 21 we stopped-adding unfoldings to lambda binders (#17530).  It was always a-hack and bit us in multiple small and not-so-small ways-+Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this    case (case .. ) of c {      I# c# -> ....c....@@ -3708,7 +3791,7 @@  and now the (&& a F) etc can optimise.  Moreover there might be a RULE for the function that can fire when it "sees" the-particular case alterantive.+particular case alternative.  But Plan A can have terrible, terrible behaviour. Here is a classic case:@@ -3843,14 +3926,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@@ -3858,11 +3941,8 @@             --             to expose.  (We could instead use the RHS, but currently             --             we don't.)  The simple thing is always to have one.   where-    -- Might as well force this, profiles indicate up to 0.5MB of thunks-    -- just from this site.-    !is_top_lvl   = isTopLevel top_lvl-    -- See Note [Force bottoming field]-    !is_bottoming = isDeadEndId id+    is_top_lvl   = isTopLevel top_lvl+    is_bottoming = isDeadEndId id  ------------------- simplStableUnfolding :: SimplEnv -> TopLevelFlag@@ -3899,17 +3979,11 @@                           , ug_boring_ok = boring_ok                           }                           -- Happens for INLINE things-                        -- Really important to force new_boring_ok as otherwise-                        -- `ug_boring_ok` is a thunk chain of-                        -- inlineBoringExprOk expr0-                        --  || inlineBoringExprOk expr1 || ...-                        --  See #20134-                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'-                            guide' =+                     -> let guide' =                               UnfWhen { ug_arity = arity                                       , ug_unsat_ok = sat_ok-                                      , ug_boring_ok = new_boring_ok-+                                      , ug_boring_ok =+                                          boring_ok || inlineBoringOk expr'                                       }                         -- Refresh the boring-ok flag, in case expr'                         -- has got small. This happens, notably in the inlinings@@ -3922,17 +3996,15 @@                             -- 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-    -- Forcing this can save about 0.5MB of max residency and the result-    -- is small and easy to compute so might as well force it.-    !is_top_lvl = isTopLevel top_lvl+    uf_opts    = seUnfoldingOpts env+    is_top_lvl = isTopLevel top_lvl     act        = idInlineActivation id     unf_env    = updMode (updModeForStableUnfoldings act) env          -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils@@ -4034,14 +4106,17 @@       = return rule      simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs })+                          , ru_fn = fn_name, ru_rhs = rhs+                          , ru_act = act })       = do { (env', bndrs') <- simplBinders env bndrs            ; let rhs_ty = substTy env' (exprType rhs)                  rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]                                 Nothing   -> mkBoringStop rhs_ty                                 Just cont -> ASSERT2( join_ok, bad_join_msg )                                              cont-                 rule_env = updMode updModeForRules env'+                 lhs_env = updMode updModeForRules env'+                 rhs_env = updMode (updModeForStableUnfoldings act) env'+                           -- See Note [Simplifying the RHS of a RULE]                  fn_name' = case mb_new_id of                               Just id -> idName id                               Nothing -> fn_name@@ -4056,9 +4131,18 @@                  bad_join_msg = vcat [ ppr mb_new_id, ppr rule                                      , ppr (fmap isJoinId_maybe mb_new_id) ] -           ; args' <- mapM (simplExpr rule_env) args-           ; rhs'  <- simplExprC rule_env rhs rhs_cont+           ; args' <- mapM (simplExpr lhs_env) args+           ; rhs'  <- simplExprC rhs_env rhs rhs_cont            ; return (rule { ru_bndrs = bndrs'                           , ru_fn    = fn_name'                           , ru_args  = args'                           , ru_rhs   = rhs' }) }++{- Note [Simplifying the RHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can simplify the RHS of a RULE much as we do the RHS of a stable+unfolding.  We used to use the much more conservative updModeForRules+for the RHS as well as the LHS, but that seems more conservative+than necesary.  Allowing some inlining might, for example, eliminate+a binding.+-}

GHC/Core/Opt/Simplify/Env.hs view

@@ -8,13 +8,13 @@  module GHC.Core.Opt.Simplify.Env (         -- * The simplifier mode-        setMode, getMode, updMode, seDynFlags,+        setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,          -- * Environments         SimplEnv(..), pprSimplEnv,   -- Temp not abstract         mkSimplEnv, extendIdSubst,         extendTvSubst, extendCvSubst,-        zapSubstEnv, setSubstEnv,+        zapSubstEnv, setSubstEnv, bumpCaseDepth,         getInScope, setInScopeFromE, setInScopeFromF,         setInScopeSet, modifyInScope, addNewInScopeIds,         getSimplRules,@@ -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@@ -68,7 +69,9 @@ import GHC.Types.Basic import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.Logger import GHC.Types.Unique.FM      ( pprUniqFM )  import Data.List (mapAccumL)@@ -87,7 +90,7 @@      -- Static in the sense of lexically scoped,      -- wrt the original expression -        seMode      :: SimplMode+        seMode      :: !SimplMode          -- The current substitution       , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType@@ -100,7 +103,9 @@          -- The current set of in-scope variables         -- They are all OutVars, and all bound in this module-      , seInScope   :: InScopeSet       -- OutVars only+      , seInScope   :: !InScopeSet       -- OutVars only++      , seCaseDepth :: !Int  -- Depth of multi-branch case alternatives     }  data SimplFloats@@ -270,11 +275,12 @@  mkSimplEnv :: SimplMode -> SimplEnv mkSimplEnv mode-  = SimplEnv { seMode = mode-             , seInScope = init_in_scope-             , seTvSubst = emptyVarEnv-             , seCvSubst = emptyVarEnv-             , seIdSubst = emptyVarEnv }+  = SimplEnv { seMode      = mode+             , seInScope   = init_in_scope+             , seTvSubst   = emptyVarEnv+             , seCvSubst   = emptyVarEnv+             , seIdSubst   = emptyVarEnv+             , seCaseDepth = 0 }         -- The top level "enclosing CC" is "SUBSUMED".  init_in_scope :: InScopeSet@@ -307,12 +313,26 @@ seDynFlags :: SimplEnv -> DynFlags seDynFlags env = sm_dflags (seMode env) +seLogger :: SimplEnv -> Logger+seLogger env = sm_logger (seMode env)+++seUnfoldingOpts :: SimplEnv -> UnfoldingOpts+seUnfoldingOpts env = sm_uf_opts (seMode env)++ setMode :: SimplMode -> SimplEnv -> SimplEnv setMode mode env = env { seMode = mode }  updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv-updMode upd env = env { seMode = upd (seMode env) }+updMode upd env+  = -- Avoid keeping env alive in case inlining fails.+    let mode = upd $! (seMode env)+    in env { seMode = mode } +bumpCaseDepth :: SimplEnv -> SimplEnv+bumpCaseDepth env = env { seCaseDepth = seCaseDepth env + 1 }+ --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res@@ -346,8 +366,12 @@ addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv         -- The new Ids are guaranteed to be freshly allocated addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs-  = env { seInScope = in_scope `extendInScopeSetList` vs,-          seIdSubst = id_subst `delVarEnvList` vs }+-- See Note [Bangs in the Simplifier]+  = let !in_scope1 = in_scope `extendInScopeSetList` vs+        !id_subst1 = id_subst `delVarEnvList` vs+    in+    env { seInScope = in_scope1,+          seIdSubst = id_subst1 }         -- Why delete?  Consider         --      let x = a*b in (x, \x -> x+3)         -- We add [x |-> a*b] to the substitution, but we must@@ -527,8 +551,8 @@       = SimplFloats { sfLetFloats  = unitLetFloat bind                     , sfJoinFloats = emptyJoinFloats                     , sfInScope    = in_scope' }--    in_scope' = seInScope env `extendInScopeSetBind` bind+    -- See Note [Bangs in the Simplifier]+    !in_scope' = seInScope env `extendInScopeSetBind` bind  extendFloats :: SimplFloats -> OutBind -> SimplFloats -- Add this binding to the floats, and extend the in-scope env too@@ -589,21 +613,21 @@ 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+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs _ff                                 , sfJoinFloats = jbs                                 , sfInScope    = in_scope })-  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )-    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+  = ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )     SimplFloats { sfLetFloats  = floats'                 , sfJoinFloats = jfloats'                 , sfInScope    = in_scope }   where-    floats'  | isNilOL bs  = emptyLetFloats-             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))-    jfloats' | isNilOL jbs = emptyJoinFloats-             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))+    -- See Note [Bangs in the Simplifier]+    !floats'  | isNilOL bs  = emptyLetFloats+              | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))+    !jfloats' | isNilOL jbs = emptyJoinFloats+              | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))  wrapFloats :: SimplFloats -> OutExpr -> OutExpr -- Wrap the floats around the expression; they should all@@ -633,12 +657,14 @@   = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings     letFloatBinds lbs +{-# INLINE mapLetFloats #-} mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats mapLetFloats (LetFloats fs ff) fun-   = LetFloats (mapOL app fs) ff+   = LetFloats fs1 ff    where     app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'-    app (Rec bs)     = Rec (map fun bs)+    app (Rec bs)     = Rec (strictMap fun bs)+    !fs1 = (mapOL' app fs) -- See Note [Bangs in the Simplifier]  {- ************************************************************************@@ -677,7 +703,8 @@ refineFromInScope in_scope v   | isLocalId v = case lookupInScope in_scope v of                   Just v' -> v'-                  Nothing -> WARN( True, ppr v ) v  -- This is an error!+                  Nothing -> pprPanic "refineFromInScope" (ppr in_scope $$ ppr v)+                             -- c.f #19074 for a subtle place where this went wrong   | otherwise = v  lookupRecBndr :: SimplEnv -> InId -> OutId@@ -731,7 +758,7 @@ -}  simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs+simplBinders  !env bndrs = mapAccumLM simplBinder  env bndrs  ------------- simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)@@ -740,7 +767,7 @@ -- Return with IdInfo already substituted, but (fragile) occurrence info zapped -- The substitution is extended only if the variable is cloned, because -- we *don't* need to use it to track occurrence info.-simplBinder env bndr+simplBinder !env bndr   | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr                         ; seqTyVar tv `seq` return (env', tv) }   | otherwise     = do  { let (env', id) = substIdBndr env bndr@@ -749,16 +776,18 @@ --------------- simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr) -- A non-recursive let binder-simplNonRecBndr env id-  = do  { let (env1, id1) = substIdBndr env id+simplNonRecBndr !env id+  -- See Note [Bangs in the Simplifier]+  = do  { let (!env1, id1) = substIdBndr env id         ; seqId id1 `seq` return (env1, id1) }  --------------- simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv -- Recursive let binders simplRecBndrs env@(SimplEnv {}) ids+  -- See Note [Bangs in the Simplifier]   = ASSERT(all (not . isJoinId) ids)-    do  { let (env1, ids1) = mapAccumL substIdBndr env ids+    do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 }  @@ -793,6 +822,10 @@ --      all fragile info is zapped substNonCoVarIdBndr env id = subst_id_bndr env id (\x -> x) +-- Inline to make the (OutId -> OutId) function a known call.+-- This is especially important for `substNonCoVarIdBndr` which+-- passes an identity lambda.+{-# INLINE subst_id_bndr #-} subst_id_bndr :: SimplEnv               -> InBndr    -- Env and binder to transform               -> (OutId -> OutId)  -- Adjust the type@@ -800,28 +833,31 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })               old_id adjust_type   = ASSERT2( not (isCoVar old_id), ppr old_id )-    (env { seInScope = in_scope `extendInScopeSet` new_id,+    (env { seInScope = new_in_scope,            seIdSubst = new_subst }, new_id)-    -- It's important that both seInScope and seIdSubt are updated with+    -- It's important that both seInScope and seIdSubst are updated with     -- the new_id, /after/ applying adjust_type. That's why adjust_type     -- is done here.  If we did adjust_type in simplJoinBndr (the only     -- place that gives a non-identity adjust_type) we'd have to fiddle     -- afresh with both seInScope and seIdSubst   where-    id1  = uniqAway in_scope old_id-    id2  = substIdType env id1-    id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding+    -- See Note [Bangs in the Simplifier]+    !id1  = uniqAway in_scope old_id+    !id2  = substIdType env id1+    !id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding                                       -- and fragile OccInfo-    new_id = adjust_type id3+    !new_id = adjust_type id3          -- Extend the substitution if the unique has changed,         -- or there's some useful occurrence information         -- See the notes with substTyVarBndr for the delSubstEnv-    new_subst | new_id /= old_id+    !new_subst | new_id /= old_id               = extendVarEnv id_subst old_id (DoneId new_id)               | otherwise               = delVarEnv id_subst old_id +    !new_in_scope = in_scope `extendInScopeSet` new_id+ ------------------------------------ seqTyVar :: TyVar -> () seqTyVar b = b `seq` ()@@ -930,7 +966,7 @@     orig_ar = idJoinArity join_id     orig_ty = idType join_id -    new_join_ty = go orig_ar orig_ty+    new_join_ty = go orig_ar orig_ty :: Type      go 0 _  = new_res_ty     go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty@@ -939,7 +975,8 @@             | otherwise             = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty) -    scale_bndr (Anon af t) = Anon af (scaleScaled mult t)+    -- See Note [Bangs in the Simplifier]+    scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)     scale_bndr b@(Named _) = b  {- Note [Scaling join point arguments]

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,13 +31,15 @@ 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 import GHC.Utils.Monad-import GHC.Utils.Error as Err+import GHC.Utils.Logger as Logger import GHC.Utils.Misc      ( count ) import GHC.Utils.Panic     (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic     ( IntWithInf, treatZeroAsInf, mkIntWithInf )@@ -58,44 +60,52 @@  newtype SimplM result   =  SM'  { unSM :: SimplTopEnv  -- Envt that does not change much-                 -> UniqSupply   -- We thread the unique supply because-                                 -- constantly splitting it is rather expensive                  -> SimplCount-                 -> IO (result, UniqSupply, SimplCount)}-    -- We only need IO here for dump output-    deriving (Functor)+                 -> IO (result, SimplCount)}+    -- We only need IO here for dump output, but since we already have it+    -- we might as well use it for uniques. -pattern SM :: (SimplTopEnv -> UniqSupply -> SimplCount-               -> IO (result, UniqSupply, SimplCount))+pattern SM :: (SimplTopEnv -> SimplCount+               -> IO (result, SimplCount))           -> SimplM result -- This pattern synonym makes the simplifier monad eta-expand, -- which as a very beneficial effect on compiler performance -- (worth a 1-2% reduction in bytes-allocated).  See #18202.--- See Note [The one-shot state monad trick] in GHC.Core.Unify+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad pattern SM m <- SM' m   where-    SM m = SM' (oneShot m)+    SM m = SM' (oneShot $ \env -> oneShot $ \ct -> m env ct)  data SimplTopEnv   = STE { st_flags     :: DynFlags-        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run+        , st_logger    :: !Logger+        , st_max_ticks :: IntWithInf  -- ^ Max #ticks in this simplifier run         , st_rules     :: RuleEnv-        , st_fams      :: (FamInstEnv, FamInstEnv) }+        , st_fams      :: (FamInstEnv, FamInstEnv) -initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)-         -> UniqSupply          -- No init count; set to 0+        , st_co_opt_opts :: !OptCoercionOpts+            -- ^ Coercion optimiser options+        }++initSmpl :: Logger -> DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)          -> Int                 -- Size of the bindings, used to limit                                 -- the number of ticks we allow          -> SimplM a          -> IO (a, SimplCount) -initSmpl dflags rules fam_envs us size m-  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)+initSmpl logger dflags rules fam_envs size m+  = do -- No init count; set to 0+       let simplCount = zeroSimplCount dflags+       (result, count) <- unSM m env simplCount        return (result, count)   where-    env = STE { st_flags = dflags, st_rules = rules+    env = STE { st_flags = dflags+              , st_logger = logger+              , 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@@ -120,7 +130,10 @@ {-# INLINE thenSmpl #-} {-# INLINE thenSmpl_ #-} {-# INLINE returnSmpl #-}+{-# INLINE mapSmpl #-} +instance Functor SimplM where+  fmap = mapSmpl  instance Applicative SimplM where     pure  = returnSmpl@@ -131,21 +144,24 @@    (>>)   = (*>)    (>>=)  = thenSmpl +mapSmpl :: (a -> b) -> SimplM a -> SimplM b+mapSmpl f m = thenSmpl m (returnSmpl . f)+ returnSmpl :: a -> SimplM a-returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))+returnSmpl e = SM (\_st_env sc -> return (e, sc))  thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b thenSmpl_ :: SimplM a -> SimplM b -> SimplM b  thenSmpl m k-  = SM $ \st_env us0 sc0 -> do-      (m_result, us1, sc1) <- unSM m st_env us0 sc0-      unSM (k m_result) st_env us1 sc1+  = SM $ \st_env sc0 -> do+      (m_result, sc1) <- unSM m st_env sc0+      unSM (k m_result) st_env sc1  thenSmpl_ m k-  = SM $ \st_env us0 sc0 -> do-      (_, us1, sc1) <- unSM m st_env us0 sc0-      unSM k st_env us1 sc1+  = SM $ \st_env sc0 -> do+      (_, sc1) <- unSM m st_env sc0+      unSM k st_env sc1  -- TODO: this specializing is not allowed -- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}@@ -154,10 +170,11 @@  traceSmpl :: String -> SDoc -> SimplM () traceSmpl herald doc-  = do { dflags <- getDynFlags-       ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"-           FormatText-           (hang (text herald) 2 doc) }+  = do dflags <- getDynFlags+       logger <- getLogger+       liftIO $ Logger.dumpIfSet_dyn logger dflags Opt_D_dump_simpl_trace "Simpl Trace"+         FormatText+         (hang (text herald) 2 doc) {-# INLINE traceSmpl #-}  -- see Note [INLINE conditional tracing utilities]  {-@@ -168,33 +185,34 @@ ************************************************************************ -} -instance MonadUnique SimplM where-    getUniqueSupplyM-       = SM (\_st_env us sc -> case splitUniqSupply us of-                                (us1, us2) -> return (us1, us2, sc))--    getUniqueM-       = SM (\_st_env us sc -> case takeUniqFromSupply us of-                                (u, us') -> return (u, us', sc))+-- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques+simplMask :: Char+simplMask = 's' -    getUniquesM-        = SM (\_st_env us sc -> case splitUniqSupply us of-                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))+instance MonadUnique SimplM where+    getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplMask+    getUniqueM = liftIO $ uniqFromMask simplMask  instance HasDynFlags SimplM where-    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))+    getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc)) +instance HasLogger SimplM where+    getLogger = SM (\st_env sc -> return (st_logger st_env, sc))+ instance MonadIO SimplM where-    liftIO m = SM $ \_ us sc -> do+    liftIO m = SM $ \_ sc -> do       x <- m-      return (x, us, sc)+      return (x, sc)  getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))+getSimplRules = SM (\st_env sc -> return (st_rules st_env, sc))  getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)-getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))+getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc)) +getOptCoercionOpts :: SimplM OptCoercionOpts+getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc))+ newId :: FastString -> Mult -> Type -> SimplM Id newId fs w ty = do uniq <- getUniqueM                    return (mkSysLocalOrCoVar fs uniq w ty)@@ -222,29 +240,34 @@ -}  getSimplCount :: SimplM SimplCount-getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))+getSimplCount = SM (\_st_env sc -> return (sc, sc))  tick :: Tick -> SimplM ()-tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc-                              in sc' `seq` return ((), us, sc'))+tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc+                              in sc' `seq` return ((), sc'))  checkedTick :: Tick -> SimplM () -- Try to take a tick, but fail if too many checkedTick t-  = SM (\st_env us sc ->+  = SM (\st_env sc ->            if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)            then throwGhcExceptionIO $                   PprProgramError "Simplifier ticks exhausted" (msg sc)            else let sc' = doSimplTick (st_flags st_env) t sc-                in sc' `seq` return ((), us, sc'))+                in sc' `seq` return ((), sc'))   where     msg sc = vcat       [ text "When trying" <+> ppr t       , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."       , space-      , text "If you need to increase the limit substantially, please file a"-      , text "bug report and indicate the factor you needed."+      , text "In addition try adjusting -funfolding-case-threshold=N and"+      , text "-funfolding-case-scaling=N for the module in question."+      , text "Using threshold=1 and scaling=5 should break most inlining loops."       , space+      , text "If you need to increase the tick factor substantially, while also"+      , text "adjusting unfolding parameters please file a bug report and"+      , text "indicate the factor you needed."+      , space       , text "If GHC was unable to complete compilation even"                <+> text "with a very large factor"       , text "(a thousand or more), please consult the"@@ -264,5 +287,5 @@ -- Record a tick, but don't add to the total tick count, which is -- used to decide when nothing further has happened freeTick t-   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc-                           in sc' `seq` return ((), us, sc'))+   = SM (\_st_env sc -> let sc' = doFreeSimplTick t sc+                           in sc' `seq` return ((), sc'))

GHC/Core/Opt/Simplify/Utils.hs view

@@ -44,6 +44,7 @@ import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) ) import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Core import qualified GHC.Core.Subst import GHC.Core.Ppr@@ -52,9 +53,11 @@ 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+import GHC.Types.Tickish import GHC.Types.Var import GHC.Types.Demand import GHC.Types.Var.Set@@ -68,6 +71,8 @@ import GHC.Data.OrdList ( isNilOL ) import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Logger+import GHC.Utils.Panic import GHC.Core.Opt.ConstantFold import GHC.Data.FastString ( fsLit ) @@ -162,7 +167,7 @@       , sc_cont :: SimplCont }    | TickIt              -- (TickIt t K)[e] = K[ tick t e ]-        (Tickish Id)    -- Tick tickish <hole>+        CoreTickish     -- Tick tickish <hole>         SimplCont  type StaticEnv = SimplEnv       -- Just the static part is relevant@@ -326,7 +331,7 @@ isStrictArgInfo :: ArgInfo -> Bool -- True if the function is strict in the next argument isStrictArgInfo (ArgInfo { ai_dmds = dmds })-  | dmd:_ <- dmds = isStrictDmd dmd+  | dmd:_ <- dmds = isStrUsedDmd dmd   | otherwise     = False  argInfoAppArgs :: [ArgSpec] -> [OutExpr]@@ -573,13 +578,13 @@     add_type_strictness fun_ty dmds       | null dmds = [] -      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty+      | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty       = add_type_strictness fun_ty' dmds     -- Look through foralls        | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info       , dmd : rest_dmds <- dmds       , let dmd' = case isLiftedType_maybe arg_ty of-                       Just False -> strictenDmd dmd+                       Just False -> strictifyDmd dmd                        _          -> dmd       = dmd' : add_type_strictness fun_ty' rest_dmds           -- If the type is levity-polymorphic, we can't know whether it's@@ -855,29 +860,36 @@         sm_eta_expand :: Bool     -- Whether eta-expansion is enabled -} -simplEnvForGHCi :: DynFlags -> SimplEnv-simplEnvForGHCi dflags+simplEnvForGHCi :: Logger -> DynFlags -> SimplEnv+simplEnvForGHCi logger dflags   = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]                            , sm_phase  = InitialPhase+                           , sm_logger = logger                            , 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]-updModeForStableUnfoldings inline_rule_act current_mode-  = current_mode { sm_phase      = phaseFromActivation inline_rule_act+updModeForStableUnfoldings unf_act current_mode+  = current_mode { sm_phase      = phaseFromActivation unf_act                  , sm_inline     = True                  , sm_eta_expand = False }-                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]-       -- For sm_rules, just inherit; sm_rules might be "off"+       -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]+       -- sm_rules: just inherit; sm_rules might be "off"        -- because of -fno-enable-rewrite-rules   where     phaseFromActivation (ActiveAfter _ n) = Phase n@@ -1181,7 +1193,7 @@ inactive in the initial stages.  See Note [Gentle mode].  Note [Stable unfoldings and preInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas! Example @@ -1198,15 +1210,22 @@ it might make fInt look big, and we'll lose the opportunity to inline f at each of fInt's call sites.  The INLINE pragma will only inline when the application is saturated for exactly this reason; and we don't-want PreInlineUnconditionally to second-guess it.  A live example is-#3736.+want PreInlineUnconditionally to second-guess it. A live example is #3736.     c.f. Note [Stable unfoldings and postInlineUnconditionally] -NB: if the pragma is INLINEABLE, then we don't want to behave in-this special way -- an INLINEABLE pragma just says to GHC "inline this-if you like".  But if there is a unique occurrence, we want to inline-the stable unfolding, not the RHS.+NB: this only applies for INLINE things. Do /not/ switch off+preInlineUnconditionally for +* INLINABLE. It just says to GHC "inline this if you like".  If there+  is a unique occurrence, we want to inline the stable unfolding, not+  the RHS.++* NONLINE[n] just switches off inlining until phase n.  We should+  respect that, but after phase n, just behave as usual.++* NoUserInlinePrag.  There is no pragma at all. This ends up on wrappers.+  (See #18815.)+ Note [Top-level bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Don't inline top-level Ids that are bottoming, even if they are used just@@ -1236,15 +1255,15 @@   | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]                                                        -- in module Exitify   | not (one_occ (idOccInfo bndr))           = Nothing-  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)+  | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs)    -- Note [Stable unfoldings and preInlineUnconditionally]-  | isInlinablePragma inline_prag-  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)+  | not (isInlinePragma inline_prag)+  , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)   | otherwise                                = Nothing   where     unf = idUnfolding bndr-    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)+    extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)      one_occ IAmDead = True -- Happens in ((\x.1) v)     one_occ OneOcc{ occ_n_br   = 1@@ -1254,7 +1273,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 +1389,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 +1435,7 @@    where     unfolding = idUnfolding bndr-    dflags    = seDynFlags env+    uf_opts   = seUnfoldingOpts env     phase     = sm_phase (getMode env)     active    = isActive phase (idInlineActivation bndr)         -- See Note [pre/postInlineUnconditionally in gentle mode]@@ -1466,7 +1485,7 @@ So I just set an arbitrary, high limit of 100, to stop any totally exponential behaviour. -This still leaves the nasty possiblity that /ordinary/ inlining (not+This still leaves the nasty possibility that /ordinary/ inlining (not postInlineUnconditionally) might inline these join points, each of which is individually quiet small.  I'm still not sure what to do about this (e.g. see #15488).@@ -1649,8 +1668,8 @@   | Just join_arity <- isJoinId_maybe bndr   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs              oss   = [idOneShotInfo id | id <- join_bndrs, isId id]-             arity_type | exprIsDeadEnd join_body = ABot (length oss)-                        | otherwise               = ATop oss+             arity_type | exprIsDeadEnd join_body = mkBotArityType oss+                        | otherwise               = mkTopArityType oss        ; return (arity_type, rhs) }          -- Note [Do not eta-expand join points]          -- But do return the correct arity and bottom-ness, because@@ -1909,9 +1928,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@@ -1926,7 +1945,7 @@     abstract subst (NonRec id rhs)       = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id            ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'-                 subst' = GHC.Core.Subst.extendIdSubst subst id poly_app+                 !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app            ; return (subst', NonRec poly_id2 poly_rhs) }       where         rhs' = GHC.Core.Subst.substExpr subst rhs@@ -1987,7 +2006,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@@ -2229,15 +2248,15 @@ --      1. Merge Nested Cases -------------------------------------------------- -mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)+mkCase dflags scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)   | gopt Opt_CaseMerge dflags   , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)        <- stripTicksTop tickishFloatable deflt_rhs   , inner_scrut_var == outer_bndr   = do  { tick (CaseMerge outer_bndr) -        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )-                                          (con, args, wrap_rhs rhs)+        ; let wrap_alt (Alt con args rhs) = ASSERT( outer_bndr `notElem` args )+                                            (Alt con args (wrap_rhs rhs))                 -- Simplifier's no-shadowing invariant should ensure                 -- that outer_bndr is not shadowed by the inner patterns               wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs@@ -2271,13 +2290,13 @@ --      2. Eliminate Identity Case -------------------------------------------------- -mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case+mkCase1 _dflags scrut case_bndr _ alts@(Alt _ _ rhs1 : _)      -- Identity case   | all identity_alt alts   = do { tick (CaseIdentity case_bndr)        ; return (mkTicks ticks $ re_cast scrut rhs1) }   where-    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)-    identity_alt (con, args, rhs) = check_eq rhs con args+    ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) (tail alts)+    identity_alt (Alt con args rhs) = check_eq rhs con args      check_eq (Cast rhs co) con args        -- See Note [RHS casts]       = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args@@ -2319,8 +2338,8 @@ mkCase2 dflags scrut bndr alts_ty alts   | -- See Note [Scrutinee Constant Folding]     case alts of  -- Not if there is just a DEFAULT alternative-      [(DEFAULT,_,_)] -> False-      _               -> True+      [Alt DEFAULT _ _] -> False+      _                 -> True   , gopt Opt_CaseFolding dflags   , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut   = do { bndr' <- newId (fsLit "lwild") Many (exprType scrut')@@ -2355,11 +2374,11 @@      tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id            -> CoreAlt -> SimplM (Maybe CoreAlt)-    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)+    tx_alt tx_con mk_orig new_bndr (Alt con bs rhs)       = case tx_con con of           Nothing   -> return Nothing           Just con' -> do { bs' <- mk_new_bndrs new_bndr con'-                          ; return (Just (con', bs', rhs')) }+                          ; return (Just (Alt con' bs' rhs')) }       where         rhs' | isDeadBinder bndr = rhs              | otherwise         = bindNonRec bndr orig_val rhs@@ -2386,8 +2405,8 @@      add_default :: [CoreAlt] -> [CoreAlt]     -- See Note [Literal cases]-    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts-    add_default alts                          = alts+    add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts+    add_default alts                            = alts  {- Note [Literal cases] ~~~~~~~~~~~~~~~~~~~~~~~

GHC/Core/Opt/SpecConstr.hs view

@@ -26,17 +26,17 @@ 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 )-import GHC.Driver.Types ( ModGuts(..) )+import GHC.Unit.Module.ModGuts import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs ) import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules import GHC.Core.Type     hiding ( substTy )-import GHC.Core.TyCon   ( tyConName )+import GHC.Core.TyCon   ( tyConUnique, tyConName ) import GHC.Core.Multiplicity import GHC.Types.Id import GHC.Core.Ppr     ( pprParendExpr )@@ -44,9 +44,11 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name+import GHC.Types.Tickish import GHC.Types.Basic import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )                           , gopt, hasPprDebug )+import GHC.Driver.Ppr import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing ) import GHC.Types.Demand import GHC.Types.Cpr@@ -55,12 +57,13 @@ import GHC.Data.Pair import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique.FM import GHC.Utils.Monad import Control.Monad    ( zipWithM )-import Data.List-import GHC.Builtin.Names ( specTyConName )+import Data.List (nubBy, sortBy, partition)+import GHC.Builtin.Names ( specTyConKey ) import GHC.Unit.Module import GHC.Core.TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) )@@ -813,6 +816,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@@ -867,6 +871,7 @@ initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv initScEnv dflags this_mod anns   = SCE { sc_dflags      = dflags,+          sc_uf_opts     = unfoldingOpts dflags,           sc_module      = this_mod,           sc_size        = specConstrThreshold dflags,           sc_count       = specConstrCount     dflags,@@ -1004,7 +1009,6 @@ ignoreType    :: ScEnv -> Type   -> Bool ignoreDataCon  :: ScEnv -> DataCon -> Bool forceSpecBndr :: ScEnv -> Var    -> Bool-forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var  ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) @@ -1017,6 +1021,8 @@ ignoreTyCon env tycon   = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr +forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var+ forceSpecFunTy :: ScEnv -> Type -> Bool forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys @@ -1027,7 +1033,7 @@ forceSpecArgTy env ty   | Just (tycon, tys) <- splitTyConApp_maybe ty   , tycon /= funTyCon-      = tyConName tycon == specTyConName+      = tyConUnique tycon == specTyConKey         || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr         || any (forceSpecArgTy env) tys @@ -1111,14 +1117,6 @@  combineCalls :: CallEnv -> CallEnv -> CallEnv combineCalls = plusVarEnv_C (++)-  where---    plus cs ds | length res > 1---               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs---                                               , text "ds:" <+> ppr ds])---                 res---               | otherwise = res---       where---          res = cs ++ ds  combineUsage :: ScUsage -> ScUsage -> ScUsage combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),@@ -1236,8 +1234,8 @@         }   where     sc_con_app con args scrut'  -- Known constructor; simplify-     = do { let (_, bs, rhs) = findAlt con alts-                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)+     = do { let Alt _ bs rhs = findAlt con alts+                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty)                 alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)           ; scExpr alt_env' rhs } @@ -1257,7 +1255,7 @@           ; return (foldr combineUsage scrut_usg' alt_usgs,                     Case scrut' b' (scSubstTy env ty) alts') } -    sc_alt env scrut' b' (con,bs,rhs)+    sc_alt env scrut' b' (Alt con bs rhs)      = do { let (env1, bs1) = extendBndrsWith RecArg env bs                 (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1           ; (usg, rhs') <- scExpr env2 rhs@@ -1265,7 +1263,7 @@                 scrut_occ = case con of                                DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)                                _          -> ScrutOcc emptyUFM-          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }+          ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }  scExpr' env (Let (NonRec bndr rhs) body)   | isTyVar bndr        -- Type-lets may be created by doBeta@@ -1411,7 +1409,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@@ -1777,11 +1775,12 @@     go env _      _                = env      go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv-    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d-    go_one env d e-           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict-           , (Var _, args) <- collectArgs e = go env ds args-    go_one env _         _ = env+    go_one env d          (Var v) = extendVarEnv_C plusDmd env v d+    go_one env (_n :* cd) e -- NB: _n does not have to be strict+      | (Var _, args) <- collectArgs e+      , Just ds <- viewProd (length args) cd+      = go env ds args+    go_one env _               _       = env  {- Note [spec_usg includes rhs_usg]@@ -1789,8 +1788,8 @@ In calls to 'specialise', the returned ScUsage must include the rhs_usg in the passed-in SpecInfo, unless there are no calls at all to the function. -The caller can, indeed must, assume this.  He should not combine in rhs_usg-himself, or he'll get rhs_usg twice -- and that can lead to an exponential+The caller can, indeed must, assume this.  They should not combine in rhs_usg+themselves, or they'll get rhs_usg twice -- and that can lead to an exponential blowup of duplicates in the CallEnv.  This is what gave rise to the massive performance loss in #8852.

GHC/Core/Opt/Specialise.hs view

@@ -1,59 +1,67 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998  \section[Specialise]{Stamping out overloading, and (optionally) polymorphism} -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where  #include "HsVersions.h"  import GHC.Prelude -import GHC.Types.Id+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Config+import GHC.Driver.Env+ import GHC.Tc.Utils.TcType hiding( substTy )+ import GHC.Core.Type  hiding( substTy, extendTvSubstList ) import GHC.Core.Multiplicity import GHC.Core.Predicate-import GHC.Unit.Module( Module, HasModule(..) ) import GHC.Core.Coercion( Coercion ) import GHC.Core.Opt.Monad import qualified GHC.Core.Subst as Core-import GHC.Core.Unfold-import GHC.Types.Var      ( isLocalVar )-import GHC.Types.Var.Set-import GHC.Types.Var.Env+import GHC.Core.Unfold.Make 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.TyCo.Rep (TyCoBinder (..))+import GHC.Core.Opt.Arity     ( collectBindersPushingCo+                              , etaExpandToJoinPointRule )++import GHC.Builtin.Types  ( unboxedUnitTy )++import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust )+import GHC.Data.Bag+import GHC.Data.FastString++import GHC.Types.Basic import GHC.Types.Unique.Supply+import GHC.Types.Unique.DFM import GHC.Types.Name+import GHC.Types.Tickish import GHC.Types.Id.Make  ( voidArgId, voidPrimId )-import GHC.Builtin.Types.Prim ( voidPrimTy )-import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust )+import GHC.Types.Var      ( isLocalVar )+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+ import GHC.Utils.Monad    ( foldlM )-import GHC.Types.Basic-import GHC.Driver.Types-import GHC.Data.Bag-import GHC.Driver.Session import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Utils.Monad.State-import GHC.Types.Unique.DFM-import GHC.Core.TyCo.Rep (TyCoBinder (..))+import GHC.Utils.Panic -import Control.Monad+import GHC.Unit.Module( Module )+import GHC.Unit.Module.ModGuts+import GHC.Unit.External  {- ************************************************************************@@ -588,29 +596,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -639,13 +648,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 []) @@ -653,8 +662,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@@ -670,9 +678,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@@ -682,8 +688,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@@ -697,16 +702,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@@ -715,8 +717,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@@ -724,11 +725,9 @@                         -- call to the original function    | null good_calls-  = do { -- debugTraceMsg (text "specImport:no valid calls")-       ; return ([], []) }+  = 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@@ -739,9 +738,8 @@              rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn         ; (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 }+            <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr 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@@ -749,7 +747,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)@@ -765,11 +763,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@@ -794,24 +815,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].@@ -824,7 +868,7 @@ from the parent.  Lacking this caused #17151, a really nasty bug.  Here is what happened.-* Class struture:+* Class structure:     Source is a superclass of Mut     Index is a superclass of Source @@ -908,7 +952,7 @@ Note [specImport call stack] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When specialising an imports function 'f', we may get new calls-of an imported fuction 'g', which we want to specialise in turn,+of an imported function 'g', which we want to specialise in turn, and similarly specialising 'g' might expose a new call to 'h'.  We track the stack of enclosing functions. So when specialising 'h' we@@ -999,6 +1043,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@@ -1079,9 +1126,9 @@        ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }  ---------------specTickish :: SpecEnv -> Tickish Id -> Tickish Id-specTickish env (Breakpoint ix ids)-  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]+specTickish :: SpecEnv -> CoreTickish -> CoreTickish+specTickish env (Breakpoint ext ix ids)+  = Breakpoint ext ix [ id' | id <- ids, Var id' <- [specVar env id]]   -- drop vars from the list if they have a non-variable substitution.   -- should never happen, but it's harmless to drop them anyway. specTickish _ other_tickish = other_tickish@@ -1094,14 +1141,14 @@                   , Id                   , [CoreAlt]                   , UsageDetails)-specCase env scrut' case_bndr [(con, args, rhs)]+specCase env scrut' case_bndr [Alt con args rhs]   | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]   , interestingDict env scrut'   , not (isDeadBinder case_bndr && null sc_args')   = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')         ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')-                              [(con, args', Var sc_arg')]+                              [Alt con args' (Var sc_arg')]                        | sc_arg' <- sc_args' ]               -- Extend the substitution for RHS to map the *original* binders@@ -1125,7 +1172,7 @@              flt_binds     = scrut_bind : sc_binds              (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds              all_uds = flt_binds `addDictBinds` free_uds-             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')+             alt'    = Alt con args' (wrapDictBindsE dumped_dbs rhs')        ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }   where     (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)@@ -1154,10 +1201,10 @@        ; return (scrut, case_bndr', alts', uds_alts) }   where     (env_alt, case_bndr') = substBndr env case_bndr-    spec_alt (con, args, rhs) = do+    spec_alt (Alt con args rhs) = do           (rhs', uds) <- specExpr env_rhs rhs           let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds-          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)+          return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds)         where           (env_rhs, args') = substBndrs env_alt args @@ -1306,7 +1353,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@@ -1319,8 +1366,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]@@ -1335,7 +1382,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))@@ -1366,7 +1413,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] @@ -1408,8 +1457,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@@ -1427,7 +1474,7 @@                  (spec_bndrs, spec_rhs, spec_fn_ty)                    | add_void_arg = ( voidPrimId : spec_bndrs1                                     , Lam        voidArgId  spec_rhs1-                                    , mkVisFunTyMany voidPrimTy spec_fn_ty1)+                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)                    | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1)                   join_arity_decr = length rule_lhs_args - length spec_bndrs@@ -1437,17 +1484,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))@@ -1476,6 +1521,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]@@ -1485,10 +1532,10 @@                         -- See Note [Specialising imported functions] in "GHC.Core.Opt.OccurAnal"                    | InlinePragma { inl_inline = Inlinable } <- inl_prag-                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)+                  = (inl_prag { inl_inline = NoUserInlinePrag }, 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)                  --------------------------------------@@ -2474,15 +2521,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@@ -2519,12 +2566,23 @@     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!+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2774,55 +2832,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)

GHC/Core/Opt/StaticArgs.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -48,7 +50,6 @@ essential to make this work well! -} -{-# LANGUAGE CPP, PatternSynonyms #-} module GHC.Core.Opt.StaticArgs ( doStaticArgs ) where  import GHC.Prelude@@ -68,6 +69,7 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.List (mapAccumL) import GHC.Data.FastString@@ -187,7 +189,7 @@                    else Nothing     return (var, emptyIdSATInfo, app_info) -satExpr lit@(Lit _) _ = do+satExpr lit@(Lit _) _ =     return (lit, emptyIdSATInfo, Nothing)  satExpr (Lam binders body) interesting_ids = do@@ -223,9 +225,9 @@     let (alts', sat_infos_alts) = unzip zipped_alts'     return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)   where-    satAlt (con, bndrs, expr) = do+    satAlt (Alt con bndrs expr) = do         (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids-        return ((con, bndrs, expr'), sat_info_expr)+        return (Alt con bndrs expr', sat_info_expr)  satExpr (Let bind body) interesting_ids = do     (body', sat_info_body, body_app) <- satExpr body interesting_ids@@ -236,10 +238,10 @@     (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids     return (Tick tickish expr', sat_info_expr, expr_app) -satExpr ty@(Type _) _ = do+satExpr ty@(Type _) _ =     return (ty, emptyIdSATInfo, Nothing) -satExpr co@(Coercion _) _ = do+satExpr co@(Coercion _) _ =     return (co, emptyIdSATInfo, Nothing)  satExpr (Cast expr coercion) interesting_ids = do

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@@ -21,11 +22,16 @@ import GHC.Types.Unique.Supply 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.Types.SourceText import GHC.Core.Opt.WorkWrap.Utils import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Types.Unique+import GHC.Utils.Panic import GHC.Core.FamInstEnv import GHC.Utils.Monad @@ -137,12 +143,12 @@       -- See Note [Zapping Used Once info in WorkWrap]     return (Case new_expr new_binder ty new_alts)   where-    ww_alt (con, binders, rhs) = do+    ww_alt (Alt con binders rhs) = do         new_rhs <- wwExpr dflags fam_envs rhs         let new_binders = [ if isId b then zapIdUsedOnceInfo b else b                           | b <- binders ]            -- See Note [Zapping Used Once info in WorkWrap]-        return (con, new_binders, new_rhs)+        return (Alt con new_binders new_rhs)  {- ************************************************************************@@ -203,6 +209,23 @@ How do we "transfer the unfolding"? Easy: by using the old one, wrapped in work_fn! See GHC.Core.Unfold.mkWorkerUnfolding. +Note [No worker-wrapper for record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We sometimes generate a lot of record selectors, and generally the+don't benefit from worker/wrapper.  Yes, mkWwBodies would find a w/w split,+but it is then suppressed by the certainlyWillInline test in splitFun.++The wasted effort in mkWwBodies makes a measurable difference in+compile time (see MR !2873), so although it's a terribly ad-hoc test,+we just check here for record selectors, and do a no-op in that case.++I did look for a generalisation, so that it's not just record+selectors that benefit.  But you'd need a cheap test for "this+function will definitely get a w/w split" and that's hard to predict+in advance...the logic in mkWwBodies is complex. So I've left the+super-simple test, with this Note to explain.++ Note [Worker-wrapper for NOINLINE functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We used to disable worker/wrapper for NOINLINE things, but it turns out@@ -316,8 +339,8 @@ In general, we refrain from w/w-ing *small* functions, which are not loop breakers, because they'll inline anyway.  But we must take care: it may look small now, but get to be big later after other inlining-has happened.  So we take the precaution of adding an INLINE pragma to-any such functions.+has happened.  So we take the precaution of adding a StableUnfolding+for any such functions.  I made this change when I observed a big function at the end of compilation with a useful strictness signature but no w-w.  (It was@@ -442,13 +465,19 @@   - Otherwise inline wrapper in phase 2.  That allows the     'gentle' simplification pass to apply specialisation rules --Note [Wrapper NoUserInline]+Note [Wrapper NoUserInlinePrag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~-The use an inl_inline of NoUserInline on the wrapper distinguishes-this pragma from one that was given by the user. In particular, CSE-will not happen if there is a user-specified pragma, but should happen-for w/w’ed things (#14186).+We use NoUserInlinePrag on the wrapper, to say that there is no+user-specified inline pragma. (The worker inherits that; see Note+[Worker-wrapper for INLINABLE functions].)  The wrapper has no pragma+given by the user.++(Historical note: we used to give the wrapper an INLINE pragma, but+CSE will not happen if there is a user-specified pragma, but should+happen for w/w’ed things (#14186).  We don't need a pragma, because+everything we needs is expressed by (a) the stable unfolding and (b)+the inl_act activation.)+ -}  tryWW   :: DynFlags@@ -465,7 +494,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]@@ -473,13 +502,14 @@   | is_fun && is_eta_exp   = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds div cpr rhs -  | is_thunk                                   -- See Note [Thunk splitting]+  | isNonRec is_rec, is_thunk                        -- See Note [Thunk splitting]   = splitThunk dflags fam_envs is_rec new_fn_id rhs    | otherwise   = return [ (new_fn_id, rhs) ]    where+    uf_opts      = unfoldingOpts dflags     fn_info      = idInfo fn_id     (wrap_dmds, div) = splitStrictSig (strictnessInfo fn_info) @@ -572,94 +602,117 @@   ----------------------splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> CprResult -> CoreExpr+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> Divergence -> Cpr -> CoreExpr          -> UniqSM [(Id, CoreExpr)] splitFun dflags fam_envs fn_id fn_info wrap_dmds div cpr rhs-  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) ) do-    -- The arity should match the signature-    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info-    case stuff of-      Just (work_demands, join_arity, wrap_fn, work_fn) -> do-        work_uniq <- getUniqueM-        let work_rhs = work_fn rhs-            work_act = case fn_inline_spec of  -- See Note [Worker activation]-                          NoInline -> inl_act fn_inl_prag-                          _        -> inl_act wrap_prag+  | isRecordSelector fn_id  -- See Note [No worker/wrapper for record selectors]+  = return [ (fn_id, rhs ) ] -            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"-                                     , inl_inline = fn_inline_spec-                                     , inl_sat    = Nothing-                                     , inl_act    = work_act-                                     , inl_rule   = FunLike }-              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]-              -- inl_act:    see Note [Worker activation]-              -- inl_rule:   it does not make sense for workers to be constructorlike.+  | otherwise+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr cpr) )+          -- The arity should match the signature+    do { mb_stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_cpr_info+       ; case mb_stuff of+            Nothing -> return [(fn_id, rhs)] -            work_join_arity | isJoinId fn_id = Just join_arity-                            | otherwise      = Nothing-              -- worker is join point iff wrapper is join point-              -- (see Note [Don't w/w join points for CPR])+            Just stuff+              | Just stable_unf <- certainlyWillInline (unfoldingOpts dflags) 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] -            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)-                        `setIdOccInfo` occInfo fn_info-                                -- Copy over occurrence info from parent-                                -- Notably whether it's a loop breaker-                                -- Doesn't matter much, since we will simplify next, but-                                -- seems right-er to do so+              | otherwise+              -> do { work_uniq <- getUniqueM+                    ; return (mkWWBindPair dflags fn_id fn_info arity rhs+                                           work_uniq div cpr stuff) } }+  where+    rhs_fvs = exprFreeVars rhs+    arity   = arityInfo fn_info+            -- The arity is set by the simplifier using exprEtaExpandArity+            -- So it may be more than the number of top-level-visible lambdas -                        `setInlinePragma` work_prag+    -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,+    -- see Note [Don't w/w join points for CPR].+    use_cpr_info  | isJoinId fn_id = topCpr+                  | otherwise      = cpr -                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding-                                -- See Note [Worker-wrapper for INLINABLE functions] -                        `setIdStrictness` mkClosedStrictSig work_demands div-                                -- Even though we may not be at top level,-                                -- it's ok to give it an empty DmdEnv+mkWWBindPair :: DynFlags -> Id -> IdInfo -> Arity+             -> CoreExpr -> Unique -> Divergence -> Cpr+             -> ([Demand], JoinArity, Id -> CoreExpr, Expr CoreBndr -> CoreExpr)+             -> [(Id, CoreExpr)]+mkWWBindPair dflags fn_id fn_info arity rhs work_uniq div cpr+             (work_demands, join_arity, wrap_fn, work_fn)+  = [(work_id, work_rhs), (wrap_id, wrap_rhs)]+     -- Worker first, because wrapper mentions it+  where+    simpl_opts = initSimpleOpts dflags -                        `setIdCprInfo` mkCprSig work_arity work_cpr_info+    work_rhs = work_fn rhs+    work_act = case fn_inline_spec of  -- See Note [Worker activation]+                   NoInline -> inl_act fn_inl_prag+                   _        -> inl_act wrap_prag -                        `setIdDemandInfo` worker_demand+    work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"+                             , inl_inline = fn_inline_spec+                             , inl_sat    = Nothing+                             , inl_act    = work_act+                             , inl_rule   = FunLike }+      -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+      -- inl_act:    see Note [Worker activation]+      -- inl_rule:   it does not make sense for workers to be constructorlike. -                        `setIdArity` work_arity-                                -- Set the arity so that the Core Lint check that the-                                -- arity is consistent with the demand type goes-                                -- through-                        `asJoinId_maybe` work_join_arity+    work_join_arity | isJoinId fn_id = Just join_arity+                    | otherwise      = Nothing+      -- worker is join point iff wrapper is join point+      -- (see Note [Don't w/w join points for CPR]) -            work_arity = length work_demands+    work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+                `setIdOccInfo` occInfo fn_info+                        -- Copy over occurrence info from parent+                        -- Notably whether it's a loop breaker+                        -- Doesn't matter much, since we will simplify next, but+                        -- seems right-er to do so -            -- See Note [Demand on the Worker]-            single_call = saturatedByOneShots arity (demandInfo fn_info)-            worker_demand | single_call = mkWorkerDemand work_arity-                          | otherwise   = topDmd+                `setInlinePragma` work_prag -            wrap_rhs  = wrap_fn work_id-            wrap_prag = mkStrWrapperInlinePrag fn_inl_prag-            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity-                              `setInlinePragma` wrap_prag-                              `setIdOccInfo`    noOccInfo-                                -- Zap any loop-breaker-ness, to avoid bleating from Lint-                                -- about a loop breaker with an INLINE rule+                `setIdUnfolding` mkWorkerUnfolding simpl_opts work_fn fn_unfolding+                        -- See Note [Worker-wrapper for INLINABLE functions] +                `setIdStrictness` mkClosedStrictSig work_demands div+                        -- Even though we may not be at top level,+                        -- it's ok to give it an empty DmdEnv +                `setIdCprInfo` mkCprSig work_arity work_cpr_info -        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]-            -- Worker first, because wrapper mentions it+                `setIdDemandInfo` worker_demand -      Nothing -> return [(fn_id, rhs)]-  where-    rhs_fvs         = exprFreeVars rhs+                `setIdArity` work_arity+                        -- Set the arity so that the Core Lint check that the+                        -- arity is consistent with the demand type goes+                        -- through+                `asJoinId_maybe` work_join_arity++    work_arity = length work_demands++    -- See Note [Demand on the Worker]+    single_call = saturatedByOneShots arity (demandInfo fn_info)+    worker_demand | single_call = mkWorkerDemand work_arity+                  | otherwise   = topDmd++    wrap_rhs  = wrap_fn work_id+    wrap_prag = mkStrWrapperInlinePrag fn_inl_prag++    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+                        -- about a loop breaker with an INLINE rule+     fn_inl_prag     = inlinePragInfo fn_info     fn_inline_spec  = inl_inline fn_inl_prag     fn_unfolding    = unfoldingInfo fn_info-    arity           = arityInfo fn_info-                    -- The arity is set by the simplifier using exprEtaExpandArity-                    -- So it may be more than the number of top-level-visible lambdas -    -- use_cpr_info is the CPR we w/w for. Note that we kill it for join points,-    -- see Note [Don't w/w join points for CPR].-    use_cpr_info  | isJoinId fn_id = topCpr-                  | otherwise      = cpr     -- Even if we don't w/w join points for CPR, we might still do so for     -- strictness. In which case a join point worker keeps its original CPR     -- property; see Note [Don't w/w join points for CPR]. Otherwise, the worker@@ -667,11 +720,10 @@     work_cpr_info | isJoinId fn_id = cpr                   | otherwise      = topCpr - mkStrWrapperInlinePrag :: InlinePragma -> InlinePragma mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })   = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInline -- See Note [Wrapper NoUserInline]+                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInline]                  , inl_sat    = Nothing                  , inl_act    = wrap_act                  , inl_rule   = rule_info }  -- RuleMatchInfo is (and must be) unaffected@@ -763,27 +815,63 @@ In fact, splitThunk uses the function argument w/w splitting function, so that if x's demand is deeper (say U(U(L,L),L)) then the splitting will go deeper too.++NB: For recursive thunks, the Simplifier is unable to float `x-rhs` out of+`x*`'s RHS, because `x*` occurs freely in `x-rhs`, and will just change it+back to the original definition, so we just split non-recursive thunks.++Note [Thunk splitting for top-level binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level bindings are never strict. Yet they can be absent, as T14270 shows:++  module T14270 (mkTrApp) where+  mkTrApp x y+    | Just ... <- ... typeRepKind x ...+    = undefined+    | otherwise+    = undefined+  typeRepKind = Tick scc undefined++(T19180 is a profiling-free test case for this)+Note that `typeRepKind` is not exported and its only use site in+`mkTrApp` guards a bottoming expression. Thus, demand analysis+figures out that `typeRepKind` is absent and splits the thunk to++  typeRepKind =+    let typeRepKind = Tick scc undefined in+    let typeRepKind = absentError in+    typeRepKind++But now we have a local binding with an External Name+(See Note [About the NameSorts]). That will trigger a CoreLint error, which we+get around by localising the Id for the auxiliary bindings in 'splitThunk'. -} --- See Note [Thunk splitting]+-- | See Note [Thunk splitting].+-- -- splitThunk converts the *non-recursive* binding --      x = e -- into---      x = let x = e---          in case x of---               I# y -> let x = I# y in x }+--      x = let x' = e in+--          case x' of I# y -> let x' = I# y in x' -- See comments above. Is it not beautifully short? -- Moreover, it works just as well when there are -- several binders, and if the binders are lifted -- E.g.     x = e---     -->  x = let x = e in---              case x of (a,b) -> let x = (a,b)  in x-+--     -->  x = let x' = e in+--              case x' of (a,b) -> let x' = (a,b)  in x'+-- Here, x' is a localised version of x, in case x is a+-- top-level Id with an External Name, because Lint rejects local binders with+-- External Names; see Note [About the NameSorts] in GHC.Types.Name.+--+-- How can we do thunk-splitting on a top-level binder?  See+-- Note [Thunk splitting for top-level binders]. splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]-splitThunk dflags fam_envs is_rec fn_id rhs-  = ASSERT(not (isJoinId fn_id))-    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]-       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]-       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive+splitThunk dflags fam_envs is_rec x rhs+  = ASSERT(not (isJoinId x))+    do { let x' = localiseId x -- See comment above+       ; (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [x']+       ; let res = [ (x, Let (NonRec x' rhs) (wrap_fn (work_fn (Var x')))) ]+       ; if useful then ASSERT2( isNonRec is_rec, ppr x ) -- The thunk must be non-recursive                    return res-                   else return [(fn_id, rhs)] }+                   else return [(x, rhs)] }

GHC/Core/Opt/WorkWrap/Utils.hs view

@@ -8,7 +8,7 @@  module GHC.Core.Opt.WorkWrap.Utils    ( mkWwBodies, mkWWstr, mkWorkerArgs-   , DataConAppContext(..), deepSplitProductType_maybe, wantToUnbox+   , DataConPatContext(..), UnboxingDecision(..), splitArgType_maybe, wantToUnbox    , findTypeShape    , isWorkerSmallEnough    )@@ -19,7 +19,8 @@ import GHC.Prelude  import GHC.Core-import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase )+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase, mkSingleAltCase+                        , dataConRepFSInstPat ) import GHC.Types.Id import GHC.Types.Id.Info ( JoinArity ) import GHC.Core.DataCon@@ -28,8 +29,7 @@ import GHC.Core.Make    ( mkAbsentErrorApp, mkCoreUbxTup                         , mkCoreApp, mkCoreLet ) import GHC.Types.Id.Make ( voidArgId, voidPrimId )-import GHC.Builtin.Types      ( tupleDataCon )-import GHC.Builtin.Types.Prim ( voidPrimTy )+import GHC.Builtin.Types      ( tupleDataCon, unboxedUnitTy ) import GHC.Types.Literal ( absentLiteralOf, rubbishLit ) import GHC.Types.Var.Env ( mkInScopeSet ) import GHC.Types.Var.Set ( VarSet )@@ -41,12 +41,16 @@ import GHC.Core.FamInstEnv import GHC.Types.Basic       ( Boxity(..) ) import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Types.Unique.Supply import GHC.Types.Unique+import GHC.Types.Name ( getOccFS ) import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import GHC.Data.List.SetOps @@ -131,7 +135,7 @@                              -- See Note [Freshen WW arguments]            -> Id             -- The original function            -> [Demand]       -- Strictness of original function-           -> CprResult      -- Info about function result+           -> Cpr            -- Info about function result            -> UniqSM (Maybe WwResult)  -- wrap_fn_args E       = \x y -> E@@ -433,7 +437,7 @@                   apply_or_bind_then work_fn_args (varToCoreExpr id),                   res_ty) } -  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty+  | Just (tv, fun_ty') <- splitForAllTyCoVar_maybe fun_ty   = do  { uniq <- getUniqueM         ; let (subst', tv') = cloneTyVarBndr subst tv uniq                 -- See Note [Freshen WW arguments]@@ -507,43 +511,161 @@      Another tricky case was when f :: forall a. a -> forall a. a->a     (i.e. with shadowing), and then the worker used the same 'a' twice.+-} +{- ************************************************************************ *                                                                      *-\subsection{Strictness stuff}+\subsection{Unboxing Decision for Strictness and CPR} *                                                                      * ************************************************************************ -} -mkWWstr :: DynFlags-        -> FamInstEnvs-        -> Bool    -- True <=> INLINEABLE pragma on this function defn-                   -- See Note [Do not unpack class dictionaries]-        -> [Var]                                -- Wrapper args; have their demand info on them-                                                --  *Includes type variables*-        -> UniqSM (Bool,                        -- Is this useful-                   [Var],                       -- Worker args-                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call-                                                -- and without its lambdas-                                                -- This fn adds the unboxing+-- | The information needed to build a pattern for a DataCon to be unboxed.+-- The pattern can be generated from 'dcpc_dc' and 'dcpc_tc_args' via+-- 'GHC.Core.Utils.dataConRepInstPat'. The coercion 'dcpc_co' is for newtype+-- wrappers.+--+-- If we get @DataConPatContext dc tys co@ for some type @ty@+-- and @dataConRepInstPat ... dc tys = (exs, flds)@, then+--+--   * @dc @exs flds :: T tys@+--   * @co :: T tys ~ ty@+data DataConPatContext+  = DataConPatContext+  { dcpc_dc      :: !DataCon+  , dcpc_tc_args :: ![Type]+  , dcpc_co      :: !Coercion+  } -                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,-                                                -- and lacking its lambdas.-                                                -- This fn does the reboxing-mkWWstr dflags fam_envs has_inlineable_prag args-  = go args+-- | If @splitArgType_maybe ty = Just (dc, tys, co)@+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@+-- and  @co :: ty ~ tc tys@+-- where underscore prefixes are holes, e.g. yet unspecified.+--+-- See Note [Which types are unboxed?].+splitArgType_maybe :: FamInstEnvs -> Type -> Maybe DataConPatContext+splitArgType_maybe fam_envs ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , Just con <- tyConSingleAlgDataCon_maybe tc+  = Just DataConPatContext { dcpc_dc      = con+                           , dcpc_tc_args = tc_args+                           , dcpc_co      = co }+splitArgType_maybe _ _ = Nothing++-- | If @splitResultType_maybe n ty = Just (dc, tys, co)@+-- then @dc \@tys \@_ex_tys (_args::_arg_tys) :: tc tys@+-- and  @co :: ty ~ tc tys@+-- where underscore prefixes are holes, e.g. yet unspecified.+-- @dc@ is the @n@th data constructor of @tc@.+--+-- See Note [Which types are unboxed?].+splitResultType_maybe :: FamInstEnvs -> ConTag -> Type -> Maybe DataConPatContext+splitResultType_maybe fam_envs con_tag ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , isDataTyCon tc -- NB: rules out unboxed sums and pairs!+  , let cons = tyConDataCons tc+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the+                                 -- type constructor via a .hs-boot file (#8743)+  , let con = cons `getNth` (con_tag - fIRST_TAG)+  , null (dataConExTyCoVars con) -- no existentials;+                                 -- See Note [Which types are unboxed?]+                                 -- and GHC.Core.Opt.CprAnal.extendEnvForDataAlt+                                 -- where we also check this.+  , all isLinear (dataConInstArgTys con tc_args)+  -- Deactivates CPR worker/wrapper splits on constructors with non-linear+  -- arguments, for the moment, because they require unboxed tuple with variable+  -- multiplicity fields.+  = Just DataConPatContext { dcpc_dc = con+                           , dcpc_tc_args = tc_args+                           , dcpc_co = co }+splitResultType_maybe _ _ _ = Nothing++isLinear :: Scaled a -> Bool+isLinear (Scaled w _ ) =+  case w of+    One -> True+    _ -> False++-- | Describes the outer shape of an argument to be unboxed or left as-is+-- Depending on how @s@ is instantiated (e.g., 'Demand').+data UnboxingDecision s+  = StopUnboxing+  -- ^ We ran out of strictness info. Leave untouched.+  | Unbox !DataConPatContext [s]+  -- ^ The argument is used strictly or the returned product was constructed, so+  -- unbox it.+  -- The 'DataConPatContext' carries the bits necessary for+  -- instantiation with 'dataConRepInstPat'.+  -- The @[s]@ carries the bits of information with which we can continue+  -- unboxing, e.g. @s@ will be 'Demand'.++wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> UnboxingDecision Demand+-- See Note [Which types are unboxed?]+wantToUnbox fam_envs has_inlineable_prag ty dmd =+  case splitArgType_maybe fam_envs ty of+    Just dcpc@DataConPatContext{ dcpc_dc = dc }+      | isStrUsedDmd dmd+      , let arity = dataConRepArity dc+      -- See Note [Unpacking arguments with product and polymorphic demands]+      , Just cs <- split_prod_dmd_arity dmd arity+      -- See Note [Do not unpack class dictionaries]+      , not (has_inlineable_prag && isClassPred ty)+      -- See Note [mkWWstr and unsafeCoerce]+      , cs `lengthIs` arity+      -- See Note [Add demands for strict constructors]+      , let cs' = addDataConStrictness dc cs+      -> Unbox dcpc cs'+    _ -> StopUnboxing   where-    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg+    split_prod_dmd_arity dmd arity+      -- For seqDmd, it should behave like <S(AAAA)>, for some+      -- suitable arity+      | isSeqDmd dmd        = Just (replicate arity absDmd)+      | _ :* Prod ds <- dmd = Just ds+      | otherwise           = Nothing -    go []           = return (False, [], nop_fn, nop_fn)-    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg-                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args-                         ; return ( useful1 || useful2-                                  , args1 ++ args2-                                  , wrap_fn1 . wrap_fn2-                                  , work_fn1 . work_fn2) }+{- Note [Which types are unboxed?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Worker/wrapper will unbox -{-+  1. A strict data type argument, that+       * is an algebraic data type (not a newtype)+       * has a single constructor (thus is a "product")+       * that may bind existentials+     We can transform+     > f (D @ex a b) = e+     to+     > $wf @ex a b = e+     via 'mkWWstr'.++  2. The constructed result of a function, if+       * its type is an algebraic data type (not a newtype)+       * (might have multiple constructors, in contrast to (1))+       * the applied data constructor *does not* bind existentials+     We can transform+     > f x y = let ... in D a b+     to+     > $wf x y = let ... in (# a, b #)+     via 'mkWWcpr'.++     NB: We don't allow existentials for CPR W/W, because we don't have unboxed+     dependent tuples (yet?). Otherwise, we could transform+     > f x y = let ... in D @ex (a :: ..ex..) (b :: ..ex..)+     to+     > $wf x y = let ... in (# @ex, (a :: ..ex..), (b :: ..ex..) #)++The respective tests are in 'splitArgType_maybe' and+'splitResultType_maybe', respectively.++Note that the data constructor /can/ have evidence arguments: equality+constraints, type classes etc.  So it can be GADT.  These evidence+arguments are simply value arguments, and should not get in the way.+ Note [Unpacking arguments with product and polymorphic demands] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The argument is unpacked in a case if it has a product type and has a@@ -570,169 +692,33 @@ source code, in Packages.applyPackageFlag, which ended up un-boxing the enormous DynFlags tuple, and being strict in the as-yet-un-filled-in unitState files.--} -------------------------- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)---   *  wrap_fn assumes wrap_arg is in scope,---        brings into scope work_args (via cases)---   * work_fn assumes work_args are in scope, a---        brings into scope wrap_arg (via lets)--- See Note [How to do the worker/wrapper split]-mkWWstr_one :: DynFlags -> FamInstEnvs-            -> Bool    -- True <=> INLINEABLE pragma on this function defn-                       -- See Note [Do not unpack class dictionaries]-            -> Var-            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-mkWWstr_one dflags fam_envs has_inlineable_prag arg-  | isTyVar arg-  = return (False, [arg],  nop_fn, nop_fn)--  | isAbsDmd dmd-  , Just work_fn <- mk_absent_let dflags fam_envs arg-     -- Absent case.  We can't always handle absence for arbitrary-     -- unlifted types, so we need to choose just the cases we can-     -- (that's what mk_absent_let does)-  = return (True, [], nop_fn, work_fn)--  | Just (cs, acdc) <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd-  = unbox_one dflags fam_envs arg cs acdc--  | otherwise   -- Other cases-  = return (False, [arg], nop_fn, nop_fn)--  where-    arg_ty = idType arg-    dmd    = idDemandInfo arg--wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataConAppContext)-wantToUnbox fam_envs has_inlineable_prag ty dmd =-  case deepSplitProductType_maybe fam_envs ty of-    Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys }-      | isStrictDmd dmd-      -- See Note [Unpacking arguments with product and polymorphic demands]-      , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)-      -- See Note [Do not unpack class dictionaries]-      , not (has_inlineable_prag && isClassPred ty)-      -- See Note [mkWWstr and unsafeCoerce]-      , cs `equalLength` con_arg_tys-      -> Just (cs, dcac)-    _ -> Nothing-  where-    split_prod_dmd_arity dmd arty-      -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would-      -- it know the arity?), but it should behave like <S, U(AAAA)>, for some-      -- suitable arity-      | isSeqDmd dmd = Just (replicate arty absDmd)-      -- Otherwise splitProdDmd_maybe does the job-      | otherwise    = splitProdDmd_maybe dmd--unbox_one :: DynFlags -> FamInstEnvs -> Var-          -> [Demand]-          -> DataConAppContext-          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)-unbox_one dflags fam_envs arg cs-          DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys-                            , dcac_arg_tys = inst_con_arg_tys-                            , dcac_co = co }-  = do { (uniq1:uniqs) <- getUniquesM-        ; let   scale = scaleScaled (idMult arg)-                scaled_inst_con_arg_tys = map (\(t,s) -> (scale t, s)) inst_con_arg_tys-                -- See Note [Add demands for strict constructors]-                cs'       = addDataConStrictness data_con cs-                unpk_args = zipWith3 mk_ww_arg uniqs scaled_inst_con_arg_tys cs'-                unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) uniq1-                                         data_con unpk_args-                arg_no_unf = zapStableUnfolding arg-                             -- See Note [Zap unfolding when beta-reducing]-                             -- in GHC.Core.Opt.Simplify; and see #13890-                rebox_fn   = Let (NonRec arg_no_unf con_app)-                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co-         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args-         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }-                           -- Don't pass the arg, rebox instead-  where-    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd-------------------------nop_fn :: CoreExpr -> CoreExpr-nop_fn body = body--addDataConStrictness :: DataCon -> [Demand] -> [Demand]--- See Note [Add demands for strict constructors]-addDataConStrictness con ds-  = zipWithEqual "addDataConStrictness" add ds strs-  where-    strs = dataConRepStrictness con-    add dmd str | isMarkedStrict str = strictifyDmd dmd-                | otherwise          = dmd--{- Note [How to do the worker/wrapper split]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker-wrapper transformation, mkWWstr_one, takes into account-several possibilities to decide if the function is worthy for-splitting:--1. If an argument is absent, it would be silly to pass it to-   the worker.  Hence the isAbsDmd case.  This case must come-   first because a demand like <S,A> or <B,A> is possible.-   E.g. <B,A> comes from a function like-       f x = error "urk"-   and <S,A> can come from Note [Add demands for strict constructors]--2. If the argument is evaluated strictly, and we can split the-   product demand (splitProdDmd_maybe), then unbox it and w/w its-   pieces.  For example--    f :: (Int, Int) -> Int-    f p = (case p of (a,b) -> a) + 1-  is split to-    f :: (Int, Int) -> Int-    f p = case p of (a,b) -> $wf a--    $wf :: Int -> Int-    $wf a = a + 1--  and-    g :: Bool -> (Int, Int) -> Int-    g c p = case p of (a,b) ->-               if c then a else b-  is split to-   g c p = case p of (a,b) -> $gw c a b-   $gw c a b = if c then a else b--2a But do /not/ split if the components are not used; that is, the-   usage is just 'Used' rather than 'UProd'. In this case-   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing-   a massive tuple which is barely used.  Example:--        f :: ((Int,Int) -> String) -> (Int,Int) -> a-        f g pr = error (g pr)--        main = print (f fst (1, error "no"))+Note [Do not unpack class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   f :: Ord a => [a] -> Int -> a+   {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),+which can still be specialised by the type-class specialiser, something like+   fw :: Ord a => [a] -> Int# -> a -   Here, f does not take 'pr' apart, and it's stupid to do so.-   Imagine that it had millions of fields. This actually happened-   in GHC itself where the tuple was DynFlags+BUT if f is strict in the Ord dictionary, we might unpack it, to get+   fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that. An example is #6056. -3. A plain 'seqDmd', which is head-strict with usage UHead, can't-   be split by splitProdDmd_maybe.  But we want it to behave just-   like U(AAAA) for suitable number of absent demands. So we have-   a special case for it, with arity coming from the data constructor.+But in any other situation a dictionary is just an ordinary value,+and can be unpacked.  So we track the INLINABLE pragma, and switch+off the unpacking in mkWWstr_one (see the isClassPred test). -Note [Worker-wrapper for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used not to split if the result is bottom.-[Justification:  there's no efficiency to be gained.]+Historical note: #14955 describes how I got this fix wrong the first time. -But it's sometimes bad not to make a wrapper.  Consider-        fw = \x# -> let x = I# x# in case e of-                                        p1 -> error_fn x-                                        p2 -> error_fn x-                                        p3 -> the real stuff-The re-boxing code won't go away unless error_fn gets a wrapper too.-[We don't do reboxing now, but in general it's better to pass an-unboxed thing to f, and have it reboxed in the error cases....]+Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug.  The fix here is simply to decline to do w/w if that happens.  Note [Add demands for strict constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -854,15 +840,184 @@ applying the strictness demands to the final result of DmdAnal. The result is that we get the strict demand signature we wanted even if we can't float the case on `x` up through the case on `burble`.+-} +{-+************************************************************************+*                                                                      *+\subsection{Strictness stuff}+*                                                                      *+************************************************************************+-} -Note [mkWWstr and unsafeCoerce]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-By using unsafeCoerce, it is possible to make the number of demands fail to-match the number of constructor arguments; this happened in #8037.-If so, the worker/wrapper split doesn't work right and we get a Core Lint-bug.  The fix here is simply to decline to do w/w if that happens.+mkWWstr :: DynFlags+        -> FamInstEnvs+        -> Bool    -- True <=> INLINEABLE pragma on this function defn+                   -- See Note [Do not unpack class dictionaries]+        -> [Var]                                -- Wrapper args; have their demand info on them+                                                --  *Includes type variables*+        -> UniqSM (Bool,                        -- Is this useful+                   [Var],                       -- Worker args+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call+                                                -- and without its lambdas+                                                -- This fn adds the unboxing +                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,+                                                -- and lacking its lambdas.+                                                -- This fn does the reboxing+mkWWstr dflags fam_envs has_inlineable_prag args+  = go args+  where+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg++    go []           = return (False, [], nop_fn, nop_fn)+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args+                         ; return ( useful1 || useful2+                                  , args1 ++ args2+                                  , wrap_fn1 . wrap_fn2+                                  , work_fn1 . work_fn2) }++----------------------+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)+--   *  wrap_fn assumes wrap_arg is in scope,+--        brings into scope work_args (via cases)+--   * work_fn assumes work_args are in scope, a+--        brings into scope wrap_arg (via lets)+-- See Note [How to do the worker/wrapper split]+mkWWstr_one :: DynFlags -> FamInstEnvs+            -> Bool    -- True <=> INLINEABLE pragma on this function defn+                       -- See Note [Do not unpack class dictionaries]+            -> Var+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+mkWWstr_one dflags fam_envs has_inlineable_prag arg+  | isTyVar arg+  = return (False, [arg],  nop_fn, nop_fn)++  | isAbsDmd dmd+  , Just work_fn <- mk_absent_let dflags fam_envs arg dmd+     -- Absent case.  We can't always handle absence for arbitrary+     -- unlifted types, so we need to choose just the cases we can+     -- (that's what mk_absent_let does)+  = return (True, [], nop_fn, work_fn)++  | Unbox dcpc cs <- wantToUnbox fam_envs has_inlineable_prag arg_ty dmd+  = unbox_one dflags fam_envs arg cs dcpc++  | otherwise   -- Other cases+  = return (False, [arg], nop_fn, nop_fn)++  where+    arg_ty = idType arg+    dmd    = idDemandInfo arg++unbox_one :: DynFlags -> FamInstEnvs -> Var+          -> [Demand]+          -> DataConPatContext+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+unbox_one dflags fam_envs arg cs+          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                            , dcpc_co = co }+  = do { (case_bndr_uniq:pat_bndrs_uniqs) <- getUniquesM+       ; let ex_name_fss     = map getOccFS $ dataConExTyCoVars dc+             (ex_tvs', arg_ids) =+               dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix) pat_bndrs_uniqs (idMult arg) dc tc_args+             arg_ids'  = zipWithEqual "unbox_one" setIdDemandInfo arg_ids cs+             unbox_fn  = mkUnpackCase (Var arg) co (idMult arg) case_bndr_uniq+                                      dc (ex_tvs' ++ arg_ids')+             arg_no_unf = zapStableUnfolding arg+                          -- See Note [Zap unfolding when beta-reducing]+                          -- in GHC.Core.Opt.Simplify; and see #13890+             rebox_fn   = Let (NonRec arg_no_unf con_app)+             con_app    = mkConApp2 dc tc_args (ex_tvs' ++ arg_ids') `mkCast` mkSymCo co+       ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False (ex_tvs' ++ arg_ids')+       ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+                          -- Don't pass the arg, rebox instead++----------------------+nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body++addDataConStrictness :: DataCon -> [Demand] -> [Demand]+-- See Note [Add demands for strict constructors]+addDataConStrictness con ds+  | Nothing <- dataConWrapId_maybe con+  -- DataCon worker=wrapper. Implies no strict fields, so nothing to do+  = ds+addDataConStrictness con ds+  = zipWithEqual "addDataConStrictness" add ds strs+  where+    strs = dataConRepStrictness con+    add dmd str | isMarkedStrict str = strictifyDmd dmd+                | otherwise          = dmd++{- Note [How to do the worker/wrapper split]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker-wrapper transformation, mkWWstr_one, takes into account+several possibilities to decide if the function is worthy for+splitting:++1. If an argument is absent, it would be silly to pass it to+   the worker.  Hence the isAbsDmd case.  This case must come+   first because a demand like <S,A> or <B,A> is possible.+   E.g. <B,A> comes from a function like+       f x = error "urk"+   and <S,A> can come from Note [Add demands for strict constructors]++2. If the argument is evaluated strictly, and we can split the+   product demand (splitProdDmd_maybe), then unbox it and w/w its+   pieces.  For example++    f :: (Int, Int) -> Int+    f p = (case p of (a,b) -> a) + 1+  is split to+    f :: (Int, Int) -> Int+    f p = case p of (a,b) -> $wf a++    $wf :: Int -> Int+    $wf a = a + 1++  and+    g :: Bool -> (Int, Int) -> Int+    g c p = case p of (a,b) ->+               if c then a else b+  is split to+   g c p = case p of (a,b) -> $gw c a b+   $gw c a b = if c then a else b++2a But do /not/ split if the components are not used; that is, the+   usage is just 'Used' rather than 'UProd'. In this case+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing+   a massive tuple which is barely used.  Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++   Here, f does not take 'pr' apart, and it's stupid to do so.+   Imagine that it had millions of fields. This actually happened+   in GHC itself where the tuple was DynFlags++3. A plain 'seqDmd', which is head-strict with usage UHead, can't+   be split by splitProdDmd_maybe.  But we want it to behave just+   like U(AAAA) for suitable number of absent demands. So we have+   a special case for it, with arity coming from the data constructor.++Note [Worker-wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]+ Note [Record evaluated-ness in worker/wrapper] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -910,105 +1065,8 @@          Type scrutiny that is specific to demand analysis *                                                                      * ************************************************************************--Note [Do not unpack class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   f :: Ord a => [a] -> Int -> a-   {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-which can still be specialised by the type-class specialiser, something like-   fw :: Ord a => [a] -> Int# -> a--BUT if f is strict in the Ord dictionary, we might unpack it, to get-   fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that.  An example is-#6056.--But in any other situation a dictionary is just an ordinary value,-and can be unpacked.  So we track the INLINABLE pragma, and switch-off the unpacking in mkWWstr_one (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong-the first time. -} --- | Context for a 'DataCon' application with a hole for every field, including--- surrounding coercions.--- The result of 'deepSplitProductType_maybe' and 'deepSplitCprType_maybe'.------ Example:------ > DataConAppContext Just [Int] [(Lazy, Int)] (co :: Maybe Int ~ First Int)------ represents------ > Just @Int (_1 :: Int) |> co :: First Int------ where _1 is a hole for the first argument. The number of arguments is--- determined by the length of @arg_tys@.-data DataConAppContext-  = DataConAppContext-  { dcac_dc      :: !DataCon-  , dcac_tys     :: ![Type]-  , dcac_arg_tys :: ![(Scaled Type, StrictnessMark)]-  , dcac_co      :: !Coercion-  }--deepSplitProductType_maybe :: FamInstEnvs -> Type -> Maybe DataConAppContext--- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)--- then  dc @ tys (args::arg_tys) :: rep_ty---       co :: ty ~ rep_ty--- Why do we return the strictness of the data-con arguments?--- Answer: see Note [Record evaluated-ness in worker/wrapper]-deepSplitProductType_maybe fam_envs ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , Just con <- isDataProductTyCon_maybe tc-  , let arg_tys = dataConInstArgTys con tc_args-        strict_marks = dataConRepStrictness con-  = Just DataConAppContext { dcac_dc = con-                           , dcac_tys = tc_args-                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks-                           , dcac_co = co }-deepSplitProductType_maybe _ _ = Nothing--deepSplitCprType_maybe-  :: FamInstEnvs -> ConTag -> Type -> Maybe DataConAppContext--- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)--- then  dc @ tys (args::arg_tys) :: rep_ty---       co :: ty ~ rep_ty--- Why do we return the strictness of the data-con arguments?--- Answer: see Note [Record evaluated-ness in worker/wrapper]-deepSplitCprType_maybe fam_envs con_tag ty-  | let (co, ty1) = topNormaliseType_maybe fam_envs ty-                    `orElse` (mkRepReflCo ty, ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  , isDataTyCon tc-  , let cons = tyConDataCons tc-  , cons `lengthAtLeast` con_tag -- This might not be true if we import the-                                 -- type constructor via a .hs-bool file (#8743)-  , let con = cons `getNth` (con_tag - fIRST_TAG)-        arg_tys = dataConInstArgTys con tc_args-        strict_marks = dataConRepStrictness con-  , all isLinear arg_tys-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear-  -- arguments, for the moment, because they require unboxed tuple with variable-  -- multiplicity fields.-  = Just DataConAppContext { dcac_dc = con-                           , dcac_tys = tc_args-                           , dcac_arg_tys = zipEqual "dspt" arg_tys strict_marks-                           , dcac_co = co }-deepSplitCprType_maybe _ _ _ = Nothing--isLinear :: Scaled a -> Bool-isLinear (Scaled w _ ) =-  case w of-    One -> True-    _ -> False- findTypeShape :: FamInstEnvs -> Type -> TypeShape -- Uncover the arrow and product shape of a type -- The data type TypeShape is defined in GHC.Types.Demand@@ -1027,7 +1085,7 @@        | Just (tc, tc_args)  <- splitTyConApp_maybe ty        = go_tc rec_tc tc tc_args -       | Just (_, ty') <- splitForAllTy_maybe ty+       | Just (_, ty') <- splitForAllTyCoVar_maybe ty        = go rec_tc ty'         | otherwise@@ -1037,13 +1095,16 @@        | Just (_, rhs, _) <- topReduceTyFamApp_maybe fam_envs tc tc_args        = go rec_tc rhs -       | Just con <- isDataProductTyCon_maybe tc+       | Just con <- tyConSingleAlgDataCon_maybe tc        , Just rec_tc <- if isTupleTyCon tc                         then Just rec_tc                         else checkRecTc rec_tc tc          -- We treat tuples specially because they can't cause loops.          -- Maybe we should do so in checkRecTc.-       = TsProd (map (go rec_tc . scaledThing) (dataConInstArgTys con tc_args))+         -- The use of 'dubiousDataConInstArgTys' is OK, since this+         -- function performs no substitution at all, hence the uniques+         -- don't matter.+       = TsProd (map (go rec_tc) (dubiousDataConInstArgTys con tc_args))         | Just (ty', _) <- instNewTyCon_maybe tc tc_args        , Just rec_tc <- checkRecTc rec_tc tc@@ -1052,6 +1113,18 @@        | otherwise        = TsUnk +-- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that+-- the 'DataCon' may not have existentials. The lack of cloning the existentials+-- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";+-- only use it where type variables aren't substituted for!+dubiousDataConInstArgTys :: DataCon -> [Type] -> [Type]+dubiousDataConInstArgTys dc tc_args = arg_tys+  where+    univ_tvs = dataConUnivTyVars dc+    ex_tvs   = dataConExTyCoVars dc+    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs+    arg_tys  = map (substTy subst . scaledThing) (dataConRepArgTys dc)+ {- ************************************************************************ *                                                                      *@@ -1072,7 +1145,7 @@ mkWWcpr :: Bool         -> FamInstEnvs         -> Type                              -- function body type-        -> CprResult                         -- CPR analysis results+        -> Cpr                               -- CPR analysis results         -> UniqSM (Bool,                     -- Is w/w'ing useful?                    CoreExpr -> CoreExpr,     -- New wrapper                    CoreExpr -> CoreExpr,     -- New worker@@ -1085,35 +1158,37 @@   | otherwise   = case asConCpr cpr of        Nothing      -> return (False, id, id, body_ty)  -- No CPR info-       Just con_tag | Just dcac <- deepSplitCprType_maybe fam_envs con_tag body_ty-                    -> mkWWcpr_help dcac-                    |  otherwise-                       -- See Note [non-algebraic or open body type warning]-                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )-                       return (False, id, id, body_ty)+       Just (con_tag, _cprs)+         | Just dcpc <- splitResultType_maybe fam_envs con_tag body_ty+         -> mkWWcpr_help dcpc+         |  otherwise+         -- See Note [non-algebraic or open body type warning]+         -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )+            return (False, id, id, body_ty) -mkWWcpr_help :: DataConAppContext+mkWWcpr_help :: DataConPatContext              -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type) -mkWWcpr_help (DataConAppContext { dcac_dc = data_con, dcac_tys = inst_tys-                                , dcac_arg_tys = arg_tys, dcac_co = co })-  | [arg1@(arg_ty1, _)] <- arg_tys-  , isUnliftedType (scaledThing arg_ty1)-  , isLinear arg_ty1+mkWWcpr_help (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args+                                , dcpc_co = co })+  | [arg_ty]   <- dataConInstArgTys dc tc_args -- NB: No existentials!+  , [str_mark] <- dataConRepStrictness dc+  , isUnliftedType (scaledThing arg_ty)+  , isLinear arg_ty         -- Special case when there is a single result of unlifted, linear, type         --         -- Wrapper:     case (..call worker..) of x -> C x         -- Worker:      case (   ..body..    ) of C x -> x   = do { (work_uniq : arg_uniq : _) <- getUniquesM-       ; let arg       = mk_ww_local arg_uniq arg1-             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co+       ; let arg_id    = mk_ww_local arg_uniq str_mark arg_ty+             con_app   = mkConApp2 dc tc_args [arg_id] `mkCast` mkSymCo co         ; return ( True-                , \ wkr_call -> mkDefaultCase wkr_call arg con_app-                , \ body     -> mkUnpackCase body co One work_uniq data_con [arg] (varToCoreExpr arg)+                , \ wkr_call -> mkDefaultCase wkr_call arg_id con_app+                , \ body     -> mkUnpackCase body co One work_uniq dc [arg_id] (varToCoreExpr arg_id)                                 -- varToCoreExpr important here: arg can be a coercion                                 -- Lacking this caused #10658-                , scaledThing arg_ty1 ) }+                , scaledThing arg_ty ) }    | otherwise   -- The general case         -- Wrapper: case (..call worker..) of (# a, b #) -> C a b@@ -1125,18 +1200,22 @@         -- parametrised by the multiplicity of its fields. Specifically, in this         -- instance, the multiplicity of the fields of (#,#) is chosen to be the         -- same as those of C.-  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM-       ; let wrap_wild   = mk_ww_local wild_uniq (linear ubx_tup_ty,MarkedStrict)-             args        = zipWith mk_ww_local uniqs arg_tys-             ubx_tup_ty  = exprType ubx_tup_app-             ubx_tup_app = mkCoreUbxTup (map (scaledThing . fst) arg_tys) (map varToCoreExpr args)-             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co-             tup_con     = tupleDataCon Unboxed (length arg_tys)+  = do { (work_uniq : wild_uniq : pat_bndrs_uniqs) <- getUniquesM+       ; let case_mult       = One -- see above+             (_exs, arg_ids) =+               dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs case_mult dc tc_args+             wrap_wild       = mk_ww_local wild_uniq MarkedStrict (Scaled case_mult ubx_tup_ty)+             ubx_tup_ty      = exprType ubx_tup_app+             ubx_tup_app     = mkCoreUbxTup (map idType arg_ids) (map varToCoreExpr arg_ids)+             con_app         = mkConApp2 dc tc_args arg_ids `mkCast` mkSymCo co+             tup_con         = tupleDataCon Unboxed (length arg_ids) +       ; MASSERT( null _exs ) -- Should have been caught by splitResultType_maybe+        ; return (True                 , \ wkr_call -> mkSingleAltCase wkr_call wrap_wild-                                                (DataAlt tup_con) args con_app-                , \ body     -> mkUnpackCase body co One work_uniq data_con args ubx_tup_app+                                                (DataAlt tup_con) arg_ids con_app+                , \ body     -> mkUnpackCase body co case_mult work_uniq dc arg_ids ubx_tup_app                 , ubx_tup_ty ) }  mkUnpackCase ::  CoreExpr -> Coercion -> Mult -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr@@ -1151,7 +1230,7 @@                     (DataAlt boxing_con) unpk_args body   where     casted_scrut = scrut `mkCast` co-    bndr = mk_ww_local uniq (Scaled mult (exprType casted_scrut), MarkedStrict)+    bndr = mk_ww_local uniq MarkedStrict (Scaled mult (exprType casted_scrut))       -- An unpacking case can always be chosen linear, because the variables       -- are always passed to a constructor. This limits the {-@@ -1204,22 +1283,73 @@  Note [Absent errors] ~~~~~~~~~~~~~~~~~~~~-We make a new binding for Ids that are marked absent, thus-   let x = absentError "x :: Int"-The idea is that this binding will never be used; but if it-buggily is used we'll get a runtime error message.+Consider+  data T = MkT [Int] [Int] ![Int]+  f :: T -> Int# -> blah+  f ps w = case ps of MkT xs _ _ -> <body mentioning xs>+Then f gets a strictness sig of <S(L,A,A)><A>. We make worker $wf thus: -Coping with absence for *unlifted* types is important; see, for-example, #4306 and #15627.  In the UnliftedRep case, we can-use LitRubbish, which we need to apply to the required type.-For the unlifted types of singleton kind like Float#, Addr#, etc. we-also find a suitable literal, using Literal.absentLiteralOf.  We don't-have literals for every primitive type, so the function is partial.+$wf :: [Int] -> blah+$wf xs = case ps of MkT xs _ _ -> <body mentioning xs>+  where+    ys = absentError "ys :: [Int]"+    zs = LitRubbish True+    ps = MkT xs ys zs+    w  = 0# -Note: I did try the experiment of using an error thunk for unlifted-things too, relying on the simplifier to drop it as dead code.-But this is fragile+We make a let-binding for Absent arguments, such as ys and w, that are not even+passed to the worker. They should, of course, never be used. We distinguish four+cases: +1. Ordinary boxed, lifted arguments, like 'ys' We make a new binding for Ids+   that are marked absent, thus+      let ys = absentError "ys :: [Int]"+   The idea is that this binding will never be used; but if it+   buggily is used we'll get a runtime error message.++2. Boxed, lifted types, with a strict demand, like 'zs'.  You may ask: how the+   demand be both absent and strict?  That's exactly what happens for 'zs': it+   is not used, so its demand is Absent, but then during w/w, in+   addDataConStrictness, we strictify the demand.  So it gets cardinality C_10,+   the empty interval.++   We don't want to use an error-thunk for 'zs' because MkT's third argument has+   a bang, and hence should be always evaluated. This turned out to be+   important when fixing #16970, which establishes the invariant that strict+   constructor arguments are always evaluated. So we use LitRubbish instead+   of an error thunk -- see #19133.++   These first two cases are distinguished by isStrictDmd in lifted_rhs.++3. Unboxed types, like 'w', with a type like Float#, Int#. Coping with absence+   for unboxed types is important; see, for example, #4306 and #15627.  We+   simply find a suitable literal, using Literal.absentLiteralOf.  We don't have+   literals for every primitive type, so the function is partial.++4. Boxed, unlifted types, like (Array# t).  We can't use absentError because+   unlifted bindings ares strict.  So we use LitRubbish, which we need to apply+   to the required type.++Case (2) and (4) crucially use LitRubbish as the placeholder: see Note [Rubbish+literals] in GHC.Types.Literal.  We could do that in case (1) as well, but we+get slightly better self-checking with an error thunk.++Suppose we use LitRubbish and absence analysis is Wrong, so that the "absent"+value is used after all.  Then in case (2) we could get a seg-fault, because we+may have replaced, say, a [Either Int Bool] by (), and that will fail if we do+case analysis on it.  Similarly with boxed unlifted types, case (4).++In case (3), if absence analysis is wrong we could conceivably get an exception,+from a divide-by-zero with the absent value.  But it's very unlikely.++Only in case (1) can we guarantee a civilised runtime error.  Not much we can do+about this; we really rely on absence analysis to be correct.+++Historical note: I did try the experiment of using an error thunk for unlifted+things too, relying on the simplifier to drop it as dead code.  But this is+fragile+  - It fails when profiling is on, which disables various optimisations   - It fails when reboxing happens. E.g.@@ -1230,10 +1360,8 @@    pass that component to the worker for 'f', which reconstructs 'p' to    pass it to 'g'.  Alas we can't say        ...f (MkT a (absentError Int# "blah"))...-   bacause `MkT` is strict in its Int# argument, so we get an absentError+   because `MkT` is strict in its Int# argument, so we get an absentError    exception when we shouldn't.  Very annoying!--So absentError is only used for lifted types. -}  -- | Tries to find a suitable dummy RHS to bind the given absent identifier to.@@ -1241,23 +1369,28 @@ -- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding -- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be -- found (currently only happens for bindings of 'VecRep' representation).-mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Maybe (CoreExpr -> CoreExpr)-mk_absent_let dflags fam_envs arg+mk_absent_let :: DynFlags -> FamInstEnvs -> Id -> Demand -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let dflags fam_envs arg dmd+   -- The lifted case: Bind 'absentError'   -- See Note [Absent errors]   | not (isUnliftedType arg_ty)-  = Just (Let (NonRec lifted_arg abs_rhs))+  = Just (Let (NonRec lifted_arg lifted_rhs))   -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@   -- See Note [Absent errors]+   | [UnliftedRep] <- typePrimRep arg_ty   = Just (Let (NonRec arg unlifted_rhs))+   -- The monomorphic unlifted cases: Bind to some literal, if possible   -- See Note [Absent errors]   | Just tc <- tyConAppTyCon_maybe nty   , Just lit <- absentLiteralOf tc   = Just (Let (NonRec arg (Lit lit `mkCast` mkSymCo co)))-  | nty `eqType` voidPrimTy++  | nty `eqType` unboxedUnitTy   = Just (Let (NonRec arg (Var voidPrimId `mkCast` mkSymCo co)))+   | otherwise   = WARN( True, text "No absent value for" <+> ppr arg_ty )     Nothing -- Can happen for 'State#' and things of 'VecRep'@@ -1266,6 +1399,11 @@               -- Note in strictness signature that this is bottoming               -- (for the sake of the "empty case scrutinee not known to               -- diverge for sure lint" warning)++    lifted_rhs | isStrictDmd dmd = mkTyApps (Lit (rubbishLit True))  [arg_ty]+               | otherwise       = mkAbsentErrorApp arg_ty msg+    unlifted_rhs = mkTyApps (Lit (rubbishLit False)) [arg_ty]+     arg_ty       = idType arg      -- Normalise the type to have best chance of finding an absent literal@@ -1275,24 +1413,29 @@     (co, nty)    = topNormaliseType_maybe fam_envs arg_ty                    `orElse` (mkRepReflCo arg_ty, arg_ty) -    abs_rhs      = mkAbsentErrorApp arg_ty msg     msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)-                            (ppr arg <+> ppr (idType arg) <+> file_msg)+                            (vcat+                              [ text "Arg:" <+> ppr arg+                              , text "Type:" <+> ppr arg_ty+                              , file_msg+                              ])     file_msg     = case outputFile dflags of                      Nothing -> empty-                     Just f  -> text "in output file " <+> quotes (text f)+                     Just f  -> text "In output file " <+> quotes (text f)               -- We need to suppress uniques here because otherwise they'd               -- end up in the generated code as strings. This is bad for               -- determinism, because with different uniques the strings               -- will have different lengths and hence different costs for               -- the inliner leading to different inlining.               -- See also Note [Unique Determinism] in GHC.Types.Unique-    unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty] -mk_ww_local :: Unique -> (Scaled Type, StrictnessMark) -> Id+ww_prefix :: FastString+ww_prefix = fsLit "ww"++mk_ww_local :: Unique -> StrictnessMark -> Scaled Type -> Id -- The StrictnessMark comes form the data constructor and says -- whether this field is strict -- See Note [Record evaluated-ness in worker/wrapper]-mk_ww_local uniq (Scaled w ty,str)+mk_ww_local uniq str (Scaled w ty)   = setCaseBndrEvald str $-    mkSysLocalOrCoVar (fsLit "ww") uniq w ty+    mkSysLocalOrCoVar ww_prefix uniq w ty

GHC/Core/PatSyn.hs view

@@ -9,10 +9,11 @@  module GHC.Core.PatSyn (         -- * Main data types-        PatSyn, mkPatSyn,+        PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,          -- ** Type deconstruction-        patSynName, patSynArity, patSynIsInfix,+        patSynName, patSynArity, patSynIsInfix, patSynResultType,+        isVanillaPatSyn,         patSynArgs,         patSynMatcher, patSynBuilder,         patSynUnivTyVarBinders, patSynExTyVars, patSynExTyVarBinders,@@ -20,7 +21,7 @@         patSynInstArgTys, patSynInstResTy, patSynFieldLabels,         patSynFieldType, -        updatePatSynIds, pprPatSynType+        pprPatSynType     ) where  #include "HsVersions.h"@@ -30,13 +31,15 @@ import GHC.Core.Type import GHC.Core.TyCo.Ppr import GHC.Types.Name-import GHC.Utils.Outputable import GHC.Types.Unique-import GHC.Utils.Misc import GHC.Types.Basic import GHC.Types.Var import GHC.Types.FieldLabel +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import qualified Data.Data as Data import Data.Function import Data.List (find)@@ -84,34 +87,38 @@                                -- See Note [Pattern synonym result type]          -- See Note [Matchers and builders for pattern synonyms]-        psMatcher     :: (Id, Bool),-             -- Matcher function.-             -- If Bool is True then prov_theta and arg_tys are empty-             -- and type is-             --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.-             --                          req_theta-             --                       => res_ty-             --                       -> (forall ex_tvs. Void# -> r)-             --                       -> (Void# -> r)-             --                       -> r-             ---             -- Otherwise type is-             --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.-             --                          req_theta-             --                       => res_ty-             --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)-             --                       -> (Void# -> r)-             --                       -> r--        psBuilder     :: Maybe (Id, Bool)-             -- Nothing  => uni-directional pattern synonym-             -- Just (builder, is_unlifted) => bi-directional-             -- Builder function, of type-             --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)-             --                       =>  arg_tys -> res_ty-             -- See Note [Builder for pattern synonyms with unboxed type]+        -- See Note [Keep Ids out of PatSyn]+        psMatcher     :: PatSynMatcher,+        psBuilder     :: PatSynBuilder   } +type PatSynMatcher = (Name, Type, Bool)+     -- Matcher function.+     -- If Bool is True then prov_theta and arg_tys are empty+     -- and type is+     --   forall (p :: RuntimeRep) (r :: TYPE p) univ_tvs.+     --                          req_theta+     --                       => res_ty+     --                       -> (forall ex_tvs. Void# -> r)+     --                       -> (Void# -> r)+     --                       -> r+     --+     -- Otherwise type is+     --   forall (p :: RuntimeRep) (r :: TYPE r) univ_tvs.+     --                          req_theta+     --                       => res_ty+     --                       -> (forall ex_tvs. prov_theta => arg_tys -> r)+     --                       -> (Void# -> r)+     --                       -> r++type PatSynBuilder = Maybe (Name, Type, Bool)+     -- Nothing  => uni-directional pattern synonym+     -- Just (builder, is_unlifted) => bi-directional+     -- Builder function, of type+     --  forall univ_tvs, ex_tvs. (req_theta, prov_theta)+     --                       =>  arg_tys -> res_ty+     -- See Note [Builder for pattern synonyms with unboxed type]+ {- Note [Pattern synonym signature contexts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a pattern synonym signature we write@@ -201,6 +208,22 @@ Also rather different to GADTs is the fact that Just42 doesn't have any universally quantified type variables, whereas Just'42 or MkS above has. +Note [Keep Ids out of PatSyn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We carefully arrange that PatSyn does not contain the Ids for the matcher+and builder.  We want PatSyn, like TyCon and DataCon, to be completely+immutable. But, the matcher and builder are relatively sophisticated+functions, and we want to get their final IdInfo in the same way as+any other Id, so we'd have to update the Ids in the PatSyn too.++Rather than try to tidy PatSyns (which is easy to forget and is a bit+tricky, see #19074), it seems cleaner to make them entirely immutable,+like TyCons and Classes.  To that end PatSynBuilder and PatSynMatcher+contain Names not Ids. Which, it turns out, is absolutely fine.++c.f. DefMethInfo in Class, which contains the Name, but not the Id,+of the default method.+ Note [Pattern synonym representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following pattern synonym declaration@@ -361,8 +384,8 @@                                          -- variables and provided dicts          -> [Type]               -- ^ Original arguments          -> Type                 -- ^ Original result type-         -> (Id, Bool)           -- ^ Name of matcher-         -> Maybe (Id, Bool)     -- ^ Name of builder+         -> PatSynMatcher        -- ^ Matcher+         -> PatSynBuilder        -- ^ Builder          -> [FieldLabel]         -- ^ Names of fields for                                  --   a record pattern synonym          -> PatSyn@@ -399,6 +422,10 @@ patSynArity :: PatSyn -> Arity patSynArity = psArity +-- | Is this a \'vanilla\' pattern synonym (no existentials, no provided constraints)?+isVanillaPatSyn :: PatSyn -> Bool+isVanillaPatSyn ps = null (psExTyVars ps) && null (psProvTheta ps)+ patSynArgs :: PatSyn -> [Type] patSynArgs = psArgs @@ -431,17 +458,14 @@ patSynSig ps = let (u_tvs, req, e_tvs, prov, arg_tys, res_ty) = patSynSigBndr ps                in (binderVars u_tvs, req, binderVars e_tvs, prov, arg_tys, res_ty) -patSynMatcher :: PatSyn -> (Id,Bool)+patSynMatcher :: PatSyn -> PatSynMatcher patSynMatcher = psMatcher -patSynBuilder :: PatSyn -> Maybe (Id, Bool)+patSynBuilder :: PatSyn -> PatSynBuilder patSynBuilder = psBuilder -updatePatSynIds :: (Id -> Id) -> PatSyn -> PatSyn-updatePatSynIds tidy_fn ps@(MkPatSyn { psMatcher = matcher, psBuilder = builder })-  = ps { psMatcher = tidy_pr matcher, psBuilder = fmap tidy_pr builder }-  where-    tidy_pr (id, dummy) = (tidy_fn id, dummy)+patSynResultType :: PatSyn -> Type+patSynResultType = psResultTy  patSynInstArgTys :: PatSyn -> [Type] -> [Type] -- Return the types of the argument patterns

− GHC/Core/PatSyn.hs-boot

@@ -1,13 +0,0 @@-module GHC.Core.PatSyn where--import GHC.Types.Basic (Arity)-import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type)-import GHC.Types.Var (TyVar)-import GHC.Types.Name (Name)--data PatSyn--patSynArity :: PatSyn -> Arity-patSynInstArgTys :: PatSyn -> [Type] -> [Type]-patSynExTyVars :: PatSyn -> [TyVar]-patSynName :: PatSyn -> Name

GHC/Core/Ppr.hs view

@@ -1,4 +1,16 @@+{-# LANGUAGE LambdaCase #-}+ {-+   these are needed for the Outputable instance for GenTickish,+   since we need XTickishId to be Outputable. This should immediately+   resolve to something like Id.+ -}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++{- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998 @@ -6,10 +18,6 @@ Printing of Core syntax -} -{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE LambdaCase #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}- module GHC.Core.Ppr (         pprCoreExpr, pprParendExpr,         pprCoreBinding, pprCoreBindings, pprCoreAlt,@@ -38,6 +46,7 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Types.SrcLoc ( pprUserRealSpan )+import GHC.Types.Tickish  {- ************************************************************************@@ -69,6 +78,9 @@ instance OutputableBndr b => Outputable (Expr b) where     ppr expr = pprCoreExpr expr +instance OutputableBndr b => Outputable (Alt b) where+    ppr expr = pprCoreAlt expr+ {- ************************************************************************ *                                                                      *@@ -161,15 +173,20 @@               True  -> angleBrackets (text "Co:" <> int (coercionSize co))               False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)] +ppr_id_occ :: (SDoc -> SDoc) -> Id -> SDoc+ppr_id_occ add_par id+  | isJoinId id = add_par ((text "jump") <+> pp_id)+  | otherwise   = pp_id+  where+    pp_id = ppr id  -- We could use pprPrefixOcc to print (+) etc, but this is+                    -- Core where we don't print things infix anyway, so doing+                    -- so just adds extra redundant parens+ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc         -- The function adds parens in context that need         -- an atomic value (e.g. function args) -ppr_expr add_par (Var name)- | isJoinId name               = add_par ((text "jump") <+> pp_name)- | otherwise                   = pp_name- where-   pp_name = pprPrefixOcc name+ppr_expr add_par (Var id)      = ppr_id_occ add_par id ppr_expr add_par (Type ty)     = add_par (text "TYPE:" <+> ppr ty)       -- Weird ppr_expr add_par (Coercion co) = add_par (text "CO:" <+> ppr co) ppr_expr add_par (Lit lit)     = pprLiteral add_par lit@@ -212,13 +229,12 @@                     _ -> parens (hang fun_doc 2 pp_args)                    where-                     fun_doc | isJoinId f = text "jump" <+> ppr f-                             | otherwise  = ppr f+                     fun_doc = ppr_id_occ noParens f          _ -> parens (hang (pprParendExpr fun) 2 pp_args)     } -ppr_expr add_par (Case expr var ty [(con,args,rhs)])+ppr_expr add_par (Case expr var ty [Alt con args rhs])   = sdocOption sdocPrintCaseAsLet $ \case       True -> add_par $  -- See Note [Print case as let]                sep [ sep [ text "let! {"@@ -296,8 +312,8 @@       True  -> ppr_expr add_par expr       False -> add_par (sep [ppr tickish, pprCoreExpr expr]) -pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc-pprCoreAlt (con, args, rhs)+pprCoreAlt :: OutputableBndr a => Alt a -> SDoc+pprCoreAlt (Alt con args rhs)   = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs)  ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc@@ -639,13 +655,13 @@ ----------------------------------------------------- -} -instance Outputable id => Outputable (Tickish id) where+instance Outputable (XTickishId pass) => Outputable (GenTickish pass) where   ppr (HpcTick modl ix) =       hcat [text "hpc<",             ppr modl, comma,             ppr ix,             text ">"]-  ppr (Breakpoint ix vars) =+  ppr (Breakpoint _ext ix vars) =       hcat [text "break<",             ppr ix,             text ">",

− GHC/Core/Ppr/TyThing.hs

@@ -1,205 +0,0 @@------------------------------------------------------------------------------------ Pretty-printing TyThings------ (c) The GHC Team 2005-----------------------------------------------------------------------------------{-# LANGUAGE CPP #-}-module GHC.Core.Ppr.TyThing (-        pprTyThing,-        pprTyThingInContext,-        pprTyThingLoc,-        pprTyThingInContextLoc,-        pprTyThingHdr,-        pprTypeForUser,-        pprFamInst-  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Core.Type    ( Type, ArgFlag(..), TyThing(..), mkTyVarBinders, tidyOpenType )-import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)-  , showToHeader, pprIfaceDecl )-import GHC.Core.Coercion.Axiom ( coAxiomTyCon )-import GHC.Driver.Types( tyThingParent_maybe )-import GHC.Iface.Make ( tyThingToIfaceDecl )-import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )-import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )-import GHC.Types.Name-import GHC.Types.Var.Env( emptyTidyEnv )-import GHC.Utils.Outputable---- -------------------------------------------------------------------------------- Pretty-printing entities that we get from the GHC API--{- Note [Pretty printing via Iface syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Our general plan for pretty-printing-  - Types-  - TyCons-  - Classes-  - Pattern synonyms-  ...etc...--is to convert them to Iface syntax, and pretty-print that. For example-  - pprType converts a Type to an IfaceType, and pretty prints that.-  - pprTyThing converts the TyThing to an IfaceDecl,-    and pretty prints that.--So Iface syntax plays a dual role:-  - it's the internal version of an interface files-  - it's used for pretty-printing--Why do this?--* A significant reason is that we need to be able-  to pretty-print Iface syntax (to display Foo.hi), and it was a-  pain to duplicate masses of pretty-printing goop, esp for-  Type and IfaceType.--* When pretty-printing (a type, say), we want to tidy (with-  tidyType) to avoids having (forall a a. blah) where the two-  a's have different uniques.--  Alas, for type constructors, TyCon, tidying does not work well,-  because a TyCon includes DataCons which include Types, which mention-  TyCons. And tidying can't tidy a mutually recursive data structure-  graph, only trees.--* Interface files contains fast-strings, not uniques, so the very same-  tidying must take place when we convert to IfaceDecl. E.g.-  GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,-  Class etc) to an IfaceDecl.--  Bottom line: IfaceDecls are already 'tidy', so it's straightforward-  to print them.--* An alternative I once explored was to ensure that TyCons get type-  variables with distinct print-names. That's ok for type variables-  but less easy for kind variables. Processing data type declarations-  is already so complicated that I don't think it's sensible to add-  the extra requirement that it generates only "pretty" types and-  kinds.--Consequences:--- Iface syntax (and IfaceType) must contain enough information to-  print nicely.  Hence, for example, the IfaceAppArgs type, which-  allows us to suppress invisible kind arguments in types-  (see Note [Suppressing invisible arguments] in GHC.Iface.Type)--- In a few places we have info that is used only for pretty-printing,-  and is totally ignored when turning Iface syntax back into Core-  (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon-  stores a [IfaceAxBranch] that is used only for pretty-printing.--- See Note [Free tyvars in IfaceType] in GHC.Iface.Type--See #7730, #8776 for details   -}------------------------- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.-pprFamInst :: FamInst -> SDoc---  * For data instances we go via pprTyThing of the representational TyCon,---    because there is already much cleverness associated with printing---    data type declarations that I don't want to duplicate---  * For type instances we print directly here; there is no TyCon---    to give to pprTyThing------ FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes--pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })-  = pprTyThingInContextLoc (ATyCon rep_tc)--pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom-                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })-  = showWithLoc (pprDefinedAt (getName axiom)) $-    hang (text "type instance"-            <+> pprUserForAll (mkTyVarBinders Specified tvs)-                -- See Note [Printing foralls in type family instances]-                -- in GHC.Iface.Type-            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)-       2 (equals <+> ppr rhs)--------------------------------- | Pretty-prints a 'TyThing' with its defining location.-pprTyThingLoc :: TyThing -> SDoc-pprTyThingLoc tyThing-  = showWithLoc (pprDefinedAt (getName tyThing))-                (pprTyThing showToHeader tyThing)---- | Pretty-prints the 'TyThing' header. For functions and data constructors--- the function is equivalent to 'pprTyThing' but for type constructors--- and classes it prints only the header part of the declaration.-pprTyThingHdr :: TyThing -> SDoc-pprTyThingHdr = pprTyThing showToHeader---- | Pretty-prints a 'TyThing' in context: that is, if the entity--- is a data constructor, record selector, or class method, then--- the entity's parent declaration is pretty-printed with irrelevant--- parts omitted.-pprTyThingInContext :: ShowSub -> TyThing -> SDoc-pprTyThingInContext show_sub thing-  = go [] thing-  where-    go ss thing-      = case tyThingParent_maybe thing of-          Just parent ->-            go (getOccName thing : ss) parent-          Nothing ->-            pprTyThing-              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })-              thing---- | Like 'pprTyThingInContext', but adds the defining location.-pprTyThingInContextLoc :: TyThing -> SDoc-pprTyThingInContextLoc tyThing-  = showWithLoc (pprDefinedAt (getName tyThing))-                (pprTyThingInContext showToHeader tyThing)---- | Pretty-prints a 'TyThing'.-pprTyThing :: ShowSub -> TyThing -> SDoc--- We pretty-print 'TyThing' via 'IfaceDecl'--- See Note [Pretty-printing TyThings]-pprTyThing ss ty_thing-  = sdocWithDynFlags (\dflags -> pprIfaceDecl ss' (tyThingToIfaceDecl dflags ty_thing))-  where-    ss' = case ss_how_much ss of-      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }-      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }-      _                   -> ss--    ppr' = AltPpr $ ppr_bndr $ getName ty_thing--    ppr_bndr :: Name -> Maybe (OccName -> SDoc)-    ppr_bndr name-      | isBuiltInSyntax name-         = Nothing-      | otherwise-         = case nameModule_maybe name of-             Just mod -> Just $ \occ -> getPprStyle $ \sty ->-               pprModulePrefix sty mod occ <> ppr occ-             Nothing  -> WARN( True, ppr name ) Nothing-             -- Nothing is unexpected here; TyThings have External names--pprTypeForUser :: Type -> SDoc--- The type is tidied-pprTypeForUser ty-  = pprSigmaType tidy_ty-  where-    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty-     -- Often the types/kinds we print in ghci are fully generalised-     -- and have no free variables, but it turns out that we sometimes-     -- print un-generalised kinds (eg when doing :k T), so it's-     -- better to use tidyOpenType here--showWithLoc :: SDoc -> SDoc -> SDoc-showWithLoc loc doc-    = hang doc 2 (char '\t' <> comment <+> loc)-                -- The tab tries to make them line up a bit-  where-    comment = text "--"

GHC/Core/Predicate.hs view

@@ -34,14 +34,16 @@ import GHC.Core.Type import GHC.Core.Class import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Types.Var import GHC.Core.Coercion+import GHC.Core.Multiplicity ( scaledThing )  import GHC.Builtin.Names  import GHC.Utils.Outputable import GHC.Utils.Misc-import GHC.Core.Multiplicity ( scaledThing )+import GHC.Utils.Panic   -- | A predicate in the solver. The solver tries to prove Wanted predicates@@ -67,7 +69,7 @@       | Just clas <- tyConClass_maybe tc       -> ClassPred clas tys -    _ | (tvs, rho) <- splitForAllTys ev_ty+    _ | (tvs, rho) <- splitForAllTyCoVars ev_ty       , (theta, pred) <- splitFunTys rho       , not (null tvs && null theta)       -> ForAllPred tvs (map scaledThing theta) pred

GHC/Core/Rules.hs view

@@ -31,6 +31,7 @@ import GHC.Prelude  import GHC.Core         -- All of it+import GHC.Unit.Types    ( primUnitId, bignumUnitId ) import GHC.Unit.Module   ( Module ) import GHC.Unit.Module.Env import GHC.Core.Subst@@ -57,17 +58,20 @@ import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Unique.FM+import GHC.Types.Tickish import GHC.Core.Unify as Unify ( ruleMatchTyKiX ) import GHC.Types.Basic-import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform )+import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform, homeUnitId_ )+import GHC.Driver.Ppr import GHC.Driver.Flags import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.Bag import GHC.Utils.Misc as Utils-import Data.List-import Data.Ord+import Data.List (sortBy, mapAccumL, isPrefixOf)+import Data.Function    ( on ) import Control.Monad    ( guard )  {-@@ -269,7 +273,7 @@ pprRulesForUser rules   = withPprStyle defaultUserStyle $     pprRules $-    sortBy (comparing ruleName) $+    sortBy (lexicalCompareFS `on` ruleName) $     tidyRules emptyTidyEnv rules  {-@@ -522,9 +526,12 @@ -- | Initialize RuleOpts from DynFlags initRuleOpts :: DynFlags -> RuleOpts initRuleOpts dflags = RuleOpts-  { roPlatform = targetPlatform dflags-  , roNumConstantFolding = gopt Opt_NumConstantFolding dflags+  { roPlatform                = targetPlatform dflags+  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags   , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+    -- disable bignum rules in ghc-prim and ghc-bignum itself+  , roBignumRules             = homeUnitId_ dflags /= primUnitId+                                && homeUnitId_ dflags /= bignumUnitId   }  @@ -888,7 +895,7 @@            -> Maybe RuleSubst match_alts _ subst [] []   = return subst-match_alts renv subst ((c1,vs1,r1):alts1) ((c2,vs2,r2):alts2)+match_alts renv subst (Alt c1 vs1 r1:alts1) (Alt c2 vs2 r2:alts2)   | c1 == c2   = do  { subst1 <- match renv' subst r1 r2         ; match_alts renv subst1 alts1 alts2 }@@ -1209,7 +1216,7 @@ ruleCheck env (Let bd e)    = ruleCheckBind env bd `unionBags` ruleCheck env e ruleCheck env (Lam _ e)     = ruleCheck env e ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`-                                unionManyBags [ruleCheck env r | (_,_,r) <- as]+                                unionManyBags [ruleCheck env r | Alt _ _ r <- as]  ruleCheckApp :: RuleCheckEnv -> Expr CoreBndr -> [Arg CoreBndr] -> Bag SDoc ruleCheckApp env (App f a) as = ruleCheck env a `unionBags` ruleCheckApp env f (a:as)

GHC/Core/Seq.hs view

@@ -17,11 +17,12 @@ import GHC.Types.Demand( seqDemand, seqStrictSig ) import GHC.Types.Cpr( seqCprSig ) import GHC.Types.Basic( seqOccInfo )+import GHC.Types.Tickish import GHC.Types.Var.Set( seqDVarSet ) import GHC.Types.Var( varType, tyVarKind ) import GHC.Core.Type( seqType, isTyVar ) import GHC.Core.Coercion( seqCo )-import GHC.Types.Id( Id, idInfo )+import GHC.Types.Id( idInfo )  -- | Evaluate all the fields of the 'IdInfo' that are generally demanded by the -- compiler@@ -71,7 +72,7 @@ seqExprs [] = () seqExprs (e:es) = seqExpr e `seq` seqExprs es -seqTickish :: Tickish Id -> ()+seqTickish :: CoreTickish -> () seqTickish ProfNote{ profNoteCC = cc } = cc `seq` () seqTickish HpcTick{} = () seqTickish Breakpoint{ breakpointFVs = ids } = seqBndrs ids@@ -99,7 +100,7 @@  seqAlts :: [CoreAlt] -> () seqAlts [] = ()-seqAlts ((c,bs,e):alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts+seqAlts (Alt c bs e:alts) = c `seq` seqBndrs bs `seq` seqExpr e `seq` seqAlts alts  seqUnfolding :: Unfolding -> () seqUnfolding (CoreUnfolding { uf_tmpl = e, uf_is_top = top,

GHC/Core/SimpleOpt.hs view

@@ -7,6 +7,8 @@ {-# LANGUAGE MultiWayIf #-}  module GHC.Core.SimpleOpt (+        SimpleOpts (..), defaultSimpleOpts,+         -- ** Simple expression optimiser         simpleOptPgm, simpleOptExpr, simpleOptExprWith, @@ -16,23 +18,20 @@         -- ** Predicates on expressions         exprIsConApp_maybe, exprIsLiteral_maybe, exprIsLambda_maybe, -        -- ** Coercions and casts-        pushCoArg, pushCoValArg, pushCoTyArg, collectBindersPushingCo     ) where  #include "HsVersions.h"  import GHC.Prelude -import GHC.Core.Opt.Arity( etaExpandToJoinPoint )- import GHC.Core+import GHC.Core.Opt.Arity import GHC.Core.Subst import GHC.Core.Utils import GHC.Core.FVs-import {-# SOURCE #-} GHC.Core.Unfold( mkUnfolding )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make import GHC.Core.Make ( FloatBind(..) )-import GHC.Core.Ppr  ( pprCoreBindings, pprRules ) import GHC.Core.Opt.OccurAnal( occurAnalyseExpr, occurAnalysePgm ) import GHC.Types.Literal import GHC.Types.Id@@ -42,24 +41,21 @@ import GHC.Types.Var.Env import GHC.Core.DataCon import GHC.Types.Demand( etaConvertStrictSig )-import GHC.Core.Coercion.Opt ( optCoercion )+import GHC.Types.Tickish+import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) ) import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList                             , isInScope, substTyVarBndr, cloneTyVarBndr ) import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )-import GHC.Core.TyCon ( tyConArity )-import GHC.Core.Multiplicity import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Types.Basic import GHC.Unit.Module ( Module ) import GHC.Utils.Encoding-import GHC.Utils.Error-import GHC.Driver.Session import GHC.Utils.Outputable-import GHC.Data.Pair+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Data.Maybe       ( orElse )-import Data.List+import Data.List (mapAccumL) import qualified Data.ByteString as BS  {-@@ -93,7 +89,21 @@  -} -simpleOptExpr :: HasDebugCallStack => DynFlags -> CoreExpr -> CoreExpr+-- | Simple optimiser options+data SimpleOpts = SimpleOpts+   { so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options+   , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options+   }++-- | Default options for the Simple optimiser.+defaultSimpleOpts :: SimpleOpts+defaultSimpleOpts = SimpleOpts+   { so_uf_opts = defaultUnfoldingOpts+   , so_co_opts = OptCoercionOpts+      { optCoercionEnabled = False }+   }++simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr -- See Note [The simple optimiser] -- Do simple optimisation on an expression -- The optimisation is very straightforward: just@@ -109,10 +119,18 @@ -- The result is NOT guaranteed occurrence-analysed, because -- in  (let x = y in ....) we substitute for x; so y's occ-info -- may change radically+--+-- Note that simpleOptExpr is a pure function that we want to be able to call+-- from lots of places, including ones that don't have DynFlags (e.g to optimise+-- unfoldings of statically defined Ids via mkCompulsoryUnfolding). It used to+-- fetch its options directly from the DynFlags, however, so some callers had to+-- resort to using unsafeGlobalDynFlags (a global mutable variable containing+-- the DynFlags). It has been modified to take its own SimpleOpts that may be+-- created from DynFlags, but not necessarily. -simpleOptExpr dflags expr+simpleOptExpr opts expr   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)-    simpleOptExprWith dflags init_subst expr+    simpleOptExprWith opts init_subst expr   where     init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))         -- It's potentially important to make a proper in-scope set@@ -125,32 +143,29 @@         -- It's a bit painful to call exprFreeVars, because it makes         -- three passes instead of two (occ-anal, and go) -simpleOptExprWith :: HasDebugCallStack => DynFlags -> Subst -> InExpr -> OutExpr+simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr -- See Note [The simple optimiser]-simpleOptExprWith dflags subst expr+simpleOptExprWith opts subst expr   = simple_opt_expr init_env (occurAnalyseExpr expr)   where-    init_env = SOE { soe_dflags = dflags-                   , soe_inl = emptyVarEnv-                   , soe_subst = subst }+    init_env = (emptyEnv opts) { soe_subst = subst }  -----------------------simpleOptPgm :: DynFlags -> Module-             -> CoreProgram -> [CoreRule]-             -> IO (CoreProgram, [CoreRule])+simpleOptPgm :: SimpleOpts+             -> Module+             -> CoreProgram+             -> [CoreRule]+             -> (CoreProgram, [CoreRule], CoreProgram) -- See Note [The simple optimiser]-simpleOptPgm dflags this_mod binds rules-  = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"-            FormatCore (pprCoreBindings occ_anald_binds $$ pprRules rules );--       ; return (reverse binds', rules') }+simpleOptPgm opts this_mod binds rules =+    (reverse binds', rules', occ_anald_binds)   where     occ_anald_binds  = occurAnalysePgm this_mod                           (\_ -> True)  {- All unfoldings active -}                           (\_ -> False) {- No rules active -}                           rules binds -    (final_env, binds') = foldl' do_one (emptyEnv dflags, []) occ_anald_binds+    (final_env, binds') = foldl' do_one (emptyEnv opts, []) occ_anald_binds     final_subst = soe_subst final_env      rules' = substRulesForImportedIds final_subst rules@@ -168,14 +183,19 @@ type SimpleClo = (SimpleOptEnv, InExpr)  data SimpleOptEnv-  = SOE { soe_dflags :: DynFlags+  = SOE { soe_co_opt_opts :: !OptCoercionOpts+             -- ^ Options for the coercion optimiser++        , soe_uf_opts :: !UnfoldingOpts+             -- ^ Unfolding options+         , soe_inl   :: IdEnv SimpleClo-             -- Deals with preInlineUnconditionally; things+             -- ^ Deals with preInlineUnconditionally; things              -- that occur exactly once and are inlined              -- without having first been simplified          , soe_subst :: Subst-             -- Deals with cloning; includes the InScopeSet+             -- ^ Deals with cloning; includes the InScopeSet         }  instance Outputable SimpleOptEnv where@@ -184,11 +204,13 @@                             , text "soe_subst =" <+> ppr subst ]                    <+> text "}" -emptyEnv :: DynFlags -> SimpleOptEnv-emptyEnv dflags-  = SOE { soe_dflags = dflags-        , soe_inl = emptyVarEnv-        , soe_subst = emptySubst }+emptyEnv :: SimpleOpts -> SimpleOptEnv+emptyEnv opts = SOE+   { soe_inl         = emptyVarEnv+   , soe_subst       = emptySubst+   , soe_co_opt_opts = so_co_opts opts+   , soe_uf_opts     = so_uf_opts opts+   }  soeZapSubst :: SimpleOptEnv -> SimpleOptEnv soeZapSubst env@(SOE { soe_subst = subst })@@ -236,7 +258,7 @@       | isDeadBinder b       , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e'         -- We don't need to be concerned about floats when looking for coerce.-      , Just (altcon, bs, rhs) <- findAlt (DataAlt con) as+      , Just (Alt altcon bs rhs) <- findAlt (DataAlt con) as       = case altcon of           DEFAULT -> go rhs           _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs@@ -246,7 +268,7 @@           -- Note [Getting the map/coerce RULE to work]       | isDeadBinder b-      , [(DEFAULT, _, rhs)] <- as+      , [Alt DEFAULT _ rhs] <- as       , isCoVarType (varType b)       , (Var fun, _args) <- collectArgs e       , fun `hasKey` coercibleSCSelIdKey@@ -261,11 +283,11 @@         (env', b') = subst_opt_bndr env b      -----------------------    go_co co = optCoercion (soe_dflags env) (getTCvSubst subst) co+    go_co co = optCoercion (soe_co_opt_opts env) (getTCvSubst subst) co      -----------------------    go_alt env (con, bndrs, rhs)-      = (con, bndrs', simple_opt_expr env' rhs)+    go_alt env (Alt con bndrs rhs)+      = Alt con bndrs' (simple_opt_expr env' rhs)       where         (env', bndrs') = subst_opt_bndrs env bndrs @@ -312,10 +334,21 @@ simple_app env (App e1 e2) as   = simple_app env e1 ((env, e2) : as) -simple_app env (Lam b e) (a:as)-  = wrapLet mb_pr (simple_app env' e as)+simple_app env e@(Lam {}) as@(_:_)+  | (bndrs, body) <- collectBinders e+  , let zapped_bndrs = zapLamBndrs (length as) bndrs+    -- Be careful to zap the lambda binders if necessary+    -- c.f. the Lam caes of simplExprF1 in GHC.Core.Opt.Simplify+    -- Lacking this zap caused #19347, when we had a redex+    --   (\ a b. K a b) e1 e2+    -- where (as it happens) the eta-expanded K is produced by+    -- Note [Linear fields generalization] in GHC.Tc.Gen.Head+  = do_beta env zapped_bndrs body as   where-     (env', mb_pr) = simple_bind_pair env b Nothing a NotTopLevel+    do_beta env (b:bs) body (a:as)+      | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel+      = wrapLet mb_pr $ do_beta env' bs body as+    do_beta env bs body as = simple_app env (mkLams bs body) as  simple_app env (Tick t e) as   -- Okay to do "(Tick t e) x ==> Tick t (e x)"?@@ -390,7 +423,7 @@     (env { soe_subst = extendTvSubst subst in_bndr out_ty }, Nothing)    | Coercion co <- in_rhs-  , let out_co = optCoercion (soe_dflags env) (getTCvSubst (soe_subst rhs_env)) co+  , let out_co = optCoercion (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co   = ASSERT( isCoVar in_bndr )     (env { soe_subst = extendCvSubst subst in_bndr out_co }, Nothing) @@ -622,7 +655,7 @@  | otherwise        = lazySetIdInfo new_bndr new_info  where    subst    = soe_subst env-   dflags   = soe_dflags env+   uf_opts  = soe_uf_opts env    old_info = idInfo old_bndr     -- Add back in the rules and unfolding which were@@ -633,7 +666,7 @@                               `setUnfoldingInfo` new_unfolding     old_rules = ruleInfo old_info-   new_rules = substSpec subst new_bndr old_rules+   new_rules = substRuleInfo subst new_bndr old_rules     old_unfolding = unfoldingInfo old_info    new_unfolding | isStableUnfolding old_unfolding@@ -641,7 +674,7 @@                  | otherwise                  = unfolding_from_rhs -   unfolding_from_rhs = mkUnfolding dflags InlineRhs+   unfolding_from_rhs = mkUnfolding uf_opts InlineRhs                                     (isTopLevel top_level)                                     False -- may be bottom or not                                     new_rhs@@ -754,6 +787,28 @@ ************************************************************************ -} +{- Note [Strictness and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   let f = \x.  if x>200 then e1 else e1++and we know that f is strict in x.  Then if we subsequently+discover that f is an arity-2 join point, we'll eta-expand it to++   let f = \x y.  if x>200 then e1 else e1++and now it's only strict if applied to two arguments.  So we should+adjust the strictness info.++A more common case is when++   f = \x. error ".."++and again its arity increases (#15517)+-}++ -- | Returns Just (bndr,rhs) if the binding is a join point: -- If it's a JoinId, just return it -- If it's not yet a JoinId but is always tail-called,@@ -787,27 +842,6 @@   = mapM (uncurry joinPointBinding_maybe) bndrs  -{- Note [Strictness and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   let f = \x.  if x>200 then e1 else e1--and we know that f is strict in x.  Then if we subsequently-discover that f is an arity-2 join point, we'll eta-expand it to--   let f = \x y.  if x>200 then e1 else e1--and now it's only strict if applied to two arguments.  So we should-adjust the strictness info.--A more common case is when--   f = \x. error ".."--and again its arity increases (#15517)--}- {- ********************************************************************* *                                                                      *          exprIsConApp_maybe@@ -1108,7 +1142,7 @@              float           = FloatLet (NonRec bndr' rhs')          in go subst' (float:floats) expr cont -    go subst floats (Case scrut b _ [(con, vars, expr)]) cont+    go subst floats (Case scrut b _ [Alt con vars expr]) cont        = let           scrut'           = subst_expr subst scrut           (subst', b')     = subst_bndr subst b@@ -1285,7 +1319,7 @@ -}  exprIsLambda_maybe :: InScopeEnv -> CoreExpr-                      -> Maybe (Var, CoreExpr,[Tickish Id])+                      -> Maybe (Var, CoreExpr,[CoreTickish])     -- See Note [exprIsLambda_maybe]  -- The simple case: It is a lambda already@@ -1317,7 +1351,7 @@     -- Make sure there is hope to get a lambda     , Just rhs <- expandUnfolding_maybe (id_unf f)     -- Optimize, for beta-reduction-    , let e' = simpleOptExprWith unsafeGlobalDynFlags (mkEmptySubst in_scope_set) (rhs `mkApps` as)+    , let e' = simpleOptExprWith defaultSimpleOpts (mkEmptySubst in_scope_set) (rhs `mkApps` as)     -- Recurse, because of possible casts     , Just (x', e'', ts') <- exprIsLambda_maybe (in_scope_set, id_unf) e'     , let res = Just (x', e'', ts++ts')@@ -1327,277 +1361,3 @@ exprIsLambda_maybe _ _e     = -- pprTrace "exprIsLambda_maybe:Fail" (vcat [ppr _e])       Nothing---{- *********************************************************************-*                                                                      *-              The "push rules"-*                                                                      *-************************************************************************--Here we implement the "push rules" from FC papers:--* The push-argument rules, where we can move a coercion past an argument.-  We have-      (fun |> co) arg-  and we want to transform it to-    (fun arg') |> co'-  for some suitable co' and transformed arg'.--* The PushK rule for data constructors.  We have-       (K e1 .. en) |> co-  and we want to transform to-       (K e1' .. en')-  by pushing the coercion into the arguments--}--pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)-pushCoArgs co []         = return ([], MCo co)-pushCoArgs co (arg:args) = do { (arg',  m_co1) <- pushCoArg  co  arg-                              ; case m_co1 of-                                  MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args-                                                 ; return (arg':args', m_co2) }-                                  MRefl  -> return (arg':args, MRefl) }--pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)--- We have (fun |> co) arg, and we want to transform it to---         (fun arg) |> co--- This may fail, e.g. if (fun :: N) where N is a newtype--- C.f. simplCast in GHC.Core.Opt.Simplify--- 'co' is always Representational--- If the returned coercion is Nothing, then it would have been reflexive-pushCoArg co (Type ty) = do { (ty', m_co') <- pushCoTyArg co ty-                            ; return (Type ty', m_co') }-pushCoArg co val_arg   = do { (arg_co, m_co') <- pushCoValArg co-                            ; return (val_arg `mkCast` arg_co, m_co') }--pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)--- We have (fun |> co) @ty--- Push the coercion through to return---         (fun @ty') |> co'--- 'co' is always Representational--- If the returned coercion is Nothing, then it would have been reflexive;--- it's faster not to compute it, though.-pushCoTyArg co ty-  -- The following is inefficient - don't do `eqType` here, the coercion-  -- optimizer will take care of it. See #14737.-  -- -- | tyL `eqType` tyR-  -- -- = Just (ty, Nothing)--  | isReflCo co-  = Just (ty, MRefl)--  | isForAllTy_ty tyL-  = ASSERT2( isForAllTy_ty tyR, ppr co $$ ppr ty )-    Just (ty `mkCastTy` co1, MCo co2)--  | otherwise-  = Nothing-  where-    Pair tyL tyR = coercionKind co-       -- co :: tyL ~ tyR-       -- tyL = forall (a1 :: k1). ty1-       -- tyR = forall (a2 :: k2). ty2--    co1 = mkSymCo (mkNthCo Nominal 0 co)-       -- co1 :: k2 ~N k1-       -- Note that NthCo can extract a Nominal equality between the-       -- kinds of the types related by a coercion between forall-types.-       -- See the NthCo case in GHC.Core.Lint.--    co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)-        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]-        -- Arg of mkInstCo is always nominal, hence mkNomReflCo--pushCoValArg :: CoercionR -> Maybe (Coercion, MCoercion)--- We have (fun |> co) arg--- Push the coercion through to return---         (fun (arg |> co_arg)) |> co_res--- 'co' is always Representational--- If the second returned Coercion is actually Nothing, then no cast is necessary;--- the returned coercion would have been reflexive.-pushCoValArg co-  -- The following is inefficient - don't do `eqType` here, the coercion-  -- optimizer will take care of it. See #14737.-  -- -- | tyL `eqType` tyR-  -- -- = Just (mkRepReflCo arg, Nothing)--  | isReflCo co-  = Just (mkRepReflCo arg, MRefl)--  | isFunTy tyL-  , (co_mult, co1, co2) <- decomposeFunCo Representational co-  , isReflexiveCo co_mult-    -- We can't push the coercion in the case where co_mult isn't reflexivity:-    -- it could be an unsafe axiom, and losing this information could yield-    -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x)-    -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int-    -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed--              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)-              -- then co1 :: tyL1 ~ tyR1-              --      co2 :: tyL2 ~ tyR2-  = ASSERT2( isFunTy tyR, ppr co $$ ppr arg )-    Just (mkSymCo co1, MCo co2)--  | otherwise-  = Nothing-  where-    arg = funArgTy tyR-    Pair tyL tyR = coercionKind co--pushCoercionIntoLambda-    :: InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)--- This implements the Push rule from the paper on coercions---    (\x. e) |> co--- ===>---    (\x'. e |> co')-pushCoercionIntoLambda in_scope x e co-    | ASSERT(not (isTyVar x) && not (isCoVar x)) True-    , Pair s1s2 t1t2 <- coercionKind co-    , Just (_, _s1,_s2) <- splitFunTy_maybe s1s2-    , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2-    , (co_mult, co1, co2) <- decomposeFunCo Representational co-    , isReflexiveCo co_mult-      -- We can't push the coercion in the case where co_mult isn't-      -- reflexivity. See pushCoValArg for more details.-    = let-          -- Should we optimize the coercions here?-          -- Otherwise they might not match too well-          x' = x `setIdType` t1 `setIdMult` w1-          in_scope' = in_scope `extendInScopeSet` x'-          subst = extendIdSubst (mkEmptySubst in_scope')-                                x-                                (mkCast (Var x') co1)-      in Just (x', substExpr subst e `mkCast` co2)-    | otherwise-    = pprTrace "exprIsLambda_maybe: Unexpected lambda in case" (ppr (Lam x e))-      Nothing--pushCoDataCon :: DataCon -> [CoreExpr] -> Coercion-              -> Maybe (DataCon-                       , [Type]      -- Universal type args-                       , [CoreExpr]) -- All other args incl existentials--- Implement the KPush reduction rule as described in "Down with kinds"--- The transformation applies iff we have---      (C e1 ... en) `cast` co--- where co :: (T t1 .. tn) ~ to_ty--- The left-hand one must be a T, because exprIsConApp returned True--- but the right-hand one might not be.  (Though it usually will.)-pushCoDataCon dc dc_args co-  | isReflCo co || from_ty `eqType` to_ty  -- try cheap test first-  , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args-  = Just (dc, map exprToType univ_ty_args, rest_args)--  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty-  , to_tc == dataConTyCon dc-        -- These two tests can fail; we might see-        --      (C x y) `cast` (g :: T a ~ S [a]),-        -- where S is a type function.  In fact, exprIsConApp-        -- will probably not be called in such circumstances,-        -- but there's nothing wrong with it--  = let-        tc_arity       = tyConArity to_tc-        dc_univ_tyvars = dataConUnivTyVars dc-        dc_ex_tcvars   = dataConExTyCoVars dc-        arg_tys        = dataConRepArgTys dc--        non_univ_args  = dropList dc_univ_tyvars dc_args-        (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args--        -- Make the "Psi" from the paper-        omegas = decomposeCo tc_arity co (tyConRolesRepresentational to_tc)-        (psi_subst, to_ex_arg_tys)-          = liftCoSubstWithEx Representational-                              dc_univ_tyvars-                              omegas-                              dc_ex_tcvars-                              (map exprToType ex_args)--          -- Cast the value arguments (which include dictionaries)-        new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args-        cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)--        to_ex_args = map Type to_ex_arg_tys--        dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tcvars,-                         ppr arg_tys, ppr dc_args,-                         ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc-                         , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]-    in-    ASSERT2( eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)), dump_doc )-    ASSERT2( equalLength val_args arg_tys, dump_doc )-    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)--  | otherwise-  = Nothing--  where-    Pair from_ty to_ty = coercionKind co--collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)--- Collect lambda binders, pushing coercions inside if possible--- E.g.   (\x.e) |> g         g :: <Int> -> blah---        = (\x. e |> Nth 1 g)------ That is,------ collectBindersPushingCo ((\x.e) |> g) === ([x], e |> Nth 1 g)-collectBindersPushingCo e-  = go [] e-  where-    -- Peel off lambdas until we hit a cast.-    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)-    -- The accumulator is in reverse order-    go bs (Lam b e)   = go (b:bs) e-    go bs (Cast e co) = go_c bs e co-    go bs e           = (reverse bs, e)--    -- We are in a cast; peel off casts until we hit a lambda.-    go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)-    -- (go_c bs e c) is same as (go bs e (e |> c))-    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)-    go_c bs (Lam b e)    co  = go_lam bs b e co-    go_c bs e            co  = (reverse bs, mkCast e co)--    -- We are in a lambda under a cast; peel off lambdas and build a-    -- new coercion for the body.-    go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)-    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)-    go_lam bs b e co-      | isTyVar b-      , let Pair tyL tyR = coercionKind co-      , ASSERT( isForAllTy_ty tyL )-        isForAllTy_ty tyR-      , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]-      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))--      | isCoVar b-      , let Pair tyL tyR = coercionKind co-      , ASSERT( isForAllTy_co tyL )-        isForAllTy_co tyR-      , isReflCo (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]-      , let cov = mkCoVarCo b-      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))--      | isId b-      , let Pair tyL tyR = coercionKind co-      , ASSERT( isFunTy tyL) isFunTy tyR-      , (co_mult, co_arg, co_res) <- decomposeFunCo Representational co-      , isReflCo co_mult -- See Note [collectBindersPushingCo]-      , isReflCo co_arg  -- See Note [collectBindersPushingCo]-      = go_c (b:bs) e co_res--      | otherwise = (reverse bs, mkCast (Lam b e) co)--{---Note [collectBindersPushingCo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We just look for coercions of form-   <type> # w -> blah-(and similarly for foralls) to keep this function simple.  We could do-more elaborate stuff, but it'd involve substitution etc.---}

+ GHC/Core/SimpleOpt.hs-boot view

@@ -0,0 +1,11 @@+module GHC.Core.SimpleOpt where++import GHC.Core+import {-# SOURCE #-} GHC.Core.Unfold+import GHC.Utils.Misc (HasDebugCallStack)++data SimpleOpts++so_uf_opts :: SimpleOpts -> UnfoldingOpts++simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr

GHC/Core/Stats.hs view

@@ -17,6 +17,7 @@ import GHC.Core import GHC.Utils.Outputable import GHC.Core.Coercion+import GHC.Types.Tickish import GHC.Types.Var import GHC.Core.Type(Type, typeSize) import GHC.Types.Id (isJoinId)@@ -84,7 +85,7 @@ exprStats (Tick _ e)      = exprStats e  altStats :: CoreAlt -> CoreStats-altStats (_, bs, r) = altBndrStats bs `plusCS` exprStats r+altStats (Alt _ bs r) = altBndrStats bs `plusCS` exprStats r  altBndrStats :: [Var] -> CoreStats -- Charge one for the alternative, not for each binder@@ -116,7 +117,7 @@ exprSize (Type _)        = 1 exprSize (Coercion _)    = 1 -tickSize :: Tickish Id -> Int+tickSize :: CoreTickish -> Int tickSize (ProfNote _ _ _) = 1 tickSize _ = 1 @@ -134,4 +135,4 @@ pairSize (b,e) = bndrSize b + exprSize e  altSize :: CoreAlt -> Int-altSize (_,bs,e) = bndrsSize bs + exprSize e+altSize (Alt _ bs e) = bndrsSize bs + exprSize e

GHC/Core/Subst.hs view

@@ -14,7 +14,7 @@         TvSubstEnv, IdSubstEnv, InScopeSet,          -- ** Substituting into expressions and related types-        deShadowBinds, substSpec, substRulesForImportedIds,+        deShadowBinds, substRuleInfo, substRulesForImportedIds,         substTy, substCo, substExpr, substExprSC, substBind, substBindSC,         substUnfolding, substUnfoldingSC,         lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc,@@ -39,6 +39,8 @@  import GHC.Prelude +import GHC.Driver.Ppr+ import GHC.Core import GHC.Core.FVs import GHC.Core.Seq@@ -58,12 +60,14 @@ import GHC.Types.Id import GHC.Types.Name     ( Name ) import GHC.Types.Var+import GHC.Types.Tickish import GHC.Types.Id.Info import GHC.Types.Unique.Supply import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable-import Data.List+import GHC.Utils.Panic+import Data.List (mapAccumL)   @@ -340,6 +344,8 @@  substExprSC :: HasDebugCallStack => Subst -> CoreExpr -> CoreExpr -- Just like substExpr, but a no-op if the substitution is empty+-- Note that this does /not/ replace occurrences of free vars with+-- their canonical representatives in the in-scope set substExprSC subst orig_expr   | isEmptySubst subst = orig_expr   | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $@@ -381,7 +387,7 @@                                  where                                  (subst', bndr') = substBndr subst bndr -    go_alt subst (con, bndrs, rhs) = (con, bndrs', substExpr subst' rhs)+    go_alt subst (Alt con bndrs rhs) = Alt con bndrs' (substExpr subst' rhs)                                  where                                    (subst', bndrs') = substBndrs subst bndrs @@ -579,7 +585,7 @@         (TCvSubst in_scope' tv_env' cv_env', cv')            -> (Subst in_scope' id_env tv_env' cv_env', cv') --- | See 'Type.substTy'+-- | See 'GHC.Core.Type.substTy'. substTy :: Subst -> Type -> Type substTy subst ty = Type.substTyUnchecked (getTCvSubst subst) ty @@ -616,7 +622,7 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info   | nothing_to_do = Nothing-  | otherwise     = Just (info `setRuleInfo`      substSpec subst new_id old_rules+  | otherwise     = Just (info `setRuleInfo`      substRuleInfo subst new_id old_rules                                `setUnfoldingInfo` substUnfolding subst old_unf)   where     old_rules     = ruleInfo info@@ -625,6 +631,9 @@  ------------------ -- | Substitutes for the 'Id's within an unfolding+-- NB: substUnfolding /discards/ any unfolding without+--     without a Stable source.  This is usually what we want,+--     but it may be a bit unexpected substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding         -- Seq'ing on the returned Unfolding is enough to cause         -- all the substitutions to happen completely@@ -659,14 +668,13 @@                         other  -> pprPanic "substIdOcc" (vcat [ppr v <+> ppr other, ppr subst])  --------------------- | Substitutes for the 'Id's within the 'WorkerInfo' given the new function 'Id'-substSpec :: Subst -> Id -> RuleInfo -> RuleInfo-substSpec subst new_id (RuleInfo rules rhs_fvs)-  = seqRuleInfo new_spec `seq` new_spec+-- | Substitutes for the 'Id's within the 'RuleInfo' given the new function 'Id'+substRuleInfo :: Subst -> Id -> RuleInfo -> RuleInfo+substRuleInfo subst new_id (RuleInfo rules rhs_fvs)+  = RuleInfo (map (substRule subst subst_ru_fn) rules)+                  (substDVarSet subst rhs_fvs)   where     subst_ru_fn = const (idName new_id)-    new_spec = RuleInfo (map (substRule subst subst_ru_fn) rules)-                        (substDVarSet subst rhs_fvs)  ------------------ substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]@@ -709,9 +717,9 @@      | otherwise = tyCoFVsOfType (lookupTCvSubst subst fv) (const True) emptyVarSet $! acc  -------------------substTickish :: Subst -> Tickish Id -> Tickish Id-substTickish subst (Breakpoint n ids)-   = Breakpoint n (map do_one ids)+substTickish :: Subst -> CoreTickish -> CoreTickish+substTickish subst (Breakpoint ext n ids)+   = Breakpoint ext n (map do_one ids)  where     do_one = getIdFromTrivialExpr . lookupIdSubst subst substTickish _subst other = other@@ -728,6 +736,31 @@  In any case we don't need to optimise the RHS of rules, or unfoldings, because the simplifier will do that.++Another place this went wrong was in `substRuleInfo`, which would immediately force+the lazy call to substExpr, which led to an infinite loop (as reported by #20112).++This time the call stack looked something like:++* `substRecBndrs`+* `substIdBndr`+* `substIdInfo`+* `substRuleInfo`+* `substRule`+* `substExpr`+* `mkTick`+* `isSaturatedConApp`+* Look at `IdInfo` for thing we are currently substituting because the rule is attached to `transpose` and mentions it in the `RHS` of the rule.++and the rule was++{-# RULES+"transpose/overlays1" forall xs. transpose (overlays1 xs) = overlays1 (fmap transpose xs)+#-}++This rule was attached to `transpose`, but also mentions itself in the RHS so we have+to be careful to not force the `IdInfo` for transpose when dealing with the RHS of the rule.+   Note [substTickish]

GHC/Core/Tidy.hs view

@@ -21,7 +21,7 @@ import GHC.Core.Seq ( seqUnfolding ) import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Types.Demand ( zapUsageEnvSig )+import GHC.Types.Demand ( zapDmdEnvSig ) import GHC.Core.Type     ( tidyType, tidyVarBndr ) import GHC.Core.Coercion ( tidyCo ) import GHC.Types.Var@@ -30,8 +30,9 @@ import GHC.Types.Unique.FM import GHC.Types.Name hiding (tidyNameOcc) import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Data.Maybe-import Data.List+import Data.List (mapAccumL)  {- ************************************************************************@@ -83,13 +84,14 @@  ------------  Case alternatives  -------------- tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt-tidyAlt env (con, vs, rhs)+tidyAlt env (Alt con vs rhs)   = tidyBndrs env vs    =: \ (env', vs) ->-    (con, vs, tidyExpr env' rhs)+    (Alt con vs (tidyExpr env' rhs))  ------------  Tickish  ---------------tidyTickish :: TidyEnv -> Tickish Id -> Tickish Id-tidyTickish env (Breakpoint ix ids) = Breakpoint ix (map (tidyVarOcc env) ids)+tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish+tidyTickish env (Breakpoint ext ix ids)+  = Breakpoint ext ix (map (tidyVarOcc env) ids) tidyTickish _   other_tickish       = other_tickish  ------------  Rules  --------------@@ -206,7 +208,7 @@         new_info = vanillaIdInfo                     `setOccInfo`        occInfo old_info                     `setArityInfo`      arityInfo old_info-                    `setStrictnessInfo` zapUsageEnvSig (strictnessInfo old_info)+                    `setStrictnessInfo` zapDmdEnvSig (strictnessInfo old_info)                     `setDemandInfo`     demandInfo old_info                     `setInlinePragInfo` inlinePragInfo old_info                     `setUnfoldingInfo`  new_unf

GHC/Core/TyCo/FVs.hs view

@@ -26,7 +26,8 @@         injectiveVarsOfType, injectiveVarsOfTypes,         invisibleVarsOfType, invisibleVarsOfTypes, -        -- No Free vars+        -- Any and No Free vars+        anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo,         noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo,          -- * Well-scoped free variables@@ -47,7 +48,7 @@  import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes) -import Data.Monoid as DM ( Endo(..), All(..) )+import Data.Monoid as DM ( Endo(..), Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon import GHC.Types.Var@@ -386,7 +387,7 @@ {- Note [Finding free coercion varibles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here we are only interested in the free /coercion/ variables.-We can achieve this through a slightly differnet TyCo folder.+We can achieve this through a slightly different TyCo folder.  Notice that we look deeply, into kinds. @@ -861,32 +862,43 @@  {- ********************************************************************* *                                                                      *-                 No free vars+                 Any free vars *                                                                      * ********************************************************************* -} -nfvFolder :: TyCoFolder TyCoVarSet DM.All-nfvFolder = TyCoFolder { tcf_view = noView-                       , tcf_tyvar = do_tcv, tcf_covar = do_tcv-                       , tcf_hole = do_hole, tcf_tycobinder = do_bndr }+{-# INLINE afvFolder #-}   -- so that specialization to (const True) works+afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any+afvFolder check_fv = TyCoFolder { tcf_view = noView+                                , tcf_tyvar = do_tcv, tcf_covar = do_tcv+                                , tcf_hole = do_hole, tcf_tycobinder = do_bndr }   where-    do_tcv is tv = All (tv `elemVarSet` is)-    do_hole _ _  = All True    -- I'm unsure; probably never happens+    do_tcv is tv = Any (not (tv `elemVarSet` is) && check_fv tv)+    do_hole _ _  = Any False    -- I'm unsure; probably never happens     do_bndr is tv _ = is `extendVarSet` tv -nfv_ty  :: Type       -> DM.All-nfv_tys :: [Type]     -> DM.All-nfv_co  :: Coercion   -> DM.All-(nfv_ty, nfv_tys, nfv_co, _) = foldTyCo nfvFolder emptyVarSet+anyFreeVarsOfType :: (TyCoVar -> Bool) -> Type -> Bool+anyFreeVarsOfType check_fv ty = DM.getAny (f ty)+  where (f, _, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet +anyFreeVarsOfTypes :: (TyCoVar -> Bool) -> [Type] -> Bool+anyFreeVarsOfTypes check_fv tys = DM.getAny (f tys)+  where (_, f, _, _) = foldTyCo (afvFolder check_fv) emptyVarSet++anyFreeVarsOfCo :: (TyCoVar -> Bool) -> Coercion -> Bool+anyFreeVarsOfCo check_fv co = DM.getAny (f co)+  where (_, _, f, _) = foldTyCo (afvFolder check_fv) emptyVarSet+ noFreeVarsOfType :: Type -> Bool-noFreeVarsOfType ty = DM.getAll (nfv_ty ty)+noFreeVarsOfType ty = not $ DM.getAny (f ty)+  where (f, _, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet  noFreeVarsOfTypes :: [Type] -> Bool-noFreeVarsOfTypes tys = DM.getAll (nfv_tys tys)+noFreeVarsOfTypes tys = not $ DM.getAny (f tys)+  where (_, f, _, _) = foldTyCo (afvFolder (const True)) emptyVarSet  noFreeVarsOfCo :: Coercion -> Bool-noFreeVarsOfCo co = getAll (nfv_co co)+noFreeVarsOfCo co = not $ DM.getAny (f co)+  where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet   {- *********************************************************************@@ -989,4 +1001,3 @@ -- | Get the free vars of types in scoped order tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar] tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList-

GHC/Core/TyCo/Ppr.hs view

@@ -22,9 +22,6 @@         pprCo, pprParendCo,          debugPprType,--        -- * Pretty-printing 'TyThing's-        pprTyThingCategory, pprShortTyThing,   ) where  import GHC.Prelude@@ -34,10 +31,10 @@    , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )  import {-# SOURCE #-} GHC.Core.DataCon-   ( dataConFullSig , dataConUserTyVarBinders-   , DataCon )+   ( dataConFullSig , dataConUserTyVarBinders, DataCon ) -import GHC.Core.Type ( isLiftedTypeKind, pattern One, pattern Many )+import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many,+                       splitForAllReqTVBinders, splitForAllInvisTVBinders )  import GHC.Core.TyCon import GHC.Core.TyCo.Rep@@ -52,6 +49,7 @@ import GHC.Types.Var.Env  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Basic ( PprPrec(..), topPrec, sigPrec, opPrec                        , funPrec, appPrec, maybeParen ) @@ -78,7 +76,7 @@ -------------------------------------------------------- -- When pretty-printing types, we convert to IfaceType, --   and pretty-print that.--- See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing+-- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr --------------------------------------------------------  pprType, pprParendType, pprTidiedType :: Type -> SDoc@@ -192,11 +190,35 @@ -- pprIfaceTvBndr is minimal, and the loss of uniques etc in -- debug printing is disastrous pprTyVar tv-  | isLiftedTypeKind kind = ppr tv-  | otherwise             = parens (ppr tv <+> dcolon <+> ppr kind)+  | pickyIsLiftedTypeKind kind = ppr tv  -- See Note [Suppressing * kinds]+  | otherwise                  = parens (ppr tv <+> dcolon <+> ppr kind)   where     kind = tyVarKind tv +{- Note [Suppressing * kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally we want to print+      forall a. a->a+not   forall (a::*). a->a+or    forall (a::Type). a->a+That is, for brevity we suppress a kind ascription of '*' (or Type).++But what if the kind is (Const Type x)?+   type Const p q = p++Then (Const Type x) is just a long way of saying Type.  But it may be+jolly confusing to suppress the 'x'.  Suppose we have (polykinds/T18451a)+   foo :: forall a b (c :: Const Type b). Proxy '[a, c]++Then this error message+    • These kind and type variables: a b (c :: Const Type b)+      are out of dependency order. Perhaps try this ordering:+        (b :: k) (a :: Const (*) b) (c :: Const (*) b)+would be much less helpful if we suppressed the kind ascription on 'a'.++Hence the use of pickyIsLiftedTypeKind.+-}+ ----------------- debugPprType :: Type -> SDoc -- ^ debugPprType is a simple pretty printer that prints a type@@ -245,19 +267,34 @@ debug_ppr_ty _ (CoercionTy co)   = parens (text "CO" <+> ppr co) -debug_ppr_ty prec ty@(ForAllTy {})-  | (tvs, body) <- split ty+-- Invisible forall:  forall {k} (a :: k). t+debug_ppr_ty prec t+  | (bndrs, body) <- splitForAllInvisTVBinders t+  , not (null bndrs)   = maybeParen prec funPrec $-    hang (text "forall" <+> fsep (map ppr tvs) <> dot)-         -- The (map ppr tvs) will print kind-annotated-         -- tvs, because we are (usually) in debug-style-       2 (ppr body)+    sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot,+          ppr body ]   where-    split ty | ForAllTy tv ty' <- ty-             , (tvs, body) <- split ty'-             = (tv:tvs, body)-             | otherwise-             = ([], ty)+    -- (ppr tv) will print the binder kind-annotated+    -- when in debug-style+    ppr_bndr (Bndr tv InferredSpec)  = braces (ppr tv)+    ppr_bndr (Bndr tv SpecifiedSpec) = ppr tv++-- Visible forall:  forall x y -> t+debug_ppr_ty prec t+  | (bndrs, body) <- splitForAllReqTVBinders t+  , not (null bndrs)+  = maybeParen prec funPrec $+    sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow,+          ppr body ]+  where+    -- (ppr tv) will print the binder kind-annotated+    -- when in debug-style+    ppr_bndr (Bndr tv ()) = ppr tv++-- Impossible case: neither visible nor invisible forall.+debug_ppr_ty _ ForAllTy{}+  = panic "debug_ppr_ty: neither splitForAllInvisTVBinders nor splitForAllReqTVBinders returned any binders"  {- Note [Infix type variables]

GHC/Core/TyCo/Rep.hs view

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiWayIf         #-}++{-# OPTIONS_HADDOCK not-home #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998@@ -18,11 +24,7 @@ -}  -- We expose the relevant stuff from this module via the Type module-{-# OPTIONS_HADDOCK not-home #-}-{-# LANGUAGE CPP, MultiWayIf, PatternSynonyms, BangPatterns, DeriveDataTypeable #-}- module GHC.Core.TyCo.Rep (-        TyThing(..), tyThingCategory, pprTyThingCategory, pprShortTyThing,          -- * Types         Type(..),@@ -36,12 +38,12 @@         -- * Coercions         Coercion(..),         UnivCoProvenance(..),-        CoercionHole(..), BlockSubstFlag(..), coHoleCoVar, setCoHoleCoVar,+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,         CoercionN, CoercionR, CoercionP, KindCoercion,         MCoercion(..), MCoercionR, MCoercionN,          -- * Functions over types-        mkTyConTy, mkTyVarTy, mkTyVarTys,+        mkTyConTy_, mkTyVarTy, mkTyVarTys,         mkTyCoVarTy, mkTyCoVarTys,         mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys,         mkForAllTy, mkForAllTys, mkInvisForAllTys,@@ -50,7 +52,7 @@         mkScaledFunTy,         mkVisFunTyMany, mkVisFunTysMany,         mkInvisFunTyMany, mkInvisFunTysMany,-        mkTyConApp,+        nonDetCmpTyLit, cmpTyLit,          -- * Functions over binders         TyCoBinder(..), TyCoVarBinder, TyBinder,@@ -81,89 +83,26 @@     -- Transitively pulls in a LOT of stuff, better to break the loop -import {-# SOURCE #-} GHC.Core.ConLike ( ConLike(..), conLikeName )- -- friends: import GHC.Iface.Type import GHC.Types.Var import GHC.Types.Var.Set-import GHC.Types.Name hiding ( varName ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom  -- others-import GHC.Builtin.Names ( liftedTypeKindTyConKey, manyDataConKey )-import {-# SOURCE #-} GHC.Builtin.Types ( liftedTypeKindTyCon, manyDataConTy )+import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy ) import GHC.Types.Basic ( LeftOrRight(..), pickLR )-import GHC.Types.Unique ( hasKey )+import GHC.Types.Unique ( Uniquable(..) ) import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc+import GHC.Utils.Panic  -- libraries import qualified Data.Data as Data hiding ( TyCon ) import Data.IORef ( IORef )   -- for CoercionHole -{--%************************************************************************-%*                                                                      *-                        TyThing-%*                                                                      *-%************************************************************************--Despite the fact that DataCon has to be imported via a hi-boot route,-this module seems the right place for TyThing, because it's needed for-funTyCon and all the types in GHC.Builtin.Types.Prim.--It is also SOURCE-imported into "GHC.Types.Name"---Note [ATyCon for classes]-~~~~~~~~~~~~~~~~~~~~~~~~~-Both classes and type constructors are represented in the type environment-as ATyCon.  You can tell the difference, and get to the class, with-   isClassTyCon :: TyCon -> Bool-   tyConClass_maybe :: TyCon -> Maybe Class-The Class and its associated TyCon have the same Name.--}---- | A global typecheckable-thing, essentially anything that has a name.--- Not to be confused with a 'TcTyThing', which is also a typecheckable--- thing but in the *local* context.  See "GHC.Tc.Utils.Env" for how to retrieve--- a 'TyThing' given a 'Name'.-data TyThing-  = AnId     Id-  | AConLike ConLike-  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]-  | ACoAxiom (CoAxiom Branched)--instance Outputable TyThing where-  ppr = pprShortTyThing--instance NamedThing TyThing where       -- Can't put this with the type-  getName (AnId id)     = getName id    -- decl, because the DataCon instance-  getName (ATyCon tc)   = getName tc    -- isn't visible there-  getName (ACoAxiom cc) = getName cc-  getName (AConLike cl) = conLikeName cl--pprShortTyThing :: TyThing -> SDoc--- c.f. GHC.Core.Ppr.TyThing.pprTyThing, which prints all the details-pprShortTyThing thing-  = pprTyThingCategory thing <+> quotes (ppr (getName thing))--pprTyThingCategory :: TyThing -> SDoc-pprTyThingCategory = text . capitalise . tyThingCategory--tyThingCategory :: TyThing -> String-tyThingCategory (ATyCon tc)-  | isClassTyCon tc = "class"-  | otherwise       = "type constructor"-tyThingCategory (ACoAxiom _) = "coercion axiom"-tyThingCategory (AnId   _)   = "identifier"-tyThingCategory (AConLike (RealDataCon _)) = "data constructor"-tyThingCategory (AConLike (PatSynCon _))  = "pattern synonym"-- {- ********************************************************************** *                                                                       *                         Type@@ -251,8 +190,29 @@ data TyLit   = NumTyLit Integer   | StrTyLit FastString-  deriving (Eq, Ord, Data.Data)+  | CharTyLit Char+  deriving (Eq, Data.Data) +-- Non-determinism arises due to uniqCompareFS+nonDetCmpTyLit :: TyLit -> TyLit -> Ordering+nonDetCmpTyLit = cmpTyLitWith NonDetFastString++-- Slower than nonDetCmpTyLit but deterministic+cmpTyLit :: TyLit -> TyLit -> Ordering+cmpTyLit = cmpTyLitWith LexicalFastString++{-# INLINE cmpTyLitWith #-}+cmpTyLitWith :: Ord r => (FastString -> r) -> TyLit -> TyLit -> Ordering+cmpTyLitWith _ (NumTyLit  x) (NumTyLit  y) = compare x y+cmpTyLitWith w (StrTyLit  x) (StrTyLit  y) = compare (w x) (w y)+cmpTyLitWith _ (CharTyLit x) (CharTyLit y) = compare x y+cmpTyLitWith _ a b = compare (tag a) (tag b)+  where+    tag :: TyLit -> Int+    tag NumTyLit{}  = 0+    tag StrTyLit{}  = 1+    tag CharTyLit{} = 2+ instance Outputable TyLit where    ppr = pprTyLit @@ -540,6 +500,12 @@ This principle also tells us that eqType must relate only types with the same kinds. +Besides eqType, another equality relation that upholds the (EQ) property above+is /typechecker equality/, which is implemented as+GHC.Tc.Utils.TcType.tcEqType. See+Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType for+what the difference between eqType and tcEqType is.+ Note [Respecting definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note [Non-trivial definitional equality] introduces the property (EQ).@@ -1045,61 +1011,11 @@ mkPiTys :: [TyCoBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs --- | Create the plain type constructor type which has been applied to no type arguments at all.-mkTyConTy :: TyCon -> Type-mkTyConTy tycon = TyConApp tycon []---- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to--- its arguments.  Applies its arguments to the constructor from left to right.-mkTyConApp :: TyCon -> [Type] -> Type-mkTyConApp tycon tys-  | isFunTyCon tycon-  , [w, _rep1,_rep2,ty1,ty2] <- tys-  -- The FunTyCon (->) is always a visible one-  = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }--  -- Note [mkTyConApp and Type]-  | tycon `hasKey` liftedTypeKindTyConKey-  = ASSERT2( null tys, ppr tycon $$ ppr tys )-    liftedTypeKindTyConApp-  | tycon `hasKey` manyDataConKey-  -- There are a lot of occurrences of 'Many' so it's a small optimisation to-  -- avoid reboxing every time `mkTyConApp` is called.-  = ASSERT2( null tys, ppr tycon $$ ppr tys )-    manyDataConTy-  | otherwise-  = TyConApp tycon tys---- This is a single, global definition of the type `Type`--- Defined here so it is only allocated once.--- See Note [mkTyConApp and Type]-liftedTypeKindTyConApp :: Type-liftedTypeKindTyConApp = TyConApp liftedTypeKindTyCon []--{--Note [mkTyConApp and Type]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Whilst benchmarking it was observed in #17292 that GHC allocated a lot-of `TyConApp` constructors. Upon further inspection a large number of these-TyConApp constructors were all duplicates of `Type` applied to no arguments.--```-(From a sample of 100000 TyConApp closures)-0x45f3523    - 28732 - `Type`-0x420b840702 - 9629  - generic type constructors-0x42055b7e46 - 9596-0x420559b582 - 9511-0x420bb15a1e - 9509-0x420b86c6ba - 9501-0x42055bac1e - 9496-0x45e68fd    - 538 - `TYPE ...`-```--Therefore in `mkTyConApp` we have a special case for `Type` to ensure that-only one `TyConApp 'Type []` closure is allocated during the course of-compilation. In order to avoid a potentially expensive series of checks in-`mkTyConApp` only this egregious case is special cased at the moment.--}+-- | Create a nullary 'TyConApp'. In general you should rather use+-- 'GHC.Core.Type.mkTyConTy'. This merely exists to break the import cycle+-- between 'GHC.Core.TyCon' and this module.+mkTyConTy_ :: TyCon -> Type+mkTyConTy_ tycon = TyConApp tycon []  {- %************************************************************************@@ -1640,15 +1556,9 @@   = CoercionHole { ch_co_var  :: CoVar                        -- See Note [CoercionHoles and coercion free variables] -                 , ch_blocker :: BlockSubstFlag  -- should this hole block substitution?-                                                 -- See (2a) in TcCanonical-                                                 -- Note [Equalities with incompatible kinds]                  , ch_ref     :: IORef (Maybe Coercion)                  } -data BlockSubstFlag = YesBlockSubst-                    | NoBlockSubst- coHoleCoVar :: CoercionHole -> CoVar coHoleCoVar = ch_co_var @@ -1664,9 +1574,8 @@ instance Outputable CoercionHole where   ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv) -instance Outputable BlockSubstFlag where-  ppr YesBlockSubst = text "YesBlockSubst"-  ppr NoBlockSubst  = text "NoBlockSubst"+instance Uniquable CoercionHole where+  getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv  {- Note [Phantom coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1913,7 +1822,7 @@       = let !env' = tycobinder env tv vis  -- Avoid building a thunk here         in go_ty env (varType tv) `mappend` go_ty env' inner -    -- Explicit recursion becuase using foldr builds a local+    -- Explicit recursion because using foldr builds a local     -- loop (with env free) and I'm not confident it'll be     -- lambda lifted in the end     go_tys _   []     = mempty@@ -2024,13 +1933,16 @@ -}  -- | A shorthand for data with an attached 'Mult' element (the multiplicity).-data Scaled a = Scaled Mult a+data Scaled a = Scaled !Mult a   deriving (Data.Data)-  -- You might think that this would be a natural candiate for+  -- You might think that this would be a natural candidate for   -- Functor, Traversable but Krzysztof says (!3674) "it was too easy   -- to accidentally lift functions (substitutions, zonking etc.) from   -- Type -> Type to Scaled Type -> Scaled Type, ignoring   -- multiplicities and causing bugs".  So we don't.+  --+  -- Being strict in a is worse for performance, so we are only strict on the+  -- Mult part of scaled.   instance (Outputable a) => Outputable (Scaled a) where

GHC/Core/TyCo/Rep.hs-boot view

@@ -3,9 +3,9 @@ import GHC.Utils.Outputable ( Outputable ) import Data.Data  ( Data ) import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag )+import {-# SOURCE #-} GHC.Core.TyCon ( TyCon )  data Type-data TyThing data Coercion data UnivCoProvenance data TyLit@@ -23,6 +23,7 @@  mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type mkForAllTy :: Var -> ArgFlag -> Type -> Type+mkTyConTy_ :: TyCon -> Type  instance Data Type  -- To support Data instances in GHC.Core.Coercion.Axiom instance Outputable Type

GHC/Core/TyCo/Subst.hs view

@@ -18,7 +18,7 @@         mkTCvSubst, mkTvSubst, mkCvSubst,         getTvSubstEnv,         getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs,-        isInScope, notElemTCvSubst,+        isInScope, elemTCvSubst, notElemTCvSubst,         setTvSubstEnv, setCvSubstEnv, zapTCvSubst,         extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,         extendTCvSubst, extendTCvSubstWithClone,@@ -46,6 +46,7 @@         substTyVarBndr, substTyVarBndrs,         substCoVarBndr,         substTyVar, substTyVars, substTyCoVars,+        substTyCoBndr,         substForAllCoBndr,         substVarBndrUsing, substForAllCoBndrUsing,         checkValidSubst, isValidTCvSubst,@@ -56,7 +57,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Core.Type-   ( mkCastTy, mkAppTy, isCoercionTy )+   ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp ) import {-# SOURCE #-} GHC.Core.Coercion    ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo    , mkNomReflCo, mkSubCo, mkSymCo@@ -81,6 +82,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.List (mapAccumL) @@ -291,13 +293,16 @@ isInScope :: Var -> TCvSubst -> Bool isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope -notElemTCvSubst :: Var -> TCvSubst -> Bool-notElemTCvSubst v (TCvSubst _ tenv cenv)+elemTCvSubst :: Var -> TCvSubst -> Bool+elemTCvSubst v (TCvSubst _ tenv cenv)   | isTyVar v-  = not (v `elemVarEnv` tenv)+  = v `elemVarEnv` tenv   | otherwise-  = not (v `elemVarEnv` cenv)+  = v `elemVarEnv` cenv +notElemTCvSubst :: Var -> TCvSubst -> Bool+notElemTCvSubst v = not . elemTCvSubst v+ setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv @@ -423,6 +428,7 @@ -- | Generates the in-scope set for the 'TCvSubst' from the types in the -- incoming environment. No CoVars, please! mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst+mkTvSubstPrs []  = emptyTCvSubst mkTvSubstPrs prs =     ASSERT2( onlyTyVarsAndNoCoercionTy, text "prs" <+> ppr prs )     mkTvSubst in_scope tenv@@ -439,7 +445,7 @@   = pprPanic "zipTyEnv" (ppr tyvars $$ ppr tys)   | otherwise   = ASSERT( all (not . isCoercionTy) tys )-    mkVarEnv (zipEqual "zipTyEnv" tyvars tys)+    zipToUFM tyvars tys         -- There used to be a special case for when         --      ty == TyVarTy tv         -- (a not-uncommon case) in which case the substitution was dropped.@@ -740,7 +746,8 @@     go (TyConApp tc tys) = (mkTyConApp $! tc) $! strictMap go tys                                -- NB: mkTyConApp, not TyConApp.                                -- mkTyConApp has optimizations.-                               -- See Note [mkTyConApp and Type] in GHC.Core.TyCo.Rep+                               -- See Note [Prefer Type over TYPE 'LiftedRep]+                               -- in GHC.Core.TyCo.Rep     go ty@(FunTy { ft_mult = mult, ft_arg = arg, ft_res = res })       = let !mult' = go mult             !arg' = go arg@@ -1052,3 +1059,10 @@     (uniq, usupply') = takeUniqFromSupply usupply     (subst' , tv )   = cloneTyVarBndr subst t uniq     (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply'++substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder)+substTyCoBndr subst (Anon af ty)          = (subst, Anon af (substScaledTy subst ty))+substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))+                                          where+                                            (subst', tv') = substVarBndr subst tv+

GHC/Core/TyCo/Tidy.hs view

@@ -26,7 +26,7 @@ import GHC.Types.Name hiding (varName) import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Utils.Misc (seqList)+import GHC.Utils.Misc (strictMap)  import Data.List (mapAccumL) @@ -123,29 +123,48 @@         Just tv' -> tv'  ---------------++{-+Note [Strictness in tidyType and friends]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Perhaps surprisingly, making `tidyType` strict has a rather large effect on+performance: see #14738.  So you will see lots of strict applications ($!)+and uses of `strictMap` in `tidyType`, `tidyTypes` and `tidyCo`.++See #14738 for the performance impact -- sometimes as much as a 5%+reduction in allocation.+-}++-- | Tidy a list of Types+--+-- See Note [Strictness in tidyType and friends] tidyTypes :: TidyEnv -> [Type] -> [Type]-tidyTypes env tys = map (tidyType env) tys+tidyTypes env tys = strictMap (tidyType env) tys  ---------------+++-- | Tidy a Type+--+-- See Note [Strictness in tidyType and friends] tidyType :: TidyEnv -> Type -> Type tidyType _   (LitTy n)             = LitTy n-tidyType env (TyVarTy tv)          = TyVarTy (tidyTyCoVarOcc env tv)-tidyType env (TyConApp tycon tys)  = let args = tidyTypes env tys-                                     in args `seqList` TyConApp tycon args+tidyType env (TyVarTy tv)          = TyVarTy $! tidyTyCoVarOcc env tv+tidyType env (TyConApp tycon tys)  = TyConApp tycon $! tidyTypes env tys tidyType env (AppTy fun arg)       = (AppTy $! (tidyType env fun)) $! (tidyType env arg) tidyType env ty@(FunTy _ w arg res)  = let { !w'   = tidyType env w                                            ; !arg' = tidyType env arg                                            ; !res' = tidyType env res }                                        in ty { ft_mult = w', ft_arg = arg', ft_res = res' }-tidyType env (ty@(ForAllTy{}))     = mkForAllTys' (zip tvs' vis) $! tidyType env' body_ty+tidyType env (ty@(ForAllTy{}))     = (mkForAllTys' $! (zip tvs' vis)) $! tidyType env' body_ty   where-    (tvs, vis, body_ty) = splitForAllTys' ty+    (tvs, vis, body_ty) = splitForAllTyCoVars' ty     (env', tvs') = tidyVarBndrs env tvs tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co) tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)  --- The following two functions differ from mkForAllTys and splitForAllTys in that+-- The following two functions differ from mkForAllTys and splitForAllTyCoVars in that -- they expect/preserve the ArgFlag argument. These belong to "GHC.Core.Type", but -- how should they be named? mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type@@ -153,8 +172,8 @@   where     strictMkForAllTy (tv,vis) ty = (ForAllTy $! ((Bndr $! tv) $! vis)) $! ty -splitForAllTys' :: Type -> ([TyCoVar], [ArgFlag], Type)-splitForAllTys' ty = go ty [] []+splitForAllTyCoVars' :: Type -> ([TyCoVar], [ArgFlag], Type)+splitForAllTyCoVars' ty = go ty [] []   where     go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)     go ty                          tvs viss = (reverse tvs, reverse viss, ty)@@ -192,17 +211,20 @@ tidyKind = tidyType  ----------------++-- | Tidy a Coercion+--+-- See Note [Strictness in tidyType and friends] tidyCo :: TidyEnv -> Coercion -> Coercion tidyCo env@(_, subst) co   = go co   where     go_mco MRefl    = MRefl-    go_mco (MCo co) = MCo (go co)+    go_mco (MCo co) = MCo $! go co -    go (Refl ty)             = Refl (tidyType env ty)-    go (GRefl r ty mco)      = GRefl r (tidyType env ty) $! go_mco mco-    go (TyConAppCo r tc cos) = let args = map go cos-                               in args `seqList` TyConAppCo r tc args+    go (Refl ty)             = Refl $! tidyType env ty+    go (GRefl r ty mco)      = (GRefl r $! tidyType env ty) $! go_mco mco+    go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2     go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)                                where (envp, tvp) = tidyVarBndr env tv@@ -213,8 +235,7 @@                                  Nothing  -> CoVarCo cv                                  Just cv' -> CoVarCo cv'     go (HoleCo h)            = HoleCo h-    go (AxiomInstCo con ind cos) = let args = map go cos-                               in  args `seqList` AxiomInstCo con ind args+    go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos     go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!                                 tidyType env t1) $! tidyType env t2     go (SymCo co)            = SymCo $! go co@@ -224,13 +245,12 @@     go (InstCo co ty)        = (InstCo $! go co) $! go ty     go (KindCo co)           = KindCo $! go co     go (SubCo co)            = SubCo $! go co-    go (AxiomRuleCo ax cos)  = let cos1 = tidyCos env cos-                               in cos1 `seqList` AxiomRuleCo ax cos1+    go (AxiomRuleCo ax cos)  = AxiomRuleCo ax $ strictMap go cos -    go_prov (PhantomProv co)    = PhantomProv (go co)-    go_prov (ProofIrrelProv co) = ProofIrrelProv (go co)+    go_prov (PhantomProv co)    = PhantomProv $! go co+    go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co     go_prov p@(PluginProv _)    = p     go_prov p@CorePrepProv      = p  tidyCos :: TidyEnv -> [Coercion] -> [Coercion]-tidyCos env = map (tidyCo env)+tidyCos env = strictMap (tidyCo env)

GHC/Core/TyCon.hs view

@@ -1,3 +1,7 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase        #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,9 +10,6 @@ The @TyCon@ datatype -} -{-# LANGUAGE CPP, FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Core.TyCon(         -- * Main TyCon data types         TyCon,@@ -55,10 +56,9 @@         mustBeSaturated,         isPromotedDataCon, isPromotedDataCon_maybe,         isKindTyCon, isLiftedTypeKindTyConName,-        isTauTyCon, isFamFreeTyCon,+        isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon, -        isDataTyCon, isProductTyCon, isDataProductTyCon_maybe,-        isDataSumTyCon_maybe,+        isDataTyCon,         isEnumerationTyCon,         isNewTyCon, isAbstractTyCon,         isFamilyTyCon, isOpenFamilyTyCon,@@ -83,10 +83,12 @@         tyConCType, tyConCType_maybe,         tyConDataCons, tyConDataCons_maybe,         tyConSingleDataCon_maybe, tyConSingleDataCon,+        tyConAlgDataCons_maybe,         tyConSingleAlgDataCon_maybe,         tyConFamilySize,         tyConStupidTheta,         tyConArity,+        tyConNullaryTy,         tyConRoles,         tyConFlavour,         tyConTuple_maybe, tyConClass_maybe, tyConATs,@@ -126,10 +128,6 @@         primRepsCompatible,         primRepCompatible, -        -- * Recursion breaking-        RecTcChecker, initRecTc, defaultRecTcMaxBound,-        setRecTcMaxBound, checkRecTc- ) where  #include "HsVersions.h"@@ -138,17 +136,20 @@ import GHC.Platform  import {-# SOURCE #-} GHC.Core.TyCo.Rep-   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany )+   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkTyConTy_ ) import {-# SOURCE #-} GHC.Core.TyCo.Ppr    ( pprType ) import {-# SOURCE #-} GHC.Builtin.Types-   ( runtimeRepTyCon, constraintKind+   ( runtimeRepTyCon, constraintKind, levityTyCon    , multiplicityTyCon    , vecCountTyCon, vecElemTyCon, liftedTypeKind ) import {-# SOURCE #-} GHC.Core.DataCon-   ( DataCon, dataConExTyCoVars, dataConFieldLabels+   ( DataCon, dataConFieldLabels    , dataConTyCon, dataConFullSig-   , isUnboxedSumCon )+   , isUnboxedSumDataCon )+import GHC.Builtin.Uniques+  ( tyConRepNameUnique+  , dataConTyRepNameUnique )  import GHC.Utils.Binary import GHC.Types.Var@@ -162,11 +163,11 @@ import GHC.Builtin.Names import GHC.Data.Maybe import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants import GHC.Utils.Misc-import GHC.Types.Unique( tyConRepNameUnique, dataConTyRepNameUnique ) import GHC.Types.Unique.Set import GHC.Unit.Module @@ -224,8 +225,8 @@  * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon -* The user does not see any "equivalent types" as he did with type-  synonym families.  He just sees constructors with types+* The user does not see any "equivalent types" as they did with type+  synonym families.  They just see constructors with types         T1 :: T Int         T2 :: Bool -> T Int @@ -417,6 +418,20 @@  * [Verifying injectivity annotation] in GHC.Core.FamInstEnv  * [Type inference for type families with injectivity] in GHC.Tc.Solver.Interact +Note [Sharing nullary TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Nullary type constructor applications are extremely common. For this reason+each TyCon carries with it a @TyConApp tycon []@. This ensures that+'mkTyConTy' does not need to allocate and eliminates quite a bit of heap+residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp',+ensuring that this function also benefits from sharing.++This optimisation improves allocations in the Cabal test by around 0.3% and+decreased cache misses measurably.++See #19367.++ ************************************************************************ *                                                                      *                     TyConBinder, TyConTyCoBinder@@ -424,11 +439,10 @@ ************************************************************************ -} -type TyConBinder = VarBndr TyVar TyConBndrVis---- In the whole definition of @data TyCon@, only @PromotedDataCon@ will really--- contain CoVar.+type TyConBinder     = VarBndr TyVar   TyConBndrVis type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis+     -- Only PromotedDataCon has TyConTyCoBinders+     -- See Note [Promoted GADT data construtors]  data TyConBndrVis   = NamedTCB ArgFlag@@ -719,6 +733,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,          tcRepName :: TyConRepName     }@@ -749,6 +764,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@                -- The tyConTyVars scope over:               --@@ -806,6 +822,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@              -- tyConTyVars scope over: synTcRhs          tcRoles      :: [Role],  -- ^ The role for each type variable@@ -818,10 +835,15 @@         synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not                                  --          have any foralls, after expanding any                                  --          nested synonyms-        synIsFamFree  :: Bool    -- True <=> the RHS of this synonym does not mention+        synIsFamFree  :: Bool,   -- True <=> the RHS of this synonym does not mention                                  --          any type synonym families (data families                                  --          are fine), again after expanding any                                  --          nested synonyms+        synIsForgetful :: Bool   -- True <=  at least one argument is not mentioned+                                 --          in the RHS (or is mentioned only under+                                 --          forgetful synonyms)+                                 -- Test is conservative, so True does not guarantee+                                 -- forgetfulness.     }    -- | Represents families (both type and data)@@ -839,6 +861,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@             -- tyConTyVars connect an associated family TyCon             -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst @@ -875,6 +898,7 @@         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@          tcRoles       :: [Role], -- ^ The role for each type variable                                  -- This list has length = tyConArity@@ -896,9 +920,11 @@          -- See Note [The binders/kind/arity fields of a TyCon]         tyConBinders :: [TyConTyCoBinder], -- ^ Full binders+           -- TyConTyCoBinder: see Note [Promoted GADT data construtors]         tyConResKind :: Kind,             -- ^ Result kind         tyConKind    :: Kind,             -- ^ Kind of this TyCon         tyConArity   :: Arity,            -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@          tcRoles       :: [Role],    -- ^ Roles: N for kind vars, R for type vars         dataCon       :: DataCon,   -- ^ Corresponding data constructor@@ -918,6 +944,7 @@         tyConResKind :: Kind,          -- ^ Result kind         tyConKind    :: Kind,          -- ^ Kind of this TyCon         tyConArity   :: Arity,         -- ^ Arity+        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@            -- NB: the TyConArity of a TcTyCon must match           -- the number of Required (positional, user-specified)@@ -934,7 +961,6 @@                            -- ^ What sort of 'TyCon' this represents.       } {- Note [Scoped tyvars in a TcTyCon]- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The tcTyConScopedTyVars field records the lexicial-binding connection between the original, user-specified Name (i.e. thing in scope) and@@ -949,6 +975,17 @@    * tyConArity = length required_tvs  See also Note [How TcTyCons work] in GHC.Tc.TyCl++Note [Promoted GADT data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Any promoted GADT data constructor will have a type with equality+constraints in its type; e.g.+    K :: forall a b. (a ~# [b]) => a -> b -> T a++So, when promoted to become a type constructor, the tyConBinders+will include CoVars.  That is why we use [TyConTyCoBinder] for the+tyconBinders field.  TyConTyCoBinder is a synonym for TyConBinder,+but with the clue that the binder can be a CoVar not just a TyVar. -}  -- | Represents right-hand-sides of 'TyCon's for algebraic types@@ -1058,6 +1095,8 @@       -- be the list of arguments to the promoted datacon.   | VecCount Int         -- ^ A constructor of @VecCount@   | VecElem PrimElemRep  -- ^ A constructor of @VecElem@+  | LiftedInfo           -- ^ A constructor of @Levity@+  | UnliftedInfo         -- ^ A constructor of @Levity@  -- | Extract those 'DataCon's that we are able to learn about.  Note -- that visibility in this sense does not correspond to visibility in@@ -1320,7 +1359,7 @@ tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })   = Just rep_nm tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })-  | isUnboxedSumCon dc   -- see #13276+  | isUnboxedSumDataCon dc   -- see #13276   = Nothing   | otherwise   = Just rep_nm@@ -1430,18 +1469,18 @@   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value   | Int32Rep      -- ^ Signed, 32-bit value-  | Int64Rep      -- ^ Signed, 64 bit value (with 32-bit words only)+  | Int64Rep      -- ^ Signed, 64 bit value   | IntRep        -- ^ Signed, word-sized value   | Word8Rep      -- ^ Unsigned, 8 bit value   | Word16Rep     -- ^ Unsigned, 16 bit value   | Word32Rep     -- ^ Unsigned, 32 bit value-  | Word64Rep     -- ^ Unsigned, 64 bit value (with 32-bit words only)+  | Word64Rep     -- ^ Unsigned, 64 bit value   | WordRep       -- ^ Unsigned, word-sized value   | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use '(Un)liftedRep')   | FloatRep   | DoubleRep   | VecRep Int PrimElemRep  -- ^ A vector-  deriving( Show )+  deriving( Eq, Show )  data PrimElemRep   = Int8ElemRep@@ -1502,11 +1541,11 @@    Int8Rep          -> 1    Int16Rep         -> 2    Int32Rep         -> 4-   Int64Rep         -> wORD64_SIZE+   Int64Rep         -> 8    Word8Rep         -> 1    Word16Rep        -> 2    Word32Rep        -> 4-   Word64Rep        -> wORD64_SIZE+   Word64Rep        -> 8    FloatRep         -> fLOAT_SIZE    DoubleRep        -> dOUBLE_SIZE    AddrRep          -> platformWordSizeInBytes platform@@ -1587,20 +1626,20 @@ -- this functionality mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon mkFunTyCon name binders rep_nm-  = FunTyCon {-        tyConUnique  = nameUnique name,-        tyConName    = name,-        tyConBinders = binders,-        tyConResKind = liftedTypeKind,-        tyConKind    = mkTyConKind binders liftedTypeKind,-        tyConArity   = length binders,-        tcRepName    = rep_nm-    }+  = let tc =+          FunTyCon {+              tyConUnique  = nameUnique name,+              tyConName    = name,+              tyConBinders = binders,+              tyConResKind = liftedTypeKind,+              tyConKind    = mkTyConKind binders liftedTypeKind,+              tyConArity   = length binders,+              tyConNullaryTy = mkTyConTy_ tc,+              tcRepName    = rep_nm+          }+    in tc --- | This is the making of an algebraic 'TyCon'. Notably, you have to--- pass in the generic (in the -XGenerics sense) information about the--- type constructor - you can get hold of it easily (see Generics--- module)+-- | This is the making of an algebraic 'TyCon'. mkAlgTyCon :: Name            -> [TyConBinder]  -- ^ Binders of the 'TyCon'            -> Kind              -- ^ Result kind@@ -1614,22 +1653,25 @@            -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?            -> TyCon mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn-  = AlgTyCon {-        tyConName        = name,-        tyConUnique      = nameUnique name,-        tyConBinders     = binders,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = length binders,-        tyConTyVars      = binderVars binders,-        tcRoles          = roles,-        tyConCType       = cType,-        algTcStupidTheta = stupid,-        algTcRhs         = rhs,-        algTcFields      = fieldsOfAlgTcRhs rhs,-        algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,-        algTcGadtSyntax  = gadt_syn-    }+  = let tc =+          AlgTyCon {+              tyConName        = name,+              tyConUnique      = nameUnique name,+              tyConBinders     = binders,+              tyConResKind     = res_kind,+              tyConKind        = mkTyConKind binders res_kind,+              tyConArity       = length binders,+              tyConNullaryTy   = mkTyConTy_ tc,+              tyConTyVars      = binderVars binders,+              tcRoles          = roles,+              tyConCType       = cType,+              algTcStupidTheta = stupid,+              algTcRhs         = rhs,+              algTcFields      = fieldsOfAlgTcRhs rhs,+              algTcParent      = ASSERT2( okParent name parent, ppr name $$ ppr parent ) parent,+              algTcGadtSyntax  = gadt_syn+          }+    in tc  -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> [TyConBinder]@@ -1649,23 +1691,26 @@              -> AlgTyConFlav              -> TyCon mkTupleTyCon name binders res_kind arity con sort parent-  = AlgTyCon {-        tyConUnique      = nameUnique name,-        tyConName        = name,-        tyConBinders     = binders,-        tyConTyVars      = binderVars binders,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = arity,-        tcRoles          = replicate arity Representational,-        tyConCType       = Nothing,-        algTcGadtSyntax  = False,-        algTcStupidTheta = [],-        algTcRhs         = TupleTyCon { data_con = con,-                                        tup_sort = sort },-        algTcFields      = emptyDFsEnv,-        algTcParent      = parent-    }+  = let tc =+          AlgTyCon {+              tyConUnique      = nameUnique name,+              tyConName        = name,+              tyConBinders     = binders,+              tyConTyVars      = binderVars binders,+              tyConResKind     = res_kind,+              tyConKind        = mkTyConKind binders res_kind,+              tyConArity       = arity,+              tyConNullaryTy   = mkTyConTy_ tc,+              tcRoles          = replicate arity Representational,+              tyConCType       = Nothing,+              algTcGadtSyntax  = False,+              algTcStupidTheta = [],+              algTcRhs         = TupleTyCon { data_con = con,+                                              tup_sort = sort },+              algTcFields      = emptyDFsEnv,+              algTcParent      = parent+          }+    in tc  mkSumTyCon :: Name              -> [TyConBinder]@@ -1676,22 +1721,25 @@              -> AlgTyConFlav              -> TyCon mkSumTyCon name binders res_kind arity tyvars cons parent-  = AlgTyCon {-        tyConUnique      = nameUnique name,-        tyConName        = name,-        tyConBinders     = binders,-        tyConTyVars      = tyvars,-        tyConResKind     = res_kind,-        tyConKind        = mkTyConKind binders res_kind,-        tyConArity       = arity,-        tcRoles          = replicate arity Representational,-        tyConCType       = Nothing,-        algTcGadtSyntax  = False,-        algTcStupidTheta = [],-        algTcRhs         = mkSumTyConRhs cons,-        algTcFields      = emptyDFsEnv,-        algTcParent      = parent-    }+  = let tc =+          AlgTyCon {+              tyConUnique      = nameUnique name,+              tyConName        = name,+              tyConBinders     = binders,+              tyConTyVars      = tyvars,+              tyConResKind     = res_kind,+              tyConKind        = mkTyConKind binders res_kind,+              tyConArity       = arity,+              tyConNullaryTy   = mkTyConTy_ tc,+              tcRoles          = replicate arity Representational,+              tyConCType       = Nothing,+              algTcGadtSyntax  = False,+              algTcStupidTheta = [],+              algTcRhs         = mkSumTyConRhs cons,+              algTcFields      = emptyDFsEnv,+              algTcParent      = parent+          }+    in tc  -- | Makes a tycon suitable for use during type-checking. It stores -- a variety of details about the definition of the TyCon, but no@@ -1709,16 +1757,19 @@           -> TyConFlavour        -- ^ What sort of 'TyCon' this represents           -> TyCon mkTcTyCon name binders res_kind scoped_tvs poly flav-  = TcTyCon { tyConUnique  = getUnique name-            , tyConName    = name-            , tyConTyVars  = binderVars binders-            , tyConBinders = binders-            , tyConResKind = res_kind-            , tyConKind    = mkTyConKind binders res_kind-            , tyConArity   = length binders-            , tcTyConScopedTyVars = scoped_tvs-            , tcTyConIsPoly       = poly-            , tcTyConFlavour      = flav }+  = let tc =+          TcTyCon { tyConUnique  = getUnique name+                  , tyConName    = name+                  , tyConTyVars  = binderVars binders+                  , tyConBinders = binders+                  , tyConResKind = res_kind+                  , tyConKind    = mkTyConKind binders res_kind+                  , tyConArity   = length binders+                  , tyConNullaryTy = mkTyConTy_ tc+                  , tcTyConScopedTyVars = scoped_tvs+                  , tcTyConIsPoly       = poly+                  , tcTyConFlavour      = flav }+    in tc  -- | No scoped type variables (to be used with mkTcTyCon). noTcTyConScopedTyVars :: [(Name, TcTyVar)]@@ -1755,54 +1806,64 @@              -> [Role]              -> Bool -> Maybe TyConRepName -> TyCon mkPrimTyCon' name binders res_kind roles is_unlifted rep_nm-  = PrimTyCon {-        tyConName    = name,-        tyConUnique  = nameUnique name,-        tyConBinders = binders,-        tyConResKind = res_kind,-        tyConKind    = mkTyConKind binders res_kind,-        tyConArity   = length roles,-        tcRoles      = roles,-        isUnlifted   = is_unlifted,-        primRepName  = rep_nm-    }+  = let tc =+          PrimTyCon {+              tyConName    = name,+              tyConUnique  = nameUnique name,+              tyConBinders = binders,+              tyConResKind = res_kind,+              tyConKind    = mkTyConKind binders res_kind,+              tyConArity   = length roles,+              tyConNullaryTy = mkTyConTy_ tc,+              tcRoles      = roles,+              isUnlifted   = is_unlifted,+              primRepName  = rep_nm+          }+    in tc  -- | Create a type synonym 'TyCon' mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind-               -> [Role] -> Type -> Bool -> Bool -> TyCon-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free-  = SynonymTyCon {-        tyConName    = name,-        tyConUnique  = nameUnique name,-        tyConBinders = binders,-        tyConResKind = res_kind,-        tyConKind    = mkTyConKind binders res_kind,-        tyConArity   = length binders,-        tyConTyVars  = binderVars binders,-        tcRoles      = roles,-        synTcRhs     = rhs,-        synIsTau     = is_tau,-        synIsFamFree = is_fam_free-    }+               -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful+  = let tc =+          SynonymTyCon {+              tyConName      = name,+              tyConUnique    = nameUnique name,+              tyConBinders   = binders,+              tyConResKind   = res_kind,+              tyConKind      = mkTyConKind binders res_kind,+              tyConArity     = length binders,+              tyConNullaryTy = mkTyConTy_ tc,+              tyConTyVars    = binderVars binders,+              tcRoles        = roles,+              synTcRhs       = rhs,+              synIsTau       = is_tau,+              synIsFamFree   = is_fam_free,+              synIsForgetful = is_forgetful+          }+    in tc  -- | Create a type family 'TyCon' mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind               -> Maybe Name -> FamTyConFlav               -> Maybe Class -> Injectivity -> TyCon mkFamilyTyCon name binders res_kind resVar flav parent inj-  = FamilyTyCon-      { tyConUnique  = nameUnique name-      , tyConName    = name-      , tyConBinders = binders-      , tyConResKind = res_kind-      , tyConKind    = mkTyConKind binders res_kind-      , tyConArity   = length binders-      , tyConTyVars  = binderVars binders-      , famTcResVar  = resVar-      , famTcFlav    = flav-      , famTcParent  = classTyCon <$> parent-      , famTcInj     = inj-      }+  = let tc =+          FamilyTyCon+            { tyConUnique  = nameUnique name+            , tyConName    = name+            , tyConBinders = binders+            , tyConResKind = res_kind+            , tyConKind    = mkTyConKind binders res_kind+            , tyConArity   = length binders+            , tyConNullaryTy = mkTyConTy_ tc+            , tyConTyVars  = binderVars binders+            , famTcResVar  = resVar+            , famTcFlav    = flav+            , famTcParent  = classTyCon <$> parent+            , famTcInj     = inj+            }+    in tc   -- | Create a promoted data constructor 'TyCon'@@ -1813,18 +1874,21 @@                   -> [TyConTyCoBinder] -> Kind -> [Role]                   -> RuntimeRepInfo -> TyCon mkPromotedDataCon con name rep_name binders res_kind roles rep_info-  = PromotedDataCon {-        tyConUnique   = nameUnique name,-        tyConName     = name,-        tyConArity    = length roles,-        tcRoles       = roles,-        tyConBinders  = binders,-        tyConResKind  = res_kind,-        tyConKind     = mkTyConKind binders res_kind,-        dataCon       = con,-        tcRepName     = rep_name,-        promDcRepInfo = rep_info-  }+  = let tc =+          PromotedDataCon {+            tyConUnique   = nameUnique name,+            tyConName     = name,+            tyConArity    = length roles,+            tyConNullaryTy = mkTyConTy_ tc,+            tcRoles       = roles,+            tyConBinders  = binders,+            tyConResKind  = res_kind,+            tyConKind     = mkTyConKind binders res_kind,+            dataCon       = con,+            tcRepName     = rep_name,+            promDcRepInfo = rep_info+          }+    in tc  isFunTyCon :: TyCon -> Bool isFunTyCon (FunTyCon {}) = True@@ -1960,72 +2024,6 @@                            = Just (tvs, rhs, co) unwrapNewTyConEtad_maybe _ = Nothing -isProductTyCon :: TyCon -> Bool--- True of datatypes or newtypes that have---   one, non-existential, data constructor--- See Note [Product types]-isProductTyCon tc@(AlgTyCon {})-  = case algTcRhs tc of-      TupleTyCon {} -> True-      DataTyCon{ data_cons = [data_con] }-                    -> null (dataConExTyCoVars data_con)-      NewTyCon {}   -> True-      _             -> False-isProductTyCon _ = False--isDataProductTyCon_maybe :: TyCon -> Maybe DataCon--- True of datatypes (not newtypes) with---   one, vanilla, data constructor--- See Note [Product types]-isDataProductTyCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-       DataTyCon { data_cons = [con] }-         | null (dataConExTyCoVars con)  -- non-existential-         -> Just con-       TupleTyCon { data_con = con }-         -> Just con-       _ -> Nothing-isDataProductTyCon_maybe _ = Nothing--isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]-isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = cons }-        | cons `lengthExceeds` 1-        , all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?-        -> Just cons-      SumTyCon { data_cons = cons }-        | all (null . dataConExTyCoVars) cons -- FIXME(osa): Why do we need this?-        -> Just cons-      _ -> Nothing-isDataSumTyCon_maybe _ = Nothing--{- Note [Product types]-~~~~~~~~~~~~~~~~~~~~~~~-A product type is- * A data type (not a newtype)- * With one, boxed data constructor- * That binds no existential type variables--The main point is that product types are amenable to unboxing for-  * Strict function calls; we can transform-        f (D a b) = e-    to-        fw a b = e-    via the worker/wrapper transformation.  (Question: couldn't this-    work for existentials too?)--  * CPR for function results; we can transform-        f x y = let ... in D a b-    to-        fw x y = let ... in (# a, b #)--Note that the data constructor /can/ have evidence arguments: equality-constraints, type classes etc.  So it can be GADT.  These evidence-arguments are simply value arguments, and should not get in the way.--}-- -- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)? {-# INLINE isTypeSynonymTyCon #-}  -- See Note [Inlining coreView] in GHC.Core.Type isTypeSynonymTyCon :: TyCon -> Bool@@ -2036,11 +2034,22 @@ isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau isTauTyCon _                                    = True +-- | Is this tycon neither a type family nor a synonym that expands+-- to a type family? isFamFreeTyCon :: TyCon -> Bool isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav isFamFreeTyCon _                                          = True +-- | Is this a forgetful type synonym? If this is a type synonym whose+-- RHS does not mention one (or more) of its bound variables, returns+-- True. Thus, False means that all bound variables appear on the RHS;+-- True may not mean anything, as the test to set this flag is+-- conservative.+isForgetfulSynTyCon :: TyCon -> Bool+isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget+isForgetfulSynTyCon _                                          = False+ -- As for newtypes, it is in some contexts important to distinguish between -- closed synonyms and synonym families, as synonym families have no unique -- right hand side to which a synonym family application can expand.@@ -2108,7 +2117,7 @@   (FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb}) = mb isClosedSynFamilyTyConWithAxiom_maybe _               = Nothing --- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ is @tc@ is an+-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an -- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is -- injective), or 'NotInjective' otherwise. tyConInjectivityInfo :: TyCon -> Injectivity@@ -2208,8 +2217,8 @@ -- -XDataKinds. kindTyConKeys :: UniqSet Unique kindTyConKeys = unionManyUniqSets-  ( mkUniqSet [ liftedTypeKindTyConKey, constraintKindTyConKey, tYPETyConKey ]-  : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon+  ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ]+  : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon                                           , multiplicityTyCon                                           , vecCountTyCon, vecElemTyCon ] )   where@@ -2259,7 +2268,11 @@ -- The new kind is always a zonked version of its previous -- kind, so we don't need to update any other fields. -- See Note [The Purely Kinded Invariant] in GHC.Tc.Gen.HsType-setTcTyConKind tc@(TcTyCon {}) kind = tc { tyConKind = kind }+setTcTyConKind tc@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind+                                                   , tyConNullaryTy = mkTyConTy_ tc'+                                                       -- see Note [Sharing nullary TyCons]+                                                   }+                                      in tc' setTcTyConKind tc              _    = pprPanic "setTcTyConKind" (ppr tc)  -- | Could this TyCon ever be levity-polymorphic when fully applied?@@ -2296,16 +2309,19 @@                                   -- type of the synonym (not yet substituted)                                   -- and any arguments remaining from the                                   -- application---- ^ Expand a type synonym application, if any+-- ^ Expand a type synonym application+-- Return Nothing if the TyCon is not a synonym,+-- or if not enough arguments are supplied expandSynTyCon_maybe tc tys   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc-  = case tys `listLengthCmp` arity of-        GT -> Just (tvs `zip` tys, rhs, drop arity tys)-        EQ -> Just (tvs `zip` tys, rhs, [])-        LT -> Nothing-  | otherwise-  = Nothing+  = if arity == 0+    then Just ([], rhs, tys)  -- Avoid a bit of work in the case of nullary synonyms+    else case tys `listLengthCmp` arity of+              GT -> Just (tvs `zip` tys, rhs, drop arity tys)+              EQ -> Just (tvs `zip` tys, rhs, [])+              LT -> Nothing+   | otherwise+   = Nothing  ---------------- @@ -2353,8 +2369,7 @@ -- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@ -- type with one alternative, a tuple type or a @newtype@ then that constructor -- is returned. If the 'TyCon' has more than one constructor, or represents a--- primitive or function type constructor then @Nothing@ is returned. In any--- other case, the function panics+-- primitive or function type constructor then @Nothing@ is returned. tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon tyConSingleDataCon_maybe (AlgTyCon { algTcRhs = rhs })   = case rhs of@@ -2364,22 +2379,30 @@       _                             -> Nothing tyConSingleDataCon_maybe _           = Nothing +-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'. tyConSingleDataCon :: TyCon -> DataCon tyConSingleDataCon tc   = case tyConSingleDataCon_maybe tc of       Just c  -> c       Nothing -> pprPanic "tyConDataCon" (ppr tc) +-- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes. tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon--- Returns (Just con) for single-constructor--- *algebraic* data types *not* newtypes-tyConSingleAlgDataCon_maybe (AlgTyCon { algTcRhs = rhs })-  = case rhs of-      DataTyCon { data_cons = [c] } -> Just c-      TupleTyCon { data_con = c }   -> Just c-      _                             -> Nothing-tyConSingleAlgDataCon_maybe _        = Nothing+tyConSingleAlgDataCon_maybe tycon+  | isNewTyCon tycon = Nothing+  | otherwise        = tyConSingleDataCon_maybe tycon +-- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type+-- or a sum type with data constructors dcs. If the 'TyCon' has more than one+-- constructor, or represents a primitive or function type constructor then+-- @Nothing@ is returned.+--+-- Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes.+tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon]+tyConAlgDataCons_maybe tycon+  | isNewTyCon tycon = Nothing+  | otherwise        = tyConDataCons_maybe tycon+ -- | Determine the number of value constructors a 'TyCon' has. Panics if the -- 'TyCon' is not algebraic or a tuple tyConFamilySize  :: TyCon -> Int@@ -2696,83 +2719,6 @@                     0 -> return NotInjective                     _ -> do { xs <- get bh                             ; return (Injective xs) } }--{--************************************************************************-*                                                                      *-           Walking over recursive TyCons-*                                                                      *-************************************************************************--Note [Expanding newtypes and products]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When expanding a type to expose a data-type constructor, we need to be-careful about newtypes, lest we fall into an infinite loop. Here are-the key examples:--  newtype Id  x = MkId x-  newtype Fix f = MkFix (f (Fix f))-  newtype T     = MkT (T -> T)--  Type           Expansion- ---------------------------  T              T -> T-  Fix Maybe      Maybe (Fix Maybe)-  Id (Id Int)    Int-  Fix Id         NO NO NO--Notice that- * We can expand T, even though it's recursive.- * We can expand Id (Id Int), even though the Id shows up-   twice at the outer level, because Id is non-recursive--So, when expanding, we keep track of when we've seen a recursive-newtype at outermost level; and bail out if we see it again.--We sometimes want to do the same for product types, so that the-strictness analyser doesn't unbox infinitely deeply.--More precisely, we keep a *count* of how many times we've seen it.-This is to account for-   data instance T (a,b) = MkT (T a) (T b)-Then (#10482) if we have a type like-        T (Int,(Int,(Int,(Int,Int))))-we can still unbox deeply enough during strictness analysis.-We have to treat T as potentially recursive, but it's still-good to be able to unwrap multiple layers.--The function that manages all this is checkRecTc.--}--data RecTcChecker = RC !Int (NameEnv Int)-  -- The upper bound, and the number of times-  -- we have encountered each TyCon---- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.-initRecTc :: RecTcChecker-initRecTc = RC defaultRecTcMaxBound emptyNameEnv---- | The default upper bound (100) for the number of times a 'RecTcChecker' is--- allowed to encounter each 'TyCon'.-defaultRecTcMaxBound :: Int-defaultRecTcMaxBound = 100--- Should we have a flag for this?---- | Change the upper bound for the number of times a 'RecTcChecker' is allowed--- to encounter each 'TyCon'.-setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker-setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts--checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker--- Nothing      => Recursion detected--- Just rec_tcs => Keep going-checkRecTc (RC bound rec_nts) tc-  = case lookupNameEnv rec_nts tc_name of-      Just n | n >= bound -> Nothing-             | otherwise  -> Just (RC bound (extendNameEnv rec_nts tc_name (n+1)))-      Nothing             -> Just (RC bound (extendNameEnv rec_nts tc_name 1))-  where-    tc_name = tyConName tc  -- | Returns whether or not this 'TyCon' is definite, or a hole -- that may be filled in at some later point.  See Note [Skolem abstract data]

GHC/Core/TyCon.hs-boot view

@@ -2,11 +2,20 @@  import GHC.Prelude import GHC.Types.Unique ( Uniquable )+import {-# SOURCE #-} GHC.Types.Name+import GHC.Utils.Outputable  data TyCon  instance Uniquable TyCon+instance Outputable TyCon +type TyConRepName = Name+ isTupleTyCon        :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool isFunTyCon          :: TyCon -> Bool++tyConRepName_maybe  :: TyCon -> Maybe TyConRepName+mkPrelTyConRepName  :: Name -> TyConRepName+tyConName :: TyCon -> Name

+ GHC/Core/TyCon/Env.hs view

@@ -0,0 +1,147 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TyConEnv]{@TyConEnv@: tyCon environments}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module GHC.Core.TyCon.Env (+        -- * TyCon environment (map)+        TyConEnv,++        -- ** Manipulating these environments+        mkTyConEnv, mkTyConEnvWith,+        emptyTyConEnv, isEmptyTyConEnv,+        unitTyConEnv, nameEnvElts,+        extendTyConEnv_C, extendTyConEnv_Acc, extendTyConEnv,+        extendTyConEnvList, extendTyConEnvList_C,+        filterTyConEnv, anyTyConEnv,+        plusTyConEnv, plusTyConEnv_C, plusTyConEnv_CD, plusTyConEnv_CD2, alterTyConEnv,+        lookupTyConEnv, lookupTyConEnv_NF, delFromTyConEnv, delListFromTyConEnv,+        elemTyConEnv, mapTyConEnv, disjointTyConEnv,++        DTyConEnv,++        emptyDTyConEnv, isEmptyDTyConEnv,+        lookupDTyConEnv,+        delFromDTyConEnv, filterDTyConEnv,+        mapDTyConEnv, mapMaybeDTyConEnv,+        adjustDTyConEnv, alterDTyConEnv, extendDTyConEnv, foldDTyConEnv+    ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Core.TyCon (TyCon)++import GHC.Data.Maybe++{-+************************************************************************+*                                                                      *+\subsection{TyCon environment}+*                                                                      *+************************************************************************+-}++-- | TyCon Environment+type TyConEnv a = UniqFM TyCon a       -- Domain is TyCon++emptyTyConEnv       :: TyConEnv a+isEmptyTyConEnv     :: TyConEnv a -> Bool+mkTyConEnv          :: [(TyCon,a)] -> TyConEnv a+mkTyConEnvWith      :: (a -> TyCon) -> [a] -> TyConEnv a+nameEnvElts        :: TyConEnv a -> [a]+alterTyConEnv       :: (Maybe a-> Maybe a) -> TyConEnv a -> TyCon -> TyConEnv a+extendTyConEnv_C    :: (a->a->a) -> TyConEnv a -> TyCon -> a -> TyConEnv a+extendTyConEnv_Acc  :: (a->b->b) -> (a->b) -> TyConEnv b -> TyCon -> a -> TyConEnv b+extendTyConEnv      :: TyConEnv a -> TyCon -> a -> TyConEnv a+plusTyConEnv        :: TyConEnv a -> TyConEnv a -> TyConEnv a+plusTyConEnv_C      :: (a->a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a+plusTyConEnv_CD     :: (a->a->a) -> TyConEnv a -> a -> TyConEnv a -> a -> TyConEnv a+plusTyConEnv_CD2    :: (Maybe a->Maybe a->a) -> TyConEnv a -> TyConEnv a -> TyConEnv a+extendTyConEnvList  :: TyConEnv a -> [(TyCon,a)] -> TyConEnv a+extendTyConEnvList_C :: (a->a->a) -> TyConEnv a -> [(TyCon,a)] -> TyConEnv a+delFromTyConEnv     :: TyConEnv a -> TyCon -> TyConEnv a+delListFromTyConEnv :: TyConEnv a -> [TyCon] -> TyConEnv a+elemTyConEnv        :: TyCon -> TyConEnv a -> Bool+unitTyConEnv        :: TyCon -> a -> TyConEnv a+lookupTyConEnv      :: TyConEnv a -> TyCon -> Maybe a+lookupTyConEnv_NF   :: TyConEnv a -> TyCon -> a+filterTyConEnv      :: (elt -> Bool) -> TyConEnv elt -> TyConEnv elt+anyTyConEnv         :: (elt -> Bool) -> TyConEnv elt -> Bool+mapTyConEnv         :: (elt1 -> elt2) -> TyConEnv elt1 -> TyConEnv elt2+disjointTyConEnv    :: TyConEnv a -> TyConEnv a -> Bool++nameEnvElts x         = eltsUFM x+emptyTyConEnv          = emptyUFM+isEmptyTyConEnv        = isNullUFM+unitTyConEnv x y       = unitUFM x y+extendTyConEnv x y z   = addToUFM x y z+extendTyConEnvList x l = addListToUFM x l+lookupTyConEnv x y     = lookupUFM x y+alterTyConEnv          = alterUFM+mkTyConEnv     l       = listToUFM l+mkTyConEnvWith f       = mkTyConEnv . map (\a -> (f a, a))+elemTyConEnv x y          = elemUFM x y+plusTyConEnv x y          = plusUFM x y+plusTyConEnv_C f x y      = plusUFM_C f x y+plusTyConEnv_CD f x d y b = plusUFM_CD f x d y b+plusTyConEnv_CD2 f x y    = plusUFM_CD2 f x y+extendTyConEnv_C f x y z  = addToUFM_C f x y z+mapTyConEnv f x           = mapUFM f x+extendTyConEnv_Acc x y z a b  = addToUFM_Acc x y z a b+extendTyConEnvList_C x y z = addListToUFM_C x y z+delFromTyConEnv x y      = delFromUFM x y+delListFromTyConEnv x y  = delListFromUFM x y+filterTyConEnv x y       = filterUFM x y+anyTyConEnv f x          = foldUFM ((||) . f) False x+disjointTyConEnv x y     = disjointUFM x y++lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n)++-- | Deterministic TyCon Environment+--+-- See Note [Deterministic UniqFM] in "GHC.Types.Unique.DFM" for explanation why+-- we need DTyConEnv.+type DTyConEnv a = UniqDFM TyCon a++emptyDTyConEnv :: DTyConEnv a+emptyDTyConEnv = emptyUDFM++isEmptyDTyConEnv :: DTyConEnv a -> Bool+isEmptyDTyConEnv = isNullUDFM++lookupDTyConEnv :: DTyConEnv a -> TyCon -> Maybe a+lookupDTyConEnv = lookupUDFM++delFromDTyConEnv :: DTyConEnv a -> TyCon -> DTyConEnv a+delFromDTyConEnv = delFromUDFM++filterDTyConEnv :: (a -> Bool) -> DTyConEnv a -> DTyConEnv a+filterDTyConEnv = filterUDFM++mapDTyConEnv :: (a -> b) -> DTyConEnv a -> DTyConEnv b+mapDTyConEnv = mapUDFM++mapMaybeDTyConEnv :: (a -> Maybe b) -> DTyConEnv a -> DTyConEnv b+mapMaybeDTyConEnv = mapMaybeUDFM++adjustDTyConEnv :: (a -> a) -> DTyConEnv a -> TyCon -> DTyConEnv a+adjustDTyConEnv = adjustUDFM++alterDTyConEnv :: (Maybe a -> Maybe a) -> DTyConEnv a -> TyCon -> DTyConEnv a+alterDTyConEnv = alterUDFM++extendDTyConEnv :: DTyConEnv a -> TyCon -> a -> DTyConEnv a+extendDTyConEnv = addToUDFM++foldDTyConEnv :: (elt -> a -> a) -> a -> DTyConEnv elt -> a+foldDTyConEnv = foldUDFM

+ GHC/Core/TyCon/RecWalk.hs view

@@ -0,0 +1,99 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Check for recursive type constructors.++-}++{-# LANGUAGE CPP #-}++module GHC.Core.TyCon.RecWalk (++        -- * Recursion breaking+        RecTcChecker, initRecTc, defaultRecTcMaxBound,+        setRecTcMaxBound, checkRecTc++    ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Core.TyCon+import GHC.Core.TyCon.Env++{-+************************************************************************+*                                                                      *+           Walking over recursive TyCons+*                                                                      *+************************************************************************++Note [Expanding newtypes and products]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When expanding a type to expose a data-type constructor, we need to be+careful about newtypes, lest we fall into an infinite loop. Here are+the key examples:++  newtype Id  x = MkId x+  newtype Fix f = MkFix (f (Fix f))+  newtype T     = MkT (T -> T)++  Type           Expansion+ --------------------------+  T              T -> T+  Fix Maybe      Maybe (Fix Maybe)+  Id (Id Int)    Int+  Fix Id         NO NO NO++Notice that+ * We can expand T, even though it's recursive.+ * We can expand Id (Id Int), even though the Id shows up+   twice at the outer level, because Id is non-recursive++So, when expanding, we keep track of when we've seen a recursive+newtype at outermost level; and bail out if we see it again.++We sometimes want to do the same for product types, so that the+strictness analyser doesn't unbox infinitely deeply.++More precisely, we keep a *count* of how many times we've seen it.+This is to account for+   data instance T (a,b) = MkT (T a) (T b)+Then (#10482) if we have a type like+        T (Int,(Int,(Int,(Int,Int))))+we can still unbox deeply enough during strictness analysis.+We have to treat T as potentially recursive, but it's still+good to be able to unwrap multiple layers.++The function that manages all this is checkRecTc.+-}++data RecTcChecker = RC !Int (TyConEnv Int)+  -- The upper bound, and the number of times+  -- we have encountered each TyCon++-- | Initialise a 'RecTcChecker' with 'defaultRecTcMaxBound'.+initRecTc :: RecTcChecker+initRecTc = RC defaultRecTcMaxBound emptyTyConEnv++-- | The default upper bound (100) for the number of times a 'RecTcChecker' is+-- allowed to encounter each 'TyCon'.+defaultRecTcMaxBound :: Int+defaultRecTcMaxBound = 100+-- Should we have a flag for this?++-- | Change the upper bound for the number of times a 'RecTcChecker' is allowed+-- to encounter each 'TyCon'.+setRecTcMaxBound :: Int -> RecTcChecker -> RecTcChecker+setRecTcMaxBound new_bound (RC _old_bound rec_nts) = RC new_bound rec_nts++checkRecTc :: RecTcChecker -> TyCon -> Maybe RecTcChecker+-- Nothing      => Recursion detected+-- Just rec_tcs => Keep going+checkRecTc (RC bound rec_nts) tc+  = case lookupTyConEnv rec_nts tc of+      Just n | n >= bound -> Nothing+             | otherwise  -> Just (RC bound (extendTyConEnv rec_nts tc (n+1)))+      Nothing             -> Just (RC bound (extendTyConEnv rec_nts tc 1))

+ GHC/Core/TyCon/Set.hs view

@@ -0,0 +1,73 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++{-# LANGUAGE CPP #-}++module GHC.Core.TyCon.Set (+        -- * TyCons set type+        TyConSet,++        -- ** Manipulating these sets+        emptyTyConSet, unitTyConSet, mkTyConSet, unionTyConSet, unionTyConSets,+        minusTyConSet, elemTyConSet, extendTyConSet, extendTyConSetList,+        delFromTyConSet, delListFromTyConSet, isEmptyTyConSet, filterTyConSet,+        intersectsTyConSet, disjointTyConSet, intersectTyConSet,+        nameSetAny, nameSetAll+    ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Types.Unique.Set+import GHC.Core.TyCon (TyCon)++type TyConSet = UniqSet TyCon++emptyTyConSet       :: TyConSet+unitTyConSet        :: TyCon -> TyConSet+extendTyConSetList   :: TyConSet -> [TyCon] -> TyConSet+extendTyConSet    :: TyConSet -> TyCon -> TyConSet+mkTyConSet          :: [TyCon] -> TyConSet+unionTyConSet      :: TyConSet -> TyConSet -> TyConSet+unionTyConSets  :: [TyConSet] -> TyConSet+minusTyConSet       :: TyConSet -> TyConSet -> TyConSet+elemTyConSet        :: TyCon -> TyConSet -> Bool+isEmptyTyConSet     :: TyConSet -> Bool+delFromTyConSet     :: TyConSet -> TyCon -> TyConSet+delListFromTyConSet :: TyConSet -> [TyCon] -> TyConSet+filterTyConSet      :: (TyCon -> Bool) -> TyConSet -> TyConSet+intersectTyConSet   :: TyConSet -> TyConSet -> TyConSet+intersectsTyConSet  :: TyConSet -> TyConSet -> Bool+-- ^ True if there is a non-empty intersection.+-- @s1 `intersectsTyConSet` s2@ doesn't compute @s2@ if @s1@ is empty+disjointTyConSet    :: TyConSet -> TyConSet -> Bool++isEmptyTyConSet    = isEmptyUniqSet+emptyTyConSet      = emptyUniqSet+unitTyConSet       = unitUniqSet+mkTyConSet         = mkUniqSet+extendTyConSetList = addListToUniqSet+extendTyConSet     = addOneToUniqSet+unionTyConSet      = unionUniqSets+unionTyConSets     = unionManyUniqSets+minusTyConSet      = minusUniqSet+elemTyConSet       = elementOfUniqSet+delFromTyConSet    = delOneFromUniqSet+filterTyConSet     = filterUniqSet+intersectTyConSet  = intersectUniqSets+disjointTyConSet   = disjointUniqSets+++delListFromTyConSet set ns = foldl' delFromTyConSet set ns++intersectsTyConSet s1 s2 = not (isEmptyTyConSet (s1 `intersectTyConSet` s2))++nameSetAny :: (TyCon -> Bool) -> TyConSet -> Bool+nameSetAny = uniqSetAny++nameSetAll :: (TyCon -> Bool) -> TyConSet -> Bool+nameSetAll = uniqSetAll

GHC/Core/Type.hs view

@@ -3,7 +3,7 @@ -- -- Type - public interface -{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, ViewPatterns #-}+{-# LANGUAGE CPP, FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -15,7 +15,7 @@         -- $type_classification          -- $representation_types-        TyThing(..), Type, ArgFlag(..), AnonArgFlag(..),+        Type, ArgFlag(..), AnonArgFlag(..),         Specificity(..),         KindOrType, PredType, ThetaType,         Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,@@ -29,14 +29,14 @@         mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,         splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe, -        mkVisFunTy, mkInvisFunTy,+        mkFunTy, mkVisFunTy, mkInvisFunTy,         mkVisFunTys,         mkVisFunTyMany, mkInvisFunTyMany,         mkVisFunTysMany, mkInvisFunTysMany,         splitFunTy, splitFunTy_maybe,         splitFunTys, funResultTy, funArgTy, -        mkTyConApp, mkTyConTy,+        mkTyConApp, mkTyConTy, tYPE,         tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,         tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,         splitTyConApp_maybe, splitTyConApp, tyConAppArgN,@@ -48,11 +48,11 @@         mkSpecForAllTy, mkSpecForAllTys,         mkVisForAllTys, mkTyCoInvForAllTy,         mkInfForAllTy, mkInfForAllTys,-        splitForAllTys,-        splitForAllTysReq, splitForAllTysInvis,-        splitForAllVarBndrs,-        splitForAllTy_maybe, splitForAllTy,-        splitForAllTy_ty_maybe, splitForAllTy_co_maybe,+        splitForAllTyCoVars,+        splitForAllReqTVBinders, splitForAllInvisTVBinders,+        splitForAllTyCoVarBinders,+        splitForAllTyCoVar_maybe, splitForAllTyCoVar,+        splitForAllTyVar_maybe, splitForAllCoVar_maybe,         splitPiTy_maybe, splitPiTy, splitPiTys,         mkTyConBindersPreferAnon,         mkPiTy, mkPiTys,@@ -63,6 +63,7 @@          mkNumLitTy, isNumLitTy,         mkStrLitTy, isStrLitTy,+        mkCharLitTy, isCharLitTy,         isLitTy,          isPredTy,@@ -76,12 +77,11 @@         coAxNthLHS,         stripCoercionTy, -        splitPiTysInvisible, splitPiTysInvisibleN,+        splitInvisPiTys, splitInvisPiTysN,         invisibleTyBndrCount,         filterOutInvisibleTypes, filterOutInferredTypes,         partitionInvisibleTypes, partitionInvisibles,         tyConArgFlags, appTyArgFlags,-        synTyConResKind,          -- ** Analyzing types         TyCoMapper(..), mapTyCo, mapTyCoX,@@ -120,11 +120,13 @@          -- *** Levity and boxity         isLiftedType_maybe,-        isLiftedTypeKind, isUnliftedTypeKind,-        isLiftedRuntimeRep, isUnliftedRuntimeRep,-        isUnliftedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,+        isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind,+        isLiftedRuntimeRep, isUnliftedRuntimeRep, isBoxedRuntimeRep,+        isLiftedLevity, isUnliftedLevity,+        isUnliftedType, isBoxedType, mightBeUnliftedType, isUnboxedTupleType, isUnboxedSumType,         isAlgType, isDataFamilyAppType,         isPrimitiveType, isStrictType,+        isLevityTy, isLevityVar,         isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,         dropRuntimeRepArgs,         getRuntimeRep,@@ -144,10 +146,10 @@         -- ** Finding the kind of a type         typeKind, tcTypeKind, isTypeLevPoly, resultIsLevPoly,         tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,-        tcIsRuntimeTypeKind,+        tcIsBoxedTypeKind, tcIsRuntimeTypeKind,          -- ** Common Kind-        liftedTypeKind,+        liftedTypeKind, unliftedTypeKind,          -- * Type free variables         tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,@@ -156,6 +158,7 @@         coVarsOfType,         coVarsOfTypes, +        anyFreeVarsOfType, anyFreeVarsOfTypes,         noFreeVarsOfType,         splitVisVarsOfType, splitVisVarsOfTypes,         expandTypeSynonyms,@@ -212,6 +215,7 @@         substCoUnchecked, substCoWithUnchecked,         substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,         substVarBndr, substVarBndrs,+        substTyCoBndr,         cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,          -- * Tidying type related things up for printing@@ -254,8 +258,9 @@ import GHC.Core.TyCon import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types-                                 ( listTyCon, typeNatKind-                                 , typeSymbolKind, liftedTypeKind+                                 ( charTy, naturalTy, listTyCon+                                 , typeSymbolKind, liftedTypeKind, unliftedTypeKind+                                 , liftedRepTyCon, unliftedRepTyCon                                  , constraintKind                                  , unrestrictedFunTyCon                                  , manyDataConTy, oneDataConTy )@@ -276,6 +281,7 @@ import GHC.Utils.Misc import GHC.Utils.FV import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Pair import GHC.Data.List.SetOps@@ -288,26 +294,29 @@ -- $type_classification -- #type_classification# ----- Types are one of:+-- Types are any, but at least one, of: ----- [Unboxed]            Iff its representation is other than a pointer---                      Unboxed types are also unlifted.+-- [Boxed]              Iff its representation is a pointer to an object on the+--                      GC'd heap. Operationally, heap objects can be entered as+--                      a means of evaluation. ----- [Lifted]             Iff it has bottom as an element.---                      Closures always have lifted types: i.e. any---                      let-bound identifier in Core must have a lifted---                      type. Operationally, a lifted object is one that---                      can be entered.+-- [Lifted]             Iff it has bottom as an element: An instance of a+--                      lifted type might diverge when evaluated.+--                      GHC Haskell's unboxed types are unlifted.+--                      An unboxed, but lifted type is not very useful.+--                      (Example: A byte-represented type, where evaluating 0xff+--                      computes the 12345678th collatz number modulo 0xff.) --                      Only lifted types may be unified with a type variable. -- -- [Algebraic]          Iff it is a type with one or more constructors, whether --                      declared with @data@ or @newtype@. --                      An algebraic type is one that can be deconstructed---                      with a case expression. This is /not/ the same as---                      lifted types, because we also include unboxed---                      tuples in this classification.+--                      with a case expression. There are algebraic types that+--                      are not lifted types, like unlifted data types or+--                      unboxed tuples. -- -- [Data]               Iff it is a type declared with @data@, or a boxed tuple.+--                      There are also /unlifted/ data types. -- -- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell. --@@ -357,41 +366,53 @@  We implement this by making 'coreView' convert 'Constraint' to 'TYPE LiftedRep' on the fly.  The function tcView (used in the type checker)-does not do this.+does not do this. Accordingly, tcView is used in type-checker-oriented+functions (including the pure unifier, used in instance resolution),+while coreView is used during e.g. optimisation passes.  See also #11715, which tracks removing this inconsistency. +The inconsistency actually leads to a potential soundness bug, in that+Constraint and Type are considered *apart* by the type family engine.+To wit, we can write++  type family F a+  type instance F Type = Bool+  type instance F Constraint = Int++and (because Type ~# Constraint in Core), thus build a coercion between+Int and Bool. I (Richard E) conjecture that this never happens in practice,+but it's very uncomfortable. This, essentially, is the root problem+underneath #11715, which is quite resistant to an easy fix. The best+idea is to have roles in kind coercions, but that has yet to be implemented.+See also "A Role for Dependent Types in Haskell", ICFP 2019, which describes+how roles in kinds might work out.+ -}  -- | Gives the typechecker view of a type. This unwraps synonyms but--- leaves 'Constraint' alone. c.f. coreView, which turns Constraint into--- TYPE LiftedRep. Returns Nothing if no unwrapping happens.+-- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into+-- 'Type'. Returns 'Nothing' if no unwrapping happens. -- See also Note [coreView vs tcView]-{-# INLINE tcView #-} tcView :: Type -> Maybe Type-tcView (TyConApp tc tys) | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')-               -- The free vars of 'rhs' should all be bound by 'tenv', so it's-               -- ok to use 'substTy' here.-               -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.-               -- Its important to use mkAppTys, rather than (foldl AppTy),-               -- because the function part might well return a-               -- partially-applied type constructor; indeed, usually will!+tcView (TyConApp tc tys)+  | res@(Just _) <- expandSynTyConApp_maybe tc tys+  = res tcView _ = Nothing+-- See Note [Inlining coreView].+{-# INLINE tcView #-} -{-# INLINE coreView #-} coreView :: Type -> Maybe Type--- ^ This function Strips off the /top layer only/ of a type synonym+-- ^ This function strips off the /top layer only/ of a type synonym -- application (if any) its underlying representation type.--- Returns Nothing if there is nothing to look through.--- This function considers 'Constraint' to be a synonym of @TYPE LiftedRep@.+-- Returns 'Nothing' if there is nothing to look through.+-- This function considers 'Constraint' to be a synonym of @Type@. -- -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing coreView ty@(TyConApp tc tys)-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  = Just (mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys')-    -- This equation is exactly like tcView+  | res@(Just _) <- expandSynTyConApp_maybe tc tys+  = res    -- At the Core level, Constraint = Type   -- See Note [coreView vs tcView]@@ -400,8 +421,48 @@     Just liftedTypeKind  coreView _ = Nothing+-- See Note [Inlining coreView].+{-# INLINE coreView #-} -{-# INLINE coreFullView #-}+-----------------------------------------------++-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@+-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a+-- synonym.+expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type+expandSynTyConApp_maybe tc tys+  | Just (tvs, rhs) <- synTyConDefn_maybe tc+  , tys `lengthAtLeast` arity+  = Just (expand_syn arity tvs rhs tys)+  | otherwise+  = Nothing+  where+    arity = tyConArity tc+-- Without this INLINE the call to expandSynTyConApp_maybe in coreView+-- will result in an avoidable allocation.+{-# INLINE expandSynTyConApp_maybe #-}++-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path+-- into call-sites.+expand_syn :: Int      -- ^ the arity of the synonym+           -> [TyVar]  -- ^ the variables bound by the synonym+           -> Type     -- ^ the RHS of the synonym+           -> [Type]   -- ^ the type arguments the synonym is instantiated at.+           -> Type+expand_syn arity tvs rhs tys+  | tys `lengthExceeds` arity = mkAppTys rhs' (drop arity tys)+  | otherwise                 = rhs'+  where+    rhs' = substTy (mkTvSubstPrs (tvs `zip` tys)) rhs+               -- The free vars of 'rhs' should all be bound by 'tenv', so it's+               -- ok to use 'substTy' here (which is what expandSynTyConApp_maybe does).+               -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.+               -- Its important to use mkAppTys, rather than (foldl AppTy),+               -- because the function part might well return a+               -- partially-applied type constructor; indeed, usually will!+-- We never want to inline this cold-path.+{-# INLINE expand_syn #-}+ coreFullView :: Type -> Type -- ^ Iterates 'coreView' until there is no more to synonym to expand. -- See Note [Inlining coreView].@@ -413,9 +474,10 @@       | otherwise = ty  coreFullView ty = ty+{-# INLINE coreFullView #-} -{- Note [Inlining coreView] in GHC.Core.Type-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Inlining coreView]+~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is very common to have a function    f :: Type -> ...@@ -527,6 +589,18 @@       -- order of a coercion)     go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst +-- | An INLINE helper for function such as 'kindRep_maybe' below.+--+-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff+-- the type @ty = T tys@, where T's unique = key+isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type]+isTyConKeyApp_maybe key ty+  | TyConApp tc args <- coreFullView ty+  , tc `hasKey` key+  = Just args+  | otherwise+  = Nothing+{-# INLINE isTyConKeyApp_maybe #-}  -- | Extract the RuntimeRep classifier of a type from its kind. For example, -- @kindRep * = LiftedRep@; Panics if this is not possible.@@ -542,10 +616,19 @@ -- Treats * and Constraint as the same kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type kindRep_maybe kind-  | TyConApp tc [arg] <- coreFullView kind-  , tc `hasKey` tYPETyConKey    = Just arg-  | otherwise                   = Nothing+  | Just [arg] <- isTyConKeyApp_maybe tYPETyConKey kind = Just arg+  | otherwise                                           = Nothing +-- | Returns True if the kind classifies types which are allocated on+-- the GC'd heap and False otherwise. Note that this returns False for+-- levity-polymorphic kinds, which may be specialized to a kind that+-- classifies AddrRep or even unboxed kinds.+isBoxedTypeKind :: Kind -> Bool+isBoxedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isBoxedRuntimeRep rep+      Nothing  -> False+ -- | This version considers Constraint to be the same as *. Returns True -- if the argument is equivalent to Type/Constraint and False otherwise. -- See Note [Kind Constraint and kind Type]@@ -555,55 +638,118 @@       Just rep -> isLiftedRuntimeRep rep       Nothing  -> False -isLiftedRuntimeRep :: Type -> Bool--- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep--- False of type variables (a :: RuntimeRep)---   and of other reps e.g. (IntRep :: RuntimeRep)-isLiftedRuntimeRep rep-  | TyConApp rr_tc args <- coreFullView rep-  , rr_tc `hasKey` liftedRepDataConKey = ASSERT( null args ) True+pickyIsLiftedTypeKind :: Kind -> Bool+-- Checks whether the kind is literally+--      TYPE LiftedRep+-- or   TYPE ('BoxedRep 'Lifted)+-- or   Type+-- without expanding type synonyms or anything+-- Used only when deciding whether to suppress the ":: *" in+-- (a :: *) when printing kinded type variables+-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr+pickyIsLiftedTypeKind kind+  | TyConApp tc [arg] <- kind+  , tc `hasKey` tYPETyConKey+  , TyConApp rr_tc rr_args <- arg = case rr_args of+      [] -> rr_tc `hasKey` liftedRepTyConKey+      [rr_arg]+        | rr_tc `hasKey` boxedRepDataConKey+        , TyConApp lev [] <- rr_arg+        , lev `hasKey` liftedDataConKey -> True+      _ -> False+  | TyConApp tc [] <- kind+  , tc `hasKey` liftedTypeKindTyConKey = True   | otherwise                          = False --- | Returns True if the kind classifies unlifted types and False otherwise.--- Note that this returns False for levity-polymorphic kinds, which may--- be specialized to a kind that classifies unlifted types.+-- | Returns True if the kind classifies unlifted types (like 'Int#') and False+-- otherwise. Note that this returns False for levity-polymorphic kinds, which+-- may be specialized to a kind that classifies unlifted types. isUnliftedTypeKind :: Kind -> Bool isUnliftedTypeKind kind   = case kindRep_maybe kind of       Just rep -> isUnliftedRuntimeRep rep       Nothing  -> False +-- | See 'isBoxedRuntimeRep_maybe'.+isBoxedRuntimeRep :: Type -> Bool+isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep)++-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep`+-- expands to `Boxed lev` and returns `Nothing` otherwise.+--+-- Types with this runtime rep are represented by pointers on the GC'd heap.+isBoxedRuntimeRep_maybe :: Type -> Maybe Type+isBoxedRuntimeRep_maybe rep+  | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep+  = Just lev+  | otherwise+  = Nothing++isLiftedRuntimeRep :: Type -> Bool+-- isLiftedRuntimeRep is true of LiftedRep :: RuntimeRep+-- False of type variables (a :: RuntimeRep)+--   and of other reps e.g. (IntRep :: RuntimeRep)+isLiftedRuntimeRep rep+  | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep+  = isLiftedLevity lev+  | otherwise+  = False+ isUnliftedRuntimeRep :: Type -> Bool+-- PRECONDITION: The type has kind RuntimeRep -- True of definitely-unlifted RuntimeReps -- False of           (LiftedRep :: RuntimeRep) --   and of variables (a :: RuntimeRep) isUnliftedRuntimeRep rep-  | TyConApp rr_tc _ <- coreFullView rep   -- NB: args might be non-empty-                                           --     e.g. TupleRep [r1, .., rn]-  = isPromotedDataCon rr_tc && not (rr_tc `hasKey` liftedRepDataConKey)+  | TyConApp rr_tc args <- coreFullView rep -- NB: args might be non-empty+                                            --     e.g. TupleRep [r1, .., rn]+  , isPromotedDataCon rr_tc =+      -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]+      if (rr_tc `hasKey` boxedRepDataConKey)+        then case args of+          [lev] -> isUnliftedLevity lev+          _     -> False+        else True         -- Avoid searching all the unlifted RuntimeRep type cons         -- In the RuntimeRep data type, only LiftedRep is lifted-        -- But be careful of type families (F tys) :: RuntimeRep-  | otherwise {- Variables, applications -}+        -- But be careful of type families (F tys) :: RuntimeRep,+        -- hence the isPromotedDataCon rr_tc+isUnliftedRuntimeRep _ = False++-- | An INLINE helper for function such as 'isLiftedRuntimeRep' below.+isNullaryTyConKeyApp :: Unique -> Type -> Bool+isNullaryTyConKeyApp key ty+  | Just args <- isTyConKeyApp_maybe key ty+  = ASSERT( null args ) True+  | otherwise   = False+{-# INLINE isNullaryTyConKeyApp #-} +isLiftedLevity :: Type -> Bool+isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey++isUnliftedLevity :: Type -> Bool+isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey++-- | Is this the type 'Levity'?+isLevityTy :: Type -> Bool+isLevityTy = isNullaryTyConKeyApp levityTyConKey+ -- | Is this the type 'RuntimeRep'? isRuntimeRepTy :: Type -> Bool-isRuntimeRepTy ty-  | TyConApp tc args <- coreFullView ty-  , tc `hasKey` runtimeRepTyConKey = ASSERT( null args ) True--  | otherwise = False+isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey  -- | Is a tyvar of type 'RuntimeRep'? isRuntimeRepVar :: TyVar -> Bool isRuntimeRepVar = isRuntimeRepTy . tyVarKind +-- | Is a tyvar of type 'Levity'?+isLevityVar :: TyVar -> Bool+isLevityVar = isLevityTy . tyVarKind+ -- | Is this the type 'Multiplicity'? isMultiplicityTy :: Type -> Bool-isMultiplicityTy ty-  | TyConApp tc [] <- coreFullView ty = tc `hasKey` multiplicityTyConKey-  | otherwise                         = False+isMultiplicityTy  = isNullaryTyConKeyApp multiplicityTyConKey  -- | Is a tyvar of type 'Multiplicity'? isMultiplicityVar :: TyVar -> Bool@@ -1004,7 +1150,17 @@   | LitTy (StrTyLit s) <- coreFullView ty = Just s   | otherwise                             = Nothing --- | Is this a type literal (symbol or numeric).+mkCharLitTy :: Char -> Type+mkCharLitTy c = LitTy (CharTyLit c)++-- | Is this a char literal? We also look through type synonyms.+isCharLitTy :: Type -> Maybe Char+isCharLitTy ty+  | LitTy (CharTyLit s) <- coreFullView ty = Just s+  | otherwise                              = Nothing+++-- | Is this a type literal (symbol, numeric, or char)? isLitTy :: Type -> Maybe TyLit isLitTy ty   | LitTy l <- coreFullView ty = Just l@@ -1077,7 +1233,7 @@     FunTy (Anon a) b  Note how the RuntimeReps are implied in the FunTy representation. For this-reason we must be careful when recontructing the TyConApp representation (see,+reason we must be careful when reconstructing the TyConApp representation (see, for instance, splitTyConApp_maybe).  In the compiler we maintain the invariant that all saturated applications of@@ -1086,14 +1242,14 @@ See #11714. -} -splitFunTy :: Type -> (Type, Type, Type)--- ^ Attempts to extract the argument and result types from a type, and--- panics if that is not possible. See also 'splitFunTy_maybe'+splitFunTy :: Type -> (Mult, Type, Type)+-- ^ Attempts to extract the multiplicity, argument and result types from a type,+-- and panics if that is not possible. See also 'splitFunTy_maybe' splitFunTy = expectJust "splitFunTy" . splitFunTy_maybe  {-# INLINE splitFunTy_maybe #-}-splitFunTy_maybe :: Type -> Maybe (Type, Type, Type)--- ^ Attempts to extract the argument and result types from a type+splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type)+-- ^ Attempts to extract the multiplicity, argument and result types from a type splitFunTy_maybe ty   | FunTy _ w arg res <- coreFullView ty = Just (w, arg, res)   | otherwise                            = Nothing@@ -1310,11 +1466,19 @@ -- of @a@ isn't of the form @TYPE rep@). Consequently, you may need to zonk your -- type before using this function. --+-- This does *not* split types headed with (=>), as that's not a TyCon in the+-- type-checker.+-- -- If you only need the 'TyCon', consider using 'tcTyConAppTyCon_maybe'. tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty | Just ty' <- tcView ty = tcSplitTyConApp_maybe ty'-tcSplitTyConApp_maybe ty                         = repSplitTyConApp_maybe ty+tcSplitTyConApp_maybe (TyConApp tc tys)          = Just (tc, tys)+tcSplitTyConApp_maybe (FunTy VisArg w arg res)+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])+tcSplitTyConApp_maybe _ = Nothing  ------------------- repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])@@ -1325,7 +1489,7 @@ -- have enough info to extract the runtime-rep arguments that -- the funTyCon requires.  This will usually be true; -- but may be temporarily false during canonicalization:---     see Note [FunTy and decomposing tycon applications] in "GHC.Tc.Solver.Canonical"+--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical -- repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys) repSplitTyConApp_maybe (FunTy _ w arg res)@@ -1401,8 +1565,102 @@     to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)     to_tyb (Bndr tv (AnonTCB af))   = Anon af (tymult (varType tv)) +-- | Create the plain type constructor type which has been applied to no type arguments at all.+mkTyConTy :: TyCon -> Type+mkTyConTy tycon = tyConNullaryTy tycon+  -- see Note [Sharing nullary TyConApps] in GHC.Core.TyCon +-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to+-- its arguments.  Applies its arguments to the constructor from left to right.+mkTyConApp :: TyCon -> [Type] -> Type+mkTyConApp tycon tys+  | null tys+  = mkTyConTy tycon++  | isFunTyCon tycon+  , [w, _rep1,_rep2,ty1,ty2] <- tys+  -- The FunTyCon (->) is always a visible one+  = FunTy { ft_af = VisArg, ft_mult = w, ft_arg = ty1, ft_res = ty2 }++  -- See Note [Prefer Type over TYPE 'LiftedRep].+  | tycon `hasKey` tYPETyConKey+  , [rep] <- tys+  = tYPE rep+  -- The catch-all case+  | otherwise+  = TyConApp tycon tys+ {-+Note [Prefer Type over TYPE 'LiftedRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Core of nearly any program will have numerous occurrences of+@TYPE 'LiftedRep@ (and, equivalently, 'Type') floating about. Concretely, while+investigating #17292 we found that these constituting a majority of TyConApp+constructors on the heap:++```+(From a sample of 100000 TyConApp closures)+0x45f3523    - 28732 - `Type`+0x420b840702 - 9629  - generic type constructors+0x42055b7e46 - 9596+0x420559b582 - 9511+0x420bb15a1e - 9509+0x420b86c6ba - 9501+0x42055bac1e - 9496+0x45e68fd    - 538 - `TYPE ...`+```++Consequently, we try hard to ensure that operations on such types are+efficient. Specifically, we strive to++ a. Avoid heap allocation of such types+ b. Use a small (shallow in the tree-depth sense) representation+    for such types++Goal (b) is particularly useful as it makes traversals (e.g. free variable+traversal, substitution, and comparison) more efficient.+Comparison in particular takes special advantage of nullary type synonym+applications (e.g. things like @TyConApp typeTyCon []@), Note [Comparing+nullary type synonyms] in "GHC.Core.Type".++To accomplish these we use a number of tricks:++ 1. Instead of representing the lifted kind as+    @TyConApp tYPETyCon [liftedRepDataCon]@ we rather prefer to+    use the 'GHC.Types.Type' type synonym (represented as a nullary TyConApp).+    This serves goal (b) since there are no applied type arguments to traverse,+    e.g., during comparison.++ 2. We have a top-level binding to represent `TyConApp GHC.Types.Type []`+    (namely 'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we+    don't need to allocate such types (goal (a)).++ 3. We use the sharing mechanism described in Note [Sharing nullary TyConApps]+    in GHC.Core.TyCon to ensure that we never need to allocate such+    nullary applications (goal (a)).++See #17958.+-}+++-- | Given a @RuntimeRep@, applies @TYPE@ to it.+-- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.+tYPE :: Type -> Type+tYPE rr@(TyConApp tc [arg])+  -- See Note [Prefer Type of TYPE 'LiftedRep]+  | tc `hasKey` boxedRepDataConKey+  , TyConApp tc' [] <- arg+  = if | tc' `hasKey` liftedDataConKey   -> liftedTypeKind   -- TYPE (BoxedRep 'Lifted)+       | tc' `hasKey` unliftedDataConKey -> unliftedTypeKind -- TYPE (BoxedRep 'Unlifted)+       | otherwise                       -> TyConApp tYPETyCon [rr]+  | tc == liftedRepTyCon                               -- TYPE LiftedRep+  = liftedTypeKind+  | tc == unliftedRepTyCon                             -- TYPE UnliftedRep+  = unliftedTypeKind+tYPE rr = TyConApp tYPETyCon [rr]+++{- --------------------------------------------------------------------                             CoercionTy                             ~~~~~~~~~~@@ -1519,47 +1777,47 @@ -- | Take a ForAllTy apart, returning the list of tycovars and the result type. -- This always succeeds, even if it returns only an empty list. Note that the -- result type returned may have free variables that were bound by a forall.-splitForAllTys :: Type -> ([TyCoVar], Type)-splitForAllTys ty = split ty ty []+splitForAllTyCoVars :: Type -> ([TyCoVar], Type)+splitForAllTyCoVars ty = split ty ty []   where     split _       (ForAllTy (Bndr tv _) ty)    tvs = split ty ty (tv:tvs)     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs     split orig_ty _                            tvs = (reverse tvs, orig_ty) --- | Splits the longest initial sequence of ForAllTys' that satisfy+-- | Splits the longest initial sequence of 'ForAllTy's that satisfy -- @argf_pred@, returning the binders transformed by @argf_pred@-splitSomeForAllTys :: (ArgFlag -> Maybe af) -> Type -> ([VarBndr TyCoVar af], Type)-splitSomeForAllTys argf_pred ty = split ty ty []+splitSomeForAllTyCoVarBndrs :: (ArgFlag -> Maybe af) -> Type -> ([VarBndr TyCoVar af], Type)+splitSomeForAllTyCoVarBndrs argf_pred ty = split ty ty []   where     split _ (ForAllTy (Bndr tcv argf) ty) tvs       | Just argf' <- argf_pred argf               = split ty ty (Bndr tcv argf' : tvs)     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs     split orig_ty _                            tvs = (reverse tvs, orig_ty) --- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Required' type+-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. Furthermore, each returned tyvar is annotated with '()'.-splitForAllTysReq :: Type -> ([ReqTVBinder], Type)-splitForAllTysReq ty = splitSomeForAllTys argf_pred ty+splitForAllReqTVBinders :: Type -> ([ReqTVBinder], Type)+splitForAllReqTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty   where     argf_pred :: ArgFlag -> Maybe ()     argf_pred Required       = Just ()     argf_pred (Invisible {}) = Nothing --- | Like 'splitForAllTys', but only splits 'ForAllTy's with 'Invisible' type+-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. Furthermore, each returned tyvar is annotated with its -- 'Specificity'.-splitForAllTysInvis :: Type -> ([InvisTVBinder], Type)-splitForAllTysInvis ty = splitSomeForAllTys argf_pred ty+splitForAllInvisTVBinders :: Type -> ([InvisTVBinder], Type)+splitForAllInvisTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty   where     argf_pred :: ArgFlag -> Maybe Specificity     argf_pred Required         = Nothing     argf_pred (Invisible spec) = Just spec --- | Like splitForAllTys, but split only for tyvars.+-- | Like 'splitForAllTyCoVars', but split only for tyvars. -- This always succeeds, even if it returns only an empty list. Note that the -- result type returned may have free variables that were bound by a forall.-splitTyVarForAllTys :: Type -> ([TyVar], Type)-splitTyVarForAllTys ty = split ty ty []+splitForAllTyVars :: Type -> ([TyVar], Type)+splitForAllTyVars ty = split ty ty []   where     split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs)     split orig_ty ty tvs | Just ty' <- coreView ty     = split orig_ty ty' tvs@@ -1603,10 +1861,10 @@   | otherwise                   = False  -- | Take a forall type apart, or panics if that is not possible.-splitForAllTy :: Type -> (TyCoVar, Type)-splitForAllTy ty-  | Just answer <- splitForAllTy_maybe ty = answer-  | otherwise                             = pprPanic "splitForAllTy" (ppr ty)+splitForAllTyCoVar :: Type -> (TyCoVar, Type)+splitForAllTyCoVar ty+  | Just answer <- splitForAllTyCoVar_maybe ty = answer+  | otherwise                                  = pprPanic "splitForAllTyCoVar" (ppr ty)  -- | Drops all ForAllTys dropForAlls :: Type -> Type@@ -1618,23 +1876,23 @@  -- | Attempts to take a forall type apart, but only if it's a proper forall, -- with a named binder-splitForAllTy_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTy_maybe ty+splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTyCoVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty)   | otherwise                                        = Nothing --- | Like splitForAllTy_maybe, but only returns Just if it is a tyvar binder.-splitForAllTy_ty_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTy_ty_maybe ty+-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder.+splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTyVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty   , isTyVar tv   = Just (tv, inner_ty)    | otherwise = Nothing --- | Like splitForAllTy_maybe, but only returns Just if it is a covar binder.-splitForAllTy_co_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTy_co_maybe ty+-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder.+splitForAllCoVar_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllCoVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty   , isCoVar tv   = Just (tv, inner_ty)@@ -1669,26 +1927,26 @@     split orig_ty _                bs = (reverse bs, orig_ty)  -- | Like 'splitPiTys' but split off only /named/ binders---   and returns TyCoVarBinders rather than TyCoBinders-splitForAllVarBndrs :: Type -> ([TyCoVarBinder], Type)-splitForAllVarBndrs ty = split ty ty []+--   and returns 'TyCoVarBinder's rather than 'TyCoBinder's+splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type)+splitForAllTyCoVarBinders ty = split ty ty []   where     split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs     split _       (ForAllTy b res) bs = split res res (b:bs)     split orig_ty _                bs = (reverse bs, orig_ty)-{-# INLINE splitForAllVarBndrs #-}+{-# INLINE splitForAllTyCoVarBinders #-}  invisibleTyBndrCount :: Type -> Int -- Returns the number of leading invisible forall'd binders in the type -- Includes invisible predicate arguments; e.g. for --    e.g.  forall {k}. (k ~ *) => k -> k -- returns 2 not 1-invisibleTyBndrCount ty = length (fst (splitPiTysInvisible ty))+invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty)) --- Like splitPiTys, but returns only *invisible* binders, including constraints--- Stops at the first visible binder-splitPiTysInvisible :: Type -> ([TyCoBinder], Type)-splitPiTysInvisible ty = split ty ty []+-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints.+-- Stops at the first visible binder.+splitInvisPiTys :: Type -> ([TyCoBinder], Type)+splitInvisPiTys ty = split ty ty []    where     split _ (ForAllTy b res) bs       | Bndr _ vis <- b@@ -1699,11 +1957,11 @@       | Just ty' <- coreView ty  = split orig_ty ty' bs     split orig_ty _          bs  = (reverse bs, orig_ty) -splitPiTysInvisibleN :: Int -> Type -> ([TyCoBinder], Type)--- Same as splitPiTysInvisible, but stop when---   - you have found 'n' TyCoBinders,+splitInvisPiTysN :: Int -> Type -> ([TyCoBinder], Type)+-- ^ Same as 'splitInvisPiTys', but stop when+--   - you have found @n@ 'TyCoBinder's, --   - or you run out of invisible binders-splitPiTysInvisibleN n ty = split n ty ty []+splitInvisPiTysN n ty = split n ty ty []    where     split n orig_ty ty bs       | n == 0                  = (reverse bs, orig_ty)@@ -1933,13 +2191,17 @@  buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind               -> [Role] -> KnotTied Type -> TyCon--- This function is here beucase here is where we have+-- This function is here because here is where we have --   isFamFree and isTauTy buildSynTyCon name binders res_kind roles rhs-  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free+  = mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful   where-    is_tau      = isTauTy rhs-    is_fam_free = isFamFreeTy rhs+    is_tau       = isTauTy rhs+    is_fam_free  = isFamFreeTy rhs+    is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders ||+                   uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs)+         -- NB: This is allowed to be conservative, returning True more often+         -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon  {- ************************************************************************@@ -1983,6 +2245,13 @@       Just is_lifted -> not is_lifted       Nothing -> True +-- | See "Type#type_classification" for what a boxed type is.+-- Panics on levity polymorphic types; See 'mightBeUnliftedType' for+-- a more approximate predicate that behaves better in the presence of+-- levity polymorphism.+isBoxedType :: Type -> Bool+isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty)+ -- | Is this a type of kind RuntimeRep? (e.g. LiftedRep) isRuntimeRepKindedTy :: Type -> Bool isRuntimeRepKindedTy = isRuntimeRepTy . typeKind@@ -2081,7 +2350,7 @@     valid_under tvs arity ty       | arity == 0       = tvs `disjointVarSet` tyCoVarsOfType ty-      | Just (t, ty') <- splitForAllTy_maybe ty+      | Just (t, ty') <- splitForAllTyCoVar_maybe ty       = valid_under (tvs `extendVarSet` t) (arity-1) ty'       | Just (_, _, res_ty) <- splitFunTy_maybe ty       = valid_under tvs (arity-1) res_ty@@ -2161,6 +2430,35 @@ to use repSplitAppTy_maybe to break up the TyConApp into its pieces and then continue. Easy to do, but also easy to forget to do. +Note [Comparing nullary type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of testing equality between two 'Type's of the form++  TyConApp tc []++where @tc@ is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of @tc@ may be large; it is+much better to rather compare the TyCons directly. Consequently, before+expanding type synonyms in type comparisons we first look for a nullary+TyConApp and simply compare the TyCons if we find one. Of course, if we find+that the TyCons are *not* equal then we still need to perform the expansion as+their RHSs may still be equal.++We perform this optimisation in a number of places:++ * GHC.Core.Types.eqType+ * GHC.Core.Types.nonDetCmpType+ * GHC.Core.Unify.unify_ty+ * TcCanonical.can_eq_nc'+ * TcUnify.uType++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See Note [Prefer Type over TYPE 'LiftedRep] in+GHC.Core.TyCo.Rep for details.+ -}  eqType :: Type -> Type -> Bool@@ -2203,7 +2501,7 @@  {- Note [nonDetCmpType nondeterminism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,@@ -2272,6 +2570,10 @@     -- Returns both the resulting ordering relation between the two types     -- and whether either contains a cast.     go :: RnEnv2 -> Type -> Type -> TypeOrdering+    -- See Note [Comparing nullary type synonyms].+    go _   (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = TEQ     go env t1 t2       | Just t1' <- coreView t1 = go env t1' t2       | Just t2' <- coreView t2 = go env t1 t2'@@ -2293,7 +2595,7 @@         -- Comparing multiplicities last because the test is usually true     go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)       = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2-    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (compare l1 l2)+    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (nonDetCmpTyLit l1 l2)     go env (CastTy t1 _)       t2                  = hasCast $ go env t1 t2     go env t1                  (CastTy t2 _)       = hasCast $ go env t1 t2 @@ -2464,7 +2766,7 @@       Nothing -> pprPanic "typeKind"                   (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)   where-    (tvs, body) = splitTyVarForAllTys ty+    (tvs, body) = splitForAllTyVars ty     body_kind   = typeKind body  ---------------------------------------------@@ -2509,7 +2811,7 @@       Nothing -> pprPanic "tcTypeKind"                   (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)   where-    (tvs, body) = splitTyVarForAllTys ty+    (tvs, body) = splitForAllTyVars ty     body_kind = tcTypeKind body  @@ -2530,28 +2832,40 @@   | otherwise   = False --- | Is this kind equivalent to @*@?+-- | Like 'kindRep_maybe', but considers 'Constraint' to be distinct+-- from 'Type'. For a version that treats them as the same type, see+-- 'kindRep_maybe'.+tcKindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type+tcKindRep_maybe kind+  | Just (tc, [arg]) <- tcSplitTyConApp_maybe kind    -- Note: tcSplit here+  , tc `hasKey` tYPETyConKey    = Just arg+  | otherwise                   = Nothing++-- | Is this kind equivalent to 'Type'? ----- This considers 'Constraint' to be distinct from @*@. For a version that+-- This considers 'Constraint' to be distinct from 'Type'. For a version that -- treats them as the same type, see 'isLiftedTypeKind'. tcIsLiftedTypeKind :: Kind -> Bool-tcIsLiftedTypeKind ty-  | Just (tc, [arg]) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here-  , tc `hasKey` tYPETyConKey-  = isLiftedRuntimeRep arg-  | otherwise-  = False+tcIsLiftedTypeKind kind+  = case tcKindRep_maybe kind of+      Just rep -> isLiftedRuntimeRep rep+      Nothing  -> False +-- | Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@?+--+-- This considers 'Constraint' to be distinct from 'Type'. For a version that+-- treats them as the same type, see 'isLiftedTypeKind'.+tcIsBoxedTypeKind :: Kind -> Bool+tcIsBoxedTypeKind kind+  = case tcKindRep_maybe kind of+      Just rep -> isBoxedRuntimeRep rep+      Nothing  -> False+ -- | Is this kind equivalent to @TYPE r@ (for some unknown r)? -- -- This considers 'Constraint' to be distinct from @*@. tcIsRuntimeTypeKind :: Kind -> Bool-tcIsRuntimeTypeKind ty-  | Just (tc, _) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here-  , tc `hasKey` tYPETyConKey-  = True-  | otherwise-  = False+tcIsRuntimeTypeKind kind = isJust (tcKindRep_maybe kind)  tcReturnsConstraintKind :: Kind -> Bool -- True <=> the Kind ultimately returns a Constraint@@ -2566,8 +2880,9 @@  -------------------------- typeLiteralKind :: TyLit -> Kind-typeLiteralKind (NumTyLit {}) = typeNatKind+typeLiteralKind (NumTyLit {}) = naturalTy typeLiteralKind (StrTyLit {}) = typeSymbolKind+typeLiteralKind (CharTyLit {}) = charTy  -- | Returns True if a type is levity polymorphic. Should be the same -- as (isKindLevPoly . typeKind) but much faster.@@ -2621,6 +2936,46 @@ We have   occCheckExpand b (F (G b)) = Just (F Char) even though we could also expand F to get rid of b.++Note [Occurrence checking: look inside kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are considering unifying+   (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)+This may be an error (what is that alpha doing inside beta's kind?),+but we must not make the mistake of actually unifying or we'll+build an infinite data structure.  So when looking for occurrences+of alpha in the rhs, we must look in the kinds of type variables+that occur there.++occCheckExpand tries to expand type synonyms to remove+unnecessary occurrences of a variable, and thereby get past an+occurs-check failure.  This is good; but+     we can't do it in the /kind/ of a variable /occurrence/++For example #18451 built an infinite type:+    type Const a b = a+    data SameKind :: k -> k -> Type+    type T (k :: Const Type a) = forall (b :: k). SameKind a b++We have+  b :: k+  k :: Const Type a+  a :: k   (must be same as b)++So if we aren't careful, a's kind mentions a, which is bad.+And expanding an /occurrence/ of 'a' doesn't help, because the+/binding site/ is the master copy and all the occurrences should+match it.++Here's a related example:+   f :: forall a b (c :: Const Type b). Proxy '[a, c]++The list means that 'a' gets the same kind as 'c'; but that+kind mentions 'b', so the binders are out of order.++Bottom line: in occCheckExpand, do not expand inside the kinds+of occurrences.  See bad_var_occ in occCheckExpand.  And+see #18451 for more debate. -}  occCheckExpand :: [Var] -> Type -> Maybe Type@@ -2641,11 +2996,10 @@           -- The VarSet is the set of variables we are trying to avoid           -- The VarEnv carries mappings necessary           -- because of kind expansion-    go cxt@(as, env) (TyVarTy tv')-      | tv' `elemVarSet` as               = Nothing-      | Just tv'' <- lookupVarEnv env tv' = return (mkTyVarTy tv'')-      | otherwise                         = do { tv'' <- go_var cxt tv'-                                               ; return (mkTyVarTy tv'') }+    go (as, env) ty@(TyVarTy tv)+      | Just tv' <- lookupVarEnv env tv = return (mkTyVarTy tv')+      | bad_var_occ as tv               = Nothing+      | otherwise                       = return ty      go _   ty@(LitTy {}) = return ty     go cxt (AppTy ty1 ty2) = do { ty1' <- go cxt ty1@@ -2658,7 +3012,7 @@             ; return (ty { ft_mult = w', ft_arg = ty1', ft_res = ty2' }) }     go cxt@(as, env) (ForAllTy (Bndr tv vis) body_ty)        = do { ki' <- go cxt (varType tv)-            ; let tv' = setVarType tv ki'+            ; let tv'  = setVarType tv ki'                   env' = extendVarEnv env tv tv'                   as'  = as `delVarSet` tv             ; body' <- go (as', env') body_ty@@ -2682,9 +3036,12 @@                                 ; return (mkCoercionTy co') }      -------------------    go_var cxt v = updateVarTypeM (go cxt) v-           -- Works for TyVar and CoVar-           -- See Note [Occurrence checking: look inside kinds]+    bad_var_occ :: VarSet -> Var -> Bool+    -- Works for TyVar and CoVar+    -- See Note [Occurrence checking: look inside kinds]+    bad_var_occ vs_to_avoid v+       =  v                          `elemVarSet`       vs_to_avoid+       || tyCoVarsOfType (varType v) `intersectsVarSet` vs_to_avoid      ------------------     go_mco _   MRefl = return MRefl@@ -2714,13 +3071,15 @@                                              ; co2' <- go_co cxt co2                                              ; w' <- go_co cxt w                                              ; return (mkFunCo r w' co1' co2') }-    go_co cxt@(as,env) (CoVarCo c)-      | c `elemVarSet` as               = Nothing+    go_co (as,env) co@(CoVarCo c)       | Just c' <- lookupVarEnv env c   = return (mkCoVarCo c')-      | otherwise                       = do { c' <- go_var cxt c-                                             ; return (mkCoVarCo c') }-    go_co cxt (HoleCo h)                = do { c' <- go_var cxt (ch_co_var h)-                                             ; return (HoleCo (h { ch_co_var = c' })) }+      | bad_var_occ as c                = Nothing+      | otherwise                       = return co++    go_co (as,_) co@(HoleCo h)+      | bad_var_occ as (ch_co_var h)    = Nothing+      | otherwise                       = return co+     go_co cxt (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args                                              ; return (mkAxiomInstCo ax ind args') }     go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p@@ -2815,13 +3174,6 @@      go_tc tc = unitUniqSet tc      go_ax ax = go_tc $ coAxiomTyCon ax --- | Find the result 'Kind' of a type synonym,--- after applying it to its 'arity' number of type variables--- Actually this function works fine on data types too,--- but they'd always return '*', so we never need to ask-synTyConResKind :: TyCon -> Kind-synTyConResKind tycon = piResultTys (tyConKind tycon) (mkTyVarTys (tyConTyVars tycon))- -- | Retrieve the free variables in this type, splitting them based -- on whether they are used visibly or invisibly. Invisible ones come -- first.@@ -2858,7 +3210,7 @@ ************************************************************************  Note [Kind Constraint and kind Type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The kind Constraint is the kind of classes and other type constraints. The special thing about types of kind Constraint is that  * They are displayed with double arrow:@@ -2876,6 +3228,18 @@     C a ~ (a -> a) so on the left we have Constraint, and on the right we have Type. See #7451.++Because we treat Constraint/Type differently during and after type inference,+GHC has two notions of equality that differ in whether they equate+Constraint/Type or not:++* GHC.Tc.Utils.TcType.tcEqType implements typechecker equality (see+  Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType),+  which treats Constraint and Type as distinct. This is used during type+  inference. See #11715 for issues that arise from this.+* GHC.Core.TyCo.Rep.eqType implements definitional equality (see+  Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep), which treats+  Constraint and Type as equal. This is used after type inference.  Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with distinct uniques, they are treated as equal at all times except

GHC/Core/Type.hs-boot view

@@ -12,6 +12,8 @@  mkAppTy    :: Type -> Type -> Type mkCastTy   :: Type -> Coercion -> Type+mkTyConTy  :: TyCon -> Type+mkTyConApp :: TyCon -> [Type] -> Type piResultTy :: HasDebugCallStack => Type -> Type -> Type  coreView :: Type -> Maybe Type@@ -19,6 +21,7 @@ isRuntimeRepTy :: Type -> Bool isMultiplicityTy :: Type -> Bool isLiftedTypeKind :: Type -> Bool+tYPE :: Type -> Type  splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) tyConAppTyCon_maybe :: Type -> Maybe TyCon

GHC/Core/Unfold.hs view

@@ -16,19 +16,17 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module GHC.Core.Unfold (         Unfolding, UnfoldingGuidance,   -- Abstract types -        noUnfolding,-        mkUnfolding, mkCoreUnfolding,-        mkFinalUnfolding, mkSimpleUnfolding, mkWorkerUnfolding,-        mkInlineUnfolding, mkInlineUnfoldingWithArity,-        mkInlinableUnfolding, mkWwInlineRule,-        mkCompulsoryUnfolding, mkDFunUnfolding,-        specUnfolding,+        UnfoldingOpts (..), defaultUnfoldingOpts,+        updateCreationThreshold, updateUseThreshold,+        updateFunAppDiscount, updateDictDiscount,+        updateVeryAggressive, updateCaseScaling, updateCaseThreshold,          ArgSummary(..), @@ -36,10 +34,7 @@         certainlyWillInline, smallEnoughToInline,          callSiteInline, CallCtxt(..),--        -- Reexport from GHC.Core.Subst (it only live there so it can be used-        -- by the Very Simple Optimiser)-        exprIsConApp_maybe, exprIsLiteral_maybe+        calcUnfoldingGuidance     ) where  #include "HsVersions.h"@@ -47,13 +42,11 @@ import GHC.Prelude  import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Core-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-import GHC.Core.SimpleOpt-import GHC.Core.Opt.Arity   ( manifestArity ) import GHC.Core.Utils import GHC.Types.Id-import GHC.Types.Demand ( StrictSig, isDeadEndSig )+import GHC.Types.Demand ( isDeadEndSig ) import GHC.Core.DataCon import GHC.Types.Literal import GHC.Builtin.PrimOps@@ -63,284 +56,95 @@ import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Data.Bag+import GHC.Utils.Logger import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.ForeignCall import GHC.Types.Name-import GHC.Utils.Error+import GHC.Types.Tickish  import qualified Data.ByteString as BS-import Data.List+import Data.List (isPrefixOf) -{--************************************************************************-*                                                                      *-\subsection{Making unfoldings}-*                                                                      *-************************************************************************--} -mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding--- "Final" in the sense that this is a GlobalId that will not be further--- simplified; so the unfolding should be occurrence-analysed-mkFinalUnfolding dflags src strict_sig expr-  = mkUnfolding dflags src-                True {- Top level -}-                (isDeadEndSig strict_sig)-                expr+-- | Unfolding options+data UnfoldingOpts = UnfoldingOpts+   { unfoldingCreationThreshold :: !Int+      -- ^ Threshold above which unfoldings are not *created* -mkCompulsoryUnfolding :: CoreExpr -> Unfolding-mkCompulsoryUnfolding expr         -- Used for things that absolutely must be unfolded-  = mkCoreUnfolding InlineCompulsory True-                    (simpleOptExpr unsafeGlobalDynFlags expr)-                    (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter-                             , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })+   , unfoldingUseThreshold :: !Int+      -- ^ Threshold above which unfoldings are not *inlined* +   , unfoldingFunAppDiscount :: !Int+      -- ^ Discount for lambdas that are used (applied) --- Note [Top-level flag on inline rules]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Slight hack: note that mk_inline_rules conservatively sets the--- top-level flag to True.  It gets set more accurately by the simplifier--- Simplify.simplUnfolding.+   , unfoldingDictDiscount :: !Int+      -- ^ Discount for dictionaries -mkSimpleUnfolding :: DynFlags -> CoreExpr -> Unfolding-mkSimpleUnfolding dflags rhs-  = mkUnfolding dflags InlineRhs False False rhs+   , unfoldingVeryAggressive :: !Bool+      -- ^ Force inlining in many more cases -mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding-mkDFunUnfolding bndrs con ops-  = DFunUnfolding { df_bndrs = bndrs-                  , df_con = con-                  , df_args = map occurAnalyseExpr ops }-                  -- See Note [Occurrence analysis of unfoldings]+      -- Don't consider depth up to x+   , unfoldingCaseThreshold :: !Int -mkWwInlineRule :: DynFlags -> CoreExpr -> Arity -> Unfolding-mkWwInlineRule dflags expr arity-  = mkCoreUnfolding InlineStable True-                   (simpleOptExpr dflags expr)-                   (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk-                            , ug_boring_ok = boringCxtNotOk })+      -- Penalize depth with 1/x+   , unfoldingCaseScaling :: !Int+   } -mkWorkerUnfolding :: DynFlags -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding--- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap-mkWorkerUnfolding dflags work_fn-                  (CoreUnfolding { uf_src = src, uf_tmpl = tmpl-                                 , uf_is_top = top_lvl })-  | isStableSource src-  = mkCoreUnfolding src top_lvl new_tmpl guidance-  where-    new_tmpl = simpleOptExpr dflags (work_fn tmpl)-    guidance = calcUnfoldingGuidance dflags False new_tmpl+defaultUnfoldingOpts :: UnfoldingOpts+defaultUnfoldingOpts = UnfoldingOpts+   { unfoldingCreationThreshold = 750+      -- The unfoldingCreationThreshold threshold must be reasonably high+      -- to take account of possible discounts.+      -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to+      -- inline into Csg.calc (The unfolding for sqr never makes it+      -- into the interface file.) -mkWorkerUnfolding _ _ _ = noUnfolding+   , unfoldingUseThreshold   = 90+      -- Last adjusted upwards in #18282, when I reduced+      -- the result discount for constructors. --- | Make an unfolding that may be used unsaturated--- (ug_unsat_ok = unSaturatedOk) and that is reported as having its--- manifest arity (the number of outer lambdas applications will--- resolve before doing any work).-mkInlineUnfolding :: CoreExpr -> Unfolding-mkInlineUnfolding expr-  = mkCoreUnfolding InlineStable-                    True         -- Note [Top-level flag on inline rules]-                    expr' guide-  where-    expr' = simpleOptExpr unsafeGlobalDynFlags expr-    guide = UnfWhen { ug_arity = manifestArity expr'-                    , ug_unsat_ok = unSaturatedOk-                    , ug_boring_ok = boring_ok }-    boring_ok = inlineBoringOk expr'+   , unfoldingFunAppDiscount = 60+      -- Be fairly keen to inline a function if that means+      -- we'll be able to pick the right method from a dictionary --- | Make an unfolding that will be used once the RHS has been saturated--- to the given arity.-mkInlineUnfoldingWithArity :: Arity -> CoreExpr -> Unfolding-mkInlineUnfoldingWithArity arity expr-  = mkCoreUnfolding InlineStable-                    True         -- Note [Top-level flag on inline rules]-                    expr' guide-  where-    expr' = simpleOptExpr unsafeGlobalDynFlags expr-    guide = UnfWhen { ug_arity = arity-                    , ug_unsat_ok = needSaturated-                    , ug_boring_ok = boring_ok }-    -- See Note [INLINE pragmas and boring contexts] as to why we need to look-    -- at the arity here.-    boring_ok | arity == 0 = True-              | otherwise  = inlineBoringOk expr'+   , unfoldingDictDiscount   = 30+      -- Be fairly keen to inline a function if that means+      -- we'll be able to pick the right method from a dictionary -mkInlinableUnfolding :: DynFlags -> CoreExpr -> Unfolding-mkInlinableUnfolding dflags expr-  = mkUnfolding dflags InlineStable False False expr'-  where-    expr' = simpleOptExpr dflags expr+   , unfoldingVeryAggressive = False -specUnfolding :: DynFlags-              -> [Var] -> (CoreExpr -> CoreExpr)-              -> [CoreArg]   -- LHS arguments in the RULE-              -> Unfolding -> Unfolding--- See Note [Specialising unfoldings]--- specUnfolding spec_bndrs spec_args unf---   = \spec_bndrs. unf spec_args----specUnfolding dflags spec_bndrs spec_app rule_lhs_args-              df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })-  = ASSERT2( rule_lhs_args `equalLength` old_bndrs-           , ppr df $$ ppr rule_lhs_args )-           -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise-    mkDFunUnfolding spec_bndrs con (map spec_arg args)-      -- For DFunUnfoldings we transform-      --       \obs. MkD <op1> ... <opn>-      -- to-      --       \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>-  where-    spec_arg arg = simpleOptExpr dflags $-                   spec_app (mkLams old_bndrs arg)-                   -- The beta-redexes created by spec_app will be-                   -- simplified away by simplOptExpr+      -- Only apply scaling once we are deeper than threshold cases+      -- in an RHS.+   , unfoldingCaseThreshold = 2 -specUnfolding dflags spec_bndrs spec_app rule_lhs_args-              (CoreUnfolding { uf_src = src, uf_tmpl = tmpl-                             , uf_is_top = top_lvl-                             , uf_guidance = old_guidance })- | isStableSource src  -- See Note [Specialising unfoldings]- , UnfWhen { ug_arity     = old_arity } <- old_guidance- = mkCoreUnfolding src top_lvl new_tmpl-                   (old_guidance { ug_arity = old_arity - arity_decrease })- where-   new_tmpl = simpleOptExpr dflags $-              mkLams spec_bndrs    $-              spec_app tmpl  -- The beta-redexes created by spec_app-                             -- will besimplified away by simplOptExpr-   arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs+      -- Penalize depth with (size*depth)/scaling+   , unfoldingCaseScaling = 30+   } +-- Helpers for "GHC.Driver.Session" -specUnfolding _ _ _ _ _ = noUnfolding+updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCreationThreshold n opts = opts { unfoldingCreationThreshold = n } -{- Note [Specialising unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we specialise a function for some given type-class arguments, we use-specUnfolding to specialise its unfolding.  Some important points:+updateUseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateUseThreshold n opts = opts { unfoldingUseThreshold = n } -* If the original function has a DFunUnfolding, the specialised one-  must do so too!  Otherwise we lose the magic rules that make it-  interact with ClassOps+updateFunAppDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts+updateFunAppDiscount n opts = opts { unfoldingFunAppDiscount = n } -* There is a bit of hack for INLINABLE functions:-     f :: Ord a => ....-     f = <big-rhs>-     {- INLINABLE f #-}-  Now if we specialise f, should the specialised version still have-  an INLINABLE pragma?  If it does, we'll capture a specialised copy-  of <big-rhs> as its unfolding, and that probably won't inline.  But-  if we don't, the specialised version of <big-rhs> might be small-  enough to inline at a call site. This happens with Control.Monad.liftM3,-  and can cause a lot more allocation as a result (nofib n-body shows this).+updateDictDiscount :: Int -> UnfoldingOpts -> UnfoldingOpts+updateDictDiscount n opts = opts { unfoldingDictDiscount = n } -  Moreover, keeping the INLINABLE thing isn't much help, because-  the specialised function (probably) isn't overloaded any more.+updateVeryAggressive :: Bool -> UnfoldingOpts -> UnfoldingOpts+updateVeryAggressive n opts = opts { unfoldingVeryAggressive = n } -  Conclusion: drop the INLINEALE pragma.  In practice what this means is:-     if a stable unfolding has UnfoldingGuidance of UnfWhen,-        we keep it (so the specialised thing too will always inline)-     if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs-        (which arises from INLINABLE), we discard it -Note [Honour INLINE on 0-ary bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--   x = <expensive>-   {-# INLINE x #-}--   f y = ...x...--The semantics of an INLINE pragma is--  inline x at every call site, provided it is saturated;-  that is, applied to at least as many arguments as appear-  on the LHS of the Haskell source definition.--(This source-code-derived arity is stored in the `ug_arity` field of-the `UnfoldingGuidance`.)--In the example, x's ug_arity is 0, so we should inline it at every use-site.  It's rare to have such an INLINE pragma (usually INLINE Is on-functions), but it's occasionally very important (#15578, #15519).-In #15519 we had something like-   x = case (g a b) of I# r -> T r-   {-# INLINE x #-}-   f y = ...(h x)....--where h is strict.  So we got-   f y = ...(case g a b of I# r -> h (T r))...--and that in turn allowed SpecConstr to ramp up performance.--How do we deliver on this?  By adjusting the ug_boring_ok-flag in mkInlineUnfoldingWithArity; see-Note [INLINE pragmas and boring contexts]--NB: there is a real risk that full laziness will float it right back-out again. Consider again-  x = factorial 200-  {-# INLINE x #-}-  f y = ...x...--After inlining we get-  f y = ...(factorial 200)...--but it's entirely possible that full laziness will do-  lvl23 = factorial 200-  f y = ...lvl23...--That's a problem for another day.--Note [INLINE pragmas and boring contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An INLINE pragma uses mkInlineUnfoldingWithArity to build the-unfolding.  That sets the ug_boring_ok flag to False if the function-is not tiny (inlineBoringOK), so that even INLINE functions are not-inlined in an utterly boring context.  E.g.-     \x y. Just (f y x)-Nothing is gained by inlining f here, even if it has an INLINE-pragma.--But for 0-ary bindings, we want to inline regardless; see-Note [Honour INLINE on 0-ary bindings].--I'm a bit worried that it's possible for the same kind of problem-to arise for non-0-ary functions too, but let's wait and see.--}--mkUnfolding :: DynFlags -> UnfoldingSource-            -> Bool       -- Is top-level-            -> Bool       -- Definitely a bottoming binding-                          -- (only relevant for top-level bindings)-            -> CoreExpr-            -> Unfolding--- Calculates unfolding guidance--- Occurrence-analyses the expression before capturing it-mkUnfolding dflags src top_lvl is_bottoming expr-  = mkCoreUnfolding src top_lvl expr guidance-  where-    is_top_bottoming = top_lvl && is_bottoming-    guidance         = calcUnfoldingGuidance dflags is_top_bottoming expr-        -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!-        -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]--mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr-                -> UnfoldingGuidance -> Unfolding--- Occurrence-analyses the expression before capturing it-mkCoreUnfolding src top_lvl expr guidance-  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,-                      -- See Note [Occurrence analysis of unfoldings]-                    uf_src          = src,-                    uf_is_top       = top_lvl,-                    uf_is_value     = exprIsHNF        expr,-                    uf_is_conlike   = exprIsConLike    expr,-                    uf_is_work_free = exprIsWorkFree   expr,-                    uf_expandable   = exprIsExpandable expr,-                    uf_guidance     = guidance }+updateCaseThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseThreshold n opts = opts { unfoldingCaseThreshold = n } +updateCaseScaling :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseScaling n opts = opts { unfoldingCaseScaling = n }  {- Note [Occurrence analysis of unfoldings]@@ -412,21 +216,21 @@                         , exprIsTrivial a  = go (credit-1) f     go credit (Tick _ e)                   = go credit e -- dubious     go credit (Cast e _)                   = go credit e-    go credit (Case scrut _ _ [(_,_,rhs)]) -- See Note [Inline unsafeCoerce]+    go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce]       | isUnsafeEqualityProof scrut        = go credit rhs     go _      (Var {})                     = boringCxtOk     go _      _                            = boringCxtNotOk  calcUnfoldingGuidance-        :: DynFlags+        :: UnfoldingOpts         -> Bool          -- Definitely a top-level, bottoming binding         -> CoreExpr      -- Expression to look at         -> UnfoldingGuidance-calcUnfoldingGuidance dflags is_top_bottoming (Tick t expr)+calcUnfoldingGuidance opts is_top_bottoming (Tick t expr)   | not (tickishIsCode t)  -- non-code ticks don't matter for unfolding-  = calcUnfoldingGuidance dflags is_top_bottoming expr-calcUnfoldingGuidance dflags is_top_bottoming expr-  = case sizeExpr dflags bOMB_OUT_SIZE val_bndrs body of+  = calcUnfoldingGuidance opts is_top_bottoming expr+calcUnfoldingGuidance opts is_top_bottoming expr+  = case sizeExpr opts bOMB_OUT_SIZE val_bndrs body of       TooBig -> UnfNever       SizeIs size cased_bndrs scrut_discount         | uncondInline expr n_val_bndrs size@@ -444,7 +248,7 @@    where     (bndrs, body) = collectBinders expr-    bOMB_OUT_SIZE = ufCreationThreshold dflags+    bOMB_OUT_SIZE = unfoldingCreationThreshold opts            -- Bomb out if size gets bigger than this     val_bndrs   = filter isId bndrs     n_val_bndrs = length val_bndrs@@ -603,7 +407,7 @@   | arity > 0 = size <= 10 * (arity + 1) -- See Note [INLINE for small functions] (1)   | otherwise = exprIsTrivial rhs        -- See Note [INLINE for small functions] (4) -sizeExpr :: DynFlags+sizeExpr :: UnfoldingOpts          -> Int             -- Bomb out if it gets bigger than this          -> [Id]            -- Arguments; we're interested in which of these                             -- get case'd@@ -612,7 +416,9 @@  -- Note [Computing the size of an expression] -sizeExpr dflags bOMB_OUT_SIZE top_args expr+-- Forcing bOMB_OUT_SIZE early prevents repeated+-- unboxing of the Int argument.+sizeExpr opts !bOMB_OUT_SIZE top_args expr   = size_up expr   where     size_up (Cast e _) = size_up e@@ -631,7 +437,7 @@                         size_up_app fun [arg] (if isRealWorldExpr arg then 1 else 0)      size_up (Lam b e)-      | isId b && not (isRealWorldId b) = lamScrutDiscount dflags (size_up e `addSizeN` 10)+      | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)       | otherwise = size_up e      size_up (Let (NonRec binder rhs) body)@@ -752,11 +558,11 @@            FCallId _        -> sizeN (callSize (length val_args) voids)            DataConWorkId dc -> conSize    dc (length val_args)            PrimOpId op      -> primOpSize op (length val_args)-           ClassOpId _      -> classOpSize dflags top_args val_args-           _                -> funSize dflags top_args fun (length val_args) voids+           ClassOpId _      -> classOpSize opts top_args val_args+           _                -> funSize opts top_args fun (length val_args) voids      -------------    size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10+    size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10         -- Don't charge for args, so that wrappers look cheap         -- (See comments about wrappers with Case)         --@@ -817,11 +623,11 @@                       -- Key point: if  x |-> 4, then x must inline unconditionally                       --            (eg via case binding) -classOpSize :: DynFlags -> [Id] -> [CoreExpr] -> ExprSize+classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize -- See Note [Conlike is interesting] classOpSize _ _ []   = sizeZero-classOpSize dflags top_args (arg1 : other_args)+classOpSize opts top_args (arg1 : other_args)   = SizeIs size arg_discount 0   where     size = 20 + (10 * length other_args)@@ -830,7 +636,7 @@     -- The actual discount is rather arbitrarily chosen     arg_discount = case arg1 of                      Var dict | dict `elem` top_args-                              -> unitBag (dict, ufDictDiscount dflags)+                              -> unitBag (dict, unfoldingDictDiscount opts)                      _other   -> emptyBag  -- | The size of a function call@@ -854,10 +660,10 @@   -- spectral/puzzle. TODO Perhaps adjusting the default threshold would be a   -- better solution? -funSize :: DynFlags -> [Id] -> Id -> Int -> Int -> ExprSize+funSize :: UnfoldingOpts -> [Id] -> Id -> Int -> Int -> ExprSize -- Size for functions that are not constructors or primops -- Note [Function applications]-funSize dflags top_args fun n_val_args voids+funSize opts top_args fun n_val_args voids   | fun `hasKey` buildIdKey   = buildSize   | fun `hasKey` augmentIdKey = augmentSize   | otherwise = SizeIs size arg_discount res_discount@@ -872,12 +678,12 @@         --                  DISCOUNTS         --  See Note [Function and non-function discounts]     arg_discount | some_val_args && fun `elem` top_args-                 = unitBag (fun, ufFunAppDiscount dflags)+                 = unitBag (fun, unfoldingFunAppDiscount opts)                  | otherwise = emptyBag         -- If the function is an argument and is applied         -- to some values, give it an arg-discount -    res_discount | idArity fun > n_val_args = ufFunAppDiscount dflags+    res_discount | idArity fun > n_val_args = unfoldingFunAppDiscount opts                  | otherwise                = 0         -- If the function is partially applied, show a result discount -- XXX maybe behave like ConSize for eval'd variable@@ -887,7 +693,7 @@   | n_val_args == 0 = SizeIs 0 emptyBag 10    -- Like variables  -- See Note [Unboxed tuple size and result discount]-  | isUnboxedTupleCon dc = SizeIs 0 emptyBag 10+  | isUnboxedTupleDataCon dc = SizeIs 0 emptyBag 10  -- See Note [Constructor size and result discount]   | otherwise = SizeIs 10 emptyBag 10@@ -928,8 +734,7 @@ discount: (10 * (10 + n_val_args)), and said it was an "unambiguous win", but its terribly dangerous because a function with many many case branches, each finishing with a constructor, can have an-arbitrarily large discount.  This led to terrible code bloat: see-#6099.+arbitrarily large discount.  This led to terrible code bloat: see #6099.  Note [Unboxed tuple size and result discount] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1009,8 +814,8 @@         -- e plus ys. The -2 accounts for the \cn  -- When we return a lambda, give a discount if it's used (applied)-lamScrutDiscount :: DynFlags -> ExprSize -> ExprSize-lamScrutDiscount dflags (SizeIs n vs _) = SizeIs n vs (ufFunAppDiscount dflags)+lamScrutDiscount :: UnfoldingOpts -> ExprSize -> ExprSize+lamScrutDiscount opts (SizeIs n vs _) = SizeIs n vs (unfoldingFunAppDiscount opts) lamScrutDiscount _      TooBig          = TooBig  {-@@ -1025,30 +830,27 @@  Note [Discounts and thresholds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Constants for discounts and thesholds are defined in "GHC.Driver.Session",-all of form ufXxxx.   They are: -ufCreationThreshold+Constants for discounts and thresholds are defined in 'UnfoldingOpts'. They are:++unfoldingCreationThreshold      At a definition site, if the unfolding is bigger than this, we      may discard it altogether -ufUseThreshold+unfoldingUseThreshold      At a call site, if the unfolding, less discounts, is smaller than      this, then it's small enough inline -ufDictDiscount+unfoldingDictDiscount      The discount for each occurrence of a dictionary argument      as an argument of a class method.  Should be pretty small      else big functions may get inlined -ufFunAppDiscount+unfoldingFunAppDiscount      Discount for a function argument that is applied.  Quite      large, because if we inline we avoid the higher-order call. -ufDearOp-     The size of a foreign call or not-dupable PrimOp--ufVeryAggressive+unfoldingVeryAggressive      If True, the compiler ignores all the thresholds and inlines very      aggressively. It still adheres to arity, simplifier phase control and      loop breakers.@@ -1134,32 +936,42 @@ actual arguments. -} -couldBeSmallEnoughToInline :: DynFlags -> Int -> CoreExpr -> Bool-couldBeSmallEnoughToInline dflags threshold rhs-  = case sizeExpr dflags threshold [] body of+couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool+couldBeSmallEnoughToInline opts threshold rhs+  = case sizeExpr opts threshold [] body of        TooBig -> False        _      -> True   where     (_, body) = collectBinders rhs  -----------------smallEnoughToInline :: DynFlags -> Unfolding -> Bool-smallEnoughToInline dflags (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})-  = size <= ufUseThreshold dflags+smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool+smallEnoughToInline opts (CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_size = size}})+  = size <= unfoldingUseThreshold opts smallEnoughToInline _ _   = False  ---------------- -certainlyWillInline :: DynFlags -> IdInfo -> Maybe Unfolding+certainlyWillInline :: UnfoldingOpts -> IdInfo -> Maybe Unfolding -- ^ Sees if the unfolding is pretty certain to inline. -- If so, return a *stable* unfolding for it, that will always inline.-certainlyWillInline dflags fn_info-  = case unfoldingInfo fn_info of-      CoreUnfolding { uf_tmpl = e, uf_guidance = g }-        | loop_breaker -> Nothing      -- Won't inline, so try w/w-        | noinline     -> Nothing      -- See Note [Worker-wrapper for NOINLINE functions]-        | otherwise    -> do_cunf e g  -- Depends on size, so look at that+certainlyWillInline opts fn_info+  = case fn_unf of+      CoreUnfolding { uf_tmpl = expr, uf_guidance = guidance, uf_src = src }+        | loop_breaker -> Nothing       -- Won't inline, so try w/w+        | noinline     -> Nothing       -- See Note [Worker-wrapper for NOINLINE functions]+        | otherwise+        -> case guidance of+             UnfNever  -> Nothing+             UnfWhen {} -> Just (fn_unf { uf_src = src' })+                             -- INLINE functions have UnfWhen+             UnfIfGoodArgs { ug_size = size, ug_args = args }+               -> do_cunf expr size args src'+        where+          src' = case src of+                   InlineRhs -> InlineStable+                   _         -> src  -- Do not change InlineCompulsory!        DFunUnfolding {} -> Just fn_unf  -- Don't w/w DFuns; it never makes sense                                        -- to do so, and even if it is currently a@@ -1172,25 +984,20 @@     noinline     = inlinePragmaSpec (inlinePragInfo fn_info) == NoInline     fn_unf       = unfoldingInfo fn_info -    do_cunf :: CoreExpr -> UnfoldingGuidance -> Maybe Unfolding-    do_cunf _ UnfNever     = Nothing-    do_cunf _ (UnfWhen {}) = Just (fn_unf { uf_src = InlineStable })-                             -- INLINE functions have UnfWhen-         -- The UnfIfGoodArgs case seems important.  If we w/w small functions         -- binary sizes go up by 10%!  (This is with SplitObjs.)         -- I'm not totally sure why.         -- INLINABLE functions come via this path         --    See Note [certainlyWillInline: INLINABLE]-    do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args })+    do_cunf expr size args src'       | arityInfo fn_info > 0  -- See Note [certainlyWillInline: be careful of thunks]       , not (isDeadEndSig (strictnessInfo fn_info))               -- Do not unconditionally inline a bottoming functions even if               -- it seems smallish. We've carefully lifted it out to top level,               -- so we don't want to re-inline it.       , let unf_arity = length args-      , size - (10 * (unf_arity + 1)) <= ufUseThreshold dflags-      = Just (fn_unf { uf_src      = InlineStable+      , size - (10 * (unf_arity + 1)) <= unfoldingUseThreshold opts+      = Just (fn_unf { uf_src      = src'                      , uf_guidance = UnfWhen { ug_arity     = unf_arity                                              , ug_unsat_ok  = unSaturatedOk                                              , ug_boring_ok = inlineBoringOk expr } })@@ -1251,7 +1058,9 @@ StrictAnal.addStrictnessInfoToTopId -} -callSiteInline :: DynFlags+callSiteInline :: Logger+               -> DynFlags+               -> Int                   -- Case depth                -> Id                    -- The Id                -> Bool                  -- True <=> unfolding is active                -> Bool                  -- True if there are no arguments at all (incl type args)@@ -1294,7 +1103,7 @@   ppr DiscArgCtxt = text "DiscArgCtxt"   ppr RuleArgCtxt = text "RuleArgCtxt" -callSiteInline dflags id active_unfolding lone_variable arg_infos cont_info+callSiteInline logger dflags !case_depth id active_unfolding lone_variable arg_infos cont_info   = case idUnfolding id of       -- idUnfolding checks for loop-breakers, returning NoUnfolding       -- Things with an INLINE pragma may have an unfolding *and*@@ -1302,26 +1111,26 @@         CoreUnfolding { uf_tmpl = unf_template                       , uf_is_work_free = is_wf                       , uf_guidance = guidance, uf_expandable = is_exp }-          | active_unfolding -> tryUnfolding dflags id lone_variable+          | active_unfolding -> tryUnfolding logger dflags case_depth id lone_variable                                     arg_infos cont_info unf_template                                     is_wf is_exp guidance-          | otherwise -> traceInline dflags id "Inactive unfolding:" (ppr id) Nothing+          | otherwise -> traceInline logger dflags id "Inactive unfolding:" (ppr id) Nothing         NoUnfolding      -> Nothing         BootUnfolding    -> Nothing         OtherCon {}      -> Nothing         DFunUnfolding {} -> Nothing     -- Never unfold a DFun  -- | Report the inlining of an identifier's RHS to the user, if requested.-traceInline :: DynFlags -> Id -> String -> SDoc -> a -> a-traceInline dflags inline_id str doc result+traceInline :: Logger -> DynFlags -> Id -> String -> SDoc -> a -> a+traceInline logger dflags inline_id str doc result   -- We take care to ensure that doc is used in only one branch, ensuring that   -- the simplifier can push its allocation into the branch. See Note [INLINE   -- conditional tracing utilities].-  | enable    = traceAction dflags str doc result+  | enable    = putTraceMsg logger dflags str doc result   | otherwise = result   where     enable-      | dopt Opt_D_dump_verbose_inlinings dflags+      | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags       = True       | Just prefix <- inlineCheck dflags       = prefix `isPrefixOf` occNameString (getOccName inline_id)@@ -1329,40 +1138,144 @@       = False {-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities] -tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt+{- Note [Avoid inlining into deeply nested cases]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a function f like this:++  f arg1 arg2 =+    case ...+      ... -> g arg1+      ... -> g arg2++This function is small. So should be safe to inline.+However sometimes this doesn't quite work out like that.+Consider this code:++f1 arg1 arg2 ... = ...+    case _foo of+      alt1 -> ... f2 arg1 ...+      alt2 -> ... f2 arg2 ...++f2 arg1 arg2 ... = ...+    case _foo of+      alt1 -> ... f3 arg1 ...+      alt2 -> ... f3 arg2 ...++f3 arg1 arg2 ... = ...++... repeats up to n times. And then f1 is+applied to some arguments:++foo = ... f1 <interestingArgs> ...++Initially f2..fn are not interesting to inline so we don't.+However we see that f1 is applied to interesting args.+So it's an obvious choice to inline those:++foo =+    ...+      case _foo of+        alt1 -> ... f2 <interestingArg> ...+        alt2 -> ... f2 <interestingArg> ...++As a result we go and inline f2 both mentions of f2 in turn are now applied to interesting+arguments and f2 is small:++foo =+    ...+      case _foo of+        alt1 -> ... case _foo of+            alt1 -> ... f3 <interestingArg> ...+            alt2 -> ... f3 <interestingArg> ...++        alt2 -> ... case _foo of+            alt1 -> ... f3 <interestingArg> ...+            alt2 -> ... f3 <interestingArg> ...++The same thing happens for each binding up to f_n, duplicating the amount of inlining+done in each step. Until at some point we are either done or run out of simplifier+ticks/RAM. This pattern happened #18730.++To combat this we introduce one more heuristic when weighing inlining decision.+We keep track of a "case-depth". Which increases each time we look inside a case+expression with more than one alternative.++We then apply a penalty to inlinings based on the case-depth at which they would+be inlined. Bounding the number of inlinings in such a scenario.++The heuristic can be tuned in two ways:++* We can ignore the first n levels of case nestings for inlining decisions using+  -funfolding-case-threshold.+* The penalty grows linear with the depth. It's computed as size*(depth-threshold)/scaling.+  Scaling can be set with -funfolding-case-scaling.++Some guidance on setting these defaults:++* A low treshold (<= 2) is needed to prevent exponential cases from spiraling out of+  control. We picked 2 for no particular reason.+* Scaling the penalty by any more than 30 means the reproducer from+  T18730 won't compile even with reasonably small values of n. Instead+  it will run out of runs/ticks. This means to positively affect the reproducer+  a scaling <= 30 is required.+* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks.+  (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps)+* A scaling of >= 25 showed no regressions on nofib. However it showed a number of+  (small) regression for compiler perf benchmarks.++The end result is that we are settling for a scaling of 30, with a threshold of 2.+This gives us minimal compiler perf regressions. No nofib runtime regressions and+will still avoid this pattern sometimes. This is a "safe" default, where we err on+the side of compiler blowup instead of risking runtime regressions.++For cases where the default falls short the flag can be changed to allow more/less inlining as+needed on a per-module basis.++-}++tryUnfolding :: Logger -> DynFlags -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt              -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance              -> Maybe CoreExpr-tryUnfolding dflags id lone_variable+tryUnfolding logger dflags !case_depth id lone_variable              arg_infos cont_info unf_template              is_wf is_exp guidance  = case guidance of-     UnfNever -> traceInline dflags id str (text "UnfNever") Nothing+     UnfNever -> traceInline logger dflags id str (text "UnfNever") Nothing       UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }-        | enough_args && (boring_ok || some_benefit || ufVeryAggressive dflags)+        | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive uf_opts)                 -- See Note [INLINE for small functions (3)]-        -> traceInline dflags id str (mk_doc some_benefit empty True) (Just unf_template)+        -> traceInline logger dflags id str (mk_doc some_benefit empty True) (Just unf_template)         | otherwise-        -> traceInline dflags id str (mk_doc some_benefit empty False) Nothing+        -> traceInline logger dflags id str (mk_doc some_benefit empty False) Nothing         where           some_benefit = calc_some_benefit uf_arity           enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)       UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }-        | ufVeryAggressive dflags-        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)+        | unfoldingVeryAggressive uf_opts+        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)         | is_wf && some_benefit && small_enough-        -> traceInline dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)+        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc True) (Just unf_template)         | otherwise-        -> traceInline dflags id str (mk_doc some_benefit extra_doc False) Nothing+        -> traceInline logger dflags id str (mk_doc some_benefit extra_doc False) Nothing         where           some_benefit = calc_some_benefit (length arg_discounts)-          extra_doc = text "discounted size =" <+> int discounted_size-          discounted_size = size - discount-          small_enough = discounted_size <= ufUseThreshold dflags+          extra_doc = vcat [ text "case depth =" <+> int case_depth+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "discounted size =" <+> int adjusted_size ]+          -- See Note [Avoid inlining into deeply nested cases]+          depth_treshold = unfoldingCaseThreshold uf_opts+          depth_scaling = unfoldingCaseScaling uf_opts+          depth_penalty | case_depth <= depth_treshold = 0+                        | otherwise       = (size * (case_depth - depth_treshold)) `div` depth_scaling+          adjusted_size = size + depth_penalty - discount+          small_enough = adjusted_size <= unfoldingUseThreshold uf_opts           discount = computeDiscount arg_discounts res_discount arg_infos cont_info    where+    uf_opts = unfoldingOpts dflags     mk_doc some_benefit extra_doc yes_or_no       = vcat [ text "arg infos" <+> ppr arg_infos              , text "interesting continuation" <+> ppr cont_info@@ -1373,7 +1286,8 @@              , extra_doc              , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"] -    str = "Considering inlining: " ++ showSDocDump dflags (ppr id)+    ctx = initSDocContext dflags defaultDumpStyle+    str = "Considering inlining: " ++ showSDocDump ctx (ppr id)     n_val_args = length arg_infos             -- some_benefit is used when the RHS is small enough

GHC/Core/Unfold.hs-boot view

@@ -1,16 +1,15 @@-module GHC.Core.Unfold (-        mkUnfolding, mkInlineUnfolding-    ) where+module GHC.Core.Unfold where  import GHC.Prelude-import GHC.Core-import GHC.Driver.Session -mkInlineUnfolding :: CoreExpr -> Unfolding+data UnfoldingOpts -mkUnfolding :: DynFlags-            -> UnfoldingSource-            -> Bool-            -> Bool-            -> CoreExpr-            -> Unfolding+defaultUnfoldingOpts :: UnfoldingOpts++updateCreationThreshold :: Int -> UnfoldingOpts -> UnfoldingOpts+updateUseThreshold      :: Int -> UnfoldingOpts -> UnfoldingOpts+updateFunAppDiscount    :: Int -> UnfoldingOpts -> UnfoldingOpts+updateDictDiscount      :: Int -> UnfoldingOpts -> UnfoldingOpts+updateVeryAggressive    :: Bool -> UnfoldingOpts -> UnfoldingOpts+updateCaseThreshold     :: Int -> UnfoldingOpts -> UnfoldingOpts+updateCaseScaling       :: Int -> UnfoldingOpts -> UnfoldingOpts

+ GHC/Core/Unfold/Make.hs view

@@ -0,0 +1,311 @@+{-# LANGUAGE CPP #-}++-- | Unfolding creation+module GHC.Core.Unfold.Make+   ( noUnfolding+   , mkUnfolding+   , mkCoreUnfolding+   , mkFinalUnfolding+   , mkSimpleUnfolding+   , mkWorkerUnfolding+   , mkInlineUnfolding+   , mkInlineUnfoldingWithArity+   , mkInlinableUnfolding+   , mkWwInlineRule+   , mkCompulsoryUnfolding+   , mkCompulsoryUnfolding'+   , mkDFunUnfolding+   , specUnfolding+   )+where++#include "HsVersions.h"++import GHC.Prelude+import GHC.Core+import GHC.Core.Unfold+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.Opt.Arity   ( manifestArity )+import GHC.Core.DataCon+import GHC.Core.Utils+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Demand ( StrictSig, isDeadEndSig )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++-- the very simple optimiser is used to optimise unfoldings+import {-# SOURCE #-} GHC.Core.SimpleOpt++++mkFinalUnfolding :: UnfoldingOpts -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfolding+-- "Final" in the sense that this is a GlobalId that will not be further+-- simplified; so the unfolding should be occurrence-analysed+mkFinalUnfolding opts src strict_sig expr+  = mkUnfolding opts src+                True {- Top level -}+                (isDeadEndSig strict_sig)+                expr++-- | Used for things that absolutely must be unfolded+mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding+mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr)++-- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed+-- on the unfolding.+mkCompulsoryUnfolding' :: CoreExpr -> Unfolding+mkCompulsoryUnfolding' expr+  = mkCoreUnfolding InlineCompulsory True+                    expr+                    (UnfWhen { ug_arity = 0    -- Arity of unfolding doesn't matter+                             , ug_unsat_ok = unSaturatedOk, ug_boring_ok = boringCxtOk })++-- Note [Top-level flag on inline rules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Slight hack: note that mk_inline_rules conservatively sets the+-- top-level flag to True.  It gets set more accurately by the simplifier+-- Simplify.simplUnfolding.++mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding+mkSimpleUnfolding opts rhs+  = mkUnfolding opts InlineRhs False False rhs++mkDFunUnfolding :: [Var] -> DataCon -> [CoreExpr] -> Unfolding+mkDFunUnfolding bndrs con ops+  = DFunUnfolding { df_bndrs = bndrs+                  , df_con = con+                  , df_args = map occurAnalyseExpr ops }+                  -- See Note [Occurrence analysis of unfoldings]++mkWwInlineRule :: SimpleOpts -> CoreExpr -> Arity -> Unfolding+mkWwInlineRule opts expr arity+  = mkCoreUnfolding InlineStable True+                   (simpleOptExpr opts expr)+                   (UnfWhen { ug_arity = arity, ug_unsat_ok = unSaturatedOk+                            , ug_boring_ok = boringCxtNotOk })++mkWorkerUnfolding :: SimpleOpts -> (CoreExpr -> CoreExpr) -> Unfolding -> Unfolding+-- See Note [Worker-wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap+mkWorkerUnfolding opts work_fn+                  (CoreUnfolding { uf_src = src, uf_tmpl = tmpl+                                 , uf_is_top = top_lvl })+  | isStableSource src+  = mkCoreUnfolding src top_lvl new_tmpl guidance+  where+    new_tmpl = simpleOptExpr opts (work_fn tmpl)+    guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl++mkWorkerUnfolding _ _ _ = noUnfolding++-- | Make an unfolding that may be used unsaturated+-- (ug_unsat_ok = unSaturatedOk) and that is reported as having its+-- manifest arity (the number of outer lambdas applications will+-- resolve before doing any work).+mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding+mkInlineUnfolding opts expr+  = mkCoreUnfolding InlineStable+                    True         -- Note [Top-level flag on inline rules]+                    expr' guide+  where+    expr' = simpleOptExpr opts expr+    guide = UnfWhen { ug_arity = manifestArity expr'+                    , ug_unsat_ok = unSaturatedOk+                    , ug_boring_ok = boring_ok }+    boring_ok = inlineBoringOk expr'++-- | Make an unfolding that will be used once the RHS has been saturated+-- to the given arity.+mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding+mkInlineUnfoldingWithArity arity opts expr+  = mkCoreUnfolding InlineStable+                    True         -- Note [Top-level flag on inline rules]+                    expr' guide+  where+    expr' = simpleOptExpr opts expr+    guide = UnfWhen { ug_arity = arity+                    , ug_unsat_ok = needSaturated+                    , ug_boring_ok = boring_ok }+    -- See Note [INLINE pragmas and boring contexts] as to why we need to look+    -- at the arity here.+    boring_ok | arity == 0 = True+              | otherwise  = inlineBoringOk expr'++mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding+mkInlinableUnfolding opts expr+  = mkUnfolding (so_uf_opts opts) InlineStable False False expr'+  where+    expr' = simpleOptExpr opts expr++specUnfolding :: SimpleOpts+              -> [Var] -> (CoreExpr -> CoreExpr)+              -> [CoreArg]   -- LHS arguments in the RULE+              -> Unfolding -> Unfolding+-- See Note [Specialising unfoldings]+-- specUnfolding spec_bndrs spec_args unf+--   = \spec_bndrs. unf spec_args+--+specUnfolding opts spec_bndrs spec_app rule_lhs_args+              df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })+  = ASSERT2( rule_lhs_args `equalLength` old_bndrs+           , ppr df $$ ppr rule_lhs_args )+           -- For this ASSERT see Note [DFunUnfoldings] in GHC.Core.Opt.Specialise+    mkDFunUnfolding spec_bndrs con (map spec_arg args)+      -- For DFunUnfoldings we transform+      --       \obs. MkD <op1> ... <opn>+      -- to+      --       \sbs. MkD ((\obs. <op1>) spec_args) ... ditto <opn>+  where+    spec_arg arg = simpleOptExpr opts $+                   spec_app (mkLams old_bndrs arg)+                   -- The beta-redexes created by spec_app will be+                   -- simplified away by simplOptExpr++specUnfolding opts spec_bndrs spec_app rule_lhs_args+              (CoreUnfolding { uf_src = src, uf_tmpl = tmpl+                             , uf_is_top = top_lvl+                             , uf_guidance = old_guidance })+ | isStableSource src  -- See Note [Specialising unfoldings]+ , UnfWhen { ug_arity     = old_arity } <- old_guidance+ = mkCoreUnfolding src top_lvl new_tmpl+                   (old_guidance { ug_arity = old_arity - arity_decrease })+ where+   new_tmpl = simpleOptExpr opts $+              mkLams spec_bndrs    $+              spec_app tmpl  -- The beta-redexes created by spec_app+                             -- will besimplified away by simplOptExpr+   arity_decrease = count isValArg rule_lhs_args - count isId spec_bndrs+++specUnfolding _ _ _ _ _ = noUnfolding++{- Note [Specialising unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise a function for some given type-class arguments, we use+specUnfolding to specialise its unfolding.  Some important points:++* If the original function has a DFunUnfolding, the specialised one+  must do so too!  Otherwise we lose the magic rules that make it+  interact with ClassOps++* There is a bit of hack for INLINABLE functions:+     f :: Ord a => ....+     f = <big-rhs>+     {- INLINABLE f #-}+  Now if we specialise f, should the specialised version still have+  an INLINABLE pragma?  If it does, we'll capture a specialised copy+  of <big-rhs> as its unfolding, and that probably won't inline.  But+  if we don't, the specialised version of <big-rhs> might be small+  enough to inline at a call site. This happens with Control.Monad.liftM3,+  and can cause a lot more allocation as a result (nofib n-body shows this).++  Moreover, keeping the INLINABLE thing isn't much help, because+  the specialised function (probably) isn't overloaded any more.++  Conclusion: drop the INLINEALE pragma.  In practice what this means is:+     if a stable unfolding has UnfoldingGuidance of UnfWhen,+        we keep it (so the specialised thing too will always inline)+     if a stable unfolding has UnfoldingGuidance of UnfIfGoodArgs+        (which arises from INLINABLE), we discard it++Note [Honour INLINE on 0-ary bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++   x = <expensive>+   {-# INLINE x #-}++   f y = ...x...++The semantics of an INLINE pragma is++  inline x at every call site, provided it is saturated;+  that is, applied to at least as many arguments as appear+  on the LHS of the Haskell source definition.++(This source-code-derived arity is stored in the `ug_arity` field of+the `UnfoldingGuidance`.)++In the example, x's ug_arity is 0, so we should inline it at every use+site.  It's rare to have such an INLINE pragma (usually INLINE Is on+functions), but it's occasionally very important (#15578, #15519).+In #15519 we had something like+   x = case (g a b) of I# r -> T r+   {-# INLINE x #-}+   f y = ...(h x)....++where h is strict.  So we got+   f y = ...(case g a b of I# r -> h (T r))...++and that in turn allowed SpecConstr to ramp up performance.++How do we deliver on this?  By adjusting the ug_boring_ok+flag in mkInlineUnfoldingWithArity; see+Note [INLINE pragmas and boring contexts]++NB: there is a real risk that full laziness will float it right back+out again. Consider again+  x = factorial 200+  {-# INLINE x #-}+  f y = ...x...++After inlining we get+  f y = ...(factorial 200)...++but it's entirely possible that full laziness will do+  lvl23 = factorial 200+  f y = ...lvl23...++That's a problem for another day.++Note [INLINE pragmas and boring contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An INLINE pragma uses mkInlineUnfoldingWithArity to build the+unfolding.  That sets the ug_boring_ok flag to False if the function+is not tiny (inlineBoringOK), so that even INLINE functions are not+inlined in an utterly boring context.  E.g.+     \x y. Just (f y x)+Nothing is gained by inlining f here, even if it has an INLINE+pragma.++But for 0-ary bindings, we want to inline regardless; see+Note [Honour INLINE on 0-ary bindings].++I'm a bit worried that it's possible for the same kind of problem+to arise for non-0-ary functions too, but let's wait and see.+-}++mkUnfolding :: UnfoldingOpts+            -> UnfoldingSource+            -> Bool       -- Is top-level+            -> Bool       -- Definitely a bottoming binding+                          -- (only relevant for top-level bindings)+            -> CoreExpr+            -> Unfolding+-- Calculates unfolding guidance+-- Occurrence-analyses the expression before capturing it+mkUnfolding opts src top_lvl is_bottoming expr+  = mkCoreUnfolding src top_lvl expr guidance+  where+    is_top_bottoming = top_lvl && is_bottoming+    guidance         = calcUnfoldingGuidance opts is_top_bottoming expr+        -- NB: *not* (calcUnfoldingGuidance (occurAnalyseExpr expr))!+        -- See Note [Calculate unfolding guidance on the non-occ-anal'd expression]++mkCoreUnfolding :: UnfoldingSource -> Bool -> CoreExpr+                -> UnfoldingGuidance -> Unfolding+-- Occurrence-analyses the expression before capturing it+mkCoreUnfolding src top_lvl expr guidance+  = CoreUnfolding { uf_tmpl         = occurAnalyseExpr expr,+                      -- See Note [Occurrence analysis of unfoldings]+                    uf_src          = src,+                    uf_is_top       = top_lvl,+                    uf_is_value     = exprIsHNF        expr,+                    uf_is_conlike   = exprIsConLike    expr,+                    uf_is_work_free = exprIsWorkFree   expr,+                    uf_expandable   = exprIsExpandable expr,+                    uf_guidance     = guidance }++

GHC/Core/Unify.hs view

@@ -2,7 +2,7 @@  {-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFunctor, DeriveDataTypeable #-}  module GHC.Core.Unify (         tcMatchTy, tcMatchTyKi,@@ -11,17 +11,20 @@         tcMatchTyX_BM, ruleMatchTyKiX,          -- * Rough matching-        roughMatchTcs, instanceCantMatch,-        typesCantMatch,+        RoughMatchTc(..), roughMatchTcs, instanceCantMatch,+        typesCantMatch, isRoughOtherTc,          -- Side-effect free unification         tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,         tcUnifyTysFG, tcUnifyTyWithTFs,-        BindFlag(..),-        UnifyResult, UnifyResultM(..),+        BindFun, BindFlag(..), matchBindFun, alwaysBindFun,+        UnifyResult, UnifyResultM(..), MaybeApartReason(..),          -- Matching a type against a lifted type (coercion)-        liftCoMatch+        liftCoMatch,++        -- The core flattening algorithm+        flattenTys, flattenTysX    ) where  #include "HsVersions.h"@@ -31,24 +34,29 @@ import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set-import GHC.Types.Name( Name )+import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName ) import GHC.Core.Type     hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes ) import GHC.Core.TyCo.Subst ( mkTvSubst )+import GHC.Core.Map.Type import GHC.Utils.FV( FV, fvVarSet, fvVarList ) import GHC.Utils.Misc import GHC.Data.Pair import GHC.Utils.Outputable+import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Exts( oneShot )+import GHC.Utils.Panic+import GHC.Data.FastString +import Data.Data ( Data )+import Data.List ( mapAccumL ) import Control.Monad-import Control.Applicative hiding ( empty )-import qualified Control.Applicative+import qualified Data.Semigroup as S  {- @@ -102,6 +110,16 @@    equals the kind of the target, then use the TyKi version. -} +-- | Some unification functions are parameterised by a 'BindFun', which+-- says whether or not to allow a certain unification to take place.+-- A 'BindFun' takes the 'TyVar' involved along with the 'Type' it will+-- potentially be bound to.+--+-- It is possible for the variable to actually be a coercion variable+-- (Note [Matching coercion variables]), but only when one-way matching.+-- In this case, the 'Type' will be a 'CoercionTy'.+type BindFun = TyCoVar -> Type -> BindFlag+ -- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1)) -- @s@ such that @s(t1)@ equals @t2@. -- The returned substitution might bind coercion variables,@@ -117,7 +135,7 @@ tcMatchTy :: Type -> Type -> Maybe TCvSubst tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2] -tcMatchTyX_BM :: (TyVar -> BindFlag) -> TCvSubst+tcMatchTyX_BM :: BindFun -> TCvSubst               -> Type -> Type -> Maybe TCvSubst tcMatchTyX_BM bind_me subst ty1 ty2   = tc_match_tys_x bind_me False subst [ty1] [ty2]@@ -127,7 +145,7 @@ -- See also Note [tcMatchTy vs tcMatchTyKi] tcMatchTyKi :: Type -> Type -> Maybe TCvSubst tcMatchTyKi ty1 ty2-  = tc_match_tys (const BindMe) True [ty1] [ty2]+  = tc_match_tys alwaysBindFun True [ty1] [ty2]  -- | This is similar to 'tcMatchTy', but extends a substitution -- See also Note [tcMatchTy vs tcMatchTyKi]@@ -136,7 +154,7 @@            -> Type                -- ^ Target            -> Maybe TCvSubst tcMatchTyX subst ty1 ty2-  = tc_match_tys_x (const BindMe) False subst [ty1] [ty2]+  = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2]  -- | Like 'tcMatchTy' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi]@@ -145,7 +163,7 @@            -> Maybe TCvSubst -- ^ One-shot; in principle the template                              -- variables could be free in the target tcMatchTys tys1 tys2-  = tc_match_tys (const BindMe) False tys1 tys2+  = tc_match_tys alwaysBindFun False tys1 tys2  -- | Like 'tcMatchTyKi' but over a list of types. -- See also Note [tcMatchTy vs tcMatchTyKi]@@ -153,7 +171,7 @@              -> [Type]         -- ^ Target              -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTyKis tys1 tys2-  = tc_match_tys (const BindMe) True tys1 tys2+  = tc_match_tys alwaysBindFun True tys1 tys2  -- | Like 'tcMatchTys', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi]@@ -162,7 +180,7 @@             -> [Type]         -- ^ Target             -> Maybe TCvSubst -- ^ One-shot substitution tcMatchTysX subst tys1 tys2-  = tc_match_tys_x (const BindMe) False subst tys1 tys2+  = tc_match_tys_x alwaysBindFun False subst tys1 tys2  -- | Like 'tcMatchTyKis', but extending a substitution -- See also Note [tcMatchTy vs tcMatchTyKi]@@ -171,21 +189,21 @@               -> [Type]          -- ^ Target               -> Maybe TCvSubst  -- ^ One-shot substitution tcMatchTyKisX subst tys1 tys2-  = tc_match_tys_x (const BindMe) True subst tys1 tys2+  = tc_match_tys_x alwaysBindFun True subst tys1 tys2  -- | Same as tc_match_tys_x, but starts with an empty substitution-tc_match_tys :: (TyVar -> BindFlag)-               -> Bool          -- ^ match kinds?-               -> [Type]-               -> [Type]-               -> Maybe TCvSubst+tc_match_tys :: BindFun+             -> Bool          -- ^ match kinds?+             -> [Type]+             -> [Type]+             -> Maybe TCvSubst tc_match_tys bind_me match_kis tys1 tys2   = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2   where     in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)  -- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'-tc_match_tys_x :: (TyVar -> BindFlag)+tc_match_tys_x :: BindFun                -> Bool          -- ^ match kinds?                -> TCvSubst                -> [Type]@@ -218,9 +236,22 @@       Unifiable (tenv', _) -> Just tenv'       _                    -> Nothing -matchBindFun :: TyCoVarSet -> TyVar -> BindFlag-matchBindFun tvs tv = if tv `elemVarSet` tvs then BindMe else Skolem+-- | Allow binding only for any variable in the set. Variables may+-- be bound to any type.+-- Used when doing simple matching; e.g. can we find a substitution+--+-- @+-- S = [a :-> t1, b :-> t2] such that+--     S( Maybe (a, b->Int )  =   Maybe (Bool, Char -> Int)+-- @+matchBindFun :: TyCoVarSet -> BindFun+matchBindFun tvs tv _ty+  | tv `elemVarSet` tvs = BindMe+  | otherwise           = Apart +-- | Allow the binding of any variable to any type+alwaysBindFun :: BindFun+alwaysBindFun _tv _ty = BindMe  {- ********************************************************************* *                                                                      *@@ -228,26 +259,70 @@ *                                                                      * ********************************************************************* -} --- See Note [Rough match] field in GHC.Core.InstEnv+{- Note [Rough matching in class and family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  instance C (Maybe [Tree a]) Bool+and suppose we are looking up+     C Bool Bool -roughMatchTcs :: [Type] -> [Maybe Name]+We can very quickly rule the instance out, because the first+argument is headed by Maybe, whereas in the constraint we are looking+up has first argument headed by Bool.  These "headed by" TyCons are+called the "rough match TyCons" of the constraint or instance.+They are used for a quick filter, to check when an instance cannot+possibly match.++The main motivation is to avoid sucking in whole instance+declarations that are utterly useless.  See GHC.Core.InstEnv+Note [ClsInst laziness and the rough-match fields].++INVARIANT: a rough-match TyCons `tc` is always a real, generative tycon,+like Maybe or Either, including a newtype or a data family, both of+which are generative. It replies True to `isGenerativeTyCon tc Nominal`.++But it is never+    - A type synonym+      E.g. Int and (S Bool) might match+           if (S Bool) is a synonym for Int++    - A type family (#19336)+      E.g.   (Just a) and (F a) might match if (F a) reduces to (Just a)+             albeit perhaps only after 'a' is instantiated.+-}++data RoughMatchTc+  = KnownTc Name   -- INVARIANT: Name refers to a TyCon tc that responds+                   -- true to `isGenerativeTyCon tc Nominal`. See+                   -- Note [Rough matching in class and family instances]+  | OtherTc        -- e.g. type variable at the head+  deriving( Data )++isRoughOtherTc :: RoughMatchTc -> Bool+isRoughOtherTc OtherTc      = True+isRoughOtherTc (KnownTc {}) = False++roughMatchTcs :: [Type] -> [RoughMatchTc] roughMatchTcs tys = map rough tys   where     rough ty       | Just (ty', _) <- splitCastTy_maybe ty   = rough ty'-      | Just (tc,_)   <- splitTyConApp_maybe ty = Just (tyConName tc)-      | otherwise                               = Nothing+      | Just (tc,_)   <- splitTyConApp_maybe ty+      , not (isTypeFamilyTyCon tc)              = ASSERT2( isGenerativeTyCon tc Nominal, ppr tc )+                                                  KnownTc (tyConName tc)+        -- See Note [Rough matching in class and family instances]+      | otherwise                               = OtherTc -instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool+instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool -- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot -- possibly be instantiated to actual, nor vice versa; -- False is non-committal instanceCantMatch (mt : ts) (ma : as) = itemCantMatch mt ma || instanceCantMatch ts as instanceCantMatch _         _         =  False  -- Safe -itemCantMatch :: Maybe Name -> Maybe Name -> Bool-itemCantMatch (Just t) (Just a) = t /= a-itemCantMatch _        _        = False+itemCantMatch :: RoughMatchTc -> RoughMatchTc -> Bool+itemCantMatch (KnownTc t) (KnownTc a) = t /= a+itemCantMatch _           _           = False   {-@@ -294,7 +369,7 @@ typesCantMatch prs = any (uncurry cant_match) prs   where     cant_match :: Type -> Type -> Bool-    cant_match t1 t2 = case tcUnifyTysFG (const BindMe) [t1] [t2] of+    cant_match t1 t2 = case tcUnifyTysFG alwaysBindFun [t1] [t2] of       SurelyApart -> True       _           -> False @@ -339,6 +414,46 @@ when it should. See test case indexed-types/should_fail/Overlap15 for an example. +Note [Unificiation result]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When unifying t1 ~ t2, we return+* Unifiable s, if s is a substitution such that s(t1) is syntactically the+  same as s(t2), modulo type-synonym expansion.+* SurelyApart, if there is no substitution s such that s(t1) = s(t2),+  where "=" includes type-family reductions.+* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason.++Examples+* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify+* [(a,Int)] ~ [(Bool,b)]:  Unifiable+* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool (the unifier+                    does not try this)+* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart either; consider+       a := Loop+       where  type family Loop where Loop = Maybe Loop++There is the possibility that two types are MaybeApart for *both* reasons:++* (a, F Int) ~ (Maybe a, Bool)++What reason should we use? The *only* consumer of the reason is described+in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal+there is identify which instances might match a target later (but don't+match now) -- except that we want to ignore the possibility of infinitary+substitutions. So let's examine a concrete scenario:++  class C a b c+  instance C a (Maybe a) Bool+  -- other instances, including one that will actually match+  [W] C b b (F Int)++Do we want the instance as a future possibility? No. The only way that+instance can match is in the presence of an infinite type (infinitely+nested Maybes). We thus say that MARInfinite takes precedence, so that+InstEnv treats this case as an infinitary substitution case; the fact+that a type family is involved is only incidental. We thus define+the Semigroup instance for MaybeApartReason to prefer MARInfinite.+ Note [The substitution in MaybeApart] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?@@ -355,12 +470,6 @@ type family applications to reduce. See test case indexed-types/should_compile/Overlap14. -Note [Unification with skolems]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we discover that two types unify if and only if a skolem variable is-substituted, we can't properly unify the types. But, that skolem variable-may later be instantiated with a unifyable type. So, we return maybeApart-in these cases. -}  -- | Simple unification of two types; all type variables are bindable@@ -368,11 +477,11 @@ tcUnifyTy :: Type -> Type       -- All tyvars are bindable           -> Maybe TCvSubst                        -- A regular one-shot (idempotent) substitution-tcUnifyTy t1 t2 = tcUnifyTys (const BindMe) [t1] [t2]+tcUnifyTy t1 t2 = tcUnifyTys alwaysBindFun [t1] [t2]  -- | Like 'tcUnifyTy', but also unifies the kinds tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst-tcUnifyTyKi t1 t2 = tcUnifyTyKis (const BindMe) [t1] [t2]+tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [t1] [t2]  -- | Unify two types, treating type family applications as possibly unifying -- with anything and looking through injective type family applications.@@ -386,11 +495,11 @@ -- The code is incorporated with the standard unifier for convenience, but -- its operation should match the specification in the paper. tcUnifyTyWithTFs twoWay t1 t2-  = case tc_unify_tys (const BindMe) twoWay True False+  = case tc_unify_tys alwaysBindFun twoWay True False                        rn_env emptyTvSubstEnv emptyCvSubstEnv                        [t1] [t2] of-      Unifiable  (subst, _) -> Just $ maybe_fix subst-      MaybeApart (subst, _) -> Just $ maybe_fix subst+      Unifiable          (subst, _) -> Just $ maybe_fix subst+      MaybeApart _reason (subst, _) -> Just $ maybe_fix subst       -- we want to *succeed* in questionable cases. This is a       -- pre-unification algorithm.       SurelyApart      -> Nothing@@ -403,7 +512,7 @@                                                -- domain with range  ------------------tcUnifyTys :: (TyCoVar -> BindFlag)+tcUnifyTys :: BindFun            -> [Type] -> [Type]            -> Maybe TCvSubst                                 -- ^ A regular one-shot (idempotent) substitution@@ -418,7 +527,7 @@       _                -> Nothing  -- | Like 'tcUnifyTys' but also unifies the kinds-tcUnifyTyKis :: (TyCoVar -> BindFlag)+tcUnifyTyKis :: BindFun              -> [Type] -> [Type]              -> Maybe TCvSubst tcUnifyTyKis bind_fn tys1 tys2@@ -429,55 +538,61 @@ -- This type does double-duty. It is used in the UM (unifier monad) and to -- return the final result. See Note [Fine-grained unification] type UnifyResult = UnifyResultM TCvSubst++-- | See Note [Unificiation result] data UnifyResultM a = Unifiable a        -- the subst that unifies the types-                    | MaybeApart a       -- the subst has as much as we know+                    | MaybeApart MaybeApartReason+                                 a       -- the subst has as much as we know                                          -- it must be part of a most general unifier                                          -- See Note [The substitution in MaybeApart]                     | SurelyApart                     deriving Functor +-- | Why are two types 'MaybeApart'? 'MARTypeFamily' takes precedence:+-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv+data MaybeApartReason = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool+                      | MARInfinite     -- ^ matching e.g. a ~? Maybe a++instance Outputable MaybeApartReason where+  ppr MARTypeFamily = text "MARTypeFamily"+  ppr MARInfinite   = text "MARInfinite"++instance Semigroup MaybeApartReason where+  -- see end of Note [Unification result] for why+  MARTypeFamily <> r = r+  MARInfinite   <> _ = MARInfinite+ instance Applicative UnifyResultM where   pure  = Unifiable   (<*>) = ap  instance Monad UnifyResultM where-   SurelyApart  >>= _ = SurelyApart-  MaybeApart x >>= f = case f x of-                         Unifiable y -> MaybeApart y-                         other       -> other+  MaybeApart r1 x >>= f = case f x of+                            Unifiable y     -> MaybeApart r1 y+                            MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y+                            SurelyApart     -> SurelyApart   Unifiable x  >>= f = f x -instance Alternative UnifyResultM where-  empty = SurelyApart--  a@(Unifiable {})  <|> _                 = a-  _                 <|> b@(Unifiable {})  = b-  a@(MaybeApart {}) <|> _                 = a-  _                 <|> b@(MaybeApart {}) = b-  SurelyApart       <|> SurelyApart       = SurelyApart--instance MonadPlus UnifyResultM---- | @tcUnifyTysFG bind_tv tys1 tys2@ attepts to find a substitution @s@ (whose+-- | @tcUnifyTysFG bind_tv tys1 tys2@ attempts to find a substitution @s@ (whose -- domain elements all respond 'BindMe' to @bind_tv@) such that -- @s(tys1)@ and that of @s(tys2)@ are equal, as witnessed by the returned -- Coercions. This version requires that the kinds of the types are the same, -- if you unify left-to-right.-tcUnifyTysFG :: (TyVar -> BindFlag)+tcUnifyTysFG :: BindFun              -> [Type] -> [Type]              -> UnifyResult tcUnifyTysFG bind_fn tys1 tys2   = tc_unify_tys_fg False bind_fn tys1 tys2 -tcUnifyTyKisFG :: (TyVar -> BindFlag)+tcUnifyTyKisFG :: BindFun                -> [Type] -> [Type]                -> UnifyResult tcUnifyTyKisFG bind_fn tys1 tys2   = tc_unify_tys_fg True bind_fn tys1 tys2  tc_unify_tys_fg :: Bool-                -> (TyVar -> BindFlag)+                -> BindFun                 -> [Type] -> [Type]                 -> UnifyResult tc_unify_tys_fg match_kis bind_fn tys1 tys2@@ -491,7 +606,7 @@  -- | This function is actually the one to call the unifier -- a little -- too general for outside clients, though.-tc_unify_tys :: (TyVar -> BindFlag)+tc_unify_tys :: BindFun              -> AmIUnifying -- ^ True <=> unify; False <=> match              -> Bool        -- ^ True <=> doing an injectivity check              -> Bool        -- ^ True <=> treat the kinds as well@@ -528,9 +643,9 @@     kis2 = map typeKind tys2  instance Outputable a => Outputable (UnifyResultM a) where-  ppr SurelyApart    = text "SurelyApart"-  ppr (Unifiable x)  = text "Unifiable" <+> ppr x-  ppr (MaybeApart x) = text "MaybeApart" <+> ppr x+  ppr SurelyApart      = text "SurelyApart"+  ppr (Unifiable x)    = text "Unifiable" <+> ppr x+  ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x  {- ************************************************************************@@ -690,9 +805,7 @@  The algorithm implemented here is rather delicate, and we depend on it to uphold certain properties. This is a summary of these required-properties. Any reference to "flattening" refers to the flattening-algorithm in GHC.Core.FamInstEnv (See Note [Flattening] in GHC.Core.FamInstEnv), not-the flattening algorithm in the solver.+properties.  Notation:  θ,φ    substitutions@@ -773,7 +886,7 @@ We thus must parameterize the algorithm over whether it's being used for an injectivity check (refrain from looking at non-injective arguments to type families) or not (do indeed look at those arguments).  This is-implemented  by the uf_inj_tf field of UmEnv.+implemented  by the um_inj_tf field of UMEnv.  (It's all a question of whether or not to include equation (7) from Fig. 2 of [ITF].)@@ -957,6 +1070,11 @@ -- Respects newtypes, PredTypes  unify_ty env ty1 ty2 kco+  -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.+  | TyConApp tc1 [] <- ty1+  , TyConApp tc2 [] <- ty2+  , tc1 == tc2                = return ()+     -- TODO: More commentary needed here   | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco   | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco@@ -975,9 +1093,11 @@   = uVar (umSwapRn env) tv2 ty1 (mkSymCo kco)  unify_ty env ty1 ty2 _kco+ -- NB: This keeps Constraint and Type distinct, as it should for use in the+ -- type-checker.   | Just (tc1, tys1) <- mb_tc_app1   , Just (tc2, tys2) <- mb_tc_app2-  , tc1 == tc2 || (tcIsLiftedTypeKind ty1 && tcIsLiftedTypeKind ty2)+  , tc1 == tc2   = if isInjectiveTyCon tc1 Nominal     then unify_tys env tys1 tys2     else do { let inj | isTypeFamilyTyCon tc1@@ -992,7 +1112,7 @@              ; unify_tys env inj_tys1 inj_tys2             ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification]-              don'tBeSoSure $ unify_tys env noninj_tys1 noninj_tys2 }+              don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 }    | Just (tc1, _) <- mb_tc_app1   , not (isGenerativeTyCon tc1 Nominal)@@ -1000,7 +1120,7 @@     --        because the (F ty1) behaves like a variable     --        NB: if unifying, we have already dealt     --            with the 'ty2 = variable' case-  = maybeApart+  = maybeApart MARTypeFamily    | Just (tc2, _) <- mb_tc_app2   , not (isGenerativeTyCon tc2 Nominal)@@ -1008,7 +1128,7 @@     -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)     --        because the (F ty2) behaves like a variable     --        NB: we have already dealt with the 'ty1 = variable' case-  = maybeApart+  = maybeApart MARTypeFamily    where     mb_tc_app1 = tcSplitTyConApp_maybe ty1@@ -1026,6 +1146,16 @@   | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1   = unify_ty_app env ty1a [ty1b] ty2a [ty2b] +  -- tcSplitTyConApp won't split a (=>), so we handle this separately.+unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco+   -- Look at result representations, but arg representations would be redundant+   -- as anything that can appear to the left of => is lifted.+   -- And anything that can appear to the left of => is unrestricted, so skip the+   -- multiplicities.+  | Just res_rep1 <- getRuntimeRep_maybe res1+  , Just res_rep2 <- getRuntimeRep_maybe res2+  = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2]+ unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()  unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco@@ -1040,18 +1170,17 @@            CoVarCo cv              | not (um_unif env)              , not (cv `elemVarEnv` c_subst)-             , BindMe <- tvBindFlag env cv-             -> do { checkRnEnv env (tyCoVarsOfCo co2)-                   ; let (_, co_l, co_r) = decomposeFunCo Nominal kco-                     -- Because the coercion is nominal, it should be safe to+             , let (_, co_l, co_r) = decomposeFunCo Nominal kco+                     -- Because the coercion is used in a type, it should be safe to                      -- ignore the multiplicity coercion.                       -- cv :: t1 ~ t2                       -- co2 :: s1 ~ s2                       -- co_l :: t1 ~ s1                       -- co_r :: t2 ~ s2-                   ; extendCvEnv cv (co_l `mkTransCo`-                                     co2 `mkTransCo`-                                     mkSymCo co_r) }+                   rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r+             , BindMe <- tvBindFlag env cv (CoercionTy rhs_co)+             -> do { checkRnEnv env (tyCoVarsOfCo co2)+                   ; extendCvEnv cv rhs_co }            _ -> return () }  unify_ty _ _ _ _ = surelyApart@@ -1108,7 +1237,8 @@                       -- this is because the range of the subst is the target                       -- type, not the template type. So, just check for                       -- normal type equality.-                      guard ((ty' `mkCastTy` kco) `eqType` ty)+                      unless ((ty' `mkCastTy` kco) `eqType` ty) $+                      surelyApart           Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue  uUnrefined :: UMEnv@@ -1121,7 +1251,8 @@ -- We know that tv1 isn't refined  uUnrefined env tv1' ty2 ty2' kco-  | Just ty2'' <- coreView ty2'+    -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.+  | Just ty2'' <- tcView ty2'   = uUnrefined env tv1' ty2 ty2'' kco    -- Unwrap synonyms                 -- This is essential, in case we have                 --      type Foo a = a@@ -1142,25 +1273,29 @@      do {   -- So both are unrefined            -- Bind one or the other, depending on which is bindable-       ; let b1  = tvBindFlag env tv1'-             b2  = tvBindFlag env tv2'+       ; let rhs1 = ty2 `mkCastTy` mkSymCo kco+             rhs2 = ty1 `mkCastTy` kco+             b1  = tvBindFlag env tv1' rhs1+             b2  = tvBindFlag env tv2' rhs2              ty1 = mkTyVarTy tv1'        ; case (b1, b2) of-           (BindMe, _) -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)+           (BindMe, _) -> bindTv env tv1' rhs1            (_, BindMe) | um_unif env-                       -> bindTv (umSwapRn env) tv2 (ty1 `mkCastTy` kco)+                       -> bindTv (umSwapRn env) tv2 rhs2             _ | tv1' == tv2' -> return ()              -- How could this happen? If we're only matching and if              -- we're comparing forall-bound variables. -           _ -> maybeApart -- See Note [Unification with skolems]+           _ -> surelyApart   }}}}  uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable-  = case tvBindFlag env tv1' of-      Skolem -> maybeApart  -- See Note [Unification with skolems]-      BindMe -> bindTv env tv1' (ty2 `mkCastTy` mkSymCo kco)+  = case tvBindFlag env tv1' rhs of+      Apart  -> surelyApart+      BindMe -> bindTv env tv1' rhs+  where+    rhs = ty2 `mkCastTy` mkSymCo kco  bindTv :: UMEnv -> OutTyVar -> Type -> UM () -- OK, so we want to extend the substitution with tv := ty@@ -1177,7 +1312,7 @@         -- Make sure you include 'kco' (which ty2 does) #14846         ; occurs <- occursCheck env tv1 free_tvs2 -        ; if occurs then maybeApart+        ; if occurs then maybeApart MARInfinite                     else extendTvEnv tv1 ty2 }  occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool@@ -1198,11 +1333,16 @@ -}  data BindFlag-  = BindMe      -- A regular type variable+  = BindMe      -- ^ A regular type variable -  | Skolem      -- This type variable is a skolem constant-                -- Don't bind it; it only matches itself+  | Apart       -- ^ Declare that this type variable is /apart/ from the+                -- type provided. That is, the type variable will never+                -- be instantiated to that type.+                -- See also Note [Binding when looking up instances]+                -- in GHC.Core.InstEnv.   deriving Eq+-- NB: It would be conceivable to have an analogue to MaybeApart here,+-- but there is not yet a need.  {- ************************************************************************@@ -1212,77 +1352,6 @@ ************************************************************************ -} -{- Note [The one-shot state monad trick]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Many places in GHC use a state monad, and we really want those-functions to be eta-expanded (#18202).  Consider--    newtype M a = MkM (State -> (State, a))--    instance Monad M where-       mf >>= k = MkM (\s -> case mf  of MkM f  ->-                             case f s of (s',r) ->-                             case k r of MkM g  ->-                             g s')--    foo :: Int -> M Int-    foo x = g y >>= \r -> h r-      where-        y = expensive x--In general, you might say (map (foo 4) xs), and expect (expensive 4)-to be evaluated only once.  So foo should have arity 1 (not 2).-But that's rare, and if you /aren't/ re-using (M a) values it's much-more efficient to make foo have arity 2.--See https://www.joachim-breitner.de/blog/763-Faster_Winter_5__Eta-Expanding_ReaderT--So here is the trick.  Define--    data M a = MkM' (State -> (State, a))-    pattern MkM f <- MkM' f-      where-        MkM f = MkM' (oneShot f)--The patten synonm means that whenever we write (MkM f), we'll-actually get (MkM' (oneShot f)), so we'll pin a one-shot flag-on f's lambda-binder. Now look at foo:--  foo = \x. g (expensive x) >>= \r -> h r-      = \x. let mf = g (expensive x)-                k  = \r -> h r-            in MkM' (oneShot (\s -> case mf  of MkM' f  ->-                                    case f s of (s',r) ->-                                    case k r of MkM' g  ->-                                    g s'))-      -- The MkM' are just newtype casts nt_co-      = \x. let mf = g (expensive x)-                k  = \r -> h r-            in (\s{os}. case (mf |> nt_co) s of (s',r) ->-                        (k r) |> nt_co s')-               |> sym nt_co--      -- Float into that \s{os}-      = \x. (\s{os}. case (g (expensive x) |> nt_co) s of (s',r) ->-                     h r |> nt_co s')-            |> sym nt_co--and voila!  In summary:--* It's a very simple, two-line change--* It eta-expands all uses of the monad, automatically--* It is very similar to the built-in "state hack" (see-  GHC.Core.Opt.Arity Note [The state-transformer hack]) but the trick-  described here is applicable on a monad-by-monad basis under-  programmer control.--* Beware: itt changes the behaviour of-     map (foo 3) xs-  ToDo: explain what to do if you want to do this--}- data UMEnv   = UMEnv { um_unif :: AmIUnifying @@ -1300,7 +1369,7 @@             -- Do not bind these in the substitution!             -- See the function tvBindFlag -          , um_bind_fun :: TyVar -> BindFlag+          , um_bind_fun :: BindFun             -- User-supplied BindFlag function,             -- for variables not in um_skols           }@@ -1311,11 +1380,11 @@  newtype UM a   = UM' { unUM :: UMState -> UnifyResultM (UMState, a) }-    -- See Note [The one-shot state monad trick]+    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad   deriving (Functor)  pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a--- See Note [The one-shot state monad trick]+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad pattern UM m <- UM' m   where     UM m = UM' (oneShot m)@@ -1329,15 +1398,6 @@                   do { (state', v) <- unUM m state                      ; unUM (k v) state' }) --- need this instance because of a use of 'guard' above-instance Alternative UM where-  empty     = UM (\_ -> Control.Applicative.empty)-  m1 <|> m2 = UM (\state ->-                  unUM m1 state <|>-                  unUM m2 state)--instance MonadPlus UM- instance MonadFail UM where     fail _   = UM (\_ -> SurelyApart) -- failed pattern match @@ -1346,17 +1406,17 @@        -> UM a -> UnifyResultM a initUM subst_env cv_subst_env um   = case unUM um state of-      Unifiable (_, subst)  -> Unifiable subst-      MaybeApart (_, subst) -> MaybeApart subst-      SurelyApart           -> SurelyApart+      Unifiable (_, subst)    -> Unifiable subst+      MaybeApart r (_, subst) -> MaybeApart r subst+      SurelyApart             -> SurelyApart   where     state = UMState { um_tv_env = subst_env                     , um_cv_env = cv_subst_env } -tvBindFlag :: UMEnv -> OutTyVar -> BindFlag-tvBindFlag env tv-  | tv `elemVarSet` um_skols env = Skolem-  | otherwise                    = um_bind_fun env tv+tvBindFlag :: UMEnv -> OutTyVar -> Type -> BindFlag+tvBindFlag env tv rhs+  | tv `elemVarSet` um_skols env = Apart+  | otherwise                    = um_bind_fun env tv rhs  getTvSubstEnv :: UM TvSubstEnv getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)@@ -1388,9 +1448,7 @@ checkRnEnv env varset   | isEmptyVarSet skol_vars           = return ()   | varset `disjointVarSet` skol_vars = return ()-  | otherwise                         = maybeApart-               -- ToDo: why MaybeApart?-               -- I think SurelyApart would be right+  | otherwise                         = surelyApart   where     skol_vars = um_skols env     -- NB: That isEmptyVarSet guard is a critical optimization;@@ -1398,10 +1456,10 @@     -- the type, often saving quite a bit of allocation.  -- | Converts any SurelyApart to a MaybeApart-don'tBeSoSure :: UM () -> UM ()-don'tBeSoSure um = UM $ \ state ->+don'tBeSoSure :: MaybeApartReason -> UM () -> UM ()+don'tBeSoSure r um = UM $ \ state ->   case unUM um state of-    SurelyApart -> MaybeApart (state, ())+    SurelyApart -> MaybeApart r (state, ())     other       -> other  umRnOccL :: UMEnv -> TyVar -> TyVar@@ -1413,8 +1471,8 @@ umSwapRn :: UMEnv -> UMEnv umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) } -maybeApart :: UM ()-maybeApart = UM (\state -> MaybeApart (state, ()))+maybeApart :: MaybeApartReason -> UM ()+maybeApart r = UM (\state -> MaybeApart r (state, ()))  surelyApart :: UM a surelyApart = UM (\_ -> SurelyApart)@@ -1483,6 +1541,8 @@             -> Maybe LiftCoEnv ty_co_match menv subst ty co lkco rkco   | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco+     -- why coreView here, not tcView? Because we're firmly after type-checking.+     -- This function is used only during coercion optimisation.    -- handle Refl case:   | tyCoVarsOfType ty `isNotInDomainOf` subst@@ -1668,3 +1728,321 @@       -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))     -- NB: NoRefl variant. Otherwise, we get a loop!     _ -> Nothing++{-+************************************************************************+*                                                                      *+              Flattening+*                                                                      *+************************************************************************++Note [Flattening type-family applications when matching instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+we need to flatten core types before unifying them, when checking for "surely-apart"+against earlier equations of a closed type family.+Flattening means replacing all top-level uses of type functions with+fresh variables, *taking care to preserve sharing*. That is, the type+(Either (F a b) (F a b)) should flatten to (Either c c), never (Either+c d).++Here is a nice example of why it's all necessary:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't match,+while the second equation does. But, before reducing, we must make sure that the+target can never become (F Int Bool). Well, no matter what G Float becomes, it+certainly won't become *both* Int and Bool, so indeed we're safe reducing+(F (G Float) (G Float)) to Double.++This is necessary not only to get more reductions (which we might be+willing to give up on), but for substitutivity. If we have (F x x), we+can see that (F x x) can reduce to Double. So, it had better be the+case that (F blah blah) can reduce to Double, no matter what (blah)+is!  Flattening as done below ensures this.++We also use this flattening operation to check for class instances.+If we have+  instance C (Maybe b)+  instance {-# OVERLAPPING #-} C (Maybe Bool)+  [W] C (Maybe (F a))+we want to know that the second instance might match later. So we+flatten the (F a) in the target before trying to unify with instances.+(This is done in GHC.Core.InstEnv.lookupInstEnv'.)++The algorithm works by building up a TypeMap TyVar, mapping+type family applications to fresh variables. This mapping must+be threaded through all the function calls, as any entry in+the mapping must be propagated to all future nodes in the tree.++The algorithm also must track the set of in-scope variables, in+order to make fresh variables as it flattens. (We are far from a+source of fresh Uniques.) See Wrinkle 2, below.++There are wrinkles, of course:++1. The flattening algorithm must account for the possibility+   of inner `forall`s. (A `forall` seen here can happen only+   because of impredicativity. However, the flattening operation+   is an algorithm in Core, which is impredicative.)+   Suppose we have (forall b. F b) -> (forall b. F b). Of course,+   those two bs are entirely unrelated, and so we should certainly+   not flatten the two calls F b to the same variable. Instead, they+   must be treated separately. We thus carry a substitution that+   freshens variables; we must apply this substitution (in+   `coreFlattenTyFamApp`) before looking up an application in the environment.+   Note that the range of the substitution contains only TyVars, never anything+   else.++   For the sake of efficiency, we only apply this substitution when absolutely+   necessary. Namely:++   * We do not perform the substitution at all if it is empty.+   * We only need to worry about the arguments of a type family that are within+     the arity of said type family, so we can get away with not applying the+     substitution to any oversaturated type family arguments.+   * Importantly, we do /not/ achieve this substitution by recursively+     flattening the arguments, as this would be wrong. Consider `F (G a)`,+     where F and G are type families. We might decide that `F (G a)` flattens+     to `beta`. Later, the substitution is non-empty (but does not map `a`) and+     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,+     `F gamma` is unknown, and so we flatten it to `delta`, but it really+     should have been `beta`! Argh!++     Moral of the story: instead of flattening the arguments, just substitute+     them directly.++2. There are two different reasons we might add a variable+   to the in-scope set as we work:++     A. We have just invented a new flattening variable.+     B. We have entered a `forall`.++   Annoying here is that in-scope variable source (A) must be+   threaded through the calls. For example, consider (F b -> forall c. F c).+   Suppose that, when flattening F b, we invent a fresh variable c.+   Now, when we encounter (forall c. F c), we need to know c is already in+   scope so that we locally rename c to c'. However, if we don't thread through+   the in-scope set from one argument of (->) to the other, we won't know this+   and might get very confused.++   In contrast, source (B) increases only as we go deeper, as in-scope sets+   normally do. However, even here we must be careful. The TypeMap TyVar that+   contains mappings from type family applications to freshened variables will+   be threaded through both sides of (forall b. F b) -> (forall b. F b). We+   thus must make sure that the two `b`s don't get renamed to the same b1. (If+   they did, then looking up `F b1` would yield the same flatten var for+   each.) So, even though `forall`-bound variables should really be in the+   in-scope set only when they are in scope, we retain these variables even+   outside of their scope. This ensures that, if we encounter a fresh+   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a+   larger in-scope set than strictly necessary is always OK, as in-scope sets+   are only ever used to avoid collisions.++   Sadly, the freshening substitution described in (1) really mustn't bind+   variables outside of their scope: note that its domain is the *unrenamed*+   variables. This means that the substitution gets "pushed down" (like a+   reader monad) while the in-scope set gets threaded (like a state monad).+   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;+   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet+   traveling separately as necessary.++3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:++     type family F ty_1 ... ty_k :: res_k++   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a+   flattening skolem. But we must instead flatten it to+   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the+   type family.++   Why is this better? Consider the following concrete example from #16995:++     type family Param :: Type -> Type++     type family LookupParam (a :: Type) :: Type where+       LookupParam (f Char) = Bool+       LookupParam x        = Int++     foo :: LookupParam (Param ())+     foo = 42++   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to+   `Int`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if+   `alpha` is apart from `f Char`, so it won't fall through to the second+   equation. But since the `Param` type family has arity 0, we can instead+   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is+   apart from `f Char`, permitting the second equation to be reached.++   Not only does this allow more programs to be accepted, it's also important+   for correctness. Not doing this was the root cause of the Core Lint error+   in #16995.++flattenTys is defined here because of module dependencies.+-}++data FlattenEnv+  = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type])+                 -- domain: exactly-saturated type family applications+                 -- range: (fresh variable, type family tycon, args)+               , fe_in_scope :: InScopeSet }+                 -- See Note [Flattening type-family applications when matching instances]++emptyFlattenEnv :: InScopeSet -> FlattenEnv+emptyFlattenEnv in_scope+  = FlattenEnv { fe_type_map = emptyTypeMap+               , fe_in_scope = in_scope }++updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv+updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }++flattenTys :: InScopeSet -> [Type] -> [Type]+-- See Note [Flattening type-family applications when matching instances]+flattenTys in_scope tys = fst (flattenTysX in_scope tys)++flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))+-- See Note [Flattening type-family applications when matching instances]+-- NB: the returned types mention the fresh type variables+--     in the domain of the returned env, whose range includes+--     the original type family applications. Building a substitution+--     from this information and applying it would yield the original+--     types -- almost. The problem is that the original type might+--     have something like (forall b. F a b); the returned environment+--     can't really sensibly refer to that b. So it may include a locally-+--     bound tyvar in its range. Currently, the only usage of this env't+--     checks whether there are any meta-variables in it+--     (in GHC.Tc.Solver.Monad.mightEqualLater), so this is all OK.+flattenTysX in_scope tys+  = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in+    (result, build_env (fe_type_map env))+  where+    build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type])+    build_env env_in+      = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys))+               env_in emptyVarEnv++coreFlattenTys :: TvSubstEnv -> FlattenEnv+               -> [Type] -> (FlattenEnv, [Type])+coreFlattenTys subst = mapAccumL (coreFlattenTy subst)++coreFlattenTy :: TvSubstEnv -> FlattenEnv+              -> Type -> (FlattenEnv, Type)+coreFlattenTy subst = go+  where+    go env ty | Just ty' <- coreView ty = go env ty'++    go env (TyVarTy tv)+      | Just ty <- lookupVarEnv subst tv = (env, ty)+      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in+                                           (env', mkTyVarTy $ setTyVarKind tv ki)+    go env (AppTy ty1 ty2) = let (env1, ty1') = go env  ty1+                                 (env2, ty2') = go env1 ty2 in+                             (env2, AppTy ty1' ty2')+    go env (TyConApp tc tys)+         -- NB: Don't just check if isFamilyTyCon: this catches *data* families,+         -- which are generative and thus can be preserved during flattening+      | not (isGenerativeTyCon tc Nominal)+      = coreFlattenTyFamApp subst env tc tys++      | otherwise+      = let (env', tys') = coreFlattenTys subst env tys in+        (env', mkTyConApp tc tys')++    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })+      = let (env1, ty1') = go env  ty1+            (env2, ty2') = go env1 ty2+            (env3, mult') = go env2 mult in+        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })++    go env (ForAllTy (Bndr tv vis) ty)+      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv+            (env2, ty') = coreFlattenTy subst' env1 ty in+        (env2, ForAllTy (Bndr tv' vis) ty')++    go env ty@(LitTy {}) = (env, ty)++    go env (CastTy ty co)+      = let (env1, ty') = go env ty+            (env2, co') = coreFlattenCo subst env1 co in+        (env2, CastTy ty' co')++    go env (CoercionTy co)+      = let (env', co') = coreFlattenCo subst env co in+        (env', CoercionTy co')+++-- when flattening, we don't care about the contents of coercions.+-- so, just return a fresh variable of the right (flattened) type+coreFlattenCo :: TvSubstEnv -> FlattenEnv+              -> Coercion -> (FlattenEnv, Coercion)+coreFlattenCo subst env co+  = (env2, mkCoVarCo covar)+  where+    (env1, kind') = coreFlattenTy subst env (coercionType co)+    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'+    -- Add the covar to the FlattenEnv's in-scope set.+    -- See Note [Flattening type-family applications when matching instances], wrinkle 2A.+    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)++coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv+                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)+coreFlattenVarBndr subst env tv+  = (env2, subst', tv')+  where+    -- See Note [Flattening type-family applications when matching instances], wrinkle 2B.+    kind          = varType tv+    (env1, kind') = coreFlattenTy subst env kind+    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')+    subst'        = extendVarEnv subst tv (mkTyVarTy tv')+    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')++coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv+                    -> TyCon         -- type family tycon+                    -> [Type]        -- args, already flattened+                    -> (FlattenEnv, Type)+coreFlattenTyFamApp tv_subst env fam_tc fam_args+  = case lookupTypeMap type_map fam_ty of+      Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args')+      Nothing ->+        let tyvar_name = mkFlattenFreshTyName fam_tc+            tv         = uniqAway in_scope $+                         mkTyVar tyvar_name (typeKind fam_ty)++            ty'   = mkAppTys (mkTyVarTy tv) leftover_args'+            env'' = env' { fe_type_map = extendTypeMap type_map fam_ty+                                                       (tv, fam_tc, sat_fam_args)+                         , fe_in_scope = extendInScopeSet in_scope tv }+        in (env'', ty')+  where+    arity = tyConArity fam_tc+    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv+    (sat_fam_args, leftover_args) = ASSERT( arity <= length fam_args )+                                    splitAt arity fam_args+    -- Apply the substitution before looking up an application in the+    -- environment. See Note [Flattening type-family applications when matching instances],+    -- wrinkle 1.+    -- NB: substTys short-cuts the common case when the substitution is empty.+    sat_fam_args' = substTys tcv_subst sat_fam_args+    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args+    -- `fam_tc` may be over-applied to `fam_args` (see+    -- Note [Flattening type-family applications when matching instances]+    -- wrinkle 3), so we split it into the arguments needed to saturate it+    -- (sat_fam_args') and the rest (leftover_args')+    fam_ty = mkTyConApp fam_tc sat_fam_args'+    FlattenEnv { fe_type_map = type_map+               , fe_in_scope = in_scope } = env'++mkFlattenFreshTyName :: Uniquable a => a -> Name+mkFlattenFreshTyName unq+  = mkSysTvName (getUnique unq) (fsLit "flt")++mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar+mkFlattenFreshCoVar in_scope kind+  = let uniq = unsafeGetFreshLocalUnique in_scope+        name = mkSystemVarName uniq (fsLit "flc")+    in mkCoVar name kind

GHC/Core/UsageEnv.hs view

@@ -1,7 +1,18 @@-{-# LANGUAGE ViewPatterns #-}-module GHC.Core.UsageEnv (UsageEnv, addUsage, scaleUsage, zeroUE,-                          lookupUE, scaleUE, deleteUE, addUE, Usage(..), unitUE,-                          bottomUE, supUE, supUEs) where+module GHC.Core.UsageEnv+  ( Usage(..)+  , UsageEnv+  , addUE+  , addUsage+  , bottomUE+  , deleteUE+  , lookupUE+  , scaleUE+  , scaleUsage+  , supUE+  , supUEs+  , unitUE+  , zeroUE+  ) where  import Data.Foldable import GHC.Prelude@@ -9,6 +20,7 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable+import GHC.Utils.Panic  -- -- * Usage environments

GHC/Core/Utils.hs view

@@ -40,8 +40,8 @@         cheapEqExpr, cheapEqExpr', eqExpr,         diffExpr, diffBinds, -        -- * Eta reduction-        tryEtaReduce,+        -- * Lambdas and eta reduction+        tryEtaReduce, zapLamBndrs,          -- * Manipulating data constructors and types         exprToType, exprToCoercion_maybe,@@ -71,8 +71,10 @@ import GHC.Prelude import GHC.Platform +import GHC.Driver.Ppr+ import GHC.Core-import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofName )+import GHC.Builtin.Names (absentErrorIdKey, makeStaticName, unsafeEqualityProofName) import GHC.Core.Ppr import GHC.Core.FVs( exprFreeVars ) import GHC.Types.Var@@ -81,11 +83,11 @@ import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Literal+import GHC.Types.Tickish import GHC.Core.DataCon import GHC.Builtin.PrimOps import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Builtin.Names( absentErrorIdKey ) import GHC.Core.Type as Type import GHC.Core.Predicate import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )@@ -94,16 +96,16 @@ import GHC.Core.Multiplicity import GHC.Types.Unique import GHC.Utils.Outputable-import GHC.Builtin.Types.Prim+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe import GHC.Data.List.SetOps( minusList )-import GHC.Types.Basic     ( Arity )+import GHC.Types.Basic     ( Arity, FullArgCount ) import GHC.Utils.Misc import GHC.Data.Pair import Data.ByteString     ( ByteString ) import Data.Function       ( on )-import Data.List+import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL ) import Data.Ord            ( comparing ) import GHC.Data.OrdList import qualified Data.Set as Set@@ -136,11 +138,11 @@   = case collectArgs e of         (fun, args) -> applyTypeToArgs e (exprType fun) args -exprType other = pprTrace "exprType" (pprCoreExpr other) alphaTy+exprType other = pprPanic "exprType" (pprCoreExpr other)  coreAltType :: CoreAlt -> Type -- ^ Returns the type of the alternatives right hand side-coreAltType alt@(_,bs,rhs)+coreAltType alt@(Alt _ bs rhs)   = case occCheckExpand bs rhs_ty of       -- Note [Existential variables and silly type synonyms]       Just ty -> ty@@ -338,7 +340,7 @@  -- | Wraps the given expression in the source annotation, dropping the -- annotation if possible.-mkTick :: Tickish Id -> CoreExpr -> CoreExpr+mkTick :: CoreTickish -> CoreExpr -> CoreExpr mkTick t orig_expr = mkTick' id id orig_expr  where   -- Some ticks (cost-centres) can be split in two, with the@@ -423,7 +425,7 @@     -- Catch-all: Annotate where we stand     _any -> top $ Tick t $ rest expr -mkTicks :: [Tickish Id] -> CoreExpr -> CoreExpr+mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr mkTicks ticks expr = foldr mkTick expr ticks  isSaturatedConApp :: CoreExpr -> Bool@@ -434,13 +436,13 @@         go (Cast f _) as = go f as         go _ _ = False -mkTickNoHNF :: Tickish Id -> CoreExpr -> CoreExpr+mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr mkTickNoHNF t e   | exprIsHNF e = tickHNFArgs t e   | otherwise   = mkTick t e  -- push a tick into the arguments of a HNF (call or constructor app)-tickHNFArgs :: Tickish Id -> CoreExpr -> CoreExpr+tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr tickHNFArgs t e = push t e  where   push t (App f (Type u)) = App (push t f) (Type u)@@ -448,28 +450,28 @@   push _t e = e  -- | Strip ticks satisfying a predicate from top of an expression-stripTicksTop :: (Tickish Id -> Bool) -> Expr b -> ([Tickish Id], Expr b)+stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b) stripTicksTop p = go []   where go ts (Tick t e) | p t = go (t:ts) e         go ts other            = (reverse ts, other)  -- | Strip ticks satisfying a predicate from top of an expression, -- returning the remaining expression-stripTicksTopE :: (Tickish Id -> Bool) -> Expr b -> Expr b+stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b stripTicksTopE p = go   where go (Tick t e) | p t = go e         go other            = other  -- | Strip ticks satisfying a predicate from top of an expression, -- returning the ticks-stripTicksTopT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]+stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] stripTicksTopT p = go []   where go ts (Tick t e) | p t = go (t:ts) e         go ts _                = ts  -- | Completely strip ticks satisfying a predicate from an -- expression. Note this is O(n) in the size of the expression!-stripTicksE :: (Tickish Id -> Bool) -> Expr b -> Expr b+stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b stripTicksE p expr = go expr   where go (App e a)        = App (go e) (go a)         go (Lam b e)        = Lam b (go e)@@ -483,9 +485,9 @@         go_bs (NonRec b e)  = NonRec b (go e)         go_bs (Rec bs)      = Rec (map go_b bs)         go_b (b, e)         = (b, go e)-        go_a (c,bs,e)       = (c,bs, go e)+        go_a (Alt c bs e)   = Alt c bs (go e) -stripTicksT :: (Tickish Id -> Bool) -> Expr b -> [Tickish Id]+stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish] stripTicksT p expr = fromOL $ go expr   where go (App e a)        = go e `appOL` go a         go (Lam _ e)        = go e@@ -499,7 +501,7 @@         go_bs (NonRec _ e)  = go e         go_bs (Rec bs)      = concatOL (map go_b bs)         go_b (_, e)         = go e-        go_a (_, _, e)      = go e+        go_a (Alt _ _ e)    = go e  {- ************************************************************************@@ -559,7 +561,7 @@ mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr -- Make (case x of y { DEFAULT -> e } mkDefaultCase scrut case_bndr body-  = Case scrut case_bndr (exprType body) [(DEFAULT, [], body)]+  = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body]  mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr -- Use this function if possible, when building a case,@@ -567,7 +569,7 @@ -- doesn't mention variables bound by the case -- See Note [Care with the type of a case expression] mkSingleAltCase scrut case_bndr con bndrs body-  = Case scrut case_bndr case_ty [(con,bndrs,body)]+  = Case scrut case_bndr case_ty [Alt con bndrs body]   where     body_ty = exprType body @@ -601,7 +603,7 @@  ************************************************************************ *                                                                      *-               Operations oer case alternatives+               Operations over case alternatives *                                                                      * ************************************************************************ @@ -610,30 +612,30 @@ -}  -- | Extract the default case alternative-findDefault :: [(AltCon, [a], b)] -> ([(AltCon, [a], b)], Maybe b)-findDefault ((DEFAULT,args,rhs) : alts) = ASSERT( null args ) (alts, Just rhs)-findDefault alts                        =                     (alts, Nothing)+findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefault (Alt DEFAULT args rhs : alts) = ASSERT( null args ) (alts, Just rhs)+findDefault alts                          =                     (alts, Nothing) -addDefault :: [(AltCon, [a], b)] -> Maybe b -> [(AltCon, [a], b)]+addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b] addDefault alts Nothing    = alts-addDefault alts (Just rhs) = (DEFAULT, [], rhs) : alts+addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts -isDefaultAlt :: (AltCon, a, b) -> Bool-isDefaultAlt (DEFAULT, _, _) = True-isDefaultAlt _               = False+isDefaultAlt :: Alt b -> Bool+isDefaultAlt (Alt DEFAULT _ _) = True+isDefaultAlt _                 = False  -- | Find the case alternative corresponding to a particular -- constructor: panics if no such constructor exists-findAlt :: AltCon -> [(AltCon, a, b)] -> Maybe (AltCon, a, b)+findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)     -- A "Nothing" result *is* legitimate     -- See Note [Unreachable code] findAlt con alts   = case alts of-        (deflt@(DEFAULT,_,_):alts) -> go alts (Just deflt)-        _                          -> go alts Nothing+        (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt)+        _                              -> go alts Nothing   where     go []                     deflt = deflt-    go (alt@(con1,_,_) : alts) deflt+    go (alt@(Alt con1 _ _) : alts) deflt       = case con `cmpAltCon` con1 of           LT -> deflt   -- Missed it already; the alts are in increasing order           EQ -> Just alt@@ -670,7 +672,7 @@ -}  ----------------------------------mergeAlts :: [(AltCon, a, b)] -> [(AltCon, a, b)] -> [(AltCon, a, b)]+mergeAlts :: [Alt a] -> [Alt a] -> [Alt a] -- ^ Merge alternatives preserving order; alternatives in -- the first argument shadow ones in the second mergeAlts [] as2 = as2@@ -699,8 +701,8 @@ filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)            -> [Type]               -- ^ And its type arguments            -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee-           -> [(AltCon, [Var], a)] -- ^ Alternatives-           -> ([AltCon], [(AltCon, [Var], a)])+           -> [Alt b] -- ^ Alternatives+           -> ([AltCon], [Alt b])              -- Returns:              --  1. Constructors that will never be encountered by the              --     *default* case (if any).  A superset of imposs_cons@@ -720,7 +722,7 @@   = (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)   where     (alts_wo_default, maybe_deflt) = findDefault alts-    alt_cons = [con | (con,_,_) <- alts_wo_default]+    alt_cons = [con | Alt con _ _ <- alts_wo_default]      trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default @@ -731,10 +733,10 @@          --   EITHER by the context,          --   OR by a non-DEFAULT branch in this case expression. -    impossible_alt :: [Type] -> (AltCon, a, b) -> Bool-    impossible_alt _ (con, _, _) | con `Set.member` imposs_cons_set = True-    impossible_alt inst_tys (DataAlt con, _, _) = dataConCannotMatch inst_tys con-    impossible_alt _  _                         = False+    impossible_alt :: [Type] -> Alt b -> Bool+    impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True+    impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con+    impossible_alt _  _                             = False  -- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so. -- See Note [Refine DEFAULT case alternatives]@@ -746,7 +748,7 @@                  -> [CoreAlt]                  -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt' refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts-  | (DEFAULT,_,rhs) : rest_alts <- all_alts+  | Alt DEFAULT _ rhs : rest_alts <- all_alts   , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.   , not (isNewTyCon tycon)      -- We can have a newtype, if we are just doing an eval:                                 --      case x of { DEFAULT -> e }@@ -763,7 +765,7 @@        []    -> (False, rest_alts)         -- It matches exactly one constructor, so fill it in:-       [con] -> (True, mergeAlts rest_alts [(DataAlt con, ex_tvs ++ arg_ids, rhs)])+       [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs])                        -- We need the mergeAlts to keep the alternatives in the right order              where                 (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys@@ -946,25 +948,25 @@                          [CoreAlt]) -- New alternatives -- See Note [Combine identical alternatives] -- True <=> we did some combining, result is a single DEFAULT alternative-combineIdenticalAlts imposs_deflt_cons ((con1,bndrs1,rhs1) : rest_alts)+combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)   | all isDeadBinder bndrs1    -- Remember the default   , not (null elim_rest) -- alternative comes first   = (True, imposs_deflt_cons', deflt_alt : filtered_rest)   where     (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts-    deflt_alt = (DEFAULT, [], mkTicks (concat tickss) rhs1)+    deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1)       -- See Note [Care with impossible-constructors when combining alternatives]     imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons-    elim_cons = elim_con1 ++ map fstOf3 elim_rest+    elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest     elim_con1 = case con1 of     -- Don't forget con1!                   DEFAULT -> []  -- See Note [                   _       -> [con1]      cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2-    identical_to_alt1 (_con,bndrs,rhs)+    identical_to_alt1 (Alt _con bndrs rhs)       = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1-    tickss = map (stripTicksT tickishFloatable . thdOf3) elim_rest+    tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest  combineIdenticalAlts imposs_cons alts   = (False, imposs_cons, alts)@@ -975,7 +977,7 @@ scaleAltsBy w alts = map scaleAlt alts   where     scaleAlt :: CoreAlt -> CoreAlt-    scaleAlt (con, bndrs, rhs) = (con, map scaleBndr bndrs, rhs)+    scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs      scaleBndr :: CoreBndr -> CoreBndr     scaleBndr b = scaleVarBy w b@@ -1316,7 +1318,7 @@     go _ (Coercion {})                = True     go n (Cast e _)                   = go n e     go n (Case scrut _ _ alts)        = ok scrut &&-                                        and [ go n rhs | (_,_,rhs) <- alts ]+                                        and [ go n rhs | Alt _ _ rhs <- alts ]     go n (Tick t e) | tickishCounts t = False                     | otherwise       = go n e     go n (Lam x e)  | isRuntimeVar x  = n==0 || go (n-1) e@@ -1509,7 +1511,7 @@ Suppose the user wrote this    {-# RULE  forall x. foo (negate x) = h x #-}    f x = ....(foo (negate x))....-He'd expect the rule to fire. But since negate is overloaded, we might+They'd expect the rule to fire. But since negate is overloaded, we might get this:     f = \d -> let n = negate d in \x -> ...foo (n x)... So we treat the application of a function (negate in this case) to a@@ -1601,7 +1603,7 @@   =  -- See Note [exprOkForSpeculation: case expressions]      expr_ok primop_ok scrut   && isUnliftedType (idType bndr)-  && all (\(_,_,rhs) -> expr_ok primop_ok rhs) alts+  && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts   && altsAreExhaustive alts  expr_ok primop_ok other_expr@@ -1610,7 +1612,7 @@         Var f   -> app_ok primop_ok f args         -- 'LitRubbish' is the only literal that can occur in the head of an         -- application and will not be matched by the above case (Var /= Lit).-        Lit lit -> ASSERT( lit == rubbishLit ) True+        Lit lit -> ASSERT( isRubbishLit lit ) True         _       -> False  -----------------------------@@ -1627,7 +1629,7 @@                 -- to take the arguments into account        PrimOpId op-        | isDivOp op+        | primOpIsDiv op         , [arg1, Lit lit] <- args         -> not (isZeroLit lit) && expr_ok primop_ok arg1               -- Special case for dividing operations that fail@@ -1670,7 +1672,7 @@ -- False <=> they may or may not be altsAreExhaustive []   = False    -- Should not happen-altsAreExhaustive ((con1,_,_) : alts)+altsAreExhaustive (Alt con1 _ _ : alts)   = case con1 of       DEFAULT   -> True       LitAlt {} -> False@@ -1680,19 +1682,6 @@       -- we behave conservatively here -- I don't think it's important       -- enough to deserve special treatment --- | True of dyadic operators that can fail only if the second arg is zero!-isDivOp :: PrimOp -> Bool--- This function probably belongs in GHC.Builtin.PrimOps, or even in--- an automagically generated file.. but it's such a--- special case I thought I'd leave it here for now.-isDivOp IntQuotOp        = True-isDivOp IntRemOp         = True-isDivOp WordQuotOp       = True-isDivOp WordRemOp        = True-isDivOp FloatDivOp       = True-isDivOp DoubleDivOp      = True-isDivOp _                = False- {- Note [exprOkForSpeculation: case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ exprOkForSpeculation accepts very special case expressions.@@ -2102,7 +2091,7 @@ cheapEqExpr = cheapEqExpr' (const False)  -- | Cheap expression equality test, can ignore ticks by type.-cheapEqExpr' :: (Tickish Id -> Bool) -> Expr b -> Expr b -> Bool+cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool {-# INLINE cheapEqExpr' #-} cheapEqExpr' ignoreTick e1 e2   = go e1 e2@@ -2163,12 +2152,14 @@     go _ _ _ = False      ------------    go_alt env (c1, bs1, e1) (c2, bs2, e2)+    go_alt env (Alt c1 bs1 e1) (Alt c2 bs2 e2)       = c1 == c2 && go (rnBndrs2 env bs1 bs2) e1 e2 -eqTickish :: RnEnv2 -> Tickish Id -> Tickish Id -> Bool-eqTickish env (Breakpoint lid lids) (Breakpoint rid rids)-      = lid == rid  &&  map (rnOccL env) lids == map (rnOccR env) rids+eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool+eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)+      = lid == rid &&+        map (rnOccL env) lids == map (rnOccR env) rids &&+        lext == rext eqTickish _ l r = l == r  -- | Finds differences between core expressions, modulo alpha and@@ -2206,7 +2197,7 @@     -- See Note [Empty case alternatives] in GHC.Data.TrieMap   = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)   where env' = rnBndr2 env b1 b2-        diffAlt (c1, bs1, e1) (c2, bs2, e2)+        diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2)           | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]           | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2 diffExpr _  _ e1 e2@@ -2482,7 +2473,7 @@            -> Type             -- Type of the function to which the argument is applied            -> Maybe (Coercion  -- Of type (arg_t -> t1 ~  bndr_t -> t2)                                --   (and similarly for tyvars, coercion args)-                    , [Tickish Var])+                    , [CoreTickish])     -- See Note [Eta reduction with casted arguments]     ok_arg bndr (Type ty) co _        | Just tv <- getTyVar_maybe ty@@ -2522,9 +2513,34 @@ we can eta-reduce    \x. f x  ===>  f  This turned up in #7542.+-} +{- *********************************************************************+*                                                                      *+                  Zapping lambda binders+*                                                                      *+********************************************************************* -} -************************************************************************+zapLamBndrs :: FullArgCount -> [Var] -> [Var]+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear under the \x+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs+zapLamBndrs arg_count bndrs+  | no_need_to_zap = bndrs+  | otherwise      = zap_em arg_count bndrs+  where+    no_need_to_zap = all isOneShotBndr (drop arg_count bndrs)++    zap_em :: FullArgCount -> [Var] -> [Var]+    zap_em 0 bs = bs+    zap_em _ [] = []+    zap_em n (b:bs) | isTyVar b = b              : zap_em (n-1) bs+                    | otherwise = zapLamIdInfo b : zap_em (n-1) bs+++{- ********************************************************************* *                                                                      * \subsection{Determining non-updatable right-hand-sides} *                                                                      *@@ -2621,4 +2637,3 @@   = idName v == unsafeEqualityProofName   | otherwise   = False-

− GHC/CoreToByteCode.hs

@@ -1,2066 +0,0 @@-{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE PatternSynonyms #-}-{-# OPTIONS_GHC -fprof-auto-top #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------  (c) The University of Glasgow 2002-2006------- | GHC.CoreToByteCode: Generate bytecode from Core-module GHC.CoreToByteCode ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.ByteCode.Instr-import GHC.ByteCode.Asm-import GHC.ByteCode.Types--import GHC.Runtime.Interpreter-import GHCi.FFI-import GHCi.RemoteTypes-import GHC.Types.Basic-import GHC.Driver.Session-import GHC.Utils.Outputable-import GHC.Platform-import GHC.Types.Name-import GHC.Types.Id.Make-import GHC.Types.Id-import GHC.Types.ForeignCall-import GHC.Driver.Types-import GHC.Core.Utils-import GHC.Core-import GHC.Core.Ppr-import GHC.Types.Literal-import GHC.Builtin.PrimOps-import GHC.Core.FVs-import GHC.Core.Type-import GHC.Types.RepType-import GHC.Core.DataCon-import GHC.Core.TyCon-import GHC.Utils.Misc-import GHC.Types.Var.Set-import GHC.Builtin.Types.Prim-import GHC.Core.TyCo.Ppr ( pprType )-import GHC.Utils.Error-import GHC.Types.Unique-import GHC.Data.FastString-import GHC.Utils.Panic-import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )-import GHC.StgToCmm.Layout-import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)-import GHC.Data.Bitmap-import GHC.Data.OrdList-import GHC.Data.Maybe-import GHC.Types.Var.Env-import GHC.Builtin.Names ( unsafeEqualityProofName )--import Data.List-import Foreign-import Control.Monad-import Data.Char--import GHC.Types.Unique.Supply-import GHC.Unit.Module--import Control.Exception-import Data.Array-import Data.ByteString (ByteString)-import Data.Map (Map)-import Data.IntMap (IntMap)-import qualified Data.Map as Map-import qualified Data.IntMap as IntMap-import qualified GHC.Data.FiniteMap as Map-import Data.Ord-import GHC.Stack.CCS-import Data.Either ( partitionEithers )---- -------------------------------------------------------------------------------- Generating byte code for a complete module--byteCodeGen :: HscEnv-            -> Module-            -> CoreProgram-            -> [TyCon]-            -> Maybe ModBreaks-            -> IO CompiledByteCode-byteCodeGen hsc_env this_mod binds tycs mb_modBreaks-   = withTiming dflags-                (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod))-                (const ()) $ do-        -- Split top-level binds into strings and others.-        -- See Note [generating code for top-level string literal bindings].-        let (strings, flatBinds) = partitionEithers $ do  -- list monad-                (bndr, rhs) <- flattenBinds binds-                return $ case exprIsTickedString_maybe rhs of-                    Just str -> Left (bndr, str)-                    _ -> Right (bndr, simpleFreeVars rhs)-        stringPtrs <- allocateTopStrings hsc_env strings--        us <- mkSplitUniqSupply 'y'-        (BcM_State{..}, proto_bcos) <--           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $-             mapM schemeTopBind flatBinds--        when (notNull ffis)-             (panic "GHC.CoreToByteCode.byteCodeGen: missing final emitBc?")--        dumpIfSet_dyn dflags Opt_D_dump_BCOs-           "Proto-BCOs" FormatByteCode-           (vcat (intersperse (char ' ') (map ppr proto_bcos)))--        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)-          (case modBreaks of-             Nothing -> Nothing-             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })--        -- Squash space leaks in the CompiledByteCode.  This is really-        -- important, because when loading a set of modules into GHCi-        -- we don't touch the CompiledByteCode until the end when we-        -- do linking.  Forcing out the thunks here reduces space-        -- usage by more than 50% when loading a large number of-        -- modules.-        evaluate (seqCompiledByteCode cbc)--        return cbc--  where dflags = hsc_dflags hsc_env--allocateTopStrings-  :: HscEnv-  -> [(Id, ByteString)]-  -> IO [(Var, RemotePtr ())]-allocateTopStrings hsc_env topStrings = do-  let !(bndrs, strings) = unzip topStrings-  ptrs <- iservCmd hsc_env $ MallocStrings strings-  return $ zip bndrs ptrs--{--Note [generating code for top-level string literal bindings]--Here is a summary on how the byte code generator deals with top-level string-literals:--1. Top-level string literal bindings are separated from the rest of the module.--2. The strings are allocated via iservCmd, in allocateTopStrings--3. The mapping from binders to allocated strings (topStrings) are maintained in-   BcM and used when generating code for variable references.--}---- -------------------------------------------------------------------------------- Generating byte code for an expression---- Returns: the root BCO for this expression-coreExprToBCOs :: HscEnv-               -> Module-               -> CoreExpr-               -> IO UnlinkedBCO-coreExprToBCOs hsc_env this_mod expr- = withTiming dflags-              (text "GHC.CoreToByteCode"<+>brackets (ppr this_mod))-              (const ()) $ do-      -- create a totally bogus name for the top-level BCO; this-      -- should be harmless, since it's never used for anything-      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")--      -- the uniques are needed to generate fresh variables when we introduce new-      -- let bindings for ticked expressions-      us <- mkSplitUniqSupply 'y'-      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)-         <- runBc hsc_env us this_mod Nothing emptyVarEnv $-              schemeR [] (invented_name, simpleFreeVars expr)--      when (notNull mallocd)-           (panic "GHC.CoreToByteCode.coreExprToBCOs: missing final emitBc?")--      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" FormatByteCode-         (ppr proto_bco)--      assembleOneBCO hsc_env proto_bco-  where dflags = hsc_dflags hsc_env---- The regular freeVars function gives more information than is useful to--- us here. We need only the free variables, not everything in an FVAnn.--- Historical note: At one point FVAnn was more sophisticated than just--- a set. Now it isn't. So this function is much simpler. Keeping it around--- so that if someone changes FVAnn, they will get a nice type error right--- here.-simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet-simpleFreeVars = freeVars---- -------------------------------------------------------------------------------- Compilation schema for the bytecode generator--type BCInstrList = OrdList BCInstr--newtype ByteOff = ByteOff Int-    deriving (Enum, Eq, Integral, Num, Ord, Real)--newtype WordOff = WordOff Int-    deriving (Enum, Eq, Integral, Num, Ord, Real)--wordsToBytes :: Platform -> WordOff -> ByteOff-wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral---- Used when we know we have a whole number of words-bytesToWords :: Platform -> ByteOff -> WordOff-bytesToWords platform (ByteOff bytes) =-    let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)-    in if r == 0-           then fromIntegral q-           else panic $ "GHC.CoreToByteCode.bytesToWords: bytes=" ++ show bytes--wordSize :: Platform -> ByteOff-wordSize platform = ByteOff (platformWordSizeInBytes platform)--type Sequel = ByteOff -- back off to this depth before ENTER--type StackDepth = ByteOff---- | Maps Ids to their stack depth. This allows us to avoid having to mess with--- it after each push/pop.-type BCEnv = Map Id StackDepth -- To find vars on the stack--{--ppBCEnv :: BCEnv -> SDoc-ppBCEnv p-   = text "begin-env"-     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))-     $$ text "end-env"-     where-        pp_one (var, offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgRep var)-        cmp_snd x y = compare (snd x) (snd y)--}---- Create a BCO and do a spot of peephole optimisation on the insns--- at the same time.-mkProtoBCO-   :: DynFlags-   -> name-   -> BCInstrList-   -> Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet)-        -- ^ original expression; for debugging only-   -> Int-   -> Word16-   -> [StgWord]-   -> Bool      -- True <=> is a return point, rather than a function-   -> [FFIInfo]-   -> ProtoBCO name-mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis-   = ProtoBCO {-        protoBCOName = nm,-        protoBCOInstrs = maybe_with_stack_check,-        protoBCOBitmap = bitmap,-        protoBCOBitmapSize = bitmap_size,-        protoBCOArity = arity,-        protoBCOExpr = origin,-        protoBCOFFIs = ffis-      }-     where-        -- Overestimate the stack usage (in words) of this BCO,-        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit-        -- stack check.  (The interpreter always does a stack check-        -- for iNTERP_STACK_CHECK_THRESH words at the start of each-        -- BCO anyway, so we only need to add an explicit one in the-        -- (hopefully rare) cases when the (overestimated) stack use-        -- exceeds iNTERP_STACK_CHECK_THRESH.-        maybe_with_stack_check-           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d-                -- don't do stack checks at return points,-                -- everything is aggregated up to the top BCO-                -- (which must be a function).-                -- That is, unless the stack usage is >= AP_STACK_SPLIM,-                -- see bug #1466.-           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH-           = STKCHECK stack_usage : peep_d-           | otherwise-           = peep_d     -- the supposedly common case--        -- We assume that this sum doesn't wrap-        stack_usage = sum (map bciStackUse peep_d)--        -- Merge local pushes-        peep_d = peep (fromOL instrs_ordlist)--        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)-           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest-        peep (PUSH_L off1 : PUSH_L off2 : rest)-           = PUSH_LL off1 (off2-1) : peep rest-        peep (i:rest)-           = i : peep rest-        peep []-           = []--argBits :: Platform -> [ArgRep] -> [Bool]-argBits _        [] = []-argBits platform (rep : args)-  | isFollowableArg rep  = False : argBits platform args-  | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args---- -------------------------------------------------------------------------------- schemeTopBind---- Compile code for the right-hand side of a top-level binding--schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)-schemeTopBind (id, rhs)-  | Just data_con <- isDataConWorkId_maybe id,-    isNullaryRepDataCon data_con = do-    dflags <- getDynFlags-        -- Special case for the worker of a nullary data con.-        -- It'll look like this:        Nil = /\a -> Nil a-        -- If we feed it into schemeR, we'll get-        --      Nil = Nil-        -- because mkConAppCode treats nullary constructor applications-        -- by just re-using the single top-level definition.  So-        -- for the worker itself, we must allocate it directly.-    -- ioToBc (putStrLn $ "top level BCO")-    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])-                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})--  | otherwise-  = schemeR [{- No free variables -}] (getName id, rhs)----- -------------------------------------------------------------------------------- schemeR---- Compile code for a right-hand side, to give a BCO that,--- when executed with the free variables and arguments on top of the stack,--- will return with a pointer to the result on top of the stack, after--- removing the free variables and arguments.------ Park the resulting BCO in the monad.  Also requires the--- name of the variable to which this value was bound,--- so as to give the resulting BCO a name.--schemeR :: [Id]                 -- Free vars of the RHS, ordered as they-                                -- will appear in the thunk.  Empty for-                                -- top-level things, which have no free vars.-        -> (Name, AnnExpr Id DVarSet)-        -> BcM (ProtoBCO Name)-schemeR fvs (nm, rhs)-{--   | trace (showSDoc (-              (char ' '-               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs-               $$ pprCoreExpr (deAnnotate rhs)-               $$ char ' '-              ))) False-   = undefined-   | otherwise--}-   = schemeR_wrk fvs nm rhs (collect rhs)---- If an expression is a lambda, return the--- list of arguments to the lambda (in R-to-L order) and the--- underlying expression-collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)-collect (_, e) = go [] e-  where-    go xs e | Just e' <- bcView e = go xs e'-    go xs (AnnLam x (_,e))-      | typePrimRep (idType x) `lengthExceeds` 1-      = multiValException-      | otherwise-      = go (x:xs) e-    go xs not_lambda = (reverse xs, not_lambda)--schemeR_wrk-    :: [Id]-    -> Name-    -> AnnExpr Id DVarSet             -- expression e, for debugging only-    -> ([Var], AnnExpr' Var DVarSet)  -- result of collect on e-    -> BcM (ProtoBCO Name)-schemeR_wrk fvs nm original_body (args, body)-   = do-     dflags <- getDynFlags-     let-         platform  = targetPlatform dflags-         all_args  = reverse args ++ fvs-         arity     = length all_args-         -- all_args are the args in reverse order.  We're compiling a function-         -- \fv1..fvn x1..xn -> e-         -- i.e. the fvs come first--         -- Stack arguments always take a whole number of words, we never pack-         -- them unlike constructor fields.-         szsb_args = map (wordsToBytes platform . idSizeW platform) all_args-         sum_szsb_args  = sum szsb_args-         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))--         -- make the arg bitmap-         bits = argBits platform (reverse (map bcIdArgRep all_args))-         bitmap_size = genericLength bits-         bitmap = mkBitmap platform bits-     body_code <- schemeER_wrk sum_szsb_args p_init body--     emitBc (mkProtoBCO dflags nm body_code (Right original_body)-                 arity bitmap_size bitmap False{-not alts-})---- introduce break instructions for ticked expressions-schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-schemeER_wrk d p rhs-  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs-  = do  code <- schemeE d 0 p newRhs-        cc_arr <- getCCArray-        this_mod <- moduleName <$> getCurrentModule-        dflags <- getDynFlags-        let platform = targetPlatform dflags-        let idOffSets = getVarOffSets platform d p fvs-        let breakInfo = CgBreakInfo-                        { cgb_vars = idOffSets-                        , cgb_resty = exprType (deAnnotate' newRhs)-                        }-        newBreakInfo tick_no breakInfo-        hsc_env <- getHscEnv-        let cc | Just interp <- hsc_interp hsc_env-               , interpreterProfiled interp-               = cc_arr ! tick_no-               | otherwise = toRemotePtr nullPtr-        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc-        return $ breakInstr `consOL` code-   | otherwise = schemeE d 0 p rhs--getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]-getVarOffSets platform depth env = map getOffSet-  where-    getOffSet id = case lookupBCEnv_maybe id env of-        Nothing     -> Nothing-        Just offset ->-            -- michalt: I'm not entirely sure why we need the stack-            -- adjustment by 2 here. I initially thought that there's-            -- something off with getIdValFromApStack (the only user of this-            -- value), but it looks ok to me. My current hypothesis is that-            -- this "adjustment" is needed due to stack manipulation for-            -- BRK_FUN in Interpreter.c In any case, this is used only when-            -- we trigger a breakpoint.-            let !var_depth_ws =-                    trunc16W $ bytesToWords platform (depth - offset) + 2-            in Just (id, var_depth_ws)--truncIntegral16 :: Integral a => a -> Word16-truncIntegral16 w-    | w > fromIntegral (maxBound :: Word16)-    = panic "stack depth overflow"-    | otherwise-    = fromIntegral w--trunc16B :: ByteOff -> Word16-trunc16B = truncIntegral16--trunc16W :: WordOff -> Word16-trunc16W = truncIntegral16--fvsToEnv :: BCEnv -> DVarSet -> [Id]--- Takes the free variables of a right-hand side, and--- delivers an ordered list of the local variables that will--- be captured in the thunk for the RHS--- The BCEnv argument tells which variables are in the local--- environment: these are the ones that should be captured------ The code that constructs the thunk, and the code that executes--- it, have to agree about this layout-fvsToEnv p fvs = [v | v <- dVarSetElems fvs,-                      isId v,           -- Could be a type variable-                      v `Map.member` p]---- -------------------------------------------------------------------------------- schemeE--returnUnboxedAtom-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> AnnExpr' Id DVarSet-    -> ArgRep-    -> BcM BCInstrList--- Returning an unlifted value.--- Heave it on the stack, SLIDE, and RETURN.-returnUnboxedAtom d s p e e_rep = do-    dflags <- getDynFlags-    let platform = targetPlatform dflags-    (push, szb) <- pushAtom d p e-    return (push                                  -- value onto stack-           `appOL`  mkSlideB platform szb (d - s) -- clear to sequel-           `snocOL` RETURN_UBX e_rep)             -- go---- Compile code to apply the given expression to the remaining args--- on the stack, returning a HNF.-schemeE-    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-schemeE d s p e-   | Just e' <- bcView e-   = schemeE d s p e'---- Delegate tail-calls to schemeT.-schemeE d s p e@(AnnApp _ _) = schemeT d s p e--schemeE d s p e@(AnnLit lit)     = returnUnboxedAtom d s p e (typeArgRep (literalType lit))-schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e V--schemeE d s p e@(AnnVar v)-      -- See Note [Not-necessarily-lifted join points], step 3.-    | isNNLJoinPoint v          = doTailCall d s p (protectNNLJoinPointId v) [AnnVar voidPrimId]-    | isUnliftedType (idType v) = returnUnboxedAtom d s p e (bcIdArgRep v)-    | otherwise                 = schemeT d s p e--schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body))-   | (AnnVar v, args_r_to_l) <- splitApp rhs,-     Just data_con <- isDataConWorkId_maybe v,-     dataConRepArity data_con == length args_r_to_l-   = do -- Special case for a non-recursive let whose RHS is a-        -- saturated constructor application.-        -- Just allocate the constructor and carry on-        alloc_code <- mkConAppCode d s p data_con args_r_to_l-        platform <- targetPlatform <$> getDynFlags-        let !d2 = d + wordSize platform-        body_code <- schemeE d2 s (Map.insert x d2 p) body-        return (alloc_code `appOL` body_code)---- General case for let.  Generates correct, if inefficient, code in--- all situations.-schemeE d s p (AnnLet binds (_,body)) = do-     platform <- targetPlatform <$> getDynFlags-     let (xs,rhss) = case binds of AnnNonRec x rhs  -> ([x],[rhs])-                                   AnnRec xs_n_rhss -> unzip xs_n_rhss-         n_binds = genericLength xs--         fvss  = map (fvsToEnv p' . fst) rhss--           -- See Note [Not-necessarily-lifted join points], step 2.-         (xs',rhss') = zipWithAndUnzip protectNNLJoinPointBind xs rhss--         -- Sizes of free vars-         size_w = trunc16W . idSizeW platform-         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss--         -- the arity of each rhs-         arities = map (genericLength . fst . collect) rhss'--         -- This p', d' defn is safe because all the items being pushed-         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack-         -- after the closures have been allocated in the heap (but not-         -- filled in), and pointers to them parked on the stack.-         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))-         p' = Map.insertList (zipE xs' offsets) p-         d' = d + wordsToBytes platform n_binds-         zipE = zipEqual "schemeE"--         -- ToDo: don't build thunks for things with no free variables-         build_thunk-             :: StackDepth-             -> [Id]-             -> Word16-             -> ProtoBCO Name-             -> Word16-             -> Word16-             -> BcM BCInstrList-         build_thunk _ [] size bco off arity-            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))-           where-                mkap | arity == 0 = MKAP-                     | otherwise  = MKPAP-         build_thunk dd (fv:fvs) size bco off arity = do-              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)-              more_push_code <--                  build_thunk (dd + pushed_szb) fvs size bco off arity-              return (push_code `appOL` more_push_code)--         alloc_code = toOL (zipWith mkAlloc sizes arities)-           where mkAlloc sz 0-                    | is_tick     = ALLOC_AP_NOUPD sz-                    | otherwise   = ALLOC_AP sz-                 mkAlloc sz arity = ALLOC_PAP arity sz--         is_tick = case binds of-                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS-                     _other -> False--         compile_bind d' fvs x rhs size arity off = do-                bco <- schemeR fvs (getName x,rhs)-                build_thunk d' fvs size bco off arity--         compile_binds =-            [ compile_bind d' fvs x rhs size arity (trunc16W n)-            | (fvs, x, rhs, size, arity, n) <--                zip6 fvss xs' rhss' sizes arities [n_binds, n_binds-1 .. 1]-            ]-     body_code <- schemeE d' s p' body-     thunk_codes <- sequence compile_binds-     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)---- Introduce a let binding for a ticked case expression. This rule--- *should* only fire when the expression was not already let-bound--- (the code gen for let bindings should take care of that).  Todo: we--- call exprFreeVars on a deAnnotated expression, this may not be the--- best way to calculate the free vars but it seemed like the least--- intrusive thing to do-schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)-   | isLiftedTypeKind (typeKind ty)-   = do   id <- newId ty-          -- Todo: is emptyVarSet correct on the next line?-          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)-          schemeE d s p letExp--   | otherwise-   = do   -- If the result type is not definitely lifted, then we must generate-          --   let f = \s . tick<n> e-          --   in  f realWorld#-          -- When we stop at the breakpoint, _result will have an unlifted-          -- type and hence won't be bound in the environment, but the-          -- breakpoint will otherwise work fine.-          ---          -- NB (#12007) this /also/ applies for if (ty :: TYPE r), where-          --    r :: RuntimeRep is a variable. This can happen in the-          --    continuations for a pattern-synonym matcher-          --    match = /\(r::RuntimeRep) /\(a::TYPE r).-          --            \(k :: Int -> a) \(v::T).-          --            case v of MkV n -> k n-          -- Here (k n) :: a :: Type r, so we don't know if it's lifted-          -- or not; but that should be fine provided we add that void arg.--          id <- newId (mkVisFunTyMany realWorldStatePrimTy ty)-          st <- newId realWorldStatePrimTy-          let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyDVarSet, exp)))-                              (emptyDVarSet, (AnnApp (emptyDVarSet, AnnVar id)-                                                    (emptyDVarSet, AnnVar realWorldPrimId)))-          schemeE d s p letExp--   where-     exp' = deAnnotate' exp-     fvs  = exprFreeVarsDSet exp'-     ty   = exprType exp'---- ignore other kinds of tick-schemeE d s p (AnnTick _ (_, rhs)) = schemeE d s p rhs---- no alts: scrut is guaranteed to diverge-schemeE d s p (AnnCase (_,scrut) _ _ []) = schemeE d s p scrut---- handle pairs with one void argument (e.g. state token)-schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])-   | isUnboxedTupleCon dc-        -- Convert-        --      case .... of x { (# V'd-thing, a #) -> ... }-        -- to-        --      case .... of a { DEFAULT -> ... }-        -- because the return convention for both are identical.-        ---        -- Note that it does not matter losing the void-rep thing from the-        -- envt (it won't be bound now) because we never look such things up.-   , Just res <- case (typePrimRep (idType bind1), typePrimRep (idType bind2)) of-                   ([], [_])-                     -> Just $ doCase d s p scrut bind2 [(DEFAULT, [], rhs)] (Just bndr)-                   ([_], [])-                     -> Just $ doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)-                   _ -> Nothing-   = res---- handle unit tuples-schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])-   | isUnboxedTupleCon dc-   , typePrimRep (idType bndr) `lengthAtMost` 1-   = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)---- handle nullary tuples-schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])-   | isUnboxedTupleType (idType bndr)-   , Just ty <- case typePrimRep (idType bndr) of-       [_]  -> Just (unwrapType (idType bndr))-       []   -> Just voidPrimTy-       _    -> Nothing-       -- handles any pattern with a single non-void binder; in particular I/O-       -- monad returns (# RealWorld#, a #)-   = doCase d s p scrut (bndr `setIdType` ty) alt (Just bndr)--schemeE d s p (AnnCase scrut bndr _ alts)-   = doCase d s p scrut bndr alts Nothing{-not an unboxed tuple-}--schemeE _ _ _ expr-   = pprPanic "GHC.CoreToByteCode.schemeE: unhandled case"-               (pprCoreExpr (deAnnotate' expr))---- Is this Id a not-necessarily-lifted join point?--- See Note [Not-necessarily-lifted join points], step 1-isNNLJoinPoint :: Id -> Bool-isNNLJoinPoint x = isJoinId x &&-                   Just True /= isLiftedType_maybe (idType x)---- If necessary, modify this Id and body to protect not-necessarily-lifted join points.--- See Note [Not-necessarily-lifted join points], step 2.-protectNNLJoinPointBind :: Id -> AnnExpr Id DVarSet -> (Id, AnnExpr Id DVarSet)-protectNNLJoinPointBind x rhs@(fvs, _)-  | isNNLJoinPoint x-  = (protectNNLJoinPointId x, (fvs, AnnLam voidArgId rhs))--  | otherwise-  = (x, rhs)---- Update an Id's type to take a Void# argument.--- Precondition: the Id is a not-necessarily-lifted join point.--- See Note [Not-necessarily-lifted join points]-protectNNLJoinPointId :: Id -> Id-protectNNLJoinPointId x-  = ASSERT( isNNLJoinPoint x )-    updateIdTypeButNotMult (voidPrimTy `mkVisFunTyMany`) x--{--   Ticked Expressions-   --------------------  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on-  the code. When we find such a thing, we pull out the useful information,-  and then compile the code as if it was just the expression E.--Note [Not-necessarily-lifted join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A join point variable is essentially a goto-label: it is, for example,-never used as an argument to another function, and it is called only-in tail position. See Note [Join points] and Note [Invariants on join points],-both in GHC.Core. Because join points do not compile to true, red-blooded-variables (with, e.g., registers allocated to them), they are allowed-to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]-in GHC.Core.)--However, in this byte-code generator, join points *are* treated just as-ordinary variables. There is no check whether a binding is for a join point-or not; they are all treated uniformly. (Perhaps there is a missed optimization-opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)--We thus must have *some* strategy for dealing with levity-polymorphic and-unlifted join points. Levity-polymorphic variables are generally not allowed-(though levity-polymorphic join points *are*; see Note [Invariants on join points]-in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.-The questionable join points are *not-necessarily-lifted join points*-(NNLJPs). (Not having such a strategy led to #16509, which panicked in the-isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:--1. Detect NNLJPs. This is done in isNNLJoinPoint.--2. When binding an NNLJP, add a `\ (_ :: Void#) ->` to its RHS, and modify the-   type to tack on a `Void# ->`. (Void# is written voidPrimTy within GHC.)-   Note that functions are never levity-polymorphic, so this transformation-   changes an NNLJP to a non-levity-polymorphic join point. This is done-   in protectNNLJoinPointBind, called from the AnnLet case of schemeE.--3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),-   being careful to note the new type of the NNLJP. This is done in the AnnVar-   case of schemeE, with help from protectNNLJoinPointId.--Here is an example. Suppose we have--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      join j :: a-           j = error @r @a "bloop"-      in case x of-           A -> j-           B -> j-           C -> error @r @a "blurp"--Our plan is to behave is if the code was--  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).-      let j :: (Void# -> a)-          j = \ _ -> error @r @a "bloop"-      in case x of-           A -> j void#-           B -> j void#-           C -> error @r @a "blurp"--It's a bit hacky, but it works well in practice and is local. I suspect the-Right Fix is to take advantage of join points as goto-labels.---}---- Compile code to do a tail call.  Specifically, push the fn,--- slide the on-stack app back down to the sequel depth,--- and enter.  Four cases:------ 0.  (Nasty hack).---     An application "GHC.Prim.tagToEnum# <type> unboxed-int".---     The int will be on the stack.  Generate a code sequence---     to convert it to the relevant constructor, SLIDE and ENTER.------ 1.  The fn denotes a ccall.  Defer to generateCCall.------ 2.  (Another nasty hack).  Spot (# a::V, b #) and treat---     it simply as  b  -- since the representations are identical---     (the V takes up zero stack space).  Also, spot---     (# b #) and treat it as  b.------ 3.  Application of a constructor, by defn saturated.---     Split the args into ptrs and non-ptrs, and push the nonptrs,---     then the ptrs, and then do PACK and RETURN.------ 4.  Otherwise, it must be a function call.  Push the args---     right to left, SLIDE and ENTER.--schemeT :: StackDepth   -- Stack depth-        -> Sequel       -- Sequel depth-        -> BCEnv        -- stack env-        -> AnnExpr' Id DVarSet-        -> BcM BCInstrList--schemeT d s p app--   -- Case 0-   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app-   = implement_tagToId d s p arg constr_names--   -- Case 1-   | Just (CCall ccall_spec) <- isFCallId_maybe fn-   = if isSupportedCConv ccall_spec-      then generateCCall d s p ccall_spec fn args_r_to_l-      else unsupportedCConvException---   -- Case 2: Constructor application-   | Just con <- maybe_saturated_dcon-   , isUnboxedTupleCon con-   = case args_r_to_l of-        [arg1,arg2] | isVAtom arg1 ->-                  unboxedTupleReturn d s p arg2-        [arg1,arg2] | isVAtom arg2 ->-                  unboxedTupleReturn d s p arg1-        _other -> multiValException--   -- Case 3: Ordinary data constructor-   | Just con <- maybe_saturated_dcon-   = do alloc_con <- mkConAppCode d s p con args_r_to_l-        dflags <- getDynFlags-        let platform = targetPlatform dflags-        return (alloc_con         `appOL`-                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`-                ENTER)--   -- Case 4: Tail call of function-   | otherwise-   = doTailCall d s p fn args_r_to_l--   where-        -- Extract the args (R->L) and fn-        -- The function will necessarily be a variable,-        -- because we are compiling a tail call-      (AnnVar fn, args_r_to_l) = splitApp app--      -- Only consider this to be a constructor application iff it is-      -- saturated.  Otherwise, we'll call the constructor wrapper.-      n_args = length args_r_to_l-      maybe_saturated_dcon-        = case isDataConWorkId_maybe fn of-                Just con | dataConRepArity con == n_args -> Just con-                _ -> Nothing---- -------------------------------------------------------------------------------- Generate code to build a constructor application,--- leaving it on top of the stack--mkConAppCode-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> DataCon                  -- The data constructor-    -> [AnnExpr' Id DVarSet]    -- Args, in *reverse* order-    -> BcM BCInstrList-mkConAppCode _ _ _ con []       -- Nullary constructor-  = ASSERT( isNullaryRepDataCon con )-    return (unitOL (PUSH_G (getName (dataConWorkId con))))-        -- Instead of doing a PACK, which would allocate a fresh-        -- copy of this constructor, use the single shared version.--mkConAppCode orig_d _ p con args_r_to_l =-    ASSERT( args_r_to_l `lengthIs` dataConRepArity con ) app_code-  where-    app_code = do-        dflags <- getDynFlags-        let platform = targetPlatform dflags--        -- The args are initially in reverse order, but mkVirtHeapOffsets-        -- expects them to be left-to-right.-        let non_voids =-                [ NonVoid (prim_rep, arg)-                | arg <- reverse args_r_to_l-                , let prim_rep = atomPrimRep arg-                , not (isVoidRep prim_rep)-                ]-            (_, _, args_offsets) =-                mkVirtHeapOffsetsWithPadding dflags StdHeader non_voids--            do_pushery !d (arg : args) = do-                (push, arg_bytes) <- case arg of-                    (Padding l _) -> return $! pushPadding l-                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)-                more_push_code <- do_pushery (d + arg_bytes) args-                return (push `appOL` more_push_code)-            do_pushery !d [] = do-                let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d)-                return (unitOL (PACK con n_arg_words))--        -- Push on the stack in the reverse order.-        do_pushery orig_d (reverse args_offsets)----- -------------------------------------------------------------------------------- Returning an unboxed tuple with one non-void component (the only--- case we can handle).------ Remember, we don't want to *evaluate* the component that is being--- returned, even if it is a pointed type.  We always just return.--unboxedTupleReturn-    :: StackDepth -> Sequel -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList-unboxedTupleReturn d s p arg = returnUnboxedAtom d s p arg (atomRep arg)---- -------------------------------------------------------------------------------- Generate code for a tail-call--doTailCall-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> Id-    -> [AnnExpr' Id DVarSet]-    -> BcM BCInstrList-doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args)-  where-  do_pushes !d [] reps = do-        ASSERT( null reps ) return ()-        (push_fn, sz) <- pushAtom d p (AnnVar fn)-        dflags <- getDynFlags-        let platform = targetPlatform dflags-        ASSERT( sz == wordSize platform ) return ()-        let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)-        return (push_fn `appOL` (slide `appOL` unitOL ENTER))-  do_pushes !d args reps = do-      let (push_apply, n, rest_of_reps) = findPushSeq reps-          (these_args, rest_of_args) = splitAt n args-      (next_d, push_code) <- push_seq d these_args-      dflags <- getDynFlags-      let platform = targetPlatform dflags-      instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps-      --                          ^^^ for the PUSH_APPLY_ instruction-      return (push_code `appOL` (push_apply `consOL` instrs))--  push_seq d [] = return (d, nilOL)-  push_seq d (arg:args) = do-    (push_code, sz) <- pushAtom d p arg-    (final_d, more_push_code) <- push_seq (d + sz) args-    return (final_d, push_code `appOL` more_push_code)---- v. similar to CgStackery.findMatch, ToDo: merge-findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])-findPushSeq (P: P: P: P: P: P: rest)-  = (PUSH_APPLY_PPPPPP, 6, rest)-findPushSeq (P: P: P: P: P: rest)-  = (PUSH_APPLY_PPPPP, 5, rest)-findPushSeq (P: P: P: P: rest)-  = (PUSH_APPLY_PPPP, 4, rest)-findPushSeq (P: P: P: rest)-  = (PUSH_APPLY_PPP, 3, rest)-findPushSeq (P: P: rest)-  = (PUSH_APPLY_PP, 2, rest)-findPushSeq (P: rest)-  = (PUSH_APPLY_P, 1, rest)-findPushSeq (V: rest)-  = (PUSH_APPLY_V, 1, rest)-findPushSeq (N: rest)-  = (PUSH_APPLY_N, 1, rest)-findPushSeq (F: rest)-  = (PUSH_APPLY_F, 1, rest)-findPushSeq (D: rest)-  = (PUSH_APPLY_D, 1, rest)-findPushSeq (L: rest)-  = (PUSH_APPLY_L, 1, rest)-findPushSeq _-  = panic "GHC.CoreToByteCode.findPushSeq"---- -------------------------------------------------------------------------------- Case expressions--doCase-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> AnnExpr Id DVarSet-    -> Id-    -> [AnnAlt Id DVarSet]-    -> Maybe Id  -- Just x <=> is an unboxed tuple case with scrut binder,-                 -- don't enter the result-    -> BcM BCInstrList-doCase d s p (_,scrut) bndr alts is_unboxed_tuple-  | typePrimRep (idType bndr) `lengthExceeds` 1-  = multiValException--  | otherwise-  = do-     dflags <- getDynFlags-     hsc_env <- getHscEnv-     let-        platform = targetPlatform dflags-        profiling-          | Just interp <- hsc_interp hsc_env-          = interpreterProfiled interp-          | otherwise = False--        -- Top of stack is the return itbl, as usual.-        -- underneath it is the pointer to the alt_code BCO.-        -- When an alt is entered, it assumes the returned value is-        -- on top of the itbl.-        ret_frame_size_b :: StackDepth-        ret_frame_size_b = 2 * wordSize platform--        -- The extra frame we push to save/restore the CCCS when profiling-        save_ccs_size_b | profiling = 2 * wordSize platform-                        | otherwise = 0--        -- An unlifted value gets an extra info table pushed on top-        -- when it is returned.-        unlifted_itbl_size_b :: StackDepth-        unlifted_itbl_size_b | isAlgCase = 0-                             | otherwise = wordSize platform--        -- depth of stack after the return value has been pushed-        d_bndr =-            d + ret_frame_size_b + wordsToBytes platform (idSizeW platform bndr)--        -- depth of stack after the extra info table for an unboxed return-        -- has been pushed, if any.  This is the stack depth at the-        -- continuation.-        d_alts = d_bndr + unlifted_itbl_size_b--        -- Env in which to compile the alts, not including-        -- any vars bound by the alts themselves-        p_alts0 = Map.insert bndr d_bndr p--        p_alts = case is_unboxed_tuple of-                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0-                   Nothing       -> p_alts0--        bndr_ty = idType bndr-        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple--        -- given an alt, return a discr and code for it.-        codeAlt (DEFAULT, _, (_,rhs))-           = do rhs_code <- schemeE d_alts s p_alts rhs-                return (NoDiscr, rhs_code)--        codeAlt alt@(_, bndrs, (_,rhs))-           -- primitive or nullary constructor alt: no need to UNPACK-           | null real_bndrs = do-                rhs_code <- schemeE d_alts s p_alts rhs-                return (my_discr alt, rhs_code)-           -- If an alt attempts to match on an unboxed tuple or sum, we must-           -- bail out, as the bytecode compiler can't handle them.-           -- (See #14608.)-           | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs-           = multiValException-           -- algebraic alt with some binders-           | otherwise =-             let (tot_wds, _ptrs_wds, args_offsets) =-                     mkVirtHeapOffsets dflags NoHeader-                         [ NonVoid (bcIdPrimRep id, id)-                         | NonVoid id <- nonVoidIds real_bndrs-                         ]-                 size = WordOff tot_wds--                 stack_bot = d_alts + wordsToBytes platform size--                 -- convert offsets from Sp into offsets into the virtual stack-                 p' = Map.insertList-                        [ (arg, stack_bot - ByteOff offset)-                        | (NonVoid arg, offset) <- args_offsets ]-                        p_alts-             in do-             MASSERT(isAlgCase)-             rhs_code <- schemeE stack_bot s p' rhs-             return (my_discr alt,-                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)-           where-             real_bndrs = filterOut isTyVar bndrs--        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}-        my_discr (DataAlt dc, _, _)-           | isUnboxedTupleCon dc || isUnboxedSumCon dc-           = multiValException-           | otherwise-           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))-        my_discr (LitAlt l, _, _)-           = case l of LitNumber LitNumInt i  -> DiscrI (fromInteger i)-                       LitNumber LitNumWord w -> DiscrW (fromInteger w)-                       LitFloat r   -> DiscrF (fromRational r)-                       LitDouble r  -> DiscrD (fromRational r)-                       LitChar i    -> DiscrI (ord i)-                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)--        maybe_ncons-           | not isAlgCase = Nothing-           | otherwise-           = case [dc | (DataAlt dc, _, _) <- alts] of-                []     -> Nothing-                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))--        -- the bitmap is relative to stack depth d, i.e. before the-        -- BCO, info table and return value are pushed on.-        -- This bit of code is v. similar to buildLivenessMask in CgBindery,-        -- except that here we build the bitmap from the known bindings of-        -- things that are pointers, whereas in CgBindery the code builds the-        -- bitmap from the free slots and unboxed bindings.-        -- (ToDo: merge?)-        ---        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.-        -- The bitmap must cover the portion of the stack up to the sequel only.-        -- Previously we were building a bitmap for the whole depth (d), but we-        -- really want a bitmap up to depth (d-s).  This affects compilation of-        -- case-of-case expressions, which is the only time we can be compiling a-        -- case expression with s /= 0.-        bitmap_size = trunc16W $ bytesToWords platform (d - s)-        bitmap_size' :: Int-        bitmap_size' = fromIntegral bitmap_size-        bitmap = intsToReverseBitmap platform bitmap_size'{-size-}-                        (sort (filter (< bitmap_size') rel_slots))-          where-          binds = Map.toList p-          -- NB: unboxed tuple cases bind the scrut binder to the same offset-          -- as one of the alt binders, so we have to remove any duplicates here:-          rel_slots = nub $ map fromIntegral $ concatMap spread binds-          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]-                              | otherwise                      = []-                where rel_offset = trunc16W $ bytesToWords platform (d - offset)--     alt_stuff <- mapM codeAlt alts-     alt_final <- mkMultiBranch maybe_ncons alt_stuff--     let-         alt_bco_name = getName bndr-         alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)-                       0{-no arity-} bitmap_size bitmap True{-is alts-}---     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++---            "\n      bitmap = " ++ show bitmap) $ do--     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)-                           (d + ret_frame_size_b + save_ccs_size_b)-                           p scrut-     alt_bco' <- emitBc alt_bco-     let push_alts-            | isAlgCase = PUSH_ALTS alt_bco'-            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)-     return (push_alts `consOL` scrut_code)----- -------------------------------------------------------------------------------- Deal with a CCall.---- Taggedly push the args onto the stack R->L,--- deferencing ForeignObj#s and adjusting addrs to point to--- payloads in Ptr/Byte arrays.  Then, generate the marshalling--- (machine) code for the ccall, and create bytecodes to call that and--- then return in the right way.--generateCCall-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> CCallSpec               -- where to call-    -> Id                      -- of target, for type info-    -> [AnnExpr' Id DVarSet]   -- args (atoms)-    -> BcM BCInstrList-generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l- = do-     dflags <- getDynFlags--     let-         platform = targetPlatform dflags-         -- useful constants-         addr_size_b :: ByteOff-         addr_size_b = wordSize platform--         -- Get the args on the stack, with tags and suitably-         -- dereferenced for the CCall.  For each arg, return the-         -- depth to the first word of the bits for that arg, and the-         -- ArgRep of what was actually pushed.--         pargs-             :: ByteOff -> [AnnExpr' Id DVarSet] -> BcM [(BCInstrList, PrimRep)]-         pargs _ [] = return []-         pargs d (a:az)-            = let arg_ty = unwrapType (exprType (deAnnotate' a))--              in case tyConAppTyCon_maybe arg_ty of-                    -- Don't push the FO; instead push the Addr# it-                    -- contains.-                    Just t-                     | t == arrayPrimTyCon || t == mutableArrayPrimTyCon-                       -> do rest <- pargs (d + addr_size_b) az-                             code <- parg_ArrayishRep (fromIntegral (arrPtrsHdrSize dflags)) d p a-                             return ((code,AddrRep):rest)--                     | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon-                       -> do rest <- pargs (d + addr_size_b) az-                             code <- parg_ArrayishRep (fromIntegral (smallArrPtrsHdrSize dflags)) d p a-                             return ((code,AddrRep):rest)--                     | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon-                       -> do rest <- pargs (d + addr_size_b) az-                             code <- parg_ArrayishRep (fromIntegral (arrWordsHdrSize dflags)) d p a-                             return ((code,AddrRep):rest)--                    -- Default case: push taggedly, but otherwise intact.-                    _-                       -> do (code_a, sz_a) <- pushAtom d p a-                             rest <- pargs (d + sz_a) az-                             return ((code_a, atomPrimRep a) : rest)--         -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on-         -- the stack but then advance it over the headers, so as to-         -- point to the payload.-         parg_ArrayishRep-             :: Word16-             -> StackDepth-             -> BCEnv-             -> AnnExpr' Id DVarSet-             -> BcM BCInstrList-         parg_ArrayishRep hdrSize d p a-            = do (push_fo, _) <- pushAtom d p a-                 -- The ptr points at the header.  Advance it over the-                 -- header and then pretend this is an Addr#.-                 return (push_fo `snocOL` SWIZZLE 0 hdrSize)--     code_n_reps <- pargs d0 args_r_to_l-     let-         (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps-         a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)--         push_args    = concatOL pushs_arg-         !d_after_args = d0 + wordsToBytes platform a_reps_sizeW-         a_reps_pushed_RAW-            | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))-            = panic "GHC.CoreToByteCode.generateCCall: missing or invalid World token?"-            | otherwise-            = reverse (tail a_reps_pushed_r_to_l)--         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.-         -- push_args is the code to do that.-         -- d_after_args is the stack depth once the args are on.--         -- Get the result rep.-         (returns_void, r_rep)-            = case maybe_getCCallReturnRep (idType fn) of-                 Nothing -> (True,  VoidRep)-                 Just rr -> (False, rr)-         {--         Because the Haskell stack grows down, the a_reps refer to-         lowest to highest addresses in that order.  The args for the call-         are on the stack.  Now push an unboxed Addr# indicating-         the C function to call.  Then push a dummy placeholder for the-         result.  Finally, emit a CCALL insn with an offset pointing to the-         Addr# just pushed, and a literal field holding the mallocville-         address of the piece of marshalling code we generate.-         So, just prior to the CCALL insn, the stack looks like this-         (growing down, as usual):--            <arg_n>-            ...-            <arg_1>-            Addr# address_of_C_fn-            <placeholder-for-result#> (must be an unboxed type)--         The interpreter then calls the marshall code mentioned-         in the CCALL insn, passing it (& <placeholder-for-result#>),-         that is, the addr of the topmost word in the stack.-         When this returns, the placeholder will have been-         filled in.  The placeholder is slid down to the sequel-         depth, and we RETURN.--         This arrangement makes it simple to do f-i-dynamic since the Addr#-         value is the first arg anyway.--         The marshalling code is generated specifically for this-         call site, and so knows exactly the (Haskell) stack-         offsets of the args, fn address and placeholder.  It-         copies the args to the C stack, calls the stacked addr,-         and parks the result back in the placeholder.  The interpreter-         calls it as a normal C call, assuming it has a signature-            void marshall_code ( StgWord* ptr_to_top_of_stack )-         -}-         -- resolve static address-         maybe_static_target :: Maybe Literal-         maybe_static_target =-             case target of-                 DynamicTarget -> Nothing-                 StaticTarget _ _ _ False ->-                   panic "generateCCall: unexpected FFI value import"-                 StaticTarget _ target _ True ->-                   Just (LitLabel target mb_size IsFunction)-                   where-                      mb_size-                          | OSMinGW32 <- platformOS platform-                          , StdCallConv <- cconv-                          = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)-                          | otherwise-                          = Nothing--     let-         is_static = isJust maybe_static_target--         -- Get the arg reps, zapping the leading Addr# in the dynamic case-         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"-                | is_static = a_reps_pushed_RAW-                | otherwise = if null a_reps_pushed_RAW-                              then panic "GHC.CoreToByteCode.generateCCall: dyn with no args"-                              else tail a_reps_pushed_RAW--         -- push the Addr#-         (push_Addr, d_after_Addr)-            | Just machlabel <- maybe_static_target-            = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)-            | otherwise -- is already on the stack-            = (nilOL, d_after_args)--         -- Push the return placeholder.  For a call returning nothing,-         -- this is a V (tag).-         r_sizeW   = repSizeWords platform r_rep-         d_after_r = d_after_Addr + wordsToBytes platform r_sizeW-         push_r =-             if returns_void-                then nilOL-                else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))--         -- generate the marshalling code we're going to call--         -- Offset of the next stack frame down the stack.  The CCALL-         -- instruction needs to describe the chunk of stack containing-         -- the ccall args to the GC, so it needs to know how large it-         -- is.  See comment in Interpreter.c with the CCALL instruction.-         stk_offset   = trunc16W $ bytesToWords platform (d_after_r - s)--         conv = case cconv of-           CCallConv -> FFICCall-           StdCallConv -> FFIStdCall-           _ -> panic "GHC.CoreToByteCode: unexpected calling convention"--     -- the only difference in libffi mode is that we prepare a cif-     -- describing the call type by calling libffi, and we attach the-     -- address of this to the CCALL instruction.---     let ffires = primRepToFFIType platform r_rep-         ffiargs = map (primRepToFFIType platform) a_reps-     hsc_env <- getHscEnv-     token <- ioToBc $ iservCmd hsc_env (PrepFFI conv ffiargs ffires)-     recordFFIBc token--     let-         -- do the call-         do_call      = unitOL (CCALL stk_offset token flags)-           where flags = case safety of-                           PlaySafe          -> 0x0-                           PlayInterruptible -> 0x1-                           PlayRisky         -> 0x2--         -- slide and return-         d_after_r_min_s = bytesToWords platform (d_after_r - s)-         wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)-                        `snocOL` RETURN_UBX (toArgRep r_rep)-         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $-     return (-         push_args `appOL`-         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup-         )--primRepToFFIType :: Platform -> PrimRep -> FFIType-primRepToFFIType platform r-  = case r of-     VoidRep     -> FFIVoid-     IntRep      -> signed_word-     WordRep     -> unsigned_word-     Int64Rep    -> FFISInt64-     Word64Rep   -> FFIUInt64-     AddrRep     -> FFIPointer-     FloatRep    -> FFIFloat-     DoubleRep   -> FFIDouble-     _           -> panic "primRepToFFIType"-  where-    (signed_word, unsigned_word) = case platformWordSize platform of-       PW4 -> (FFISInt32, FFIUInt32)-       PW8 -> (FFISInt64, FFIUInt64)---- Make a dummy literal, to be used as a placeholder for FFI return--- values on the stack.-mkDummyLiteral :: Platform -> PrimRep -> Literal-mkDummyLiteral platform pr-   = case pr of-        IntRep    -> mkLitInt  platform 0-        WordRep   -> mkLitWord platform 0-        Int64Rep  -> mkLitInt64 0-        Word64Rep -> mkLitWord64 0-        AddrRep   -> LitNullAddr-        DoubleRep -> LitDouble 0-        FloatRep  -> LitFloat 0-        _         -> pprPanic "mkDummyLiteral" (ppr pr)----- Convert (eg)---     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld---                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)------ to  Just IntRep--- and check that an unboxed pair is returned wherein the first arg is V'd.------ Alternatively, for call-targets returning nothing, convert------     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld---                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)------ to  Nothing--maybe_getCCallReturnRep :: Type -> Maybe PrimRep-maybe_getCCallReturnRep fn_ty-   = let-       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)-       r_reps = typePrimRepArgs r_ty--       blargh :: a -- Used at more than one type-       blargh = pprPanic "maybe_getCCallReturn: can't handle:"-                         (pprType fn_ty)-     in-       case r_reps of-         []            -> panic "empty typePrimRepArgs"-         [VoidRep]     -> Nothing-         [rep]-           | isGcPtrRep rep -> blargh-           | otherwise      -> Just rep--                 -- if it was, it would be impossible to create a-                 -- valid return value placeholder on the stack-         _             -> blargh--maybe_is_tagToEnum_call :: AnnExpr' Id DVarSet -> Maybe (AnnExpr' Id DVarSet, [Name])--- Detect and extract relevant info for the tagToEnum kludge.-maybe_is_tagToEnum_call app-  | AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg <- app-  , Just TagToEnumOp <- isPrimOpId_maybe v-  = Just (snd arg, extract_constr_Names t)-  | otherwise-  = Nothing-  where-    extract_constr_Names ty-           | rep_ty <- unwrapType ty-           , Just tyc <- tyConAppTyCon_maybe rep_ty-           , isDataTyCon tyc-           = map (getName . dataConWorkId) (tyConDataCons tyc)-           -- NOTE: use the worker name, not the source name of-           -- the DataCon.  See "GHC.Core.DataCon" for details.-           | otherwise-           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)--{- ------------------------------------------------------------------------------Note [Implementing tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(implement_tagToId arg names) compiles code which takes an argument-'arg', (call it i), and enters the i'th closure in the supplied list-as a consequence.  The [Name] is a list of the constructors of this-(enumeration) type.--The code we generate is this:-                push arg-                push bogus-word--                TESTEQ_I 0 L1-                  PUSH_G <lbl for first data con>-                  JMP L_Exit--        L1:     TESTEQ_I 1 L2-                  PUSH_G <lbl for second data con>-                  JMP L_Exit-        ...etc...-        Ln:     TESTEQ_I n L_fail-                  PUSH_G <lbl for last data con>-                  JMP L_Exit--        L_fail: CASEFAIL--        L_exit: SLIDE 1 n-                ENTER--The 'bogus-word' push is because TESTEQ_I expects the top of the stack-to have an info-table, and the next word to have the value to be-tested.  This is very weird, but it's the way it is right now.  See-Interpreter.c.  We don't actually need an info-table here; we just-need to have the argument to be one-from-top on the stack, hence pushing-a 1-word null. See #8383.--}---implement_tagToId-    :: StackDepth-    -> Sequel-    -> BCEnv-    -> AnnExpr' Id DVarSet-    -> [Name]-    -> BcM BCInstrList--- See Note [Implementing tagToEnum#]-implement_tagToId d s p arg names-  = ASSERT( notNull names )-    do (push_arg, arg_bytes) <- pushAtom d p arg-       labels <- getLabelsBc (genericLength names)-       label_fail <- getLabelBc-       label_exit <- getLabelBc-       dflags <- getDynFlags-       let infos = zip4 labels (tail labels ++ [label_fail])-                               [0 ..] names-           platform = targetPlatform dflags-           steps = map (mkStep label_exit) infos-           slide_ws = bytesToWords platform (d - s + arg_bytes)--       return (push_arg-               `appOL` unitOL (PUSH_UBX LitNullAddr 1)-                   -- Push bogus word (see Note [Implementing tagToEnum#])-               `appOL` concatOL steps-               `appOL` toOL [ LABEL label_fail, CASEFAIL,-                              LABEL label_exit ]-               `appOL` mkSlideW 1 (slide_ws + 1)-                   -- "+1" to account for bogus word-                   --      (see Note [Implementing tagToEnum#])-               `appOL` unitOL ENTER)-  where-        mkStep l_exit (my_label, next_label, n, name_for_n)-           = toOL [LABEL my_label,-                   TESTEQ_I n next_label,-                   PUSH_G name_for_n,-                   JMP l_exit]----- -------------------------------------------------------------------------------- pushAtom---- Push an atom onto the stack, returning suitable code & number of--- stack words used.------ The env p must map each variable to the highest- numbered stack--- slot for it.  For example, if the stack has depth 4 and we--- tagged-ly push (v :: Int#) on it, the value will be in stack[4],--- the tag in stack[5], the stack will have depth 6, and p must map v--- to 5 and not to 4.  Stack locations are numbered from zero, so a--- depth 6 stack has valid words 0 .. 5.--pushAtom-    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)-pushAtom d p e-   | Just e' <- bcView e-   = pushAtom d p e'--pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,-   = return (nilOL, 0)          -- treated just like a variable V---- See Note [Empty case alternatives] in GHC.Core--- and Note [Bottoming expressions] in GHC.Core.Utils:--- The scrutinee of an empty case evaluates to bottom-pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128-   = pushAtom d p a--pushAtom d p (AnnVar var)-   | [] <- typePrimRep (idType var)-   = return (nilOL, 0)--   | isFCallId var-   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)--   | Just primop <- isPrimOpId_maybe var-   = do-       platform <- targetPlatform <$> getDynFlags-       return (unitOL (PUSH_PRIMOP primop), wordSize platform)--   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable-   = do platform <- targetPlatform <$> getDynFlags--        let !szb = idSizeCon platform var-            with_instr instr = do-                let !off_b = trunc16B $ d - d_v-                return (unitOL (instr off_b), wordSize platform)--        case szb of-            1 -> with_instr PUSH8_W-            2 -> with_instr PUSH16_W-            4 -> with_instr PUSH32_W-            _ -> do-                let !szw = bytesToWords platform szb-                    !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1-                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)-        -- d - d_v           offset from TOS to the first slot of the object-        ---        -- d - d_v + sz - 1  offset from the TOS of the last slot of the object-        ---        -- Having found the last slot, we proceed to copy the right number of-        -- slots on to the top of the stack.--   | otherwise  -- var must be a global variable-   = do topStrings <- getTopStrings-        platform <- targetPlatform <$> getDynFlags-        case lookupVarEnv topStrings var of-            Just ptr -> pushAtom d p $ AnnLit $ mkLitWord platform $-              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr-            Nothing -> do-                let sz = idSizeCon platform var-                MASSERT( sz == wordSize platform )-                return (unitOL (PUSH_G (getName var)), sz)---pushAtom _ _ (AnnLit lit) = do-     platform <- targetPlatform <$> getDynFlags-     let code rep-             = let size_words = WordOff (argRepSizeW platform rep)-               in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),-                           wordsToBytes platform size_words)--     case lit of-        LitLabel _ _ _  -> code N-        LitFloat _      -> code F-        LitDouble _     -> code D-        LitChar _       -> code N-        LitNullAddr     -> code N-        LitString _     -> code N-        LitRubbish      -> code N-        LitNumber nt _  -> case nt of-          LitNumInt     -> code N-          LitNumWord    -> code N-          LitNumInt64   -> code L-          LitNumWord64  -> code L-          -- No LitInteger's or LitNatural's should be left by the time this is-          -- called. CorePrep should have converted them all to a real core-          -- representation.-          LitNumInteger -> panic "pushAtom: LitInteger"-          LitNumNatural -> panic "pushAtom: LitNatural"--pushAtom _ _ expr-   = pprPanic "GHC.CoreToByteCode.pushAtom"-              (pprCoreExpr (deAnnotate' expr))----- | Push an atom for constructor (i.e., PACK instruction) onto the stack.--- This is slightly different to @pushAtom@ due to the fact that we allow--- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.-pushConstrAtom-    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)--pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =-    return (unitOL (PUSH_UBX32 lit), 4)--pushConstrAtom d p (AnnVar v)-    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable-        platform <- targetPlatform <$> getDynFlags-        let !szb = idSizeCon platform v-            done instr = do-                let !off = trunc16B $ d - d_v-                return (unitOL (instr off), szb)-        case szb of-            1 -> done PUSH8-            2 -> done PUSH16-            4 -> done PUSH32-            _ -> pushAtom d p (AnnVar v)--pushConstrAtom d p expr = pushAtom d p expr--pushPadding :: Int -> (BCInstrList, ByteOff)-pushPadding !n = go n (nilOL, 0)-  where-    go n acc@(!instrs, !off) = case n of-        0 -> acc-        1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)-        2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)-        3 -> go 1 (go 2 acc)-        4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)-        _ -> go (n - 4) (go 4 acc)---- -------------------------------------------------------------------------------- Given a bunch of alts code and their discrs, do the donkey work--- of making a multiway branch using a switch tree.--- What a load of hassle!--mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt-                                -- a hint; generates better code-                                -- Nothing is always safe-              -> [(Discr, BCInstrList)]-              -> BcM BCInstrList-mkMultiBranch maybe_ncons raw_ways = do-     lbl_default <- getLabelBc--     let-         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList-         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))-             -- shouldn't happen?--         mkTree [val] range_lo range_hi-            | range_lo == range_hi-            = return (snd val)-            | null defaults -- Note [CASEFAIL]-            = do lbl <- getLabelBc-                 return (testEQ (fst val) lbl-                            `consOL` (snd val-                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))-            | otherwise-            = return (testEQ (fst val) lbl_default `consOL` snd val)--            -- Note [CASEFAIL] It may be that this case has no default-            -- branch, but the alternatives are not exhaustive - this-            -- happens for GADT cases for example, where the types-            -- prove that certain branches are impossible.  We could-            -- just assume that the other cases won't occur, but if-            -- this assumption was wrong (because of a bug in GHC)-            -- then the result would be a segfault.  So instead we-            -- emit an explicit test and a CASEFAIL instruction that-            -- causes the interpreter to barf() if it is ever-            -- executed.--         mkTree vals range_lo range_hi-            = let n = length vals `div` 2-                  vals_lo = take n vals-                  vals_hi = drop n vals-                  v_mid = fst (head vals_hi)-              in do-              label_geq <- getLabelBc-              code_lo <- mkTree vals_lo range_lo (dec v_mid)-              code_hi <- mkTree vals_hi v_mid range_hi-              return (testLT v_mid label_geq-                      `consOL` (code_lo-                      `appOL`   unitOL (LABEL label_geq)-                      `appOL`   code_hi))--         the_default-            = case defaults of-                []         -> nilOL-                [(_, def)] -> LABEL lbl_default `consOL` def-                _          -> panic "mkMultiBranch/the_default"-     instrs <- mkTree notd_ways init_lo init_hi-     return (instrs `appOL` the_default)-  where-         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways-         notd_ways = sortBy (comparing fst) not_defaults--         testLT (DiscrI i) fail_label = TESTLT_I i fail_label-         testLT (DiscrW i) fail_label = TESTLT_W i fail_label-         testLT (DiscrF i) fail_label = TESTLT_F i fail_label-         testLT (DiscrD i) fail_label = TESTLT_D i fail_label-         testLT (DiscrP i) fail_label = TESTLT_P i fail_label-         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"--         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label-         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label-         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label-         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label-         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label-         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"--         -- None of these will be needed if there are no non-default alts-         (init_lo, init_hi)-            | null notd_ways-            = panic "mkMultiBranch: awesome foursome"-            | otherwise-            = case fst (head notd_ways) of-                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )-                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )-                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )-                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )-                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )-                NoDiscr -> panic "mkMultiBranch NoDiscr"--         (algMinBound, algMaxBound)-            = case maybe_ncons of-                 -- XXX What happens when n == 0?-                 Just n  -> (0, fromIntegral n - 1)-                 Nothing -> (minBound, maxBound)--         isNoDiscr NoDiscr = True-         isNoDiscr _       = False--         dec (DiscrI i) = DiscrI (i-1)-         dec (DiscrW w) = DiscrW (w-1)-         dec (DiscrP i) = DiscrP (i-1)-         dec other      = other         -- not really right, but if you-                -- do cases on floating values, you'll get what you deserve--         -- same snotty comment applies to the following-         minF, maxF :: Float-         minD, maxD :: Double-         minF = -1.0e37-         maxF =  1.0e37-         minD = -1.0e308-         maxD =  1.0e308----- -------------------------------------------------------------------------------- Supporting junk for the compilation schemes---- Describes case alts-data Discr-   = DiscrI Int-   | DiscrW Word-   | DiscrF Float-   | DiscrD Double-   | DiscrP Word16-   | NoDiscr-    deriving (Eq, Ord)--instance Outputable Discr where-   ppr (DiscrI i) = int i-   ppr (DiscrW w) = text (show w)-   ppr (DiscrF f) = text (show f)-   ppr (DiscrD d) = text (show d)-   ppr (DiscrP i) = ppr i-   ppr NoDiscr    = text "DEF"---lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff-lookupBCEnv_maybe = Map.lookup--idSizeW :: Platform -> Id -> WordOff-idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep--idSizeCon :: Platform -> Id -> ByteOff-idSizeCon platform = ByteOff . primRepSizeB platform . bcIdPrimRep--bcIdArgRep :: Id -> ArgRep-bcIdArgRep = toArgRep . bcIdPrimRep--bcIdPrimRep :: Id -> PrimRep-bcIdPrimRep id-  | [rep] <- typePrimRepArgs (idType id)-  = rep-  | otherwise-  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))--repSizeWords :: Platform -> PrimRep -> WordOff-repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep rep)--isFollowableArg :: ArgRep -> Bool-isFollowableArg P = True-isFollowableArg _ = False--isVoidArg :: ArgRep -> Bool-isVoidArg V = True-isVoidArg _ = False---- See bug #1257-multiValException :: a-multiValException = throwGhcException (ProgramError-  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"++-   "  Possibly due to foreign import/export decls in source.\n"++-   "  Workaround: use -fobject-code, or compile this module to .o separately."))---- | Indicate if the calling convention is supported-isSupportedCConv :: CCallSpec -> Bool-isSupportedCConv (CCallSpec _ cconv _) = case cconv of-   CCallConv            -> True     -- we explicitly pattern match on every-   StdCallConv          -> True     -- convention to ensure that a warning-   PrimCallConv         -> False    -- is triggered when a new one is added-   JavaScriptCallConv   -> False-   CApiConv             -> False---- See bug #10462-unsupportedCConvException :: a-unsupportedCConvException = throwGhcException (ProgramError-  ("Error: bytecode compiler can't handle some foreign calling conventions\n"++-   "  Workaround: use -fobject-code, or compile this module to .o separately."))--mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr-mkSlideB platform !nb !db = mkSlideW n d-  where-    !n = trunc16W $ bytesToWords platform nb-    !d = bytesToWords platform db--mkSlideW :: Word16 -> WordOff -> OrdList BCInstr-mkSlideW !n !ws-    | ws > fromIntegral limit-    -- If the amount to slide doesn't fit in a Word16, generate multiple slide-    -- instructions-    = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)-    | ws == 0-    = nilOL-    | otherwise-    = unitOL (SLIDE n $ fromIntegral ws)-  where-    limit :: Word16-    limit = maxBound--splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])-        -- The arguments are returned in *right-to-left* order-splitApp e | Just e' <- bcView e = splitApp e'-splitApp (AnnApp (_,f) (_,a))    = case splitApp f of-                                      (f', as) -> (f', a:as)-splitApp e                       = (e, [])---bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)--- The "bytecode view" of a term discards---  a) type abstractions---  b) type applications---  c) casts---  d) ticks (but not breakpoints)---  e) case unsafeEqualityProof of UnsafeRefl -> e  ==> e--- Type lambdas *can* occur in random expressions,--- whereas value lambdas cannot; that is why they are nuked here-bcView (AnnCast (_,e) _)             = Just e-bcView (AnnLam v (_,e)) | isTyVar v  = Just e-bcView (AnnApp (_,e) (_, AnnType _)) = Just e-bcView (AnnTick Breakpoint{} _)      = Nothing-bcView (AnnTick _other_tick (_,e))   = Just e-bcView (AnnCase (_,e) _ _ alts)  -- Handle unsafe equality proof-  | AnnVar id <- bcViewLoop e-  , idName id == unsafeEqualityProofName-  , [(_, _, (_, rhs))] <- alts-  = Just rhs-bcView _                             = Nothing--bcViewLoop :: AnnExpr' Var ann -> AnnExpr' Var ann-bcViewLoop e =-    case bcView e of-      Nothing -> e-      Just e' -> bcViewLoop e'--isVAtom :: AnnExpr' Var ann -> Bool-isVAtom e | Just e' <- bcView e = isVAtom e'-isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)-isVAtom (AnnCoercion {})        = True-isVAtom _                     = False--atomPrimRep :: AnnExpr' Id ann -> PrimRep-atomPrimRep e | Just e' <- bcView e = atomPrimRep e'-atomPrimRep (AnnVar v)              = bcIdPrimRep v-atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l)---- #12128:--- A case expression can be an atom because empty cases evaluate to bottom.--- See Note [Empty case alternatives] in GHC.Core-atomPrimRep (AnnCase _ _ ty _)      =-  ASSERT(case typePrimRep ty of [LiftedRep] -> True; _ -> False) LiftedRep-atomPrimRep (AnnCoercion {})        = VoidRep-atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate' other))--atomRep :: AnnExpr' Id ann -> ArgRep-atomRep e = toArgRep (atomPrimRep e)---- | Let szsw be the sizes in bytes of some items pushed onto the stack, which--- has initial depth @original_depth@.  Return the values which the stack--- environment should map these items to.-mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]-mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)--typeArgRep :: Type -> ArgRep-typeArgRep = toArgRep . typePrimRep1---- -------------------------------------------------------------------------------- The bytecode generator's monad--data BcM_State-   = BcM_State-        { bcm_hsc_env :: HscEnv-        , uniqSupply  :: UniqSupply      -- for generating fresh variable names-        , thisModule  :: Module          -- current module (for breakpoints)-        , nextlabel   :: Word16          -- for generating local labels-        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later-                                         -- Should be free()d when it is GCd-        , modBreaks   :: Maybe ModBreaks -- info about breakpoints-        , breakInfo   :: IntMap CgBreakInfo-        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals-          -- See Note [generating code for top-level string literal bindings].-        }--newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)--ioToBc :: IO a -> BcM a-ioToBc io = BcM $ \st -> do-  x <- io-  return (st, x)--runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks-      -> IdEnv (RemotePtr ())-      -> BcM r-      -> IO (BcM_State, r)-runBc hsc_env us this_mod modBreaks topStrings (BcM m)-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)--thenBc :: BcM a -> (a -> BcM b) -> BcM b-thenBc (BcM expr) cont = BcM $ \st0 -> do-  (st1, q) <- expr st0-  let BcM k = cont q-  (st2, r) <- k st1-  return (st2, r)--thenBc_ :: BcM a -> BcM b -> BcM b-thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do-  (st1, _) <- expr st0-  (st2, r) <- cont st1-  return (st2, r)--returnBc :: a -> BcM a-returnBc result = BcM $ \st -> (return (st, result))--instance Applicative BcM where-    pure = returnBc-    (<*>) = ap-    (*>) = thenBc_--instance Monad BcM where-  (>>=) = thenBc-  (>>)  = (*>)--instance HasDynFlags BcM where-    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))--getHscEnv :: BcM HscEnv-getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)--emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)-emitBc bco-  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))--recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()-recordFFIBc a-  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())--getLabelBc :: BcM Word16-getLabelBc-  = BcM $ \st -> do let nl = nextlabel st-                    when (nl == maxBound) $-                        panic "getLabelBc: Ran out of labels"-                    return (st{nextlabel = nl + 1}, nl)--getLabelsBc :: Word16 -> BcM [Word16]-getLabelsBc n-  = BcM $ \st -> let ctr = nextlabel st-                 in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1])--getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))-getCCArray = BcM $ \st ->-  let breaks = expectJust "GHC.CoreToByteCode.getCCArray" $ modBreaks st in-  return (st, modBreaks_ccs breaks)---newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()-newBreakInfo ix info = BcM $ \st ->-  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())--newUnique :: BcM Unique-newUnique = BcM $-   \st -> case takeUniqFromSupply (uniqSupply st) of-             (uniq, us) -> let newState = st { uniqSupply = us }-                           in  return (newState, uniq)--getCurrentModule :: BcM Module-getCurrentModule = BcM $ \st -> return (st, thisModule st)--getTopStrings :: BcM (IdEnv (RemotePtr ()))-getTopStrings = BcM $ \st -> return (st, topStrings st)--newId :: Type -> BcM Id-newId ty = do-    uniq <- newUnique-    return $ mkSysLocal tickFS uniq Many ty--tickFS :: FastString-tickFS = fsLit "ticked"

GHC/CoreToIface.hs view

@@ -48,6 +48,7 @@  import GHC.Prelude +import GHC.Driver.Ppr import GHC.Iface.Syntax import GHC.Core.DataCon import GHC.Types.Id@@ -66,11 +67,13 @@ import GHC.Core.Multiplicity import GHC.Core.PatSyn import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set+import GHC.Types.Tickish import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Tidy ( tidyCo ) import GHC.Types.Demand ( isTopSig )@@ -186,13 +189,13 @@   = IfaceTupleTy sort NotPromoted (toIfaceTcArgsX fr tc tys)    | Just dc <- isPromotedDataCon_maybe tc-  , isTupleDataCon dc+  , isBoxedTupleDataCon dc   , n_tys == 2*arity   = IfaceTupleTy BoxedTuple IsPromoted (toIfaceTcArgsX fr tc (drop arity tys))    | tc `elem` [ eqPrimTyCon, eqReprPrimTyCon, heqTyCon ]   , (k1:k2:_) <- tys-  = let info = IfaceTyConInfo NotPromoted sort+  = let info = mkIfaceTyConInfo NotPromoted sort         sort | k1 `eqType` k2 = IfaceEqualityTyCon              | otherwise      = IfaceNormalTyCon     in IfaceTyConApp (IfaceTyCon (tyConName tc) info) (toIfaceTcArgsX fr tc tys)@@ -222,7 +225,7 @@   = IfaceTyCon tc_name info   where     tc_name = tyConName tc-    info    = IfaceTyConInfo promoted sort+    info    = mkIfaceTyConInfo promoted sort     promoted | isPromotedDataCon tc = IsPromoted              | otherwise            = NotPromoted @@ -243,20 +246,21 @@       , Just tsort <- tupleSort tc'          = tsort        | isUnboxedSumTyCon tc-      , Just cons <- isDataSumTyCon_maybe tc = IfaceSumTyCon (length cons)+      , Just cons <- tyConDataCons_maybe tc  = IfaceSumTyCon (length cons)        | otherwise                            = IfaceNormalTyCon   toIfaceTyCon_name :: Name -> IfaceTyCon toIfaceTyCon_name n = IfaceTyCon n info-  where info = IfaceTyConInfo NotPromoted IfaceNormalTyCon+  where info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon   -- Used for the "rough-match" tycon stuff,   -- where pretty-printing is not an issue  toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x+toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x  ---------------- toIfaceCoercion :: Coercion -> IfaceCoercion@@ -405,7 +409,7 @@     ex_bndrs   = patSynExTyVarBinders ps     (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs     (env2, ex_bndrs')   = tidyTyCoVarBinders env1 ex_bndrs-    to_if_pr (id, needs_dummy) = (idName id, needs_dummy)+    to_if_pr (name, _type, needs_dummy) = (name, needs_dummy)  {- ************************************************************************@@ -560,7 +564,7 @@                   = IfaceNoOneShot  ----------------------toIfaceTickish :: Tickish Id -> Maybe IfaceTickish+toIfaceTickish :: CoreTickish -> Maybe IfaceTickish toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push) toIfaceTickish (HpcTick modl ix)       = Just (IfaceHpcTick modl ix) toIfaceTickish (SourceNote src names)  = Just (IfaceSource src names)@@ -574,9 +578,8 @@ toIfaceBind (Rec prs)    = IfaceRec [(toIfaceLetBndr b, toIfaceExpr r) | (b,r) <- prs]  ----------------------toIfaceAlt :: (AltCon, [Var], CoreExpr)-           -> (IfaceConAlt, [FastString], IfaceExpr)-toIfaceAlt (c,bs,r) = (toIfaceCon c, map getOccFS bs, toIfaceExpr r)+toIfaceAlt :: CoreAlt -> IfaceAlt+toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map getOccFS bs) (toIfaceExpr r)  --------------------- toIfaceCon :: AltCon -> IfaceConAlt

GHC/CoreToStg.hs view

@@ -1,4 +1,6 @@-{-# LANGUAGE CPP, DeriveFunctor #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TypeFamilies #-}  -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998@@ -22,6 +24,7 @@                         , exprIsTickedString_maybe ) import GHC.Core.Opt.Arity   ( manifestArity ) import GHC.Stg.Syntax+import GHC.Stg.Debug  import GHC.Core.Type import GHC.Types.RepType@@ -31,6 +34,7 @@ import GHC.Types.Id.Info import GHC.Core.DataCon import GHC.Types.CostCentre+import GHC.Types.Tickish import GHC.Types.Var.Env import GHC.Unit.Module import GHC.Types.Name   ( isExternalName, nameModule_maybe )@@ -41,16 +45,19 @@ import GHC.Utils.Monad import GHC.Data.FastString import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Ways+import GHC.Driver.Ppr import GHC.Types.ForeignCall-import GHC.Types.Demand    ( isUsedOnce )+import GHC.Types.IPE+import GHC.Types.Demand    ( isUsedOnceDmd ) import GHC.Builtin.PrimOps ( PrimCall(..) ) import GHC.Types.SrcLoc    ( mkGeneralSrcSpan ) -import Data.List.NonEmpty (nonEmpty, toList)-import Data.Maybe    (fromMaybe) import Control.Monad (ap)+import Data.Maybe (fromMaybe)+import Data.Tuple (swap) import qualified Data.Set as Set  -- Note [Live vs free]@@ -223,14 +230,21 @@ -- Setting variable info: top-level, binds, RHSs -- -------------------------------------------------------------- -coreToStg :: DynFlags -> Module -> CoreProgram-          -> ([StgTopBinding], CollectedCCs)-coreToStg dflags this_mod pgm-  = (pgm', final_ccs)++coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram+          -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)+coreToStg dflags this_mod ml pgm+  = (pgm'', denv, final_ccs)   where     (_, (local_ccs, local_cc_stacks), pgm')       = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm +    -- See Note [Mapping Info Tables to Source Positions]+    (!pgm'', !denv) =+        if gopt Opt_InfoTableMap dflags+          then collectDebugInformation dflags ml pgm'+          else (pgm', emptyInfoTableProvMap)+     prof = WayProf `Set.member` ways dflags      final_ccs@@ -307,14 +321,10 @@          -- generate StgTopBindings and CAF cost centres created for CAFs         (ccs', stg_rhss)-          = initCts dflags env' $ do-               mapAccumLM (\ccs rhs -> do-                            (rhs', ccs') <--                              coreToTopStgRhs dflags ccs this_mod rhs-                            return (ccs', rhs'))-                          ccs-                          pairs-+          = initCts dflags env' $+              mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)+                         ccs+                         pairs         bind = StgTopLifted $ StgRec (zip binders stg_rhss)     in     (env', ccs', bind)@@ -327,7 +337,7 @@         -> CtsM (StgRhs, CollectedCCs)  coreToTopStgRhs dflags ccs this_mod (bndr, rhs)-  = do { new_rhs <- coreToStgExpr rhs+  = do { new_rhs <- coreToPreStgRhs rhs         ; let (stg_rhs, ccs') =                mkTopStgRhs dflags this_mod ccs bndr new_rhs@@ -360,6 +370,10 @@ -- Expressions -- --------------------------------------------------------------------------- +-- coreToStgExpr panics if the input expression is a value lambda. CorePrep+-- ensures that value lambdas only exist as the RHS of bindings, which we+-- handle with the function coreToPreStgRhs.+ coreToStgExpr         :: CoreExpr         -> CtsM StgExpr@@ -375,9 +389,10 @@ coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l)      = return (StgLit l)-coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)+coreToStgExpr (App (Lit lit) _some_boxed_type)+  | isRubbishLit lit   -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in-  -- a STG to Cmm pass.+  -- a STG to Cmm pass. Doesn't matter whether it is lifted or unlifted   = coreToStgExpr (Var unitDataConId) coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _)@@ -392,25 +407,19 @@ coreToStgExpr expr@(Lam _ _)   = let         (args, body) = myCollectBinders expr-        args'        = filterStgBinders args     in-    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do-    body' <- coreToStgExpr body-    let-        result_expr = case nonEmpty args' of-          Nothing     -> body'-          Just args'' -> StgLam args'' body'+    case filterStgBinders args of -    return result_expr+      [] -> coreToStgExpr body +      _ -> pprPanic "coretoStgExpr" $+        text "Unexpected value lambda:" $$ ppr expr+ coreToStgExpr (Tick tick expr)-  = do case tick of-         HpcTick{}    -> return ()-         ProfNote{}   -> return ()-         SourceNote{} -> return ()-         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"-       expr2 <- coreToStgExpr expr-       return (StgTick tick expr2)+  = do+       let !stg_tick = coreToStgTick (exprType expr) tick+       !expr2 <- coreToStgExpr expr+       return (StgTick stg_tick expr2)  coreToStgExpr (Cast expr _)   = coreToStgExpr expr@@ -444,8 +453,8 @@        ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)        ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }   where-    vars_alt :: (AltCon, [Var], CoreExpr) -> CtsM (AltCon, [Var], StgExpr)-    vars_alt (con, binders, rhs)+    vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)+    vars_alt (Alt con binders rhs)       | DataAlt c <- con, c == unboxedUnitDataCon       = -- This case is a bit smelly.         -- See Note [Nullary unboxed tuple] in GHC.Core.Type@@ -461,10 +470,8 @@         rhs2 <- coreToStgExpr rhs         return (con, binders', rhs2) -coreToStgExpr (Let bind body) = do-    coreToStgLet bind body--coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)+coreToStgExpr (Let bind body) = coreToStgLet bind body+coreToStgExpr e               = pprPanic "coreToStgExpr" (ppr e)  mkStgAltType :: Id -> [CoreAlt] -> AltType mkStgAltType bndr alts@@ -473,15 +480,16 @@    | otherwise   = case prim_reps of-      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of-        Just tc-          | isAbstractTyCon tc -> look_for_better_tycon-          | isAlgTyCon tc      -> AlgAlt tc-          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )-                                  PolyAlt-        Nothing                -> PolyAlt-      [unlifted] -> PrimAlt unlifted-      not_unary  -> MultiValAlt (length not_unary)+      [rep] | isGcPtrRep rep ->+        case tyConAppTyCon_maybe (unwrapType bndr_ty) of+          Just tc+            | isAbstractTyCon tc -> look_for_better_tycon+            | isAlgTyCon tc      -> AlgAlt tc+            | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )+                                    PolyAlt+          Nothing                -> PolyAlt+      [non_gcd] -> PrimAlt non_gcd+      not_unary -> MultiValAlt (length not_unary)   where    bndr_ty   = idType bndr    prim_reps = typePrimRep bndr_ty@@ -498,7 +506,7 @@    -- grabbing the one from a constructor alternative    -- if one exists.    look_for_better_tycon-        | ((DataAlt con, _, _) : _) <- data_alts =+        | ((Alt (DataAlt con) _ _) : _) <- data_alts =                 AlgAlt (dataConTyCon con)         | otherwise =                 ASSERT(null data_alts)@@ -512,7 +520,7 @@  coreToStgApp :: Id            -- Function              -> [CoreArg]     -- Arguments-             -> [Tickish Id]  -- Debug ticks+             -> [CoreTickish] -- Debug ticks              -> CtsM StgExpr coreToStgApp f args ticks = do     (args', ticks') <- coreToStgArgs args@@ -534,7 +542,7 @@         res_ty = exprType (mkApps (Var f) args)         app = case idDetails f of                 DataConWorkId dc-                  | saturated    -> StgConApp dc args'+                  | saturated    -> StgConApp dc NoNumber args'                                       (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))                  -- Some primitive operator that might be implemented as a library call.@@ -556,7 +564,8 @@                 TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')                 _other           -> StgApp f args' -        tapp = foldr StgTick app (ticks ++ ticks')+        add_tick !t !e = StgTick t e+        tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks')      -- Forcing these fixes a leak in the code generator, noticed while     -- profiling for trac #4367@@ -567,7 +576,7 @@ -- This is the guy that turns applications into A-normal form -- --------------------------------------------------------------------------- -coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])+coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [StgTickish]) coreToStgArgs []   = return ([], []) @@ -582,7 +591,8 @@ coreToStgArgs (Tick t e : args)   = ASSERT( not (tickishIsCode t) )     do { (args', ts) <- coreToStgArgs (e : args)-       ; return (args', t:ts) }+       ; let !t' = coreToStgTick (exprType e) t+       ; return (args', t':ts) }  coreToStgArgs (arg : args) = do         -- Non-type argument     (stg_args, ticks) <- coreToStgArgs args@@ -591,7 +601,7 @@         (aticks, arg'') = stripStgTicksTop tickishFloatable arg'         stg_arg = case arg'' of                        StgApp v []        -> StgVarArg v-                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)+                       StgConApp con _ [] _ -> StgVarArg (dataConWorkId con)                        StgLit lit         -> StgLitArg lit                        _                  -> pprPanic "coreToStgArgs" (ppr arg) @@ -614,6 +624,13 @@     WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )      return (stg_arg : stg_args, ticks ++ aticks) +coreToStgTick :: Type -- type of the ticked expression+              -> CoreTickish+              -> StgTickish+coreToStgTick _ty (HpcTick m i)           = HpcTick m i+coreToStgTick _ty (SourceNote span nm)    = SourceNote span nm+coreToStgTick _ty (ProfNote cc cnt scope) = ProfNote cc cnt scope+coreToStgTick !ty (Breakpoint _ bid fvs)  = Breakpoint ty bid fvs  -- --------------------------------------------------------------------------- -- The magic for lets:@@ -671,30 +688,49 @@              -> CtsM StgRhs  coreToStgRhs (bndr, rhs) = do-    new_rhs <- coreToStgExpr rhs+    new_rhs <- coreToPreStgRhs rhs     return (mkStgRhs bndr new_rhs) +-- Represents the RHS of a binding for use with mk(Top)StgRhs.+data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks++-- Convert the RHS of a binding from Core to STG. This is a wrapper around+-- coreToStgExpr that can handle value lambdas.+coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs+coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr+coreToPreStgRhs expr@(Lam _ _) =+    let+        (args, body) = myCollectBinders expr+        args'        = filterStgBinders args+    in+        extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do+          body' <- coreToStgExpr body+          return (PreStgRhs args' body')+coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr+ -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument. mkTopStgRhs :: DynFlags -> Module -> CollectedCCs-            -> Id -> StgExpr -> (StgRhs, CollectedCCs)+            -> Id -> PreStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs bndr rhs-  | StgLam bndrs body <- rhs-  = -- StgLam can't have empty arguments, so not CAF+mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)+  | not (null bndrs)+  = -- The list of arguments is non-empty, so not CAF     ( StgRhsClosure noExtFieldSilent                     dontCareCCS                     ReEntrant-                    (toList bndrs) body+                    bndrs rhs     , ccs ) -  | StgConApp con args _ <- unticked_rhs+  -- After this point we know that `bndrs` is empty,+  -- so this is not a function binding+  | StgConApp con mn args _ <- unticked_rhs   , -- 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 )+    ( StgRhsCon dontCareCCS con mn ticks args, ccs )    -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].   | gopt Opt_AutoSccsOnIndividualCafs dflags@@ -710,10 +746,10 @@     , ccs )    where-    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs+    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs -    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry-             | otherwise                      = Updatable+    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry+             | otherwise                         = Updatable      -- CAF cost centres generated for -fcaf-all     caf_cc = mkAutoCC bndr modl@@ -729,14 +765,16 @@  -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan].-mkStgRhs :: Id -> StgExpr -> StgRhs-mkStgRhs bndr rhs-  | StgLam bndrs body <- rhs+mkStgRhs :: Id -> PreStgRhs -> StgRhs+mkStgRhs bndr (PreStgRhs bndrs rhs)+  | not (null bndrs)   = StgRhsClosure noExtFieldSilent                   currentCCS                   ReEntrant-                  (toList bndrs) body+                  bndrs rhs +  -- After this point we know that `bndrs` is empty,+  -- so this is not a function binding   | isJoinId bndr -- must be a nullary join point   = ASSERT(idJoinArity bndr == 0)     StgRhsClosure noExtFieldSilent@@ -744,18 +782,18 @@                   ReEntrant -- ignored for LNE                   [] rhs -  | StgConApp con args _ <- unticked_rhs-  = StgRhsCon currentCCS con args+  | StgConApp con mn args _ <- unticked_rhs+  = StgRhsCon currentCCS con mn ticks args    | otherwise   = StgRhsClosure noExtFieldSilent                   currentCCS                   upd_flag [] rhs   where-    unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs+    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs -    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry-             | otherwise                      = Updatable+    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry+             | otherwise                         = Updatable    {-     SDM: disabled.  Eval/Apply can't handle functions with arity zero very@@ -919,24 +957,39 @@  -- | Precondition: argument expression is an 'App', and there is a 'Var' at the -- head of the 'App' chain.-myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])+myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish]) myCollectArgs expr   = go expr [] []   where     go (Var v)          as ts = (v, as, ts)     go (App f a)        as ts = go f (a:as) ts-    go (Tick t e)       as ts = ASSERT( all isTypeArg as )+    go (Tick t e)       as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as+                                       , ppr e $$ ppr as $$ ppr ts )+                                -- See Note [Ticks in applications]                                 go e as (t:ts) -- ticks can appear in type apps     go (Cast e _)       as ts = go e as ts     go (Lam b e)        as ts        | isTyVar b            = go e as ts -- Note [Collect args]     go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr) --- Note [Collect args]--- ~~~~~~~~~~~~~~~~~~~------ This big-lambda case occurred following a rather obscure eta expansion.--- It all seems a bit yukky to me.+{- Note [Collect args]+~~~~~~~~~~~~~~~~~~~~~~+This big-lambda case occurred following a rather obscure eta expansion.+It all seems a bit yukky to me.++Note [Ticks in applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can get an application like+   (tick t f) True False+via inlining in the CorePrep pass; see Note [Inlining in CorePrep]+in GHC.CoreToStg.Prep.  The tick does not satisfy tickishIsCode;+the inlining-in-CorePrep happens for cpExprIsTrivial which tests+tickishIsCode.++So we test the same thing here, pushing any non-code ticks to+the top (they don't generate any code, after all).  This showed+up in the fallout from fixing #19360.+-}  stgArity :: Id -> HowBound -> Arity stgArity _ (LetBound _ arity) = arity

GHC/CoreToStg/Prep.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE BangPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow, 1994-2006 @@ -5,10 +10,6 @@ Core pass to saturate constructors and PrimOps -} -{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.CoreToStg.Prep    ( corePrepPgm    , corePrepExpr@@ -19,15 +20,23 @@ #include "HsVersions.h"  import GHC.Prelude+ import GHC.Platform+import GHC.Platform.Ways -import GHC.Core.Opt.OccurAnal+import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Ppr +import GHC.Tc.Utils.Env+import GHC.Unit++import GHC.Builtin.Names import GHC.Builtin.PrimOps+import GHC.Builtin.Types import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Id.Make ( realWorldPrimId, mkPrimOpId )-import GHC.Driver.Types-import GHC.Builtin.Names+ import GHC.Core.Utils import GHC.Core.Opt.Arity import GHC.Core.FVs@@ -36,39 +45,43 @@ import GHC.Core import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here import GHC.Core.Type-import GHC.Types.Literal import GHC.Core.Coercion-import GHC.Tc.Utils.Env import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core.Opt.OccurAnal import GHC.Core.TyCo.Rep( UnivCoProvenance(..) )+++import GHC.Data.Maybe+import GHC.Data.OrdList+import GHC.Data.FastString++import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Utils.Monad  ( mapAccumLM )+import GHC.Utils.Logger+ import GHC.Types.Demand import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Id.Info-import GHC.Builtin.Types-import GHC.Core.DataCon import GHC.Types.Basic-import GHC.Unit.Module-import GHC.Types.Unique.Supply-import GHC.Data.Maybe-import GHC.Data.OrdList-import GHC.Utils.Error-import GHC.Driver.Session-import GHC.Driver.Ways-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Data.FastString import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName ) import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Types.TyThing+import GHC.Types.CostCentre ( CostCentre, ccFromThisModule )+import GHC.Types.Unique.Supply+ import GHC.Data.Pair-import Data.Bits-import GHC.Utils.Monad  ( mapAccumLM ) import Data.List        ( unfoldr ) import Data.Functor.Identity import Control.Monad-import GHC.Types.CostCentre ( CostCentre, ccFromThisModule ) import qualified Data.Set as S  {-@@ -228,9 +241,9 @@ corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]             -> IO (CoreProgram, S.Set CostCentre) corePrepPgm hsc_env this_mod mod_loc binds data_tycons =-    withTiming dflags+    withTiming logger dflags                (text "CorePrep"<+>brackets (ppr this_mod))-               (const ()) $ do+               (\(a,b) -> a `seqList` b `seq` ()) $ do     us <- mkSplitUniqSupply 's'     initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env @@ -253,15 +266,17 @@     return (binds_out, cost_centres)   where     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env  corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr corePrepExpr hsc_env expr = do     let dflags = hsc_dflags hsc_env-    withTiming dflags (text "CorePrep [expr]") (const ()) $ do+    let logger = hsc_logger hsc_env+    withTiming logger dflags (text "CorePrep [expr]") (\e -> e `seq` ()) $ do       us <- mkSplitUniqSupply 's'       initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env       let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)-      dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)+      dumpIfSet_dyn logger dflags Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)       return new_expr  corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats@@ -792,9 +807,9 @@   = do { body <- cpeBodyNF env expr        ; return (emptyFloats, mkTick tickish' body) }   where-    tickish' | Breakpoint n fvs <- tickish+    tickish' | Breakpoint ext n fvs <- tickish              -- See also 'substTickish'-             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)+             = Breakpoint ext n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)              | otherwise              = tickish @@ -825,7 +840,7 @@   | isUnsafeEqualityProof scrut   , isDeadBinder bndr -- We can only discard the case if the case-binder                       -- is dead.  It usually is, but see #18227-  , [(_, [co_var], rhs)] <- alts+  , [Alt _ [co_var] rhs] <- alts   , let Pair ty1 ty2 = coVarTypes co_var         the_co = mkUnsafeCo Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)         env'   = extendCoVarEnv env co_var the_co@@ -851,10 +866,10 @@         ; return (floats, Case scrut' bndr2 ty alts'') }   where-    sat_alt env (con, bs, rhs)+    sat_alt env (Alt con bs rhs)        = do { (env2, bs') <- cpCloneBndrs env bs             ; rhs' <- cpeBodyNF env2 rhs-            ; return (con, bs', rhs') }+            ; return (Alt con bs' rhs') }  -- --------------------------------------------------------------------------- --              CpeBody: produces a result satisfying CpeBody@@ -924,7 +939,7 @@  data ArgInfo = CpeApp  CoreArg              | CpeCast Coercion-             | CpeTick (Tickish Id)+             | CpeTick CoreTickish  instance Outputable ArgInfo where   ppr (CpeApp arg) = text "app" <+> ppr arg@@ -967,7 +982,10 @@             -> UniqSM (Floats, CpeRhs)     cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth         | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and+            -- See Note [lazyId magic] in GHC.Types.Id.Make        || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a+            -- See Note [noinlineId magic] in GHC.Types.Id.Make+         -- Consider the code:         --         --      lazy (f x) y@@ -1005,9 +1023,9 @@                   Lam s body -> cpe_app (extendCorePrepEnvExpr env s s0) body rest (n-2)                   _          -> cpe_app env k (CpeApp s0 : rest) (n-1)              ; let touchId = mkPrimOpId TouchOp-                   expr = Case k' y result_ty [(DEFAULT, [], rhs)]+                   expr = Case k' y result_ty [Alt DEFAULT [] rhs]                    rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]-                         in Case scrut s2 result_ty [(DEFAULT, [], Var y)]+                         in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)]              ; (floats', expr') <- cpeBody env expr              ; return (floats `appendFloats` floats', expr')              }@@ -1159,7 +1177,7 @@    GHC.Magic. This definition is used in cases where runRW is curried.   * In addition to its normal Haskell definition in GHC.Magic, we give it-   a special late inlining here in CorePrep and GHC.CoreToByteCode, avoiding+   a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding    the incorrect sharing due to float-out noted above.   * It is levity-polymorphic:@@ -1260,7 +1278,7 @@  If runRW# were a "normal" function this call to join point j would not be allowed in its continuation argument. However, since runRW# is inlined (as-described in Note [runRW magic] above), such join point occurences are+described in Note [runRW magic] above), such join point occurrences are completely fine. Both occurrence analysis (see the runRW guard in occAnalApp) and Core Lint (see the App case of lintCoreExpr) have special treatment for runRW# applications. See Note [Linting of runRW#] for details on the latter.@@ -1533,6 +1551,22 @@ Note [Pin demand info on floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We pin demand info on floated lets, so that we can see the one-shot thunks.++Note [Speculative evaluation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since call-by-value is much cheaper than call-by-need, we case-bind arguments+that are either++  1. Strictly evaluated anyway, according to the DmdSig of the callee, or+  2. ok-for-spec, according to 'exprOkForSpeculation'++While (1) is a no-brainer and always beneficial, (2) is a bit+more subtle, as the careful haddock for 'exprOkForSpeculation'+points out. Still, by case-binding the argument we don't need+to allocate a thunk for it, whose closure must be retained as+long as the callee might evaluate it. And if it is evaluated on+most code paths anyway, we get to turn the unknown eval in the+callee into a known call at the call site. -}  data FloatingBind@@ -1548,7 +1582,7 @@                       -- but lifted binding   -- | See Note [Floating Ticks in CorePrep]- | FloatTick (Tickish Id)+ | FloatTick CoreTickish  data Floats = Floats OkToSpec (OrdList FloatingBind) @@ -1581,19 +1615,33 @@  mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind mkFloat dmd is_unlifted bndr rhs-  | is_strict-  , not is_hnf  = FloatCase rhs bndr DEFAULT [] (exprOkForSpeculation rhs)+  | is_strict || ok_for_spec -- See Note [Speculative evaluation]+  , not is_hnf  = FloatCase rhs bndr DEFAULT [] ok_for_spec     -- Don't make a case for a HNF binding, even if it's strict     -- Otherwise we get  case (\x -> e) of ...! -  | is_unlifted = ASSERT2( exprOkForSpeculation rhs, ppr rhs )-                  FloatCase rhs bndr DEFAULT [] True-  | is_hnf    = FloatLet (NonRec bndr                       rhs)-  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)+  | is_unlifted = FloatCase rhs bndr DEFAULT [] True+      -- we used to ASSERT2(ok_for_spec, ppr rhs) here, but it is now disabled+      -- because exprOkForSpeculation isn't stable under ANF-ing. See for+      -- example #19489 where the following unlifted expression:+      --+      --    GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0]+      --                    (GHC.Types.: @a_ax0 a2_agq a3_agl)+      --+      -- is ok-for-spec but is ANF-ised into:+      --+      --    let sat = GHC.Types.: @a_ax0 a2_agq a3_agl+      --    in GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] sat+      --+      -- which isn't ok-for-spec because of the let-expression.++  | is_hnf      = FloatLet (NonRec bndr                       rhs)+  | otherwise   = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)                    -- See Note [Pin demand info on floats]   where-    is_hnf    = exprIsHNF rhs-    is_strict = isStrictDmd dmd+    is_hnf      = exprIsHNF rhs+    is_strict   = isStrUsedDmd dmd+    ok_for_spec = exprOkForSpeculation rhs  emptyFloats :: Floats emptyFloats = Floats OkToSpec nilOL@@ -1605,7 +1653,7 @@ wrapBinds (Floats _ binds) body   = foldrOL mk_bind body binds   where-    mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [(con,bs,body)]+    mk_bind (FloatCase rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs body]     mk_bind (FloatLet bind)               body = Let bind body     mk_bind (FloatTick tickish)           body = mkTick tickish body @@ -1680,7 +1728,7 @@ wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec dmd is_unlifted floats rhs   =  isEmptyFloats floats-  || isStrictDmd dmd+  || isStrUsedDmd dmd   || is_unlifted   || (allLazyNested is_rec floats && exprIsHNF rhs)         -- Why the test for allLazyNested?@@ -1797,9 +1845,9 @@ mkInitialCorePrepEnv hsc_env = do    convertNumLit <- mkConvertNumLiteral hsc_env    return $ CPE-      { cpe_dynFlags = hsc_dflags hsc_env-      , cpe_env = emptyVarEnv-      , cpe_tyco_env = Nothing+      { cpe_dynFlags      = hsc_dflags hsc_env+      , cpe_env           = emptyVarEnv+      , cpe_tyco_env      = Nothing       , cpe_convertNumLit = convertNumLit       } @@ -2091,7 +2139,7 @@       Type{} -> cs       Coercion{} -> cs -    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)+    go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)      go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre     go_bind cs (NonRec b e) =@@ -2116,10 +2164,11 @@    let       dflags   = hsc_dflags hsc_env       platform = targetPlatform dflags+      home_unit = hsc_home_unit hsc_env       guardBignum act-         | homeUnitId dflags == primUnitId+         | isHomeUnitInstanceOf home_unit primUnitId          = return $ panic "Bignum literals are not supported in ghc-prim"-         | homeUnitId dflags == bignumUnitId+         | isHomeUnitInstanceOf home_unit bignumUnitId          = return $ panic "Bignum literals are not supported in ghc-bignum"          | otherwise = act @@ -2192,4 +2241,3 @@      return convertNumLit-

GHC/Data/Bag.hs view

@@ -6,7 +6,7 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor #-}+{-# LANGUAGE ScopedTypeVariables, CPP, DeriveFunctor, TypeFamilies #-}  module GHC.Data.Bag (         Bag, -- abstract type@@ -17,7 +17,7 @@         filterBag, partitionBag, partitionBagWith,         concatBag, catBagMaybes, foldBag,         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,-        listToBag, bagToList, mapAccumBagL,+        listToBag, nonEmptyToBag, bagToList, mapAccumBagL,         concatMapBag, concatMapBagPair, mapMaybeBag,         mapBagM, mapBagM_,         flatMapBagM, flatMapBagPairM,@@ -27,14 +27,15 @@  import GHC.Prelude +import GHC.Exts ( IsList(..) ) import GHC.Utils.Outputable import GHC.Utils.Misc- import GHC.Utils.Monad import Control.Monad import Data.Data import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL )+import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.Foldable as Foldable  infixr 3 `consBag`@@ -299,6 +300,10 @@ listToBag [x] = UnitBag x listToBag vs = ListBag vs +nonEmptyToBag :: NonEmpty a -> Bag a+nonEmptyToBag (x :| []) = UnitBag x+nonEmptyToBag (x :| xs) = ListBag (x : xs)+ bagToList :: Bag a -> [a] bagToList b = foldr (:) [] b @@ -333,3 +338,8 @@   traverse f (UnitBag x)     = UnitBag <$> f x   traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2   traverse f (ListBag xs)    = ListBag <$> traverse f xs++instance IsList (Bag a) where+  type Item (Bag a) = a+  fromList = listToBag+  toList   = bagToList

GHC/Data/Bitmap.hs view

@@ -19,7 +19,6 @@ import GHC.Platform import GHC.Runtime.Heap.Layout -import Data.Bits  {-| A bitmap represented by a sequence of 'StgWord's on the /target/

GHC/Data/BooleanFormula.hs view

@@ -1,5 +1,5 @@-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,-             DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveTraversable  #-}  -------------------------------------------------------------------------------- -- | Boolean formulas without quantifiers and without negation.@@ -24,6 +24,7 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Binary+import GHC.Parser.Annotation ( LocatedL ) import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Set@@ -32,7 +33,7 @@ -- Boolean formula type and smart constructors ---------------------------------------------------------------------- -type LBooleanFormula a = Located (BooleanFormula a)+type LBooleanFormula a = LocatedL (BooleanFormula a)  data BooleanFormula a = Var a | And [LBooleanFormula a] | Or [LBooleanFormula a]                       | Parens (LBooleanFormula a)

GHC/Data/EnumSet.hs view

@@ -8,6 +8,7 @@     , toList     , fromList     , empty+    , difference     ) where  import GHC.Prelude@@ -33,3 +34,6 @@  empty :: EnumSet a empty = EnumSet IntSet.empty++difference :: EnumSet a -> EnumSet a -> EnumSet a+difference (EnumSet a) (EnumSet b) = EnumSet (IntSet.difference a b)

GHC/Data/FastMutInt.hs view

@@ -10,52 +10,37 @@ module GHC.Data.FastMutInt(         FastMutInt, newFastMutInt,         readFastMutInt, writeFastMutInt,--        FastMutPtr, newFastMutPtr,-        readFastMutPtr, writeFastMutPtr+        atomicFetchAddFastMut   ) where  import GHC.Prelude -import Data.Bits import GHC.Base-import GHC.Ptr -newFastMutInt :: IO FastMutInt-readFastMutInt :: FastMutInt -> IO Int-writeFastMutInt :: FastMutInt -> Int -> IO ()--newFastMutPtr :: IO FastMutPtr-readFastMutPtr :: FastMutPtr -> IO (Ptr a)-writeFastMutPtr :: FastMutPtr -> Ptr a -> IO ()--data FastMutInt = FastMutInt (MutableByteArray# RealWorld)+data FastMutInt = FastMutInt !(MutableByteArray# RealWorld) -newFastMutInt = IO $ \s ->-  case newByteArray# size s of { (# s, arr #) ->-  (# s, FastMutInt arr #) }-  where !(I# size) = finiteBitSize (0 :: Int)+newFastMutInt :: Int -> IO FastMutInt+newFastMutInt n = do+    x <- create+    writeFastMutInt x n+    return x+  where+    !(I# size) = finiteBitSize (0 :: Int) `unsafeShiftR` 3+    create = IO $ \s ->+      case newByteArray# size s of+        (# s, arr #) -> (# s, FastMutInt arr #) +readFastMutInt :: FastMutInt -> IO Int readFastMutInt (FastMutInt arr) = IO $ \s ->-  case readIntArray# arr 0# s of { (# s, i #) ->-  (# s, I# i #) }+  case readIntArray# arr 0# s of+    (# s, i #) -> (# s, I# i #) +writeFastMutInt :: FastMutInt -> Int -> IO () writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->-  case writeIntArray# arr 0# i s of { s ->-  (# s, () #) }--data FastMutPtr = FastMutPtr (MutableByteArray# RealWorld)--newFastMutPtr = IO $ \s ->-  case newByteArray# size s of { (# s, arr #) ->-  (# s, FastMutPtr arr #) }-  -- GHC assumes 'sizeof (Int) == sizeof (Ptr a)'-  where !(I# size) = finiteBitSize (0 :: Int)--readFastMutPtr (FastMutPtr arr) = IO $ \s ->-  case readAddrArray# arr 0# s of { (# s, i #) ->-  (# s, Ptr i #) }+  case writeIntArray# arr 0# i s of+    s -> (# s, () #) -writeFastMutPtr (FastMutPtr arr) (Ptr i) = IO $ \s ->-  case writeAddrArray# arr 0# i s of { s ->-  (# s, () #) }+atomicFetchAddFastMut :: FastMutInt -> Int -> IO Int+atomicFetchAddFastMut (FastMutInt arr) (I# i) = IO $ \s ->+  case fetchAddIntArray# arr 0# i s of+    (# s, n #) -> (# s, I# n #)

GHC/Data/FastString.hs view

@@ -1,7 +1,13 @@ -- (c) The University of Glasgow, 1997-2006 -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples,-    GeneralizedNewtypeDeriving #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UnliftedFFITypes #-}+ {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected@@ -12,8 +18,12 @@ -- ['FastString'] -- --   * A compact, hash-consed, representation of character strings.---   * Comparison is O(1), and you can get a 'GHC.Types.Unique.Unique' from them. --   * Generated by 'fsLit'.+--   * You can get a 'GHC.Types.Unique.Unique' from them.+--   * Equality test is O(1) (it uses the Unique).+--   * Comparison is O(1) or O(n):+--       * O(n) but deterministic with lexical comparison (`lexicalCompareFS`)+--       * O(1) but non-deterministic with Unique comparison (`uniqCompareFS`) --   * Turn into 'GHC.Utils.Outputable.SDoc' with 'GHC.Utils.Outputable.ftext'. -- -- ['PtrString']@@ -50,6 +60,8 @@          -- * FastStrings         FastString(..),     -- not abstract, for now.+        NonDetFastString (..),+        LexicalFastString (..),          -- ** Construction         fsLit,@@ -60,6 +72,7 @@          -- ** Deconstruction         unpackFS,           -- :: FastString -> String+        unconsFS,           -- :: FastString -> Maybe (Char, FastString)          -- ** Encoding         zEncodeFS,@@ -74,6 +87,8 @@         consFS,         nilFS,         isUnderscoreFS,+        lexicalCompareFS,+        uniqCompareFS,          -- ** Outputting         hPutFS,@@ -105,6 +120,7 @@ import GHC.Utils.IO.Unsafe import GHC.Utils.Panic.Plain import GHC.Utils.Misc+import GHC.Data.FastMutInt  import Control.Concurrent.MVar import Control.DeepSeq@@ -115,7 +131,9 @@ import qualified Data.ByteString.Char8    as BSC import qualified Data.ByteString.Unsafe   as BS import qualified Data.ByteString.Short    as SBS+#if !MIN_VERSION_bytestring(0,11,0) import qualified Data.ByteString.Short.Internal as SBS+#endif import Foreign.C import System.IO import Data.Data@@ -135,7 +153,7 @@ import GHC.Exts import GHC.IO --- | Gives the UTF-8 encoded bytes corresponding to a 'FastString'+-- | Gives the Modified UTF-8 encoded bytes corresponding to a 'FastString' bytesFS, fastStringToByteString :: FastString -> ByteString bytesFS = fastStringToByteString @@ -187,7 +205,8 @@       n_chars :: {-# UNPACK #-} !Int, -- number of chars       fs_sbs  :: {-# UNPACK #-} !ShortByteString,       fs_zenc :: FastZString-      -- ^ Lazily computed z-encoding of this string.+      -- ^ Lazily computed Z-encoding of this string. See Note [Z-Encoding] in+      -- GHC.Utils.Encoding.       --       -- Since 'FastString's are globally memoized this is computed at most       -- once for any given string.@@ -196,17 +215,10 @@ instance Eq FastString where   f1 == f2  =  uniq f1 == uniq f2 -instance Ord FastString where-    -- Compares lexicographically, not by unique-    a <= b = case cmpFS a b of { LT -> True;  EQ -> True;  GT -> False }-    a <  b = case cmpFS a b of { LT -> True;  EQ -> False; GT -> False }-    a >= b = case cmpFS a b of { LT -> False; EQ -> True;  GT -> True  }-    a >  b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True  }-    max x y | x >= y    =  x-            | otherwise =  y-    min x y | x <= y    =  x-            | otherwise =  y-    compare a b = cmpFS a b+-- We don't provide any "Ord FastString" instance to force you to think about+-- which ordering you want:+--    * lexical:   deterministic,     O(n). Cf lexicalCompareFS and LexicalFastString.+--    * by unique: non-deterministic, O(1). Cf uniqCompareFS    and NonDetFastString.  instance IsString FastString where     fromString = fsLit@@ -231,11 +243,52 @@ instance NFData FastString where   rnf fs = seq fs () -cmpFS :: FastString -> FastString -> Ordering-cmpFS fs1 fs2 =+-- | Compare FastString lexically+--+-- If you don't care about the lexical ordering, use `uniqCompareFS` instead.+lexicalCompareFS :: FastString -> FastString -> Ordering+lexicalCompareFS fs1 fs2 =   if uniq fs1 == uniq fs2 then EQ else-  compare (fs_sbs fs1) (fs_sbs fs2)+  utf8CompareShortByteString (fs_sbs fs1) (fs_sbs fs2)+  -- perform a lexical comparison taking into account the Modified UTF-8+  -- encoding we use (cf #18562) +-- | Compare FastString by their Unique (not lexically).+--+-- Much cheaper than `lexicalCompareFS` but non-deterministic!+uniqCompareFS :: FastString -> FastString -> Ordering+uniqCompareFS fs1 fs2 = compare (uniq fs1) (uniq fs2)++-- | Non-deterministic FastString+--+-- This is a simple FastString wrapper with an Ord instance using+-- `uniqCompareFS` (i.e. which compares FastStrings on their Uniques). Hence it+-- is not deterministic from one run to the other.+newtype NonDetFastString+   = NonDetFastString FastString+   deriving (Eq,Data)++instance Ord NonDetFastString where+   compare (NonDetFastString fs1) (NonDetFastString fs2) = uniqCompareFS fs1 fs2++instance Show NonDetFastString where+   show (NonDetFastString fs) = show fs++-- | Lexical FastString+--+-- This is a simple FastString wrapper with an Ord instance using+-- `lexicalCompareFS` (i.e. which compares FastStrings on their String+-- representation). Hence it is deterministic from one run to the other.+newtype LexicalFastString+   = LexicalFastString FastString+   deriving (Eq,Data)++instance Ord LexicalFastString where+   compare (LexicalFastString fs1) (LexicalFastString fs2) = lexicalCompareFS fs1 fs2++instance Show LexicalFastString where+   show (LexicalFastString fs) = show fs+ -- ----------------------------------------------------------------------------- -- Construction @@ -250,13 +303,13 @@ See Note [Updating the FastString table] on how it's updated. -} data FastStringTable = FastStringTable-  {-# UNPACK #-} !(IORef Int) -- the unique ID counter shared with all buckets-  {-# UNPACK #-} !(IORef Int) -- number of computed z-encodings for all buckets+  {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets+  {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets   (Array# (IORef FastStringTableSegment)) -- concurrent segments  data FastStringTableSegment = FastStringTableSegment-  {-# UNPACK #-} !(MVar ()) -- the lock for write in each segment-  {-# UNPACK #-} !(IORef Int) -- the number of elements+  {-# UNPACK #-} !(MVar ())  -- the lock for write in each segment+  {-# UNPACK #-} !FastMutInt -- the number of elements   (MutableArray# RealWorld [FastString]) -- buckets in this segment  {-@@ -289,7 +342,7 @@   segment@(FastStringTableSegment lock counter old#) <- readIORef segmentRef   let oldSize# = sizeofMutableArray# old#       newSize# = oldSize# *# 2#-  (I# n#) <- readIORef counter+  (I# n#) <- readFastMutInt counter   if isTrue# (n# <# newSize#) -- maximum load of 1   then return segment   else do@@ -317,14 +370,14 @@       loop a# i# s1#         | isTrue# (i# ==# numSegments#) = s1#         | otherwise = case newMVar () `unIO` s1# of-            (# s2#, lock #) -> case newIORef 0 `unIO` s2# of+            (# s2#, lock #) -> case newFastMutInt 0 `unIO` s2# of               (# s3#, counter #) -> case newArray# initialNumBuckets# [] s3# of                 (# s4#, buckets# #) -> case newIORef                     (FastStringTableSegment lock counter buckets#) `unIO` s4# of                   (# s5#, segment #) -> case writeArray# a# i# segment s5# of                     s6# -> loop a# (i# +# 1#) s6#-  uid <- newIORef 603979776 -- ord '$' * 0x01000000-  n_zencs <- newIORef 0+  uid <- newFastMutInt 603979776 -- ord '$' * 0x01000000+  n_zencs <- newFastMutInt 0   tab <- IO $ \s1# ->     case newArray# numSegments# (panic "string_table") s1# of       (# s2#, arr# #) -> case loop arr# 0# s2# of@@ -377,6 +430,7 @@ -}  mkFastString# :: Addr# -> FastString+{-# INLINE mkFastString# #-} mkFastString# a# = mkFastStringBytes ptr (ptrStrLength ptr)   where ptr = Ptr a# @@ -405,7 +459,7 @@ -}  mkFastStringWith-    :: (Int -> IORef Int-> IO FastString) -> ShortByteString -> IO FastString+    :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString mkFastStringWith mk_fs sbs = do   FastStringTableSegment lock _ buckets# <- readIORef segmentRef   let idx# = hashToIndex# buckets# hash#@@ -422,7 +476,7 @@       withMVar lock $ \_ -> insert new_fs   where     !(FastStringTable uid n_zencs segments#) = stringTable-    get_uid = atomicModifyIORef' uid $ \n -> (n+1,n)+    get_uid = atomicFetchAddFastMut uid 1      !(I# hash#) = hashStr sbs     (# segmentRef #) = indexArray# segments# (hashToSegment# hash#)@@ -437,9 +491,9 @@         Just found -> return found         Nothing -> do           IO $ \s1# ->-            case writeArray# buckets# idx# (fs: bucket) s1# of+            case writeArray# buckets# idx# (fs : bucket) s1# of               s2# -> (# s2#, () #)-          modifyIORef' counter succ+          _ <- atomicFetchAddFastMut counter 1           return fs  bucket_match :: [FastString] -> ShortByteString -> IO (Maybe FastString)@@ -457,7 +511,7 @@         mkFastStringWith (mkNewFastStringShortByteString sbs) sbs  newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString-newSBSFromPtr (Ptr src#) (I# len#) = do+newSBSFromPtr (Ptr src#) (I# len#) =   IO $ \s ->     case newByteArray# len# s of { (# s, dst# #) ->     case copyAddrToByteArray# src# dst# 0# len# s of { s ->@@ -489,14 +543,14 @@ mkFastStringByteList str = mkFastStringShortByteString (SBS.pack str)  -- | Creates a (lazy) Z-encoded 'FastString' from a 'ShortByteString' and--- account the number of forced z-strings into the passed 'IORef'.-mkZFastString :: IORef Int -> ShortByteString -> FastZString+-- account the number of forced z-strings into the passed 'FastMutInt'.+mkZFastString :: FastMutInt -> ShortByteString -> FastZString mkZFastString n_zencs sbs = unsafePerformIO $ do-  atomicModifyIORef' n_zencs $ \n -> (n+1, ())+  _ <- atomicFetchAddFastMut n_zencs 1   return $ mkFastZStringString (zEncodeString (utf8DecodeShortByteString sbs))  mkNewFastStringShortByteString :: ShortByteString -> Int-                               -> IORef Int -> IO FastString+                               -> FastMutInt -> IO FastString mkNewFastStringShortByteString sbs uid n_zencs = do   let zstr = mkZFastString n_zencs sbs   chars <- countUTF8Chars sbs@@ -515,7 +569,11 @@           -- DO NOT move this let binding! indexCharOffAddr# reads from the           -- pointer so we need to evaluate this based on the length check           -- above. Not doing this right caused #17909.+#if __GLASGOW_HASKELL__ >= 901+          !c = int8ToInt# (indexInt8Array# ba# n)+#else           !c = indexInt8Array# ba# n+#endif           !h2 = (h *# 16777619#) `xorI#` c         in           loop h2 (n +# 1#)@@ -558,6 +616,12 @@ consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) +unconsFS :: FastString -> Maybe (Char, FastString)+unconsFS fs =+  case unpackFS fs of+    []          -> Nothing+    (chr : str) -> Just (chr, mkFastString str)+ uniqueOfFS :: FastString -> Int uniqueOfFS fs = uniq fs @@ -582,7 +646,7 @@     !(FastStringTable _ _ segments#) = stringTable  getFastStringZEncCounter :: IO Int-getFastStringZEncCounter = readIORef n_zencs+getFastStringZEncCounter = readFastMutInt n_zencs   where     !(FastStringTable _ n_zencs _) = stringTable @@ -605,6 +669,7 @@  -- | Wrap an unboxed address into a 'PtrString'. mkPtrString# :: Addr# -> PtrString+{-# INLINE mkPtrString# #-} mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#))  -- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1@@ -640,8 +705,14 @@ -- ----------------------------------------------------------------------------- -- under the carpet +#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0) foreign import ccall unsafe "strlen"-  ptrStrLength :: Ptr Word8 -> Int+  cstringLength# :: Addr# -> Int#+#endif++ptrStrLength :: Ptr Word8 -> Int+{-# INLINE ptrStrLength #-}+ptrStrLength (Ptr a) = I# (cstringLength# a)  {-# NOINLINE sLit #-} sLit :: String -> PtrString

GHC/Data/Graph/Color.hs view

@@ -25,9 +25,10 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.Maybe-import Data.List+import Data.List (mapAccumL)   -- | Try to color a graph with this set of colors.

GHC/Data/Graph/Directed.hs view

@@ -1,7 +1,9 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE CPP, ScopedTypeVariables, ViewPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}  module GHC.Data.Graph.Directed (         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,@@ -46,12 +48,13 @@  import GHC.Utils.Misc ( minWith, count ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust )  -- std interfaces import Data.Maybe import Data.Array-import Data.List hiding (transpose)+import Data.List ( sort ) import qualified Data.Map as Map import qualified Data.Set as Set

GHC/Data/Graph/Ops.hs view

@@ -41,11 +41,12 @@ import GHC.Data.Graph.Base  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Types.Unique.FM -import Data.List        hiding (union)+import Data.List (mapAccumL, sortBy) import Data.Maybe  -- | Lookup a node from the graph.

GHC/Data/Graph/UnVar.hs view

@@ -17,7 +17,7 @@ module GHC.Data.Graph.UnVar     ( UnVarSet     , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets-    , delUnVarSet+    , extendUnVarSet, delUnVarSet     , elemUnVarSet, isEmptyUnVarSet     , UnVarGraph     , emptyUnVarGraph@@ -34,7 +34,6 @@ import GHC.Types.Var.Env import GHC.Types.Unique.FM import GHC.Utils.Outputable-import GHC.Data.Bag import GHC.Types.Unique  import qualified Data.IntSet as S@@ -64,30 +63,38 @@ delUnVarSet :: UnVarSet -> Var -> UnVarSet delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s +minusUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet+minusUnVarSet (UnVarSet s) (UnVarSet s') = UnVarSet $ s `S.difference` s'++sizeUnVarSet :: UnVarSet -> Int+sizeUnVarSet (UnVarSet s) = S.size s+ mkUnVarSet :: [Var] -> UnVarSet mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs  varEnvDom :: VarEnv a -> UnVarSet varEnvDom ae = UnVarSet $ ufmToSet_Directly ae +extendUnVarSet :: Var -> UnVarSet -> UnVarSet+extendUnVarSet v (UnVarSet s) = UnVarSet $ S.insert (k v) s+ unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)  unionUnVarSets :: [UnVarSet] -> UnVarSet-unionUnVarSets = foldr unionUnVarSet emptyUnVarSet+unionUnVarSets = foldl' (flip unionUnVarSet) emptyUnVarSet  instance Outputable UnVarSet where     ppr (UnVarSet s) = braces $         hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s] ---- The graph type. A list of complete bipartite graphs-data Gen = CBPG UnVarSet UnVarSet -- complete bipartite-         | CG   UnVarSet          -- complete-newtype UnVarGraph = UnVarGraph (Bag Gen)+data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph+                | CG    !UnVarSet           -- ^ complete graph+                | Union UnVarGraph UnVarGraph+                | Del   !UnVarSet UnVarGraph  emptyUnVarGraph :: UnVarGraph-emptyUnVarGraph = UnVarGraph emptyBag+emptyUnVarGraph = CG emptyUnVarSet  unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph {-@@ -101,45 +108,74 @@     = pprTrace "unionUnVarGraph fired2" empty $       completeGraph (s1 `unionUnVarSet` s2) -}-unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)-    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $-      UnVarGraph (g1 `unionBags` g2)+unionUnVarGraph a b+  | is_null a = b+  | is_null b = a+  | otherwise = Union a b  unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph  -- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B } completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph-completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2+completeBipartiteGraph s1 s2 = prune $ CBPG s1 s2  completeGraph :: UnVarSet -> UnVarGraph-completeGraph s = prune $ UnVarGraph $ unitBag $ CG s+completeGraph s = prune $ CG s +-- (v' ∈ neighbors G v) <=> v--v' ∈ G neighbors :: UnVarGraph -> Var -> UnVarSet-neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g-  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])-        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) ++-                          (if v `elemUnVarSet` s2 then [s1] else [])+neighbors = go+  where+    go (Del d g) v+      | v `elemUnVarSet` d = emptyUnVarSet+      | otherwise          = go g v `minusUnVarSet` d+    go (Union g1 g2) v     = go g1 v `unionUnVarSet` go g2 v+    go (CG s) v            = if v `elemUnVarSet` s then s else emptyUnVarSet+    go (CBPG s1 s2) v      = (if v `elemUnVarSet` s1 then s2 else emptyUnVarSet) `unionUnVarSet`+                             (if v `elemUnVarSet` s2 then s1 else emptyUnVarSet)  -- hasLoopAt G v <=> v--v ∈ G hasLoopAt :: UnVarGraph -> Var -> Bool-hasLoopAt (UnVarGraph g) v = any go $ bagToList g-  where go (CG s)       = v `elemUnVarSet` s-        go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2-+hasLoopAt = go+  where+    go (Del d g) v+      | v `elemUnVarSet` d  = False+      | otherwise           = go g v+    go (Union g1 g2) v      = go g1 v || go g2 v+    go (CG s) v             = v `elemUnVarSet` s+    go (CBPG s1 s2) v       = v `elemUnVarSet` s1 && v `elemUnVarSet` s2  delNode :: UnVarGraph -> Var -> UnVarGraph-delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g-  where go (CG s)       = CG (s `delUnVarSet` v)-        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)+delNode (Del d g) v = Del (extendUnVarSet v d) g+delNode g         v+  | is_null g       = emptyUnVarGraph+  | otherwise       = Del (mkUnVarSet [v]) g +-- | Resolves all `Del`, by pushing them in, and simplifies `∅ ∪ … = …` prune :: UnVarGraph -> UnVarGraph-prune (UnVarGraph g) = UnVarGraph $ filterBag go g-  where go (CG s)       = not (isEmptyUnVarSet s)-        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)+prune = go emptyUnVarSet+  where+    go :: UnVarSet -> UnVarGraph -> UnVarGraph+    go dels (Del dels' g) = go (dels `unionUnVarSet` dels') g+    go dels (Union g1 g2)+      | is_null g1' = g2'+      | is_null g2' = g1'+      | otherwise   = Union g1' g2'+      where+        g1' = go dels g1+        g2' = go dels g2+    go dels (CG s)        = CG (s `minusUnVarSet` dels)+    go dels (CBPG s1 s2)  = CBPG (s1 `minusUnVarSet` dels) (s2 `minusUnVarSet` dels) -instance Outputable Gen where-    ppr (CG s)       = ppr s  <> char '²'-    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2+-- | Shallow empty check.+is_null :: UnVarGraph -> Bool+is_null (CBPG s1 s2)  = isEmptyUnVarSet s1 || isEmptyUnVarSet s2+is_null (CG   s)      = isEmptyUnVarSet s+is_null _             = False+ instance Outputable UnVarGraph where-    ppr (UnVarGraph g) = ppr g+    ppr (Del d g) = text "Del" <+> ppr (sizeUnVarSet d) <+> parens (ppr g)+    ppr (Union a b) = text "Union" <+> parens (ppr a) <+> parens (ppr b)+    ppr (CG s) = text "CG" <+> ppr (sizeUnVarSet s)+    ppr (CBPG a b) = text "CBPG" <+> ppr (sizeUnVarSet a) <+> ppr (sizeUnVarSet b)

GHC/Data/IOEnv.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DerivingVia #-}-+{-# LANGUAGE PatternSynonyms #-} -- -- (c) The University of Glasgow 2002-2006 --@@ -29,13 +29,14 @@         tryM, tryAllM, tryMostM, fixM,          -- I/O operations-        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar, updMutVarM,         atomicUpdMutVar, atomicUpdMutVar'   ) where  import GHC.Prelude  import GHC.Driver.Session+import {-# SOURCE #-} GHC.Driver.Hooks import GHC.Utils.Exception import GHC.Unit.Module import GHC.Utils.Panic@@ -48,7 +49,9 @@ import Control.Monad.Trans.Reader import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import GHC.Utils.Monad+import GHC.Utils.Logger import Control.Applicative (Alternative(..))+import GHC.Exts( oneShot ) import Control.Concurrent.MVar (newEmptyMVar, readMVar, putMVar) import Control.Concurrent (forkIO, killThread) @@ -57,10 +60,24 @@ ----------------------------------------------------------------------  -newtype IOEnv env a = IOEnv (env -> IO a)-  deriving (Functor)-  deriving (MonadThrow, MonadCatch, MonadMask, MonadIO) via (ReaderT env IO)+newtype IOEnv env a = IOEnv' (env -> IO a)+  deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT env IO) +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+instance Functor (IOEnv env) where+   fmap f (IOEnv g) = IOEnv $ \env -> fmap f (g env)+   a <$ IOEnv g     = IOEnv $ \env -> g env >> pure a++instance MonadIO (IOEnv env) where+   liftIO f = IOEnv (\_ -> f)++pattern IOEnv :: forall env a. (env -> IO a) -> IOEnv env a+pattern IOEnv m <- IOEnv' m+  where+    IOEnv m = IOEnv' (oneShot m)++{-# COMPLETE IOEnv #-}+ unIOEnv :: IOEnv env a -> (env -> IO a) unIOEnv (IOEnv m) = m @@ -103,6 +120,15 @@     getDynFlags = do env <- getEnv                      return $! extractDynFlags env +instance ContainsHooks env => HasHooks (IOEnv env) where+    getHooks = do env <- getEnv+                  return $! extractHooks env++instance ContainsLogger env => HasLogger (IOEnv env) where+    getLogger = do env <- getEnv+                   return $! extractLogger env++ instance ContainsModule env => HasModule (IOEnv env) where     getModule = do env <- getEnv                    return $ extractModule env@@ -199,6 +225,12 @@  updMutVar :: IORef a -> (a -> a) -> IOEnv env () updMutVar var upd = liftIO (modifyIORef var upd)++updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env ()+updMutVarM ref upd+  = do { contents     <- liftIO $ readIORef ref+       ; new_contents <- upd contents+       ; liftIO $ writeIORef ref new_contents }  -- | Atomically update the reference.  Does not force the evaluation of the -- new variable contents.  For strict update, use 'atomicUpdMutVar''.

GHC/Data/List/SetOps.hs view

@@ -28,7 +28,9 @@ import GHC.Prelude  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Driver.Ppr  import qualified Data.List as L import qualified Data.List.NonEmpty as NE@@ -101,12 +103,13 @@ Inefficient finite maps based on association lists and equality. -} --- A finite mapping based on equality and association lists+-- | A finite mapping based on equality and association lists. type Assoc a b = [(a,b)]  assoc             :: (Eq a) => String -> Assoc a b -> a -> b assocDefault      :: (Eq a) => b -> Assoc a b -> a -> b assocUsing        :: (a -> a -> Bool) -> String -> Assoc a b -> a -> b+-- | Lookup key, fail gracefully using Nothing if not found. assocMaybe        :: (Eq a) => Assoc a b -> a -> Maybe b assocDefaultUsing :: (a -> a -> Bool) -> b -> Assoc a b -> a -> b

GHC/Data/Maybe.hs view

@@ -16,7 +16,7 @@         failME, isSuccess,          orElse,-        firstJust, firstJusts,+        firstJust, firstJusts, firstJustsM,         whenIsJust,         expectJust,         rightToMaybe,@@ -31,6 +31,7 @@ import Control.Monad.Trans.Maybe import Control.Exception (catch, SomeException(..)) import Data.Maybe+import Data.Foldable ( foldlM ) import GHC.Utils.Misc (HasCallStack)  infixr 4 `orElse`@@ -50,6 +51,15 @@ -- @Nothing@ otherwise. firstJusts :: [Maybe a] -> Maybe a firstJusts = msum++-- | Takes computations returnings @Maybes@; tries each one in order.+-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations+-- return @Nothing@.+firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)+firstJustsM = foldlM go Nothing where+  go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)+  go Nothing         action  = action+  go result@(Just _) _action = return result  expectJust :: HasCallStack => String -> Maybe a -> a {-# INLINE expectJust #-}

GHC/Data/OrdList.hs view

@@ -5,23 +5,28 @@  -} {-# LANGUAGE DeriveFunctor #-}- {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedSums #-}+{-# LANGUAGE UnboxedTuples #-}  -- | Provide trees (of instructions), so that lists of instructions can be -- appended in linear time. module GHC.Data.OrdList (-        OrdList,+        OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,         headOL,-        mapOL, fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,+        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,         strictlyEqOL, strictlyOrdOL ) where  import GHC.Prelude import Data.Foldable +import GHC.Utils.Misc (strictMap) import GHC.Utils.Outputable+import GHC.Utils.Panic  import qualified Data.Semigroup as Semigroup @@ -78,6 +83,50 @@ consOL a    bs   = Cons a bs concatOL aas = foldr appOL None aas +pattern NilOL :: OrdList a+pattern NilOL <- (isNilOL -> True) where+  NilOL = None++-- | An unboxed 'Maybe' type with two unboxed fields in the 'Just' case.+-- Useful for defining 'viewCons' and 'viewSnoc' without overhead.+type VMaybe a b = (# (# a, b #) | (# #) #)+pattern VJust :: a -> b -> VMaybe a b+pattern VJust a b = (# (# a, b #) | #)+pattern VNothing :: VMaybe a b+pattern VNothing = (# | (# #) #)+{-# COMPLETE VJust, VNothing #-}++pattern ConsOL :: a -> OrdList a -> OrdList a+pattern ConsOL x xs <- (viewCons -> VJust x xs) where+  ConsOL x xs = consOL x xs+{-# COMPLETE NilOL, ConsOL #-}+viewCons :: OrdList a -> VMaybe a (OrdList a)+viewCons (One a)       = VJust a NilOL+viewCons (Cons a as) = VJust a as+viewCons (Snoc as a) = case viewCons as of+  VJust a' as' -> VJust a' (Snoc as' a)+  VNothing     -> VJust a NilOL+viewCons (Two as1 as2) = case viewCons as1 of+  VJust a' as1' -> VJust a' (Two as1' as2)+  VNothing      -> viewCons as2+viewCons _ = VNothing++pattern SnocOL :: OrdList a -> a -> OrdList a+pattern SnocOL xs x <- (viewSnoc -> VJust xs x) where+  SnocOL xs x = snocOL xs x+{-# COMPLETE NilOL, SnocOL #-}+viewSnoc :: OrdList a -> VMaybe (OrdList a) a+viewSnoc (One a)       = VJust NilOL a+viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) a+viewSnoc (Snoc as a) = VJust as a+viewSnoc (Cons a as) = case viewSnoc as of+  VJust as' a' -> VJust (Cons a as') a'+  VNothing     -> VJust NilOL a+viewSnoc (Two as1 as2) = case viewSnoc as2 of+  VJust as2' a' -> VJust (Two as1 as2') a'+  VNothing      -> viewSnoc as1+viewSnoc _ = VNothing+ headOL None        = panic "headOL" headOL (One a)     = a headOL (Many as)   = head as@@ -131,6 +180,20 @@ mapOL :: (a -> b) -> OrdList a -> OrdList b mapOL = fmap +mapOL' :: (a->b) -> OrdList a -> OrdList b+mapOL' _ None        = None+mapOL' f (One x)     = One $! f x+mapOL' f (Cons x xs) = let !x1 = f x+                           !xs1 = mapOL' f xs+                       in Cons x1 xs1+mapOL' f (Snoc xs x) = let !x1 = f x+                           !xs1 = mapOL' f xs+                       in Snoc xs1 x1+mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1+                           !b2' = mapOL' f b2+                       in Two b1' b2'+mapOL' f (Many xs)   = Many $! strictMap f xs+ foldrOL :: (a->b->b) -> b -> OrdList a -> b foldrOL _ z None        = z foldrOL k z (One x)     = k x z@@ -188,5 +251,3 @@ strictlyOrdOL (Two _ _)    _          = LT strictlyOrdOL (Many as)   (Many bs)   = compare as bs strictlyOrdOL (Many _ )   _           = GT--

GHC/Data/Stream.hs view

@@ -1,3 +1,6 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TupleSections #-} -- ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2012@@ -6,25 +9,28 @@  -- | Monadic streams module GHC.Data.Stream (-    Stream(..), yield, liftIO,-    collect, collect_, consume, fromList,-    map, mapM, mapAccumL, mapAccumL_+    Stream(..), StreamS(..), runStream, yield, liftIO,+    collect,  consume, fromList,+    map, mapM, mapAccumL_   ) where  import GHC.Prelude hiding (map,mapM)  import Control.Monad hiding (mapM)+import Control.Monad.IO.Class  -- | -- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence -- of elements of type @a@ followed by a result of type @b@. ----- More concretely, a value of type @Stream m a b@ can be run using @runStream@+-- More concretely, a value of type @Stream m a b@ can be run using @runStreamInternal@ -- in the Monad @m@, and it delivers either -----  * the final result: @Left b@, or---  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@---    is a computation to get the rest of the stream.+--  * the final result: @Done b@, or+--  * @Yield a str@ where @a@ is the next element in the stream, and @str@+--     is the rest of the stream+--  * @Effect mstr@ where @mstr@ is some action running in @m@ which+--  generates the rest of the stream. -- -- Stream is itself a Monad, and provides an operation 'yield' that -- produces a new element of the stream.  This makes it convenient to turn@@ -38,57 +44,73 @@ -- Stream, and the consumer pulls on the stream each time it wants a -- new value. ---newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }+-- 'Stream' is implemented in the "yoneda" style for efficiency. By+-- representing a stream in this manner 'fmap' and '>>=' operations are+-- accumulated in the function parameters before being applied once when+-- the stream is destroyed. In the old implementation each usage of 'mapM'+-- and '>>=' would traverse the entire stream in order to apply the+-- substitution at the leaves.+--+-- The >>= operation for 'Stream' was a hot-spot in the ticky profile for+-- the "ManyConstructors" test which called the 'cg' function many times in+-- @StgToCmm.hs@+--+newtype Stream m a b =+          Stream { runStreamInternal :: forall r' r .+                                        (a -> m r') -- For fusing calls to `map` and `mapM`+                                     -> (b -> StreamS m r' r)  -- For fusing `>>=`+                                     -> StreamS m r' r } -instance Monad f => Functor (Stream f a) where+runStream :: Applicative m => Stream m r' r -> StreamS m r' r+runStream st = runStreamInternal st pure Done++data StreamS m a b = Yield a (StreamS m a b)+                   | Done b+                   | Effect (m (StreamS m a b))++instance Monad m => Functor (StreamS m a) where   fmap = liftM -instance Monad m => Applicative (Stream m a) where-  pure a = Stream (return (Left a))+instance Monad m => Applicative (StreamS m a) where+  pure = Done   (<*>) = ap -instance Monad m => Monad (Stream m a) where+instance Monad m => Monad (StreamS m a) where+  a >>= k = case a of+                      Done r -> k r+                      Yield a s -> Yield a (s >>= k)+                      Effect m -> Effect (fmap (>>= k) m) -  Stream m >>= k = Stream $ do-                r <- m-                case r of-                  Left b        -> runStream (k b)-                  Right (a,str) -> return (Right (a, str >>= k))+instance Functor (Stream f a) where+  fmap = liftM -yield :: Monad m => a -> Stream m a ()-yield a = Stream (return (Right (a, return ())))+instance Applicative (Stream m a) where+  pure a = Stream $ \_f g -> g a+  (<*>) = ap -liftIO :: IO a -> Stream IO b a-liftIO io = Stream $ io >>= return . Left+instance Monad (Stream m a) where+  Stream m >>= k = Stream $ \f h -> m f (\a -> runStreamInternal (k a) f h) --- | Turn a Stream into an ordinary list, by demanding all the elements.-collect :: Monad m => Stream m a () -> m [a]-collect str = go str []- where-  go str acc = do-    r <- runStream str-    case r of-      Left () -> return (reverse acc)-      Right (a, str') -> go str' (a:acc)+instance MonadIO m => MonadIO (Stream m b) where+  liftIO io = Stream $ \_f g -> Effect (g <$> liftIO io) +yield :: Monad m => a -> Stream m a ()+yield a = Stream $ \f rest -> Effect (flip Yield (rest ())  <$> f a)+ -- | Turn a Stream into an ordinary list, by demanding all the elements.-collect_ :: Monad m => Stream m a r -> m ([a], r)-collect_ str = go str []+collect :: Monad m => Stream m a () -> m [a]+collect str = go [] (runStream str)  where-  go str acc = do-    r <- runStream str-    case r of-      Left r -> return (reverse acc, r)-      Right (a, str') -> go str' (a:acc)+  go acc (Done ()) = return (reverse acc)+  go acc (Effect m) = m >>= go acc+  go acc (Yield a k) = go (a:acc) k -consume :: Monad m => Stream m a b -> (a -> m ()) -> m b-consume str f = do-    r <- runStream str-    case r of-      Left ret -> return ret-      Right (a, str') -> do-        f a-        consume str' f+consume :: (Monad m, Monad n) => Stream m a b -> (forall a . m a -> n a) -> (a -> n ()) -> n b+consume str l f = go (runStream str)+  where+    go (Done r) = return r+    go (Yield a p) = f a >> go p+    go (Effect m)  = l m >>= go  -- | Turn a list into a 'Stream', by yielding each element in turn. fromList :: Monad m => [a] -> Stream m a ()@@ -96,40 +118,27 @@  -- | Apply a function to each element of a 'Stream', lazily map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x-map f str = Stream $ do-   r <- runStream str-   case r of-     Left x -> return (Left x)-     Right (a, str') -> return (Right (f a, map f str'))+map f str = Stream $ \g h -> runStreamInternal str (g . f) h  -- | Apply a monadic operation to each element of a 'Stream', lazily mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x-mapM f str = Stream $ do-   r <- runStream str-   case r of-     Left x -> return (Left x)-     Right (a, str') -> do-        b <- f a-        return (Right (b, mapM f str'))---- | analog of the list-based 'mapAccumL' on Streams.  This is a simple--- way to map over a Stream while carrying some state around.-mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()-          -> Stream m b c-mapAccumL f c str = Stream $ do-  r <- runStream str-  case r of-    Left  () -> return (Left c)-    Right (a, str') -> do-      (c',b) <- f c a-      return (Right (b, mapAccumL f c' str'))+mapM f str = Stream $ \g h -> runStreamInternal str (g <=< f) h -mapAccumL_ :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r+-- | Note this is not very efficient because it traverses the whole stream+-- before rebuilding it, avoid using it if you can. mapAccumL used to+-- implemented but it wasn't used anywhere in the compiler and has similar+-- effiency problems.+mapAccumL_ :: forall m a b c r . Monad m => (c -> a -> m (c,b)) -> c -> Stream m a r            -> Stream m b (c, r)-mapAccumL_ f c str = Stream $ do-  r <- runStream str-  case r of-    Left  r -> return (Left (c, r))-    Right (a, str') -> do-      (c',b) <- f c a-      return (Right (b, mapAccumL_ f c' str'))+mapAccumL_ f c str = Stream $ \f h -> go c f h (runStream str)++  where+    go :: c+             -> (b -> m r')+             -> ((c, r) -> StreamS m r' r1)+             -> StreamS m a r+             -> StreamS m r' r1+    go c _f1 h1 (Done r) = h1 (c, r)+    go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b+                                           >>= \r' -> return $ Yield r' (go c' f1 h1 p)))+    go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m)

GHC/Data/StringBuffer.hs view

@@ -6,7 +6,11 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+ {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected@@ -42,11 +46,7 @@           -- * Parsing integers         parseUnsignedInteger,--        -- * Checking for bi-directional format characters-        containsBidirectionalFormatChar,-        bidirectionalFormatChars-        ) where+       ) where  #include "HsVersions.h" @@ -191,7 +191,7 @@   let size = utf8EncodedLength str   buf <- mallocForeignPtrArray (size+3)   unsafeWithForeignPtr buf $ \ptr -> do-    utf8EncodeString ptr str+    utf8EncodeStringPtr ptr str     pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]     -- sentinels for UTF-8 decoding   return (StringBuffer buf size 0)@@ -214,58 +214,6 @@           (# c#, nBytes# #) ->              let cur' = I# (cur# +# nBytes#) in              return (C# c#, StringBuffer buf len cur')---bidirectionalFormatChars :: [(Char,String)]-bidirectionalFormatChars =-  [ ('\x202a' , "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)")-  , ('\x202b' , "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)")-  , ('\x202c' , "U+202C POP DIRECTIONAL FORMATTING (PDF)")-  , ('\x202d' , "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)")-  , ('\x202e' , "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)")-  , ('\x2066' , "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)")-  , ('\x2067' , "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)")-  , ('\x2068' , "U+2068 FIRST STRONG ISOLATE (FSI)")-  , ('\x2069' , "U+2069 POP DIRECTIONAL ISOLATE (PDI)")-  ]--{-| Returns true if the buffer contains Unicode bi-directional formatting-characters.--https://www.unicode.org/reports/tr9/#Bidirectional_Character_Types--Bidirectional format characters are one of-'\x202a' : "U+202A LEFT-TO-RIGHT EMBEDDING (LRE)"-'\x202b' : "U+202B RIGHT-TO-LEFT EMBEDDING (RLE)"-'\x202c' : "U+202C POP DIRECTIONAL FORMATTING (PDF)"-'\x202d' : "U+202D LEFT-TO-RIGHT OVERRIDE (LRO)"-'\x202e' : "U+202E RIGHT-TO-LEFT OVERRIDE (RLO)"-'\x2066' : "U+2066 LEFT-TO-RIGHT ISOLATE (LRI)"-'\x2067' : "U+2067 RIGHT-TO-LEFT ISOLATE (RLI)"-'\x2068' : "U+2068 FIRST STRONG ISOLATE (FSI)"-'\x2069' : "U+2069 POP DIRECTIONAL ISOLATE (PDI)"--This list is encoded in 'bidirectionalFormatChars'---}-{-# INLINE containsBidirectionalFormatChar #-}-containsBidirectionalFormatChar :: StringBuffer -> Bool-containsBidirectionalFormatChar (StringBuffer buf (I# len#) (I# cur#))-  = inlinePerformIO $ unsafeWithForeignPtr buf $ \(Ptr a#) -> do-  let go :: Int# -> Bool-      go i | isTrue# (i >=# len#) = False-           | otherwise = case utf8DecodeCharAddr# a# i of-                (# '\x202a'#  , _ #) -> True-                (# '\x202b'#  , _ #) -> True-                (# '\x202c'#  , _ #) -> True-                (# '\x202d'#  , _ #) -> True-                (# '\x202e'#  , _ #) -> True-                (# '\x2066'#  , _ #) -> True-                (# '\x2067'#  , _ #) -> True-                (# '\x2068'#  , _ #) -> True-                (# '\x2069'#  , _ #) -> True-                (# _, bytes #) -> go (i +# bytes)-  pure $! go cur#  -- | Return the first UTF-8 character of a nonempty 'StringBuffer' (analogous -- to 'Data.List.head').  __Warning:__ The behavior is undefined if the

GHC/Data/TrieMap.hs view

@@ -1,14 +1,13 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -}--{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} module GHC.Data.TrieMap(    -- * Maps over 'Maybe' values    MaybeMap,@@ -17,11 +16,11 @@    -- * Maps over 'Literal's    LiteralMap,    -- * 'TrieMap' class-   TrieMap(..), insertTM, deleteTM,+   TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM,     -- * Things helpful for adding additional Instances.    (>.>), (|>), (|>>), XT,-   foldMaybe,+   foldMaybe, filterMaybe,    -- * Map for leaf compression    GenMap,    lkG, xtG, mapG, fdG,@@ -41,13 +40,15 @@ import Control.Monad( (>=>) ) import Data.Kind( Type ) +import qualified Data.Semigroup as S+ {- This module implements TrieMaps, which are finite mappings whose key is a structured value like a CoreExpr or Type.  This file implements tries over general data structures. Implementation for tries over Core Expressions/Types are-available in GHC.Core.Map.+available in GHC.Core.Map.Expr.  The regular pattern for handling TrieMaps on data structures was first described (to my knowledge) in Connelly and Morris's 1995 paper "A@@ -71,6 +72,7 @@    lookupTM :: forall b. Key m -> m b -> Maybe b    alterTM  :: forall b. Key m -> XT b -> m b -> m b    mapTM    :: (a->b) -> m a -> m b+   filterTM :: (a -> Bool) -> m a -> m a     foldTM   :: (a -> b -> b) -> m a -> b -> b       -- The unusual argument order here makes@@ -83,6 +85,13 @@ deleteTM :: TrieMap m => Key m -> m a -> m a deleteTM k m = alterTM k (\_ -> Nothing) m +foldMapTM :: (TrieMap m, Monoid r) => (a -> r) -> m a -> r+foldMapTM f m = foldTM (\ x r -> f x S.<> r) m mempty++-- This looks inefficient.+isEmptyTM :: TrieMap m => m a -> Bool+isEmptyTM m = foldTM (\ _ _ -> False) m True+ ---------------------- -- Recall that --   Control.Monad.(>=>) :: (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c@@ -122,6 +131,7 @@   alterTM = xtInt   foldTM k m z = IntMap.foldr k z m   mapTM f m = IntMap.map f m+  filterTM f m = IntMap.filter f m  xtInt :: Int -> XT a -> IntMap.IntMap a -> IntMap.IntMap a xtInt k f m = IntMap.alter f k m@@ -133,6 +143,7 @@   alterTM k f m = Map.alter f k m   foldTM k m z = Map.foldr k z m   mapTM f m = Map.map f m+  filterTM f m = Map.filter f m   {-@@ -209,6 +220,7 @@   alterTM k f m = alterUDFM f m k   foldTM k m z = foldUDFM k z m   mapTM f m = mapUDFM f m+  filterTM f m = filterUDFM f m  {- ************************************************************************@@ -230,7 +242,11 @@    alterTM  = xtMaybe alterTM    foldTM   = fdMaybe    mapTM    = mapMb+   filterTM = ftMaybe +instance TrieMap m => Foldable (MaybeMap m) where+  foldMap = foldMapTM+ mapMb :: TrieMap m => (a->b) -> MaybeMap m a -> MaybeMap m b mapMb f (MM { mm_nothing = mn, mm_just = mj })   = MM { mm_nothing = fmap f mn, mm_just = mapTM f mj }@@ -249,6 +265,19 @@ fdMaybe k m = foldMaybe k (mm_nothing m)             . foldTM k (mm_just m) +ftMaybe :: TrieMap m => (a -> Bool) -> MaybeMap m a -> MaybeMap m a+ftMaybe f (MM { mm_nothing = mn, mm_just = mj })+  = MM { mm_nothing = filterMaybe f mn, mm_just = filterTM f mj }++foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b+foldMaybe _ Nothing  b = b+foldMaybe k (Just a) b = k a b++filterMaybe :: (a -> Bool) -> Maybe a -> Maybe a+filterMaybe _ Nothing = Nothing+filterMaybe f input@(Just x) | f x       = input+                             | otherwise = Nothing+ {- ************************************************************************ *                                                                      *@@ -268,7 +297,11 @@    alterTM  = xtList alterTM    foldTM   = fdList    mapTM    = mapList+   filterTM = ftList +instance TrieMap m => Foldable (ListMap m) where+  foldMap = foldMapTM+ instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where   ppr m = text "List elts" <+> ppr (foldTM (:) m []) @@ -291,9 +324,9 @@ fdList k m = foldMaybe k          (lm_nil m)            . foldTM    (fdList k) (lm_cons m) -foldMaybe :: (a -> b -> b) -> Maybe a -> b -> b-foldMaybe _ Nothing  b = b-foldMaybe k (Just a) b = k a b+ftList :: TrieMap m => (a -> Bool) -> ListMap m a -> ListMap m a+ftList f (LM { lm_nil = mnil, lm_cons = mcons })+  = LM { lm_nil = filterMaybe f mnil, lm_cons = mapTM (filterTM f) mcons }  {- ************************************************************************@@ -333,7 +366,7 @@ nothing in the map, don't bother building out the (possibly infinite) recursive TrieMap structure! -Compressed triemaps are heavily used by GHC.Core.Map. So we have to mark some things+Compressed triemaps are heavily used by GHC.Core.Map.Expr. So we have to mark some things as INLINEABLE to permit specialization. -} @@ -355,7 +388,11 @@    alterTM  = xtG    foldTM   = fdG    mapTM    = mapG+   filterTM = ftG +instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where+  foldMap = foldMapTM+ --We want to be able to specialize these functions when defining eg --tries over (GenMap CoreExpr) which requires INLINEABLE @@ -404,3 +441,13 @@ fdG _ EmptyMap = \z -> z fdG k (SingletonMap _ v) = \z -> k v z fdG k (MultiMap m) = foldTM k m++{-# INLINEABLE ftG #-}+ftG :: TrieMap m => (a -> Bool) -> GenMap m a -> GenMap m a+ftG _ EmptyMap = EmptyMap+ftG f input@(SingletonMap _ v)+  | f v       = input+  | otherwise = EmptyMap+ftG f (MultiMap m) = MultiMap (filterTM f m)+  -- we don't have enough information to reconstruct the key to make+  -- a SingletonMap

GHC/Driver/Backend.hs view

@@ -5,18 +5,82 @@    ( Backend (..)    , platformDefaultBackend    , platformNcgSupported+   , backendProducesObject+   , backendRetainsAllBindings    ) where  import GHC.Prelude import GHC.Platform --- | Backend+-- | Code generation backends.+--+-- GHC supports several code generation backends serving different purposes+-- (producing machine code, producing ByteCode for the interpreter) and+-- supporting different platforms.+-- data Backend-   = NCG           -- ^ Native code generator backend-   | LLVM          -- ^ LLVM backend-   | ViaC          -- ^ Via-C backend-   | Interpreter   -- ^ Interpreter+   = NCG           -- ^ Native code generator backend.+                   --+                   -- Compiles Cmm code into textual assembler, then relies on+                   -- an external assembler toolchain to produce machine code.+                   --+                   -- Only supports a few platforms (X86, PowerPC, SPARC).+                   --+                   -- See "GHC.CmmToAsm".+++   | LLVM          -- ^ LLVM backend.+                   --+                   -- Compiles Cmm code into LLVM textual IR, then relies on+                   -- LLVM toolchain to produce machine code.+                   --+                   -- It relies on LLVM support for the calling convention used+                   -- by the NCG backend to produce code objects ABI compatible+                   -- with it (see "cc 10" or "ghccc" calling convention in+                   -- https://llvm.org/docs/LangRef.html#calling-conventions).+                   --+                   -- Support a few platforms (X86, AArch64, s390x, ARM).+                   --+                   -- See "GHC.CmmToLlvm"+++   | ViaC          -- ^ Via-C backend.+                   --+                   -- Compiles Cmm code into C code, then relies on a C compiler+                   -- to produce machine code.+                   --+                   -- It produces code objects that are *not* ABI compatible+                   -- with those produced by NCG and LLVM backends.+                   --+                   -- Produced code is expected to be less efficient than the+                   -- one produced by NCG and LLVM backends because STG+                   -- registers are not pinned into real registers.  On the+                   -- other hand, it supports more target platforms (those+                   -- having a valid C toolchain).+                   --+                   -- See "GHC.CmmToC"+++   | Interpreter   -- ^ ByteCode interpreter.+                   --+                   -- Produce ByteCode objects (BCO, see "GHC.ByteCode") that+                   -- can be interpreted. It is used by GHCi.+                   --+                   -- Currently some extensions are not supported+                   -- (foreign primops).+                   --+                   -- See "GHC.StgToByteCode"+++   | NoBackend     -- ^ No code generated.+                   --+                   -- Use this to disable code generation. It is particularly+                   -- useful when GHC is used as a library for other purpose+                   -- than generating code (e.g. to generate documentation with+                   -- Haddock) or when the user requested it (via -fno-code) for+                   -- some reason.+    deriving (Eq,Ord,Show,Read)  -- | Default backend to use for the given platform.@@ -40,4 +104,29 @@          ArchPPC       -> True          ArchPPC_64 {} -> True          ArchSPARC     -> True+         ArchAArch64   -> True          _             -> False++-- | Will this backend produce an object file on the disk?+backendProducesObject :: Backend -> Bool+backendProducesObject ViaC        = True+backendProducesObject NCG         = True+backendProducesObject LLVM        = True+backendProducesObject Interpreter = False+backendProducesObject NoBackend   = False++-- | Does this backend retain *all* top-level bindings for a module,+-- rather than just the exported bindings, in the TypeEnv and compiled+-- code (if any)?+--+-- Interpreter backend does this, so that GHCi can call functions inside a+-- module.+--+-- When no backend is used we also do it, so that Haddock can get access to the+-- GlobalRdrEnv for a module after typechecking it.+backendRetainsAllBindings :: Backend -> Bool+backendRetainsAllBindings Interpreter = True+backendRetainsAllBindings NoBackend   = True+backendRetainsAllBindings ViaC        = False+backendRetainsAllBindings NCG         = False+backendRetainsAllBindings LLVM        = False

GHC/Driver/Backpack.hs view

@@ -1,8 +1,10 @@-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} + -- | This is the driver for the 'ghc --backpack' mode, which -- is a reimplementation of the "package manager" bits of -- Backpack directly in GHC.  The basic method of operation@@ -22,38 +24,59 @@  -- In a separate module because it hooks into the parser. import GHC.Driver.Backpack.Syntax+import GHC.Driver.Config+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Main+import GHC.Driver.Make+import GHC.Driver.Env+import GHC.Driver.Errors -import GHC.Parser.Annotation-import GHC hiding (Failed, Succeeded) import GHC.Parser+import GHC.Parser.Header import GHC.Parser.Lexer-import GHC.Driver.Monad-import GHC.Driver.Session+import GHC.Parser.Annotation+import GHC.Parser.Errors.Ppr++import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad-import GHC.Tc.Module-import GHC.Unit-import GHC.Driver.Types-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Utils.Error+import GHC.Iface.Recomp+import GHC.Builtin.Names+ import GHC.Types.SrcLoc-import GHC.Driver.Main+import GHC.Types.SourceError+import GHC.Types.SourceText+import GHC.Types.SourceFile import GHC.Types.Unique.FM import GHC.Types.Unique.DFM-import GHC.Utils.Outputable-import GHC.Data.Maybe-import GHC.Parser.Header-import GHC.Iface.Recomp-import GHC.Driver.Make import GHC.Types.Unique.DSet-import GHC.Builtin.Names-import GHC.Types.Basic hiding (SuccessFlag(..))-import GHC.Driver.Finder++import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Logger +import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModSummary+import GHC.Unit.Home.ModInfo++import GHC.Linker.Types+ import qualified GHC.LanguageExtensions as LangExt -import GHC.Utils.Panic+import GHC.Data.Maybe+import GHC.Data.StringBuffer+import GHC.Data.FastString+import qualified GHC.Data.EnumSet as EnumSet+import qualified GHC.Data.ShortText as ST+ import Data.List ( partition ) import System.Exit import Control.Monad@@ -64,10 +87,13 @@ import Data.IORef import Data.Map (Map) import qualified Data.Map as Map+import qualified Data.Set as Set  -- | Entry point to compile a Backpack file. doBackpack :: [FilePath] -> Ghc () doBackpack [src_filename] = do+    logger <- getLogger+     -- Apply options from file to dflags     dflags0 <- getDynFlags     let dflags1 = dflags0@@ -75,19 +101,19 @@     (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts     modifySession (\hsc_env -> hsc_env {hsc_dflags = dflags})     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline-    liftIO $ checkProcessArgsResult dflags unhandled_flags-    liftIO $ handleFlagWarnings dflags warns+    liftIO $ checkProcessArgsResult unhandled_flags+    liftIO $ handleFlagWarnings logger dflags warns     -- TODO: Preprocessing not implemented      buf <- liftIO $ hGetStringBuffer src_filename     let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 -- TODO: not great-    case unP parseBackpack (mkPState dflags buf loc) of-        PFailed pst -> throwErrors (getErrorMessages pst dflags)+    case unP parseBackpack (initParserState (initParserOpts dflags) buf loc) of+        PFailed pst -> throwErrors (fmap pprError (getErrorMessages pst))         POk _ pkgname_bkp -> do             -- OK, so we have an LHsUnit PackageName, but we want an             -- LHsUnit HsComponentId.  So let's rename it.-            let pkgstate = unitState dflags-            let bkp = renameHsUnits pkgstate (bkpPackageNameMap pkgstate pkgname_bkp) pkgname_bkp+            hsc_env <- getSession+            let bkp = renameHsUnits (hsc_units hsc_env) (bkpPackageNameMap pkgname_bkp) pkgname_bkp             initBkpM src_filename bkp $                 forM_ (zip [1..] bkp) $ \(i, lunit) -> do                     let comp_name = unLoc (hsunitName (unLoc lunit))@@ -95,7 +121,7 @@                     innerBkpM $ do                         let (cid, insts) = computeUnitId lunit                         if null insts-                            then if cid == Indefinite (UnitId (fsLit "main")) Nothing+                            then if cid == Indefinite (UnitId (fsLit "main"))                                     then compileExe lunit                                     else compileUnit cid []                             else typecheckUnit cid insts@@ -136,7 +162,7 @@                -> BkpM a withBkpSession cid insts deps session_type do_this = do     dflags <- getDynFlags-    let cid_fs = unitIdFS (indefUnit cid)+    let cid_fs = unitFS (indefUnit cid)         is_primary = False         uid_str = unpackFS (mkInstantiatedUnitHash cid insts)         cid_str = unpackFS cid_fs@@ -153,62 +179,71 @@                  -- Special case when package is definite                  , not (null insts) = sub_comp (key_base p) </> uid_str                  | otherwise = sub_comp (key_base p)-    withTempSession (overHscDynFlags (\dflags ->-      -- If we're type-checking an indefinite package, we want to-      -- turn on interface writing.  However, if the user also-      -- explicitly passed in `-fno-code`, we DON'T want to write-      -- interfaces unless the user also asked for `-fwrite-interface`.-      -- See Note [-fno-code mode]-      (case session_type of-        -- Make sure to write interfaces when we are type-checking-        -- indefinite packages.-        TcSession | hscTarget dflags /= HscNothing-                  -> flip gopt_set Opt_WriteInterface-                  | otherwise -> id-        CompSession -> id-        ExeSession -> id) $-      dflags {-        hscTarget   = case session_type of-                        TcSession -> HscNothing-                        _ -> hscTarget dflags,-        homeUnitInstantiations = insts,-                                 -- if we don't have any instantiation, don't-                                 -- fill `homeUnitInstanceOfId` as it makes no-                                 -- sense (we're not instantiating anything)-        homeUnitInstanceOfId   = if null insts then Nothing else Just cid,-        homeUnitId =-            case session_type of++        mk_temp_env hsc_env = hsc_env+            { hsc_dflags   = mk_temp_dflags (hsc_units hsc_env) (hsc_dflags hsc_env)+            }+        mk_temp_dflags unit_state dflags = dflags+            { backend = case session_type of+                            TcSession -> NoBackend+                            _         -> backend dflags+            , homeUnitInstantiations_ = insts+                                     -- if we don't have any instantiation, don't+                                     -- fill `homeUnitInstanceOfId` as it makes no+                                     -- sense (we're not instantiating anything)+            , homeUnitInstanceOf_   = if null insts then Nothing else Just (indefUnit cid)+            , homeUnitId_ = case session_type of                 TcSession -> newUnitId cid Nothing                 -- No hash passed if no instances                 _ | null insts -> newUnitId cid Nothing-                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)),-        -- Setup all of the output directories according to our hierarchy-        objectDir   = Just (outdir objectDir),-        hiDir       = Just (outdir hiDir),-        stubDir     = Just (outdir stubDir),-        -- Unset output-file for non exe builds-        outputFile  = if session_type == ExeSession-                        then outputFile dflags-                        else Nothing,-        -- Clear the import path so we don't accidentally grab anything-        importPaths = [],-        -- Synthesized the flags-        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->-          let state = unitState dflags-              uid = unwireUnit state (improveUnit state $ renameHoleUnit state (listToUFM insts) uid0)-          in ExposePackage-            (showSDoc dflags-                (text "-unit-id" <+> ppr uid <+> ppr rn))-            (UnitIdArg uid) rn) deps-      } )) $ do-        dflags <- getSessionDynFlags-        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()-        setSessionDynFlags dflags -- calls initUnits-        do_this+                  | otherwise  -> newUnitId cid (Just (mkInstantiatedUnitHash cid insts)) ++            -- If we're type-checking an indefinite package, we want to+            -- turn on interface writing.  However, if the user also+            -- explicitly passed in `-fno-code`, we DON'T want to write+            -- interfaces unless the user also asked for `-fwrite-interface`.+            -- See Note [-fno-code mode]+            , generalFlags = case session_type of+                -- Make sure to write interfaces when we are type-checking+                -- indefinite packages.+                TcSession+                  | backend dflags /= NoBackend+                  -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)+                _ -> generalFlags dflags++            -- Setup all of the output directories according to our hierarchy+            , objectDir   = Just (outdir objectDir)+            , hiDir       = Just (outdir hiDir)+            , stubDir     = Just (outdir stubDir)+            -- Unset output-file for non exe builds+            , outputFile_ = case session_type of+                ExeSession -> outputFile_ dflags+                _          -> Nothing+            , dynOutputFile_ = case session_type of+                ExeSession -> dynOutputFile_ dflags+                _          -> Nothing+            -- Clear the import path so we don't accidentally grab anything+            , importPaths = []+            -- Synthesize the flags+            , packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->+              let uid = unwireUnit unit_state+                        $ improveUnit unit_state+                        $ renameHoleUnit unit_state (listToUFM insts) uid0+              in ExposePackage+                (showSDoc dflags+                    (text "-unit-id" <+> ppr uid <+> ppr rn))+                (UnitIdArg uid) rn) deps+            }+    withTempSession mk_temp_env $ do+      dflags <- getSessionDynFlags+      -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()+      setSessionDynFlags dflags -- calls initUnits+      do_this+ withBkpExeSession :: [(Unit, ModRenaming)] -> BkpM a -> BkpM a-withBkpExeSession deps do_this = do-    withBkpSession (Indefinite (UnitId (fsLit "main")) Nothing) [] deps ExeSession do_this+withBkpExeSession deps do_this =+    withBkpSession (Indefinite (UnitId (fsLit "main"))) [] deps ExeSession do_this  getSource :: IndefUnitId -> BkpM (LHsUnit HsComponentId) getSource cid = do@@ -258,11 +293,11 @@     -- any object files.     let deps_w_rns = hsunitDeps (session == TcSession) (unLoc lunit)         raw_deps = map fst deps_w_rns-    dflags <- getDynFlags+    hsc_env <- getSession     -- The compilation dependencies are just the appropriately filled     -- in unit IDs which must be compiled before we can compile.     let hsubst = listToUFM insts-        deps0 = map (renameHoleUnit (unitState dflags) hsubst) raw_deps+        deps0 = map (renameHoleUnit (hsc_units hsc_env) hsubst) raw_deps      -- Build dependencies OR make sure they make sense. BUT NOTE,     -- we can only check the ones that are fully filled; the rest@@ -273,9 +308,8 @@             TcSession -> return ()             _ -> compileInclude (length deps0) (i, dep) -    dflags <- getDynFlags     -- IMPROVE IT-    let deps = map (improveUnit (unitState dflags)) deps0+    let deps = map (improveUnit (hsc_units hsc_env)) deps0      mb_old_eps <- case session of                     TcSession -> fmap Just getEpsGhc@@ -284,8 +318,7 @@     conf <- withBkpSession cid insts deps_w_rns session $ do          dflags <- getDynFlags-        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)-        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()+        mod_graph <- hsunitModuleGraph (unLoc lunit)          msg <- mkBackpackMsg         ok <- load' LoadAllTargets (Just msg) mod_graph@@ -305,10 +338,11 @@                       $ home_mod_infos             getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)             obj_files = concatMap getOfiles linkables-            state     = unitState (hsc_dflags hsc_env)+            state     = hsc_units hsc_env          let compat_fs = unitIdFS (indefUnit cid)             compat_pn = PackageName compat_fs+            unit_id   = homeUnitId (hsc_home_unit hsc_env)          return GenericUnitInfo {             -- Stub data@@ -316,7 +350,7 @@             unitPackageId = PackageId compat_fs,             unitPackageName = compat_pn,             unitPackageVersion = makeVersion [],-            unitId = toUnitId (homeUnit dflags),+            unitId = unit_id,             unitComponentName = Nothing,             unitInstanceOf = cid,             unitInstantiations = insts,@@ -337,8 +371,8 @@             unitAbiDepends = [],             unitLinkerOptions = case session of                                  TcSession -> []-                                 _ -> obj_files,-            unitImportDirs = [ hi_dir ],+                                 _ -> map ST.pack $ obj_files,+            unitImportDirs = [ ST.pack $ hi_dir ],             unitIsExposed = False,             unitIsIndefinite = case session of                                  TcSession -> True@@ -360,7 +394,7 @@             }  -    addPackage conf+    addUnit conf     case mb_old_eps of         Just old_eps -> updateEpsGhc_ (const old_eps)         _ -> return ()@@ -374,29 +408,46 @@     forM_ (zip [1..] deps) $ \(i, dep) ->         compileInclude (length deps) (i, dep)     withBkpExeSession deps_w_rns $ do-        dflags <- getDynFlags-        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+        mod_graph <- hsunitModuleGraph (unLoc lunit)         msg <- mkBackpackMsg         ok <- load' LoadAllTargets (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1))  -- | Register a new virtual unit database containing a single unit-addPackage :: GhcMonad m => UnitInfo -> m ()-addPackage pkg = do-    dflags <- GHC.getSessionDynFlags-    case unitDatabases dflags of-        Nothing -> panic "addPackage: called too early"-        Just dbs -> do+addUnit :: GhcMonad m => UnitInfo -> m ()+addUnit u = do+    hsc_env <- getSession+    logger <- getLogger+    let dflags0 = hsc_dflags hsc_env+    newdbs <- case hsc_unit_dbs hsc_env of+        Nothing  -> panic "addUnit: called too early"+        Just dbs ->          let newdb = UnitDatabase-               { unitDatabasePath  = "(in memory " ++ showSDoc dflags (ppr (unitId pkg)) ++ ")"-               , unitDatabaseUnits = [pkg]+               { unitDatabasePath  = "(in memory " ++ showSDoc dflags0 (ppr (unitId u)) ++ ")"+               , unitDatabaseUnits = [u]                }-         GHC.setSessionDynFlags (dflags { unitDatabases = Just (dbs ++ [newdb]) })+         in return (dbs ++ [newdb]) -- added at the end because ordering matters+    (dbs,unit_state,home_unit,mconstants) <- liftIO $ initUnits logger dflags0 (Just newdbs) +    -- update platform constants+    dflags <- liftIO $ updatePlatformConstants dflags0 mconstants++    let unit_env = UnitEnv+          { ue_platform  = targetPlatform dflags+          , ue_namever   = ghcNameVersion dflags+          , ue_home_unit = home_unit+          , ue_units     = unit_state+          }+    setSession $ hsc_env+        { hsc_unit_dbs = Just dbs+        , hsc_dflags   = dflags+        , hsc_unit_env = unit_env+        }+ compileInclude :: Int -> (Int, Unit) -> BkpM () compileInclude n (i, uid) = do     hsc_env <- getSession-    let pkgs = unitState (hsc_dflags hsc_env)+    let pkgs = hsc_units hsc_env     msgInclude (i, n) uid     -- Check if we've compiled it already     case uid of@@ -433,7 +484,10 @@ -- TODO: just make a proper new monad for BkpM, rather than use IOEnv instance {-# OVERLAPPING #-} HasDynFlags BkpM where     getDynFlags = fmap hsc_dflags getSession+instance {-# OVERLAPPING #-} HasLogger BkpM where+    getLogger = fmap hsc_logger getSession + instance GhcMonad BkpM where     getSession = do         Session s <- fmap bkp_session getEnv@@ -450,13 +504,9 @@ getBkpLevel :: BkpM Int getBkpLevel = bkp_level `fmap` getBkpEnv --- | Apply a function on 'DynFlags' on an 'HscEnv'-overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv-overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }- -- | Run a 'BkpM' computation, with the nesting level bumped one. innerBkpM :: BkpM a -> BkpM a-innerBkpM do_this = do+innerBkpM do_this =     -- NB: withTempSession mutates, so we don't have to worry     -- about bkp_session being stale.     updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this@@ -475,14 +525,14 @@  -- | Run 'BkpM' in 'Ghc'. initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a-initBkpM file bkp m = do-    reifyGhc $ \session -> do+initBkpM file bkp m =+  reifyGhc $ \session -> do     let env = BkpEnv {-                    bkp_session = session,-                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],-                    bkp_filename = file,-                    bkp_level = 0-                }+        bkp_session = session,+        bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],+        bkp_filename = file,+        bkp_level = 0+      }     runIOEnv env m  -- ----------------------------------------------------------------------------@@ -490,9 +540,10 @@  -- | Print a compilation progress message, but with indentation according -- to @level@ (for nested compilation).-backpackProgressMsg :: Int -> DynFlags -> String -> IO ()-backpackProgressMsg level dflags msg =-    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg+backpackProgressMsg :: Int -> Logger -> DynFlags -> SDoc -> IO ()+backpackProgressMsg level logger dflags msg =+    compilationProgressMsg logger dflags $ text (replicate (level * 2) ' ') -- TODO: use GHC.Utils.Ppr.RStr+                                      <> msg  -- | Creates a 'Messager' for Backpack compilation; this is basically -- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which@@ -500,20 +551,30 @@ mkBackpackMsg :: BkpM Messager mkBackpackMsg = do     level <- getBkpLevel-    return $ \hsc_env mod_index recomp mod_summary ->+    return $ \hsc_env mod_index recomp node ->       let dflags = hsc_dflags hsc_env+          logger = hsc_logger hsc_env+          state = hsc_units hsc_env           showMsg msg reason =-            backpackProgressMsg level dflags $-                showModuleIndex mod_index ++-                msg ++ showModMsg dflags (hscTarget dflags)-                                  (recompileRequired recomp) mod_summary-                    ++ reason-      in case recomp of-            MustCompile -> showMsg "Compiling " ""+            backpackProgressMsg level logger dflags $ pprWithUnitState state $+                showModuleIndex mod_index <>+                msg <> showModMsg dflags (recompileRequired recomp) node+                    <> reason+      in case node of+        InstantiationNode _ ->+          case recomp of+            MustCompile -> showMsg (text "Instantiating ") empty             UpToDate-                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""-                | otherwise -> return ()-            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")+              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+              | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")+        ModuleNode _ ->+          case recomp of+            MustCompile -> showMsg (text "Compiling ") empty+            UpToDate+              | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty+              | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")  -- | 'PprStyle' for Backpack messages; here we usually want the module to -- be qualified (so we can tell how it was instantiated.) But we try not@@ -529,43 +590,50 @@ msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM () msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do     dflags <- getDynFlags+    logger <- getLogger     level <- getBkpLevel-    liftIO . backpackProgressMsg level dflags-        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn+    liftIO . backpackProgressMsg level logger dflags+        $ showModuleIndex (i, n) <> text "Processing " <> ftext fs_pn  -- | Message when we instantiate a Backpack unit. msgUnitId :: Unit -> BkpM () msgUnitId pk = do     dflags <- getDynFlags+    logger <- getLogger+    hsc_env <- getSession     level <- getBkpLevel-    liftIO . backpackProgressMsg level dflags-        $ "Instantiating " ++ renderWithStyle-                                (initSDocContext dflags backpackStyle)-                                (ppr pk)+    let state = hsc_units hsc_env+    liftIO . backpackProgressMsg level logger dflags+        $ pprWithUnitState state+        $ text "Instantiating "+           <> withPprStyle backpackStyle (ppr pk)  -- | Message when we include a Backpack unit. msgInclude :: (Int,Int) -> Unit -> BkpM () msgInclude (i,n) uid = do     dflags <- getDynFlags+    logger <- getLogger+    hsc_env <- getSession     level <- getBkpLevel-    liftIO . backpackProgressMsg level dflags-        $ showModuleIndex (i, n) ++ "Including " ++-          renderWithStyle (initSDocContext dflags backpackStyle)-            (ppr uid)+    let state = hsc_units hsc_env+    liftIO . backpackProgressMsg level logger dflags+        $ pprWithUnitState state+        $ showModuleIndex (i, n) <> text "Including "+            <> withPprStyle backpackStyle (ppr uid)  -- ---------------------------------------------------------------------------- -- 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-unitDefines :: UnitState -> LHsUnit PackageName -> (PackageName, HsComponentId)-unitDefines pkgstate (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })-    = (pn, HsComponentId pn (mkIndefUnitId pkgstate fs))+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })+    = (pn, HsComponentId pn (Indefinite (UnitId fs))) -bkpPackageNameMap :: UnitState -> [LHsUnit PackageName] -> PackageNameMap HsComponentId-bkpPackageNameMap pkgstate units = Map.fromList (map (unitDefines pkgstate) units)+bkpPackageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId+bkpPackageNameMap units = listToUFM (map unitDefines units)  renameHsUnits :: UnitState -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId] renameHsUnits pkgstate m units = map (fmap renameHsUnit) units@@ -573,7 +641,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"@@ -638,14 +706,17 @@ -- -- We don't bother trying to support GHC.Driver.Make for now, it's more trouble -- than it's worth for inline modules.-hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph-hsunitModuleGraph dflags unit = do+hsunitModuleGraph :: HsUnit HsComponentId -> BkpM ModuleGraph+hsunitModuleGraph unit = do+    hsc_env <- getSession+     let decls = hsunitBody unit         pn = hsPackageName (unLoc (hsunitName unit))+        home_unit = hsc_home_unit hsc_env      --  1. Create a HsSrcFile/HsigFile summary for every     --  explicitly mentioned module/signature.-    let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) = do+    let get_decl (L _ (DeclD hsc_src lmodname mb_hsmod)) =           Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod         get_decl _ = return Nothing     nodes <- catMaybes `fmap` mapM get_decl decls@@ -653,16 +724,21 @@     --  2. For each hole which does not already have an hsig file,     --  create an "empty" hsig file to induce compilation for the     --  requirement.-    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)-                                | n <- nodes ]-    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations dflags) $ \(mod_name, _) ->-        let has_local = Map.member (mod_name, True) node_map-        in if has_local+    let hsig_set = Set.fromList+          [ ms_mod_name ms+          | ExtendedModSummary { emsModSummary = ms } <- nodes+          , ms_hsc_src ms == HsigFile+          ]+    req_nodes <- fmap catMaybes . forM (homeUnitInstantiations home_unit) $ \(mod_name, _) ->+        if Set.member mod_name hsig_set             then return Nothing-            else fmap Just $ summariseRequirement pn mod_name+            else fmap (Just . extendModSummaryNoDeps) $ summariseRequirement pn mod_name+            -- Using extendModSummaryNoDeps here is okay because we're making a leaf node+            -- representing a signature that can't depend on any other unit.      -- 3. Return the kaboodle-    return $ mkModuleGraph $ nodes ++ req_nodes+    return $ mkModuleGraph' $+      (ModuleNode <$> (nodes ++ req_nodes)) ++ instantiationNodes (hsc_units hsc_env)  summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary summariseRequirement pn mod_name = do@@ -695,16 +771,16 @@         ms_textual_imps = extra_sig_imports,         ms_parsed_mod = Just (HsParsedModule {                 hpm_module = L loc (HsModule {+                        hsmodAnn = noAnn,                         hsmodLayout = NoLayoutInfo,-                        hsmodName = Just (L loc mod_name),+                        hsmodName = Just (L (noAnnSrcSpan loc) mod_name),                         hsmodExports = Nothing,                         hsmodImports = [],                         hsmodDecls = [],                         hsmodDeprecMessage = Nothing,                         hsmodHaddockModHeader = Nothing                     }),-                hpm_src_files = [],-                hpm_annotations = ApiAnns Map.empty Nothing Map.empty []+                hpm_src_files = []             }),         ms_hspp_file = "", -- none, it came inline         ms_hspp_opts = dflags,@@ -715,21 +791,20 @@               -> HscSource               -> Located ModuleName               -> Maybe (Located HsModule)-              -> BkpM ModSummary+              -> BkpM ExtendedModSummary summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing     = do hsc_env <- getSession-         let dflags = hsc_dflags hsc_env          -- TODO: this looks for modules in the wrong place          r <- liftIO $ summariseModule hsc_env-                         Map.empty -- GHC API recomp not supported+                         emptyModNodeMap -- GHC API recomp not supported                          (hscSourceToIsBoot hsc_src)                          lmodname                          True -- Target lets you disallow, but not here                          Nothing -- GHC API buffer support not supported                          [] -- No exclusions          case r of-            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))+            Nothing -> throwOneError (mkPlainMsgEnvelope loc (text "module" <+> ppr modname <+> text "was not found"))             Just (Left err) -> throwErrors err             Just (Right summary) -> return summary @@ -742,7 +817,7 @@                      -> HscSource                      -> ModuleName                      -> Located HsModule-                     -> BkpM ModSummary+                     -> BkpM ExtendedModSummary hsModuleToModSummary pn hsc_src modname                      hsmod = do     let imps = hsmodImports (unLoc hsmod)@@ -785,16 +860,18 @@         implicit_prelude = xopt LangExt.ImplicitPrelude dflags         implicit_imports = mkPrelImports modname loc                                          implicit_prelude imps-        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), reLoc $ ideclName i)      extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname      let normal_imports = map convImport (implicit_imports ++ ordinary_imps)-    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports+    (implicit_sigs, inst_deps) <- liftIO $ implicitRequirementsShallow hsc_env normal_imports      -- So that Finder can find it, even though it doesn't exist...     this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location-    return ModSummary {+    return $ ExtendedModSummary+      { emsModSummary =+          ModSummary {             ms_mod = this_mod,             ms_hsc_src = hsc_src,             ms_location = location,@@ -809,18 +886,19 @@                            -- due to merging, requirements may end up with                            -- extra imports                            ++ extra_sig_imports-                           ++ required_by_imports,+                           ++ ((,) Nothing . noLoc <$> implicit_sigs),             -- This is our hack to get the parse tree to the right spot             ms_parsed_mod = Just (HsParsedModule {                     hpm_module = hsmod,-                    hpm_src_files = [], -- TODO if we preprocessed it-                    hpm_annotations = ApiAnns Map.empty Nothing Map.empty [] -- BOGUS+                    hpm_src_files = [] -- TODO if we preprocessed it                 }),             ms_hs_date = time,             ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS             ms_iface_date = hi_timestamp,             ms_hie_date = hie_timestamp-        }+          }+      , emsInstantiatedUnits = inst_deps+      }  -- | Create a new, externally provided hashed unit id from -- a hash.

GHC/Driver/Backpack/Syntax.hs view

@@ -18,11 +18,16 @@  import GHC.Prelude -import GHC.Driver.Phases import GHC.Hs+ import GHC.Types.SrcLoc+import GHC.Types.SourceFile++import GHC.Unit.Module.Name+import GHC.Unit.Types+import GHC.Unit.Info+ import GHC.Utils.Outputable-import GHC.Unit  {- ************************************************************************

GHC/Driver/CmdLine.hs view

@@ -36,7 +36,7 @@ import GHC.Utils.Json  import Data.Function-import Data.List+import Data.List (sortBy, intercalate, stripPrefix)  import Control.Monad (liftM, ap) @@ -77,6 +77,7 @@     | OptPrefix (String -> EwM m ())       -- -f or -farg (i.e. the arg is optional)     | OptIntSuffix (Maybe Int -> EwM m ()) -- -f or -f=n; pass n to fn     | IntSuffix (Int -> EwM m ())          -- -f or -f=n; pass n to fn+    | WordSuffix (Word -> EwM m ())        -- -f or -f=n; pass n to fn     | FloatSuffix (Float -> EwM m ())      -- -f or -f=n; pass n to fn     | PassFlag  (String -> EwM m ())       -- -f; pass "-f" fn     | AnySuffix (String -> EwM m ())       -- -f or -farg; pass entire "-farg" to fn@@ -253,6 +254,9 @@         IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)                     | otherwise -> Left ("malformed integer argument in " ++ dash_arg) +        WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)+                     | otherwise -> Left ("malformed natural argument in " ++ dash_arg)+         FloatSuffix f | Just n <- parseFloat rest_no_eq -> Right (f n, args)                       | otherwise -> Left ("malformed float argument in " ++ dash_arg) @@ -279,6 +283,7 @@                                             -- to improve error message (#12625) arg_ok (OptIntSuffix    _)  _    _   = True arg_ok (IntSuffix       _)  _    _   = True+arg_ok (WordSuffix      _)  _    _   = True arg_ok (FloatSuffix     _)  _    _   = True arg_ok (OptPrefix       _)  _    _   = True arg_ok (PassFlag        _)  rest _   = null rest@@ -291,6 +296,11 @@ --   * gibberish    => Nothing parseInt :: String -> Maybe Int parseInt s = case reads s of+                 ((n,""):_) -> Just n+                 _          -> Nothing++parseWord :: String -> Maybe Word+parseWord s = case reads s of                  ((n,""):_) -> Just n                  _          -> Nothing

GHC/Driver/CodeOutput.hs view

@@ -10,34 +10,48 @@    ( codeOutput    , outputForeignStubs    , profilingInitCode+   , ipInitCode    ) where  #include "HsVersions.h"  import GHC.Prelude+import GHC.Platform+import GHC.ForeignSrcLang  import GHC.CmmToAsm     ( nativeCodeGen ) import GHC.CmmToLlvm    ( llvmCodeGen ) -import GHC.Types.Unique.Supply ( mkSplitUniqSupply )--import GHC.Driver.Finder    ( mkStubPaths )-import GHC.CmmToC           ( writeC )+import GHC.CmmToC           ( cmmToC ) import GHC.Cmm.Lint         ( cmmLint ) import GHC.Cmm              ( RawCmmGroup ) import GHC.Cmm.CLabel-import GHC.Driver.Types+ import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Backend++import qualified GHC.Data.ShortText as ST import GHC.Data.Stream           ( Stream ) import qualified GHC.Data.Stream as Stream-import GHC.SysTools.FileCleanup +import GHC.Utils.TmpFs++ import GHC.Utils.Error import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+ import GHC.Unit+import GHC.Unit.State+import GHC.Unit.Finder      ( mkStubPaths )+ import GHC.Types.SrcLoc import GHC.Types.CostCentre+import GHC.Types.ForeignStubs+import GHC.Types.Unique.Supply ( mkSplitUniqSupply )  import Control.Exception import System.Directory@@ -52,21 +66,24 @@ ************************************************************************ -} -codeOutput :: DynFlags-           -> Module-           -> FilePath-           -> ModLocation-           -> ForeignStubs-           -> [(ForeignSrcLang, FilePath)]-           -- ^ additional files to be compiled with the C compiler-           -> [UnitId]-           -> Stream IO RawCmmGroup a                       -- Compiled C---           -> IO (FilePath,-                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),-                  [(ForeignSrcLang, FilePath)]{-foreign_fps-},-                  a)--codeOutput dflags this_mod filenm location foreign_stubs foreign_fps pkg_deps+codeOutput+    :: Logger+    -> TmpFs+    -> DynFlags+    -> UnitState+    -> Module+    -> FilePath+    -> ModLocation+    -> (a -> ForeignStubs)+    -> [(ForeignSrcLang, FilePath)]+    -- ^ additional files to be compiled with the C compiler+    -> [UnitId]+    -> Stream IO RawCmmGroup a                       -- Compiled C--+    -> IO (FilePath,+           (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),+           [(ForeignSrcLang, FilePath)]{-foreign_fps-},+           a)+codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps   cmm_stream   =     do  {@@ -76,31 +93,32 @@                     then Stream.mapM do_lint cmm_stream                     else cmm_stream -              do_lint cmm = withTimingSilent+              do_lint cmm = withTimingSilent logger                   dflags                   (text "CmmLint"<+>brackets (ppr this_mod))                   (const ()) $ do-                { case cmmLint dflags cmm of-                        Just err -> do { log_action dflags+                { case cmmLint (targetPlatform dflags) cmm of+                        Just err -> do { putLogMsg logger                                                    dflags                                                    NoReason                                                    SevDump                                                    noSrcSpan                                                    $ withPprStyle defaultDumpStyle err-                                       ; ghcExit dflags 1+                                       ; ghcExit logger dflags 1                                        }                         Nothing  -> return ()                 ; return cmm                 } -        ; stubs_exist <- outputForeignStubs dflags this_mod location foreign_stubs-        ; a <- case hscTarget dflags of-                 HscAsm         -> outputAsm dflags this_mod location filenm-                                             linted_cmm_stream-                 HscC           -> outputC dflags filenm linted_cmm_stream pkg_deps-                 HscLlvm        -> outputLlvm dflags filenm linted_cmm_stream-                 HscInterpreted -> panic "codeOutput: HscInterpreted"-                 HscNothing     -> panic "codeOutput: HscNothing"+        ; a <- case backend dflags of+                 NCG         -> outputAsm logger dflags this_mod location filenm+                                          linted_cmm_stream+                 ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps+                 LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream+                 Interpreter -> panic "codeOutput: Interpreter"+                 NoBackend   -> panic "codeOutput: NoBackend"+        ; let stubs = genForeignStubs a+        ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs         ; return (filenm, stubs_exist, foreign_fps, a)         } @@ -115,20 +133,27 @@ ************************************************************************ -} -outputC :: DynFlags+outputC :: Logger+        -> DynFlags         -> FilePath         -> Stream IO RawCmmGroup a         -> [UnitId]         -> IO a--outputC dflags filenm cmm_stream packages-  = do-       withTiming dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do-         let pkg_names = map unitIdString packages-         doOutput filenm $ \ h -> do-            hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")-            hPutStr h "#include \"Stg.h\"\n"-            Stream.consume cmm_stream (writeC dflags h)+outputC logger dflags filenm cmm_stream packages =+  withTiming logger dflags (text "C codegen") (\a -> seq a () {- FIXME -}) $ do+    let pkg_names = map unitIdString packages+    doOutput filenm $ \ h -> do+      hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")+      hPutStr h "#include \"Stg.h\"\n"+      let platform = targetPlatform dflags+          writeC cmm = do+            let doc = cmmToC platform cmm+            dumpIfSet_dyn logger dflags Opt_D_dump_c_backend+                          "C backend output"+                          FormatC+                          doc+            printForC dflags h doc+      Stream.consume cmm_stream id writeC  {- ************************************************************************@@ -138,17 +163,19 @@ ************************************************************************ -} -outputAsm :: DynFlags -> Module -> ModLocation -> FilePath+outputAsm :: Logger+          -> DynFlags+          -> Module+          -> ModLocation+          -> FilePath           -> Stream IO RawCmmGroup a           -> IO a-outputAsm dflags this_mod location filenm cmm_stream-  = do ncg_uniqs <- mkSplitUniqSupply 'n'--       debugTraceMsg dflags 4 (text "Outputing asm to" <+> text filenm)--       {-# SCC "OutputAsm" #-} doOutput filenm $-           \h -> {-# SCC "NativeCodeGen" #-}-                 nativeCodeGen dflags this_mod location h ncg_uniqs cmm_stream+outputAsm logger dflags this_mod location filenm cmm_stream = do+  ncg_uniqs <- mkSplitUniqSupply 'n'+  debugTraceMsg logger dflags 4 (text "Outputing asm to" <+> text filenm)+  {-# SCC "OutputAsm" #-} doOutput filenm $+    \h -> {-# SCC "NativeCodeGen" #-}+      nativeCodeGen logger dflags this_mod location h ncg_uniqs cmm_stream  {- ************************************************************************@@ -158,11 +185,11 @@ ************************************************************************ -} -outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm dflags filenm cmm_stream-  = do {-# SCC "llvm_output" #-} doOutput filenm $-           \f -> {-# SCC "llvm_CodeGen" #-}-                 llvmCodeGen dflags f cmm_stream+outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a+outputLlvm logger dflags filenm cmm_stream =+  {-# SCC "llvm_output" #-} doOutput filenm $+    \f -> {-# SCC "llvm_CodeGen" #-}+      llvmCodeGen logger dflags f cmm_stream  {- ************************************************************************@@ -172,19 +199,26 @@ ************************************************************************ -} -outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs-                   -> IO (Bool,         -- Header file created-                          Maybe FilePath) -- C file created-outputForeignStubs dflags mod location stubs+outputForeignStubs+    :: Logger+    -> TmpFs+    -> DynFlags+    -> UnitState+    -> Module+    -> ModLocation+    -> ForeignStubs+    -> IO (Bool,         -- Header file created+           Maybe FilePath) -- C file created+outputForeignStubs logger tmpfs dflags unit_state mod location stubs  = do    let stub_h = mkStubPaths dflags (moduleName mod) location-   stub_c <- newTempName dflags TFL_CurrentModule "c"+   stub_c <- newTempName logger tmpfs dflags TFL_CurrentModule "c"     case stubs of      NoStubs ->         return (False, Nothing) -     ForeignStubs h_code c_code -> do+     ForeignStubs (CHeader h_code) (CStub c_code) -> do         let             stub_c_output_d = pprCode CStyle c_code             stub_c_output_w = showSDoc dflags stub_c_output_d@@ -195,16 +229,21 @@          createDirectoryIfMissing True (takeDirectory stub_h) -        dumpIfSet_dyn dflags Opt_D_dump_foreign+        dumpIfSet_dyn logger dflags Opt_D_dump_foreign                       "Foreign export header file"                       FormatC                       stub_h_output_d          -- we need the #includes from the rts package for the stub files         let rts_includes =-               let rts_pkg = unsafeLookupUnitId (unitState dflags) rtsUnitId in-               concatMap mk_include (unitIncludes rts_pkg)-            mk_include i = "#include \"" ++ i ++ "\"\n"+               let mrts_pkg = lookupUnitId unit_state rtsUnitId+                   mk_include i = "#include \"" ++ ST.unpack i ++ "\"\n"+               in case mrts_pkg of+                    Just rts_pkg -> concatMap mk_include (unitIncludes rts_pkg)+                    -- This case only happens when compiling foreign stub for the rts+                    -- library itself. The only time we do this at the moment is for+                    -- IPE information for the RTS info tables+                    Nothing -> ""              -- wrapper code mentions the ffi_arg type, which comes from ffi.h             ffi_includes@@ -215,7 +254,7 @@            <- outputForeignStubs_help stub_h stub_h_output_w                 ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr -        dumpIfSet_dyn dflags Opt_D_dump_foreign+        dumpIfSet_dyn logger dflags Opt_D_dump_foreign                       "Foreign export stubs" FormatC stub_c_output_d          stub_c_file_exists@@ -254,9 +293,9 @@ -- module;  -- | Generate code to initialise cost centres-profilingInitCode :: Module -> CollectedCCs -> SDoc-profilingInitCode this_mod (local_CCs, singleton_CCSs)- = vcat+profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub+profilingInitCode platform this_mod (local_CCs, singleton_CCSs)+ = CStub $ vcat     $  map emit_cc_decl local_CCs     ++ map emit_ccs_decl singleton_CCSs     ++ [emit_cc_list local_CCs]@@ -272,22 +311,53 @@  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++-- | Generate code to initialise info pointer origin+-- See note [Mapping Info Tables to Source Positions]+ipInitCode :: DynFlags -> Module -> [InfoProvEnt] -> CStub+ipInitCode dflags this_mod ents+ = if not (gopt Opt_InfoTableMap dflags)+    then mempty+    else CStub $ vcat+    $  map emit_ipe_decl ents+    ++ [emit_ipe_list ents]+    ++ [ text "static void ip_init_" <> ppr this_mod+            <> text "(void) __attribute__((constructor));"+       , text "static void ip_init_" <> ppr this_mod <> text "(void)"+       , braces (vcat+                 [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi+                 ])+       ]+ where+   platform = targetPlatform dflags+   emit_ipe_decl ipe =+       text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"+     where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)+   local_ipe_list_label = text "local_ipe_" <> ppr this_mod+   emit_ipe_list ipes =+      text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="+      <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma+                         | ipe <- ipes+                         ] ++ [text "NULL"])+      <> semi++

+ GHC/Driver/Config.hs view

@@ -0,0 +1,38 @@+-- | Subsystem configuration+module GHC.Driver.Config+   ( initOptCoercionOpts+   , initSimpleOpts+   , initParserOpts+   )+where++import GHC.Prelude++import GHC.Driver.Session+import GHC.Core.SimpleOpt+import GHC.Core.Coercion.Opt+import GHC.Parser.Lexer++-- | Initialise coercion optimiser configuration from DynFlags+initOptCoercionOpts :: DynFlags -> OptCoercionOpts+initOptCoercionOpts dflags = OptCoercionOpts+   { optCoercionEnabled = not (hasNoOptCoercion dflags)+   }++-- | Initialise Simple optimiser configuration from DynFlags+initSimpleOpts :: DynFlags -> SimpleOpts+initSimpleOpts dflags = SimpleOpts+   { so_uf_opts = unfoldingOpts dflags+   , so_co_opts = initOptCoercionOpts dflags+   }++-- | Extracts the flag information needed for parsing+initParserOpts :: DynFlags -> ParserOpts+initParserOpts =+  mkParserOpts+    <$> warningFlags+    <*> extensionFlags+    <*> safeImportsOn+    <*> gopt Opt_Haddock+    <*> gopt Opt_KeepRawTokenStream+    <*> const True

+ GHC/Driver/Env.hs view

@@ -0,0 +1,287 @@+{-# LANGUAGE CPP #-}++module GHC.Driver.Env+   ( Hsc(..)+   , HscEnv (..)+   , hsc_home_unit+   , hsc_units+   , runHsc+   , mkInteractiveHscEnv+   , runInteractiveHsc+   , hscEPS+   , hptCompleteSigs+   , hptInstances+   , hptAnns+   , hptAllThings+   , hptSomeThingsBelowUs+   , hptRules+   , prepareAnnotations+   , lookupType+   , lookupIfaceByModule+   , mainModIs+   )+where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Ppr+import GHC.Driver.Session+import GHC.Driver.Errors ( printOrThrowWarnings )++import GHC.Runtime.Context+import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo+import GHC.Unit.Env+import GHC.Unit.External++import GHC.Core         ( CoreRule )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( ClsInst )++import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )+import GHC.Types.CompleteMatch+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.TyThing++import GHC.Builtin.Names ( gHC_PRIM )++import GHC.Data.Maybe+import GHC.Data.Bag++import GHC.Utils.Outputable+import GHC.Utils.Monad+import GHC.Utils.Panic+import GHC.Utils.Misc++import Control.Monad    ( guard )+import Data.IORef++runHsc :: HscEnv -> Hsc a -> IO a+runHsc hsc_env (Hsc hsc) = do+    (a, w) <- hsc hsc_env emptyBag+    printOrThrowWarnings (hsc_logger hsc_env) (hsc_dflags hsc_env) w+    return a++-- | Switches in the DynFlags and Plugins from the InteractiveContext+mkInteractiveHscEnv :: HscEnv -> HscEnv+mkInteractiveHscEnv hsc_env =+    let ic = hsc_IC hsc_env+    in hsc_env { hsc_dflags  = ic_dflags  ic+               , hsc_plugins = ic_plugins ic+               }++-- | A variant of runHsc that switches in the DynFlags and Plugins from the+-- InteractiveContext before running the Hsc computation.+runInteractiveHsc :: HscEnv -> Hsc a -> IO a+runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)++hsc_home_unit :: HscEnv -> HomeUnit+hsc_home_unit = ue_home_unit . hsc_unit_env++hsc_units :: HscEnv -> UnitState+hsc_units = ue_units . hsc_unit_env++{-++Note [Target code interpreter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Template Haskell and GHCi use an interpreter to execute code that is built for+the compiler target platform (= code host platform) on the compiler host+platform (= code build platform).++The internal interpreter can be used when both platforms are the same and when+the built code is compatible with the compiler itself (same way, etc.). This+interpreter is not always available: for instance stage1 compiler doesn't have+it because there might be an ABI mismatch between the code objects (built by+stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).++In most cases, an external interpreter can be used instead: it runs in a+separate process and it communicates with the compiler via a two-way message+passing channel. The process is lazily spawned to avoid overhead when it is not+used.++The target code interpreter to use can be selected per session via the+`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in+which case Template Haskell and GHCi will fail to run. The interpreter to use is+configured via command-line flags (in `GHC.setSessionDynFlags`).+++-}++-- Note [hsc_type_env_var hack]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- hsc_type_env_var is used to initialize tcg_type_env_var, and+-- eventually it is the mutable variable that is queried from+-- if_rec_types to get a TypeEnv.  So, clearly, it's something+-- related to knot-tying (see Note [Tying the knot]).+-- hsc_type_env_var is used in two places: initTcRn (where+-- it initializes tcg_type_env_var) and initIfaceCheck+-- (where it initializes if_rec_types).+--+-- But why do we need a way to feed a mutable variable in?  Why+-- can't we just initialize tcg_type_env_var when we start+-- typechecking?  The problem is we need to knot-tie the+-- EPS, and we may start adding things to the EPS before type+-- checking starts.+--+-- Here is a concrete example. Suppose we are running+-- "ghc -c A.hs", and we have this file system state:+--+--  A.hs-boot   A.hi-boot **up to date**+--  B.hs        B.hi      **up to date**+--  A.hs        A.hi      **stale**+--+-- The first thing we do is run checkOldIface on A.hi.+-- checkOldIface will call loadInterface on B.hi so it can+-- get its hands on the fingerprints, to find out if A.hi+-- needs recompilation.  But loadInterface also populates+-- the EPS!  And so if compilation turns out to be necessary,+-- as it is in this case, the thunks we put into the EPS for+-- B.hi need to have the correct if_rec_types mutable variable+-- to query.+--+-- If the mutable variable is only allocated WHEN we start+-- typechecking, then that's too late: we can't get the+-- information to the thunks.  So we need to pre-commit+-- to a type variable in 'hscIncrementalCompile' BEFORE we+-- check the old interface.+--+-- This is all a massive hack because arguably checkOldIface+-- should not populate the EPS. But that's a refactor for+-- another day.++-- | Retrieve the ExternalPackageState cache.+hscEPS :: HscEnv -> IO ExternalPackageState+hscEPS hsc_env = readIORef (hsc_EPS hsc_env)++hptCompleteSigs :: HscEnv -> [CompleteMatch]+hptCompleteSigs = hptAllThings  (md_complete_matches . hm_details)++-- | Find all the instance declarations (of classes and families) from+-- the Home Package Table filtered by the provided predicate function.+-- Used in @tcRnImports@, to select the instances that are in the+-- transitive closure of imports from the currently compiled module.+hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])+hptInstances hsc_env want_this_module+  = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do+                guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))+                let details = hm_details mod_info+                return (md_insts details, md_fam_insts details)+    in (concat insts, concat famInsts)++-- | Get rules from modules "below" this one (in the dependency sense)+hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]+hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False+++-- | Get annotations from modules "below" this one (in the dependency sense)+hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]+hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps+hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env++hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]+hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))++-- | Get things from modules "below" this one (in the dependency sense)+-- C.f Inst.hptInstances+hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]+hptSomeThingsBelowUs extract include_hi_boot hsc_env deps+  | isOneShot (ghcMode (hsc_dflags hsc_env)) = []++  | otherwise+  = let hpt = hsc_HPT hsc_env+    in+    [ thing+    |   -- Find each non-hi-boot module below me+      GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps+    , include_hi_boot || (is_boot == NotBoot)++        -- unsavoury: when compiling the base package with --make, we+        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't+        -- be in the HPT, because we never compile it; it's in the EPT+        -- instead. ToDo: clean up, and remove this slightly bogus filter:+    , mod /= moduleName gHC_PRIM++        -- Look it up in the HPT+    , let things = case lookupHpt hpt mod of+                    Just info -> extract info+                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []+          msg = vcat [text "missing module" <+> ppr mod,+                      text "Probable cause: out-of-date interface files"]+                        -- This really shouldn't happen, but see #962++        -- And get its dfuns+    , thing <- things ]+++-- | Deal with gathering annotations in from all possible places+--   and combining them into a single 'AnnEnv'+prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv+prepareAnnotations hsc_env mb_guts = do+    eps <- hscEPS hsc_env+    let -- Extract annotations from the module being compiled if supplied one+        mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts+        -- Extract dependencies of the module if we are supplied one,+        -- otherwise load annotations from all home package table+        -- entries regardless of dependency ordering.+        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts+        other_pkg_anns = eps_ann_env eps+        ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,+                                                         Just home_pkg_anns,+                                                         Just other_pkg_anns]+    return ann_env++-- | Find the 'TyThing' for the given 'Name' by using all the resources+-- at our disposal: the compiled modules in the 'HomePackageTable' and the+-- compiled modules in other packages that live in 'PackageTypeEnv'. Note+-- that this does NOT look up the 'TyThing' in the module being compiled: you+-- have to do that yourself, if desired+lookupType :: HscEnv -> Name -> IO (Maybe TyThing)+lookupType hsc_env name = do+   eps <- liftIO $ readIORef (hsc_EPS hsc_env)+   let pte = eps_PTE eps+       hpt = hsc_HPT hsc_env++       mod = ASSERT2( isExternalName name, ppr name )+             if isHoleName name+               then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))+               else nameModule name++       !ty = if isOneShot (ghcMode (hsc_dflags hsc_env))+               -- in one-shot, we don't use the HPT+               then lookupNameEnv pte name+               else case lookupHptByModule hpt mod of+                Just hm -> lookupNameEnv (md_types (hm_details hm)) name+                Nothing -> lookupNameEnv pte name+   pure ty++-- | Find the 'ModIface' for a 'Module', searching in both the loaded home+-- and external package module information+lookupIfaceByModule+        :: HomePackageTable+        -> PackageIfaceTable+        -> Module+        -> Maybe ModIface+lookupIfaceByModule hpt pit mod+  = case lookupHptByModule hpt mod of+       Just hm -> Just (hm_iface hm)+       Nothing -> lookupModuleEnv pit mod+   -- If the module does come from the home package, why do we look in the PIT as well?+   -- (a) In OneShot mode, even home-package modules accumulate in the PIT+   -- (b) Even in Batch (--make) mode, there is *one* case where a home-package+   --     module is in the PIT, namely GHC.Prim when compiling the base package.+   -- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package+   -- of its own, but it doesn't seem worth the bother.++mainModIs :: HscEnv -> Module+mainModIs hsc_env = mkHomeModule (hsc_home_unit hsc_env) (mainModuleNameIs (hsc_dflags hsc_env))

+ GHC/Driver/Env/Types.hs view

@@ -0,0 +1,163 @@+{-# LANGUAGE DeriveFunctor #-}+module GHC.Driver.Env.Types+  ( Hsc(..)+  , HscEnv(..)+  ) where++import {-# SOURCE #-} GHC.Driver.Hooks+import GHC.Driver.Session ( DynFlags, HasDynFlags(..) )+import GHC.Prelude+import GHC.Runtime.Context+import GHC.Runtime.Interpreter.Types ( Interp )+import GHC.Types.Error ( WarningMessages )+import GHC.Types.Name.Cache+import GHC.Types.Target+import GHC.Types.TypeEnv+import GHC.Unit.External+import GHC.Unit.Finder.Types+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.Graph+import GHC.Unit.Env+import GHC.Unit.State+import GHC.Unit.Types+import GHC.Utils.Logger+import GHC.Utils.TmpFs+import {-# SOURCE #-} GHC.Driver.Plugins++import Control.Monad ( ap )+import Control.Monad.IO.Class+import Data.IORef++-- | The Hsc monad: Passing an environment and warning state+newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))+    deriving (Functor)++instance Applicative Hsc where+    pure a = Hsc $ \_ w -> return (a, w)+    (<*>) = ap++instance Monad Hsc where+    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w+                                   case k a of+                                       Hsc k' -> k' e w1++instance MonadIO Hsc where+    liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)++instance HasDynFlags Hsc where+    getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)++instance HasLogger Hsc where+    getLogger = Hsc $ \e w -> return (hsc_logger e, w)+++-- | HscEnv is like 'GHC.Driver.Monad.Session', except that some of the fields are immutable.+-- An HscEnv is used to compile a single module from plain Haskell source+-- code (after preprocessing) to either C, assembly or C--. It's also used+-- to store the dynamic linker state to allow for multiple linkers in the+-- same address space.+-- Things like the module graph don't change during a single compilation.+--+-- Historical note: \"hsc\" used to be the name of the compiler binary,+-- when there was a separate driver and compiler.  To compile a single+-- module, the driver would invoke hsc on the source code... so nowadays+-- we think of hsc as the layer of the compiler that deals with compiling+-- a single module.+data HscEnv+  = HscEnv {+        hsc_dflags :: DynFlags,+                -- ^ The dynamic flag settings++        hsc_targets :: [Target],+                -- ^ The targets (or roots) of the current session++        hsc_mod_graph :: ModuleGraph,+                -- ^ The module graph of the current session++        hsc_IC :: InteractiveContext,+                -- ^ The context for evaluating interactive statements++        hsc_HPT    :: HomePackageTable,+                -- ^ The home package table describes already-compiled+                -- home-package modules, /excluding/ the module we+                -- are compiling right now.+                -- (In one-shot mode the current module is the only+                -- home-package module, so hsc_HPT is empty.  All other+                -- modules count as \"external-package\" modules.+                -- However, even in GHCi mode, hi-boot interfaces are+                -- demand-loaded into the external-package table.)+                --+                -- 'hsc_HPT' is not mutable because we only demand-load+                -- external packages; the home package is eagerly+                -- loaded, module by module, by the compilation manager.+                --+                -- The HPT may contain modules compiled earlier by @--make@+                -- but not actually below the current module in the dependency+                -- graph.+                --+                -- (This changes a previous invariant: changed Jan 05.)++        hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),+                -- ^ Information about the currently loaded external packages.+                -- This is mutable because packages will be demand-loaded during+                -- a compilation run as required.++        hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),+                -- ^ As with 'hsc_EPS', this is side-effected by compiling to+                -- reflect sucking in interface files.  They cache the state of+                -- external interface files, in effect.++        hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),+                -- ^ The cached result of performing finding in the file system++        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)+                -- ^ Used for one-shot compilation only, to initialise+                -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for+                -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]++        , hsc_interp :: Maybe Interp+                -- ^ target code interpreter (if any) to use for TH and GHCi.+                -- See Note [Target code interpreter]++        , hsc_plugins :: ![LoadedPlugin]+                -- ^ plugins dynamically loaded after processing arguments. What+                -- will be loaded here is directed by DynFlags.pluginModNames.+                -- Arguments are loaded from DynFlags.pluginModNameOpts.+                --+                -- The purpose of this field is to cache the plugins so they+                -- don't have to be loaded each time they are needed.  See+                -- 'GHC.Runtime.Loader.initializePlugins'.++        , hsc_static_plugins :: ![StaticPlugin]+                -- ^ static plugins which do not need dynamic loading. These plugins are+                -- intended to be added by GHC API users directly to this list.+                --+                -- To add dynamically loaded plugins through the GHC API see+                -- 'addPluginModuleName' instead.++        , hsc_unit_dbs :: !(Maybe [UnitDatabase UnitId])+                -- ^ Stack of unit databases for the target platform.+                --+                -- This field is populated with the result of `initUnits`.+                --+                -- 'Nothing' means the databases have never been read from disk.+                --+                -- Usually we don't reload the databases from disk if they are+                -- cached, even if the database flags changed!++        , hsc_unit_env :: UnitEnv+                -- ^ Unit environment (unit state, home unit, etc.).+                --+                -- Initialized from the databases cached in 'hsc_unit_dbs' and+                -- from the DynFlags.++        , hsc_logger :: !Logger+                -- ^ Logger++        , hsc_hooks :: !Hooks+                -- ^ Hooks++        , hsc_tmpfs :: !TmpFs+                -- ^ Temporary files+ }+

+ GHC/Driver/Errors.hs view

@@ -0,0 +1,93 @@+module GHC.Driver.Errors (+    warningsToMessages+  , printOrThrowWarnings+  , printBagOfErrors+  , isWarnMsgFatal+  , handleFlagWarnings+  ) where++import GHC.Driver.Session+import GHC.Data.Bag+import GHC.Utils.Exception+import GHC.Utils.Error ( formatBulleted, sortMsgBag )+import GHC.Types.SourceError ( mkSrcErr )+import GHC.Prelude+import GHC.Types.SrcLoc+import GHC.Types.Error+import GHC.Utils.Outputable ( text, withPprStyle, mkErrStyle )+import GHC.Utils.Logger+import qualified GHC.Driver.CmdLine as CmdLine++-- | Converts a list of 'WarningMessages' into a tuple where the second element contains only+-- error, i.e. warnings that are considered fatal by GHC based on the input 'DynFlags'.+warningsToMessages :: DynFlags -> WarningMessages -> (WarningMessages, ErrorMessages)+warningsToMessages dflags =+  partitionBagWith $ \warn ->+    case isWarnMsgFatal dflags warn of+      Nothing -> Left warn+      Just err_reason ->+        Right warn{ errMsgSeverity = SevError+                  , errMsgReason = ErrReason err_reason }++printBagOfErrors :: RenderableDiagnostic a => Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()+printBagOfErrors logger dflags bag_of_errors+  = sequence_ [ let style = mkErrStyle unqual+                    ctx   = initSDocContext dflags style+                in putLogMsg logger dflags reason sev s $+                   withPprStyle style (formatBulleted ctx (renderDiagnostic doc))+              | MsgEnvelope { errMsgSpan      = s,+                              errMsgDiagnostic = doc,+                              errMsgSeverity  = sev,+                              errMsgReason    = reason,+                              errMsgContext   = unqual } <- sortMsgBag (Just dflags)+                                                                       bag_of_errors ]++handleFlagWarnings :: Logger -> DynFlags -> [CmdLine.Warn] -> IO ()+handleFlagWarnings logger dflags warns = do+  let warns' = filter (shouldPrintWarning dflags . CmdLine.warnReason)  warns++      -- It would be nicer if warns :: [Located SDoc], but that+      -- has circular import problems.+      bag = listToBag [ mkPlainWarnMsg loc (text warn)+                      | CmdLine.Warn _ (L loc warn) <- warns' ]++  printOrThrowWarnings logger dflags bag++-- | Checks if given 'WarnMsg' is a fatal warning.+isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)+isWarnMsgFatal dflags MsgEnvelope{errMsgReason = Reason wflag}+  = if wopt_fatal wflag dflags+      then Just (Just wflag)+      else Nothing+isWarnMsgFatal dflags _+  = if gopt Opt_WarnIsError dflags+      then Just Nothing+      else Nothing++-- Given a warn reason, check to see if it's associated -W opt is enabled+shouldPrintWarning :: DynFlags -> CmdLine.WarnReason -> Bool+shouldPrintWarning dflags CmdLine.ReasonDeprecatedFlag+  = wopt Opt_WarnDeprecatedFlags dflags+shouldPrintWarning dflags CmdLine.ReasonUnrecognisedFlag+  = wopt Opt_WarnUnrecognisedWarningFlags dflags+shouldPrintWarning _ _+  = True++-- | Given a bag of warnings, turn them into an exception if+-- -Werror is enabled, or print them out otherwise.+printOrThrowWarnings :: Logger -> DynFlags -> Bag WarnMsg -> IO ()+printOrThrowWarnings logger dflags warns = do+  let (make_error, warns') =+        mapAccumBagL+          (\make_err warn ->+            case isWarnMsgFatal dflags warn of+              Nothing ->+                (make_err, warn)+              Just err_reason ->+                (True, warn{ errMsgSeverity = SevError+                           , errMsgReason = ErrReason err_reason+                           }))+          False warns+  if make_error+    then throwIO (mkSrcErr warns')+    else printBagOfErrors logger dflags warns

− GHC/Driver/Finder.hs

@@ -1,851 +0,0 @@-{--(c) The University of Glasgow, 2000-2006--\section[Finder]{Module Finder}--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}--module GHC.Driver.Finder (-    flushFinderCaches,-    FindResult(..),-    findImportedModule,-    findPluginModule,-    findExactModule,-    findHomeModule,-    findExposedPackageModule,-    mkHomeModLocation,-    mkHomeModLocation2,-    mkHiOnlyModLocation,-    mkHiPath,-    mkObjPath,-    addHomeModuleToFinder,-    uncacheModule,-    mkStubPaths,--    findObjectLinkableMaybe,-    findObjectLinkable,--    cannotFindModule,-    cannotFindInterface,--  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Unit-import GHC.Driver.Types-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Builtin.Names ( gHC_PRIM )-import GHC.Driver.Session-import GHC.Driver.Ways-import GHC.Utils.Outputable as Outputable-import GHC.Data.Maybe    ( expectJust )--import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )-import System.Directory-import System.FilePath-import Control.Monad-import Data.Time---type FileExt = String   -- Filename extension-type BaseName = String  -- Basename of file---- -------------------------------------------------------------------------------- The Finder---- The Finder provides a thin filesystem abstraction to the rest of--- the compiler.  For a given module, it can tell you where the--- source, interface, and object files for that module live.---- It does *not* know which particular package a module lives in.  Use--- Packages.lookupModuleInAllUnits for that.---- -------------------------------------------------------------------------------- The finder's cache---- remove all the home modules from the cache; package modules are--- assumed to not move around during a session.-flushFinderCaches :: HscEnv -> IO ()-flushFinderCaches hsc_env =-  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())- where-        this_pkg = homeUnit (hsc_dflags hsc_env)-        fc_ref = hsc_FC hsc_env-        is_ext mod _ | not (moduleUnit mod `unitIdEq` this_pkg) = True-                     | otherwise = False--addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()-addToFinderCache ref key val =-  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())--removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()-removeFromFinderCache ref key =-  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())--lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)-lookupFinderCache ref key = do-   c <- readIORef ref-   return $! lookupInstalledModuleEnv c key---- -------------------------------------------------------------------------------- The three external entry points---- | Locate a module that was imported by the user.  We have the--- module's name, and possibly a package name.  Without a package--- name, this function will use the search path and the known exposed--- packages to find the module, if a package is specified then only--- that package is searched for the module.--findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult-findImportedModule hsc_env mod_name mb_pkg =-  case mb_pkg of-        Nothing                        -> unqual_import-        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special-                 | otherwise           -> pkg_import-  where-    home_import   = findHomeModule hsc_env mod_name--    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg--    unqual_import = home_import-                    `orIfNotFound`-                    findExposedPackageModule hsc_env mod_name Nothing---- | Locate a plugin module requested by the user, for a compiler--- plugin.  This consults the same set of exposed packages as--- 'findImportedModule', unless @-hide-all-plugin-packages@ or--- @-plugin-package@ are specified.-findPluginModule :: HscEnv -> ModuleName -> IO FindResult-findPluginModule hsc_env mod_name =-  findHomeModule hsc_env mod_name-  `orIfNotFound`-  findExposedPluginPackageModule hsc_env mod_name---- | Locate a specific 'Module'.  The purpose of this function is to--- create a 'ModLocation' for a given 'Module', that is to find out--- where the files associated with this module live.  It is used when--- reading the interface for a module mentioned by another interface,--- for example (a "system import").--findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findExactModule hsc_env mod =-    let dflags = hsc_dflags hsc_env-    in if moduleUnit mod `unitIdEq` homeUnit dflags-       then findInstalledHomeModule hsc_env (moduleName mod)-       else findPackageModule hsc_env mod---- -------------------------------------------------------------------------------- Helpers---- | Given a monadic actions @this@ and @or_this@, first execute--- @this@.  If the returned 'FindResult' is successful, return--- it; otherwise, execute @or_this@.  If both failed, this function--- also combines their failure messages in a reasonable way.-orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult-orIfNotFound this or_this = do-  res <- this-  case res of-    NotFound { fr_paths = paths1, fr_mods_hidden = mh1-             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }-     -> do res2 <- or_this-           case res2 of-             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2-                      , fr_pkgs_hidden = ph2, fr_unusables = u2-                      , fr_suggestions = s2 }-              -> return (NotFound { fr_paths = paths1 ++ paths2-                                  , fr_pkg = mb_pkg2 -- snd arg is the package search-                                  , fr_mods_hidden = mh1 ++ mh2-                                  , fr_pkgs_hidden = ph1 ++ ph2-                                  , fr_unusables = u1 ++ u2-                                  , fr_suggestions = s1  ++ s2 })-             _other -> return res2-    _other -> return res---- | Helper function for 'findHomeModule': this function wraps an IO action--- which would look up @mod_name@ in the file system (the home package),--- and first consults the 'hsc_FC' cache to see if the lookup has already--- been done.  Otherwise, do the lookup (with the IO action) and save--- the result in the finder cache and the module location cache (if it--- was successful.)-homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult-homeSearchCache hsc_env mod_name do_this = do-  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name-  modLocationCache hsc_env mod do_this--findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString-                         -> IO FindResult-findExposedPackageModule hsc_env mod_name mb_pkg-  = findLookupResult hsc_env-  $ lookupModuleWithSuggestions-        (unitState (hsc_dflags hsc_env)) mod_name mb_pkg--findExposedPluginPackageModule :: HscEnv -> ModuleName-                               -> IO FindResult-findExposedPluginPackageModule hsc_env mod_name-  = findLookupResult hsc_env-  $ lookupPluginModuleWithSuggestions-        (unitState (hsc_dflags hsc_env)) mod_name Nothing--findLookupResult :: HscEnv -> LookupResult -> IO FindResult-findLookupResult hsc_env r = case r of-     LookupFound m pkg_conf -> do-       let im = fst (getModuleInstantiation m)-       r' <- findPackageModule_ hsc_env im (fst pkg_conf)-       case r' of-        -- TODO: ghc -M is unlikely to do the right thing-        -- with just the location of the thing that was-        -- instantiated; you probably also need all of the-        -- implicit locations from the instances-        InstalledFound loc   _ -> return (Found loc m)-        InstalledNoPackage   _ -> return (NoPackage (moduleUnit m))-        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)-                                         , fr_pkgs_hidden = []-                                         , fr_mods_hidden = []-                                         , fr_unusables = []-                                         , fr_suggestions = []})-     LookupMultiple rs ->-       return (FoundMultiple rs)-     LookupHidden pkg_hiddens mod_hiddens ->-       return (NotFound{ fr_paths = [], fr_pkg = Nothing-                       , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens-                       , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens-                       , fr_unusables = []-                       , fr_suggestions = [] })-     LookupUnusable unusable ->-       let unusables' = map get_unusable unusable-           get_unusable (m, ModUnusable r) = (moduleUnit m, r)-           get_unusable (_, r)             =-             pprPanic "findLookupResult: unexpected origin" (ppr r)-       in return (NotFound{ fr_paths = [], fr_pkg = Nothing-                          , fr_pkgs_hidden = []-                          , fr_mods_hidden = []-                          , fr_unusables = unusables'-                          , fr_suggestions = [] })-     LookupNotFound suggest -> do-       let suggest'-             | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest-             | otherwise = []-       return (NotFound{ fr_paths = [], fr_pkg = Nothing-                       , fr_pkgs_hidden = []-                       , fr_mods_hidden = []-                       , fr_unusables = []-                       , fr_suggestions = suggest' })--modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult-modLocationCache hsc_env mod do_this = do-  m <- lookupFinderCache (hsc_FC hsc_env) mod-  case m of-    Just result -> return result-    Nothing     -> do-        result <- do_this-        addToFinderCache (hsc_FC hsc_env) mod result-        return result--mkHomeInstalledModule :: DynFlags -> ModuleName -> InstalledModule-mkHomeInstalledModule dflags mod_name =-  let iuid = homeUnitId dflags-  in Module iuid mod_name---- This returns a module because it's more convenient for users-addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module-addHomeModuleToFinder hsc_env mod_name loc = do-  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name-  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)-  return (mkHomeModule (hsc_dflags hsc_env) mod_name)--uncacheModule :: HscEnv -> ModuleName -> IO ()-uncacheModule hsc_env mod_name = do-  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name-  removeFromFinderCache (hsc_FC hsc_env) mod---- --------------------------------------------------------------------------------      The internal workers--findHomeModule :: HscEnv -> ModuleName -> IO FindResult-findHomeModule hsc_env mod_name = do-  r <- findInstalledHomeModule hsc_env mod_name-  return $ case r of-    InstalledFound loc _ -> Found loc (mkModule uid mod_name)-    InstalledNoPackage _ -> NoPackage uid -- impossible-    InstalledNotFound fps _ -> NotFound {-        fr_paths = fps,-        fr_pkg = Just uid,-        fr_mods_hidden = [],-        fr_pkgs_hidden = [],-        fr_unusables = [],-        fr_suggestions = []-      }- where-  dflags = hsc_dflags hsc_env-  uid    = homeUnit dflags---- | Implements the search for a module name in the home package only.  Calling--- this function directly is usually *not* what you want; currently, it's used--- as a building block for the following operations:------  1. When you do a normal package lookup, we first check if the module---  is available in the home module, before looking it up in the package---  database.------  2. When you have a package qualified import with package name "this",---  we shortcut to the home module.------  3. When we look up an exact 'Module', if the unit id associated with---  the module is the current home module do a look up in the home module.------  4. Some special-case code in GHCi (ToDo: Figure out why that needs to---  call this.)-findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult-findInstalledHomeModule hsc_env mod_name =-   homeSearchCache hsc_env mod_name $-   let-     dflags = hsc_dflags hsc_env-     home_path = importPaths dflags-     hisuf = hiSuf dflags-     mod = mkHomeInstalledModule dflags mod_name--     source_exts =-      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")-      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")-      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")-      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")-      ]--     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that-     -- when hiDir field is set in dflags, we know to look there (see #16500)-     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)-               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)-               ]--        -- In compilation manager modes, we look for source files in the home-        -- package because we can compile these automatically.  In one-shot-        -- compilation mode we look for .hi and .hi-boot files only.-     exts | isOneShot (ghcMode dflags) = hi_exts-          | otherwise                  = source_exts-   in--  -- special case for GHC.Prim; we won't find it in the filesystem.-  -- This is important only when compiling the base package (where GHC.Prim-  -- is a home module).-  if mod `installedModuleEq` gHC_PRIM-        then return (InstalledFound (error "GHC.Prim ModLocation") mod)-        else searchPathExts home_path mod exts----- | Search for a module in external packages only.-findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult-findPackageModule hsc_env mod = do-  let-        dflags = hsc_dflags hsc_env-        pkg_id = moduleUnit mod-        pkgstate = unitState dflags-  ---  case lookupUnitId pkgstate pkg_id of-     Nothing -> return (InstalledNoPackage pkg_id)-     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf---- | Look up the interface file associated with module @mod@.  This function--- requires a few invariants to be upheld: (1) the 'Module' in question must--- be the module identifier of the *original* implementation of a module,--- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2)--- the 'UnitInfo' must be consistent with the unit id in the 'Module'.--- The redundancy is to avoid an extra lookup in the package state--- for the appropriate config.-findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult-findPackageModule_ hsc_env mod pkg_conf =-  ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )-  modLocationCache hsc_env mod $--  -- special case for GHC.Prim; we won't find it in the filesystem.-  if mod `installedModuleEq` gHC_PRIM-        then return (InstalledFound (error "GHC.Prim ModLocation") mod)-        else--  let-     dflags = hsc_dflags hsc_env-     tag = waysBuildTag (ways dflags)--           -- hi-suffix for packages depends on the build tag.-     package_hisuf | null tag  = "hi"-                   | otherwise = tag ++ "_hi"--     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf--     import_dirs = unitImportDirs pkg_conf-      -- we never look for a .hi-boot file in an external package;-      -- .hi-boot files only make sense for the home package.-  in-  case import_dirs of-    [one] | MkDepend <- ghcMode dflags -> do-          -- there's only one place that this .hi file can be, so-          -- don't bother looking for it.-          let basename = moduleNameSlashes (moduleName mod)-          loc <- mk_hi_loc one basename-          return (InstalledFound loc mod)-    _otherwise ->-          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]---- -------------------------------------------------------------------------------- General path searching--searchPathExts-  :: [FilePath]         -- paths to search-  -> InstalledModule             -- module name-  -> [ (-        FileExt,                                -- suffix-        FilePath -> BaseName -> IO ModLocation  -- action-       )-     ]-  -> IO InstalledFindResult--searchPathExts paths mod exts-   = do result <- search to_search-{--        hPutStrLn stderr (showSDoc $-                vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)-                    , nest 2 (vcat (map text paths))-                    , case result of-                        Succeeded (loc, p) -> text "Found" <+> ppr loc-                        Failed fs          -> text "not found"])--}-        return result--  where-    basename = moduleNameSlashes (moduleName mod)--    to_search :: [(FilePath, IO ModLocation)]-    to_search = [ (file, fn path basename)-                | path <- paths,-                  (ext,fn) <- exts,-                  let base | path == "." = basename-                           | otherwise   = path </> basename-                      file = base <.> ext-                ]--    search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))--    search ((file, mk_result) : rest) = do-      b <- doesFileExist file-      if b-        then do { loc <- mk_result; return (InstalledFound loc mod) }-        else search rest--mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt-                          -> FilePath -> BaseName -> IO ModLocation-mkHomeModLocationSearched dflags mod suff path basename = do-   mkHomeModLocation2 dflags mod (path </> basename) suff---- -------------------------------------------------------------------------------- Constructing a home module location---- This is where we construct the ModLocation for a module in the home--- package, for which we have a source file.  It is called from three--- places:------  (a) Here in the finder, when we are searching for a module to import,---      using the search path (-i option).------  (b) The compilation manager, when constructing the ModLocation for---      a "root" module (a source file named explicitly on the command line---      or in a :load command in GHCi).------  (c) The driver in one-shot mode, when we need to construct a---      ModLocation for a source file named on the command-line.------ Parameters are:------ mod---      The name of the module------ path---      (a): The search path component where the source file was found.---      (b) and (c): "."------ src_basename---      (a): (moduleNameSlashes mod)---      (b) and (c): The filename of the source file, minus its extension------ ext---      The filename extension of the source file (usually "hs" or "lhs").--mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation-mkHomeModLocation dflags mod src_filename = do-   let (basename,extension) = splitExtension src_filename-   mkHomeModLocation2 dflags mod basename extension--mkHomeModLocation2 :: DynFlags-                   -> ModuleName-                   -> FilePath  -- Of source module, without suffix-                   -> String    -- Suffix-                   -> IO ModLocation-mkHomeModLocation2 dflags mod src_basename ext = do-   let mod_basename = moduleNameSlashes mod--       obj_fn = mkObjPath  dflags src_basename mod_basename-       hi_fn  = mkHiPath   dflags src_basename mod_basename-       hie_fn = mkHiePath  dflags src_basename mod_basename--   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),-                        ml_hi_file   = hi_fn,-                        ml_obj_file  = obj_fn,-                        ml_hie_file  = hie_fn })--mkHomeModHiOnlyLocation :: DynFlags-                        -> ModuleName-                        -> FilePath-                        -> BaseName-                        -> IO ModLocation-mkHomeModHiOnlyLocation dflags mod path basename = do-   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""-   return loc { ml_hs_file = Nothing }--mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String-                    -> IO ModLocation-mkHiOnlyModLocation dflags hisuf path basename- = do let full_basename = path </> basename-          obj_fn = mkObjPath  dflags full_basename basename-          hie_fn = mkHiePath  dflags full_basename basename-      return ModLocation{    ml_hs_file   = Nothing,-                             ml_hi_file   = full_basename <.> hisuf,-                                -- Remove the .hi-boot suffix from-                                -- hi_file, if it had one.  We always-                                -- want the name of the real .hi file-                                -- in the ml_hi_file field.-                             ml_obj_file  = obj_fn,-                             ml_hie_file  = hie_fn-                  }---- | Constructs the filename of a .o file for a given source file.--- Does /not/ check whether the .o file exists-mkObjPath-  :: DynFlags-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath-mkObjPath dflags basename mod_basename = obj_basename <.> osuf-  where-                odir = objectDir dflags-                osuf = objectSuf dflags--                obj_basename | Just dir <- odir = dir </> mod_basename-                             | otherwise        = basename----- | Constructs the filename of a .hi file for a given source file.--- Does /not/ check whether the .hi file exists-mkHiPath-  :: DynFlags-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath-mkHiPath dflags basename mod_basename = hi_basename <.> hisuf- where-                hidir = hiDir dflags-                hisuf = hiSuf dflags--                hi_basename | Just dir <- hidir = dir </> mod_basename-                            | otherwise         = basename---- | Constructs the filename of a .hie file for a given source file.--- Does /not/ check whether the .hie file exists-mkHiePath-  :: DynFlags-  -> FilePath           -- the filename of the source file, minus the extension-  -> String             -- the module name with dots replaced by slashes-  -> FilePath-mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf- where-                hiedir = hieDir dflags-                hiesuf = hieSuf dflags--                hie_basename | Just dir <- hiedir = dir </> mod_basename-                             | otherwise          = basename------ -------------------------------------------------------------------------------- Filenames of the stub files---- We don't have to store these in ModLocations, because they can be derived--- from other available information, and they're only rarely needed.--mkStubPaths-  :: DynFlags-  -> ModuleName-  -> ModLocation-  -> FilePath--mkStubPaths dflags mod location-  = let-        stubdir = stubDir dflags--        mod_basename = moduleNameSlashes mod-        src_basename = dropExtension $ expectJust "mkStubPaths"-                                                  (ml_hs_file location)--        stub_basename0-            | Just dir <- stubdir = dir </> mod_basename-            | otherwise           = src_basename--        stub_basename = stub_basename0 ++ "_stub"-     in-        stub_basename <.> "h"---- -------------------------------------------------------------------------------- findLinkable isn't related to the other stuff in here,--- but there's no other obvious place for it--findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)-findObjectLinkableMaybe mod locn-   = do let obj_fn = ml_obj_file locn-        maybe_obj_time <- modificationTimeIfExists obj_fn-        case maybe_obj_time of-          Nothing -> return Nothing-          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)---- Make an object linkable when we know the object file exists, and we know--- its modification time.-findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable-findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])-  -- We used to look for _stub.o files here, but that was a bug (#706)-  -- Now GHC merges the stub.o into the main .o (#3687)---- -------------------------------------------------------------------------------- Error messages--cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc-cannotFindModule flags mod res =-  cantFindErr (sLit cannotFindMsg)-              (sLit "Ambiguous module name")-              flags mod res-  where-    cannotFindMsg =-      case res of-        NotFound { fr_mods_hidden = hidden_mods-                 , fr_pkgs_hidden = hidden_pkgs-                 , fr_unusables = unusables }-          | not (null hidden_mods && null hidden_pkgs && null unusables)-          -> "Could not load module"-        _ -> "Could not find module"--cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc-cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")-                                           (sLit "Ambiguous interface for")--cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult-            -> SDoc-cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)-  | Just pkgs <- unambiguousPackages-  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (-       sep [text "it was found in multiple packages:",-                hsep (map ppr pkgs) ]-    )-  | otherwise-  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (-       vcat (map pprMod mods)-    )-  where-    unambiguousPackages = foldl' unambiguousPackage (Just []) mods-    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)-        = Just (moduleUnit m : xs)-    unambiguousPackage _ _ = Nothing--    pprMod (m, o) = text "it is bound as" <+> ppr m <+>-                                text "by" <+> pprOrigin m o-    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"-    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"-    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (-      if e == Just True-          then [text "package" <+> ppr (moduleUnit m)]-          else [] ++-      map ((text "a reexport in package" <+>)-                .ppr.mkUnit) res ++-      if f then [text "a package flag"] else []-      )--cantFindErr cannot_find _ dflags mod_name find_result-  = ptext cannot_find <+> quotes (ppr mod_name)-    $$ more_info-  where-    pkgs = unitState dflags-    more_info-      = case find_result of-            NoPackage pkg-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>-                   text "was found"--            NotFound { fr_paths = files, fr_pkg = mb_pkg-                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens-                     , fr_unusables = unusables, fr_suggestions = suggest }-                | Just pkg <- mb_pkg, pkg /= homeUnit dflags-                -> not_found_in_package pkg files--                | not (null suggest)-                -> pp_suggestions suggest $$ tried_these files dflags--                | null files && null mod_hiddens &&-                  null pkg_hiddens && null unusables-                -> text "It is not a module in the current program, or in any known package."--                | otherwise-                -> vcat (map pkg_hidden pkg_hiddens) $$-                   vcat (map mod_hidden mod_hiddens) $$-                   vcat (map unusable unusables) $$-                   tried_these files dflags--            _ -> panic "cantFindErr"--    build_tag = waysBuildTag (ways dflags)--    not_found_in_package pkg files-       | build_tag /= ""-       = let-            build = if build_tag == "p" then "profiling"-                                        else "\"" ++ build_tag ++ "\""-         in-         text "Perhaps you haven't installed the " <> text build <>-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$-         tried_these files dflags--       | otherwise-       = text "There are files missing in the " <> quotes (ppr pkg) <>-         text " package," $$-         text "try running 'ghc-pkg check'." $$-         tried_these files dflags--    pkg_hidden :: Unit -> SDoc-    pkg_hidden uid =-        text "It is a member of the hidden package"-        <+> quotes (ppr uid)-        --FIXME: we don't really want to show the unit id here we should-        -- show the source package id or installed package id if it's ambiguous-        <> dot $$ pkg_hidden_hint uid-    pkg_hidden_hint uid-     | gopt Opt_BuildingCabalPackage dflags-        = let pkg = expectJust "pkg_hidden" (lookupUnit pkgs uid)-           in text "Perhaps you need to add" <+>-              quotes (ppr (unitPackageName pkg)) <+>-              text "to the build-depends in your .cabal file."-     | Just pkg <- lookupUnit pkgs uid-         = text "You can run" <+>-           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>-           text "to expose it." $$-           text "(Note: this unloads all the modules in the current scope.)"-     | otherwise = Outputable.empty--    mod_hidden pkg =-        text "it is a hidden module in the package" <+> quotes (ppr pkg)--    unusable (pkg, reason)-      = text "It is a member of the package"-      <+> quotes (ppr pkg)-      $$ pprReason (text "which is") reason--    pp_suggestions :: [ModuleSuggestion] -> SDoc-    pp_suggestions sugs-      | null sugs = Outputable.empty-      | otherwise = hang (text "Perhaps you meant")-                       2 (vcat (map pp_sugg sugs))--    -- NB: Prefer the *original* location, and then reexports, and then-    -- package flags when making suggestions.  ToDo: if the original package-    -- also has a reexport, prefer that one-    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o-      where provenance ModHidden = Outputable.empty-            provenance (ModUnusable _) = Outputable.empty-            provenance (ModOrigin{ fromOrigUnit = e,-                                   fromExposedReexport = res,-                                   fromPackageFlag = f })-              | Just True <- e-                 = parens (text "from" <+> ppr (moduleUnit mod))-              | f && moduleName mod == m-                 = parens (text "from" <+> ppr (moduleUnit mod))-              | (pkg:_) <- res-                 = parens (text "from" <+> ppr (mkUnit pkg)-                    <> comma <+> text "reexporting" <+> ppr mod)-              | f-                 = parens (text "defined via package flags to be"-                    <+> ppr mod)-              | otherwise = Outputable.empty-    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o-      where provenance ModHidden =  Outputable.empty-            provenance (ModUnusable _) = Outputable.empty-            provenance (ModOrigin{ fromOrigUnit = e,-                                   fromHiddenReexport = rhs })-              | Just False <- e-                 = parens (text "needs flag -package-id"-                    <+> ppr (moduleUnit mod))-              | (pkg:_) <- rhs-                 = parens (text "needs flag -package-id"-                    <+> ppr (mkUnit pkg))-              | otherwise = Outputable.empty--cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName-                     -> InstalledFindResult -> SDoc-cantFindInstalledErr cannot_find _ dflags mod_name find_result-  = ptext cannot_find <+> quotes (ppr mod_name)-    $$ more_info-  where-    more_info-      = case find_result of-            InstalledNoPackage pkg-                -> text "no unit id matching" <+> quotes (ppr pkg) <+>-                   text "was found" $$ looks_like_srcpkgid pkg--            InstalledNotFound files mb_pkg-                | Just pkg <- mb_pkg, not (pkg `unitIdEq` homeUnit dflags)-                -> not_found_in_package pkg files--                | null files-                -> text "It is not a module in the current program, or in any known package."--                | otherwise-                -> tried_these files dflags--            _ -> panic "cantFindInstalledErr"--    build_tag = waysBuildTag (ways dflags)-    pkgstate = unitState dflags--    looks_like_srcpkgid :: UnitId -> SDoc-    looks_like_srcpkgid pk-     -- Unsafely coerce a unit id (i.e. an installed package component-     -- identifier) into a PackageId and see if it means anything.-     | (pkg:pkgs) <- searchPackageId pkgstate (PackageId (unitIdFS pk))-     = parens (text "This unit ID looks like the source package ID;" $$-       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$-       (if null pkgs then Outputable.empty-        else text "and" <+> int (length pkgs) <+> text "other candidates"))-     -- Todo: also check if it looks like a package name!-     | otherwise = Outputable.empty--    not_found_in_package pkg files-       | build_tag /= ""-       = let-            build = if build_tag == "p" then "profiling"-                                        else "\"" ++ build_tag ++ "\""-         in-         text "Perhaps you haven't installed the " <> text build <>-         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$-         tried_these files dflags--       | otherwise-       = text "There are files missing in the " <> quotes (ppr pkg) <>-         text " package," $$-         text "try running 'ghc-pkg check'." $$-         tried_these files dflags--tried_these :: [FilePath] -> DynFlags -> SDoc-tried_these files dflags-    | null files = Outputable.empty-    | verbosity dflags < 3 =-          text "Use -v (or `:set -v` in ghci) " <>-              text "to see a list of the files searched for."-    | otherwise =-          hang (text "Locations searched:") 2 $ vcat (map text files)

GHC/Driver/Flags.hs view

@@ -49,6 +49,7 @@    | Opt_D_dump_asm_conflicts    | Opt_D_dump_asm_stats    | Opt_D_dump_asm_expanded+   | Opt_D_dump_c_backend    | Opt_D_dump_llvm    | Opt_D_dump_core_stats    | Opt_D_dump_deriv@@ -56,7 +57,6 @@    | Opt_D_dump_ds_preopt    | Opt_D_dump_foreign    | Opt_D_dump_inlinings-   | Opt_D_dump_verbose_inlinings    | Opt_D_dump_rule_firings    | Opt_D_dump_rule_rewrites    | Opt_D_dump_simpl_trace@@ -69,9 +69,9 @@    | Opt_D_dump_simpl_iterations    | Opt_D_dump_spec    | Opt_D_dump_prep-   | Opt_D_dump_stg -- CoreToStg output-   | Opt_D_dump_stg_unarised -- STG after unarise-   | Opt_D_dump_stg_final -- STG after stg2stg+   | Opt_D_dump_stg_from_core -- ^ Initial STG (CoreToStg output)+   | Opt_D_dump_stg_unarised  -- ^ STG after unarise+   | Opt_D_dump_stg_final     -- ^ Final STG (after stg2stg)    | Opt_D_dump_call_arity    | Opt_D_dump_exitify    | Opt_D_dump_stranal@@ -112,6 +112,7 @@    | Opt_D_dump_json    | Opt_D_ppr_debug    | Opt_D_no_debug_output+   | Opt_D_dump_faststrings    deriving (Eq, Show, Enum)  -- | Enumerates the simple on-or-off dynamic flags@@ -131,6 +132,9 @@    | Opt_FastLlvm                       -- hidden flag    | Opt_NoTypeableBinds +   | Opt_DistinctConstructorTables+   | Opt_InfoTableMap+    | Opt_WarnIsError                    -- -Werror; makes warnings fatal    | Opt_ShowWarnGroups                 -- Show the group a warning belongs to    | Opt_HideSourcePaths                -- Hide module source/object paths@@ -159,6 +163,8 @@    | Opt_Specialise    | Opt_SpecialiseAggressively    | Opt_CrossModuleSpecialise+   | Opt_InlineGenerics+   | Opt_InlineGenericsAggressively    | Opt_StaticArgumentTransformation    | Opt_CSE    | Opt_StgCSE@@ -189,7 +195,8 @@    | Opt_OmitYields    | Opt_FunToThunk               -- allow GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs to remove all value lambdas    | Opt_DictsStrict                     -- be strict in argument dictionaries-   | Opt_DmdTxDictSel              -- use a special demand transformer for dictionary selectors+   | Opt_DmdTxDictSel              -- ^ deprecated, no effect and behaviour is now default.+                                   -- Allowed switching of a special demand transformer for dictionary selectors    | Opt_Loopification                  -- See Note [Self-recursive tail calls]    | Opt_CfgBlocklayout             -- ^ Use the cfg based block layout algorithm.    | Opt_WeightlessBlocklayout         -- ^ Layout based on last instruction per block.@@ -260,7 +267,7 @@    | Opt_RPath    | Opt_RelativeDynlibPaths    | Opt_Hpc-   | Opt_FlatCache+   | Opt_FamAppCache    | Opt_ExternalInterpreter    | Opt_OptimalApplicativeDo    | Opt_VersionMacros@@ -272,9 +279,10 @@    -- forwards all -L flags to the collect2 command without using a    -- response file and as such breaking apart.    | Opt_SingleLibFolder+   | Opt_ExposeInternalSymbols    | Opt_KeepCAFs    | Opt_KeepGoing-   | Opt_ByteCodeIfUnboxed+   | Opt_ByteCode    | Opt_LinkRts     -- output style opts@@ -442,6 +450,7 @@    | Opt_WarnUnusedTypePatterns    | Opt_WarnUnusedForalls    | Opt_WarnUnusedRecordWildcards+   | Opt_WarnRedundantBangPatterns    | Opt_WarnRedundantRecordWildcards    | Opt_WarnWarningsDeprecations    | Opt_WarnDeprecatedFlags@@ -498,8 +507,12 @@    | Opt_WarnCompatUnqualifiedImports     -- Since 8.10    | Opt_WarnDerivingDefaults    | Opt_WarnInvalidHaddock               -- Since 8.12-   | Opt_WarnUnicodeBidirectionalFormatCharacters -- Since 9.0.2-   deriving (Eq, Show, Enum)+   | Opt_WarnOperatorWhitespaceExtConflict  -- Since 9.2+   | Opt_WarnOperatorWhitespace             -- Since 9.2+   | Opt_WarnAmbiguousFields                -- Since 9.2+   | Opt_WarnImplicitLift                 -- Since 9.2+   | Opt_WarnMissingKindSignatures        -- Since 9.2+   deriving (Eq, Ord, Show, Enum)  -- | Used when outputting warnings: if a reason is given, it is -- displayed. If a warning isn't controlled by a flag, this is made@@ -522,8 +535,9 @@   json (ErrReason (Just wf)) = JSString (show wf)  -data Language = Haskell98 | Haskell2010+data Language = Haskell98 | Haskell2010 | GHC2021    deriving (Eq, Enum, Show, Bounded)  instance Outputable Language where     ppr = text . show+

GHC/Driver/Hooks.hs view

@@ -3,14 +3,15 @@ -- NB: this module is SOURCE-imported by DynFlags, and should primarily --     refer to *types*, rather than *code* -{-# LANGUAGE CPP, RankNTypes #-}+{-# LANGUAGE CPP, RankNTypes, TypeFamilies #-}  module GHC.Driver.Hooks    ( Hooks+   , HasHooks (..)+   , ContainsHooks (..)    , emptyHooks-   , lookupHook-   , getHooked      -- the hooks:+   , DsForeignsHook    , dsForeignsHook    , tcForeignImportsHook    , tcForeignExportsHook@@ -30,35 +31,48 @@  import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session import GHC.Driver.Pipeline.Monad-import GHC.Driver.Types+ import GHC.Hs.Decls import GHC.Hs.Binds import GHC.Hs.Expr-import GHC.Data.OrdList-import GHC.Tc.Types-import GHC.Data.Bag+import GHC.Hs.Extension+ import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Id-import GHC.Core-import GHCi.RemoteTypes import GHC.Types.SrcLoc-import GHC.Core.Type-import System.Process import GHC.Types.Basic+import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.Meta+import GHC.Types.HpcInfo+import GHC.Types.ForeignStubs+ import GHC.Unit.Module+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo++import GHC.Core import GHC.Core.TyCon-import GHC.Types.CostCentre+import GHC.Core.Type++import GHC.Tc.Types import GHC.Stg.Syntax-import GHC.Data.Stream-import GHC.Cmm-import GHC.Hs.Extension import GHC.StgToCmm.Types (ModuleLFInfos)+import GHC.Cmm -import Data.Maybe+import GHCi.RemoteTypes +import GHC.Data.Stream+import GHC.Data.Bag++import qualified Data.Kind+import System.Process+ {- ************************************************************************ *                                                                      *@@ -89,34 +103,56 @@   , cmmToRawCmmHook        = Nothing   } +{- Note [The Decoupling Abstract Data Hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "Abstract Data" idea is due to Richard Eisenberg in+https://gitlab.haskell.org/ghc/ghc/-/merge_requests/1957, where the pattern is+described in more detail.++Here we use it as a temporary measure to break the dependency from the Parser on+the Desugarer until the parser is free of DynFlags. We introduced a nullary type+family @DsForeignsook@, whose single definition is in GHC.HsToCore.Types, where+we instantiate it to++   [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr))++In doing so, the Hooks module (which is an hs-boot dependency of DynFlags) can+be decoupled from its use of the DsM definition in GHC.HsToCore.Types. Since+both DsM and the definition of @ForeignsHook@ live in the same module, there is+virtually no difference for plugin authors that want to write a foreign hook.+-}++-- See Note [The Decoupling Abstract Data Hack]+type family DsForeignsHook :: Data.Kind.Type+ data Hooks = Hooks-  { dsForeignsHook         :: Maybe ([LForeignDecl GhcTc]-                           -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))-  , tcForeignImportsHook   :: Maybe ([LForeignDecl GhcRn]-                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt))-  , tcForeignExportsHook   :: Maybe ([LForeignDecl GhcRn]-            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt))-  , hscFrontendHook        :: Maybe (ModSummary -> Hsc FrontendResult)+  { dsForeignsHook         :: !(Maybe DsForeignsHook)+  -- ^ Actual type:+  -- @Maybe ([LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList (Id, CoreExpr)))@+  , tcForeignImportsHook   :: !(Maybe ([LForeignDecl GhcRn]+                          -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)))+  , tcForeignExportsHook   :: !(Maybe ([LForeignDecl GhcRn]+            -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)))+  , hscFrontendHook        :: !(Maybe (ModSummary -> Hsc FrontendResult))   , hscCompileCoreExprHook ::-               Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)-  , ghcPrimIfaceHook       :: Maybe ModIface-  , runPhaseHook           :: Maybe (PhasePlus -> FilePath -> DynFlags-                                         -> CompPipeline (PhasePlus, FilePath))-  , runMetaHook            :: Maybe (MetaHook TcM)-  , linkHook               :: Maybe (GhcLink -> DynFlags -> Bool-                                         -> HomePackageTable -> IO SuccessFlag)-  , runRnSpliceHook        :: Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn))-  , getValueSafelyHook     :: Maybe (HscEnv -> Name -> Type-                                                          -> IO (Maybe HValue))-  , createIservProcessHook :: Maybe (CreateProcess -> IO ProcessHandle)-  , stgToCmmHook           :: Maybe (DynFlags -> Module -> [TyCon] -> CollectedCCs-                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos)-  , cmmToRawCmmHook        :: forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a-                                 -> IO (Stream IO RawCmmGroup a))+               !(Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue))+  , ghcPrimIfaceHook       :: !(Maybe ModIface)+  , runPhaseHook           :: !(Maybe (PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)))+  , runMetaHook            :: !(Maybe (MetaHook TcM))+  , linkHook               :: !(Maybe (GhcLink -> DynFlags -> Bool+                                         -> HomePackageTable -> IO SuccessFlag))+  , runRnSpliceHook        :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))+  , getValueSafelyHook     :: !(Maybe (HscEnv -> Name -> Type+                                                          -> IO (Maybe HValue)))+  , createIservProcessHook :: !(Maybe (CreateProcess -> IO ProcessHandle))+  , stgToCmmHook           :: !(Maybe (DynFlags -> Module -> InfoTableProvMap -> [TyCon] -> CollectedCCs+                                 -> [CgStgTopBinding] -> HpcInfo -> Stream IO CmmGroup (CStub, ModuleLFInfos)))+  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a+                                 -> IO (Stream IO RawCmmGroup a)))   } -getHooked :: (Functor f, HasDynFlags f) => (Hooks -> Maybe a) -> a -> f a-getHooked hook def = fmap (lookupHook hook def) getDynFlags+class HasHooks m where+    getHooks :: m Hooks -lookupHook :: (Hooks -> Maybe a) -> a -> DynFlags -> a-lookupHook hook def = fromMaybe def . hook . hooks+class ContainsHooks a where+    extractHooks :: a -> Hooks

GHC/Driver/Hooks.hs-boot view

@@ -5,3 +5,9 @@ data Hooks  emptyHooks :: Hooks++class HasHooks m where+    getHooks :: m Hooks++class ContainsHooks a where+    extractHooks :: a -> Hooks

GHC/Driver/Main.hs view

@@ -1,2037 +1,2172 @@-{-# LANGUAGE BangPatterns, CPP, MagicHash, NondecreasingIndentation #-}-{-# OPTIONS_GHC -fprof-auto-top #-}--------------------------------------------------------------------------------------- | Main API for compiling plain Haskell source code.------ This module implements compilation of a Haskell source. It is--- /not/ concerned with preprocessing of source files; this is handled--- in "GHC.Driver.Pipeline"------ There are various entry points depending on what mode we're in:--- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and--- "interactive" mode (GHCi). There are also entry points for--- individual passes: parsing, typechecking/renaming, desugaring, and--- simplification.------ All the functions here take an 'HscEnv' as a parameter, but none of--- them return a new one: 'HscEnv' is treated as an immutable value--- from here on in (although it has mutable components, for the--- caches).------ We use the Hsc monad to deal with warning messages consistently:--- specifically, while executing within an Hsc monad, warnings are--- collected. When a Hsc monad returns to an IO monad, the--- warnings are printed, or compilation aborts if the @-Werror@--- flag is enabled.------ (c) The GRASP/AQUA Project, Glasgow University, 1993-2000-------------------------------------------------------------------------------------module GHC.Driver.Main-    (-    -- * Making an HscEnv-      newHscEnv--    -- * Compiling complete source files-    , Messager, batchMsg-    , HscStatus (..)-    , hscIncrementalCompile-    , initModDetails-    , hscMaybeWriteIface-    , hscCompileCmmFile--    , hscGenHardCode-    , hscInteractive--    -- * Running passes separately-    , hscParse-    , hscTypecheckRename-    , hscDesugar-    , makeSimpleDetails-    , hscSimplify -- ToDo, shouldn't really export this--    -- * Safe Haskell-    , hscCheckSafe-    , hscGetSafe--    -- * Support for interactive evaluation-    , hscParseIdentifier-    , hscTcRcLookupName-    , hscTcRnGetInfo-    , hscIsGHCiMonad-    , hscGetModuleInterface-    , hscRnImportDecls-    , hscTcRnLookupRdrName-    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt-    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls-    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType-    , hscParseExpr-    , hscParseType-    , hscCompileCoreExpr-    -- * Low-level exports for hooks-    , hscCompileCoreExpr'-      -- We want to make sure that we export enough to be able to redefine-      -- hsc_typecheck in client code-    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen-    , getHscEnv-    , hscSimpleIface'-    , oneShotMsg-    , dumpIfaceStats-    , ioMsgMaybe-    , showModuleIndex-    , hscAddSptEntries-    ) where--import GHC.Prelude--import Data.Data hiding (Fixity, TyCon)-import Data.Maybe       ( fromJust )-import GHC.Types.Id-import GHC.Runtime.Interpreter ( addSptEntry )-import GHCi.RemoteTypes        ( ForeignHValue )-import GHC.CoreToByteCode      ( byteCodeGen, coreExprToBCOs )-import GHC.Runtime.Linker-import GHC.Core.Tidy           ( tidyExpr )-import GHC.Core.Type           ( Type, Kind )-import GHC.Core.Lint           ( lintInteractiveExpr )-import GHC.Types.Var.Env       ( emptyTidyEnv )-import GHC.Utils.Panic-import GHC.Core.ConLike--import GHC.Parser.Annotation-import GHC.Unit.Module-import GHC.Unit.State-import GHC.Types.Name.Reader-import GHC.Hs-import GHC.Hs.Dump-import GHC.Core-import GHC.Data.StringBuffer-import GHC.Parser-import GHC.Parser.Lexer as Lexer-import GHC.Types.SrcLoc-import GHC.Tc.Module-import GHC.IfaceToCore  ( typecheckIface )-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )-import GHC.Types.Name.Cache ( initNameCache )-import GHC.Builtin.Utils-import GHC.Core.Opt.Pipeline-import GHC.HsToCore-import GHC.Iface.Load   ( ifaceStats, initExternalPackageState, writeIface )-import GHC.Iface.Make-import GHC.Iface.Recomp-import GHC.Iface.Tidy-import GHC.CoreToStg.Prep-import GHC.CoreToStg    ( coreToStg )-import GHC.Stg.Syntax-import GHC.Stg.FVs      ( annTopBindingsFreeVars )-import GHC.Stg.Pipeline ( stg2stg )-import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import GHC.Types.CostCentre-import GHC.Core.TyCon-import GHC.Types.Name-import GHC.Cmm-import GHC.Cmm.Parser       ( parseCmmFile )-import GHC.Cmm.Info.Build-import GHC.Cmm.Pipeline-import GHC.Cmm.Info-import GHC.Driver.CodeOutput-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv-import GHC.Utils.Fingerprint ( Fingerprint )-import GHC.Driver.Hooks-import GHC.Tc.Utils.Env-import GHC.Builtin.Names-import GHC.Driver.Plugins-import GHC.Runtime.Loader   ( initializePlugins )-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)--import GHC.Driver.Session-import GHC.Utils.Error--import GHC.Utils.Outputable-import GHC.Types.Name.Env-import GHC.Hs.Stats         ( ppSourceStats )-import GHC.Driver.Types-import GHC.Data.FastString-import GHC.Types.Unique.Supply-import GHC.Data.Bag-import GHC.Utils.Exception-import qualified GHC.Data.Stream as Stream-import GHC.Data.Stream (Stream)--import GHC.Utils.Misc--import Data.List        ( nub, isPrefixOf, partition )-import Control.Monad-import Data.IORef-import System.FilePath as FilePath-import System.Directory-import System.IO (fixIO)-import qualified Data.Map as M-import qualified Data.Set as S-import Data.Set (Set)-import Data.Functor-import Control.DeepSeq (force)-import Data.Bifunctor (first)--import GHC.Iface.Ext.Ast    ( mkHieFile )-import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))-import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )-import Data.List.NonEmpty (NonEmpty ((:|)))--#include "HsVersions.h"---{- **********************************************************************-%*                                                                      *-                Initialisation-%*                                                                      *-%********************************************************************* -}--newHscEnv :: DynFlags -> IO HscEnv-newHscEnv dflags = do-    eps_var <- newIORef (initExternalPackageState dflags)-    us      <- mkSplitUniqSupply 'r'-    nc_var  <- newIORef (initNameCache us knownKeyNames)-    fc_var  <- newIORef emptyInstalledModuleEnv-    emptyDynLinker <- uninitializedLinker-    return HscEnv {  hsc_dflags       = dflags-                  ,  hsc_targets      = []-                  ,  hsc_mod_graph    = emptyMG-                  ,  hsc_IC           = emptyInteractiveContext dflags-                  ,  hsc_HPT          = emptyHomePackageTable-                  ,  hsc_EPS          = eps_var-                  ,  hsc_NC           = nc_var-                  ,  hsc_FC           = fc_var-                  ,  hsc_type_env_var = Nothing-                  ,  hsc_interp       = Nothing-                  ,  hsc_dynLinker    = emptyDynLinker-                  }---- -------------------------------------------------------------------------------getWarnings :: Hsc WarningMessages-getWarnings = Hsc $ \_ w -> return (w, w)--clearWarnings :: Hsc ()-clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)--logWarnings :: WarningMessages -> Hsc ()-logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)--getHscEnv :: Hsc HscEnv-getHscEnv = Hsc $ \e w -> return (e, w)--handleWarnings :: Hsc ()-handleWarnings = do-    dflags <- getDynFlags-    w <- getWarnings-    liftIO $ printOrThrowWarnings dflags w-    clearWarnings---- | log warning in the monad, and if there are errors then--- throw a SourceError exception.-logWarningsReportErrors :: Messages -> Hsc ()-logWarningsReportErrors (warns,errs) = do-    logWarnings warns-    when (not $ isEmptyBag errs) $ throwErrors errs---- | Log warnings and throw errors, assuming the messages--- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: Messages -> Hsc a-handleWarningsThrowErrors (warns, errs) = do-    logWarnings warns-    dflags <- getDynFlags-    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings-    liftIO $ printBagOfErrors dflags wWarns-    throwErrors (unionBags errs wErrs)---- | Deal with errors and warnings returned by a compilation step------ In order to reduce dependencies to other parts of the compiler, functions--- outside the "main" parts of GHC return warnings and errors as a parameter--- and signal success via by wrapping the result in a 'Maybe' type. This--- function logs the returned warnings and propagates errors as exceptions--- (of type 'SourceError').------ This function assumes the following invariants:------  1. If the second result indicates success (is of the form 'Just x'),---     there must be no error messages in the first result.------  2. If there are no error messages, but the second result indicates failure---     there should be warnings in the first result. That is, if the action---     failed, it must have been due to the warnings (i.e., @-Werror@).-ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    ((warns,errs), mb_r) <- liftIO ioA-    logWarnings warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> ASSERT( isEmptyBag errs ) return r---- | like ioMsgMaybe, except that we ignore error messages and return--- 'Nothing' instead.-ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)-ioMsgMaybe' ioA = do-    ((warns,_errs), mb_r) <- liftIO $ ioA-    logWarnings warns-    return mb_r---- -------------------------------------------------------------------------------- | Lookup things in the compiler's environment--hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]-hscTcRnLookupRdrName hsc_env0 rdr_name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }--hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)-hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe' $ tcRnLookupName hsc_env name-      -- ignore errors: the only error we're likely to get is-      -- "name not found", and the Maybe in the return type-      -- is used to indicate that.--hscTcRnGetInfo :: HscEnv -> Name-               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))-hscTcRnGetInfo hsc_env0 name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }--hscIsGHCiMonad :: HscEnv -> String -> IO Name-hscIsGHCiMonad hsc_env name-  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name--hscGetModuleInterface :: HscEnv -> Module -> IO ModIface-hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ getModuleInterface hsc_env mod---- -------------------------------------------------------------------------------- | Rename some import declarations-hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv-hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls---- -------------------------------------------------------------------------------- | parse a file, returning the abstract syntax--hscParse :: HscEnv -> ModSummary -> IO HsParsedModule-hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary---- internal version, that doesn't fail due to -Werror-hscParse' :: ModSummary -> Hsc HsParsedModule-hscParse' mod_summary- | Just r <- ms_parsed_mod mod_summary = return r- | otherwise = {-# SCC "Parser" #-}-    withTimingD (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))-                (const ()) $ do-    dflags <- getDynFlags-    let src_filename  = ms_hspp_file mod_summary-        maybe_src_buf = ms_hspp_buf  mod_summary--    --------------------------  Parser  -----------------    -- sometimes we already have the buffer in memory, perhaps-    -- because we needed to parse the imports out of it, or get the-    -- module name.-    buf <- case maybe_src_buf of-               Just b  -> return b-               Nothing -> liftIO $ hGetStringBuffer src_filename--    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1-    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do-      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of-        Nothing -> pure ()-        Just ((loc,chr,desc) :| xs) ->-          let span = mkSrcSpanPs $ mkPsSpan loc (advancePsLoc loc chr)-              warn = makeIntoWarning (Reason Opt_WarnUnicodeBidirectionalFormatCharacters) $ mkLongWarnMsg dflags span neverQualify msg empty-              msg = text "A unicode bidirectional formatting character" <+> parens (text desc)-                 $$ text "was found at offset" <+> ppr (bufPos (psBufPos loc)) <+> text "in the file"-                 $$ (case xs of-                       [] -> empty-                       xs -> text "along with further bidirectional formatting characters at" <+> pprChars xs-                        where-                          pprChars [] = empty-                          pprChars ((loc,_,desc):xs) = text "offset" <+> ppr (bufPos (psBufPos loc)) <> text ":" <+> text desc-                                                    $$ pprChars xs)-                 $$ text "Bidirectional formatting characters may be rendered misleadingly in certain editors"--          in liftIO $ printOrThrowWarnings dflags (unitBag warn)--    let parseMod | HsigFile == ms_hsc_src mod_summary-                 = parseSignature-                 | otherwise = parseModule--    case unP parseMod (mkPState dflags buf loc) of-        PFailed pst ->-            handleWarningsThrowErrors (getMessages pst dflags)-        POk pst rdr_module -> do-            let (warns, errs) = getMessages pst dflags-            logWarnings warns-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"-                        FormatHaskell (ppr rdr_module)-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"-                        FormatHaskell (showAstData NoBlankSrcSpan rdr_module)-            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"-                        FormatText (ppSourceStats False rdr_module)-            when (not $ isEmptyBag errs) $ throwErrors errs--            -- To get the list of extra source files, we take the list-            -- that the parser gave us,-            --   - eliminate files beginning with '<'.  gcc likes to use-            --     pseudo-filenames like "<built-in>" and "<command-line>"-            --   - normalise them (eliminate differences between ./f and f)-            --   - filter out the preprocessed source file-            --   - filter out anything beginning with tmpdir-            --   - remove duplicates-            --   - filter out the .hs/.lhs source filename if we have one-            ---            let n_hspp  = FilePath.normalise src_filename-                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))-                            $ filter (not . (== n_hspp))-                            $ map FilePath.normalise-                            $ filter (not . isPrefixOf "<")-                            $ map unpackFS-                            $ srcfiles pst-                srcs1 = case ml_hs_file (ms_location mod_summary) of-                          Just f  -> filter (/= FilePath.normalise f) srcs0-                          Nothing -> srcs0--            -- sometimes we see source files from earlier-            -- preprocessing stages that cannot be found, so just-            -- filter them out:-            srcs2 <- liftIO $ filterM doesFileExist srcs1--            let api_anns = ApiAnns {-                      apiAnnItems = M.fromListWith (++) $ annotations pst,-                      apiAnnEofPos = eof_pos pst,-                      apiAnnComments = M.fromList (annotations_comments pst),-                      apiAnnRogueComments = comment_q pst-                   }-                res = HsParsedModule {-                      hpm_module    = rdr_module,-                      hpm_src_files = srcs2,-                      hpm_annotations = api_anns-                   }--            -- apply parse transformation of plugins-            let applyPluginAction p opts-                  = parsedResultAction p opts mod_summary-            withPlugins dflags applyPluginAction res--checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))-checkBidirectionFormatChars start_loc sb-  | containsBidirectionalFormatChar sb = Just $ go start_loc sb-  | otherwise = Nothing-  where-    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)-    go loc sb-      | atEnd sb = panic "checkBidirectionFormatChars: no char found"-      | otherwise = case nextChar sb of-          (chr, sb)-            | Just desc <- lookup chr bidirectionalFormatChars ->-                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb-            | otherwise -> go (advancePsLoc loc chr) sb--    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]-    go1 loc sb-      | atEnd sb = []-      | otherwise = case nextChar sb of-          (chr, sb)-            | Just desc <- lookup chr bidirectionalFormatChars ->-                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb-            | otherwise -> go1 (advancePsLoc loc chr) sb----- -------------------------------------------------------------------------------- | If the renamed source has been kept, extract it. Dump it if requested.---extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff-extract_renamed_stuff mod_summary tc_result = do-    let rn_info = getRenamedStuff tc_result--    dflags <- getDynFlags-    liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer"-                FormatHaskell (showAstData NoBlankSrcSpan rn_info)--    -- Create HIE files-    when (gopt Opt_WriteHie dflags) $ do-        -- I assume this fromJust is safe because `-fwrite-hie-file`-        -- enables the option which keeps the renamed source.-        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)-        let out_file = ml_hie_file $ ms_location mod_summary-        liftIO $ writeHieFile out_file hieFile-        liftIO $ dumpIfSet_dyn dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)--        -- Validate HIE files-        when (gopt Opt_ValidateHie dflags) $ do-            hs_env <- Hsc $ \e w -> return (e, w)-            liftIO $ do-              -- Validate Scopes-              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of-                  [] -> putMsg dflags $ text "Got valid scopes"-                  xs -> do-                    putMsg dflags $ text "Got invalid scopes"-                    mapM_ (putMsg dflags) xs-              -- Roundtrip testing-              file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file-              case diffFile hieFile (hie_file_result file') of-                [] ->-                  putMsg dflags $ text "Got no roundtrip errors"-                xs -> do-                  putMsg dflags $ text "Got roundtrip errors"-                  mapM_ (putMsg (dopt_set dflags Opt_D_ppr_debug)) xs-    return rn_info----- -------------------------------------------------------------------------------- | Rename and typecheck a module, additionally returning the renamed syntax-hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule-                   -> IO (TcGblEnv, RenamedStuff)-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $-    hsc_typecheck True mod_summary (Just rdr_module)----- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack--- b) concerning dumping rename info and hie files. It would be nice to further--- separate this stuff out, probably in conjunction better separating renaming--- and type checking (#17781).-hsc_typecheck :: Bool -- ^ Keep renamed source?-              -> ModSummary -> Maybe HsParsedModule-              -> Hsc (TcGblEnv, RenamedStuff)-hsc_typecheck keep_rn mod_summary mb_rdr_module = do-    hsc_env <- getHscEnv-    let hsc_src = ms_hsc_src mod_summary-        dflags = hsc_dflags hsc_env-        outer_mod = ms_mod mod_summary-        mod_name = moduleName outer_mod-        outer_mod' = mkHomeModule dflags mod_name-        inner_mod = canonicalizeHomeModule dflags mod_name-        src_filename  = ms_hspp_file mod_summary-        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1-        keep_rn' = gopt Opt_WriteHie dflags || keep_rn-    MASSERT( isHomeModule dflags outer_mod )-    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)-        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc-        else-         do hpm <- case mb_rdr_module of-                    Just hpm -> return hpm-                    Nothing -> hscParse' mod_summary-            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm-            if hsc_src == HsigFile-                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing-                        ioMsgMaybe $-                            tcRnMergeSignatures hsc_env hpm tc_result0 iface-                else return tc_result0-    -- TODO are we extracting anything when we merely instantiate a signature?-    -- If not, try to move this into the "else" case above.-    rn_info <- extract_renamed_stuff mod_summary tc_result-    return (tc_result, rn_info)---- wrapper around tcRnModule to handle safe haskell extras-tcRnModule' :: ModSummary -> Bool -> HsParsedModule-            -> Hsc TcGblEnv-tcRnModule' sum save_rn_syntax mod = do-    hsc_env <- getHscEnv-    dflags   <- getDynFlags--    -- -Wmissing-safe-haskell-mode-    when (not (safeHaskellModeEnabled dflags)-          && wopt Opt_WarnMissingSafeHaskellMode dflags) $-        logWarnings $ unitBag $-        makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $-        mkPlainWarnMsg dflags (getLoc (hpm_module mod)) $-        warnMissingSafeHaskellMode--    tcg_res <- {-# SCC "Typecheck-Rename" #-}-               ioMsgMaybe $-                   tcRnModule hsc_env sum-                     save_rn_syntax mod--    -- See Note [Safe Haskell Overlapping Instances Implementation]-    -- although this is used for more than just that failure case.-    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)-    let allSafeOK = safeInferred dflags && tcSafeOK--    -- end of the safe haskell line, how to respond to user?-    if not (safeHaskellOn dflags)-         || (safeInferOn dflags && not allSafeOK)-      -- if safe Haskell off or safe infer failed, mark unsafe-      then markUnsafeInfer tcg_res whyUnsafe--      -- module (could be) safe, throw warning if needed-      else do-          tcg_res' <- hscCheckSafeImports tcg_res-          safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')-          when safe $ do-            case wopt Opt_WarnSafe dflags of-              True-                | safeHaskell dflags == Sf_Safe -> return ()-                | otherwise -> (logWarnings $ unitBag $-                       makeIntoWarning (Reason Opt_WarnSafe) $-                       mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $-                       errSafe tcg_res')-              False | safeHaskell dflags == Sf_Trustworthy &&-                      wopt Opt_WarnTrustworthySafe dflags ->-                      (logWarnings $ unitBag $-                       makeIntoWarning (Reason Opt_WarnTrustworthySafe) $-                       mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $-                       errTwthySafe tcg_res')-              False -> return ()-          return tcg_res'-  where-    pprMod t  = ppr $ moduleName $ tcg_mod t-    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"-    errTwthySafe t = quotes (pprMod t)-      <+> text "is marked as Trustworthy but has been inferred as safe!"-    warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))-      <+> text "is missing Safe Haskell mode"---- | Convert a typechecked module to Core-hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts-hscDesugar hsc_env mod_summary tc_result =-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result--hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts-hscDesugar' mod_location tc_result = do-    hsc_env <- getHscEnv-    r <- ioMsgMaybe $-      {-# SCC "deSugar" #-}-      deSugar hsc_env mod_location tc_result--    -- always check -Werror after desugaring, this is the last opportunity for-    -- warnings to arise before the backend.-    handleWarnings-    return r---- | Make a 'ModDetails' from the results of typechecking. Used when--- typechecking only, as opposed to full compilation.-makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails-makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result---{- **********************************************************************-%*                                                                      *-                The main compiler pipeline-%*                                                                      *-%********************************************************************* -}--{--                   ---------------------------------                        The compilation proper-                   ----------------------------------It's the task of the compilation proper to compile Haskell, hs-boot and core-files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all-(the module is still parsed and type-checked. This feature is mostly used by-IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',-'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'-mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode-targets byte-code.--The modes are kept separate because of their different types and meanings:-- * In 'one-shot' mode, we're only compiling a single file and can therefore- discard the new ModIface and ModDetails. This is also the reason it only- targets hard-code; compiling to byte-code or nothing doesn't make sense when- we discard the result.-- * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface- and ModDetails. 'Batch' mode doesn't target byte-code since that require us to- return the newly compiled byte-code.-- * 'Nothing' mode has exactly the same type as 'batch' mode but they're still- kept separate. This is because compiling to nothing is fairly special: We- don't output any interface files, we don't run the simplifier and we don't- generate any code.-- * 'Interactive' mode is similar to 'batch' mode except that we return the- compiled byte-code together with the ModIface and ModDetails.--Trying to compile a hs-boot file to byte-code will result in a run-time error.-This is the only thing that isn't caught by the type-system.--}---type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()---- | This function runs GHC's frontend with recompilation--- avoidance. Specifically, it checks if recompilation is needed,--- and if it is, it parses and typechecks the input module.--- It does not write out the results of typechecking (See--- compileOne and hscIncrementalCompile).-hscIncrementalFrontend :: Bool -- always do basic recompilation check?-                       -> Maybe TcGblEnv-                       -> Maybe Messager-                       -> ModSummary-                       -> SourceModified-                       -> Maybe ModIface  -- Old interface, if available-                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)-                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))--hscIncrementalFrontend-  always_do_basic_recompilation_check m_tc_result-  mHscMessage mod_summary source_modified mb_old_iface mod_index-    = do-    hsc_env <- getHscEnv--    let msg what = case mHscMessage of-                   Just hscMessage -> hscMessage hsc_env mod_index what mod_summary-                   Nothing -> return ()--        skip iface = do-            liftIO $ msg UpToDate-            return $ Left iface--        compile mb_old_hash reason = do-            liftIO $ msg reason-            (tc_result, _) <- hsc_typecheck False mod_summary Nothing-            return $ Right (FrontendTypecheck tc_result, mb_old_hash)--        stable = case source_modified of-                     SourceUnmodifiedAndStable -> True-                     _                         -> False--    case m_tc_result of-         Just tc_result-          | not always_do_basic_recompilation_check ->-             return $ Right (FrontendTypecheck tc_result, Nothing)-         _ -> do-            (recomp_reqd, mb_checked_iface)-                <- {-# SCC "checkOldIface" #-}-                   liftIO $ checkOldIface hsc_env mod_summary-                                source_modified mb_old_iface-            -- save the interface that comes back from checkOldIface.-            -- In one-shot mode we don't have the old iface until this-            -- point, when checkOldIface reads it from the disk.-            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface--            case mb_checked_iface of-                Just iface | not (recompileRequired recomp_reqd) ->-                    -- If the module used TH splices when it was last-                    -- compiled, then the recompilation check is not-                    -- accurate enough (#481) and we must ignore-                    -- it.  However, if the module is stable (none of-                    -- the modules it depends on, directly or-                    -- indirectly, changed), then we *can* skip-                    -- recompilation. This is why the SourceModified-                    -- type contains SourceUnmodifiedAndStable, and-                    -- it's pretty important: otherwise ghc --make-                    -- would always recompile TH modules, even if-                    -- nothing at all has changed. Stability is just-                    -- the same check that make is doing for us in-                    -- one-shot mode.-                    case m_tc_result of-                    Nothing-                     | mi_used_th iface && not stable ->-                        compile mb_old_hash (RecompBecause "TH")-                    _ ->-                        skip iface-                _ ->-                    case m_tc_result of-                    Nothing -> compile mb_old_hash recomp_reqd-                    Just tc_result ->-                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)------------------------------------------------------------------- Compilers------------------------------------------------------------------- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts--- of the pipeline.--- We return a interface if we already had an old one around and recompilation--- was not needed. Otherwise it will be created during later passes when we--- run the compilation pipeline.-hscIncrementalCompile :: Bool-                      -> Maybe TcGblEnv-                      -> Maybe Messager-                      -> HscEnv-                      -> ModSummary-                      -> SourceModified-                      -> Maybe ModIface-                      -> (Int,Int)-                      -> IO (HscStatus, DynFlags)-hscIncrementalCompile always_do_basic_recompilation_check m_tc_result-    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index-  = do-    dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')-    let hsc_env'' = hsc_env' { hsc_dflags = dflags }--    -- One-shot mode needs a knot-tying mutable variable for interface-    -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.-    -- See also Note [hsc_type_env_var hack]-    type_env_var <- newIORef emptyNameEnv-    let mod = ms_mod mod_summary-        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))-                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }-                | otherwise-                = hsc_env''--    -- NB: enter Hsc monad here so that we don't bail out early with-    -- -Werror on typechecker warnings; we also want to run the desugarer-    -- to get those warnings too. (But we'll always exit at that point-    -- because the desugarer runs ioMsgMaybe.)-    runHsc hsc_env $ do-    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage-            mod_summary source_modified mb_old_iface mod_index-    case e of-        -- We didn't need to do any typechecking; the old interface-        -- file on disk was good enough.-        Left iface -> do-            details <- liftIO $ initModDetails hsc_env mod_summary iface-            return (HscUpToDate iface details, dflags)-        -- We finished type checking.  (mb_old_hash is the hash of-        -- the interface that existed on disk; it's possible we had-        -- to retypecheck but the resulting interface is exactly-        -- the same.)-        Right (FrontendTypecheck tc_result, mb_old_hash) -> do-            status <- finish mod_summary tc_result mb_old_hash-            return (status, dflags)---- Knot tying!  See Note [Knot-tying typecheckIface]--- See Note [ModDetails and --make mode]-initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails-initModDetails hsc_env mod_summary iface =-  fixIO $ \details' -> do-    let hsc_env' = hsc_env {-                    hsc_HPT = addToHpt (hsc_HPT hsc_env)-                                       (ms_mod_name mod_summary)-                                       (HomeModInfo iface details' Nothing)-                   }-    -- NB: This result is actually not that useful-    -- in one-shot mode, since we're not going to do-    -- any further typechecking.  It's much more useful-    -- in make mode, since this HMI will go into the HPT.-    genModDetails hsc_env' iface---{--Note [ModDetails and --make mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--An interface file consists of two parts--* The `ModIface` which ends up getting written to disk.-  The `ModIface` is a completely acyclic tree, which can be serialised-  and de-serialised completely straightforwardly.  The `ModIface` is-  also the structure that is finger-printed for recompilation control.--* The `ModDetails` which provides a more structured view that is suitable-  for usage during compilation.  The `ModDetails` is heavily cyclic:-  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind-  that mentions other `TyCons`; the `Id` also includes an unfolding that-  in turn mentions more `Id`s;  And so on.--The `ModIface` can be created from the `ModDetails` and the `ModDetails` from-a `ModIface`.--During tidying, just before interfaces are written to disk,-the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).-Then when GHC needs to restart typechecking from a certain point it can read the-interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).-The key part about the loading is that the ModDetails is regenerated lazily-from the ModIface, so that there's only a detailed in-memory representation-for declarations which are actually used from the interface. This mode is-also used when reading interface files from external packages.--In the old --make mode implementation, the interface was written after compiling a module-but the in-memory ModDetails which was used to compute the ModIface was retained.-The result was that --make mode used much more memory than `-c` mode, because a large amount of-information about a module would be kept in the ModDetails but never used.--The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`-at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that-we only have to keep the `ModIface` decls in memory and then lazily load-detailed representations if needed. It turns out this makes a really big difference-to memory usage, halving maximum memory used in some cases.--See !5492 and #13586--}---- Runs the post-typechecking frontend (desugar and simplify). We want to--- generate most of the interface as late as possible. This gets us up-to-date--- and good unfoldings and other info in the interface file.------ We might create a interface right away, in which case we also return the--- updated HomeModInfo. But we might also need to run the backend first. In the--- later case Status will be HscRecomp and we return a function from ModIface ->--- HomeModInfo.------ HscRecomp in turn will carry the information required to compute a interface--- when passed the result of the code generator. So all this can and is done at--- the call site of the backend code gen if it is run.-finish :: ModSummary-       -> TcGblEnv-       -> Maybe Fingerprint-       -> Hsc HscStatus-finish summary tc_result mb_old_hash = do-  hsc_env <- getHscEnv-  let dflags = hsc_dflags hsc_env-      target = hscTarget dflags-      hsc_src = ms_hsc_src summary--  -- Desugar, if appropriate-  ---  -- We usually desugar even when we are not generating code, otherwise we-  -- would miss errors thrown by the desugaring (see #10600). The only-  -- exceptions are when the Module is Ghc.Prim or when it is not a-  -- HsSrcFile Module.-  mb_desugar <--      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile-      then Just <$> hscDesugar' (ms_location summary) tc_result-      else pure Nothing--  -- Simplify, if appropriate, and (whether we simplified or not) generate an-  -- interface file.-  case mb_desugar of-      -- Just cause we desugared doesn't mean we are generating code, see above.-      Just desugared_guts | target /= HscNothing -> do-          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)-          simplified_guts <- hscSimplify' plugins desugared_guts--          (cg_guts, details) <- {-# SCC "CoreTidy" #-}-              liftIO $ tidyProgram hsc_env simplified_guts--          let !partial_iface =-                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}-                -- This `force` saves 2M residency in test T10370-                -- See Note [Avoiding space leaks in toIface*] for details.-                force (mkPartialIface hsc_env details simplified_guts)--          return HscRecomp { hscs_guts = cg_guts,-                             hscs_mod_location = ms_location summary,-                             hscs_partial_iface = partial_iface,-                             hscs_old_iface_hash = mb_old_hash,-                             hscs_iface_dflags = dflags }--      -- We are not generating code, so we can skip simplification-      -- and generate a simple interface.-      _ -> do-        (iface, mb_old_iface_hash, details) <- liftIO $-          hscSimpleIface hsc_env tc_result mb_old_hash--        liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary)--        return $ case (target, hsc_src) of-          (HscNothing, _) -> HscNotGeneratingCode iface details-          (_, HsBootFile) -> HscUpdateBoot iface details-          (_, HsigFile) -> HscUpdateSig iface details-          _ -> panic "finish"--{--Note [Writing interface files]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We write interface files in GHC.Driver.Main and GHC.Driver.Pipeline using-hscMaybeWriteIface, but only once per compilation (twice with dynamic-too).--* If a compilation does NOT require (re)compilation of the hard code we call-  hscMaybeWriteIface inside GHC.Driver.Main:finish.-* If we run in One Shot mode and target bytecode we write it in compileOne'-* Otherwise we must be compiling to regular hard code and require recompilation.-  In this case we create the interface file inside RunPhase using the interface-  generator contained inside the HscRecomp status.--}-hscMaybeWriteIface :: DynFlags -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()-hscMaybeWriteIface dflags iface old_iface location = do-    let force_write_interface = gopt Opt_WriteInterface dflags-        write_interface = case hscTarget dflags of-                            HscNothing      -> False-                            HscInterpreted  -> False-                            _               -> True-        no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))--    when (write_interface || force_write_interface) $-          hscWriteIface dflags iface no_change location------------------------------------------------------------------- NoRecomp handlers------------------------------------------------------------------- NB: this must be knot-tied appropriately, see hscIncrementalCompile-genModDetails :: HscEnv -> ModIface -> IO ModDetails-genModDetails hsc_env old_iface-  = do-    new_details <- {-# SCC "tcRnIface" #-}-                   initIfaceLoad hsc_env (typecheckIface old_iface)-    dumpIfaceStats hsc_env-    return new_details------------------------------------------------------------------- Progress displayers.-----------------------------------------------------------------oneShotMsg :: HscEnv -> RecompileRequired -> IO ()-oneShotMsg hsc_env recomp =-    case recomp of-        UpToDate ->-            compilationProgressMsg (hsc_dflags hsc_env) $-                   "compilation IS NOT required"-        _ ->-            return ()--batchMsg :: Messager-batchMsg hsc_env mod_index recomp mod_summary =-    case recomp of-        MustCompile -> showMsg "Compiling " ""-        UpToDate-            | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""-            | otherwise -> return ()-        RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")-    where-        dflags = hsc_dflags hsc_env-        showMsg msg reason =-            compilationProgressMsg dflags $-            (showModuleIndex mod_index ++-            msg ++ showModMsg dflags (hscTarget dflags)-                              (recompileRequired recomp) mod_summary)-                ++ reason------------------------------------------------------------------- Safe Haskell------------------------------------------------------------------- Note [Safe Haskell Trust Check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell checks that an import is trusted according to the following--- rules for an import of module M that resides in Package P:------   * If M is recorded as Safe and all its trust dependencies are OK---     then M is considered safe.---   * If M is recorded as Trustworthy and P is considered trusted and---     all M's trust dependencies are OK then M is considered safe.------ By trust dependencies we mean that the check is transitive. So if--- a module M that is Safe relies on a module N that is trustworthy,--- importing module M will first check (according to the second case)--- that N is trusted before checking M is trusted.------ This is a minimal description, so please refer to the user guide--- for more details. The user guide is also considered the authoritative--- source in this matter, not the comments or code.----- Note [Safe Haskell Inference]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell does Safe inference on modules that don't have any specific--- safe haskell mode flag. The basic approach to this is:---   * When deciding if we need to do a Safe language check, treat---     an unmarked module as having -XSafe mode specified.---   * For checks, don't throw errors but return them to the caller.---   * Caller checks if there are errors:---     * For modules explicitly marked -XSafe, we throw the errors.---     * For unmarked modules (inference mode), we drop the errors---       and mark the module as being Unsafe.------ It used to be that we only did safe inference on modules that had no Safe--- Haskell flags, but now we perform safe inference on all modules as we want--- to allow users to set the `-Wsafe`, `-Wunsafe` and--- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a--- user can ensure their assumptions are correct and see reasons for why a--- module is safe or unsafe.------ This is tricky as we must be careful when we should throw an error compared--- to just warnings. For checking safe imports we manage it as two steps. First--- we check any imports that are required to be safe, then we check all other--- imports to see if we can infer them to be safe.----- | Check that the safe imports of the module being compiled are valid.--- If not we either issue a compilation error if the module is explicitly--- using Safe Haskell, or mark the module as unsafe if we're in safe--- inference mode.-hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv-hscCheckSafeImports tcg_env = do-    dflags   <- getDynFlags-    tcg_env' <- checkSafeImports tcg_env-    checkRULES dflags tcg_env'--  where-    checkRULES dflags tcg_env' = do-      case safeLanguageOn dflags of-          True -> do-              -- XSafe: we nuke user written RULES-              logWarnings $ warns dflags (tcg_rules tcg_env')-              return tcg_env' { tcg_rules = [] }-          False-                -- SafeInferred: user defined RULES, so not safe-              | safeInferOn dflags && not (null $ tcg_rules tcg_env')-              -> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')--                -- Trustworthy OR SafeInferred: with no RULES-              | otherwise-              -> return tcg_env'--    warns dflags rules = listToBag $ map (warnRules dflags) rules--    warnRules :: DynFlags -> GenLocated SrcSpan (RuleDecl GhcTc) -> ErrMsg-    warnRules dflags (L loc (HsRule { rd_name = n })) =-        mkPlainWarnMsg dflags loc $-            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$-            text "User defined rules are disabled under Safe Haskell"---- | Validate that safe imported modules are actually safe.  For modules in the--- HomePackage (the package the module we are compiling in resides) this just--- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules--- that reside in another package we also must check that the external package--- is trusted. See the Note [Safe Haskell Trust Check] above for more--- information.------ The code for this is quite tricky as the whole algorithm is done in a few--- distinct phases in different parts of the code base. See--- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a--- module are collected and unioned.  Specifically see the Note [Tracking Trust--- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in--- "GHC.Rename.Names".-checkSafeImports :: TcGblEnv -> Hsc TcGblEnv-checkSafeImports tcg_env-    = do-        dflags <- getDynFlags-        imps <- mapM condense imports'-        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps--        -- We want to use the warning state specifically for detecting if safe-        -- inference has failed, so store and clear any existing warnings.-        oldErrs <- getWarnings-        clearWarnings--        -- Check safe imports are correct-        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps-        safeErrs <- getWarnings-        clearWarnings--        -- Check non-safe imports are correct if inferring safety-        -- See the Note [Safe Haskell Inference]-        (infErrs, infPkgs) <- case (safeInferOn dflags) of-          False -> return (emptyBag, S.empty)-          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps-                     infErrs <- getWarnings-                     clearWarnings-                     return (infErrs, infPkgs)--        -- restore old errors-        logWarnings oldErrs--        case (isEmptyBag safeErrs) of-          -- Failed safe check-          False -> liftIO . throwIO . mkSrcErr $ safeErrs--          -- Passed safe check-          True -> do-            let infPassed = isEmptyBag infErrs-            tcg_env' <- case (not infPassed) of-              True  -> markUnsafeInfer tcg_env infErrs-              False -> return tcg_env-            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs-            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed-            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }--  where-    impInfo  = tcg_imports tcg_env     -- ImportAvails-    imports  = imp_mods impInfo        -- ImportedMods-    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])-    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])-    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]--    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)-    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"-    condense (m, x:xs) = do imv <- foldlM cond' x xs-                            return (m, imv_span imv, imv_is_safe imv)--    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)-    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal-    cond' v1 v2-        | imv_is_safe v1 /= imv_is_safe v2-        = do-            dflags <- getDynFlags-            throwOneError $ mkPlainErrMsg dflags (imv_span v1)-              (text "Module" <+> ppr (imv_name v1) <+>-              (text $ "is imported both as a safe and unsafe import!"))-        | otherwise-        = return v1--    -- easier interface to work with-    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)-    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l--    -- what pkg's to add to our trust requirements-    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->-          Bool -> ImportAvails-    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags-                                  && not (safeHaskellModeEnabled dflags) && infPassed-                                   = emptyImportAvails {-                                       imp_trust_pkgs = req `S.union` inf-                                   }-    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe-                         = emptyImportAvails-    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }---- | Check that a module is safe to import.------ We return True to indicate the import is safe and False otherwise--- although in the False case an exception may be thrown first.-hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool-hscCheckSafe hsc_env m l = runHsc hsc_env $ do-    dflags <- getDynFlags-    pkgs <- snd `fmap` hscCheckSafe' m l-    when (packageTrustOn dflags) $ checkPkgTrust pkgs-    errs <- getWarnings-    return $ isEmptyBag errs---- | Return if a module is trusted and the pkgs it depends on to be trusted.-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)-hscGetSafe hsc_env m l = runHsc hsc_env $ do-    (self, pkgs) <- hscCheckSafe' m l-    good         <- isEmptyBag `fmap` getWarnings-    clearWarnings -- don't want them printed...-    let pkgs' | Just p <- self = S.insert p pkgs-              | otherwise      = pkgs-    return (good, pkgs')---- | Is a module trusted? If not, throw or log errors depending on the type.--- Return (regardless of trusted or not) if the trust type requires the modules--- own package be trusted and a list of other packages required to be trusted--- (these later ones haven't been checked) but the own package trust has been.-hscCheckSafe' :: Module -> SrcSpan-  -> Hsc (Maybe UnitId, Set UnitId)-hscCheckSafe' m l = do-    dflags <- getDynFlags-    (tw, pkgs) <- isModSafe m l-    case tw of-        False                        -> return (Nothing, pkgs)-        True | isHomeModule dflags m -> return (Nothing, pkgs)-             -- TODO: do we also have to check the trust of the instantiation?-             -- Not necessary if that is reflected in dependencies-             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)-  where-    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set UnitId)-    isModSafe m l = do-        dflags <- getDynFlags-        iface <- lookup' m-        case iface of-            -- can't load iface to check trust!-            Nothing -> throwOneError $ mkPlainErrMsg dflags l-                         $ text "Can't load the interface file for" <+> ppr m-                           <> text ", to check that it can be safely imported"--            -- got iface, check trust-            Just iface' ->-                let trust = getSafeMode $ mi_trust iface'-                    trust_own_pkg = mi_trust_pkg iface'-                    -- check module is trusted-                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]-                    -- check package is trusted-                    safeP = packageTrusted dflags trust trust_own_pkg m-                    -- pkg trust reqs-                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'-                    -- warn if Safe module imports Safe-Inferred module.-                    warns = if wopt Opt_WarnInferredSafeImports dflags-                                && safeLanguageOn dflags-                                && trust == Sf_SafeInferred-                                then inferredImportWarn-                                else emptyBag-                    -- General errors we throw but Safe errors we log-                    errs = case (safeM, safeP) of-                        (True, True ) -> emptyBag-                        (True, False) -> pkgTrustErr-                        (False, _   ) -> modTrustErr-                in do-                    logWarnings warns-                    logWarnings errs-                    return (trust == Sf_Trustworthy, pkgRs)--                where-                    state = unitState dflags-                    inferredImportWarn = unitBag-                        $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)-                        $ mkWarnMsg dflags l (pkgQual state)-                        $ sep-                            [ text "Importing Safe-Inferred module "-                                <> ppr (moduleName m)-                                <> text " from explicitly Safe module"-                            ]-                    pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $-                        sep [ ppr (moduleName m)-                                <> text ": Can't be safely imported!"-                            , text "The package (" <> ppr (moduleUnit m)-                                <> text ") the module resides in isn't trusted."-                            ]-                    modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual state) $-                        sep [ ppr (moduleName m)-                                <> text ": Can't be safely imported!"-                            , text "The module itself isn't safe." ]--    -- | Check the package a module resides in is trusted. Safe compiled-    -- modules are trusted without requiring that their package is trusted. For-    -- trustworthy modules, modules in the home package are trusted but-    -- otherwise we check the package trust flag.-    packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool-    packageTrusted _ Sf_None      _ _ = False -- shouldn't hit these cases-    packageTrusted _ Sf_Ignore    _ _ = False -- shouldn't hit these cases-    packageTrusted _ Sf_Unsafe    _ _ = False -- prefer for completeness.-    packageTrusted dflags _ _ _-        | not (packageTrustOn dflags) = True-    packageTrusted _ Sf_Safe  False _ = True-    packageTrusted _ Sf_SafeInferred False _ = True-    packageTrusted dflags _ _ m-        | isHomeModule dflags m = True-        | otherwise = unitIsTrusted $ unsafeLookupUnit (unitState dflags) (moduleUnit m)--    lookup' :: Module -> Hsc (Maybe ModIface)-    lookup' m = do-        hsc_env <- getHscEnv-        hsc_eps <- liftIO $ hscEPS hsc_env-        let pkgIfaceT = eps_PIT hsc_eps-            homePkgT  = hsc_HPT hsc_env-            iface     = lookupIfaceByModule homePkgT pkgIfaceT m-        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi-        -- as the compiler hasn't filled in the various module tables-        -- so we need to call 'getModuleInterface' to load from disk-        iface' <- case iface of-            Just _  -> return iface-            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)-        return iface'----- | Check the list of packages are trusted.-checkPkgTrust :: Set UnitId -> Hsc ()-checkPkgTrust pkgs = do-    dflags <- getDynFlags-    let errors = S.foldr go [] pkgs-        state  = unitState dflags-        go pkg acc-            | unitIsTrusted $ unsafeLookupUnitId state pkg-            = acc-            | otherwise-            = (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual state)-                     $ text "The package (" <> ppr pkg <> text ") is required" <>-                       text " to be trusted but it isn't!"-    case errors of-        [] -> return ()-        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors---- | Set module to unsafe and (potentially) wipe trust information.------ Make sure to call this method to set a module to inferred unsafe, it should--- be a central and single failure method. We only wipe the trust information--- when we aren't in a specific Safe Haskell mode.------ While we only use this for recording that a module was inferred unsafe, we--- may call it on modules using Trustworthy or Unsafe flags so as to allow--- warning flags for safety to function correctly. See Note [Safe Haskell--- Inference].-markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv-markUnsafeInfer tcg_env whyUnsafe = do-    dflags <- getDynFlags--    when (wopt Opt_WarnUnsafe dflags)-         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $-             mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))--    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)-    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other-    -- times inference may be on but we are in Trustworthy mode -- so we want-    -- to record safe-inference failed but not wipe the trust dependencies.-    case not (safeHaskellModeEnabled dflags) of-      True  -> return $ tcg_env { tcg_imports = wiped_trust }-      False -> return tcg_env--  where-    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }-    pprMod        = ppr $ moduleName $ tcg_mod tcg_env-    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"-                         , text "Reason:"-                         , nest 4 $ (vcat $ badFlags df) $+$-                                    (vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$-                                    (vcat $ badInsts $ tcg_insts tcg_env)-                         ]-    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer-    badFlag df (str,loc,on,_)-        | on df     = [mkLocMessage SevOutput (loc df) $-                            text str <+> text "is not allowed in Safe Haskell"]-        | otherwise = []-    badInsts insts = concatMap badInst insts--    checkOverlap (NoOverlap _) = False-    checkOverlap _             = True--    badInst ins | checkOverlap (overlapMode (is_flag ins))-                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $-                      ppr (overlapMode $ is_flag ins) <+>-                      text "overlap mode isn't allowed in Safe Haskell"]-                | otherwise = []----- | Figure out the final correct safe haskell mode-hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode-hscGetSafeMode tcg_env = do-    dflags  <- getDynFlags-    liftIO $ finalSafeMode dflags tcg_env------------------------------------------------------------------- Simplifiers-----------------------------------------------------------------hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts-hscSimplify hsc_env plugins modguts =-    runHsc hsc_env $ hscSimplify' plugins modguts--hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts-hscSimplify' plugins ds_result = do-    hsc_env <- getHscEnv-    let hsc_env_with_plugins = hsc_env-          { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins-          }-    {-# SCC "Core2Core" #-}-      liftIO $ core2core hsc_env_with_plugins ds_result------------------------------------------------------------------- Interface generators------------------------------------------------------------------- | Generate a striped down interface file, e.g. for boot files or when ghci--- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]-hscSimpleIface :: HscEnv-               -> TcGblEnv-               -> Maybe Fingerprint-               -> IO (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface hsc_env tc_result mb_old_iface-    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface--hscSimpleIface' :: TcGblEnv-                -> Maybe Fingerprint-                -> Hsc (ModIface, Maybe Fingerprint, ModDetails)-hscSimpleIface' tc_result mb_old_iface = do-    hsc_env   <- getHscEnv-    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result-    safe_mode <- hscGetSafeMode tc_result-    new_iface-        <- {-# SCC "MkFinalIface" #-}-           liftIO $-               mkIfaceTc hsc_env safe_mode details tc_result-    -- And the answer is ...-    liftIO $ dumpIfaceStats hsc_env-    return (new_iface, mb_old_iface, details)------------------------------------------------------------------- BackEnd combinators----------------------------------------------------------------{--Note [Interface filename extensions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--ModLocation only contains the base names, however when generating dynamic files-the actual extension might differ from the default.--So we only load the base name from ModLocation and replace the actual extension-according to the information in DynFlags.--If we generate a interface file right after running the core pipeline we will-have set -dynamic-too and potentially generate both interface files at the same-time.--If we generate a interface file after running the backend then dynamic-too won't-be set, however then the extension will be contained in the dynflags instead so-things still work out fine.--}--hscWriteIface :: DynFlags -> ModIface -> Bool -> ModLocation -> IO ()-hscWriteIface dflags iface no_change mod_location = do-    -- mod_location only contains the base name, so we rebuild the-    -- correct file extension from the dynflags.-    let ifaceBaseFile = ml_hi_file mod_location-    unless no_change $-        let ifaceFile = buildIfName ifaceBaseFile (hiSuf dflags)-        in  {-# SCC "writeIface" #-}-            writeIface dflags ifaceFile iface-    whenGeneratingDynamicToo dflags $ do-        -- TODO: We should do a no_change check for the dynamic-        --       interface file too-        -- When we generate iface files after core-        let dynDflags = dynamicTooMkDynamicDynFlags dflags-            -- dynDflags will have set hiSuf correctly.-            dynIfaceFile = buildIfName ifaceBaseFile (hiSuf dynDflags)--        writeIface dynDflags dynIfaceFile iface-  where-    buildIfName :: String -> String -> String-    buildIfName baseName suffix-      | Just name <- outputHi dflags-      = name-      | otherwise-      = let with_hi = replaceExtension baseName suffix-        in  addBootSuffix_maybe (mi_boot iface) with_hi---- | Compile to hard-code.-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)-               -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts location output_filename = do-        let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                    -- From now on, we just use the bits we need.-                    cg_module   = this_mod,-                    cg_binds    = core_binds,-                    cg_tycons   = tycons,-                    cg_foreign  = foreign_stubs0,-                    cg_foreign_files = foreign_files,-                    cg_dep_pkgs = dependencies,-                    cg_hpc_info = hpc_info } = cgguts-            dflags = hsc_dflags hsc_env-            data_tycons = filter isDataTyCon tycons-            -- cg_tycons includes newtypes, for the benefit of External Core,-            -- but we don't generate any code for newtypes--        --------------------        -- PREPARE FOR CODE GENERATION-        -- Do saturation and convert to A-normal form-        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}-                       corePrepPgm hsc_env this_mod location-                                   core_binds data_tycons-        -----------------  Convert to STG -------------------        (stg_binds, (caf_ccs, caf_cc_stacks))-            <- {-# SCC "CoreToStg" #-}-               myCoreToStg dflags this_mod prepd_binds--        let cost_centre_info =-              (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)-            prof_init-               | sccProfilingEnabled dflags = profilingInitCode this_mod cost_centre_info-               | otherwise = empty-            foreign_stubs = foreign_stubs0 `appendStubC` prof_init--        ------------------  Code generation --------------------        -- The back-end is streamed: each top-level function goes-        -- from Stg all the way to asm before dealing with the next-        -- top-level function, so showPass isn't very useful here.-        -- Hence we have one showPass for the whole backend, the-        -- next showPass after this will be "Assembler".-        withTiming dflags-                   (text "CodeGen"<+>brackets (ppr this_mod))-                   (const ()) $ do-            cmms <- {-# SCC "StgToCmm" #-}-                            doCodeGen hsc_env this_mod data_tycons-                                cost_centre_info-                                stg_binds hpc_info--            ------------------  Code output ------------------------            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}-                      lookupHook (\x -> cmmToRawCmmHook x)-                        (\dflg _ -> cmmToRawCmm dflg) dflags dflags (Just this_mod) cmms--            let dump a = do-                  unless (null a) $-                    dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (ppr a)-                  return a-                rawcmms1 = Stream.mapM dump rawcmms0--            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)-                <- {-# SCC "codeOutput" #-}-                  codeOutput dflags this_mod output_filename location-                  foreign_stubs foreign_files dependencies rawcmms1-            return (output_filename, stub_c_exists, foreign_fps, cg_infos)---hscInteractive :: HscEnv-               -> CgGuts-               -> ModLocation-               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])-hscInteractive hsc_env cgguts location = do-    let dflags = hsc_dflags hsc_env-    let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                -- From now on, we just use the bits we need.-               cg_module   = this_mod,-               cg_binds    = core_binds,-               cg_tycons   = tycons,-               cg_foreign  = foreign_stubs,-               cg_modBreaks = mod_breaks,-               cg_spt_entries = spt_entries } = cgguts--        data_tycons = filter isDataTyCon tycons-        -- cg_tycons includes newtypes, for the benefit of External Core,-        -- but we don't generate any code for newtypes--    --------------------    -- PREPARE FOR CODE GENERATION-    -- Do saturation and convert to A-normal form-    (prepd_binds, _) <- {-# SCC "CorePrep" #-}-                   corePrepPgm hsc_env this_mod location core_binds data_tycons-    -----------------  Generate byte code -------------------    comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks-    ------------------ Create f-x-dynamic C-side stuff ------    (_istub_h_exists, istub_c_exists)-        <- outputForeignStubs dflags this_mod location foreign_stubs-    return (istub_c_exists, comp_bc, spt_entries)----------------------------------hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()-hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do-    let dflags = hsc_dflags hsc_env-    cmm <- ioMsgMaybe $ parseCmmFile dflags filename-    liftIO $ do-        dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (ppr 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-            cmm_mod = mkHomeModule dflags mod_name--        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering-        -- them in SRT analysis.-        ---        -- Re-ordering here causes breakage when booting with C backend because-        -- in C we must declare before use, but SRT algorithm is free to-        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]-        cmmgroup <--          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm--        unless (null cmmgroup) $-          dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm"-            FormatCMM (ppr cmmgroup)-        rawCmms <- lookupHook (\x -> cmmToRawCmmHook x)-                     (\dflgs _ -> cmmToRawCmm dflgs) dflags dflags Nothing (Stream.yield cmmgroup)-        _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []-             rawCmms-        return ()-  where-    no_loc = ModLocation{ ml_hs_file  = Just filename,-                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",-                          ml_obj_file = panic "hscCompileCmmFile: no obj file",-                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}---------------------- Stuff for new code gen -----------------------{--Note [Forcing of stg_binds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~--The two last steps in the STG pipeline are:--* Sorting the bindings in dependency order.-* Annotating them with free variables.--We want to make sure we do not keep references to unannotated STG bindings-alive, nor references to bindings which have already been compiled to Cmm.--We explicitly force the bindings to avoid this.--This reduces residency towards the end of the CodeGen phase significantly-(5-10%).--}--doCodeGen   :: HscEnv -> Module -> [TyCon]-            -> CollectedCCs-            -> [StgTopBinding]-            -> HpcInfo-            -> IO (Stream IO CmmGroupSRTs CgInfos)-         -- Note we produce a 'Stream' of CmmGroups, so that the-         -- backend can be run incrementally.  Otherwise it generates all-         -- the C-- up front, which has a significant space cost.-doCodeGen hsc_env this_mod data_tycons-              cost_centre_info stg_binds hpc_info = do-    let dflags = hsc_dflags hsc_env--    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds--    dumpIfSet_dyn dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)--    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos-        -- See Note [Forcing of stg_binds]-        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}-            lookupHook stgToCmmHook StgToCmm.codeGen dflags dflags this_mod data_tycons-                           cost_centre_info stg_binds_w_fvs hpc_info--        -- codegen consumes a stream of CmmGroup, and produces a new-        -- stream of CmmGroup (not necessarily synchronised: one-        -- CmmGroup on input may produce many CmmGroups on output due-        -- to proc-point splitting).--    let dump1 a = do-          unless (null a) $-            dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg-              "Cmm produced by codegen" FormatCMM (ppr a)-          return a--        ppr_stream1 = Stream.mapM dump1 cmm_stream--        pipeline_stream :: Stream IO CmmGroupSRTs CgInfos-        pipeline_stream = do-          (non_cafs, lf_infos) <--            {-# SCC "cmmPipeline" #-}-            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1-              <&> first (srtMapNonCAFs . moduleSRTMap)--          return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos }--        dump2 a = do-          unless (null a) $-            dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (ppr a)-          return a--    return (Stream.mapM dump2 pipeline_stream)--myCoreToStg :: DynFlags -> Module -> CoreProgram-            -> IO ( [StgTopBinding] -- output program-                  , CollectedCCs )  -- CAF cost centre info (declared and used)-myCoreToStg dflags this_mod prepd_binds = do-    let (stg_binds, cost_centre_info)-         = {-# SCC "Core2Stg" #-}-           coreToStg dflags this_mod prepd_binds--    stg_binds2-        <- {-# SCC "Stg2Stg" #-}-           stg2stg dflags this_mod stg_binds--    return (stg_binds2, cost_centre_info)---{- **********************************************************************-%*                                                                      *-\subsection{Compiling a do-statement}-%*                                                                      *-%********************************************************************* -}--{--When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When-you run it you get a list of HValues that should be the same length as the list-of names; add them to the ClosureEnv.--A naked expression returns a singleton Name [it]. The stmt is lifted into the-IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types--}---- | Compile a stmt all the way to an HValue, but don't run it------ We return Nothing to indicate an empty statement (or comment only), not a--- parse error.-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))-hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1---- | Compile a stmt all the way to an HValue, but don't run it------ We return Nothing to indicate an empty statement (or comment only), not a--- parse error.-hscStmtWithLocation :: HscEnv-                    -> String -- ^ The statement-                    -> String -- ^ The source-                    -> Int    -- ^ Starting line-                    -> IO ( Maybe ([Id]-                          , ForeignHValue {- IO [HValue] -}-                          , FixityEnv))-hscStmtWithLocation hsc_env0 stmt source linenumber =-  runInteractiveHsc hsc_env0 $ do-    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt-    case maybe_stmt of-      Nothing -> return Nothing--      Just parsed_stmt -> do-        hsc_env <- getHscEnv-        liftIO $ hscParsedStmt hsc_env parsed_stmt--hscParsedStmt :: HscEnv-              -> GhciLStmt GhcPs  -- ^ The parsed statement-              -> IO ( Maybe ([Id]-                    , ForeignHValue {- IO [HValue] -}-                    , FixityEnv))-hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do-  -- Rename and typecheck it-  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt--  -- Desugar it-  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr-  liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)-  handleWarnings--  -- Then code-gen, and link it-  -- It's important NOT to have package 'interactive' as thisUnitId-  -- for linking, else we try to link 'main' and can't find it.-  -- Whereas the linker already knows to ignore 'interactive'-  let src_span = srcLocSpan interactiveSrcLoc-  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr--  return $ Just (ids, hval, fix_env)---- | Compile a decls-hscDecls :: HscEnv-         -> String -- ^ The statement-         -> IO ([TyThing], InteractiveContext)-hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1--hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]-hscParseDeclsWithLocation hsc_env source line_num str = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source line_num parseModule str-    return decls---- | Compile a decls-hscDeclsWithLocation :: HscEnv-                     -> String -- ^ The statement-                     -> String -- ^ The source-                     -> Int    -- ^ Starting line-                     -> IO ([TyThing], InteractiveContext)-hscDeclsWithLocation hsc_env str source linenumber = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source linenumber parseModule str-    hscParsedDecls hsc_env decls--hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)-hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do-    {- Rename and typecheck it -}-    hsc_env <- getHscEnv-    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls--    {- Grab the new instances -}-    -- We grab the whole environment because of the overlapping that may have-    -- been done. See the notes at the definition of InteractiveContext-    -- (ic_instances) for more details.-    let defaults = tcg_default tc_gblenv--    {- Desugar it -}-    -- We use a basically null location for iNTERACTIVE-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",-                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }-    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv--    {- Simplify -}-    simpl_mg <- liftIO $ do-      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)-      hscSimplify hsc_env plugins ds_result--    {- Tidy -}-    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg--    let !CgGuts{ cg_module    = this_mod,-                 cg_binds     = core_binds,-                 cg_tycons    = tycons,-                 cg_modBreaks = mod_breaks } = tidy_cg--        !ModDetails { md_insts     = cls_insts-                    , md_fam_insts = fam_insts } = mod_details-            -- Get the *tidied* cls_insts and fam_insts--        data_tycons = filter isDataTyCon tycons--    {- Prepare For Code Generation -}-    -- Do saturation and convert to A-normal form-    (prepd_binds, _) <- {-# SCC "CorePrep" #-}-      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons--    {- Generate byte code -}-    cbc <- liftIO $ byteCodeGen hsc_env this_mod-                                prepd_binds data_tycons mod_breaks--    let src_span = srcLocSpan interactiveSrcLoc-    liftIO $ linkDecls hsc_env src_span cbc--    {- Load static pointer table entries -}-    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)--    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)-        patsyns = mg_patsyns simpl_mg--        ext_ids = [ id | id <- bindersOfBinds core_binds-                       , isExternalName (idName id)-                       , not (isDFunId id || isImplicitId id) ]-            -- We only need to keep around the external bindings-            -- (as decided by GHC.Iface.Tidy), since those are the only ones-            -- that might later be looked up by name.  But we can exclude-            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Driver.Types-            --    - Implicit Ids, which are implicit in tcs-            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv--        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns-        ictxt        = hsc_IC hsc_env-        -- See Note [Fixity declarations in GHCi]-        fix_env      = tcg_fix_env tc_gblenv-        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts-                                                fam_insts defaults fix_env-    return (new_tythings, new_ictxt)---- | Load the given static-pointer table entries into the interpreter.--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()-hscAddSptEntries hsc_env entries = do-    let add_spt_entry :: SptEntry -> IO ()-        add_spt_entry (SptEntry i fpr) = do-            val <- getHValue hsc_env (idName i)-            addSptEntry hsc_env fpr val-    mapM_ add_spt_entry entries--{--  Note [Fixity declarations in GHCi]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--  To support fixity declarations on types defined within GHCi (as requested-  in #10018) we record the fixity environment in InteractiveContext.-  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this-  fixity environment and uses it to initialize the global typechecker environment.-  After the typechecker has finished its business, an updated fixity environment-  (reflecting whatever fixity declarations were present in the statements we-  passed it) will be returned from hscParsedStmt. This is passed to-  updateFixityEnv, which will stuff it back into InteractiveContext, to be-  used in evaluating the next statement.---}--hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)-hscImport hsc_env str = runInteractiveHsc hsc_env $ do-    (L _ (HsModule{hsmodImports=is})) <--       hscParseThing parseModule str-    case is of-        [L _ i] -> return i-        _ -> liftIO $ throwOneError $-                 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $-                     text "parse error in import declaration"---- | Typecheck an expression (but don't run it)-hscTcExpr :: HscEnv-          -> TcRnExprMode-          -> String -- ^ The expression-          -> IO Type-hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  parsed_expr <- hscParseExpr expr-  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr---- | Find the kind of a type, after generalisation-hscKcType-  :: HscEnv-  -> Bool            -- ^ Normalise the type-  -> String          -- ^ The type as a string-  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind-hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do-    hsc_env <- getHscEnv-    ty <- hscParseType str-    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty--hscParseExpr :: String -> Hsc (LHsExpr GhcPs)-hscParseExpr expr = do-  hsc_env <- getHscEnv-  maybe_stmt <- hscParseStmt expr-  case maybe_stmt of-    Just (L _ (BodyStmt _ expr _ _)) -> return expr-    _ -> throwOneError $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan-      (text "not an expression:" <+> quotes (text expr))--hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmt = hscParseThing parseStmt--hscParseStmtWithLocation :: String -> Int -> String-                         -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmtWithLocation source linenumber stmt =-    hscParseThingWithLocation source linenumber parseStmt stmt--hscParseType :: String -> Hsc (LHsType GhcPs)-hscParseType = hscParseThing parseType--hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)-hscParseIdentifier hsc_env str =-    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str--hscParseThing :: (Outputable thing, Data thing)-              => Lexer.P thing -> String -> Hsc thing-hscParseThing = hscParseThingWithLocation "<interactive>" 1--hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int-                          -> Lexer.P thing -> String -> Hsc thing-hscParseThingWithLocation source linenumber parser str-  = withTimingD-               (text "Parser [source]")-               (const ()) $ {-# SCC "Parser" #-} do-    dflags <- getDynFlags--    let buf = stringToStringBuffer str-        loc = mkRealSrcLoc (fsLit source) linenumber 1--    case unP parser (mkPState dflags buf loc) of-        PFailed pst -> do-            handleWarningsThrowErrors (getMessages pst dflags)--        POk pst thing -> do-            logWarningsReportErrors (getMessages pst dflags)-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser"-                        FormatHaskell (ppr thing)-            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST"-                        FormatHaskell (showAstData NoBlankSrcSpan thing)-            return thing---{- **********************************************************************-%*                                                                      *-        Desugar, simplify, convert to bytecode, and link an expression-%*                                                                      *-%********************************************************************* -}--hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue-hscCompileCoreExpr hsc_env =-  lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env--hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue-hscCompileCoreExpr' hsc_env srcspan ds_expr-    = do { {- Simplify it -}-           simpl_expr <- simplifyExpr hsc_env ds_expr--           {- Tidy it (temporary, until coreSat does cloning) -}-         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr--           {- Prepare for codegen -}-         ; prepd_expr <- corePrepExpr hsc_env tidy_expr--           {- Lint if necessary -}-         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr--           {- Convert to BCOs -}-         ; bcos <- coreExprToBCOs hsc_env-                     (icInteractiveModule (hsc_IC hsc_env)) prepd_expr--           {- link it -}-         ; hval <- linkExpr hsc_env srcspan bcos--         ; return hval }---{- **********************************************************************-%*                                                                      *-        Statistics on reading interfaces-%*                                                                      *-%********************************************************************* -}--dumpIfaceStats :: HscEnv -> IO ()-dumpIfaceStats hsc_env = do-    eps <- readIORef (hsc_EPS hsc_env)-    dumpIfSet dflags (dump_if_trace || dump_rn_stats)-              "Interface statistics"-              (ifaceStats eps)-  where-    dflags = hsc_dflags hsc_env-    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags-    dump_if_trace = dopt Opt_D_dump_if_trace dflags---{- **********************************************************************-%*                                                                      *-        Progress Messages: Module i of n-%*                                                                      *-%********************************************************************* -}--showModuleIndex :: (Int, Int) -> String-showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "-  where-    n_str = show n-    i_str = show i-    padded = replicate (length n_str - length i_str) ' ' ++ i_str+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE BangPatterns             #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE LambdaCase               #-}+{-# LANGUAGE ViewPatterns             #-}+{-# OPTIONS_GHC -fprof-auto-top #-}++-------------------------------------------------------------------------------+--+-- | Main API for compiling plain Haskell source code.+--+-- This module implements compilation of a Haskell source. It is+-- /not/ concerned with preprocessing of source files; this is handled+-- in "GHC.Driver.Pipeline"+--+-- There are various entry points depending on what mode we're in:+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and+-- "interactive" mode (GHCi). There are also entry points for+-- individual passes: parsing, typechecking/renaming, desugaring, and+-- simplification.+--+-- All the functions here take an 'HscEnv' as a parameter, but none of+-- them return a new one: 'HscEnv' is treated as an immutable value+-- from here on in (although it has mutable components, for the+-- caches).+--+-- We use the Hsc monad to deal with warning messages consistently:+-- specifically, while executing within an Hsc monad, warnings are+-- collected. When a Hsc monad returns to an IO monad, the+-- warnings are printed, or compilation aborts if the @-Werror@+-- flag is enabled.+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000+--+-------------------------------------------------------------------------------++module GHC.Driver.Main+    (+    -- * Making an HscEnv+      newHscEnv++    -- * Compiling complete source files+    , Messager, batchMsg+    , HscStatus (..)+    , hscIncrementalCompile+    , hscMaybeWriteIface+    , hscCompileCmmFile++    , hscGenHardCode+    , hscInteractive++    -- * Running passes separately+    , hscParse+    , hscTypecheckRename+    , hscDesugar+    , makeSimpleDetails+    , hscSimplify -- ToDo, shouldn't really export this++    -- * Safe Haskell+    , hscCheckSafe+    , hscGetSafe++    -- * Support for interactive evaluation+    , hscParseIdentifier+    , hscTcRcLookupName+    , hscTcRnGetInfo+    , hscIsGHCiMonad+    , hscGetModuleInterface+    , hscRnImportDecls+    , hscTcRnLookupRdrName+    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt+    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType+    , hscParseExpr+    , hscParseType+    , hscCompileCoreExpr+    -- * Low-level exports for hooks+    , hscCompileCoreExpr'+      -- We want to make sure that we export enough to be able to redefine+      -- hsc_typecheck in client code+    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen+    , getHscEnv+    , hscSimpleIface'+    , oneShotMsg+    , dumpIfaceStats+    , ioMsgMaybe+    , showModuleIndex+    , hscAddSptEntries+    ) where++import GHC.Prelude++import GHC.Driver.Plugins+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.CodeOutput+import GHC.Driver.Config+import GHC.Driver.Hooks++import GHC.Runtime.Context+import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )+import GHC.Runtime.Loader      ( initializePlugins )+import GHCi.RemoteTypes        ( ForeignHValue )+import GHC.ByteCode.Types++import GHC.Linker.Loader+import GHC.Linker.Types++import GHC.Hs+import GHC.Hs.Dump+import GHC.Hs.Stats         ( ppSourceStats )++import GHC.HsToCore++import GHC.StgToByteCode    ( byteCodeGen )++import GHC.IfaceToCore  ( typecheckIface )++import GHC.Iface.Load   ( ifaceStats, initExternalPackageState, writeIface )+import GHC.Iface.Make+import GHC.Iface.Recomp+import GHC.Iface.Tidy+import GHC.Iface.Ext.Ast    ( mkHieFile )+import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result, NameCacheUpdater(..))+import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )+import GHC.Iface.Env        ( updNameCache )++import GHC.Core+import GHC.Core.Tidy           ( tidyExpr )+import GHC.Core.Type           ( Type, Kind )+import GHC.Core.Lint           ( lintInteractiveExpr )+import GHC.Core.Multiplicity+import GHC.Core.Utils          ( exprType )+import GHC.Core.ConLike+import GHC.Core.Opt.Pipeline+import GHC.Core.TyCon+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv++import GHC.CoreToStg.Prep+import GHC.CoreToStg    ( coreToStg )++import GHC.Parser.Errors+import GHC.Parser.Errors.Ppr+import GHC.Parser+import GHC.Parser.Lexer as Lexer++import GHC.Tc.Module+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )++import GHC.Stg.Syntax+import GHC.Stg.FVs      ( annTopBindingsFreeVars )+import GHC.Stg.Pipeline ( stg2stg )++import GHC.Builtin.Utils+import GHC.Builtin.Names+import GHC.Builtin.Uniques ( mkPseudoUniqueE )++import qualified GHC.StgToCmm as StgToCmm ( codeGen )+import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)++import GHC.Cmm+import GHC.Cmm.Parser       ( parseCmmFile )+import GHC.Cmm.Info.Build+import GHC.Cmm.Pipeline+import GHC.Cmm.Info++import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Status+import GHC.Unit.Home.ModInfo++import GHC.Types.Id+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.ForeignStubs+import GHC.Types.Var.Env       ( emptyTidyEnv )+import GHC.Types.Error+import GHC.Types.Fixity.Env+import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.Unique.Supply+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Cache ( initNameCache )+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.HpcInfo++import GHC.Utils.Fingerprint ( Fingerprint )+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Exception+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Data.FastString+import GHC.Data.Bag+import GHC.Data.StringBuffer+import qualified GHC.Data.Stream as Stream+import GHC.Data.Stream (Stream)++import Data.Data hiding (Fixity, TyCon)+import Data.List        ( nub, isPrefixOf, partition )+import Control.Monad+import Data.IORef+import System.FilePath as FilePath+import System.Directory+import System.IO (fixIO)+import qualified Data.Set as S+import Data.Set (Set)+import Data.Functor+import Control.DeepSeq (force)+import Data.Bifunctor (first, bimap)+import GHC.Data.Maybe++#include "HsVersions.h"+++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: DynFlags -> IO HscEnv+newHscEnv dflags = do+    -- we don't store the unit databases and the unit state to still+    -- allow `setSessionDynFlags` to be used to set unit db flags.+    eps_var <- newIORef initExternalPackageState+    us      <- mkSplitUniqSupply 'r'+    nc_var  <- newIORef (initNameCache us knownKeyNames)+    fc_var  <- newIORef emptyInstalledModuleEnv+    logger  <- initLogger+    tmpfs   <- initTmpFs+    -- FIXME: it's sad that we have so many "unitialized" fields filled with+    -- empty stuff or lazy panics. We should have two kinds of HscEnv+    -- (initialized or not) instead and less fields that are mutable over time.+    return HscEnv {  hsc_dflags         = dflags+                  ,  hsc_logger         = logger+                  ,  hsc_targets        = []+                  ,  hsc_mod_graph      = emptyMG+                  ,  hsc_IC             = emptyInteractiveContext dflags+                  ,  hsc_HPT            = emptyHomePackageTable+                  ,  hsc_EPS            = eps_var+                  ,  hsc_NC             = nc_var+                  ,  hsc_FC             = fc_var+                  ,  hsc_type_env_var   = Nothing+                  ,  hsc_interp         = Nothing+                  ,  hsc_unit_env       = panic "hsc_unit_env not initialized"+                  ,  hsc_plugins        = []+                  ,  hsc_static_plugins = []+                  ,  hsc_unit_dbs       = Nothing+                  ,  hsc_hooks          = emptyHooks+                  ,  hsc_tmpfs          = tmpfs+                  }++-- -----------------------------------------------------------------------------++getWarnings :: Hsc WarningMessages+getWarnings = Hsc $ \_ w -> return (w, w)++clearWarnings :: Hsc ()+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)++logWarnings :: WarningMessages -> Hsc ()+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)++getHscEnv :: Hsc HscEnv+getHscEnv = Hsc $ \e w -> return (e, w)++handleWarnings :: Hsc ()+handleWarnings = do+    dflags <- getDynFlags+    logger <- getLogger+    w <- getWarnings+    liftIO $ printOrThrowWarnings logger dflags w+    clearWarnings++-- | log warning in the monad, and if there are errors then+-- throw a SourceError exception.+logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()+logWarningsReportErrors (warnings,errors) = do+    let warns = fmap pprWarning warnings+        errs  = fmap pprError   errors+    logWarnings warns+    when (not $ isEmptyBag errs) $ throwErrors errs++-- | Log warnings and throw errors, assuming the messages+-- contain at least one error (e.g. coming from PFailed)+handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a+handleWarningsThrowErrors (warnings, errors) = do+    let warns = fmap pprWarning warnings+        errs  = fmap pprError   errors+    logWarnings warns+    dflags <- getDynFlags+    logger <- getLogger+    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings+    liftIO $ printBagOfErrors logger dflags wWarns+    throwErrors (unionBags errs wErrs)++-- | Deal with errors and warnings returned by a compilation step+--+-- In order to reduce dependencies to other parts of the compiler, functions+-- outside the "main" parts of GHC return warnings and errors as a parameter+-- and signal success via by wrapping the result in a 'Maybe' type. This+-- function logs the returned warnings and propagates errors as exceptions+-- (of type 'SourceError').+--+-- This function assumes the following invariants:+--+--  1. If the second result indicates success (is of the form 'Just x'),+--     there must be no error messages in the first result.+--+--  2. If there are no error messages, but the second result indicates failure+--     there should be warnings in the first result. That is, if the action+--     failed, it must have been due to the warnings (i.e., @-Werror@).+ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+    (msgs, mb_r) <- liftIO ioA+    let (warns, errs) = partitionMessages msgs+    logWarnings warns+    case mb_r of+        Nothing -> throwErrors errs+        Just r  -> ASSERT( isEmptyBag errs ) return r++-- | like ioMsgMaybe, except that we ignore error messages and return+-- 'Nothing' instead.+ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' ioA = do+    (msgs, mb_r) <- liftIO $ ioA+    logWarnings (getWarningMessages msgs)+    return mb_r++-- -----------------------------------------------------------------------------+-- | Lookup things in the compiler's environment++hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }++hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe' $ tcRnLookupName hsc_env name+      -- ignore errors: the only error we're likely to get is+      -- "name not found", and the Maybe in the return type+      -- is used to indicate that.++hscTcRnGetInfo :: HscEnv -> Name+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))+hscTcRnGetInfo hsc_env0 name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }++hscIsGHCiMonad :: HscEnv -> String -> IO Name+hscIsGHCiMonad hsc_env name+  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name++hscGetModuleInterface :: HscEnv -> Module -> IO ModIface+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ getModuleInterface hsc_env mod++-- -----------------------------------------------------------------------------+-- | Rename some import declarations+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls++-- -----------------------------------------------------------------------------+-- | parse a file, returning the abstract syntax++hscParse :: HscEnv -> ModSummary -> IO HsParsedModule+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary++-- internal version, that doesn't fail due to -Werror+hscParse' :: ModSummary -> Hsc HsParsedModule+hscParse' mod_summary+ | Just r <- ms_parsed_mod mod_summary = return r+ | otherwise = do+    dflags <- getDynFlags+    logger <- getLogger+    {-# SCC "Parser" #-} withTiming logger dflags+                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+                (const ()) $ do+    let src_filename  = ms_hspp_file mod_summary+        maybe_src_buf = ms_hspp_buf  mod_summary++    --------------------------  Parser  ----------------+    -- sometimes we already have the buffer in memory, perhaps+    -- because we needed to parse the imports out of it, or get the+    -- module name.+    buf <- case maybe_src_buf of+               Just b  -> return b+               Nothing -> liftIO $ hGetStringBuffer src_filename++    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1+    let parseMod | HsigFile == ms_hsc_src mod_summary+                 = parseSignature+                 | otherwise = parseModule++    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of+        PFailed pst ->+            handleWarningsThrowErrors (getMessages pst)+        POk pst rdr_module -> do+            let (warns, errs) = bimap (fmap pprWarning) (fmap pprError) (getMessages pst)+            logWarnings warns+            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"+                        FormatHaskell (ppr rdr_module)+            liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"+                        FormatHaskell (showAstData NoBlankSrcSpan+                                                   NoBlankEpAnnotations+                                                   rdr_module)+            liftIO $ dumpIfSet_dyn logger dflags Opt_D_source_stats "Source Statistics"+                        FormatText (ppSourceStats False rdr_module)+            when (not $ isEmptyBag errs) $ throwErrors errs++            -- To get the list of extra source files, we take the list+            -- that the parser gave us,+            --   - eliminate files beginning with '<'.  gcc likes to use+            --     pseudo-filenames like "<built-in>" and "<command-line>"+            --   - normalise them (eliminate differences between ./f and f)+            --   - filter out the preprocessed source file+            --   - filter out anything beginning with tmpdir+            --   - remove duplicates+            --   - filter out the .hs/.lhs source filename if we have one+            --+            let n_hspp  = FilePath.normalise src_filename+                srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))+                            $ filter (not . (== n_hspp))+                            $ map FilePath.normalise+                            $ filter (not . isPrefixOf "<")+                            $ map unpackFS+                            $ srcfiles pst+                srcs1 = case ml_hs_file (ms_location mod_summary) of+                          Just f  -> filter (/= FilePath.normalise f) srcs0+                          Nothing -> srcs0++            -- sometimes we see source files from earlier+            -- preprocessing stages that cannot be found, so just+            -- filter them out:+            srcs2 <- liftIO $ filterM doesFileExist srcs1++            let res = HsParsedModule {+                      hpm_module    = rdr_module,+                      hpm_src_files = srcs2+                   }++            -- apply parse transformation of plugins+            let applyPluginAction p opts+                  = parsedResultAction p opts mod_summary+            hsc_env <- getHscEnv+            withPlugins hsc_env applyPluginAction res+++-- -----------------------------------------------------------------------------+-- | If the renamed source has been kept, extract it. Dump it if requested.+extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff+extract_renamed_stuff mod_summary tc_result = do+    let rn_info = getRenamedStuff tc_result++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)++    -- Create HIE files+    when (gopt Opt_WriteHie dflags) $ do+        -- I assume this fromJust is safe because `-fwrite-hie-file`+        -- enables the option which keeps the renamed source.+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)+        let out_file = ml_hie_file $ ms_location mod_summary+        liftIO $ writeHieFile out_file hieFile+        liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)++        -- Validate HIE files+        when (gopt Opt_ValidateHie dflags) $ do+            hs_env <- Hsc $ \e w -> return (e, w)+            liftIO $ do+              -- Validate Scopes+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of+                  [] -> putMsg logger dflags $ text "Got valid scopes"+                  xs -> do+                    putMsg logger dflags $ text "Got invalid scopes"+                    mapM_ (putMsg logger dflags) xs+              -- Roundtrip testing+              file' <- readHieFile (NCU $ updNameCache $ hsc_NC hs_env) out_file+              case diffFile hieFile (hie_file_result file') of+                [] ->+                  putMsg logger dflags $ text "Got no roundtrip errors"+                xs -> do+                  putMsg logger dflags $ text "Got roundtrip errors"+                  mapM_ (putMsg logger (dopt_set dflags Opt_D_ppr_debug)) xs+    return rn_info+++-- -----------------------------------------------------------------------------+-- | Rename and typecheck a module, additionally returning the renamed syntax+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO (TcGblEnv, RenamedStuff)+hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $+    hsc_typecheck True mod_summary (Just rdr_module)+++-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack+-- b) concerning dumping rename info and hie files. It would be nice to further+-- separate this stuff out, probably in conjunction better separating renaming+-- and type checking (#17781).+hsc_typecheck :: Bool -- ^ Keep renamed source?+              -> ModSummary -> Maybe HsParsedModule+              -> Hsc (TcGblEnv, RenamedStuff)+hsc_typecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkHomeModule home_unit mod_name+        inner_mod = homeModuleNameInstantiation home_unit mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn+    MASSERT( isHomeModule home_unit outer_mod )+    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing -> hscParse' mod_summary+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm+            if hsc_src == HsigFile+                then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing+                        ioMsgMaybe $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0+    -- TODO are we extracting anything when we merely instantiate a signature?+    -- If not, try to move this into the "else" case above.+    rn_info <- extract_renamed_stuff mod_summary tc_result+    return (tc_result, rn_info)++-- wrapper around tcRnModule to handle safe haskell extras+tcRnModule' :: ModSummary -> Bool -> HsParsedModule+            -> Hsc TcGblEnv+tcRnModule' sum save_rn_syntax mod = do+    hsc_env <- getHscEnv+    dflags   <- getDynFlags++    -- -Wmissing-safe-haskell-mode+    when (not (safeHaskellModeEnabled dflags)+          && wopt Opt_WarnMissingSafeHaskellMode dflags) $+        logWarnings $ unitBag $+        makeIntoWarning (Reason Opt_WarnMissingSafeHaskellMode) $+        mkPlainWarnMsg (getLoc (hpm_module mod)) $+        warnMissingSafeHaskellMode++    tcg_res <- {-# SCC "Typecheck-Rename" #-}+               ioMsgMaybe $+                   tcRnModule hsc_env sum+                     save_rn_syntax mod++    -- See Note [Safe Haskell Overlapping Instances Implementation]+    -- although this is used for more than just that failure case.+    (tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)+    let allSafeOK = safeInferred dflags && tcSafeOK++    -- end of the safe haskell line, how to respond to user?+    if not (safeHaskellOn dflags)+         || (safeInferOn dflags && not allSafeOK)+      -- if safe Haskell off or safe infer failed, mark unsafe+      then markUnsafeInfer tcg_res whyUnsafe++      -- module (could be) safe, throw warning if needed+      else do+          tcg_res' <- hscCheckSafeImports tcg_res+          safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')+          when safe $+            case wopt Opt_WarnSafe dflags of+              True+                | safeHaskell dflags == Sf_Safe -> return ()+                | otherwise -> (logWarnings $ unitBag $+                       makeIntoWarning (Reason Opt_WarnSafe) $+                       mkPlainWarnMsg (warnSafeOnLoc dflags) $+                       errSafe tcg_res')+              False | safeHaskell dflags == Sf_Trustworthy &&+                      wopt Opt_WarnTrustworthySafe dflags ->+                      (logWarnings $ unitBag $+                       makeIntoWarning (Reason Opt_WarnTrustworthySafe) $+                       mkPlainWarnMsg (trustworthyOnLoc dflags) $+                       errTwthySafe tcg_res')+              False -> return ()+          return tcg_res'+  where+    pprMod t  = ppr $ moduleName $ tcg_mod t+    errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"+    errTwthySafe t = quotes (pprMod t)+      <+> text "is marked as Trustworthy but has been inferred as safe!"+    warnMissingSafeHaskellMode = ppr (moduleName (ms_mod sum))+      <+> text "is missing Safe Haskell mode"++-- | Convert a typechecked module to Core+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts+hscDesugar hsc_env mod_summary tc_result =+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result++hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts+hscDesugar' mod_location tc_result = do+    hsc_env <- getHscEnv+    r <- ioMsgMaybe $+      {-# SCC "deSugar" #-}+      deSugar hsc_env mod_location tc_result++    -- always check -Werror after desugaring, this is the last opportunity for+    -- warnings to arise before the backend.+    handleWarnings+    return r++-- | Make a 'ModDetails' from the results of typechecking. Used when+-- typechecking only, as opposed to full compilation.+makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails+makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result+++{- **********************************************************************+%*                                                                      *+                The main compiler pipeline+%*                                                                      *+%********************************************************************* -}++{-+                   --------------------------------+                        The compilation proper+                   --------------------------------++It's the task of the compilation proper to compile Haskell, hs-boot and core+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all+(the module is still parsed and type-checked. This feature is mostly used by+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode+targets byte-code.++The modes are kept separate because of their different types and meanings:++ * In 'one-shot' mode, we're only compiling a single file and can therefore+ discard the new ModIface and ModDetails. This is also the reason it only+ targets hard-code; compiling to byte-code or nothing doesn't make sense when+ we discard the result.++ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to+ return the newly compiled byte-code.++ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still+ kept separate. This is because compiling to nothing is fairly special: We+ don't output any interface files, we don't run the simplifier and we don't+ generate any code.++ * 'Interactive' mode is similar to 'batch' mode except that we return the+ compiled byte-code together with the ModIface and ModDetails.++Trying to compile a hs-boot file to byte-code will result in a run-time error.+This is the only thing that isn't caught by the type-system.+-}+++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()++-- | This function runs GHC's frontend with recompilation+-- avoidance. Specifically, it checks if recompilation is needed,+-- and if it is, it parses and typechecks the input module.+-- It does not write out the results of typechecking (See+-- compileOne and hscIncrementalCompile).+hscIncrementalFrontend :: Bool -- always do basic recompilation check?+                       -> Maybe TcGblEnv+                       -> Maybe Messager+                       -> ModSummary+                       -> SourceModified+                       -> Maybe ModIface  -- Old interface, if available+                       -> (Int,Int)       -- (i,n) = module i of n (for msgs)+                       -> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))++hscIncrementalFrontend+  always_do_basic_recompilation_check m_tc_result+  mHscMessage mod_summary source_modified mb_old_iface mod_index+    = do+    hsc_env <- getHscEnv++    let msg what = case mHscMessage of+          -- We use extendModSummaryNoDeps because extra backpack deps are only needed for batch mode+          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode (extendModSummaryNoDeps mod_summary))+          Nothing -> return ()++        skip iface = do+            liftIO $ msg UpToDate+            return $ Left iface++        compile mb_old_hash reason = do+            liftIO $ msg reason+            tc_result <- case hscFrontendHook (hsc_hooks hsc_env) of+              Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False mod_summary Nothing+              Just h  -> h mod_summary+            return $ Right (tc_result, mb_old_hash)++        stable = case source_modified of+                     SourceUnmodifiedAndStable -> True+                     _                         -> False++    case m_tc_result of+         Just tc_result+          | not always_do_basic_recompilation_check ->+             return $ Right (FrontendTypecheck tc_result, Nothing)+         _ -> do+            (recomp_reqd, mb_checked_iface)+                <- {-# SCC "checkOldIface" #-}+                   liftIO $ checkOldIface hsc_env mod_summary+                                source_modified mb_old_iface+            -- save the interface that comes back from checkOldIface.+            -- In one-shot mode we don't have the old iface until this+            -- point, when checkOldIface reads it from the disk.+            let mb_old_hash = fmap (mi_iface_hash . mi_final_exts) mb_checked_iface++            case mb_checked_iface of+                Just iface | not (recompileRequired recomp_reqd) ->+                    -- If the module used TH splices when it was last+                    -- compiled, then the recompilation check is not+                    -- accurate enough (#481) and we must ignore+                    -- it.  However, if the module is stable (none of+                    -- the modules it depends on, directly or+                    -- indirectly, changed), then we *can* skip+                    -- recompilation. This is why the SourceModified+                    -- type contains SourceUnmodifiedAndStable, and+                    -- it's pretty important: otherwise ghc --make+                    -- would always recompile TH modules, even if+                    -- nothing at all has changed. Stability is just+                    -- the same check that make is doing for us in+                    -- one-shot mode.+                    case m_tc_result of+                    Nothing+                     | mi_used_th iface && not stable ->+                        compile mb_old_hash (RecompBecause "TH")+                    _ ->+                        skip iface+                _ ->+                    case m_tc_result of+                    Nothing -> compile mb_old_hash recomp_reqd+                    Just tc_result ->+                        return $ Right (FrontendTypecheck tc_result, mb_old_hash)++--------------------------------------------------------------+-- Compilers+--------------------------------------------------------------++-- | Used by both OneShot and batch mode. Runs the pipeline HsSyn and Core parts+-- of the pipeline.+-- We return a interface if we already had an old one around and recompilation+-- was not needed. Otherwise it will be created during later passes when we+-- run the compilation pipeline.+hscIncrementalCompile :: Bool+                      -> Maybe TcGblEnv+                      -> Maybe Messager+                      -> HscEnv+                      -> ModSummary+                      -> SourceModified+                      -> Maybe ModIface+                      -> (Int,Int)+                      -> IO (HscStatus, HscEnv)+hscIncrementalCompile always_do_basic_recompilation_check m_tc_result+    mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index+  = do+    hsc_env'' <- initializePlugins hsc_env'++    -- One-shot mode needs a knot-tying mutable variable for interface+    -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.+    -- See also Note [hsc_type_env_var hack]+    type_env_var <- newIORef emptyNameEnv+    let mod = ms_mod mod_summary+        hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))+                = hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }+                | otherwise+                = hsc_env''++    -- NB: enter Hsc monad here so that we don't bail out early with+    -- -Werror on typechecker warnings; we also want to run the desugarer+    -- to get those warnings too. (But we'll always exit at that point+    -- because the desugarer runs ioMsgMaybe.)+    runHsc hsc_env $ do+    e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage+            mod_summary source_modified mb_old_iface mod_index+    case e of+        -- We didn't need to do any typechecking; the old interface+        -- file on disk was good enough.+        Left iface -> do+            -- Knot tying!  See Note [Knot-tying typecheckIface]+            details <- liftIO . fixIO $ \details' -> do+                let hsc_env' =+                        hsc_env {+                            hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                        (ms_mod_name mod_summary) (HomeModInfo iface details' Nothing)+                        }+                -- NB: This result is actually not that useful+                -- in one-shot mode, since we're not going to do+                -- any further typechecking.  It's much more useful+                -- in make mode, since this HMI will go into the HPT.+                genModDetails hsc_env' iface+            return (HscUpToDate iface details, hsc_env')+        -- We finished type checking.  (mb_old_hash is the hash of+        -- the interface that existed on disk; it's possible we had+        -- to retypecheck but the resulting interface is exactly+        -- the same.)+        Right (FrontendTypecheck tc_result, mb_old_hash) -> do+            status <- finish mod_summary tc_result mb_old_hash+            return (status, hsc_env)++-- Runs the post-typechecking frontend (desugar and simplify). We want to+-- generate most of the interface as late as possible. This gets us up-to-date+-- and good unfoldings and other info in the interface file.+--+-- We might create a interface right away, in which case we also return the+-- updated HomeModInfo. But we might also need to run the backend first. In the+-- later case Status will be HscRecomp and we return a function from ModIface ->+-- HomeModInfo.+--+-- HscRecomp in turn will carry the information required to compute a interface+-- when passed the result of the code generator. So all this can and is done at+-- the call site of the backend code gen if it is run.+finish :: ModSummary+       -> TcGblEnv+       -> Maybe Fingerprint+       -> Hsc HscStatus+finish summary tc_result mb_old_hash = do+  hsc_env <- getHscEnv+  dflags <- getDynFlags+  logger <- getLogger+  let bcknd  = backend dflags+      hsc_src = ms_hsc_src summary++  -- Desugar, if appropriate+  --+  -- We usually desugar even when we are not generating code, otherwise we+  -- would miss errors thrown by the desugaring (see #10600). The only+  -- exceptions are when the Module is Ghc.Prim or when it is not a+  -- HsSrcFile Module.+  mb_desugar <-+      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile+      then Just <$> hscDesugar' (ms_location summary) tc_result+      else pure Nothing++  -- Simplify, if appropriate, and (whether we simplified or not) generate an+  -- interface file.+  case mb_desugar of+      -- Just cause we desugared doesn't mean we are generating code, see above.+      Just desugared_guts | bcknd /= NoBackend -> do+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          simplified_guts <- hscSimplify' plugins desugared_guts++          (cg_guts, details) <- {-# SCC "CoreTidy" #-}+              liftIO $ tidyProgram hsc_env simplified_guts++          let !partial_iface =+                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}+                -- This `force` saves 2M residency in test T10370+                -- See Note [Avoiding space leaks in toIface*] for details.+                force (mkPartialIface hsc_env details simplified_guts)++          return HscRecomp { hscs_guts = cg_guts,+                             hscs_mod_location = ms_location summary,+                             hscs_mod_details = details,+                             hscs_partial_iface = partial_iface,+                             hscs_old_iface_hash = mb_old_hash+                           }++      -- We are not generating code, so we can skip simplification+      -- and generate a simple interface.+      _ -> do+        (iface, mb_old_iface_hash, details) <- liftIO $+          hscSimpleIface hsc_env tc_result mb_old_hash++        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_iface_hash (ms_location summary)++        return $ case bcknd of+          NoBackend -> HscNotGeneratingCode iface details+          _         -> case hsc_src of+                        HsBootFile -> HscUpdateBoot iface details+                        HsigFile   -> HscUpdateSig iface details+                        _          -> panic "finish"++{-+Note [Writing interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We write one interface file per module and per compilation, except with+-dynamic-too where we write two interface files (non-dynamic and dynamic).++We can write two kinds of interfaces (see Note [Interface file stages] in+"GHC.Driver.Types"):++   * simple interface: interface generated after the core pipeline++   * full interface: simple interface completed with information from the+     backend++Depending on the situation, we write one or the other (using+`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the+backend is run twice, so if we write a simple interface we need to write both+the non-dynamic and the dynamic interfaces at the same time (with the same+contents).++Cases for which we generate simple interfaces:++   * GHC.Driver.Main.finish: when a compilation does NOT require (re)compilation+   of the hard code++   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target+   bytecode (if interface writing is forced).++   * GHC.Driver.Backpack uses simple interfaces for indefinite units+   (units with module holes). It writes them indirectly by forcing the+   -fwrite-interface flag while setting backend to NoBackend.++Cases for which we generate full interfaces:++   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard+   code and/or require recompilation.++By default interface file names are derived from module file names by adding+suffixes. The interface file name can be overloaded with "-ohi", except when+`-dynamic-too` is used.++-}++-- | Write interface files+hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprint -> ModLocation -> IO ()+hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do+    let force_write_interface = gopt Opt_WriteInterface dflags+        write_interface = case backend dflags of+                            NoBackend    -> False+                            Interpreter  -> False+                            _            -> True++      -- mod_location only contains the base name, so we rebuild the+      -- correct file extension from the dynflags.+        baseName = ml_hi_file mod_location+        buildIfName suffix is_dynamic+          | Just name <- (if is_dynamic then dynOutputHi else outputHi) dflags+          = name+          | otherwise+          = let with_hi = replaceExtension baseName suffix+            in  addBootSuffix_maybe (mi_boot iface) with_hi++        write_iface dflags' iface =+          let !iface_name = buildIfName (hiSuf dflags') (dynamicNow dflags')+          in+          {-# SCC "writeIface" #-}+          withTiming logger dflags'+              (text "WriteIface"<+>brackets (text iface_name))+              (const ())+              (writeIface logger dflags' iface_name iface)++    when (write_interface || force_write_interface) $ do++      -- FIXME: with -dynamic-too, "no_change" is only meaningful for the+      -- non-dynamic interface, not for the dynamic one. We should have another+      -- flag for the dynamic interface. In the meantime:+      --+      --    * when we write a single full interface, we check if we are+      --    currently writing the dynamic interface due to -dynamic-too, in+      --    which case we ignore "no_change".+      --+      --    * when we write two simple interfaces at once because of+      --    dynamic-too, we use "no_change" both for the non-dynamic and the+      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic+      --    interfaces stay in sync...+      --+      let no_change = old_iface == Just (mi_iface_hash (mi_final_exts iface))++      dt <- dynamicTooState dflags++      when (dopt Opt_D_dump_if_trace dflags) $ putMsg logger dflags $+        hang (text "Writing interface(s):") 2 $ vcat+         [ text "Kind:" <+> if is_simple then text "simple" else text "full"+         , text "Hash change:" <+> ppr (not no_change)+         , text "DynamicToo state:" <+> text (show dt)+         ]++      if is_simple+         then unless no_change $ do -- FIXME: see no_change' comment above+            write_iface dflags iface+            case dt of+               DT_Dont   -> return ()+               DT_Failed -> return ()+               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"+               DT_OK     -> write_iface (setDynamicNow dflags) iface+         else case dt of+               DT_Dont | not no_change             -> write_iface dflags iface+               DT_OK   | not no_change             -> write_iface dflags iface+               -- FIXME: see no_change' comment above+               DT_Dyn                              -> write_iface dflags iface+               DT_Failed | not (dynamicNow dflags) -> write_iface dflags iface+               _                                   -> return ()++--------------------------------------------------------------+-- NoRecomp handlers+--------------------------------------------------------------++-- NB: this must be knot-tied appropriately, see hscIncrementalCompile+genModDetails :: HscEnv -> ModIface -> IO ModDetails+genModDetails hsc_env old_iface+  = do+    new_details <- {-# SCC "tcRnIface" #-}+                   initIfaceLoad hsc_env (typecheckIface old_iface)+    dumpIfaceStats hsc_env+    return new_details++--------------------------------------------------------------+-- Progress displayers.+--------------------------------------------------------------++oneShotMsg :: HscEnv -> RecompileRequired -> IO ()+oneShotMsg hsc_env recomp =+    case recomp of+        UpToDate ->+            compilationProgressMsg logger dflags $+                   text "compilation IS NOT required"+        _ ->+            return ()+    where+        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env++batchMsg :: Messager+batchMsg hsc_env mod_index recomp node = case node of+    InstantiationNode _ ->+        case recomp of+            MustCompile -> showMsg (text "Instantiating ") empty+            UpToDate+                | verbosity dflags >= 2 -> showMsg (text "Skipping  ") empty+                | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Instantiating ") (text " [" <> text reason <> text "]")+    ModuleNode _ ->+        case recomp of+            MustCompile -> showMsg (text "Compiling ") empty+            UpToDate+                | verbosity dflags >= 2 -> showMsg (text "Skipping  ") empty+                | otherwise -> return ()+            RecompBecause reason -> showMsg (text "Compiling ") (text " [" <> text reason <> text "]")+    where+        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        showMsg msg reason =+            compilationProgressMsg logger dflags $+            (showModuleIndex mod_index <>+            msg <> showModMsg dflags (recompileRequired recomp) node)+                <> reason++--------------------------------------------------------------+-- Safe Haskell+--------------------------------------------------------------++-- Note [Safe Haskell Trust Check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell checks that an import is trusted according to the following+-- rules for an import of module M that resides in Package P:+--+--   * If M is recorded as Safe and all its trust dependencies are OK+--     then M is considered safe.+--   * If M is recorded as Trustworthy and P is considered trusted and+--     all M's trust dependencies are OK then M is considered safe.+--+-- By trust dependencies we mean that the check is transitive. So if+-- a module M that is Safe relies on a module N that is trustworthy,+-- importing module M will first check (according to the second case)+-- that N is trusted before checking M is trusted.+--+-- This is a minimal description, so please refer to the user guide+-- for more details. The user guide is also considered the authoritative+-- source in this matter, not the comments or code.+++-- Note [Safe Haskell Inference]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell does Safe inference on modules that don't have any specific+-- safe haskell mode flag. The basic approach to this is:+--   * When deciding if we need to do a Safe language check, treat+--     an unmarked module as having -XSafe mode specified.+--   * For checks, don't throw errors but return them to the caller.+--   * Caller checks if there are errors:+--     * For modules explicitly marked -XSafe, we throw the errors.+--     * For unmarked modules (inference mode), we drop the errors+--       and mark the module as being Unsafe.+--+-- It used to be that we only did safe inference on modules that had no Safe+-- Haskell flags, but now we perform safe inference on all modules as we want+-- to allow users to set the `-Wsafe`, `-Wunsafe` and+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a+-- user can ensure their assumptions are correct and see reasons for why a+-- module is safe or unsafe.+--+-- This is tricky as we must be careful when we should throw an error compared+-- to just warnings. For checking safe imports we manage it as two steps. First+-- we check any imports that are required to be safe, then we check all other+-- imports to see if we can infer them to be safe.+++-- | Check that the safe imports of the module being compiled are valid.+-- If not we either issue a compilation error if the module is explicitly+-- using Safe Haskell, or mark the module as unsafe if we're in safe+-- inference mode.+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv+hscCheckSafeImports tcg_env = do+    dflags   <- getDynFlags+    tcg_env' <- checkSafeImports tcg_env+    checkRULES dflags tcg_env'++  where+    checkRULES dflags tcg_env' =+      case safeLanguageOn dflags of+          True -> do+              -- XSafe: we nuke user written RULES+              logWarnings $ warns (tcg_rules tcg_env')+              return tcg_env' { tcg_rules = [] }+          False+                -- SafeInferred: user defined RULES, so not safe+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')+              -> markUnsafeInfer tcg_env' $ warns (tcg_rules tcg_env')++                -- Trustworthy OR SafeInferred: with no RULES+              | otherwise+              -> return tcg_env'++    warns rules = listToBag $ map warnRules rules++    warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc+    warnRules (L loc (HsRule { rd_name = n })) =+        mkPlainWarnMsg (locA loc) $+            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$+            text "User defined rules are disabled under Safe Haskell"++-- | Validate that safe imported modules are actually safe.  For modules in the+-- HomePackage (the package the module we are compiling in resides) this just+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules+-- that reside in another package we also must check that the external package+-- is trusted. See the Note [Safe Haskell Trust Check] above for more+-- information.+--+-- The code for this is quite tricky as the whole algorithm is done in a few+-- distinct phases in different parts of the code base. See+-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a+-- module are collected and unioned.  Specifically see the Note [Tracking Trust+-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in+-- "GHC.Rename.Names".+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv+checkSafeImports tcg_env+    = do+        dflags <- getDynFlags+        imps <- mapM condense imports'+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps++        -- We want to use the warning state specifically for detecting if safe+        -- inference has failed, so store and clear any existing warnings.+        oldErrs <- getWarnings+        clearWarnings++        -- Check safe imports are correct+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps+        safeErrs <- getWarnings+        clearWarnings++        -- Check non-safe imports are correct if inferring safety+        -- See the Note [Safe Haskell Inference]+        (infErrs, infPkgs) <- case (safeInferOn dflags) of+          False -> return (emptyBag, S.empty)+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps+                     infErrs <- getWarnings+                     clearWarnings+                     return (infErrs, infPkgs)++        -- restore old errors+        logWarnings oldErrs++        case (isEmptyBag safeErrs) of+          -- Failed safe check+          False -> liftIO . throwIO . mkSrcErr $ safeErrs++          -- Passed safe check+          True -> do+            let infPassed = isEmptyBag infErrs+            tcg_env' <- case (not infPassed) of+              True  -> markUnsafeInfer tcg_env infErrs+              False -> return tcg_env+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }++  where+    impInfo  = tcg_imports tcg_env     -- ImportAvails+    imports  = imp_mods impInfo        -- ImportedMods+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])+    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]++    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)+    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"+    condense (m, x:xs) = do imv <- foldlM cond' x xs+                            return (m, imv_span imv, imv_is_safe imv)++    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal+    cond' v1 v2+        | imv_is_safe v1 /= imv_is_safe v2+        = throwOneError $ mkPlainMsgEnvelope (imv_span v1)+              (text "Module" <+> ppr (imv_name v1) <+>+              (text $ "is imported both as a safe and unsafe import!"))+        | otherwise+        = return v1++    -- easier interface to work with+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l++    -- what pkg's to add to our trust requirements+    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->+          Bool -> ImportAvails+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags+                                  && not (safeHaskellModeEnabled dflags) && infPassed+                                   = emptyImportAvails {+                                       imp_trust_pkgs = req `S.union` inf+                                   }+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe+                         = emptyImportAvails+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }++-- | Check that a module is safe to import.+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an exception may be thrown first.+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool+hscCheckSafe hsc_env m l = runHsc hsc_env $ do+    dflags <- getDynFlags+    pkgs <- snd `fmap` hscCheckSafe' m l+    when (packageTrustOn dflags) $ checkPkgTrust pkgs+    errs <- getWarnings+    return $ isEmptyBag errs++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)+hscGetSafe hsc_env m l = runHsc hsc_env $ do+    (self, pkgs) <- hscCheckSafe' m l+    good         <- isEmptyBag `fmap` getWarnings+    clearWarnings -- don't want them printed...+    let pkgs' | Just p <- self = S.insert p pkgs+              | otherwise      = pkgs+    return (good, pkgs')++-- | Is a module trusted? If not, throw or log errors depending on the type.+-- Return (regardless of trusted or not) if the trust type requires the modules+-- own package be trusted and a list of other packages required to be trusted+-- (these later ones haven't been checked) but the own package trust has been.+hscCheckSafe' :: Module -> SrcSpan+  -> Hsc (Maybe UnitId, Set UnitId)+hscCheckSafe' m l = do+    hsc_env <- getHscEnv+    let home_unit = hsc_home_unit hsc_env+    (tw, pkgs) <- isModSafe home_unit m l+    case tw of+        False                           -> return (Nothing, pkgs)+        True | isHomeModule home_unit m -> return (Nothing, pkgs)+             -- TODO: do we also have to check the trust of the instantiation?+             -- Not necessary if that is reflected in dependencies+             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)+  where+    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)+    isModSafe home_unit m l = do+        hsc_env <- getHscEnv+        dflags <- getDynFlags+        iface <- lookup' m+        case iface of+            -- can't load iface to check trust!+            Nothing -> throwOneError $ mkPlainMsgEnvelope l+                         $ text "Can't load the interface file for" <+> ppr m+                           <> text ", to check that it can be safely imported"++            -- got iface, check trust+            Just iface' ->+                let trust = getSafeMode $ mi_trust iface'+                    trust_own_pkg = mi_trust_pkg iface'+                    -- check module is trusted+                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]+                    -- check package is trusted+                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m+                    -- pkg trust reqs+                    pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'+                    -- warn if Safe module imports Safe-Inferred module.+                    warns = if wopt Opt_WarnInferredSafeImports dflags+                                && safeLanguageOn dflags+                                && trust == Sf_SafeInferred+                                then inferredImportWarn+                                else emptyBag+                    -- General errors we throw but Safe errors we log+                    errs = case (safeM, safeP) of+                        (True, True ) -> emptyBag+                        (True, False) -> pkgTrustErr+                        (False, _   ) -> modTrustErr+                in do+                    logWarnings warns+                    logWarnings errs+                    return (trust == Sf_Trustworthy, pkgRs)++                where+                    state = hsc_units hsc_env+                    inferredImportWarn = unitBag+                        $ makeIntoWarning (Reason Opt_WarnInferredSafeImports)+                        $ mkWarnMsg l (pkgQual state)+                        $ sep+                            [ text "Importing Safe-Inferred module "+                                <> ppr (moduleName m)+                                <> text " from explicitly Safe module"+                            ]+                    pkgTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $+                        sep [ ppr (moduleName m)+                                <> text ": Can't be safely imported!"+                            , text "The package ("+                                <> (pprWithUnitState state $ ppr (moduleUnit m))+                                <> text ") the module resides in isn't trusted."+                            ]+                    modTrustErr = unitBag $ mkMsgEnvelope l (pkgQual state) $+                        sep [ ppr (moduleName m)+                                <> text ": Can't be safely imported!"+                            , text "The module itself isn't safe." ]++    -- | Check the package a module resides in is trusted. Safe compiled+    -- modules are trusted without requiring that their package is trusted. For+    -- trustworthy modules, modules in the home package are trusted but+    -- otherwise we check the package trust flag.+    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool+    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =+        case safe_mode of+            Sf_None      -> False -- shouldn't hit these cases+            Sf_Ignore    -> False -- shouldn't hit these cases+            Sf_Unsafe    -> False -- prefer for completeness.+            _ | not (packageTrustOn dflags)     -> True+            Sf_Safe | not trust_own_pkg         -> True+            Sf_SafeInferred | not trust_own_pkg -> True+            _ | isHomeModule home_unit mod      -> True+            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)++    lookup' :: Module -> Hsc (Maybe ModIface)+    lookup' m = do+        hsc_env <- getHscEnv+        hsc_eps <- liftIO $ hscEPS hsc_env+        let pkgIfaceT = eps_PIT hsc_eps+            homePkgT  = hsc_HPT hsc_env+            iface     = lookupIfaceByModule homePkgT pkgIfaceT m+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi+        -- as the compiler hasn't filled in the various module tables+        -- so we need to call 'getModuleInterface' to load from disk+        case iface of+            Just _  -> return iface+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)+++-- | Check the list of packages are trusted.+checkPkgTrust :: Set UnitId -> Hsc ()+checkPkgTrust pkgs = do+    hsc_env <- getHscEnv+    let errors = S.foldr go [] pkgs+        state  = hsc_units hsc_env+        go pkg acc+            | unitIsTrusted $ unsafeLookupUnitId state pkg+            = acc+            | otherwise+            = (:acc) $ mkMsgEnvelope noSrcSpan (pkgQual state)+                     $ pprWithUnitState state+                     $ text "The package ("+                        <> ppr pkg+                        <> text ") is required to be trusted but it isn't!"+    case errors of+        [] -> return ()+        _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors++-- | Set module to unsafe and (potentially) wipe trust information.+--+-- Make sure to call this method to set a module to inferred unsafe, it should+-- be a central and single failure method. We only wipe the trust information+-- when we aren't in a specific Safe Haskell mode.+--+-- While we only use this for recording that a module was inferred unsafe, we+-- may call it on modules using Trustworthy or Unsafe flags so as to allow+-- warning flags for safety to function correctly. See Note [Safe Haskell+-- Inference].+markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv+markUnsafeInfer tcg_env whyUnsafe = do+    dflags <- getDynFlags++    when (wopt Opt_WarnUnsafe dflags)+         (logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $+             mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))++    liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)+    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other+    -- times inference may be on but we are in Trustworthy mode -- so we want+    -- to record safe-inference failed but not wipe the trust dependencies.+    case not (safeHaskellModeEnabled dflags) of+      True  -> return $ tcg_env { tcg_imports = wiped_trust }+      False -> return tcg_env++  where+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env+    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"+                         , text "Reason:"+                         , nest 4 $ (vcat $ badFlags df) $+$+                                    (vcat $ pprMsgEnvelopeBagWithLoc whyUnsafe) $+$+                                    (vcat $ badInsts $ tcg_insts tcg_env)+                         ]+    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer+    badFlag df (str,loc,on,_)+        | on df     = [mkLocMessage SevOutput (loc df) $+                            text str <+> text "is not allowed in Safe Haskell"]+        | otherwise = []+    badInsts insts = concatMap badInst insts++    checkOverlap (NoOverlap _) = False+    checkOverlap _             = True++    badInst ins | checkOverlap (overlapMode (is_flag ins))+                = [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $+                      ppr (overlapMode $ is_flag ins) <+>+                      text "overlap mode isn't allowed in Safe Haskell"]+                | otherwise = []+++-- | Figure out the final correct safe haskell mode+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode+hscGetSafeMode tcg_env = do+    dflags  <- getDynFlags+    liftIO $ finalSafeMode dflags tcg_env++--------------------------------------------------------------+-- Simplifiers+--------------------------------------------------------------++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts+hscSimplify hsc_env plugins modguts =+    runHsc hsc_env $ hscSimplify' plugins modguts++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts+hscSimplify' plugins ds_result = do+    hsc_env <- getHscEnv+    hsc_env_with_plugins <- if null plugins -- fast path+        then return hsc_env+        else liftIO $ initializePlugins $ hsc_env+                { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins+                }+    {-# SCC "Core2Core" #-}+      liftIO $ core2core hsc_env_with_plugins ds_result++--------------------------------------------------------------+-- Interface generators+--------------------------------------------------------------++-- | Generate a striped down interface file, e.g. for boot files or when ghci+-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]+hscSimpleIface :: HscEnv+               -> TcGblEnv+               -> Maybe Fingerprint+               -> IO (ModIface, Maybe Fingerprint, ModDetails)+hscSimpleIface hsc_env tc_result mb_old_iface+    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface++hscSimpleIface' :: TcGblEnv+                -> Maybe Fingerprint+                -> Hsc (ModIface, Maybe Fingerprint, ModDetails)+hscSimpleIface' tc_result mb_old_iface = do+    hsc_env   <- getHscEnv+    details   <- liftIO $ mkBootModDetailsTc hsc_env tc_result+    safe_mode <- hscGetSafeMode tc_result+    new_iface+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIfaceTc hsc_env safe_mode details tc_result+    -- And the answer is ...+    liftIO $ dumpIfaceStats hsc_env+    return (new_iface, mb_old_iface, details)++--------------------------------------------------------------+-- BackEnd combinators+--------------------------------------------------------------++-- | Compile to hard-code.+hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)+               -- ^ @Just f@ <=> _stub.c is f+hscGenHardCode hsc_env cgguts location output_filename = do+        let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                    -- From now on, we just use the bits we need.+                    cg_module   = this_mod,+                    cg_binds    = core_binds,+                    cg_tycons   = tycons,+                    cg_foreign  = foreign_stubs0,+                    cg_foreign_files = foreign_files,+                    cg_dep_pkgs = dependencies,+                    cg_hpc_info = hpc_info } = cgguts+            dflags = hsc_dflags hsc_env+            logger = hsc_logger hsc_env+            hooks  = hsc_hooks hsc_env+            tmpfs  = hsc_tmpfs hsc_env+            data_tycons = filter isDataTyCon tycons+            -- cg_tycons includes newtypes, for the benefit of External Core,+            -- but we don't generate any code for newtypes++        -------------------+        -- PREPARE FOR CODE GENERATION+        -- Do saturation and convert to A-normal form+        (prepd_binds, local_ccs) <- {-# SCC "CorePrep" #-}+                       corePrepPgm hsc_env this_mod location+                                   core_binds data_tycons++        -----------------  Convert to STG ------------------+        (stg_binds, denv, (caf_ccs, caf_cc_stacks))+            <- {-# SCC "CoreToStg" #-}+               withTiming logger dflags+                   (text "CoreToStg"<+>brackets (ppr this_mod))+                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())+                   (myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds)++        let cost_centre_info =+              (S.toList local_ccs ++ caf_ccs, caf_cc_stacks)+            platform = targetPlatform dflags+            prof_init+              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info+              | otherwise = mempty++        ------------------  Code generation ------------------+        -- The back-end is streamed: each top-level function goes+        -- from Stg all the way to asm before dealing with the next+        -- top-level function, so showPass isn't very useful here.+        -- Hence we have one showPass for the whole backend, the+        -- next showPass after this will be "Assembler".+        withTiming logger dflags+                   (text "CodeGen"<+>brackets (ppr this_mod))+                   (const ()) $ do+            cmms <- {-# SCC "StgToCmm" #-}+                            doCodeGen hsc_env this_mod denv data_tycons+                                cost_centre_info+                                stg_binds hpc_info++            ------------------  Code output -----------------------+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}+                        case cmmToRawCmmHook hooks of+                            Nothing -> cmmToRawCmm logger dflags cmms+                            Just h  -> h dflags (Just this_mod) cmms++            let dump a = do+                  unless (null a) $+                    dumpIfSet_dyn logger dflags Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+                  return a+                rawcmms1 = Stream.mapM dump rawcmms0++            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init+                                                  `appendStubC` cgIPEStub st++            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)+                <- {-# SCC "codeOutput" #-}+                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location+                  foreign_stubs foreign_files dependencies rawcmms1+            return (output_filename, stub_c_exists, foreign_fps, cg_infos)+++hscInteractive :: HscEnv+               -> CgGuts+               -> ModLocation+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])+hscInteractive hsc_env cgguts location = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let tmpfs  = hsc_tmpfs hsc_env+    let CgGuts{ -- This is the last use of the ModGuts in a compilation.+                -- From now on, we just use the bits we need.+               cg_module   = this_mod,+               cg_binds    = core_binds,+               cg_tycons   = tycons,+               cg_foreign  = foreign_stubs,+               cg_modBreaks = mod_breaks,+               cg_spt_entries = spt_entries } = cgguts++        data_tycons = filter isDataTyCon tycons+        -- cg_tycons includes newtypes, for the benefit of External Core,+        -- but we don't generate any code for newtypes++    -------------------+    -- PREPARE FOR CODE GENERATION+    -- Do saturation and convert to A-normal form+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}+                   corePrepPgm hsc_env this_mod location core_binds data_tycons++    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+      <- {-# SCC "CoreToStg" #-}+          myCoreToStg logger dflags (hsc_IC hsc_env) this_mod location prepd_binds+    -----------------  Generate byte code ------------------+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks+    ------------------ Create f-x-dynamic C-side stuff -----+    (_istub_h_exists, istub_c_exists)+        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs+    return (istub_c_exists, comp_bc, spt_entries)++------------------------------++hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)+hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do+    let dflags   = hsc_dflags hsc_env+    let logger   = hsc_logger hsc_env+    let hooks    = hsc_hooks hsc_env+    let tmpfs    = hsc_tmpfs hsc_env+        home_unit = hsc_home_unit hsc_env+        platform  = targetPlatform dflags+        -- 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+        cmm_mod = mkHomeModule home_unit mod_name+    (cmm, ents) <- ioMsgMaybe+               $ do+                  (warns,errs,cmm) <- withTiming logger dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())+                                       $ parseCmmFile dflags cmm_mod home_unit filename+                  return (mkMessages (fmap pprWarning warns `unionBags` fmap pprError errs), cmm)+    liftIO $ do+        dumpIfSet_dyn logger dflags Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)++        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering+        -- them in SRT analysis.+        --+        -- Re-ordering here causes breakage when booting with C backend because+        -- in C we must declare before use, but SRT algorithm is free to+        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]+        cmmgroup <-+          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm++        unless (null cmmgroup) $+          dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm"+            FormatCMM (pdoc platform cmmgroup)++        rawCmms <- case cmmToRawCmmHook hooks of+          Nothing -> cmmToRawCmm logger dflags         (Stream.yield cmmgroup)+          Just h  -> h                  dflags Nothing (Stream.yield cmmgroup)++        let foreign_stubs _ =+              let ip_init = ipInitCode dflags cmm_mod ents+              in NoStubs `appendStubC` ip_init++        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)+          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] []+             rawCmms+        return stub_c_exists+  where+    no_loc = ModLocation{ ml_hs_file  = Just filename,+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}++-------------------- Stuff for new code gen ---------------------++{-+Note [Forcing of stg_binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++The two last steps in the STG pipeline are:++* Sorting the bindings in dependency order.+* Annotating them with free variables.++We want to make sure we do not keep references to unannotated STG bindings+alive, nor references to bindings which have already been compiled to Cmm.++We explicitly force the bindings to avoid this.++This reduces residency towards the end of the CodeGen phase significantly+(5-10%).+-}++doCodeGen   :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+            -> CollectedCCs+            -> [StgTopBinding]+            -> HpcInfo+            -> IO (Stream IO CmmGroupSRTs CgInfos)+         -- Note we produce a 'Stream' of CmmGroups, so that the+         -- backend can be run incrementally.  Otherwise it generates all+         -- the C-- up front, which has a significant space cost.+doCodeGen hsc_env this_mod denv data_tycons+              cost_centre_info stg_binds hpc_info = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let hooks  = hsc_hooks hsc_env+    let tmpfs  = hsc_tmpfs hsc_env+    let platform = targetPlatform dflags++    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds++    dumpIfSet_dyn logger dflags Opt_D_dump_stg_final "Final STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_fvs)++    let stg_to_cmm = case stgToCmmHook hooks of+                        Nothing -> StgToCmm.codeGen logger tmpfs+                        Just h  -> h++    let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)+        -- See Note [Forcing of stg_binds]+        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}+            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info++        -- codegen consumes a stream of CmmGroup, and produces a new+        -- stream of CmmGroup (not necessarily synchronised: one+        -- CmmGroup on input may produce many CmmGroups on output due+        -- to proc-point splitting).++    let dump1 a = do+          unless (null a) $+            dumpIfSet_dyn logger dflags Opt_D_dump_cmm_from_stg+              "Cmm produced by codegen" FormatCMM (pdoc platform a)+          return a++        ppr_stream1 = Stream.mapM dump1 cmm_stream++        pipeline_stream :: Stream IO CmmGroupSRTs CgInfos+        pipeline_stream = do+          (non_cafs, (used_info, lf_infos)) <-+            {-# SCC "cmmPipeline" #-}+            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1+              <&> first (srtMapNonCAFs . moduleSRTMap)++          return CgInfos{ cgNonCafs = non_cafs, cgLFInfos = lf_infos, cgIPEStub = used_info }++        dump2 a = do+          unless (null a) $+            dumpIfSet_dyn logger dflags Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)+          return a++    return (Stream.mapM dump2 pipeline_stream)++myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext+                -> Module -> ModLocation -> CoreExpr+                -> IO ( Id+                      , [StgTopBinding]+                      , InfoTableProvMap+                      , CollectedCCs )+myCoreToStgExpr logger dflags ictxt this_mod ml prepd_expr = do+    {- Create a temporary binding (just because myCoreToStg needs a+       binding for the stg2stg step) -}+    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")+                                (mkPseudoUniqueE 0)+                                Many+                                (exprType prepd_expr)+    (stg_binds, prov_map, collected_ccs) <-+       myCoreToStg logger+                   dflags+                   ictxt+                   this_mod+                   ml+                   [NonRec bco_tmp_id prepd_expr]+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)++myCoreToStg :: Logger -> DynFlags -> InteractiveContext+            -> Module -> ModLocation -> CoreProgram+            -> IO ( [StgTopBinding] -- output program+                  , InfoTableProvMap+                  , CollectedCCs )  -- CAF cost centre info (declared and used)+myCoreToStg logger dflags ictxt this_mod ml prepd_binds = do+    let (stg_binds, denv, cost_centre_info)+         = {-# SCC "Core2Stg" #-}+           coreToStg dflags this_mod ml prepd_binds++    stg_binds2+        <- {-# SCC "Stg2Stg" #-}+           stg2stg logger dflags ictxt this_mod stg_binds++    return (stg_binds2, denv, cost_centre_info)++{- **********************************************************************+%*                                                                      *+\subsection{Compiling a do-statement}+%*                                                                      *+%********************************************************************* -}++{-+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When+you run it you get a list of HValues that should be the same length as the list+of names; add them to the ClosureEnv.++A naked expression returns a singleton Name [it]. The stmt is lifted into the+IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context+-}++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmtWithLocation :: HscEnv+                    -> String -- ^ The statement+                    -> String -- ^ The source+                    -> Int    -- ^ Starting line+                    -> IO ( Maybe ([Id]+                          , ForeignHValue {- IO [HValue] -}+                          , FixityEnv))+hscStmtWithLocation hsc_env0 stmt source linenumber =+  runInteractiveHsc hsc_env0 $ do+    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt+    case maybe_stmt of+      Nothing -> return Nothing++      Just parsed_stmt -> do+        hsc_env <- getHscEnv+        liftIO $ hscParsedStmt hsc_env parsed_stmt++hscParsedStmt :: HscEnv+              -> GhciLStmt GhcPs  -- ^ The parsed statement+              -> IO ( Maybe ([Id]+                    , ForeignHValue {- IO [HValue] -}+                    , FixityEnv))+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do+  -- Rename and typecheck it+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt++  -- Desugar it+  ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr+  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)+  handleWarnings++  -- Then code-gen, and link it+  -- It's important NOT to have package 'interactive' as thisUnitId+  -- for linking, else we try to link 'main' and can't find it.+  -- Whereas the linker already knows to ignore 'interactive'+  let src_span = srcLocSpan interactiveSrcLoc+  hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr++  return $ Just (ids, hval, fix_env)++-- | Compile a decls+hscDecls :: HscEnv+         -> String -- ^ The statement+         -> IO ([TyThing], InteractiveContext)+hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1++hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]+hscParseDeclsWithLocation hsc_env source line_num str = do+    L _ (HsModule{ hsmodDecls = decls }) <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source line_num parseModule str+    return decls++-- | Compile a decls+hscDeclsWithLocation :: HscEnv+                     -> String -- ^ The statement+                     -> String -- ^ The source+                     -> Int    -- ^ Starting line+                     -> IO ([TyThing], InteractiveContext)+hscDeclsWithLocation hsc_env str source linenumber = do+    L _ (HsModule{ hsmodDecls = decls }) <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source linenumber parseModule str+    hscParsedDecls hsc_env decls++hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)+hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do+    hsc_env <- getHscEnv+    let interp = hscInterp hsc_env++    {- Rename and typecheck it -}+    tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls++    {- Grab the new instances -}+    -- We grab the whole environment because of the overlapping that may have+    -- been done. See the notes at the definition of InteractiveContext+    -- (ic_instances) for more details.+    let defaults = tcg_default tc_gblenv++    {- Desugar it -}+    -- We use a basically null location for iNTERACTIVE+    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",+                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",+                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv++    {- Simplify -}+    simpl_mg <- liftIO $ do+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)+      hscSimplify hsc_env plugins ds_result++    {- Tidy -}+    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg++    let !CgGuts{ cg_module    = this_mod,+                 cg_binds     = core_binds,+                 cg_tycons    = tycons,+                 cg_modBreaks = mod_breaks } = tidy_cg++        !ModDetails { md_insts     = cls_insts+                    , md_fam_insts = fam_insts } = mod_details+            -- Get the *tidied* cls_insts and fam_insts++        data_tycons = filter isDataTyCon tycons++    {- Prepare For Code Generation -}+    -- Do saturation and convert to A-normal form+    (prepd_binds, _) <- {-# SCC "CorePrep" #-}+      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons++    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+        <- {-# SCC "CoreToStg" #-}+           liftIO $ myCoreToStg (hsc_logger hsc_env)+                                (hsc_dflags hsc_env)+                                (hsc_IC hsc_env)+                                this_mod+                                iNTERACTIVELoc+                                prepd_binds++    {- Generate byte code -}+    cbc <- liftIO $ byteCodeGen hsc_env this_mod+                                stg_binds data_tycons mod_breaks++    let src_span = srcLocSpan interactiveSrcLoc+    _ <- liftIO $ loadDecls interp hsc_env src_span cbc++    {- Load static pointer table entries -}+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)++    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)+        patsyns = mg_patsyns simpl_mg++        ext_ids = [ id | id <- bindersOfBinds core_binds+                       , isExternalName (idName id)+                       , not (isDFunId id || isImplicitId id) ]+            -- We only need to keep around the external bindings+            -- (as decided by GHC.Iface.Tidy), since those are the only ones+            -- that might later be looked up by name.  But we can exclude+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context+            --    - Implicit Ids, which are implicit in tcs+            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv++        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns+        ictxt        = hsc_IC hsc_env+        -- See Note [Fixity declarations in GHCi]+        fix_env      = tcg_fix_env tc_gblenv+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts+                                                fam_insts defaults fix_env+    return (new_tythings, new_ictxt)++-- | Load the given static-pointer table entries into the interpreter.+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do+    let interp = hscInterp hsc_env+    let add_spt_entry :: SptEntry -> IO ()+        add_spt_entry (SptEntry i fpr) = do+            val <- loadName interp hsc_env (idName i)+            addSptEntry interp fpr val+    mapM_ add_spt_entry entries++{-+  Note [Fixity declarations in GHCi]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  To support fixity declarations on types defined within GHCi (as requested+  in #10018) we record the fixity environment in InteractiveContext.+  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this+  fixity environment and uses it to initialize the global typechecker environment.+  After the typechecker has finished its business, an updated fixity environment+  (reflecting whatever fixity declarations were present in the statements we+  passed it) will be returned from hscParsedStmt. This is passed to+  updateFixityEnv, which will stuff it back into InteractiveContext, to be+  used in evaluating the next statement.++-}++hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)+hscImport hsc_env str = runInteractiveHsc hsc_env $ do+    (L _ (HsModule{hsmodImports=is})) <-+       hscParseThing parseModule str+    case is of+        [L _ i] -> return i+        _ -> liftIO $ throwOneError $+                 mkPlainMsgEnvelope noSrcSpan $+                     text "parse error in import declaration"++-- | Typecheck an expression (but don't run it)+hscTcExpr :: HscEnv+          -> TcRnExprMode+          -> String -- ^ The expression+          -> IO Type+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  parsed_expr <- hscParseExpr expr+  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr++-- | Find the kind of a type, after generalisation+hscKcType+  :: HscEnv+  -> Bool            -- ^ Normalise the type+  -> String          -- ^ The type as a string+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do+    hsc_env <- getHscEnv+    ty <- hscParseType str+    ioMsgMaybe $ tcRnType hsc_env DefaultFlexi normalise ty++hscParseExpr :: String -> Hsc (LHsExpr GhcPs)+hscParseExpr expr = do+  maybe_stmt <- hscParseStmt expr+  case maybe_stmt of+    Just (L _ (BodyStmt _ expr _ _)) -> return expr+    _ -> throwOneError $ mkPlainMsgEnvelope noSrcSpan+      (text "not an expression:" <+> quotes (text expr))++hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))+hscParseStmt = hscParseThing parseStmt++hscParseStmtWithLocation :: String -> Int -> String+                         -> Hsc (Maybe (GhciLStmt GhcPs))+hscParseStmtWithLocation source linenumber stmt =+    hscParseThingWithLocation source linenumber parseStmt stmt++hscParseType :: String -> Hsc (LHsType GhcPs)+hscParseType = hscParseThing parseType++hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)+hscParseIdentifier hsc_env str =+    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str++hscParseThing :: (Outputable thing, Data thing)+              => Lexer.P thing -> String -> Hsc thing+hscParseThing = hscParseThingWithLocation "<interactive>" 1++hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int+                          -> Lexer.P thing -> String -> Hsc thing+hscParseThingWithLocation source linenumber parser str = do+    dflags <- getDynFlags+    logger <- getLogger+    withTiming logger dflags+               (text "Parser [source]")+               (const ()) $ {-# SCC "Parser" #-} do++        let buf = stringToStringBuffer str+            loc = mkRealSrcLoc (fsLit source) linenumber 1++        case unP parser (initParserState (initParserOpts dflags) buf loc) of+            PFailed pst ->+                handleWarningsThrowErrors (getMessages pst)+            POk pst thing -> do+                logWarningsReportErrors (getMessages pst)+                liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed "Parser"+                            FormatHaskell (ppr thing)+                liftIO $ dumpIfSet_dyn logger dflags Opt_D_dump_parsed_ast "Parser AST"+                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)+                return thing+++{- **********************************************************************+%*                                                                      *+        Desugar, simplify, convert to bytecode, and link an expression+%*                                                                      *+%********************************************************************* -}++hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr hsc_env loc expr =+  case hscCompileCoreExprHook (hsc_hooks hsc_env) of+      Nothing -> hscCompileCoreExpr' hsc_env loc expr+      Just h  -> h                   hsc_env loc expr++hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr' hsc_env srcspan ds_expr+    = do { {- Simplify it -}+           -- Question: should we call SimpleOpt.simpleOptExpr here instead?+           -- It is, well, simpler, and does less inlining etc.+           simpl_expr <- simplifyExpr hsc_env ds_expr++           {- Tidy it (temporary, until coreSat does cloning) -}+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++           {- Prepare for codegen -}+         ; prepd_expr <- corePrepExpr hsc_env tidy_expr++           {- Lint if necessary -}+         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr+         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,+                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",+                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",+                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }++         ; let ictxt = hsc_IC hsc_env+         ; (binding_id, stg_expr, _, _) <-+             myCoreToStgExpr (hsc_logger hsc_env)+                             (hsc_dflags hsc_env)+                             ictxt+                             (icInteractiveModule ictxt)+                             iNTERACTIVELoc+                             prepd_expr++           {- Convert to BCOs -}+         ; bcos <- byteCodeGen hsc_env+                     (icInteractiveModule ictxt)+                     stg_expr+                     [] Nothing++           {- load it -}+         ; fv_hvs <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos+           {- Get the HValue for the root -}+         ; return (expectJust "hscCompileCoreExpr'"+              $ lookup (idName binding_id) fv_hvs) }+++{- **********************************************************************+%*                                                                      *+        Statistics on reading interfaces+%*                                                                      *+%********************************************************************* -}++dumpIfaceStats :: HscEnv -> IO ()+dumpIfaceStats hsc_env = do+    eps <- readIORef (hsc_EPS hsc_env)+    dumpIfSet logger dflags (dump_if_trace || dump_rn_stats)+              "Interface statistics"+              (ifaceStats eps)+  where+    dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env+    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags+    dump_if_trace = dopt Opt_D_dump_if_trace dflags+++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> SDoc+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "+  where+    -- compute the length of x > 0 in base 10+    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)+    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr

GHC/Driver/Make.hs view

@@ -1,2779 +1,2971 @@-{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 2011------ This module implements multi-module compilation, and is used--- by --make and GHCi.------ ------------------------------------------------------------------------------module GHC.Driver.Make (-        depanal, depanalE, depanalPartial,-        load, load', LoadHowMuch(..),--        downsweep,--        topSortModuleGraph,--        ms_home_srcimps, ms_home_imps,--        summariseModule,-        hscSourceToIsBoot,-        findExtraSigImports,-        implicitRequirements,--        noModError, cyclicModuleErr,-        moduleGraphNodes, SummaryNode,-        IsBootInterface(..)-    ) where--#include "HsVersions.h"--import GHC.Prelude--import qualified GHC.Runtime.Linker as Linker--import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Session-import GHC.Utils.Error-import GHC.Driver.Finder-import GHC.Driver.Monad-import GHC.Parser.Header-import GHC.Driver.Types-import GHC.Unit.Module-import GHC.IfaceToCore     ( typecheckIface )-import GHC.Tc.Utils.Monad  ( initIfaceCheck )-import GHC.Driver.Main--import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )-import GHC.Types.Basic-import GHC.Data.Graph.Directed-import GHC.Utils.Exception ( tryIO )-import GHC.Data.FastString-import GHC.Data.Maybe      ( expectJust )-import GHC.Types.Name-import GHC.Utils.Monad     ( allM )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Types.SrcLoc-import GHC.Data.StringBuffer-import GHC.Types.Unique.FM-import GHC.Types.Unique.DSet-import GHC.Tc.Utils.Backpack-import GHC.Unit.State-import GHC.Types.Unique.Set-import GHC.Utils.Misc-import qualified GHC.LanguageExtensions as LangExt-import GHC.Types.Name.Env-import GHC.SysTools.FileCleanup---import Data.Either ( rights, partitionEithers )-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Set as Set-import qualified GHC.Data.FiniteMap as Map ( insertListWith )--import Control.Concurrent ( forkIOWithUnmask, killThread )-import qualified GHC.Conc as CC-import Control.Concurrent.MVar-import Control.Concurrent.QSem-import Control.Exception-import Control.Monad-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )-import qualified Control.Monad.Catch as MC-import Data.IORef-import Data.List-import qualified Data.List as List-import Data.Foldable (toList)-import Data.Maybe-import Data.Ord ( comparing )-import Data.Time-import System.Directory-import System.FilePath-import System.IO        ( fixIO )-import System.IO.Error  ( isDoesNotExistError )--import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )--label_self :: String -> IO ()-label_self thread_name = do-    self_tid <- CC.myThreadId-    CC.labelThread self_tid thread_name---- -------------------------------------------------------------------------------- Loading the program---- | Perform a dependency analysis starting from the current targets--- and update the session with the new module graph.------ Dependency analysis entails parsing the @import@ directives and may--- therefore require running certain preprocessors.------ Note that each 'ModSummary' in the module graph caches its 'DynFlags'.--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want--- changes to the 'DynFlags' to take effect you need to call this function--- again.--- In case of errors, just throw them.----depanal :: GhcMonad m =>-           [ModuleName]  -- ^ excluded modules-        -> Bool          -- ^ allow duplicate roots-        -> m ModuleGraph-depanal excluded_mods allow_dup_roots = do-    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots-    if isEmptyBag errs-      then pure mod_graph-      else throwErrors errs---- | Perform dependency analysis like in 'depanal'.--- In case of errors, the errors and an empty module graph are returned.-depanalE :: GhcMonad m =>     -- New for #17459-            [ModuleName]      -- ^ excluded modules-            -> Bool           -- ^ allow duplicate roots-            -> m (ErrorMessages, ModuleGraph)-depanalE excluded_mods allow_dup_roots = do-    hsc_env <- getSession-    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots-    if isEmptyBag errs-      then do-        let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph-            unused_pkg_err = warnUnusedPackages hsc_env mod_graph-            warns = unused_home_mod_err ++ unused_pkg_err-        when (not $ null warns) $-          logWarnings (listToBag warns)-        setSession hsc_env { hsc_mod_graph = mod_graph }-        pure (errs, mod_graph)-      else do-        -- We don't have a complete module dependency graph,-        -- The graph may be disconnected and is unusable.-        setSession hsc_env { hsc_mod_graph = emptyMG }-        pure (errs, emptyMG)----- | Perform dependency analysis like 'depanal' but return a partial module--- graph even in the face of problems with some modules.------ Modules which have parse errors in the module header, failing--- preprocessors or other issues preventing them from being summarised will--- simply be absent from the returned module graph.------ Unlike 'depanal' this function will not update 'hsc_mod_graph' with the--- new module graph.-depanalPartial-    :: GhcMonad m-    => [ModuleName]  -- ^ excluded modules-    -> Bool          -- ^ allow duplicate roots-    -> m (ErrorMessages, ModuleGraph)-    -- ^ possibly empty 'Bag' of errors and a module graph.-depanalPartial excluded_mods allow_dup_roots = do-  hsc_env <- getSession-  let-         dflags  = hsc_dflags hsc_env-         targets = hsc_targets hsc_env-         old_graph = hsc_mod_graph hsc_env--  withTiming dflags (text "Chasing dependencies") (const ()) $ do-    liftIO $ debugTraceMsg dflags 2 (hcat [-              text "Chasing modules from: ",-              hcat (punctuate comma (map pprTarget targets))])--    -- Home package modules may have been moved or deleted, and new-    -- source files may have appeared in the home package that shadow-    -- external package modules, so we have to discard the existing-    -- cached finder data.-    liftIO $ flushFinderCaches hsc_env--    mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)-                                     excluded_mods allow_dup_roots-    let-           (errs, mod_summaries) = partitionEithers mod_summariesE-           mod_graph = mkModuleGraph mod_summaries-    return (unionManyBags errs, mod_graph)---- Note [Missing home modules]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.------ Here "home module" means a module, that doesn't come from an other package.------ For example, if GHC is invoked with modules "A" and "B" as targets,--- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.------ The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules :: HscEnv -> ModuleGraph -> [ErrMsg]-warnMissingHomeModules hsc_env mod_graph =-    if (wopt Opt_WarnMissingHomeModules dflags && not (null missing))-    then [warn]-    else []-  where-    dflags = hsc_dflags hsc_env-    targets = map targetId (hsc_targets hsc_env)--    is_known_module mod = any (is_my_target mod) targets--    -- We need to be careful to handle the case where (possibly-    -- path-qualified) filenames (aka 'TargetFile') rather than module-    -- names are being passed on the GHC command-line.-    ---    -- For instance, `ghc --make src-exe/Main.hs` and-    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.-    -- Note also that we can't always infer the associated module name-    -- directly from the filename argument.  See #13727.-    is_my_target mod (TargetModule name)-      = moduleName (ms_mod mod) == name-    is_my_target mod (TargetFile target_file _)-      | Just mod_file <- ml_hs_file (ms_location mod)-      = target_file == mod_file ||--           --  Don't warn on B.hs-boot if B.hs is specified (#16551)-           addBootSuffix target_file == mod_file ||--           --  We can get a file target even if a module name was-           --  originally specified in a command line because it can-           --  be converted in guessTarget (by appending .hs/.lhs).-           --  So let's convert it back and compare with module name-           mkModuleName (fst $ splitExtension target_file)-            == moduleName (ms_mod mod)-    is_my_target _ _ = False--    missing = map (moduleName . ms_mod) $-      filter (not . is_known_module) (mgModSummaries mod_graph)--    msg-      | gopt Opt_BuildingCabalPackage dflags-      = hang-          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")-          4-          (sep (map ppr missing))-      | otherwise-      =-        hang-          (text "Modules are not listed in command line but needed for compilation: ")-          4-          (sep (map ppr missing))-    warn = makeIntoWarning-      (Reason Opt_WarnMissingHomeModules)-      (mkPlainErrMsg dflags noSrcSpan msg)---- | Describes which modules of the module graph need to be loaded.-data LoadHowMuch-   = LoadAllTargets-     -- ^ Load all targets and its dependencies.-   | LoadUpTo ModuleName-     -- ^ Load only the given module and its dependencies.-   | LoadDependenciesOf ModuleName-     -- ^ Load only the dependencies of the given module, but not the module-     -- itself.---- | Try to load the program.  See 'LoadHowMuch' for the different modes.------ This function implements the core of GHC's @--make@ mode.  It preprocesses,--- compiles and loads the specified modules, avoiding re-compilation wherever--- possible.  Depending on the target (see 'GHC.Driver.Session.hscTarget') compiling--- and loading may result in files being created on disk.------ Calls the 'defaultWarnErrLogger' after each compiling each module, whether--- successful or not.------ If errors are encountered during dependency analysis, the module `depanalE`--- returns together with the errors an empty ModuleGraph.--- After processing this empty ModuleGraph, the errors of depanalE are thrown.--- All other errors are reported using the 'defaultWarnErrLogger'.----load :: GhcMonad m => LoadHowMuch -> m SuccessFlag-load how_much = do-    (errs, mod_graph) <- depanalE [] False                        -- #17459-    success <- load' how_much (Just batchMsg) mod_graph-    if isEmptyBag errs-      then pure success-      else throwErrors errs---- Note [Unused packages]------ Cabal passes `--package-id` flag for each direct dependency. But GHC--- loads them lazily, so when compilation is done, we have a list of all--- actually loaded packages. All the packages, specified on command line,--- but never loaded, are probably unused dependencies.--warnUnusedPackages :: HscEnv -> ModuleGraph -> [ErrMsg]-warnUnusedPackages hsc_env mod_graph =-    let dflags = hsc_dflags hsc_env-        state  = unitState dflags--    -- Only need non-source imports here because SOURCE imports are always HPT-        loadedPackages = concat $-          mapMaybe (\(fs, mn) -> lookupModulePackage state (unLoc mn) fs)-            $ concatMap ms_imps (mgModSummaries mod_graph)--        requestedArgs = mapMaybe packageArg (packageFlags dflags)--        unusedArgs-          = filter (\arg -> not $ any (matching state arg) loadedPackages)-                   requestedArgs--        warn = makeIntoWarning-          (Reason Opt_WarnUnusedPackages)-          (mkPlainErrMsg dflags noSrcSpan msg)-        msg = vcat [ text "The following packages were specified" <+>-                     text "via -package or -package-id flags,"-                   , text "but were not needed for compilation:"-                   , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]--    in if not (null unusedArgs) && wopt Opt_WarnUnusedPackages dflags-       then [warn]-       else []--    where-        packageArg (ExposePackage _ arg _) = Just arg-        packageArg _ = Nothing--        pprUnusedArg (PackageArg str) = text str-        pprUnusedArg (UnitIdArg uid) = ppr uid--        withDash = (<+>) (text "-")--        matchingStr :: String -> UnitInfo -> Bool-        matchingStr str p-                =  str == unitPackageIdString p-                || str == unitPackageNameString p--        matching :: UnitState -> PackageArg -> UnitInfo -> Bool-        matching _ (PackageArg str) p = matchingStr str p-        matching state (UnitIdArg uid) p = uid == realUnit state p--        -- For wired-in packages, we have to unwire their id,-        -- otherwise they won't match package flags-        realUnit :: UnitState -> UnitInfo -> Unit-        realUnit state-          = unwireUnit state-          . RealUnit-          . Definite-          . unitId---- | Generalized version of 'load' which also supports a custom--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally--- produced by calling 'depanal'.-load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag-load' how_much mHscMessage mod_graph = do-    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }-    guessOutputFile-    hsc_env <- getSession--    let hpt1   = hsc_HPT hsc_env-    let dflags = hsc_dflags hsc_env--    -- The "bad" boot modules are the ones for which we have-    -- B.hs-boot in the module graph, but no B.hs-    -- The downsweep should have ensured this does not happen-    -- (see msDeps)-    let all_home_mods =-          mkUniqSet [ ms_mod_name s-                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]-    -- TODO: Figure out what the correct form of this assert is. It's violated-    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot-    -- files without corresponding hs files.-    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,-    --                              not (ms_mod_name s `elem` all_home_mods)]-    -- ASSERT( null bad_boot_mods ) return ()--    -- check that the module given in HowMuch actually exists, otherwise-    -- topSortModuleGraph will bomb later.-    let checkHowMuch (LoadUpTo m)           = checkMod m-        checkHowMuch (LoadDependenciesOf m) = checkMod m-        checkHowMuch _ = id--        checkMod m and_then-            | m `elementOfUniqSet` all_home_mods = and_then-            | otherwise = do-                    liftIO $ errorMsg dflags (text "no such module:" <+>-                                     quotes (ppr m))-                    return Failed--    checkHowMuch how_much $ do--    -- mg2_with_srcimps drops the hi-boot nodes, returning a-    -- graph with cycles.  Among other things, it is used for-    -- backing out partially complete cycles following a failed-    -- upsweep, and for removing from hpt all the modules-    -- not in strict downwards closure, during calls to compile.-    let mg2_with_srcimps :: [SCC ModSummary]-        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing--    -- If we can determine that any of the {-# SOURCE #-} imports-    -- are definitely unnecessary, then emit a warning.-    warnUnnecessarySourceImports mg2_with_srcimps--    let-        -- check the stability property for each module.-        stable_mods@(stable_obj,stable_bco)-            = checkStability hpt1 mg2_with_srcimps all_home_mods--        -- prune bits of the HPT which are definitely redundant now,-        -- to save space.-        pruned_hpt = pruneHomePackageTable hpt1-                            (flattenSCCs mg2_with_srcimps)-                            stable_mods--    _ <- liftIO $ evaluate pruned_hpt--    -- before we unload anything, make sure we don't leave an old-    -- interactive context around pointing to dead bindings.  Also,-    -- write the pruned HPT to allow the old HPT to be GC'd.-    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }--    liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$-                            text "Stable BCO:" <+> ppr stable_bco)--    -- Unload any modules which are going to be re-linked this time around.-    let stable_linkables = [ linkable-                           | m <- nonDetEltsUniqSet stable_obj ++-                                  nonDetEltsUniqSet stable_bco,-                             -- It's OK to use nonDetEltsUniqSet here-                             -- because it only affects linking. Besides-                             -- this list only serves as a poor man's set.-                             Just hmi <- [lookupHpt pruned_hpt m],-                             Just linkable <- [hm_linkable hmi] ]-    liftIO $ unload hsc_env stable_linkables--    -- We could at this point detect cycles which aren't broken by-    -- a source-import, and complain immediately, but it seems better-    -- to let upsweep_mods do this, so at least some useful work gets-    -- done before the upsweep is abandoned.-    --hPutStrLn stderr "after tsort:\n"-    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))--    -- Now do the upsweep, calling compile for each module in-    -- turn.  Final result is version 3 of everything.--    -- Topologically sort the module graph, this time including hi-boot-    -- nodes, and possibly just including the portion of the graph-    -- reachable from the module specified in the 2nd argument to load.-    -- This graph should be cycle-free.-    -- If we're restricting the upsweep to a portion of the graph, we-    -- also want to retain everything that is still stable.-    let full_mg :: [SCC ModSummary]-        full_mg    = topSortModuleGraph False mod_graph Nothing--        maybe_top_mod = case how_much of-                            LoadUpTo m           -> Just m-                            LoadDependenciesOf m -> Just m-                            _                    -> Nothing--        partial_mg0 :: [SCC ModSummary]-        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod--        -- LoadDependenciesOf m: we want the upsweep to stop just-        -- short of the specified module (unless the specified module-        -- is stable).-        partial_mg-            | LoadDependenciesOf _mod <- how_much-            = ASSERT( case last partial_mg0 of-                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )-              List.init partial_mg0-            | otherwise-            = partial_mg0--        stable_mg =-            [ AcyclicSCC ms-            | AcyclicSCC ms <- full_mg,-              stable_mod_summary ms ]--        stable_mod_summary ms =-          ms_mod_name ms `elementOfUniqSet` stable_obj ||-          ms_mod_name ms `elementOfUniqSet` stable_bco--        -- the modules from partial_mg that are not also stable-        -- NB. also keep cycles, we need to emit an error message later-        unstable_mg = filter not_stable partial_mg-          where not_stable (CyclicSCC _) = True-                not_stable (AcyclicSCC ms)-                   = not $ stable_mod_summary ms--        -- Load all the stable modules first, before attempting to load-        -- an unstable module (#7231).-        mg = stable_mg ++ unstable_mg--    -- clean up between compilations-    let cleanup = cleanCurrentModuleTempFiles . hsc_dflags-    liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")-                               2 (ppr mg))--    n_jobs <- case parMakeCount dflags of-                    Nothing -> liftIO getNumProcessors-                    Just n  -> return n-    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs-                   | otherwise  = upsweep--    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }-    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $-      upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg--    -- Make modsDone be the summaries for each home module now-    -- available; this should equal the domain of hpt3.-    -- Get in in a roughly top .. bottom order (hence reverse).--    let modsDone = reverse modsUpswept--    -- Try and do linking in some form, depending on whether the-    -- upsweep was completely or only partially successful.--    if succeeded upsweep_ok--     then-       -- Easy; just relink it all.-       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")--          -- Clean up after ourselves-          hsc_env1 <- getSession-          liftIO $ cleanCurrentModuleTempFiles dflags--          -- Issue a warning for the confusing case where the user-          -- said '-o foo' but we're not going to do any linking.-          -- We attempt linking if either (a) one of the modules is-          -- called Main, or (b) the user said -no-hs-main, indicating-          -- that main() is going to come from somewhere else.-          ---          let ofile = outputFile dflags-          let no_hs_main = gopt Opt_NoHsMain dflags-          let-            main_mod = mainModIs dflags-            a_root_is_Main = mgElemModule mod_graph main_mod-            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib--          -- link everything together-          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)--          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking-             then do-                liftIO $ errorMsg dflags $ text-                   ("output was redirected with -o, " ++-                    "but no output will be generated\n" ++-                    "because there is no " ++-                    moduleNameString (moduleName main_mod) ++ " module.")-                -- This should be an error, not a warning (#10895).-                loadFinish Failed linkresult-             else-                loadFinish Succeeded linkresult--     else-       -- Tricky.  We need to back out the effects of compiling any-       -- half-done cycles, both so as to clean up the top level envs-       -- and to avoid telling the interactive linker to link them.-       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")--          let modsDone_names-                 = map ms_mod modsDone-          let mods_to_zap_names-                 = findPartiallyCompletedCycles modsDone_names-                      mg2_with_srcimps-          let (mods_to_clean, mods_to_keep) =-                partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone-          hsc_env1 <- getSession-          let hpt4 = hsc_HPT hsc_env1-              -- We must change the lifetime to TFL_CurrentModule for any temp-              -- file created for an element of mod_to_clean during the upsweep.-              -- These include preprocessed files and object files for loaded-              -- modules.-              unneeded_temps = concat-                [ms_hspp_file : object_files-                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean-                , let object_files = maybe [] linkableObjs $-                        lookupHpt hpt4 (moduleName ms_mod)-                        >>= hm_linkable-                ]-          liftIO $-            changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps-          liftIO $ cleanCurrentModuleTempFiles dflags--          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)-                                          hpt4--          -- Clean up after ourselves--          -- there should be no Nothings where linkables should be, now-          let just_linkables =-                    isNoLink (ghcLink dflags)-                 || allHpt (isJust.hm_linkable)-                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)-                                hpt5)-          ASSERT( just_linkables ) do--          -- Link everything together-          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5--          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }-          loadFinish Failed linkresult----- | Finish up after a load.-loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag---- If the link failed, unload everything and return.-loadFinish _all_ok Failed-  = do hsc_env <- getSession-       liftIO $ unload hsc_env []-       modifySession discardProg-       return Failed---- Empty the interactive context and set the module context to the topmost--- newly loaded module, or the Prelude if none were loaded.-loadFinish all_ok Succeeded-  = do modifySession discardIC-       return all_ok----- | Forget the current program, but retain the persistent info in HscEnv-discardProg :: HscEnv -> HscEnv-discardProg hsc_env-  = discardIC $ hsc_env { hsc_mod_graph = emptyMG-                        , hsc_HPT = emptyHomePackageTable }---- | Discard the contents of the InteractiveContext, but keep the DynFlags.--- It will also keep ic_int_print and ic_monad if their names are from--- external packages.-discardIC :: HscEnv -> HscEnv-discardIC hsc_env-  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print-                                , ic_monad = new_ic_monad } }-  where-  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic-  !new_ic_int_print = keep_external_name ic_int_print-  !new_ic_monad = keep_external_name ic_monad-  dflags = ic_dflags old_ic-  old_ic = hsc_IC hsc_env-  empty_ic = emptyInteractiveContext dflags-  keep_external_name ic_name-    | nameIsFromExternalPackage this_pkg old_name = old_name-    | otherwise = ic_name empty_ic-    where-    this_pkg = homeUnit dflags-    old_name = ic_name old_ic---- | If there is no -o option, guess the name of target executable--- by using top-level source file name as a base.-guessOutputFile :: GhcMonad m => m ()-guessOutputFile = modifySession $ \env ->-    let dflags = hsc_dflags env-        -- Force mod_graph to avoid leaking env-        !mod_graph = hsc_mod_graph env-        mainModuleSrcPath :: Maybe String-        mainModuleSrcPath = do-            ms <- mgLookupModule mod_graph (mainModIs dflags)-            ml_hs_file (ms_location ms)-        name = fmap dropExtension mainModuleSrcPath--        name_exe = do-#if defined(mingw32_HOST_OS)-          -- we must add the .exe extension unconditionally here, otherwise-          -- when name has an extension of its own, the .exe extension will-          -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248-          name' <- fmap (<.> "exe") name-#else-          name' <- name-#endif-          mainModuleSrcPath' <- mainModuleSrcPath-          -- #9930: don't clobber input files (unless they ask for it)-          if name' == mainModuleSrcPath'-            then throwGhcException . UsageError $-                 "default output name would overwrite the input file; " ++-                 "must specify -o explicitly"-            else Just name'-    in-    case outputFile dflags of-        Just _ -> env-        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }---- ----------------------------------------------------------------------------------- | Prune the HomePackageTable------ Before doing an upsweep, we can throw away:------   - For non-stable modules:---      - all ModDetails, all linked code---   - all unlinked code that is out of date with respect to---     the source file------ This is VERY IMPORTANT otherwise we'll end up requiring 2x the--- space at the end of the upsweep, because the topmost ModDetails of the--- old HPT holds on to the entire type environment from the previous--- compilation.-pruneHomePackageTable :: HomePackageTable-                      -> [ModSummary]-                      -> StableModules-                      -> HomePackageTable-pruneHomePackageTable hpt summ (stable_obj, stable_bco)-  = mapHpt prune hpt-  where prune hmi-          | is_stable modl = hmi'-          | otherwise      = hmi'{ hm_details = emptyModDetails }-          where-           modl = moduleName (mi_module (hm_iface hmi))-           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms-                = hmi{ hm_linkable = Nothing }-                | otherwise-                = hmi-                where ms = expectJust "prune" (lookupUFM ms_map modl)--        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]--        is_stable m =-          m `elementOfUniqSet` stable_obj ||-          m `elementOfUniqSet` stable_bco---- ----------------------------------------------------------------------------------- | Return (names of) all those in modsDone who are part of a cycle as defined--- by theGraph.-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module-findPartiallyCompletedCycles modsDone theGraph-   = Set.unions-       [mods_in_this_cycle-       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.-       , let names_in_this_cycle = Set.fromList (map ms_mod vs)-             mods_in_this_cycle =-                    Set.intersection (Set.fromList modsDone) names_in_this_cycle-         -- If size mods_in_this_cycle == size names_in_this_cycle,-         -- then this cycle has already been completed and we're not-         -- interested.-       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]----- --------------------------------------------------------------------------------- | Unloading-unload :: HscEnv -> [Linkable] -> IO ()-unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'-  = case ghcLink (hsc_dflags hsc_env) of-        LinkInMemory -> Linker.unload hsc_env stable_linkables-        _other -> return ()---- ------------------------------------------------------------------------------{- |--  Stability tells us which modules definitely do not need to be recompiled.-  There are two main reasons for having stability:--   - avoid doing a complete upsweep of the module graph in GHCi when-     modules near the bottom of the tree have not changed.--   - to tell GHCi when it can load object code: we can only load object code-     for a module when we also load object code fo  all of the imports of the-     module.  So we need to know that we will definitely not be recompiling-     any of these modules, and we can use the object code.--  The stability check is as follows.  Both stableObject and-  stableBCO are used during the upsweep phase later.--@-  stable m = stableObject m || stableBCO m--  stableObject m =-        all stableObject (imports m)-        && old linkable does not exist, or is == on-disk .o-        && date(on-disk .o) > date(.hs)--  stableBCO m =-        all stable (imports m)-        && date(BCO) > date(.hs)-@--  These properties embody the following ideas:--    - if a module is stable, then:--        - if it has been compiled in a previous pass (present in HPT)-          then it does not need to be compiled or re-linked.--        - if it has not been compiled in a previous pass,-          then we only need to read its .hi file from disk and-          link it to produce a 'ModDetails'.--    - if a modules is not stable, we will definitely be at least-      re-linking, and possibly re-compiling it during the 'upsweep'.-      All non-stable modules can (and should) therefore be unlinked-      before the 'upsweep'.--    - Note that objects are only considered stable if they only depend-      on other objects.  We can't link object code against byte code.--    - Note that even if an object is stable, we may end up recompiling-      if the interface is out of date because an *external* interface-      has changed.  The current code in GHC.Driver.Make handles this case-      fairly poorly, so be careful.--}--type StableModules =-  ( UniqSet ModuleName  -- stableObject-  , UniqSet ModuleName  -- stableBCO-  )---checkStability-        :: HomePackageTable   -- HPT from last compilation-        -> [SCC ModSummary]   -- current module graph (cyclic)-        -> UniqSet ModuleName -- all home modules-        -> StableModules--checkStability hpt sccs all_home_mods =-  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs-  where-   checkSCC :: StableModules -> SCC ModSummary -> StableModules-   checkSCC (stable_obj, stable_bco) scc0-     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)-     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)-     | otherwise     = (stable_obj, stable_bco)-     where-        scc = flattenSCC scc0-        scc_mods = map ms_mod_name scc-        home_module m =-          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods--        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))-            -- all imports outside the current SCC, but in the home pkg--        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps-        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps--        stableObjects =-           and stable_obj_imps-           && all object_ok scc--        stableBCOs =-           and (zipWith (||) stable_obj_imps stable_bco_imps)-           && all bco_ok scc--        object_ok ms-          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False-          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms-                                         && same_as_prev t-          | otherwise = False-          where-             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of-                                Just hmi  | Just l <- hm_linkable hmi-                                 -> isObjectLinkable l && t == linkableTime l-                                _other  -> True-                -- why '>=' rather than '>' above?  If the filesystem stores-                -- times to the nearest second, we may occasionally find that-                -- the object & source have the same modification time,-                -- especially if the source was automatically generated-                -- and compiled.  Using >= is slightly unsafe, but it matches-                -- make's behaviour.-                ---                -- But see #5527, where someone ran into this and it caused-                -- a problem.--        bco_ok ms-          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False-          | otherwise = case lookupHpt hpt (ms_mod_name ms) of-                Just hmi  | Just l <- hm_linkable hmi ->-                        not (isObjectLinkable l) &&-                        linkableTime l >= ms_hs_date ms-                _other  -> False--{- Parallel Upsweep- -- - The parallel upsweep attempts to concurrently compile the modules in the- - compilation graph using multiple Haskell threads.- -- - The Algorithm- -- - A Haskell thread is spawned for each module in the module graph, waiting for- - its direct dependencies to finish building before it itself begins to build.- -- - Each module is associated with an initially empty MVar that stores the- - result of that particular module's compile. If the compile succeeded, then- - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that- - module, and the module's HMI is deleted from the old HPT (synchronized by an- - IORef) to save space.- -- - Instead of immediately outputting messages to the standard handles, all- - compilation output is deferred to a per-module TQueue. A QSem is used to- - limit the number of workers that are compiling simultaneously.- -- - Meanwhile, the main thread sequentially loops over all the modules in the- - module graph, outputting the messages stored in each module's TQueue.--}---- | Each module is given a unique 'LogQueue' to redirect compilation messages--- to. A 'Nothing' value contains the result of compilation, and denotes the--- end of the message queue.-data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, MsgDoc)])-                         !(MVar ())---- | The graph of modules to compile and their corresponding result 'MVar' and--- 'LogQueue'.-type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]---- | Build a 'CompilationGraph' out of a list of strongly-connected modules,--- also returning the first, if any, encountered module cycle.-buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])-buildCompGraph [] = return ([], Nothing)-buildCompGraph (scc:sccs) = case scc of-    AcyclicSCC ms -> do-        mvar <- newEmptyMVar-        log_queue <- do-            ref <- newIORef []-            sem <- newEmptyMVar-            return (LogQueue ref sem)-        (rest,cycle) <- buildCompGraph sccs-        return ((ms,mvar,log_queue):rest, cycle)-    CyclicSCC mss -> return ([], Just mss)---- | A Module and whether it is a boot module.------ We need to treat boot modules specially when building compilation graphs,--- since they break cycles. Regular source files and signature files are treated--- equivalently.-type BuildModule = ModuleWithIsBoot---- | Tests if an 'HscSource' is a boot file, primarily for constructing elements--- of 'BuildModule'. We conflate signatures and modules because they are bound--- in the same namespace; only boot interfaces can be disambiguated with--- `import {-# SOURCE #-}`.-hscSourceToIsBoot :: HscSource -> IsBootInterface-hscSourceToIsBoot HsBootFile = IsBoot-hscSourceToIsBoot _ = NotBoot--mkBuildModule :: ModSummary -> BuildModule-mkBuildModule ms = GWIB-  { gwib_mod = ms_mod ms-  , gwib_isBoot = isBootSummary ms-  }--mkHomeBuildModule :: ModSummary -> ModuleNameWithIsBoot-mkHomeBuildModule ms = GWIB-  { gwib_mod = moduleName $ ms_mod ms-  , gwib_isBoot = isBootSummary ms-  }---- | The entry point to the parallel upsweep.------ See also the simpler, sequential 'upsweep'.-parUpsweep-    :: GhcMonad m-    => Int-    -- ^ The number of workers we wish to run in parallel-    -> Maybe Messager-    -> HomePackageTable-    -> StableModules-    -> (HscEnv -> IO ())-    -> [SCC ModSummary]-    -> m (SuccessFlag,-          [ModSummary])-parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do-    hsc_env <- getSession-    let dflags = hsc_dflags hsc_env--    when (not (null (instantiatedUnitsToCheck dflags))) $-      throwGhcException (ProgramError "Backpack typechecking not supported with -j")--    -- The bits of shared state we'll be using:--    -- The global HscEnv is updated with the module's HMI when a module-    -- successfully compiles.-    hsc_env_var <- liftIO $ newMVar hsc_env--    -- The old HPT is used for recompilation checking in upsweep_mod. When a-    -- module successfully gets compiled, its HMI is pruned from the old HPT.-    old_hpt_var <- liftIO $ newIORef old_hpt--    -- What we use to limit parallelism with.-    par_sem <- liftIO $ newQSem n_jobs---    let updNumCapabilities = liftIO $ do-            n_capabilities <- getNumCapabilities-            n_cpus <- getNumProcessors-            -- Setting number of capabilities more than-            -- CPU count usually leads to high userspace-            -- lock contention. #9221-            let n_caps = min n_jobs n_cpus-            unless (n_capabilities /= 1) $ setNumCapabilities n_caps-            return n_capabilities-    -- Reset the number of capabilities once the upsweep ends.-    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n--    MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do--    -- Sync the global session with the latest HscEnv once the upsweep ends.-    let finallySyncSession io = io `MC.finally` do-            hsc_env <- liftIO $ readMVar hsc_env_var-            setSession hsc_env--    finallySyncSession $ do--    -- Build the compilation graph out of the list of SCCs. Module cycles are-    -- handled at the very end, after some useful work gets done. Note that-    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).-    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs-    let comp_graph_w_idx = zip comp_graph [1..]--    -- The list of all loops in the compilation graph.-    -- NB: For convenience, the last module of each loop (aka the module that-    -- finishes the loop) is prepended to the beginning of the loop.-    let graph = map fstOf3 (reverse comp_graph)-        boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms == IsBoot]-        comp_graph_loops = go graph boot_modules-          where-            remove ms bm = case isBootSummary ms of-              IsBoot -> delModuleSet bm (ms_mod ms)-              NotBoot -> bm-            go [] _ = []-            go mg@(ms:mss) boot_modules-              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)-              = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules)-              | otherwise-              = go mss (remove ms boot_modules)--    -- Build a Map out of the compilation graph with which we can efficiently-    -- look up the result MVar associated with a particular home module.-    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)-        home_mod_map =-            Map.fromList [ (mkBuildModule ms, (mvar, idx))-                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]---    liftIO $ label_self "main --make thread"-    -- For each module in the module graph, spawn a worker thread that will-    -- compile this module.-    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->-            forkIOWithUnmask $ \unmask -> do-                liftIO $ label_self $ unwords-                    [ "worker --make thread"-                    , "for module"-                    , show (moduleNameString (ms_mod_name mod))-                    , "number"-                    , show mod_idx-                    ]-                -- Replace the default log_action with one that writes each-                -- message to the module's log_queue. The main thread will-                -- deal with synchronously printing these messages.-                ---                -- Use a local filesToClean var so that we can clean up-                -- intermediate files in a timely fashion (as soon as-                -- compilation for that module is finished) without having to-                -- worry about accidentally deleting a simultaneous compile's-                -- important files.-                lcl_files_to_clean <- newIORef emptyFilesToClean-                let lcl_dflags = dflags { log_action = parLogAction log_queue-                                        , filesToClean = lcl_files_to_clean }--                -- Unmask asynchronous exceptions and perform the thread-local-                -- work to compile the module (see parUpsweep_one).-                m_res <- MC.try $ unmask $ prettyPrintGhcErrors lcl_dflags $-                        parUpsweep_one mod home_mod_map comp_graph_loops-                                       lcl_dflags mHscMessage cleanup-                                       par_sem hsc_env_var old_hpt_var-                                       stable_mods mod_idx (length sccs)--                res <- case m_res of-                    Right flag -> return flag-                    Left exc -> do-                        -- Don't print ThreadKilled exceptions: they are used-                        -- to kill the worker thread in the event of a user-                        -- interrupt, and the user doesn't have to be informed-                        -- about that.-                        when (fromException exc /= Just ThreadKilled)-                             (errorMsg lcl_dflags (text (show exc)))-                        return Failed--                -- Populate the result MVar.-                putMVar mvar res--                -- Write the end marker to the message queue, telling the main-                -- thread that it can stop waiting for messages from this-                -- particular compile.-                writeLogQueue log_queue Nothing--                -- Add the remaining files that weren't cleaned up to the-                -- global filesToClean ref, for cleanup later.-                FilesToClean-                  { ftcCurrentModule = cm_files-                  , ftcGhcSession = gs_files-                  } <- readIORef (filesToClean lcl_dflags)-                addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files-                addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files--        -- Kill all the workers, masking interrupts (since killThread is-        -- interruptible). XXX: This is not ideal.-        ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread }---    -- Spawn the workers, making sure to kill them later. Collect the results-    -- of each compile.-    results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ ->-        -- Loop over each module in the compilation graph in order, printing-        -- each message from its log_queue.-        forM comp_graph $ \(mod,mvar,log_queue) -> do-            printLogs dflags log_queue-            result <- readMVar mvar-            if succeeded result then return (Just mod) else return Nothing---    -- Collect and return the ModSummaries of all the successful compiles.-    -- NB: Reverse this list to maintain output parity with the sequential upsweep.-    let ok_results = reverse (catMaybes results)--    -- Handle any cycle in the original compilation graph and return the result-    -- of the upsweep.-    case cycle of-        Just mss -> do-            liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)-            return (Failed,ok_results)-        Nothing  -> do-            let success_flag = successIf (all isJust results)-            return (success_flag,ok_results)--  where-    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,MsgDoc) -> IO ()-    writeLogQueue (LogQueue ref sem) msg = do-        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())-        _ <- tryPutMVar sem ()-        return ()--    -- The log_action callback that is used to synchronize messages from a-    -- worker thread.-    parLogAction :: LogQueue -> LogAction-    parLogAction log_queue _dflags !reason !severity !srcSpan !msg = do-        writeLogQueue log_queue (Just (reason,severity,srcSpan,msg))--    -- Print each message from the log_queue using the log_action from the-    -- session's DynFlags.-    printLogs :: DynFlags -> LogQueue -> IO ()-    printLogs !dflags (LogQueue ref sem) = read_msgs-      where read_msgs = do-                takeMVar sem-                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)-                print_loop msgs--            print_loop [] = read_msgs-            print_loop (x:xs) = case x of-                Just (reason,severity,srcSpan,msg) -> do-                    putLogMsg dflags reason severity srcSpan msg-                    print_loop xs-                -- Exit the loop once we encounter the end marker.-                Nothing -> return ()---- The interruptible subset of the worker threads' work.-parUpsweep_one-    :: ModSummary-    -- ^ The module we wish to compile-    -> Map BuildModule (MVar SuccessFlag, Int)-    -- ^ The map of home modules and their result MVar-    -> [[BuildModule]]-    -- ^ The list of all module loops within the compilation graph.-    -> DynFlags-    -- ^ The thread-local DynFlags-    -> Maybe Messager-    -- ^ The messager-    -> (HscEnv -> IO ())-    -- ^ The callback for cleaning up intermediate files-    -> QSem-    -- ^ The semaphore for limiting the number of simultaneous compiles-    -> MVar HscEnv-    -- ^ The MVar that synchronizes updates to the global HscEnv-    -> IORef HomePackageTable-    -- ^ The old HPT-    -> StableModules-    -- ^ Sets of stable objects and BCOs-    -> Int-    -- ^ The index of this module-    -> Int-    -- ^ The total number of modules-    -> IO SuccessFlag-    -- ^ The result of this compile-parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem-               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do--    let this_build_mod = mkBuildModule mod--    let home_imps     = map unLoc $ ms_home_imps mod-    let home_src_imps = map unLoc $ ms_home_srcimps mod--    -- All the textual imports of this module.-    let textual_deps = Set.fromList $-            zipWith f home_imps     (repeat NotBoot) ++-            zipWith f home_src_imps (repeat IsBoot)-          where f mn isBoot = GWIB-                  { gwib_mod = mkHomeModule lcl_dflags mn-                  , gwib_isBoot = isBoot-                  }--    -- Dealing with module loops-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~-    ---    -- Not only do we have to deal with explicit textual dependencies, we also-    -- have to deal with implicit dependencies introduced by import cycles that-    -- are broken by an hs-boot file. We have to ensure that:-    ---    -- 1. A module that breaks a loop must depend on all the modules in the-    --    loop (transitively or otherwise). This is normally always fulfilled-    --    by the module's textual dependencies except in degenerate loops,-    --    e.g.:-    ---    --    A.hs imports B.hs-boot-    --    B.hs doesn't import A.hs-    --    C.hs imports A.hs, B.hs-    ---    --    In this scenario, getModLoop will detect the module loop [A,B] but-    --    the loop finisher B doesn't depend on A. So we have to explicitly add-    --    A in as a dependency of B when we are compiling B.-    ---    -- 2. A module that depends on a module in an external loop can't proceed-    --    until the entire loop is re-typechecked.-    ---    -- These two invariants have to be maintained to correctly build a-    -- compilation graph with one or more loops.---    -- The loop that this module will finish. After this module successfully-    -- compiles, this loop is going to get re-typechecked.-    let finish_loop = listToMaybe-            [ tail loop | loop <- comp_graph_loops-                        , head loop == this_build_mod ]--    -- If this module finishes a loop then it must depend on all the other-    -- modules in that loop because the entire module loop is going to be-    -- re-typechecked once this module gets compiled. These extra dependencies-    -- are this module's "internal" loop dependencies, because this module is-    -- inside the loop in question.-    let int_loop_deps = Set.fromList $-            case finish_loop of-                Nothing   -> []-                Just loop -> filter (/= this_build_mod) loop--    -- If this module depends on a module within a loop then it must wait for-    -- that loop to get re-typechecked, i.e. it must wait on the module that-    -- finishes that loop. These extra dependencies are this module's-    -- "external" loop dependencies, because this module is outside of the-    -- loop(s) in question.-    let ext_loop_deps = Set.fromList-            [ head loop | loop <- comp_graph_loops-                        , any (`Set.member` textual_deps) loop-                        , this_build_mod `notElem` loop ]---    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]--    -- All of the module's home-module dependencies.-    let home_deps_with_idx =-            [ home_dep | dep <- Set.toList all_deps-                       , Just home_dep <- [Map.lookup dep home_mod_map] ]--    -- Sort the list of dependencies in reverse-topological order. This way, by-    -- the time we get woken up by the result of an earlier dependency,-    -- subsequent dependencies are more likely to have finished. This step-    -- effectively reduces the number of MVars that each thread blocks on.-    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx--    -- Wait for the all the module's dependencies to finish building.-    deps_ok <- allM (fmap succeeded . readMVar) home_deps--    -- We can't build this module if any of its dependencies failed to build.-    if not deps_ok-      then return Failed-      else do-        -- Any hsc_env at this point is OK to use since we only really require-        -- that the HPT contains the HMIs of our dependencies.-        hsc_env <- readMVar hsc_env_var-        old_hpt <- readIORef old_hpt_var--        let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)--        -- Limit the number of parallel compiles.-        let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)-        mb_mod_info <- withSem par_sem $-            handleSourceError (\err -> do logger err; return Nothing) $ do-                -- Have the ModSummary and HscEnv point to our local log_action-                -- and filesToClean var.-                let lcl_mod = localize_mod mod-                let lcl_hsc_env = localize_hsc_env hsc_env--                -- Re-typecheck the loop-                -- This is necessary to make sure the knot is tied when-                -- we close a recursive module loop, see bug #12035.-                type_env_var <- liftIO $ newIORef emptyNameEnv-                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =-                                    Just (ms_mod lcl_mod, type_env_var) }-                lcl_hsc_env'' <- case finish_loop of-                    Nothing   -> return lcl_hsc_env'-                    -- In the non-parallel case, the retypecheck prior to-                    -- typechecking the loop closer includes all modules-                    -- EXCEPT the loop closer.  However, our precomputed-                    -- SCCs include the loop closer, so we have to filter-                    -- it out.-                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $-                                 filter (/= moduleName (gwib_mod this_build_mod)) $-                                 map (moduleName . gwib_mod) loop--                -- Compile the module.-                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods-                                        lcl_mod mod_index num_mods-                return (Just mod_info)--        case mb_mod_info of-            Nothing -> return Failed-            Just mod_info -> do-                let this_mod = ms_mod_name mod--                -- Prune the old HPT unless this is an hs-boot module.-                unless (isBootSummary mod == IsBoot) $-                    atomicModifyIORef' old_hpt_var $ \old_hpt ->-                        (delFromHpt old_hpt this_mod, ())--                -- Update and fetch the global HscEnv.-                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do-                    let hsc_env' = hsc_env-                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)-                                                           this_mod mod_info }-                    -- We've finished typechecking the module, now we must-                    -- retypecheck the loop AGAIN to ensure unfoldings are-                    -- updated.  This time, however, we include the loop-                    -- closer!-                    hsc_env'' <- case finish_loop of-                        Nothing   -> return hsc_env'-                        Just loop -> typecheckLoop lcl_dflags hsc_env' $-                                     map (moduleName . gwib_mod) loop-                    return (hsc_env'', localize_hsc_env hsc_env'')--                -- Clean up any intermediate files.-                cleanup lcl_hsc_env'-                return Succeeded--  where-    localize_mod mod-        = mod { ms_hspp_opts = (ms_hspp_opts mod)-                 { log_action = log_action lcl_dflags-                 , filesToClean = filesToClean lcl_dflags } }--    localize_hsc_env hsc_env-        = hsc_env { hsc_dflags = (hsc_dflags hsc_env)-                     { log_action = log_action lcl_dflags-                     , filesToClean = filesToClean lcl_dflags } }---- ----------------------------------------------------------------------------------- | The upsweep------ This is where we compile each module in the module graph, in a pass--- from the bottom to the top of the graph.------ There better had not be any cyclic groups here -- we check for them.-upsweep-    :: GhcMonad m-    => Maybe Messager-    -> HomePackageTable            -- ^ HPT from last time round (pruned)-    -> StableModules               -- ^ stable modules (see checkStability)-    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files-    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)-    -> m (SuccessFlag,-          [ModSummary])-       -- ^ Returns:-       ---       --  1. A flag whether the complete upsweep was successful.-       --  2. The 'HscEnv' in the monad has an updated HPT-       --  3. A list of modules which succeeded loading.--upsweep mHscMessage old_hpt stable_mods cleanup sccs = do-   dflags <- getSessionDynFlags-   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)-                           (instantiatedUnitsToCheck dflags) done_holes-   return (res, reverse $ mgModSummaries done)- where-  done_holes = emptyUniqSet--  keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do-    let sum_deps ms (AcyclicSCC mod) =-          if any (flip elem $ unfilteredEdges False mod) ms-            then mkHomeBuildModule mod:ms-            else ms-        sum_deps ms _ = ms-        dep_closure = foldl' sum_deps this_mods mods-        dropped_ms = drop (length this_mods) (reverse dep_closure)-        prunable (AcyclicSCC mod) = elem (mkHomeBuildModule mod) dep_closure-        prunable _ = False-        mods' = filter (not . prunable) mods-        nmods' = nmods - length dropped_ms--    when (not $ null dropped_ms) $ do-        dflags <- getSessionDynFlags-        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr $ gwib_mod <$> dropped_ms)-    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes-    return (Failed, done')--  upsweep'-    :: GhcMonad m-    => HomePackageTable-    -> ModuleGraph-    -> [SCC ModSummary]-    -> Int-    -> Int-    -> [Unit]-    -> UniqSet ModuleName-    -> m (SuccessFlag, ModuleGraph)-  upsweep' _old_hpt done-     [] _ _ uids_to_check _-   = do hsc_env <- getSession-        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) uids_to_check-        return (Succeeded, done)--  upsweep' _old_hpt done-     (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes-   = do dflags <- getSessionDynFlags-        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)-        if gopt Opt_KeepGoing dflags-          then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods-                          uids_to_check done_holes-          else return (Failed, done)--  upsweep' old_hpt done-     (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes-   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++-        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)-        --                     (moduleEnvElts (hsc_HPT hsc_env)))-        let logger _mod = defaultWarnErrLogger--        hsc_env <- getSession--        -- TODO: Cache this, so that we don't repeatedly re-check-        -- our imports when you run --make.-        let (ready_uids, uids_to_check')-                = partition (\uid -> isEmptyUniqDSet-                    (unitFreeModuleHoles uid `uniqDSetMinusUniqSet` done_holes))-                     uids_to_check-            done_holes'-                | ms_hsc_src mod == HsigFile-                = addOneToUniqSet done_holes (ms_mod_name mod)-                | otherwise = done_holes-        liftIO . runHsc hsc_env $ mapM_ (ioMsgMaybe . tcRnCheckUnit hsc_env) ready_uids--        -- Remove unwanted tmp files between compilations-        liftIO (cleanup hsc_env)--        -- Get ready to tie the knot-        type_env_var <- liftIO $ newIORef emptyNameEnv-        let hsc_env1 = hsc_env { hsc_type_env_var =-                                    Just (ms_mod mod, type_env_var) }-        setSession hsc_env1--        -- Lazily reload the HPT modules participating in the loop.-        -- See Note [Tying the knot]--if we don't throw out the old HPT-        -- and reinitalize the knot-tying process, anything that was forced-        -- while we were previously typechecking won't get updated, this-        -- was bug #12035.-        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done-        setSession hsc_env2--        mb_mod_info-            <- handleSourceError-                   (\err -> do logger mod (Just err); return Nothing) $ do-                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods-                                                  mod mod_index nmods-                 logger mod Nothing -- log warnings-                 return (Just mod_info)--        case mb_mod_info of-          Nothing -> do-                dflags <- getSessionDynFlags-                if gopt Opt_KeepGoing dflags-                  then keep_going [mkHomeBuildModule mod] old_hpt done mods mod_index nmods-                                  uids_to_check done_holes-                  else return (Failed, done)-          Just mod_info -> do-                let this_mod = ms_mod_name mod--                        -- Add new info to hsc_env-                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info-                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }--                        -- Space-saving: delete the old HPT entry-                        -- for mod BUT if mod is a hs-boot-                        -- node, don't delete it.  For the-                        -- interface, the HPT entry is probably for the-                        -- main Haskell source file.  Deleting it-                        -- would force the real module to be recompiled-                        -- every time.-                    old_hpt1 = case isBootSummary mod of-                      IsBoot -> old_hpt-                      NotBoot -> delFromHpt old_hpt this_mod--                    done' = extendMG done mod--                        -- fixup our HomePackageTable after we've finished compiling-                        -- a mutually-recursive loop.  We have to do this again-                        -- to make sure we have the final unfoldings, which may-                        -- not have been computed accurately in the previous-                        -- retypecheck.-                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'-                setSession hsc_env4--                        -- Add any necessary entries to the static pointer-                        -- table. See Note [Grand plan for static forms] in-                        -- GHC.Iface.Tidy.StaticPtrTable.-                when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $-                    liftIO $ hscAddSptEntries hsc_env4-                                 [ spt-                                 | Just linkable <- pure $ hm_linkable mod_info-                                 , unlinked <- linkableUnlinked linkable-                                 , BCOs _ spts <- pure unlinked-                                 , spt <- spts-                                 ]--                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'---- | Return a list of instantiated units to type check from the UnitState.------ Use explicit (instantiated) units as roots and also return their--- instantiations that are themselves instantiations and so on recursively.-instantiatedUnitsToCheck :: DynFlags -> [Unit]-instantiatedUnitsToCheck dflags =-  nubSort $ concatMap goUnit (explicitUnits (unitState dflags))- where-  goUnit HoleUnit         = []-  goUnit (RealUnit _)     = []-  goUnit uid@(VirtUnit i) = uid : concatMap (goUnit . moduleUnit . snd) (instUnitInsts i)--maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)-maybeGetIfaceDate dflags location- | writeInterfaceOnlyMode dflags-    -- Minor optimization: it should be harmless to check the hi file location-    -- always, but it's better to avoid hitting the filesystem if possible.-    = modificationTimeIfExists (ml_hi_file location)- | otherwise-    = return Nothing---- | Compile a single module.  Always produce a Linkable for it if--- successful.  If no compilation happened, return the old Linkable.-upsweep_mod :: HscEnv-            -> Maybe Messager-            -> HomePackageTable-            -> StableModules-            -> ModSummary-            -> Int  -- index of module-            -> Int  -- total number of modules-            -> IO HomeModInfo-upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods-   =    let-            this_mod_name = ms_mod_name summary-            this_mod    = ms_mod summary-            mb_obj_date = ms_obj_date summary-            mb_if_date  = ms_iface_date summary-            obj_fn      = ml_obj_file (ms_location summary)-            hs_date     = ms_hs_date summary--            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj-            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco--            old_hmi = lookupHpt old_hpt this_mod_name--            -- We're using the dflags for this module now, obtained by-            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.-            dflags = ms_hspp_opts summary-            prevailing_target = hscTarget (hsc_dflags hsc_env)-            local_target      = hscTarget dflags--            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that-            -- we don't do anything dodgy: these should only work to change-            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,-            -- otherwise we could end up trying to link object code to byte-            -- code.-            target = if prevailing_target /= local_target-                        && (not (isObjectTarget prevailing_target)-                            || not (isObjectTarget local_target))-                        && not (prevailing_target == HscNothing)-                        && not (prevailing_target == HscInterpreted)-                        then prevailing_target-                        else local_target--            -- store the corrected hscTarget into the summary-            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }--            -- The old interface is ok if-            --  a) we're compiling a source file, and the old HPT-            --     entry is for a source file-            --  b) we're compiling a hs-boot file-            -- Case (b) allows an hs-boot file to get the interface of its-            -- real source file on the second iteration of the compilation-            -- manager, but that does no harm.  Otherwise the hs-boot file-            -- will always be recompiled--            mb_old_iface-                = case old_hmi of-                     Nothing                                        -> Nothing-                     Just hm_info | isBootSummary summary == IsBoot -> Just iface-                                  | mi_boot iface == NotBoot        -> Just iface-                                  | otherwise                       -> Nothing-                                   where-                                     iface = hm_iface hm_info--            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo-            compile_it  mb_linkable src_modified =-                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods-                             mb_old_iface mb_linkable src_modified--            compile_it_discard_iface :: Maybe Linkable -> SourceModified-                                     -> IO HomeModInfo-            compile_it_discard_iface mb_linkable  src_modified =-                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods-                             Nothing mb_linkable src_modified--            -- With the HscNothing target we create empty linkables to avoid-            -- recompilation.  We have to detect these to recompile anyway if-            -- the target changed since the last compile.-            is_fake_linkable-               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =-                  null (linkableUnlinked l)-               | otherwise =-                   -- we have no linkable, so it cannot be fake-                   False--            implies False _ = True-            implies True x  = x--        in-        case () of-         _-                -- Regardless of whether we're generating object code or-                -- byte code, we can always use an existing object file-                -- if it is *stable* (see checkStability).-          | is_stable_obj, Just hmi <- old_hmi -> do-                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                           (text "skipping stable obj mod:" <+> ppr this_mod_name)-                return hmi-                -- object is stable, and we have an entry in the-                -- old HPT: nothing to do--          | is_stable_obj, isNothing old_hmi -> do-                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                           (text "compiling stable on-disk mod:" <+> ppr this_mod_name)-                linkable <- liftIO $ findObjectLinkable this_mod obj_fn-                              (expectJust "upsweep1" mb_obj_date)-                compile_it (Just linkable) SourceUnmodifiedAndStable-                -- object is stable, but we need to load the interface-                -- off disk to make a HMI.--          | not (isObjectTarget target), is_stable_bco,-            (target /= HscNothing) `implies` not is_fake_linkable ->-                ASSERT(isJust old_hmi) -- must be in the old_hpt-                let Just hmi = old_hmi in do-                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                           (text "skipping stable BCO mod:" <+> ppr this_mod_name)-                return hmi-                -- BCO is stable: nothing to do--          | not (isObjectTarget target),-            Just hmi <- old_hmi,-            Just l <- hm_linkable hmi,-            not (isObjectLinkable l),-            (target /= HscNothing) `implies` not is_fake_linkable,-            linkableTime l >= ms_hs_date summary -> do-                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                           (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)-                compile_it (Just l) SourceUnmodified-                -- we have an old BCO that is up to date with respect-                -- to the source: do a recompilation check as normal.--          -- When generating object code, if there's an up-to-date-          -- object file on the disk, then we can use it.-          -- However, if the object file is new (compared to any-          -- linkable we had from a previous compilation), then we-          -- must discard any in-memory interface, because this-          -- means the user has compiled the source file-          -- separately and generated a new interface, that we must-          -- read from the disk.-          ---          | isObjectTarget target,-            Just obj_date <- mb_obj_date,-            obj_date >= hs_date -> do-                case old_hmi of-                  Just hmi-                    | Just l <- hm_linkable hmi,-                      isObjectLinkable l && linkableTime l == obj_date -> do-                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                                     (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)-                          compile_it (Just l) SourceUnmodified-                  _otherwise -> do-                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                                     (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)-                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date-                          compile_it_discard_iface (Just linkable) SourceUnmodified--          -- See Note [Recompilation checking in -fno-code mode]-          | writeInterfaceOnlyMode dflags,-            Just if_date <- mb_if_date,-            if_date >= hs_date -> do-                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                           (text "skipping tc'd mod:" <+> ppr this_mod_name)-                compile_it Nothing SourceUnmodified--         _otherwise -> do-                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5-                           (text "compiling mod:" <+> ppr this_mod_name)-                compile_it Nothing SourceModified---{- Note [-fno-code mode]-~~~~~~~~~~~~~~~~~~~~~~~~-GHC offers the flag -fno-code for the purpose of parsing and typechecking a-program without generating object files. This is intended to be used by tooling-and IDEs to provide quick feedback on any parser or type errors as cheaply as-possible.--When GHC is invoked with -fno-code no object files or linked output will be-generated. As many errors and warnings as possible will be generated, as if--fno-code had not been passed. The session DynFlags will have-hscTarget == HscNothing.---fwrite-interface-~~~~~~~~~~~~~~~~-Whether interface files are generated in -fno-code mode is controlled by the--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is-not also passed. Recompilation avoidance requires interface files, so passing--fno-code without -fwrite-interface should be avoided. If -fno-code were-re-implemented today, -fwrite-interface would be discarded and it would be-considered always on; this behaviour is as it is for backwards compatibility.--================================================================-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER-================================================================--Template Haskell-~~~~~~~~~~~~~~~~-A module using template haskell may invoke an imported function from inside a-splice. This will cause the type-checker to attempt to execute that code, which-would fail if no object files had been generated. See #8025. To rectify this,-during the downsweep we patch the DynFlags in the ModSummary of any home module-that is imported by a module that uses template haskell, to generate object-code.--The flavour of generated object code is chosen by defaultObjectTarget for the-target platform. It would likely be faster to generate bytecode, but this is not-supported on all platforms(?Please Confirm?), and does not support the entirety-of GHC haskell. See #1257.--The object files (and interface files if -fwrite-interface is disabled) produced-for template haskell are written to temporary files.--Note that since template haskell can run arbitrary IO actions, -fno-code mode-is no more secure than running without it.--Potential TODOS:-~~~~~-* Remove -fwrite-interface and have interface files always written in -fno-code-  mode-* Both .o and .dyn_o files are generated for template haskell, but we only need-  .dyn_o. Fix it.-* In make mode, a message like-  Compiling A (A.hs, /tmp/ghc_123.o)-  is shown if downsweep enabled object code generation for A. Perhaps we should-  show "nothing" or "temporary object file" instead. Note that one-  can currently use -keep-tmp-files and inspect the generated file with the-  current behaviour.-* Offer a -no-codedir command line option, and write what were temporary-  object files there. This would speed up recompilation.-* Use existing object files (if they are up to date) instead of always-  generating temporary ones.--}---- Note [Recompilation checking in -fno-code mode]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- If we are compiling with -fno-code -fwrite-interface, there won't--- be any object code that we can compare against, nor should there--- be: we're *just* generating interface files.  In this case, we--- want to check if the interface file is new, in lieu of the object--- file.  See also #9243.---- Filter modules in the HPT-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable-retainInTopLevelEnvs keep_these hpt-   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)-                 | mod <- keep_these-                 , let mb_mod_info = lookupHpt hpt mod-                 , isJust mb_mod_info ]---- ------------------------------------------------------------------------------ Typecheck module loops-{--See bug #930.  This code fixes a long-standing bug in --make.  The-problem is that when compiling the modules *inside* a loop, a data-type that is only defined at the top of the loop looks opaque; but-after the loop is done, the structure of the data type becomes-apparent.--The difficulty is then that two different bits of code have-different notions of what the data type looks like.--The idea is that after we compile a module which also has an .hs-boot-file, we re-generate the ModDetails for each of the modules that-depends on the .hs-boot file, so that everyone points to the proper-TyCons, Ids etc. defined by the real module, not the boot module.-Fortunately re-generating a ModDetails from a ModIface is easy: the-function GHC.IfaceToCore.typecheckIface does exactly that.--Picking the modules to re-typecheck is slightly tricky.  Starting from-the module graph consisting of the modules that have already been-compiled, we reverse the edges (so they point from the imported module-to the importing module), and depth-first-search from the .hs-boot-node.  This gives us all the modules that depend transitively on the-.hs-boot module, and those are exactly the modules that we need to-re-typecheck.--Following this fix, GHC can compile itself with --make -O2.--}--reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv-reTypecheckLoop hsc_env ms graph-  | Just loop <- getModLoop ms mss appearsAsBoot-  -- SOME hs-boot files should still-  -- get used, just not the loop-closer.-  , let non_boot = filter (\l -> not (isBootSummary l == IsBoot &&-                                 ms_mod l == ms_mod ms)) loop-  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)-  | otherwise-  = return hsc_env-  where-  mss = mgModSummaries graph-  appearsAsBoot = (`elemModuleSet` mgBootModules graph)---- | Given a non-boot ModSummary @ms@ of a module, for which there exists a--- corresponding boot file in @graph@, return the set of modules which--- transitively depend on this boot file.  This function is slightly misnamed,--- but its name "getModLoop" alludes to the fact that, when getModLoop is called--- with a graph that does not contain @ms@ (non-parallel case) or is an--- SCC with hs-boot nodes dropped (parallel-case), the modules which--- depend on the hs-boot file are typically (but not always) the--- modules participating in the recursive module loop.  The returned--- list includes the hs-boot file.------ Example:---      let g represent the module graph:---          C.hs---          A.hs-boot imports C.hs---          B.hs imports A.hs-boot---          A.hs imports B.hs---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]------      It would also be permissible to omit A.hs from the graph,---      in which case the result is [A.hs-boot, B.hs]------ Example:---      A counter-example to the claim that modules returned---      by this function participate in the loop occurs here:------      let g represent the module graph:---          C.hs---          A.hs-boot imports C.hs---          B.hs imports A.hs-boot---          A.hs imports B.hs---          D.hs imports A.hs-boot---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]------      Arguably, D.hs should import A.hs, not A.hs-boot, but---      a dependency on the boot file is not illegal.----getModLoop-  :: ModSummary-  -> [ModSummary]-  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'-  -> Maybe [ModSummary]-getModLoop ms graph appearsAsBoot-  | isBootSummary ms == NotBoot-  , appearsAsBoot this_mod-  , let mss = reachableBackwards (ms_mod_name ms) graph-  = Just mss-  | otherwise-  = Nothing- where-  this_mod = ms_mod ms---- NB: sometimes mods has duplicates; this is harmless because--- any duplicates get clobbered in addListToHpt and never get forced.-typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv-typecheckLoop dflags hsc_env mods = do-  debugTraceMsg dflags 2 $-     text "Re-typechecking loop: " <> ppr mods-  new_hpt <--    fixIO $ \new_hpt -> do-      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }-      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $-                mapM (typecheckIface . hm_iface) hmis-      let new_hpt = addListToHpt old_hpt-                        (zip mods [ hmi{ hm_details = details }-                                  | (hmi,details) <- zip hmis mds ])-      return new_hpt-  return hsc_env{ hsc_HPT = new_hpt }-  where-    old_hpt = hsc_HPT hsc_env-    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods--reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]-reachableBackwards mod summaries-  = [ node_payload node | node <- reachableG (transposeG graph) root ]-  where -- the rest just sets up the graph:-        (graph, lookup_node) = moduleGraphNodes False summaries-        root  = expectJust "reachableBackwards" (lookup_node $ GWIB mod IsBoot)---- --------------------------------------------------------------------------------- | Topological sort of the module graph-topSortModuleGraph-          :: Bool-          -- ^ Drop hi-boot nodes? (see below)-          -> ModuleGraph-          -> Maybe ModuleName-             -- ^ Root module name.  If @Nothing@, use the full graph.-          -> [SCC ModSummary]--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes--- The resulting list of strongly-connected-components is in topologically--- sorted order, starting with the module(s) at the bottom of the--- dependency graph (ie compile them first) and ending with the ones at--- the top.------ Drop hi-boot nodes (first boolean arg)?------ - @False@:   treat the hi-boot summaries as nodes of the graph,---              so the graph must be acyclic------ - @True@:    eliminate the hi-boot nodes, and instead pretend---              the a source-import of Foo is an import of Foo---              The resulting graph has no hi-boot nodes, but can be cyclic--topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod-  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph-  where-    summaries = mgModSummaries module_graph-    -- stronglyConnCompG flips the original order, so if we reverse-    -- the summaries we get a stable topological sort.-    (graph, lookup_node) =-      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)--    initial_graph = case mb_root_mod of-        Nothing -> graph-        Just root_mod ->-            -- restrict the graph to just those modules reachable from-            -- the specified module.  We do this by building a graph with-            -- the full set of nodes, and determining the reachable set from-            -- the specified node.-            let root | Just node <- lookup_node $ GWIB root_mod NotBoot-                     , graph `hasVertexG` node-                     = node-                     | otherwise-                     = throwGhcException (ProgramError "module does not exist")-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))--type SummaryNode = Node Int ModSummary--summaryNodeKey :: SummaryNode -> Int-summaryNodeKey = node_key--summaryNodeSummary :: SummaryNode -> ModSummary-summaryNodeSummary = node_payload--unfilteredEdges :: Bool -> ModSummary -> [ModuleNameWithIsBoot]-unfilteredEdges drop_hs_boot_nodes ms =-    (flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++-    (flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) ++-    [ GWIB (ms_mod_name ms) IsBoot-    | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile-      -- see [boot-edges] below-    ]-  where-    -- [boot-edges] if this is a .hs and there is an equivalent-    -- .hs-boot, add a link from the former to the latter.  This-    -- has the effect of detecting bogus cases where the .hs-boot-    -- depends on the .hs, by introducing a cycle.  Additionally,-    -- it ensures that we will always process the .hs-boot before-    -- the .hs, and so the HomePackageTable will always have the-    -- most up to date information.--    -- Drop hs-boot nodes by using HsSrcFile as the key-    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature-                | otherwise          = IsBoot--moduleGraphNodes :: Bool -> [ModSummary]-  -> (Graph SummaryNode, ModuleNameWithIsBoot -> Maybe SummaryNode)-moduleGraphNodes drop_hs_boot_nodes summaries =-  (graphFromEdgedVerticesUniq nodes, lookup_node)-  where-    numbered_summaries = zip summaries [1..]--    lookup_node :: ModuleNameWithIsBoot -> Maybe SummaryNode-    lookup_node mnwib = Map.lookup mnwib node_map--    lookup_key :: ModuleNameWithIsBoot -> Maybe Int-    lookup_key = fmap summaryNodeKey . lookup_node--    node_map :: NodeMap SummaryNode-    node_map = Map.fromList [ (mkHomeBuildModule s, node)-                            | node <- nodes-                            , let s = summaryNodeSummary node-                            ]--    -- We use integers as the keys for the SCC algorithm-    nodes :: [SummaryNode]-    nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s-            | (s, key) <- numbered_summaries-             -- Drop the hi-boot ones if told to do so-            , not (isBootSummary s == IsBoot && drop_hs_boot_nodes)-            ]--    out_edge_keys :: [ModuleNameWithIsBoot] -> [Int]-    out_edge_keys = mapMaybe lookup_key-        -- If we want keep_hi_boot_nodes, then we do lookup_key with-        -- IsBoot; else False---- The nodes of the graph are keyed by (mod, is boot?) pairs--- NB: hsig files show up as *normal* nodes (not boot!), since they don't--- participate in cycles (for now)-type NodeKey   = ModuleNameWithIsBoot-type NodeMap a = Map.Map NodeKey a--msKey :: ModSummary -> NodeKey-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })-    = GWIB-        { gwib_mod = moduleName mod-        , gwib_isBoot = hscSourceToIsBoot boot-        }--mkNodeMap :: [ModSummary] -> NodeMap ModSummary-mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]--nodeMapElts :: NodeMap a -> [a]-nodeMapElts = Map.elems---- | If there are {-# SOURCE #-} imports between strongly connected--- components in the topological sort, then those imports can--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE--- were necessary, then the edge would be part of a cycle.-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()-warnUnnecessarySourceImports sccs = do-  dflags <- getDynFlags-  when (wopt Opt_WarnUnusedImports dflags)-    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))-  where check dflags ms =-           let mods_in_this_cycle = map ms_mod_name ms in-           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,-                             unLoc i `notElem`  mods_in_this_cycle ]--        warn :: DynFlags -> Located ModuleName -> WarnMsg-        warn dflags (L loc mod) =-           mkPlainErrMsg dflags loc-                (text "Warning: {-# SOURCE #-} unnecessary in import of "-                 <+> quotes (ppr mod))-------------------------------------------------------------------------------------- | Downsweep (dependency analysis)------ Chase downwards from the specified root set, returning summaries--- for all home modules encountered.  Only follow source-import--- links.------ We pass in the previous collection of summaries, which is used as a--- cache to avoid recalculating a module summary if the source is--- unchanged.------ The returned list of [ModSummary] nodes has one node for each home-package--- module, plus one for any hs-boot files.  The imports of these nodes--- are all there, including the imports of non-home-package modules.-downsweep :: HscEnv-          -> [ModSummary]       -- Old summaries-          -> [ModuleName]       -- Ignore dependencies on these; treat-                                -- them as if they were package modules-          -> Bool               -- True <=> allow multiple targets to have-                                --          the same module name; this is-                                --          very useful for ghc -M-          -> IO [Either ErrorMessages ModSummary]-                -- The elts of [ModSummary] all have distinct-                -- (Modules, IsBoot) identifiers, unless the Bool is true-                -- in which case there can be repeats-downsweep hsc_env old_summaries excl_mods allow_dup_roots-   = do-       rootSummaries <- mapM getRootSummary roots-       let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549-           root_map = mkRootMap rootSummariesOk-       checkDuplicates root_map-       map0 <- loop (concatMap calcDeps rootSummariesOk) root_map-       -- if we have been passed -fno-code, we enable code generation-       -- for dependencies of modules that have -XTemplateHaskell,-       -- otherwise those modules will fail to compile.-       -- See Note [-fno-code mode] #8025-       map1 <- if hscTarget dflags == HscNothing-         then enableCodeGenForTH-           (defaultObjectTarget dflags)-           map0-         else if hscTarget dflags == HscInterpreted-           then enableCodeGenForUnboxedTuplesOrSums-             (defaultObjectTarget dflags)-             map0-           else return map0-       if null errs-         then pure $ concat $ nodeMapElts map1-         else pure $ map Left errs-     where-        calcDeps = msDeps--        dflags = hsc_dflags hsc_env-        roots = hsc_targets hsc_env--        old_summary_map :: NodeMap ModSummary-        old_summary_map = mkNodeMap old_summaries--        getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)-        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)-           = do exists <- liftIO $ doesFileExist file-                if exists || isJust maybe_buf-                    then summariseFile hsc_env old_summaries file mb_phase-                                       obj_allowed maybe_buf-                    else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $-                           text "can't find file:" <+> text file-        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)-           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot-                                           (L rootLoc modl) obj_allowed-                                           maybe_buf excl_mods-                case maybe_summary of-                   Nothing -> return $ Left $ moduleNotFoundErr dflags modl-                   Just s  -> return s--        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")--        -- In a root module, the filename is allowed to diverge from the module-        -- name, so we have to check that there aren't multiple root files-        -- defining the same module (otherwise the duplicates will be silently-        -- ignored, leading to confusing behaviour).-        checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()-        checkDuplicates root_map-           | allow_dup_roots = return ()-           | null dup_roots  = return ()-           | otherwise       = liftIO $ multiRootsErr dflags (head dup_roots)-           where-             dup_roots :: [[ModSummary]]        -- Each at least of length 2-             dup_roots = filterOut isSingleton $ map rights $ nodeMapElts root_map--        loop :: [GenWithIsBoot (Located ModuleName)]-                        -- Work list: process these modules-             -> NodeMap [Either ErrorMessages ModSummary]-                        -- Visited set; the range is a list because-                        -- the roots can have the same module names-                        -- if allow_dup_roots is True-             -> IO (NodeMap [Either ErrorMessages ModSummary])-                        -- The result is the completed NodeMap-        loop [] done = return done-        loop (s : ss) done-          | Just summs <- Map.lookup key done-          = if isSingleton summs then-                loop ss done-            else-                do { multiRootsErr dflags (rights summs); return Map.empty }-          | otherwise-          = do mb_s <- summariseModule hsc_env old_summary_map-                                       is_boot wanted_mod True-                                       Nothing excl_mods-               case mb_s of-                   Nothing -> loop ss done-                   Just (Left e) -> loop ss (Map.insert key [Left e] done)-                   Just (Right s)-> do-                     new_map <--                       loop (calcDeps s) (Map.insert key [Right s] done)-                     loop ss new_map-          where-            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s-            wanted_mod = L loc mod-            key = GWIB-                    { gwib_mod = unLoc wanted_mod-                    , gwib_isBoot = is_boot-                    }---- | Update the every ModSummary that is depended on--- by a module that needs template haskell. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.--- See Note [-fno-code mode]-enableCodeGenForTH :: HscTarget-  -> NodeMap [Either ErrorMessages ModSummary]-  -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenForTH =-  enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession-  where-    condition = isTemplateHaskellOrQQNonBoot-    should_modify (ModSummary { ms_hspp_opts = dflags }) =-      hscTarget dflags == HscNothing &&-      -- Don't enable codegen for TH on indefinite packages; we-      -- can't compile anything anyway! See #16219.-      homeUnitIsDefinite dflags---- | Update the every ModSummary that is depended on--- by a module that needs unboxed tuples. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.------ This is used in order to load code that uses unboxed tuples--- or sums into GHCi while still allowing some code to be interpreted.-enableCodeGenForUnboxedTuplesOrSums :: HscTarget-  -> NodeMap [Either ErrorMessages ModSummary]-  -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenForUnboxedTuplesOrSums =-  enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule-  where-    condition ms =-      unboxed_tuples_or_sums (ms_hspp_opts ms) &&-      not (gopt Opt_ByteCodeIfUnboxed (ms_hspp_opts ms)) &&-      (isBootSummary ms == NotBoot)-    unboxed_tuples_or_sums d =-      xopt LangExt.UnboxedTuples d || xopt LangExt.UnboxedSums d-    should_modify (ModSummary { ms_hspp_opts = dflags }) =-      hscTarget dflags == HscInterpreted---- | Helper used to implement 'enableCodeGenForTH' and--- 'enableCodeGenForUnboxedTuples'. In particular, this enables--- unoptimized code generation for all modules that meet some--- condition (first parameter), or are dependencies of those--- modules. The second parameter is a condition to check before--- marking modules for code generation.-enableCodeGenWhen-  :: (ModSummary -> Bool)-  -> (ModSummary -> Bool)-  -> TempFileLifetime-  -> TempFileLifetime-  -> HscTarget-  -> NodeMap [Either ErrorMessages ModSummary]-  -> IO (NodeMap [Either ErrorMessages ModSummary])-enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =-  traverse (traverse (traverse enable_code_gen)) nodemap-  where-    enable_code_gen ms-      | ModSummary-        { ms_mod = ms_mod-        , ms_location = ms_location-        , ms_hsc_src = HsSrcFile-        , ms_hspp_opts = dflags-        } <- ms-      , should_modify ms-      , ms_mod `Set.member` needs_codegen_set-      = do-        let new_temp_file suf dynsuf = do-              tn <- newTempName dflags staticLife suf-              let dyn_tn = tn -<.> dynsuf-              addFilesToClean dflags dynLife [dyn_tn]-              return tn-          -- We don't want to create .o or .hi files unless we have been asked-          -- to by the user. But we need them, so we patch their locations in-          -- the ModSummary with temporary files.-          ---        (hi_file, o_file) <--          -- If ``-fwrite-interface` is specified, then the .o and .hi files-          -- are written into `-odir` and `-hidir` respectively.  #16670-          if gopt Opt_WriteInterface dflags-            then return (ml_hi_file ms_location, ml_obj_file ms_location)-            else (,) <$> (new_temp_file (hiSuf dflags) (dynHiSuf dflags))-                     <*> (new_temp_file (objectSuf dflags) (dynObjectSuf dflags))-        return $-          ms-          { ms_location =-              ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}-          , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}-          }-      | otherwise = return ms--    needs_codegen_set = transitive_deps_set-      [ ms-      | mss <- Map.elems nodemap-      , Right ms <- mss-      , condition ms-      ]--    -- find the set of all transitive dependencies of a list of modules.-    transitive_deps_set modSums = foldl' go Set.empty modSums-      where-        go marked_mods ms@ModSummary{ms_mod}-          | ms_mod `Set.member` marked_mods = marked_mods-          | otherwise =-            let deps =-                  [ dep_ms-                  -- If a module imports a boot module, msDeps helpfully adds a-                  -- dependency to that non-boot module in it's result. This-                  -- means we don't have to think about boot modules here.-                  | dep <- msDeps ms-                  , NotBoot == gwib_isBoot dep-                  , dep_ms_0 <- toList $ Map.lookup (unLoc <$> dep) nodemap-                  , dep_ms_1 <- toList $ dep_ms_0-                  , dep_ms <- toList $ dep_ms_1-                  ]-                new_marked_mods = Set.insert ms_mod marked_mods-            in foldl' go new_marked_mods deps--mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]-mkRootMap summaries = Map.insertListWith (flip (++))-                                         [ (msKey s, [Right s]) | s <- summaries ]-                                         Map.empty---- | Returns the dependencies of the ModSummary s.--- A wrinkle is that for a {-# SOURCE #-} import we return---      *both* the hs-boot file---      *and* the source file--- as "dependencies".  That ensures that the list of all relevant--- modules always contains B.hs if it contains B.hs-boot.--- Remember, this pass isn't doing the topological sort.  It's--- just gathering the list of all relevant ModSummaries-msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]-msDeps s = [ d-           | m <- ms_home_srcimps s-           , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }-                  , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }-                  ]-           ]-        ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }-           | m <- ms_home_imps s-           ]---------------------------------------------------------------------------------- Summarising modules---- We have two types of summarisation:------    * Summarise a file.  This is used for the root module(s) passed to---      cmLoadModules.  The file is read, and used to determine the root---      module name.  The module name may differ from the filename.------    * Summarise a module.  We are given a module name, and must provide---      a summary.  The finder is used to locate the file in which the module---      resides.--summariseFile-        :: HscEnv-        -> [ModSummary]                 -- old summaries-        -> FilePath                     -- source file name-        -> Maybe Phase                  -- start phase-        -> Bool                         -- object code allowed?-        -> Maybe (StringBuffer,UTCTime)-        -> IO (Either ErrorMessages ModSummary)--summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf-        -- we can use a cached summary if one is available and the-        -- source file hasn't changed,  But we have to look up the summary-        -- by source file, rather than module name as we do in summarise.-   | Just old_summary <- findSummaryBySourceFile old_summaries src_fn-   = do-        let location = ms_location old_summary-            dflags = hsc_dflags hsc_env--        src_timestamp <- get_src_timestamp-                -- The file exists; we checked in getRootSummary above.-                -- If it gets removed subsequently, then this-                -- getModificationUTCTime may fail, but that's the right-                -- behaviour.--                -- return the cached summary if the source didn't change-        checkSummaryTimestamp-            hsc_env dflags obj_allowed NotBoot (new_summary src_fn)-            old_summary location src_timestamp--   | otherwise-   = do src_timestamp <- get_src_timestamp-        new_summary src_fn src_timestamp-  where-    get_src_timestamp = case maybe_buf of-                           Just (_,t) -> return t-                           Nothing    -> liftIO $ getModificationUTCTime src_fn-                        -- getModificationUTCTime may fail--    new_summary src_fn src_timestamp = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf---        -- Make a ModLocation for this file-        location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn--        -- Tell the Finder cache where it is, so that subsequent calls-        -- to findModule will find it, even if it's not on any search path-        mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_timestamp = src_timestamp-            , nms_is_boot = NotBoot-            , nms_hsc_src =-                if isHaskellSigFilename src_fn-                   then HsigFile-                   else HsSrcFile-            , nms_location = location-            , nms_mod = mod-            , nms_obj_allowed = obj_allowed-            , nms_preimps = preimps-            }--findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary-findSummaryBySourceFile summaries file-  = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],-                                 expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of-        [] -> Nothing-        (x:_) -> Just x--checkSummaryTimestamp-    :: HscEnv -> DynFlags -> Bool -> IsBootInterface-    -> (UTCTime -> IO (Either e ModSummary))-    -> ModSummary -> ModLocation -> UTCTime-    -> IO (Either e ModSummary)-checkSummaryTimestamp-  hsc_env dflags obj_allowed is_boot new_summary-  old_summary location src_timestamp-  | ms_hs_date old_summary == src_timestamp &&-      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do-           -- update the object-file timestamp-           obj_timestamp <--             if isObjectTarget (hscTarget (hsc_dflags hsc_env))-                 || obj_allowed -- bug #1205-                 then liftIO $ getObjTimestamp location is_boot-                 else return Nothing--           -- We have to repopulate the Finder's cache for file targets-           -- because the file might not even be on the regular search path-           -- and it was likely flushed in depanal. This is not technically-           -- needed when we're called from sumariseModule but it shouldn't-           -- hurt.-           _ <- addHomeModuleToFinder hsc_env-                  (moduleName (ms_mod old_summary)) location--           hi_timestamp <- maybeGetIfaceDate dflags location-           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)--           return $ Right old_summary-               { ms_obj_date = obj_timestamp-               , ms_iface_date = hi_timestamp-               , ms_hie_date = hie_timestamp-               }--   | otherwise =-           -- source changed: re-summarise.-           new_summary src_timestamp---- Summarise a module, and pick up source and timestamp.-summariseModule-          :: HscEnv-          -> NodeMap ModSummary -- Map of old summaries-          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import-          -> Located ModuleName -- Imported module to be summarised-          -> Bool               -- object code allowed?-          -> Maybe (StringBuffer, UTCTime)-          -> [ModuleName]               -- Modules to exclude-          -> IO (Maybe (Either ErrorMessages ModSummary))      -- Its new summary--summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)-                obj_allowed maybe_buf excl_mods-  | wanted_mod `elem` excl_mods-  = return Nothing--  | Just old_summary <- Map.lookup-      (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })-      old_summary_map-  = do          -- Find its new timestamp; all the-                -- ModSummaries in the old map have valid ml_hs_files-        let location = ms_location old_summary-            src_fn = expectJust "summariseModule" (ml_hs_file location)--                -- check the modification time on the source file, and-                -- return the cached summary if it hasn't changed.  If the-                -- file has disappeared, we need to call the Finder again.-        case maybe_buf of-           Just (_,t) ->-               Just <$> check_timestamp old_summary location src_fn t-           Nothing    -> do-                m <- tryIO (getModificationUTCTime src_fn)-                case m of-                   Right t ->-                       Just <$> check_timestamp old_summary location src_fn t-                   Left e | isDoesNotExistError e -> find_it-                          | otherwise             -> ioError e--  | otherwise  = find_it-  where-    dflags = hsc_dflags hsc_env--    check_timestamp old_summary location src_fn =-        checkSummaryTimestamp-          hsc_env dflags obj_allowed is_boot-          (new_summary location (ms_mod old_summary) src_fn)-          old_summary location--    find_it = do-        found <- findImportedModule hsc_env wanted_mod Nothing-        case found of-             Found location mod-                | isJust (ml_hs_file location) ->-                        -- Home package-                         Just <$> just_found location mod--             _ -> return Nothing-                        -- Not found-                        -- (If it is TRULY not found at all, we'll-                        -- error when we actually try to compile)--    just_found location mod = do-                -- Adjust location to point to the hs-boot source file,-                -- hi file, object file, when is_boot says so-        let location' = case is_boot of-              IsBoot -> addBootSuffixLocn location-              NotBoot -> location-            src_fn = expectJust "summarise2" (ml_hs_file location')--                -- Check that it exists-                -- It might have been deleted since the Finder last found it-        maybe_t <- modificationTimeIfExists src_fn-        case maybe_t of-          Nothing -> return $ Left $ noHsFileErr dflags loc src_fn-          Just t  -> new_summary location' mod src_fn t--    new_summary location mod src_fn src_timestamp-      = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf--        -- NB: Despite the fact that is_boot is a top-level parameter, we-        -- don't actually know coming into this function what the HscSource-        -- of the module in question is.  This is because we may be processing-        -- this module because another module in the graph imported it: in this-        -- case, we know if it's a boot or not because of the {-# SOURCE #-}-        -- annotation, but we don't know if it's a signature or a regular-        -- module until we actually look it up on the filesystem.-        let hsc_src-              | is_boot == IsBoot = HsBootFile-              | isHaskellSigFilename src_fn = HsigFile-              | otherwise = HsSrcFile--        when (pi_mod_name /= wanted_mod) $-                throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $-                              text "File name does not match module name:"-                              $$ text "Saw:" <+> quotes (ppr pi_mod_name)-                              $$ text "Expected:" <+> quotes (ppr wanted_mod)--        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations dflags))) $-            let suggested_instantiated_with =-                    hcat (punctuate comma $-                        [ ppr k <> text "=" <> ppr v-                        | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)-                                : homeUnitInstantiations dflags)-                        ])-            in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $-                text "Unexpected signature:" <+> quotes (ppr pi_mod_name)-                $$ if gopt Opt_BuildingCabalPackage dflags-                    then parens (text "Try adding" <+> quotes (ppr pi_mod_name)-                            <+> text "to the"-                            <+> quotes (text "signatures")-                            <+> text "field in your Cabal file.")-                    else parens (text "Try passing -instantiated-with=\"" <>-                                 suggested_instantiated_with <> text "\"" $$-                                text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_timestamp = src_timestamp-            , nms_is_boot = is_boot-            , nms_hsc_src = hsc_src-            , nms_location = location-            , nms_mod = mod-            , nms_obj_allowed = obj_allowed-            , nms_preimps = preimps-            }---- | Convenience named arguments for 'makeNewModSummary' only used to make--- code more readable, not exported.-data MakeNewModSummary-  = MakeNewModSummary-      { nms_src_fn :: FilePath-      , nms_src_timestamp :: UTCTime-      , nms_is_boot :: IsBootInterface-      , nms_hsc_src :: HscSource-      , nms_location :: ModLocation-      , nms_mod :: Module-      , nms_obj_allowed :: Bool-      , nms_preimps :: PreprocessedImports-      }--makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary-makeNewModSummary hsc_env MakeNewModSummary{..} = do-  let PreprocessedImports{..} = nms_preimps-  let dflags = hsc_dflags hsc_env--  -- when the user asks to load a source file by name, we only-  -- use an object file if -fobject-code is on.  See #1205.-  obj_timestamp <- liftIO $-      if isObjectTarget (hscTarget dflags)-         || nms_obj_allowed -- bug #1205-          then getObjTimestamp nms_location nms_is_boot-          else return Nothing--  hi_timestamp <- maybeGetIfaceDate dflags nms_location-  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)--  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name-  required_by_imports <- implicitRequirements hsc_env pi_theimps--  return $ ModSummary-      { ms_mod = nms_mod-      , ms_hsc_src = nms_hsc_src-      , ms_location = nms_location-      , ms_hspp_file = pi_hspp_fn-      , ms_hspp_opts = pi_local_dflags-      , ms_hspp_buf  = Just pi_hspp_buf-      , ms_parsed_mod = Nothing-      , ms_srcimps = pi_srcimps-      , ms_textual_imps =-          pi_theimps ++ extra_sig_imports ++ required_by_imports-      , ms_hs_date = nms_src_timestamp-      , ms_iface_date = hi_timestamp-      , ms_hie_date = hie_timestamp-      , ms_obj_date = obj_timestamp-      }--getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)-getObjTimestamp location is_boot-  = case is_boot of-      IsBoot -> return Nothing-      NotBoot -> modificationTimeIfExists (ml_obj_file location)--data PreprocessedImports-  = PreprocessedImports-      { pi_local_dflags :: DynFlags-      , pi_srcimps  :: [(Maybe FastString, Located ModuleName)]-      , pi_theimps  :: [(Maybe FastString, Located ModuleName)]-      , pi_hspp_fn  :: FilePath-      , pi_hspp_buf :: StringBuffer-      , pi_mod_name_loc :: SrcSpan-      , pi_mod_name :: ModuleName-      }---- Preprocess the source file and get its imports--- The pi_local_dflags contains the OPTIONS pragmas-getPreprocessedImports-    :: HscEnv-    -> FilePath-    -> Maybe Phase-    -> Maybe (StringBuffer, UTCTime)-    -- ^ optional source code buffer and modification time-    -> ExceptT ErrorMessages IO PreprocessedImports-getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do-  (pi_local_dflags, pi_hspp_fn)-      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase-  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn-  (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)-      <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn-  return PreprocessedImports {..}-----------------------------------------------------------------------------------                      Error messages---------------------------------------------------------------------------------- Defer and group warning, error and fatal messages so they will not get lost--- in the regular output.-withDeferredDiagnostics :: GhcMonad m => m a -> m a-withDeferredDiagnostics f = do-  dflags <- getDynFlags-  if not $ gopt Opt_DeferDiagnostics dflags-  then f-  else do-    warnings <- liftIO $ newIORef []-    errors <- liftIO $ newIORef []-    fatals <- liftIO $ newIORef []--    let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do-          let action = putLogMsg dflags reason severity srcSpan msg-          case severity of-            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())-            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())-            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())-            _ -> action--        printDeferredDiagnostics = liftIO $-          forM_ [warnings, errors, fatals] $ \ref -> do-            -- This IORef can leak when the dflags leaks, so let us always-            -- reset the content.-            actions <- atomicModifyIORef' ref $ \i -> ([], i)-            sequence_ $ reverse actions--        setLogAction action = modifySession $ \hsc_env ->-          hsc_env{ hsc_dflags = (hsc_dflags hsc_env){ log_action = action } }--    MC.bracket-      (setLogAction deferDiagnostics)-      (\_ -> setLogAction (log_action dflags) >> printDeferredDiagnostics)-      (\_ -> f)--noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg--- ToDo: we don't have a proper line number for this error-noModError dflags loc wanted_mod err-  = mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err--noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages-noHsFileErr dflags loc path-  = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path--moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages-moduleNotFoundErr dflags mod-  = unitBag $ mkPlainErrMsg dflags noSrcSpan $-        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"--multiRootsErr :: DynFlags -> [ModSummary] -> IO ()-multiRootsErr _      [] = panic "multiRootsErr"-multiRootsErr dflags summs@(summ1:_)-  = throwOneError $ mkPlainErrMsg dflags noSrcSpan $-        text "module" <+> quotes (ppr mod) <+>-        text "is defined in multiple files:" <+>-        sep (map text files)-  where-    mod = ms_mod summ1-    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs--keepGoingPruneErr :: [ModuleName] -> SDoc-keepGoingPruneErr ms-  = vcat (( text "-fkeep-going in use, removing the following" <+>-            text "dependencies and continuing:"):-          map (nest 6 . ppr) ms )--cyclicModuleErr :: [ModSummary] -> SDoc--- From a strongly connected component we find--- a single cycle to report-cyclicModuleErr mss-  = ASSERT( not (null mss) )-    case findCycle graph of-       Nothing   -> text "Unexpected non-cycle" <+> ppr mss-       Just path -> vcat [ text "Module imports form a cycle:"-                         , nest 2 (show_path path) ]-  where-    graph :: [Node NodeKey ModSummary]-    graph = [ DigraphNode ms (msKey ms) (get_deps ms) | ms <- mss]--    get_deps :: ModSummary -> [NodeKey]-    get_deps ms =-      [ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }-      | m <- ms_home_srcimps ms ] ++-      [ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }-      | m <- ms_home_imps    ms ]--    show_path []         = panic "show_path"-    show_path [m]        = text "module" <+> ppr_ms m-                           <+> text "imports itself"-    show_path (m1:m2:ms) = vcat ( nest 7 (text "module" <+> ppr_ms m1)-                                : nest 6 (text "imports" <+> ppr_ms m2)-                                : go ms )-       where-         go []     = [text "which imports" <+> ppr_ms m1]-         go (m:ms) = (text "which imports" <+> ppr_ms m) : go ms-+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GHC.Driver.Make (+        depanal, depanalE, depanalPartial,+        load, load', LoadHowMuch(..),+        instantiationNodes,++        downsweep,++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        summariseModule,+        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirementsShallow,++        noModError, cyclicModuleErr,+        moduleGraphNodes, SummaryNode,+        IsBootInterface(..),++        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert+    ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad  ( initIfaceCheck )++import GHC.Runtime.Interpreter+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types++import GHC.Runtime.Context++import GHC.Driver.Config+import GHC.Driver.Phases+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Main++import GHC.Parser.Header+import GHC.Parser.Errors.Ppr++import GHC.Iface.Load      ( cannotFindModule )+import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired ( MustCompile ) )++import GHC.Data.Bag        ( unitBag, listToBag, unionManyBags, isEmptyBag )+import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe      ( expectJust )+import GHC.Data.StringBuffer+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( tryIO )+import GHC.Utils.Monad     ( allM )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Types.Basic+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet+import GHC.Types.Unique.Set+import GHC.Types.Name+import GHC.Types.Name.Env++import GHC.Unit+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo++import Data.Either ( rights, partitionEithers )+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import qualified GHC.Data.FiniteMap as Map ( insertListWith )++import Control.Concurrent ( forkIOWithUnmask, killThread )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Concurrent.QSem+import Control.Exception+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.List (nub, sortBy, partition)+import qualified Data.List as List+import Data.Foldable (toList)+import Data.Maybe+import Data.Ord ( comparing )+import Data.Time+import Data.Bifunctor (first)+import System.Directory+import System.FilePath+import System.IO        ( fixIO )+import System.IO.Error  ( isDoesNotExistError )++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+-- In case of errors, just throw them.+--+depanal :: GhcMonad m =>+           [ModuleName]  -- ^ excluded modules+        -> Bool          -- ^ allow duplicate roots+        -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots+    if isEmptyBag errs+      then pure mod_graph+      else throwErrors errs++-- | Perform dependency analysis like in 'depanal'.+-- In case of errors, the errors and an empty module graph are returned.+depanalE :: GhcMonad m =>     -- New for #17459+            [ModuleName]      -- ^ excluded modules+            -> Bool           -- ^ allow duplicate roots+            -> m (ErrorMessages, ModuleGraph)+depanalE excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots+    if isEmptyBag errs+      then do+        let unused_home_mod_err = warnMissingHomeModules hsc_env mod_graph+            unused_pkg_err = warnUnusedPackages hsc_env mod_graph+            warns = unused_home_mod_err ++ unused_pkg_err+        when (not $ null warns) $+          logWarnings (listToBag warns)+        setSession hsc_env { hsc_mod_graph = mod_graph }+        pure (errs, mod_graph)+      else do+        -- We don't have a complete module dependency graph,+        -- The graph may be disconnected and is unusable.+        setSession hsc_env { hsc_mod_graph = emptyMG }+        pure (errs, emptyMG)+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+    :: GhcMonad m+    => [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (ErrorMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial excluded_mods allow_dup_roots = do+  hsc_env <- getSession+  let+         dflags  = hsc_dflags hsc_env+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env+         logger  = hsc_logger hsc_env++  withTiming logger dflags (text "Chasing dependencies") (const ()) $ do+    liftIO $ debugTraceMsg logger dflags 2 (hcat [+              text "Chasing modules from: ",+              hcat (punctuate comma (map pprTarget targets))])++    -- Home package modules may have been moved or deleted, and new+    -- source files may have appeared in the home package that shadow+    -- external package modules, so we have to discard the existing+    -- cached finder data.+    liftIO $ flushFinderCaches hsc_env++    mod_summariesE <- liftIO $ downsweep+      hsc_env (mgExtendedModSummaries old_graph)+      excluded_mods allow_dup_roots+    let+      (errs, mod_summaries) = partitionEithers mod_summariesE+      mod_graph = mkModuleGraph' $+        fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)+    return (unionManyBags errs, mod_graph)++-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+--+-- In the future, perhaps more of the work of instantiation could be moved here,+-- instead of shoved in with the module compilation nodes. That could simplify+-- backpack, and maybe hs-boot too.+instantiationNodes :: UnitState -> [ModuleGraphNode]+instantiationNodes unit_state = InstantiationNode <$> iuids_to_check+  where+    iuids_to_check :: [InstantiatedUnit]+    iuids_to_check =+      nubSort $ concatMap goUnitId (explicitUnits unit_state)+     where+      goUnitId uid =+        [ recur+        | VirtUnit indef <- [uid]+        , inst <- instUnitInsts indef+        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+        ]++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes user doesn't want GHC to pick up modules, not explicitly listed+-- in a command line. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns user about modules, not listed+-- neither in `exposed-modules`, nor in `other-modules`.+--+-- Here "home module" means a module, that doesn't come from an other package.+--+-- For example, if GHC is invoked with modules "A" and "B" as targets,+-- but "A" imports some other module "C", then GHC will issue a warning+-- about module "C" not being listed in a command line.+--+-- The warning in enabled by `-Wmissing-home-modules`. See #13129+warnMissingHomeModules :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]+warnMissingHomeModules hsc_env mod_graph =+    if (wopt Opt_WarnMissingHomeModules dflags && not (null missing))+    then [warn]+    else []+  where+    dflags = hsc_dflags hsc_env+    targets = map targetId (hsc_targets hsc_env)++    is_known_module mod = any (is_my_target mod) targets++    -- We need to be careful to handle the case where (possibly+    -- path-qualified) filenames (aka 'TargetFile') rather than module+    -- names are being passed on the GHC command-line.+    --+    -- For instance, `ghc --make src-exe/Main.hs` and+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.+    -- Note also that we can't always infer the associated module name+    -- directly from the filename argument.  See #13727.+    is_my_target mod (TargetModule name)+      = moduleName (ms_mod mod) == name+    is_my_target mod (TargetFile target_file _)+      | Just mod_file <- ml_hs_file (ms_location mod)+      = target_file == mod_file ||++           --  Don't warn on B.hs-boot if B.hs is specified (#16551)+           addBootSuffix target_file == mod_file ||++           --  We can get a file target even if a module name was+           --  originally specified in a command line because it can+           --  be converted in guessTarget (by appending .hs/.lhs).+           --  So let's convert it back and compare with module name+           mkModuleName (fst $ splitExtension target_file)+            == moduleName (ms_mod mod)+    is_my_target _ _ = False++    missing = map (moduleName . ms_mod) $+      filter (not . is_known_module) (mgModSummaries mod_graph)++    msg+      | gopt Opt_BuildingCabalPackage dflags+      = hang+          (text "These modules are needed for compilation but not listed in your .cabal file's other-modules: ")+          4+          (sep (map ppr missing))+      | otherwise+      =+        hang+          (text "Modules are not listed in command line but needed for compilation: ")+          4+          (sep (map ppr missing))+    warn = makeIntoWarning+      (Reason Opt_WarnMissingHomeModules)+      (mkPlainMsgEnvelope noSrcSpan msg)++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+   = LoadAllTargets+     -- ^ Load all targets and its dependencies.+   | LoadUpTo ModuleName+     -- ^ Load only the given module and its dependencies.+   | LoadDependenciesOf ModuleName+     -- ^ Load only the dependencies of the given module, but not the module+     -- itself.++-- | Try to load the program.  See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- If errors are encountered during dependency analysis, the module `depanalE`+-- returns together with the errors an empty ModuleGraph.+-- After processing this empty ModuleGraph, the errors of depanalE are thrown.+-- All other errors are reported using the 'defaultWarnErrLogger'.+--+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag+load how_much = do+    (errs, mod_graph) <- depanalE [] False                        -- #17459+    success <- load' how_much (Just batchMsg) mod_graph+    if isEmptyBag errs+      then pure success+      else throwErrors errs++-- Note [Unused packages]+--+-- Cabal passes `--package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: HscEnv -> ModuleGraph -> [MsgEnvelope DecoratedSDoc]+warnUnusedPackages hsc_env mod_graph =+    let dflags = hsc_dflags hsc_env+        state  = hsc_units hsc_env++    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(fs, mn) -> lookupModulePackage state (unLoc mn) fs)+            $ concatMap ms_imps (mgModSummaries mod_graph)++        requestedArgs = mapMaybe packageArg (packageFlags dflags)++        unusedArgs+          = filter (\arg -> not $ any (matching state arg) loadedPackages)+                   requestedArgs++        warn = makeIntoWarning+          (Reason Opt_WarnUnusedPackages)+          (mkPlainMsgEnvelope noSrcSpan msg)+        msg = vcat [ text "The following packages were specified" <+>+                     text "via -package or -package-id flags,"+                   , text "but were not needed for compilation:"+                   , nest 2 (vcat (map (withDash . pprUnusedArg) unusedArgs)) ]++    in if not (null unusedArgs) && wopt Opt_WarnUnusedPackages dflags+       then [warn]+       else []++    where+        packageArg (ExposePackage _ arg _) = Just arg+        packageArg _ = Nothing++        pprUnusedArg (PackageArg str) = text str+        pprUnusedArg (UnitIdArg uid) = ppr uid++        withDash = (<+>) (text "-")++        matchingStr :: String -> UnitInfo -> Bool+        matchingStr str p+                =  str == unitPackageIdString p+                || str == unitPackageNameString p++        matching :: UnitState -> PackageArg -> UnitInfo -> Bool+        matching _ (PackageArg str) p = matchingStr str p+        matching state (UnitIdArg uid) p = uid == realUnit state p++        -- For wired-in packages, we have to unwire their id,+        -- otherwise they won't match package flags+        realUnit :: UnitState -> UnitInfo -> Unit+        realUnit state+          = unwireUnit state+          . RealUnit+          . Definite+          . unitId++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' how_much mHscMessage mod_graph = do+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }+    guessOutputFile+    hsc_env <- getSession++    let hpt1   = hsc_HPT hsc_env+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let interp = hscInterp hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods =+          mkUniqSet [ ms_mod_name s+                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- files without corresponding hs files.+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,+    --                              not (ms_mod_name s `elem` all_home_mods)]+    -- ASSERT( null bad_boot_mods ) return ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo m)           = checkMod m+        checkHowMuch (LoadDependenciesOf m) = checkMod m+        checkHowMuch _ = id++        checkMod m and_then+            | m `elementOfUniqSet` all_home_mods = and_then+            | otherwise = do+                    liftIO $ errorMsg logger dflags+                        (text "no such module:" <+> quotes (ppr m))+                    return Failed++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles.  Among other things, it is used for+    -- backing out partially complete cycles following a failed+    -- upsweep, and for removing from hpt all the modules+    -- not in strict downwards closure, during calls to compile.+    let mg2_with_srcimps :: [SCC ModSummary]+        mg2_with_srcimps = filterToposortToModules $+          topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports mg2_with_srcimps++    let+        -- check the stability property for each module.+        stable_mods@(stable_obj,stable_bco)+            = checkStability hpt1 mg2_with_srcimps all_home_mods++        -- prune bits of the HPT which are definitely redundant now,+        -- to save space.+        pruned_hpt = pruneHomePackageTable hpt1+                            (flattenSCCs mg2_with_srcimps)+                            stable_mods++    _ <- liftIO $ evaluate pruned_hpt++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write the pruned HPT to allow the old HPT to be GC'd.+    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }++    liftIO $ debugTraceMsg logger dflags 2 (text "Stable obj:" <+> ppr stable_obj $$+                            text "Stable BCO:" <+> ppr stable_bco)++    -- Unload any modules which are going to be re-linked this time around.+    let stable_linkables = [ linkable+                           | m <- nonDetEltsUniqSet stable_obj +++                                  nonDetEltsUniqSet stable_bco,+                             -- It's OK to use nonDetEltsUniqSet here+                             -- because it only affects linking. Besides+                             -- this list only serves as a poor man's set.+                             Just hmi <- [lookupHpt pruned_hpt m],+                             Just linkable <- [hm_linkable hmi] ]+    liftIO $ unload interp hsc_env stable_linkables++    -- We could at this point detect cycles which aren't broken by+    -- a source-import, and complain immediately, but it seems better+    -- to let upsweep_mods do this, so at least some useful work gets+    -- done before the upsweep is abandoned.+    --hPutStrLn stderr "after tsort:\n"+    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))++    -- Now do the upsweep, calling compile for each module in+    -- turn.  Final result is version 3 of everything.++    -- Topologically sort the module graph, this time including hi-boot+    -- nodes, and possibly just including the portion of the graph+    -- reachable from the module specified in the 2nd argument to load.+    -- This graph should be cycle-free.+    -- If we're restricting the upsweep to a portion of the graph, we+    -- also want to retain everything that is still stable.+    let full_mg, partial_mg0, partial_mg, unstable_mg :: [SCC ModuleGraphNode]+        stable_mg :: [SCC ExtendedModSummary]+        full_mg    = topSortModuleGraph False mod_graph Nothing++        maybe_top_mod = case how_much of+                            LoadUpTo m           -> Just m+                            LoadDependenciesOf m -> Just m+                            _                    -> Nothing++        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod++        -- LoadDependenciesOf m: we want the upsweep to stop just+        -- short of the specified module (unless the specified module+        -- is stable).+        partial_mg+            | LoadDependenciesOf _mod <- how_much+            = ASSERT( case last partial_mg0 of+                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod; _ -> False )+              List.init partial_mg0+            | otherwise+            = partial_mg0++        stable_mg =+            [ AcyclicSCC ems+            | AcyclicSCC (ModuleNode ems@(ExtendedModSummary ms _)) <- full_mg+            , stable_mod_summary ms+            ]++        stable_mod_summary ms =+          ms_mod_name ms `elementOfUniqSet` stable_obj ||+          ms_mod_name ms `elementOfUniqSet` stable_bco++        -- the modules from partial_mg that are not also stable+        -- NB. also keep cycles, we need to emit an error message later+        unstable_mg = filter not_stable partial_mg+          where not_stable (CyclicSCC _) = True+                not_stable (AcyclicSCC (InstantiationNode _)) = True+                not_stable (AcyclicSCC (ModuleNode (ExtendedModSummary ms _)))+                   = not $ stable_mod_summary ms++        -- Load all the stable modules first, before attempting to load+        -- an unstable module (#7231).+        mg = fmap (fmap ModuleNode) stable_mg ++ unstable_mg++    liftIO $ debugTraceMsg logger dflags 2 (hang (text "Ready for upsweep")+                               2 (ppr mg))++    n_jobs <- case parMakeCount dflags of+                    Nothing -> liftIO getNumProcessors+                    Just n  -> return n+    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs+                   | otherwise  = upsweep++    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }+    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $+      upsweep_fn mHscMessage pruned_hpt stable_mods mg++    -- Make modsDone be the summaries for each home module now+    -- available; this should equal the domain of hpt3.+    -- Get in in a roughly top .. bottom order (hence reverse).++    let nodesDone = reverse modsUpswept+        (_, modsDone) = partitionNodes nodesDone++    -- Try and do linking in some form, depending on whether the+    -- upsweep was completely or only partially successful.++    if succeeded upsweep_ok++     then+       -- Easy; just relink it all.+       do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep completely successful.")++          -- Clean up after ourselves+          hsc_env1 <- getSession+          liftIO $ cleanCurrentModuleTempFiles logger (hsc_tmpfs hsc_env1) dflags++          -- Issue a warning for the confusing case where the user+          -- said '-o foo' but we're not going to do any linking.+          -- We attempt linking if either (a) one of the modules is+          -- called Main, or (b) the user said -no-hs-main, indicating+          -- that main() is going to come from somewhere else.+          --+          let ofile = outputFile dflags+          let no_hs_main = gopt Opt_NoHsMain dflags+          let+            main_mod = mainModIs hsc_env+            a_root_is_Main = mgElemModule mod_graph main_mod+            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++          -- link everything together+          hsc_env <- getSession+          linkresult <- liftIO $ link (ghcLink dflags)+                                      logger+                                      (hsc_tmpfs hsc_env)+                                      (hsc_hooks hsc_env)+                                      dflags+                                      (hsc_unit_env hsc_env)+                                      do_linking+                                      (hsc_HPT hsc_env1)++          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking+             then do+                liftIO $ errorMsg logger dflags $ text+                   ("output was redirected with -o, " +++                    "but no output will be generated\n" +++                    "because there is no " +++                    moduleNameString (moduleName main_mod) ++ " module.")+                -- This should be an error, not a warning (#10895).+                loadFinish Failed linkresult+             else+                loadFinish Succeeded linkresult++     else+       -- Tricky.  We need to back out the effects of compiling any+       -- half-done cycles, both so as to clean up the top level envs+       -- and to avoid telling the interactive linker to link them.+       do liftIO $ debugTraceMsg logger dflags 2 (text "Upsweep partially successful.")++          let modsDone_names+                 = map (ms_mod . emsModSummary) modsDone+          let mods_to_zap_names+                 = findPartiallyCompletedCycles modsDone_names+                      mg2_with_srcimps+          let (mods_to_clean, mods_to_keep) =+                partition ((`Set.member` mods_to_zap_names).ms_mod) $+                emsModSummary <$> modsDone+          hsc_env1 <- getSession+          let hpt4 = hsc_HPT hsc_env1+              -- We must change the lifetime to TFL_CurrentModule for any temp+              -- file created for an element of mod_to_clean during the upsweep.+              -- These include preprocessed files and object files for loaded+              -- modules.+              unneeded_temps = concat+                [ms_hspp_file : object_files+                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean+                , let object_files = maybe [] linkableObjs $+                        lookupHpt hpt4 (moduleName ms_mod)+                        >>= hm_linkable+                ]+          tmpfs <- hsc_tmpfs <$> getSession+          liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps+          liftIO $ cleanCurrentModuleTempFiles logger tmpfs dflags++          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)+                                          hpt4++          -- Clean up after ourselves++          -- there should be no Nothings where linkables should be, now+          let just_linkables =+                    isNoLink (ghcLink dflags)+                 || allHpt (isJust.hm_linkable)+                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)+                                hpt5)+          ASSERT( just_linkables ) do++          -- Link everything together+          hsc_env <- getSession+          linkresult <- liftIO $ link (ghcLink dflags)+                                      logger+                                      (hsc_tmpfs hsc_env)+                                      (hsc_hooks hsc_env)+                                      dflags+                                      (hsc_unit_env hsc_env)+                                      False+                                      hpt5++          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }+          loadFinish Failed linkresult++partitionNodes+  :: [ModuleGraphNode]+  -> ( [InstantiatedUnit]+     , [ExtendedModSummary]+     )+partitionNodes ns = partitionEithers $ flip fmap ns $ \case+  InstantiationNode x -> Left x+  ModuleNode x -> Right x++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag++-- If the link failed, unload everything and return.+loadFinish _all_ok Failed+  = do hsc_env <- getSession+       let interp = hscInterp hsc_env+       liftIO $ unload interp hsc_env []+       modifySession discardProg+       return Failed++-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok Succeeded+  = do modifySession discardIC+       return all_ok+++-- | Forget the current program, but retain the persistent info in HscEnv+discardProg :: HscEnv -> HscEnv+discardProg hsc_env+  = discardIC $ hsc_env { hsc_mod_graph = emptyMG+                        , hsc_HPT = emptyHomePackageTable }++-- | Discard the contents of the InteractiveContext, but keep the DynFlags and+-- the loaded plugins.  It will also keep ic_int_print and ic_monad if their+-- names are from external packages.+discardIC :: HscEnv -> HscEnv+discardIC hsc_env+  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print+                                , ic_monad     = new_ic_monad+                                , ic_plugins   = old_plugins+                                } }+  where+  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic+  !new_ic_int_print = keep_external_name ic_int_print+  !new_ic_monad = keep_external_name ic_monad+  !old_plugins = ic_plugins old_ic+  dflags = ic_dflags old_ic+  old_ic = hsc_IC hsc_env+  empty_ic = emptyInteractiveContext dflags+  keep_external_name ic_name+    | nameIsFromExternalPackage home_unit old_name = old_name+    | otherwise = ic_name empty_ic+    where+    home_unit = hsc_home_unit hsc_env+    old_name = ic_name old_ic++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    let dflags = hsc_dflags env+        -- Force mod_graph to avoid leaking env+        !mod_graph = hsc_mod_graph env+        mainModuleSrcPath :: Maybe String+        mainModuleSrcPath = do+            ms <- mgLookupModule mod_graph (mainModIs env)+            ml_hs_file (ms_location ms)+        name = fmap dropExtension mainModuleSrcPath++        name_exe = do+#if defined(mingw32_HOST_OS)+          -- we must add the .exe extension unconditionally here, otherwise+          -- when name has an extension of its own, the .exe extension will+          -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248+          name' <- fmap (<.> "exe") name+#else+          name' <- name+#endif+          mainModuleSrcPath' <- mainModuleSrcPath+          -- #9930: don't clobber input files (unless they ask for it)+          if name' == mainModuleSrcPath'+            then throwGhcException . UsageError $+                 "default output name would overwrite the input file; " +++                 "must specify -o explicitly"+            else Just name'+    in+    case outputFile_ dflags of+        Just _ -> env+        Nothing -> env { hsc_dflags = dflags { outputFile_ = name_exe } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - For non-stable modules:+--      - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+pruneHomePackageTable :: HomePackageTable+                      -> [ModSummary]+                      -> StableModules+                      -> HomePackageTable+pruneHomePackageTable hpt summ (stable_obj, stable_bco)+  = mapHpt prune hpt+  where prune hmi+          | is_stable modl = hmi'+          | otherwise      = hmi'{ hm_details = emptyModDetails }+          where+           modl = moduleName (mi_module (hm_iface hmi))+           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms+                = hmi{ hm_linkable = Nothing }+                | otherwise+                = hmi+                where ms = expectJust "prune" (lookupUFM ms_map modl)++        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]++        is_stable m =+          m `elementOfUniqSet` stable_obj ||+          m `elementOfUniqSet` stable_bco++-- -----------------------------------------------------------------------------+--+-- | Return (names of) all those in modsDone who are part of a cycle as defined+-- by theGraph.+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module+findPartiallyCompletedCycles modsDone theGraph+   = Set.unions+       [mods_in_this_cycle+       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.+       , let names_in_this_cycle = Set.fromList (map ms_mod vs)+             mods_in_this_cycle =+                    Set.intersection (Set.fromList modsDone) names_in_this_cycle+         -- If size mods_in_this_cycle == size names_in_this_cycle,+         -- then this cycle has already been completed and we're not+         -- interested.+       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]+++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: Interp -> HscEnv -> [Linkable] -> IO ()+unload interp hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload interp hsc_env stable_linkables+        _other -> return ()++-- -----------------------------------------------------------------------------+{- |++  Stability tells us which modules definitely do not need to be recompiled.+  There are two main reasons for having stability:++   - avoid doing a complete upsweep of the module graph in GHCi when+     modules near the bottom of the tree have not changed.++   - to tell GHCi when it can load object code: we can only load object code+     for a module when we also load object code fo  all of the imports of the+     module.  So we need to know that we will definitely not be recompiling+     any of these modules, and we can use the object code.++  The stability check is as follows.  Both stableObject and+  stableBCO are used during the upsweep phase later.++@+  stable m = stableObject m || stableBCO m++  stableObject m =+        all stableObject (imports m)+        && old linkable does not exist, or is == on-disk .o+        && date(on-disk .o) > date(.hs)++  stableBCO m =+        all stable (imports m)+        && date(BCO) > date(.hs)+@++  These properties embody the following ideas:++    - if a module is stable, then:++        - if it has been compiled in a previous pass (present in HPT)+          then it does not need to be compiled or re-linked.++        - if it has not been compiled in a previous pass,+          then we only need to read its .hi file from disk and+          link it to produce a 'ModDetails'.++    - if a modules is not stable, we will definitely be at least+      re-linking, and possibly re-compiling it during the 'upsweep'.+      All non-stable modules can (and should) therefore be unlinked+      before the 'upsweep'.++    - Note that objects are only considered stable if they only depend+      on other objects.  We can't link object code against byte code.++    - Note that even if an object is stable, we may end up recompiling+      if the interface is out of date because an *external* interface+      has changed.  The current code in GHC.Driver.Make handles this case+      fairly poorly, so be careful.+-}++type StableModules =+  ( UniqSet ModuleName  -- stableObject+  , UniqSet ModuleName  -- stableBCO+  )+++checkStability+        :: HomePackageTable   -- HPT from last compilation+        -> [SCC ModSummary]   -- current module graph (cyclic)+        -> UniqSet ModuleName -- all home modules+        -> StableModules++checkStability hpt sccs all_home_mods =+  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs+  where+   checkSCC :: StableModules -> SCC ModSummary -> StableModules+   checkSCC (stable_obj, stable_bco) scc0+     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)+     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)+     | otherwise     = (stable_obj, stable_bco)+     where+        scc = flattenSCC scc0+        scc_mods = map ms_mod_name scc+        home_module m =+          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods++        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))+            -- all imports outside the current SCC, but in the home pkg++        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps+        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps++        stableObjects =+           and stable_obj_imps+           && all object_ok scc++        stableBCOs =+           and (zipWith (||) stable_obj_imps stable_bco_imps)+           && all bco_ok scc++        object_ok ms+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False+          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms+                                         && same_as_prev t+          | otherwise = False+          where+             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of+                                Just hmi  | Just l <- hm_linkable hmi+                                 -> isObjectLinkable l && t == linkableTime l+                                _other  -> True+                -- why '>=' rather than '>' above?  If the filesystem stores+                -- times to the nearest second, we may occasionally find that+                -- the object & source have the same modification time,+                -- especially if the source was automatically generated+                -- and compiled.  Using >= is slightly unsafe, but it matches+                -- make's behaviour.+                --+                -- But see #5527, where someone ran into this and it caused+                -- a problem.++        bco_ok ms+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False+          | otherwise = case lookupHpt hpt (ms_mod_name ms) of+                Just hmi  | Just l <- hm_linkable hmi ->+                        not (isObjectLinkable l) &&+                        linkableTime l >= ms_hs_date ms+                _other  -> False++{- Parallel Upsweep+ -+ - The parallel upsweep attempts to concurrently compile the modules in the+ - compilation graph using multiple Haskell threads.+ -+ - The Algorithm+ -+ - A Haskell thread is spawned for each module in the module graph, waiting for+ - its direct dependencies to finish building before it itself begins to build.+ -+ - Each module is associated with an initially empty MVar that stores the+ - result of that particular module's compile. If the compile succeeded, then+ - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that+ - module, and the module's HMI is deleted from the old HPT (synchronized by an+ - IORef) to save space.+ -+ - Instead of immediately outputting messages to the standard handles, all+ - compilation output is deferred to a per-module TQueue. A QSem is used to+ - limit the number of workers that are compiling simultaneously.+ -+ - Meanwhile, the main thread sequentially loops over all the modules in the+ - module graph, outputting the messages stored in each module's TQueue.+-}++-- | Each module is given a unique 'LogQueue' to redirect compilation messages+-- to. A 'Nothing' value contains the result of compilation, and denotes the+-- end of the message queue.+data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, SDoc)])+                         !(MVar ())++-- | The graph of modules to compile and their corresponding result 'MVar' and+-- 'LogQueue'.+type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]++-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,+-- also returning the first, if any, encountered module cycle.+buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])+buildCompGraph [] = return ([], Nothing)+buildCompGraph (scc:sccs) = case scc of+    AcyclicSCC ms -> do+        mvar <- newEmptyMVar+        log_queue <- do+            ref <- newIORef []+            sem <- newEmptyMVar+            return (LogQueue ref sem)+        (rest,cycle) <- buildCompGraph sccs+        return ((ms,mvar,log_queue):rest, cycle)+    CyclicSCC mss -> return ([], Just mss)++-- | A Module and whether it is a boot module.+--+-- We need to treat boot modules specially when building compilation graphs,+-- since they break cycles. Regular source files and signature files are treated+-- equivalently.+data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot+  deriving (Eq, Ord)++-- | Tests if an 'HscSource' is a boot file, primarily for constructing elements+-- of 'BuildModule'. We conflate signatures and modules because they are bound+-- in the same namespace; only boot interfaces can be disambiguated with+-- `import {-# SOURCE #-}`.+hscSourceToIsBoot :: HscSource -> IsBootInterface+hscSourceToIsBoot HsBootFile = IsBoot+hscSourceToIsBoot _ = NotBoot++mkBuildModule :: ModuleGraphNode -> BuildModule+mkBuildModule = \case+  InstantiationNode x -> BuildModule_Unit x+  ModuleNode ems -> BuildModule_Module $ mkBuildModule0 (emsModSummary ems)++mkHomeBuildModule :: ModuleGraphNode -> NodeKey+mkHomeBuildModule = \case+  InstantiationNode x -> NodeKey_Unit x+  ModuleNode ems -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary ems)++mkBuildModule0 :: ModSummary -> ModuleWithIsBoot+mkBuildModule0 ms = GWIB+  { gwib_mod = ms_mod ms+  , gwib_isBoot = isBootSummary ms+  }++mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot+mkHomeBuildModule0 ms = GWIB+  { gwib_mod = moduleName $ ms_mod ms+  , gwib_isBoot = isBootSummary ms+  }++-- | The entry point to the parallel upsweep.+--+-- See also the simpler, sequential 'upsweep'.+parUpsweep+    :: GhcMonad m+    => Int+    -- ^ The number of workers we wish to run in parallel+    -> Maybe Messager+    -> HomePackageTable+    -> StableModules+    -> [SCC ModuleGraphNode]+    -> m (SuccessFlag,+          [ModuleGraphNode])+parUpsweep n_jobs mHscMessage old_hpt stable_mods sccs = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let tmpfs  = hsc_tmpfs hsc_env++    -- The bits of shared state we'll be using:++    -- The global HscEnv is updated with the module's HMI when a module+    -- successfully compiles.+    hsc_env_var <- liftIO $ newMVar hsc_env++    -- The old HPT is used for recompilation checking in upsweep_mod. When a+    -- module successfully gets compiled, its HMI is pruned from the old HPT.+    old_hpt_var <- liftIO $ newIORef old_hpt++    -- What we use to limit parallelism with.+    par_sem <- liftIO $ newQSem n_jobs+++    let updNumCapabilities = liftIO $ do+            n_capabilities <- getNumCapabilities+            n_cpus <- getNumProcessors+            -- Setting number of capabilities more than+            -- CPU count usually leads to high userspace+            -- lock contention. #9221+            let n_caps = min n_jobs n_cpus+            unless (n_capabilities /= 1) $ setNumCapabilities n_caps+            return n_capabilities+    -- Reset the number of capabilities once the upsweep ends.+    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n++    MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do++    -- Sync the global session with the latest HscEnv once the upsweep ends.+    let finallySyncSession io = io `MC.finally` do+            hsc_env <- liftIO $ readMVar hsc_env_var+            setSession hsc_env++    finallySyncSession $ do++    -- Build the compilation graph out of the list of SCCs. Module cycles are+    -- handled at the very end, after some useful work gets done. Note that+    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).+    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs+    let comp_graph_w_idx = zip comp_graph [1..]++    -- The list of all loops in the compilation graph.+    -- NB: For convenience, the last module of each loop (aka the module that+    -- finishes the loop) is prepended to the beginning of the loop.+    let graph = map fstOf3 (reverse comp_graph)+        boot_modules = mkModuleSet+          [ms_mod ms | ModuleNode (ExtendedModSummary ms _) <- graph, isBootSummary ms == IsBoot]+        comp_graph_loops = go graph boot_modules+          where+            remove ms bm = case isBootSummary ms of+              IsBoot -> delModuleSet bm (ms_mod ms)+              NotBoot -> bm+            go [] _ = []+            go (InstantiationNode _ : mss) boot_modules+              = go mss boot_modules+            go mg@(mnode@(ModuleNode (ExtendedModSummary ms _)) : mss) boot_modules+              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)+              = map mkBuildModule (mnode : loop) : go mss (remove ms boot_modules)+              | otherwise+              = go mss (remove ms boot_modules)++    -- Build a Map out of the compilation graph with which we can efficiently+    -- look up the result MVar associated with a particular home module.+    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)+        home_mod_map =+            Map.fromList [ (mkBuildModule ms, (mvar, idx))+                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]+++    liftIO $ label_self "main --make thread"++    -- Make the logger thread_safe: we only make the "log" action thread-safe in+    -- each worker by setting a LogAction hook, so we need to make the logger+    -- thread-safe for other actions (DumpAction, TraceAction).+    thread_safe_logger <- liftIO $ makeThreadSafe logger++    -- For each module in the module graph, spawn a worker thread that will+    -- compile this module.+    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->+            forkIOWithUnmask $ \unmask -> do+                liftIO $ label_self $ unwords $ concat+                    [ [ "worker --make thread" ]+                    , case mod of+                        InstantiationNode iuid ->+                          [ "for instantiation of unit"+                          , show $ VirtUnit iuid+                          ]+                        ModuleNode ems ->+                          [ "for module"+                          , show (moduleNameString (ms_mod_name (emsModSummary ems)))+                          ]+                    , ["number"+                      , show mod_idx+                      ]+                    ]+                -- Replace the default log_action with one that writes each+                -- message to the module's log_queue. The main thread will+                -- deal with synchronously printing these messages.+                let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger++                -- Use a local TmpFs so that we can clean up intermediate files+                -- in a timely fashion (as soon as compilation for that module+                -- is finished) without having to worry about accidentally+                -- deleting a simultaneous compile's important files.+                lcl_tmpfs <- forkTmpFsFrom tmpfs++                -- Unmask asynchronous exceptions and perform the thread-local+                -- work to compile the module (see parUpsweep_one).+                m_res <- MC.try $ unmask $ prettyPrintGhcErrors dflags $+                  case mod of+                    InstantiationNode iuid -> do+                      hsc_env <- readMVar hsc_env_var+                      liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid+                      pure Succeeded+                    ModuleNode ems ->+                      parUpsweep_one (emsModSummary ems) home_mod_map comp_graph_loops+                                     lcl_logger lcl_tmpfs dflags (hsc_home_unit hsc_env)+                                     mHscMessage+                                     par_sem hsc_env_var old_hpt_var+                                     stable_mods mod_idx (length sccs)++                res <- case m_res of+                    Right flag -> return flag+                    Left exc -> do+                        -- Don't print ThreadKilled exceptions: they are used+                        -- to kill the worker thread in the event of a user+                        -- interrupt, and the user doesn't have to be informed+                        -- about that.+                        when (fromException exc /= Just ThreadKilled)+                             (errorMsg lcl_logger dflags (text (show exc)))+                        return Failed++                -- Populate the result MVar.+                putMVar mvar res++                -- Write the end marker to the message queue, telling the main+                -- thread that it can stop waiting for messages from this+                -- particular compile.+                writeLogQueue log_queue Nothing++                -- Add the remaining files that weren't cleaned up to the+                -- global TmpFs, for cleanup later.+                mergeTmpFsInto lcl_tmpfs tmpfs++        -- Kill all the workers, masking interrupts (since killThread is+        -- interruptible). XXX: This is not ideal.+        ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread }+++    -- Spawn the workers, making sure to kill them later. Collect the results+    -- of each compile.+    results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ ->+        -- Loop over each module in the compilation graph in order, printing+        -- each message from its log_queue.+        forM comp_graph $ \(mod,mvar,log_queue) -> do+            printLogs logger dflags log_queue+            result <- readMVar mvar+            if succeeded result then return (Just mod) else return Nothing+++    -- Collect and return the ModSummaries of all the successful compiles.+    -- NB: Reverse this list to maintain output parity with the sequential upsweep.+    let ok_results = reverse (catMaybes results)++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+            liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr mss)+            return (Failed,ok_results)+        Nothing  -> do+            let success_flag = successIf (all isJust results)+            return (success_flag,ok_results)++  where+    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,SDoc) -> IO ()+    writeLogQueue (LogQueue ref sem) msg = do+        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())+        _ <- tryPutMVar sem ()+        return ()++    -- The log_action callback that is used to synchronize messages from a+    -- worker thread.+    parLogAction :: LogQueue -> LogAction+    parLogAction log_queue _dflags !reason !severity !srcSpan !msg =+        writeLogQueue log_queue (Just (reason,severity,srcSpan,msg))++    -- Print each message from the log_queue using the log_action from the+    -- session's DynFlags.+    printLogs :: Logger -> DynFlags -> LogQueue -> IO ()+    printLogs !logger !dflags (LogQueue ref sem) = read_msgs+      where read_msgs = do+                takeMVar sem+                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)+                print_loop msgs++            print_loop [] = read_msgs+            print_loop (x:xs) = case x of+                Just (reason,severity,srcSpan,msg) -> do+                    putLogMsg logger dflags reason severity srcSpan msg+                    print_loop xs+                -- Exit the loop once we encounter the end marker.+                Nothing -> return ()++-- The interruptible subset of the worker threads' work.+parUpsweep_one+    :: ModSummary+    -- ^ The module we wish to compile+    -> Map BuildModule (MVar SuccessFlag, Int)+    -- ^ The map of home modules and their result MVar+    -> [[BuildModule]]+    -- ^ The list of all module loops within the compilation graph.+    -> Logger+    -- ^ The thread-local Logger+    -> TmpFs+    -- ^ The thread-local TmpFs+    -> DynFlags+    -- ^ The thread-local DynFlags+    -> HomeUnit+    -- ^ The home-unit+    -> Maybe Messager+    -- ^ The messager+    -> QSem+    -- ^ The semaphore for limiting the number of simultaneous compiles+    -> MVar HscEnv+    -- ^ The MVar that synchronizes updates to the global HscEnv+    -> IORef HomePackageTable+    -- ^ The old HPT+    -> StableModules+    -- ^ Sets of stable objects and BCOs+    -> Int+    -- ^ The index of this module+    -> Int+    -- ^ The total number of modules+    -> IO SuccessFlag+    -- ^ The result of this compile+parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem+               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do++    let this_build_mod = mkBuildModule0 mod++    let home_imps     = map unLoc $ ms_home_imps mod+    let home_src_imps = map unLoc $ ms_home_srcimps mod++    -- All the textual imports of this module.+    let textual_deps = Set.fromList $+            zipWith f home_imps     (repeat NotBoot) +++            zipWith f home_src_imps (repeat IsBoot)+          where f mn isBoot = BuildModule_Module $ GWIB+                  { gwib_mod = mkHomeModule home_unit mn+                  , gwib_isBoot = isBoot+                  }++    -- Dealing with module loops+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~+    --+    -- Not only do we have to deal with explicit textual dependencies, we also+    -- have to deal with implicit dependencies introduced by import cycles that+    -- are broken by an hs-boot file. We have to ensure that:+    --+    -- 1. A module that breaks a loop must depend on all the modules in the+    --    loop (transitively or otherwise). This is normally always fulfilled+    --    by the module's textual dependencies except in degenerate loops,+    --    e.g.:+    --+    --    A.hs imports B.hs-boot+    --    B.hs doesn't import A.hs+    --    C.hs imports A.hs, B.hs+    --+    --    In this scenario, getModLoop will detect the module loop [A,B] but+    --    the loop finisher B doesn't depend on A. So we have to explicitly add+    --    A in as a dependency of B when we are compiling B.+    --+    -- 2. A module that depends on a module in an external loop can't proceed+    --    until the entire loop is re-typechecked.+    --+    -- These two invariants have to be maintained to correctly build a+    -- compilation graph with one or more loops.+++    -- The loop that this module will finish. After this module successfully+    -- compiles, this loop is going to get re-typechecked.+    let finish_loop :: Maybe [ModuleWithIsBoot]+        finish_loop = listToMaybe+          [ flip mapMaybe (tail loop) $ \case+              BuildModule_Unit _ -> Nothing+              BuildModule_Module ms -> Just ms+          | loop <- comp_graph_loops+          , head loop == BuildModule_Module this_build_mod+          ]++    -- If this module finishes a loop then it must depend on all the other+    -- modules in that loop because the entire module loop is going to be+    -- re-typechecked once this module gets compiled. These extra dependencies+    -- are this module's "internal" loop dependencies, because this module is+    -- inside the loop in question.+    let int_loop_deps :: Set.Set BuildModule+        int_loop_deps = Set.fromList $+            case finish_loop of+                Nothing   -> []+                Just loop -> BuildModule_Module <$> filter (/= this_build_mod) loop++    -- If this module depends on a module within a loop then it must wait for+    -- that loop to get re-typechecked, i.e. it must wait on the module that+    -- finishes that loop. These extra dependencies are this module's+    -- "external" loop dependencies, because this module is outside of the+    -- loop(s) in question.+    let ext_loop_deps :: Set.Set BuildModule+        ext_loop_deps = Set.fromList+            [ head loop | loop <- comp_graph_loops+                        , any (`Set.member` textual_deps) loop+                        , BuildModule_Module this_build_mod `notElem` loop ]+++    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]++    -- All of the module's home-module dependencies.+    let home_deps_with_idx =+            [ home_dep | dep <- Set.toList all_deps+                       , Just home_dep <- [Map.lookup dep home_mod_map]+                       ]++    -- Sort the list of dependencies in reverse-topological order. This way, by+    -- the time we get woken up by the result of an earlier dependency,+    -- subsequent dependencies are more likely to have finished. This step+    -- effectively reduces the number of MVars that each thread blocks on.+    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx++    -- Wait for the all the module's dependencies to finish building.+    deps_ok <- allM (fmap succeeded . readMVar) home_deps++    -- We can't build this module if any of its dependencies failed to build.+    if not deps_ok+      then return Failed+      else do+        -- Any hsc_env at this point is OK to use since we only really require+        -- that the HPT contains the HMIs of our dependencies.+        hsc_env <- readMVar hsc_env_var+        old_hpt <- readIORef old_hpt_var++        let logg err = printBagOfErrors lcl_logger lcl_dflags (srcErrorMessages err)++        -- Limit the number of parallel compiles.+        let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)+        mb_mod_info <- withSem par_sem $+            handleSourceError (\err -> do logg err; return Nothing) $ do+                -- Have the HscEnv point to our local logger and tmpfs.+                let lcl_hsc_env = localize_hsc_env hsc_env++                -- Re-typecheck the loop+                -- This is necessary to make sure the knot is tied when+                -- we close a recursive module loop, see bug #12035.+                type_env_var <- liftIO $ newIORef emptyNameEnv+                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =+                                    Just (ms_mod mod, type_env_var) }+                lcl_hsc_env'' <- case finish_loop of+                    Nothing   -> return lcl_hsc_env'+                    -- In the non-parallel case, the retypecheck prior to+                    -- typechecking the loop closer includes all modules+                    -- EXCEPT the loop closer.  However, our precomputed+                    -- SCCs include the loop closer, so we have to filter+                    -- it out.+                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $+                                 filter (/= moduleName (gwib_mod this_build_mod)) $+                                 map (moduleName . gwib_mod) loop++                -- Compile the module.+                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods+                                        mod mod_index num_mods+                return (Just mod_info)++        case mb_mod_info of+            Nothing -> return Failed+            Just mod_info -> do+                let this_mod = ms_mod_name mod++                -- Prune the old HPT unless this is an hs-boot module.+                unless (isBootSummary mod == IsBoot) $+                    atomicModifyIORef' old_hpt_var $ \old_hpt ->+                        (delFromHpt old_hpt this_mod, ())++                -- Update and fetch the global HscEnv.+                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do+                    let hsc_env' = hsc_env+                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                                           this_mod mod_info }+                    -- We've finished typechecking the module, now we must+                    -- retypecheck the loop AGAIN to ensure unfoldings are+                    -- updated.  This time, however, we include the loop+                    -- closer!+                    hsc_env'' <- case finish_loop of+                        Nothing   -> return hsc_env'+                        Just loop -> typecheckLoop lcl_dflags hsc_env' $+                                     map (moduleName . gwib_mod) loop+                    return (hsc_env'', localize_hsc_env hsc_env'')++                -- Clean up any intermediate files.+                cleanCurrentModuleTempFiles (hsc_logger lcl_hsc_env')+                                            (hsc_tmpfs  lcl_hsc_env')+                                            (hsc_dflags lcl_hsc_env')+                return Succeeded++  where+    localize_hsc_env hsc_env+        = hsc_env { hsc_logger = lcl_logger+                  , hsc_tmpfs  = lcl_tmpfs+                  }++-- -----------------------------------------------------------------------------+--+-- | The upsweep+--+-- This is where we compile each module in the module graph, in a pass+-- from the bottom to the top of the graph.+--+-- There better had not be any cyclic groups here -- we check for them.+upsweep+    :: forall m+    .  GhcMonad m+    => Maybe Messager+    -> HomePackageTable            -- ^ HPT from last time round (pruned)+    -> StableModules               -- ^ stable modules (see checkStability)+    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)+    -> m (SuccessFlag,+          [ModuleGraphNode])+       -- ^ Returns:+       --+       --  1. A flag whether the complete upsweep was successful.+       --  2. The 'HscEnv' in the monad has an updated HPT+       --  3. A list of modules which succeeded loading.++upsweep mHscMessage old_hpt stable_mods sccs = do+   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)+   return (res, reverse $ mgModSummaries' done)+ where+  keep_going+    :: [NodeKey]+    -> HomePackageTable+    -> ModuleGraph+    -> [SCC ModuleGraphNode]+    -> Int+    -> Int+    -> m (SuccessFlag, ModuleGraph)+  keep_going this_mods old_hpt done mods mod_index nmods = do+    let sum_deps ms (AcyclicSCC iuidOrMod) =+          if any (flip elem $ unfilteredEdges False iuidOrMod) $ ms+          then mkHomeBuildModule iuidOrMod : ms+          else ms+        sum_deps ms _ = ms+        dep_closure = foldl' sum_deps this_mods mods+        dropped_ms = drop (length this_mods) (reverse dep_closure)+        prunable (AcyclicSCC node) = elem (mkHomeBuildModule node) dep_closure+        prunable _ = False+        mods' = filter (not . prunable) mods+        nmods' = nmods - length dropped_ms++    when (not $ null dropped_ms) $ do+        dflags <- getSessionDynFlags+        logger <- getLogger+        liftIO $ fatalErrorMsg logger dflags (keepGoingPruneErr $ dropped_ms)+    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'+    return (Failed, done')++  upsweep'+    :: HomePackageTable+    -> ModuleGraph+    -> [SCC ModuleGraphNode]+    -> Int+    -> Int+    -> m (SuccessFlag, ModuleGraph)+  upsweep' _old_hpt done+     [] _ _+     = return (Succeeded, done)++  upsweep' _old_hpt done+     (CyclicSCC ms : mods) mod_index nmods+   = do dflags <- getSessionDynFlags+        logger <- getLogger+        liftIO $ fatalErrorMsg logger dflags (cyclicModuleErr ms)+        if gopt Opt_KeepGoing dflags+          then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods+          else return (Failed, done)++  upsweep' old_hpt done+     (AcyclicSCC (InstantiationNode iuid) : mods) mod_index nmods+   = do hsc_env <- getSession+        liftIO $ upsweep_inst hsc_env mHscMessage mod_index nmods iuid+        upsweep' old_hpt done mods (mod_index+1) nmods++  upsweep' old_hpt done+     (AcyclicSCC (ModuleNode ems@(ExtendedModSummary mod _)) : mods) mod_index nmods+   = do -- putStrLn ("UPSWEEP_MOD: hpt = " +++        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)+        --                     (moduleEnvElts (hsc_HPT hsc_env)))+        let logg _mod = defaultWarnErrLogger++        hsc_env <- getSession++        -- Remove unwanted tmp files between compilations+        liftIO $ cleanCurrentModuleTempFiles (hsc_logger hsc_env)+                                             (hsc_tmpfs  hsc_env)+                                             (hsc_dflags hsc_env)++        -- Get ready to tie the knot+        type_env_var <- liftIO $ newIORef emptyNameEnv+        let hsc_env1 = hsc_env { hsc_type_env_var =+                                    Just (ms_mod mod, type_env_var) }+        setSession hsc_env1++        -- Lazily reload the HPT modules participating in the loop.+        -- See Note [Tying the knot]--if we don't throw out the old HPT+        -- and reinitalize the knot-tying process, anything that was forced+        -- while we were previously typechecking won't get updated, this+        -- was bug #12035.+        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done+        setSession hsc_env2++        mb_mod_info+            <- handleSourceError+                   (\err -> do logg mod (Just err); return Nothing) $ do+                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt stable_mods+                                                  mod mod_index nmods+                 logg mod Nothing -- log warnings+                 return (Just mod_info)++        case mb_mod_info of+          Nothing -> do+                dflags <- getSessionDynFlags+                if gopt Opt_KeepGoing dflags+                  then keep_going [NodeKey_Module $ mkHomeBuildModule0 mod] old_hpt done mods mod_index nmods+                  else return (Failed, done)+          Just mod_info -> do+                let this_mod = ms_mod_name mod++                        -- Add new info to hsc_env+                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info+                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }++                        -- Space-saving: delete the old HPT entry+                        -- for mod BUT if mod is a hs-boot+                        -- node, don't delete it.  For the+                        -- interface, the HPT entry is probably for the+                        -- main Haskell source file.  Deleting it+                        -- would force the real module to be recompiled+                        -- every time.+                    old_hpt1 = case isBootSummary mod of+                      IsBoot -> old_hpt+                      NotBoot -> delFromHpt old_hpt this_mod++                    done' = extendMG done ems++                        -- fixup our HomePackageTable after we've finished compiling+                        -- a mutually-recursive loop.  We have to do this again+                        -- to make sure we have the final unfoldings, which may+                        -- not have been computed accurately in the previous+                        -- retypecheck.+                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'+                setSession hsc_env4++                        -- Add any necessary entries to the static pointer+                        -- table. See Note [Grand plan for static forms] in+                        -- GHC.Iface.Tidy.StaticPtrTable.+                when (backend (hsc_dflags hsc_env4) == Interpreter) $+                    liftIO $ hscAddSptEntries hsc_env4+                                 [ spt+                                 | Just linkable <- pure $ hm_linkable mod_info+                                 , unlinked <- linkableUnlinked linkable+                                 , BCOs _ spts <- pure unlinked+                                 , spt <- spts+                                 ]++                upsweep' old_hpt1 done' mods (mod_index+1) nmods++maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)+maybeGetIfaceDate dflags location+ | writeInterfaceOnlyMode dflags+    -- Minor optimization: it should be harmless to check the hi file location+    -- always, but it's better to avoid hitting the filesystem if possible.+    = modificationTimeIfExists (ml_hi_file location)+ | otherwise+    = return Nothing++upsweep_inst :: HscEnv+             -> Maybe Messager+             -> Int  -- index of module+             -> Int  -- total number of modules+             -> InstantiatedUnit+             -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods iuid = do+        case mHscMessage of+            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) MustCompile (InstantiationNode iuid)+            Nothing -> return ()+        runHsc hsc_env $ ioMsgMaybe $ tcRnCheckUnit hsc_env $ VirtUnit iuid+        pure ()++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> HomePackageTable+            -> StableModules+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods+   =    let+            this_mod_name = ms_mod_name summary+            this_mod    = ms_mod summary+            mb_obj_date = ms_obj_date summary+            mb_if_date  = ms_iface_date summary+            obj_fn      = ml_obj_file (ms_location summary)+            hs_date     = ms_hs_date summary++            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj+            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco++            old_hmi = lookupHpt old_hpt this_mod_name++            -- We're using the dflags for this module now, obtained by+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.+            lcl_dflags = ms_hspp_opts summary+            prevailing_backend = backend (hsc_dflags hsc_env)+            local_backend      = backend lcl_dflags++            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that+            -- we don't do anything dodgy: these should only work to change+            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,+            -- otherwise we could end up trying to link object code to byte+            -- code.+            bcknd = case (prevailing_backend,local_backend) of+               (LLVM,NCG) -> NCG+               (NCG,LLVM) -> LLVM+               (NoBackend,b)+                  | backendProducesObject b -> b+               (Interpreter,b)+                  | backendProducesObject b -> b+               _ -> prevailing_backend++            -- store the corrected backend into the summary+            summary' = summary{ ms_hspp_opts = lcl_dflags { backend = bcknd } }++            -- The old interface is ok if+            --  a) we're compiling a source file, and the old HPT+            --     entry is for a source file+            --  b) we're compiling a hs-boot file+            -- Case (b) allows an hs-boot file to get the interface of its+            -- real source file on the second iteration of the compilation+            -- manager, but that does no harm.  Otherwise the hs-boot file+            -- will always be recompiled++            mb_old_iface+                = case old_hmi of+                     Nothing                                        -> Nothing+                     Just hm_info | isBootSummary summary == IsBoot -> Just iface+                                  | mi_boot iface == NotBoot        -> Just iface+                                  | otherwise                       -> Nothing+                                   where+                                     iface = hm_iface hm_info++            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo+            compile_it  mb_linkable src_modified =+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods+                             mb_old_iface mb_linkable src_modified++            compile_it_discard_iface :: Maybe Linkable -> SourceModified+                                     -> IO HomeModInfo+            compile_it_discard_iface mb_linkable  src_modified =+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods+                             Nothing mb_linkable src_modified++            -- With NoBackend we create empty linkables to avoid recompilation.+            -- We have to detect these to recompile anyway if the backend changed+            -- since the last compile.+            is_fake_linkable+               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =+                  null (linkableUnlinked l)+               | otherwise =+                   -- we have no linkable, so it cannot be fake+                   False++            implies False _ = True+            implies True x  = x++            debug_trace n t = liftIO $ debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) n t++        in+        case () of+         _+                -- Regardless of whether we're generating object code or+                -- byte code, we can always use an existing object file+                -- if it is *stable* (see checkStability).+          | is_stable_obj, Just hmi <- old_hmi -> do+                debug_trace 5 (text "skipping stable obj mod:" <+> ppr this_mod_name)+                return hmi+                -- object is stable, and we have an entry in the+                -- old HPT: nothing to do++          | is_stable_obj, isNothing old_hmi -> do+                debug_trace 5 (text "compiling stable on-disk mod:" <+> ppr this_mod_name)+                linkable <- liftIO $ findObjectLinkable this_mod obj_fn+                              (expectJust "upsweep1" mb_obj_date)+                compile_it (Just linkable) SourceUnmodifiedAndStable+                -- object is stable, but we need to load the interface+                -- off disk to make a HMI.++          | not (backendProducesObject bcknd), is_stable_bco,+            (bcknd /= NoBackend) `implies` not is_fake_linkable ->+                ASSERT(isJust old_hmi) -- must be in the old_hpt+                let Just hmi = old_hmi in do+                debug_trace 5 (text "skipping stable BCO mod:" <+> ppr this_mod_name)+                return hmi+                -- BCO is stable: nothing to do++          | not (backendProducesObject bcknd),+            Just hmi <- old_hmi,+            Just l <- hm_linkable hmi,+            not (isObjectLinkable l),+            (bcknd /= NoBackend) `implies` not is_fake_linkable,+            linkableTime l >= ms_hs_date summary -> do+                debug_trace 5 (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)+                compile_it (Just l) SourceUnmodified+                -- we have an old BCO that is up to date with respect+                -- to the source: do a recompilation check as normal.++          -- When generating object code, if there's an up-to-date+          -- object file on the disk, then we can use it.+          -- However, if the object file is new (compared to any+          -- linkable we had from a previous compilation), then we+          -- must discard any in-memory interface, because this+          -- means the user has compiled the source file+          -- separately and generated a new interface, that we must+          -- read from the disk.+          --+          | backendProducesObject bcknd,+            Just obj_date <- mb_obj_date,+            obj_date >= hs_date -> do+                case old_hmi of+                  Just hmi+                    | Just l <- hm_linkable hmi,+                      isObjectLinkable l && linkableTime l == obj_date -> do+                          debug_trace 5 (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)+                          compile_it (Just l) SourceUnmodified+                  _otherwise -> do+                          debug_trace 5 (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)+                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date+                          compile_it_discard_iface (Just linkable) SourceUnmodified++          -- See Note [Recompilation checking in -fno-code mode]+          | writeInterfaceOnlyMode lcl_dflags,+            Just if_date <- mb_if_date,+            if_date >= hs_date -> do+                debug_trace 5 (text "skipping tc'd mod:" <+> ppr this_mod_name)+                compile_it Nothing SourceUnmodified++         _otherwise -> do+                debug_trace 5 (text "compiling mod:" <+> ppr this_mod_name)+                compile_it Nothing SourceModified+++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+backend == NoBackend.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, -fwrite-interface would be discarded and it would be+considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using template haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses template haskell, to generate object+code.++The flavour of generated object code is chosen by defaultObjectTarget for the+target platform. It would likely be faster to generate bytecode, but this is not+supported on all platforms(?Please Confirm?), and does not support the entirety+of GHC haskell. See #1257.++The object files (and interface files if -fwrite-interface is disabled) produced+for template haskell are written to temporary files.++Note that since template haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+  mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+  .dyn_o. Fix it.+* In make mode, a message like+  Compiling A (A.hs, /tmp/ghc_123.o)+  is shown if downsweep enabled object code generation for A. Perhaps we should+  show "nothing" or "temporary object file" instead. Note that one+  can currently use -keep-tmp-files and inspect the generated file with the+  current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+  object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+  generating temporary ones.+-}++-- Note [Recompilation checking in -fno-code mode]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If we are compiling with -fno-code -fwrite-interface, there won't+-- be any object code that we can compare against, nor should there+-- be: we're *just* generating interface files.  In this case, we+-- want to check if the interface file is new, in lieu of the object+-- file.  See also #9243.++-- Filter modules in the HPT+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable+retainInTopLevelEnvs keep_these hpt+   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)+                 | mod <- keep_these+                 , let mb_mod_info = lookupHpt hpt mod+                 , isJust mb_mod_info ]++-- ---------------------------------------------------------------------------+-- Typecheck module loops+{-+See bug #930.  This code fixes a long-standing bug in --make.  The+problem is that when compiling the modules *inside* a loop, a data+type that is only defined at the top of the loop looks opaque; but+after the loop is done, the structure of the data type becomes+apparent.++The difficulty is then that two different bits of code have+different notions of what the data type looks like.++The idea is that after we compile a module which also has an .hs-boot+file, we re-generate the ModDetails for each of the modules that+depends on the .hs-boot file, so that everyone points to the proper+TyCons, Ids etc. defined by the real module, not the boot module.+Fortunately re-generating a ModDetails from a ModIface is easy: the+function GHC.IfaceToCore.typecheckIface does exactly that.++Picking the modules to re-typecheck is slightly tricky.  Starting from+the module graph consisting of the modules that have already been+compiled, we reverse the edges (so they point from the imported module+to the importing module), and depth-first-search from the .hs-boot+node.  This gives us all the modules that depend transitively on the+.hs-boot module, and those are exactly the modules that we need to+re-typecheck.++Following this fix, GHC can compile itself with --make -O2.+-}++reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv+reTypecheckLoop hsc_env ms graph+  | Just loop <- getModLoop ms mss appearsAsBoot+  -- SOME hs-boot files should still+  -- get used, just not the loop-closer.+  , let non_boot = flip mapMaybe loop $ \case+          InstantiationNode _ -> Nothing+          ModuleNode ems -> do+            let l = emsModSummary ems+            guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms+            pure l+  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)+  | otherwise+  = return hsc_env+  where+  mss = mgModSummaries' graph+  appearsAsBoot = (`elemModuleSet` mgBootModules graph)++-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a+-- corresponding boot file in @graph@, return the set of modules which+-- transitively depend on this boot file.  This function is slightly misnamed,+-- but its name "getModLoop" alludes to the fact that, when getModLoop is called+-- with a graph that does not contain @ms@ (non-parallel case) or is an+-- SCC with hs-boot nodes dropped (parallel-case), the modules which+-- depend on the hs-boot file are typically (but not always) the+-- modules participating in the recursive module loop.  The returned+-- list includes the hs-boot file.+--+-- Example:+--      let g represent the module graph:+--          C.hs+--          A.hs-boot imports C.hs+--          B.hs imports A.hs-boot+--          A.hs imports B.hs+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]+--+--      It would also be permissible to omit A.hs from the graph,+--      in which case the result is [A.hs-boot, B.hs]+--+-- Example:+--      A counter-example to the claim that modules returned+--      by this function participate in the loop occurs here:+--+--      let g represent the module graph:+--          C.hs+--          A.hs-boot imports C.hs+--          B.hs imports A.hs-boot+--          A.hs imports B.hs+--          D.hs imports A.hs-boot+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]+--+--      Arguably, D.hs should import A.hs, not A.hs-boot, but+--      a dependency on the boot file is not illegal.+--+getModLoop+  :: ModSummary+  -> [ModuleGraphNode]+  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'+  -> Maybe [ModuleGraphNode]+getModLoop ms graph appearsAsBoot+  | isBootSummary ms == NotBoot+  , appearsAsBoot this_mod+  , let mss = reachableBackwards (ms_mod_name ms) graph+  = Just mss+  | otherwise+  = Nothing+ where+  this_mod = ms_mod ms++-- NB: sometimes mods has duplicates; this is harmless because+-- any duplicates get clobbered in addListToHpt and never get forced.+typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv+typecheckLoop dflags hsc_env mods = do+  debugTraceMsg logger dflags 2 $+     text "Re-typechecking loop: " <> ppr mods+  new_hpt <-+    fixIO $ \new_hpt -> do+      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }+      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $+                mapM (typecheckIface . hm_iface) hmis+      let new_hpt = addListToHpt old_hpt+                        (zip mods [ hmi{ hm_details = details }+                                  | (hmi,details) <- zip hmis mds ])+      return new_hpt+  return hsc_env{ hsc_HPT = new_hpt }+  where+    logger  = hsc_logger hsc_env+    old_hpt = hsc_HPT hsc_env+    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods++reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]+reachableBackwards mod summaries+  = [ node_payload node | node <- reachableG (transposeG graph) root ]+  where -- the rest just sets up the graph:+        (graph, lookup_node) = moduleGraphNodes False summaries+        root  = expectJust "reachableBackwards" (lookup_node $ NodeKey_Module $ GWIB mod IsBoot)++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> ModuleGraph+          -> Maybe ModuleName+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModuleGraphNode]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic++topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    summaries = mgModSummaries' module_graph+    -- stronglyConnCompG flips the original order, so if we reverse+    -- the summaries we get a stable topological sort.+    (graph, lookup_node) =+      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just root_mod ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let root | Just node <- lookup_node $ NodeKey_Module $ GWIB root_mod NotBoot+                     , graph `hasVertexG` node+                     = node+                     | otherwise+                     = throwGhcException (ProgramError "module does not exist")+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))++type SummaryNode = Node Int ModuleGraphNode++summaryNodeKey :: SummaryNode -> Int+summaryNodeKey = node_key++summaryNodeSummary :: SummaryNode -> ModuleGraphNode+summaryNodeSummary = node_payload++-- | Collect the immediate dependencies of a ModuleGraphNode,+-- optionally avoiding hs-boot dependencies.+-- If the drop_hs_boot_nodes flag is False, and if this is a .hs and there is+-- an equivalent .hs-boot, add a link from the former to the latter.  This+-- has the effect of detecting bogus cases where the .hs-boot depends on the+-- .hs, by introducing a cycle.  Additionally, it ensures that we will always+-- process the .hs-boot before the .hs, and so the HomePackageTable will always+-- have the most up to date information.+unfilteredEdges :: Bool -> ModuleGraphNode -> [NodeKey]+unfilteredEdges drop_hs_boot_nodes = \case+    InstantiationNode iuid ->+      NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)+    ModuleNode (ExtendedModSummary ms bds) ->+      (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) +++      (NodeKey_Module . flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) +++      [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot+      | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile+      ] +++      [ NodeKey_Unit inst_unit+      | inst_unit <- bds+      ]+  where+    -- Drop hs-boot nodes by using HsSrcFile as the key+    hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature+                | otherwise          = IsBoot++moduleGraphNodes :: Bool -> [ModuleGraphNode]+  -> (Graph SummaryNode, NodeKey -> Maybe SummaryNode)+moduleGraphNodes drop_hs_boot_nodes summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    numbered_summaries = zip summaries [1..]++    lookup_node :: NodeKey -> Maybe SummaryNode+    lookup_node key = Map.lookup key (unNodeMap node_map)++    lookup_key :: NodeKey -> Maybe Int+    lookup_key = fmap summaryNodeKey . lookup_node++    node_map :: NodeMap SummaryNode+    node_map = NodeMap $+      Map.fromList [ (mkHomeBuildModule s, node)+                   | node <- nodes+                   , let s = summaryNodeSummary node+                   ]++    -- We use integers as the keys for the SCC algorithm+    nodes :: [SummaryNode]+    nodes = [ DigraphNode s key $ out_edge_keys $ unfilteredEdges drop_hs_boot_nodes s+            | (s, key) <- numbered_summaries+             -- Drop the hi-boot ones if told to do so+            , case s of+                InstantiationNode _ -> True+                ModuleNode ems -> not $ isBootSummary (emsModSummary ems) == IsBoot && drop_hs_boot_nodes+            ]++    out_edge_keys :: [NodeKey] -> [Int]+    out_edge_keys = mapMaybe lookup_key+        -- If we want keep_hi_boot_nodes, then we do lookup_key with+        -- IsBoot; else False++-- The nodes of the graph are keyed by (mod, is boot?) pairs for the current+-- modules, and indefinite unit IDs for dependencies which are instantiated with+-- our holes.+--+-- NB: hsig files show up as *normal* nodes (not boot!), since they don't+-- participate in cycles (for now)+type ModNodeKey = ModuleNameWithIsBoot+newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+  deriving (Functor, Traversable, Foldable)++emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty++modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)++modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m++modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey+  deriving (Eq, Ord)++newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }+  deriving (Functor, Traversable, Foldable)++msKey :: ModSummary -> ModNodeKey+msKey = mkHomeBuildModule0++mkNodeKey :: ModuleGraphNode -> NodeKey+mkNodeKey = \case+  InstantiationNode x -> NodeKey_Unit x+  ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)++pprNodeKey :: NodeKey -> SDoc+pprNodeKey (NodeKey_Unit iu) = ppr iu+pprNodeKey (NodeKey_Module mk) = ppr mk++mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary+mkNodeMap summaries = ModNodeMap $ Map.fromList+  [ (msKey $ emsModSummary s, s) | s <- summaries]++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()+warnUnnecessarySourceImports sccs = do+  dflags <- getDynFlags+  when (wopt Opt_WarnUnusedImports dflags)+    (logWarnings (listToBag (concatMap (check . flattenSCC) sccs)))+  where check ms =+           let mods_in_this_cycle = map ms_mod_name ms in+           [ warn i | m <- ms, i <- ms_home_srcimps m,+                      unLoc i `notElem`  mods_in_this_cycle ]++        warn :: Located ModuleName -> WarnMsg+        warn (L loc mod) =+           mkPlainMsgEnvelope loc+                (text "Warning: {-# SOURCE #-} unnecessary in import of "+                 <+> quotes (ppr mod))+++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis)+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered.  Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned list of [ModSummary] nodes has one node for each home-package+-- module, plus one for any hs-boot files.  The imports of these nodes+-- are all there, including the imports of non-home-package modules.+downsweep :: HscEnv+          -> [ExtendedModSummary]+          -- ^ Old summaries+          -> [ModuleName]       -- Ignore dependencies on these; treat+                                -- them as if they were package modules+          -> Bool               -- True <=> allow multiple targets to have+                                --          the same module name; this is+                                --          very useful for ghc -M+          -> IO [Either ErrorMessages ExtendedModSummary]+                -- The non-error elements of the returned list all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true in+                -- which case there can be repeats+downsweep hsc_env old_summaries excl_mods allow_dup_roots+   = do+       rootSummaries <- mapM getRootSummary roots+       let (errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549+           root_map = mkRootMap rootSummariesOk+       checkDuplicates root_map+       map0 <- loop (concatMap calcDeps rootSummariesOk) root_map+       -- if we have been passed -fno-code, we enable code generation+       -- for dependencies of modules that have -XTemplateHaskell,+       -- otherwise those modules will fail to compile.+       -- See Note [-fno-code mode] #8025+       let default_backend = platformDefaultBackend (targetPlatform dflags)+       let home_unit       = hsc_home_unit hsc_env+       let tmpfs           = hsc_tmpfs     hsc_env+       map1 <- case backend dflags of+         NoBackend   -> enableCodeGenForTH logger tmpfs home_unit default_backend map0+         _           -> return map0+       if null errs+         then pure $ concat $ modNodeMapElems map1+         else pure $ map Left errs+     where+        -- TODO(@Ericson2314): Probably want to include backpack instantiations+        -- in the map eventually for uniformity+        calcDeps (ExtendedModSummary ms _bkp_deps) = msDeps ms++        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        roots = hsc_targets hsc_env++        old_summary_map :: ModNodeMap ExtendedModSummary+        old_summary_map = mkNodeMap old_summaries++        getRootSummary :: Target -> IO (Either ErrorMessages ExtendedModSummary)+        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)+           = do exists <- liftIO $ doesFileExist file+                if exists || isJust maybe_buf+                    then summariseFile hsc_env old_summaries file mb_phase+                                       obj_allowed maybe_buf+                    else return $ Left $ unitBag $ mkPlainMsgEnvelope noSrcSpan $+                           text "can't find file:" <+> text file+        getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)+           = do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot+                                           (L rootLoc modl) obj_allowed+                                           maybe_buf excl_mods+                case maybe_summary of+                   Nothing -> return $ Left $ moduleNotFoundErr modl+                   Just s  -> return s++        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++        -- In a root module, the filename is allowed to diverge from the module+        -- name, so we have to check that there aren't multiple root files+        -- defining the same module (otherwise the duplicates will be silently+        -- ignored, leading to confusing behaviour).+        checkDuplicates+          :: ModNodeMap+               [Either ErrorMessages+                       ExtendedModSummary]+          -> IO ()+        checkDuplicates root_map+           | allow_dup_roots = return ()+           | null dup_roots  = return ()+           | otherwise       = liftIO $ multiRootsErr (emsModSummary <$> head dup_roots)+           where+             dup_roots :: [[ExtendedModSummary]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights $ modNodeMapElems root_map++        loop :: [GenWithIsBoot (Located ModuleName)]+                        -- Work list: process these modules+             -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+                        -- Visited set; the range is a list because+                        -- the roots can have the same module names+                        -- if allow_dup_roots is True+             -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])+                        -- The result is the completed NodeMap+        loop [] done = return done+        loop (s : ss) done+          | Just summs <- modNodeMapLookup key done+          = if isSingleton summs then+                loop ss done+            else+                do { multiRootsErr (emsModSummary <$> rights summs)+                   ; return (ModNodeMap Map.empty)+                   }+          | otherwise+          = do mb_s <- summariseModule hsc_env old_summary_map+                                       is_boot wanted_mod True+                                       Nothing excl_mods+               case mb_s of+                   Nothing -> loop ss done+                   Just (Left e) -> loop ss (modNodeMapInsert key [Left e] done)+                   Just (Right s)-> do+                     new_map <-+                       loop (calcDeps s) (modNodeMapInsert key [Right s] done)+                     loop ss new_map+          where+            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = s+            wanted_mod = L loc mod+            key = GWIB+                    { gwib_mod = unLoc wanted_mod+                    , gwib_isBoot = is_boot+                    }++-- | Update the every ModSummary that is depended on+-- by a module that needs template haskell. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+-- See Note [-fno-code mode]+enableCodeGenForTH+  :: Logger+  -> TmpFs+  -> HomeUnit+  -> Backend+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])+enableCodeGenForTH logger tmpfs home_unit =+  enableCodeGenWhen logger tmpfs condition should_modify TFL_CurrentModule TFL_GhcSession+  where+    condition = isTemplateHaskellOrQQNonBoot+    should_modify (ModSummary { ms_hspp_opts = dflags }) =+      backend dflags == NoBackend &&+      -- Don't enable codegen for TH on indefinite packages; we+      -- can't compile anything anyway! See #16219.+      isHomeUnitDefinite home_unit++-- | Helper used to implement 'enableCodeGenForTH'.+-- In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+  :: Logger+  -> TmpFs+  -> (ModSummary -> Bool)+  -> (ModSummary -> Bool)+  -> TempFileLifetime+  -> TempFileLifetime+  -> Backend+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+  -> IO (ModNodeMap [Either ErrorMessages ExtendedModSummary])+enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife bcknd nodemap =+  traverse (traverse (traverse enable_code_gen)) nodemap+  where+    enable_code_gen :: ExtendedModSummary -> IO ExtendedModSummary+    enable_code_gen (ExtendedModSummary ms bkp_deps)+      | ModSummary+        { ms_mod = ms_mod+        , ms_location = ms_location+        , ms_hsc_src = HsSrcFile+        , ms_hspp_opts = dflags+        } <- ms+      , should_modify ms+      , ms_mod `Set.member` needs_codegen_set+      = do+        let new_temp_file suf dynsuf = do+              tn <- newTempName logger tmpfs dflags staticLife suf+              let dyn_tn = tn -<.> dynsuf+              addFilesToClean tmpfs dynLife [dyn_tn]+              return tn+          -- We don't want to create .o or .hi files unless we have been asked+          -- to by the user. But we need them, so we patch their locations in+          -- the ModSummary with temporary files.+          --+        (hi_file, o_file) <-+          -- If ``-fwrite-interface` is specified, then the .o and .hi files+          -- are written into `-odir` and `-hidir` respectively.  #16670+          if gopt Opt_WriteInterface dflags+            then return (ml_hi_file ms_location, ml_obj_file ms_location)+            else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+                     <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+        let ms' = ms+              { ms_location =+                  ms_location {ml_hi_file = hi_file, ml_obj_file = o_file}+              , ms_hspp_opts = updOptLevel 0 $ dflags {backend = bcknd}+              }+        pure (ExtendedModSummary ms' bkp_deps)+      | otherwise = return (ExtendedModSummary ms bkp_deps)++    needs_codegen_set = transitive_deps_set+      [ ms+      | mss <- modNodeMapElems nodemap+      , Right (ExtendedModSummary { emsModSummary = ms }) <- mss+      , condition ms+      ]++    -- find the set of all transitive dependencies of a list of modules.+    transitive_deps_set :: [ModSummary] -> Set.Set Module+    transitive_deps_set modSums = foldl' go Set.empty modSums+      where+        go marked_mods ms@ModSummary{ms_mod}+          | ms_mod `Set.member` marked_mods = marked_mods+          | otherwise =+            let deps =+                  [ dep_ms+                  -- If a module imports a boot module, msDeps helpfully adds a+                  -- dependency to that non-boot module in it's result. This+                  -- means we don't have to think about boot modules here.+                  | dep <- msDeps ms+                  , NotBoot == gwib_isBoot dep+                  , dep_ms_0 <- toList $ modNodeMapLookup (unLoc <$> dep) nodemap+                  , dep_ms_1 <- toList $ dep_ms_0+                  , (ExtendedModSummary { emsModSummary = dep_ms }) <- toList $ dep_ms_1+                  ]+                new_marked_mods = Set.insert ms_mod marked_mods+            in foldl' go new_marked_mods deps++mkRootMap+  :: [ExtendedModSummary]+  -> ModNodeMap [Either ErrorMessages ExtendedModSummary]+mkRootMap summaries = ModNodeMap $ Map.insertListWith+  (flip (++))+  [ (msKey $ emsModSummary s, [Right s]) | s <- summaries ]+  Map.empty++-- | Returns the dependencies of the ModSummary s.+-- A wrinkle is that for a {-# SOURCE #-} import we return+--      *both* the hs-boot file+--      *and* the source file+-- as "dependencies".  That ensures that the list of all relevant+-- modules always contains B.hs if it contains B.hs-boot.+-- Remember, this pass isn't doing the topological sort.  It's+-- just gathering the list of all relevant ModSummaries+msDeps :: ModSummary -> [GenWithIsBoot (Located ModuleName)]+msDeps s = [ d+           | m <- ms_home_srcimps s+           , d <- [ GWIB { gwib_mod = m, gwib_isBoot = IsBoot }+                  , GWIB { gwib_mod = m, gwib_isBoot = NotBoot }+                  ]+           ]+        ++ [ GWIB { gwib_mod = m, gwib_isBoot = NotBoot }+           | m <- ms_home_imps s+           ]++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+--    * Summarise a file.  This is used for the root module(s) passed to+--      cmLoadModules.  The file is read, and used to determine the root+--      module name.  The module name may differ from the filename.+--+--    * Summarise a module.  We are given a module name, and must provide+--      a summary.  The finder is used to locate the file in which the module+--      resides.++summariseFile+        :: HscEnv+        -> [ExtendedModSummary]         -- old summaries+        -> FilePath                     -- source file name+        -> Maybe Phase                  -- start phase+        -> Bool                         -- object code allowed?+        -> Maybe (StringBuffer,UTCTime)+        -> IO (Either ErrorMessages ExtendedModSummary)++summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf+        -- we can use a cached summary if one is available and the+        -- source file hasn't changed,  But we have to look up the summary+        -- by source file, rather than module name as we do in summarise.+   | Just old_summary <- findSummaryBySourceFile old_summaries src_fn+   = do+        let location = ms_location $ emsModSummary old_summary+            dflags = hsc_dflags hsc_env++        src_timestamp <- get_src_timestamp+                -- The file exists; we checked in getRootSummary above.+                -- If it gets removed subsequently, then this+                -- getModificationUTCTime may fail, but that's the right+                -- behaviour.++                -- return the cached summary if the source didn't change+        checkSummaryTimestamp+            hsc_env dflags obj_allowed NotBoot (new_summary src_fn)+            old_summary location src_timestamp++   | otherwise+   = do src_timestamp <- get_src_timestamp+        new_summary src_fn src_timestamp+  where+    get_src_timestamp = case maybe_buf of+                           Just (_,t) -> return t+                           Nothing    -> liftIO $ getModificationUTCTime src_fn+                        -- getModificationUTCTime may fail++    new_summary src_fn src_timestamp = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf+++        -- Make a ModLocation for this file+        location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn++        -- Tell the Finder cache where it is, so that subsequent calls+        -- to findModule will find it, even if it's not on any search path+        mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_timestamp = src_timestamp+            , nms_is_boot = NotBoot+            , nms_hsc_src =+                if isHaskellSigFilename src_fn+                   then HsigFile+                   else HsSrcFile+            , nms_location = location+            , nms_mod = mod+            , nms_obj_allowed = obj_allowed+            , nms_preimps = preimps+            }++findSummaryBySourceFile :: [ExtendedModSummary] -> FilePath -> Maybe ExtendedModSummary+findSummaryBySourceFile summaries file = case+    [ ms+    | ms <- summaries+    , HsSrcFile <- [ms_hsc_src $ emsModSummary ms]+    , let derived_file = ml_hs_file $ ms_location $ emsModSummary ms+    , expectJust "findSummaryBySourceFile" derived_file == file+    ]+  of+    [] -> Nothing+    (x:_) -> Just x++checkSummaryTimestamp+    :: HscEnv -> DynFlags -> Bool -> IsBootInterface+    -> (UTCTime -> IO (Either e ExtendedModSummary))+    -> ExtendedModSummary -> ModLocation -> UTCTime+    -> IO (Either e ExtendedModSummary)+checkSummaryTimestamp+  hsc_env dflags obj_allowed is_boot new_summary+  (ExtendedModSummary { emsModSummary = old_summary, emsInstantiatedUnits = bkp_deps})+  location src_timestamp+  | ms_hs_date old_summary == src_timestamp &&+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+           -- update the object-file timestamp+           obj_timestamp <-+             if backendProducesObject (backend (hsc_dflags hsc_env))+                 || obj_allowed -- bug #1205+                 then liftIO $ getObjTimestamp location is_boot+                 else return Nothing++           -- We have to repopulate the Finder's cache for file targets+           -- because the file might not even be on the regular search path+           -- and it was likely flushed in depanal. This is not technically+           -- needed when we're called from sumariseModule but it shouldn't+           -- hurt.+           _ <- addHomeModuleToFinder hsc_env+                  (moduleName (ms_mod old_summary)) location++           hi_timestamp <- maybeGetIfaceDate dflags location+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++           return $ Right+             ( ExtendedModSummary { emsModSummary = old_summary+                     { ms_obj_date = obj_timestamp+                     , ms_iface_date = hi_timestamp+                     , ms_hie_date = hie_timestamp+                     }+                   , emsInstantiatedUnits = bkp_deps+                   }+             )++   | otherwise =+           -- source changed: re-summarise.+           new_summary src_timestamp++-- Summarise a module, and pick up source and timestamp.+summariseModule+          :: HscEnv+          -> ModNodeMap ExtendedModSummary+          -- ^ Map of old summaries+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> Bool               -- object code allowed?+          -> Maybe (StringBuffer, UTCTime)+          -> [ModuleName]               -- Modules to exclude+          -> IO (Maybe (Either ErrorMessages ExtendedModSummary))      -- Its new summary++summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)+                obj_allowed maybe_buf excl_mods+  | wanted_mod `elem` excl_mods+  = return Nothing++  | Just old_summary <- modNodeMapLookup+      (GWIB { gwib_mod = wanted_mod, gwib_isBoot = is_boot })+      old_summary_map+  = do          -- Find its new timestamp; all the+                -- ModSummaries in the old map have valid ml_hs_files+        let location = ms_location $ emsModSummary old_summary+            src_fn = expectJust "summariseModule" (ml_hs_file location)++                -- check the modification time on the source file, and+                -- return the cached summary if it hasn't changed.  If the+                -- file has disappeared, we need to call the Finder again.+        case maybe_buf of+           Just (_,t) ->+               Just <$> check_timestamp old_summary location src_fn t+           Nothing    -> do+                m <- tryIO (getModificationUTCTime src_fn)+                case m of+                   Right t ->+                       Just <$> check_timestamp old_summary location src_fn t+                   Left e | isDoesNotExistError e -> find_it+                          | otherwise             -> ioError e++  | otherwise  = find_it+  where+    dflags = hsc_dflags hsc_env+    home_unit = hsc_home_unit hsc_env++    check_timestamp old_summary location src_fn =+        checkSummaryTimestamp+          hsc_env dflags obj_allowed is_boot+          (new_summary location (ms_mod $ emsModSummary old_summary) src_fn)+          old_summary location++    find_it = do+        found <- findImportedModule hsc_env wanted_mod Nothing+        case found of+             Found location mod+                | isJust (ml_hs_file location) ->+                        -- Home package+                         Just <$> just_found location mod++             _ -> return Nothing+                        -- Not found+                        -- (If it is TRULY not found at all, we'll+                        -- error when we actually try to compile)++    just_found location mod = do+                -- Adjust location to point to the hs-boot source file,+                -- hi file, object file, when is_boot says so+        let location' = case is_boot of+              IsBoot -> addBootSuffixLocn location+              NotBoot -> location+            src_fn = expectJust "summarise2" (ml_hs_file location')++                -- Check that it exists+                -- It might have been deleted since the Finder last found it+        maybe_t <- modificationTimeIfExists src_fn+        case maybe_t of+          Nothing -> return $ Left $ noHsFileErr loc src_fn+          Just t  -> new_summary location' mod src_fn t++    new_summary location mod src_fn src_timestamp+      = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf++        -- NB: Despite the fact that is_boot is a top-level parameter, we+        -- don't actually know coming into this function what the HscSource+        -- of the module in question is.  This is because we may be processing+        -- this module because another module in the graph imported it: in this+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}+        -- annotation, but we don't know if it's a signature or a regular+        -- module until we actually look it up on the filesystem.+        let hsc_src+              | is_boot == IsBoot = HsBootFile+              | isHaskellSigFilename src_fn = HsigFile+              | otherwise = HsSrcFile++        when (pi_mod_name /= wanted_mod) $+                throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $+                              text "File name does not match module name:"+                              $$ text "Saw:" <+> quotes (ppr pi_mod_name)+                              $$ text "Expected:" <+> quotes (ppr wanted_mod)++        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (homeUnitInstantiations home_unit))) $+            let suggested_instantiated_with =+                    hcat (punctuate comma $+                        [ ppr k <> text "=" <> ppr v+                        | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)+                                : homeUnitInstantiations home_unit)+                        ])+            in throwE $ unitBag $ mkPlainMsgEnvelope pi_mod_name_loc $+                text "Unexpected signature:" <+> quotes (ppr pi_mod_name)+                $$ if gopt Opt_BuildingCabalPackage dflags+                    then parens (text "Try adding" <+> quotes (ppr pi_mod_name)+                            <+> text "to the"+                            <+> quotes (text "signatures")+                            <+> text "field in your Cabal file.")+                    else parens (text "Try passing -instantiated-with=\"" <>+                                 suggested_instantiated_with <> text "\"" $$+                                text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_timestamp = src_timestamp+            , nms_is_boot = is_boot+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_obj_allowed = obj_allowed+            , nms_preimps = preimps+            }++-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+  = MakeNewModSummary+      { nms_src_fn :: FilePath+      , nms_src_timestamp :: UTCTime+      , nms_is_boot :: IsBootInterface+      , nms_hsc_src :: HscSource+      , nms_location :: ModLocation+      , nms_mod :: Module+      , nms_obj_allowed :: Bool+      , nms_preimps :: PreprocessedImports+      }++makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ExtendedModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+  let PreprocessedImports{..} = nms_preimps+  let dflags = hsc_dflags hsc_env++  -- when the user asks to load a source file by name, we only+  -- use an object file if -fobject-code is on.  See #1205.+  obj_timestamp <- liftIO $+      if backendProducesObject (backend dflags)+         || nms_obj_allowed -- bug #1205+          then getObjTimestamp nms_location nms_is_boot+          else return Nothing++  hi_timestamp <- maybeGetIfaceDate dflags nms_location+  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)++  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+  (implicit_sigs, inst_deps) <- implicitRequirementsShallow hsc_env pi_theimps++  return $ ExtendedModSummary+    { emsModSummary =+        ModSummary+        { ms_mod = nms_mod+        , ms_hsc_src = nms_hsc_src+        , ms_location = nms_location+        , ms_hspp_file = pi_hspp_fn+        , ms_hspp_opts = pi_local_dflags+        , ms_hspp_buf  = Just pi_hspp_buf+        , ms_parsed_mod = Nothing+        , ms_srcimps = pi_srcimps+        , ms_textual_imps =+            pi_theimps +++            extra_sig_imports +++            ((,) Nothing . noLoc <$> implicit_sigs)+        , ms_hs_date = nms_src_timestamp+        , ms_iface_date = hi_timestamp+        , ms_hie_date = hie_timestamp+        , ms_obj_date = obj_timestamp+        }+    , emsInstantiatedUnits = inst_deps+    }++getObjTimestamp :: ModLocation -> IsBootInterface -> IO (Maybe UTCTime)+getObjTimestamp location is_boot+  = case is_boot of+      IsBoot -> return Nothing+      NotBoot -> modificationTimeIfExists (ml_obj_file location)++data PreprocessedImports+  = PreprocessedImports+      { pi_local_dflags :: DynFlags+      , pi_srcimps  :: [(Maybe FastString, Located ModuleName)]+      , pi_theimps  :: [(Maybe FastString, Located ModuleName)]+      , pi_hspp_fn  :: FilePath+      , pi_hspp_buf :: StringBuffer+      , pi_mod_name_loc :: SrcSpan+      , pi_mod_name :: ModuleName+      }++-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+    :: HscEnv+    -> FilePath+    -> Maybe Phase+    -> Maybe (StringBuffer, UTCTime)+    -- ^ optional source code buffer and modification time+    -> ExceptT ErrorMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+  (pi_local_dflags, pi_hspp_fn)+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+  (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)+      <- ExceptT $ do+          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags+              popts = initParserOpts pi_local_dflags+          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn+          return (first (fmap pprError) mimps)+  return PreprocessedImports {..}+++-----------------------------------------------------------------------------+--                      Error messages+-----------------------------------------------------------------------------++-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+  dflags <- getDynFlags+  if not $ gopt Opt_DeferDiagnostics dflags+  then f+  else do+    warnings <- liftIO $ newIORef []+    errors <- liftIO $ newIORef []+    fatals <- liftIO $ newIORef []+    logger <- getLogger++    let deferDiagnostics _dflags !reason !severity !srcSpan !msg = do+          let action = putLogMsg logger dflags reason severity srcSpan msg+          case severity of+            SevWarning -> atomicModifyIORef' warnings $ \i -> (action: i, ())+            SevError -> atomicModifyIORef' errors $ \i -> (action: i, ())+            SevFatal -> atomicModifyIORef' fatals $ \i -> (action: i, ())+            _ -> action++        printDeferredDiagnostics = liftIO $+          forM_ [warnings, errors, fatals] $ \ref -> do+            -- This IORef can leak when the dflags leaks, so let us always+            -- reset the content.+            actions <- atomicModifyIORef' ref $ \i -> ([], i)+            sequence_ $ reverse actions++    MC.bracket+      (pushLogHookM (const deferDiagnostics))+      (\_ -> popLogHookM >> printDeferredDiagnostics)+      (\_ -> f)++noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope DecoratedSDoc+-- ToDo: we don't have a proper line number for this error+noModError hsc_env loc wanted_mod err+  = mkPlainMsgEnvelope loc $ cannotFindModule hsc_env wanted_mod err++noHsFileErr :: SrcSpan -> String -> ErrorMessages+noHsFileErr loc path+  = unitBag $ mkPlainMsgEnvelope loc $ text "Can't find" <+> text path++moduleNotFoundErr :: ModuleName -> ErrorMessages+moduleNotFoundErr mod+  = unitBag $ mkPlainMsgEnvelope noSrcSpan $+        text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"++multiRootsErr :: [ModSummary] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+  = throwOneError $ mkPlainMsgEnvelope noSrcSpan $+        text "module" <+> quotes (ppr mod) <+>+        text "is defined in multiple files:" <+>+        sep (map text files)+  where+    mod = ms_mod summ1+    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs++keepGoingPruneErr :: [NodeKey] -> SDoc+keepGoingPruneErr ms+  = vcat (( text "-fkeep-going in use, removing the following" <+>+            text "dependencies and continuing:"):+          map (nest 6 . pprNodeKey) ms )++cyclicModuleErr :: [ModuleGraphNode] -> SDoc+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = ASSERT( not (null mss) )+    case findCycle graph of+       Nothing   -> text "Unexpected non-cycle" <+> ppr mss+       Just path0 -> vcat+        [ case partitionNodes path0 of+            ([],_) -> text "Module imports form a cycle:"+            (_,[]) -> text "Module instantiations form a cycle:"+            _ -> text "Module imports and instantiations form a cycle:"+        , nest 2 (show_path path0)]+  where+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = get_deps ms+        }+      | ms <- mss+      ]++    get_deps :: ModuleGraphNode -> [NodeKey]+    get_deps = \case+      InstantiationNode iuid ->+        [ NodeKey_Module $ GWIB { gwib_mod = hole, gwib_isBoot = NotBoot }+        | hole <- uniqDSetToList $ instUnitHoles iuid+        ]+      ModuleNode (ExtendedModSummary ms bds) ->+        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }+        | m <- ms_home_srcimps ms ] +++        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }+        | m <- ms_home_imps    ms ] +++        [ NodeKey_Unit inst_unit+        | inst_unit <- bds+        ]++    show_path :: [ModuleGraphNode] -> SDoc+    show_path []  = panic "show_path"+    show_path [m] = ppr_node m <+> text "imports itself"+    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)+                                : nest 6 (text "imports" <+> ppr_node m2)+                                : go ms )+       where+         go []     = [text "which imports" <+> ppr_node m1]+         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms++    ppr_node :: ModuleGraphNode -> SDoc+    ppr_node (ModuleNode m) = text "module" <+> ppr_ms (emsModSummary m)+    ppr_node (InstantiationNode u) = text "instantiated unit" <+> ppr u      ppr_ms :: ModSummary -> SDoc     ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>

GHC/Driver/MakeFile.hs view

@@ -20,21 +20,29 @@ import qualified GHC import GHC.Driver.Monad import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Misc-import GHC.Driver.Types+import GHC.Driver.Env import qualified GHC.SysTools as SysTools-import GHC.Unit.Module import GHC.Data.Graph.Directed ( SCC(..) )-import GHC.Driver.Finder import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Types.SourceError import GHC.Types.SrcLoc-import Data.List+import Data.List (partition) import GHC.Data.FastString-import GHC.SysTools.FileCleanup+import GHC.Utils.TmpFs +import GHC.Iface.Load (cannotFindModule)++import GHC.Unit.Module+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Finder+ import GHC.Utils.Exception import GHC.Utils.Error+import GHC.Utils.Logger  import System.Directory import System.FilePath@@ -53,6 +61,8 @@  doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do+    logger <- getLogger+     -- Initialisation     dflags0 <- GHC.getSessionDynFlags @@ -62,17 +72,18 @@     -- We therefore do the initial dependency generation with an empty     -- way and .o/.hi extensions, regardless of any flags that might     -- be specified.-    let dflags = dflags0 {-                     ways = Set.empty,-                     hiSuf = "hi",-                     objectSuf = "o"-                 }+    let dflags = dflags0+            { targetWays_ = Set.empty+            , hiSuf_      = "hi"+            , objectSuf_  = "o"+            }     GHC.setSessionDynFlags dflags      when (null (depSuffixes dflags)) $ liftIO $         throwGhcExceptionIO (ProgramError "You must specify at least one -dep-suffix") -    files <- liftIO $ beginMkDependHS dflags+    tmpfs <- hsc_tmpfs <$> getSession+    files <- liftIO $ beginMkDependHS logger tmpfs dflags      -- Do the downsweep to find all the modules     targets <- mapM (\s -> GHC.guessTarget s Nothing) srcs@@ -85,7 +96,7 @@     let sorted = GHC.topSortModuleGraph False module_graph Nothing      -- Print out the dependencies if wanted-    liftIO $ debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)+    liftIO $ debugTraceMsg logger dflags 2 (text "Module dependencies" $$ ppr sorted)      -- Process them one by one, dumping results into makefile     -- and complaining about cycles@@ -94,10 +105,10 @@     mapM_ (liftIO . processDeps dflags hsc_env excl_mods root (mkd_tmp_hdl files)) sorted      -- If -ddump-mod-cycles, show cycles in the module graph-    liftIO $ dumpModCycles dflags module_graph+    liftIO $ dumpModCycles logger dflags module_graph      -- Tidy up-    liftIO $ endMkDependHS dflags files+    liftIO $ endMkDependHS logger dflags files      -- Unconditional exiting is a bad idea.  If an error occurs we'll get an     --exception; if that is not caught it's fine, but at least we have a@@ -121,11 +132,11 @@             mkd_tmp_file  :: FilePath,          -- Name of the temporary file             mkd_tmp_hdl   :: Handle }           -- Handle of the open temporary file -beginMkDependHS :: DynFlags -> IO MkDepFiles-beginMkDependHS dflags = do+beginMkDependHS :: Logger -> TmpFs -> DynFlags -> IO MkDepFiles+beginMkDependHS logger tmpfs dflags = do         -- open a new temp file in which to stuff the dependency info         -- as we go along.-  tmp_file <- newTempName dflags TFL_CurrentModule "dep"+  tmp_file <- newTempName logger tmpfs dflags TFL_CurrentModule "dep"   tmp_hdl <- openFile tmp_file WriteMode          -- open the makefile@@ -179,7 +190,7 @@             -> [ModuleName]             -> FilePath             -> Handle           -- Write dependencies to here-            -> SCC ModSummary+            -> SCC ModuleGraphNode             -> IO () -- Write suitable dependencies to handle -- Always:@@ -198,9 +209,17 @@  processDeps dflags _ _ _ _ (CyclicSCC nodes)   =     -- There shouldn't be any cycles; report them-    throwGhcExceptionIO (ProgramError (showSDoc dflags $ GHC.cyclicModuleErr nodes))+    throwGhcExceptionIO $ ProgramError $+      showSDoc dflags $ GHC.cyclicModuleErr nodes -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC node)+processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode node))+  =     -- There shouldn't be any backpack instantiations; report them as well+    throwGhcExceptionIO $ ProgramError $+      showSDoc dflags $+        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"+             , nest 2 $ ppr node ]++processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode (ExtendedModSummary node _)))   = do  { let extra_suffixes = depSuffixes dflags               include_pkg_deps = depIncludePkgDeps dflags               src_file  = msHsFilePath node@@ -282,9 +301,8 @@                 -> return Nothing              fail ->-                let dflags = hsc_dflags hsc_env-                in throwOneError $ mkPlainErrMsg dflags srcloc $-                        cannotFindModule dflags imp fail+                throwOneError $ mkPlainMsgEnvelope srcloc $+                     cannotFindModule hsc_env imp fail         }  -----------------------------@@ -324,9 +342,9 @@ -- ----------------------------------------------------------------- -endMkDependHS :: DynFlags -> MkDepFiles -> IO ()+endMkDependHS :: Logger -> DynFlags -> MkDepFiles -> IO () -endMkDependHS dflags+endMkDependHS logger dflags    (MkDep { mkd_make_file = makefile, mkd_make_hdl =  makefile_hdl,             mkd_tmp_file  = tmp_file, mkd_tmp_hdl  =  tmp_hdl })   = do@@ -352,32 +370,34 @@          -- Create a backup of the original makefile   when (isJust makefile_hdl)-       (SysTools.copy dflags ("Backing up " ++ makefile)+       (SysTools.copy logger dflags ("Backing up " ++ makefile)           makefile (makefile++".bak"))          -- Copy the new makefile in place-  SysTools.copy dflags "Installing new makefile" tmp_file makefile+  SysTools.copy logger dflags "Installing new makefile" tmp_file makefile   ----------------------------------------------------------------- --              Module cycles ----------------------------------------------------------------- -dumpModCycles :: DynFlags -> ModuleGraph -> IO ()-dumpModCycles dflags module_graph+dumpModCycles :: Logger -> DynFlags -> ModuleGraph -> IO ()+dumpModCycles logger dflags module_graph   | not (dopt Opt_D_dump_mod_cycles dflags)   = return ()    | null cycles-  = putMsg dflags (text "No module cycles")+  = putMsg logger dflags (text "No module cycles")    | otherwise-  = putMsg dflags (hang (text "Module cycles found:") 2 pp_cycles)+  = putMsg logger dflags (hang (text "Module cycles found:") 2 pp_cycles)   where+    topoSort = filterToposortToModules $+      GHC.topSortModuleGraph True module_graph Nothing      cycles :: [[ModSummary]]     cycles =-      [ c | CyclicSCC c <- GHC.topSortModuleGraph True module_graph Nothing ]+      [ c | CyclicSCC c <- topoSort ]      pp_cycles = vcat [ (text "---------- Cycle" <+> int n <+> ptext (sLit "----------"))                         $$ pprCycle c $$ blankLine@@ -405,8 +425,8 @@            loop_breaker = head boot_only           all_others   = tail boot_only ++ others-          groups =-            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing+          groups = filterToposortToModules $+            GHC.topSortModuleGraph True (mkModuleGraph $ extendModSummaryNoDeps <$> all_others) Nothing      pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))                        <+> (pp_imps empty (map snd (ms_imps summary)) $$

GHC/Driver/Monad.hs view

@@ -16,8 +16,17 @@         reflectGhc, reifyGhc,         getSessionDynFlags,         liftIO,-        Session(..), withSession, modifySession, withTempSession,+        Session(..), withSession, modifySession, modifySessionM,+        withTempSession, +        -- * Logger+        modifyLogger,+        pushLogHookM,+        popLogHookM,+        putLogMsgM,+        putMsgM,+        withTimingM,+         -- ** Warnings         logWarnings, printException,         WarnErrLogger, defaultWarnErrLogger@@ -25,12 +34,18 @@  import GHC.Prelude -import GHC.Utils.Monad-import GHC.Driver.Types import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Errors ( printOrThrowWarnings, printBagOfErrors )++import GHC.Utils.Monad import GHC.Utils.Exception import GHC.Utils.Error+import GHC.Utils.Logger +import GHC.Types.SrcLoc+import GHC.Types.SourceError+ import Control.Monad import Control.Monad.Catch as MC import Control.Monad.Trans.Reader@@ -52,7 +67,7 @@ -- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' -- before any call to the GHC API functions can occur. ---class (Functor m, ExceptionMonad m, HasDynFlags m) => GhcMonad m where+class (Functor m, ExceptionMonad m, HasDynFlags m, HasLogger m ) => GhcMonad m where   getSession :: m HscEnv   setSession :: HscEnv -> m () @@ -70,6 +85,13 @@ modifySession f = do h <- getSession                      setSession $! f h +-- | Set the current session to the result of applying the current session to+-- the argument.+modifySessionM :: GhcMonad m => (HscEnv -> m HscEnv) -> m ()+modifySessionM f = do h <- getSession+                      h' <- f h+                      setSession $! h'+ withSavedSession :: GhcMonad m => m a -> m a withSavedSession m = do   saved_session <- getSession@@ -80,13 +102,52 @@ withTempSession f m =   withSavedSession $ modifySession f >> m +----------------------------------------+-- Logging+----------------------------------------++-- | Modify the logger+modifyLogger :: GhcMonad m => (Logger -> Logger) -> m ()+modifyLogger f = modifySession $ \hsc_env ->+    hsc_env { hsc_logger = f (hsc_logger hsc_env) }++-- | Push a log hook on the stack+pushLogHookM :: GhcMonad m => (LogAction -> LogAction) -> m ()+pushLogHookM = modifyLogger . pushLogHook++-- | Pop a log hook from the stack+popLogHookM :: GhcMonad m => m ()+popLogHookM  = modifyLogger popLogHook++-- | Put a log message+putMsgM :: GhcMonad m => SDoc -> m ()+putMsgM doc = do+    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putMsg logger dflags doc++-- | Put a log message+putLogMsgM :: GhcMonad m => WarnReason -> Severity -> SrcSpan -> SDoc -> m ()+putLogMsgM reason sev loc doc = do+    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putLogMsg logger dflags reason sev loc doc++-- | Time an action+withTimingM :: GhcMonad m => SDoc -> (b -> ()) -> m b -> m b+withTimingM doc force action = do+    logger <- getLogger+    dflags <- getDynFlags+    withTiming logger dflags doc force action+ -- ----------------------------------------------------------------------------- -- | A monad that allows logging of warnings.  logWarnings :: GhcMonad m => WarningMessages -> m () logWarnings warns = do   dflags <- getSessionDynFlags-  liftIO $ printOrThrowWarnings dflags warns+  logger <- getLogger+  liftIO $ printOrThrowWarnings logger dflags warns  -- ----------------------------------------------------------------------------- -- | A minimal implementation of a 'GhcMonad'.  If you need a custom monad,@@ -118,6 +179,9 @@ instance HasDynFlags Ghc where   getDynFlags = getSessionDynFlags +instance HasLogger Ghc where+  getLogger = hsc_logger <$> getSession+ instance GhcMonad Ghc where   getSession = Ghc $ \(Session r) -> readIORef r   setSession s' = Ghc $ \(Session r) -> writeIORef r s'@@ -168,6 +232,9 @@ instance MonadIO m => HasDynFlags (GhcT m) where   getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) +instance MonadIO m => HasLogger (GhcT m) where+  getLogger = GhcT $ \(Session r) -> liftM hsc_logger (liftIO $ readIORef r)+ instance ExceptionMonad m => GhcMonad (GhcT m) where   getSession = GhcT $ \(Session r) -> liftIO $ readIORef r   setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'@@ -178,7 +245,8 @@ printException :: GhcMonad m => SourceError -> m () printException err = do   dflags <- getSessionDynFlags-  liftIO $ printBagOfErrors dflags (srcErrorMessages err)+  logger <- getLogger+  liftIO $ printBagOfErrors logger dflags (srcErrorMessages err)  -- | A function called to log warnings and errors. type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()

GHC/Driver/Phases.hs view

@@ -9,7 +9,6 @@ -----------------------------------------------------------------------------  module GHC.Driver.Phases (-   HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString,    Phase(..),    happensBefore, eqPhase, anyHsc, isStopLn,    startPhase,@@ -34,19 +33,27 @@    isCishFilename,    isDynLibFilename,    isHaskellUserSrcFilename,-   isSourceFilename+   isSourceFilename,++   phaseForeignLanguage  ) where  #include "HsVersions.h"  import GHC.Prelude -import GHC.Utils.Outputable import GHC.Platform-import System.FilePath-import GHC.Utils.Binary++import GHC.ForeignSrcLang++import GHC.Types.SourceFile++import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc +import System.FilePath+ ----------------------------------------------------------------------------- -- Phases @@ -62,70 +69,6 @@    linker                 | other         | -             | a.out -} --- Note [HscSource types]--- ~~~~~~~~~~~~~~~~~~~~~~--- There are three types of source file for Haskell code:------      * HsSrcFile is an ordinary hs file which contains code,------      * HsBootFile is an hs-boot file, which is used to break---        recursive module imports (there will always be an---        HsSrcFile associated with it), and------      * HsigFile is an hsig file, which contains only type---        signatures and is used to specify signatures for---        modules.------ Syntactically, hs-boot files and hsig files are quite similar: they--- only include type signatures and must be associated with an--- actual HsSrcFile.  isHsBootOrSig allows us to abstract over code--- which is indifferent to which.  However, there are some important--- differences, mostly owing to the fact that hsigs are proper--- modules (you `import Sig` directly) whereas HsBootFiles are--- temporary placeholders (you `import {-# SOURCE #-} Mod).--- When we finish compiling the true implementation of an hs-boot,--- we replace the HomeModInfo with the real HsSrcFile.  An HsigFile, on the--- other hand, is never replaced (in particular, we *cannot* use the--- HomeModInfo of the original HsSrcFile backing the signature, since it--- will export too many symbols.)------ Additionally, while HsSrcFile is the only Haskell file--- which has *code*, we do generate .o files for HsigFile, because--- this is how the recompilation checker figures out if a file--- needs to be recompiled.  These are fake object files which--- should NOT be linked against.--data HscSource-   = HsSrcFile | HsBootFile | HsigFile-     deriving( Eq, Ord, Show )-        -- Ord needed for the finite maps we build in CompManager--instance Binary HscSource where-    put_ bh HsSrcFile = putByte bh 0-    put_ bh HsBootFile = putByte bh 1-    put_ bh HsigFile = putByte bh 2-    get bh = do-        h <- getByte bh-        case h of-            0 -> return HsSrcFile-            1 -> return HsBootFile-            _ -> return HsigFile--hscSourceString :: HscSource -> String-hscSourceString HsSrcFile   = ""-hscSourceString HsBootFile  = "[boot]"-hscSourceString HsigFile    = "[sig]"---- See Note [isHsBootOrSig]-isHsBootOrSig :: HscSource -> Bool-isHsBootOrSig HsBootFile = True-isHsBootOrSig HsigFile   = True-isHsBootOrSig _          = False--isHsigFile :: HscSource -> Bool-isHsigFile HsigFile = True-isHsigFile _        = False- data Phase         = Unlit HscSource         | Cpp   HscSource@@ -367,3 +310,16 @@ isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) isDynLibFilename platform f = isDynLibSuffix platform (drop 1 $ takeExtension f)++-- | Foreign language of the phase if the phase deals with a foreign code+phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang+phaseForeignLanguage phase = case phase of+  Cc           -> Just LangC+  Ccxx         -> Just LangCxx+  Cobjc        -> Just LangObjc+  Cobjcxx      -> Just LangObjcxx+  HCc          -> Just LangC+  As _         -> Just LangAsm+  MergeForeign -> Just RawObject+  _            -> Nothing+

GHC/Driver/Pipeline.hs view

@@ -1,2299 +1,2153 @@-{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- GHC Driver------ (c) The University of Glasgow 2005-----------------------------------------------------------------------------------module GHC.Driver.Pipeline (-        -- Run a series of compilation steps in a pipeline, for a-        -- collection of source files.-   oneShot, compileFile,--        -- Interfaces for the batch-mode driver-   linkBinary,--        -- Interfaces for the compilation manager (interpreted/batch-mode)-   preprocess,-   compileOne, compileOne',-   link,--        -- Exports for hooks to override runPhase and link-   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),-   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,-   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,-   runPhase, exeFileName,-   maybeCreateManifest,-   doCpp,-   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode-  ) where--#include <ghcplatform.h>-#include "HsVersions.h"--import GHC.Prelude--import GHC.Driver.Pipeline.Monad-import GHC.Unit.State-import GHC.Driver.Ways-import GHC.Parser.Header-import GHC.Driver.Phases-import GHC.SysTools-import GHC.SysTools.ExtraObj-import GHC.Driver.Main-import GHC.Driver.Finder-import GHC.Driver.Types hiding ( Hsc )-import GHC.Utils.Outputable-import GHC.Unit.Module-import GHC.Utils.Error-import GHC.Driver.Session-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Data.StringBuffer ( hGetStringBuffer, hPutStringBuffer )-import GHC.Types.Basic       ( SuccessFlag(..) )-import GHC.Data.Maybe        ( expectJust )-import GHC.Types.SrcLoc-import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )-import GHC.Utils.Monad-import GHC.Platform-import GHC.Tc.Types-import GHC.Driver.Hooks-import qualified GHC.LanguageExtensions as LangExt-import GHC.SysTools.FileCleanup-import GHC.SysTools.Ar-import GHC.Settings-import GHC.Data.Bag             ( unitBag )-import GHC.Data.FastString      ( mkFastString )-import GHC.Iface.Make           ( mkFullIface )--import GHC.Utils.Exception as Exception-import System.Directory-import System.FilePath-import System.IO-import Control.Monad-import qualified Control.Monad.Catch as MC (handle)-import Data.List        ( isInfixOf, intercalate )-import Data.Maybe-import Data.Version-import Data.Either      ( partitionEithers )--import Data.Time        ( UTCTime )---- ------------------------------------------------------------------------------ Pre-process---- | Just preprocess a file, put the result in a temp. file (used by the--- compilation manager during the summary phase).------ We return the augmented DynFlags, because they contain the result--- of slurping in the OPTIONS pragmas--preprocess :: HscEnv-           -> FilePath -- ^ input filename-           -> Maybe InputFileBuffer-           -- ^ optional buffer to use instead of reading the input file-           -> Maybe Phase -- ^ starting phase-           -> IO (Either ErrorMessages (DynFlags, FilePath))-preprocess hsc_env input_fn mb_input_buf mb_phase =-  handleSourceError (\err -> return (Left (srcErrorMessages err))) $-  MC.handle handler $-  fmap Right $ do-  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)-  (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)-        Nothing-        -- We keep the processed file for the whole session to save on-        -- duplicated work in ghci.-        (Temporary TFL_GhcSession)-        Nothing{-no ModLocation-}-        []{-no foreign objects-}-  -- We stop before Hsc phase so we shouldn't generate an interface-  MASSERT(isNothing mb_iface)-  return (dflags, fp)-  where-    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1-    handler (ProgramError msg) = return $ Left $ unitBag $-        mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg-    handler ex = throwGhcExceptionIO ex---- ------------------------------------------------------------------------------- | Compile------ Compile a single module, under the control of the compilation manager.------ This is the interface between the compilation manager and the--- compiler proper (hsc), where we deal with tedious details like--- reading the OPTIONS pragma from the source file, converting the--- C or assembly that GHC produces into an object file, and compiling--- FFI stub files.------ NB.  No old interface can also mean that the source has changed.--compileOne :: HscEnv-           -> ModSummary      -- ^ summary for module being compiled-           -> Int             -- ^ module N ...-           -> Int             -- ^ ... of M-           -> Maybe ModIface  -- ^ old interface, if we have one-           -> Maybe Linkable  -- ^ old linkable, if we have one-           -> SourceModified-           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful--compileOne = compileOne' Nothing (Just batchMsg)--compileOne' :: Maybe TcGblEnv-            -> Maybe Messager-            -> HscEnv-            -> ModSummary      -- ^ summary for module being compiled-            -> Int             -- ^ module N ...-            -> Int             -- ^ ... of M-            -> Maybe ModIface  -- ^ old interface, if we have one-            -> Maybe Linkable  -- ^ old linkable, if we have one-            -> SourceModified-            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful--compileOne' m_tc_result mHscMessage-            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable-            source_modified0- = do--   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)--   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)-   (status, plugin_dflags) <- hscIncrementalCompile-                        always_do_basic_recompilation_check-                        m_tc_result mHscMessage-                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)--   let flags = hsc_dflags hsc_env0-     in do unless (gopt Opt_KeepHiFiles flags) $-               addFilesToClean flags TFL_CurrentModule $-                   [ml_hi_file $ ms_location summary]-           unless (gopt Opt_KeepOFiles flags) $-               addFilesToClean flags TFL_GhcSession $-                   [ml_obj_file $ ms_location summary]--   -- Use an HscEnv with DynFlags updated with the plugin info (returned from-   -- hscIncrementalCompile)-   let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags }--   case (status, hsc_lang) of-        (HscUpToDate iface hmi_details, _) ->-            -- TODO recomp014 triggers this assert. What's going on?!-            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )-            return $! HomeModInfo iface hmi_details mb_old_linkable-        (HscNotGeneratingCode iface hmi_details, HscNothing) ->-            let mb_linkable = if isHsBootOrSig src_flavour-                                then Nothing-                                -- TODO: Questionable.-                                else Just (LM (ms_hs_date summary) this_mod [])-            in return $! HomeModInfo iface hmi_details mb_linkable-        (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"-        (_, HscNothing) -> panic "compileOne HscNothing"-        (HscUpdateBoot iface hmi_details, HscInterpreted) -> do-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateBoot iface hmi_details, _) -> do-            touchObjectFile dflags object_filename-            return $! HomeModInfo iface hmi_details Nothing-        (HscUpdateSig iface hmi_details, HscInterpreted) -> do-            let !linkable = LM (ms_hs_date summary) this_mod []-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscUpdateSig iface hmi_details, _) -> do-            output_fn <- getOutputFilename next_phase-                            (Temporary TFL_CurrentModule) basename dflags-                            next_phase (Just location)--            -- #10660: Use the pipeline instead of calling-            -- compileEmptyStub directly, so -dynamic-too gets-            -- handled properly-            _ <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour-                                            mod_name (HscUpdateSig iface hmi_details)))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            return $! HomeModInfo iface hmi_details (Just linkable)-        (HscRecomp { hscs_guts = cgguts,-                     hscs_mod_location = mod_location,-                     hscs_partial_iface = partial_iface,-                     hscs_old_iface_hash = mb_old_iface_hash,-                     hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do-            -- In interpreted mode the regular codeGen backend is not run so we-            -- generate a interface without codeGen info.-            let hsc_env'' = hsc_env'{hsc_dflags=iface_dflags}-            final_iface <- mkFullIface hsc_env'' partial_iface Nothing-            -- Reconstruct the `ModDetails` from the just-constructed `ModIface`-            -- See Note [ModDetails and --make mode]-            hmi_details <- liftIO $ initModDetails hsc_env'' summary final_iface-            liftIO $ hscMaybeWriteIface dflags final_iface mb_old_iface_hash (ms_location summary)--            (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location--            stub_o <- case hasStub of-                      Nothing -> return []-                      Just stub_c -> do-                          stub_o <- compileStub hsc_env' stub_c-                          return [DotO stub_o]--            let hs_unlinked = [BCOs comp_bc spt_entries]-                unlinked_time = ms_hs_date summary-              -- Why do we use the timestamp of the source file here,-              -- rather than the current time?  This works better in-              -- the case where the local clock is out of sync-              -- with the filesystem's clock.  It's just as accurate:-              -- if the source is modified, then the linkable will-              -- be out of date.-            let !linkable = LM unlinked_time (ms_mod summary)-                           (hs_unlinked ++ stub_o)-            return $! HomeModInfo final_iface hmi_details (Just linkable)-        (HscRecomp{}, _) -> do-            output_fn <- getOutputFilename next_phase-                            (Temporary TFL_CurrentModule)-                            basename dflags next_phase (Just location)-            -- We're in --make mode: finish the compilation pipeline.-            (_, _, Just iface) <- runPipeline StopLn hsc_env'-                              (output_fn,-                               Nothing,-                               Just (HscOut src_flavour mod_name status))-                              (Just basename)-                              Persistent-                              (Just location)-                              []-                  -- The object filename comes from the ModLocation-            o_time <- getModificationUTCTime object_filename-            let !linkable = LM o_time this_mod [DotO object_filename]-            -- See Note [ModDetails and --make mode]-            details <- initModDetails hsc_env' summary iface-            return $! HomeModInfo iface details (Just linkable)-- where dflags0     = ms_hspp_opts summary-       this_mod    = ms_mod summary-       location    = ms_location summary-       input_fn    = expectJust "compile:hs" (ml_hs_file location)-       input_fnpp  = ms_hspp_file summary-       mod_graph   = hsc_mod_graph hsc_env0-       needsLinker = needsTemplateHaskellOrQQ mod_graph-       isDynWay    = any (== WayDyn) (ways dflags0)-       isProfWay   = any (== WayProf) (ways dflags0)-       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)--       src_flavour = ms_hsc_src summary-       mod_name = ms_mod_name summary-       next_phase = hscPostBackendPhase src_flavour hsc_lang-       object_filename = ml_obj_file location--       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so-       -- the linker can correctly load the object files.  This isn't necessary-       -- when using -fexternal-interpreter.-       dflags1 = if hostIsDynamic && internalInterpreter &&-                    not isDynWay && not isProfWay && needsLinker-                  then gopt_set dflags0 Opt_BuildDynamicToo-                  else dflags0--       -- #16331 - when no "internal interpreter" is available but we-       -- need to process some TemplateHaskell or QuasiQuotes, we automatically-       -- turn on -fexternal-interpreter.-       dflags2 = if not internalInterpreter && needsLinker-                 then gopt_set dflags1 Opt_ExternalInterpreter-                 else dflags1--       basename = dropExtension input_fn--       -- We add the directory in which the .hs files resides) to the import-       -- path.  This is needed when we try to compile the .hc file later, if it-       -- imports a _stub.h file that we created here.-       current_dir = takeDirectory basename-       old_paths   = includePaths dflags2-       !prevailing_dflags = hsc_dflags hsc_env0-       dflags =-          dflags2 { includePaths = addImplicitQuoteInclude old_paths [current_dir]-                  , log_action = log_action prevailing_dflags }-                  -- use the prevailing log_action / log_finaliser,-                  -- not the one cached in the summary.  This is so-                  -- that we can change the log_action without having-                  -- to re-summarize all the source files.-       hsc_env     = hsc_env0 {hsc_dflags = dflags}--       -- Figure out what lang we're generating-       hsc_lang = hscTarget dflags--       -- -fforce-recomp should also work with --make-       force_recomp = gopt Opt_ForceRecomp dflags-       source_modified-         | force_recomp = SourceModified-         | otherwise = source_modified0--       always_do_basic_recompilation_check = case hsc_lang of-                                             HscInterpreted -> True-                                             _ -> False---------------------------------------------------------------------------------- stub .h and .c files (for foreign export support), and cc files.---- The _stub.c file is derived from the haskell source file, possibly taking--- into account the -stubdir option.------ The object file created by compiling the _stub.c file is put into a--- temporary file, which will be later combined with the main .o file--- (see the MergeForeigns phase).------ Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files--- from TH, that are then compiled and linked to the module. This is--- useful to implement facilities such as inline-c.--compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath-compileForeign _ RawObject object_file = return object_file-compileForeign hsc_env lang stub_c = do-        let phase = case lang of-              LangC      -> Cc-              LangCxx    -> Ccxx-              LangObjc   -> Cobjc-              LangObjcxx -> Cobjcxx-              LangAsm    -> As True -- allow CPP-#if __GLASGOW_HASKELL__ < 811-              RawObject  -> panic "compileForeign: should be unreachable"-#endif-        (_, stub_o, _) <- runPipeline StopLn hsc_env-                       (stub_c, Nothing, Just (RealPhase phase))-                       Nothing (Temporary TFL_GhcSession)-                       Nothing{-no ModLocation-}-                       []-        return stub_o--compileStub :: HscEnv -> FilePath -> IO FilePath-compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c--compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()-compileEmptyStub dflags hsc_env basename location mod_name = do-  -- To maintain the invariant that every Haskell file-  -- compiles to object code, we make an empty (but-  -- valid) stub object file for signatures.  However,-  -- we make sure this object file has a unique symbol,-  -- so that ranlib on OS X doesn't complain, see-  -- https://gitlab.haskell.org/ghc/ghc/issues/12673-  -- and https://github.com/haskell/cabal/issues/2257-  empty_stub <- newTempName dflags TFL_CurrentModule "c"-  let src = text "int" <+> ppr (mkHomeModule dflags mod_name) <+> text "= 0;"-  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))-  _ <- runPipeline StopLn hsc_env-                  (empty_stub, Nothing, Nothing)-                  (Just basename)-                  Persistent-                  (Just location)-                  []-  return ()---- ------------------------------------------------------------------------------ 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?-     -> HomePackageTable        -- what to link-     -> IO SuccessFlag---- For the moment, in the batch linker, we don't bother to tell doLink--- which packages to link -- it just tries all that are available.--- batch_attempt_linking should only be *looked at* in batch mode.  It--- should only be True if the upsweep was successful and someone--- exports main, i.e., we have good reason to believe that linking--- will succeed.--link ghcLink dflags-  = lookupHook linkHook l dflags ghcLink dflags-  where-    l LinkInMemory _ _ _-      = if platformMisc_ghcWithInterpreter $ platformMisc dflags-        then -- Not Linking...(demand linker will do the job)-             return Succeeded-        else panicBadLink LinkInMemory--    l NoLink _ _ _-      = return Succeeded--    l LinkBinary dflags batch_attempt_linking hpt-      = link' dflags batch_attempt_linking hpt--    l LinkStaticLib dflags batch_attempt_linking hpt-      = link' dflags batch_attempt_linking hpt--    l LinkDynLib dflags batch_attempt_linking hpt-      = link' dflags batch_attempt_linking hpt--panicBadLink :: GhcLink -> a-panicBadLink other = panic ("link: GHC not built to link this way: " ++-                            show other)--link' :: DynFlags                -- dynamic flags-      -> Bool                    -- attempt linking in batch mode?-      -> HomePackageTable        -- what to link-      -> IO SuccessFlag--link' dflags batch_attempt_linking hpt-   | batch_attempt_linking-   = do-        let-            staticLink = case ghcLink dflags of-                          LinkStaticLib -> True-                          _ -> False--            home_mod_infos = eltsHpt hpt--            -- the packages we depend on-            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos--            -- the linkables to link-            linkables = map (expectJust "link".hm_linkable) home_mod_infos--        debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))--        -- check for the -no-link flag-        if isNoLink (ghcLink dflags)-          then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")-                  return Succeeded-          else do--        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)-            obj_files = concatMap getOfiles linkables--            exe_file = exeFileName staticLink dflags--        linking_needed <- linkingNeeded dflags staticLink linkables pkg_deps--        if not (gopt Opt_ForceRecomp dflags) && not linking_needed-           then do debugTraceMsg dflags 2 (text exe_file <+> text "is up to date, linking not required.")-                   return Succeeded-           else do--        compilationProgressMsg dflags ("Linking " ++ exe_file ++ " ...")--        -- Don't showPass in Batch mode; doLink will do that for us.-        let link = case ghcLink dflags of-                LinkBinary    -> linkBinary-                LinkStaticLib -> linkStaticLib-                LinkDynLib    -> linkDynLibCheck-                other         -> panicBadLink other-        link dflags obj_files pkg_deps--        debugTraceMsg dflags 3 (text "link: done")--        -- linkBinary only returns if it succeeds-        return Succeeded--   | otherwise-   = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$-                                text "   Main.main not exported; not linking.")-        return Succeeded---linkingNeeded :: DynFlags -> Bool -> [Linkable] -> [UnitId] -> IO Bool-linkingNeeded dflags staticLink linkables pkg_deps = do-        -- if the modification time on the executable is later than the-        -- modification times on all of the objects and libraries, then omit-        -- linking (unless the -fforce-recomp flag was given).-  let exe_file = exeFileName staticLink dflags-  e_exe_time <- tryIO $ getModificationUTCTime exe_file-  case e_exe_time of-    Left _  -> return True-    Right t -> do-        -- first check object files and extra_ld_inputs-        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]-        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs-        let (errs,extra_times) = partitionEithers e_extra_times-        let obj_times =  map linkableTime linkables ++ extra_times-        if not (null errs) || any (t <) obj_times-            then return True-            else do--        -- next, check libraries. XXX this only checks Haskell libraries,-        -- not extra_libraries or -l things from the command line.-        let pkgstate = unitState dflags-        let pkg_hslibs  = [ (collectLibraryPaths dflags [c], lib)-                          | Just c <- map (lookupUnitId pkgstate) pkg_deps,-                            lib <- packageHsLibs dflags c ]--        pkg_libfiles <- mapM (uncurry (findHSLib dflags)) pkg_hslibs-        if any isNothing pkg_libfiles then return True else do-        e_lib_times <- mapM (tryIO . getModificationUTCTime)-                          (catMaybes pkg_libfiles)-        let (lib_errs,lib_times) = partitionEithers e_lib_times-        if not (null lib_errs) || any (t <) lib_times-           then return True-           else checkLinkInfo dflags pkg_deps exe_file--findHSLib :: DynFlags -> [String] -> String -> IO (Maybe FilePath)-findHSLib dflags dirs lib = do-  let batch_lib_file = if WayDyn `notElem` ways dflags-                      then "lib" ++ lib <.> "a"-                      else mkSOName (targetPlatform dflags) lib-  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)-  case found of-    [] -> return Nothing-    (x:_) -> return (Just x)---- -------------------------------------------------------------------------------- Compile files in one-shot mode.--oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()-oneShot hsc_env stop_phase srcs = do-  o_files <- mapM (compileFile hsc_env stop_phase) srcs-  doLink (hsc_dflags hsc_env) stop_phase o_files--compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath-compileFile hsc_env stop_phase (src, mb_phase) = do-   exists <- doesFileExist src-   when (not exists) $-        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))--   let-        dflags    = hsc_dflags hsc_env-        mb_o_file = outputFile dflags-        ghc_link  = ghcLink dflags      -- Set by -c or -no-link--        -- When linking, the -o argument refers to the linker's output.-        -- otherwise, we use it as the name for the pipeline's output.-        output-         -- If we are doing -fno-code, then act as if the output is-         -- 'Temporary'. This stops GHC trying to copy files to their-         -- final location.-         | HscNothing <- hscTarget dflags = Temporary TFL_CurrentModule-         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent-                -- -o foo applies to linker-         | isJust mb_o_file = SpecificFile-                -- -o foo applies to the file we are compiling now-         | otherwise = Persistent--   ( _, out_file, _) <- runPipeline stop_phase hsc_env-                            (src, Nothing, fmap RealPhase mb_phase)-                            Nothing-                            output-                            Nothing{-no ModLocation-} []-   return out_file---doLink :: DynFlags -> Phase -> [FilePath] -> IO ()-doLink dflags stop_phase o_files-  | not (isStopLn stop_phase)-  = return ()           -- We stopped before the linking phase--  | otherwise-  = case ghcLink dflags of-        NoLink        -> return ()-        LinkBinary    -> linkBinary         dflags o_files []-        LinkStaticLib -> linkStaticLib      dflags o_files []-        LinkDynLib    -> linkDynLibCheck    dflags o_files []-        other         -> panicBadLink other----- ------------------------------------------------------------------------------- | Run a compilation pipeline, consisting of multiple phases.------ This is the interface to the compilation pipeline, which runs--- a series of compilation steps on a single source file, specifying--- at which stage to stop.------ The DynFlags can be modified by phases in the pipeline (eg. by--- OPTIONS_GHC pragmas), and the changes affect later phases in the--- pipeline.-runPipeline-  :: Phase                      -- ^ When to stop-  -> HscEnv                     -- ^ Compilation environment-  -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)-                                -- ^ Pipeline input file name, optional-                                -- buffer and maybe -x suffix-  -> Maybe FilePath             -- ^ original basename (if different from ^^^)-  -> PipelineOutput             -- ^ Output filename-  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module-  -> [FilePath]                 -- ^ foreign objects-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)-runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)-             mb_basename output maybe_loc foreign_os--    = do let-             dflags0 = hsc_dflags hsc_env0--             -- Decide where dump files should go based on the pipeline output-             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }-             hsc_env = hsc_env0 {hsc_dflags = dflags}--             (input_basename, suffix) = splitExtension input_fn-             suffix' = drop 1 suffix -- strip off the .-             basename | Just b <- mb_basename = b-                      | otherwise             = input_basename--             -- If we were given a -x flag, then use that phase to start from-             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase--             isHaskell (RealPhase (Unlit _)) = True-             isHaskell (RealPhase (Cpp   _)) = True-             isHaskell (RealPhase (HsPp  _)) = True-             isHaskell (RealPhase (Hsc   _)) = True-             isHaskell (HscOut {})           = True-             isHaskell _                     = False--             isHaskellishFile = isHaskell start_phase--             env = PipeEnv{ stop_phase,-                            src_filename = input_fn,-                            src_basename = basename,-                            src_suffix = suffix',-                            output_spec = output }--         when (isBackpackishSuffix suffix') $-           throwGhcExceptionIO (UsageError-                       ("use --backpack to process " ++ input_fn))--         -- We want to catch cases of "you can't get there from here" before-         -- we start the pipeline, because otherwise it will just run off the-         -- end.-         let happensBefore' = happensBefore (targetPlatform dflags)-         case start_phase of-             RealPhase start_phase' ->-                 -- See Note [Partial ordering on phases]-                 -- Not the same as: (stop_phase `happensBefore` start_phase')-                 when (not (start_phase' `happensBefore'` stop_phase ||-                            start_phase' `eqPhase` stop_phase)) $-                       throwGhcExceptionIO (UsageError-                                   ("cannot compile this file to desired target: "-                                      ++ input_fn))-             HscOut {} -> return ()--         -- Write input buffer to temp file if requested-         input_fn' <- case (start_phase, mb_input_buf) of-             (RealPhase real_start_phase, Just input_buf) -> do-                 let suffix = phaseInputExt real_start_phase-                 fn <- newTempName dflags TFL_CurrentModule suffix-                 hdl <- openBinaryFile fn WriteMode-                 -- Add a LINE pragma so reported source locations will-                 -- mention the real input file, not this temp file.-                 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"-                 hPutStringBuffer hdl input_buf-                 hClose hdl-                 return fn-             (_, _) -> return input_fn--         debugTraceMsg dflags 4 (text "Running the pipeline")-         r <- runPipeline' start_phase hsc_env env input_fn'-                           maybe_loc foreign_os--         -- If we are compiling a Haskell module, and doing-         -- -dynamic-too, but couldn't do the -dynamic-too fast-         -- path, then rerun the pipeline for the dyn way-         let dflags = hsc_dflags hsc_env-         -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)-         when (not $ platformOS (targetPlatform dflags) == OSMinGW32) $ do-           when isHaskellishFile $ whenCannotGenerateDynamicToo dflags $ do-               debugTraceMsg dflags 4-                   (text "Running the pipeline again for -dynamic-too")-               let dflags' = dynamicTooMkDynamicDynFlags dflags-               hsc_env' <- newHscEnv dflags'-               _ <- runPipeline' start_phase hsc_env' env input_fn'-                                 maybe_loc foreign_os-               return ()-         return r--runPipeline'-  :: PhasePlus                  -- ^ When to start-  -> HscEnv                     -- ^ Compilation environment-  -> PipeEnv-  -> FilePath                   -- ^ Input filename-  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module-  -> [FilePath]                 -- ^ foreign objects, if we have one-  -> IO (DynFlags, FilePath, Maybe ModIface)-                                -- ^ (final flags, output filename, interface)-runPipeline' start_phase hsc_env env input_fn-             maybe_loc foreign_os-  = do-  -- Execute the pipeline...-  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }-  (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state-  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state)---- ------------------------------------------------------------------------------ outer pipeline loop---- | pipeLoop runs phases until we reach the stop phase-pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath-pipeLoop phase input_fn = do-  env <- getPipeEnv-  dflags <- getDynFlags-  -- See Note [Partial ordering on phases]-  let happensBefore' = happensBefore (targetPlatform dflags)-      stopPhase = stop_phase env-  case phase of-   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done-     -> -- Sometimes, a compilation phase doesn't actually generate any output-        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this-        -- stage, but we wanted to keep the output, then we have to explicitly-        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that-        -- further compilation stages can tell what the original filename was.-        case output_spec env of-        Temporary _ ->-            return input_fn-        output ->-            do pst <- getPipeState-               final_fn <- liftIO $ getOutputFilename-                                        stopPhase output (src_basename env)-                                        dflags stopPhase (maybe_loc pst)-               when (final_fn /= input_fn) $ do-                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")-                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")-                  liftIO $ copyWithHeader dflags msg line_prag input_fn final_fn-               return final_fn---     | not (realPhase `happensBefore'` stopPhase)-        -- Something has gone wrong.  We'll try to cover all the cases when-        -- this could happen, so if we reach here it is a panic.-        -- eg. it might happen if the -C flag is used on a source file that-        -- has {-# OPTIONS -fasm #-}.-     -> panic ("pipeLoop: at phase " ++ show realPhase ++-           " but I wanted to stop at phase " ++ show stopPhase)--   _-     -> do liftIO $ debugTraceMsg dflags 4-                                  (text "Running phase" <+> ppr phase)-           (next_phase, output_fn) <- runHookedPhase phase input_fn dflags-           case phase of-               HscOut {} -> do-                   -- We don't pass Opt_BuildDynamicToo to the backend-                   -- in DynFlags.-                   -- Instead it's run twice with flags accordingly set-                   -- per run.-                   let noDynToo = pipeLoop next_phase output_fn-                   let dynToo = do-                          setDynFlags $ gopt_unset dflags Opt_BuildDynamicToo-                          r <- pipeLoop next_phase output_fn-                          setDynFlags $ dynamicTooMkDynamicDynFlags dflags-                          -- TODO shouldn't ignore result:-                          _ <- pipeLoop phase input_fn-                          return r-                   ifGeneratingDynamicToo dflags dynToo noDynToo-               _ -> pipeLoop next_phase output_fn--runHookedPhase :: PhasePlus -> FilePath -> DynFlags-               -> CompPipeline (PhasePlus, FilePath)-runHookedPhase pp input dflags =-  lookupHook runPhaseHook runPhase dflags pp input dflags---- -------------------------------------------------------------------------------- In each phase, we need to know into what filename to generate the--- output.  All the logic about which filenames we generate output--- into is embodied in the following function.---- | Computes the next output filename after we run @next_phase@.--- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad--- (which specifies all of the ambient information.)-phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath-phaseOutputFilename next_phase = do-  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv-  PipeState{maybe_loc, hsc_env} <- getPipeState-  let dflags = hsc_dflags hsc_env-  liftIO $ getOutputFilename stop_phase output_spec-                             src_basename dflags next_phase maybe_loc---- | Computes the next output filename for something in the compilation--- pipeline.  This is controlled by several variables:------      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This---         is used to tell if we're in the last phase or not, because---         in that case flags like @-o@ may be important.---      2. 'PipelineOutput': is this intended to be a 'Temporary' or---         'Persistent' build output?  Temporary files just go in---         a fresh temporary name.---      3. 'String': what was the basename of the original input file?---      4. 'DynFlags': the obvious thing---      5. 'Phase': the phase we want to determine the output filename of.---      6. @Maybe ModLocation@: the 'ModLocation' of the module we're---         compiling; this can be used to override the default output---         of an object file.  (TODO: do we actually need this?)-getOutputFilename-  :: Phase -> PipelineOutput -> String-  -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath-getOutputFilename stop_phase output basename dflags next_phase maybe_location- | is_last_phase, Persistent   <- output = persistent_fn- | is_last_phase, SpecificFile <- output = case outputFile dflags of-                                           Just f -> return f-                                           Nothing ->-                                               panic "SpecificFile: No filename"- | keep_this_output                      = persistent_fn- | Temporary lifetime <- output          = newTempName dflags lifetime suffix- | otherwise                             = newTempName dflags TFL_CurrentModule-   suffix-    where-          hcsuf      = hcSuf dflags-          odir       = objectDir dflags-          osuf       = objectSuf dflags-          keep_hc    = gopt Opt_KeepHcFiles dflags-          keep_hscpp = gopt Opt_KeepHscppFiles dflags-          keep_s     = gopt Opt_KeepSFiles dflags-          keep_bc    = gopt Opt_KeepLlvmFiles dflags--          myPhaseInputExt HCc       = hcsuf-          myPhaseInputExt MergeForeign = osuf-          myPhaseInputExt StopLn    = osuf-          myPhaseInputExt other     = phaseInputExt other--          is_last_phase = next_phase `eqPhase` stop_phase--          -- sometimes, we keep output from intermediate stages-          keep_this_output =-               case next_phase of-                       As _    | keep_s     -> True-                       LlvmOpt | keep_bc    -> True-                       HCc     | keep_hc    -> True-                       HsPp _  | keep_hscpp -> True   -- See #10869-                       _other               -> False--          suffix = myPhaseInputExt next_phase--          -- persistent object files get put in odir-          persistent_fn-             | StopLn <- next_phase = return odir_persistent-             | otherwise            = return persistent--          persistent = basename <.> suffix--          odir_persistent-             | Just loc <- maybe_location = ml_obj_file loc-             | Just d <- odir = d </> persistent-             | otherwise      = persistent----- | LLVM Options. These are flags to be passed to opt and llc, to ensure--- consistency we list them in pairs, so that they form groups.-llvmOptions :: DynFlags-            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments-llvmOptions dflags =-       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]-    ++ [("-relocation-model=" ++ rmodel-        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]-    ++ [("-stack-alignment=" ++ (show align)-        ,"-stack-alignment=" ++ (show align)) | align > 0 ]--    -- Additional llc flags-    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)-                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]-    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]--  where target = platformMisc_llvmTarget $ platformMisc dflags-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)--        -- Relocation models-        rmodel | gopt Opt_PIC dflags        = "pic"-               | positionIndependent dflags = "pic"-               | WayDyn `elem` ways dflags  = "dynamic-no-pic"-               | otherwise                  = "static"--        align :: Int-        align = case platformArch (targetPlatform dflags) of-                  ArchX86_64 | isAvxEnabled dflags -> 32-                  _                                -> 0--        attrs :: String-        attrs = intercalate "," $ mattr-              ++ ["+sse42"   | isSse4_2Enabled dflags   ]-              ++ ["+sse2"    | isSse2Enabled dflags     ]-              ++ ["+sse"     | isSseEnabled dflags      ]-              ++ ["+avx512f" | isAvx512fEnabled dflags  ]-              ++ ["+avx2"    | isAvx2Enabled dflags     ]-              ++ ["+avx"     | isAvxEnabled dflags      ]-              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]-              ++ ["+avx512er"| isAvx512erEnabled dflags ]-              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]-              ++ ["+bmi"     | isBmiEnabled dflags      ]-              ++ ["+bmi2"    | isBmi2Enabled dflags     ]---- -------------------------------------------------------------------------------- | Each phase in the pipeline returns the next phase to execute, and the--- name of the file in which the output was placed.------ We must do things dynamically this way, because we often don't know--- what the rest of the phases will be until part-way through the--- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning--- of a source file can change the latter stages of the pipeline from--- taking the LLVM route to using the native code generator.----runPhase :: PhasePlus   -- ^ Run this phase-         -> FilePath    -- ^ name of the input file-         -> DynFlags    -- ^ for convenience, we pass the current dflags in-         -> CompPipeline (PhasePlus,           -- next phase to run-                          FilePath)            -- output filename--        -- Invariant: the output filename always contains the output-        -- Interesting case: Hsc when there is no recompilation to do-        --                   Then the output filename is still a .o file------------------------------------------------------------------------------------- Unlit phase--runPhase (RealPhase (Unlit sf)) input_fn dflags-  = do-       output_fn <- phaseOutputFilename (Cpp sf)--       let flags = [ -- The -h option passes the file name for unlit to-                     -- put in a #line directive-                     GHC.SysTools.Option     "-h"-                     -- See Note [Don't normalise input filenames].-                   , GHC.SysTools.Option $ escape input_fn-                   , GHC.SysTools.FileOption "" input_fn-                   , GHC.SysTools.FileOption "" output_fn-                   ]--       liftIO $ GHC.SysTools.runUnlit dflags flags--       return (RealPhase (Cpp sf), output_fn)-  where-       -- escape the characters \, ", and ', but don't try to escape-       -- Unicode or anything else (so we don't use Util.charToC-       -- here).  If we get this wrong, then in-       -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in-       -- a SrcLoc is the same as the source filenaame, the two will-       -- look bogusly different. See test:-       -- libraries/hpc/tests/function/subdir/tough2.hs-       escape ('\\':cs) = '\\':'\\': escape cs-       escape ('\"':cs) = '\\':'\"': escape cs-       escape ('\'':cs) = '\\':'\'': escape cs-       escape (c:cs)    = c : escape cs-       escape []        = []------------------------------------------------------------------------------------ Cpp phase : (a) gets OPTIONS out of file---             (b) runs cpp if necessary--runPhase (RealPhase (Cpp sf)) input_fn dflags0-  = do-       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn-       (dflags1, unhandled_flags, warns)-           <- liftIO $ parseDynamicFilePragma dflags0 src_opts-       setDynFlags dflags1-       liftIO $ checkProcessArgsResult dflags1 unhandled_flags--       if not (xopt LangExt.Cpp dflags1) then do-           -- we have to be careful to emit warnings only once.-           unless (gopt Opt_Pp dflags1) $-               liftIO $ handleFlagWarnings dflags1 warns--           -- no need to preprocess CPP, just pass input file along-           -- to the next phase of the pipeline.-           return (RealPhase (HsPp sf), input_fn)-        else do-            output_fn <- phaseOutputFilename (HsPp sf)-            liftIO $ doCpp dflags1 True{-raw-}-                           input_fn output_fn-            -- re-read the pragmas now that we've preprocessed the file-            -- See #2464,#3457-            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn-            (dflags2, unhandled_flags, warns)-                <- liftIO $ parseDynamicFilePragma dflags0 src_opts-            liftIO $ checkProcessArgsResult dflags2 unhandled_flags-            unless (gopt Opt_Pp dflags2) $-                liftIO $ handleFlagWarnings dflags2 warns-            -- the HsPp pass below will emit warnings--            setDynFlags dflags2--            return (RealPhase (HsPp sf), output_fn)------------------------------------------------------------------------------------ HsPp phase--runPhase (RealPhase (HsPp sf)) input_fn dflags-  = do-       if not (gopt Opt_Pp dflags) then-           -- no need to preprocess, just pass input file along-           -- to the next phase of the pipeline.-          return (RealPhase (Hsc sf), input_fn)-        else do-            PipeEnv{src_basename, src_suffix} <- getPipeEnv-            let orig_fn = src_basename <.> src_suffix-            output_fn <- phaseOutputFilename (Hsc sf)-            liftIO $ GHC.SysTools.runPp dflags-                           ( [ GHC.SysTools.Option     orig_fn-                             , GHC.SysTools.Option     input_fn-                             , GHC.SysTools.FileOption "" output_fn-                             ]-                           )--            -- re-read pragmas now that we've parsed the file (see #3674)-            src_opts <- liftIO $ getOptionsFromFile dflags output_fn-            (dflags1, unhandled_flags, warns)-                <- liftIO $ parseDynamicFilePragma dflags src_opts-            setDynFlags dflags1-            liftIO $ checkProcessArgsResult dflags1 unhandled_flags-            liftIO $ handleFlagWarnings dflags1 warns--            return (RealPhase (Hsc sf), output_fn)---------------------------------------------------------------------------------- Hsc phase---- Compilation of a single module, in "legacy" mode (_not_ under--- the direction of the compilation manager).-runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0- = do   -- normal Hsc mode, not mkdependHS--        PipeEnv{ stop_phase=stop,-                 src_basename=basename,-                 src_suffix=suff } <- getPipeEnv--  -- we add the current directory (i.e. the directory in which-  -- the .hs files resides) to the include path, since this is-  -- what gcc does, and it's probably what you want.-        let current_dir = takeDirectory basename-            new_includes = addImplicitQuoteInclude paths [current_dir]-            paths = includePaths dflags0-            dflags = dflags0 { includePaths = new_includes }--        setDynFlags dflags--  -- gather the imports and module name-        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do-          do-            buf <- hGetStringBuffer input_fn-            eimps <- getImports dflags buf input_fn (basename <.> suff)-            case eimps of-              Left errs -> throwErrors errs-              Right (src_imps,imps,L _ mod_name) -> return-                  (Just buf, mod_name, imps, src_imps)--  -- Take -o into account if present-  -- Very like -ohi, but we must *only* do this if we aren't linking-  -- (If we're linking then the -o applies to the linked thing, not to-  -- the object file for one module.)-  -- Note the nasty duplication with the same computation in compileFile above-        location <- getLocation src_flavour mod_name--        let o_file = ml_obj_file location -- The real object file-            hi_file = ml_hi_file location-            hie_file = ml_hie_file location-            dest_file | writeInterfaceOnlyMode dflags-                            = hi_file-                      | otherwise-                            = o_file--  -- Figure out if the source has changed, for recompilation avoidance.-  ---  -- Setting source_unchanged to True means that M.o (or M.hie) seems-  -- to be up to date wrt M.hs; so no need to recompile unless imports have-  -- changed (which the compiler itself figures out).-  -- Setting source_unchanged to False tells the compiler that M.o is out of-  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.-        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)--        source_unchanged <- liftIO $-          if not (isStopLn stop)-                -- SourceModified unconditionally if-                --      (a) recompilation checker is off, or-                --      (b) we aren't going all the way to .o file (e.g. ghc -S)-             then return SourceModified-                -- Otherwise look at file modification dates-             else do dest_file_mod <- sourceModified dest_file src_timestamp-                     hie_file_mod <- if gopt Opt_WriteHie dflags-                                        then sourceModified hie_file-                                                            src_timestamp-                                        else pure False-                     if dest_file_mod || hie_file_mod-                        then return SourceModified-                        else return SourceUnmodified--        PipeState{hsc_env=hsc_env'} <- getPipeState--  -- Tell the finder cache about this module-        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location--  -- Make the ModSummary to hand to hscMain-        let-            mod_summary = ModSummary {  ms_mod       = mod,-                                        ms_hsc_src   = src_flavour,-                                        ms_hspp_file = input_fn,-                                        ms_hspp_opts = dflags,-                                        ms_hspp_buf  = hspp_buf,-                                        ms_location  = location,-                                        ms_hs_date   = src_timestamp,-                                        ms_obj_date  = Nothing,-                                        ms_parsed_mod   = Nothing,-                                        ms_iface_date   = Nothing,-                                        ms_hie_date     = Nothing,-                                        ms_textual_imps = imps,-                                        ms_srcimps      = src_imps }--  -- run the compiler!-        let msg hsc_env _ what _ = oneShotMsg hsc_env what-        (result, plugin_dflags) <--          liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'-                            mod_summary source_unchanged Nothing (1,1)--        -- In the rest of the pipeline use the dflags with plugin info-        setDynFlags plugin_dflags--        return (HscOut src_flavour mod_name result,-                panic "HscOut doesn't have an input filename")--runPhase (HscOut src_flavour mod_name result) _ dflags = do-        location <- getLocation src_flavour mod_name-        setModLocation location--        let o_file = ml_obj_file location -- The real object file-            hsc_lang = hscTarget dflags-            next_phase = hscPostBackendPhase src_flavour hsc_lang--        case result of-            HscNotGeneratingCode _ _ ->-                return (RealPhase StopLn,-                        panic "No output filename from Hsc when no-code")-            HscUpToDate _ _ ->-                do liftIO $ touchObjectFile dflags o_file-                   -- The .o file must have a later modification date-                   -- than the source file (else we wouldn't get Nothing)-                   -- but we touch it anyway, to keep 'make' happy (we think).-                   return (RealPhase StopLn, o_file)-            HscUpdateBoot _ _ ->-                do -- In the case of hs-boot files, generate a dummy .o-boot-                   -- stamp file for the benefit of Make-                   liftIO $ touchObjectFile dflags o_file-                   return (RealPhase StopLn, o_file)-            HscUpdateSig _ _ ->-                do -- We need to create a REAL but empty .o file-                   -- because we are going to attempt to put it in a library-                   PipeState{hsc_env=hsc_env'} <- getPipeState-                   let input_fn = expectJust "runPhase" (ml_hs_file location)-                       basename = dropExtension input_fn-                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name-                   return (RealPhase StopLn, o_file)-            HscRecomp { hscs_guts = cgguts,-                        hscs_mod_location = mod_location,-                        hscs_partial_iface = partial_iface,-                        hscs_old_iface_hash = mb_old_iface_hash,-                        hscs_iface_dflags = iface_dflags }-              -> do output_fn <- phaseOutputFilename next_phase--                    PipeState{hsc_env=hsc_env'} <- getPipeState--                    (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $-                      hscGenHardCode hsc_env' cgguts mod_location output_fn--                    final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface (Just cg_infos))-                    setIface final_iface--                    -- See Note [Writing interface files]-                    let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo-                    liftIO $ hscMaybeWriteIface if_dflags final_iface mb_old_iface_hash mod_location--                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)-                    foreign_os <- liftIO $-                      mapM (uncurry (compileForeign hsc_env')) foreign_files-                    setForeignOs (maybe [] return stub_o ++ foreign_os)--                    return (RealPhase next_phase, outputFilename)---------------------------------------------------------------------------------- Cmm phase--runPhase (RealPhase CmmCpp) input_fn dflags-  = do output_fn <- phaseOutputFilename Cmm-       liftIO $ doCpp dflags False{-not raw-}-                      input_fn output_fn-       return (RealPhase Cmm, output_fn)--runPhase (RealPhase Cmm) input_fn dflags-  = do let hsc_lang = hscTarget dflags-       let next_phase = hscPostBackendPhase HsSrcFile hsc_lang-       output_fn <- phaseOutputFilename next_phase-       PipeState{hsc_env} <- getPipeState-       liftIO $ hscCompileCmmFile hsc_env input_fn output_fn-       return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- Cc phase--runPhase (RealPhase cc_phase) input_fn dflags-   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]-   = do-        let platform = targetPlatform dflags-            hcc = cc_phase `eqPhase` HCc--        let cmdline_include_paths = includePaths dflags--        -- HC files have the dependent packages stamped into them-        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []--        -- add package include paths even if we're just compiling .c-        -- files; this is the Value Add(TM) that using ghc instead of-        -- gcc gives you :)-        pkg_include_dirs <- liftIO $ getUnitIncludePath dflags pkgs-        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)-        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-              (includePathsQuote cmdline_include_paths ++-               includePathsQuoteImplicit cmdline_include_paths)-        let include_paths = include_paths_quote ++ include_paths_global--        -- pass -D or -optP to preprocessor when compiling foreign C files-        -- (#16737). Doing it in this way is simpler and also enable the C-        -- compiler to perform preprocessing and parsing in a single pass,-        -- but it may introduce inconsistency if a different pgm_P is specified.-        let more_preprocessor_opts = concat-              [ ["-Xpreprocessor", i]-              | not hcc-              , i <- getOpts dflags opt_P-              ]--        let gcc_extra_viac_flags = extraGccViaCFlags dflags-        let pic_c_flags = picCCOpts dflags--        let verbFlags = getVerbFlags dflags--        -- cc-options are not passed when compiling .hc files.  Our-        -- hc code doesn't not #include any header files anyway, so these-        -- options aren't necessary.-        pkg_extra_cc_opts <- liftIO $-          if hcc-             then return []-             else getUnitExtraCcOpts dflags pkgs--        framework_paths <--            if platformUsesFrameworks platform-            then do pkgFrameworkPaths <- liftIO $ getUnitFrameworkPath dflags pkgs-                    let cmdlineFrameworkPaths = frameworkPaths dflags-                    return $ map ("-F"++)-                                 (cmdlineFrameworkPaths ++ pkgFrameworkPaths)-            else return []--        let cc_opt | optLevel dflags >= 2 = [ "-O2" ]-                   | optLevel dflags >= 1 = [ "-O" ]-                   | otherwise            = []--        -- Decide next phase-        let next_phase = As False-        output_fn <- phaseOutputFilename next_phase--        let-          more_hcc_opts =-                -- on x86 the floating point regs have greater precision-                -- than a double, which leads to unpredictable results.-                -- By default, we turn this off with -ffloat-store unless-                -- the user specified -fexcess-precision.-                (if platformArch platform == ArchX86 &&-                    not (gopt Opt_ExcessPrecision dflags)-                        then [ "-ffloat-store" ]-                        else []) ++--                -- gcc's -fstrict-aliasing allows two accesses to memory-                -- to be considered non-aliasing if they have different types.-                -- This interacts badly with the C code we generate, which is-                -- very weakly typed, being derived from C--.-                ["-fno-strict-aliasing"]--        ghcVersionH <- liftIO $ getGhcVersionPathName dflags--        liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) dflags (-                        [ GHC.SysTools.FileOption "" input_fn-                        , GHC.SysTools.Option "-o"-                        , GHC.SysTools.FileOption "" output_fn-                        ]-                       ++ map GHC.SysTools.Option (-                          pic_c_flags--                -- Stub files generated for foreign exports references the runIO_closure-                -- and runNonIO_closure symbols, which are defined in the base package.-                -- These symbols are imported into the stub.c file via RtsAPI.h, and the-                -- way we do the import depends on whether we're currently compiling-                -- the base package or not.-                       ++ (if platformOS platform == OSMinGW32 &&-                              homeUnitId dflags == baseUnitId-                                then [ "-DCOMPILING_BASE_PACKAGE" ]-                                else [])--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack. See #2872, commit-        -- 5bd3072ac30216a505151601884ac88bf404c9f2-                       ++ (if platformArch platform == ArchSPARC-                           then ["-mcpu=v9"]-                           else [])--                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.-                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)-                             then ["-Wimplicit"]-                             else [])--                       ++ (if hcc-                             then gcc_extra_viac_flags ++ more_hcc_opts-                             else [])-                       ++ verbFlags-                       ++ [ "-S" ]-                       ++ cc_opt-                       ++ [ "-include", ghcVersionH ]-                       ++ framework_paths-                       ++ include_paths-                       ++ more_preprocessor_opts-                       ++ pkg_extra_cc_opts-                       ))--        return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- As, SpitAs phase : Assembler---- This is for calling the assembler on a regular assembly file-runPhase (RealPhase (As with_cpp)) input_fn dflags-  = do-        -- LLVM from version 3.0 onwards doesn't support the OS X system-        -- assembler, so we use clang as the assembler instead. (#5636)-        let as_prog | hscTarget dflags == HscLlvm &&-                      platformOS (targetPlatform dflags) == OSDarwin-                    = GHC.SysTools.runClang-                    | otherwise = GHC.SysTools.runAs--        let cmdline_include_paths = includePaths dflags-        let pic_c_flags = picCCOpts dflags--        next_phase <- maybeMergeForeign-        output_fn <- phaseOutputFilename next_phase--        -- we create directories for the object file, because it-        -- might be a hierarchical module.-        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)--        ccInfo <- liftIO $ getCompilerInfo dflags-        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)-                              | p <- includePathsGlobal cmdline_include_paths ]-        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ++-                                includePathsQuoteImplicit cmdline_include_paths]-        let runAssembler inputFilename outputFilename-              = liftIO $ do-                  withAtomicRename outputFilename $ \temp_outputFilename -> do-                    as_prog-                       dflags-                       (local_includes ++ global_includes-                       -- See Note [-fPIC for assembler]-                       ++ map GHC.SysTools.Option pic_c_flags-                       -- See Note [Produce big objects on Windows]-                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"-                          | platformOS (targetPlatform dflags) == OSMinGW32-                          , not $ target32Bit (targetPlatform dflags)-                          ]--        -- We only support SparcV9 and better because V8 lacks an atomic CAS-        -- instruction so we have to make sure that the assembler accepts the-        -- instruction set. Note that the user can still override this-        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag-        -- regardless of the ordering.-        ---        -- This is a temporary hack.-                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC-                           then [GHC.SysTools.Option "-mcpu=v9"]-                           else [])-                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]-                            then [GHC.SysTools.Option "-Qunused-arguments"]-                            else [])-                       ++ [ GHC.SysTools.Option "-x"-                          , if with_cpp-                              then GHC.SysTools.Option "assembler-with-cpp"-                              else GHC.SysTools.Option "assembler"-                          , GHC.SysTools.Option "-c"-                          , GHC.SysTools.FileOption "" inputFilename-                          , GHC.SysTools.Option "-o"-                          , GHC.SysTools.FileOption "" temp_outputFilename-                          ])--        liftIO $ debugTraceMsg dflags 4 (text "Running the assembler")-        runAssembler input_fn output_fn--        return (RealPhase next_phase, output_fn)----------------------------------------------------------------------------------- LlvmOpt phase-runPhase (RealPhase LlvmOpt) input_fn dflags-  = do-    output_fn <- phaseOutputFilename LlvmLlc--    liftIO $ GHC.SysTools.runLlvmOpt dflags-               (   optFlag-                ++ defaultOptions ++-                [ GHC.SysTools.FileOption "" input_fn-                , GHC.SysTools.Option "-o"-                , GHC.SysTools.FileOption "" output_fn]-                )--    return (RealPhase LlvmLlc, output_fn)-  where-        -- we always (unless -optlo specified) run Opt since we rely on it to-        -- fix up some pretty big deficiencies in the code we generate-        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]-        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of-                    Just passes -> passes-                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "-                                      ++ "is missing passes for level "-                                      ++ show optIdx)--        -- don't specify anything if user has specified commands. We do this-        -- for opt but not llc since opt is very specifically for optimisation-        -- passes only, so if the user is passing us extra options we assume-        -- they know what they are doing and don't get in the way.-        optFlag = if null (getOpts dflags opt_lo)-                  then map GHC.SysTools.Option $ words llvmOpts-                  else []--        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst-                       $ unzip (llvmOptions dflags)---------------------------------------------------------------------------------- LlvmLlc phase--runPhase (RealPhase LlvmLlc) input_fn dflags-  = do-    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling-                     | gopt Opt_NoLlvmMangler dflags -> return (As False)-                     | otherwise -> return LlvmMangle--    output_fn <- phaseOutputFilename next_phase--    liftIO $ GHC.SysTools.runLlvmLlc dflags-                (  optFlag-                ++ defaultOptions-                ++ [ GHC.SysTools.FileOption "" input_fn-                   , GHC.SysTools.Option "-o"-                   , GHC.SysTools.FileOption "" output_fn-                   ]-                )--    return (RealPhase next_phase, output_fn)-  where-    -- Note [Clamping of llc optimizations]-    ---    -- See #13724-    ---    -- we clamp the llc optimization between [1,2]. This is because passing -O0-    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with-    ---    --   Error while trying to spill R1 from class GPR: Cannot scavenge register-    --   without an emergency spill slot!-    ---    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.-    ---    ---    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile-    --   rts/HeapStackCheck.cmm-    ---    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s-    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40-    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358-    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26-    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876-    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699-    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381-    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457-    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20-    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134-    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498-    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67-    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920-    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133-    -- 13 llc                      0x000000010195bf0b main + 491-    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1-    -- Stack dump:-    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s-    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.-    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'-    ---    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa-    ---    llvmOpts = case optLevel dflags of-      0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.-      1 -> "-O1"-      _ -> "-O2"--    optFlag = if null (getOpts dflags opt_lc)-              then map GHC.SysTools.Option $ words llvmOpts-              else []--    defaultOptions = map GHC.SysTools.Option . concatMap words . snd-                   $ unzip (llvmOptions dflags)----------------------------------------------------------------------------------- LlvmMangle phase--runPhase (RealPhase LlvmMangle) input_fn dflags-  = do-      let next_phase = As False-      output_fn <- phaseOutputFilename next_phase-      liftIO $ llvmFixupAsm dflags input_fn output_fn-      return (RealPhase next_phase, output_fn)---------------------------------------------------------------------------------- merge in stub objects--runPhase (RealPhase MergeForeign) input_fn dflags- = do-     PipeState{foreign_os} <- getPipeState-     output_fn <- phaseOutputFilename StopLn-     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)-     if null foreign_os-       then panic "runPhase(MergeForeign): no foreign objects"-       else do-         liftIO $ joinObjectFiles dflags (input_fn : foreign_os) output_fn-         return (RealPhase StopLn, output_fn)---- warning suppression-runPhase (RealPhase other) _input_fn _dflags =-   panic ("runPhase: don't know how to run phase " ++ show other)--maybeMergeForeign :: CompPipeline Phase-maybeMergeForeign- = do-     PipeState{foreign_os} <- getPipeState-     if null foreign_os then return StopLn else return MergeForeign--getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation-getLocation src_flavour mod_name = do-    dflags <- getDynFlags--    PipeEnv{ src_basename=basename,-             src_suffix=suff } <- getPipeEnv-    PipeState { maybe_loc=maybe_loc} <- getPipeState-    case maybe_loc of-        -- Build a ModLocation to pass to hscMain.-        -- The source filename is rather irrelevant by now, but it's used-        -- by hscMain for messages.  hscMain also needs-        -- the .hi and .o filenames. If we already have a ModLocation-        -- then simply update the extensions of the interface and object-        -- files to match the DynFlags, otherwise use the logic in Finder.-      Just l -> return $ l-        { ml_hs_file = Just $ basename <.> suff-        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags-        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags-        }-      _ -> do-        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff--        -- Boot-ify it if necessary-        let location2-              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1-              | otherwise                 = location1---        -- Take -ohi into account if present-        -- This can't be done in mkHomeModuleLocation because-        -- it only applies to the module being compiles-        let ohi = outputHi dflags-            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }-                      | otherwise      = location2--        -- Take -o into account if present-        -- Very like -ohi, but we must *only* do this if we aren't linking-        -- (If we're linking then the -o applies to the linked thing, not to-        -- the object file for one module.)-        -- Note the nasty duplication with the same computation in compileFile-        -- above-        let expl_o_file = outputFile dflags-            location4 | Just ofile <- expl_o_file-                      , isNoLink (ghcLink dflags)-                      = location3 { ml_obj_file = ofile }-                      | otherwise = location3-        return location4---------------------------------------------------------------------------------- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file--getHCFilePackages :: FilePath -> IO [UnitId]-getHCFilePackages filename =-  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do-    l <- hGetLine h-    case l of-      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->-          return (map stringToUnitId (words rest))-      _other ->-          return []---------------------------------------------------------------------------------- Static linking, of .o files---- The list of packages passed to link is the list of packages on--- which this program depends, as discovered by the compilation--- manager.  It is combined with the list of packages that the user--- specifies on the command line with -package flags.------ In one-shot linking mode, we can't discover the package--- dependencies (because we haven't actually done any compilation or--- read any interface files), so the user must explicitly specify all--- the packages.--{--Note [-Xlinker -rpath vs -Wl,-rpath]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---Wl takes a comma-separated list of options which in the case of--Wl,-rpath -Wl,some,path,with,commas parses the path with commas-as separate options.-Buck, the build system, produces paths with commas in them.---Xlinker doesn't have this disadvantage and as far as I can tell-it is supported by both gcc and clang. Anecdotally nvcc supports--Xlinker, but not -Wl.--}--linkBinary :: DynFlags -> [FilePath] -> [UnitId] -> IO ()-linkBinary = linkBinary' False--linkBinary' :: Bool -> DynFlags -> [FilePath] -> [UnitId] -> IO ()-linkBinary' staticLink dflags o_files dep_units = do-    let platform = targetPlatform dflags-        toolSettings' = toolSettings dflags-        verbFlags = getVerbFlags dflags-        output_fn = exeFileName staticLink dflags--    -- get the full list of packages to link with, by combining the-    -- explicit packages with the auto packages and all of their-    -- dependencies, and eliminating duplicates.--    full_output_fn <- if isAbsolute output_fn-                      then return output_fn-                      else do d <- getCurrentDirectory-                              return $ normalise (d </> output_fn)-    pkg_lib_paths <- getUnitLibraryPath dflags dep_units-    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths-        get_pkg_lib_path_opts l-         | osElfTarget (platformOS platform) &&-           dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags-            = let libpath = if gopt Opt_RelativeDynlibPaths dflags-                            then "$ORIGIN" </>-                                 (l `makeRelativeTo` full_output_fn)-                            else l-                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]-                  rpath = if useXLinkerRPath dflags (platformOS platform)-                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]-                          else []-                  -- Solaris 11's linker does not support -rpath-link option. It silently-                  -- ignores it and then complains about next option which is -l<some-                  -- dir> as being a directory and not expected object file, E.g-                  -- ld: elf error: file-                  -- /tmp/ghc-src/libraries/base/dist-install/build:-                  -- elf_begin: I/O error: region read: Is a directory-                  rpathlink = if (platformOS platform) == OSSolaris2-                              then []-                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]-              in ["-L" ++ l] ++ rpathlink ++ rpath-         | osMachOTarget (platformOS platform) &&-           dynLibLoader dflags == SystemDependent &&-           WayDyn `elem` ways dflags &&-           useXLinkerRPath dflags (platformOS platform)-            = let libpath = if gopt Opt_RelativeDynlibPaths dflags-                            then "@loader_path" </>-                                 (l `makeRelativeTo` full_output_fn)-                            else l-              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]-         | otherwise = ["-L" ++ l]--    pkg_lib_path_opts <--      if gopt Opt_SingleLibFolder dflags-      then do-        libs <- getLibs dflags dep_units-        tmpDir <- newTempDir dflags-        sequence_ [ copyFile lib (tmpDir </> basename)-                  | (lib, basename) <- libs]-        return [ "-L" ++ tmpDir ]-      else pure pkg_lib_path_opts--    let-      dead_strip-        | gopt Opt_WholeArchiveHsLibs dflags = []-        | otherwise = if osSubsectionsViaSymbols (platformOS platform)-                        then ["-Wl,-dead_strip"]-                        else []-    let lib_paths = libraryPaths dflags-    let lib_path_opts = map ("-L"++) lib_paths--    extraLinkObj <- mkExtraObjToLinkIntoBinary dflags-    noteLinkObjs <- mkNoteObjsToLinkIntoBinary dflags dep_units--    let-      (pre_hs_libs, post_hs_libs)-        | gopt Opt_WholeArchiveHsLibs dflags-        = if platformOS platform == OSDarwin-            then (["-Wl,-all_load"], [])-              -- OS X does not have a flag to turn off -all_load-            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])-        | otherwise-        = ([],[])--    pkg_link_opts <- do-        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags dep_units-        return $ if staticLink-            then package_hs_libs -- If building an executable really means making a static-                                 -- library (e.g. iOS), then we only keep the -l options for-                                 -- HS packages, because libtool doesn't accept other options.-                                 -- In the case of iOS these need to be added by hand to the-                                 -- final link in Xcode.-            else other_flags ++ dead_strip-                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs-                  ++ extra_libs-                 -- -Wl,-u,<sym> contained in other_flags-                 -- needs to be put before -l<package>,-                 -- otherwise Solaris linker fails linking-                 -- a binary with unresolved symbols in RTS-                 -- which are defined in base package-                 -- the reason for this is a note in ld(1) about-                 -- '-u' option: "The placement of this option-                 -- on the command line is significant.-                 -- This option must be placed before the library-                 -- that defines the symbol."--    -- frameworks-    pkg_framework_opts <- getUnitFrameworkOpts dflags platform dep_units-    let framework_opts = getFrameworkOpts dflags platform--        -- probably _stub.o files-    let extra_ld_inputs = ldInputs dflags--    rc_objs <- maybeCreateManifest dflags output_fn--    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"-                         , GHC.SysTools.FileOption "" output_fn-                         ]-                      ++ libmLinkOpts-                      ++ map GHC.SysTools.Option (-                         []--                      -- See Note [No PIE when linking]-                      ++ picCCOpts dflags--                      -- Permit the linker to auto link _symbol to _imp_symbol.-                      -- This lets us link against DLLs without needing an "import library".-                      ++ (if platformOS platform == OSMinGW32-                          then ["-Wl,--enable-auto-import"]-                          else [])--                      -- '-no_compact_unwind'-                      -- C++/Objective-C exceptions cannot use optimised-                      -- stack unwinding code. The optimised form is the-                      -- default in Xcode 4 on at least x86_64, and-                      -- without this flag we're also seeing warnings-                      -- like-                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog-                      -- on x86.-                      ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&-                             not staticLink &&-                             (platformOS platform == OSDarwin) &&-                             case platformArch platform of-                               ArchX86 -> True-                               ArchX86_64 -> True-                               ArchARM {} -> True-                               ArchAArch64  -> True-                               _ -> False-                          then ["-Wl,-no_compact_unwind"]-                          else [])--                      -- '-Wl,-read_only_relocs,suppress'-                      -- ld gives loads of warnings like:-                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure-                      -- when linking any program. We're not sure-                      -- whether this is something we ought to fix, but-                      -- for now this flags silences them.-                      ++ (if platformOS   platform == OSDarwin &&-                             platformArch platform == ArchX86 &&-                             not staticLink-                          then ["-Wl,-read_only_relocs,suppress"]-                          else [])--                      ++ (if toolSettings_ldIsGnuLd toolSettings' &&-                             not (gopt Opt_WholeArchiveHsLibs dflags)-                          then ["-Wl,--gc-sections"]-                          else [])--                      ++ o_files-                      ++ lib_path_opts)-                      ++ extra_ld_inputs-                      ++ map GHC.SysTools.Option (-                         rc_objs-                      ++ framework_opts-                      ++ pkg_lib_path_opts-                      ++ extraLinkObj:noteLinkObjs-                      ++ pkg_link_opts-                      ++ pkg_framework_opts-                      ++ (if platformOS platform == OSDarwin-                          --  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 [])-                    ))--exeFileName :: Bool -> DynFlags -> FilePath-exeFileName staticLink dflags-  | Just s <- outputFile dflags =-      case platformOS (targetPlatform dflags) of-          OSMinGW32 -> s <?.> "exe"-          _         -> if staticLink-                         then s <?.> "a"-                         else s-  | otherwise =-      if platformOS (targetPlatform dflags) == OSMinGW32-      then "main.exe"-      else if staticLink-           then "liba.a"-           else "a.out"- where s <?.> ext | null (takeExtension s) = s <.> ext-                  | otherwise              = s--maybeCreateManifest-   :: DynFlags-   -> FilePath                          -- filename of executable-   -> IO [FilePath]                     -- extra objects to embed, maybe-maybeCreateManifest dflags exe_filename- | platformOS (targetPlatform dflags) == OSMinGW32 &&-   gopt Opt_GenManifest dflags-    = do let manifest_filename = exe_filename <.> "manifest"--         writeFile manifest_filename $-             "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++-             "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++-             "  <assemblyIdentity version=\"1.0.0.0\"\n"++-             "     processorArchitecture=\"X86\"\n"++-             "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++-             "     type=\"win32\"/>\n\n"++-             "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++-             "    <security>\n"++-             "      <requestedPrivileges>\n"++-             "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++-             "        </requestedPrivileges>\n"++-             "       </security>\n"++-             "  </trustInfo>\n"++-             "</assembly>\n"--         -- Windows will find the manifest file if it is named-         -- foo.exe.manifest. However, for extra robustness, and so that-         -- we can move the binary around, we can embed the manifest in-         -- the binary itself using windres:-         if not (gopt Opt_EmbedManifest dflags) then return [] else do--         rc_filename <- newTempName dflags TFL_CurrentModule "rc"-         rc_obj_filename <--           newTempName dflags TFL_GhcSession (objectSuf dflags)--         writeFile rc_filename $-             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"-               -- magic numbers :-)-               -- show is a bit hackish above, but we need to escape the-               -- backslashes in the path.--         runWindres dflags $ map GHC.SysTools.Option $-               ["--input="++rc_filename,-                "--output="++rc_obj_filename,-                "--output-format=coff"]-               -- no FileOptions here: windres doesn't like seeing-               -- backslashes, apparently--         removeFile manifest_filename--         return [rc_obj_filename]- | otherwise = return []---linkDynLibCheck :: DynFlags -> [String] -> [UnitId] -> IO ()-linkDynLibCheck dflags o_files dep_units- = do-    when (haveRtsOptsFlags dflags) $ do-      putLogMsg dflags NoReason SevInfo noSrcSpan-          $ withPprStyle defaultUserStyle-          (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$-           text "    Call hs_init_ghc() from your main() function to set these options.")--    linkDynLib dflags o_files dep_units---- | Linking a static lib will not really link anything. It will merely produce--- a static archive of all dependent static libraries. The resulting library--- will still need to be linked with any remaining link flags.-linkStaticLib :: DynFlags -> [String] -> [UnitId] -> IO ()-linkStaticLib dflags o_files dep_units = do-  let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]-      modules = o_files ++ extra_ld_inputs-      output_fn = exeFileName True dflags--  full_output_fn <- if isAbsolute output_fn-                    then return output_fn-                    else do d <- getCurrentDirectory-                            return $ normalise (d </> output_fn)-  output_exists <- doesFileExist full_output_fn-  (when output_exists) $ removeFile full_output_fn--  pkg_cfgs_init <- getPreloadUnitsAnd dflags dep_units--  let pkg_cfgs-        | gopt Opt_LinkRts dflags-        = pkg_cfgs_init-        | otherwise-        = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init--  archives <- concatMapM (collectArchives dflags) pkg_cfgs--  ar <- foldl mappend-        <$> (Archive <$> mapM loadObj modules)-        <*> mapM loadAr archives--  if toolSettings_ldIsGnuLd (toolSettings dflags)-    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar-    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar--  -- run ranlib over the archive. write*Ar does *not* create the symbol index.-  runRanlib dflags [GHC.SysTools.FileOption "" output_fn]---- -------------------------------------------------------------------------------- Running CPP--doCpp :: DynFlags -> Bool -> FilePath -> FilePath -> IO ()-doCpp dflags raw input_fn output_fn = do-    let hscpp_opts = picPOpts dflags-    let cmdline_include_paths = includePaths dflags--    pkg_include_dirs <- getUnitIncludePath dflags []-    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths ++-           includePathsQuoteImplicit cmdline_include_paths)-    let include_paths = include_paths_quote ++ include_paths_global--    let verbFlags = getVerbFlags dflags--    let cpp_prog args | raw       = GHC.SysTools.runCpp dflags args-                      | otherwise = GHC.SysTools.runCc Nothing dflags (GHC.SysTools.Option "-E" : args)--    let targetArch = stringEncodeArch $ platformArch $ targetPlatform dflags-        targetOS = stringEncodeOS $ platformOS $ targetPlatform dflags-        isWindows = (platformOS $ targetPlatform dflags) == OSMinGW32-    let target_defs =-          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",-            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",-            "-D" ++ targetOS    ++ "_HOST_OS",-            "-D" ++ targetArch  ++ "_HOST_ARCH" ]-        -- remember, in code we *compile*, the HOST is the same our TARGET,-        -- and BUILD is the same as our HOST.--    let io_manager_defs =-          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++-          [ "-D__IO_MANAGER_MIO__=1"               ]--    let sse_defs =-          [ "-D__SSE__"      | isSseEnabled      dflags ] ++-          [ "-D__SSE2__"     | isSse2Enabled     dflags ] ++-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]--    let avx_defs =-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]--    backend_defs <- getBackendDefs dflags--    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]-    -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags-    let hsSourceCppOpts = [ "-include", ghcVersionH ]--    -- MIN_VERSION macros-    let state = unitState dflags-        uids = explicitUnits state-        pkgs = catMaybes (map (lookupUnit state) uids)-    mb_macro_include <--        if not (null pkgs) && gopt Opt_VersionMacros dflags-            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"-                    writeFile macro_stub (generatePackageVersionMacros pkgs)-                    -- Include version macros for every *exposed* package.-                    -- Without -hide-all-packages and with a package database-                    -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See #10970-                    -- comment 8.-                    return [GHC.SysTools.FileOption "-include" macro_stub]-            else return []--    cpp_prog       (   map GHC.SysTools.Option verbFlags-                    ++ map GHC.SysTools.Option include_paths-                    ++ map GHC.SysTools.Option hsSourceCppOpts-                    ++ map GHC.SysTools.Option target_defs-                    ++ map GHC.SysTools.Option backend_defs-                    ++ map GHC.SysTools.Option th_defs-                    ++ map GHC.SysTools.Option hscpp_opts-                    ++ map GHC.SysTools.Option sse_defs-                    ++ map GHC.SysTools.Option avx_defs-                    ++ map GHC.SysTools.Option io_manager_defs-                    ++ mb_macro_include-        -- Set the language mode to assembler-with-cpp when preprocessing. This-        -- alleviates some of the C99 macro rules relating to whitespace and the hash-        -- operator, which we tend to abuse. Clang in particular is not very happy-        -- about this.-                    ++ [ GHC.SysTools.Option     "-x"-                       , GHC.SysTools.Option     "assembler-with-cpp"-                       , GHC.SysTools.Option     input_fn-        -- We hackily use Option instead of FileOption here, so that the file-        -- name is not back-slashed on Windows.  cpp is capable of-        -- dealing with / in filenames, so it works fine.  Furthermore-        -- if we put in backslashes, cpp outputs #line directives-        -- with *double* backslashes.   And that in turn means that-        -- our error messages get double backslashes in them.-        -- In due course we should arrange that the lexer deals-        -- with these \\ escapes properly.-                       , GHC.SysTools.Option     "-o"-                       , GHC.SysTools.FileOption "" output_fn-                       ])--getBackendDefs :: DynFlags -> IO [String]-getBackendDefs dflags | hscTarget dflags == HscLlvm = do-    llvmVer <- figureLlvmVersion dflags-    return $ case fmap llvmVersionList llvmVer of-               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]-               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-               _ -> []-  where-    format (major, minor)-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int--getBackendDefs _ =-    return []---- ------------------------------------------------------------------------------ Macros (cribbed from Cabal)--generatePackageVersionMacros :: [UnitInfo] -> String-generatePackageVersionMacros pkgs = concat-  -- Do not add any C-style comments. See #3389.-  [ generateMacros "" pkgname version-  | pkg <- pkgs-  , let version = unitPackageVersion pkg-        pkgname = map fixchar (unitPackageNameString pkg)-  ]--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c   = c--generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =-  concat-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]-  where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)---- ------------------------------------------------------------------------------ join object files into a single relocatable object file, using ld -r--{--Note [Produce big objects on Windows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The Windows Portable Executable object format has a limit of 32k sections, which-we tend to blow through pretty easily. Thankfully, there is a "big object"-extension, which raises this limit to 2^32. However, it must be explicitly-enabled in the toolchain:-- * the assembler accepts the -mbig-obj flag, which causes it to produce a-   bigobj-enabled COFF object.-- * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name-   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a-   PE executable.--We must enable bigobj output in a few places:-- * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)-- * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))--Unfortunately the big object format is not supported on 32-bit targets so-none of this can be used in that case.---Note [Merging object files for GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHCi can usually loads standard linkable object files using GHC's linker-implementation. However, most users build their projects with -split-sections,-meaning that such object files can have an extremely high number of sections.-As the linker must map each of these sections individually, loading such object-files is very inefficient.--To avoid this inefficiency, we use the linker's `-r` flag and a linker script-to produce a merged relocatable object file. This file will contain a singe-text section section and can consequently be mapped far more efficiently. As-gcc tends to do unpredictable things to our linker command line, we opt to-invoke ld directly in this case, in contrast to our usual strategy of linking-via gcc.---}--joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()-joinObjectFiles dflags o_files output_fn = do-  let toolSettings' = toolSettings dflags-      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'-      osInfo = platformOS (targetPlatform dflags)-      ld_r args = GHC.SysTools.runMergeObjects dflags (-                        -- See Note [Produce big objects on Windows]-                        concat-                          [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]-                          | OSMinGW32 == osInfo-                          , not $ target32Bit (targetPlatform dflags)-                          ]-                     ++ map GHC.SysTools.Option ld_build_id-                     ++ [ GHC.SysTools.Option "-o",-                          GHC.SysTools.FileOption "" output_fn ]-                     ++ args)--      -- suppress the generation of the .note.gnu.build-id section,-      -- which we don't need and sometimes causes ld to emit a-      -- warning:-      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]-                  | otherwise                     = []--  if ldIsGnuLd-     then do-          script <- newTempName dflags TFL_CurrentModule "ldscript"-          cwd <- getCurrentDirectory-          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files-          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"-          ld_r [GHC.SysTools.FileOption "" script]-     else if toolSettings_ldSupportsFilelist toolSettings'-     then do-          filelist <- newTempName dflags TFL_CurrentModule "filelist"-          writeFile filelist $ unlines o_files-          ld_r [GHC.SysTools.Option "-filelist",-                GHC.SysTools.FileOption "" filelist]-     else do-          ld_r (map (GHC.SysTools.FileOption "") o_files)---- -------------------------------------------------------------------------------- Misc.--writeInterfaceOnlyMode :: DynFlags -> Bool-writeInterfaceOnlyMode dflags =- gopt Opt_WriteInterface dflags &&- HscNothing == hscTarget dflags---- | Figure out if a source file was modified after an output file (or if we--- anyways need to consider the source file modified since the output is gone).-sourceModified :: FilePath -- ^ destination file we are looking for-               -> UTCTime  -- ^ last time of modification of source file-               -> IO Bool  -- ^ do we need to regenerate the output?-sourceModified dest_file src_timestamp = do-  dest_file_exists <- doesFileExist dest_file-  if not dest_file_exists-    then return True       -- Need to recompile-     else do t2 <- getModificationUTCTime dest_file-             return (t2 <= src_timestamp)---- | What phase to run after one of the backend code generators has run-hscPostBackendPhase :: HscSource -> HscTarget -> Phase-hscPostBackendPhase HsBootFile _    =  StopLn-hscPostBackendPhase HsigFile _      =  StopLn-hscPostBackendPhase _ hsc_lang =-  case hsc_lang of-        HscC           -> HCc-        HscAsm         -> As False-        HscLlvm        -> LlvmOpt-        HscNothing     -> StopLn-        HscInterpreted -> StopLn--touchObjectFile :: DynFlags -> FilePath -> IO ()-touchObjectFile dflags path = do-  createDirectoryIfMissing True $ takeDirectory path-  GHC.SysTools.touch dflags "Touching object file" path---- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> IO FilePath-getGhcVersionPathName dflags = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> (map (</> "ghcversion.h")) <$>-               (getUnitIncludePath dflags [rtsUnitId])+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+--+-- GHC Driver+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module GHC.Driver.Pipeline (+        -- Run a series of compilation steps in a pipeline, for a+        -- collection of source files.+   oneShot, compileFile,++        -- Interfaces for the compilation manager (interpreted/batch-mode)+   preprocess,+   compileOne, compileOne',+   link,++        -- Exports for hooks to override runPhase and link+   PhasePlus(..), CompPipeline(..), PipeEnv(..), PipeState(..),+   phaseOutputFilename, getOutputFilename, getPipeState, getPipeEnv,+   hscPostBackendPhase, getLocation, setModLocation, setDynFlags,+   runPhase,+   doCpp,+   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode+  ) where++#include <ghcplatform.h>+#include "HsVersions.h"++import GHC.Prelude++import GHC.Platform++import GHC.Tc.Types++import GHC.Driver.Main+import GHC.Driver.Env hiding ( Hsc )+import GHC.Driver.Errors+import GHC.Driver.Pipeline.Monad+import GHC.Driver.Config+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Hooks++import GHC.Platform.Ways+import GHC.Platform.ArchOS++import GHC.Parser.Header+import GHC.Parser.Errors.Ppr++import GHC.SysTools+import GHC.Utils.TmpFs++import GHC.Linker.ExtraObj+import GHC.Linker.Dynamic+import GHC.Linker.Static+import GHC.Linker.Types++import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Exception as Exception+import GHC.Utils.Logger++import GHC.CmmToLlvm         ( llvmFixupAsm, llvmVersionList )+import qualified GHC.LanguageExtensions as LangExt+import GHC.Settings++import GHC.Data.Bag            ( unitBag )+import GHC.Data.FastString     ( mkFastString )+import GHC.Data.StringBuffer   ( hGetStringBuffer, hPutStringBuffer )+import GHC.Data.Maybe          ( expectJust )++import GHC.Iface.Make          ( mkFullIface )+import GHC.Iface.UpdateIdInfos ( updateModDetailsIdInfos )++import GHC.Types.Basic       ( SuccessFlag(..) )+import GHC.Types.Target+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.SourceError++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph (needsTemplateHaskellOrQQ)+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo++import System.Directory+import System.FilePath+import System.IO+import Control.Monad+import qualified Control.Monad.Catch as MC (handle)+import Data.List        ( isInfixOf, intercalate )+import Data.Maybe+import Data.Version+import Data.Either      ( partitionEithers )++import Data.Time        ( UTCTime )++-- ---------------------------------------------------------------------------+-- Pre-process++-- | Just preprocess a file, put the result in a temp. file (used by the+-- compilation manager during the summary phase).+--+-- We return the augmented DynFlags, because they contain the result+-- of slurping in the OPTIONS pragmas++preprocess :: HscEnv+           -> FilePath -- ^ input filename+           -> Maybe InputFileBuffer+           -- ^ optional buffer to use instead of reading the input file+           -> Maybe Phase -- ^ starting phase+           -> IO (Either ErrorMessages (DynFlags, FilePath))+preprocess hsc_env input_fn mb_input_buf mb_phase =+  handleSourceError (\err -> return (Left (srcErrorMessages err))) $+  MC.handle handler $+  fmap Right $ do+  MASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)+  (dflags, fp, mb_iface) <- runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)+        Nothing+        -- We keep the processed file for the whole session to save on+        -- duplicated work in ghci.+        (Temporary TFL_GhcSession)+        Nothing{-no ModLocation-}+        []{-no foreign objects-}+  -- We stop before Hsc phase so we shouldn't generate an interface+  MASSERT(isNothing mb_iface)+  return (dflags, fp)+  where+    srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1+    handler (ProgramError msg) = return $ Left $ unitBag $+        mkPlainMsgEnvelope srcspan $ text msg+    handler ex = throwGhcExceptionIO ex++-- ---------------------------------------------------------------------------++-- | Compile+--+-- Compile a single module, under the control of the compilation manager.+--+-- This is the interface between the compilation manager and the+-- compiler proper (hsc), where we deal with tedious details like+-- reading the OPTIONS pragma from the source file, converting the+-- C or assembly that GHC produces into an object file, and compiling+-- FFI stub files.+--+-- NB.  No old interface can also mean that the source has changed.++compileOne :: HscEnv+           -> ModSummary      -- ^ summary for module being compiled+           -> Int             -- ^ module N ...+           -> Int             -- ^ ... of M+           -> Maybe ModIface  -- ^ old interface, if we have one+           -> Maybe Linkable  -- ^ old linkable, if we have one+           -> SourceModified+           -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful++compileOne = compileOne' Nothing (Just batchMsg)++compileOne' :: Maybe TcGblEnv+            -> Maybe Messager+            -> HscEnv+            -> ModSummary      -- ^ summary for module being compiled+            -> Int             -- ^ module N ...+            -> Int             -- ^ ... of M+            -> Maybe ModIface  -- ^ old interface, if we have one+            -> Maybe Linkable  -- ^ old linkable, if we have one+            -> SourceModified+            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful++compileOne' m_tc_result mHscMessage+            hsc_env0 summary mod_index nmods mb_old_iface mb_old_linkable+            source_modified0+ = do++   let logger = hsc_logger hsc_env0+   let tmpfs  = hsc_tmpfs hsc_env0+   debugTraceMsg logger dflags1 2 (text "compile: input file" <+> text input_fnpp)++   -- Run the pipeline up to codeGen (so everything up to, but not including, STG)+   (status, plugin_hsc_env) <- hscIncrementalCompile+                        always_do_basic_recompilation_check+                        m_tc_result mHscMessage+                        hsc_env summary source_modified mb_old_iface (mod_index, nmods)+   -- Use an HscEnv updated with the plugin info+   let hsc_env' = plugin_hsc_env++   let flags = hsc_dflags hsc_env0+     in do unless (gopt Opt_KeepHiFiles flags) $+               addFilesToClean tmpfs TFL_CurrentModule $+                   [ml_hi_file $ ms_location summary]+           unless (gopt Opt_KeepOFiles flags) $+               addFilesToClean tmpfs TFL_GhcSession $+                   [ml_obj_file $ ms_location summary]++   case (status, bcknd) of+        (HscUpToDate iface hmi_details, _) ->+            -- TODO recomp014 triggers this assert. What's going on?!+            -- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )+            return $! HomeModInfo iface hmi_details mb_old_linkable+        (HscNotGeneratingCode iface hmi_details, NoBackend) ->+            let mb_linkable = if isHsBootOrSig src_flavour+                                then Nothing+                                -- TODO: Questionable.+                                else Just (LM (ms_hs_date summary) this_mod [])+            in return $! HomeModInfo iface hmi_details mb_linkable+        (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"+        (_, NoBackend) -> panic "compileOne NoBackend"+        (HscUpdateBoot iface hmi_details, Interpreter) ->+            return $! HomeModInfo iface hmi_details Nothing+        (HscUpdateBoot iface hmi_details, _) -> do+            touchObjectFile logger dflags object_filename+            return $! HomeModInfo iface hmi_details Nothing+        (HscUpdateSig iface hmi_details, Interpreter) -> do+            let !linkable = LM (ms_hs_date summary) this_mod []+            return $! HomeModInfo iface hmi_details (Just linkable)+        (HscUpdateSig iface hmi_details, _) -> do+            output_fn <- getOutputFilename logger tmpfs next_phase+                            (Temporary TFL_CurrentModule) basename dflags+                            next_phase (Just location)++            -- #10660: Use the pipeline instead of calling+            -- compileEmptyStub directly, so -dynamic-too gets+            -- handled properly+            _ <- runPipeline StopLn hsc_env'+                              (output_fn,+                               Nothing,+                               Just (HscOut src_flavour+                                            mod_name (HscUpdateSig iface hmi_details)))+                              (Just basename)+                              Persistent+                              (Just location)+                              []+            o_time <- getModificationUTCTime object_filename+            let !linkable = LM o_time this_mod [DotO object_filename]+            return $! HomeModInfo iface hmi_details (Just linkable)+        (HscRecomp { hscs_guts = cgguts,+                     hscs_mod_location = mod_location,+                     hscs_mod_details = hmi_details,+                     hscs_partial_iface = partial_iface,+                     hscs_old_iface_hash = mb_old_iface_hash+                   }, Interpreter) -> do+            -- In interpreted mode the regular codeGen backend is not run so we+            -- generate a interface without codeGen info.+            final_iface <- mkFullIface hsc_env' partial_iface Nothing+            liftIO $ hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash (ms_location summary)++            (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env' cgguts mod_location++            stub_o <- case hasStub of+                      Nothing -> return []+                      Just stub_c -> do+                          stub_o <- compileStub hsc_env' stub_c+                          return [DotO stub_o]++            let hs_unlinked = [BCOs comp_bc spt_entries]+                unlinked_time = ms_hs_date summary+              -- Why do we use the timestamp of the source file here,+              -- rather than the current time?  This works better in+              -- the case where the local clock is out of sync+              -- with the filesystem's clock.  It's just as accurate:+              -- if the source is modified, then the linkable will+              -- be out of date.+            let !linkable = LM unlinked_time (ms_mod summary)+                           (hs_unlinked ++ stub_o)+            return $! HomeModInfo final_iface hmi_details (Just linkable)+        (HscRecomp{}, _) -> do+            output_fn <- getOutputFilename logger tmpfs next_phase+                            (Temporary TFL_CurrentModule)+                            basename dflags next_phase (Just location)+            -- We're in --make mode: finish the compilation pipeline.+            (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env'+                              (output_fn,+                               Nothing,+                               Just (HscOut src_flavour mod_name status))+                              (Just basename)+                              Persistent+                              (Just location)+                              []+                  -- The object filename comes from the ModLocation+            o_time <- getModificationUTCTime object_filename+            let !linkable = LM o_time this_mod [DotO object_filename]+            return $! HomeModInfo iface details (Just linkable)++ where dflags0     = ms_hspp_opts summary+       this_mod    = ms_mod summary+       location    = ms_location summary+       input_fn    = expectJust "compile:hs" (ml_hs_file location)+       input_fnpp  = ms_hspp_file summary+       mod_graph   = hsc_mod_graph hsc_env0+       needsLinker = needsTemplateHaskellOrQQ mod_graph+       isDynWay    = any (== WayDyn) (ways dflags0)+       isProfWay   = any (== WayProf) (ways dflags0)+       internalInterpreter = not (gopt Opt_ExternalInterpreter dflags0)++       src_flavour = ms_hsc_src summary+       mod_name = ms_mod_name summary+       next_phase = hscPostBackendPhase src_flavour bcknd+       object_filename = ml_obj_file location++       -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+       -- the linker can correctly load the object files.  This isn't necessary+       -- when using -fexternal-interpreter.+       dflags1 = if hostIsDynamic && internalInterpreter &&+                    not isDynWay && not isProfWay && needsLinker+                  then gopt_set dflags0 Opt_BuildDynamicToo+                  else dflags0++       -- #16331 - when no "internal interpreter" is available but we+       -- need to process some TemplateHaskell or QuasiQuotes, we automatically+       -- turn on -fexternal-interpreter.+       dflags2 = if not internalInterpreter && needsLinker+                 then gopt_set dflags1 Opt_ExternalInterpreter+                 else dflags1++       basename = dropExtension input_fn++       -- We add the directory in which the .hs files resides) to the import+       -- path.  This is needed when we try to compile the .hc file later, if it+       -- imports a _stub.h file that we created here.+       current_dir = takeDirectory basename+       old_paths   = includePaths dflags2+       loadAsByteCode+         | Just (Target _ obj _) <- findTarget summary (hsc_targets hsc_env0)+         , not obj+         = True+         | otherwise = False+       -- Figure out which backend we're using+       (bcknd, dflags3)+         -- #8042: When module was loaded with `*` prefix in ghci, but DynFlags+         -- suggest to generate object code (which may happen in case -fobject-code+         -- was set), force it to generate byte-code. This is NOT transitive and+         -- only applies to direct targets.+         | loadAsByteCode+         = (Interpreter, dflags2 { backend = Interpreter })+         | otherwise+         = (backend dflags, dflags2)+       dflags  = dflags3 { includePaths = addImplicitQuoteInclude old_paths [current_dir] }+       hsc_env = hsc_env0 {hsc_dflags = dflags}++       -- -fforce-recomp should also work with --make+       force_recomp = gopt Opt_ForceRecomp dflags+       source_modified+         -- #8042: Usually pre-compiled code is preferred to be loaded in ghci+         -- if available. So, if the "*" prefix was used, force recompilation+         -- to make sure byte-code is loaded.+         | force_recomp || loadAsByteCode = SourceModified+         | otherwise = source_modified0++       always_do_basic_recompilation_check = case bcknd of+                                             Interpreter -> True+                                             _ -> False++-----------------------------------------------------------------------------+-- stub .h and .c files (for foreign export support), and cc files.++-- The _stub.c file is derived from the haskell source file, possibly taking+-- into account the -stubdir option.+--+-- The object file created by compiling the _stub.c file is put into a+-- temporary file, which will be later combined with the main .o file+-- (see the MergeForeigns phase).+--+-- Moreover, we also let the user emit arbitrary C/C++/ObjC/ObjC++ files+-- from TH, that are then compiled and linked to the module. This is+-- useful to implement facilities such as inline-c.++compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath+compileForeign _ RawObject object_file = return object_file+compileForeign hsc_env lang stub_c = do+        let phase = case lang of+              LangC      -> Cc+              LangCxx    -> Ccxx+              LangObjc   -> Cobjc+              LangObjcxx -> Cobjcxx+              LangAsm    -> As True -- allow CPP+#if __GLASGOW_HASKELL__ < 811+              RawObject  -> panic "compileForeign: should be unreachable"+#endif+        (_, stub_o, _) <- runPipeline StopLn hsc_env+                       (stub_c, Nothing, Just (RealPhase phase))+                       Nothing (Temporary TFL_GhcSession)+                       Nothing{-no ModLocation-}+                       []+        return stub_o++compileStub :: HscEnv -> FilePath -> IO FilePath+compileStub hsc_env stub_c = compileForeign hsc_env LangC stub_c++compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()+compileEmptyStub dflags hsc_env basename location mod_name = do+  -- To maintain the invariant that every Haskell file+  -- compiles to object code, we make an empty (but+  -- valid) stub object file for signatures.  However,+  -- we make sure this object file has a unique symbol,+  -- so that ranlib on OS X doesn't complain, see+  -- https://gitlab.haskell.org/ghc/ghc/issues/12673+  -- and https://github.com/haskell/cabal/issues/2257+  let logger = hsc_logger hsc_env+  let tmpfs  = hsc_tmpfs hsc_env+  empty_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "c"+  let home_unit = hsc_home_unit hsc_env+      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"+  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))+  _ <- runPipeline StopLn hsc_env+                  (empty_stub, Nothing, Nothing)+                  (Just basename)+                  Persistent+                  (Just location)+                  []+  return ()++-- ---------------------------------------------------------------------------+-- 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+     -> Logger                  -- ^ Logger+     -> TmpFs+     -> Hooks+     -> DynFlags                -- ^ dynamic flags+     -> UnitEnv                 -- ^ unit environment+     -> Bool                    -- ^ attempt linking in batch mode?+     -> HomePackageTable        -- ^ what to link+     -> IO SuccessFlag++-- For the moment, in the batch linker, we don't bother to tell doLink+-- which packages to link -- it just tries all that are available.+-- batch_attempt_linking should only be *looked at* in batch mode.  It+-- should only be True if the upsweep was successful and someone+-- exports main, i.e., we have good reason to believe that linking+-- will succeed.++link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking hpt =+  case linkHook hooks of+      Nothing -> case ghcLink of+          NoLink        -> return Succeeded+          LinkBinary    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt+          LinkStaticLib -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt+          LinkDynLib    -> link' logger tmpfs dflags unit_env batch_attempt_linking hpt+          LinkInMemory+              | platformMisc_ghcWithInterpreter $ platformMisc dflags+              -> -- Not Linking...(demand linker will do the job)+                 return Succeeded+              | otherwise+              -> panicBadLink LinkInMemory+      Just h  -> h ghcLink dflags batch_attempt_linking hpt+++panicBadLink :: GhcLink -> a+panicBadLink other = panic ("link: GHC not built to link this way: " +++                            show other)++link' :: Logger+      -> TmpFs+      -> DynFlags                -- ^ dynamic flags+      -> UnitEnv                 -- ^ unit environment+      -> Bool                    -- ^ attempt linking in batch mode?+      -> HomePackageTable        -- ^ what to link+      -> IO SuccessFlag++link' logger tmpfs dflags unit_env batch_attempt_linking hpt+   | batch_attempt_linking+   = do+        let+            staticLink = case ghcLink dflags of+                          LinkStaticLib -> True+                          _ -> False++            home_mod_infos = eltsHpt hpt++            -- the packages we depend on+            pkg_deps  = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos++            -- the linkables to link+            linkables = map (expectJust "link".hm_linkable) home_mod_infos++        debugTraceMsg logger dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))++        -- check for the -no-link flag+        if isNoLink (ghcLink dflags)+          then do debugTraceMsg logger dflags 3 (text "link(batch): linking omitted (-c flag given).")+                  return Succeeded+          else do++        let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)+            obj_files = concatMap getOfiles linkables+            platform  = targetPlatform dflags+            exe_file  = exeFileName platform staticLink (outputFile dflags)++        linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps++        if not (gopt Opt_ForceRecomp dflags) && not linking_needed+           then do debugTraceMsg logger dflags 2 (text exe_file <+> text "is up to date, linking not required.")+                   return Succeeded+           else do++        compilationProgressMsg logger dflags (text "Linking " <> text exe_file <> text " ...")++        -- Don't showPass in Batch mode; doLink will do that for us.+        let link = case ghcLink dflags of+                LinkBinary    -> linkBinary logger tmpfs+                LinkStaticLib -> linkStaticLib logger+                LinkDynLib    -> linkDynLibCheck logger tmpfs+                other         -> panicBadLink other+        link dflags unit_env obj_files pkg_deps++        debugTraceMsg logger dflags 3 (text "link: done")++        -- linkBinary only returns if it succeeds+        return Succeeded++   | otherwise+   = do debugTraceMsg logger dflags 3 (text "link(batch): upsweep (partially) failed OR" $$+                                text "   Main.main not exported; not linking.")+        return Succeeded+++linkingNeeded :: Logger -> DynFlags -> UnitEnv -> Bool -> [Linkable] -> [UnitId] -> IO Bool+linkingNeeded logger dflags unit_env staticLink linkables pkg_deps = do+        -- if the modification time on the executable is later than the+        -- modification times on all of the objects and libraries, then omit+        -- linking (unless the -fforce-recomp flag was given).+  let platform   = ue_platform unit_env+      unit_state = ue_units unit_env+      exe_file   = exeFileName platform staticLink (outputFile dflags)+  e_exe_time <- tryIO $ getModificationUTCTime exe_file+  case e_exe_time of+    Left _  -> return True+    Right t -> do+        -- first check object files and extra_ld_inputs+        let extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]+        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs+        let (errs,extra_times) = partitionEithers e_extra_times+        let obj_times =  map linkableTime linkables ++ extra_times+        if not (null errs) || any (t <) obj_times+            then return True+            else do++        -- next, check libraries. XXX this only checks Haskell libraries,+        -- not extra_libraries or -l things from the command line.+        let pkg_hslibs  = [ (collectLibraryDirs (ways dflags) [c], lib)+                          | Just c <- map (lookupUnitId unit_state) pkg_deps,+                            lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ]++        pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs+        if any isNothing pkg_libfiles then return True else do+        e_lib_times <- mapM (tryIO . getModificationUTCTime)+                          (catMaybes pkg_libfiles)+        let (lib_errs,lib_times) = partitionEithers e_lib_times+        if not (null lib_errs) || any (t <) lib_times+           then return True+           else checkLinkInfo logger dflags unit_env pkg_deps exe_file++findHSLib :: Platform -> Ways -> [String] -> String -> IO (Maybe FilePath)+findHSLib platform ws dirs lib = do+  let batch_lib_file = if WayDyn `notElem` ws+                      then "lib" ++ lib <.> "a"+                      else platformSOName platform lib+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)+  case found of+    [] -> return Nothing+    (x:_) -> return (Just x)++-- -----------------------------------------------------------------------------+-- Compile files in one-shot mode.++oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()+oneShot hsc_env stop_phase srcs = do+  o_files <- mapM (compileFile hsc_env stop_phase) srcs+  doLink hsc_env stop_phase o_files++compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath+compileFile hsc_env stop_phase (src, mb_phase) = do+   exists <- doesFileExist src+   when (not exists) $+        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))++   let+        dflags    = hsc_dflags hsc_env+        mb_o_file = outputFile dflags+        ghc_link  = ghcLink dflags      -- Set by -c or -no-link++        -- When linking, the -o argument refers to the linker's output.+        -- otherwise, we use it as the name for the pipeline's output.+        output+         -- If we are doing -fno-code, then act as if the output is+         -- 'Temporary'. This stops GHC trying to copy files to their+         -- final location.+         | NoBackend <- backend dflags = Temporary TFL_CurrentModule+         | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent+                -- -o foo applies to linker+         | isJust mb_o_file = SpecificFile+                -- -o foo applies to the file we are compiling now+         | otherwise = Persistent++   ( _, out_file, _) <- runPipeline stop_phase hsc_env+                            (src, Nothing, fmap RealPhase mb_phase)+                            Nothing+                            output+                            Nothing{-no ModLocation-} []+   return out_file+++doLink :: HscEnv -> Phase -> [FilePath] -> IO ()+doLink hsc_env stop_phase o_files+  | not (isStopLn stop_phase)+  = return ()           -- We stopped before the linking phase++  | otherwise+  = let+        dflags   = hsc_dflags   hsc_env+        logger   = hsc_logger   hsc_env+        unit_env = hsc_unit_env hsc_env+        tmpfs    = hsc_tmpfs    hsc_env+    in case ghcLink dflags of+        NoLink        -> return ()+        LinkBinary    -> linkBinary         logger tmpfs dflags unit_env o_files []+        LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []+        LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []+        other         -> panicBadLink other+++-- ---------------------------------------------------------------------------++-- | Run a compilation pipeline, consisting of multiple phases.+--+-- This is the interface to the compilation pipeline, which runs+-- a series of compilation steps on a single source file, specifying+-- at which stage to stop.+--+-- The DynFlags can be modified by phases in the pipeline (eg. by+-- OPTIONS_GHC pragmas), and the changes affect later phases in the+-- pipeline.+runPipeline+  :: Phase                      -- ^ When to stop+  -> HscEnv                     -- ^ Compilation environment+  -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)+                                -- ^ Pipeline input file name, optional+                                -- buffer and maybe -x suffix+  -> Maybe FilePath             -- ^ original basename (if different from ^^^)+  -> PipelineOutput             -- ^ Output filename+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module+  -> [FilePath]                 -- ^ foreign objects+  -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+                                -- ^ (final flags, output filename, interface)+runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)+             mb_basename output maybe_loc foreign_os++    = do let+             dflags0 = hsc_dflags hsc_env0++             -- Decide where dump files should go based on the pipeline output+             dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }+             hsc_env = hsc_env0 {hsc_dflags = dflags}+             logger = hsc_logger hsc_env+             tmpfs  = hsc_tmpfs  hsc_env++             (input_basename, suffix) = splitExtension input_fn+             suffix' = drop 1 suffix -- strip off the .+             basename | Just b <- mb_basename = b+                      | otherwise             = input_basename++             -- If we were given a -x flag, then use that phase to start from+             start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase++             isHaskell (RealPhase (Unlit _)) = True+             isHaskell (RealPhase (Cpp   _)) = True+             isHaskell (RealPhase (HsPp  _)) = True+             isHaskell (RealPhase (Hsc   _)) = True+             isHaskell (HscOut {})           = True+             isHaskell _                     = False++             isHaskellishFile = isHaskell start_phase++             env = PipeEnv{ stop_phase,+                            src_filename = input_fn,+                            src_basename = basename,+                            src_suffix = suffix',+                            output_spec = output }++         when (isBackpackishSuffix suffix') $+           throwGhcExceptionIO (UsageError+                       ("use --backpack to process " ++ input_fn))++         -- We want to catch cases of "you can't get there from here" before+         -- we start the pipeline, because otherwise it will just run off the+         -- end.+         let happensBefore' = happensBefore (targetPlatform dflags)+         case start_phase of+             RealPhase start_phase' ->+                 -- See Note [Partial ordering on phases]+                 -- Not the same as: (stop_phase `happensBefore` start_phase')+                 when (not (start_phase' `happensBefore'` stop_phase ||+                            start_phase' `eqPhase` stop_phase)) $+                       throwGhcExceptionIO (UsageError+                                   ("cannot compile this file to desired target: "+                                      ++ input_fn))+             HscOut {} -> return ()++         -- Write input buffer to temp file if requested+         input_fn' <- case (start_phase, mb_input_buf) of+             (RealPhase real_start_phase, Just input_buf) -> do+                 let suffix = phaseInputExt real_start_phase+                 fn <- newTempName logger tmpfs dflags TFL_CurrentModule suffix+                 hdl <- openBinaryFile fn WriteMode+                 -- Add a LINE pragma so reported source locations will+                 -- mention the real input file, not this temp file.+                 hPutStrLn hdl $ "{-# LINE 1 \""++ input_fn ++ "\"#-}"+                 hPutStringBuffer hdl input_buf+                 hClose hdl+                 return fn+             (_, _) -> return input_fn++         debugTraceMsg logger dflags 4 (text "Running the pipeline")+         r <- runPipeline' start_phase hsc_env env input_fn'+                           maybe_loc foreign_os++         let dflags = hsc_dflags hsc_env+         when isHaskellishFile $+           dynamicTooState dflags >>= \case+               DT_Dont   -> return ()+               DT_Dyn    -> return ()+               DT_OK     -> return ()+               -- If we are compiling a Haskell module with -dynamic-too, we+               -- first try the "fast path": that is we compile the non-dynamic+               -- version and at the same time we check that interfaces depended+               -- on exist both for the non-dynamic AND the dynamic way. We also+               -- check that they have the same hash.+               --    If they don't, dynamicTooState is set to DT_Failed.+               --       See GHC.Iface.Load.checkBuildDynamicToo+               --    If they do, in the end we produce both the non-dynamic and+               --    dynamic outputs.+               --+               -- If this "fast path" failed, we execute the whole pipeline+               -- again, this time for the dynamic way *only*. To do that we+               -- just set the dynamicNow bit from the start to ensure that the+               -- dynamic DynFlags fields are used and we disable -dynamic-too+               -- (its state is already set to DT_Failed so it wouldn't do much+               -- anyway).+               DT_Failed+                   -- NB: Currently disabled on Windows (ref #7134, #8228, and #5987)+                   | OSMinGW32 <- platformOS (targetPlatform dflags) -> return ()+                   | otherwise -> do+                       debugTraceMsg logger dflags 4+                           (text "Running the full pipeline again for -dynamic-too")+                       let dflags0 = flip gopt_unset Opt_BuildDynamicToo+                                      $ setDynamicNow+                                      $ dflags+                       hsc_env' <- newHscEnv dflags0+                       (dbs,unit_state,home_unit,mconstants) <- initUnits logger dflags0 Nothing+                       dflags1 <- updatePlatformConstants dflags0 mconstants+                       let unit_env = UnitEnv+                             { ue_platform  = targetPlatform dflags1+                             , ue_namever   = ghcNameVersion dflags1+                             , ue_home_unit = home_unit+                             , ue_units     = unit_state+                             }+                       let hsc_env'' = hsc_env'+                            { hsc_dflags   = dflags1+                            , hsc_unit_env = unit_env+                            , hsc_unit_dbs = Just dbs+                            }+                       _ <- runPipeline' start_phase hsc_env'' env input_fn'+                                         maybe_loc foreign_os+                       return ()+         return r++runPipeline'+  :: PhasePlus                  -- ^ When to start+  -> HscEnv                     -- ^ Compilation environment+  -> PipeEnv+  -> FilePath                   -- ^ Input filename+  -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module+  -> [FilePath]                 -- ^ foreign objects, if we have one+  -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))+                                -- ^ (final flags, output filename, interface)+runPipeline' start_phase hsc_env env input_fn+             maybe_loc foreign_os+  = do+  -- Execute the pipeline...+  let state = PipeState{ hsc_env, maybe_loc, foreign_os = foreign_os, iface = Nothing }+  (pipe_state, fp) <- evalP (pipeLoop start_phase input_fn) env state+  return (pipeStateDynFlags pipe_state, fp, pipeStateModIface pipe_state)++-- ---------------------------------------------------------------------------+-- outer pipeline loop++-- | pipeLoop runs phases until we reach the stop phase+pipeLoop :: PhasePlus -> FilePath -> CompPipeline FilePath+pipeLoop phase input_fn = do+  env <- getPipeEnv+  dflags <- getDynFlags+  logger <- getLogger+  -- See Note [Partial ordering on phases]+  let happensBefore' = happensBefore (targetPlatform dflags)+      stopPhase = stop_phase env+  case phase of+   RealPhase realPhase | realPhase `eqPhase` stopPhase            -- All done+     -> -- Sometimes, a compilation phase doesn't actually generate any output+        -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this+        -- stage, but we wanted to keep the output, then we have to explicitly+        -- copy the file, remembering to prepend a {-# LINE #-} pragma so that+        -- further compilation stages can tell what the original filename was.+        case output_spec env of+        Temporary _ ->+            return input_fn+        output ->+            do pst <- getPipeState+               tmpfs <- hsc_tmpfs <$> getPipeSession+               final_fn <- liftIO $ getOutputFilename logger tmpfs+                                        stopPhase output (src_basename env)+                                        dflags stopPhase (maybe_loc pst)+               when (final_fn /= input_fn) $ do+                  let msg = ("Copying `" ++ input_fn ++"' to `" ++ final_fn ++ "'")+                      line_prag = Just ("{-# LINE 1 \"" ++ src_filename env ++ "\" #-}\n")+                  liftIO $ copyWithHeader logger dflags msg line_prag input_fn final_fn+               return final_fn+++     | not (realPhase `happensBefore'` stopPhase)+        -- Something has gone wrong.  We'll try to cover all the cases when+        -- this could happen, so if we reach here it is a panic.+        -- eg. it might happen if the -C flag is used on a source file that+        -- has {-# OPTIONS -fasm #-}.+     -> panic ("pipeLoop: at phase " ++ show realPhase +++           " but I wanted to stop at phase " ++ show stopPhase)++   _+     -> do liftIO $ debugTraceMsg logger dflags 4+                                  (text "Running phase" <+> ppr phase)++           case phase of+               HscOut {} -> do+                   -- Depending on the dynamic-too state, we first run the+                   -- backend to generate the non-dynamic objects and then+                   -- re-run it to generate the dynamic ones.+                   let noDynToo = do+                        (next_phase, output_fn) <- runHookedPhase phase input_fn+                        pipeLoop next_phase output_fn+                   let dynToo = do+                          -- we must run the non-dynamic way before the dynamic+                          -- one because there may be interfaces loaded only in+                          -- the backend (e.g., in CorePrep). See #19264+                          r <- noDynToo++                          -- we must check the dynamic-too state again, because+                          -- we may have failed to load a dynamic interface in+                          -- the backend.+                          dynamicTooState dflags >>= \case+                            DT_OK -> do+                                let dflags' = setDynamicNow dflags -- set "dynamicNow"+                                setDynFlags dflags'+                                (next_phase, output_fn) <- runHookedPhase phase input_fn+                                _ <- pipeLoop next_phase output_fn+                                -- TODO: we probably shouldn't ignore the result of+                                -- the dynamic compilation+                                setDynFlags dflags -- restore flags without "dynamicNow" set+                                return r+                            _ -> return r++                   dynamicTooState dflags >>= \case+                     DT_Dont   -> noDynToo+                     DT_Failed -> noDynToo+                     DT_OK     -> dynToo+                     DT_Dyn    -> noDynToo+                        -- it shouldn't be possible to be in this last case+                        -- here. It would mean that we executed the whole+                        -- pipeline with DynamicNow and Opt_BuildDynamicToo set.+                        --+                        -- When we restart the whole pipeline for -dynamic-too+                        -- we set DynamicNow but we unset Opt_BuildDynamicToo so+                        -- it's weird.+               _ -> do+                  (next_phase, output_fn) <- runHookedPhase phase input_fn+                  pipeLoop next_phase output_fn++runHookedPhase :: PhasePlus -> FilePath -> CompPipeline (PhasePlus, FilePath)+runHookedPhase pp input = do+  hooks <- hsc_hooks <$> getPipeSession+  case runPhaseHook hooks of+    Nothing -> runPhase pp input+    Just h  -> h pp input++-- -----------------------------------------------------------------------------+-- In each phase, we need to know into what filename to generate the+-- output.  All the logic about which filenames we generate output+-- into is embodied in the following function.++-- | Computes the next output filename after we run @next_phase@.+-- Like 'getOutputFilename', but it operates in the 'CompPipeline' monad+-- (which specifies all of the ambient information.)+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath+phaseOutputFilename next_phase = do+  PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv+  PipeState{maybe_loc,hsc_env} <- getPipeState+  dflags <- getDynFlags+  logger <- getLogger+  let tmpfs = hsc_tmpfs hsc_env+  liftIO $ getOutputFilename logger tmpfs stop_phase output_spec+                             src_basename dflags next_phase maybe_loc++-- | Computes the next output filename for something in the compilation+-- pipeline.  This is controlled by several variables:+--+--      1. 'Phase': the last phase to be run (e.g. 'stopPhase').  This+--         is used to tell if we're in the last phase or not, because+--         in that case flags like @-o@ may be important.+--      2. 'PipelineOutput': is this intended to be a 'Temporary' or+--         'Persistent' build output?  Temporary files just go in+--         a fresh temporary name.+--      3. 'String': what was the basename of the original input file?+--      4. 'DynFlags': the obvious thing+--      5. 'Phase': the phase we want to determine the output filename of.+--      6. @Maybe ModLocation@: the 'ModLocation' of the module we're+--         compiling; this can be used to override the default output+--         of an object file.  (TODO: do we actually need this?)+getOutputFilename+  :: Logger+  -> TmpFs+  -> Phase+  -> PipelineOutput+  -> String+  -> DynFlags+  -> Phase -- next phase+  -> Maybe ModLocation+  -> IO FilePath+getOutputFilename logger tmpfs stop_phase output basename dflags next_phase maybe_location+ | is_last_phase, Persistent   <- output = persistent_fn+ | is_last_phase, SpecificFile <- output = case outputFile dflags of+                                           Just f -> return f+                                           Nothing ->+                                               panic "SpecificFile: No filename"+ | keep_this_output                      = persistent_fn+ | Temporary lifetime <- output          = newTempName logger tmpfs dflags lifetime suffix+ | otherwise                             = newTempName logger tmpfs dflags TFL_CurrentModule+   suffix+    where+          hcsuf      = hcSuf dflags+          odir       = objectDir dflags+          osuf       = objectSuf dflags+          keep_hc    = gopt Opt_KeepHcFiles dflags+          keep_hscpp = gopt Opt_KeepHscppFiles dflags+          keep_s     = gopt Opt_KeepSFiles dflags+          keep_bc    = gopt Opt_KeepLlvmFiles dflags++          myPhaseInputExt HCc       = hcsuf+          myPhaseInputExt MergeForeign = osuf+          myPhaseInputExt StopLn    = osuf+          myPhaseInputExt other     = phaseInputExt other++          is_last_phase = next_phase `eqPhase` stop_phase++          -- sometimes, we keep output from intermediate stages+          keep_this_output =+               case next_phase of+                       As _    | keep_s     -> True+                       LlvmOpt | keep_bc    -> True+                       HCc     | keep_hc    -> True+                       HsPp _  | keep_hscpp -> True   -- See #10869+                       _other               -> False++          suffix = myPhaseInputExt next_phase++          -- persistent object files get put in odir+          persistent_fn+             | StopLn <- next_phase = return odir_persistent+             | otherwise            = return persistent++          persistent = basename <.> suffix++          odir_persistent+             | Just loc <- maybe_location = ml_obj_file loc+             | Just d <- odir = d </> persistent+             | otherwise      = persistent+++-- | LLVM Options. These are flags to be passed to opt and llc, to ensure+-- consistency we list them in pairs, so that they form groups.+llvmOptions :: DynFlags+            -> [(String, String)]  -- ^ pairs of (opt, llc) arguments+llvmOptions dflags =+       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]+    ++ [("-relocation-model=" ++ rmodel+        ,"-relocation-model=" ++ rmodel) | not (null rmodel)]+    ++ [("-stack-alignment=" ++ (show align)+        ,"-stack-alignment=" ++ (show align)) | align > 0 ]++    -- Additional llc flags+    ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)+                                 , not (any (isInfixOf "-mcpu") (getOpts dflags opt_lc)) ]+    ++ [("", "-mattr=" ++ attrs) | not (null attrs) ]+    ++ [("", "-target-abi=" ++ abi) | not (null abi) ]++  where target = platformMisc_llvmTarget $ platformMisc dflags+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)++        -- Relocation models+        rmodel | gopt Opt_PIC dflags        = "pic"+               | positionIndependent dflags = "pic"+               | WayDyn `elem` ways dflags  = "dynamic-no-pic"+               | otherwise                  = "static"++        platform = targetPlatform dflags++        align :: Int+        align = case platformArch platform of+                  ArchX86_64 | isAvxEnabled dflags -> 32+                  _                                -> 0++        attrs :: String+        attrs = intercalate "," $ mattr+              ++ ["+sse42"   | isSse4_2Enabled dflags   ]+              ++ ["+sse2"    | isSse2Enabled platform   ]+              ++ ["+sse"     | isSseEnabled platform    ]+              ++ ["+avx512f" | isAvx512fEnabled dflags  ]+              ++ ["+avx2"    | isAvx2Enabled dflags     ]+              ++ ["+avx"     | isAvxEnabled dflags      ]+              ++ ["+avx512cd"| isAvx512cdEnabled dflags ]+              ++ ["+avx512er"| isAvx512erEnabled dflags ]+              ++ ["+avx512pf"| isAvx512pfEnabled dflags ]+              ++ ["+bmi"     | isBmiEnabled dflags      ]+              ++ ["+bmi2"    | isBmi2Enabled dflags     ]++        abi :: String+        abi = case platformArch (targetPlatform dflags) of+                ArchRISCV64 -> "lp64d"+                _           -> ""++-- -----------------------------------------------------------------------------+-- | Each phase in the pipeline returns the next phase to execute, and the+-- name of the file in which the output was placed.+--+-- We must do things dynamically this way, because we often don't know+-- what the rest of the phases will be until part-way through the+-- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning+-- of a source file can change the latter stages of the pipeline from+-- taking the LLVM route to using the native code generator.+--+runPhase :: PhasePlus   -- ^ Run this phase+         -> FilePath    -- ^ name of the input file+         -> CompPipeline (PhasePlus,           -- next phase to run+                          FilePath)            -- output filename++        -- Invariant: the output filename always contains the output+        -- Interesting case: Hsc when there is no recompilation to do+        --                   Then the output filename is still a .o file+++-------------------------------------------------------------------------------+-- Unlit phase++runPhase (RealPhase (Unlit sf)) input_fn = do+    let+       -- escape the characters \, ", and ', but don't try to escape+       -- Unicode or anything else (so we don't use Util.charToC+       -- here).  If we get this wrong, then in+       -- GHC.HsToCore.Coverage.isGoodTickSrcSpan where we check that the filename in+       -- a SrcLoc is the same as the source filenaame, the two will+       -- look bogusly different. See test:+       -- libraries/hpc/tests/function/subdir/tough2.hs+       escape ('\\':cs) = '\\':'\\': escape cs+       escape ('\"':cs) = '\\':'\"': escape cs+       escape ('\'':cs) = '\\':'\'': escape cs+       escape (c:cs)    = c : escape cs+       escape []        = []++    output_fn <- phaseOutputFilename (Cpp sf)++    let flags = [ -- The -h option passes the file name for unlit to+                  -- put in a #line directive+                  GHC.SysTools.Option     "-h"+                  -- See Note [Don't normalise input filenames].+                , GHC.SysTools.Option $ escape input_fn+                , GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.FileOption "" output_fn+                ]++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ GHC.SysTools.runUnlit logger dflags flags++    return (RealPhase (Cpp sf), output_fn)++-------------------------------------------------------------------------------+-- Cpp phase : (a) gets OPTIONS out of file+--             (b) runs cpp if necessary++runPhase (RealPhase (Cpp sf)) input_fn+  = do+       dflags0 <- getDynFlags+       logger <- getLogger+       src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn+       (dflags1, unhandled_flags, warns)+           <- liftIO $ parseDynamicFilePragma dflags0 src_opts+       setDynFlags dflags1+       liftIO $ checkProcessArgsResult unhandled_flags++       if not (xopt LangExt.Cpp dflags1) then do+           -- we have to be careful to emit warnings only once.+           unless (gopt Opt_Pp dflags1) $+               liftIO $ handleFlagWarnings logger dflags1 warns++           -- no need to preprocess CPP, just pass input file along+           -- to the next phase of the pipeline.+           return (RealPhase (HsPp sf), input_fn)+        else do+            output_fn <- phaseOutputFilename (HsPp sf)+            hsc_env <- getPipeSession+            liftIO $ doCpp logger+                           (hsc_tmpfs hsc_env)+                           (hsc_dflags hsc_env)+                           (hsc_unit_env hsc_env)+                           True{-raw-}+                           input_fn output_fn+            -- re-read the pragmas now that we've preprocessed the file+            -- See #2464,#3457+            src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn+            (dflags2, unhandled_flags, warns)+                <- liftIO $ parseDynamicFilePragma dflags0 src_opts+            liftIO $ checkProcessArgsResult unhandled_flags+            unless (gopt Opt_Pp dflags2) $+                liftIO $ handleFlagWarnings logger dflags2 warns+            -- the HsPp pass below will emit warnings++            setDynFlags dflags2++            return (RealPhase (HsPp sf), output_fn)++-------------------------------------------------------------------------------+-- HsPp phase++runPhase (RealPhase (HsPp sf)) input_fn = do+    dflags <- getDynFlags+    logger <- getLogger+    if not (gopt Opt_Pp dflags) then+      -- no need to preprocess, just pass input file along+      -- to the next phase of the pipeline.+       return (RealPhase (Hsc sf), input_fn)+    else do+        PipeEnv{src_basename, src_suffix} <- getPipeEnv+        let orig_fn = src_basename <.> src_suffix+        output_fn <- phaseOutputFilename (Hsc sf)+        liftIO $ GHC.SysTools.runPp logger dflags+                       ( [ GHC.SysTools.Option     orig_fn+                         , GHC.SysTools.Option     input_fn+                         , GHC.SysTools.FileOption "" output_fn+                         ]+                       )++        -- re-read pragmas now that we've parsed the file (see #3674)+        src_opts <- liftIO $ getOptionsFromFile dflags output_fn+        (dflags1, unhandled_flags, warns)+            <- liftIO $ parseDynamicFilePragma dflags src_opts+        setDynFlags dflags1+        liftIO $ checkProcessArgsResult unhandled_flags+        liftIO $ handleFlagWarnings logger dflags1 warns++        return (RealPhase (Hsc sf), output_fn)++-----------------------------------------------------------------------------+-- Hsc phase++-- Compilation of a single module, in "legacy" mode (_not_ under+-- the direction of the compilation manager).+runPhase (RealPhase (Hsc src_flavour)) input_fn+ = do   -- normal Hsc mode, not mkdependHS+        dflags0 <- getDynFlags++        PipeEnv{ stop_phase=stop,+                 src_basename=basename,+                 src_suffix=suff } <- getPipeEnv++  -- we add the current directory (i.e. the directory in which+  -- the .hs files resides) to the include path, since this is+  -- what gcc does, and it's probably what you want.+        let current_dir = takeDirectory basename+            new_includes = addImplicitQuoteInclude paths [current_dir]+            paths = includePaths dflags0+            dflags = dflags0 { includePaths = new_includes }++        setDynFlags dflags++  -- gather the imports and module name+        (hspp_buf,mod_name,imps,src_imps) <- liftIO $ do+            buf <- hGetStringBuffer input_fn+            let imp_prelude = xopt LangExt.ImplicitPrelude dflags+                popts = initParserOpts dflags+            eimps <- getImports popts imp_prelude buf input_fn (basename <.> suff)+            case eimps of+              Left errs -> throwErrors (fmap pprError errs)+              Right (src_imps,imps,L _ mod_name) -> return+                  (Just buf, mod_name, imps, src_imps)++  -- Take -o into account if present+  -- Very like -ohi, but we must *only* do this if we aren't linking+  -- (If we're linking then the -o applies to the linked thing, not to+  -- the object file for one module.)+  -- Note the nasty duplication with the same computation in compileFile above+        location <- getLocation src_flavour mod_name++        let o_file = ml_obj_file location -- The real object file+            hi_file = ml_hi_file location+            hie_file = ml_hie_file location+            dest_file | writeInterfaceOnlyMode dflags+                            = hi_file+                      | otherwise+                            = o_file++  -- Figure out if the source has changed, for recompilation avoidance.+  --+  -- Setting source_unchanged to True means that M.o (or M.hie) seems+  -- to be up to date wrt M.hs; so no need to recompile unless imports have+  -- changed (which the compiler itself figures out).+  -- Setting source_unchanged to False tells the compiler that M.o is out of+  -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.+        src_timestamp <- liftIO $ getModificationUTCTime (basename <.> suff)++        source_unchanged <- liftIO $+          if not (isStopLn stop)+                -- SourceModified unconditionally if+                --      (a) recompilation checker is off, or+                --      (b) we aren't going all the way to .o file (e.g. ghc -S)+             then return SourceModified+                -- Otherwise look at file modification dates+             else do dest_file_mod <- sourceModified dest_file src_timestamp+                     hie_file_mod <- if gopt Opt_WriteHie dflags+                                        then sourceModified hie_file+                                                            src_timestamp+                                        else pure False+                     if dest_file_mod || hie_file_mod+                        then return SourceModified+                        else return SourceUnmodified++        PipeState{hsc_env=hsc_env'} <- getPipeState++  -- Tell the finder cache about this module+        mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location++  -- Make the ModSummary to hand to hscMain+        let+            mod_summary = ModSummary {  ms_mod       = mod,+                                        ms_hsc_src   = src_flavour,+                                        ms_hspp_file = input_fn,+                                        ms_hspp_opts = dflags,+                                        ms_hspp_buf  = hspp_buf,+                                        ms_location  = location,+                                        ms_hs_date   = src_timestamp,+                                        ms_obj_date  = Nothing,+                                        ms_parsed_mod   = Nothing,+                                        ms_iface_date   = Nothing,+                                        ms_hie_date     = Nothing,+                                        ms_textual_imps = imps,+                                        ms_srcimps      = src_imps }++  -- run the compiler!+        let msg hsc_env _ what _ = oneShotMsg hsc_env what+        (result, plugin_hsc_env) <-+          liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'+                            mod_summary source_unchanged Nothing (1,1)++        -- In the rest of the pipeline use the loaded plugins+        setPlugins (hsc_plugins        plugin_hsc_env)+                   (hsc_static_plugins plugin_hsc_env)+        -- "driver" plugins may have modified the DynFlags so we update them+        setDynFlags (hsc_dflags plugin_hsc_env)++        return (HscOut src_flavour mod_name result,+                panic "HscOut doesn't have an input filename")++runPhase (HscOut src_flavour mod_name result) _ = do+        dflags <- getDynFlags+        logger <- getLogger+        location <- getLocation src_flavour mod_name+        setModLocation location++        let o_file = ml_obj_file location -- The real object file+            next_phase = hscPostBackendPhase src_flavour (backend dflags)++        case result of+            HscNotGeneratingCode _ _ ->+                return (RealPhase StopLn,+                        panic "No output filename from Hsc when no-code")+            HscUpToDate _ _ ->+                do liftIO $ touchObjectFile logger dflags o_file+                   -- The .o file must have a later modification date+                   -- than the source file (else we wouldn't get Nothing)+                   -- but we touch it anyway, to keep 'make' happy (we think).+                   return (RealPhase StopLn, o_file)+            HscUpdateBoot _ _ ->+                do -- In the case of hs-boot files, generate a dummy .o-boot+                   -- stamp file for the benefit of Make+                   liftIO $ touchObjectFile logger dflags o_file+                   return (RealPhase StopLn, o_file)+            HscUpdateSig _ _ ->+                do -- We need to create a REAL but empty .o file+                   -- because we are going to attempt to put it in a library+                   PipeState{hsc_env=hsc_env'} <- getPipeState+                   let input_fn = expectJust "runPhase" (ml_hs_file location)+                       basename = dropExtension input_fn+                   liftIO $ compileEmptyStub dflags hsc_env' basename location mod_name+                   return (RealPhase StopLn, o_file)+            HscRecomp { hscs_guts = cgguts,+                        hscs_mod_location = mod_location,+                        hscs_mod_details = mod_details,+                        hscs_partial_iface = partial_iface,+                        hscs_old_iface_hash = mb_old_iface_hash+                      }+              -> do output_fn <- phaseOutputFilename next_phase++                    PipeState{hsc_env=hsc_env'} <- getPipeState++                    (outputFilename, mStub, foreign_files, cg_infos) <- liftIO $+                      hscGenHardCode hsc_env' cgguts mod_location output_fn++                    let dflags = hsc_dflags hsc_env'+                    final_iface <- liftIO (mkFullIface hsc_env' partial_iface (Just cg_infos))+                    let final_mod_details+                           | gopt Opt_OmitInterfacePragmas dflags+                           = mod_details+                           | otherwise = {-# SCC updateModDetailsIdInfos #-}+                                         updateModDetailsIdInfos cg_infos mod_details+                    setIface final_iface final_mod_details++                    -- See Note [Writing interface files]+                    liftIO $ hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location++                    stub_o <- liftIO (mapM (compileStub hsc_env') mStub)+                    foreign_os <- liftIO $+                      mapM (uncurry (compileForeign hsc_env')) foreign_files+                    setForeignOs (maybe [] return stub_o ++ foreign_os)++                    return (RealPhase next_phase, outputFilename)++-----------------------------------------------------------------------------+-- Cmm phase++runPhase (RealPhase CmmCpp) input_fn = do+       hsc_env <- getPipeSession+       logger <- getLogger+       output_fn <- phaseOutputFilename Cmm+       liftIO $ doCpp logger+                      (hsc_tmpfs hsc_env)+                      (hsc_dflags hsc_env)+                      (hsc_unit_env hsc_env)+                      False{-not raw-}+                      input_fn output_fn+       return (RealPhase Cmm, output_fn)++runPhase (RealPhase Cmm) input_fn = do+       hsc_env <- getPipeSession+       let dflags = hsc_dflags hsc_env+       let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)+       output_fn <- phaseOutputFilename next_phase+       PipeState{hsc_env} <- getPipeState+       mstub <- liftIO $ hscCompileCmmFile hsc_env input_fn output_fn+       stub_o <- liftIO (mapM (compileStub hsc_env) mstub)+       setForeignOs (maybeToList stub_o)+       return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- Cc phase++runPhase (RealPhase cc_phase) input_fn+   | any (cc_phase `eqPhase`) [Cc, Ccxx, HCc, Cobjc, Cobjcxx]+   = do+        hsc_env <- getPipeSession+        let dflags    = hsc_dflags hsc_env+        let unit_env  = hsc_unit_env hsc_env+        let home_unit = hsc_home_unit hsc_env+        let tmpfs     = hsc_tmpfs hsc_env+        let platform  = ue_platform unit_env+        let hcc       = cc_phase `eqPhase` HCc++        let cmdline_include_paths = includePaths dflags++        -- HC files have the dependent packages stamped into them+        pkgs <- if hcc then liftIO $ getHCFilePackages input_fn else return []++        -- add package include paths even if we're just compiling .c+        -- files; this is the Value Add(TM) that using ghc instead of+        -- gcc gives you :)+        ps <- liftIO $ mayThrowUnitErr (preloadUnitsInfo' unit_env pkgs)+        let pkg_include_dirs     = collectIncludeDirs ps+        let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+              (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+        let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+              (includePathsQuote cmdline_include_paths +++               includePathsQuoteImplicit cmdline_include_paths)+        let include_paths = include_paths_quote ++ include_paths_global++        -- pass -D or -optP to preprocessor when compiling foreign C files+        -- (#16737). Doing it in this way is simpler and also enable the C+        -- compiler to perform preprocessing and parsing in a single pass,+        -- but it may introduce inconsistency if a different pgm_P is specified.+        let more_preprocessor_opts = concat+              [ ["-Xpreprocessor", i]+              | not hcc+              , i <- getOpts dflags opt_P+              ]++        let gcc_extra_viac_flags = extraGccViaCFlags dflags+        let pic_c_flags = picCCOpts dflags++        let verbFlags = getVerbFlags dflags++        -- cc-options are not passed when compiling .hc files.  Our+        -- hc code doesn't not #include any header files anyway, so these+        -- options aren't necessary.+        let pkg_extra_cc_opts+                | hcc       = []+                | otherwise = collectExtraCcOpts ps++        let framework_paths+                | platformUsesFrameworks platform+                = let pkgFrameworkPaths     = collectFrameworksDirs ps+                      cmdlineFrameworkPaths = frameworkPaths dflags+                  in map ("-F"++) (cmdlineFrameworkPaths ++ pkgFrameworkPaths)+                | otherwise+                = []++        let cc_opt | optLevel dflags >= 2 = [ "-O2" ]+                   | optLevel dflags >= 1 = [ "-O" ]+                   | otherwise            = []++        -- Decide next phase+        let next_phase = As False+        output_fn <- phaseOutputFilename next_phase++        let+          more_hcc_opts =+                -- on x86 the floating point regs have greater precision+                -- than a double, which leads to unpredictable results.+                -- By default, we turn this off with -ffloat-store unless+                -- the user specified -fexcess-precision.+                (if platformArch platform == ArchX86 &&+                    not (gopt Opt_ExcessPrecision dflags)+                        then [ "-ffloat-store" ]+                        else []) ++++                -- gcc's -fstrict-aliasing allows two accesses to memory+                -- to be considered non-aliasing if they have different types.+                -- This interacts badly with the C code we generate, which is+                -- very weakly typed, being derived from C--.+                ["-fno-strict-aliasing"]++        ghcVersionH <- liftIO $ getGhcVersionPathName dflags unit_env++        logger <- getLogger+        liftIO $ GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (+                        [ GHC.SysTools.FileOption "" input_fn+                        , GHC.SysTools.Option "-o"+                        , GHC.SysTools.FileOption "" output_fn+                        ]+                       ++ map GHC.SysTools.Option (+                          pic_c_flags++                -- Stub files generated for foreign exports references the runIO_closure+                -- and runNonIO_closure symbols, which are defined in the base package.+                -- These symbols are imported into the stub.c file via RtsAPI.h, and the+                -- way we do the import depends on whether we're currently compiling+                -- the base package or not.+                       ++ (if platformOS platform == OSMinGW32 &&+                              isHomeUnitId home_unit baseUnitId+                                then [ "-DCOMPILING_BASE_PACKAGE" ]+                                else [])++        -- We only support SparcV9 and better because V8 lacks an atomic CAS+        -- instruction. Note that the user can still override this+        -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag+        -- regardless of the ordering.+        --+        -- This is a temporary hack. See #2872, commit+        -- 5bd3072ac30216a505151601884ac88bf404c9f2+                       ++ (if platformArch platform == ArchSPARC+                           then ["-mcpu=v9"]+                           else [])++                       -- GCC 4.6+ doesn't like -Wimplicit when compiling C++.+                       ++ (if (cc_phase /= Ccxx && cc_phase /= Cobjcxx)+                             then ["-Wimplicit"]+                             else [])++                       ++ (if hcc+                             then gcc_extra_viac_flags ++ more_hcc_opts+                             else [])+                       ++ verbFlags+                       ++ [ "-S" ]+                       ++ cc_opt+                       ++ [ "-include", ghcVersionH ]+                       ++ framework_paths+                       ++ include_paths+                       ++ more_preprocessor_opts+                       ++ pkg_extra_cc_opts+                       ))++        return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- As, SpitAs phase : Assembler++-- This is for calling the assembler on a regular assembly file+runPhase (RealPhase (As with_cpp)) input_fn+  = do+        hsc_env <- getPipeSession+        let dflags     = hsc_dflags   hsc_env+        let logger     = hsc_logger   hsc_env+        let unit_env   = hsc_unit_env hsc_env+        let platform   = ue_platform unit_env++        -- LLVM from version 3.0 onwards doesn't support the OS X system+        -- assembler, so we use clang as the assembler instead. (#5636)+        let as_prog | backend dflags == LLVM+                    , platformOS platform == OSDarwin+                    = GHC.SysTools.runClang+                    | otherwise+                    = GHC.SysTools.runAs++        let cmdline_include_paths = includePaths dflags+        let pic_c_flags = picCCOpts dflags++        next_phase <- maybeMergeForeign+        output_fn <- phaseOutputFilename next_phase++        -- we create directories for the object file, because it+        -- might be a hierarchical module.+        liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)++        ccInfo <- liftIO $ getCompilerInfo logger dflags+        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)+                              | p <- includePathsGlobal cmdline_include_paths ]+        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)+                             | p <- includePathsQuote cmdline_include_paths +++                                includePathsQuoteImplicit cmdline_include_paths]+        let runAssembler inputFilename outputFilename+              = liftIO $+                  withAtomicRename outputFilename $ \temp_outputFilename ->+                    as_prog+                       logger dflags+                       (local_includes ++ global_includes+                       -- See Note [-fPIC for assembler]+                       ++ map GHC.SysTools.Option pic_c_flags+                       -- See Note [Produce big objects on Windows]+                       ++ [ GHC.SysTools.Option "-Wa,-mbig-obj"+                          | platformOS (targetPlatform dflags) == OSMinGW32+                          , not $ target32Bit (targetPlatform dflags)+                          ]++        -- We only support SparcV9 and better because V8 lacks an atomic CAS+        -- instruction so we have to make sure that the assembler accepts the+        -- instruction set. Note that the user can still override this+        -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag+        -- regardless of the ordering.+        --+        -- This is a temporary hack.+                       ++ (if platformArch (targetPlatform dflags) == ArchSPARC+                           then [GHC.SysTools.Option "-mcpu=v9"]+                           else [])+                       ++ (if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                            then [GHC.SysTools.Option "-Qunused-arguments"]+                            else [])+                       ++ [ GHC.SysTools.Option "-x"+                          , if with_cpp+                              then GHC.SysTools.Option "assembler-with-cpp"+                              else GHC.SysTools.Option "assembler"+                          , GHC.SysTools.Option "-c"+                          , GHC.SysTools.FileOption "" inputFilename+                          , GHC.SysTools.Option "-o"+                          , GHC.SysTools.FileOption "" temp_outputFilename+                          ])++        liftIO $ debugTraceMsg logger dflags 4 (text "Running the assembler")+        runAssembler input_fn output_fn++        return (RealPhase next_phase, output_fn)+++-----------------------------------------------------------------------------+-- LlvmOpt phase+runPhase (RealPhase LlvmOpt) input_fn = do+    dflags <- getDynFlags+    logger <- getLogger+    let -- we always (unless -optlo specified) run Opt since we rely on it to+        -- fix up some pretty big deficiencies in the code we generate+        optIdx = max 0 $ min 2 $ optLevel dflags  -- ensure we're in [0,2]+        llvmOpts = case lookup optIdx $ llvmPasses $ llvmConfig dflags of+                    Just passes -> passes+                    Nothing -> panic ("runPhase LlvmOpt: llvm-passes file "+                                      ++ "is missing passes for level "+                                      ++ show optIdx)+        defaultOptions = map GHC.SysTools.Option . concat . fmap words . fst+                         $ unzip (llvmOptions dflags)++        -- don't specify anything if user has specified commands. We do this+        -- for opt but not llc since opt is very specifically for optimisation+        -- passes only, so if the user is passing us extra options we assume+        -- they know what they are doing and don't get in the way.+        optFlag = if null (getOpts dflags opt_lo)+                  then map GHC.SysTools.Option $ words llvmOpts+                  else []++    output_fn <- phaseOutputFilename LlvmLlc++    liftIO $ GHC.SysTools.runLlvmOpt logger dflags+               (   optFlag+                ++ defaultOptions +++                [ GHC.SysTools.FileOption "" input_fn+                , GHC.SysTools.Option "-o"+                , GHC.SysTools.FileOption "" output_fn]+                )++    return (RealPhase LlvmLlc, output_fn)+++-----------------------------------------------------------------------------+-- LlvmLlc phase++runPhase (RealPhase LlvmLlc) input_fn = do+    -- Note [Clamping of llc optimizations]+    --+    -- See #13724+    --+    -- we clamp the llc optimization between [1,2]. This is because passing -O0+    -- to llc 3.9 or llc 4.0, the naive register allocator can fail with+    --+    --   Error while trying to spill R1 from class GPR: Cannot scavenge register+    --   without an emergency spill slot!+    --+    -- Observed at least with target 'arm-unknown-linux-gnueabihf'.+    --+    --+    -- With LLVM4, llc -O3 crashes when ghc-stage1 tries to compile+    --   rts/HeapStackCheck.cmm+    --+    -- llc -O3 '-mtriple=arm-unknown-linux-gnueabihf' -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s+    -- 0  llc                      0x0000000102ae63e8 llvm::sys::PrintStackTrace(llvm::raw_ostream&) + 40+    -- 1  llc                      0x0000000102ae69a6 SignalHandler(int) + 358+    -- 2  libsystem_platform.dylib 0x00007fffc23f4b3a _sigtramp + 26+    -- 3  libsystem_c.dylib        0x00007fffc226498b __vfprintf + 17876+    -- 4  llc                      0x00000001029d5123 llvm::SelectionDAGISel::LowerArguments(llvm::Function const&) + 5699+    -- 5  llc                      0x0000000102a21a35 llvm::SelectionDAGISel::SelectAllBasicBlocks(llvm::Function const&) + 3381+    -- 6  llc                      0x0000000102a202b1 llvm::SelectionDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 1457+    -- 7  llc                      0x0000000101bdc474 (anonymous namespace)::ARMDAGToDAGISel::runOnMachineFunction(llvm::MachineFunction&) + 20+    -- 8  llc                      0x00000001025573a6 llvm::MachineFunctionPass::runOnFunction(llvm::Function&) + 134+    -- 9  llc                      0x000000010274fb12 llvm::FPPassManager::runOnFunction(llvm::Function&) + 498+    -- 10 llc                      0x000000010274fd23 llvm::FPPassManager::runOnModule(llvm::Module&) + 67+    -- 11 llc                      0x00000001027501b8 llvm::legacy::PassManagerImpl::run(llvm::Module&) + 920+    -- 12 llc                      0x000000010195f075 compileModule(char**, llvm::LLVMContext&) + 12133+    -- 13 llc                      0x000000010195bf0b main + 491+    -- 14 libdyld.dylib            0x00007fffc21e5235 start + 1+    -- Stack dump:+    -- 0.  Program arguments: llc -O3 -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc -o /var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_7.lm_s+    -- 1.  Running pass 'Function Pass Manager' on module '/var/folders/fv/xqjrpfj516n5xq_m_ljpsjx00000gn/T/ghc33674_0/ghc_6.bc'.+    -- 2.  Running pass 'ARM Instruction Selection' on function '@"stg_gc_f1$def"'+    --+    -- Observed at least with -mtriple=arm-unknown-linux-gnueabihf -enable-tbaa+    --+    dflags <- getDynFlags+    logger <- getLogger+    let+        llvmOpts = case optLevel dflags of+          0 -> "-O1" -- required to get the non-naive reg allocator. Passing -regalloc=greedy is not sufficient.+          1 -> "-O1"+          _ -> "-O2"++        defaultOptions = map GHC.SysTools.Option . concatMap words . snd+                         $ unzip (llvmOptions dflags)+        optFlag = if null (getOpts dflags opt_lc)+                  then map GHC.SysTools.Option $ words llvmOpts+                  else []++    next_phase <- if -- hidden debugging flag '-dno-llvm-mangler' to skip mangling+                     | gopt Opt_NoLlvmMangler dflags -> return (As False)+                     | otherwise -> return LlvmMangle++    output_fn <- phaseOutputFilename next_phase++    liftIO $ GHC.SysTools.runLlvmLlc logger dflags+                (  optFlag+                ++ defaultOptions+                ++ [ GHC.SysTools.FileOption "" input_fn+                   , GHC.SysTools.Option "-o"+                   , GHC.SysTools.FileOption "" output_fn+                   ]+                )++    return (RealPhase next_phase, output_fn)++++-----------------------------------------------------------------------------+-- LlvmMangle phase++runPhase (RealPhase LlvmMangle) input_fn = do+      let next_phase = As False+      output_fn <- phaseOutputFilename next_phase+      dflags <- getDynFlags+      logger <- getLogger+      liftIO $ llvmFixupAsm logger dflags input_fn output_fn+      return (RealPhase next_phase, output_fn)++-----------------------------------------------------------------------------+-- merge in stub objects++runPhase (RealPhase MergeForeign) input_fn = do+     PipeState{foreign_os,hsc_env} <- getPipeState+     output_fn <- phaseOutputFilename StopLn+     liftIO $ createDirectoryIfMissing True (takeDirectory output_fn)+     if null foreign_os+       then panic "runPhase(MergeForeign): no foreign objects"+       else do+         dflags <- getDynFlags+         logger <- getLogger+         let tmpfs = hsc_tmpfs hsc_env+         liftIO $ joinObjectFiles logger tmpfs dflags (input_fn : foreign_os) output_fn+         return (RealPhase StopLn, output_fn)++-- warning suppression+runPhase (RealPhase other) _input_fn =+   panic ("runPhase: don't know how to run phase " ++ show other)++maybeMergeForeign :: CompPipeline Phase+maybeMergeForeign+ = do+     PipeState{foreign_os} <- getPipeState+     if null foreign_os then return StopLn else return MergeForeign++getLocation :: HscSource -> ModuleName -> CompPipeline ModLocation+getLocation src_flavour mod_name = do+    dflags <- getDynFlags++    PipeEnv{ src_basename=basename,+             src_suffix=suff } <- getPipeEnv+    PipeState { maybe_loc=maybe_loc} <- getPipeState+    case maybe_loc of+        -- Build a ModLocation to pass to hscMain.+        -- The source filename is rather irrelevant by now, but it's used+        -- by hscMain for messages.  hscMain also needs+        -- the .hi and .o filenames. If we already have a ModLocation+        -- then simply update the extensions of the interface and object+        -- files to match the DynFlags, otherwise use the logic in Finder.+      Just l -> return $ l+        { ml_hs_file = Just $ basename <.> suff+        , ml_hi_file = ml_hi_file l -<.> hiSuf dflags+        , ml_obj_file = ml_obj_file l -<.> objectSuf dflags+        }+      _ -> do+        location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff++        -- Boot-ify it if necessary+        let location2+              | HsBootFile <- src_flavour = addBootSuffixLocnOut location1+              | otherwise                 = location1+++        -- Take -ohi into account if present+        -- This can't be done in mkHomeModuleLocation because+        -- it only applies to the module being compiles+        let ohi = outputHi dflags+            location3 | Just fn <- ohi = location2{ ml_hi_file = fn }+                      | otherwise      = location2++        -- Take -o into account if present+        -- Very like -ohi, but we must *only* do this if we aren't linking+        -- (If we're linking then the -o applies to the linked thing, not to+        -- the object file for one module.)+        -- Note the nasty duplication with the same computation in compileFile+        -- above+        let expl_o_file = outputFile dflags+            location4 | Just ofile <- expl_o_file+                      , isNoLink (ghcLink dflags)+                      = location3 { ml_obj_file = ofile }+                      | otherwise = location3+        return location4++-----------------------------------------------------------------------------+-- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file++getHCFilePackages :: FilePath -> IO [UnitId]+getHCFilePackages filename =+  Exception.bracket (openFile filename ReadMode) hClose $ \h -> do+    l <- hGetLine h+    case l of+      '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->+          return (map stringToUnitId (words rest))+      _other ->+          return []+++linkDynLibCheck :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()+linkDynLibCheck logger tmpfs dflags unit_env o_files dep_units = do+  when (haveRtsOptsFlags dflags) $+    putLogMsg logger dflags NoReason SevInfo noSrcSpan+      $ withPprStyle defaultUserStyle+      (text "Warning: -rtsopts and -with-rtsopts have no effect with -shared." $$+      text "    Call hs_init_ghc() from your main() function to set these options.")+  linkDynLib logger tmpfs dflags unit_env o_files dep_units+++-- -----------------------------------------------------------------------------+-- Running CPP++-- | Run CPP+--+-- UnitState is needed to compute MIN_VERSION macros+doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()+doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = includePaths dflags+    let unit_state = ue_units unit_env+    pkg_include_dirs <- mayThrowUnitErr+                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)+    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs)+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+          (includePathsQuote cmdline_include_paths +++           includePathsQuoteImplicit cmdline_include_paths)+    let include_paths = include_paths_quote ++ include_paths_global++    let verbFlags = getVerbFlags dflags++    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args+                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags+                                        (GHC.SysTools.Option "-E" : args)++    let platform   = targetPlatform dflags+        targetArch = stringEncodeArch $ platformArch platform+        targetOS = stringEncodeOS $ platformOS platform+        isWindows = platformOS platform == OSMinGW32+    let target_defs =+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",+            "-D" ++ targetOS    ++ "_HOST_OS",+            "-D" ++ targetArch  ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let io_manager_defs =+          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] +++          [ "-D__IO_MANAGER_MIO__=1"               ]++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      platform ] +++          [ "-D__SSE2__"     | isSse2Enabled     platform ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs logger dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags unit_env+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitUnits unit_state+        pkgs = catMaybes (map (lookupUnit unit_state) uids)+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName logger tmpfs dflags TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [GHC.SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map GHC.SysTools.Option verbFlags+                    ++ map GHC.SysTools.Option include_paths+                    ++ map GHC.SysTools.Option hsSourceCppOpts+                    ++ map GHC.SysTools.Option target_defs+                    ++ map GHC.SysTools.Option backend_defs+                    ++ map GHC.SysTools.Option th_defs+                    ++ map GHC.SysTools.Option hscpp_opts+                    ++ map GHC.SysTools.Option sse_defs+                    ++ map GHC.SysTools.Option avx_defs+                    ++ map GHC.SysTools.Option io_manager_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ GHC.SysTools.Option     "-x"+                       , GHC.SysTools.Option     "assembler-with-cpp"+                       , GHC.SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , GHC.SysTools.Option     "-o"+                       , GHC.SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: Logger -> DynFlags -> IO [String]+getBackendDefs logger dflags | backend dflags == LLVM = do+    llvmVer <- figureLlvmVersion logger dflags+    return $ case fmap llvmVersionList llvmVer of+               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]+               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+               _ -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ _ =+    return []++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [UnitInfo] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = unitPackageVersion pkg+        pkgname = map fixchar (unitPackageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)++-- ---------------------------------------------------------------------------+-- join object files into a single relocatable object file, using ld -r++{-+Note [Produce big objects on Windows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The Windows Portable Executable object format has a limit of 32k sections, which+we tend to blow through pretty easily. Thankfully, there is a "big object"+extension, which raises this limit to 2^32. However, it must be explicitly+enabled in the toolchain:++ * the assembler accepts the -mbig-obj flag, which causes it to produce a+   bigobj-enabled COFF object.++ * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name+   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a+   PE executable.++We must enable bigobj output in a few places:++ * When merging object files (GHC.Driver.Pipeline.joinObjectFiles)++ * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...))++Unfortunately the big object format is not supported on 32-bit targets so+none of this can be used in that case.+++Note [Merging object files for GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHCi can usually loads standard linkable object files using GHC's linker+implementation. However, most users build their projects with -split-sections,+meaning that such object files can have an extremely high number of sections.+As the linker must map each of these sections individually, loading such object+files is very inefficient.++To avoid this inefficiency, we use the linker's `-r` flag and a linker script+to produce a merged relocatable object file. This file will contain a singe+text section section and can consequently be mapped far more efficiently. As+gcc tends to do unpredictable things to our linker command line, we opt to+invoke ld directly in this case, in contrast to our usual strategy of linking+via gcc.++-}++joinObjectFiles :: Logger -> TmpFs -> DynFlags -> [FilePath] -> FilePath -> IO ()+joinObjectFiles logger tmpfs dflags o_files output_fn = do+  let toolSettings' = toolSettings dflags+      ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'+      osInfo = platformOS (targetPlatform dflags)+      ld_r args = GHC.SysTools.runMergeObjects logger tmpfs dflags (+                        -- See Note [Produce big objects on Windows]+                        concat+                          [ [GHC.SysTools.Option "--oformat", GHC.SysTools.Option "pe-bigobj-x86-64"]+                          | OSMinGW32 == osInfo+                          , not $ target32Bit (targetPlatform dflags)+                          ]+                     ++ map GHC.SysTools.Option ld_build_id+                     ++ [ GHC.SysTools.Option "-o",+                          GHC.SysTools.FileOption "" output_fn ]+                     ++ args)++      -- suppress the generation of the .note.gnu.build-id section,+      -- which we don't need and sometimes causes ld to emit a+      -- warning:+      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]+                  | otherwise                     = []++  if ldIsGnuLd+     then do+          script <- newTempName logger tmpfs dflags TFL_CurrentModule "ldscript"+          cwd <- getCurrentDirectory+          let o_files_abs = map (\x -> "\"" ++ (cwd </> x) ++ "\"") o_files+          writeFile script $ "INPUT(" ++ unwords o_files_abs ++ ")"+          ld_r [GHC.SysTools.FileOption "" script]+     else if toolSettings_ldSupportsFilelist toolSettings'+     then do+          filelist <- newTempName logger tmpfs dflags TFL_CurrentModule "filelist"+          writeFile filelist $ unlines o_files+          ld_r [GHC.SysTools.Option "-filelist",+                GHC.SysTools.FileOption "" filelist]+     else+          ld_r (map (GHC.SysTools.FileOption "") o_files)++-- -----------------------------------------------------------------------------+-- Misc.++writeInterfaceOnlyMode :: DynFlags -> Bool+writeInterfaceOnlyMode dflags =+ gopt Opt_WriteInterface dflags &&+ NoBackend == backend dflags++-- | Figure out if a source file was modified after an output file (or if we+-- anyways need to consider the source file modified since the output is gone).+sourceModified :: FilePath -- ^ destination file we are looking for+               -> UTCTime  -- ^ last time of modification of source file+               -> IO Bool  -- ^ do we need to regenerate the output?+sourceModified dest_file src_timestamp = do+  dest_file_exists <- doesFileExist dest_file+  if not dest_file_exists+    then return True       -- Need to recompile+     else do t2 <- getModificationUTCTime dest_file+             return (t2 <= src_timestamp)++-- | What phase to run after one of the backend code generators has run+hscPostBackendPhase :: HscSource -> Backend -> Phase+hscPostBackendPhase HsBootFile _    =  StopLn+hscPostBackendPhase HsigFile _      =  StopLn+hscPostBackendPhase _ bcknd =+  case bcknd of+        ViaC        -> HCc+        NCG         -> As False+        LLVM        -> LlvmOpt+        NoBackend   -> StopLn+        Interpreter -> StopLn++touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()+touchObjectFile logger dflags path = do+  createDirectoryIfMissing True $ takeDirectory path+  GHC.SysTools.touch logger dflags "Touching object file" path++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath+getGhcVersionPathName dflags unit_env = do+  candidates <- case ghcVersionFile dflags of+    Just path -> return [path]+    Nothing -> do+        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])+        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)    found <- filterM doesFileExist candidates   case found of

GHC/Driver/Pipeline/Monad.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE NamedFieldPuns #-} -- | The CompPipeline monad and associated ops -- -- Defined in separate module so that it can safely be imported from Hooks@@ -7,19 +6,30 @@     CompPipeline(..), evalP   , PhasePlus(..)   , PipeEnv(..), PipeState(..), PipelineOutput(..)-  , getPipeEnv, getPipeState, setDynFlags, setModLocation, setForeignOs, setIface-  , pipeStateDynFlags, pipeStateModIface+  , getPipeEnv, getPipeState, getPipeSession+  , setDynFlags, setModLocation, setForeignOs, setIface+  , pipeStateDynFlags, pipeStateModIface, setPlugins   ) where  import GHC.Prelude  import GHC.Utils.Monad import GHC.Utils.Outputable+import GHC.Utils.Logger+ import GHC.Driver.Session import GHC.Driver.Phases-import GHC.Driver.Types+import GHC.Driver.Env+import GHC.Driver.Plugins++import GHC.Utils.TmpFs (TempFileLifetime)++import GHC.Types.SourceFile+ import GHC.Unit.Module-import GHC.SysTools.FileCleanup (TempFileLifetime)+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Status  import Control.Monad @@ -62,9 +72,9 @@ -- PipeState: information that might change during a pipeline run data PipeState = PipeState {        hsc_env   :: HscEnv,-          -- ^ only the DynFlags change in the HscEnv.  The DynFlags change-          -- at various points, for example when we read the OPTIONS_GHC-          -- pragmas in the Cpp phase.+          -- ^ only the DynFlags and the Plugins change in the HscEnv.  The+          -- DynFlags change at various points, for example when we read the+          -- OPTIONS_GHC pragmas in the Cpp phase.        maybe_loc :: Maybe ModLocation,           -- ^ the ModLocation.  This is discovered during compilation,           -- in the Hsc phase where we read the module header.@@ -72,7 +82,7 @@          -- ^ additional object files resulting from compiling foreign          -- code. They come from two sources: foreign stubs, and          -- add{C,Cxx,Objc,Objcxx}File from template haskell-       iface :: Maybe ModIface+       iface :: Maybe (ModIface, ModDetails)          -- ^ Interface generated by HscOut phase. Only available after the          -- phase runs.   }@@ -80,7 +90,7 @@ pipeStateDynFlags :: PipeState -> DynFlags pipeStateDynFlags = hsc_dflags . hsc_env -pipeStateModIface :: PipeState -> Maybe ModIface+pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails) pipeStateModIface = iface  data PipelineOutput@@ -103,13 +113,24 @@ getPipeState :: CompPipeline PipeState getPipeState = P $ \_env state -> return (state, state) +getPipeSession :: CompPipeline HscEnv+getPipeSession = P $ \_env state -> return (state, hsc_env state)+ instance HasDynFlags CompPipeline where     getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) +instance HasLogger CompPipeline where+    getLogger = P $ \_env state -> return (state, hsc_logger (hsc_env state))+ setDynFlags :: DynFlags -> CompPipeline () setDynFlags dflags = P $ \_env state ->   return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) +setPlugins :: [LoadedPlugin] -> [StaticPlugin] -> CompPipeline ()+setPlugins dyn static = P $ \_env state ->+  let hsc_env' = (hsc_env state){ hsc_plugins = dyn, hsc_static_plugins = static }+  in return (state{hsc_env = hsc_env'}, ())+ setModLocation :: ModLocation -> CompPipeline () setModLocation loc = P $ \_env state ->   return (state{ maybe_loc = Just loc }, ())@@ -118,5 +139,5 @@ setForeignOs os = P $ \_env state ->   return (state{ foreign_os = os }, ()) -setIface :: ModIface -> CompPipeline ()-setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ())+setIface :: ModIface -> ModDetails -> CompPipeline ()+setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ())

GHC/Driver/Plugins.hs view

@@ -49,20 +49,25 @@  import GHC.Prelude -import GHC.Core.Opt.Monad ( CoreToDo, CoreM )+import GHC.Driver.Env+import GHC.Driver.Monad+import GHC.Driver.Phases++import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+ import qualified GHC.Tc.Types import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports  ) import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )++import GHC.Core.Opt.Monad ( CoreToDo, CoreM ) import GHC.Hs-import GHC.Driver.Session-import GHC.Driver.Types-import GHC.Driver.Monad-import GHC.Driver.Phases-import GHC.Unit.Module import GHC.Utils.Fingerprint-import Data.List (sort) import GHC.Utils.Outputable (Outputable(..), text, (<+>)) +import Data.List (sort)+ --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<> import qualified Data.Semigroup@@ -92,13 +97,14 @@   , holeFitPlugin :: HoleFitPlugin     -- ^ An optional plugin to handle hole fits, which may re-order     --   or change the list of valid hole fits and refinement hole fits.-  , dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags-    -- ^ An optional plugin to update 'DynFlags', right after-    --   plugin loading. This can be used to register hooks-    --   or tweak any field of 'DynFlags' before doing-    --   actual work on a module.++  , driverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv+    -- ^ An optional plugin to update 'HscEnv', right after plugin loading. This+    -- can be used to register hooks or tweak any field of 'DynFlags' before+    -- doing actual work on a module.     --     --   @since 8.10.1+   , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile     -- ^ Specify how the plugin should affect recompilation.   , parsedResultAction :: [CommandLineOption] -> ModSummary -> HsParsedModule@@ -208,7 +214,7 @@         installCoreToDos      = const return       , tcPlugin              = const Nothing       , holeFitPlugin         = const Nothing-      , dynflagsPlugin        = const return+      , driverPlugin          = const return       , pluginRecompile       = impurePlugin       , renamedResultAction   = \_ env grp -> return (env, grp)       , parsedResultAction    = \_ _ -> return@@ -236,25 +242,25 @@ type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m () -plugins :: DynFlags -> [PluginWithArgs]-plugins df =-  map lpPlugin (cachedPlugins df) ++-  map spPlugin (staticPlugins df)+plugins :: HscEnv -> [PluginWithArgs]+plugins hsc_env =+  map lpPlugin (hsc_plugins hsc_env) +++  map spPlugin (hsc_static_plugins hsc_env)  -- | Perform an operation by using all of the plugins in turn.-withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a-withPlugins df transformation input = foldM go input (plugins df)+withPlugins :: Monad m => HscEnv -> PluginOperation m a -> a -> m a+withPlugins hsc_env transformation input = foldM go input (plugins hsc_env)   where     go arg (PluginWithArgs p opts) = transformation p opts arg -mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a]-mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df)+mapPlugins :: HscEnv -> (Plugin -> [CommandLineOption] -> a) -> [a]+mapPlugins hsc_env f = map (\(PluginWithArgs p opts) -> f p opts) (plugins hsc_env)  -- | Perform a constant operation by using all of the plugins in turn.-withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()-withPlugins_ df transformation input+withPlugins_ :: Monad m => HscEnv -> ConstPluginOperation m a -> a -> m ()+withPlugins_ hsc_env transformation input   = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)-          (plugins df)+          (plugins hsc_env)  type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc () data FrontendPlugin = FrontendPlugin {

+ GHC/Driver/Ppr.hs view

@@ -0,0 +1,136 @@+-- | Printing related functions that depend on session state (DynFlags)+module GHC.Driver.Ppr+   ( showSDoc+   , showSDocForUser+   , showSDocDebug+   , showSDocDump+   , showPpr+   , pprDebugAndThen+   , printForUser+   , printForC+   -- ** Trace+   , warnPprTrace+   , pprTrace+   , pprTraceWithFlags+   , pprTraceM+   , pprTraceDebug+   , pprTraceIt+   , pprSTrace+   , pprTraceException+   )+where++import GHC.Prelude++import {-# SOURCE #-} GHC.Driver.Session+import {-# SOURCE #-} GHC.Unit.State++import GHC.Utils.Exception+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.GlobalVars+import GHC.Utils.Ppr       ( Mode(..) )++import System.IO ( Handle )+import Control.Monad.IO.Class++-- | Show a SDoc as a String with the default user style+showSDoc :: DynFlags -> SDoc -> String+showSDoc dflags sdoc = renderWithContext (initSDocContext dflags defaultUserStyle) sdoc++showPpr :: Outputable a => DynFlags -> a -> String+showPpr dflags thing = showSDoc dflags (ppr thing)++-- | Allows caller to specify the PrintUnqualified to use+showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String+showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc'+   where+      sty  = mkUserStyle unqual AllTheWay+      doc' = pprWithUnitState unit_state doc++showSDocDump :: SDocContext -> SDoc -> String+showSDocDump ctx d = renderWithContext ctx (withPprStyle defaultDumpStyle d)++showSDocDebug :: DynFlags -> SDoc -> String+showSDocDebug dflags d = renderWithContext ctx d+   where+      ctx = (initSDocContext dflags defaultDumpStyle)+               { sdocPprDebug = True+               }++printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()+printForUser dflags handle unqual depth doc+  = printSDocLn ctx (PageMode False) handle doc+    where ctx = initSDocContext dflags (mkUserStyle unqual depth)++-- | Like 'printSDocLn' but specialized with 'LeftMode' and+-- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.+printForC :: DynFlags -> Handle -> SDoc -> IO ()+printForC dflags handle doc =+  printSDocLn ctx LeftMode handle doc+  where ctx = initSDocContext dflags (PprCode CStyle)++pprDebugAndThen :: SDocContext -> (String -> a) -> SDoc -> SDoc -> a+pprDebugAndThen ctx cont heading pretty_msg+ = cont (showSDocDump ctx doc)+ where+     doc = sep [heading, nest 2 pretty_msg]++-- | If debug output is on, show some 'SDoc' on the screen+pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a+pprTraceWithFlags dflags str doc x+  | hasNoDebugOutput dflags = x+  | otherwise               = pprDebugAndThen (initSDocContext dflags defaultDumpStyle)+                                              trace (text str) doc x++-- | If debug output is on, show some 'SDoc' on the screen+pprTrace :: String -> SDoc -> a -> a+pprTrace str doc x+  | unsafeHasNoDebugOutput = x+  | otherwise              = pprDebugAndThen defaultSDocContext trace (text str) doc x++pprTraceM :: Applicative f => String -> SDoc -> f ()+pprTraceM str doc = pprTrace str doc (pure ())++pprTraceDebug :: String -> SDoc -> a -> a+pprTraceDebug str doc x+   | debugIsOn && unsafeHasPprDebug = pprTrace str doc x+   | otherwise                      = x++-- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.+-- This allows you to print details from the returned value as well as from+-- ambient variables.+pprTraceWith :: String -> (a -> SDoc) -> a -> a+pprTraceWith desc f x = pprTrace desc (f x) x++-- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@+pprTraceIt :: Outputable a => String -> a -> a+pprTraceIt desc x = pprTraceWith desc ppr x++-- | @pprTraceException desc x action@ runs action, printing a message+-- if it throws an exception.+pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a+pprTraceException heading doc =+    handleGhcException $ \exc -> liftIO $ do+        putStrLn $ showSDocDump defaultSDocContext (sep [text heading, nest 2 doc])+        throwGhcExceptionIO exc++-- | If debug output is on, show some 'SDoc' on the screen along+-- with a call stack when available.+pprSTrace :: HasCallStack => SDoc -> a -> a+pprSTrace doc = pprTrace "" (doc $$ callStackDoc)++warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a+-- ^ Just warn about an assertion failure, recording the given file and line number.+-- Should typically be accessed with the WARN macros+warnPprTrace _     _     _     _    x | not debugIsOn     = x+warnPprTrace _     _file _line _msg x+   | unsafeHasNoDebugOutput = x+warnPprTrace False _file _line _msg x = x+warnPprTrace True   file  line  msg x+  = pprDebugAndThen defaultSDocContext trace heading+                    (msg $$ callStackDoc )+                    x+  where+    heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]

+ GHC/Driver/Ppr.hs-boot view

@@ -0,0 +1,9 @@+module GHC.Driver.Ppr where++import GHC.Prelude+import GHC.Stack+import {-# SOURCE #-} GHC.Driver.Session+import {-# SOURCE #-} GHC.Utils.Outputable++showSDoc :: DynFlags -> SDoc -> String+warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a

GHC/Driver/Session.hs view

@@ -15,5321 +15,5045 @@ -- ------------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-cse #-}--- -fno-cse is needed for GLOBAL_VAR's to behave properly-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Driver.Session (-        -- * Dynamic flags and associated configuration types-        DumpFlag(..),-        GeneralFlag(..),-        WarningFlag(..), WarnReason(..),-        Language(..),-        PlatformConstants(..),-        FatalMessager, LogAction, FlushOut(..), FlushErr(..),-        ProfAuto(..),-        glasgowExtsFlags,-        warningGroups, warningHierarchies,-        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,-        dopt, dopt_set, dopt_unset,-        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',-        wopt, wopt_set, wopt_unset,-        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,-        xopt, xopt_set, xopt_unset,-        xopt_set_unlessExplSpec,-        lang_set,-        whenGeneratingDynamicToo, ifGeneratingDynamicToo,-        whenCannotGenerateDynamicToo,-        dynamicTooMkDynamicDynFlags,-        dynamicOutputFile,-        sccProfilingEnabled,-        DynFlags(..),-        FlagSpec(..),-        HasDynFlags(..), ContainsDynFlags(..),-        RtsOptsEnabled(..),-        HscTarget(..), isObjectTarget, defaultObjectTarget,-        targetRetainsAllBindings,-        GhcMode(..), isOneShot,-        GhcLink(..), isNoLink,-        PackageFlag(..), PackageArg(..), ModRenaming(..),-        packageFlagsChanged,-        IgnorePackageFlag(..), TrustFlag(..),-        PackageDBFlag(..), PkgDbRef(..),-        Option(..), showOpt,-        DynLibLoader(..),-        fFlags, fLangFlags, xFlags,-        wWarningFlags,-        dynFlagDependencies,-        makeDynFlagsConsistent,-        positionIndependent,-        optimisationFlags,-        setFlagsFromEnvFile,--        addWay',--        homeUnit, mkHomeModule, isHomeModule,--        -- ** Log output-        putLogMsg,--        -- ** Safe Haskell-        SafeHaskellMode(..),-        safeHaskellOn, safeHaskellModeEnabled,-        safeImportsOn, safeLanguageOn, safeInferOn,-        packageTrustOn,-        safeDirectImpsReq, safeImplicitImpsReq,-        unsafeFlags, unsafeFlagsForInfer,--        -- ** LLVM Targets-        LlvmTarget(..), LlvmConfig(..),--        -- ** System tool settings and locations-        Settings(..),-        sProgramName,-        sProjectVersion,-        sGhcUsagePath,-        sGhciUsagePath,-        sToolDir,-        sTopDir,-        sTmpDir,-        sGlobalPackageDatabasePath,-        sLdSupportsCompactUnwind,-        sLdSupportsBuildId,-        sLdSupportsFilelist,-        sLdIsGnuLd,-        sGccSupportsNoPie,-        sPgm_L,-        sPgm_P,-        sPgm_F,-        sPgm_c,-        sPgm_a,-        sPgm_l,-        sPgm_lm,-        sPgm_dll,-        sPgm_T,-        sPgm_windres,-        sPgm_libtool,-        sPgm_ar,-        sPgm_ranlib,-        sPgm_lo,-        sPgm_lc,-        sPgm_lcc,-        sPgm_i,-        sOpt_L,-        sOpt_P,-        sOpt_P_fingerprint,-        sOpt_F,-        sOpt_c,-        sOpt_cxx,-        sOpt_a,-        sOpt_l,-        sOpt_lm,-        sOpt_windres,-        sOpt_lo,-        sOpt_lc,-        sOpt_lcc,-        sOpt_i,-        sExtraGccViaCFlags,-        sTargetPlatformString,-        sGhcWithInterpreter,-        sGhcWithSMP,-        sGhcRTSWays,-        sLibFFI,-        sGhcThreaded,-        sGhcDebugged,-        sGhcRtsWithLibdw,-        GhcNameVersion(..),-        FileSettings(..),-        PlatformMisc(..),-        settings,-        programName, projectVersion,-        ghcUsagePath, ghciUsagePath, topDir, tmpDir,-        versionedAppDir, versionedFilePath,-        extraGccViaCFlags, globalPackageDatabasePath,-        pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,-        pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool,-        pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,-        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,-        opt_P_signature,-        opt_windres, opt_lo, opt_lc, opt_lcc,--        -- ** Manipulating DynFlags-        addPluginModuleName,-        defaultDynFlags,                -- Settings -> DynFlags-        defaultWays,-        initDynFlags,                   -- DynFlags -> IO DynFlags-        defaultFatalMessager,-        defaultLogAction,-        defaultLogActionHPrintDoc,-        defaultLogActionHPutStrDoc,-        defaultFlushOut,-        defaultFlushErr,--        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]-        getVerbFlags,-        updOptLevel,-        setTmpDir,-        setUnitId,-        canonicalizeHomeModule,-        canonicalizeModuleIfHome,--        TurnOnFlag,-        turnOn,-        turnOff,-        impliedGFlags,-        impliedOffGFlags,-        impliedXFlags,--        -- ** Parsing DynFlags-        parseDynamicFlagsCmdLine,-        parseDynamicFilePragma,-        parseDynamicFlagsFull,--        -- ** Available DynFlags-        allNonDeprecatedFlags,-        flagsAll,-        flagsDynamic,-        flagsPackage,-        flagsForCompletion,--        supportedLanguagesAndExtensions,-        languageExtensions,--        -- ** DynFlags C compiler options-        picCCOpts, picPOpts,--        -- * Compiler configuration suitable for display to the user-        compilerInfo,--#include "GHCConstantsHaskellExports.hs"-        bLOCK_SIZE_W,-        wordAlignment,-        tAG_MASK,-        mAX_PTR_TAG,--        unsafeGlobalDynFlags, setUnsafeGlobalDynFlags,--        -- * SSE and AVX-        isSseEnabled,-        isSse2Enabled,-        isSse4_2Enabled,-        isBmiEnabled,-        isBmi2Enabled,-        isAvxEnabled,-        isAvx2Enabled,-        isAvx512cdEnabled,-        isAvx512erEnabled,-        isAvx512fEnabled,-        isAvx512pfEnabled,--        -- * Linker/compiler information-        LinkerInfo(..),-        CompilerInfo(..),-        useXLinkerRPath,--        -- * File cleanup-        FilesToClean(..), emptyFilesToClean,--        -- * Include specifications-        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,-        addImplicitQuoteInclude,--        -- * SDoc-        initSDocContext, initDefaultSDocContext,--        -- * Make use of the Cmm CFG-        CfgWeights(..)-  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Platform-import GHC.UniqueSubdir (uniqueSubdir)-import GHC.Unit.Types-import GHC.Unit.Parser-import GHC.Unit.Module-import {-# SOURCE #-} GHC.Driver.Plugins-import {-# SOURCE #-} GHC.Driver.Hooks-import GHC.Builtin.Names ( mAIN )-import {-# SOURCE #-} GHC.Unit.State (UnitState, emptyUnitState, UnitDatabase, updateIndefUnitId)-import GHC.Driver.Phases ( Phase(..), phaseInputExt )-import GHC.Driver.Flags-import GHC.Driver.Ways-import GHC.Driver.Backend-import GHC.Settings.Config-import GHC.Utils.CliOption-import GHC.Driver.CmdLine hiding (WarnReason(..))-import qualified GHC.Driver.CmdLine as Cmd-import GHC.Settings.Constants-import GHC.Utils.Panic-import qualified GHC.Utils.Ppr.Colour as Col-import GHC.Utils.Misc-import GHC.Data.Maybe-import GHC.Utils.Monad-import qualified GHC.Utils.Ppr as Pretty-import GHC.Types.SrcLoc-import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )-import GHC.Data.FastString-import GHC.Utils.Fingerprint-import GHC.Utils.Outputable-import GHC.Settings--import {-# SOURCE #-} GHC.Utils.Error-                               ( Severity(..), MsgDoc, mkLocMessageAnn-                               , getCaretDiagnostic, DumpAction, TraceAction-                               , defaultDumpAction, defaultTraceAction )-import GHC.Utils.Json-import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )-import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )--import System.IO.Unsafe ( unsafePerformIO )-import Data.IORef-import Control.Arrow ((&&&))-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Writer-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Except--import Data.Ord-import Data.Bits-import Data.Char-import Data.List-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Set (Set)-import qualified Data.Set as Set-import System.FilePath-import System.Directory-import System.Environment (lookupEnv)-import System.IO-import System.IO.Error-import Text.ParserCombinators.ReadP hiding (char)-import Text.ParserCombinators.ReadP as R--import GHC.Data.EnumSet (EnumSet)-import qualified GHC.Data.EnumSet as EnumSet--import GHC.Foreign (withCString, peekCString)-import qualified GHC.LanguageExtensions as LangExt--#if GHC_STAGE >= 2--- used by SHARED_GLOBAL_VAR-import Foreign (Ptr)-#endif---- Note [Updating flag description in the User's Guide]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you modify anything in this file please make sure that your changes are--- described in the User's Guide. Please update the flag description in the--- users guide (docs/users_guide) whenever you add or change a flag.---- Note [Supporting CLI completion]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ The command line interface completion (in for example bash) is an easy way--- for the developer to learn what flags are available from GHC.--- GHC helps by separating which flags are available when compiling with GHC,--- and which flags are available when using GHCi.--- A flag is assumed to either work in both these modes, or only in one of them.--- When adding or changing a flag, please consider for which mode the flag will--- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,--- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.---- Note [Adding a language extension]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ There are a few steps to adding (or removing) a language extension,------  * Adding the extension to GHC.LanguageExtensions------    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs---    is the canonical list of language extensions known by GHC.------  * Adding a flag to DynFlags.xFlags------    This is fairly self-explanatory. The name should be concise, memorable,---    and consistent with any previous implementations of the similar idea in---    other Haskell compilers.------  * Adding the flag to the documentation------    This is the same as any other flag. See---    Note [Updating flag description in the User's Guide]------  * Adding the flag to Cabal------    The Cabal library has its own list of all language extensions supported---    by all major compilers. This is the list that user code being uploaded---    to Hackage is checked against to ensure language extension validity.---    Consequently, it is very important that this list remains up-to-date.------    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)---    whose job it is to ensure these GHC's extensions are consistent with---    Cabal.------    The recommended workflow is,------     1. Temporarily add your new language extension to the---        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't---        break while Cabal is updated.------     2. After your GHC change is accepted, submit a Cabal pull request adding---        your new extension to Cabal's list (found in---        Cabal/Language/Haskell/Extension.hs).------     3. After your Cabal change is accepted, let the GHC developers know so---        they can update the Cabal submodule and remove the extensions from---        expectedGhcOnlyExtensions.------  * Adding the flag to the GHC Wiki------    There is a change log tracking language extension additions and removals---    on the GHC wiki:  https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history------  See #4437 and #8176.---- -------------------------------------------------------------------------------- DynFlags----- | Used to differentiate the scope an include needs to apply to.--- We have to split the include paths to avoid accidentally forcing recursive--- includes since -I overrides the system search paths. See #14312.-data IncludeSpecs-  = IncludeSpecs { includePathsQuote  :: [String]-                 , includePathsGlobal :: [String]-                 -- | See note [Implicit include paths]-                 , includePathsQuoteImplicit :: [String]-                 }-  deriving Show---- | Append to the list of includes a path that shall be included using `-I`--- when the C compiler is called. These paths override system search paths.-addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs-addGlobalInclude spec paths  = let f = includePathsGlobal spec-                               in spec { includePathsGlobal = f ++ paths }---- | Append to the list of includes a path that shall be included using--- `-iquote` when the C compiler is called. These paths only apply when quoted--- includes are used. e.g. #include "foo.h"-addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs-addQuoteInclude spec paths  = let f = includePathsQuote spec-                              in spec { includePathsQuote = f ++ paths }---- | These includes are not considered while fingerprinting the flags for iface--- | See note [Implicit include paths]-addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs-addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec-                              in spec { includePathsQuoteImplicit = f ++ paths }----- | Concatenate and flatten the list of global and quoted includes returning--- just a flat list of paths.-flattenIncludes :: IncludeSpecs -> [String]-flattenIncludes specs =-    includePathsQuote specs ++-    includePathsQuoteImplicit specs ++-    includePathsGlobal specs--{- Note [Implicit include paths]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  The compile driver adds the path to the folder containing the source file being-  compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'-  that are used later to compute the interface file. Because of this,-  the flags fingerprint derived from these 'DynFlags' and recorded in the-  interface file will end up containing the absolute path to the source folder.--  Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)-  store the build artifacts produced by a build BA for reuse in subsequent builds.--  Embedding source paths in interface fingerprints will thwart these attemps and-  lead to unnecessary recompilations when the source paths in BA differ from the-  source paths in subsequent builds.- -}----- | The various Safe Haskell modes-data SafeHaskellMode-   = Sf_None          -- ^ inferred unsafe-   | Sf_Unsafe        -- ^ declared and checked-   | Sf_Trustworthy   -- ^ declared and checked-   | Sf_Safe          -- ^ declared and checked-   | Sf_SafeInferred  -- ^ inferred as safe-   | Sf_Ignore        -- ^ @-fno-safe-haskell@ state-   deriving (Eq)--instance Show SafeHaskellMode where-    show Sf_None         = "None"-    show Sf_Unsafe       = "Unsafe"-    show Sf_Trustworthy  = "Trustworthy"-    show Sf_Safe         = "Safe"-    show Sf_SafeInferred = "Safe-Inferred"-    show Sf_Ignore       = "Ignore"--instance Outputable SafeHaskellMode where-    ppr = text . show---- | Contains not only a collection of 'GeneralFlag's but also a plethora of--- information relating to the compilation of a single file or GHC session-data DynFlags = DynFlags {-  ghcMode               :: GhcMode,-  ghcLink               :: GhcLink,-  hscTarget             :: HscTarget,--  -- formerly Settings-  ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,-  fileSettings      :: {-# UNPACK #-} !FileSettings,-  targetPlatform    :: Platform,       -- Filled in by SysTools-  toolSettings      :: {-# UNPACK #-} !ToolSettings,-  platformMisc      :: {-# UNPACK #-} !PlatformMisc,-  platformConstants :: PlatformConstants,-  rawSettings       :: [(String, String)],--  llvmConfig            :: LlvmConfig,-    -- ^ N.B. It's important that this field is lazy since we load the LLVM-    -- configuration lazily. See Note [LLVM Configuration] in "GHC.SysTools".-  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]-  optLevel              :: Int,         -- ^ Optimisation level-  debugLevel            :: Int,         -- ^ How much debug information to produce-  simplPhases           :: Int,         -- ^ Number of simplifier phases-  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations-  ruleCheck             :: Maybe String,-  inlineCheck           :: Maybe String, -- ^ A prefix to report inlining decisions about-  strictnessBefore      :: [Int],       -- ^ Additional demand analysis--  parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel-                                        --   in --make mode, where Nothing ==> compile as-                                        --   many in parallel as there are CPUs.--  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?-  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.--  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt-                                        --   to show in type error messages-  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show-                                        --   in typed hole error messages-  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole-                                        --   fits to show in typed hole error-                                        --   messages-  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for-                                        --   refinement hole fits in typed hole-                                        --   error messages-  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show-                                        --   in non-exhaustiveness warnings-  maxPmCheckModels      :: Int,         -- ^ Soft limit on the number of models-                                        --   the pattern match checker checks-                                        --   a pattern against. A safe guard-                                        --   against exponential blow-up.-  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks-  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr-  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function-  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types-                                        --   Not optional; otherwise ForceSpecConstr can diverge.-  binBlobThreshold      :: Word,        -- ^ Binary literals (e.g. strings) whose size is above-                                        --   this threshold will be dumped in a binary file-                                        --   by the assembler code generator (0 to disable)-  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase-  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating-                                        --   See 'GHC.Core.Opt.Monad.FloatOutSwitches'--  liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a-                                        --   recursive function.-  liftLamsNonRecArgs    :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a-                                        --   non-recursive function.-  liftLamsKnown         :: Bool,        -- ^ Lambda lift even when this turns a known call-                                        --   into an unknown call.--  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.--  historySize           :: Int,         -- ^ Simplification history size--  importPaths           :: [FilePath],-  mainModIs             :: Module,-  mainFunIs             :: Maybe String,-  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth-  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver-                                         --   Typically only 1 is needed--  homeUnitId            :: UnitId,                 -- ^ Target home unit-id-  homeUnitInstanceOfId  :: Maybe IndefUnitId,      -- ^ Unit-id to instantiate-  homeUnitInstantiations:: [(ModuleName, Module)], -- ^ How to instantiate `homeUnitInstanceOfId` unit--  -- ways-  ways                  :: Set Way,     -- ^ Way flags from the command line--  -- For object splitting-  splitInfo             :: Maybe (String,Int),--  -- paths etc.-  objectDir             :: Maybe String,-  dylibInstallName      :: Maybe String,-  hiDir                 :: Maybe String,-  hieDir                :: Maybe String,-  stubDir               :: Maybe String,-  dumpDir               :: Maybe String,--  objectSuf             :: String,-  hcSuf                 :: String,-  hiSuf                 :: String,-  hieSuf                :: String,--  canGenerateDynamicToo :: IORef Bool,-  dynObjectSuf          :: String,-  dynHiSuf              :: String,--  outputFile            :: Maybe String,-  dynOutputFile         :: Maybe String,-  outputHi              :: Maybe String,-  dynLibLoader          :: DynLibLoader,--  -- | This is set by 'GHC.Driver.Pipeline.runPipeline' based on where-  --    its output is going.-  dumpPrefix            :: Maybe FilePath,--  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'.-  --    Set by @-ddump-file-prefix@-  dumpPrefixForce       :: Maybe FilePath,--  ldInputs              :: [Option],--  includePaths          :: IncludeSpecs,-  libraryPaths          :: [String],-  frameworkPaths        :: [String],    -- used on darwin only-  cmdlineFrameworks     :: [String],    -- ditto--  rtsOpts               :: Maybe String,-  rtsOptsEnabled        :: RtsOptsEnabled,-  rtsOptsSuggestions    :: Bool,--  hpcDir                :: String,      -- ^ Path to store the .mix files--  -- Plugins-  pluginModNames        :: [ModuleName],-  pluginModNameOpts     :: [(ModuleName,String)],-  frontendPluginOpts    :: [String],-    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*-    -- order that they're specified on the command line.-  cachedPlugins         :: [LoadedPlugin],-    -- ^ plugins dynamically loaded after processing arguments. What will be-    -- loaded here is directed by pluginModNames. Arguments are loaded from-    -- pluginModNameOpts. The purpose of this field is to cache the plugins so-    -- they don't have to be loaded each time they are needed.  See-    -- 'GHC.Runtime.Loader.initializePlugins'.-  staticPlugins            :: [StaticPlugin],-    -- ^ static plugins which do not need dynamic loading. These plugins are-    -- intended to be added by GHC API users directly to this list.-    ---    -- To add dynamically loaded plugins through the GHC API see-    -- 'addPluginModuleName' instead.--  -- GHC API hooks-  hooks                 :: Hooks,--  --  For ghc -M-  depMakefile           :: FilePath,-  depIncludePkgDeps     :: Bool,-  depIncludeCppDeps     :: Bool,-  depExcludeMods        :: [ModuleName],-  depSuffixes           :: [String],--  --  Package flags-  packageDBFlags        :: [PackageDBFlag],-        -- ^ The @-package-db@ flags given on the command line, In-        -- *reverse* order that they're specified on the command line.-        -- This is intended to be applied with the list of "initial"-        -- package databases derived from @GHC_PACKAGE_PATH@; see-        -- 'getUnitDbRefs'.--  ignorePackageFlags    :: [IgnorePackageFlag],-        -- ^ The @-ignore-package@ flags from the command line.-        -- In *reverse* order that they're specified on the command line.-  packageFlags          :: [PackageFlag],-        -- ^ The @-package@ and @-hide-package@ flags from the command-line.-        -- In *reverse* order that they're specified on the command line.-  pluginPackageFlags    :: [PackageFlag],-        -- ^ The @-plugin-package-id@ flags from command line.-        -- In *reverse* order that they're specified on the command line.-  trustFlags            :: [TrustFlag],-        -- ^ The @-trust@ and @-distrust@ flags.-        -- In *reverse* order that they're specified on the command line.-  packageEnv            :: Maybe FilePath,-        -- ^ Filepath to the package environment file (if overriding default)--  unitDatabases         :: Maybe [UnitDatabase UnitId],-        -- ^ Stack of unit databases for the target platform.-        ---        -- This field is populated by `initUnits`.-        ---        -- 'Nothing' means the databases have never been read from disk. If-        -- `initUnits` is called again, it doesn't reload the databases from-        -- disk.--  unitState             :: UnitState,-        -- ^ Consolidated unit database built by 'initUnits' from the unit-        -- databases in 'unitDatabases' and flags ('-ignore-package', etc.).-        ---        -- It also contains mapping from module names to actual Modules.--  -- Temporary files-  -- These have to be IORefs, because the defaultCleanupHandler needs to-  -- know what to clean when an exception happens-  filesToClean          :: IORef FilesToClean,-  dirsToClean           :: IORef (Map FilePath FilePath),-  -- The next available suffix to uniquely name a temp file, updated atomically-  nextTempSuffix        :: IORef Int,--  -- Names of files which were generated from -ddump-to-file; used to-  -- track which ones we need to truncate because it's our first run-  -- through-  generatedDumps        :: IORef (Set FilePath),--  -- hsc dynamic flags-  dumpFlags             :: EnumSet DumpFlag,-  generalFlags          :: EnumSet GeneralFlag,-  warningFlags          :: EnumSet WarningFlag,-  fatalWarningFlags     :: EnumSet WarningFlag,-  -- Don't change this without updating extensionFlags:-  language              :: Maybe Language,-  -- | Safe Haskell mode-  safeHaskell           :: SafeHaskellMode,-  safeInfer             :: Bool,-  safeInferred          :: Bool,-  -- We store the location of where some extension and flags were turned on so-  -- we can produce accurate error messages when Safe Haskell fails due to-  -- them.-  thOnLoc               :: SrcSpan,-  newDerivOnLoc         :: SrcSpan,-  deriveViaOnLoc        :: SrcSpan,-  overlapInstLoc        :: SrcSpan,-  incoherentOnLoc       :: SrcSpan,-  pkgTrustOnLoc         :: SrcSpan,-  warnSafeOnLoc         :: SrcSpan,-  warnUnsafeOnLoc       :: SrcSpan,-  trustworthyOnLoc      :: SrcSpan,-  -- Don't change this without updating extensionFlags:-  -- Here we collect the settings of the language extensions-  -- from the command line, the ghci config file and-  -- from interactive :set / :seti commands.-  extensions            :: [OnOff LangExt.Extension],-  -- extensionFlags should always be equal to-  --     flattenExtensionFlags language extensions-  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used-  -- by template-haskell-  extensionFlags        :: EnumSet LangExt.Extension,--  -- Unfolding control-  -- See Note [Discounts and thresholds] in GHC.Core.Unfold-  ufCreationThreshold   :: Int,-  ufUseThreshold        :: Int,-  ufFunAppDiscount      :: Int,-  ufDictDiscount        :: Int,-  ufDearOp              :: Int,-  ufVeryAggressive      :: Bool,--  maxWorkerArgs         :: Int,--  ghciHistSize          :: Int,--  -- | MsgDoc output action: use "GHC.Utils.Error" instead of this if you can-  log_action            :: LogAction,-  dump_action           :: DumpAction,-  trace_action          :: TraceAction,-  flushOut              :: FlushOut,-  flushErr              :: FlushErr,--  ghcVersionFile        :: Maybe FilePath,-  haddockOptions        :: Maybe String,--  -- | GHCi scripts specified by -ghci-script, in reverse order-  ghciScripts           :: [String],--  -- Output style options-  pprUserLength         :: Int,-  pprCols               :: Int,--  useUnicode            :: Bool,-  useColor              :: OverridingBool,-  canUseColor           :: Bool,-  colScheme             :: Col.Scheme,--  -- | what kind of {-# SCC #-} to add automatically-  profAuto              :: ProfAuto,--  interactivePrint      :: Maybe String,--  nextWrapperNum        :: IORef (ModuleEnv Int),--  -- | Machine dependent flags (-m\<blah> stuff)-  sseVersion            :: Maybe SseVersion,-  bmiVersion            :: Maybe BmiVersion,-  avx                   :: Bool,-  avx2                  :: Bool,-  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.-  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.-  avx512f               :: Bool, -- Enable AVX-512 instructions.-  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.--  -- | Run-time linker information (what options we need, etc.)-  rtldInfo              :: IORef (Maybe LinkerInfo),--  -- | Run-time compiler information-  rtccInfo              :: IORef (Maybe CompilerInfo),--  -- Constants used to control the amount of optimization done.--  -- | Max size, in bytes, of inline array allocations.-  maxInlineAllocSize    :: Int,--  -- | Only inline memcpy if it generates no more than this many-  -- pseudo (roughly: Cmm) instructions.-  maxInlineMemcpyInsns  :: Int,--  -- | Only inline memset if it generates no more than this many-  -- pseudo (roughly: Cmm) instructions.-  maxInlineMemsetInsns  :: Int,--  -- | Reverse the order of error messages in GHC/GHCi-  reverseErrors         :: Bool,--  -- | Limit the maximum number of errors to show-  maxErrors             :: Maybe Int,--  -- | Unique supply configuration for testing build determinism-  initialUnique         :: Int,-  uniqueIncrement       :: Int,--  -- | Temporary: CFG Edge weights for fast iterations-  cfgWeightInfo         :: CfgWeights-}---- | Edge weights to use when generating a CFG from CMM-data CfgWeights-    = CFGWeights-    { uncondWeight :: Int-    , condBranchWeight :: Int-    , switchWeight :: Int-    , callWeight :: Int-    , likelyCondWeight :: Int-    , unlikelyCondWeight :: Int-    , infoTablePenalty :: Int-    , backEdgeBonus :: Int-    }--defaultCfgWeights :: CfgWeights-defaultCfgWeights-    = CFGWeights-    { uncondWeight = 1000-    , condBranchWeight = 800-    , switchWeight = 1-    , callWeight = -10-    , likelyCondWeight = 900-    , unlikelyCondWeight = 300-    , infoTablePenalty = 300-    , backEdgeBonus = 400-    }--parseCfgWeights :: String -> CfgWeights -> CfgWeights-parseCfgWeights s oldWeights =-        foldl' (\cfg (n,v) -> update n v cfg) oldWeights assignments-    where-        assignments = map assignment $ settings s-        update "uncondWeight" n w =-            w {uncondWeight = n}-        update "condBranchWeight" n w =-            w {condBranchWeight = n}-        update "switchWeight" n w =-            w {switchWeight = n}-        update "callWeight" n w =-            w {callWeight = n}-        update "likelyCondWeight" n w =-            w {likelyCondWeight = n}-        update "unlikelyCondWeight" n w =-            w {unlikelyCondWeight = n}-        update "infoTablePenalty" n w =-            w {infoTablePenalty = n}-        update "backEdgeBonus" n w =-            w {backEdgeBonus = n}-        update other _ _-            = panic $ other ++-                      " is not a cfg weight parameter. " ++-                      exampleString-        settings s-            | (s1,rest) <- break (== ',') s-            , null rest-            = [s1]-            | (s1,rest) <- break (== ',') s-            = s1 : settings (drop 1 rest)--        assignment as-            | (name, _:val) <- break (== '=') as-            = (name,read val)-            | otherwise-            = panic $ "Invalid cfg parameters." ++ exampleString--        exampleString = "Example parameters: uncondWeight=1000," ++-            "condBranchWeight=800,switchWeight=0,callWeight=300" ++-            ",likelyCondWeight=900,unlikelyCondWeight=300" ++-            ",infoTablePenalty=300,backEdgeBonus=400"--class HasDynFlags m where-    getDynFlags :: m DynFlags--{- It would be desirable to have the more generalised--  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where-      getDynFlags = lift getDynFlags--instance definition. However, that definition would overlap with the-`HasDynFlags (GhcT m)` instance. Instead we define instances for a-couple of common Monad transformers explicitly. -}--instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where-    getDynFlags = lift getDynFlags--instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where-    getDynFlags = lift getDynFlags--instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where-    getDynFlags = lift getDynFlags--instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where-    getDynFlags = lift getDynFlags--class ContainsDynFlags t where-    extractDynFlags :: t -> DynFlags--data ProfAuto-  = NoProfAuto         -- ^ no SCC annotations added-  | ProfAutoAll        -- ^ top-level and nested functions are annotated-  | ProfAutoTop        -- ^ top-level functions annotated only-  | ProfAutoExports    -- ^ exported functions annotated only-  | ProfAutoCalls      -- ^ annotate call-sites-  deriving (Eq,Enum)--data LlvmTarget = LlvmTarget-  { lDataLayout :: String-  , lCPU        :: String-  , lAttributes :: [String]-  }---- | See Note [LLVM Configuration] in "GHC.SysTools".-data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)]-                             , llvmPasses  :: [(Int, String)]-                             }---------------------------------------------------------------------------------- Accessessors from 'DynFlags'---- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the--- vast majority of code. But GHCi questionably uses this to produce a default--- 'DynFlags' from which to compute a flags diff for printing.-settings :: DynFlags -> Settings-settings dflags = Settings-  { sGhcNameVersion = ghcNameVersion dflags-  , sFileSettings = fileSettings dflags-  , sTargetPlatform = targetPlatform dflags-  , sToolSettings = toolSettings dflags-  , sPlatformMisc = platformMisc dflags-  , sPlatformConstants = platformConstants dflags-  , sRawSettings = rawSettings dflags-  }--programName :: DynFlags -> String-programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags-projectVersion :: DynFlags -> String-projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags)-ghcUsagePath          :: DynFlags -> FilePath-ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags-ghciUsagePath         :: DynFlags -> FilePath-ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags-toolDir               :: DynFlags -> Maybe FilePath-toolDir dflags = fileSettings_toolDir $ fileSettings dflags-topDir                :: DynFlags -> FilePath-topDir dflags = fileSettings_topDir $ fileSettings dflags-tmpDir                :: DynFlags -> String-tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags-extraGccViaCFlags     :: DynFlags -> [String]-extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags-globalPackageDatabasePath   :: DynFlags -> FilePath-globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags-pgm_L                 :: DynFlags -> String-pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags-pgm_P                 :: DynFlags -> (String,[Option])-pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags-pgm_F                 :: DynFlags -> String-pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags-pgm_c                 :: DynFlags -> String-pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags-pgm_a                 :: DynFlags -> (String,[Option])-pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags-pgm_l                 :: DynFlags -> (String,[Option])-pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags-pgm_lm                 :: DynFlags -> (String,[Option])-pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags-pgm_dll               :: DynFlags -> (String,[Option])-pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags-pgm_T                 :: DynFlags -> String-pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags-pgm_windres           :: DynFlags -> String-pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags-pgm_libtool           :: DynFlags -> String-pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags-pgm_lcc               :: DynFlags -> (String,[Option])-pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags-pgm_ar                :: DynFlags -> String-pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags-pgm_otool             :: DynFlags -> String-pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags-pgm_install_name_tool :: DynFlags -> String-pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags-pgm_ranlib            :: DynFlags -> String-pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags-pgm_lo                :: DynFlags -> (String,[Option])-pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags-pgm_lc                :: DynFlags -> (String,[Option])-pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags-pgm_i                 :: DynFlags -> String-pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags-opt_L                 :: DynFlags -> [String]-opt_L dflags = toolSettings_opt_L $ toolSettings dflags-opt_P                 :: DynFlags -> [String]-opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)-            ++ toolSettings_opt_P (toolSettings dflags)---- This function packages everything that's needed to fingerprint opt_P--- flags. See Note [Repeated -optP hashing].-opt_P_signature       :: DynFlags -> ([String], Fingerprint)-opt_P_signature dflags =-  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)-  , toolSettings_opt_P_fingerprint $ toolSettings dflags-  )--opt_F                 :: DynFlags -> [String]-opt_F dflags= toolSettings_opt_F $ toolSettings dflags-opt_c                 :: DynFlags -> [String]-opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)-            ++ toolSettings_opt_c (toolSettings dflags)-opt_cxx               :: DynFlags -> [String]-opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags-opt_a                 :: DynFlags -> [String]-opt_a dflags= toolSettings_opt_a $ toolSettings dflags-opt_l                 :: DynFlags -> [String]-opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)-            ++ toolSettings_opt_l (toolSettings dflags)-opt_lm                :: DynFlags -> [String]-opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags-opt_windres           :: DynFlags -> [String]-opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags-opt_lcc                :: DynFlags -> [String]-opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags-opt_lo                :: DynFlags -> [String]-opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags-opt_lc                :: DynFlags -> [String]-opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags-opt_i                 :: DynFlags -> [String]-opt_i dflags= toolSettings_opt_i $ toolSettings dflags---- | The directory for this version of ghc in the user's app directory--- (typically something like @~/.ghc/x86_64-linux-7.6.3@)----versionedAppDir :: String -> PlatformMini -> MaybeT IO FilePath-versionedAppDir appname platform = do-  -- Make sure we handle the case the HOME isn't set (see #11678)-  appdir <- tryMaybeT $ getAppUserDataDirectory appname-  return $ appdir </> versionedFilePath platform--versionedFilePath :: PlatformMini -> FilePath-versionedFilePath platform = uniqueSubdir platform---- | The target code type of the compilation (if any).------ Whenever you change the target, also make sure to set 'ghcLink' to--- something sensible.------ 'HscNothing' can be used to avoid generating any output, however, note--- that:------  * If a program uses Template Haskell the typechecker may need to run code---    from an imported module.  To facilitate this, code generation is enabled---    for modules imported by modules that use template haskell.---    See Note [-fno-code mode].----data HscTarget-  = HscC           -- ^ Generate C code.-  | HscAsm         -- ^ Generate assembly using the native code generator.-  | HscLlvm        -- ^ Generate assembly using the llvm code generator.-  | HscInterpreted -- ^ Generate bytecode.  (Requires 'LinkInMemory')-  | HscNothing     -- ^ Don't generate any code.  See notes above.-  deriving (Eq, Show)---- | Will this target result in an object file on the disk?-isObjectTarget :: HscTarget -> Bool-isObjectTarget HscC     = True-isObjectTarget HscAsm   = True-isObjectTarget HscLlvm  = True-isObjectTarget _        = False---- | Does this target retain *all* top-level bindings for a module,--- rather than just the exported bindings, in the TypeEnv and compiled--- code (if any)?  In interpreted mode we do this, so that GHCi can--- call functions inside a module.  In HscNothing mode we also do it,--- so that Haddock can get access to the GlobalRdrEnv for a module--- after typechecking it.-targetRetainsAllBindings :: HscTarget -> Bool-targetRetainsAllBindings HscInterpreted = True-targetRetainsAllBindings HscNothing     = True-targetRetainsAllBindings _              = False---- | The 'GhcMode' tells us whether we're doing multi-module--- compilation (controlled via the "GHC" API) or one-shot--- (single-module) compilation.  This makes a difference primarily to--- the "GHC.Driver.Finder": in one-shot mode we look for interface files for--- imported modules, but in multi-module mode we look for source files--- in order to check whether they need to be recompiled.-data GhcMode-  = CompManager         -- ^ @\-\-make@, GHCi, etc.-  | OneShot             -- ^ @ghc -c Foo.hs@-  | MkDepend            -- ^ @ghc -M@, see "GHC.Driver.Finder" for why we need this-  deriving Eq--instance Outputable GhcMode where-  ppr CompManager = text "CompManager"-  ppr OneShot     = text "OneShot"-  ppr MkDepend    = text "MkDepend"--isOneShot :: GhcMode -> Bool-isOneShot OneShot = True-isOneShot _other  = False---- | What to do in the link step, if there is one.-data GhcLink-  = NoLink              -- ^ Don't link at all-  | LinkBinary          -- ^ Link object code into a binary-  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both-                        --   bytecode and object code).-  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)-  | LinkStaticLib       -- ^ Link objects into a static lib-  deriving (Eq, Show)--isNoLink :: GhcLink -> Bool-isNoLink NoLink = True-isNoLink _      = False---- | We accept flags which make packages visible, but how they select--- the package varies; this data type reflects what selection criterion--- is used.-data PackageArg =-      PackageArg String    -- ^ @-package@, by 'PackageName'-    | UnitIdArg Unit       -- ^ @-package-id@, by 'Unit'-  deriving (Eq, Show)--instance Outputable PackageArg where-    ppr (PackageArg pn) = text "package" <+> text pn-    ppr (UnitIdArg uid) = text "unit" <+> ppr uid---- | Represents the renaming that may be associated with an exposed--- package, e.g. the @rns@ part of @-package "foo (rns)"@.------ Here are some example parsings of the package flags (where--- a string literal is punned to be a 'ModuleName':------      * @-package foo@ is @ModRenaming True []@---      * @-package foo ()@ is @ModRenaming False []@---      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@---      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@---      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@-data ModRenaming = ModRenaming {-    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?-    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope-                                               --   under name @n@.-  } deriving (Eq)-instance Outputable ModRenaming where-    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)---- | Flags for manipulating the set of non-broken packages.-newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@-  deriving (Eq)---- | Flags for manipulating package trust.-data TrustFlag-  = TrustPackage    String -- ^ @-trust@-  | DistrustPackage String -- ^ @-distrust@-  deriving (Eq)---- | Flags for manipulating packages visibility.-data PackageFlag-  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@-  | HidePackage     String -- ^ @-hide-package@-  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged--data PackageDBFlag-  = PackageDB PkgDbRef-  | NoUserPackageDB-  | NoGlobalPackageDB-  | ClearPackageDBs-  deriving (Eq)--packageFlagsChanged :: DynFlags -> DynFlags -> Bool-packageFlagsChanged idflags1 idflags0 =-  packageFlags idflags1 /= packageFlags idflags0 ||-  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||-  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||-  trustFlags idflags1 /= trustFlags idflags0 ||-  packageDBFlags idflags1 /= packageDBFlags idflags0 ||-  packageGFlags idflags1 /= packageGFlags idflags0- where-   packageGFlags dflags = map (`gopt` dflags)-     [ Opt_HideAllPackages-     , Opt_HideAllPluginPackages-     , Opt_AutoLinkPackages ]--instance Outputable PackageFlag where-    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)-    ppr (HidePackage str) = text "-hide-package" <+> text str---- | The 'HscTarget' value corresponding to the default way to create--- object files on the current platform.--defaultHscTarget :: Platform -> HscTarget-defaultHscTarget platform-  | platformUnregisterised platform        = HscC-  | NCG <- platformDefaultBackend platform = HscAsm-  | otherwise = HscLlvm--defaultObjectTarget :: DynFlags -> HscTarget-defaultObjectTarget dflags = defaultHscTarget-  (targetPlatform dflags)--data DynLibLoader-  = Deployable-  | SystemDependent-  deriving Eq--data RtsOptsEnabled-  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly-  | RtsOptsAll-  deriving (Show)---- | Are we building with @-fPIE@ or @-fPIC@ enabled?-positionIndependent :: DynFlags -> Bool-positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags--whenGeneratingDynamicToo :: MonadIO m => DynFlags -> m () -> m ()-whenGeneratingDynamicToo dflags f = ifGeneratingDynamicToo dflags f (return ())--ifGeneratingDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a-ifGeneratingDynamicToo dflags f g = generateDynamicTooConditional dflags f g g--whenCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m () -> m ()-whenCannotGenerateDynamicToo dflags f-    = ifCannotGenerateDynamicToo dflags f (return ())--ifCannotGenerateDynamicToo :: MonadIO m => DynFlags -> m a -> m a -> m a-ifCannotGenerateDynamicToo dflags f g-    = generateDynamicTooConditional dflags g f g--generateDynamicTooConditional :: MonadIO m-                              => DynFlags -> m a -> m a -> m a -> m a-generateDynamicTooConditional dflags canGen cannotGen notTryingToGen-    = if gopt Opt_BuildDynamicToo dflags-      then do let ref = canGenerateDynamicToo dflags-              b <- liftIO $ readIORef ref-              if b then canGen else cannotGen-      else notTryingToGen--dynamicTooMkDynamicDynFlags :: DynFlags -> DynFlags-dynamicTooMkDynamicDynFlags dflags0-    = let dflags1 = addWay' WayDyn dflags0-          dflags2 = dflags1 {-                        outputFile = dynOutputFile dflags1,-                        hiSuf = dynHiSuf dflags1,-                        objectSuf = dynObjectSuf dflags1-                    }-          dflags3 = gopt_unset dflags2 Opt_BuildDynamicToo-      in dflags3---- | Compute the path of the dynamic object corresponding to an object file.-dynamicOutputFile :: DynFlags -> FilePath -> FilePath-dynamicOutputFile dflags outputFile = dynOut outputFile-  where-    dynOut = flip addExtension (dynObjectSuf dflags) . dropExtension----------------------------------------------------------------------------------- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value-initDynFlags :: DynFlags -> IO DynFlags-initDynFlags dflags = do- let -- We can't build with dynamic-too on Windows, as labels before-     -- the fork point are different depending on whether we are-     -- building dynamically or not.-     platformCanGenerateDynamicToo-         = platformOS (targetPlatform dflags) /= OSMinGW32- refCanGenerateDynamicToo <- newIORef platformCanGenerateDynamicToo- refNextTempSuffix <- newIORef 0- refFilesToClean <- newIORef emptyFilesToClean- refDirsToClean <- newIORef Map.empty- refGeneratedDumps <- newIORef Set.empty- refRtldInfo <- newIORef Nothing- refRtccInfo <- newIORef Nothing- wrapperNum <- newIORef emptyModuleEnv- canUseUnicode <- do let enc = localeEncoding-                         str = "‘’"-                     (withCString enc str $ \cstr ->-                          do str' <- peekCString enc cstr-                             return (str == str'))-                         `catchIOError` \_ -> return False- ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"- let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode- maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"- maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"- let adjustCols (Just env) = Col.parseScheme env-     adjustCols Nothing    = id- let (useColor', colScheme') =-       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)-       (useColor dflags, colScheme dflags)- return dflags{-        canGenerateDynamicToo = refCanGenerateDynamicToo,-        nextTempSuffix = refNextTempSuffix,-        filesToClean   = refFilesToClean,-        dirsToClean    = refDirsToClean,-        generatedDumps = refGeneratedDumps,-        nextWrapperNum = wrapperNum,-        useUnicode    = useUnicode',-        useColor      = useColor',-        canUseColor   = stderrSupportsAnsiColors,-        colScheme     = colScheme',-        rtldInfo      = refRtldInfo,-        rtccInfo      = refRtccInfo-        }---- | The normal 'DynFlags'. Note that they are not suitable for use in this form--- and must be fully initialized by 'GHC.runGhc' first.-defaultDynFlags :: Settings -> LlvmConfig -> DynFlags-defaultDynFlags mySettings llvmConfig =--- See Note [Updating flag description in the User's Guide]-     DynFlags {-        ghcMode                 = CompManager,-        ghcLink                 = LinkBinary,-        hscTarget               = defaultHscTarget (sTargetPlatform mySettings),-        verbosity               = 0,-        optLevel                = 0,-        debugLevel              = 0,-        simplPhases             = 2,-        maxSimplIterations      = 4,-        ruleCheck               = Nothing,-        inlineCheck             = Nothing,-        binBlobThreshold        = 500000, -- 500K is a good default (see #16190)-        maxRelevantBinds        = Just 6,-        maxValidHoleFits   = Just 6,-        maxRefHoleFits     = Just 6,-        refLevelHoleFits   = Nothing,-        maxUncoveredPatterns    = 4,-        maxPmCheckModels        = 30,-        simplTickFactor         = 100,-        specConstrThreshold     = Just 2000,-        specConstrCount         = Just 3,-        specConstrRecursive     = 3,-        liberateCaseThreshold   = Just 2000,-        floatLamArgs            = Just 0, -- Default: float only if no fvs-        liftLamsRecArgs         = Just 5, -- Default: the number of available argument hardware registers on x86_64-        liftLamsNonRecArgs      = Just 5, -- Default: the number of available argument hardware registers on x86_64-        liftLamsKnown           = False,  -- Default: don't turn known calls into unknown ones-        cmmProcAlignment        = Nothing,--        historySize             = 20,-        strictnessBefore        = [],--        parMakeCount            = Just 1,--        enableTimeStats         = False,-        ghcHeapSize             = Nothing,--        importPaths             = ["."],-        mainModIs               = mAIN,-        mainFunIs               = Nothing,-        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,-        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,--        homeUnitId              = mainUnitId,-        homeUnitInstanceOfId    = Nothing,-        homeUnitInstantiations  = [],--        objectDir               = Nothing,-        dylibInstallName        = Nothing,-        hiDir                   = Nothing,-        hieDir                  = Nothing,-        stubDir                 = Nothing,-        dumpDir                 = Nothing,--        objectSuf               = phaseInputExt StopLn,-        hcSuf                   = phaseInputExt HCc,-        hiSuf                   = "hi",-        hieSuf                  = "hie",--        canGenerateDynamicToo   = panic "defaultDynFlags: No canGenerateDynamicToo",-        dynObjectSuf            = "dyn_" ++ phaseInputExt StopLn,-        dynHiSuf                = "dyn_hi",--        pluginModNames          = [],-        pluginModNameOpts       = [],-        frontendPluginOpts      = [],-        cachedPlugins           = [],-        staticPlugins           = [],-        hooks                   = emptyHooks,--        outputFile              = Nothing,-        dynOutputFile           = Nothing,-        outputHi                = Nothing,-        dynLibLoader            = SystemDependent,-        dumpPrefix              = Nothing,-        dumpPrefixForce         = Nothing,-        ldInputs                = [],-        includePaths            = IncludeSpecs [] [] [],-        libraryPaths            = [],-        frameworkPaths          = [],-        cmdlineFrameworks       = [],-        rtsOpts                 = Nothing,-        rtsOptsEnabled          = RtsOptsSafeOnly,-        rtsOptsSuggestions      = True,--        hpcDir                  = ".hpc",--        packageDBFlags          = [],-        packageFlags            = [],-        pluginPackageFlags      = [],-        ignorePackageFlags      = [],-        trustFlags              = [],-        packageEnv              = Nothing,-        unitDatabases           = Nothing,-        unitState               = emptyUnitState,-        ways                    = defaultWays mySettings,-        splitInfo               = Nothing,--        ghcNameVersion = sGhcNameVersion mySettings,-        fileSettings = sFileSettings mySettings,-        toolSettings = sToolSettings mySettings,-        targetPlatform = sTargetPlatform mySettings,-        platformMisc = sPlatformMisc mySettings,-        platformConstants = sPlatformConstants mySettings,-        rawSettings = sRawSettings mySettings,--        -- See Note [LLVM configuration].-        llvmConfig              = llvmConfig,--        -- ghc -M values-        depMakefile       = "Makefile",-        depIncludePkgDeps = False,-        depIncludeCppDeps = False,-        depExcludeMods    = [],-        depSuffixes       = [],-        -- end of ghc -M values-        nextTempSuffix = panic "defaultDynFlags: No nextTempSuffix",-        filesToClean   = panic "defaultDynFlags: No filesToClean",-        dirsToClean    = panic "defaultDynFlags: No dirsToClean",-        generatedDumps = panic "defaultDynFlags: No generatedDumps",-        ghcVersionFile = Nothing,-        haddockOptions = Nothing,-        dumpFlags = EnumSet.empty,-        generalFlags = EnumSet.fromList (defaultFlags mySettings),-        warningFlags = EnumSet.fromList standardWarnings,-        fatalWarningFlags = EnumSet.empty,-        ghciScripts = [],-        language = Nothing,-        safeHaskell = Sf_None,-        safeInfer   = True,-        safeInferred = True,-        thOnLoc = noSrcSpan,-        newDerivOnLoc = noSrcSpan,-        deriveViaOnLoc = noSrcSpan,-        overlapInstLoc = noSrcSpan,-        incoherentOnLoc = noSrcSpan,-        pkgTrustOnLoc = noSrcSpan,-        warnSafeOnLoc = noSrcSpan,-        warnUnsafeOnLoc = noSrcSpan,-        trustworthyOnLoc = noSrcSpan,-        extensions = [],-        extensionFlags = flattenExtensionFlags Nothing [],--        ufCreationThreshold = 750,-           -- The ufCreationThreshold threshold must be reasonably high-           -- to take account of possible discounts.-           -- E.g. 450 is not enough in 'fulsom' for Interval.sqr to-           -- inline into Csg.calc (The unfolding for sqr never makes it-           -- into the interface file.)--        ufUseThreshold = 90,-           -- Last adjusted upwards in #18282, when I reduced-           -- the result discount for constructors.--        ufFunAppDiscount = 60,-           -- Be fairly keen to inline a function if that means-           -- we'll be able to pick the right method from a dictionary--        ufDictDiscount      = 30,-        ufDearOp            = 40,-        ufVeryAggressive    = False,--        maxWorkerArgs = 10,--        ghciHistSize = 50, -- keep a log of length 50 by default--        -- Logging--        log_action   = defaultLogAction,-        dump_action  = defaultDumpAction,-        trace_action = defaultTraceAction,--        flushOut = defaultFlushOut,-        flushErr = defaultFlushErr,-        pprUserLength = 5,-        pprCols = 100,-        useUnicode = False,-        useColor = Auto,-        canUseColor = False,-        colScheme = Col.defaultScheme,-        profAuto = NoProfAuto,-        interactivePrint = Nothing,-        nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",-        sseVersion = Nothing,-        bmiVersion = Nothing,-        avx = False,-        avx2 = False,-        avx512cd = False,-        avx512er = False,-        avx512f = False,-        avx512pf = False,-        rtldInfo = panic "defaultDynFlags: no rtldInfo",-        rtccInfo = panic "defaultDynFlags: no rtccInfo",--        maxInlineAllocSize = 128,-        maxInlineMemcpyInsns = 32,-        maxInlineMemsetInsns = 32,--        initialUnique = 0,-        uniqueIncrement = 1,--        reverseErrors = False,-        maxErrors     = Nothing,-        cfgWeightInfo = defaultCfgWeights-      }--defaultWays :: Settings -> Set Way-defaultWays settings = if pc_DYNAMIC_BY_DEFAULT (sPlatformConstants settings)-                       then Set.singleton WayDyn-                       else Set.empty---------------------------------------------------------------------------------- Note [JSON Error Messages]------ When the user requests the compiler output to be dumped as json--- we used to collect them all in an IORef and then print them at the end.--- This doesn't work very well with GHCi. (See #14078) So instead we now--- use the simpler method of just outputting a JSON document inplace to--- stdout.------ Before the compiler calls log_action, it has already turned the `ErrMsg`--- into a formatted message. This means that we lose some possible--- information to provide to the user but refactoring log_action is quite--- invasive as it is called in many places. So, for now I left it alone--- and we can refine its behaviour as users request different output.--type FatalMessager = String -> IO ()--type LogAction = DynFlags-              -> WarnReason-              -> Severity-              -> SrcSpan-              -> MsgDoc-              -> IO ()--defaultFatalMessager :: FatalMessager-defaultFatalMessager = hPutStrLn stderr----- See Note [JSON Error Messages]----jsonLogAction :: LogAction-jsonLogAction dflags reason severity srcSpan msg-  = do-    defaultLogActionHPutStrDoc dflags stdout-      (withPprStyle (mkCodeStyle CStyle) (doc $$ text ""))-    where-      doc = renderJSON $-              JSObject [ ( "span", json srcSpan )-                       , ( "doc" , JSString (showSDoc dflags msg) )-                       , ( "severity", json severity )-                       , ( "reason" ,   json reason )-                       ]---defaultLogAction :: LogAction-defaultLogAction dflags reason severity srcSpan msg-    = case severity of-      SevOutput      -> printOut msg-      SevDump        -> printOut (msg $$ blankLine)-      SevInteractive -> putStrSDoc msg-      SevInfo        -> printErrs msg-      SevFatal       -> printErrs msg-      SevWarning     -> printWarns-      SevError       -> printWarns-    where-      printOut   = defaultLogActionHPrintDoc  dflags stdout-      printErrs  = defaultLogActionHPrintDoc  dflags stderr-      putStrSDoc = defaultLogActionHPutStrDoc dflags stdout-      -- Pretty print the warning flag, if any (#10752)-      message = mkLocMessageAnn flagMsg severity srcSpan msg--      printWarns = do-        hPutChar stderr '\n'-        caretDiagnostic <--            if gopt Opt_DiagnosticsShowCaret dflags-            then getCaretDiagnostic severity srcSpan-            else pure empty-        printErrs $ getPprStyle $ \style ->-          withPprStyle (setStyleColoured True style)-            (message $+$ caretDiagnostic)-        -- careful (#2302): printErrs prints in UTF-8,-        -- whereas converting to string first and using-        -- hPutStr would just emit the low 8 bits of-        -- each unicode char.--      flagMsg =-        case reason of-          NoReason -> Nothing-          Reason wflag -> do-            spec <- flagSpecOf wflag-            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)-          ErrReason Nothing ->-            return "-Werror"-          ErrReason (Just wflag) -> do-            spec <- flagSpecOf wflag-            return $-              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag ++-              ", -Werror=" ++ flagSpecName spec--      warnFlagGrp flag-          | gopt Opt_ShowWarnGroups dflags =-                case smallestGroups flag of-                    [] -> ""-                    groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"-          | otherwise = ""---- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.-defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> IO ()-defaultLogActionHPrintDoc dflags h d- = defaultLogActionHPutStrDoc dflags h (d $$ text "")--defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> IO ()-defaultLogActionHPutStrDoc dflags h d-  -- Don't add a newline at the end, so that successive-  -- calls to this log-action can output all on the same line-  = printSDoc ctx Pretty.PageMode h d-    where ctx = initSDocContext dflags defaultUserStyle--newtype FlushOut = FlushOut (IO ())--defaultFlushOut :: FlushOut-defaultFlushOut = FlushOut $ hFlush stdout--newtype FlushErr = FlushErr (IO ())--defaultFlushErr :: FlushErr-defaultFlushErr = FlushErr $ hFlush stderr--{--Note [Verbosity levels]-~~~~~~~~~~~~~~~~~~~~~~~-    0   |   print errors & warnings only-    1   |   minimal verbosity: print "compiling M ... done." for each module.-    2   |   equivalent to -dshow-passes-    3   |   equivalent to existing "ghc -v"-    4   |   "ghc -v -ddump-most"-    5   |   "ghc -v -ddump-all"--}--data OnOff a = On a-             | Off a-  deriving (Eq, Show)--instance Outputable a => Outputable (OnOff a) where-  ppr (On x)  = text "On" <+> ppr x-  ppr (Off x) = text "Off" <+> ppr x---- OnOffs accumulate in reverse order, so we use foldr in order to--- process them in the right order-flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension-flattenExtensionFlags ml = foldr f defaultExtensionFlags-    where f (On f)  flags = EnumSet.insert f flags-          f (Off f) flags = EnumSet.delete f flags-          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)---- | The language extensions implied by the various language variants.--- When updating this be sure to update the flag documentation in--- @docs/users_guide/exts@.-languageExtensions :: Maybe Language -> [LangExt.Extension]--languageExtensions Nothing-    -- Nothing => the default case-    = LangExt.NondecreasingIndentation -- This has been on by default for some time-    : delete LangExt.DatatypeContexts  -- The Haskell' committee decided to-                                       -- remove datatype contexts from the-                                       -- language:-   -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html-      (languageExtensions (Just Haskell2010))--   -- NB: MonoPatBinds is no longer the default--languageExtensions (Just Haskell98)-    = [LangExt.ImplicitPrelude,-       -- See Note [When is StarIsType enabled]-       LangExt.StarIsType,-       LangExt.CUSKs,-       LangExt.MonomorphismRestriction,-       LangExt.NPlusKPatterns,-       LangExt.DatatypeContexts,-       LangExt.TraditionalRecordSyntax,-       LangExt.NondecreasingIndentation-           -- strictly speaking non-standard, but we always had this-           -- on implicitly before the option was added in 7.1, and-           -- turning it off breaks code, so we're keeping it on for-           -- backwards compatibility.  Cabal uses -XHaskell98 by-           -- default unless you specify another language.-      ]--languageExtensions (Just Haskell2010)-    = [LangExt.ImplicitPrelude,-       -- See Note [When is StarIsType enabled]-       LangExt.StarIsType,-       LangExt.CUSKs,-       LangExt.MonomorphismRestriction,-       LangExt.DatatypeContexts,-       LangExt.TraditionalRecordSyntax,-       LangExt.EmptyDataDecls,-       LangExt.ForeignFunctionInterface,-       LangExt.PatternGuards,-       LangExt.DoAndIfThenElse,-       LangExt.RelaxedPolyRec]--hasPprDebug :: DynFlags -> Bool-hasPprDebug = dopt Opt_D_ppr_debug--hasNoDebugOutput :: DynFlags -> Bool-hasNoDebugOutput = dopt Opt_D_no_debug_output--hasNoStateHack :: DynFlags -> Bool-hasNoStateHack = gopt Opt_G_NoStateHack--hasNoOptCoercion :: DynFlags -> Bool-hasNoOptCoercion = gopt Opt_G_NoOptCoercion----- | Test whether a 'DumpFlag' is set-dopt :: DumpFlag -> DynFlags -> Bool-dopt f dflags = (f `EnumSet.member` dumpFlags dflags)-             || (verbosity dflags >= 4 && enableIfVerbose f)-    where enableIfVerbose Opt_D_dump_tc_trace               = False-          enableIfVerbose Opt_D_dump_rn_trace               = False-          enableIfVerbose Opt_D_dump_cs_trace               = False-          enableIfVerbose Opt_D_dump_if_trace               = False-          enableIfVerbose Opt_D_dump_vt_trace               = False-          enableIfVerbose Opt_D_dump_tc                     = False-          enableIfVerbose Opt_D_dump_rn                     = False-          enableIfVerbose Opt_D_dump_rn_stats               = False-          enableIfVerbose Opt_D_dump_hi_diffs               = False-          enableIfVerbose Opt_D_verbose_core2core           = False-          enableIfVerbose Opt_D_verbose_stg2stg             = False-          enableIfVerbose Opt_D_dump_splices                = False-          enableIfVerbose Opt_D_th_dec_file                 = False-          enableIfVerbose Opt_D_dump_rule_firings           = False-          enableIfVerbose Opt_D_dump_rule_rewrites          = False-          enableIfVerbose Opt_D_dump_simpl_trace            = False-          enableIfVerbose Opt_D_dump_rtti                   = False-          enableIfVerbose Opt_D_dump_inlinings              = False-          enableIfVerbose Opt_D_dump_verbose_inlinings      = False-          enableIfVerbose Opt_D_dump_core_stats             = False-          enableIfVerbose Opt_D_dump_asm_stats              = False-          enableIfVerbose Opt_D_dump_types                  = False-          enableIfVerbose Opt_D_dump_simpl_iterations       = False-          enableIfVerbose Opt_D_dump_ticked                 = False-          enableIfVerbose Opt_D_dump_view_pattern_commoning = False-          enableIfVerbose Opt_D_dump_mod_cycles             = False-          enableIfVerbose Opt_D_dump_mod_map                = False-          enableIfVerbose Opt_D_dump_ec_trace               = False-          enableIfVerbose _                                 = True---- | Set a 'DumpFlag'-dopt_set :: DynFlags -> DumpFlag -> DynFlags-dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) }---- | Unset a 'DumpFlag'-dopt_unset :: DynFlags -> DumpFlag -> DynFlags-dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }---- | Test whether a 'GeneralFlag' is set-gopt :: GeneralFlag -> DynFlags -> Bool-gopt f dflags  = f `EnumSet.member` generalFlags dflags---- | Set a 'GeneralFlag'-gopt_set :: DynFlags -> GeneralFlag -> DynFlags-gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) }---- | Unset a 'GeneralFlag'-gopt_unset :: DynFlags -> GeneralFlag -> DynFlags-gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) }---- | Test whether a 'WarningFlag' is set-wopt :: WarningFlag -> DynFlags -> Bool-wopt f dflags  = f `EnumSet.member` warningFlags dflags---- | Set a 'WarningFlag'-wopt_set :: DynFlags -> WarningFlag -> DynFlags-wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) }---- | Unset a 'WarningFlag'-wopt_unset :: DynFlags -> WarningFlag -> DynFlags-wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) }---- | Test whether a 'WarningFlag' is set as fatal-wopt_fatal :: WarningFlag -> DynFlags -> Bool-wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags---- | Mark a 'WarningFlag' as fatal (do not set the flag)-wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags-wopt_set_fatal dfs f-    = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) }---- | Mark a 'WarningFlag' as not fatal-wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags-wopt_unset_fatal dfs f-    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }---- | Test whether a 'LangExt.Extension' is set-xopt :: LangExt.Extension -> DynFlags -> Bool-xopt f dflags = f `EnumSet.member` extensionFlags dflags---- | Set a 'LangExt.Extension'-xopt_set :: DynFlags -> LangExt.Extension -> DynFlags-xopt_set dfs f-    = let onoffs = On f : extensions dfs-      in dfs { extensions = onoffs,-               extensionFlags = flattenExtensionFlags (language dfs) onoffs }---- | Unset a 'LangExt.Extension'-xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags-xopt_unset dfs f-    = let onoffs = Off f : extensions dfs-      in dfs { extensions = onoffs,-               extensionFlags = flattenExtensionFlags (language dfs) onoffs }---- | Set or unset a 'LangExt.Extension', unless it has been explicitly---   set or unset before.-xopt_set_unlessExplSpec-        :: LangExt.Extension-        -> (DynFlags -> LangExt.Extension -> DynFlags)-        -> DynFlags -> DynFlags-xopt_set_unlessExplSpec ext setUnset dflags =-    let referedExts = stripOnOff <$> extensions dflags-        stripOnOff (On x)  = x-        stripOnOff (Off x) = x-    in-        if ext `elem` referedExts then dflags else setUnset dflags ext--lang_set :: DynFlags -> Maybe Language -> DynFlags-lang_set dflags lang =-   dflags {-            language = lang,-            extensionFlags = flattenExtensionFlags lang (extensions dflags)-          }---- | Set the Haskell language standard to use-setLanguage :: Language -> DynP ()-setLanguage l = upd (`lang_set` Just l)---- | Some modules have dependencies on others through the DynFlags rather than textual imports-dynFlagDependencies :: DynFlags -> [ModuleName]-dynFlagDependencies = pluginModNames---- | Is the -fpackage-trust mode on-packageTrustOn :: DynFlags -> Bool-packageTrustOn = gopt Opt_PackageTrust---- | Is Safe Haskell on in some way (including inference mode)-safeHaskellOn :: DynFlags -> Bool-safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags--safeHaskellModeEnabled :: DynFlags -> Bool-safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy-                                                   , Sf_Safe ]----- | Is the Safe Haskell safe language in use-safeLanguageOn :: DynFlags -> Bool-safeLanguageOn dflags = safeHaskell dflags == Sf_Safe---- | Is the Safe Haskell safe inference mode active-safeInferOn :: DynFlags -> Bool-safeInferOn = safeInfer---- | Test if Safe Imports are on in some form-safeImportsOn :: DynFlags -> Bool-safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||-                       safeHaskell dflags == Sf_Trustworthy ||-                       safeHaskell dflags == Sf_Safe---- | Set a 'Safe Haskell' flag-setSafeHaskell :: SafeHaskellMode -> DynP ()-setSafeHaskell s = updM f-    where f dfs = do-              let sf = safeHaskell dfs-              safeM <- combineSafeFlags sf s-              case s of-                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }-                -- leave safe inferrence on in Trustworthy mode so we can warn-                -- if it could have been inferred safe.-                Sf_Trustworthy -> do-                  l <- getCurLoc-                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }-                -- leave safe inference on in Unsafe mode as well.-                _ -> return $ dfs { safeHaskell = safeM }---- | Are all direct imports required to be safe for this Safe Haskell mode?--- Direct imports are when the code explicitly imports a module-safeDirectImpsReq :: DynFlags -> Bool-safeDirectImpsReq d = safeLanguageOn d---- | Are all implicit imports required to be safe for this Safe Haskell mode?--- Implicit imports are things in the prelude. e.g System.IO when print is used.-safeImplicitImpsReq :: DynFlags -> Bool-safeImplicitImpsReq d = safeLanguageOn d---- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.--- This makes Safe Haskell very much a monoid but for now I prefer this as I don't--- want to export this functionality from the module but do want to export the--- type constructors.-combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode-combineSafeFlags a b | a == Sf_None         = return b-                     | b == Sf_None         = return a-                     | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore-                     | a == b               = return a-                     | otherwise            = addErr errm >> pure a-    where errm = "Incompatible Safe Haskell flags! ("-                    ++ show a ++ ", " ++ show b ++ ")"---- | A list of unsafe flags under Safe Haskell. Tuple elements are:---     * name of the flag---     * function to get srcspan that enabled the flag---     * function to test if the flag is on---     * function to turn the flag off-unsafeFlags, unsafeFlagsForInfer-  :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]-unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,-                    xopt LangExt.GeneralizedNewtypeDeriving,-                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)-              , ("-XDerivingVia", deriveViaOnLoc,-                    xopt LangExt.DerivingVia,-                    flip xopt_unset LangExt.DerivingVia)-              , ("-XTemplateHaskell", thOnLoc,-                    xopt LangExt.TemplateHaskell,-                    flip xopt_unset LangExt.TemplateHaskell)-              ]-unsafeFlagsForInfer = unsafeFlags----- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order-getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from-        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors-        -> [a]                  -- ^ Correctly ordered extracted options-getOpts dflags opts = reverse (opts dflags)-        -- We add to the options from the front, so we need to reverse the list---- | Gets the verbosity flag for the current verbosity level. This is fed to--- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included-getVerbFlags :: DynFlags -> [String]-getVerbFlags dflags-  | verbosity dflags >= 4 = ["-v"]-  | otherwise             = []--setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,-         setDynObjectSuf, setDynHiSuf,-         setDylibInstallName,-         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,-         setPgmP, addOptl, addOptc, addOptcxx, addOptP,-         addCmdlineFramework, addHaddockOpts, addGhciScript,-         setInteractivePrint-   :: String -> DynFlags -> DynFlags-setOutputFile, setDynOutputFile, setOutputHi, setDumpPrefixForce-   :: Maybe String -> DynFlags -> DynFlags--setObjectDir  f d = d { objectDir  = Just f}-setHiDir      f d = d { hiDir      = Just f}-setHieDir     f d = d { hieDir     = Just f}-setStubDir    f d = d { stubDir    = Just f-                      , includePaths = addGlobalInclude (includePaths d) [f] }-  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file-  -- \#included from the .hc file when compiling via C (i.e. unregisterised-  -- builds).-setDumpDir    f d = d { dumpDir    = Just f}-setOutputDir  f = setObjectDir f-                . setHieDir f-                . setHiDir f-                . setStubDir f-                . setDumpDir f-setDylibInstallName  f d = d { dylibInstallName = Just f}--setObjectSuf    f d = d { objectSuf    = f}-setDynObjectSuf f d = d { dynObjectSuf = f}-setHiSuf        f d = d { hiSuf        = f}-setHieSuf       f d = d { hieSuf       = f}-setDynHiSuf     f d = d { dynHiSuf     = f}-setHcSuf        f d = d { hcSuf        = f}--setOutputFile f d = d { outputFile = f}-setDynOutputFile f d = d { dynOutputFile = f}-setOutputHi   f d = d { outputHi   = f}--setJsonLogAction :: DynFlags -> DynFlags-setJsonLogAction d = d { log_action = jsonLogAction }---- | Make a module in home unit-mkHomeModule :: DynFlags -> ModuleName -> Module-mkHomeModule dflags = mkModule (homeUnit dflags)---- | Test if the module comes from the home unit-isHomeModule :: DynFlags -> Module -> Bool-isHomeModule dflags m = moduleUnit m == homeUnit dflags---- | Get home unit-homeUnit :: DynFlags -> Unit-homeUnit dflags =-   case (homeUnitInstanceOfId dflags, homeUnitInstantiations dflags) of-      (Nothing,[]) -> RealUnit (Definite (homeUnitId dflags))-      (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")-      (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")-      (Just u, is)-         -- detect fully indefinite units: all their instantiations are hole-         -- modules and the home unit id is the same as the instantiating unit-         -- id (see Note [About units] in GHC.Unit)-         | all (isHoleModule . snd) is && indefUnit u == homeUnitId dflags-         -> mkVirtUnit (updateIndefUnitId (unitState dflags) u) is-         -- otherwise it must be that we compile a fully definite units-         -- TODO: error when the unit is partially instantiated??-         | otherwise-         -> RealUnit (Definite (homeUnitId dflags))--parseUnitInsts :: String -> Instantiations-parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of-    [(r, "")] -> r-    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)-  where parse = sepBy parseEntry (R.char ',')-        parseEntry = do-            n <- parseModuleName-            _ <- R.char '='-            m <- parseHoleyModule-            return (n, m)--setUnitInstantiations :: String -> DynFlags -> DynFlags-setUnitInstantiations s d =-    d { homeUnitInstantiations = parseUnitInsts s }--setUnitInstanceOf :: String -> DynFlags -> DynFlags-setUnitInstanceOf s d =-    d { homeUnitInstanceOfId = Just (Indefinite (UnitId (fsLit s)) Nothing) }--addPluginModuleName :: String -> DynFlags -> DynFlags-addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }--clearPluginModuleNames :: DynFlags -> DynFlags-clearPluginModuleNames d =-    d { pluginModNames = []-      , pluginModNameOpts = []-      , cachedPlugins = [] }--addPluginModuleNameOption :: String -> DynFlags -> DynFlags-addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }-  where (m, rest) = break (== ':') optflag-        option = case rest of-          [] -> "" -- should probably signal an error-          (_:plug_opt) -> plug_opt -- ignore the ':' from break--addFrontendPluginOption :: String -> DynFlags -> DynFlags-addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }--parseDynLibLoaderMode f d =- case splitAt 8 f of-   ("deploy", "")       -> d { dynLibLoader = Deployable }-   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }-   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))--setDumpPrefixForce f d = d { dumpPrefixForce = f}---- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]--- Config.hs should really use Option.-setPgmP   f = alterToolSettings (\s -> s { toolSettings_pgm_P   = (pgm, map Option args)})-  where (pgm:args) = words f-addOptl   f = alterToolSettings (\s -> s { toolSettings_opt_l   = f : toolSettings_opt_l s})-addOptc   f = alterToolSettings (\s -> s { toolSettings_opt_c   = f : toolSettings_opt_c s})-addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s})-addOptP   f = alterToolSettings $ \s -> s-          { toolSettings_opt_P   = f : toolSettings_opt_P s-          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)-          }-          -- See Note [Repeated -optP hashing]-  where-  fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss---setDepMakefile :: FilePath -> DynFlags -> DynFlags-setDepMakefile f d = d { depMakefile = f }--setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags-setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }--setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags-setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }--addDepExcludeMod :: String -> DynFlags -> DynFlags-addDepExcludeMod m d-    = d { depExcludeMods = mkModuleName m : depExcludeMods d }--addDepSuffix :: FilePath -> DynFlags -> DynFlags-addDepSuffix s d = d { depSuffixes = s : depSuffixes d }--addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}--addGhcVersionFile :: FilePath -> DynFlags -> DynFlags-addGhcVersionFile f d = d { ghcVersionFile = Just f }--addHaddockOpts f d = d { haddockOptions = Just f}--addGhciScript f d = d { ghciScripts = f : ghciScripts d}--setInteractivePrint f d = d { interactivePrint = Just f}---------------------------------------------------------------------------------- Setting the optimisation level--updOptLevel :: Int -> DynFlags -> DynFlags--- ^ Sets the 'DynFlags' to be appropriate to the optimisation level-updOptLevel n dfs-  = dfs2{ optLevel = final_n }-  where-   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2-   dfs1 = foldr (flip gopt_unset) dfs  remove_gopts-   dfs2 = foldr (flip gopt_set)   dfs1 extra_gopts--   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]-   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]--{- **********************************************************************-%*                                                                      *-                DynFlags parser-%*                                                                      *-%********************************************************************* -}---- -------------------------------------------------------------------------------- Parsing the dynamic flags.----- | Parse dynamic flags from a list of command line arguments.  Returns--- the parsed 'DynFlags', the left-over arguments, and a list of warnings.--- Throws a 'UsageError' if errors occurred during parsing (such as unknown--- flags or missing arguments).-parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]-                         -> m (DynFlags, [Located String], [Warn])-                            -- ^ Updated 'DynFlags', left-over arguments, and-                            -- list of warnings.-parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True----- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags--- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).--- Used to parse flags set in a modules pragma.-parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]-                       -> m (DynFlags, [Located String], [Warn])-                          -- ^ Updated 'DynFlags', left-over arguments, and-                          -- list of warnings.-parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False----- | Parses the dynamically set flags for GHC. This is the most general form of--- the dynamic flag parser that the other methods simply wrap. It allows--- saying which flags are valid flags and indicating if we are parsing--- arguments from the command line or from a file pragma.-parseDynamicFlagsFull :: MonadIO m-                  => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against-                  -> Bool                          -- ^ are the arguments from the command line?-                  -> DynFlags                      -- ^ current dynamic flags-                  -> [Located String]              -- ^ arguments to parse-                  -> m (DynFlags, [Located String], [Warn])-parseDynamicFlagsFull activeFlags cmdline dflags0 args = do-  let ((leftover, errs, warns), dflags1)-          = runCmdLine (processArgs activeFlags args) dflags0--  -- See Note [Handling errors when parsing commandline flags]-  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $-    map ((showPpr dflags0 . getLoc &&& unLoc) . errMsg) $ errs--  -- check for disabled flags in safe haskell-  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1-      theWays = ways dflags2--  unless (allowed_combination theWays) $ liftIO $-      throwGhcExceptionIO (CmdLineError ("combination not supported: " ++-                               intercalate "/" (map wayDesc (Set.toAscList theWays))))--  let chooseOutput-        | isJust (outputFile dflags2)          -- Only iff user specified -o ...-        , not (isJust (dynOutputFile dflags2)) -- but not -dyno-        = return $ dflags2 { dynOutputFile = Just $ dynamicOutputFile dflags2 outFile }-        | otherwise-        = return dflags2-        where-          outFile = fromJust $ outputFile dflags2-  dflags3 <- ifGeneratingDynamicToo dflags2 chooseOutput (return dflags2)--  let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3--  -- Set timer stats & heap size-  when (enableTimeStats dflags4) $ liftIO enableTimingStats-  case (ghcHeapSize dflags4) of-    Just x -> liftIO (setHeapSize x)-    _      -> return ()--  liftIO $ setUnsafeGlobalDynFlags dflags4--  let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)--  return (dflags4, leftover, warns' ++ warns)---- | Write an error or warning to the 'LogOutput'.-putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> MsgDoc -> IO ()-putLogMsg dflags = log_action dflags dflags---- | Check (and potentially disable) any extensions that aren't allowed--- in safe mode.------ The bool is to indicate if we are parsing command line flags (false means--- file pragma). This allows us to generate better warnings.-safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])-safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)-  where-    -- Handle illegal flags under safe language.-    (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags--    check_method (df, warns) (str,loc,test,fix)-        | test df   = (fix df, warns ++ safeFailure (loc df) str)-        | otherwise = (df, warns)--    safeFailure loc str-       = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring "-           ++ str]--safeFlagCheck cmdl dflags =-  case (safeInferOn dflags) of-    True | safeFlags -> (dflags', warn)-    True             -> (dflags' { safeInferred = False }, warn)-    False            -> (dflags', warn)--  where-    -- dynflags and warn for when -fpackage-trust by itself with no safe-    -- haskell flag-    (dflags', warn)-      | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags-      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)-      | otherwise = (dflags, [])--    pkgWarnMsg = [L (pkgTrustOnLoc dflags') $-                    "-fpackage-trust ignored;" ++-                    " must be specified with a Safe Haskell flag"]--    -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference]-    safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer---{- **********************************************************************-%*                                                                      *-                DynFlags specifications-%*                                                                      *-%********************************************************************* -}---- | All dynamic flags option strings without the deprecated ones.--- These are the user facing strings for enabling and disabling options.-allNonDeprecatedFlags :: [String]-allNonDeprecatedFlags = allFlagsDeps False---- | All flags with possibility to filter deprecated ones-allFlagsDeps :: Bool -> [String]-allFlagsDeps keepDeprecated = [ '-':flagName flag-                              | (deprecated, flag) <- flagsAllDeps-                              , keepDeprecated || not (isDeprecated deprecated)]-  where isDeprecated Deprecated = True-        isDeprecated _ = False--{-- - Below we export user facing symbols for GHC dynamic flags for use with the- - GHC API.- -}---- All dynamic flags present in GHC.-flagsAll :: [Flag (CmdLineP DynFlags)]-flagsAll = map snd flagsAllDeps---- All dynamic flags present in GHC with deprecation information.-flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]-flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps----- All dynamic flags, minus package flags, present in GHC.-flagsDynamic :: [Flag (CmdLineP DynFlags)]-flagsDynamic = map snd dynamic_flags_deps---- ALl package flags present in GHC.-flagsPackage :: [Flag (CmdLineP DynFlags)]-flagsPackage = map snd package_flags_deps------------------Helpers to make flags and keep deprecation information------------type FlagMaker m = String -> OptKind m -> Flag m-type DynFlagMaker = FlagMaker (CmdLineP DynFlags)-data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord)---- Make a non-deprecated flag-make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)-              -> (Deprecation, Flag (CmdLineP DynFlags))-make_ord_flag fm name kind = (NotDeprecated, fm name kind)---- Make a deprecated flag-make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String-                 -> (Deprecation, Flag (CmdLineP DynFlags))-make_dep_flag fm name kind message = (Deprecated,-                                      fm name $ add_dep_message kind message)--add_dep_message :: OptKind (CmdLineP DynFlags) -> String-                -> OptKind (CmdLineP DynFlags)-add_dep_message (NoArg f) message = NoArg $ f >> deprecate message-add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message-add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message-add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message-add_dep_message (OptPrefix f) message =-                                  OptPrefix $ \s -> f s >> deprecate message-add_dep_message (OptIntSuffix f) message =-                               OptIntSuffix $ \oi -> f oi >> deprecate message-add_dep_message (IntSuffix f) message =-                                  IntSuffix $ \i -> f i >> deprecate message-add_dep_message (FloatSuffix f) message =-                                FloatSuffix $ \fl -> f fl >> deprecate message-add_dep_message (PassFlag f) message =-                                   PassFlag $ \s -> f s >> deprecate message-add_dep_message (AnySuffix f) message =-                                  AnySuffix $ \s -> f s >> deprecate message------------------------- The main flags themselves --------------------------------- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]-dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]-dynamic_flags_deps = [-    make_dep_flag defFlag "n" (NoArg $ return ())-        "The -n flag is deprecated and no longer has any effect"-  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))-  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))-  , (Deprecated, defFlag "#include"-      (HasArg (\_s ->-         deprecate ("-#include and INCLUDE pragmas are " ++-                    "deprecated: They no longer have any effect"))))-  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)--  , make_ord_flag defGhcFlag "j"     (OptIntSuffix-        (\n -> case n of-                 Just n-                     | n > 0     -> upd (\d -> d { parMakeCount = Just n })-                     | otherwise -> addErr "Syntax: -j[n] where n > 0"-                 Nothing -> upd (\d -> d { parMakeCount = Nothing })))-                 -- When the number of parallel builds-                 -- is omitted, it is the same-                 -- as specifying that the number of-                 -- parallel builds is equal to the-                 -- result of getNumProcessors-  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)-  , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)--    -- RTS options --------------------------------------------------------------  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->-          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))--  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->-                                               d { enableTimeStats = True })))--    ------- ways ----------------------------------------------------------------  , make_ord_flag defGhcFlag "prof"           (NoArg (addWay WayProf))-  , make_ord_flag defGhcFlag "eventlog"       (NoArg (addWay WayEventLog))-  , make_ord_flag defGhcFlag "debug"          (NoArg (addWay WayDebug))-  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWay WayThreaded))--  , make_ord_flag defGhcFlag "ticky"-      (NoArg (setGeneralFlag Opt_Ticky >> addWay WayDebug))--    -- -ticky enables ticky-ticky code generation, and also implies -debug which-    -- is required to get the RTS ticky support.--        ----- Linker ---------------------------------------------------------  , make_ord_flag defGhcFlag "static"         (NoArg removeWayDyn)-  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWay WayDyn))-  , make_ord_flag defGhcFlag "rdynamic" $ noArg $-#if defined(linux_HOST_OS)-                              addOptl "-rdynamic"-#elif defined(mingw32_HOST_OS)-                              addOptl "-Wl,--export-all-symbols"-#else-    -- ignored for compat w/ gcc:-                              id-#endif-  , make_ord_flag defGhcFlag "relative-dynlib-paths"-      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))-  , make_ord_flag defGhcFlag "copy-libs-when-linking"-      (NoArg (setGeneralFlag Opt_SingleLibFolder))-  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))-  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))--        ------- Specific phases  ---------------------------------------------    -- need to appear before -pgmL to be parsed as LLVM flags.-  , make_ord_flag defFlag "pgmlo"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }-  , make_ord_flag defFlag "pgmlc"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }-  , make_ord_flag defFlag "pgmlm"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  = (f,[]) }-  , make_ord_flag defFlag "pgmi"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i   =  f }-  , make_ord_flag defFlag "pgmL"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L   = f }-  , make_ord_flag defFlag "pgmP"-      (hasArg setPgmP)-  , make_ord_flag defFlag "pgmF"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F   = f }-  , make_ord_flag defFlag "pgmc"-      $ hasArg $ \f -> alterToolSettings $ \s -> s-         { toolSettings_pgm_c   = f-         , -- Don't pass -no-pie with -pgmc-           -- (see #15319)-           toolSettings_ccSupportsNoPie = False-         }-  , make_ord_flag defFlag "pgmc-supports-no-pie"-      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }-  , make_ord_flag defFlag "pgms"-      (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8"))-  , make_ord_flag defFlag "pgma"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a   = (f,[]) }-  , make_ord_flag defFlag "pgml"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l   = (f,[]) }-  , make_ord_flag defFlag "pgmdll"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) }-  , make_ord_flag defFlag "pgmwindres"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }-  , make_ord_flag defFlag "pgmlibtool"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f }-  , make_ord_flag defFlag "pgmar"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f }-  , make_ord_flag defFlag "pgmotool"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f}-  , make_ord_flag defFlag "pgminstall_name_tool"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f}-  , make_ord_flag defFlag "pgmranlib"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f }---    -- need to appear before -optl/-opta to be parsed as LLVM flags.-  , make_ord_flag defFlag "optlm"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm  = f : toolSettings_opt_lm s }-  , make_ord_flag defFlag "optlo"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }-  , make_ord_flag defFlag "optlc"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }-  , make_ord_flag defFlag "opti"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }-  , make_ord_flag defFlag "optL"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L   = f : toolSettings_opt_L s }-  , make_ord_flag defFlag "optP"-      (hasArg addOptP)-  , make_ord_flag defFlag "optF"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F   = f : toolSettings_opt_F s }-  , make_ord_flag defFlag "optc"-      (hasArg addOptc)-  , make_ord_flag defFlag "optcxx"-      (hasArg addOptcxx)-  , make_ord_flag defFlag "opta"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a   = f : toolSettings_opt_a s }-  , make_ord_flag defFlag "optl"-      (hasArg addOptl)-  , make_ord_flag defFlag "optwindres"-      $ hasArg $ \f ->-        alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s }--  , make_ord_flag defGhcFlag "split-objs"-      (NoArg $ addWarn "ignoring -split-objs")--  , make_ord_flag defGhcFlag "split-sections"-      (noArgM (\dflags -> do-        if platformHasSubsectionsViaSymbols (targetPlatform dflags)-          then do addWarn $-                    "-split-sections is not useful on this platform " ++-                    "since it always uses subsections via symbols. Ignoring."-                  return dflags-          else return (gopt_set dflags Opt_SplitSections)))--        -------- ghc -M ------------------------------------------------------  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)-  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)-  , make_ord_flag defGhcFlag "include-cpp-deps"-        (noArg (setDepIncludeCppDeps True))-  , make_ord_flag defGhcFlag "include-pkg-deps"-        (noArg (setDepIncludePkgDeps True))-  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)--        -------- Linking -----------------------------------------------------  , make_ord_flag defGhcFlag "no-link"-        (noArg (\d -> d { ghcLink=NoLink }))-  , make_ord_flag defGhcFlag "shared"-        (noArg (\d -> d { ghcLink=LinkDynLib }))-  , make_ord_flag defGhcFlag "staticlib"-        (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))-  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)-  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)--        ------- Libraries ----------------------------------------------------  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)-  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))--        ------- Frameworks ---------------------------------------------------        -- -framework-path should really be -F ...-  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)-  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)--        ------- Output Redirection -------------------------------------------  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)-  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))-  , make_ord_flag defGhcFlag "dyno"-        (sepArg (setDynOutputFile . Just))-  , make_ord_flag defGhcFlag "ohi"-        (hasArg (setOutputHi . Just ))-  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)-  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)-  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)-  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)-  , make_ord_flag defGhcFlag "hiesuf"            (hasArg setHieSuf)-  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)-  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)-  , make_ord_flag defGhcFlag "hiedir"            (hasArg setHieDir)-  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)-  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)-  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)-  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)-  , make_ord_flag defGhcFlag "ddump-file-prefix"-        (hasArg (setDumpPrefixForce . Just))--  , make_ord_flag defGhcFlag "dynamic-too"-        (NoArg (setGeneralFlag Opt_BuildDynamicToo))--        ------- Keeping temporary files --------------------------------------     -- These can be singular (think ghc -c) or plural (think ghc --make)-  , make_ord_flag defGhcFlag "keep-hc-file"-        (NoArg (setGeneralFlag Opt_KeepHcFiles))-  , make_ord_flag defGhcFlag "keep-hc-files"-        (NoArg (setGeneralFlag Opt_KeepHcFiles))-  , make_ord_flag defGhcFlag "keep-hscpp-file"-        (NoArg (setGeneralFlag Opt_KeepHscppFiles))-  , make_ord_flag defGhcFlag "keep-hscpp-files"-        (NoArg (setGeneralFlag Opt_KeepHscppFiles))-  , make_ord_flag defGhcFlag "keep-s-file"-        (NoArg (setGeneralFlag Opt_KeepSFiles))-  , make_ord_flag defGhcFlag "keep-s-files"-        (NoArg (setGeneralFlag Opt_KeepSFiles))-  , make_ord_flag defGhcFlag "keep-llvm-file"-        (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles)-  , make_ord_flag defGhcFlag "keep-llvm-files"-        (NoArg $ setObjTarget HscLlvm >> setGeneralFlag Opt_KeepLlvmFiles)-     -- This only makes sense as plural-  , make_ord_flag defGhcFlag "keep-tmp-files"-        (NoArg (setGeneralFlag Opt_KeepTmpFiles))-  , make_ord_flag defGhcFlag "keep-hi-file"-        (NoArg (setGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "no-keep-hi-file"-        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "keep-hi-files"-        (NoArg (setGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "no-keep-hi-files"-        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))-  , make_ord_flag defGhcFlag "keep-o-file"-        (NoArg (setGeneralFlag Opt_KeepOFiles))-  , make_ord_flag defGhcFlag "no-keep-o-file"-        (NoArg (unSetGeneralFlag Opt_KeepOFiles))-  , make_ord_flag defGhcFlag "keep-o-files"-        (NoArg (setGeneralFlag Opt_KeepOFiles))-  , make_ord_flag defGhcFlag "no-keep-o-files"-        (NoArg (unSetGeneralFlag Opt_KeepOFiles))--        ------- Miscellaneous -----------------------------------------------  , make_ord_flag defGhcFlag "no-auto-link-packages"-        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))-  , make_ord_flag defGhcFlag "no-hs-main"-        (NoArg (setGeneralFlag Opt_NoHsMain))-  , make_ord_flag defGhcFlag "fno-state-hack"-        (NoArg (setGeneralFlag Opt_G_NoStateHack))-  , make_ord_flag defGhcFlag "fno-opt-coercion"-        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))-  , make_ord_flag defGhcFlag "with-rtsopts"-        (HasArg setRtsOpts)-  , make_ord_flag defGhcFlag "rtsopts"-        (NoArg (setRtsOptsEnabled RtsOptsAll))-  , make_ord_flag defGhcFlag "rtsopts=all"-        (NoArg (setRtsOptsEnabled RtsOptsAll))-  , make_ord_flag defGhcFlag "rtsopts=some"-        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))-  , make_ord_flag defGhcFlag "rtsopts=none"-        (NoArg (setRtsOptsEnabled RtsOptsNone))-  , make_ord_flag defGhcFlag "rtsopts=ignore"-        (NoArg (setRtsOptsEnabled RtsOptsIgnore))-  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"-        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))-  , make_ord_flag defGhcFlag "no-rtsopts"-        (NoArg (setRtsOptsEnabled RtsOptsNone))-  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"-      (noArg (\d -> d {rtsOptsSuggestions = False}))-  , make_ord_flag defGhcFlag "dhex-word-literals"-        (NoArg (setGeneralFlag Opt_HexWordLiterals))--  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)-  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)-  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))-  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))-  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)-  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)-  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)-  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)-  , make_ord_flag defGhcFlag "ticky-allocd"-        (NoArg (setGeneralFlag Opt_Ticky_Allocd))-  , make_ord_flag defGhcFlag "ticky-LNE"-        (NoArg (setGeneralFlag Opt_Ticky_LNE))-  , make_ord_flag defGhcFlag "ticky-dyn-thunk"-        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))-        ------- recompilation checker ---------------------------------------  , make_dep_flag defGhcFlag "recomp"-        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)-             "Use -fno-force-recomp instead"-  , make_dep_flag defGhcFlag "no-recomp"-        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"-  , make_ord_flag defFlag "fmax-errors"-      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))-  , make_ord_flag defFlag "fno-max-errors"-      (noArg (\d -> d { maxErrors = Nothing }))-  , make_ord_flag defFlag "freverse-errors"-        (noArg (\d -> d {reverseErrors = True} ))-  , make_ord_flag defFlag "fno-reverse-errors"-        (noArg (\d -> d {reverseErrors = False} ))--        ------ HsCpp opts ----------------------------------------------------  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))-  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))--        ------- Include/Import Paths -----------------------------------------  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)-  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)--        ------ Output style options ------------------------------------------  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->-                                                       d { pprUserLength = n }))-  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->-                                                             d { pprCols = n }))-  , make_ord_flag defFlag "fdiagnostics-color=auto"-      (NoArg (upd (\d -> d { useColor = Auto })))-  , make_ord_flag defFlag "fdiagnostics-color=always"-      (NoArg (upd (\d -> d { useColor = Always })))-  , make_ord_flag defFlag "fdiagnostics-color=never"-      (NoArg (upd (\d -> d { useColor = Never })))--  -- Suppress all that is suppressable in core dumps.-  -- Except for uniques, as some simplifier phases introduce new variables that-  -- have otherwise identical names.-  , make_ord_flag defGhcFlag "dsuppress-all"-      (NoArg $ do setGeneralFlag Opt_SuppressCoercions-                  setGeneralFlag Opt_SuppressVarKinds-                  setGeneralFlag Opt_SuppressModulePrefixes-                  setGeneralFlag Opt_SuppressTypeApplications-                  setGeneralFlag Opt_SuppressIdInfo-                  setGeneralFlag Opt_SuppressTicks-                  setGeneralFlag Opt_SuppressStgExts-                  setGeneralFlag Opt_SuppressTypeSignatures-                  setGeneralFlag Opt_SuppressTimestamps)--        ------ Debugging -----------------------------------------------------  , make_ord_flag defGhcFlag "dstg-stats"-        (NoArg (setGeneralFlag Opt_StgStats))--  , make_ord_flag defGhcFlag "ddump-cmm"-        (setDumpFlag Opt_D_dump_cmm)-  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"-        (setDumpFlag Opt_D_dump_cmm_from_stg)-  , make_ord_flag defGhcFlag "ddump-cmm-raw"-        (setDumpFlag Opt_D_dump_cmm_raw)-  , make_ord_flag defGhcFlag "ddump-cmm-verbose"-        (setDumpFlag Opt_D_dump_cmm_verbose)-  , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc"-        (setDumpFlag Opt_D_dump_cmm_verbose_by_proc)-  , make_ord_flag defGhcFlag "ddump-cmm-cfg"-        (setDumpFlag Opt_D_dump_cmm_cfg)-  , make_ord_flag defGhcFlag "ddump-cmm-cbe"-        (setDumpFlag Opt_D_dump_cmm_cbe)-  , make_ord_flag defGhcFlag "ddump-cmm-switch"-        (setDumpFlag Opt_D_dump_cmm_switch)-  , make_ord_flag defGhcFlag "ddump-cmm-proc"-        (setDumpFlag Opt_D_dump_cmm_proc)-  , make_ord_flag defGhcFlag "ddump-cmm-sp"-        (setDumpFlag Opt_D_dump_cmm_sp)-  , make_ord_flag defGhcFlag "ddump-cmm-sink"-        (setDumpFlag Opt_D_dump_cmm_sink)-  , make_ord_flag defGhcFlag "ddump-cmm-caf"-        (setDumpFlag Opt_D_dump_cmm_caf)-  , make_ord_flag defGhcFlag "ddump-cmm-procmap"-        (setDumpFlag Opt_D_dump_cmm_procmap)-  , make_ord_flag defGhcFlag "ddump-cmm-split"-        (setDumpFlag Opt_D_dump_cmm_split)-  , make_ord_flag defGhcFlag "ddump-cmm-info"-        (setDumpFlag Opt_D_dump_cmm_info)-  , make_ord_flag defGhcFlag "ddump-cmm-cps"-        (setDumpFlag Opt_D_dump_cmm_cps)-  , make_ord_flag defGhcFlag "ddump-cmm-opt"-        (setDumpFlag Opt_D_dump_opt_cmm)-  , make_ord_flag defGhcFlag "ddump-cfg-weights"-        (setDumpFlag Opt_D_dump_cfg_weights)-  , make_ord_flag defGhcFlag "ddump-core-stats"-        (setDumpFlag Opt_D_dump_core_stats)-  , make_ord_flag defGhcFlag "ddump-asm"-        (setDumpFlag Opt_D_dump_asm)-  , make_ord_flag defGhcFlag "ddump-asm-native"-        (setDumpFlag Opt_D_dump_asm_native)-  , make_ord_flag defGhcFlag "ddump-asm-liveness"-        (setDumpFlag Opt_D_dump_asm_liveness)-  , make_ord_flag defGhcFlag "ddump-asm-regalloc"-        (setDumpFlag Opt_D_dump_asm_regalloc)-  , make_ord_flag defGhcFlag "ddump-asm-conflicts"-        (setDumpFlag Opt_D_dump_asm_conflicts)-  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"-        (setDumpFlag Opt_D_dump_asm_regalloc_stages)-  , make_ord_flag defGhcFlag "ddump-asm-stats"-        (setDumpFlag Opt_D_dump_asm_stats)-  , make_ord_flag defGhcFlag "ddump-asm-expanded"-        (setDumpFlag Opt_D_dump_asm_expanded)-  , make_ord_flag defGhcFlag "ddump-llvm"-        (NoArg $ setObjTarget HscLlvm >> setDumpFlag' Opt_D_dump_llvm)-  , make_ord_flag defGhcFlag "ddump-deriv"-        (setDumpFlag Opt_D_dump_deriv)-  , make_ord_flag defGhcFlag "ddump-ds"-        (setDumpFlag Opt_D_dump_ds)-  , make_ord_flag defGhcFlag "ddump-ds-preopt"-        (setDumpFlag Opt_D_dump_ds_preopt)-  , make_ord_flag defGhcFlag "ddump-foreign"-        (setDumpFlag Opt_D_dump_foreign)-  , make_ord_flag defGhcFlag "ddump-inlinings"-        (setDumpFlag Opt_D_dump_inlinings)-  , make_ord_flag defGhcFlag "ddump-verbose-inlinings"-        (setDumpFlag Opt_D_dump_verbose_inlinings)-  , make_ord_flag defGhcFlag "ddump-rule-firings"-        (setDumpFlag Opt_D_dump_rule_firings)-  , make_ord_flag defGhcFlag "ddump-rule-rewrites"-        (setDumpFlag Opt_D_dump_rule_rewrites)-  , make_ord_flag defGhcFlag "ddump-simpl-trace"-        (setDumpFlag Opt_D_dump_simpl_trace)-  , make_ord_flag defGhcFlag "ddump-occur-anal"-        (setDumpFlag Opt_D_dump_occur_anal)-  , make_ord_flag defGhcFlag "ddump-parsed"-        (setDumpFlag Opt_D_dump_parsed)-  , make_ord_flag defGhcFlag "ddump-parsed-ast"-        (setDumpFlag Opt_D_dump_parsed_ast)-  , make_ord_flag defGhcFlag "ddump-rn"-        (setDumpFlag Opt_D_dump_rn)-  , make_ord_flag defGhcFlag "ddump-rn-ast"-        (setDumpFlag Opt_D_dump_rn_ast)-  , make_ord_flag defGhcFlag "ddump-simpl"-        (setDumpFlag Opt_D_dump_simpl)-  , make_ord_flag defGhcFlag "ddump-simpl-iterations"-      (setDumpFlag Opt_D_dump_simpl_iterations)-  , make_ord_flag defGhcFlag "ddump-spec"-        (setDumpFlag Opt_D_dump_spec)-  , make_ord_flag defGhcFlag "ddump-prep"-        (setDumpFlag Opt_D_dump_prep)-  , make_ord_flag defGhcFlag "ddump-stg"-        (setDumpFlag Opt_D_dump_stg)-  , make_ord_flag defGhcFlag "ddump-stg-unarised"-        (setDumpFlag Opt_D_dump_stg_unarised)-  , make_ord_flag defGhcFlag "ddump-stg-final"-        (setDumpFlag Opt_D_dump_stg_final)-  , make_ord_flag defGhcFlag "ddump-call-arity"-        (setDumpFlag Opt_D_dump_call_arity)-  , make_ord_flag defGhcFlag "ddump-exitify"-        (setDumpFlag Opt_D_dump_exitify)-  , make_ord_flag defGhcFlag "ddump-stranal"-        (setDumpFlag Opt_D_dump_stranal)-  , make_ord_flag defGhcFlag "ddump-str-signatures"-        (setDumpFlag Opt_D_dump_str_signatures)-  , make_ord_flag defGhcFlag "ddump-cpranal"-        (setDumpFlag Opt_D_dump_cpranal)-  , make_ord_flag defGhcFlag "ddump-cpr-signatures"-        (setDumpFlag Opt_D_dump_cpr_signatures)-  , make_ord_flag defGhcFlag "ddump-tc"-        (setDumpFlag Opt_D_dump_tc)-  , make_ord_flag defGhcFlag "ddump-tc-ast"-        (setDumpFlag Opt_D_dump_tc_ast)-  , make_ord_flag defGhcFlag "ddump-hie"-        (setDumpFlag Opt_D_dump_hie)-  , make_ord_flag defGhcFlag "ddump-types"-        (setDumpFlag Opt_D_dump_types)-  , make_ord_flag defGhcFlag "ddump-rules"-        (setDumpFlag Opt_D_dump_rules)-  , make_ord_flag defGhcFlag "ddump-cse"-        (setDumpFlag Opt_D_dump_cse)-  , make_ord_flag defGhcFlag "ddump-worker-wrapper"-        (setDumpFlag Opt_D_dump_worker_wrapper)-  , make_ord_flag defGhcFlag "ddump-rn-trace"-        (setDumpFlag Opt_D_dump_rn_trace)-  , make_ord_flag defGhcFlag "ddump-if-trace"-        (setDumpFlag Opt_D_dump_if_trace)-  , make_ord_flag defGhcFlag "ddump-cs-trace"-        (setDumpFlag Opt_D_dump_cs_trace)-  , make_ord_flag defGhcFlag "ddump-tc-trace"-        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace-                   setDumpFlag' Opt_D_dump_cs_trace))-  , make_ord_flag defGhcFlag "ddump-ec-trace"-        (setDumpFlag Opt_D_dump_ec_trace)-  , make_ord_flag defGhcFlag "ddump-vt-trace"-        (setDumpFlag Opt_D_dump_vt_trace)-  , make_ord_flag defGhcFlag "ddump-splices"-        (setDumpFlag Opt_D_dump_splices)-  , make_ord_flag defGhcFlag "dth-dec-file"-        (setDumpFlag Opt_D_th_dec_file)--  , make_ord_flag defGhcFlag "ddump-rn-stats"-        (setDumpFlag Opt_D_dump_rn_stats)-  , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt-        (setDumpFlag Opt_D_dump_opt_cmm)-  , make_ord_flag defGhcFlag "ddump-simpl-stats"-        (setDumpFlag Opt_D_dump_simpl_stats)-  , make_ord_flag defGhcFlag "ddump-bcos"-        (setDumpFlag Opt_D_dump_BCOs)-  , make_ord_flag defGhcFlag "dsource-stats"-        (setDumpFlag Opt_D_source_stats)-  , make_ord_flag defGhcFlag "dverbose-core2core"-        (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core)-  , make_ord_flag defGhcFlag "dverbose-stg2stg"-        (setDumpFlag Opt_D_verbose_stg2stg)-  , make_ord_flag defGhcFlag "ddump-hi"-        (setDumpFlag Opt_D_dump_hi)-  , make_ord_flag defGhcFlag "ddump-minimal-imports"-        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))-  , make_ord_flag defGhcFlag "ddump-hpc"-        (setDumpFlag Opt_D_dump_ticked) -- back compat-  , make_ord_flag defGhcFlag "ddump-ticked"-        (setDumpFlag Opt_D_dump_ticked)-  , make_ord_flag defGhcFlag "ddump-mod-cycles"-        (setDumpFlag Opt_D_dump_mod_cycles)-  , make_ord_flag defGhcFlag "ddump-mod-map"-        (setDumpFlag Opt_D_dump_mod_map)-  , make_ord_flag defGhcFlag "ddump-timings"-        (setDumpFlag Opt_D_dump_timings)-  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"-        (setDumpFlag Opt_D_dump_view_pattern_commoning)-  , make_ord_flag defGhcFlag "ddump-to-file"-        (NoArg (setGeneralFlag Opt_DumpToFile))-  , make_ord_flag defGhcFlag "ddump-hi-diffs"-        (setDumpFlag Opt_D_dump_hi_diffs)-  , make_ord_flag defGhcFlag "ddump-rtti"-        (setDumpFlag Opt_D_dump_rtti)-  , make_ord_flag defGhcFlag "dcore-lint"-        (NoArg (setGeneralFlag Opt_DoCoreLinting))-  , make_ord_flag defGhcFlag "dlinear-core-lint"-        (NoArg (setGeneralFlag Opt_DoLinearCoreLinting))-  , make_ord_flag defGhcFlag "dstg-lint"-        (NoArg (setGeneralFlag Opt_DoStgLinting))-  , make_ord_flag defGhcFlag "dcmm-lint"-        (NoArg (setGeneralFlag Opt_DoCmmLinting))-  , make_ord_flag defGhcFlag "dasm-lint"-        (NoArg (setGeneralFlag Opt_DoAsmLinting))-  , make_ord_flag defGhcFlag "dannot-lint"-        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))-  , make_ord_flag defGhcFlag "dshow-passes"-        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))-  , make_ord_flag defGhcFlag "dfaststring-stats"-        (NoArg (setGeneralFlag Opt_D_faststring_stats))-  , make_ord_flag defGhcFlag "dno-llvm-mangler"-        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag-  , make_ord_flag defGhcFlag "dno-typeable-binds"-        (NoArg (setGeneralFlag Opt_NoTypeableBinds))-  , make_ord_flag defGhcFlag "ddump-debug"-        (setDumpFlag Opt_D_dump_debug)-  , make_ord_flag defGhcFlag "ddump-json"-        (noArg (flip dopt_set Opt_D_dump_json . setJsonLogAction ) )-  , make_ord_flag defGhcFlag "dppr-debug"-        (setDumpFlag Opt_D_ppr_debug)-  , make_ord_flag defGhcFlag "ddebug-output"-        (noArg (flip dopt_unset Opt_D_no_debug_output))-  , make_ord_flag defGhcFlag "dno-debug-output"-        (setDumpFlag Opt_D_no_debug_output)--        ------ Machine dependent (-m<blah>) stuff -----------------------------  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->-                                                  d { sseVersion = Just SSE1 }))-  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->-                                                  d { sseVersion = Just SSE2 }))-  , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->-                                                  d { sseVersion = Just SSE3 }))-  , make_ord_flag defGhcFlag "msse4"        (noArg (\d ->-                                                  d { sseVersion = Just SSE4 }))-  , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->-                                                 d { sseVersion = Just SSE42 }))-  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->-                                                 d { bmiVersion = Just BMI1 }))-  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->-                                                 d { bmiVersion = Just BMI2 }))-  , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))-  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))-  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->-                                                         d { avx512cd = True }))-  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->-                                                         d { avx512er = True }))-  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))-  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->-                                                         d { avx512pf = True }))--     ------ Warning opts --------------------------------------------------  , make_ord_flag defFlag "W"       (NoArg (mapM_ setWarningFlag minusWOpts))-  , make_ord_flag defFlag "Werror"-               (NoArg (do { setGeneralFlag Opt_WarnIsError-                          ; mapM_ setFatalWarningFlag minusWeverythingOpts   }))-  , make_ord_flag defFlag "Wwarn"-               (NoArg (do { unSetGeneralFlag Opt_WarnIsError-                          ; mapM_ unSetFatalWarningFlag minusWeverythingOpts }))-                          -- Opt_WarnIsError is still needed to pass -Werror-                          -- to CPP; see runCpp in SysTools-  , make_dep_flag defFlag "Wnot"    (NoArg (upd (\d ->-                                              d {warningFlags = EnumSet.empty})))-                                             "Use -w or -Wno-everything instead"-  , make_ord_flag defFlag "w"       (NoArg (upd (\d ->-                                              d {warningFlags = EnumSet.empty})))--     -- New-style uniform warning sets-     ---     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything-  , make_ord_flag defFlag "Weverything"    (NoArg (mapM_-                                           setWarningFlag minusWeverythingOpts))-  , make_ord_flag defFlag "Wno-everything"-                           (NoArg (upd (\d -> d {warningFlags = EnumSet.empty})))--  , make_ord_flag defFlag "Wall"           (NoArg (mapM_-                                                  setWarningFlag minusWallOpts))-  , make_ord_flag defFlag "Wno-all"        (NoArg (mapM_-                                                unSetWarningFlag minusWallOpts))--  , make_ord_flag defFlag "Wextra"         (NoArg (mapM_-                                                     setWarningFlag minusWOpts))-  , make_ord_flag defFlag "Wno-extra"      (NoArg (mapM_-                                                   unSetWarningFlag minusWOpts))--  , make_ord_flag defFlag "Wdefault"       (NoArg (mapM_-                                               setWarningFlag standardWarnings))-  , make_ord_flag defFlag "Wno-default"    (NoArg (mapM_-                                             unSetWarningFlag standardWarnings))--  , make_ord_flag defFlag "Wcompat"        (NoArg (mapM_-                                               setWarningFlag minusWcompatOpts))-  , make_ord_flag defFlag "Wno-compat"     (NoArg (mapM_-                                             unSetWarningFlag minusWcompatOpts))--        ------ Plugin flags -------------------------------------------------  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)-  , make_ord_flag defGhcFlag "fplugin-trustworthy"-      (NoArg (setGeneralFlag Opt_PluginTrustworthy))-  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)-  , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames)-  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)--        ------ Optimisation flags -------------------------------------------  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )-                                                            "Use -O0 instead"-  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->-                                                setOptLevel (mb_n `orElse` 1)))-                -- If the number is missing, use 1--  , make_ord_flag defFlag "fbinary-blob-threshold"-      (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n }))--  , make_ord_flag defFlag "fmax-relevant-binds"-      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))-  , make_ord_flag defFlag "fno-max-relevant-binds"-      (noArg (\d -> d { maxRelevantBinds = Nothing }))--  , make_ord_flag defFlag "fmax-valid-hole-fits"-      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))-  , make_ord_flag defFlag "fno-max-valid-hole-fits"-      (noArg (\d -> d { maxValidHoleFits = Nothing }))-  , make_ord_flag defFlag "fmax-refinement-hole-fits"-      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))-  , make_ord_flag defFlag "fno-max-refinement-hole-fits"-      (noArg (\d -> d { maxRefHoleFits = Nothing }))-  , make_ord_flag defFlag "frefinement-level-hole-fits"-      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))-  , make_ord_flag defFlag "fno-refinement-level-hole-fits"-      (noArg (\d -> d { refLevelHoleFits = Nothing }))--  , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"-            (noArg id)-            "vectors registers are now passed in registers by default."-  , make_ord_flag defFlag "fmax-uncovered-patterns"-      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))-  , make_ord_flag defFlag "fmax-pmcheck-models"-      (intSuffix (\n d -> d { maxPmCheckModels = n }))-  , make_ord_flag defFlag "fsimplifier-phases"-      (intSuffix (\n d -> d { simplPhases = n }))-  , make_ord_flag defFlag "fmax-simplifier-iterations"-      (intSuffix (\n d -> d { maxSimplIterations = n }))-  , (Deprecated, defFlag "fmax-pmcheck-iterations"-      (intSuffixM (\_ d ->-       do { deprecate $ "use -fmax-pmcheck-models instead"-          ; return d })))-  , make_ord_flag defFlag "fsimpl-tick-factor"-      (intSuffix (\n d -> d { simplTickFactor = n }))-  , make_ord_flag defFlag "fspec-constr-threshold"-      (intSuffix (\n d -> d { specConstrThreshold = Just n }))-  , make_ord_flag defFlag "fno-spec-constr-threshold"-      (noArg (\d -> d { specConstrThreshold = Nothing }))-  , make_ord_flag defFlag "fspec-constr-count"-      (intSuffix (\n d -> d { specConstrCount = Just n }))-  , make_ord_flag defFlag "fno-spec-constr-count"-      (noArg (\d -> d { specConstrCount = Nothing }))-  , make_ord_flag defFlag "fspec-constr-recursive"-      (intSuffix (\n d -> d { specConstrRecursive = n }))-  , make_ord_flag defFlag "fliberate-case-threshold"-      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))-  , make_ord_flag defFlag "fno-liberate-case-threshold"-      (noArg (\d -> d { liberateCaseThreshold = Nothing }))-  , make_ord_flag defFlag "drule-check"-      (sepArg (\s d -> d { ruleCheck = Just s }))-  , make_ord_flag defFlag "dinline-check"-      (sepArg (\s d -> d { inlineCheck = Just s }))-  , make_ord_flag defFlag "freduction-depth"-      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))-  , make_ord_flag defFlag "fconstraint-solver-iterations"-      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))-  , (Deprecated, defFlag "fcontext-stack"-      (intSuffixM (\n d ->-       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"-          ; return $ d { reductionDepth = treatZeroAsInf n } })))-  , (Deprecated, defFlag "ftype-function-depth"-      (intSuffixM (\n d ->-       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"-          ; return $ d { reductionDepth = treatZeroAsInf n } })))-  , make_ord_flag defFlag "fstrictness-before"-      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))-  , make_ord_flag defFlag "ffloat-lam-args"-      (intSuffix (\n d -> d { floatLamArgs = Just n }))-  , make_ord_flag defFlag "ffloat-all-lams"-      (noArg (\d -> d { floatLamArgs = Nothing }))-  , make_ord_flag defFlag "fstg-lift-lams-rec-args"-      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))-  , make_ord_flag defFlag "fstg-lift-lams-rec-args-any"-      (noArg (\d -> d { liftLamsRecArgs = Nothing }))-  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args"-      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))-  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"-      (noArg (\d -> d { liftLamsRecArgs = Nothing }))-  , make_ord_flag defFlag "fstg-lift-lams-known"-      (noArg (\d -> d { liftLamsKnown = True }))-  , make_ord_flag defFlag "fno-stg-lift-lams-known"-      (noArg (\d -> d { liftLamsKnown = False }))-  , make_ord_flag defFlag "fproc-alignment"-      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))-  , make_ord_flag defFlag "fblock-layout-weights"-        (HasArg (\s ->-            upd (\d -> d { cfgWeightInfo =-                parseCfgWeights s (cfgWeightInfo d)})))-  , make_ord_flag defFlag "fhistory-size"-      (intSuffix (\n d -> d { historySize = n }))-  , make_ord_flag defFlag "funfolding-creation-threshold"-      (intSuffix   (\n d -> d {ufCreationThreshold = n}))-  , make_ord_flag defFlag "funfolding-use-threshold"-      (intSuffix   (\n d -> d {ufUseThreshold = n}))-  , make_ord_flag defFlag "funfolding-fun-discount"-      (intSuffix   (\n d -> d {ufFunAppDiscount = n}))-  , make_ord_flag defFlag "funfolding-dict-discount"-      (intSuffix   (\n d -> d {ufDictDiscount = n}))-  , make_dep_flag defFlag "funfolding-keeness-factor"-      (floatSuffix (\_ d -> d))-      "-funfolding-keeness-factor is no longer respected as of GHC 9.0"-  , make_ord_flag defFlag "fmax-worker-args"-      (intSuffix (\n d -> d {maxWorkerArgs = n}))-  , make_ord_flag defGhciFlag "fghci-hist-size"-      (intSuffix (\n d -> d {ghciHistSize = n}))-  , make_ord_flag defGhcFlag "fmax-inline-alloc-size"-      (intSuffix (\n d -> d { maxInlineAllocSize = n }))-  , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"-      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))-  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"-      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))-  , make_ord_flag defGhcFlag "dinitial-unique"-      (intSuffix (\n d -> d { initialUnique = n }))-  , make_ord_flag defGhcFlag "dunique-increment"-      (intSuffix (\n d -> d { uniqueIncrement = n }))--        ------ Profiling ------------------------------------------------------        -- OLD profiling flags-  , make_dep_flag defGhcFlag "auto-all"-                    (noArg (\d -> d { profAuto = ProfAutoAll } ))-                    "Use -fprof-auto instead"-  , make_dep_flag defGhcFlag "no-auto-all"-                    (noArg (\d -> d { profAuto = NoProfAuto } ))-                    "Use -fno-prof-auto instead"-  , make_dep_flag defGhcFlag "auto"-                    (noArg (\d -> d { profAuto = ProfAutoExports } ))-                    "Use -fprof-auto-exported instead"-  , make_dep_flag defGhcFlag "no-auto"-            (noArg (\d -> d { profAuto = NoProfAuto } ))-                    "Use -fno-prof-auto instead"-  , make_dep_flag defGhcFlag "caf-all"-            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))-                    "Use -fprof-cafs instead"-  , make_dep_flag defGhcFlag "no-caf-all"-            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))-                    "Use -fno-prof-cafs instead"--        -- NEW profiling flags-  , make_ord_flag defGhcFlag "fprof-auto"-      (noArg (\d -> d { profAuto = ProfAutoAll } ))-  , make_ord_flag defGhcFlag "fprof-auto-top"-      (noArg (\d -> d { profAuto = ProfAutoTop } ))-  , make_ord_flag defGhcFlag "fprof-auto-exported"-      (noArg (\d -> d { profAuto = ProfAutoExports } ))-  , make_ord_flag defGhcFlag "fprof-auto-calls"-      (noArg (\d -> d { profAuto = ProfAutoCalls } ))-  , make_ord_flag defGhcFlag "fno-prof-auto"-      (noArg (\d -> d { profAuto = NoProfAuto } ))--        ------ Compiler flags -------------------------------------------------  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjTarget HscAsm))-  , make_ord_flag defGhcFlag "fvia-c"           (NoArg-         (deprecate $ "The -fvia-c flag does nothing; " ++-                      "it will be removed in a future GHC release"))-  , make_ord_flag defGhcFlag "fvia-C"           (NoArg-         (deprecate $ "The -fvia-C flag does nothing; " ++-                      "it will be removed in a future GHC release"))-  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjTarget HscLlvm))--  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->-                  d { ghcLink=NoLink }) >> setTarget HscNothing))-  , make_ord_flag defFlag "fbyte-code"       (NoArg ((upd $ \d ->-      -- Enabling Opt_ByteCodeIfUnboxed is a workaround for #18955.-      -- See the comments for resetOptByteCodeIfUnboxed for more details.-      gopt_set d Opt_ByteCodeIfUnboxed) >> setTarget HscInterpreted))-  , make_ord_flag defFlag "fobject-code"     $ NoArg $ do-      dflags <- liftEwM getCmdLineState-      setTarget $ defaultObjectTarget dflags--  , make_dep_flag defFlag "fglasgow-exts"-      (NoArg enableGlasgowExts) "Use individual extensions instead"-  , make_dep_flag defFlag "fno-glasgow-exts"-      (NoArg disableGlasgowExts) "Use individual extensions instead"-  , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds)-  , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds)-  , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds)-  , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg-                                                            disableUnusedBinds)--        ------ Safe Haskell flags --------------------------------------------  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)-  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->-                                                    d { safeInfer = False }))-  , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore))--        ------ position independent flags  -----------------------------------  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))-  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))-  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIE))-  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIE))--         ------ Debugging flags -----------------------------------------------  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)- ]- ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps- ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps- ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps- ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps- ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps- ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps- ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps- ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps- ++ map (mkFlag turnOn  "Werror="   setWErrorFlag )     wWarningFlagsDeps- ++ map (mkFlag turnOn  "Wwarn="     unSetFatalWarningFlag )-                                                        wWarningFlagsDeps- ++ map (mkFlag turnOn  "Wno-error=" unSetFatalWarningFlag )-                                                        wWarningFlagsDeps- ++ map (mkFlag turnOn  "fwarn-"    setWarningFlag   . hideFlag)-    wWarningFlagsDeps- ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag)-    wWarningFlagsDeps- ++ [ (NotDeprecated, unrecognisedWarning "W"),-      (Deprecated,    unrecognisedWarning "fwarn-"),-      (Deprecated,    unrecognisedWarning "fno-warn-") ]- ++ [ make_ord_flag defFlag "Werror=compat"-        (NoArg (mapM_ setWErrorFlag minusWcompatOpts))-    , make_ord_flag defFlag "Wno-error=compat"-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts))-    , make_ord_flag defFlag "Wwarn=compat"-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ]- ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps- ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps- ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps- ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps- ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps- ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps- ++ [ make_dep_flag defFlag "XGenerics"-        (NoArg $ return ())-                  ("it does nothing; look into -XDefaultSignatures " ++-                   "and -XDeriveGeneric for generic programming support.")-    , make_dep_flag defFlag "XNoGenerics"-        (NoArg $ return ())-               ("it does nothing; look into -XDefaultSignatures and " ++-                  "-XDeriveGeneric for generic programming support.") ]---- | This is where we handle unrecognised warning flags. We only issue a warning--- if -Wunrecognised-warning-flags is set. See #11429 for context.-unrecognisedWarning :: String -> Flag (CmdLineP DynFlags)-unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)-  where-    action :: String -> EwM (CmdLineP DynFlags) ()-    action flag = do-      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState-      when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $-        "unrecognised warning flag: -" ++ prefix ++ flag---- See Note [Supporting CLI completion]-package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]-package_flags_deps = [-        ------- Packages -----------------------------------------------------    make_ord_flag defFlag "package-db"-      (HasArg (addPkgDbRef . PkgDbPath))-  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)-  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)-  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)-  , make_ord_flag defFlag "global-package-db"-      (NoArg (addPkgDbRef GlobalPkgDb))-  , make_ord_flag defFlag "user-package-db"-      (NoArg (addPkgDbRef UserPkgDb))-    -- backwards compat with GHC<=7.4 :-  , make_dep_flag defFlag "package-conf"-      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"-  , make_dep_flag defFlag "no-user-package-conf"-      (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"-  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name -> do-                                      upd (setUnitId name))-  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)-  , make_ord_flag defFlag "package"               (HasArg exposePackage)-  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)-  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)-  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)-  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)-  , make_ord_flag defFlag "hide-all-packages"-      (NoArg (setGeneralFlag Opt_HideAllPackages))-  , make_ord_flag defFlag "hide-all-plugin-packages"-      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))-  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)-  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)-  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"-  , make_ord_flag defFlag "distrust-all-packages"-      (NoArg (setGeneralFlag Opt_DistrustAllPackages))-  , make_ord_flag defFlag "trust"                 (HasArg trustPackage)-  , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)-  ]-  where-    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }---- | Make a list of flags for shell completion.--- Filter all available flags into two groups, for interactive GHC vs all other.-flagsForCompletion :: Bool -> [String]-flagsForCompletion isInteractive-    = [ '-':flagName flag-      | flag <- flagsAll-      , modeFilter (flagGhcMode flag)-      ]-    where-      modeFilter AllModes = True-      modeFilter OnlyGhci = isInteractive-      modeFilter OnlyGhc = not isInteractive-      modeFilter HiddenFlag = False--type TurnOnFlag = Bool   -- True  <=> we are turning the flag on-                         -- False <=> we are turning the flag off-turnOn  :: TurnOnFlag; turnOn  = True-turnOff :: TurnOnFlag; turnOff = False--data FlagSpec flag-   = FlagSpec-       { flagSpecName :: String   -- ^ Flag in string form-       , flagSpecFlag :: flag     -- ^ Flag in internal form-       , flagSpecAction :: (TurnOnFlag -> DynP ())-           -- ^ Extra action to run when the flag is found-           -- Typically, emit a warning or error-       , flagSpecGhcMode :: GhcFlagMode-           -- ^ In which ghc mode the flag has effect-       }---- | Define a new flag.-flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)-flagSpec name flag = flagSpec' name flag nop---- | Define a new flag with an effect.-flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())-          -> (Deprecation, FlagSpec flag)-flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)---- | Define a new deprecated flag with an effect.-depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String-            -> (Deprecation, FlagSpec flag)-depFlagSpecOp name flag act dep =-    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))---- | Define a new deprecated flag.-depFlagSpec :: String -> flag -> String-            -> (Deprecation, FlagSpec flag)-depFlagSpec name flag dep = depFlagSpecOp name flag nop dep---- | Define a new deprecated flag with an effect where the deprecation message--- depends on the flag value-depFlagSpecOp' :: String-             -> flag-             -> (TurnOnFlag -> DynP ())-             -> (TurnOnFlag -> String)-             -> (Deprecation, FlagSpec flag)-depFlagSpecOp' name flag act dep =-    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))-                                                                       AllModes)---- | Define a new deprecated flag where the deprecation message--- depends on the flag value-depFlagSpec' :: String-             -> flag-             -> (TurnOnFlag -> String)-             -> (Deprecation, FlagSpec flag)-depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep----- | Define a new deprecated flag where the deprecation message--- is shown depending on the flag value-depFlagSpecCond :: String-                -> flag-                -> (TurnOnFlag -> Bool)-                -> String-                -> (Deprecation, FlagSpec flag)-depFlagSpecCond name flag cond dep =-    (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep)-                                                                       AllModes)---- | Define a new flag for GHCi.-flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)-flagGhciSpec name flag = flagGhciSpec' name flag nop---- | Define a new flag for GHCi with an effect.-flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())-              -> (Deprecation, FlagSpec flag)-flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)---- | Define a new flag invisible to CLI completion.-flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)-flagHiddenSpec name flag = flagHiddenSpec' name flag nop---- | Define a new flag invisible to CLI completion with an effect.-flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())-                -> (Deprecation, FlagSpec flag)-flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act-                                                                     HiddenFlag)---- | Hide a 'FlagSpec' from being displayed in @--show-options@.------ This is for example useful for flags that are obsolete, but should not--- (yet) be deprecated for compatibility reasons.-hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)-hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })--mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on-       -> String                -- ^ The flag prefix-       -> (flag -> DynP ())     -- ^ What to do when the flag is found-       -> (Deprecation, FlagSpec flag)  -- ^ Specification of-                                        -- this particular flag-       -> (Deprecation, Flag (CmdLineP DynFlags))-mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))-    = (dep,-       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)--deprecatedForExtension :: String -> TurnOnFlag -> String-deprecatedForExtension lang turn_on-    = "use -X" ++ flag ++-      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"-    where-      flag | turn_on   = lang-           | otherwise = "No" ++ lang--useInstead :: String -> String -> TurnOnFlag -> String-useInstead prefix flag turn_on-  = "Use " ++ prefix ++ no ++ flag ++ " instead"-  where-    no = if turn_on then "" else "no-"--nop :: TurnOnFlag -> DynP ()-nop _ = return ()---- | Find the 'FlagSpec' for a 'WarningFlag'.-flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)-flagSpecOf flag = listToMaybe $ filter check wWarningFlags-  where-    check fs = flagSpecFlag fs == flag---- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@-wWarningFlags :: [FlagSpec WarningFlag]-wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)--wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]-wWarningFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  flagSpec "alternative-layout-rule-transitional"-                                      Opt_WarnAlternativeLayoutRuleTransitional,-  depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans-    "it has no effect",-  flagSpec "cpp-undef"                   Opt_WarnCPPUndef,-  flagSpec "unbanged-strict-patterns"    Opt_WarnUnbangedStrictPatterns,-  flagSpec "deferred-type-errors"        Opt_WarnDeferredTypeErrors,-  flagSpec "deferred-out-of-scope-variables"-                                         Opt_WarnDeferredOutOfScopeVariables,-  flagSpec "deprecations"                Opt_WarnWarningsDeprecations,-  flagSpec "deprecated-flags"            Opt_WarnDeprecatedFlags,-  flagSpec "deriving-defaults"           Opt_WarnDerivingDefaults,-  flagSpec "deriving-typeable"           Opt_WarnDerivingTypeable,-  flagSpec "dodgy-exports"               Opt_WarnDodgyExports,-  flagSpec "dodgy-foreign-imports"       Opt_WarnDodgyForeignImports,-  flagSpec "dodgy-imports"               Opt_WarnDodgyImports,-  flagSpec "empty-enumerations"          Opt_WarnEmptyEnumerations,-  depFlagSpec "duplicate-constraints"    Opt_WarnDuplicateConstraints-    "it is subsumed by -Wredundant-constraints",-  flagSpec "redundant-constraints"       Opt_WarnRedundantConstraints,-  flagSpec "duplicate-exports"           Opt_WarnDuplicateExports,-  depFlagSpec "hi-shadowing"                Opt_WarnHiShadows-    "it is not used, and was never implemented",-  flagSpec "inaccessible-code"           Opt_WarnInaccessibleCode,-  flagSpec "implicit-prelude"            Opt_WarnImplicitPrelude,-  depFlagSpec "implicit-kind-vars"       Opt_WarnImplicitKindVars-    "it is now an error",-  flagSpec "incomplete-patterns"         Opt_WarnIncompletePatterns,-  flagSpec "incomplete-record-updates"   Opt_WarnIncompletePatternsRecUpd,-  flagSpec "incomplete-uni-patterns"     Opt_WarnIncompleteUniPatterns,-  flagSpec "inline-rule-shadowing"       Opt_WarnInlineRuleShadowing,-  flagSpec "identities"                  Opt_WarnIdentities,-  flagSpec "missing-fields"              Opt_WarnMissingFields,-  flagSpec "missing-import-lists"        Opt_WarnMissingImportList,-  flagSpec "missing-export-lists"        Opt_WarnMissingExportList,-  depFlagSpec "missing-local-sigs"       Opt_WarnMissingLocalSignatures-    "it is replaced by -Wmissing-local-signatures",-  flagSpec "missing-local-signatures"    Opt_WarnMissingLocalSignatures,-  flagSpec "missing-methods"             Opt_WarnMissingMethods,-  flagSpec "missing-monadfail-instances" Opt_WarnMissingMonadFailInstances,-  flagSpec "semigroup"                   Opt_WarnSemigroup,-  flagSpec "missing-signatures"          Opt_WarnMissingSignatures,-  depFlagSpec "missing-exported-sigs"    Opt_WarnMissingExportedSignatures-    "it is replaced by -Wmissing-exported-signatures",-  flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures,-  flagSpec "monomorphism-restriction"    Opt_WarnMonomorphism,-  flagSpec "name-shadowing"              Opt_WarnNameShadowing,-  flagSpec "noncanonical-monad-instances"-                                         Opt_WarnNonCanonicalMonadInstances,-  depFlagSpec "noncanonical-monadfail-instances"-                                         Opt_WarnNonCanonicalMonadInstances-    "fail is no longer a method of Monad",-  flagSpec "noncanonical-monoid-instances"-                                         Opt_WarnNonCanonicalMonoidInstances,-  flagSpec "orphans"                     Opt_WarnOrphans,-  flagSpec "overflowed-literals"         Opt_WarnOverflowedLiterals,-  flagSpec "overlapping-patterns"        Opt_WarnOverlappingPatterns,-  flagSpec "missed-specialisations"      Opt_WarnMissedSpecs,-  flagSpec "missed-specializations"      Opt_WarnMissedSpecs,-  flagSpec "all-missed-specialisations"  Opt_WarnAllMissedSpecs,-  flagSpec "all-missed-specializations"  Opt_WarnAllMissedSpecs,-  flagSpec' "safe"                       Opt_WarnSafe setWarnSafe,-  flagSpec "trustworthy-safe"            Opt_WarnTrustworthySafe,-  flagSpec "inferred-safe-imports"       Opt_WarnInferredSafeImports,-  flagSpec "missing-safe-haskell-mode"   Opt_WarnMissingSafeHaskellMode,-  flagSpec "tabs"                        Opt_WarnTabs,-  flagSpec "type-defaults"               Opt_WarnTypeDefaults,-  flagSpec "typed-holes"                 Opt_WarnTypedHoles,-  flagSpec "partial-type-signatures"     Opt_WarnPartialTypeSignatures,-  flagSpec "unrecognised-pragmas"        Opt_WarnUnrecognisedPragmas,-  flagSpec' "unsafe"                     Opt_WarnUnsafe setWarnUnsafe,-  flagSpec "unsupported-calling-conventions"-                                         Opt_WarnUnsupportedCallingConventions,-  flagSpec "unsupported-llvm-version"    Opt_WarnUnsupportedLlvmVersion,-  flagSpec "missed-extra-shared-lib"     Opt_WarnMissedExtraSharedLib,-  flagSpec "unticked-promoted-constructors"-                                         Opt_WarnUntickedPromotedConstructors,-  flagSpec "unused-do-bind"              Opt_WarnUnusedDoBind,-  flagSpec "unused-foralls"              Opt_WarnUnusedForalls,-  flagSpec "unused-imports"              Opt_WarnUnusedImports,-  flagSpec "unused-local-binds"          Opt_WarnUnusedLocalBinds,-  flagSpec "unused-matches"              Opt_WarnUnusedMatches,-  flagSpec "unused-pattern-binds"        Opt_WarnUnusedPatternBinds,-  flagSpec "unused-top-binds"            Opt_WarnUnusedTopBinds,-  flagSpec "unused-type-patterns"        Opt_WarnUnusedTypePatterns,-  flagSpec "unused-record-wildcards"     Opt_WarnUnusedRecordWildcards,-  flagSpec "redundant-record-wildcards"  Opt_WarnRedundantRecordWildcards,-  flagSpec "warnings-deprecations"       Opt_WarnWarningsDeprecations,-  flagSpec "wrong-do-bind"               Opt_WarnWrongDoBind,-  flagSpec "missing-pattern-synonym-signatures"-                                    Opt_WarnMissingPatternSynonymSignatures,-  flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies,-  flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,-  flagSpec "missing-home-modules"        Opt_WarnMissingHomeModules,-  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags,-  flagSpec "star-binder"                 Opt_WarnStarBinder,-  flagSpec "star-is-type"                Opt_WarnStarIsType,-  depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang-    "bang patterns can no longer be written with a space",-  flagSpec "partial-fields"              Opt_WarnPartialFields,-  flagSpec "prepositive-qualified-module"-                                         Opt_WarnPrepositiveQualifiedModule,-  flagSpec "unused-packages"             Opt_WarnUnusedPackages,-  flagSpec "compat-unqualified-imports"  Opt_WarnCompatUnqualifiedImports,-  flagSpec "invalid-haddock"             Opt_WarnInvalidHaddock,-  flagSpec "unicode-bidirectional-format-characters"    Opt_WarnUnicodeBidirectionalFormatCharacters- ]---- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@-negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-negatableFlagsDeps = [-  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]---- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@-dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-dFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,-  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks-     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),-  flagSpec "suppress-ticks"             Opt_SuppressTicks,-  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts-     (useInstead "-d" "suppress-stg-exts"),-  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,-  flagSpec "suppress-coercions"         Opt_SuppressCoercions,-  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,-  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,-  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,-  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,-  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,-  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,-  flagSpec "suppress-uniques"           Opt_SuppressUniques,-  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds-  ]---- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@-fFlags :: [FlagSpec GeneralFlag]-fFlags = map snd fFlagsDeps--fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-fFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,-  flagGhciSpec "break-on-error"               Opt_BreakOnError,-  flagGhciSpec "break-on-exception"           Opt_BreakOnException,-  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,-  flagSpec "call-arity"                       Opt_CallArity,-  flagSpec "exitification"                    Opt_Exitification,-  flagSpec "case-merge"                       Opt_CaseMerge,-  flagSpec "case-folding"                     Opt_CaseFolding,-  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,-  flagSpec "cmm-sink"                         Opt_CmmSink,-  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,-  flagSpec "cse"                              Opt_CSE,-  flagSpec "stg-cse"                          Opt_StgCSE,-  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,-  flagSpec "cpr-anal"                         Opt_CprAnal,-  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,-  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,-  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,-  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,-  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,-  flagSpec "dicts-cheap"                      Opt_DictsCheap,-  flagSpec "dicts-strict"                     Opt_DictsStrict,-  flagSpec "dmd-tx-dict-sel"                  Opt_DmdTxDictSel,-  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,-  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,-  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,-  flagSpec "embed-manifest"                   Opt_EmbedManifest,-  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,-  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,-  flagSpec "error-spans"                      Opt_ErrorSpans,-  flagSpec "excess-precision"                 Opt_ExcessPrecision,-  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,-  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,-  flagSpec "external-interpreter"             Opt_ExternalInterpreter,-  flagSpec "flat-cache"                       Opt_FlatCache,-  flagSpec "float-in"                         Opt_FloatIn,-  flagSpec "force-recomp"                     Opt_ForceRecomp,-  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,-  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,-  flagSpec "full-laziness"                    Opt_FullLaziness,-  flagSpec "fun-to-thunk"                     Opt_FunToThunk,-  flagSpec "gen-manifest"                     Opt_GenManifest,-  flagSpec "ghci-history"                     Opt_GhciHistory,-  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,-  flagSpec "validate-ide-info"                Opt_ValidateHie,-  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,-  flagGhciSpec "no-it"                        Opt_NoIt,-  flagSpec "ghci-sandbox"                     Opt_GhciSandbox,-  flagSpec "helpful-errors"                   Opt_HelpfulErrors,-  flagSpec "hpc"                              Opt_Hpc,-  flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,-  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,-  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,-  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,-  flagSpec "keep-going"                       Opt_KeepGoing,-  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,-  flagSpec "late-specialise"                  Opt_LateSpecialise,-  flagSpec "liberate-case"                    Opt_LiberateCase,-  flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,-  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,-  flagSpec "loopification"                    Opt_Loopification,-  flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,-  flagSpec "block-layout-weightless"          Opt_WeightlessBlocklayout,-  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,-  flagSpec "omit-yields"                      Opt_OmitYields,-  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,-  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,-  flagSpec "pre-inlining"                     Opt_SimplPreInlining,-  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,-  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,-  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,-  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,-  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,-  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,-  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,-  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,-  flagSpec "print-axiom-incomps"              Opt_PrintAxiomIncomps,-  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,-  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,-  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,-  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,-  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,-  flagSpec "prof-count-entries"               Opt_ProfCountEntries,-  flagSpec "regs-graph"                       Opt_RegsGraph,-  flagSpec "regs-iterative"                   Opt_RegsIterative,-  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules-   (useInstead "-f" "enable-rewrite-rules"),-  flagSpec "shared-implib"                    Opt_SharedImplib,-  flagSpec "spec-constr"                      Opt_SpecConstr,-  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,-  flagSpec "specialise"                       Opt_Specialise,-  flagSpec "specialize"                       Opt_Specialise,-  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,-  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,-  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,-  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,-  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,-  flagSpec "strictness"                       Opt_Strictness,-  flagSpec "use-rpaths"                       Opt_RPath,-  flagSpec "write-interface"                  Opt_WriteInterface,-  flagSpec "write-ide-info"                   Opt_WriteHie,-  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,-  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,-  flagSpec "version-macros"                   Opt_VersionMacros,-  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,-  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,-  flagSpec "catch-bottoms"                    Opt_CatchBottoms,-  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,-  flagSpec "num-constant-folding"             Opt_NumConstantFolding,-  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,-  flagSpec "hide-source-paths"                Opt_HideSourcePaths,-  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,-  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,-  flagSpec "keep-cafs"                        Opt_KeepCAFs,-  flagSpec "link-rts"                         Opt_LinkRts-  ]-  ++ fHoleFlags---- | These @-f\<blah\>@ flags have to do with the typed-hole error message or--- the valid hole fits in that message. See Note [Valid hole fits include ...]--- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with--- @-fno-\<blah\>@-fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]-fHoleFlags = [-  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,-  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits-   (useInstead "-f" "show-valid-hole-fits"),-  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,-  -- Sorting settings-  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,-  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,-  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,-  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,-  -- Output format settings-  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,-  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,-  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,-  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,-  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,-  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,-  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits-  ]---- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@-fLangFlags :: [FlagSpec LangExt.Extension]-fLangFlags = map snd fLangFlagsDeps--fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]-fLangFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]-  depFlagSpecOp' "th"                           LangExt.TemplateHaskell-    checkTemplateHaskellOk-    (deprecatedForExtension "TemplateHaskell"),-  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface-    (deprecatedForExtension "ForeignFunctionInterface"),-  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface-    (deprecatedForExtension "ForeignFunctionInterface"),-  depFlagSpec' "arrows"                         LangExt.Arrows-    (deprecatedForExtension "Arrows"),-  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude-    (deprecatedForExtension "ImplicitPrelude"),-  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns-    (deprecatedForExtension "BangPatterns"),-  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction-    (deprecatedForExtension "MonomorphismRestriction"),-  depFlagSpec' "mono-pat-binds"                 LangExt.MonoPatBinds-    (deprecatedForExtension "MonoPatBinds"),-  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules-    (deprecatedForExtension "ExtendedDefaultRules"),-  depFlagSpec' "implicit-params"                LangExt.ImplicitParams-    (deprecatedForExtension "ImplicitParams"),-  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables-    (deprecatedForExtension "ScopedTypeVariables"),-  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances-    (deprecatedForExtension "OverlappingInstances"),-  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances-    (deprecatedForExtension "UndecidableInstances"),-  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances-    (deprecatedForExtension "IncoherentInstances")-  ]--supportedLanguages :: [String]-supportedLanguages = map (flagSpecName . snd) languageFlagsDeps--supportedLanguageOverlays :: [String]-supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps--supportedExtensions :: PlatformMini -> [String]-supportedExtensions targetPlatformMini = concatMap toFlagSpecNamePair xFlags-  where-    toFlagSpecNamePair flg-      -- IMPORTANT! Make sure that `ghc --supported-extensions` omits-      -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the-      -- box. See also GHC #11102 and #16331 for more details about-      -- the rationale-      | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]-      | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]-      | otherwise = [name, noName]-      where-        isAIX = platformMini_os targetPlatformMini == OSAIX-        noName = "No" ++ name-        name = flagSpecName flg--supportedLanguagesAndExtensions :: PlatformMini -> [String]-supportedLanguagesAndExtensions targetPlatformMini =-    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions targetPlatformMini---- | These -X<blah> flags cannot be reversed with -XNo<blah>-languageFlagsDeps :: [(Deprecation, FlagSpec Language)]-languageFlagsDeps = [-  flagSpec "Haskell98"   Haskell98,-  flagSpec "Haskell2010" Haskell2010-  ]---- | These -X<blah> flags cannot be reversed with -XNo<blah>--- They are used to place hard requirements on what GHC Haskell language--- features can be used.-safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]-safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]-    where mkF flag = flagSpec (show flag) flag---- | These -X<blah> flags can all be reversed with -XNo<blah>-xFlags :: [FlagSpec LangExt.Extension]-xFlags = map snd xFlagsDeps--xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]-xFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- See Note [Adding a language extension]--- Please keep the list of flags below sorted alphabetically-  flagSpec "AllowAmbiguousTypes"              LangExt.AllowAmbiguousTypes,-  flagSpec "AlternativeLayoutRule"            LangExt.AlternativeLayoutRule,-  flagSpec "AlternativeLayoutRuleTransitional"-                                              LangExt.AlternativeLayoutRuleTransitional,-  flagSpec "Arrows"                           LangExt.Arrows,-  depFlagSpecCond "AutoDeriveTypeable"        LangExt.AutoDeriveTypeable-    id-         ("Typeable instances are created automatically " ++-                     "for all types since GHC 8.2."),-  flagSpec "BangPatterns"                     LangExt.BangPatterns,-  flagSpec "BinaryLiterals"                   LangExt.BinaryLiterals,-  flagSpec "CApiFFI"                          LangExt.CApiFFI,-  flagSpec "CPP"                              LangExt.Cpp,-  flagSpec "CUSKs"                            LangExt.CUSKs,-  flagSpec "ConstrainedClassMethods"          LangExt.ConstrainedClassMethods,-  flagSpec "ConstraintKinds"                  LangExt.ConstraintKinds,-  flagSpec "DataKinds"                        LangExt.DataKinds,-  depFlagSpecCond "DatatypeContexts"          LangExt.DatatypeContexts-    id-         ("It was widely considered a misfeature, " ++-                     "and has been removed from the Haskell language."),-  flagSpec "DefaultSignatures"                LangExt.DefaultSignatures,-  flagSpec "DeriveAnyClass"                   LangExt.DeriveAnyClass,-  flagSpec "DeriveDataTypeable"               LangExt.DeriveDataTypeable,-  flagSpec "DeriveFoldable"                   LangExt.DeriveFoldable,-  flagSpec "DeriveFunctor"                    LangExt.DeriveFunctor,-  flagSpec "DeriveGeneric"                    LangExt.DeriveGeneric,-  flagSpec "DeriveLift"                       LangExt.DeriveLift,-  flagSpec "DeriveTraversable"                LangExt.DeriveTraversable,-  flagSpec "DerivingStrategies"               LangExt.DerivingStrategies,-  flagSpec' "DerivingVia"                     LangExt.DerivingVia-                                              setDeriveVia,-  flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,-  flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,-  flagSpec "BlockArguments"                   LangExt.BlockArguments,-  depFlagSpec' "DoRec"                        LangExt.RecursiveDo-    (deprecatedForExtension "RecursiveDo"),-  flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,-  flagSpec "EmptyCase"                        LangExt.EmptyCase,-  flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,-  flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,-  flagSpec "ExistentialQuantification"        LangExt.ExistentialQuantification,-  flagSpec "ExplicitForAll"                   LangExt.ExplicitForAll,-  flagSpec "ExplicitNamespaces"               LangExt.ExplicitNamespaces,-  flagSpec "ExtendedDefaultRules"             LangExt.ExtendedDefaultRules,-  flagSpec "FlexibleContexts"                 LangExt.FlexibleContexts,-  flagSpec "FlexibleInstances"                LangExt.FlexibleInstances,-  flagSpec "ForeignFunctionInterface"         LangExt.ForeignFunctionInterface,-  flagSpec "FunctionalDependencies"           LangExt.FunctionalDependencies,-  flagSpec "GADTSyntax"                       LangExt.GADTSyntax,-  flagSpec "GADTs"                            LangExt.GADTs,-  flagSpec "GHCForeignImportPrim"             LangExt.GHCForeignImportPrim,-  flagSpec' "GeneralizedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving-                                              setGenDeriving,-  flagSpec' "GeneralisedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving-                                              setGenDeriving,-  flagSpec "ImplicitParams"                   LangExt.ImplicitParams,-  flagSpec "ImplicitPrelude"                  LangExt.ImplicitPrelude,-  flagSpec "ImportQualifiedPost"              LangExt.ImportQualifiedPost,-  flagSpec "ImpredicativeTypes"               LangExt.ImpredicativeTypes,-  flagSpec' "IncoherentInstances"             LangExt.IncoherentInstances-                                              setIncoherentInsts,-  flagSpec "TypeFamilyDependencies"           LangExt.TypeFamilyDependencies,-  flagSpec "InstanceSigs"                     LangExt.InstanceSigs,-  flagSpec "ApplicativeDo"                    LangExt.ApplicativeDo,-  flagSpec "InterruptibleFFI"                 LangExt.InterruptibleFFI,-  flagSpec "JavaScriptFFI"                    LangExt.JavaScriptFFI,-  flagSpec "KindSignatures"                   LangExt.KindSignatures,-  flagSpec "LambdaCase"                       LangExt.LambdaCase,-  flagSpec "LexicalNegation"                  LangExt.LexicalNegation,-  flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,-  flagSpec "LinearTypes"                      LangExt.LinearTypes,-  flagSpec "MagicHash"                        LangExt.MagicHash,-  flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,-  depFlagSpec "MonadFailDesugaring"           LangExt.MonadFailDesugaring-    "MonadFailDesugaring is now the default behavior",-  flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,-  depFlagSpecCond "MonoPatBinds"              LangExt.MonoPatBinds-    id-         "Experimental feature now removed; has no effect",-  flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,-  flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,-  flagSpec "MultiWayIf"                       LangExt.MultiWayIf,-  flagSpec "NumericUnderscores"               LangExt.NumericUnderscores,-  flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,-  flagSpec "NamedFieldPuns"                   LangExt.RecordPuns,-  flagSpec "NamedWildCards"                   LangExt.NamedWildCards,-  flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,-  flagSpec "HexFloatLiterals"                 LangExt.HexFloatLiterals,-  flagSpec "NondecreasingIndentation"         LangExt.NondecreasingIndentation,-  depFlagSpec' "NullaryTypeClasses"           LangExt.NullaryTypeClasses-    (deprecatedForExtension "MultiParamTypeClasses"),-  flagSpec "NumDecimals"                      LangExt.NumDecimals,-  depFlagSpecOp "OverlappingInstances"        LangExt.OverlappingInstances-    setOverlappingInsts-    "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",-  flagSpec "OverloadedLabels"                 LangExt.OverloadedLabels,-  flagSpec "OverloadedLists"                  LangExt.OverloadedLists,-  flagSpec "OverloadedStrings"                LangExt.OverloadedStrings,-  flagSpec "PackageImports"                   LangExt.PackageImports,-  flagSpec "ParallelArrays"                   LangExt.ParallelArrays,-  flagSpec "ParallelListComp"                 LangExt.ParallelListComp,-  flagSpec "PartialTypeSignatures"            LangExt.PartialTypeSignatures,-  flagSpec "PatternGuards"                    LangExt.PatternGuards,-  depFlagSpec' "PatternSignatures"            LangExt.ScopedTypeVariables-    (deprecatedForExtension "ScopedTypeVariables"),-  flagSpec "PatternSynonyms"                  LangExt.PatternSynonyms,-  flagSpec "PolyKinds"                        LangExt.PolyKinds,-  flagSpec "PolymorphicComponents"            LangExt.RankNTypes,-  flagSpec "QuantifiedConstraints"            LangExt.QuantifiedConstraints,-  flagSpec "PostfixOperators"                 LangExt.PostfixOperators,-  flagSpec "QuasiQuotes"                      LangExt.QuasiQuotes,-  flagSpec "QualifiedDo"                      LangExt.QualifiedDo,-  flagSpec "Rank2Types"                       LangExt.RankNTypes,-  flagSpec "RankNTypes"                       LangExt.RankNTypes,-  flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,-  depFlagSpec' "RecordPuns"                   LangExt.RecordPuns-    (deprecatedForExtension "NamedFieldPuns"),-  flagSpec "RecordWildCards"                  LangExt.RecordWildCards,-  flagSpec "RecursiveDo"                      LangExt.RecursiveDo,-  flagSpec "RelaxedLayout"                    LangExt.RelaxedLayout,-  depFlagSpecCond "RelaxedPolyRec"            LangExt.RelaxedPolyRec-    not-         "You can't turn off RelaxedPolyRec any more",-  flagSpec "RoleAnnotations"                  LangExt.RoleAnnotations,-  flagSpec "ScopedTypeVariables"              LangExt.ScopedTypeVariables,-  flagSpec "StandaloneDeriving"               LangExt.StandaloneDeriving,-  flagSpec "StarIsType"                       LangExt.StarIsType,-  flagSpec "StaticPointers"                   LangExt.StaticPointers,-  flagSpec "Strict"                           LangExt.Strict,-  flagSpec "StrictData"                       LangExt.StrictData,-  flagSpec' "TemplateHaskell"                 LangExt.TemplateHaskell-                                              checkTemplateHaskellOk,-  flagSpec "TemplateHaskellQuotes"            LangExt.TemplateHaskellQuotes,-  flagSpec "StandaloneKindSignatures"         LangExt.StandaloneKindSignatures,-  flagSpec "TraditionalRecordSyntax"          LangExt.TraditionalRecordSyntax,-  flagSpec "TransformListComp"                LangExt.TransformListComp,-  flagSpec "TupleSections"                    LangExt.TupleSections,-  flagSpec "TypeApplications"                 LangExt.TypeApplications,-  flagSpec "TypeInType"                       LangExt.TypeInType,-  flagSpec "TypeFamilies"                     LangExt.TypeFamilies,-  flagSpec "TypeOperators"                    LangExt.TypeOperators,-  flagSpec "TypeSynonymInstances"             LangExt.TypeSynonymInstances,-  flagSpec "UnboxedTuples"                    LangExt.UnboxedTuples,-  flagSpec "UnboxedSums"                      LangExt.UnboxedSums,-  flagSpec "UndecidableInstances"             LangExt.UndecidableInstances,-  flagSpec "UndecidableSuperClasses"          LangExt.UndecidableSuperClasses,-  flagSpec "UnicodeSyntax"                    LangExt.UnicodeSyntax,-  flagSpec "UnliftedFFITypes"                 LangExt.UnliftedFFITypes,-  flagSpec "UnliftedNewtypes"                 LangExt.UnliftedNewtypes,-  flagSpec "ViewPatterns"                     LangExt.ViewPatterns-  ]--defaultFlags :: Settings -> [GeneralFlag]-defaultFlags settings--- See Note [Updating flag description in the User's Guide]-  = [ Opt_AutoLinkPackages,-      Opt_DiagnosticsShowCaret,-      Opt_EmbedManifest,-      Opt_FlatCache,-      Opt_GenManifest,-      Opt_GhciHistory,-      Opt_GhciSandbox,-      Opt_HelpfulErrors,-      Opt_KeepHiFiles,-      Opt_KeepOFiles,-      Opt_OmitYields,-      Opt_PrintBindContents,-      Opt_ProfCountEntries,-      Opt_SharedImplib,-      Opt_SimplPreInlining,-      Opt_VersionMacros,-      Opt_RPath-    ]--    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]-             -- The default -O0 options--    ++ default_PIC platform--    ++ concatMap (wayGeneralFlags platform) (defaultWays settings)-    ++ validHoleFitDefaults--    where platform = sTargetPlatform settings---- | These are the default settings for the display and sorting of valid hole---  fits in typed-hole error messages. See Note [Valid hole fits include ...]- -- in the "GHC.Tc.Errors.Hole" module.-validHoleFitDefaults :: [GeneralFlag]-validHoleFitDefaults-  =  [ Opt_ShowTypeAppOfHoleFits-     , Opt_ShowTypeOfHoleFits-     , Opt_ShowProvOfHoleFits-     , Opt_ShowMatchesOfHoleFits-     , Opt_ShowValidHoleFits-     , Opt_SortValidHoleFits-     , Opt_SortBySizeHoleFits-     , Opt_ShowHoleConstraints ]---validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]-validHoleFitsImpliedGFlags-  = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)-    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)-    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)-    , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)-    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]--default_PIC :: Platform -> [GeneralFlag]-default_PIC platform =-  case (platformOS platform, platformArch platform) of-    -- Darwin always requires PIC.  Especially on more recent macOS releases-    -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses-    -- while we could work around this on x86_64 (like WINE does), we won't be-    -- able on aarch64, where this is enforced.-    (OSDarwin,  ArchX86_64)  -> [Opt_PIC]-    -- For AArch64, we need to always have PIC enabled.  The relocation model-    -- on AArch64 does not permit arbitrary relocations.  Under ASLR, we can't-    -- control much how far apart symbols are in memory for our in-memory static-    -- linker;  and thus need to ensure we get sufficiently capable relocations.-    -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top-    -- of that.  Subsequently we expect all code on aarch64/linux (and macOS) to-    -- be built with -fPIC.-    (OSDarwin,  ArchAArch64) -> [Opt_PIC]-    (OSLinux,   ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]-    (OSLinux,   ArchARM {})  -> [Opt_PIC, Opt_ExternalDynamicRefs]-    (OSOpenBSD, ArchX86_64) -> [Opt_PIC] -- Due to PIE support in-                                         -- OpenBSD since 5.3 release-                                         -- (1 May 2013) we need to-                                         -- always generate PIC. See-                                         -- #10597 for more-                                         -- information.-    _                      -> []---- General flags that are switched on/off when other general flags are switched--- on-impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]-impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)-                ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)-                ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)-                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)-                ] ++ validHoleFitsImpliedGFlags---- General flags that are switched on/off when other general flags are switched--- off-impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]-impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]--impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]-impliedXFlags--- See Note [Updating flag description in the User's Guide]-  = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)-    , (LangExt.QuantifiedConstraints,     turnOn, LangExt.ExplicitForAll)-    , (LangExt.ScopedTypeVariables,       turnOn, LangExt.ExplicitForAll)-    , (LangExt.LiberalTypeSynonyms,       turnOn, LangExt.ExplicitForAll)-    , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)-    , (LangExt.FlexibleInstances,         turnOn, LangExt.TypeSynonymInstances)-    , (LangExt.FunctionalDependencies,    turnOn, LangExt.MultiParamTypeClasses)-    , (LangExt.MultiParamTypeClasses,     turnOn, LangExt.ConstrainedClassMethods)  -- c.f. #7854-    , (LangExt.TypeFamilyDependencies,    turnOn, LangExt.TypeFamilies)--    , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!--    , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)--    , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)-    , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)-    , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)--    , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures-    , (LangExt.PolyKinds,        turnOn, LangExt.KindSignatures)  -- Ditto polymorphic kinds--    -- TypeInType is now just a synonym for a couple of other extensions.-    , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)-    , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)-    , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)--    -- Standalone kind signatures are a replacement for CUSKs.-    , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)--    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable-    , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)--    -- We turn this on so that we can export associated type-    -- type synonyms in subordinates (e.g. MyClass(type AssocType))-    , (LangExt.TypeFamilies,     turnOn, LangExt.ExplicitNamespaces)-    , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)--    , (LangExt.ImpredicativeTypes,  turnOn, LangExt.RankNTypes)--        -- Record wild-cards implies field disambiguation-        -- Otherwise if you write (C {..}) you may well get-        -- stuff like " 'a' not in scope ", which is a bit silly-        -- if the compiler has just filled in field 'a' of constructor 'C'-    , (LangExt.RecordWildCards,     turnOn, LangExt.DisambiguateRecordFields)--    , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)--    , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)--    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)-    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)--    -- Duplicate record fields require field disambiguation-    , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)--    , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)-    , (LangExt.Strict, turnOn, LangExt.StrictData)-  ]---- Note [When is StarIsType enabled]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The StarIsType extension determines whether to treat '*' as a regular type--- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType--- programs expect '*' to be synonymous with 'Type', so by default StarIsType is--- enabled.------ Programs that use TypeOperators might expect to repurpose '*' for--- multiplication or another binary operation, but making TypeOperators imply--- NoStarIsType caused too much breakage on Hackage.------- Note [Documenting optimisation flags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you change the list of flags enabled for particular optimisation levels--- please remember to update the User's Guide. The relevant file is:------   docs/users_guide/using-optimisation.rst------ Make sure to note whether a flag is implied by -O0, -O or -O2.--optLevelFlags :: [([Int], GeneralFlag)]--- Default settings of flags, before any command-line overrides-optLevelFlags -- see Note [Documenting optimisation flags]-  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)-    , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]-    , ([0,1,2], Opt_DmdTxDictSel)-    , ([0,1,2], Opt_LlvmTBAA)--    , ([0],     Opt_IgnoreInterfacePragmas)-    , ([0],     Opt_OmitInterfacePragmas)--    , ([1,2],   Opt_CallArity)-    , ([1,2],   Opt_Exitification)-    , ([1,2],   Opt_CaseMerge)-    , ([1,2],   Opt_CaseFolding)-    , ([1,2],   Opt_CmmElimCommonBlocks)-    , ([2],     Opt_AsmShortcutting)-    , ([1,2],   Opt_CmmSink)-    , ([1,2],   Opt_CmmStaticPred)-    , ([1,2],   Opt_CSE)-    , ([1,2],   Opt_StgCSE)-    , ([2],     Opt_StgLiftLams)--    , ([1,2],   Opt_EnableRewriteRules)-          -- Off for -O0.   Otherwise we desugar list literals-          -- to 'build' but don't run the simplifier passes that-          -- would rewrite them back to cons cells!  This seems-          -- silly, and matters for the GHCi debugger.--    , ([1,2],   Opt_FloatIn)-    , ([1,2],   Opt_FullLaziness)-    , ([1,2],   Opt_IgnoreAsserts)-    , ([1,2],   Opt_Loopification)-    , ([1,2],   Opt_CfgBlocklayout)      -- Experimental--    , ([1,2],   Opt_Specialise)-    , ([1,2],   Opt_CrossModuleSpecialise)-    , ([1,2],   Opt_Strictness)-    , ([1,2],   Opt_UnboxSmallStrictFields)-    , ([1,2],   Opt_CprAnal)-    , ([1,2],   Opt_WorkerWrapper)-    , ([1,2],   Opt_SolveConstantDicts)-    , ([1,2],   Opt_NumConstantFolding)--    , ([2],     Opt_LiberateCase)-    , ([2],     Opt_SpecConstr)---  , ([2],     Opt_RegsGraph)---   RegsGraph suffers performance regression. See #7679---  , ([2],     Opt_StaticArgumentTransformation)---   Static Argument Transformation needs investigation. See #9374-    ]----- -------------------------------------------------------------------------------- Standard sets of warning options---- Note [Documenting warning flags]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ If you change the list of warning enabled by default--- please remember to update the User's Guide. The relevant file is:------  docs/users_guide/using-warnings.rst---- | Warning groups.------ As all warnings are in the Weverything set, it is ignored when--- displaying to the user which group a warning is in.-warningGroups :: [(String, [WarningFlag])]-warningGroups =-    [ ("compat",       minusWcompatOpts)-    , ("unused-binds", unusedBindsFlags)-    , ("default",      standardWarnings)-    , ("extra",        minusWOpts)-    , ("all",          minusWallOpts)-    , ("everything",   minusWeverythingOpts)-    ]---- | Warning group hierarchies, where there is an explicit inclusion--- relation.------ Each inner list is a hierarchy of warning groups, ordered from--- smallest to largest, where each group is a superset of the one--- before it.------ Separating this from 'warningGroups' allows for multiple--- hierarchies with no inherent relation to be defined.------ The special-case Weverything group is not included.-warningHierarchies :: [[String]]-warningHierarchies = hierarchies ++ map (:[]) rest-  where-    hierarchies = [["default", "extra", "all"]]-    rest = filter (`notElem` "everything" : concat hierarchies) $-           map fst warningGroups---- | Find the smallest group in every hierarchy which a warning--- belongs to, excluding Weverything.-smallestGroups :: WarningFlag -> [String]-smallestGroups flag = mapMaybe go warningHierarchies where-    -- Because each hierarchy is arranged from smallest to largest,-    -- the first group we find in a hierarchy which contains the flag-    -- is the smallest.-    go (group:rest) = fromMaybe (go rest) $ do-        flags <- lookup group warningGroups-        guard (flag `elem` flags)-        pure (Just group)-    go [] = Nothing---- | Warnings enabled unless specified otherwise-standardWarnings :: [WarningFlag]-standardWarnings -- see Note [Documenting warning flags]-    = [ Opt_WarnOverlappingPatterns,-        Opt_WarnWarningsDeprecations,-        Opt_WarnDeprecatedFlags,-        Opt_WarnDeferredTypeErrors,-        Opt_WarnTypedHoles,-        Opt_WarnDeferredOutOfScopeVariables,-        Opt_WarnPartialTypeSignatures,-        Opt_WarnUnrecognisedPragmas,-        Opt_WarnDuplicateExports,-        Opt_WarnDerivingDefaults,-        Opt_WarnOverflowedLiterals,-        Opt_WarnEmptyEnumerations,-        Opt_WarnMissingFields,-        Opt_WarnMissingMethods,-        Opt_WarnWrongDoBind,-        Opt_WarnUnsupportedCallingConventions,-        Opt_WarnDodgyForeignImports,-        Opt_WarnInlineRuleShadowing,-        Opt_WarnAlternativeLayoutRuleTransitional,-        Opt_WarnUnsupportedLlvmVersion,-        Opt_WarnMissedExtraSharedLib,-        Opt_WarnTabs,-        Opt_WarnUnrecognisedWarningFlags,-        Opt_WarnSimplifiableClassConstraints,-        Opt_WarnStarBinder,-        Opt_WarnInaccessibleCode,-        Opt_WarnSpaceAfterBang,-        Opt_WarnUnicodeBidirectionalFormatCharacters-      ]---- | Things you get with -W-minusWOpts :: [WarningFlag]-minusWOpts-    = standardWarnings ++-      [ Opt_WarnUnusedTopBinds,-        Opt_WarnUnusedLocalBinds,-        Opt_WarnUnusedPatternBinds,-        Opt_WarnUnusedMatches,-        Opt_WarnUnusedForalls,-        Opt_WarnUnusedImports,-        Opt_WarnIncompletePatterns,-        Opt_WarnDodgyExports,-        Opt_WarnDodgyImports,-        Opt_WarnUnbangedStrictPatterns-      ]---- | Things you get with -Wall-minusWallOpts :: [WarningFlag]-minusWallOpts-    = minusWOpts ++-      [ Opt_WarnTypeDefaults,-        Opt_WarnNameShadowing,-        Opt_WarnMissingSignatures,-        Opt_WarnHiShadows,-        Opt_WarnOrphans,-        Opt_WarnUnusedDoBind,-        Opt_WarnTrustworthySafe,-        Opt_WarnUntickedPromotedConstructors,-        Opt_WarnMissingPatternSynonymSignatures,-        Opt_WarnUnusedRecordWildcards,-        Opt_WarnRedundantRecordWildcards,-        Opt_WarnStarIsType-      ]---- | Things you get with -Weverything, i.e. *all* known warnings flags-minusWeverythingOpts :: [WarningFlag]-minusWeverythingOpts = [ toEnum 0 .. ]---- | Things you get with -Wcompat.------ This is intended to group together warnings that will be enabled by default--- at some point in the future, so that library authors eager to make their--- code future compatible to fix issues before they even generate warnings.-minusWcompatOpts :: [WarningFlag]-minusWcompatOpts-    = [ Opt_WarnSemigroup-      , Opt_WarnNonCanonicalMonoidInstances-      , Opt_WarnStarIsType-      , Opt_WarnCompatUnqualifiedImports-      ]--enableUnusedBinds :: DynP ()-enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags--disableUnusedBinds :: DynP ()-disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags---- Things you get with -Wunused-binds-unusedBindsFlags :: [WarningFlag]-unusedBindsFlags = [ Opt_WarnUnusedTopBinds-                   , Opt_WarnUnusedLocalBinds-                   , Opt_WarnUnusedPatternBinds-                   ]--enableGlasgowExts :: DynP ()-enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls-                       mapM_ setExtensionFlag glasgowExtsFlags--disableGlasgowExts :: DynP ()-disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls-                        mapM_ unSetExtensionFlag glasgowExtsFlags---- Please keep what_glasgow_exts_does.rst up to date with this list-glasgowExtsFlags :: [LangExt.Extension]-glasgowExtsFlags = [-             LangExt.ConstrainedClassMethods-           , LangExt.DeriveDataTypeable-           , LangExt.DeriveFoldable-           , LangExt.DeriveFunctor-           , LangExt.DeriveGeneric-           , LangExt.DeriveTraversable-           , LangExt.EmptyDataDecls-           , LangExt.ExistentialQuantification-           , LangExt.ExplicitNamespaces-           , LangExt.FlexibleContexts-           , LangExt.FlexibleInstances-           , LangExt.ForeignFunctionInterface-           , LangExt.FunctionalDependencies-           , LangExt.GeneralizedNewtypeDeriving-           , LangExt.ImplicitParams-           , LangExt.KindSignatures-           , LangExt.LiberalTypeSynonyms-           , LangExt.MagicHash-           , LangExt.MultiParamTypeClasses-           , LangExt.ParallelListComp-           , LangExt.PatternGuards-           , LangExt.PostfixOperators-           , LangExt.RankNTypes-           , LangExt.RecursiveDo-           , LangExt.ScopedTypeVariables-           , LangExt.StandaloneDeriving-           , LangExt.TypeOperators-           , LangExt.TypeSynonymInstances-           , LangExt.UnboxedTuples-           , LangExt.UnicodeSyntax-           , LangExt.UnliftedFFITypes ]--setWarnSafe :: Bool -> DynP ()-setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })-setWarnSafe False = return ()--setWarnUnsafe :: Bool -> DynP ()-setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })-setWarnUnsafe False = return ()--setPackageTrust :: DynP ()-setPackageTrust = do-    setGeneralFlag Opt_PackageTrust-    l <- getCurLoc-    upd $ \d -> d { pkgTrustOnLoc = l }--setGenDeriving :: TurnOnFlag -> DynP ()-setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })-setGenDeriving False = return ()--setDeriveVia :: TurnOnFlag -> DynP ()-setDeriveVia True  = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })-setDeriveVia False = return ()--setOverlappingInsts :: TurnOnFlag -> DynP ()-setOverlappingInsts False = return ()-setOverlappingInsts True = do-  l <- getCurLoc-  upd (\d -> d { overlapInstLoc = l })--setIncoherentInsts :: TurnOnFlag -> DynP ()-setIncoherentInsts False = return ()-setIncoherentInsts True = do-  l <- getCurLoc-  upd (\d -> d { incoherentOnLoc = l })--checkTemplateHaskellOk :: TurnOnFlag -> DynP ()-checkTemplateHaskellOk _turn_on-  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })--{- **********************************************************************-%*                                                                      *-                DynFlags constructors-%*                                                                      *-%********************************************************************* -}--type DynP = EwM (CmdLineP DynFlags)--upd :: (DynFlags -> DynFlags) -> DynP ()-upd f = liftEwM (do dflags <- getCmdLineState-                    putCmdLineState $! f dflags)--updM :: (DynFlags -> DynP DynFlags) -> DynP ()-updM f = do dflags <- liftEwM getCmdLineState-            dflags' <- f dflags-            liftEwM $ putCmdLineState $! dflags'----------------- Constructor functions for OptKind ------------------noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-noArg fn = NoArg (upd fn)--noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)-noArgM fn = NoArg (updM fn)--hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-hasArg fn = HasArg (upd . fn)--sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-sepArg fn = SepArg (upd . fn)--intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-intSuffix fn = IntSuffix (\n -> upd (fn n))--intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)-intSuffixM fn = IntSuffix (\n -> updM (fn n))--floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-floatSuffix fn = FloatSuffix (\n -> upd (fn n))--optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)-              -> OptKind (CmdLineP DynFlags)-optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))--setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)-setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)-----------------------------addWay :: Way -> DynP ()-addWay w = upd (addWay' w)--addWay' :: Way -> DynFlags -> DynFlags-addWay' w dflags0 = let platform = targetPlatform dflags0-                        dflags1 = dflags0 { ways = Set.insert w (ways dflags0) }-                        dflags2 = foldr setGeneralFlag' dflags1-                                        (wayGeneralFlags platform w)-                        dflags3 = foldr unSetGeneralFlag' dflags2-                                        (wayUnsetGeneralFlags platform w)-                    in dflags3--removeWayDyn :: DynP ()-removeWayDyn = upd (\dfs -> dfs { ways = Set.filter (WayDyn /=) (ways dfs) })-----------------------------setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()-setGeneralFlag   f = upd (setGeneralFlag' f)-unSetGeneralFlag f = upd (unSetGeneralFlag' f)--setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags-setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps-  where-    deps = [ if turn_on then setGeneralFlag'   d-                        else unSetGeneralFlag' d-           | (f', turn_on, d) <- impliedGFlags, f' == f ]-        -- When you set f, set the ones it implies-        -- NB: use setGeneralFlag recursively, in case the implied flags-        --     implies further flags--unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags-unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps-  where-    deps = [ if turn_on then setGeneralFlag' d-                        else unSetGeneralFlag' d-           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]-   -- In general, when you un-set f, we don't un-set the things it implies.-   -- There are however some exceptions, e.g., -fno-strictness implies-   -- -fno-worker-wrapper.-   ---   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags-   --     imply further flags.-----------------------------setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()-setWarningFlag   f = upd (\dfs -> wopt_set dfs f)-unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)--setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()-setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)-unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)--setWErrorFlag :: WarningFlag -> DynP ()-setWErrorFlag flag =-  do { setWarningFlag flag-     ; setFatalWarningFlag flag }-----------------------------setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()-setExtensionFlag f = upd (setExtensionFlag' f)-unSetExtensionFlag f = upd (unSetExtensionFlag' f)--setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags-setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps-  where-    deps = [ if turn_on then setExtensionFlag'   d-                        else unSetExtensionFlag' d-           | (f', turn_on, d) <- impliedXFlags, f' == f ]-        -- When you set f, set the ones it implies-        -- NB: use setExtensionFlag recursively, in case the implied flags-        --     implies further flags--unSetExtensionFlag' f dflags = xopt_unset dflags f-   -- When you un-set f, however, we don't un-set the things it implies-   --      (except for -fno-glasgow-exts, which is treated specially)-----------------------------alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags-alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) }--alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags-alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }-----------------------------setDumpFlag' :: DumpFlag -> DynP ()-setDumpFlag' dump_flag-  = do upd (\dfs -> dopt_set dfs dump_flag)-       when want_recomp forceRecompile-    where -- Certain dumpy-things are really interested in what's going-          -- on during recompilation checking, so in those cases we-          -- don't want to turn it off.-          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,-                                             Opt_D_dump_hi_diffs,-                                             Opt_D_no_debug_output]--forceRecompile :: DynP ()--- Whenever we -ddump, force recompilation (by switching off the--- recompilation checker), else you don't see the dump! However,--- don't switch it off in --make mode, else *everything* gets--- recompiled which probably isn't what you want-forceRecompile = do dfs <- liftEwM getCmdLineState-                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)-        where-          force_recomp dfs = isOneShot (ghcMode dfs)---setVerboseCore2Core :: DynP ()-setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core--setVerbosity :: Maybe Int -> DynP ()-setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })--setDebugLevel :: Maybe Int -> DynP ()-setDebugLevel mb_n = upd (\dfs -> dfs{ debugLevel = mb_n `orElse` 2 })--data PkgDbRef-  = GlobalPkgDb-  | UserPkgDb-  | PkgDbPath FilePath-  deriving Eq--addPkgDbRef :: PkgDbRef -> DynP ()-addPkgDbRef p = upd $ \s ->-  s { packageDBFlags = PackageDB p : packageDBFlags s }--removeUserPkgDb :: DynP ()-removeUserPkgDb = upd $ \s ->-  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }--removeGlobalPkgDb :: DynP ()-removeGlobalPkgDb = upd $ \s ->- s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }--clearPkgDb :: DynP ()-clearPkgDb = upd $ \s ->-  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }--parsePackageFlag :: String                 -- the flag-                 -> ReadP PackageArg       -- type of argument-                 -> String                 -- string to parse-                 -> PackageFlag-parsePackageFlag flag arg_parse str- = case filter ((=="").snd) (readP_to_S parse str) of-    [(r, "")] -> r-    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)-  where doc = flag ++ " " ++ str-        parse = do-            pkg_arg <- tok arg_parse-            let mk_expose = ExposePackage doc pkg_arg-            ( do _ <- tok $ string "with"-                 fmap (mk_expose . ModRenaming True) parseRns-             <++ fmap (mk_expose . ModRenaming False) parseRns-             <++ return (mk_expose (ModRenaming True [])))-        parseRns = do _ <- tok $ R.char '('-                      rns <- tok $ sepBy parseItem (tok $ R.char ',')-                      _ <- tok $ R.char ')'-                      return rns-        parseItem = do-            orig <- tok $ parseModuleName-            (do _ <- tok $ string "as"-                new <- tok $ parseModuleName-                return (orig, new)-              +++-             return (orig, orig))-        tok m = m >>= \x -> skipSpaces >> return x--exposePackage, exposePackageId, hidePackage,-        exposePluginPackage, exposePluginPackageId,-        ignorePackage,-        trustPackage, distrustPackage :: String -> DynP ()-exposePackage p = upd (exposePackage' p)-exposePackageId p =-  upd (\s -> s{ packageFlags =-    parsePackageFlag "-package-id" parseUnitArg p : packageFlags s })-exposePluginPackage p =-  upd (\s -> s{ pluginPackageFlags =-    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })-exposePluginPackageId p =-  upd (\s -> s{ pluginPackageFlags =-    parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s })-hidePackage p =-  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })-ignorePackage p =-  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })--trustPackage p = exposePackage p >> -- both trust and distrust also expose a package-  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })-distrustPackage p = exposePackage p >>-  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })--exposePackage' :: String -> DynFlags -> DynFlags-exposePackage' p dflags-    = dflags { packageFlags =-            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }--parsePackageArg :: ReadP PackageArg-parsePackageArg =-    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))--parseUnitArg :: ReadP PackageArg-parseUnitArg =-    fmap UnitIdArg parseUnit--setUnitId :: String -> DynFlags -> DynFlags-setUnitId p d = d { homeUnitId = stringToUnitId p }---- | Given a 'ModuleName' of a signature in the home library, find--- out how it is instantiated.  E.g., the canonical form of--- A in @p[A=q[]:A]@ is @q[]:A@.-canonicalizeHomeModule :: DynFlags -> ModuleName -> Module-canonicalizeHomeModule dflags mod_name =-    case lookup mod_name (homeUnitInstantiations dflags) of-        Nothing  -> mkHomeModule dflags mod_name-        Just mod -> mod--canonicalizeModuleIfHome :: DynFlags -> Module -> Module-canonicalizeModuleIfHome dflags mod-    = if homeUnit dflags == moduleUnit mod-                      then canonicalizeHomeModule dflags (moduleName mod)-                      else mod---- If we're linking a binary, then only targets that produce object--- code are allowed (requests for other target types are ignored).-setTarget :: HscTarget -> DynP ()-setTarget l = upd $ \ dfs ->-  if ghcLink dfs /= LinkBinary || isObjectTarget l-  then dfs{ hscTarget = l }-  else dfs---- Changes the target only if we're compiling object code.  This is--- used by -fasm and -fllvm, which switch from one to the other, but--- not from bytecode to object-code.  The idea is that -fasm/-fllvm--- can be safely used in an OPTIONS_GHC pragma.-setObjTarget :: HscTarget -> DynP ()-setObjTarget l = updM set-  where-   set dflags-     | isObjectTarget (hscTarget dflags)-       = return $ dflags { hscTarget = l }-     | otherwise = return dflags--setOptLevel :: Int -> DynFlags -> DynP DynFlags-setOptLevel n dflags = return (updOptLevel n dflags)--checkOptLevel :: Int -> DynFlags -> Either String DynFlags-checkOptLevel n dflags-   | hscTarget dflags == HscInterpreted && n > 0-     = Left "-O conflicts with --interactive; -O ignored."-   | otherwise-     = Right dflags--setMainIs :: String -> DynP ()-setMainIs arg-  | not (null main_fn) && isLower (head main_fn)-     -- The arg looked like "Foo.Bar.baz"-  = upd $ \d -> d { mainFunIs = Just main_fn,-                   mainModIs = mkModule mainUnit (mkModuleName main_mod) }--  | isUpper (head arg)  -- The arg looked like "Foo" or "Foo.Bar"-  = upd $ \d -> d { mainModIs = mkModule mainUnit (mkModuleName arg) }--  | otherwise                   -- The arg looked like "baz"-  = upd $ \d -> d { mainFunIs = Just arg }-  where-    (main_mod, main_fn) = splitLongestPrefix arg (== '.')--addLdInputs :: Option -> DynFlags -> DynFlags-addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}---- -------------------------------------------------------------------------------- Load dynflags from environment files.--setFlagsFromEnvFile :: FilePath -> String -> DynP ()-setFlagsFromEnvFile envfile content = do-  setGeneralFlag Opt_HideAllPackages-  parseEnvFile envfile content--parseEnvFile :: FilePath -> String -> DynP ()-parseEnvFile envfile = mapM_ parseEntry . lines-  where-    parseEntry str = case words str of-      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))-        -- relative package dbs are interpreted relative to the env file-        where envdir = takeDirectory envfile-              db     = drop 11 str-      ["clear-package-db"]  -> clearPkgDb-      ["global-package-db"] -> addPkgDbRef GlobalPkgDb-      ["user-package-db"]   -> addPkgDbRef UserPkgDb-      ["package-id", pkgid] -> exposePackageId pkgid-      (('-':'-':_):_)       -> return () -- comments-      -- and the original syntax introduced in 7.10:-      [pkgid]               -> exposePackageId pkgid-      []                    -> return ()-      _                     -> throwGhcException $ CmdLineError $-                                    "Can't parse environment file entry: "-                                 ++ envfile ++ ": " ++ str----------------------------------------------------------------------------------- Paths & Libraries--addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()---- -i on its own deletes the import paths-addImportPath "" = upd (\s -> s{importPaths = []})-addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})--addLibraryPath p =-  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})--addIncludePath p =-  upd (\s -> s{includePaths =-                  addGlobalInclude (includePaths s) (splitPathList p)})--addFrameworkPath p =-  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})--#if !defined(mingw32_HOST_OS)-split_marker :: Char-split_marker = ':'   -- not configurable (ToDo)-#endif--splitPathList :: String -> [String]-splitPathList s = filter notNull (splitUp s)-                -- empty paths are ignored: there might be a trailing-                -- ':' in the initial list, for example.  Empty paths can-                -- cause confusion when they are translated into -I options-                -- for passing to gcc.-  where-#if !defined(mingw32_HOST_OS)-    splitUp xs = split split_marker xs-#else-     -- Windows: 'hybrid' support for DOS-style paths in directory lists.-     ---     -- That is, if "foo:bar:baz" is used, this interpreted as-     -- consisting of three entries, 'foo', 'bar', 'baz'.-     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted-     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"-     ---     -- Notice that no attempt is made to fully replace the 'standard'-     -- split marker ':' with the Windows / DOS one, ';'. The reason being-     -- that this will cause too much breakage for users & ':' will-     -- work fine even with DOS paths, if you're not insisting on being silly.-     -- So, use either.-    splitUp []             = []-    splitUp (x:':':div:xs) | div `elem` dir_markers-                           = ((x:':':div:p): splitUp rs)-                           where-                              (p,rs) = findNextPath xs-          -- we used to check for existence of the path here, but that-          -- required the IO monad to be threaded through the command-line-          -- parser which is quite inconvenient.  The-    splitUp xs = cons p (splitUp rs)-               where-                 (p,rs) = findNextPath xs--                 cons "" xs = xs-                 cons x  xs = x:xs--    -- will be called either when we've consumed nought or the-    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of-    -- finding the next split marker.-    findNextPath xs =-        case break (`elem` split_markers) xs of-           (p, _:ds) -> (p, ds)-           (p, xs)   -> (p, xs)--    split_markers :: [Char]-    split_markers = [':', ';']--    dir_markers :: [Char]-    dir_markers = ['/', '\\']-#endif---- -------------------------------------------------------------------------------- tmpDir, where we store temporary files.--setTmpDir :: FilePath -> DynFlags -> DynFlags-setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir }-  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't-  -- seem necessary now --SDM 7/2/2008---------------------------------------------------------------------------------- RTS opts--setRtsOpts :: String -> DynP ()-setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}--setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()-setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}---------------------------------------------------------------------------------- Hpc stuff--setOptHpcDir :: String -> DynP ()-setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}---------------------------------------------------------------------------------- Via-C compilation stuff---- There are some options that we need to pass to gcc when compiling--- Haskell code via C, but are only supported by recent versions of--- gcc.  The configure script decides which of these options we need,--- and puts them in the "settings" file in $topdir. The advantage of--- having these in a separate file is that the file can be created at--- install-time depending on the available gcc version, and even--- re-generated later if gcc is upgraded.------ The options below are not dependent on the version of gcc, only the--- platform.--picCCOpts :: DynFlags -> [String]-picCCOpts dflags = pieOpts ++ picOpts-  where-    picOpts =-      case platformOS (targetPlatform dflags) of-      OSDarwin-          -- Apple prefers to do things the other way round.-          -- PIC is on by default.-          -- -mdynamic-no-pic:-          --     Turn off PIC code generation.-          -- -fno-common:-          --     Don't generate "common" symbols - these are unwanted-          --     in dynamic libraries.--       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]-       | otherwise           -> ["-mdynamic-no-pic"]-      OSMinGW32 -- no -fPIC for Windows-       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]-       | otherwise           -> []-      _-      -- we need -fPIC for C files when we are compiling with -dynamic,-      -- otherwise things like stub.c files don't get compiled-      -- correctly.  They need to reference data in the Haskell-      -- objects, but can't without -fPIC.  See-      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code-       | gopt Opt_PIC dflags || WayDyn `Set.member` ways dflags ->-          ["-fPIC", "-U__PIC__", "-D__PIC__"]-      -- gcc may be configured to have PIC on by default, let's be-      -- explicit here, see #15847-       | otherwise -> ["-fno-PIC"]--    pieOpts-      | gopt Opt_PICExecutable dflags       = ["-pie"]-        -- See Note [No PIE when linking]-      | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]-      | otherwise                           = []---{--Note [No PIE while linking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by-default in their gcc builds. This is incompatible with -r as it implies that we-are producing an executable. Consequently, we must manually pass -no-pie to gcc-when joining object files or linking dynamic libraries. Unless, of course, the-user has explicitly requested a PIE executable with -pie. See #12759.--}--picPOpts :: DynFlags -> [String]-picPOpts dflags- | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]- | otherwise           = []---- -------------------------------------------------------------------------------- Compiler Info--compilerInfo :: DynFlags -> [(String, String)]-compilerInfo dflags-    = -- We always make "Project name" be first to keep parsing in-      -- other languages simple, i.e. when looking for other fields,-      -- you don't have to worry whether there is a leading '[' or not-      ("Project name",                 cProjectName)-      -- Next come the settings, so anything else can be overridden-      -- in the settings file (as "lookup" uses the first match for the-      -- key)-    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))-          (rawSettings dflags)-   ++ [("Project version",             projectVersion dflags),-       ("Project Git commit id",       cProjectGitCommitId),-       ("Booter version",              cBooterVersion),-       ("Stage",                       cStage),-       ("Build platform",              cBuildPlatformString),-       ("Host platform",               cHostPlatformString),-       ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),-       ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),-       ("Object splitting supported",  showBool False),-       ("Have native code generator",  showBool $ platformNcgSupported (targetPlatform dflags)),-       ("Target default backend",      show $ platformDefaultBackend (targetPlatform dflags)),-       -- Whether or not we support @-dynamic-too@-       ("Support dynamic-too",         showBool $ not isWindows),-       -- Whether or not we support the @-j@ flag with @--make@.-       ("Support parallel --make",     "YES"),-       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in-       -- installed package info.-       ("Support reexported-modules",  "YES"),-       -- Whether or not we support extended @-package foo (Foo)@ syntax.-       ("Support thinning and renaming package flags", "YES"),-       -- Whether or not we support Backpack.-       ("Support Backpack", "YES"),-       -- If true, we require that the 'id' field in installed package info-       -- match what is passed to the @-this-unit-id@ flag for modules-       -- built in it-       ("Requires unified installed package IDs", "YES"),-       -- Whether or not we support the @-this-package-key@ flag.  Prefer-       -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@-       -- flag has been removed, otherwise it breaks Cabal...-       ("Uses package keys",           "YES"),-       -- Whether or not we support the @-this-unit-id@ flag-       ("Uses unit IDs",               "YES"),-       -- Whether or not GHC compiles libraries as dynamic by default-       ("Dynamic by default",          showBool $ dYNAMIC_BY_DEFAULT dflags),-       -- Whether or not GHC was compiled using -dynamic-       ("GHC Dynamic",                 showBool hostIsDynamic),-       -- Whether or not GHC was compiled using -prof-       ("GHC Profiled",                showBool hostIsProfiled),-       ("Debug on",                    showBool debugIsOn),-       ("LibDir",                      topDir dflags),-       -- The path of the global package database used by GHC-       ("Global Package DB",           globalPackageDatabasePath dflags)-      ]-  where-    showBool True  = "YES"-    showBool False = "NO"-    isWindows = platformOS (targetPlatform dflags) == OSMinGW32-    expandDirectories :: FilePath -> Maybe FilePath -> String -> String-    expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd---- Produced by deriveConstants-#include "GHCConstantsHaskellWrappers.hs"--bLOCK_SIZE_W :: DynFlags -> Int-bLOCK_SIZE_W dflags = bLOCK_SIZE dflags `quot` platformWordSizeInBytes platform-   where platform = targetPlatform dflags--wordAlignment :: Platform -> Alignment-wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)--tAG_MASK :: DynFlags -> Int-tAG_MASK dflags = (1 `shiftL` tAG_BITS dflags) - 1--mAX_PTR_TAG :: DynFlags -> Int-mAX_PTR_TAG = tAG_MASK--{- ------------------------------------------------------------------------------Note [DynFlags consistency]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are a number of number of DynFlags configurations which either-do not make sense or lead to unimplemented or buggy codepaths in the-compiler. makeDynFlagsConsistent is responsible for verifying the validity-of a set of DynFlags, fixing any issues, and reporting them back to the-caller.--GHCi and -O------------------When using optimization, the compiler can introduce several things-(such as unboxed tuples) into the intermediate code, which GHCi later-chokes on since the bytecode interpreter can't handle this (and while-this is arguably a bug these aren't handled, there are no plans to fix-it.)--While the driver pipeline always checks for this particular erroneous-combination when parsing flags, we also need to check when we update-the flags; this is because API clients may parse flags but update the-DynFlags afterwords, before finally running code inside a session (see-T10052 and #10052).--}---- | Resolve any internal inconsistencies in a set of 'DynFlags'.--- Returns the consistent 'DynFlags' as well as a list of warnings--- to report to the user.-makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String])--- Whenever makeDynFlagsConsistent does anything, it starts over, to--- ensure that a later change doesn't invalidate an earlier check.--- Be careful not to introduce potential loops!-makeDynFlagsConsistent dflags- -- Disable -dynamic-too on Windows (#8228, #7134, #5987)- | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags-    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo-          warn    = "-dynamic-too is not supported on Windows"-      in loop dflags' warn--   -- Via-C backend only supports unregisterised convention. Switch to a backend-   -- supporting it if possible.- | hscTarget dflags == HscC &&-   not (platformUnregisterised (targetPlatform dflags))-    = case platformDefaultBackend (targetPlatform dflags) of-         NCG  -> let dflags' = dflags { hscTarget = HscAsm }-                     warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C"-                 in loop dflags' warn-         LLVM -> let dflags' = dflags { hscTarget = HscLlvm }-                     warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C"-                 in loop dflags' warn-         _    -> pgmError "Compiling via C is only supported with unregisterised ABI but target platform doesn't use it."- | gopt Opt_Hpc dflags && hscTarget dflags == HscInterpreted-    = let dflags' = gopt_unset dflags Opt_Hpc-          warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc."-      in loop dflags' warn-- | hscTarget dflags `elem` [HscAsm, HscLlvm] &&-   platformUnregisterised (targetPlatform dflags)-    = loop (dflags { hscTarget = HscC })-           "Target platform uses unregisterised ABI, so compiling via C"-- | hscTarget dflags == HscAsm &&-   not (platformNcgSupported $ targetPlatform dflags)-      = let dflags' = dflags { hscTarget = HscLlvm }-            warn = "Native code generator doesn't support target platform, so using LLVM"-        in loop dflags' warn-- | not (osElfTarget os) && gopt Opt_PIE dflags-    = loop (gopt_unset dflags Opt_PIE)-           "Position-independent only supported on ELF platforms"- | os == OSDarwin &&-   arch == ArchX86_64 &&-   not (gopt Opt_PIC dflags)-    = loop (gopt_set dflags Opt_PIC)-           "Enabling -fPIC as it is always on for this platform"- | Left err <- checkOptLevel (optLevel dflags) dflags-    = loop (updOptLevel 0 dflags) err-- | LinkInMemory <- ghcLink dflags- , not (gopt Opt_ExternalInterpreter dflags)- , hostIsProfiled- , isObjectTarget (hscTarget dflags)- , WayProf `Set.notMember` ways dflags-    = loop dflags{ways = Set.insert WayProf (ways dflags)}-         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"-- | otherwise = (dflags, [])-    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")-          loop updated_dflags warning-              = case makeDynFlagsConsistent updated_dflags of-                (dflags', ws) -> (dflags', L loc warning : ws)-          platform = targetPlatform dflags-          arch = platformArch platform-          os   = platformOS   platform-------------------------------------------------------------------------------- Do not use unsafeGlobalDynFlags!------ unsafeGlobalDynFlags is a hack, necessary because we need to be able--- to show SDocs when tracing, but we don't always have DynFlags--- available.------ Do not use it if you can help it. You may get the wrong value, or this--- panic!---- | This is the value that 'unsafeGlobalDynFlags' takes before it is--- initialized.-defaultGlobalDynFlags :: DynFlags-defaultGlobalDynFlags =-    (defaultDynFlags settings llvmConfig) { verbosity = 2 }-  where-    settings = panic "v_unsafeGlobalDynFlags: settings not initialised"-    llvmConfig = panic "v_unsafeGlobalDynFlags: llvmConfig not initialised"--#if GHC_STAGE < 2-GLOBAL_VAR(v_unsafeGlobalDynFlags, defaultGlobalDynFlags, DynFlags)-#else-SHARED_GLOBAL_VAR( v_unsafeGlobalDynFlags-                 , getOrSetLibHSghcGlobalDynFlags-                 , "getOrSetLibHSghcGlobalDynFlags"-                 , defaultGlobalDynFlags-                 , DynFlags )-#endif--unsafeGlobalDynFlags :: DynFlags-unsafeGlobalDynFlags = unsafePerformIO $ readIORef v_unsafeGlobalDynFlags--setUnsafeGlobalDynFlags :: DynFlags -> IO ()-setUnsafeGlobalDynFlags = writeIORef v_unsafeGlobalDynFlags---- -------------------------------------------------------------------------------- SSE and AVX---- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to--- check if SSE is enabled, we might have x86-64 imply the -msse2--- flag.--isSseEnabled :: DynFlags -> Bool-isSseEnabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> True-    ArchX86    -> True-    _          -> False--isSse2Enabled :: DynFlags -> Bool-isSse2Enabled dflags = case platformArch (targetPlatform dflags) of-  -- We Assume  SSE1 and SSE2 operations are available on both-  -- x86 and x86_64. Historically we didn't default to SSE2 and-  -- SSE1 on x86, which results in defacto nondeterminism for how-  -- rounding behaves in the associated x87 floating point instructions-  -- because variations in the spill/fpu stack placement of arguments for-  -- operations would change the precision and final result of what-  -- would otherwise be the same expressions with respect to single or-  -- double precision IEEE floating point computations.-    ArchX86_64 -> True-    ArchX86    -> True-    _          -> False---isSse4_2Enabled :: DynFlags -> Bool-isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42--isAvxEnabled :: DynFlags -> Bool-isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags--isAvx2Enabled :: DynFlags -> Bool-isAvx2Enabled dflags = avx2 dflags || avx512f dflags--isAvx512cdEnabled :: DynFlags -> Bool-isAvx512cdEnabled dflags = avx512cd dflags--isAvx512erEnabled :: DynFlags -> Bool-isAvx512erEnabled dflags = avx512er dflags--isAvx512fEnabled :: DynFlags -> Bool-isAvx512fEnabled dflags = avx512f dflags--isAvx512pfEnabled :: DynFlags -> Bool-isAvx512pfEnabled dflags = avx512pf dflags---- -------------------------------------------------------------------------------- BMI2--isBmiEnabled :: DynFlags -> Bool-isBmiEnabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> bmiVersion dflags >= Just BMI1-    ArchX86    -> bmiVersion dflags >= Just BMI1-    _          -> False--isBmi2Enabled :: DynFlags -> Bool-isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> bmiVersion dflags >= Just BMI2-    ArchX86    -> bmiVersion dflags >= Just BMI2-    _          -> False---- | Indicate if cost-centre profiling is enabled-sccProfilingEnabled :: DynFlags -> Bool-sccProfilingEnabled dflags = ways dflags `hasWay` WayProf---- -------------------------------------------------------------------------------- Linker/compiler information---- LinkerInfo contains any extra options needed by the system linker.-data LinkerInfo-  = GnuLD    [Option]-  | GnuGold  [Option]-  | LlvmLLD  [Option]-  | DarwinLD [Option]-  | SolarisLD [Option]-  | AixLD    [Option]-  | UnknownLD-  deriving Eq---- CompilerInfo tells us which C compiler we're using-data CompilerInfo-   = GCC-   | Clang-   | AppleClang-   | AppleClang51-   | UnknownCC-   deriving Eq----- | Should we use `-XLinker -rpath` when linking or not?--- See Note [-fno-use-rpaths]-useXLinkerRPath :: DynFlags -> OS -> Bool-useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS]-useXLinkerRPath dflags _ = gopt Opt_RPath dflags--{--Note [-fno-use-rpaths]-~~~~~~~~~~~~~~~~~~~~~~--First read, Note [Dynamic linking on macOS] to understand why on darwin we never-use `-XLinker -rpath`.--The specification of `Opt_RPath` is as follows:--The default case `-fuse-rpaths`:-* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath-  afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin-  as things stand but it wasn't documented in the user guide before this patch how-  `-fuse-rpaths` should behave and the fact it was always disabled on darwin.-* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable,-  this is the normal way you should set the rpath.--The case of `-fno-use-rpaths`-* Never inject anything into the rpath.--When this was first implemented, `Opt_RPath` was disabled on darwin, but-the rpath was still always augmented by `runInjectRPaths`, and there was no way to-stop this. This was problematic because you couldn't build an executable in CI-with a clean rpath.---}---- -------------------------------------------------------------------------------- RTS hooks---- Convert sizes like "3.5M" into integers-decodeSize :: String -> Integer-decodeSize str-  | c == ""      = truncate n-  | c == "K" || c == "k" = truncate (n * 1000)-  | c == "M" || c == "m" = truncate (n * 1000 * 1000)-  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)-  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))-  where (m, c) = span pred str-        n      = readRational m-        pred c = isDigit c || c == '.'--foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()-foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()---- -------------------------------------------------------------------------------- Types for managing temporary files.------ these are here because FilesToClean is used in DynFlags---- | A collection of files that must be deleted before ghc exits.--- The current collection--- is stored in an IORef in DynFlags, 'filesToClean'.-data FilesToClean = FilesToClean {-  ftcGhcSession :: !(Set FilePath),-  -- ^ Files that will be deleted at the end of runGhc(T)-  ftcCurrentModule :: !(Set FilePath)-  -- ^ Files that will be deleted the next time-  -- 'FileCleanup.cleanCurrentModuleTempFiles' is called, or otherwise at the-  -- end of the session.-  }---- | An empty FilesToClean-emptyFilesToClean :: FilesToClean-emptyFilesToClean = FilesToClean Set.empty Set.empty----- | Initialize the pretty-printing options-initSDocContext :: DynFlags -> PprStyle -> SDocContext-initSDocContext dflags style = SDC-  { sdocStyle                       = style-  , sdocColScheme                   = colScheme dflags-  , sdocLastColour                  = Col.colReset-  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)-  , sdocDefaultDepth                = pprUserLength dflags-  , sdocLineLength                  = pprCols dflags-  , sdocCanUseUnicode               = useUnicode dflags-  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags-  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags-  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags-  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags-  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags-  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags-  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags-  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags-  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags-  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags-  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags-  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags-  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags-  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags-  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags-  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags-  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags-  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags-  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags-  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags-  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags-  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags-  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags-  , sdocStarIsType                  = xopt LangExt.StarIsType dflags-  , sdocImpredicativeTypes          = xopt LangExt.ImpredicativeTypes dflags-  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags-  , sdocPrintTypeAbbreviations      = True-  , sdocDynFlags                    = dflags-  }---- | Initialize the pretty-printing options using the default user style-initDefaultSDocContext :: DynFlags -> SDocContext-initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.Driver.Session (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), WarnReason(..),+        Language(..),+        PlatformConstants(..),+        FatalMessager, FlushOut(..), FlushErr(..),+        ProfAuto(..),+        glasgowExtsFlags,+        warningGroups, warningHierarchies,+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow, setDynamicTooFailed,+        dynamicOutputFile, dynamicOutputHi,+        sccProfilingEnabled,+        DynFlags(..),+        outputFile, hiSuf, objectSuf, ways,+        FlagSpec(..),+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        fFlags, fLangFlags, xFlags,+        wWarningFlags,+        wWarningFlagMap,+        dynFlagDependencies,+        makeDynFlagsConsistent,+        positionIndependent,+        optimisationFlags,+        setFlagsFromEnvFile,+        pprDynFlagsDiff,+        flagSpecOf,+        smallestGroups,++        targetProfile,++        -- ** Safe Haskell+        safeHaskellOn, safeHaskellModeEnabled,+        safeImportsOn, safeLanguageOn, safeInferOn,+        packageTrustOn,+        safeDirectImpsReq, safeImplicitImpsReq,+        unsafeFlags, unsafeFlagsForInfer,++        -- ** LLVM Targets+        LlvmTarget(..), LlvmConfig(..),++        -- ** System tool settings and locations+        Settings(..),+        sProgramName,+        sProjectVersion,+        sGhcUsagePath,+        sGhciUsagePath,+        sToolDir,+        sTopDir,+        sTmpDir,+        sGlobalPackageDatabasePath,+        sLdSupportsCompactUnwind,+        sLdSupportsBuildId,+        sLdSupportsFilelist,+        sLdIsGnuLd,+        sGccSupportsNoPie,+        sPgm_L,+        sPgm_P,+        sPgm_F,+        sPgm_c,+        sPgm_a,+        sPgm_l,+        sPgm_lm,+        sPgm_dll,+        sPgm_T,+        sPgm_windres,+        sPgm_libtool,+        sPgm_ar,+        sPgm_ranlib,+        sPgm_lo,+        sPgm_lc,+        sPgm_lcc,+        sPgm_i,+        sOpt_L,+        sOpt_P,+        sOpt_P_fingerprint,+        sOpt_F,+        sOpt_c,+        sOpt_cxx,+        sOpt_a,+        sOpt_l,+        sOpt_lm,+        sOpt_windres,+        sOpt_lo,+        sOpt_lc,+        sOpt_lcc,+        sOpt_i,+        sExtraGccViaCFlags,+        sTargetPlatformString,+        sGhcWithInterpreter,+        sGhcWithSMP,+        sGhcRTSWays,+        sLibFFI,+        sGhcRtsWithLibdw,+        GhcNameVersion(..),+        FileSettings(..),+        PlatformMisc(..),+        settings,+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir, tmpDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,+        pgm_L, pgm_P, pgm_F, pgm_c, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,+        pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool,+        pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,+        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,+        opt_P_signature,+        opt_windres, opt_lo, opt_lc, opt_lcc,+        updatePlatformConstants,++        -- ** Manipulating DynFlags+        addPluginModuleName,+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        defaultFlushErr,++        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]+        getVerbFlags,+        updOptLevel,+        setTmpDir,+        setUnitId,++        TurnOnFlag,+        turnOn,+        turnOff,+        impliedGFlags,+        impliedOffGFlags,+        impliedXFlags,++        -- ** Parsing DynFlags+        parseDynamicFlagsCmdLine,+        parseDynamicFilePragma,+        parseDynamicFlagsFull,++        -- ** Available DynFlags+        allNonDeprecatedFlags,+        flagsAll,+        flagsDynamic,+        flagsPackage,+        flagsForCompletion,++        supportedLanguagesAndExtensions,+        languageExtensions,++        -- ** DynFlags C compiler options+        picCCOpts, picPOpts,++        -- * Compiler configuration suitable for display to the user+        compilerInfo,++        wordAlignment,++        setUnsafeGlobalDynFlags,++        -- * SSE and AVX+        isSseEnabled,+        isSse2Enabled,+        isSse4_2Enabled,+        isBmiEnabled,+        isBmi2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,++        -- * Linker/compiler information+        LinkerInfo(..),+        CompilerInfo(..),+        useXLinkerRPath,++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile++import GHC.UniqueSubdir (uniqueSubdir)+import GHC.Unit.Types+import GHC.Unit.Parser+import GHC.Unit.Module+import GHC.Builtin.Names ( mAIN_NAME )+import GHC.Driver.Phases ( Phase(..), phaseInputExt )+import GHC.Driver.Flags+import GHC.Driver.Backend+import GHC.Settings.Config+import GHC.Utils.CliOption+import {-# SOURCE #-} GHC.Core.Unfold+import GHC.Driver.CmdLine hiding (WarnReason(..))+import qualified GHC.Driver.CmdLine as Cmd+import GHC.Settings.Constants+import GHC.Utils.Panic+import qualified GHC.Utils.Ppr.Colour as Col+import GHC.Utils.Misc+import GHC.Utils.GlobalVars+import GHC.Data.Maybe+import GHC.Utils.Monad+import GHC.Types.SrcLoc+import GHC.Types.SafeHaskell+import GHC.Types.Basic ( Alignment, alignmentOf, IntWithInf, treatZeroAsInf )+import qualified GHC.Types.FieldLabel as FieldLabel+import GHC.Data.FastString+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable+import GHC.Settings+import GHC.CmmToAsm.CFG.Weight+import {-# SOURCE #-} GHC.Core.Opt.CallerCC++import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )+import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )++import Data.IORef+import Control.Arrow ((&&&))+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Writer+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Except++import Data.Ord+import Data.Char+import Data.List (intercalate, sortBy)+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import System.FilePath+import System.Directory+import System.Environment (lookupEnv)+import System.IO+import System.IO.Error+import Text.ParserCombinators.ReadP hiding (char)+import Text.ParserCombinators.ReadP as R++import GHC.Data.EnumSet (EnumSet)+import qualified GHC.Data.EnumSet as EnumSet++import GHC.Foreign (withCString, peekCString)+import qualified GHC.LanguageExtensions as LangExt++-- Note [Updating flag description in the User's Guide]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you modify anything in this file please make sure that your changes are+-- described in the User's Guide. Please update the flag description in the+-- users guide (docs/users_guide) whenever you add or change a flag.++-- Note [Supporting CLI completion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The command line interface completion (in for example bash) is an easy way+-- for the developer to learn what flags are available from GHC.+-- GHC helps by separating which flags are available when compiling with GHC,+-- and which flags are available when using GHCi.+-- A flag is assumed to either work in both these modes, or only in one of them.+-- When adding or changing a flag, please consider for which mode the flag will+-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,+-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.++-- Note [Adding a language extension]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are a few steps to adding (or removing) a language extension,+--+--  * Adding the extension to GHC.LanguageExtensions+--+--    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs+--    is the canonical list of language extensions known by GHC.+--+--  * Adding a flag to DynFlags.xFlags+--+--    This is fairly self-explanatory. The name should be concise, memorable,+--    and consistent with any previous implementations of the similar idea in+--    other Haskell compilers.+--+--  * Adding the flag to the documentation+--+--    This is the same as any other flag. See+--    Note [Updating flag description in the User's Guide]+--+--  * Adding the flag to Cabal+--+--    The Cabal library has its own list of all language extensions supported+--    by all major compilers. This is the list that user code being uploaded+--    to Hackage is checked against to ensure language extension validity.+--    Consequently, it is very important that this list remains up-to-date.+--+--    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)+--    whose job it is to ensure these GHC's extensions are consistent with+--    Cabal.+--+--    The recommended workflow is,+--+--     1. Temporarily add your new language extension to the+--        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't+--        break while Cabal is updated.+--+--     2. After your GHC change is accepted, submit a Cabal pull request adding+--        your new extension to Cabal's list (found in+--        Cabal/Language/Haskell/Extension.hs).+--+--     3. After your Cabal change is accepted, let the GHC developers know so+--        they can update the Cabal submodule and remove the extensions from+--        expectedGhcOnlyExtensions.+--+--  * Adding the flag to the GHC Wiki+--+--    There is a change log tracking language extension additions and removals+--    on the GHC wiki:  https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history+--+--  See #4437 and #8176.++-- -----------------------------------------------------------------------------+-- DynFlags++-- | Used to differentiate the scope an include needs to apply to.+-- We have to split the include paths to avoid accidentally forcing recursive+-- includes since -I overrides the system search paths. See #14312.+data IncludeSpecs+  = IncludeSpecs { includePathsQuote  :: [String]+                 , includePathsGlobal :: [String]+                 -- | See note [Implicit include paths]+                 , includePathsQuoteImplicit :: [String]+                 }+  deriving Show++-- | Append to the list of includes a path that shall be included using `-I`+-- when the C compiler is called. These paths override system search paths.+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addGlobalInclude spec paths  = let f = includePathsGlobal spec+                               in spec { includePathsGlobal = f ++ paths }++-- | Append to the list of includes a path that shall be included using+-- `-iquote` when the C compiler is called. These paths only apply when quoted+-- includes are used. e.g. #include "foo.h"+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addQuoteInclude spec paths  = let f = includePathsQuote spec+                              in spec { includePathsQuote = f ++ paths }++-- | These includes are not considered while fingerprinting the flags for iface+-- | See note [Implicit include paths]+addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec+                              in spec { includePathsQuoteImplicit = f ++ paths }+++-- | Concatenate and flatten the list of global and quoted includes returning+-- just a flat list of paths.+flattenIncludes :: IncludeSpecs -> [String]+flattenIncludes specs =+    includePathsQuote specs +++    includePathsQuoteImplicit specs +++    includePathsGlobal specs++{- Note [Implicit include paths]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  The compile driver adds the path to the folder containing the source file being+  compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'+  that are used later to compute the interface file. Because of this,+  the flags fingerprint derived from these 'DynFlags' and recorded in the+  interface file will end up containing the absolute path to the source folder.++  Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)+  store the build artifacts produced by a build BA for reuse in subsequent builds.++  Embedding source paths in interface fingerprints will thwart these attemps and+  lead to unnecessary recompilations when the source paths in BA differ from the+  source paths in subsequent builds.+ -}+++-- | Contains not only a collection of 'GeneralFlag's but also a plethora of+-- information relating to the compilation of a single file or GHC session+data DynFlags = DynFlags {+  ghcMode               :: GhcMode,+  ghcLink               :: GhcLink,+  backend               :: !Backend,+   -- ^ The backend to use (if any).+   --+   -- Whenever you change the backend, also make sure to set 'ghcLink' to+   -- something sensible.+   --+   -- 'NoBackend' can be used to avoid generating any output, however, note that:+   --+   --  * If a program uses Template Haskell the typechecker may need to run code+   --    from an imported module.  To facilitate this, code generation is enabled+   --    for modules imported by modules that use template haskell, using the+   --    default backend for the platform.+   --    See Note [-fno-code mode].+++  -- formerly Settings+  ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,+  fileSettings      :: {-# UNPACK #-} !FileSettings,+  targetPlatform    :: Platform,       -- Filled in by SysTools+  toolSettings      :: {-# UNPACK #-} !ToolSettings,+  platformMisc      :: {-# UNPACK #-} !PlatformMisc,+  rawSettings       :: [(String, String)],++  llvmConfig            :: LlvmConfig,+    -- ^ N.B. It's important that this field is lazy since we load the LLVM+    -- configuration lazily. See Note [LLVM Configuration] in "GHC.SysTools".+  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]+  optLevel              :: Int,         -- ^ Optimisation level+  debugLevel            :: Int,         -- ^ How much debug information to produce+  simplPhases           :: Int,         -- ^ Number of simplifier phases+  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations+  ruleCheck             :: Maybe String,+  inlineCheck           :: Maybe String, -- ^ A prefix to report inlining decisions about+  strictnessBefore      :: [Int],       -- ^ Additional demand analysis++  parMakeCount          :: Maybe Int,   -- ^ The number of modules to compile in parallel+                                        --   in --make mode, where Nothing ==> compile as+                                        --   many in parallel as there are CPUs.++  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?+  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.++  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt+                                        --   to show in type error messages+  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show+                                        --   in typed hole error messages+  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole+                                        --   fits to show in typed hole error+                                        --   messages+  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for+                                        --   refinement hole fits in typed hole+                                        --   error messages+  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show+                                        --   in non-exhaustiveness warnings+  maxPmCheckModels      :: Int,         -- ^ Soft limit on the number of models+                                        --   the pattern match checker checks+                                        --   a pattern against. A safe guard+                                        --   against exponential blow-up.+  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks+  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr+  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function+  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types+                                        --   Not optional; otherwise ForceSpecConstr can diverge.+  binBlobThreshold      :: Word,        -- ^ Binary literals (e.g. strings) whose size is above+                                        --   this threshold will be dumped in a binary file+                                        --   by the assembler code generator (0 to disable)+  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase+  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating+                                        --   See 'GHC.Core.Opt.Monad.FloatOutSwitches'++  liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   recursive function.+  liftLamsNonRecArgs    :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   non-recursive function.+  liftLamsKnown         :: Bool,        -- ^ Lambda lift even when this turns a known call+                                        --   into an unknown call.++  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.++  historySize           :: Int,         -- ^ Simplification history size++  importPaths           :: [FilePath],+  mainModuleNameIs      :: ModuleName,+  mainFunIs             :: Maybe String,+  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth+  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver+                                         --   Typically only 1 is needed++  homeUnitId_             :: UnitId,                 -- ^ Target home unit-id+  homeUnitInstanceOf_     :: Maybe UnitId,           -- ^ Id of the unit to instantiate+  homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations++  -- ways+  targetWays_           :: Ways,         -- ^ Target way flags from the command line++  -- For object splitting+  splitInfo             :: Maybe (String,Int),++  -- paths etc.+  objectDir             :: Maybe String,+  dylibInstallName      :: Maybe String,+  hiDir                 :: Maybe String,+  hieDir                :: Maybe String,+  stubDir               :: Maybe String,+  dumpDir               :: Maybe String,++  objectSuf_            :: String,+  hcSuf                 :: String,+  hiSuf_                :: String,+  hieSuf                :: String,++  dynamicTooFailed      :: IORef Bool,+  dynObjectSuf_         :: String,+  dynHiSuf_             :: String,++  outputFile_           :: Maybe String,+  dynOutputFile_        :: Maybe String,+  outputHi              :: Maybe String,+  dynOutputHi           :: Maybe String,+  dynLibLoader          :: DynLibLoader,++  dynamicNow            :: !Bool, -- ^ Indicate if we are now generating dynamic output+                                  -- because of -dynamic-too. This predicate is+                                  -- used to query the appropriate fields+                                  -- (outputFile/dynOutputFile, ways, etc.)++  -- | This is set by 'GHC.Driver.Pipeline.runPipeline'+  --    or 'ghc.GHCi.UI.runStmt' based on where its output is going.+  dumpPrefix            :: Maybe FilePath,++  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.runPipeline'+  --    or 'ghc.GHCi.UI.runStmt'.+  --    Set by @-ddump-file-prefix@+  dumpPrefixForce       :: Maybe FilePath,++  ldInputs              :: [Option],++  includePaths          :: IncludeSpecs,+  libraryPaths          :: [String],+  frameworkPaths        :: [String],    -- used on darwin only+  cmdlineFrameworks     :: [String],    -- ditto++  rtsOpts               :: Maybe String,+  rtsOptsEnabled        :: RtsOptsEnabled,+  rtsOptsSuggestions    :: Bool,++  hpcDir                :: String,      -- ^ Path to store the .mix files++  -- Plugins+  pluginModNames        :: [ModuleName],+  pluginModNameOpts     :: [(ModuleName,String)],+  frontendPluginOpts    :: [String],+    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.++  --  For ghc -M+  depMakefile           :: FilePath,+  depIncludePkgDeps     :: Bool,+  depIncludeCppDeps     :: Bool,+  depExcludeMods        :: [ModuleName],+  depSuffixes           :: [String],++  --  Package flags+  packageDBFlags        :: [PackageDBFlag],+        -- ^ The @-package-db@ flags given on the command line, In+        -- *reverse* order that they're specified on the command line.+        -- This is intended to be applied with the list of "initial"+        -- package databases derived from @GHC_PACKAGE_PATH@; see+        -- 'getUnitDbRefs'.++  ignorePackageFlags    :: [IgnorePackageFlag],+        -- ^ The @-ignore-package@ flags from the command line.+        -- In *reverse* order that they're specified on the command line.+  packageFlags          :: [PackageFlag],+        -- ^ The @-package@ and @-hide-package@ flags from the command-line.+        -- In *reverse* order that they're specified on the command line.+  pluginPackageFlags    :: [PackageFlag],+        -- ^ The @-plugin-package-id@ flags from command line.+        -- In *reverse* order that they're specified on the command line.+  trustFlags            :: [TrustFlag],+        -- ^ The @-trust@ and @-distrust@ flags.+        -- In *reverse* order that they're specified on the command line.+  packageEnv            :: Maybe FilePath,+        -- ^ Filepath to the package environment file (if overriding default)+++  -- hsc dynamic flags+  dumpFlags             :: EnumSet DumpFlag,+  generalFlags          :: EnumSet GeneralFlag,+  warningFlags          :: EnumSet WarningFlag,+  fatalWarningFlags     :: EnumSet WarningFlag,+  -- Don't change this without updating extensionFlags:+  language              :: Maybe Language,+  -- | Safe Haskell mode+  safeHaskell           :: SafeHaskellMode,+  safeInfer             :: Bool,+  safeInferred          :: Bool,+  -- We store the location of where some extension and flags were turned on so+  -- we can produce accurate error messages when Safe Haskell fails due to+  -- them.+  thOnLoc               :: SrcSpan,+  newDerivOnLoc         :: SrcSpan,+  deriveViaOnLoc        :: SrcSpan,+  overlapInstLoc        :: SrcSpan,+  incoherentOnLoc       :: SrcSpan,+  pkgTrustOnLoc         :: SrcSpan,+  warnSafeOnLoc         :: SrcSpan,+  warnUnsafeOnLoc       :: SrcSpan,+  trustworthyOnLoc      :: SrcSpan,+  -- Don't change this without updating extensionFlags:+  -- Here we collect the settings of the language extensions+  -- from the command line, the ghci config file and+  -- from interactive :set / :seti commands.+  extensions            :: [OnOff LangExt.Extension],+  -- extensionFlags should always be equal to+  --     flattenExtensionFlags language extensions+  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used+  -- by template-haskell+  extensionFlags        :: EnumSet LangExt.Extension,++  -- | Unfolding control+  -- See Note [Discounts and thresholds] in GHC.Core.Unfold+  unfoldingOpts         :: !UnfoldingOpts,++  maxWorkerArgs         :: Int,++  ghciHistSize          :: Int,++  flushOut              :: FlushOut,+  flushErr              :: FlushErr,++  ghcVersionFile        :: Maybe FilePath,+  haddockOptions        :: Maybe String,++  -- | GHCi scripts specified by -ghci-script, in reverse order+  ghciScripts           :: [String],++  -- Output style options+  pprUserLength         :: Int,+  pprCols               :: Int,++  useUnicode            :: Bool,+  useColor              :: OverridingBool,+  canUseColor           :: Bool,+  colScheme             :: Col.Scheme,++  -- | what kind of {-# SCC #-} to add automatically+  profAuto              :: ProfAuto,+  callerCcFilters       :: [CallerCcFilter],++  interactivePrint      :: Maybe String,++  nextWrapperNum        :: IORef (ModuleEnv Int),++  -- | Machine dependent flags (-m\<blah> stuff)+  sseVersion            :: Maybe SseVersion,+  bmiVersion            :: Maybe BmiVersion,+  avx                   :: Bool,+  avx2                  :: Bool,+  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.+  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.+  avx512f               :: Bool, -- Enable AVX-512 instructions.+  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.++  -- | Run-time linker information (what options we need, etc.)+  rtldInfo              :: IORef (Maybe LinkerInfo),++  -- | Run-time compiler information+  rtccInfo              :: IORef (Maybe CompilerInfo),++  -- Constants used to control the amount of optimization done.++  -- | Max size, in bytes, of inline array allocations.+  maxInlineAllocSize    :: Int,++  -- | Only inline memcpy if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemcpyInsns  :: Int,++  -- | Only inline memset if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemsetInsns  :: Int,++  -- | Reverse the order of error messages in GHC/GHCi+  reverseErrors         :: Bool,++  -- | Limit the maximum number of errors to show+  maxErrors             :: Maybe Int,++  -- | Unique supply configuration for testing build determinism+  initialUnique         :: Word,+  uniqueIncrement       :: Int,+    -- 'Int' because it can be used to test uniques in decreasing order.++  -- | Temporary: CFG Edge weights for fast iterations+  cfgWeights            :: Weights+}++class HasDynFlags m where+    getDynFlags :: m DynFlags++{- It would be desirable to have the more generalised++  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where+      getDynFlags = lift getDynFlags++instance definition. However, that definition would overlap with the+`HasDynFlags (GhcT m)` instance. Instead we define instances for a+couple of common Monad transformers explicitly. -}++instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where+    getDynFlags = lift getDynFlags++class ContainsDynFlags t where+    extractDynFlags :: t -> DynFlags++data ProfAuto+  = NoProfAuto         -- ^ no SCC annotations added+  | ProfAutoAll        -- ^ top-level and nested functions are annotated+  | ProfAutoTop        -- ^ top-level functions annotated only+  | ProfAutoExports    -- ^ exported functions annotated only+  | ProfAutoCalls      -- ^ annotate call-sites+  deriving (Eq,Enum)++data LlvmTarget = LlvmTarget+  { lDataLayout :: String+  , lCPU        :: String+  , lAttributes :: [String]+  }++-- | See Note [LLVM Configuration] in "GHC.SysTools".+data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)]+                             , llvmPasses  :: [(Int, String)]+                             }++-----------------------------------------------------------------------------+-- Accessessors from 'DynFlags'++-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the+-- vast majority of code. But GHCi questionably uses this to produce a default+-- 'DynFlags' from which to compute a flags diff for printing.+settings :: DynFlags -> Settings+settings dflags = Settings+  { sGhcNameVersion = ghcNameVersion dflags+  , sFileSettings = fileSettings dflags+  , sTargetPlatform = targetPlatform dflags+  , sToolSettings = toolSettings dflags+  , sPlatformMisc = platformMisc dflags+  , sRawSettings = rawSettings dflags+  }++programName :: DynFlags -> String+programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags+projectVersion :: DynFlags -> String+projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags)+ghcUsagePath          :: DynFlags -> FilePath+ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags+ghciUsagePath         :: DynFlags -> FilePath+ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags+toolDir               :: DynFlags -> Maybe FilePath+toolDir dflags = fileSettings_toolDir $ fileSettings dflags+topDir                :: DynFlags -> FilePath+topDir dflags = fileSettings_topDir $ fileSettings dflags+tmpDir                :: DynFlags -> String+tmpDir dflags = fileSettings_tmpDir $ fileSettings dflags+extraGccViaCFlags     :: DynFlags -> [String]+extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags+globalPackageDatabasePath   :: DynFlags -> FilePath+globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags+pgm_L                 :: DynFlags -> String+pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags+pgm_P                 :: DynFlags -> (String,[Option])+pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags+pgm_F                 :: DynFlags -> String+pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags+pgm_c                 :: DynFlags -> String+pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags+pgm_a                 :: DynFlags -> (String,[Option])+pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags+pgm_l                 :: DynFlags -> (String,[Option])+pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags+pgm_lm                 :: DynFlags -> (String,[Option])+pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags+pgm_dll               :: DynFlags -> (String,[Option])+pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags+pgm_T                 :: DynFlags -> String+pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags+pgm_windres           :: DynFlags -> String+pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags+pgm_libtool           :: DynFlags -> String+pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags+pgm_lcc               :: DynFlags -> (String,[Option])+pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags+pgm_ar                :: DynFlags -> String+pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags+pgm_otool             :: DynFlags -> String+pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags+pgm_install_name_tool :: DynFlags -> String+pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ toolSettings dflags+pgm_ranlib            :: DynFlags -> String+pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags+pgm_lo                :: DynFlags -> (String,[Option])+pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags+pgm_lc                :: DynFlags -> (String,[Option])+pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags+pgm_i                 :: DynFlags -> String+pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags+opt_L                 :: DynFlags -> [String]+opt_L dflags = toolSettings_opt_L $ toolSettings dflags+opt_P                 :: DynFlags -> [String]+opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_P (toolSettings dflags)++-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_P_signature       :: DynFlags -> ([String], Fingerprint)+opt_P_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_P_fingerprint $ toolSettings dflags+  )++opt_F                 :: DynFlags -> [String]+opt_F dflags= toolSettings_opt_F $ toolSettings dflags+opt_c                 :: DynFlags -> [String]+opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_c (toolSettings dflags)+opt_cxx               :: DynFlags -> [String]+opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags+opt_a                 :: DynFlags -> [String]+opt_a dflags= toolSettings_opt_a $ toolSettings dflags+opt_l                 :: DynFlags -> [String]+opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_l (toolSettings dflags)+opt_lm                :: DynFlags -> [String]+opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags+opt_windres           :: DynFlags -> [String]+opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags+opt_lcc                :: DynFlags -> [String]+opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags+opt_lo                :: DynFlags -> [String]+opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags+opt_lc                :: DynFlags -> [String]+opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags+opt_i                 :: DynFlags -> [String]+opt_i dflags= toolSettings_opt_i $ toolSettings dflags++-- | The directory for this version of ghc in the user's app directory+-- (typically something like @~/.ghc/x86_64-linux-7.6.3@)+--+versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath+versionedAppDir appname platform = do+  -- Make sure we handle the case the HOME isn't set (see #11678)+  appdir <- tryMaybeT $ getXdgDirectory XdgData appname+  return $ appdir </> versionedFilePath platform++versionedFilePath :: ArchOS -> FilePath+versionedFilePath platform = uniqueSubdir platform++-- | The 'GhcMode' tells us whether we're doing multi-module+-- compilation (controlled via the "GHC" API) or one-shot+-- (single-module) compilation.  This makes a difference primarily to+-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for+-- imported modules, but in multi-module mode we look for source files+-- in order to check whether they need to be recompiled.+data GhcMode+  = CompManager         -- ^ @\-\-make@, GHCi, etc.+  | OneShot             -- ^ @ghc -c Foo.hs@+  | MkDepend            -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this+  deriving Eq++instance Outputable GhcMode where+  ppr CompManager = text "CompManager"+  ppr OneShot     = text "OneShot"+  ppr MkDepend    = text "MkDepend"++isOneShot :: GhcMode -> Bool+isOneShot OneShot = True+isOneShot _other  = False++-- | What to do in the link step, if there is one.+data GhcLink+  = NoLink              -- ^ Don't link at all+  | LinkBinary          -- ^ Link object code into a binary+  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both+                        --   bytecode and object code).+  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)+  | LinkStaticLib       -- ^ Link objects into a static lib+  deriving (Eq, Show)++isNoLink :: GhcLink -> Bool+isNoLink NoLink = True+isNoLink _      = False++-- | We accept flags which make packages visible, but how they select+-- the package varies; this data type reflects what selection criterion+-- is used.+data PackageArg =+      PackageArg String    -- ^ @-package@, by 'PackageName'+    | UnitIdArg Unit       -- ^ @-package-id@, by 'Unit'+  deriving (Eq, Show)++instance Outputable PackageArg where+    ppr (PackageArg pn) = text "package" <+> text pn+    ppr (UnitIdArg uid) = text "unit" <+> ppr uid++-- | Represents the renaming that may be associated with an exposed+-- package, e.g. the @rns@ part of @-package "foo (rns)"@.+--+-- Here are some example parsings of the package flags (where+-- a string literal is punned to be a 'ModuleName':+--+--      * @-package foo@ is @ModRenaming True []@+--      * @-package foo ()@ is @ModRenaming False []@+--      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@+--      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@+--      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@+data ModRenaming = ModRenaming {+    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?+    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope+                                               --   under name @n@.+  } deriving (Eq)+instance Outputable ModRenaming where+    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)++-- | Flags for manipulating the set of non-broken packages.+newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@+  deriving (Eq)++-- | Flags for manipulating package trust.+data TrustFlag+  = TrustPackage    String -- ^ @-trust@+  | DistrustPackage String -- ^ @-distrust@+  deriving (Eq)++-- | Flags for manipulating packages visibility.+data PackageFlag+  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@+  | HidePackage     String -- ^ @-hide-package@+  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged++data PackageDBFlag+  = PackageDB PkgDbRef+  | NoUserPackageDB+  | NoGlobalPackageDB+  | ClearPackageDBs+  deriving (Eq)++packageFlagsChanged :: DynFlags -> DynFlags -> Bool+packageFlagsChanged idflags1 idflags0 =+  packageFlags idflags1 /= packageFlags idflags0 ||+  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||+  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||+  trustFlags idflags1 /= trustFlags idflags0 ||+  packageDBFlags idflags1 /= packageDBFlags idflags0 ||+  packageGFlags idflags1 /= packageGFlags idflags0+ where+   packageGFlags dflags = map (`gopt` dflags)+     [ Opt_HideAllPackages+     , Opt_HideAllPluginPackages+     , Opt_AutoLinkPackages ]++instance Outputable PackageFlag where+    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)+    ppr (HidePackage str) = text "-hide-package" <+> text str++data DynLibLoader+  = Deployable+  | SystemDependent+  deriving Eq++data RtsOptsEnabled+  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly+  | RtsOptsAll+  deriving (Show)++-- | Are we building with @-fPIE@ or @-fPIC@ enabled?+positionIndependent :: DynFlags -> Bool+positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags++-- Note [-dynamic-too business]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic+-- objects in a single run of the compiler: the pipeline is the same down to+-- Core optimisation, then the backend (from Core to object code) is executed+-- twice.+--+-- The implementation is currently rather hacky: recompilation avoidance is+-- broken (#17968), we don't clearly separate non-dynamic and dynamic loaded+-- interfaces (#9176), etc.+--+-- To make matters worse, we automatically enable -dynamic-too when some modules+-- need Template-Haskell and GHC is dynamically linked (cf+-- GHC.Driver.Pipeline.compileOne').+--+-- This somewhat explains why we have "dynamicTooFailed :: IORef Bool" in+-- DynFlags: when -dynamic-too is enabled, we try to build the dynamic objects,+-- but we may fail and we shouldn't abort the whole compilation because the user+-- may not even have asked for -dynamic-too in the first place. So instead we+-- use this global variable to indicate that we can't build dynamic objects and+-- compilation continues to build non-dynamic objects only. At the end of the+-- non-dynamic pipeline, if this value indicates that the dynamic compilation+-- failed, we run the whole pipeline again for the dynamic way (except on+-- Windows...). See GHC.Driver.Pipeline.runPipeline.++data DynamicTooState+   = DT_Dont    -- ^ Don't try to build dynamic objects too+   | DT_Failed  -- ^ Won't try to generate dynamic objects for some reason+   | DT_OK      -- ^ Will still try to generate dynamic objects+   | DT_Dyn     -- ^ Currently generating dynamic objects (in the backend)+   deriving (Eq,Show,Ord)++dynamicTooState :: MonadIO m => DynFlags -> m DynamicTooState+dynamicTooState dflags+   | not (gopt Opt_BuildDynamicToo dflags) = return DT_Dont+   | otherwise = do+      failed <- liftIO $ readIORef (dynamicTooFailed dflags)+      if failed+         then return DT_Failed+         else if dynamicNow dflags+               then return DT_Dyn+               else return DT_OK++setDynamicNow :: DynFlags -> DynFlags+setDynamicNow dflags0 =+   dflags0+      { dynamicNow = True+      }++setDynamicTooFailed :: MonadIO m => DynFlags -> m ()+setDynamicTooFailed dflags =+   liftIO $ writeIORef (dynamicTooFailed dflags) True++-- | Compute the path of the dynamic object corresponding to an object file.+dynamicOutputFile :: DynFlags -> FilePath -> FilePath+dynamicOutputFile dflags outputFile = outputFile -<.> dynObjectSuf_ dflags++dynamicOutputHi :: DynFlags -> FilePath -> FilePath+dynamicOutputHi dflags hi = hi -<.> dynHiSuf_ dflags++-----------------------------------------------------------------------------++-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value+initDynFlags :: DynFlags -> IO DynFlags+initDynFlags dflags = do+ let -- We can't build with dynamic-too on Windows, as labels before+     -- the fork point are different depending on whether we are+     -- building dynamically or not.+     platformCanGenerateDynamicToo+         = platformOS (targetPlatform dflags) /= OSMinGW32+ refDynamicTooFailed <- newIORef (not platformCanGenerateDynamicToo)+ refRtldInfo <- newIORef Nothing+ refRtccInfo <- newIORef Nothing+ wrapperNum <- newIORef emptyModuleEnv+ canUseUnicode <- do let enc = localeEncoding+                         str = "‘’"+                     (withCString enc str $ \cstr ->+                          do str' <- peekCString enc cstr+                             return (str == str'))+                         `catchIOError` \_ -> return False+ ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"+ let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode+ maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"+ maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"+ let adjustCols (Just env) = Col.parseScheme env+     adjustCols Nothing    = id+ let (useColor', colScheme') =+       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)+       (useColor dflags, colScheme dflags)+ return dflags{+        dynamicTooFailed = refDynamicTooFailed,+        nextWrapperNum = wrapperNum,+        useUnicode    = useUnicode',+        useColor      = useColor',+        canUseColor   = stderrSupportsAnsiColors,+        colScheme     = colScheme',+        rtldInfo      = refRtldInfo,+        rtccInfo      = refRtccInfo+        }++-- | The normal 'DynFlags'. Note that they are not suitable for use in this form+-- and must be fully initialized by 'GHC.runGhc' first.+defaultDynFlags :: Settings -> LlvmConfig -> DynFlags+defaultDynFlags mySettings llvmConfig =+-- See Note [Updating flag description in the User's Guide]+     DynFlags {+        ghcMode                 = CompManager,+        ghcLink                 = LinkBinary,+        backend                 = platformDefaultBackend (sTargetPlatform mySettings),+        verbosity               = 0,+        optLevel                = 0,+        debugLevel              = 0,+        simplPhases             = 2,+        maxSimplIterations      = 4,+        ruleCheck               = Nothing,+        inlineCheck             = Nothing,+        binBlobThreshold        = 500000, -- 500K is a good default (see #16190)+        maxRelevantBinds        = Just 6,+        maxValidHoleFits   = Just 6,+        maxRefHoleFits     = Just 6,+        refLevelHoleFits   = Nothing,+        maxUncoveredPatterns    = 4,+        maxPmCheckModels        = 30,+        simplTickFactor         = 100,+        specConstrThreshold     = Just 2000,+        specConstrCount         = Just 3,+        specConstrRecursive     = 3,+        liberateCaseThreshold   = Just 2000,+        floatLamArgs            = Just 0, -- Default: float only if no fvs+        liftLamsRecArgs         = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsNonRecArgs      = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsKnown           = False,  -- Default: don't turn known calls into unknown ones+        cmmProcAlignment        = Nothing,++        historySize             = 20,+        strictnessBefore        = [],++        parMakeCount            = Just 1,++        enableTimeStats         = False,+        ghcHeapSize             = Nothing,++        importPaths             = ["."],+        mainModuleNameIs        = mAIN_NAME,+        mainFunIs               = Nothing,+        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,+        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,++        homeUnitId_             = mainUnitId,+        homeUnitInstanceOf_     = Nothing,+        homeUnitInstantiations_ = [],++        objectDir               = Nothing,+        dylibInstallName        = Nothing,+        hiDir                   = Nothing,+        hieDir                  = Nothing,+        stubDir                 = Nothing,+        dumpDir                 = Nothing,++        objectSuf_              = phaseInputExt StopLn,+        hcSuf                   = phaseInputExt HCc,+        hiSuf_                  = "hi",+        hieSuf                  = "hie",++        dynamicTooFailed        = panic "defaultDynFlags: No dynamicTooFailed",+        dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,+        dynHiSuf_               = "dyn_hi",+        dynamicNow              = False,++        pluginModNames          = [],+        pluginModNameOpts       = [],+        frontendPluginOpts      = [],++        outputFile_             = Nothing,+        dynOutputFile_          = Nothing,+        outputHi                = Nothing,+        dynOutputHi             = Nothing,+        dynLibLoader            = SystemDependent,+        dumpPrefix              = Nothing,+        dumpPrefixForce         = Nothing,+        ldInputs                = [],+        includePaths            = IncludeSpecs [] [] [],+        libraryPaths            = [],+        frameworkPaths          = [],+        cmdlineFrameworks       = [],+        rtsOpts                 = Nothing,+        rtsOptsEnabled          = RtsOptsSafeOnly,+        rtsOptsSuggestions      = True,++        hpcDir                  = ".hpc",++        packageDBFlags          = [],+        packageFlags            = [],+        pluginPackageFlags      = [],+        ignorePackageFlags      = [],+        trustFlags              = [],+        packageEnv              = Nothing,+        targetWays_             = Set.empty,+        splitInfo               = Nothing,++        ghcNameVersion = sGhcNameVersion mySettings,+        fileSettings = sFileSettings mySettings,+        toolSettings = sToolSettings mySettings,+        targetPlatform = sTargetPlatform mySettings,+        platformMisc = sPlatformMisc mySettings,+        rawSettings = sRawSettings mySettings,++        -- See Note [LLVM configuration].+        llvmConfig              = llvmConfig,++        -- ghc -M values+        depMakefile       = "Makefile",+        depIncludePkgDeps = False,+        depIncludeCppDeps = False,+        depExcludeMods    = [],+        depSuffixes       = [],+        -- end of ghc -M values+        ghcVersionFile = Nothing,+        haddockOptions = Nothing,+        dumpFlags = EnumSet.empty,+        generalFlags = EnumSet.fromList (defaultFlags mySettings),+        warningFlags = EnumSet.fromList standardWarnings,+        fatalWarningFlags = EnumSet.empty,+        ghciScripts = [],+        language = Nothing,+        safeHaskell = Sf_None,+        safeInfer   = True,+        safeInferred = True,+        thOnLoc = noSrcSpan,+        newDerivOnLoc = noSrcSpan,+        deriveViaOnLoc = noSrcSpan,+        overlapInstLoc = noSrcSpan,+        incoherentOnLoc = noSrcSpan,+        pkgTrustOnLoc = noSrcSpan,+        warnSafeOnLoc = noSrcSpan,+        warnUnsafeOnLoc = noSrcSpan,+        trustworthyOnLoc = noSrcSpan,+        extensions = [],+        extensionFlags = flattenExtensionFlags Nothing [],++        unfoldingOpts = defaultUnfoldingOpts,+        maxWorkerArgs = 10,++        ghciHistSize = 50, -- keep a log of length 50 by default++        flushOut = defaultFlushOut,+        flushErr = defaultFlushErr,+        pprUserLength = 5,+        pprCols = 100,+        useUnicode = False,+        useColor = Auto,+        canUseColor = False,+        colScheme = Col.defaultScheme,+        profAuto = NoProfAuto,+        callerCcFilters = [],+        interactivePrint = Nothing,+        nextWrapperNum = panic "defaultDynFlags: No nextWrapperNum",+        sseVersion = Nothing,+        bmiVersion = Nothing,+        avx = False,+        avx2 = False,+        avx512cd = False,+        avx512er = False,+        avx512f = False,+        avx512pf = False,+        rtldInfo = panic "defaultDynFlags: no rtldInfo",+        rtccInfo = panic "defaultDynFlags: no rtccInfo",++        maxInlineAllocSize = 128,+        maxInlineMemcpyInsns = 32,+        maxInlineMemsetInsns = 32,++        initialUnique = 0,+        uniqueIncrement = 1,++        reverseErrors = False,+        maxErrors     = Nothing,+        cfgWeights    = defaultWeights+      }++type FatalMessager = String -> IO ()++defaultFatalMessager :: FatalMessager+defaultFatalMessager = hPutStrLn stderr+++newtype FlushOut = FlushOut (IO ())++defaultFlushOut :: FlushOut+defaultFlushOut = FlushOut $ hFlush stdout++newtype FlushErr = FlushErr (IO ())++defaultFlushErr :: FlushErr+defaultFlushErr = FlushErr $ hFlush stderr++{-+Note [Verbosity levels]+~~~~~~~~~~~~~~~~~~~~~~~+    0   |   print errors & warnings only+    1   |   minimal verbosity: print "compiling M ... done." for each module.+    2   |   equivalent to -dshow-passes+    3   |   equivalent to existing "ghc -v"+    4   |   "ghc -v -ddump-most"+    5   |   "ghc -v -ddump-all"+-}++data OnOff a = On a+             | Off a+  deriving (Eq, Show)++instance Outputable a => Outputable (OnOff a) where+  ppr (On x)  = text "On" <+> ppr x+  ppr (Off x) = text "Off" <+> ppr x++-- OnOffs accumulate in reverse order, so we use foldr in order to+-- process them in the right order+flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension+flattenExtensionFlags ml = foldr f defaultExtensionFlags+    where f (On f)  flags = EnumSet.insert f flags+          f (Off f) flags = EnumSet.delete f flags+          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)++-- | The language extensions implied by the various language variants.+-- When updating this be sure to update the flag documentation in+-- @docs/users_guide/exts@.+languageExtensions :: Maybe Language -> [LangExt.Extension]++-- Nothing: the default case+languageExtensions Nothing = languageExtensions (Just GHC2021)++languageExtensions (Just Haskell98)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.NPlusKPatterns,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.FieldSelectors,+       LangExt.NondecreasingIndentation+           -- strictly speaking non-standard, but we always had this+           -- on implicitly before the option was added in 7.1, and+           -- turning it off breaks code, so we're keeping it on for+           -- backwards compatibility.  Cabal uses -XHaskell98 by+           -- default unless you specify another language.+      ]++languageExtensions (Just Haskell2010)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec]++languageExtensions (Just GHC2021)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.MonomorphismRestriction,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       -- Now the new extensions (not in Haskell2010)+       LangExt.BangPatterns,+       LangExt.BinaryLiterals,+       LangExt.ConstrainedClassMethods,+       LangExt.ConstraintKinds,+       LangExt.DeriveDataTypeable,+       LangExt.DeriveFoldable,+       LangExt.DeriveFunctor,+       LangExt.DeriveGeneric,+       LangExt.DeriveLift,+       LangExt.DeriveTraversable,+       LangExt.EmptyCase,+       LangExt.EmptyDataDeriving,+       LangExt.ExistentialQuantification,+       LangExt.ExplicitForAll,+       LangExt.FlexibleContexts,+       LangExt.FlexibleInstances,+       LangExt.GADTSyntax,+       LangExt.GeneralizedNewtypeDeriving,+       LangExt.HexFloatLiterals,+       LangExt.ImportQualifiedPost,+       LangExt.InstanceSigs,+       LangExt.KindSignatures,+       LangExt.MultiParamTypeClasses,+       LangExt.RecordPuns,+       LangExt.NamedWildCards,+       LangExt.NumericUnderscores,+       LangExt.PolyKinds,+       LangExt.PostfixOperators,+       LangExt.RankNTypes,+       LangExt.ScopedTypeVariables,+       LangExt.StandaloneDeriving,+       LangExt.StandaloneKindSignatures,+       LangExt.TupleSections,+       LangExt.TypeApplications,+       LangExt.TypeOperators,+       LangExt.TypeSynonymInstances]++hasPprDebug :: DynFlags -> Bool+hasPprDebug = dopt Opt_D_ppr_debug++hasNoDebugOutput :: DynFlags -> Bool+hasNoDebugOutput = dopt Opt_D_no_debug_output++hasNoStateHack :: DynFlags -> Bool+hasNoStateHack = gopt Opt_G_NoStateHack++hasNoOptCoercion :: DynFlags -> Bool+hasNoOptCoercion = gopt Opt_G_NoOptCoercion+++-- | Test whether a 'DumpFlag' is set+dopt :: DumpFlag -> DynFlags -> Bool+dopt f dflags = (f `EnumSet.member` dumpFlags dflags)+             || (verbosity dflags >= 4 && enableIfVerbose f)+    where enableIfVerbose Opt_D_dump_tc_trace               = False+          enableIfVerbose Opt_D_dump_rn_trace               = False+          enableIfVerbose Opt_D_dump_cs_trace               = False+          enableIfVerbose Opt_D_dump_if_trace               = False+          enableIfVerbose Opt_D_dump_vt_trace               = False+          enableIfVerbose Opt_D_dump_tc                     = False+          enableIfVerbose Opt_D_dump_rn                     = False+          enableIfVerbose Opt_D_dump_rn_stats               = False+          enableIfVerbose Opt_D_dump_hi_diffs               = False+          enableIfVerbose Opt_D_verbose_core2core           = False+          enableIfVerbose Opt_D_verbose_stg2stg             = False+          enableIfVerbose Opt_D_dump_splices                = False+          enableIfVerbose Opt_D_th_dec_file                 = False+          enableIfVerbose Opt_D_dump_rule_firings           = False+          enableIfVerbose Opt_D_dump_rule_rewrites          = False+          enableIfVerbose Opt_D_dump_simpl_trace            = False+          enableIfVerbose Opt_D_dump_rtti                   = False+          enableIfVerbose Opt_D_dump_inlinings              = False+          enableIfVerbose Opt_D_dump_core_stats             = False+          enableIfVerbose Opt_D_dump_asm_stats              = False+          enableIfVerbose Opt_D_dump_types                  = False+          enableIfVerbose Opt_D_dump_simpl_iterations       = False+          enableIfVerbose Opt_D_dump_ticked                 = False+          enableIfVerbose Opt_D_dump_view_pattern_commoning = False+          enableIfVerbose Opt_D_dump_mod_cycles             = False+          enableIfVerbose Opt_D_dump_mod_map                = False+          enableIfVerbose Opt_D_dump_ec_trace               = False+          enableIfVerbose _                                 = True++-- | Set a 'DumpFlag'+dopt_set :: DynFlags -> DumpFlag -> DynFlags+dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) }++-- | Unset a 'DumpFlag'+dopt_unset :: DynFlags -> DumpFlag -> DynFlags+dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }++-- | Test whether a 'GeneralFlag' is set+--+-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`)+-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables+-- Opt_SplitSections.+--+gopt :: GeneralFlag -> DynFlags -> Bool+gopt Opt_PIC dflags+   | dynamicNow dflags = True+gopt Opt_ExternalDynamicRefs dflags+   | dynamicNow dflags = True+gopt Opt_SplitSections dflags+   | dynamicNow dflags = False+gopt f dflags = f `EnumSet.member` generalFlags dflags++-- | Set a 'GeneralFlag'+gopt_set :: DynFlags -> GeneralFlag -> DynFlags+gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) }++-- | Unset a 'GeneralFlag'+gopt_unset :: DynFlags -> GeneralFlag -> DynFlags+gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) }++-- | Test whether a 'WarningFlag' is set+wopt :: WarningFlag -> DynFlags -> Bool+wopt f dflags  = f `EnumSet.member` warningFlags dflags++-- | Set a 'WarningFlag'+wopt_set :: DynFlags -> WarningFlag -> DynFlags+wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) }++-- | Unset a 'WarningFlag'+wopt_unset :: DynFlags -> WarningFlag -> DynFlags+wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) }++-- | Test whether a 'WarningFlag' is set as fatal+wopt_fatal :: WarningFlag -> DynFlags -> Bool+wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags++-- | Mark a 'WarningFlag' as fatal (do not set the flag)+wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_set_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) }++-- | Mark a 'WarningFlag' as not fatal+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }++-- | Test whether a 'LangExt.Extension' is set+xopt :: LangExt.Extension -> DynFlags -> Bool+xopt f dflags = f `EnumSet.member` extensionFlags dflags++-- | Set a 'LangExt.Extension'+xopt_set :: DynFlags -> LangExt.Extension -> DynFlags+xopt_set dfs f+    = let onoffs = On f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Unset a 'LangExt.Extension'+xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags+xopt_unset dfs f+    = let onoffs = Off f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Set or unset a 'LangExt.Extension', unless it has been explicitly+--   set or unset before.+xopt_set_unlessExplSpec+        :: LangExt.Extension+        -> (DynFlags -> LangExt.Extension -> DynFlags)+        -> DynFlags -> DynFlags+xopt_set_unlessExplSpec ext setUnset dflags =+    let referedExts = stripOnOff <$> extensions dflags+        stripOnOff (On x)  = x+        stripOnOff (Off x) = x+    in+        if ext `elem` referedExts then dflags else setUnset dflags ext++xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields+xopt_DuplicateRecordFields dfs+  | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields+  | otherwise                              = FieldLabel.NoDuplicateRecordFields++xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors+xopt_FieldSelectors dfs+  | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors+  | otherwise                       = FieldLabel.NoFieldSelectors++lang_set :: DynFlags -> Maybe Language -> DynFlags+lang_set dflags lang =+   dflags {+            language = lang,+            extensionFlags = flattenExtensionFlags lang (extensions dflags)+          }++-- | Set the Haskell language standard to use+setLanguage :: Language -> DynP ()+setLanguage l = upd (`lang_set` Just l)++-- | Some modules have dependencies on others through the DynFlags rather than textual imports+dynFlagDependencies :: DynFlags -> [ModuleName]+dynFlagDependencies = pluginModNames++-- | Is the -fpackage-trust mode on+packageTrustOn :: DynFlags -> Bool+packageTrustOn = gopt Opt_PackageTrust++-- | Is Safe Haskell on in some way (including inference mode)+safeHaskellOn :: DynFlags -> Bool+safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags++safeHaskellModeEnabled :: DynFlags -> Bool+safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy+                                                   , Sf_Safe ]+++-- | Is the Safe Haskell safe language in use+safeLanguageOn :: DynFlags -> Bool+safeLanguageOn dflags = safeHaskell dflags == Sf_Safe++-- | Is the Safe Haskell safe inference mode active+safeInferOn :: DynFlags -> Bool+safeInferOn = safeInfer++-- | Test if Safe Imports are on in some form+safeImportsOn :: DynFlags -> Bool+safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||+                       safeHaskell dflags == Sf_Trustworthy ||+                       safeHaskell dflags == Sf_Safe++-- | Set a 'Safe Haskell' flag+setSafeHaskell :: SafeHaskellMode -> DynP ()+setSafeHaskell s = updM f+    where f dfs = do+              let sf = safeHaskell dfs+              safeM <- combineSafeFlags sf s+              case s of+                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }+                -- leave safe inferrence on in Trustworthy mode so we can warn+                -- if it could have been inferred safe.+                Sf_Trustworthy -> do+                  l <- getCurLoc+                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }+                -- leave safe inference on in Unsafe mode as well.+                _ -> return $ dfs { safeHaskell = safeM }++-- | Are all direct imports required to be safe for this Safe Haskell mode?+-- Direct imports are when the code explicitly imports a module+safeDirectImpsReq :: DynFlags -> Bool+safeDirectImpsReq d = safeLanguageOn d++-- | Are all implicit imports required to be safe for this Safe Haskell mode?+-- Implicit imports are things in the prelude. e.g System.IO when print is used.+safeImplicitImpsReq :: DynFlags -> Bool+safeImplicitImpsReq d = safeLanguageOn d++-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.+-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't+-- want to export this functionality from the module but do want to export the+-- type constructors.+combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode+combineSafeFlags a b | a == Sf_None         = return b+                     | b == Sf_None         = return a+                     | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore+                     | a == b               = return a+                     | otherwise            = addErr errm >> pure a+    where errm = "Incompatible Safe Haskell flags! ("+                    ++ show a ++ ", " ++ show b ++ ")"++-- | A list of unsafe flags under Safe Haskell. Tuple elements are:+--     * name of the flag+--     * function to get srcspan that enabled the flag+--     * function to test if the flag is on+--     * function to turn the flag off+unsafeFlags, unsafeFlagsForInfer+  :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]+unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,+                    xopt LangExt.GeneralizedNewtypeDeriving,+                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)+              , ("-XDerivingVia", deriveViaOnLoc,+                    xopt LangExt.DerivingVia,+                    flip xopt_unset LangExt.DerivingVia)+              , ("-XTemplateHaskell", thOnLoc,+                    xopt LangExt.TemplateHaskell,+                    flip xopt_unset LangExt.TemplateHaskell)+              ]+unsafeFlagsForInfer = unsafeFlags+++-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order+getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from+        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors+        -> [a]                  -- ^ Correctly ordered extracted options+getOpts dflags opts = reverse (opts dflags)+        -- We add to the options from the front, so we need to reverse the list++-- | Gets the verbosity flag for the current verbosity level. This is fed to+-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included+getVerbFlags :: DynFlags -> [String]+getVerbFlags dflags+  | verbosity dflags >= 4 = ["-v"]+  | otherwise             = []++setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,+         setDynObjectSuf, setDynHiSuf,+         setDylibInstallName,+         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,+         setPgmP, addOptl, addOptc, addOptcxx, addOptP,+         addCmdlineFramework, addHaddockOpts, addGhciScript,+         setInteractivePrint+   :: String -> DynFlags -> DynFlags+setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce+   :: Maybe String -> DynFlags -> DynFlags++setObjectDir  f d = d { objectDir  = Just f}+setHiDir      f d = d { hiDir      = Just f}+setHieDir     f d = d { hieDir     = Just f}+setStubDir    f d = d { stubDir    = Just f+                      , includePaths = addGlobalInclude (includePaths d) [f] }+  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file+  -- \#included from the .hc file when compiling via C (i.e. unregisterised+  -- builds).+setDumpDir    f d = d { dumpDir    = Just f}+setOutputDir  f = setObjectDir f+                . setHieDir f+                . setHiDir f+                . setStubDir f+                . setDumpDir f+setDylibInstallName  f d = d { dylibInstallName = Just f}++setObjectSuf    f d = d { objectSuf_    = f}+setDynObjectSuf f d = d { dynObjectSuf_ = f}+setHiSuf        f d = d { hiSuf_        = f}+setHieSuf       f d = d { hieSuf        = f}+setDynHiSuf     f d = d { dynHiSuf_     = f}+setHcSuf        f d = d { hcSuf         = f}++setOutputFile    f d = d { outputFile_    = f}+setDynOutputFile f d = d { dynOutputFile_ = f}+setOutputHi      f d = d { outputHi       = f}+setDynOutputHi   f d = d { dynOutputHi    = f}++parseUnitInsts :: String -> Instantiations+parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)+  where parse = sepBy parseEntry (R.char ',')+        parseEntry = do+            n <- parseModuleName+            _ <- R.char '='+            m <- parseHoleyModule+            return (n, m)++setUnitInstantiations :: String -> DynFlags -> DynFlags+setUnitInstantiations s d =+    d { homeUnitInstantiations_ = parseUnitInsts s }++setUnitInstanceOf :: String -> DynFlags -> DynFlags+setUnitInstanceOf s d =+    d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) }++addPluginModuleName :: String -> DynFlags -> DynFlags+addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }++clearPluginModuleNames :: DynFlags -> DynFlags+clearPluginModuleNames d =+    d { pluginModNames = []+      , pluginModNameOpts = []+      }++addPluginModuleNameOption :: String -> DynFlags -> DynFlags+addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }+  where (m, rest) = break (== ':') optflag+        option = case rest of+          [] -> "" -- should probably signal an error+          (_:plug_opt) -> plug_opt -- ignore the ':' from break++addFrontendPluginOption :: String -> DynFlags -> DynFlags+addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }++parseDynLibLoaderMode f d =+ case splitAt 8 f of+   ("deploy", "")       -> d { dynLibLoader = Deployable }+   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }+   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))++setDumpPrefixForce f d = d { dumpPrefixForce = f}++-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmP   f = alterToolSettings (\s -> s { toolSettings_pgm_P   = (pgm, map Option args)})+  where (pgm:args) = words f+addOptl   f = alterToolSettings (\s -> s { toolSettings_opt_l   = f : toolSettings_opt_l s})+addOptc   f = alterToolSettings (\s -> s { toolSettings_opt_c   = f : toolSettings_opt_c s})+addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s})+addOptP   f = alterToolSettings $ \s -> s+          { toolSettings_opt_P   = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+          -- See Note [Repeated -optP hashing]+  where+  fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss+++setDepMakefile :: FilePath -> DynFlags -> DynFlags+setDepMakefile f d = d { depMakefile = f }++setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags+setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }++setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags+setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }++addDepExcludeMod :: String -> DynFlags -> DynFlags+addDepExcludeMod m d+    = d { depExcludeMods = mkModuleName m : depExcludeMods d }++addDepSuffix :: FilePath -> DynFlags -> DynFlags+addDepSuffix s d = d { depSuffixes = s : depSuffixes d }++addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}++addGhcVersionFile :: FilePath -> DynFlags -> DynFlags+addGhcVersionFile f d = d { ghcVersionFile = Just f }++addHaddockOpts f d = d { haddockOptions = Just f}++addGhciScript f d = d { ghciScripts = f : ghciScripts d}++setInteractivePrint f d = d { interactivePrint = Just f}++-----------------------------------------------------------------------------+-- Setting the optimisation level++updOptLevel :: Int -> DynFlags -> DynFlags+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level+updOptLevel n dfs+  = dfs2{ optLevel = final_n }+  where+   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2+   dfs1 = foldr (flip gopt_unset) dfs  remove_gopts+   dfs2 = foldr (flip gopt_set)   dfs1 extra_gopts++   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]+   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]++{- **********************************************************************+%*                                                                      *+                DynFlags parser+%*                                                                      *+%********************************************************************* -}++-- -----------------------------------------------------------------------------+-- Parsing the dynamic flags.+++-- | Parse dynamic flags from a list of command line arguments.  Returns+-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.+-- Throws a 'UsageError' if errors occurred during parsing (such as unknown+-- flags or missing arguments).+parseDynamicFlagsCmdLine :: MonadIO m => DynFlags -> [Located String]+                         -> m (DynFlags, [Located String], [Warn])+                            -- ^ Updated 'DynFlags', left-over arguments, and+                            -- list of warnings.+parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True+++-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags+-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).+-- Used to parse flags set in a modules pragma.+parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]+                       -> m (DynFlags, [Located String], [Warn])+                          -- ^ Updated 'DynFlags', left-over arguments, and+                          -- list of warnings.+parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False+++-- | Parses the dynamically set flags for GHC. This is the most general form of+-- the dynamic flag parser that the other methods simply wrap. It allows+-- saying which flags are valid flags and indicating if we are parsing+-- arguments from the command line or from a file pragma.+parseDynamicFlagsFull :: MonadIO m+                  => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against+                  -> Bool                          -- ^ are the arguments from the command line?+                  -> DynFlags                      -- ^ current dynamic flags+                  -> [Located String]              -- ^ arguments to parse+                  -> m (DynFlags, [Located String], [Warn])+parseDynamicFlagsFull activeFlags cmdline dflags0 args = do+  let ((leftover, errs, warns), dflags1)+          = runCmdLine (processArgs activeFlags args) dflags0++  -- See Note [Handling errors when parsing commandline flags]+  let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)+  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $+    map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs++  -- check for disabled flags in safe haskell+  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1+      theWays = ways dflags2++  unless (allowed_combination theWays) $ liftIO $+      throwGhcExceptionIO (CmdLineError ("combination not supported: " +++                               intercalate "/" (map wayDesc (Set.toAscList theWays))))++  let dflags3+        | Just outFile <- outputFile_ dflags2   -- Only iff user specified -o ...+        , not (isJust (dynOutputFile_ dflags2)) -- but not -dyno+        = dflags2 { dynOutputFile_ = Just $ dynamicOutputFile dflags2 outFile }+        | otherwise+        = dflags2++  let (dflags4, consistency_warnings) = makeDynFlagsConsistent dflags3++  -- Set timer stats & heap size+  when (enableTimeStats dflags4) $ liftIO enableTimingStats+  case (ghcHeapSize dflags4) of+    Just x -> liftIO (setHeapSize x)+    _      -> return ()++  liftIO $ setUnsafeGlobalDynFlags dflags4++  let warns' = map (Warn Cmd.NoReason) (consistency_warnings ++ sh_warns)++  return (dflags4, leftover, warns' ++ warns)++-- | Check (and potentially disable) any extensions that aren't allowed+-- in safe mode.+--+-- The bool is to indicate if we are parsing command line flags (false means+-- file pragma). This allows us to generate better warnings.+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Located String])+safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)+  where+    -- Handle illegal flags under safe language.+    (dflagsUnset, warns) = foldl' check_method (dflags, []) unsafeFlags++    check_method (df, warns) (str,loc,test,fix)+        | test df   = (fix df, warns ++ safeFailure (loc df) str)+        | otherwise = (df, warns)++    safeFailure loc str+       = [L loc $ str ++ " is not allowed in Safe Haskell; ignoring "+           ++ str]++safeFlagCheck cmdl dflags =+  case safeInferOn dflags of+    True   -> (dflags' { safeInferred = safeFlags }, warn)+    False  -> (dflags', warn)++  where+    -- dynflags and warn for when -fpackage-trust by itself with no safe+    -- haskell flag+    (dflags', warn)+      | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags+      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)+      | otherwise = (dflags, [])++    pkgWarnMsg = [L (pkgTrustOnLoc dflags') $+                    "-fpackage-trust ignored;" +++                    " must be specified with a Safe Haskell flag"]++    -- Have we inferred Unsafe? See Note [GHC.Driver.Main . Safe Haskell Inference]+    safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer+++{- **********************************************************************+%*                                                                      *+                DynFlags specifications+%*                                                                      *+%********************************************************************* -}++-- | All dynamic flags option strings without the deprecated ones.+-- These are the user facing strings for enabling and disabling options.+allNonDeprecatedFlags :: [String]+allNonDeprecatedFlags = allFlagsDeps False++-- | All flags with possibility to filter deprecated ones+allFlagsDeps :: Bool -> [String]+allFlagsDeps keepDeprecated = [ '-':flagName flag+                              | (deprecated, flag) <- flagsAllDeps+                              , keepDeprecated || not (isDeprecated deprecated)]+  where isDeprecated Deprecated = True+        isDeprecated _ = False++{-+ - Below we export user facing symbols for GHC dynamic flags for use with the+ - GHC API.+ -}++-- All dynamic flags present in GHC.+flagsAll :: [Flag (CmdLineP DynFlags)]+flagsAll = map snd flagsAllDeps++-- All dynamic flags present in GHC with deprecation information.+flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]+flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps+++-- All dynamic flags, minus package flags, present in GHC.+flagsDynamic :: [Flag (CmdLineP DynFlags)]+flagsDynamic = map snd dynamic_flags_deps++-- ALl package flags present in GHC.+flagsPackage :: [Flag (CmdLineP DynFlags)]+flagsPackage = map snd package_flags_deps++----------------Helpers to make flags and keep deprecation information----------++type FlagMaker m = String -> OptKind m -> Flag m+type DynFlagMaker = FlagMaker (CmdLineP DynFlags)+data Deprecation = NotDeprecated | Deprecated deriving (Eq, Ord)++-- Make a non-deprecated flag+make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)+              -> (Deprecation, Flag (CmdLineP DynFlags))+make_ord_flag fm name kind = (NotDeprecated, fm name kind)++-- Make a deprecated flag+make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String+                 -> (Deprecation, Flag (CmdLineP DynFlags))+make_dep_flag fm name kind message = (Deprecated,+                                      fm name $ add_dep_message kind message)++add_dep_message :: OptKind (CmdLineP DynFlags) -> String+                -> OptKind (CmdLineP DynFlags)+add_dep_message (NoArg f) message = NoArg $ f >> deprecate message+add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message+add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message+add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message+add_dep_message (OptPrefix f) message =+                                  OptPrefix $ \s -> f s >> deprecate message+add_dep_message (OptIntSuffix f) message =+                               OptIntSuffix $ \oi -> f oi >> deprecate message+add_dep_message (IntSuffix f) message =+                                  IntSuffix $ \i -> f i >> deprecate message+add_dep_message (WordSuffix f) message =+                                  WordSuffix $ \i -> f i >> deprecate message+add_dep_message (FloatSuffix f) message =+                                FloatSuffix $ \fl -> f fl >> deprecate message+add_dep_message (PassFlag f) message =+                                   PassFlag $ \s -> f s >> deprecate message+add_dep_message (AnySuffix f) message =+                                  AnySuffix $ \s -> f s >> deprecate message++----------------------- The main flags themselves ------------------------------+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+dynamic_flags_deps = [+    make_dep_flag defFlag "n" (NoArg $ return ())+        "The -n flag is deprecated and no longer has any effect"+  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))+  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))+  , (Deprecated, defFlag "#include"+      (HasArg (\_s ->+         deprecate ("-#include and INCLUDE pragmas are " +++                    "deprecated: They no longer have any effect"))))+  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)++  , make_ord_flag defGhcFlag "j"     (OptIntSuffix+        (\n -> case n of+                 Just n+                     | n > 0     -> upd (\d -> d { parMakeCount = Just n })+                     | otherwise -> addErr "Syntax: -j[n] where n > 0"+                 Nothing -> upd (\d -> d { parMakeCount = Nothing })))+                 -- When the number of parallel builds+                 -- is omitted, it is the same+                 -- as specifying that the number of+                 -- parallel builds is equal to the+                 -- result of getNumProcessors+  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)+  , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)++    -- RTS options -------------------------------------------------------------+  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->+          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))++  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->+                                               d { enableTimeStats = True })))++    ------- ways ---------------------------------------------------------------+  , make_ord_flag defGhcFlag "prof"           (NoArg (addWayDynP WayProf))+  , make_ord_flag defGhcFlag "eventlog"       (NoArg (addWayDynP WayTracing))+  , make_ord_flag defGhcFlag "debug"          (NoArg (addWayDynP WayDebug))+  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWayDynP WayThreaded))++  , make_ord_flag defGhcFlag "ticky"+      (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))++    -- -ticky enables ticky-ticky code generation, and also implies -debug which+    -- is required to get the RTS ticky support.++        ----- Linker --------------------------------------------------------+  , make_ord_flag defGhcFlag "static"         (NoArg removeWayDyn)+  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWayDynP WayDyn))+  , make_ord_flag defGhcFlag "rdynamic" $ noArg $+#if defined(linux_HOST_OS)+                              addOptl "-rdynamic"+#elif defined(mingw32_HOST_OS)+                              addOptl "-Wl,--export-all-symbols"+#else+    -- ignored for compat w/ gcc:+                              id+#endif+  , make_ord_flag defGhcFlag "relative-dynlib-paths"+      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))+  , make_ord_flag defGhcFlag "copy-libs-when-linking"+      (NoArg (setGeneralFlag Opt_SingleLibFolder))+  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))+  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))++        ------- Specific phases  --------------------------------------------+    -- need to appear before -pgmL to be parsed as LLVM flags.+  , make_ord_flag defFlag "pgmlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }+  , make_ord_flag defFlag "pgmlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }+  , make_ord_flag defFlag "pgmlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  = (f,[]) }+  , make_ord_flag defFlag "pgmi"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i   =  f }+  , make_ord_flag defFlag "pgmL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L   = f }+  , make_ord_flag defFlag "pgmP"+      (hasArg setPgmP)+  , make_ord_flag defFlag "pgmF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F   = f }+  , make_ord_flag defFlag "pgmc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s+         { toolSettings_pgm_c   = f+         , -- Don't pass -no-pie with -pgmc+           -- (see #15319)+           toolSettings_ccSupportsNoPie = False+         }+  , make_ord_flag defFlag "pgmc-supports-no-pie"+      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }+  , make_ord_flag defFlag "pgms"+      (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8"))+  , make_ord_flag defFlag "pgma"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a   = (f,[]) }+  , make_ord_flag defFlag "pgml"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_l   = (f,[]) }+  , make_ord_flag defFlag "pgmdll"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) }+  , make_ord_flag defFlag "pgmwindres"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }+  , make_ord_flag defFlag "pgmlibtool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = f }+  , make_ord_flag defFlag "pgmar"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f }+  , make_ord_flag defFlag "pgmotool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f}+  , make_ord_flag defFlag "pgminstall_name_tool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f}+  , make_ord_flag defFlag "pgmranlib"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f }+++    -- need to appear before -optl/-opta to be parsed as LLVM flags.+  , make_ord_flag defFlag "optlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm  = f : toolSettings_opt_lm s }+  , make_ord_flag defFlag "optlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }+  , make_ord_flag defFlag "optlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }+  , make_ord_flag defFlag "opti"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }+  , make_ord_flag defFlag "optL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L   = f : toolSettings_opt_L s }+  , make_ord_flag defFlag "optP"+      (hasArg addOptP)+  , make_ord_flag defFlag "optF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F   = f : toolSettings_opt_F s }+  , make_ord_flag defFlag "optc"+      (hasArg addOptc)+  , make_ord_flag defFlag "optcxx"+      (hasArg addOptcxx)+  , make_ord_flag defFlag "opta"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a   = f : toolSettings_opt_a s }+  , make_ord_flag defFlag "optl"+      (hasArg addOptl)+  , make_ord_flag defFlag "optwindres"+      $ hasArg $ \f ->+        alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s }++  , make_ord_flag defGhcFlag "split-objs"+      (NoArg $ addWarn "ignoring -split-objs")++  , make_ord_flag defGhcFlag "split-sections"+      (noArgM (\dflags -> do+        if platformHasSubsectionsViaSymbols (targetPlatform dflags)+          then do addWarn $+                    "-split-sections is not useful on this platform " +++                    "since it always uses subsections via symbols. Ignoring."+                  return dflags+          else return (gopt_set dflags Opt_SplitSections)))++        -------- ghc -M -----------------------------------------------------+  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)+  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)+  , make_ord_flag defGhcFlag "include-cpp-deps"+        (noArg (setDepIncludeCppDeps True))+  , make_ord_flag defGhcFlag "include-pkg-deps"+        (noArg (setDepIncludePkgDeps True))+  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)++        -------- Linking ----------------------------------------------------+  , make_ord_flag defGhcFlag "no-link"+        (noArg (\d -> d { ghcLink=NoLink }))+  , make_ord_flag defGhcFlag "shared"+        (noArg (\d -> d { ghcLink=LinkDynLib }))+  , make_ord_flag defGhcFlag "staticlib"+        (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))+  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)+  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)++        ------- Libraries ---------------------------------------------------+  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)+  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))++        ------- Frameworks --------------------------------------------------+        -- -framework-path should really be -F ...+  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)+  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)++        ------- Output Redirection ------------------------------------------+  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)+  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))+  , make_ord_flag defGhcFlag "dyno"+        (sepArg (setDynOutputFile . Just))+  , make_ord_flag defGhcFlag "ohi"+        (hasArg (setOutputHi . Just ))+  , make_ord_flag defGhcFlag "dynohi"+        (hasArg (setDynOutputHi . Just ))+  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)+  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)+  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)+  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)+  , make_ord_flag defGhcFlag "hiesuf"            (hasArg setHieSuf)+  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)+  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)+  , make_ord_flag defGhcFlag "hiedir"            (hasArg setHieDir)+  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)+  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)+  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)+  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)+  , make_ord_flag defGhcFlag "ddump-file-prefix"+        (hasArg (setDumpPrefixForce . Just))++  , make_ord_flag defGhcFlag "dynamic-too"+        (NoArg (setGeneralFlag Opt_BuildDynamicToo))++        ------- Keeping temporary files -------------------------------------+     -- These can be singular (think ghc -c) or plural (think ghc --make)+  , make_ord_flag defGhcFlag "keep-hc-file"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hc-files"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-file"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-files"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-s-file"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-s-files"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-llvm-file"+        (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles)+  , make_ord_flag defGhcFlag "keep-llvm-files"+        (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles)+     -- This only makes sense as plural+  , make_ord_flag defGhcFlag "keep-tmp-files"+        (NoArg (setGeneralFlag Opt_KeepTmpFiles))+  , make_ord_flag defGhcFlag "keep-hi-file"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-file"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-hi-files"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-files"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-o-file"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-file"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "keep-o-files"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-files"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))++        ------- Miscellaneous ----------------------------------------------+  , make_ord_flag defGhcFlag "no-auto-link-packages"+        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))+  , make_ord_flag defGhcFlag "no-hs-main"+        (NoArg (setGeneralFlag Opt_NoHsMain))+  , make_ord_flag defGhcFlag "fno-state-hack"+        (NoArg (setGeneralFlag Opt_G_NoStateHack))+  , make_ord_flag defGhcFlag "fno-opt-coercion"+        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))+  , make_ord_flag defGhcFlag "with-rtsopts"+        (HasArg setRtsOpts)+  , make_ord_flag defGhcFlag "rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=all"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=some"+        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))+  , make_ord_flag defGhcFlag "rtsopts=none"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "rtsopts=ignore"+        (NoArg (setRtsOptsEnabled RtsOptsIgnore))+  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"+        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))+  , make_ord_flag defGhcFlag "no-rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"+      (noArg (\d -> d {rtsOptsSuggestions = False}))+  , make_ord_flag defGhcFlag "dhex-word-literals"+        (NoArg (setGeneralFlag Opt_HexWordLiterals))++  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)+  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)+  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)+  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)+  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)+  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)+  , make_ord_flag defGhcFlag "ticky-allocd"+        (NoArg (setGeneralFlag Opt_Ticky_Allocd))+  , make_ord_flag defGhcFlag "ticky-LNE"+        (NoArg (setGeneralFlag Opt_Ticky_LNE))+  , make_ord_flag defGhcFlag "ticky-dyn-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))+        ------- recompilation checker --------------------------------------+  , make_dep_flag defGhcFlag "recomp"+        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)+             "Use -fno-force-recomp instead"+  , make_dep_flag defGhcFlag "no-recomp"+        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"+  , make_ord_flag defFlag "fmax-errors"+      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))+  , make_ord_flag defFlag "fno-max-errors"+      (noArg (\d -> d { maxErrors = Nothing }))+  , make_ord_flag defFlag "freverse-errors"+        (noArg (\d -> d {reverseErrors = True} ))+  , make_ord_flag defFlag "fno-reverse-errors"+        (noArg (\d -> d {reverseErrors = False} ))++        ------ HsCpp opts ---------------------------------------------------+  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))+  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))++        ------- Include/Import Paths ----------------------------------------+  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)+  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)++        ------ Output style options -----------------------------------------+  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->+                                                       d { pprUserLength = n }))+  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->+                                                             d { pprCols = n }))+  , make_ord_flag defFlag "fdiagnostics-color=auto"+      (NoArg (upd (\d -> d { useColor = Auto })))+  , make_ord_flag defFlag "fdiagnostics-color=always"+      (NoArg (upd (\d -> d { useColor = Always })))+  , make_ord_flag defFlag "fdiagnostics-color=never"+      (NoArg (upd (\d -> d { useColor = Never })))++  -- Suppress all that is suppressable in core dumps.+  -- Except for uniques, as some simplifier phases introduce new variables that+  -- have otherwise identical names.+  , make_ord_flag defGhcFlag "dsuppress-all"+      (NoArg $ do setGeneralFlag Opt_SuppressCoercions+                  setGeneralFlag Opt_SuppressVarKinds+                  setGeneralFlag Opt_SuppressModulePrefixes+                  setGeneralFlag Opt_SuppressTypeApplications+                  setGeneralFlag Opt_SuppressIdInfo+                  setGeneralFlag Opt_SuppressTicks+                  setGeneralFlag Opt_SuppressStgExts+                  setGeneralFlag Opt_SuppressTypeSignatures+                  setGeneralFlag Opt_SuppressTimestamps)++        ------ Debugging ----------------------------------------------------+  , make_ord_flag defGhcFlag "dstg-stats"+        (NoArg (setGeneralFlag Opt_StgStats))++  , make_ord_flag defGhcFlag "ddump-cmm"+        (setDumpFlag Opt_D_dump_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"+        (setDumpFlag Opt_D_dump_cmm_from_stg)+  , make_ord_flag defGhcFlag "ddump-cmm-raw"+        (setDumpFlag Opt_D_dump_cmm_raw)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose"+        (setDumpFlag Opt_D_dump_cmm_verbose)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc"+        (setDumpFlag Opt_D_dump_cmm_verbose_by_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-cfg"+        (setDumpFlag Opt_D_dump_cmm_cfg)+  , make_ord_flag defGhcFlag "ddump-cmm-cbe"+        (setDumpFlag Opt_D_dump_cmm_cbe)+  , make_ord_flag defGhcFlag "ddump-cmm-switch"+        (setDumpFlag Opt_D_dump_cmm_switch)+  , make_ord_flag defGhcFlag "ddump-cmm-proc"+        (setDumpFlag Opt_D_dump_cmm_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-sp"+        (setDumpFlag Opt_D_dump_cmm_sp)+  , make_ord_flag defGhcFlag "ddump-cmm-sink"+        (setDumpFlag Opt_D_dump_cmm_sink)+  , make_ord_flag defGhcFlag "ddump-cmm-caf"+        (setDumpFlag Opt_D_dump_cmm_caf)+  , make_ord_flag defGhcFlag "ddump-cmm-procmap"+        (setDumpFlag Opt_D_dump_cmm_procmap)+  , make_ord_flag defGhcFlag "ddump-cmm-split"+        (setDumpFlag Opt_D_dump_cmm_split)+  , make_ord_flag defGhcFlag "ddump-cmm-info"+        (setDumpFlag Opt_D_dump_cmm_info)+  , make_ord_flag defGhcFlag "ddump-cmm-cps"+        (setDumpFlag Opt_D_dump_cmm_cps)+  , make_ord_flag defGhcFlag "ddump-cmm-opt"+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-cfg-weights"+        (setDumpFlag Opt_D_dump_cfg_weights)+  , make_ord_flag defGhcFlag "ddump-core-stats"+        (setDumpFlag Opt_D_dump_core_stats)+  , make_ord_flag defGhcFlag "ddump-asm"+        (setDumpFlag Opt_D_dump_asm)+  , make_ord_flag defGhcFlag "ddump-asm-native"+        (setDumpFlag Opt_D_dump_asm_native)+  , make_ord_flag defGhcFlag "ddump-asm-liveness"+        (setDumpFlag Opt_D_dump_asm_liveness)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc"+        (setDumpFlag Opt_D_dump_asm_regalloc)+  , make_ord_flag defGhcFlag "ddump-asm-conflicts"+        (setDumpFlag Opt_D_dump_asm_conflicts)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"+        (setDumpFlag Opt_D_dump_asm_regalloc_stages)+  , make_ord_flag defGhcFlag "ddump-asm-stats"+        (setDumpFlag Opt_D_dump_asm_stats)+  , make_ord_flag defGhcFlag "ddump-asm-expanded"+        (setDumpFlag Opt_D_dump_asm_expanded)+  , make_ord_flag defGhcFlag "ddump-llvm"+        (NoArg $ setObjBackend LLVM >> setDumpFlag' Opt_D_dump_llvm)+  , make_ord_flag defGhcFlag "ddump-c-backend"+        (NoArg $ setDumpFlag' Opt_D_dump_c_backend)+  , make_ord_flag defGhcFlag "ddump-deriv"+        (setDumpFlag Opt_D_dump_deriv)+  , make_ord_flag defGhcFlag "ddump-ds"+        (setDumpFlag Opt_D_dump_ds)+  , make_ord_flag defGhcFlag "ddump-ds-preopt"+        (setDumpFlag Opt_D_dump_ds_preopt)+  , make_ord_flag defGhcFlag "ddump-foreign"+        (setDumpFlag Opt_D_dump_foreign)+  , make_ord_flag defGhcFlag "ddump-inlinings"+        (setDumpFlag Opt_D_dump_inlinings)+  , make_ord_flag defGhcFlag "ddump-rule-firings"+        (setDumpFlag Opt_D_dump_rule_firings)+  , make_ord_flag defGhcFlag "ddump-rule-rewrites"+        (setDumpFlag Opt_D_dump_rule_rewrites)+  , make_ord_flag defGhcFlag "ddump-simpl-trace"+        (setDumpFlag Opt_D_dump_simpl_trace)+  , make_ord_flag defGhcFlag "ddump-occur-anal"+        (setDumpFlag Opt_D_dump_occur_anal)+  , make_ord_flag defGhcFlag "ddump-parsed"+        (setDumpFlag Opt_D_dump_parsed)+  , make_ord_flag defGhcFlag "ddump-parsed-ast"+        (setDumpFlag Opt_D_dump_parsed_ast)+  , make_ord_flag defGhcFlag "ddump-rn"+        (setDumpFlag Opt_D_dump_rn)+  , make_ord_flag defGhcFlag "ddump-rn-ast"+        (setDumpFlag Opt_D_dump_rn_ast)+  , make_ord_flag defGhcFlag "ddump-simpl"+        (setDumpFlag Opt_D_dump_simpl)+  , make_ord_flag defGhcFlag "ddump-simpl-iterations"+      (setDumpFlag Opt_D_dump_simpl_iterations)+  , make_ord_flag defGhcFlag "ddump-spec"+        (setDumpFlag Opt_D_dump_spec)+  , make_ord_flag defGhcFlag "ddump-prep"+        (setDumpFlag Opt_D_dump_prep)+  , make_ord_flag defGhcFlag "ddump-stg-from-core"+        (setDumpFlag Opt_D_dump_stg_from_core)+  , make_ord_flag defGhcFlag "ddump-stg-unarised"+        (setDumpFlag Opt_D_dump_stg_unarised)+  , make_ord_flag defGhcFlag "ddump-stg-final"+        (setDumpFlag Opt_D_dump_stg_final)+  , make_dep_flag defGhcFlag "ddump-stg"+        (setDumpFlag Opt_D_dump_stg_from_core)+        "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead"+  , make_ord_flag defGhcFlag "ddump-call-arity"+        (setDumpFlag Opt_D_dump_call_arity)+  , make_ord_flag defGhcFlag "ddump-exitify"+        (setDumpFlag Opt_D_dump_exitify)+  , make_ord_flag defGhcFlag "ddump-stranal"+        (setDumpFlag Opt_D_dump_stranal)+  , make_ord_flag defGhcFlag "ddump-str-signatures"+        (setDumpFlag Opt_D_dump_str_signatures)+  , make_ord_flag defGhcFlag "ddump-cpranal"+        (setDumpFlag Opt_D_dump_cpranal)+  , make_ord_flag defGhcFlag "ddump-cpr-signatures"+        (setDumpFlag Opt_D_dump_cpr_signatures)+  , make_ord_flag defGhcFlag "ddump-tc"+        (setDumpFlag Opt_D_dump_tc)+  , make_ord_flag defGhcFlag "ddump-tc-ast"+        (setDumpFlag Opt_D_dump_tc_ast)+  , make_ord_flag defGhcFlag "ddump-hie"+        (setDumpFlag Opt_D_dump_hie)+  , make_ord_flag defGhcFlag "ddump-types"+        (setDumpFlag Opt_D_dump_types)+  , make_ord_flag defGhcFlag "ddump-rules"+        (setDumpFlag Opt_D_dump_rules)+  , make_ord_flag defGhcFlag "ddump-cse"+        (setDumpFlag Opt_D_dump_cse)+  , make_ord_flag defGhcFlag "ddump-worker-wrapper"+        (setDumpFlag Opt_D_dump_worker_wrapper)+  , make_ord_flag defGhcFlag "ddump-rn-trace"+        (setDumpFlag Opt_D_dump_rn_trace)+  , make_ord_flag defGhcFlag "ddump-if-trace"+        (setDumpFlag Opt_D_dump_if_trace)+  , make_ord_flag defGhcFlag "ddump-cs-trace"+        (setDumpFlag Opt_D_dump_cs_trace)+  , make_ord_flag defGhcFlag "ddump-tc-trace"+        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace+                   setDumpFlag' Opt_D_dump_cs_trace))+  , make_ord_flag defGhcFlag "ddump-ec-trace"+        (setDumpFlag Opt_D_dump_ec_trace)+  , make_ord_flag defGhcFlag "ddump-vt-trace"+        (setDumpFlag Opt_D_dump_vt_trace)+  , make_ord_flag defGhcFlag "ddump-splices"+        (setDumpFlag Opt_D_dump_splices)+  , make_ord_flag defGhcFlag "dth-dec-file"+        (setDumpFlag Opt_D_th_dec_file)++  , make_ord_flag defGhcFlag "ddump-rn-stats"+        (setDumpFlag Opt_D_dump_rn_stats)+  , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-simpl-stats"+        (setDumpFlag Opt_D_dump_simpl_stats)+  , make_ord_flag defGhcFlag "ddump-bcos"+        (setDumpFlag Opt_D_dump_BCOs)+  , make_ord_flag defGhcFlag "dsource-stats"+        (setDumpFlag Opt_D_source_stats)+  , make_ord_flag defGhcFlag "dverbose-core2core"+        (NoArg $ setVerbosity (Just 2) >> setVerboseCore2Core)+  , make_ord_flag defGhcFlag "dverbose-stg2stg"+        (setDumpFlag Opt_D_verbose_stg2stg)+  , make_ord_flag defGhcFlag "ddump-hi"+        (setDumpFlag Opt_D_dump_hi)+  , make_ord_flag defGhcFlag "ddump-minimal-imports"+        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))+  , make_ord_flag defGhcFlag "ddump-hpc"+        (setDumpFlag Opt_D_dump_ticked) -- back compat+  , make_ord_flag defGhcFlag "ddump-ticked"+        (setDumpFlag Opt_D_dump_ticked)+  , make_ord_flag defGhcFlag "ddump-mod-cycles"+        (setDumpFlag Opt_D_dump_mod_cycles)+  , make_ord_flag defGhcFlag "ddump-mod-map"+        (setDumpFlag Opt_D_dump_mod_map)+  , make_ord_flag defGhcFlag "ddump-timings"+        (setDumpFlag Opt_D_dump_timings)+  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"+        (setDumpFlag Opt_D_dump_view_pattern_commoning)+  , make_ord_flag defGhcFlag "ddump-to-file"+        (NoArg (setGeneralFlag Opt_DumpToFile))+  , make_ord_flag defGhcFlag "ddump-hi-diffs"+        (setDumpFlag Opt_D_dump_hi_diffs)+  , make_ord_flag defGhcFlag "ddump-rtti"+        (setDumpFlag Opt_D_dump_rtti)+  , make_ord_flag defGhcFlag "dcore-lint"+        (NoArg (setGeneralFlag Opt_DoCoreLinting))+  , make_ord_flag defGhcFlag "dlinear-core-lint"+        (NoArg (setGeneralFlag Opt_DoLinearCoreLinting))+  , make_ord_flag defGhcFlag "dstg-lint"+        (NoArg (setGeneralFlag Opt_DoStgLinting))+  , make_ord_flag defGhcFlag "dcmm-lint"+        (NoArg (setGeneralFlag Opt_DoCmmLinting))+  , make_ord_flag defGhcFlag "dasm-lint"+        (NoArg (setGeneralFlag Opt_DoAsmLinting))+  , make_ord_flag defGhcFlag "dannot-lint"+        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))+  , make_ord_flag defGhcFlag "dshow-passes"+        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dfaststring-stats"+        (NoArg (setGeneralFlag Opt_D_faststring_stats))+  , make_ord_flag defGhcFlag "dno-llvm-mangler"+        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag+  , make_ord_flag defGhcFlag "dno-typeable-binds"+        (NoArg (setGeneralFlag Opt_NoTypeableBinds))+  , make_ord_flag defGhcFlag "ddump-debug"+        (setDumpFlag Opt_D_dump_debug)+  , make_ord_flag defGhcFlag "ddump-json"+        (setDumpFlag Opt_D_dump_json )+  , make_ord_flag defGhcFlag "dppr-debug"+        (setDumpFlag Opt_D_ppr_debug)+  , make_ord_flag defGhcFlag "ddebug-output"+        (noArg (flip dopt_unset Opt_D_no_debug_output))+  , make_ord_flag defGhcFlag "dno-debug-output"+        (setDumpFlag Opt_D_no_debug_output)++  , make_ord_flag defGhcFlag "ddump-faststrings"+        (setDumpFlag Opt_D_dump_faststrings)++        ------ Machine dependent (-m<blah>) stuff ---------------------------++  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->+                                                  d { sseVersion = Just SSE1 }))+  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->+                                                  d { sseVersion = Just SSE2 }))+  , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->+                                                  d { sseVersion = Just SSE3 }))+  , make_ord_flag defGhcFlag "msse4"        (noArg (\d ->+                                                  d { sseVersion = Just SSE4 }))+  , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->+                                                 d { sseVersion = Just SSE42 }))+  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->+                                                 d { bmiVersion = Just BMI1 }))+  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->+                                                 d { bmiVersion = Just BMI2 }))+  , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))+  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))+  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->+                                                         d { avx512cd = True }))+  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->+                                                         d { avx512er = True }))+  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))+  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->+                                                         d { avx512pf = True }))++     ------ Warning opts -------------------------------------------------+  , make_ord_flag defFlag "W"       (NoArg (mapM_ setWarningFlag minusWOpts))+  , make_ord_flag defFlag "Werror"+               (NoArg (do { setGeneralFlag Opt_WarnIsError+                          ; mapM_ setFatalWarningFlag minusWeverythingOpts   }))+  , make_ord_flag defFlag "Wwarn"+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError+                          ; mapM_ unSetFatalWarningFlag minusWeverythingOpts }))+                          -- Opt_WarnIsError is still needed to pass -Werror+                          -- to CPP; see runCpp in SysTools+  , make_dep_flag defFlag "Wnot"    (NoArg (upd (\d ->+                                              d {warningFlags = EnumSet.empty})))+                                             "Use -w or -Wno-everything instead"+  , make_ord_flag defFlag "w"       (NoArg (upd (\d ->+                                              d {warningFlags = EnumSet.empty})))++     -- New-style uniform warning sets+     --+     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything+  , make_ord_flag defFlag "Weverything"    (NoArg (mapM_+                                           setWarningFlag minusWeverythingOpts))+  , make_ord_flag defFlag "Wno-everything"+                           (NoArg (upd (\d -> d {warningFlags = EnumSet.empty})))++  , make_ord_flag defFlag "Wall"           (NoArg (mapM_+                                                  setWarningFlag minusWallOpts))+  , make_ord_flag defFlag "Wno-all"        (NoArg (mapM_+                                                unSetWarningFlag minusWallOpts))++  , make_ord_flag defFlag "Wextra"         (NoArg (mapM_+                                                     setWarningFlag minusWOpts))+  , make_ord_flag defFlag "Wno-extra"      (NoArg (mapM_+                                                   unSetWarningFlag minusWOpts))++  , make_ord_flag defFlag "Wdefault"       (NoArg (mapM_+                                               setWarningFlag standardWarnings))+  , make_ord_flag defFlag "Wno-default"    (NoArg (mapM_+                                             unSetWarningFlag standardWarnings))++  , make_ord_flag defFlag "Wcompat"        (NoArg (mapM_+                                               setWarningFlag minusWcompatOpts))+  , make_ord_flag defFlag "Wno-compat"     (NoArg (mapM_+                                             unSetWarningFlag minusWcompatOpts))++        ------ Plugin flags ------------------------------------------------+  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)+  , make_ord_flag defGhcFlag "fplugin-trustworthy"+      (NoArg (setGeneralFlag Opt_PluginTrustworthy))+  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)+  , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames)+  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)++        ------ Optimisation flags ------------------------------------------+  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )+                                                            "Use -O0 instead"+  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->+                                                setOptLevel (mb_n `orElse` 1)))+                -- If the number is missing, use 1++  , make_ord_flag defFlag "fbinary-blob-threshold"+      (intSuffix (\n d -> d { binBlobThreshold = fromIntegral n }))++  , make_ord_flag defFlag "fmax-relevant-binds"+      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))+  , make_ord_flag defFlag "fno-max-relevant-binds"+      (noArg (\d -> d { maxRelevantBinds = Nothing }))++  , make_ord_flag defFlag "fmax-valid-hole-fits"+      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-valid-hole-fits"+      (noArg (\d -> d { maxValidHoleFits = Nothing }))+  , make_ord_flag defFlag "fmax-refinement-hole-fits"+      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-refinement-hole-fits"+      (noArg (\d -> d { maxRefHoleFits = Nothing }))+  , make_ord_flag defFlag "frefinement-level-hole-fits"+      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))+  , make_ord_flag defFlag "fno-refinement-level-hole-fits"+      (noArg (\d -> d { refLevelHoleFits = Nothing }))++  , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"+            (noArg id)+            "vectors registers are now passed in registers by default."+  , make_ord_flag defFlag "fmax-uncovered-patterns"+      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))+  , make_ord_flag defFlag "fmax-pmcheck-models"+      (intSuffix (\n d -> d { maxPmCheckModels = n }))+  , make_ord_flag defFlag "fsimplifier-phases"+      (intSuffix (\n d -> d { simplPhases = n }))+  , make_ord_flag defFlag "fmax-simplifier-iterations"+      (intSuffix (\n d -> d { maxSimplIterations = n }))+  , (Deprecated, defFlag "fmax-pmcheck-iterations"+      (intSuffixM (\_ d ->+       do { deprecate $ "use -fmax-pmcheck-models instead"+          ; return d })))+  , make_ord_flag defFlag "fsimpl-tick-factor"+      (intSuffix (\n d -> d { simplTickFactor = n }))+  , make_ord_flag defFlag "fspec-constr-threshold"+      (intSuffix (\n d -> d { specConstrThreshold = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-threshold"+      (noArg (\d -> d { specConstrThreshold = Nothing }))+  , make_ord_flag defFlag "fspec-constr-count"+      (intSuffix (\n d -> d { specConstrCount = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-count"+      (noArg (\d -> d { specConstrCount = Nothing }))+  , make_ord_flag defFlag "fspec-constr-recursive"+      (intSuffix (\n d -> d { specConstrRecursive = n }))+  , make_ord_flag defFlag "fliberate-case-threshold"+      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))+  , make_ord_flag defFlag "fno-liberate-case-threshold"+      (noArg (\d -> d { liberateCaseThreshold = Nothing }))+  , make_ord_flag defFlag "drule-check"+      (sepArg (\s d -> d { ruleCheck = Just s }))+  , make_ord_flag defFlag "dinline-check"+      (sepArg (\s d -> d { inlineCheck = Just s }))+  , make_ord_flag defFlag "freduction-depth"+      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))+  , make_ord_flag defFlag "fconstraint-solver-iterations"+      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))+  , (Deprecated, defFlag "fcontext-stack"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , (Deprecated, defFlag "ftype-function-depth"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , make_ord_flag defFlag "fstrictness-before"+      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))+  , make_ord_flag defFlag "ffloat-lam-args"+      (intSuffix (\n d -> d { floatLamArgs = Just n }))+  , make_ord_flag defFlag "ffloat-all-lams"+      (noArg (\d -> d { floatLamArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args"+      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args-any"+      (noArg (\d -> d { liftLamsRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args"+      (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"+      (noArg (\d -> d { liftLamsNonRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = True }))+  , make_ord_flag defFlag "fno-stg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = False }))+  , make_ord_flag defFlag "fproc-alignment"+      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))+  , make_ord_flag defFlag "fblock-layout-weights"+        (HasArg (\s ->+            upd (\d -> d { cfgWeights =+                parseWeights s (cfgWeights d)})))+  , make_ord_flag defFlag "fhistory-size"+      (intSuffix (\n d -> d { historySize = n }))++  , make_ord_flag defFlag "funfolding-creation-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-use-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-fun-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-dict-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)}))++  , make_ord_flag defFlag "funfolding-case-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-case-scaling"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))++  , make_dep_flag defFlag "funfolding-keeness-factor"+      (floatSuffix (\_ d -> d))+      "-funfolding-keeness-factor is no longer respected as of GHC 9.0"++  , make_ord_flag defFlag "fmax-worker-args"+      (intSuffix (\n d -> d {maxWorkerArgs = n}))+  , make_ord_flag defGhciFlag "fghci-hist-size"+      (intSuffix (\n d -> d {ghciHistSize = n}))+  , make_ord_flag defGhcFlag "fmax-inline-alloc-size"+      (intSuffix (\n d -> d { maxInlineAllocSize = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"+      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"+      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))+  , make_ord_flag defGhcFlag "dinitial-unique"+      (wordSuffix (\n d -> d { initialUnique = n }))+  , make_ord_flag defGhcFlag "dunique-increment"+      (intSuffix (\n d -> d { uniqueIncrement = n }))++        ------ Profiling ----------------------------------------------------++        -- OLD profiling flags+  , make_dep_flag defGhcFlag "auto-all"+                    (noArg (\d -> d { profAuto = ProfAutoAll } ))+                    "Use -fprof-auto instead"+  , make_dep_flag defGhcFlag "no-auto-all"+                    (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "auto"+                    (noArg (\d -> d { profAuto = ProfAutoExports } ))+                    "Use -fprof-auto-exported instead"+  , make_dep_flag defGhcFlag "no-auto"+            (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "caf-all"+            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fprof-cafs instead"+  , make_dep_flag defGhcFlag "no-caf-all"+            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fno-prof-cafs instead"++        -- NEW profiling flags+  , make_ord_flag defGhcFlag "fprof-auto"+      (noArg (\d -> d { profAuto = ProfAutoAll } ))+  , make_ord_flag defGhcFlag "fprof-auto-top"+      (noArg (\d -> d { profAuto = ProfAutoTop } ))+  , make_ord_flag defGhcFlag "fprof-auto-exported"+      (noArg (\d -> d { profAuto = ProfAutoExports } ))+  , make_ord_flag defGhcFlag "fprof-auto-calls"+      (noArg (\d -> d { profAuto = ProfAutoCalls } ))+  , make_ord_flag defGhcFlag "fno-prof-auto"+      (noArg (\d -> d { profAuto = NoProfAuto } ))++        -- Caller-CC+  , make_ord_flag defGhcFlag "fprof-callers"+         (HasArg setCallerCcFilters)+  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"+      (NoArg (setGeneralFlag Opt_DistinctConstructorTables))+  , make_ord_flag defGhcFlag "finfo-table-map"+      (NoArg (setGeneralFlag Opt_InfoTableMap))+        ------ Compiler flags -----------------------------------------------++  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend NCG))+  , make_ord_flag defGhcFlag "fvia-c"           (NoArg+         (deprecate $ "The -fvia-c flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fvia-C"           (NoArg+         (deprecate $ "The -fvia-C flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjBackend LLVM))++  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->+                  d { ghcLink=NoLink }) >> setBackend NoBackend))+  , make_ord_flag defFlag "fbyte-code"+      (noArgM $ \dflags -> do+        setBackend Interpreter+        pure $ gopt_set dflags Opt_ByteCode)+  , make_ord_flag defFlag "fobject-code"     $ NoArg $ do+      dflags <- liftEwM getCmdLineState+      setBackend $ platformDefaultBackend (targetPlatform dflags)++  , make_dep_flag defFlag "fglasgow-exts"+      (NoArg enableGlasgowExts) "Use individual extensions instead"+  , make_dep_flag defFlag "fno-glasgow-exts"+      (NoArg disableGlasgowExts) "Use individual extensions instead"+  , make_ord_flag defFlag "Wunused-binds" (NoArg enableUnusedBinds)+  , make_ord_flag defFlag "Wno-unused-binds" (NoArg disableUnusedBinds)+  , make_ord_flag defHiddenFlag "fwarn-unused-binds" (NoArg enableUnusedBinds)+  , make_ord_flag defHiddenFlag "fno-warn-unused-binds" (NoArg+                                                            disableUnusedBinds)++        ------ Safe Haskell flags -------------------------------------------+  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)+  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->+                                                    d { safeInfer = False }))+  , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore))++        ------ position independent flags  ----------------------------------+  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIE))+  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIE))++         ------ Debugging flags ----------------------------------------------+  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)+ ]+ ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps+ ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps+ ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps+ ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps+ ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps+ ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps+ ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps+ ++ map (mkFlag turnOn  "Werror="   setWErrorFlag )     wWarningFlagsDeps+ ++ map (mkFlag turnOn  "Wwarn="     unSetFatalWarningFlag )+                                                        wWarningFlagsDeps+ ++ map (mkFlag turnOn  "Wno-error=" unSetFatalWarningFlag )+                                                        wWarningFlagsDeps+ ++ map (mkFlag turnOn  "fwarn-"    setWarningFlag   . hideFlag)+    wWarningFlagsDeps+ ++ map (mkFlag turnOff "fno-warn-" unSetWarningFlag . hideFlag)+    wWarningFlagsDeps+ ++ [ (NotDeprecated, unrecognisedWarning "W"),+      (Deprecated,    unrecognisedWarning "fwarn-"),+      (Deprecated,    unrecognisedWarning "fno-warn-") ]+ ++ [ make_ord_flag defFlag "Werror=compat"+        (NoArg (mapM_ setWErrorFlag minusWcompatOpts))+    , make_ord_flag defFlag "Wno-error=compat"+        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts))+    , make_ord_flag defFlag "Wwarn=compat"+        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ]+ ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps+ ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps+ ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps+ ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps+ ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps++-- | This is where we handle unrecognised warning flags. We only issue a warning+-- if -Wunrecognised-warning-flags is set. See #11429 for context.+unrecognisedWarning :: String -> Flag (CmdLineP DynFlags)+unrecognisedWarning prefix = defHiddenFlag prefix (Prefix action)+  where+    action :: String -> EwM (CmdLineP DynFlags) ()+    action flag = do+      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState+      when f $ addFlagWarn Cmd.ReasonUnrecognisedFlag $+        "unrecognised warning flag: -" ++ prefix ++ flag++-- See Note [Supporting CLI completion]+package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+package_flags_deps = [+        ------- Packages ----------------------------------------------------+    make_ord_flag defFlag "package-db"+      (HasArg (addPkgDbRef . PkgDbPath))+  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)+  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)+  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)+  , make_ord_flag defFlag "global-package-db"+      (NoArg (addPkgDbRef GlobalPkgDb))+  , make_ord_flag defFlag "user-package-db"+      (NoArg (addPkgDbRef UserPkgDb))+    -- backwards compat with GHC<=7.4 :+  , make_dep_flag defFlag "package-conf"+      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"+  , make_dep_flag defFlag "no-user-package-conf"+      (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"+  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->+                                      upd (setUnitId name))+  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)+  , make_ord_flag defFlag "package"               (HasArg exposePackage)+  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)+  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)+  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)+  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)+  , make_ord_flag defFlag "hide-all-packages"+      (NoArg (setGeneralFlag Opt_HideAllPackages))+  , make_ord_flag defFlag "hide-all-plugin-packages"+      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))+  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)+  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)+  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"+  , make_ord_flag defFlag "distrust-all-packages"+      (NoArg (setGeneralFlag Opt_DistrustAllPackages))+  , make_ord_flag defFlag "trust"                 (HasArg trustPackage)+  , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)+  ]+  where+    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }++-- | Make a list of flags for shell completion.+-- Filter all available flags into two groups, for interactive GHC vs all other.+flagsForCompletion :: Bool -> [String]+flagsForCompletion isInteractive+    = [ '-':flagName flag+      | flag <- flagsAll+      , modeFilter (flagGhcMode flag)+      ]+    where+      modeFilter AllModes = True+      modeFilter OnlyGhci = isInteractive+      modeFilter OnlyGhc = not isInteractive+      modeFilter HiddenFlag = False++type TurnOnFlag = Bool   -- True  <=> we are turning the flag on+                         -- False <=> we are turning the flag off+turnOn  :: TurnOnFlag; turnOn  = True+turnOff :: TurnOnFlag; turnOff = False++data FlagSpec flag+   = FlagSpec+       { flagSpecName :: String   -- ^ Flag in string form+       , flagSpecFlag :: flag     -- ^ Flag in internal form+       , flagSpecAction :: (TurnOnFlag -> DynP ())+           -- ^ Extra action to run when the flag is found+           -- Typically, emit a warning or error+       , flagSpecGhcMode :: GhcFlagMode+           -- ^ In which ghc mode the flag has effect+       }++-- | Define a new flag.+flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagSpec name flag = flagSpec' name flag nop++-- | Define a new flag with an effect.+flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+          -> (Deprecation, FlagSpec flag)+flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)++-- | Define a new deprecated flag with an effect.+depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpecOp name flag act dep =+    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))++-- | Define a new deprecated flag.+depFlagSpec :: String -> flag -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpec name flag dep = depFlagSpecOp name flag nop dep++-- | Define a new deprecated flag with an effect where the deprecation message+-- depends on the flag value+depFlagSpecOp' :: String+             -> flag+             -> (TurnOnFlag -> DynP ())+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpecOp' name flag act dep =+    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))+                                                                       AllModes)++-- | Define a new deprecated flag where the deprecation message+-- depends on the flag value+depFlagSpec' :: String+             -> flag+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep+++-- | Define a new deprecated flag where the deprecation message+-- is shown depending on the flag value+depFlagSpecCond :: String+                -> flag+                -> (TurnOnFlag -> Bool)+                -> String+                -> (Deprecation, FlagSpec flag)+depFlagSpecCond name flag cond dep =+    (Deprecated, FlagSpec name flag (\f -> when (cond f) $ deprecate dep)+                                                                       AllModes)++-- | Define a new flag for GHCi.+flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagGhciSpec name flag = flagGhciSpec' name flag nop++-- | Define a new flag for GHCi with an effect.+flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+              -> (Deprecation, FlagSpec flag)+flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)++-- | Define a new flag invisible to CLI completion.+flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagHiddenSpec name flag = flagHiddenSpec' name flag nop++-- | Define a new flag invisible to CLI completion with an effect.+flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+                -> (Deprecation, FlagSpec flag)+flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act+                                                                     HiddenFlag)++-- | Hide a 'FlagSpec' from being displayed in @--show-options@.+--+-- This is for example useful for flags that are obsolete, but should not+-- (yet) be deprecated for compatibility reasons.+hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)+hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })++mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on+       -> String                -- ^ The flag prefix+       -> (flag -> DynP ())     -- ^ What to do when the flag is found+       -> (Deprecation, FlagSpec flag)  -- ^ Specification of+                                        -- this particular flag+       -> (Deprecation, Flag (CmdLineP DynFlags))+mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))+    = (dep,+       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)++deprecatedForExtension :: String -> TurnOnFlag -> String+deprecatedForExtension lang turn_on+    = "use -X" ++ flag +++      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"+    where+      flag | turn_on   = lang+           | otherwise = "No" ++ lang++useInstead :: String -> String -> TurnOnFlag -> String+useInstead prefix flag turn_on+  = "Use " ++ prefix ++ no ++ flag ++ " instead"+  where+    no = if turn_on then "" else "no-"++nop :: TurnOnFlag -> DynP ()+nop _ = return ()++-- | Find the 'FlagSpec' for a 'WarningFlag'.+wWarningFlagMap :: Map WarningFlag (FlagSpec WarningFlag)+wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags++flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)+flagSpecOf = flip Map.lookup wWarningFlagMap++-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@+wWarningFlags :: [FlagSpec WarningFlag]+wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)++wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]+wWarningFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "alternative-layout-rule-transitional"+                                      Opt_WarnAlternativeLayoutRuleTransitional,+  flagSpec "ambiguous-fields"            Opt_WarnAmbiguousFields,+  depFlagSpec "auto-orphans"             Opt_WarnAutoOrphans+    "it has no effect",+  flagSpec "cpp-undef"                   Opt_WarnCPPUndef,+  flagSpec "unbanged-strict-patterns"    Opt_WarnUnbangedStrictPatterns,+  flagSpec "deferred-type-errors"        Opt_WarnDeferredTypeErrors,+  flagSpec "deferred-out-of-scope-variables"+                                         Opt_WarnDeferredOutOfScopeVariables,+  flagSpec "deprecations"                Opt_WarnWarningsDeprecations,+  flagSpec "deprecated-flags"            Opt_WarnDeprecatedFlags,+  flagSpec "deriving-defaults"           Opt_WarnDerivingDefaults,+  flagSpec "deriving-typeable"           Opt_WarnDerivingTypeable,+  flagSpec "dodgy-exports"               Opt_WarnDodgyExports,+  flagSpec "dodgy-foreign-imports"       Opt_WarnDodgyForeignImports,+  flagSpec "dodgy-imports"               Opt_WarnDodgyImports,+  flagSpec "empty-enumerations"          Opt_WarnEmptyEnumerations,+  depFlagSpec "duplicate-constraints"    Opt_WarnDuplicateConstraints+    "it is subsumed by -Wredundant-constraints",+  flagSpec "redundant-constraints"       Opt_WarnRedundantConstraints,+  flagSpec "duplicate-exports"           Opt_WarnDuplicateExports,+  depFlagSpec "hi-shadowing"                Opt_WarnHiShadows+    "it is not used, and was never implemented",+  flagSpec "inaccessible-code"           Opt_WarnInaccessibleCode,+  flagSpec "implicit-prelude"            Opt_WarnImplicitPrelude,+  depFlagSpec "implicit-kind-vars"       Opt_WarnImplicitKindVars+    "it is now an error",+  flagSpec "incomplete-patterns"         Opt_WarnIncompletePatterns,+  flagSpec "incomplete-record-updates"   Opt_WarnIncompletePatternsRecUpd,+  flagSpec "incomplete-uni-patterns"     Opt_WarnIncompleteUniPatterns,+  flagSpec "inline-rule-shadowing"       Opt_WarnInlineRuleShadowing,+  flagSpec "identities"                  Opt_WarnIdentities,+  flagSpec "missing-fields"              Opt_WarnMissingFields,+  flagSpec "missing-import-lists"        Opt_WarnMissingImportList,+  flagSpec "missing-export-lists"        Opt_WarnMissingExportList,+  depFlagSpec "missing-local-sigs"       Opt_WarnMissingLocalSignatures+    "it is replaced by -Wmissing-local-signatures",+  flagSpec "missing-local-signatures"    Opt_WarnMissingLocalSignatures,+  flagSpec "missing-methods"             Opt_WarnMissingMethods,+  depFlagSpec "missing-monadfail-instances"+                                         Opt_WarnMissingMonadFailInstances+    "fail is no longer a method of Monad",+  flagSpec "semigroup"                   Opt_WarnSemigroup,+  flagSpec "missing-signatures"          Opt_WarnMissingSignatures,+  flagSpec "missing-kind-signatures"     Opt_WarnMissingKindSignatures,+  depFlagSpec "missing-exported-sigs"    Opt_WarnMissingExportedSignatures+    "it is replaced by -Wmissing-exported-signatures",+  flagSpec "missing-exported-signatures" Opt_WarnMissingExportedSignatures,+  flagSpec "monomorphism-restriction"    Opt_WarnMonomorphism,+  flagSpec "name-shadowing"              Opt_WarnNameShadowing,+  flagSpec "noncanonical-monad-instances"+                                         Opt_WarnNonCanonicalMonadInstances,+  depFlagSpec "noncanonical-monadfail-instances"+                                         Opt_WarnNonCanonicalMonadInstances+    "fail is no longer a method of Monad",+  flagSpec "noncanonical-monoid-instances"+                                         Opt_WarnNonCanonicalMonoidInstances,+  flagSpec "orphans"                     Opt_WarnOrphans,+  flagSpec "overflowed-literals"         Opt_WarnOverflowedLiterals,+  flagSpec "overlapping-patterns"        Opt_WarnOverlappingPatterns,+  flagSpec "missed-specialisations"      Opt_WarnMissedSpecs,+  flagSpec "missed-specializations"      Opt_WarnMissedSpecs,+  flagSpec "all-missed-specialisations"  Opt_WarnAllMissedSpecs,+  flagSpec "all-missed-specializations"  Opt_WarnAllMissedSpecs,+  flagSpec' "safe"                       Opt_WarnSafe setWarnSafe,+  flagSpec "trustworthy-safe"            Opt_WarnTrustworthySafe,+  flagSpec "inferred-safe-imports"       Opt_WarnInferredSafeImports,+  flagSpec "missing-safe-haskell-mode"   Opt_WarnMissingSafeHaskellMode,+  flagSpec "tabs"                        Opt_WarnTabs,+  flagSpec "type-defaults"               Opt_WarnTypeDefaults,+  flagSpec "typed-holes"                 Opt_WarnTypedHoles,+  flagSpec "partial-type-signatures"     Opt_WarnPartialTypeSignatures,+  flagSpec "unrecognised-pragmas"        Opt_WarnUnrecognisedPragmas,+  flagSpec' "unsafe"                     Opt_WarnUnsafe setWarnUnsafe,+  flagSpec "unsupported-calling-conventions"+                                         Opt_WarnUnsupportedCallingConventions,+  flagSpec "unsupported-llvm-version"    Opt_WarnUnsupportedLlvmVersion,+  flagSpec "missed-extra-shared-lib"     Opt_WarnMissedExtraSharedLib,+  flagSpec "unticked-promoted-constructors"+                                         Opt_WarnUntickedPromotedConstructors,+  flagSpec "unused-do-bind"              Opt_WarnUnusedDoBind,+  flagSpec "unused-foralls"              Opt_WarnUnusedForalls,+  flagSpec "unused-imports"              Opt_WarnUnusedImports,+  flagSpec "unused-local-binds"          Opt_WarnUnusedLocalBinds,+  flagSpec "unused-matches"              Opt_WarnUnusedMatches,+  flagSpec "unused-pattern-binds"        Opt_WarnUnusedPatternBinds,+  flagSpec "unused-top-binds"            Opt_WarnUnusedTopBinds,+  flagSpec "unused-type-patterns"        Opt_WarnUnusedTypePatterns,+  flagSpec "unused-record-wildcards"     Opt_WarnUnusedRecordWildcards,+  flagSpec "redundant-bang-patterns"     Opt_WarnRedundantBangPatterns,+  flagSpec "redundant-record-wildcards"  Opt_WarnRedundantRecordWildcards,+  flagSpec "warnings-deprecations"       Opt_WarnWarningsDeprecations,+  flagSpec "wrong-do-bind"               Opt_WarnWrongDoBind,+  flagSpec "missing-pattern-synonym-signatures"+                                    Opt_WarnMissingPatternSynonymSignatures,+  flagSpec "missing-deriving-strategies" Opt_WarnMissingDerivingStrategies,+  flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,+  flagSpec "missing-home-modules"        Opt_WarnMissingHomeModules,+  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags,+  flagSpec "star-binder"                 Opt_WarnStarBinder,+  flagSpec "star-is-type"                Opt_WarnStarIsType,+  depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang+    "bang patterns can no longer be written with a space",+  flagSpec "partial-fields"              Opt_WarnPartialFields,+  flagSpec "prepositive-qualified-module"+                                         Opt_WarnPrepositiveQualifiedModule,+  flagSpec "unused-packages"             Opt_WarnUnusedPackages,+  flagSpec "compat-unqualified-imports"  Opt_WarnCompatUnqualifiedImports,+  flagSpec "invalid-haddock"             Opt_WarnInvalidHaddock,+  flagSpec "operator-whitespace-ext-conflict"  Opt_WarnOperatorWhitespaceExtConflict,+  flagSpec "operator-whitespace"         Opt_WarnOperatorWhitespace,+  flagSpec "implicit-lift"               Opt_WarnImplicitLift+ ]++-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@+negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+negatableFlagsDeps = [+  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]++-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@+dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+dFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,+  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks+     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),+  flagSpec "suppress-ticks"             Opt_SuppressTicks,+  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts+     (useInstead "-d" "suppress-stg-exts"),+  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,+  flagSpec "suppress-coercions"         Opt_SuppressCoercions,+  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,+  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,+  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,+  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,+  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,+  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,+  flagSpec "suppress-uniques"           Opt_SuppressUniques,+  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fFlags :: [FlagSpec GeneralFlag]+fFlags = map snd fFlagsDeps++fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+fFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,+  flagGhciSpec "break-on-error"               Opt_BreakOnError,+  flagGhciSpec "break-on-exception"           Opt_BreakOnException,+  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,+  flagSpec "call-arity"                       Opt_CallArity,+  flagSpec "exitification"                    Opt_Exitification,+  flagSpec "case-merge"                       Opt_CaseMerge,+  flagSpec "case-folding"                     Opt_CaseFolding,+  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,+  flagSpec "cmm-sink"                         Opt_CmmSink,+  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,+  flagSpec "cse"                              Opt_CSE,+  flagSpec "stg-cse"                          Opt_StgCSE,+  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,+  flagSpec "cpr-anal"                         Opt_CprAnal,+  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,+  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,+  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,+  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,+  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,+  flagSpec "dicts-cheap"                      Opt_DictsCheap,+  flagSpec "dicts-strict"                     Opt_DictsStrict,+  depFlagSpec "dmd-tx-dict-sel"+      Opt_DmdTxDictSel "effect is now unconditionally enabled",+  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,+  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,+  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,+  flagSpec "embed-manifest"                   Opt_EmbedManifest,+  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,+  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,+  flagSpec "error-spans"                      Opt_ErrorSpans,+  flagSpec "excess-precision"                 Opt_ExcessPrecision,+  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,+  flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,+  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,+  flagSpec "external-interpreter"             Opt_ExternalInterpreter,+  flagSpec "family-application-cache"         Opt_FamAppCache,+  flagSpec "float-in"                         Opt_FloatIn,+  flagSpec "force-recomp"                     Opt_ForceRecomp,+  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,+  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,+  flagSpec "full-laziness"                    Opt_FullLaziness,+  flagSpec "fun-to-thunk"                     Opt_FunToThunk,+  flagSpec "gen-manifest"                     Opt_GenManifest,+  flagSpec "ghci-history"                     Opt_GhciHistory,+  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,+  flagSpec "validate-ide-info"                Opt_ValidateHie,+  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,+  flagGhciSpec "no-it"                        Opt_NoIt,+  flagSpec "ghci-sandbox"                     Opt_GhciSandbox,+  flagSpec "helpful-errors"                   Opt_HelpfulErrors,+  flagSpec "hpc"                              Opt_Hpc,+  flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,+  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,+  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,+  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,+  flagSpec "keep-going"                       Opt_KeepGoing,+  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,+  flagSpec "late-specialise"                  Opt_LateSpecialise,+  flagSpec "liberate-case"                    Opt_LiberateCase,+  flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,+  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,+  flagSpec "loopification"                    Opt_Loopification,+  flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,+  flagSpec "block-layout-weightless"          Opt_WeightlessBlocklayout,+  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,+  flagSpec "omit-yields"                      Opt_OmitYields,+  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,+  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,+  flagSpec "pre-inlining"                     Opt_SimplPreInlining,+  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,+  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,+  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,+  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,+  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,+  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,+  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,+  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,+  flagSpec "print-axiom-incomps"              Opt_PrintAxiomIncomps,+  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,+  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,+  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,+  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,+  flagSpec "prof-count-entries"               Opt_ProfCountEntries,+  flagSpec "regs-graph"                       Opt_RegsGraph,+  flagSpec "regs-iterative"                   Opt_RegsIterative,+  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules+   (useInstead "-f" "enable-rewrite-rules"),+  flagSpec "shared-implib"                    Opt_SharedImplib,+  flagSpec "spec-constr"                      Opt_SpecConstr,+  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,+  flagSpec "specialise"                       Opt_Specialise,+  flagSpec "specialize"                       Opt_Specialise,+  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,+  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,+  flagSpec "inline-generics"                  Opt_InlineGenerics,+  flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,+  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,+  flagSpec "strictness"                       Opt_Strictness,+  flagSpec "use-rpaths"                       Opt_RPath,+  flagSpec "write-interface"                  Opt_WriteInterface,+  flagSpec "write-ide-info"                   Opt_WriteHie,+  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,+  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,+  flagSpec "version-macros"                   Opt_VersionMacros,+  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,+  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,+  flagSpec "catch-bottoms"                    Opt_CatchBottoms,+  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,+  flagSpec "num-constant-folding"             Opt_NumConstantFolding,+  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,+  flagSpec "hide-source-paths"                Opt_HideSourcePaths,+  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,+  flagSpec "keep-cafs"                        Opt_KeepCAFs,+  flagSpec "link-rts"                         Opt_LinkRts+  ]+  ++ fHoleFlags++-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or+-- the valid hole fits in that message. See Note [Valid hole fits include ...]+-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with+-- @-fno-\<blah\>@+fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]+fHoleFlags = [+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,+  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits+   (useInstead "-f" "show-valid-hole-fits"),+  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,+  -- Sorting settings+  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,+  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,+  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,+  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,+  -- Output format settings+  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,+  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,+  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,+  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,+  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,+  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,+  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fLangFlags :: [FlagSpec LangExt.Extension]+fLangFlags = map snd fLangFlagsDeps++fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+fLangFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  depFlagSpecOp' "th"                           LangExt.TemplateHaskell+    checkTemplateHaskellOk+    (deprecatedForExtension "TemplateHaskell"),+  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "arrows"                         LangExt.Arrows+    (deprecatedForExtension "Arrows"),+  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude+    (deprecatedForExtension "ImplicitPrelude"),+  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns+    (deprecatedForExtension "BangPatterns"),+  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction+    (deprecatedForExtension "MonomorphismRestriction"),+  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules+    (deprecatedForExtension "ExtendedDefaultRules"),+  depFlagSpec' "implicit-params"                LangExt.ImplicitParams+    (deprecatedForExtension "ImplicitParams"),+  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances+    (deprecatedForExtension "OverlappingInstances"),+  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances+    (deprecatedForExtension "UndecidableInstances"),+  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances+    (deprecatedForExtension "IncoherentInstances")+  ]++supportedLanguages :: [String]+supportedLanguages = map (flagSpecName . snd) languageFlagsDeps++supportedLanguageOverlays :: [String]+supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps++supportedExtensions :: ArchOS -> [String]+supportedExtensions (ArchOS _ os) = concatMap toFlagSpecNamePair xFlags+  where+    toFlagSpecNamePair flg+      -- IMPORTANT! Make sure that `ghc --supported-extensions` omits+      -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the+      -- box. See also GHC #11102 and #16331 for more details about+      -- the rationale+      | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]+      | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]+      | otherwise = [name, noName]+      where+        isAIX = os == OSAIX+        noName = "No" ++ name+        name = flagSpecName flg++supportedLanguagesAndExtensions :: ArchOS -> [String]+supportedLanguagesAndExtensions arch_os =+    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+languageFlagsDeps :: [(Deprecation, FlagSpec Language)]+languageFlagsDeps = [+  flagSpec "Haskell98"   Haskell98,+  flagSpec "Haskell2010" Haskell2010,+  flagSpec "GHC2021"     GHC2021+  ]++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+-- They are used to place hard requirements on what GHC Haskell language+-- features can be used.+safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]+safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]+    where mkF flag = flagSpec (show flag) flag++-- | These -X<blah> flags can all be reversed with -XNo<blah>+xFlags :: [FlagSpec LangExt.Extension]+xFlags = map snd xFlagsDeps++xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+xFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- See Note [Adding a language extension]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "AllowAmbiguousTypes"              LangExt.AllowAmbiguousTypes,+  flagSpec "AlternativeLayoutRule"            LangExt.AlternativeLayoutRule,+  flagSpec "AlternativeLayoutRuleTransitional"+                                              LangExt.AlternativeLayoutRuleTransitional,+  flagSpec "Arrows"                           LangExt.Arrows,+  depFlagSpecCond "AutoDeriveTypeable"        LangExt.AutoDeriveTypeable+    id+         ("Typeable instances are created automatically " +++                     "for all types since GHC 8.2."),+  flagSpec "BangPatterns"                     LangExt.BangPatterns,+  flagSpec "BinaryLiterals"                   LangExt.BinaryLiterals,+  flagSpec "CApiFFI"                          LangExt.CApiFFI,+  flagSpec "CPP"                              LangExt.Cpp,+  flagSpec "CUSKs"                            LangExt.CUSKs,+  flagSpec "ConstrainedClassMethods"          LangExt.ConstrainedClassMethods,+  flagSpec "ConstraintKinds"                  LangExt.ConstraintKinds,+  flagSpec "DataKinds"                        LangExt.DataKinds,+  depFlagSpecCond "DatatypeContexts"          LangExt.DatatypeContexts+    id+         ("It was widely considered a misfeature, " +++                     "and has been removed from the Haskell language."),+  flagSpec "DefaultSignatures"                LangExt.DefaultSignatures,+  flagSpec "DeriveAnyClass"                   LangExt.DeriveAnyClass,+  flagSpec "DeriveDataTypeable"               LangExt.DeriveDataTypeable,+  flagSpec "DeriveFoldable"                   LangExt.DeriveFoldable,+  flagSpec "DeriveFunctor"                    LangExt.DeriveFunctor,+  flagSpec "DeriveGeneric"                    LangExt.DeriveGeneric,+  flagSpec "DeriveLift"                       LangExt.DeriveLift,+  flagSpec "DeriveTraversable"                LangExt.DeriveTraversable,+  flagSpec "DerivingStrategies"               LangExt.DerivingStrategies,+  flagSpec' "DerivingVia"                     LangExt.DerivingVia+                                              setDeriveVia,+  flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,+  flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,+  flagSpec "BlockArguments"                   LangExt.BlockArguments,+  depFlagSpec' "DoRec"                        LangExt.RecursiveDo+    (deprecatedForExtension "RecursiveDo"),+  flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,+  flagSpec "FieldSelectors"                   LangExt.FieldSelectors,+  flagSpec "EmptyCase"                        LangExt.EmptyCase,+  flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,+  flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,+  flagSpec "ExistentialQuantification"        LangExt.ExistentialQuantification,+  flagSpec "ExplicitForAll"                   LangExt.ExplicitForAll,+  flagSpec "ExplicitNamespaces"               LangExt.ExplicitNamespaces,+  flagSpec "ExtendedDefaultRules"             LangExt.ExtendedDefaultRules,+  flagSpec "FlexibleContexts"                 LangExt.FlexibleContexts,+  flagSpec "FlexibleInstances"                LangExt.FlexibleInstances,+  flagSpec "ForeignFunctionInterface"         LangExt.ForeignFunctionInterface,+  flagSpec "FunctionalDependencies"           LangExt.FunctionalDependencies,+  flagSpec "GADTSyntax"                       LangExt.GADTSyntax,+  flagSpec "GADTs"                            LangExt.GADTs,+  flagSpec "GHCForeignImportPrim"             LangExt.GHCForeignImportPrim,+  flagSpec' "GeneralizedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving+                                              setGenDeriving,+  flagSpec' "GeneralisedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving+                                              setGenDeriving,+  flagSpec "ImplicitParams"                   LangExt.ImplicitParams,+  flagSpec "ImplicitPrelude"                  LangExt.ImplicitPrelude,+  flagSpec "ImportQualifiedPost"              LangExt.ImportQualifiedPost,+  flagSpec "ImpredicativeTypes"               LangExt.ImpredicativeTypes,+  flagSpec' "IncoherentInstances"             LangExt.IncoherentInstances+                                              setIncoherentInsts,+  flagSpec "TypeFamilyDependencies"           LangExt.TypeFamilyDependencies,+  flagSpec "InstanceSigs"                     LangExt.InstanceSigs,+  flagSpec "ApplicativeDo"                    LangExt.ApplicativeDo,+  flagSpec "InterruptibleFFI"                 LangExt.InterruptibleFFI,+  flagSpec "JavaScriptFFI"                    LangExt.JavaScriptFFI,+  flagSpec "KindSignatures"                   LangExt.KindSignatures,+  flagSpec "LambdaCase"                       LangExt.LambdaCase,+  flagSpec "LexicalNegation"                  LangExt.LexicalNegation,+  flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,+  flagSpec "LinearTypes"                      LangExt.LinearTypes,+  flagSpec "MagicHash"                        LangExt.MagicHash,+  flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,+  flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,+  flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,+  flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,+  flagSpec "MultiWayIf"                       LangExt.MultiWayIf,+  flagSpec "NumericUnderscores"               LangExt.NumericUnderscores,+  flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,+  flagSpec "NamedFieldPuns"                   LangExt.RecordPuns,+  flagSpec "NamedWildCards"                   LangExt.NamedWildCards,+  flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,+  flagSpec "HexFloatLiterals"                 LangExt.HexFloatLiterals,+  flagSpec "NondecreasingIndentation"         LangExt.NondecreasingIndentation,+  depFlagSpec' "NullaryTypeClasses"           LangExt.NullaryTypeClasses+    (deprecatedForExtension "MultiParamTypeClasses"),+  flagSpec "NumDecimals"                      LangExt.NumDecimals,+  depFlagSpecOp "OverlappingInstances"        LangExt.OverlappingInstances+    setOverlappingInsts+    "instead use per-instance pragmas OVERLAPPING/OVERLAPPABLE/OVERLAPS",+  flagSpec "OverloadedLabels"                 LangExt.OverloadedLabels,+  flagSpec "OverloadedLists"                  LangExt.OverloadedLists,+  flagSpec "OverloadedStrings"                LangExt.OverloadedStrings,+  flagSpec "PackageImports"                   LangExt.PackageImports,+  flagSpec "ParallelArrays"                   LangExt.ParallelArrays,+  flagSpec "ParallelListComp"                 LangExt.ParallelListComp,+  flagSpec "PartialTypeSignatures"            LangExt.PartialTypeSignatures,+  flagSpec "PatternGuards"                    LangExt.PatternGuards,+  depFlagSpec' "PatternSignatures"            LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  flagSpec "PatternSynonyms"                  LangExt.PatternSynonyms,+  flagSpec "PolyKinds"                        LangExt.PolyKinds,+  flagSpec "PolymorphicComponents"            LangExt.RankNTypes,+  flagSpec "QuantifiedConstraints"            LangExt.QuantifiedConstraints,+  flagSpec "PostfixOperators"                 LangExt.PostfixOperators,+  flagSpec "QuasiQuotes"                      LangExt.QuasiQuotes,+  flagSpec "QualifiedDo"                      LangExt.QualifiedDo,+  flagSpec "Rank2Types"                       LangExt.RankNTypes,+  flagSpec "RankNTypes"                       LangExt.RankNTypes,+  flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,+  flagSpec "OverloadedRecordDot"              LangExt.OverloadedRecordDot,+  flagSpec "OverloadedRecordUpdate"           LangExt.OverloadedRecordUpdate,+  depFlagSpec' "RecordPuns"                   LangExt.RecordPuns+    (deprecatedForExtension "NamedFieldPuns"),+  flagSpec "RecordWildCards"                  LangExt.RecordWildCards,+  flagSpec "RecursiveDo"                      LangExt.RecursiveDo,+  flagSpec "RelaxedLayout"                    LangExt.RelaxedLayout,+  depFlagSpecCond "RelaxedPolyRec"            LangExt.RelaxedPolyRec+    not+         "You can't turn off RelaxedPolyRec any more",+  flagSpec "RoleAnnotations"                  LangExt.RoleAnnotations,+  flagSpec "ScopedTypeVariables"              LangExt.ScopedTypeVariables,+  flagSpec "StandaloneDeriving"               LangExt.StandaloneDeriving,+  flagSpec "StarIsType"                       LangExt.StarIsType,+  flagSpec "StaticPointers"                   LangExt.StaticPointers,+  flagSpec "Strict"                           LangExt.Strict,+  flagSpec "StrictData"                       LangExt.StrictData,+  flagSpec' "TemplateHaskell"                 LangExt.TemplateHaskell+                                              checkTemplateHaskellOk,+  flagSpec "TemplateHaskellQuotes"            LangExt.TemplateHaskellQuotes,+  flagSpec "StandaloneKindSignatures"         LangExt.StandaloneKindSignatures,+  flagSpec "TraditionalRecordSyntax"          LangExt.TraditionalRecordSyntax,+  flagSpec "TransformListComp"                LangExt.TransformListComp,+  flagSpec "TupleSections"                    LangExt.TupleSections,+  flagSpec "TypeApplications"                 LangExt.TypeApplications,+  flagSpec "TypeInType"                       LangExt.TypeInType,+  flagSpec "TypeFamilies"                     LangExt.TypeFamilies,+  flagSpec "TypeOperators"                    LangExt.TypeOperators,+  flagSpec "TypeSynonymInstances"             LangExt.TypeSynonymInstances,+  flagSpec "UnboxedTuples"                    LangExt.UnboxedTuples,+  flagSpec "UnboxedSums"                      LangExt.UnboxedSums,+  flagSpec "UndecidableInstances"             LangExt.UndecidableInstances,+  flagSpec "UndecidableSuperClasses"          LangExt.UndecidableSuperClasses,+  flagSpec "UnicodeSyntax"                    LangExt.UnicodeSyntax,+  flagSpec "UnliftedDatatypes"                LangExt.UnliftedDatatypes,+  flagSpec "UnliftedFFITypes"                 LangExt.UnliftedFFITypes,+  flagSpec "UnliftedNewtypes"                 LangExt.UnliftedNewtypes,+  flagSpec "ViewPatterns"                     LangExt.ViewPatterns+  ]++defaultFlags :: Settings -> [GeneralFlag]+defaultFlags settings+-- See Note [Updating flag description in the User's Guide]+  = [ Opt_AutoLinkPackages,+      Opt_DiagnosticsShowCaret,+      Opt_EmbedManifest,+      Opt_FamAppCache,+      Opt_GenManifest,+      Opt_GhciHistory,+      Opt_GhciSandbox,+      Opt_HelpfulErrors,+      Opt_KeepHiFiles,+      Opt_KeepOFiles,+      Opt_OmitYields,+      Opt_PrintBindContents,+      Opt_ProfCountEntries,+      Opt_SharedImplib,+      Opt_SimplPreInlining,+      Opt_VersionMacros,+      Opt_RPath+    ]++    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]+             -- The default -O0 options++    ++ default_PIC platform++    ++ validHoleFitDefaults++    where platform = sTargetPlatform settings++-- | These are the default settings for the display and sorting of valid hole+--  fits in typed-hole error messages. See Note [Valid hole fits include ...]+ -- in the "GHC.Tc.Errors.Hole" module.+validHoleFitDefaults :: [GeneralFlag]+validHoleFitDefaults+  =  [ Opt_ShowTypeAppOfHoleFits+     , Opt_ShowTypeOfHoleFits+     , Opt_ShowProvOfHoleFits+     , Opt_ShowMatchesOfHoleFits+     , Opt_ShowValidHoleFits+     , Opt_SortValidHoleFits+     , Opt_SortBySizeHoleFits+     , Opt_ShowHoleConstraints ]+++validHoleFitsImpliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+validHoleFitsImpliedGFlags+  = [ (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowTypeAppVarsOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowDocsOfHoleFits)+    , (Opt_ShowTypeAppVarsOfHoleFits, turnOff, Opt_ShowTypeAppOfHoleFits)+    , (Opt_UnclutterValidHoleFits, turnOff, Opt_ShowProvOfHoleFits) ]++default_PIC :: Platform -> [GeneralFlag]+default_PIC platform =+  case (platformOS platform, platformArch platform) of+    -- Darwin always requires PIC.  Especially on more recent macOS releases+    -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses+    -- while we could work around this on x86_64 (like WINE does), we won't be+    -- able on aarch64, where this is enforced.+    (OSDarwin,  ArchX86_64)  -> [Opt_PIC]+    -- For AArch64, we need to always have PIC enabled.  The relocation model+    -- on AArch64 does not permit arbitrary relocations.  Under ASLR, we can't+    -- control much how far apart symbols are in memory for our in-memory static+    -- linker;  and thus need to ensure we get sufficiently capable relocations.+    -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top+    -- of that.  Subsequently we expect all code on aarch64/linux (and macOS) to+    -- be built with -fPIC.+    (OSDarwin,  ArchAArch64) -> [Opt_PIC]+    (OSLinux,   ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchARM {})  -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSOpenBSD, ArchX86_64)  -> [Opt_PIC] -- Due to PIE support in+                                         -- OpenBSD since 5.3 release+                                         -- (1 May 2013) we need to+                                         -- always generate PIC. See+                                         -- #10597 for more+                                         -- information.+    _                      -> []++-- General flags that are switched on/off when other general flags are switched+-- on+impliedGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedGFlags = [(Opt_DeferTypeErrors, turnOn, Opt_DeferTypedHoles)+                ,(Opt_DeferTypeErrors, turnOn, Opt_DeferOutOfScopeVariables)+                ,(Opt_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)+                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)+                ] ++ validHoleFitsImpliedGFlags++-- General flags that are switched on/off when other general flags are switched+-- off+impliedOffGFlags :: [(GeneralFlag, TurnOnFlag, GeneralFlag)]+impliedOffGFlags = [(Opt_Strictness, turnOff, Opt_WorkerWrapper)]++impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]+impliedXFlags+-- See Note [Updating flag description in the User's Guide]+  = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)+    , (LangExt.QuantifiedConstraints,     turnOn, LangExt.ExplicitForAll)+    , (LangExt.ScopedTypeVariables,       turnOn, LangExt.ExplicitForAll)+    , (LangExt.LiberalTypeSynonyms,       turnOn, LangExt.ExplicitForAll)+    , (LangExt.ExistentialQuantification, turnOn, LangExt.ExplicitForAll)+    , (LangExt.FlexibleInstances,         turnOn, LangExt.TypeSynonymInstances)+    , (LangExt.FunctionalDependencies,    turnOn, LangExt.MultiParamTypeClasses)+    , (LangExt.MultiParamTypeClasses,     turnOn, LangExt.ConstrainedClassMethods)  -- c.f. #7854+    , (LangExt.TypeFamilyDependencies,    turnOn, LangExt.TypeFamilies)++    , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!++    , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)++    , (LangExt.GADTs,            turnOn, LangExt.GADTSyntax)+    , (LangExt.GADTs,            turnOn, LangExt.MonoLocalBinds)+    , (LangExt.TypeFamilies,     turnOn, LangExt.MonoLocalBinds)++    , (LangExt.TypeFamilies,     turnOn, LangExt.KindSignatures)  -- Type families use kind signatures+    , (LangExt.PolyKinds,        turnOn, LangExt.KindSignatures)  -- Ditto polymorphic kinds++    -- TypeInType is now just a synonym for a couple of other extensions.+    , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)+    , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)+    , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)++    -- Standalone kind signatures are a replacement for CUSKs.+    , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)++    -- AutoDeriveTypeable is not very useful without DeriveDataTypeable+    , (LangExt.AutoDeriveTypeable, turnOn, LangExt.DeriveDataTypeable)++    -- We turn this on so that we can export associated type+    -- type synonyms in subordinates (e.g. MyClass(type AssocType))+    , (LangExt.TypeFamilies,     turnOn, LangExt.ExplicitNamespaces)+    , (LangExt.TypeOperators, turnOn, LangExt.ExplicitNamespaces)++    , (LangExt.ImpredicativeTypes,  turnOn, LangExt.RankNTypes)++        -- Record wild-cards implies field disambiguation+        -- Otherwise if you write (C {..}) you may well get+        -- stuff like " 'a' not in scope ", which is a bit silly+        -- if the compiler has just filled in field 'a' of constructor 'C'+    , (LangExt.RecordWildCards,     turnOn, LangExt.DisambiguateRecordFields)++    , (LangExt.ParallelArrays, turnOn, LangExt.ParallelListComp)++    , (LangExt.JavaScriptFFI, turnOn, LangExt.InterruptibleFFI)++    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFunctor)+    , (LangExt.DeriveTraversable, turnOn, LangExt.DeriveFoldable)++    -- Duplicate record fields require field disambiguation+    , (LangExt.DuplicateRecordFields, turnOn, LangExt.DisambiguateRecordFields)++    , (LangExt.TemplateHaskell, turnOn, LangExt.TemplateHaskellQuotes)+    , (LangExt.Strict, turnOn, LangExt.StrictData)++    -- The extensions needed to declare an H98 unlifted data type+    , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)+    , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)+  ]++-- Note [When is StarIsType enabled]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The StarIsType extension determines whether to treat '*' as a regular type+-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType+-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is+-- enabled.+--+-- Programs that use TypeOperators might expect to repurpose '*' for+-- multiplication or another binary operation, but making TypeOperators imply+-- NoStarIsType caused too much breakage on Hackage.+--++-- Note [Documenting optimisation flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of flags enabled for particular optimisation levels+-- please remember to update the User's Guide. The relevant file is:+--+--   docs/users_guide/using-optimisation.rst+--+-- Make sure to note whether a flag is implied by -O0, -O or -O2.++optLevelFlags :: [([Int], GeneralFlag)]+-- Default settings of flags, before any command-line overrides+optLevelFlags -- see Note [Documenting optimisation flags]+  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)+    , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]+    , ([0,1,2], Opt_LlvmTBAA)++    , ([0],     Opt_IgnoreInterfacePragmas)+    , ([0],     Opt_OmitInterfacePragmas)++    , ([1,2],   Opt_CallArity)+    , ([1,2],   Opt_Exitification)+    , ([1,2],   Opt_CaseMerge)+    , ([1,2],   Opt_CaseFolding)+    , ([1,2],   Opt_CmmElimCommonBlocks)+    , ([2],     Opt_AsmShortcutting)+    , ([1,2],   Opt_CmmSink)+    , ([1,2],   Opt_CmmStaticPred)+    , ([1,2],   Opt_CSE)+    , ([1,2],   Opt_StgCSE)+    , ([2],     Opt_StgLiftLams)++    , ([1,2],   Opt_EnableRewriteRules)+          -- Off for -O0.   Otherwise we desugar list literals+          -- to 'build' but don't run the simplifier passes that+          -- would rewrite them back to cons cells!  This seems+          -- silly, and matters for the GHCi debugger.++    , ([1,2],   Opt_FloatIn)+    , ([1,2],   Opt_FullLaziness)+    , ([1,2],   Opt_IgnoreAsserts)+    , ([1,2],   Opt_Loopification)+    , ([1,2],   Opt_CfgBlocklayout)      -- Experimental++    , ([1,2],   Opt_Specialise)+    , ([1,2],   Opt_CrossModuleSpecialise)+    , ([1,2],   Opt_InlineGenerics)+    , ([1,2],   Opt_Strictness)+    , ([1,2],   Opt_UnboxSmallStrictFields)+    , ([1,2],   Opt_CprAnal)+    , ([1,2],   Opt_WorkerWrapper)+    , ([1,2],   Opt_SolveConstantDicts)+    , ([1,2],   Opt_NumConstantFolding)++    , ([2],     Opt_LiberateCase)+    , ([2],     Opt_SpecConstr)+--  , ([2],     Opt_RegsGraph)+--   RegsGraph suffers performance regression. See #7679+--  , ([2],     Opt_StaticArgumentTransformation)+--   Static Argument Transformation needs investigation. See #9374+    ]+++-- -----------------------------------------------------------------------------+-- Standard sets of warning options++-- Note [Documenting warning flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of warning enabled by default+-- please remember to update the User's Guide. The relevant file is:+--+--  docs/users_guide/using-warnings.rst++-- | Warning groups.+--+-- As all warnings are in the Weverything set, it is ignored when+-- displaying to the user which group a warning is in.+warningGroups :: [(String, [WarningFlag])]+warningGroups =+    [ ("compat",       minusWcompatOpts)+    , ("unused-binds", unusedBindsFlags)+    , ("default",      standardWarnings)+    , ("extra",        minusWOpts)+    , ("all",          minusWallOpts)+    , ("everything",   minusWeverythingOpts)+    ]++-- | Warning group hierarchies, where there is an explicit inclusion+-- relation.+--+-- Each inner list is a hierarchy of warning groups, ordered from+-- smallest to largest, where each group is a superset of the one+-- before it.+--+-- Separating this from 'warningGroups' allows for multiple+-- hierarchies with no inherent relation to be defined.+--+-- The special-case Weverything group is not included.+warningHierarchies :: [[String]]+warningHierarchies = hierarchies ++ map (:[]) rest+  where+    hierarchies = [["default", "extra", "all"]]+    rest = filter (`notElem` "everything" : concat hierarchies) $+           map fst warningGroups++-- | Find the smallest group in every hierarchy which a warning+-- belongs to, excluding Weverything.+smallestGroups :: WarningFlag -> [String]+smallestGroups flag = mapMaybe go warningHierarchies where+    -- Because each hierarchy is arranged from smallest to largest,+    -- the first group we find in a hierarchy which contains the flag+    -- is the smallest.+    go (group:rest) = fromMaybe (go rest) $ do+        flags <- lookup group warningGroups+        guard (flag `elem` flags)+        pure (Just group)+    go [] = Nothing++-- | Warnings enabled unless specified otherwise+standardWarnings :: [WarningFlag]+standardWarnings -- see Note [Documenting warning flags]+    = [ Opt_WarnOverlappingPatterns,+        Opt_WarnWarningsDeprecations,+        Opt_WarnDeprecatedFlags,+        Opt_WarnDeferredTypeErrors,+        Opt_WarnTypedHoles,+        Opt_WarnDeferredOutOfScopeVariables,+        Opt_WarnPartialTypeSignatures,+        Opt_WarnUnrecognisedPragmas,+        Opt_WarnDuplicateExports,+        Opt_WarnDerivingDefaults,+        Opt_WarnOverflowedLiterals,+        Opt_WarnEmptyEnumerations,+        Opt_WarnAmbiguousFields,+        Opt_WarnMissingFields,+        Opt_WarnMissingMethods,+        Opt_WarnWrongDoBind,+        Opt_WarnUnsupportedCallingConventions,+        Opt_WarnDodgyForeignImports,+        Opt_WarnInlineRuleShadowing,+        Opt_WarnAlternativeLayoutRuleTransitional,+        Opt_WarnUnsupportedLlvmVersion,+        Opt_WarnMissedExtraSharedLib,+        Opt_WarnTabs,+        Opt_WarnUnrecognisedWarningFlags,+        Opt_WarnSimplifiableClassConstraints,+        Opt_WarnStarBinder,+        Opt_WarnInaccessibleCode,+        Opt_WarnSpaceAfterBang,+        Opt_WarnNonCanonicalMonadInstances,+        Opt_WarnNonCanonicalMonoidInstances,+        Opt_WarnOperatorWhitespaceExtConflict+      ]++-- | Things you get with -W+minusWOpts :: [WarningFlag]+minusWOpts+    = standardWarnings +++      [ Opt_WarnUnusedTopBinds,+        Opt_WarnUnusedLocalBinds,+        Opt_WarnUnusedPatternBinds,+        Opt_WarnUnusedMatches,+        Opt_WarnUnusedForalls,+        Opt_WarnUnusedImports,+        Opt_WarnIncompletePatterns,+        Opt_WarnDodgyExports,+        Opt_WarnDodgyImports,+        Opt_WarnUnbangedStrictPatterns+      ]++-- | Things you get with -Wall+minusWallOpts :: [WarningFlag]+minusWallOpts+    = minusWOpts +++      [ Opt_WarnTypeDefaults,+        Opt_WarnNameShadowing,+        Opt_WarnMissingSignatures,+        Opt_WarnHiShadows,+        Opt_WarnOrphans,+        Opt_WarnUnusedDoBind,+        Opt_WarnTrustworthySafe,+        Opt_WarnUntickedPromotedConstructors,+        Opt_WarnMissingPatternSynonymSignatures,+        Opt_WarnUnusedRecordWildcards,+        Opt_WarnRedundantRecordWildcards,+        Opt_WarnStarIsType,+        Opt_WarnIncompleteUniPatterns,+        Opt_WarnIncompletePatternsRecUpd+      ]++-- | Things you get with -Weverything, i.e. *all* known warnings flags+minusWeverythingOpts :: [WarningFlag]+minusWeverythingOpts = [ toEnum 0 .. ]++-- | Things you get with -Wcompat.+--+-- This is intended to group together warnings that will be enabled by default+-- at some point in the future, so that library authors eager to make their+-- code future compatible to fix issues before they even generate warnings.+minusWcompatOpts :: [WarningFlag]+minusWcompatOpts+    = [ Opt_WarnSemigroup+      , Opt_WarnNonCanonicalMonoidInstances+      , Opt_WarnStarIsType+      , Opt_WarnCompatUnqualifiedImports+      ]++enableUnusedBinds :: DynP ()+enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags++disableUnusedBinds :: DynP ()+disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags++-- Things you get with -Wunused-binds+unusedBindsFlags :: [WarningFlag]+unusedBindsFlags = [ Opt_WarnUnusedTopBinds+                   , Opt_WarnUnusedLocalBinds+                   , Opt_WarnUnusedPatternBinds+                   ]++enableGlasgowExts :: DynP ()+enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls+                       mapM_ setExtensionFlag glasgowExtsFlags++disableGlasgowExts :: DynP ()+disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls+                        mapM_ unSetExtensionFlag glasgowExtsFlags++-- Please keep what_glasgow_exts_does.rst up to date with this list+glasgowExtsFlags :: [LangExt.Extension]+glasgowExtsFlags = [+             LangExt.ConstrainedClassMethods+           , LangExt.DeriveDataTypeable+           , LangExt.DeriveFoldable+           , LangExt.DeriveFunctor+           , LangExt.DeriveGeneric+           , LangExt.DeriveTraversable+           , LangExt.EmptyDataDecls+           , LangExt.ExistentialQuantification+           , LangExt.ExplicitNamespaces+           , LangExt.FlexibleContexts+           , LangExt.FlexibleInstances+           , LangExt.ForeignFunctionInterface+           , LangExt.FunctionalDependencies+           , LangExt.GeneralizedNewtypeDeriving+           , LangExt.ImplicitParams+           , LangExt.KindSignatures+           , LangExt.LiberalTypeSynonyms+           , LangExt.MagicHash+           , LangExt.MultiParamTypeClasses+           , LangExt.ParallelListComp+           , LangExt.PatternGuards+           , LangExt.PostfixOperators+           , LangExt.RankNTypes+           , LangExt.RecursiveDo+           , LangExt.ScopedTypeVariables+           , LangExt.StandaloneDeriving+           , LangExt.TypeOperators+           , LangExt.TypeSynonymInstances+           , LangExt.UnboxedTuples+           , LangExt.UnicodeSyntax+           , LangExt.UnliftedFFITypes ]++setWarnSafe :: Bool -> DynP ()+setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })+setWarnSafe False = return ()++setWarnUnsafe :: Bool -> DynP ()+setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })+setWarnUnsafe False = return ()++setPackageTrust :: DynP ()+setPackageTrust = do+    setGeneralFlag Opt_PackageTrust+    l <- getCurLoc+    upd $ \d -> d { pkgTrustOnLoc = l }++setGenDeriving :: TurnOnFlag -> DynP ()+setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })+setGenDeriving False = return ()++setDeriveVia :: TurnOnFlag -> DynP ()+setDeriveVia True  = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })+setDeriveVia False = return ()++setOverlappingInsts :: TurnOnFlag -> DynP ()+setOverlappingInsts False = return ()+setOverlappingInsts True = do+  l <- getCurLoc+  upd (\d -> d { overlapInstLoc = l })++setIncoherentInsts :: TurnOnFlag -> DynP ()+setIncoherentInsts False = return ()+setIncoherentInsts True = do+  l <- getCurLoc+  upd (\d -> d { incoherentOnLoc = l })++checkTemplateHaskellOk :: TurnOnFlag -> DynP ()+checkTemplateHaskellOk _turn_on+  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })++{- **********************************************************************+%*                                                                      *+                DynFlags constructors+%*                                                                      *+%********************************************************************* -}++type DynP = EwM (CmdLineP DynFlags)++upd :: (DynFlags -> DynFlags) -> DynP ()+upd f = liftEwM (do dflags <- getCmdLineState+                    putCmdLineState $! f dflags)++updM :: (DynFlags -> DynP DynFlags) -> DynP ()+updM f = do dflags <- liftEwM getCmdLineState+            dflags' <- f dflags+            liftEwM $ putCmdLineState $! dflags'++--------------- Constructor functions for OptKind -----------------+noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+noArg fn = NoArg (upd fn)++noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+noArgM fn = NoArg (updM fn)++hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+hasArg fn = HasArg (upd . fn)++sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+sepArg fn = SepArg (upd . fn)++intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffix fn = IntSuffix (\n -> upd (fn n))++intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffixM fn = IntSuffix (\n -> updM (fn n))++wordSuffix :: (Word -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+wordSuffix fn = WordSuffix (\n -> upd (fn n))++floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+floatSuffix fn = FloatSuffix (\n -> upd (fn n))++optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)+              -> OptKind (CmdLineP DynFlags)+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))++setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)+setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)++--------------------------+addWayDynP :: Way -> DynP ()+addWayDynP = upd . addWay'++addWay' :: Way -> DynFlags -> DynFlags+addWay' w dflags0 =+   let platform = targetPlatform dflags0+       dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }+       dflags2 = foldr setGeneralFlag' dflags1+                       (wayGeneralFlags platform w)+       dflags3 = foldr unSetGeneralFlag' dflags2+                       (wayUnsetGeneralFlags platform w)+   in dflags3++removeWayDyn :: DynP ()+removeWayDyn = upd (\dfs -> dfs { targetWays_ = Set.filter (WayDyn /=) (targetWays_ dfs) })++--------------------------+setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()+setGeneralFlag   f = upd (setGeneralFlag' f)+unSetGeneralFlag f = upd (unSetGeneralFlag' f)++setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag'   d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedGFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setGeneralFlag recursively, in case the implied flags+        --     implies further flags++unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag' d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]+   -- In general, when you un-set f, we don't un-set the things it implies.+   -- There are however some exceptions, e.g., -fno-strictness implies+   -- -fno-worker-wrapper.+   --+   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags+   --     imply further flags.++--------------------------+setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()+setWarningFlag   f = upd (\dfs -> wopt_set dfs f)+unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)++setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()+setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)+unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)++setWErrorFlag :: WarningFlag -> DynP ()+setWErrorFlag flag =+  do { setWarningFlag flag+     ; setFatalWarningFlag flag }++--------------------------+setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()+setExtensionFlag f = upd (setExtensionFlag' f)+unSetExtensionFlag f = upd (unSetExtensionFlag' f)++setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags+setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps+  where+    deps = [ if turn_on then setExtensionFlag'   d+                        else unSetExtensionFlag' d+           | (f', turn_on, d) <- impliedXFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setExtensionFlag recursively, in case the implied flags+        --     implies further flags++unSetExtensionFlag' f dflags = xopt_unset dflags f+   -- When you un-set f, however, we don't un-set the things it implies+   --      (except for -fno-glasgow-exts, which is treated specially)++--------------------------+alterFileSettings :: (FileSettings -> FileSettings) -> DynFlags -> DynFlags+alterFileSettings f dynFlags = dynFlags { fileSettings = f (fileSettings dynFlags) }++alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags+alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }++--------------------------+setDumpFlag' :: DumpFlag -> DynP ()+setDumpFlag' dump_flag+  = do upd (\dfs -> dopt_set dfs dump_flag)+       when want_recomp forceRecompile+    where -- Certain dumpy-things are really interested in what's going+          -- on during recompilation checking, so in those cases we+          -- don't want to turn it off.+          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,+                                             Opt_D_dump_hi_diffs,+                                             Opt_D_no_debug_output]++forceRecompile :: DynP ()+-- Whenever we -ddump, force recompilation (by switching off the+-- recompilation checker), else you don't see the dump! However,+-- don't switch it off in --make mode, else *everything* gets+-- recompiled which probably isn't what you want+forceRecompile = do dfs <- liftEwM getCmdLineState+                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)+        where+          force_recomp dfs = isOneShot (ghcMode dfs)+++setVerboseCore2Core :: DynP ()+setVerboseCore2Core = setDumpFlag' Opt_D_verbose_core2core++setVerbosity :: Maybe Int -> DynP ()+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })++setDebugLevel :: Maybe Int -> DynP ()+setDebugLevel mb_n =+  upd (\dfs -> exposeSyms $ dfs{ debugLevel = n })+  where+    n = mb_n `orElse` 2+    exposeSyms+      | n > 2     = setGeneralFlag' Opt_ExposeInternalSymbols+      | otherwise = id++data PkgDbRef+  = GlobalPkgDb+  | UserPkgDb+  | PkgDbPath FilePath+  deriving Eq++addPkgDbRef :: PkgDbRef -> DynP ()+addPkgDbRef p = upd $ \s ->+  s { packageDBFlags = PackageDB p : packageDBFlags s }++removeUserPkgDb :: DynP ()+removeUserPkgDb = upd $ \s ->+  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }++removeGlobalPkgDb :: DynP ()+removeGlobalPkgDb = upd $ \s ->+ s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }++clearPkgDb :: DynP ()+clearPkgDb = upd $ \s ->+  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }++parsePackageFlag :: String                 -- the flag+                 -> ReadP PackageArg       -- type of argument+                 -> String                 -- string to parse+                 -> PackageFlag+parsePackageFlag flag arg_parse str+ = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)+  where doc = flag ++ " " ++ str+        parse = do+            pkg_arg <- tok arg_parse+            let mk_expose = ExposePackage doc pkg_arg+            ( do _ <- tok $ string "with"+                 fmap (mk_expose . ModRenaming True) parseRns+             <++ fmap (mk_expose . ModRenaming False) parseRns+             <++ return (mk_expose (ModRenaming True [])))+        parseRns = do _ <- tok $ R.char '('+                      rns <- tok $ sepBy parseItem (tok $ R.char ',')+                      _ <- tok $ R.char ')'+                      return rns+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (orig, new)+              ++++             return (orig, orig))+        tok m = m >>= \x -> skipSpaces >> return x++exposePackage, exposePackageId, hidePackage,+        exposePluginPackage, exposePluginPackageId,+        ignorePackage,+        trustPackage, distrustPackage :: String -> DynP ()+exposePackage p = upd (exposePackage' p)+exposePackageId p =+  upd (\s -> s{ packageFlags =+    parsePackageFlag "-package-id" parseUnitArg p : packageFlags s })+exposePluginPackage p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })+exposePluginPackageId p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s })+hidePackage p =+  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })+ignorePackage p =+  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })++trustPackage p = exposePackage p >> -- both trust and distrust also expose a package+  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })+distrustPackage p = exposePackage p >>+  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })++exposePackage' :: String -> DynFlags -> DynFlags+exposePackage' p dflags+    = dflags { packageFlags =+            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }++parsePackageArg :: ReadP PackageArg+parsePackageArg =+    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))++parseUnitArg :: ReadP PackageArg+parseUnitArg =+    fmap UnitIdArg parseUnit++setUnitId :: String -> DynFlags -> DynFlags+setUnitId p d = d { homeUnitId_ = stringToUnitId p }++-- If we're linking a binary, then only backends that produce object+-- code are allowed (requests for other target types are ignored).+setBackend :: Backend -> DynP ()+setBackend l = upd $ \ dfs ->+  if ghcLink dfs /= LinkBinary || backendProducesObject l+  then dfs{ backend = l }+  else dfs++-- Changes the target only if we're compiling object code.  This is+-- used by -fasm and -fllvm, which switch from one to the other, but+-- not from bytecode to object-code.  The idea is that -fasm/-fllvm+-- can be safely used in an OPTIONS_GHC pragma.+setObjBackend :: Backend -> DynP ()+setObjBackend l = updM set+  where+   set dflags+     | backendProducesObject (backend dflags)+       = return $ dflags { backend = l }+     | otherwise = return dflags++setOptLevel :: Int -> DynFlags -> DynP DynFlags+setOptLevel n dflags = return (updOptLevel n dflags)++checkOptLevel :: Int -> DynFlags -> Either String DynFlags+checkOptLevel n dflags+   | backend dflags == Interpreter && n > 0+     = Left "-O conflicts with --interactive; -O ignored."+   | otherwise+     = Right dflags++setCallerCcFilters :: String -> DynP ()+setCallerCcFilters arg =+  case parseCallerCcFilter arg of+    Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d }+    Left err -> addErr err++setMainIs :: String -> DynP ()+setMainIs arg+  | not (null main_fn) && isLower (head main_fn)+     -- The arg looked like "Foo.Bar.baz"+  = upd $ \d -> d { mainFunIs = Just main_fn,+                    mainModuleNameIs = mkModuleName main_mod }++  | isUpper (head arg)  -- The arg looked like "Foo" or "Foo.Bar"+  = upd $ \d -> d { mainModuleNameIs = mkModuleName arg }++  | otherwise                   -- The arg looked like "baz"+  = upd $ \d -> d { mainFunIs = Just arg }+  where+    (main_mod, main_fn) = splitLongestPrefix arg (== '.')++addLdInputs :: Option -> DynFlags -> DynFlags+addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}++-- -----------------------------------------------------------------------------+-- Load dynflags from environment files.++setFlagsFromEnvFile :: FilePath -> String -> DynP ()+setFlagsFromEnvFile envfile content = do+  setGeneralFlag Opt_HideAllPackages+  parseEnvFile envfile content++parseEnvFile :: FilePath -> String -> DynP ()+parseEnvFile envfile = mapM_ parseEntry . lines+  where+    parseEntry str = case words str of+      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))+        -- relative package dbs are interpreted relative to the env file+        where envdir = takeDirectory envfile+              db     = drop 11 str+      ["clear-package-db"]  -> clearPkgDb+      ["global-package-db"] -> addPkgDbRef GlobalPkgDb+      ["user-package-db"]   -> addPkgDbRef UserPkgDb+      ["package-id", pkgid] -> exposePackageId pkgid+      (('-':'-':_):_)       -> return () -- comments+      -- and the original syntax introduced in 7.10:+      [pkgid]               -> exposePackageId pkgid+      []                    -> return ()+      _                     -> throwGhcException $ CmdLineError $+                                    "Can't parse environment file entry: "+                                 ++ envfile ++ ": " ++ str+++-----------------------------------------------------------------------------+-- Paths & Libraries++addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()++-- -i on its own deletes the import paths+addImportPath "" = upd (\s -> s{importPaths = []})+addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})++addLibraryPath p =+  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})++addIncludePath p =+  upd (\s -> s{includePaths =+                  addGlobalInclude (includePaths s) (splitPathList p)})++addFrameworkPath p =+  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})++#if !defined(mingw32_HOST_OS)+split_marker :: Char+split_marker = ':'   -- not configurable (ToDo)+#endif++splitPathList :: String -> [String]+splitPathList s = filter notNull (splitUp s)+                -- empty paths are ignored: there might be a trailing+                -- ':' in the initial list, for example.  Empty paths can+                -- cause confusion when they are translated into -I options+                -- for passing to gcc.+  where+#if !defined(mingw32_HOST_OS)+    splitUp xs = split split_marker xs+#else+     -- Windows: 'hybrid' support for DOS-style paths in directory lists.+     --+     -- That is, if "foo:bar:baz" is used, this interpreted as+     -- consisting of three entries, 'foo', 'bar', 'baz'.+     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted+     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"+     --+     -- Notice that no attempt is made to fully replace the 'standard'+     -- split marker ':' with the Windows / DOS one, ';'. The reason being+     -- that this will cause too much breakage for users & ':' will+     -- work fine even with DOS paths, if you're not insisting on being silly.+     -- So, use either.+    splitUp []             = []+    splitUp (x:':':div:xs) | div `elem` dir_markers+                           = ((x:':':div:p): splitUp rs)+                           where+                              (p,rs) = findNextPath xs+          -- we used to check for existence of the path here, but that+          -- required the IO monad to be threaded through the command-line+          -- parser which is quite inconvenient.  The+    splitUp xs = cons p (splitUp rs)+               where+                 (p,rs) = findNextPath xs++                 cons "" xs = xs+                 cons x  xs = x:xs++    -- will be called either when we've consumed nought or the+    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of+    -- finding the next split marker.+    findNextPath xs =+        case break (`elem` split_markers) xs of+           (p, _:ds) -> (p, ds)+           (p, xs)   -> (p, xs)++    split_markers :: [Char]+    split_markers = [':', ';']++    dir_markers :: [Char]+    dir_markers = ['/', '\\']+#endif++-- -----------------------------------------------------------------------------+-- tmpDir, where we store temporary files.++setTmpDir :: FilePath -> DynFlags -> DynFlags+setTmpDir dir = alterFileSettings $ \s -> s { fileSettings_tmpDir = normalise dir }+  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't+  -- seem necessary now --SDM 7/2/2008++-----------------------------------------------------------------------------+-- RTS opts++setRtsOpts :: String -> DynP ()+setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}++setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()+setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}++-----------------------------------------------------------------------------+-- Hpc stuff++setOptHpcDir :: String -> DynP ()+setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}++-----------------------------------------------------------------------------+-- Via-C compilation stuff++-- There are some options that we need to pass to gcc when compiling+-- Haskell code via C, but are only supported by recent versions of+-- gcc.  The configure script decides which of these options we need,+-- and puts them in the "settings" file in $topdir. The advantage of+-- having these in a separate file is that the file can be created at+-- install-time depending on the available gcc version, and even+-- re-generated later if gcc is upgraded.+--+-- The options below are not dependent on the version of gcc, only the+-- platform.++picCCOpts :: DynFlags -> [String]+picCCOpts dflags = pieOpts ++ picOpts+  where+    picOpts =+      case platformOS (targetPlatform dflags) of+      OSDarwin+          -- Apple prefers to do things the other way round.+          -- PIC is on by default.+          -- -mdynamic-no-pic:+          --     Turn off PIC code generation.+          -- -fno-common:+          --     Don't generate "common" symbols - these are unwanted+          --     in dynamic libraries.++       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]+       | otherwise           -> ["-mdynamic-no-pic"]+      OSMinGW32 -- no -fPIC for Windows+       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]+       | otherwise           -> []+      _+      -- we need -fPIC for C files when we are compiling with -dynamic,+      -- otherwise things like stub.c files don't get compiled+      -- correctly.  They need to reference data in the Haskell+      -- objects, but can't without -fPIC.  See+      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code+       | gopt Opt_PIC dflags || WayDyn `Set.member` ways dflags ->+          ["-fPIC", "-U__PIC__", "-D__PIC__"]+      -- gcc may be configured to have PIC on by default, let's be+      -- explicit here, see #15847+       | otherwise -> ["-fno-PIC"]++    pieOpts+      | gopt Opt_PICExecutable dflags       = ["-pie"]+        -- See Note [No PIE when linking]+      | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]+      | otherwise                           = []+++{-+Note [No PIE while linking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by+default in their gcc builds. This is incompatible with -r as it implies that we+are producing an executable. Consequently, we must manually pass -no-pie to gcc+when joining object files or linking dynamic libraries. Unless, of course, the+user has explicitly requested a PIE executable with -pie. See #12759.+-}++picPOpts :: DynFlags -> [String]+picPOpts dflags+ | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]+ | otherwise           = []++-- -----------------------------------------------------------------------------+-- Compiler Info++compilerInfo :: DynFlags -> [(String, String)]+compilerInfo dflags+    = -- We always make "Project name" be first to keep parsing in+      -- other languages simple, i.e. when looking for other fields,+      -- you don't have to worry whether there is a leading '[' or not+      ("Project name",                 cProjectName)+      -- Next come the settings, so anything else can be overridden+      -- in the settings file (as "lookup" uses the first match for the+      -- key)+    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))+          (rawSettings dflags)+   ++ [("Project version",             projectVersion dflags),+       ("Project Git commit id",       cProjectGitCommitId),+       ("Booter version",              cBooterVersion),+       ("Stage",                       cStage),+       ("Build platform",              cBuildPlatformString),+       ("Host platform",               cHostPlatformString),+       ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),+       ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),+       ("Object splitting supported",  showBool False),+       ("Have native code generator",  showBool $ platformNcgSupported (targetPlatform dflags)),+       ("Target default backend",      show $ platformDefaultBackend (targetPlatform dflags)),+       -- Whether or not we support @-dynamic-too@+       ("Support dynamic-too",         showBool $ not isWindows),+       -- Whether or not we support the @-j@ flag with @--make@.+       ("Support parallel --make",     "YES"),+       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in+       -- installed package info.+       ("Support reexported-modules",  "YES"),+       -- Whether or not we support extended @-package foo (Foo)@ syntax.+       ("Support thinning and renaming package flags", "YES"),+       -- Whether or not we support Backpack.+       ("Support Backpack", "YES"),+       -- If true, we require that the 'id' field in installed package info+       -- match what is passed to the @-this-unit-id@ flag for modules+       -- built in it+       ("Requires unified installed package IDs", "YES"),+       -- Whether or not we support the @-this-package-key@ flag.  Prefer+       -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@+       -- flag has been removed, otherwise it breaks Cabal...+       ("Uses package keys",           "YES"),+       -- Whether or not we support the @-this-unit-id@ flag+       ("Uses unit IDs",               "YES"),+       -- Whether or not GHC was compiled using -dynamic+       ("GHC Dynamic",                 showBool hostIsDynamic),+       -- Whether or not GHC was compiled using -prof+       ("GHC Profiled",                showBool hostIsProfiled),+       ("Debug on",                    showBool debugIsOn),+       ("LibDir",                      topDir dflags),+       -- The path of the global package database used by GHC+       ("Global Package DB",           globalPackageDatabasePath dflags)+      ]+  where+    showBool True  = "YES"+    showBool False = "NO"+    platform  = targetPlatform dflags+    isWindows = platformOS platform == OSMinGW32+    expandDirectories :: FilePath -> Maybe FilePath -> String -> String+    expandDirectories topd mtoold = expandToolDir mtoold . expandTopDir topd+++wordAlignment :: Platform -> Alignment+wordAlignment platform = alignmentOf (platformWordSizeInBytes platform)++-- | Get target profile+targetProfile :: DynFlags -> Profile+targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)++{- -----------------------------------------------------------------------------+Note [DynFlags consistency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a number of number of DynFlags configurations which either+do not make sense or lead to unimplemented or buggy codepaths in the+compiler. makeDynFlagsConsistent is responsible for verifying the validity+of a set of DynFlags, fixing any issues, and reporting them back to the+caller.++GHCi and -O+---------------++When using optimization, the compiler can introduce several things+(such as unboxed tuples) into the intermediate code, which GHCi later+chokes on since the bytecode interpreter can't handle this (and while+this is arguably a bug these aren't handled, there are no plans to fix+it.)++While the driver pipeline always checks for this particular erroneous+combination when parsing flags, we also need to check when we update+the flags; this is because API clients may parse flags but update the+DynFlags afterwords, before finally running code inside a session (see+T10052 and #10052).+-}++-- | Resolve any internal inconsistencies in a set of 'DynFlags'.+-- Returns the consistent 'DynFlags' as well as a list of warnings+-- to report to the user.+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Located String])+-- Whenever makeDynFlagsConsistent does anything, it starts over, to+-- ensure that a later change doesn't invalidate an earlier check.+-- Be careful not to introduce potential loops!+makeDynFlagsConsistent dflags+ -- Disable -dynamic-too on Windows (#8228, #7134, #5987)+ | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn    = "-dynamic-too is not supported on Windows"+      in loop dflags' warn++   -- Via-C backend only supports unregisterised ABI. Switch to a backend+   -- supporting it if possible.+ | backend dflags == ViaC &&+   not (platformUnregisterised (targetPlatform dflags))+    = case platformDefaultBackend (targetPlatform dflags) of+         NCG ->  let dflags' = dflags { backend = NCG }+                     warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C"+                 in loop dflags' warn+         LLVM -> let dflags' = dflags { backend = LLVM }+                     warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C"+                 in loop dflags' warn+         _    -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it."++ | gopt Opt_Hpc dflags && backend dflags == Interpreter+    = let dflags' = gopt_unset dflags Opt_Hpc+          warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc."+      in loop dflags' warn++ | backend dflags `elem` [NCG, LLVM] &&+   platformUnregisterised (targetPlatform dflags)+    = loop (dflags { backend = ViaC })+           "Target platform uses unregisterised ABI, so compiling via C"++ | backend dflags == NCG &&+   not (platformNcgSupported $ targetPlatform dflags)+      = let dflags' = dflags { backend = LLVM }+            warn = "Native code generator doesn't support target platform, so using LLVM"+        in loop dflags' warn++ | not (osElfTarget os) && gopt Opt_PIE dflags+    = loop (gopt_unset dflags Opt_PIE)+           "Position-independent only supported on ELF platforms"+ | os == OSDarwin &&+   arch == ArchX86_64 &&+   not (gopt Opt_PIC dflags)+    = loop (gopt_set dflags Opt_PIC)+           "Enabling -fPIC as it is always on for this platform"+ | Left err <- checkOptLevel (optLevel dflags) dflags+    = loop (updOptLevel 0 dflags) err++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , backendProducesObject (backend dflags)+ , WayProf `Set.notMember` ways dflags+    = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}+         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"++ | otherwise = (dflags, [])+    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")+          loop updated_dflags warning+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws) -> (dflags', L loc warning : ws)+          platform = targetPlatform dflags+          arch = platformArch platform+          os   = platformOS   platform+++setUnsafeGlobalDynFlags :: DynFlags -> IO ()+setUnsafeGlobalDynFlags dflags = do+   writeIORef v_unsafeHasPprDebug (hasPprDebug dflags)+   writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags)+   writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags)+++-- -----------------------------------------------------------------------------+-- SSE and AVX++-- TODO: Instead of using a separate predicate (i.e. isSse2Enabled) to+-- check if SSE is enabled, we might have x86-64 imply the -msse2+-- flag.++isSseEnabled :: Platform -> Bool+isSseEnabled platform = case platformArch platform of+    ArchX86_64 -> True+    ArchX86    -> True+    _          -> False++isSse2Enabled :: Platform -> Bool+isSse2Enabled platform = case platformArch platform of+  -- We assume  SSE1 and SSE2 operations are available on both+  -- x86 and x86_64. Historically we didn't default to SSE2 and+  -- SSE1 on x86, which results in defacto nondeterminism for how+  -- rounding behaves in the associated x87 floating point instructions+  -- because variations in the spill/fpu stack placement of arguments for+  -- operations would change the precision and final result of what+  -- would otherwise be the same expressions with respect to single or+  -- double precision IEEE floating point computations.+    ArchX86_64 -> True+    ArchX86    -> True+    _          -> False+++isSse4_2Enabled :: DynFlags -> Bool+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42++isAvxEnabled :: DynFlags -> Bool+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags++isAvx2Enabled :: DynFlags -> Bool+isAvx2Enabled dflags = avx2 dflags || avx512f dflags++isAvx512cdEnabled :: DynFlags -> Bool+isAvx512cdEnabled dflags = avx512cd dflags++isAvx512erEnabled :: DynFlags -> Bool+isAvx512erEnabled dflags = avx512er dflags++isAvx512fEnabled :: DynFlags -> Bool+isAvx512fEnabled dflags = avx512f dflags++isAvx512pfEnabled :: DynFlags -> Bool+isAvx512pfEnabled dflags = avx512pf dflags++-- -----------------------------------------------------------------------------+-- BMI2++isBmiEnabled :: DynFlags -> Bool+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI1+    ArchX86    -> bmiVersion dflags >= Just BMI1+    _          -> False++isBmi2Enabled :: DynFlags -> Bool+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI2+    ArchX86    -> bmiVersion dflags >= Just BMI2+    _          -> False++-- | Indicate if cost-centre profiling is enabled+sccProfilingEnabled :: DynFlags -> Bool+sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)++-- -----------------------------------------------------------------------------+-- Linker/compiler information++-- LinkerInfo contains any extra options needed by the system linker.+data LinkerInfo+  = GnuLD    [Option]+  | GnuGold  [Option]+  | LlvmLLD  [Option]+  | DarwinLD [Option]+  | SolarisLD [Option]+  | AixLD    [Option]+  | UnknownLD+  deriving Eq++-- CompilerInfo tells us which C compiler we're using+data CompilerInfo+   = GCC+   | Clang+   | AppleClang+   | AppleClang51+   | UnknownCC+   deriving Eq+++-- | Should we use `-XLinker -rpath` when linking or not?+-- See Note [-fno-use-rpaths]+useXLinkerRPath :: DynFlags -> OS -> Bool+useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS]+useXLinkerRPath dflags _ = gopt Opt_RPath dflags++{-+Note [-fno-use-rpaths]+~~~~~~~~~~~~~~~~~~~~~~++First read, Note [Dynamic linking on macOS] to understand why on darwin we never+use `-XLinker -rpath`.++The specification of `Opt_RPath` is as follows:++The default case `-fuse-rpaths`:+* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath+  afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin+  as things stand but it wasn't documented in the user guide before this patch how+  `-fuse-rpaths` should behave and the fact it was always disabled on darwin.+* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable,+  this is the normal way you should set the rpath.++The case of `-fno-use-rpaths`+* Never inject anything into the rpath.++When this was first implemented, `Opt_RPath` was disabled on darwin, but+the rpath was still always augmented by `runInjectRPaths`, and there was no way to+stop this. This was problematic because you couldn't build an executable in CI+with a clean rpath.++-}++-- -----------------------------------------------------------------------------+-- RTS hooks++-- Convert sizes like "3.5M" into integers+decodeSize :: String -> Integer+decodeSize str+  | c == ""      = truncate n+  | c == "K" || c == "k" = truncate (n * 1000)+  | c == "M" || c == "m" = truncate (n * 1000 * 1000)+  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)+  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))+  where (m, c) = span pred str+        n      = readRational m+        pred c = isDigit c || c == '.'++foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()+foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()+++-- | Initialize the pretty-printing options+initSDocContext :: DynFlags -> PprStyle -> SDocContext+initSDocContext dflags style = SDC+  { sdocStyle                       = style+  , sdocColScheme                   = colScheme dflags+  , sdocLastColour                  = Col.colReset+  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)+  , sdocDefaultDepth                = pprUserLength dflags+  , sdocLineLength                  = pprCols dflags+  , sdocCanUseUnicode               = useUnicode dflags+  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags+  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags+  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags+  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags+  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags+  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags+  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags+  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags+  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags+  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags+  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags+  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags+  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags+  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags+  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags+  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags+  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags+  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags+  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags+  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags+  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags+  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags+  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags+  , sdocStarIsType                  = xopt LangExt.StarIsType dflags+  , sdocImpredicativeTypes          = xopt LangExt.ImpredicativeTypes dflags+  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags+  , sdocPrintTypeAbbreviations      = True+  , sdocUnitIdForUser               = ftext+  }++-- | Initialize the pretty-printing options using the default user style+initDefaultSDocContext :: DynFlags -> SDocContext+initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle++outputFile :: DynFlags -> Maybe String+outputFile dflags+   | dynamicNow dflags = dynOutputFile_ dflags+   | otherwise         = outputFile_    dflags++hiSuf :: DynFlags -> String+hiSuf dflags+   | dynamicNow dflags = dynHiSuf_ dflags+   | otherwise         = hiSuf_    dflags++objectSuf :: DynFlags -> String+objectSuf dflags+   | dynamicNow dflags = dynObjectSuf_ dflags+   | otherwise         = objectSuf_    dflags++ways :: DynFlags -> Ways+ways dflags+   | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)+   | otherwise         = targetWays_ dflags++-- | Pretty-print the difference between 2 DynFlags.+--+-- For now only their general flags but it could be extended.+-- Useful mostly for debugging.+pprDynFlagsDiff :: DynFlags -> DynFlags -> SDoc+pprDynFlagsDiff d1 d2 =+   let gf_removed  = EnumSet.difference (generalFlags d1) (generalFlags d2)+       gf_added    = EnumSet.difference (generalFlags d2) (generalFlags d1)+       ext_removed = EnumSet.difference (extensionFlags d1) (extensionFlags d2)+       ext_added   = EnumSet.difference (extensionFlags d2) (extensionFlags d1)+   in vcat+      [ text "Added general flags:"+      , text $ show $ EnumSet.toList $ gf_added+      , text "Removed general flags:"+      , text $ show $ EnumSet.toList $ gf_removed+      , text "Added extension flags:"+      , text $ show $ EnumSet.toList $ ext_added+      , text "Removed extension flags:"+      , text $ show $ EnumSet.toList $ ext_removed+      ]++updatePlatformConstants :: DynFlags -> Maybe PlatformConstants -> IO DynFlags+updatePlatformConstants dflags mconstants = do+  let platform1 = (targetPlatform dflags) { platform_constants = mconstants }+  let dflags1   = dflags { targetPlatform = platform1 }+  return dflags1

GHC/Driver/Session.hs-boot view

@@ -3,13 +3,10 @@ import GHC.Prelude import GHC.Platform import {-# SOURCE #-} GHC.Utils.Outputable-import {-# SOURCE #-} GHC.Unit.State  data DynFlags  targetPlatform           :: DynFlags -> Platform-unitState                :: DynFlags -> UnitState-unsafeGlobalDynFlags     :: DynFlags hasPprDebug              :: DynFlags -> Bool hasNoDebugOutput         :: DynFlags -> Bool initSDocContext          :: DynFlags -> PprStyle -> SDocContext

− GHC/Driver/Types.hs

@@ -1,3407 +0,0 @@-{--(c) The University of Glasgow, 2006--\section[GHC.Driver.Types]{Types for the per-module compiler}--}--{-# LANGUAGE CPP, ScopedTypeVariables #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DataKinds #-}---- | Types for the per-module compiler-module GHC.Driver.Types (-        -- * compilation state-        HscEnv(..), hscEPS,-        FinderCache, FindResult(..), InstalledFindResult(..),-        Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,-        HscStatus(..),--        -- * ModuleGraph-        ModuleGraph, emptyMG, mkModuleGraph, extendMG, mapMG,-        mgModSummaries, mgElemModule, mgLookupModule,-        needsTemplateHaskellOrQQ, mgBootModules,--        -- * Hsc monad-        Hsc(..), runHsc, mkInteractiveHscEnv, runInteractiveHsc,--        -- * Information about modules-        ModDetails(..), emptyModDetails,-        ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,-        ImportedMods, ImportedBy(..), importedByUser, ImportedModsVal(..), SptEntry(..),-        ForeignSrcLang(..),-        phaseForeignLanguage,--        ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, ms_home_imps,-        home_imps, ms_home_allimps, ms_home_srcimps, showModMsg, isBootSummary,-        msHsFilePath, msHiFilePath, msObjFilePath,-        SourceModified(..), isTemplateHaskellOrQQNonBoot,--        -- * Information about the module being compiled-        -- (re-exported from GHC.Driver.Phases)-        HscSource(..), isHsBootOrSig, isHsigFile, hscSourceString,---        -- * State relating to modules in this package-        HomePackageTable, HomeModInfo(..), emptyHomePackageTable,-        lookupHpt, eltsHpt, filterHpt, allHpt, anyHpt, mapHpt, delFromHpt,-        addToHpt, addListToHpt, lookupHptDirectly, listToHpt,-        hptCompleteSigs,-        hptInstances, hptRules, pprHPT,--        -- * State relating to known packages-        ExternalPackageState(..), EpsStats(..), addEpsInStats,-        PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,-        lookupIfaceByModule, emptyPartialModIface, emptyFullModIface, lookupHptByModule,--        PackageInstEnv, PackageFamInstEnv, PackageRuleBase,-        PackageCompleteMatchMap,--        mkSOName, mkHsSOName, soExt,--        -- * Metaprogramming-        MetaRequest(..),-        MetaResult, -- data constructors not exported to ensure correct response type-        metaRequestE, metaRequestP, metaRequestT, metaRequestD, metaRequestAW,-        MetaHook,--        -- * Annotations-        prepareAnnotations,--        -- * Interactive context-        InteractiveContext(..), emptyInteractiveContext,-        icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,-        extendInteractiveContext, extendInteractiveContextWithIds,-        substInteractiveContext,-        setInteractivePrintName, icInteractiveModule,-        InteractiveImport(..), setInteractivePackage,-        mkPrintUnqualified, pprModulePrefix,-        mkQualPackage, mkQualModule, pkgQual,--        -- * Interfaces-        ModIface, PartialModIface, ModIface_(..), ModIfaceBackend(..),-        mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,-        emptyIfaceWarnCache, mi_boot, mi_fix,-        mi_semantic_module,-        mi_free_holes,-        renameFreeHoles,--        -- * Fixity-        FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,--        -- * TyThings and type environments-        TyThing(..),  tyThingAvailInfo,-        tyThingTyCon, tyThingDataCon, tyThingConLike,-        tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyCoVars,-        implicitTyThings, implicitTyConThings, implicitClassThings,-        isImplicitTyThing,--        TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,-        typeEnvFromEntities, mkTypeEnvWithImplicits,-        extendTypeEnv, extendTypeEnvList,-        extendTypeEnvWithIds, plusTypeEnv,-        lookupTypeEnv,-        typeEnvElts, typeEnvTyCons, typeEnvIds, typeEnvPatSyns,-        typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,--        -- * MonadThings-        MonadThings(..),--        -- * Information on imports and exports-        WhetherHasOrphans, IsBootInterface(..), Usage(..),-        Dependencies(..), noDependencies,-        updNameCache,-        IfaceExport,--        -- * Warnings-        Warnings(..), WarningTxt(..), plusWarns,--        -- * Linker stuff-        Linkable(..), isObjectLinkable, linkableObjs,-        Unlinked(..), CompiledByteCode,-        isObject, nameOfObject, isInterpretable, byteCodeOfObject,--        -- * Program coverage-        HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,--        -- * Breakpoints-        ModBreaks (..), emptyModBreaks,--        -- * Safe Haskell information-        IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,-        trustInfoToNum, numToTrustInfo, IsSafeImport,--        -- * result of the parser-        HsParsedModule(..),--        -- * Compilation errors and warnings-        SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,-        throwOneError, throwErrors, handleSourceError,-        handleFlagWarnings, printOrThrowWarnings,--        -- * COMPLETE signature-        CompleteMatch(..), CompleteMatchMap,-        mkCompleteMatchMap, extendCompleteMatchMap,--        -- * Exstensible Iface fields-        ExtensibleFields(..), FieldName,-        emptyExtensibleFields,-        readField, readIfaceField, readIfaceFieldWith,-        writeField, writeIfaceField, writeIfaceFieldWith,-        deleteField, deleteIfaceField,-    ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.ByteCode.Types-import GHC.Runtime.Eval.Types ( Resume )-import GHC.Runtime.Interpreter.Types (Interp)-import GHC.ForeignSrcLang--import GHC.Types.Unique.FM-import GHC.Hs-import GHC.Types.Name.Reader-import GHC.Types.Avail-import GHC.Unit-import GHC.Core.InstEnv ( InstEnv, ClsInst, identicalClsInstHead )-import GHC.Core.FamInstEnv-import GHC.Core         ( CoreProgram, RuleBase, CoreRule )-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Var.Set-import GHC.Types.Var-import GHC.Types.Id-import GHC.Types.Id.Info ( IdDetails(..), RecSelParent(..))-import GHC.Core.Type--import GHC.Parser.Annotation    ( ApiAnns )-import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Core.Coercion.Axiom-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.PatSyn-import GHC.Builtin.Names ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )-import GHC.Builtin.Types-import GHC.Driver.CmdLine-import GHC.Driver.Session-import GHC.Runtime.Linker.Types ( DynLinker, Linkable(..), Unlinked(..), SptEntry(..) )-import GHC.Driver.Phases-   ( Phase, HscSource(..), hscSourceString-   , isHsBootOrSig, isHsigFile )-import qualified GHC.Driver.Phases as Phase-import GHC.Types.Basic-import GHC.Iface.Syntax-import GHC.Data.Maybe-import GHC.Utils.Outputable-import GHC.Types.SrcLoc-import GHC.Types.Unique-import GHC.Types.Unique.DFM-import GHC.Data.FastString-import GHC.Data.StringBuffer ( StringBuffer )-import GHC.Utils.Fingerprint-import GHC.Utils.Monad-import GHC.Data.Bag-import GHC.Utils.Binary-import GHC.Utils.Error-import GHC.Types.Name.Cache-import GHC.Platform-import GHC.Utils.Misc-import GHC.Types.Unique.DSet-import GHC.Serialized   ( Serialized )-import qualified GHC.LanguageExtensions as LangExt--import Foreign-import Control.Monad    ( guard, liftM, ap, forM, forM_, replicateM )-import Data.IORef-import Data.Map         ( Map )-import qualified Data.Map as Map-import Data.Time-import GHC.Utils.Exception-import System.FilePath-import Control.DeepSeq-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class-import Control.Monad.Catch as MC (MonadCatch, catch)---- -------------------------------------------------------------------------------- Compilation state--- --------------------------------------------------------------------------------- | Status of a compilation to hard-code-data HscStatus-    -- | Nothing to do.-    = HscNotGeneratingCode ModIface ModDetails-    -- | Nothing to do because code already exists.-    | HscUpToDate ModIface ModDetails-    -- | Update boot file result.-    | HscUpdateBoot ModIface ModDetails-    -- | Generate signature file (backpack)-    | HscUpdateSig ModIface ModDetails-    -- | Recompile this module.-    | HscRecomp-        { hscs_guts       :: CgGuts-          -- ^ Information for the code generator.-        , hscs_mod_location :: !ModLocation-          -- ^ Module info-        , hscs_partial_iface  :: !PartialModIface-          -- ^ Partial interface-        , hscs_old_iface_hash :: !(Maybe Fingerprint)-          -- ^ Old interface hash for this compilation, if an old interface file-          -- exists. Pass to `hscMaybeWriteIface` when writing the interface to-          -- avoid updating the existing interface when the interface isn't-          -- changed.-        , hscs_iface_dflags :: !DynFlags-          -- ^ Generate final iface using this DynFlags.-          -- FIXME (osa): I don't understand why this is necessary, but I spent-          -- almost two days trying to figure this out and I couldn't .. perhaps-          -- someone who understands this code better will remove this later.-        }--- Should HscStatus contain the HomeModInfo?--- All places where we return a status we also return a HomeModInfo.---- -------------------------------------------------------------------------------- The Hsc monad: Passing an environment and warning state--newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))-    deriving (Functor)--instance Applicative Hsc where-    pure a = Hsc $ \_ w -> return (a, w)-    (<*>) = ap--instance Monad Hsc where-    Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w-                                   case k a of-                                       Hsc k' -> k' e w1--instance MonadIO Hsc where-    liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)--instance HasDynFlags Hsc where-    getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)--runHsc :: HscEnv -> Hsc a -> IO a-runHsc hsc_env (Hsc hsc) = do-    (a, w) <- hsc hsc_env emptyBag-    printOrThrowWarnings (hsc_dflags hsc_env) w-    return a--mkInteractiveHscEnv :: HscEnv -> HscEnv-mkInteractiveHscEnv hsc_env = hsc_env{ hsc_dflags = interactive_dflags }-  where-    interactive_dflags = ic_dflags (hsc_IC hsc_env)--runInteractiveHsc :: HscEnv -> Hsc a -> IO a--- A variant of runHsc that switches in the DynFlags from the--- InteractiveContext before running the Hsc computation.-runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)---- -------------------------------------------------------------------------------- Source Errors---- When the compiler (GHC.Driver.Main) discovers errors, it throws an--- exception in the IO monad.--mkSrcErr :: ErrorMessages -> SourceError-mkSrcErr = SourceError--srcErrorMessages :: SourceError -> ErrorMessages-srcErrorMessages (SourceError msgs) = msgs--mkApiErr :: DynFlags -> SDoc -> GhcApiError-mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)--throwErrors :: MonadIO io => ErrorMessages -> io a-throwErrors = liftIO . throwIO . mkSrcErr--throwOneError :: MonadIO io => ErrMsg -> io a-throwOneError = throwErrors . unitBag---- | A source error is an error that is caused by one or more errors in the--- source code.  A 'SourceError' is thrown by many functions in the--- compilation pipeline.  Inside GHC these errors are merely printed via--- 'log_action', but API clients may treat them differently, for example,--- insert them into a list box.  If you want the default behaviour, use the--- idiom:------ > handleSourceError printExceptionAndWarnings $ do--- >   ... api calls that may fail ...------ The 'SourceError's error messages can be accessed via 'srcErrorMessages'.--- This list may be empty if the compiler failed due to @-Werror@--- ('Opt_WarnIsError').------ See 'printExceptionAndWarnings' for more information on what to take care--- of when writing a custom error handler.-newtype SourceError = SourceError ErrorMessages--instance Show SourceError where-  show (SourceError msgs) = unlines . map show . bagToList $ msgs--instance Exception SourceError---- | Perform the given action and call the exception handler if the action--- throws a 'SourceError'.  See 'SourceError' for more information.-handleSourceError :: (MonadCatch m) =>-                     (SourceError -> m a) -- ^ exception handler-                  -> m a -- ^ action to perform-                  -> m a-handleSourceError handler act =-  MC.catch act (\(e :: SourceError) -> handler e)---- | An error thrown if the GHC API is used in an incorrect fashion.-newtype GhcApiError = GhcApiError String--instance Show GhcApiError where-  show (GhcApiError msg) = msg--instance Exception GhcApiError---- | Given a bag of warnings, turn them into an exception if--- -Werror is enabled, or print them out otherwise.-printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()-printOrThrowWarnings dflags warns = do-  let (make_error, warns') =-        mapAccumBagL-          (\make_err warn ->-            case isWarnMsgFatal dflags warn of-              Nothing ->-                (make_err, warn)-              Just err_reason ->-                (True, warn{ errMsgSeverity = SevError-                           , errMsgReason = ErrReason err_reason-                           }))-          False warns-  if make_error-    then throwIO (mkSrcErr warns')-    else printBagOfErrors dflags warns--handleFlagWarnings :: DynFlags -> [Warn] -> IO ()-handleFlagWarnings dflags warns = do-  let warns' = filter (shouldPrintWarning dflags . warnReason)  warns--      -- It would be nicer if warns :: [Located MsgDoc], but that-      -- has circular import problems.-      bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)-                      | Warn _ (L loc warn) <- warns' ]--  printOrThrowWarnings dflags bag---- Given a warn reason, check to see if it's associated -W opt is enabled-shouldPrintWarning :: DynFlags -> GHC.Driver.CmdLine.WarnReason -> Bool-shouldPrintWarning dflags ReasonDeprecatedFlag-  = wopt Opt_WarnDeprecatedFlags dflags-shouldPrintWarning dflags ReasonUnrecognisedFlag-  = wopt Opt_WarnUnrecognisedWarningFlags dflags-shouldPrintWarning _ _-  = True--{--************************************************************************-*                                                                      *-\subsection{HscEnv}-*                                                                      *-************************************************************************--}---- | HscEnv is like 'Session', except that some of the fields are immutable.--- An HscEnv is used to compile a single module from plain Haskell source--- code (after preprocessing) to either C, assembly or C--. It's also used--- to store the dynamic linker state to allow for multiple linkers in the--- same address space.--- Things like the module graph don't change during a single compilation.------ Historical note: \"hsc\" used to be the name of the compiler binary,--- when there was a separate driver and compiler.  To compile a single--- module, the driver would invoke hsc on the source code... so nowadays--- we think of hsc as the layer of the compiler that deals with compiling--- a single module.-data HscEnv-  = HscEnv {-        hsc_dflags :: DynFlags,-                -- ^ The dynamic flag settings--        hsc_targets :: [Target],-                -- ^ The targets (or roots) of the current session--        hsc_mod_graph :: ModuleGraph,-                -- ^ The module graph of the current session--        hsc_IC :: InteractiveContext,-                -- ^ The context for evaluating interactive statements--        hsc_HPT    :: HomePackageTable,-                -- ^ The home package table describes already-compiled-                -- home-package modules, /excluding/ the module we-                -- are compiling right now.-                -- (In one-shot mode the current module is the only-                -- home-package module, so hsc_HPT is empty.  All other-                -- modules count as \"external-package\" modules.-                -- However, even in GHCi mode, hi-boot interfaces are-                -- demand-loaded into the external-package table.)-                ---                -- 'hsc_HPT' is not mutable because we only demand-load-                -- external packages; the home package is eagerly-                -- loaded, module by module, by the compilation manager.-                ---                -- The HPT may contain modules compiled earlier by @--make@-                -- but not actually below the current module in the dependency-                -- graph.-                ---                -- (This changes a previous invariant: changed Jan 05.)--        hsc_EPS :: {-# UNPACK #-} !(IORef ExternalPackageState),-                -- ^ Information about the currently loaded external packages.-                -- This is mutable because packages will be demand-loaded during-                -- a compilation run as required.--        hsc_NC  :: {-# UNPACK #-} !(IORef NameCache),-                -- ^ As with 'hsc_EPS', this is side-effected by compiling to-                -- reflect sucking in interface files.  They cache the state of-                -- external interface files, in effect.--        hsc_FC   :: {-# UNPACK #-} !(IORef FinderCache),-                -- ^ The cached result of performing finding in the file system--        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)-                -- ^ Used for one-shot compilation only, to initialise-                -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for-                -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]--        , hsc_interp :: Maybe Interp-                -- ^ target code interpreter (if any) to use for TH and GHCi.-                -- See Note [Target code interpreter]--        , hsc_dynLinker :: DynLinker-                -- ^ dynamic linker.-- }--{---Note [Target code interpreter]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Template Haskell and GHCi use an interpreter to execute code that is built for-the compiler target platform (= code host platform) on the compiler host-platform (= code build platform).--The internal interpreter can be used when both platforms are the same and when-the built code is compatible with the compiler itself (same way, etc.). This-interpreter is not always available: for instance stage1 compiler doesn't have-it because there might be an ABI mismatch between the code objects (built by-stage1 compiler) and the stage1 compiler itself (built by stage0 compiler).--In most cases, an external interpreter can be used instead: it runs in a-separate process and it communicates with the compiler via a two-way message-passing channel. The process is lazily spawned to avoid overhead when it is not-used.--The target code interpreter to use can be selected per session via the-`hsc_interp` field of `HscEnv`. There may be no interpreter available at all, in-which case Template Haskell and GHCi will fail to run. The interpreter to use is-configured via command-line flags (in `GHC.setSessionDynFlags`).----}---- Note [hsc_type_env_var hack]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- hsc_type_env_var is used to initialize tcg_type_env_var, and--- eventually it is the mutable variable that is queried from--- if_rec_types to get a TypeEnv.  So, clearly, it's something--- related to knot-tying (see Note [Tying the knot]).--- hsc_type_env_var is used in two places: initTcRn (where--- it initializes tcg_type_env_var) and initIfaceCheck--- (where it initializes if_rec_types).------ But why do we need a way to feed a mutable variable in?  Why--- can't we just initialize tcg_type_env_var when we start--- typechecking?  The problem is we need to knot-tie the--- EPS, and we may start adding things to the EPS before type--- checking starts.------ Here is a concrete example. Suppose we are running--- "ghc -c A.hs", and we have this file system state:------  A.hs-boot   A.hi-boot **up to date**---  B.hs        B.hi      **up to date**---  A.hs        A.hi      **stale**------ The first thing we do is run checkOldIface on A.hi.--- checkOldIface will call loadInterface on B.hi so it can--- get its hands on the fingerprints, to find out if A.hi--- needs recompilation.  But loadInterface also populates--- the EPS!  And so if compilation turns out to be necessary,--- as it is in this case, the thunks we put into the EPS for--- B.hi need to have the correct if_rec_types mutable variable--- to query.------ If the mutable variable is only allocated WHEN we start--- typechecking, then that's too late: we can't get the--- information to the thunks.  So we need to pre-commit--- to a type variable in 'hscIncrementalCompile' BEFORE we--- check the old interface.------ This is all a massive hack because arguably checkOldIface--- should not populate the EPS. But that's a refactor for--- another day.---- | Retrieve the ExternalPackageState cache.-hscEPS :: HscEnv -> IO ExternalPackageState-hscEPS hsc_env = readIORef (hsc_EPS hsc_env)---- | A compilation target.------ A target may be supplied with the actual text of the--- module.  If so, use this instead of the file contents (this--- is for use in an IDE where the file hasn't been saved by--- the user yet).-data Target-  = Target {-      targetId           :: !TargetId, -- ^ module or filename-      targetAllowObjCode :: !Bool,     -- ^ object code allowed?-      targetContents     :: !(Maybe (InputFileBuffer, UTCTime))-      -- ^ Optional in-memory buffer containing the source code GHC should-      -- use for this target instead of reading it from disk.-      ---      -- Since GHC version 8.10 modules which require preprocessors such as-      -- Literate Haskell or CPP to run are also supported.-      ---      -- If a corresponding source file does not exist on disk this will-      -- result in a 'SourceError' exception if @targetId = TargetModule _@-      -- is used. However together with @targetId = TargetFile _@ GHC will-      -- not complain about the file missing.-    }--data TargetId-  = TargetModule ModuleName-        -- ^ A module name: search for the file-  | TargetFile FilePath (Maybe Phase)-        -- ^ A filename: preprocess & parse it to find the module name.-        -- If specified, the Phase indicates how to compile this file-        -- (which phase to start from).  Nothing indicates the starting phase-        -- should be determined from the suffix of the filename.-  deriving Eq--type InputFileBuffer = StringBuffer--pprTarget :: Target -> SDoc-pprTarget (Target id obj _) =-    (if obj then char '*' else empty) <> pprTargetId id--instance Outputable Target where-    ppr = pprTarget--pprTargetId :: TargetId -> SDoc-pprTargetId (TargetModule m) = ppr m-pprTargetId (TargetFile f _) = text f--instance Outputable TargetId where-    ppr = pprTargetId--{--************************************************************************-*                                                                      *-\subsection{Package and Module Tables}-*                                                                      *-************************************************************************--}---- | Helps us find information about modules in the home package-type HomePackageTable  = DModuleNameEnv HomeModInfo-        -- Domain = modules in the home package that have been fully compiled-        -- "home" unit id cached here for convenience---- | Helps us find information about modules in the imported packages-type PackageIfaceTable = ModuleEnv ModIface-        -- Domain = modules in the imported packages---- | Constructs an empty HomePackageTable-emptyHomePackageTable :: HomePackageTable-emptyHomePackageTable  = emptyUDFM---- | Constructs an empty PackageIfaceTable-emptyPackageIfaceTable :: PackageIfaceTable-emptyPackageIfaceTable = emptyModuleEnv--pprHPT :: HomePackageTable -> SDoc--- A bit arbitrary for now-pprHPT hpt = pprUDFM hpt $ \hms ->-    vcat [ hang (ppr (mi_module (hm_iface hm)))-              2 (ppr (md_types (hm_details hm)))-         | hm <- hms ]--lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo-lookupHpt = lookupUDFM--lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo-lookupHptDirectly = lookupUDFM_Directly--eltsHpt :: HomePackageTable -> [HomeModInfo]-eltsHpt = eltsUDFM--filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable-filterHpt = filterUDFM--allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool-allHpt = allUDFM--anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool-anyHpt = anyUDFM--mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable-mapHpt = mapUDFM--delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable-delFromHpt = delFromUDFM--addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable-addToHpt = addToUDFM--addListToHpt-  :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable-addListToHpt = addListToUDFM--listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable-listToHpt = listToUDFM--lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo--- The HPT is indexed by ModuleName, not Module,--- we must check for a hit on the right Module-lookupHptByModule hpt mod-  = case lookupHpt hpt (moduleName mod) of-      Just hm | mi_module (hm_iface hm) == mod -> Just hm-      _otherwise                               -> Nothing---- | Information about modules in the package being compiled-data HomeModInfo-  = HomeModInfo {-      hm_iface    :: !ModIface,-        -- ^ The basic loaded interface file: every loaded module has one of-        -- these, even if it is imported from another package-      hm_details  :: !ModDetails,-        -- ^ Extra information that has been created from the 'ModIface' for-        -- the module, typically during typechecking-      hm_linkable :: !(Maybe Linkable)-        -- ^ The actual artifact we would like to link to access things in-        -- this module.-        ---        -- 'hm_linkable' might be Nothing:-        ---        --   1. If this is an .hs-boot module-        ---        --   2. Temporarily during compilation if we pruned away-        --      the old linkable because it was out of date.-        ---        -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields-        -- in the 'HomePackageTable' will be @Just@.-        ---        -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the-        -- 'HomeModInfo' by building a new 'ModDetails' from the old-        -- 'ModIface' (only).-    }---- | Find the 'ModIface' for a 'Module', searching in both the loaded home--- and external package module information-lookupIfaceByModule-        :: HomePackageTable-        -> PackageIfaceTable-        -> Module-        -> Maybe ModIface-lookupIfaceByModule hpt pit mod-  = case lookupHptByModule hpt mod of-       Just hm -> Just (hm_iface hm)-       Nothing -> lookupModuleEnv pit mod---- If the module does come from the home package, why do we look in the PIT as well?--- (a) In OneShot mode, even home-package modules accumulate in the PIT--- (b) Even in Batch (--make) mode, there is *one* case where a home-package---     module is in the PIT, namely GHC.Prim when compiling the base package.--- We could eliminate (b) if we wanted, by making GHC.Prim belong to a package--- of its own, but it doesn't seem worth the bother.--hptCompleteSigs :: HscEnv -> [CompleteMatch]-hptCompleteSigs = hptAllThings  (md_complete_sigs . hm_details)---- | Find all the instance declarations (of classes and families) from--- the Home Package Table filtered by the provided predicate function.--- Used in @tcRnImports@, to select the instances that are in the--- transitive closure of imports from the currently compiled module.-hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [FamInst])-hptInstances hsc_env want_this_module-  = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do-                guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))-                let details = hm_details mod_info-                return (md_insts details, md_fam_insts details)-    in (concat insts, concat famInsts)---- | Get rules from modules "below" this one (in the dependency sense)-hptRules :: HscEnv -> [ModuleNameWithIsBoot] -> [CoreRule]-hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False----- | Get annotations from modules "below" this one (in the dependency sense)-hptAnns :: HscEnv -> Maybe [ModuleNameWithIsBoot] -> [Annotation]-hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps-hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env--hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]-hptAllThings extract hsc_env = concatMap extract (eltsHpt (hsc_HPT hsc_env))---- | Get things from modules "below" this one (in the dependency sense)--- C.f Inst.hptInstances-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [ModuleNameWithIsBoot] -> [a]-hptSomeThingsBelowUs extract include_hi_boot hsc_env deps-  | isOneShot (ghcMode (hsc_dflags hsc_env)) = []--  | otherwise-  = let hpt = hsc_HPT hsc_env-    in-    [ thing-    |   -- Find each non-hi-boot module below me-      GWIB { gwib_mod = mod, gwib_isBoot = is_boot } <- deps-    , include_hi_boot || (is_boot == NotBoot)--        -- unsavoury: when compiling the base package with --make, we-        -- sometimes try to look up RULES etc for GHC.Prim. GHC.Prim won't-        -- be in the HPT, because we never compile it; it's in the EPT-        -- instead. ToDo: clean up, and remove this slightly bogus filter:-    , mod /= moduleName gHC_PRIM--        -- Look it up in the HPT-    , let things = case lookupHpt hpt mod of-                    Just info -> extract info-                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []-          msg = vcat [text "missing module" <+> ppr mod,-                      text "Probable cause: out-of-date interface files"]-                        -- This really shouldn't happen, but see #962--        -- And get its dfuns-    , thing <- things ]---{--************************************************************************-*                                                                      *-\subsection{Metaprogramming}-*                                                                      *-************************************************************************--}---- | The supported metaprogramming result types-data MetaRequest-  = MetaE  (LHsExpr GhcPs   -> MetaResult)-  | MetaP  (LPat GhcPs      -> MetaResult)-  | MetaT  (LHsType GhcPs   -> MetaResult)-  | MetaD  ([LHsDecl GhcPs] -> MetaResult)-  | MetaAW (Serialized     -> MetaResult)---- | data constructors not exported to ensure correct result type-data MetaResult-  = MetaResE  { unMetaResE  :: LHsExpr GhcPs   }-  | MetaResP  { unMetaResP  :: LPat GhcPs      }-  | MetaResT  { unMetaResT  :: LHsType GhcPs   }-  | MetaResD  { unMetaResD  :: [LHsDecl GhcPs] }-  | MetaResAW { unMetaResAW :: Serialized        }--type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult--metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)-metaRequestE h = fmap unMetaResE . h (MetaE MetaResE)--metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)-metaRequestP h = fmap unMetaResP . h (MetaP MetaResP)--metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)-metaRequestT h = fmap unMetaResT . h (MetaT MetaResT)--metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]-metaRequestD h = fmap unMetaResD . h (MetaD MetaResD)--metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized-metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW)--{--************************************************************************-*                                                                      *-\subsection{Dealing with Annotations}-*                                                                      *-************************************************************************--}---- | Deal with gathering annotations in from all possible places---   and combining them into a single 'AnnEnv'-prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv-prepareAnnotations hsc_env mb_guts = do-    eps <- hscEPS hsc_env-    let -- Extract annotations from the module being compiled if supplied one-        mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts-        -- Extract dependencies of the module if we are supplied one,-        -- otherwise load annotations from all home package table-        -- entries regardless of dependency ordering.-        home_pkg_anns  = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts-        other_pkg_anns = eps_ann_env eps-        ann_env        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,-                                                         Just home_pkg_anns,-                                                         Just other_pkg_anns]-    return ann_env--{--************************************************************************-*                                                                      *-\subsection{The Finder cache}-*                                                                      *-************************************************************************--}---- | The 'FinderCache' maps modules to the result of--- searching for that module. It records the results of searching for--- modules along the search path. On @:load@, we flush the entire--- contents of this cache.----type FinderCache = InstalledModuleEnv InstalledFindResult--data InstalledFindResult-  = InstalledFound ModLocation InstalledModule-  | InstalledNoPackage UnitId-  | InstalledNotFound [FilePath] (Maybe UnitId)---- | The result of searching for an imported module.------ NB: FindResult manages both user source-import lookups--- (which can result in 'Module') as well as direct imports--- for interfaces (which always result in 'InstalledModule').-data FindResult-  = Found ModLocation Module-        -- ^ The module was found-  | NoPackage Unit-        -- ^ The requested unit was not found-  | FoundMultiple [(Module, ModuleOrigin)]-        -- ^ _Error_: both in multiple packages--        -- | Not found-  | NotFound-      { fr_paths       :: [FilePath]       -- ^ Places where I looked--      , fr_pkg         :: Maybe Unit       -- ^ Just p => module is in this unit's-                                           --   manifest, but couldn't find the-                                           --   .hi file--      , fr_mods_hidden :: [Unit]           -- ^ Module is in these units,-                                           --   but the *module* is hidden--      , fr_pkgs_hidden :: [Unit]           -- ^ Module is in these units,-                                           --   but the *unit* is hidden--        -- | Module is in these units, but it is unusable-      , fr_unusables   :: [(Unit, UnusableUnitReason)]--      , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules-      }--{--************************************************************************-*                                                                      *-\subsection{Symbol tables and Module details}-*                                                                      *-************************************************************************--}--{- Note [Interface file stages]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Interface files have two possible stages.--* A partial stage built from the result of the core pipeline.-* A fully instantiated form. Which also includes fingerprints and-  potentially information provided by backends.--We can build a full interface file two ways:-* Directly from a partial one:-  Then we omit backend information and mostly compute fingerprints.-* From a partial one + information produced by a backend.-  Then we store the provided information and fingerprint both.--}--type PartialModIface = ModIface_ 'ModIfaceCore-type ModIface = ModIface_ 'ModIfaceFinal---- | Extends a PartialModIface with information which is either:--- * Computed after codegen--- * Or computed just before writing the iface to disk. (Hashes)--- In order to fully instantiate it.-data ModIfaceBackend = ModIfaceBackend-  { mi_iface_hash :: !Fingerprint-    -- ^ Hash of the whole interface-  , mi_mod_hash :: !Fingerprint-    -- ^ Hash of the ABI only-  , mi_flag_hash :: !Fingerprint-    -- ^ Hash of the important flags used when compiling the module, excluding-    -- optimisation flags-  , mi_opt_hash :: !Fingerprint-    -- ^ Hash of optimisation flags-  , mi_hpc_hash :: !Fingerprint-    -- ^ Hash of hpc flags-  , mi_plugin_hash :: !Fingerprint-    -- ^ Hash of plugins-  , mi_orphan :: !WhetherHasOrphans-    -- ^ Whether this module has orphans-  , mi_finsts :: !WhetherHasFamInst-    -- ^ Whether this module has family instances. See Note [The type family-    -- instance consistency story].-  , mi_exp_hash :: !Fingerprint-    -- ^ Hash of export list-  , mi_orphan_hash :: !Fingerprint-    -- ^ Hash for orphan rules, class and family instances combined--    -- Cached environments for easy lookup. These are computed (lazily) from-    -- other fields and are not put into the interface file.-    -- Not really produced by the backend but there is no need to create them-    -- any earlier.-  , mi_warn_fn :: !(OccName -> Maybe WarningTxt)-    -- ^ Cached lookup for 'mi_warns'-  , mi_fix_fn :: !(OccName -> Maybe Fixity)-    -- ^ Cached lookup for 'mi_fixities'-  , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))-    -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that-    -- the thing isn't in decls. It's useful to know that when seeing if we are-    -- up to date wrt. the old interface. The 'OccName' is the parent of the-    -- name, if it has one.-  }--data ModIfacePhase-  = ModIfaceCore-  -- ^ Partial interface built based on output of core pipeline.-  | ModIfaceFinal---- | Selects a IfaceDecl representation.--- For fully instantiated interfaces we also maintain--- a fingerprint, which is used for recompilation checks.-type family IfaceDeclExts (phase :: ModIfacePhase) where-  IfaceDeclExts 'ModIfaceCore = IfaceDecl-  IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)--type family IfaceBackendExts (phase :: ModIfacePhase) where-  IfaceBackendExts 'ModIfaceCore = ()-  IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend------ | A 'ModIface' plus a 'ModDetails' summarises everything we know--- about a compiled module.  The 'ModIface' is the stuff *before* linking,--- and can be written out to an interface file. The 'ModDetails is after--- linking and can be completely recovered from just the 'ModIface'.------ When we read an interface file, we also construct a 'ModIface' from it,--- except that we explicitly make the 'mi_decls' and a few other fields empty;--- as when reading we consolidate the declarations etc. into a number of indexed--- maps and environments in the 'ExternalPackageState'.-data ModIface_ (phase :: ModIfacePhase)-  = ModIface {-        mi_module     :: !Module,             -- ^ Name of the module we are for-        mi_sig_of     :: !(Maybe Module),     -- ^ Are we a sig of another mod?--        mi_hsc_src    :: !HscSource,          -- ^ Boot? Signature?--        mi_deps     :: Dependencies,-                -- ^ The dependencies of the module.  This is-                -- consulted for directly-imported modules, but not-                -- for anything else (hence lazy)--        mi_usages   :: [Usage],-                -- ^ Usages; kept sorted so that it's easy to decide-                -- whether to write a new iface file (changing usages-                -- doesn't affect the hash of this module)-                -- NOT STRICT!  we read this field lazily from the interface file-                -- It is *only* consulted by the recompilation checker--        mi_exports  :: ![IfaceExport],-                -- ^ Exports-                -- Kept sorted by (mod,occ), to make version comparisons easier-                -- Records the modules that are the declaration points for things-                -- exported by this module, and the 'OccName's of those things---        mi_used_th  :: !Bool,-                -- ^ Module required TH splices when it was compiled.-                -- This disables recompilation avoidance (see #481).--        mi_fixities :: [(OccName,Fixity)],-                -- ^ Fixities-                -- NOT STRICT!  we read this field lazily from the interface file--        mi_warns    :: Warnings,-                -- ^ Warnings-                -- NOT STRICT!  we read this field lazily from the interface file--        mi_anns     :: [IfaceAnnotation],-                -- ^ Annotations-                -- NOT STRICT!  we read this field lazily from the interface file---        mi_decls    :: [IfaceDeclExts phase],-                -- ^ Type, class and variable declarations-                -- The hash of an Id changes if its fixity or deprecations change-                --      (as well as its type of course)-                -- Ditto data constructors, class operations, except that-                -- the hash of the parent class/tycon changes--        mi_globals  :: !(Maybe GlobalRdrEnv),-                -- ^ Binds all the things defined at the top level in-                -- the /original source/ code for this module. which-                -- is NOT the same as mi_exports, nor mi_decls (which-                -- may contains declarations for things not actually-                -- defined by the user).  Used for GHCi and for inspecting-                -- the contents of modules via the GHC API only.-                ---                -- (We need the source file to figure out the-                -- top-level environment, if we didn't compile this module-                -- from source then this field contains @Nothing@).-                ---                -- Strictly speaking this field should live in the-                -- 'HomeModInfo', but that leads to more plumbing.--                -- Instance declarations and rules-        mi_insts       :: [IfaceClsInst],     -- ^ Sorted class instance-        mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances-        mi_rules       :: [IfaceRule],     -- ^ Sorted rules--        mi_hpc       :: !AnyHpcUsage,-                -- ^ True if this program uses Hpc at any point in the program.--        mi_trust     :: !IfaceTrustInfo,-                -- ^ Safe Haskell Trust information for this module.--        mi_trust_pkg :: !Bool,-                -- ^ Do we require the package this module resides in be trusted-                -- to trust this module? This is used for the situation where a-                -- module is Safe (so doesn't require the package be trusted-                -- itself) but imports some trustworthy modules from its own-                -- package (which does require its own package be trusted).-                -- See Note [Trust Own Package] in GHC.Rename.Names-        mi_complete_sigs :: [IfaceCompleteMatch],--        mi_doc_hdr :: Maybe HsDocString,-                -- ^ Module header.--        mi_decl_docs :: DeclDocMap,-                -- ^ Docs on declarations.--        mi_arg_docs :: ArgDocMap,-                -- ^ Docs on arguments.--        mi_final_exts :: !(IfaceBackendExts phase),-                -- ^ Either `()` or `ModIfaceBackend` for-                -- a fully instantiated interface.--        mi_ext_fields :: ExtensibleFields-                -- ^ Additional optional fields, where the Map key represents-                -- the field name, resulting in a (size, serialized data) pair.-                -- Because the data is intended to be serialized through the-                -- internal `Binary` class (increasing compatibility with types-                -- using `Name` and `FastString`, such as HIE), this format is-                -- chosen over `ByteString`s.-     }---- | Old-style accessor for whether or not the ModIface came from an hs-boot--- file.-mi_boot :: ModIface -> IsBootInterface-mi_boot iface = if mi_hsc_src iface == HsBootFile-    then IsBoot-    else NotBoot---- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be--- found, 'defaultFixity' is returned instead.-mi_fix :: ModIface -> OccName -> Fixity-mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity---- | The semantic module for this interface; e.g., if it's a interface--- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'--- will be @<A>@.-mi_semantic_module :: ModIface_ a -> Module-mi_semantic_module iface = case mi_sig_of iface of-                            Nothing -> mi_module iface-                            Just mod -> mod---- | The "precise" free holes, e.g., the signatures that this--- 'ModIface' depends on.-mi_free_holes :: ModIface -> UniqDSet ModuleName-mi_free_holes iface =-  case getModuleInstantiation (mi_module iface) of-    (_, Just indef)-        -- A mini-hack: we rely on the fact that 'renameFreeHoles'-        -- drops things that aren't holes.-        -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))-    _   -> emptyUniqDSet-  where-    cands = map gwib_mod $ dep_mods $ mi_deps iface---- | Given a set of free holes, and a unit identifier, rename--- the free holes according to the instantiation of the unit--- identifier.  For example, if we have A and B free, and--- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free--- holes are just C.-renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName-renameFreeHoles fhs insts =-    unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))-  where-    hmap = listToUFM insts-    lookup_impl mod_name-        | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod-        -- It wasn't actually a hole-        | otherwise                           = emptyUniqDSet--instance Binary ModIface where-   put_ bh (ModIface {-                 mi_module    = mod,-                 mi_sig_of    = sig_of,-                 mi_hsc_src   = hsc_src,-                 mi_deps      = deps,-                 mi_usages    = usages,-                 mi_exports   = exports,-                 mi_used_th   = used_th,-                 mi_fixities  = fixities,-                 mi_warns     = warns,-                 mi_anns      = anns,-                 mi_decls     = decls,-                 mi_insts     = insts,-                 mi_fam_insts = fam_insts,-                 mi_rules     = rules,-                 mi_hpc       = hpc_info,-                 mi_trust     = trust,-                 mi_trust_pkg = trust_pkg,-                 mi_complete_sigs = complete_sigs,-                 mi_doc_hdr   = doc_hdr,-                 mi_decl_docs = decl_docs,-                 mi_arg_docs  = arg_docs,-                 mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we-                                              -- can deal with it's pointer in the header-                                              -- when we write the actual file-                 mi_final_exts = ModIfaceBackend {-                   mi_iface_hash = iface_hash,-                   mi_mod_hash = mod_hash,-                   mi_flag_hash = flag_hash,-                   mi_opt_hash = opt_hash,-                   mi_hpc_hash = hpc_hash,-                   mi_plugin_hash = plugin_hash,-                   mi_orphan = orphan,-                   mi_finsts = hasFamInsts,-                   mi_exp_hash = exp_hash,-                   mi_orphan_hash = orphan_hash-                 }}) = do-        put_ bh mod-        put_ bh sig_of-        put_ bh hsc_src-        put_ bh iface_hash-        put_ bh mod_hash-        put_ bh flag_hash-        put_ bh opt_hash-        put_ bh hpc_hash-        put_ bh plugin_hash-        put_ bh orphan-        put_ bh hasFamInsts-        lazyPut bh deps-        lazyPut bh usages-        put_ bh exports-        put_ bh exp_hash-        put_ bh used_th-        put_ bh fixities-        lazyPut bh warns-        lazyPut bh anns-        put_ bh decls-        put_ bh insts-        put_ bh fam_insts-        lazyPut bh rules-        put_ bh orphan_hash-        put_ bh hpc_info-        put_ bh trust-        put_ bh trust_pkg-        put_ bh complete_sigs-        lazyPut bh doc_hdr-        lazyPut bh decl_docs-        lazyPut bh arg_docs--   get bh = do-        mod         <- get bh-        sig_of      <- get bh-        hsc_src     <- get bh-        iface_hash  <- get bh-        mod_hash    <- get bh-        flag_hash   <- get bh-        opt_hash    <- get bh-        hpc_hash    <- get bh-        plugin_hash <- get bh-        orphan      <- get bh-        hasFamInsts <- get bh-        deps        <- lazyGet bh-        usages      <- {-# SCC "bin_usages" #-} lazyGet bh-        exports     <- {-# SCC "bin_exports" #-} get bh-        exp_hash    <- get bh-        used_th     <- get bh-        fixities    <- {-# SCC "bin_fixities" #-} get bh-        warns       <- {-# SCC "bin_warns" #-} lazyGet bh-        anns        <- {-# SCC "bin_anns" #-} lazyGet bh-        decls       <- {-# SCC "bin_tycldecls" #-} get bh-        insts       <- {-# SCC "bin_insts" #-} get bh-        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh-        rules       <- {-# SCC "bin_rules" #-} lazyGet bh-        orphan_hash <- get bh-        hpc_info    <- get bh-        trust       <- get bh-        trust_pkg   <- get bh-        complete_sigs <- get bh-        doc_hdr     <- lazyGet bh-        decl_docs   <- lazyGet bh-        arg_docs    <- lazyGet bh-        return (ModIface {-                 mi_module      = mod,-                 mi_sig_of      = sig_of,-                 mi_hsc_src     = hsc_src,-                 mi_deps        = deps,-                 mi_usages      = usages,-                 mi_exports     = exports,-                 mi_used_th     = used_th,-                 mi_anns        = anns,-                 mi_fixities    = fixities,-                 mi_warns       = warns,-                 mi_decls       = decls,-                 mi_globals     = Nothing,-                 mi_insts       = insts,-                 mi_fam_insts   = fam_insts,-                 mi_rules       = rules,-                 mi_hpc         = hpc_info,-                 mi_trust       = trust,-                 mi_trust_pkg   = trust_pkg,-                        -- And build the cached values-                 mi_complete_sigs = complete_sigs,-                 mi_doc_hdr     = doc_hdr,-                 mi_decl_docs   = decl_docs,-                 mi_arg_docs    = arg_docs,-                 mi_ext_fields  = emptyExtensibleFields, -- placeholder because this is dealt-                                                         -- with specially when the file is read-                 mi_final_exts = ModIfaceBackend {-                   mi_iface_hash = iface_hash,-                   mi_mod_hash = mod_hash,-                   mi_flag_hash = flag_hash,-                   mi_opt_hash = opt_hash,-                   mi_hpc_hash = hpc_hash,-                   mi_plugin_hash = plugin_hash,-                   mi_orphan = orphan,-                   mi_finsts = hasFamInsts,-                   mi_exp_hash = exp_hash,-                   mi_orphan_hash = orphan_hash,-                   mi_warn_fn = mkIfaceWarnCache warns,-                   mi_fix_fn = mkIfaceFixCache fixities,-                   mi_hash_fn = mkIfaceHashCache decls-                 }})---- | The original names declared of a certain module that are exported-type IfaceExport = AvailInfo--emptyPartialModIface :: Module -> PartialModIface-emptyPartialModIface mod-  = ModIface { mi_module      = mod,-               mi_sig_of      = Nothing,-               mi_hsc_src     = HsSrcFile,-               mi_deps        = noDependencies,-               mi_usages      = [],-               mi_exports     = [],-               mi_used_th     = False,-               mi_fixities    = [],-               mi_warns       = NoWarnings,-               mi_anns        = [],-               mi_insts       = [],-               mi_fam_insts   = [],-               mi_rules       = [],-               mi_decls       = [],-               mi_globals     = Nothing,-               mi_hpc         = False,-               mi_trust       = noIfaceTrustInfo,-               mi_trust_pkg   = False,-               mi_complete_sigs = [],-               mi_doc_hdr     = Nothing,-               mi_decl_docs   = emptyDeclDocMap,-               mi_arg_docs    = emptyArgDocMap,-               mi_final_exts  = (),-               mi_ext_fields  = emptyExtensibleFields-             }--emptyFullModIface :: Module -> ModIface-emptyFullModIface mod =-    (emptyPartialModIface mod)-      { mi_decls = []-      , mi_final_exts = ModIfaceBackend-        { mi_iface_hash = fingerprint0,-          mi_mod_hash = fingerprint0,-          mi_flag_hash = fingerprint0,-          mi_opt_hash = fingerprint0,-          mi_hpc_hash = fingerprint0,-          mi_plugin_hash = fingerprint0,-          mi_orphan = False,-          mi_finsts = False,-          mi_exp_hash = fingerprint0,-          mi_orphan_hash = fingerprint0,-          mi_warn_fn = emptyIfaceWarnCache,-          mi_fix_fn = emptyIfaceFixCache,-          mi_hash_fn = emptyIfaceHashCache } }---- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'-mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]-                 -> (OccName -> Maybe (OccName, Fingerprint))-mkIfaceHashCache pairs-  = \occ -> lookupOccEnv env occ-  where-    env = foldl' add_decl emptyOccEnv pairs-    add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)-      where-        add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)--emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)-emptyIfaceHashCache _occ = Nothing----- | The 'ModDetails' is essentially a cache for information in the 'ModIface'--- for home modules only. Information relating to packages will be loaded into--- global environments in 'ExternalPackageState'.-data ModDetails-  = ModDetails {-        -- The next two fields are created by the typechecker-        md_exports   :: [AvailInfo],-        md_types     :: !TypeEnv,       -- ^ Local type environment for this particular module-                                        -- Includes Ids, TyCons, PatSyns-        md_insts     :: ![ClsInst],     -- ^ 'DFunId's for the instances in this module-        md_fam_insts :: ![FamInst],-        md_rules     :: ![CoreRule],    -- ^ Domain may include 'Id's from other modules-        md_anns      :: ![Annotation],  -- ^ Annotations present in this module: currently-                                        -- they only annotate things also declared in this module-        md_complete_sigs :: [CompleteMatch]-          -- ^ Complete match pragmas for this module-     }---- | Constructs an empty ModDetails-emptyModDetails :: ModDetails-emptyModDetails-  = ModDetails { md_types     = emptyTypeEnv,-                 md_exports   = [],-                 md_insts     = [],-                 md_rules     = [],-                 md_fam_insts = [],-                 md_anns      = [],-                 md_complete_sigs = [] }---- | Records the modules directly imported by a module for extracting e.g.--- usage information, and also to give better error message-type ImportedMods = ModuleEnv [ImportedBy]---- | If a module was "imported" by the user, we associate it with--- more detailed usage information 'ImportedModsVal'; a module--- imported by the system only gets used for usage information.-data ImportedBy-    = ImportedByUser ImportedModsVal-    | ImportedBySystem--importedByUser :: [ImportedBy] -> [ImportedModsVal]-importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys-importedByUser (ImportedBySystem   : bys) =       importedByUser bys-importedByUser [] = []--data ImportedModsVal- = ImportedModsVal {-        imv_name :: ModuleName,          -- ^ The name the module is imported with-        imv_span :: SrcSpan,             -- ^ the source span of the whole import-        imv_is_safe :: IsSafeImport,     -- ^ whether this is a safe import-        imv_is_hiding :: Bool,           -- ^ whether this is an "hiding" import-        imv_all_exports :: !GlobalRdrEnv, -- ^ all the things the module could provide-          -- NB. BangPattern here: otherwise this leaks. (#15111)-        imv_qualified :: Bool            -- ^ whether this is a qualified import-        }---- | A ModGuts is carried through the compiler, accumulating stuff as it goes--- There is only one ModGuts at any time, the one for the module--- being compiled right now.  Once it is compiled, a 'ModIface' and--- 'ModDetails' are extracted and the ModGuts is discarded.-data ModGuts-  = ModGuts {-        mg_module    :: !Module,         -- ^ Module being compiled-        mg_hsc_src   :: HscSource,       -- ^ Whether it's an hs-boot module-        mg_loc       :: SrcSpan,         -- ^ For error messages from inner passes-        mg_exports   :: ![AvailInfo],    -- ^ What it exports-        mg_deps      :: !Dependencies,   -- ^ What it depends on, directly or-                                         -- otherwise-        mg_usages    :: ![Usage],        -- ^ What was used?  Used for interfaces.--        mg_used_th   :: !Bool,           -- ^ Did we run a TH splice?-        mg_rdr_env   :: !GlobalRdrEnv,   -- ^ Top-level lexical environment--        -- These fields all describe the things **declared in this module**-        mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module.-                                         -- Used for creating interface files.-        mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module-                                         -- (includes TyCons for classes)-        mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module-        mg_fam_insts :: ![FamInst],-                                         -- ^ Family instances declared in this module-        mg_patsyns   :: ![PatSyn],       -- ^ Pattern synonyms declared in this module-        mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains-                                         -- See Note [Overall plumbing for rules] in "GHC.Core.Rules"-        mg_binds     :: !CoreProgram,    -- ^ Bindings for this module-        mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module-        mg_foreign_files :: ![(ForeignSrcLang, FilePath)],-        -- ^ Files to be compiled with the C compiler-        mg_warns     :: !Warnings,       -- ^ Warnings declared in the module-        mg_anns      :: [Annotation],    -- ^ Annotations declared in this module-        mg_complete_sigs :: [CompleteMatch], -- ^ Complete Matches-        mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module-        mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module--                        -- The next two fields are unusual, because they give instance-                        -- environments for *all* modules in the home package, including-                        -- this module, rather than for *just* this module.-                        -- Reason: when looking up an instance we don't want to have to-                        --         look at each module in the home package in turn-        mg_inst_env     :: InstEnv,             -- ^ Class instance environment for-                                                -- /home-package/ modules (including this-                                                -- one); c.f. 'tcg_inst_env'-        mg_fam_inst_env :: FamInstEnv,          -- ^ Type-family instance environment for-                                                -- /home-package/ modules (including this-                                                -- one); c.f. 'tcg_fam_inst_env'--        mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode-        mg_trust_pkg    :: Bool,                -- ^ Do we need to trust our-                                                -- own package for Safe Haskell?-                                                -- See Note [Trust Own Package]-                                                -- in "GHC.Rename.Names"--        mg_doc_hdr       :: !(Maybe HsDocString), -- ^ Module header.-        mg_decl_docs     :: !DeclDocMap,     -- ^ Docs on declarations.-        mg_arg_docs      :: !ArgDocMap       -- ^ Docs on arguments.-    }---- The ModGuts takes on several slightly different forms:------ After simplification, the following fields change slightly:---      mg_rules        Orphan rules only (local ones now attached to binds)---      mg_binds        With rules attached-------------------------------------------------------------- The Tidy pass forks the information about this module:---      * one lot goes to interface file generation (ModIface)---        and later compilations (ModDetails)---      * the other lot goes to code generation (CgGuts)---- | A restricted form of 'ModGuts' for code generation purposes-data CgGuts-  = CgGuts {-        cg_module    :: !Module,-                -- ^ Module being compiled--        cg_tycons    :: [TyCon],-                -- ^ Algebraic data types (including ones that started-                -- life as classes); generate constructors and info-                -- tables. Includes newtypes, just for the benefit of-                -- External Core--        cg_binds     :: CoreProgram,-                -- ^ The tidied main bindings, including-                -- previously-implicit bindings for record and class-                -- selectors, and data constructor wrappers.  But *not*-                -- data constructor workers; reason: we regard them-                -- as part of the code-gen of tycons--        cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs-        cg_foreign_files :: ![(ForeignSrcLang, FilePath)],-        cg_dep_pkgs  :: ![UnitId], -- ^ Dependent packages, used to-                                            -- generate #includes for C code gen-        cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information-        cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints-        cg_spt_entries :: [SptEntry]-                -- ^ Static pointer table entries for static forms defined in-                -- the module.-                -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"-    }---------------------------------------- | Foreign export stubs-data ForeignStubs-  = NoStubs-      -- ^ We don't have any stubs-  | ForeignStubs SDoc SDoc-      -- ^ There are some stubs. Parameters:-      ---      --  1) Header file prototypes for-      --     "foreign exported" functions-      ---      --  2) C stubs to use when calling-      --     "foreign exported" functions--appendStubC :: ForeignStubs -> SDoc -> ForeignStubs-appendStubC NoStubs            c_code = ForeignStubs empty c_code-appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)--{--************************************************************************-*                                                                      *-                The interactive context-*                                                                      *-************************************************************************--Note [The interactive package]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Type, class, and value declarations at the command prompt are treated-as if they were defined in modules-   interactive:Ghci1-   interactive:Ghci2-   ...etc...-with each bunch of declarations using a new module, all sharing a-common package 'interactive' (see Module.interactiveUnitId, and-GHC.Builtin.Names.mkInteractiveModule).--This scheme deals well with shadowing.  For example:--   ghci> data T = A-   ghci> data T = B-   ghci> :i A-   data Ghci1.T = A  -- Defined at <interactive>:2:10--Here we must display info about constructor A, but its type T has been-shadowed by the second declaration.  But it has a respectable-qualified name (Ghci1.T), and its source location says where it was-defined.--So the main invariant continues to hold, that in any session an-original name M.T only refers to one unique thing.  (In a previous-iteration both the T's above were called :Interactive.T, albeit with-different uniques, which gave rise to all sorts of trouble.)--The details are a bit tricky though:-- * The field ic_mod_index counts which Ghci module we've got up to.-   It is incremented when extending ic_tythings-- * ic_tythings contains only things from the 'interactive' package.-- * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go-   in the Home Package Table (HPT).  When you say :load, that's when we-   extend the HPT.-- * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'.-   It stays as 'main' (or whatever -this-unit-id says), and is the-   package to which :load'ed modules are added to.-- * So how do we arrange that declarations at the command prompt get to-   be in the 'interactive' package?  Simply by setting the tcg_mod-   field of the TcGblEnv to "interactive:Ghci1".  This is done by the-   call to initTc in initTcInteractive, which in turn get the module-   from it 'icInteractiveModule' field of the interactive context.--   The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says.-- * The main trickiness is that the type environment (tcg_type_env) and-   fixity envt (tcg_fix_env), now contain entities from all the-   interactive-package modules (Ghci1, Ghci2, ...) together, rather-   than just a single module as is usually the case.  So you can't use-   "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs-   the HPT/PTE.  This is a change, but not a problem provided you-   know.--* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields-  of the TcGblEnv, which collect "things defined in this module", all-  refer to stuff define in a single GHCi command, *not* all the commands-  so far.--  In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from-  all GhciN modules, which makes sense -- they are all "home package"-  modules.---Note [Interactively-bound Ids in GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Ids bound by previous Stmts in GHCi are currently-        a) GlobalIds, with-        b) An External Name, like Ghci4.foo-           See Note [The interactive package] above-        c) A tidied type-- (a) They must be GlobalIds (not LocalIds) otherwise when we come to-     compile an expression using these ids later, the byte code-     generator will consider the occurrences to be free rather than-     global.-- (b) Having an External Name is important because of Note-     [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName-- (c) Their types are tidied. This is important, because :info may ask-     to look at them, and :info expects the things it looks up to have-     tidy types--Where do interactively-bound Ids come from?--  - GHCi REPL Stmts   e.g.-         ghci> let foo x = x+1-    These start with an Internal Name because a Stmt is a local-    construct, so the renamer naturally builds an Internal name for-    each of its binders.  Then in tcRnStmt they are externalised via-    GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo.--  - Ids bound by the debugger etc have Names constructed by-    GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by-    mkVanillaGlobal or mkVanillaGlobalWithInfo.  So again, they are-    all Global, External.--  - TyCons, Classes, and Ids bound by other top-level declarations in-    GHCi (eg foreign import, record selectors) also get External-    Names, with Ghci9 (or 8, or 7, etc) as the module name.---Note [ic_tythings]-~~~~~~~~~~~~~~~~~~-The ic_tythings field contains-  * The TyThings declared by the user at the command prompt-    (eg Ids, TyCons, Classes)--  * The user-visible Ids that arise from such things, which-    *don't* come from 'implicitTyThings', notably:-       - record selectors-       - class ops-    The implicitTyThings are readily obtained from the TyThings-    but record selectors etc are not--It does *not* contain-  * DFunIds (they can be gotten from ic_instances)-  * CoAxioms (ditto)--See also Note [Interactively-bound Ids in GHCi]--Note [Override identical instances in GHCi]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If you declare a new instance in GHCi that is identical to a previous one,-we simply override the previous one; we don't regard it as overlapping.-e.g.    Prelude> data T = A | B-        Prelude> instance Eq T where ...-        Prelude> instance Eq T where ...   -- This one overrides--It's exactly the same for type-family instances.  See #7102--}---- | Interactive context, recording information about the state of the--- context in which statements are executed in a GHCi session.-data InteractiveContext-  = InteractiveContext {-         ic_dflags     :: DynFlags,-             -- ^ The 'DynFlags' used to evaluate interactive expressions-             -- and statements.--         ic_mod_index :: Int,-             -- ^ Each GHCi stmt or declaration brings some new things into-             -- scope. We give them names like interactive:Ghci9.T,-             -- where the ic_index is the '9'.  The ic_mod_index is-             -- incremented whenever we add something to ic_tythings-             -- See Note [The interactive package]--         ic_imports :: [InteractiveImport],-             -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with-             -- these imports-             ---             -- This field is only stored here so that the client-             -- can retrieve it with GHC.getContext. GHC itself doesn't-             -- use it, but does reset it to empty sometimes (such-             -- as before a GHC.load). The context is set with GHC.setContext.--         ic_tythings   :: [TyThing],-             -- ^ TyThings defined by the user, in reverse order of-             -- definition (ie most recent at the front)-             -- See Note [ic_tythings]--         ic_rn_gbl_env :: GlobalRdrEnv,-             -- ^ The cached 'GlobalRdrEnv', built by-             -- 'GHC.Runtime.Eval.setContext' and updated regularly-             -- It contains everything in scope at the command line,-             -- including everything in ic_tythings--         ic_instances  :: ([ClsInst], [FamInst]),-             -- ^ All instances and family instances created during-             -- this session.  These are grabbed en masse after each-             -- update to be sure that proper overlapping is retained.-             -- That is, rather than re-check the overlapping each-             -- time we update the context, we just take the results-             -- from the instance code that already does that.--         ic_fix_env :: FixityEnv,-            -- ^ Fixities declared in let statements--         ic_default :: Maybe [Type],-             -- ^ The current default types, set by a 'default' declaration--          ic_resume :: [Resume],-             -- ^ The stack of breakpoint contexts--         ic_monad      :: Name,-             -- ^ The monad that GHCi is executing in--         ic_int_print  :: Name,-             -- ^ The function that is used for printing results-             -- of expressions in ghci and -e mode.--         ic_cwd :: Maybe FilePath-             -- virtual CWD of the program-    }--data InteractiveImport-  = IIDecl (ImportDecl GhcPs)-      -- ^ Bring the exports of a particular module-      -- (filtered by an import decl) into scope--  | IIModule ModuleName-      -- ^ Bring into scope the entire top-level envt of-      -- of this module, including the things imported-      -- into it.----- | Constructs an empty InteractiveContext.-emptyInteractiveContext :: DynFlags -> InteractiveContext-emptyInteractiveContext dflags-  = InteractiveContext {-       ic_dflags     = dflags,-       ic_imports    = [],-       ic_rn_gbl_env = emptyGlobalRdrEnv,-       ic_mod_index  = 1,-       ic_tythings   = [],-       ic_instances  = ([],[]),-       ic_fix_env    = emptyNameEnv,-       ic_monad      = ioTyConName,  -- IO monad by default-       ic_int_print  = printName,    -- System.IO.print by default-       ic_default    = Nothing,-       ic_resume     = [],-       ic_cwd        = Nothing }--icInteractiveModule :: InteractiveContext -> Module-icInteractiveModule (InteractiveContext { ic_mod_index = index })-  = mkInteractiveModule index---- | This function returns the list of visible TyThings (useful for--- e.g. showBindings)-icInScopeTTs :: InteractiveContext -> [TyThing]-icInScopeTTs = ic_tythings---- | Get the PrintUnqualified function based on the flags and this InteractiveContext-icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified-icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =-    mkPrintUnqualified dflags grenv---- | extendInteractiveContext is called with new TyThings recently defined to update the--- InteractiveContext to include them.  Ids are easily removed when shadowed,--- but Classes and TyCons are not.  Some work could be done to determine--- whether they are entirely shadowed, but as you could still have references--- to them (e.g. instances for classes or values of the type for TyCons), it's--- not clear whether removing them is even the appropriate behavior.-extendInteractiveContext :: InteractiveContext-                         -> [TyThing]-                         -> [ClsInst] -> [FamInst]-                         -> Maybe [Type]-                         -> FixityEnv-                         -> InteractiveContext-extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env-  = ictxt { ic_mod_index  = ic_mod_index ictxt + 1-                            -- Always bump this; even instances should create-                            -- a new mod_index (#9426)-          , ic_tythings   = new_tythings ++ old_tythings-          , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings-          , ic_instances  = ( new_cls_insts ++ old_cls_insts-                            , new_fam_insts ++ fam_insts )-                            -- we don't shadow old family instances (#7102),-                            -- so don't need to remove them here-          , ic_default    = defaults-          , ic_fix_env    = fix_env  -- See Note [Fixity declarations in GHCi]-          }-  where-    new_ids = [id | AnId id <- new_tythings]-    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)--    -- Discard old instances that have been fully overridden-    -- See Note [Override identical instances in GHCi]-    (cls_insts, fam_insts) = ic_instances ictxt-    old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts--extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext--- Just a specialised version-extendInteractiveContextWithIds ictxt new_ids-  | null new_ids = ictxt-  | otherwise    = ictxt { ic_mod_index  = ic_mod_index ictxt + 1-                         , ic_tythings   = new_tythings ++ old_tythings-                         , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }-  where-    new_tythings = map AnId new_ids-    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)--shadowed_by :: [Id] -> TyThing -> Bool-shadowed_by ids = shadowed-  where-    shadowed id = getOccName id `elemOccSet` new_occs-    new_occs = mkOccSet (map getOccName ids)---- | Set the 'DynFlags.homeUnitId' to 'interactive'-setInteractivePackage :: HscEnv -> HscEnv-setInteractivePackage hsc_env-   = hsc_env { hsc_dflags = (hsc_dflags hsc_env)-                { homeUnitId = interactiveUnitId } }--setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext-setInteractivePrintName ic n = ic{ic_int_print = n}--    -- ToDo: should not add Ids to the gbl env here---- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing--- later ones, and shadowing existing entries in the GlobalRdrEnv.-icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv-icExtendGblRdrEnv env tythings-  = foldr add env tythings  -- Foldr makes things in the front of-                            -- the list shadow things at the back-  where-    -- One at a time, to ensure each shadows the previous ones-    add thing env-       | is_sub_bndr thing-       = env-       | otherwise-       = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)-       where-          env1  = shadowNames env (concatMap availNames avail)-          avail = tyThingAvailInfo thing--    -- Ugh! The new_tythings may include record selectors, since they-    -- are not implicit-ids, and must appear in the TypeEnv.  But they-    -- will also be brought into scope by the corresponding (ATyCon-    -- tc).  And we want the latter, because that has the correct-    -- parent (#10520)-    is_sub_bndr (AnId f) = case idDetails f of-                             RecSelId {}  -> True-                             ClassOpId {} -> True-                             _            -> False-    is_sub_bndr _ = False--substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext-substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst-  | isEmptyTCvSubst subst = ictxt-  | otherwise             = ictxt { ic_tythings = map subst_ty tts }-  where-    subst_ty (AnId id)-      = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id-      -- Variables in the interactive context *can* mention free type variables-      -- because of the runtime debugger. Otherwise you'd expect all-      -- variables bound in the interactive context to be closed.-    subst_ty tt-      = tt--instance Outputable InteractiveImport where-  ppr (IIModule m) = char '*' <> ppr m-  ppr (IIDecl d)   = ppr d--{--************************************************************************-*                                                                      *-        Building a PrintUnqualified-*                                                                      *-************************************************************************--Note [Printing original names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Deciding how to print names is pretty tricky.  We are given a name-P:M.T, where P is the package name, M is the defining module, and T is-the occurrence name, and we have to decide in which form to display-the name given a GlobalRdrEnv describing the current scope.--Ideally we want to display the name in the form in which it is in-scope.  However, the name might not be in scope at all, and that's-where it gets tricky.  Here are the cases:-- 1. T uniquely maps to  P:M.T      --->  "T"      NameUnqual- 2. There is an X for which X.T-       uniquely maps to  P:M.T     --->  "X.T"    NameQual X- 3. There is no binding for "M.T"  --->  "M.T"    NameNotInScope1- 4. Otherwise                      --->  "P:M.T"  NameNotInScope2--(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at-all. In these cases we still want to refer to the name as "M.T", *but*-"M.T" might mean something else in the current scope (e.g. if there's-an "import X as M"), so to avoid confusion we avoid using "M.T" if-there's already a binding for it.  Instead we write P:M.T.--There's one further subtlety: in case (3), what if there are two-things around, P1:M.T and P2:M.T?  Then we don't want to print both of-them as M.T!  However only one of the modules P1:M and P2:M can be-exposed (say P2), so we use M.T for that, and P1:M.T for the other one.-This is handled by the qual_mod component of PrintUnqualified, inside-the (ppr mod) of case (3), in Name.pprModulePrefix--Note [Printing unit ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the old days, original names were tied to PackageIds, which directly-corresponded to the entities that users wrote in Cabal files, and were perfectly-suitable for printing when we need to disambiguate packages.  However, with-instantiated units, the situation can be different: if the key is instantiated-with some holes, we should try to give the user some more useful information.--}---- | Creates some functions that work out the best ways to format--- names for the user according to a set of heuristics.-mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified-mkPrintUnqualified dflags env = QueryQualify qual_name-                                             (mkQualModule dflags)-                                             (mkQualPackage pkgs)-  where-  pkgs = unitState dflags-  qual_name mod occ-        | [gre] <- unqual_gres-        , right_name gre-        = NameUnqual   -- If there's a unique entity that's in scope-                       -- unqualified with 'occ' AND that entity is-                       -- the right one, then we can use the unqualified name--        | [] <- unqual_gres-        , any is_name forceUnqualNames-        , not (isDerivedOccName occ)-        = NameUnqual   -- Don't qualify names that come from modules-                       -- that come with GHC, often appear in error messages,-                       -- but aren't typically in scope. Doing this does not-                       -- cause ambiguity, and it reduces the amount of-                       -- qualification in error messages thus improving-                       -- readability.-                       ---                       -- A motivating example is 'Constraint'. It's often not-                       -- in scope, but printing GHC.Prim.Constraint seems-                       -- overkill.--        | [gre] <- qual_gres-        = NameQual (greQualModName gre)--        | null qual_gres-        = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)-          then NameNotInScope1-          else NameNotInScope2--        | otherwise-        = NameNotInScope1   -- Can happen if 'f' is bound twice in the module-                            -- Eg  f = True; g = 0; f = False-      where-        is_name :: Name -> Bool-        is_name name = ASSERT2( isExternalName name, ppr name )-                       nameModule name == mod && nameOccName name == occ--        forceUnqualNames :: [Name]-        forceUnqualNames =-          map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]-          ++ [ eqTyConName ]--        right_name gre = nameModule_maybe (gre_name gre) == Just mod--        unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env-        qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)--    -- we can mention a module P:M without the P: qualifier iff-    -- "import M" would resolve unambiguously to P:M.  (if P is the-    -- current package we can just assume it is unqualified).---- | Creates a function for formatting modules based on two heuristics:--- (1) if the module is the current module, don't qualify, and (2) if there--- is only one exposed package which exports this module, don't qualify.-mkQualModule :: DynFlags -> QueryQualifyModule-mkQualModule dflags mod-     | isHomeModule dflags mod = False--     | [(_, pkgconfig)] <- lookup,-       mkUnit pkgconfig == moduleUnit mod-        -- this says: we are given a module P:M, is there just one exposed package-        -- that exposes a module M, and is it package P?-     = False--     | otherwise = True-     where lookup = lookupModuleInAllUnits (unitState dflags) (moduleName mod)---- | Creates a function for formatting packages based on two heuristics:--- (1) don't qualify if the package in question is "main", and (2) only qualify--- with a unit id if the package ID would be ambiguous.-mkQualPackage :: UnitState -> QueryQualifyPackage-mkQualPackage pkgs uid-     | uid == mainUnit || uid == interactiveUnit-        -- Skip the lookup if it's main, since it won't be in the package-        -- database!-     = False-     | Just pkgid <- mb_pkgid-     , searchPackageId pkgs pkgid `lengthIs` 1-        -- this says: we are given a package pkg-0.1@MMM, are there only one-        -- exposed packages whose package ID is pkg-0.1?-     = False-     | otherwise-     = True-     where mb_pkgid = fmap unitPackageId (lookupUnit pkgs uid)---- | A function which only qualifies package names if necessary; but--- qualifies all other identifiers.-pkgQual :: UnitState -> PrintUnqualified-pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs }--{--************************************************************************-*                                                                      *-                Implicit TyThings-*                                                                      *-************************************************************************--Note [Implicit TyThings]-~~~~~~~~~~~~~~~~~~~~~~~~-  DEFINITION: An "implicit" TyThing is one that does not have its own-  IfaceDecl in an interface file.  Instead, its binding in the type-  environment is created as part of typechecking the IfaceDecl for-  some other thing.--Examples:-  * All DataCons are implicit, because they are generated from the-    IfaceDecl for the data/newtype.  Ditto class methods.--  * Record selectors are *not* implicit, because they get their own-    free-standing IfaceDecl.--  * Associated data/type families are implicit because they are-    included in the IfaceDecl of the parent class.  (NB: the-    IfaceClass decl happens to use IfaceDecl recursively for the-    associated types, but that's irrelevant here.)--  * Dictionary function Ids are not implicit.--  * Axioms for newtypes are implicit (same as above), but axioms-    for data/type family instances are *not* implicit (like DFunIds).--}---- | Determine the 'TyThing's brought into scope by another 'TyThing'--- /other/ than itself. For example, Id's don't have any implicit TyThings--- as they just bring themselves into scope, but classes bring their--- dictionary datatype, type constructor and some selector functions into--- scope, just for a start!---- N.B. the set of TyThings returned here *must* match the set of--- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that--- TyThing.getOccName should define a bijection between the two lists.--- This invariant is used in 'GHC.Iface.Load.loadDecl' (see note [Tricky iface loop])--- The order of the list does not matter.-implicitTyThings :: TyThing -> [TyThing]-implicitTyThings (AnId _)       = []-implicitTyThings (ACoAxiom _cc) = []-implicitTyThings (ATyCon tc)    = implicitTyConThings tc-implicitTyThings (AConLike cl)  = implicitConLikeThings cl--implicitConLikeThings :: ConLike -> [TyThing]-implicitConLikeThings (RealDataCon dc)-  = dataConImplicitTyThings dc--implicitConLikeThings (PatSynCon {})-  = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher-        -- are not "implicit"; they are simply new top-level bindings,-        -- and they have their own declaration in an interface file-        -- Unless a record pat syn when there are implicit selectors-        -- They are still not included here as `implicitConLikeThings` is-        -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked-        -- by `tcTopValBinds`.--implicitClassThings :: Class -> [TyThing]-implicitClassThings cl-  = -- Does not include default methods, because those Ids may have-    --    their own pragmas, unfoldings etc, not derived from the Class object--    -- associated types-    --    No recursive call for the classATs, because they-    --    are only the family decls; they have no implicit things-    map ATyCon (classATs cl) ++--    -- superclass and operation selectors-    map AnId (classAllSelIds cl)--implicitTyConThings :: TyCon -> [TyThing]-implicitTyConThings tc-  = class_stuff ++-      -- fields (names of selectors)--      -- (possibly) implicit newtype axioms-      -- or type family axioms-    implicitCoTyCon tc ++--      -- for each data constructor in order,-      --   the constructor, worker, and (possibly) wrapper-    [ thing | dc    <- tyConDataCons tc-            , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]-      -- NB. record selectors are *not* implicit, they have fully-fledged-      -- bindings that pass through the compilation pipeline as normal.-  where-    class_stuff = case tyConClass_maybe tc of-        Nothing -> []-        Just cl -> implicitClassThings cl---- For newtypes and closed type families (only) add the implicit coercion tycon-implicitCoTyCon :: TyCon -> [TyThing]-implicitCoTyCon tc-  | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]-  | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc-                                   = [ACoAxiom co]-  | otherwise                      = []---- | Returns @True@ if there should be no interface-file declaration--- for this thing on its own: either it is built-in, or it is part--- of some other declaration, or it is generated implicitly by some--- other declaration.-isImplicitTyThing :: TyThing -> Bool-isImplicitTyThing (AConLike cl) = case cl of-                                    RealDataCon {} -> True-                                    PatSynCon {}   -> False-isImplicitTyThing (AnId id)     = isImplicitId id-isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc-isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax---- | tyThingParent_maybe x returns (Just p)--- when pprTyThingInContext should print a declaration for p--- (albeit with some "..." in it) when asked to show x--- It returns the *immediate* parent.  So a datacon returns its tycon--- but the tycon could be the associated type of a class, so it in turn--- might have a parent.-tyThingParent_maybe :: TyThing -> Maybe TyThing-tyThingParent_maybe (AConLike cl) = case cl of-    RealDataCon dc  -> Just (ATyCon (dataConTyCon dc))-    PatSynCon{}     -> Nothing-tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of-                                      Just tc -> Just (ATyCon tc)-                                      Nothing -> Nothing-tyThingParent_maybe (AnId id)     = case idDetails id of-                                      RecSelId { sel_tycon = RecSelData tc } ->-                                          Just (ATyCon tc)-                                      ClassOpId cls               ->-                                          Just (ATyCon (classTyCon cls))-                                      _other                      -> Nothing-tyThingParent_maybe _other = Nothing--tyThingsTyCoVars :: [TyThing] -> TyCoVarSet-tyThingsTyCoVars tts =-    unionVarSets $ map ttToVarSet tts-    where-        ttToVarSet (AnId id)     = tyCoVarsOfType $ idType id-        ttToVarSet (AConLike cl) = case cl of-            RealDataCon dc  -> tyCoVarsOfType $ dataConRepType dc-            PatSynCon{}     -> emptyVarSet-        ttToVarSet (ATyCon tc)-          = case tyConClass_maybe tc of-              Just cls -> (mkVarSet . fst . classTvsFds) cls-              Nothing  -> tyCoVarsOfType $ tyConKind tc-        ttToVarSet (ACoAxiom _)  = emptyVarSet---- | The Names that a TyThing should bring into scope.  Used to build--- the GlobalRdrEnv for the InteractiveContext.-tyThingAvailInfo :: TyThing -> [AvailInfo]-tyThingAvailInfo (ATyCon t)-   = case tyConClass_maybe t of-        Just c  -> [AvailTC n (n : map getName (classMethods c)-                                 ++ map getName (classATs c))-                             [] ]-             where n = getName c-        Nothing -> [AvailTC n (n : map getName dcs) flds]-             where n    = getName t-                   dcs  = tyConDataCons t-                   flds = tyConFieldLabels t-tyThingAvailInfo (AConLike (PatSynCon p))-  = map avail ((getName p) : map flSelector (patSynFieldLabels p))-tyThingAvailInfo t-   = [avail (getName t)]--{--************************************************************************-*                                                                      *-                TypeEnv-*                                                                      *-************************************************************************--}---- | A map from 'Name's to 'TyThing's, constructed by typechecking--- local declarations or interface files-type TypeEnv = NameEnv TyThing--emptyTypeEnv    :: TypeEnv-typeEnvElts     :: TypeEnv -> [TyThing]-typeEnvTyCons   :: TypeEnv -> [TyCon]-typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]-typeEnvIds      :: TypeEnv -> [Id]-typeEnvPatSyns  :: TypeEnv -> [PatSyn]-typeEnvDataCons :: TypeEnv -> [DataCon]-typeEnvClasses  :: TypeEnv -> [Class]-lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing--emptyTypeEnv        = emptyNameEnv-typeEnvElts     env = nameEnvElts env-typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env]-typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]-typeEnvIds      env = [id | AnId id     <- typeEnvElts env]-typeEnvPatSyns  env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]-typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env]-typeEnvClasses  env = [cl | tc <- typeEnvTyCons env,-                            Just cl <- [tyConClass_maybe tc]]--mkTypeEnv :: [TyThing] -> TypeEnv-mkTypeEnv things = extendTypeEnvList emptyTypeEnv things--mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv-mkTypeEnvWithImplicits things =-  mkTypeEnv things-    `plusNameEnv`-  mkTypeEnv (concatMap implicitTyThings things)--typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv-typeEnvFromEntities ids tcs famInsts =-  mkTypeEnv (   map AnId ids-             ++ map ATyCon all_tcs-             ++ concatMap implicitTyConThings all_tcs-             ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts-            )- where-  all_tcs = tcs ++ famInstsRepTyCons famInsts--lookupTypeEnv = lookupNameEnv---- Extend the type environment-extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv-extendTypeEnv env thing = extendNameEnv env (getName thing) thing--extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv-extendTypeEnvList env things = foldl' extendTypeEnv env things--extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv-extendTypeEnvWithIds env ids-  = extendNameEnvList env [(getName id, AnId id) | id <- ids]--plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv-plusTypeEnv env1 env2 = plusNameEnv env1 env2---- | Find the 'TyThing' for the given 'Name' by using all the resources--- at our disposal: the compiled modules in the 'HomePackageTable' and the--- compiled modules in other packages that live in 'PackageTypeEnv'. Note--- that this does NOT look up the 'TyThing' in the module being compiled: you--- have to do that yourself, if desired-lookupType :: DynFlags-           -> HomePackageTable-           -> PackageTypeEnv-           -> Name-           -> Maybe TyThing--lookupType dflags hpt pte name-  | isOneShot (ghcMode dflags)  -- in one-shot, we don't use the HPT-  = lookupNameEnv pte name-  | otherwise-  = case lookupHptByModule hpt mod of-       Just hm -> lookupNameEnv (md_types (hm_details hm)) name-       Nothing -> lookupNameEnv pte name-  where-    mod = ASSERT2( isExternalName name, ppr name )-          if isHoleName name-            then mkHomeModule dflags (moduleName (nameModule name))-            else nameModule name---- | As 'lookupType', but with a marginally easier-to-use interface--- if you have a 'HscEnv'-lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)-lookupTypeHscEnv hsc_env name = do-    eps <- readIORef (hsc_EPS hsc_env)-    return $! lookupType dflags hpt (eps_PTE eps) name-  where-    dflags = hsc_dflags hsc_env-    hpt = hsc_HPT hsc_env---- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise-tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon-tyThingTyCon (ATyCon tc) = tc-tyThingTyCon other       = pprPanic "tyThingTyCon" (ppr other)---- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise-tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched-tyThingCoAxiom (ACoAxiom ax) = ax-tyThingCoAxiom other         = pprPanic "tyThingCoAxiom" (ppr other)---- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise-tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon-tyThingDataCon (AConLike (RealDataCon dc)) = dc-tyThingDataCon other                       = pprPanic "tyThingDataCon" (ppr other)---- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.--- Panics otherwise-tyThingConLike :: HasDebugCallStack => TyThing -> ConLike-tyThingConLike (AConLike dc) = dc-tyThingConLike other         = pprPanic "tyThingConLike" (ppr other)---- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise-tyThingId :: HasDebugCallStack => TyThing -> Id-tyThingId (AnId id)                   = id-tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc-tyThingId other                       = pprPanic "tyThingId" (ppr other)--{--************************************************************************-*                                                                      *-\subsection{MonadThings and friends}-*                                                                      *-************************************************************************--}---- | Class that abstracts out the common ability of the monads in GHC--- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides--- a number of related convenience functions for accessing particular--- kinds of 'TyThing'-class Monad m => MonadThings m where-        lookupThing :: Name -> m TyThing--        lookupId :: Name -> m Id-        lookupId = liftM tyThingId . lookupThing--        lookupDataCon :: Name -> m DataCon-        lookupDataCon = liftM tyThingDataCon . lookupThing--        lookupTyCon :: Name -> m TyCon-        lookupTyCon = liftM tyThingTyCon . lookupThing---- Instance used in GHC.HsToCore.Quote-instance MonadThings m => MonadThings (ReaderT s m) where-  lookupThing = lift . lookupThing--{--************************************************************************-*                                                                      *-\subsection{Auxiliary types}-*                                                                      *-************************************************************************--These types are defined here because they are mentioned in ModDetails,-but they are mostly elaborated elsewhere--}-------------------- Warnings ---------------------------- | Warning information for a module-data Warnings-  = NoWarnings                          -- ^ Nothing deprecated-  | WarnAll WarningTxt                  -- ^ Whole module deprecated-  | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated--     -- Only an OccName is needed because-     --    (1) a deprecation always applies to a binding-     --        defined in the module in which the deprecation appears.-     --    (2) deprecations are only reported outside the defining module.-     --        this is important because, otherwise, if we saw something like-     ---     --        {-# DEPRECATED f "" #-}-     --        f = ...-     --        h = f-     --        g = let f = undefined in f-     ---     --        we'd need more information than an OccName to know to say something-     --        about the use of f in h but not the use of the locally bound f in g-     ---     --        however, because we only report about deprecations from the outside,-     --        and a module can only export one value called f,-     --        an OccName suffices.-     ---     --        this is in contrast with fixity declarations, where we need to map-     --        a Name to its fixity declaration.-  deriving( Eq )--instance Binary Warnings where-    put_ bh NoWarnings     = putByte bh 0-    put_ bh (WarnAll t) = do-            putByte bh 1-            put_ bh t-    put_ bh (WarnSome ts) = do-            putByte bh 2-            put_ bh ts--    get bh = do-            h <- getByte bh-            case h of-              0 -> return NoWarnings-              1 -> do aa <- get bh-                      return (WarnAll aa)-              _ -> do aa <- get bh-                      return (WarnSome aa)---- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'-mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt-mkIfaceWarnCache NoWarnings  = \_ -> Nothing-mkIfaceWarnCache (WarnAll t) = \_ -> Just t-mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)--emptyIfaceWarnCache :: OccName -> Maybe WarningTxt-emptyIfaceWarnCache _ = Nothing--plusWarns :: Warnings -> Warnings -> Warnings-plusWarns d NoWarnings = d-plusWarns NoWarnings d = d-plusWarns _ (WarnAll t) = WarnAll t-plusWarns (WarnAll t) _ = WarnAll t-plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)---- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'-mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity-mkIfaceFixCache pairs-  = \n -> lookupOccEnv env n-  where-   env = mkOccEnv pairs--emptyIfaceFixCache :: OccName -> Maybe Fixity-emptyIfaceFixCache _ = Nothing---- | Fixity environment mapping names to their fixities-type FixityEnv = NameEnv FixItem---- | Fixity information for an 'Name'. We keep the OccName in the range--- so that we can generate an interface from it-data FixItem = FixItem OccName Fixity--instance Outputable FixItem where-  ppr (FixItem occ fix) = ppr fix <+> ppr occ--emptyFixityEnv :: FixityEnv-emptyFixityEnv = emptyNameEnv--lookupFixity :: FixityEnv -> Name -> Fixity-lookupFixity env n = case lookupNameEnv env n of-                        Just (FixItem _ fix) -> fix-                        Nothing         -> defaultFixity--{--************************************************************************-*                                                                      *-\subsection{WhatsImported}-*                                                                      *-************************************************************************--}---- | Records whether a module has orphans. An \"orphan\" is one of:------ * An instance declaration in a module other than the definition---   module for one of the type constructors or classes in the instance head------ * A rewrite rule in a module other than the one defining---   the function in the head of the rule----type WhetherHasOrphans   = Bool---- | Does this module define family instances?-type WhetherHasFamInst = Bool---- | Dependency information about ALL modules and packages below this one--- in the import hierarchy.------ Invariant: the dependencies of a module @M@ never includes @M@.------ Invariant: none of the lists contain duplicates.-data Dependencies-  = Deps { dep_mods   :: [ModuleNameWithIsBoot]-                        -- ^ All home-package modules transitively below this one-                        -- I.e. modules that this one imports, or that are in the-                        --      dep_mods of those directly-imported modules--         , dep_pkgs   :: [(UnitId, Bool)]-                        -- ^ All packages transitively below this module-                        -- I.e. packages to which this module's direct imports belong,-                        --      or that are in the dep_pkgs of those modules-                        -- The bool indicates if the package is required to be-                        -- trusted when the module is imported as a safe import-                        -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names--         , dep_orphs  :: [Module]-                        -- ^ Transitive closure of orphan modules (whether-                        -- home or external pkg).-                        ---                        -- (Possible optimization: don't include family-                        -- instance orphans as they are anyway included in-                        -- 'dep_finsts'.  But then be careful about code-                        -- which relies on dep_orphs having the complete list!)-                        -- This does NOT include us, unlike 'imp_orphs'.--         , dep_finsts :: [Module]-                        -- ^ Transitive closure of depended upon modules which-                        -- contain family instances (whether home or external).-                        -- This is used by 'checkFamInstConsistency'.  This-                        -- does NOT include us, unlike 'imp_finsts'. See Note-                        -- [The type family instance consistency story].--         , dep_plgins :: [ModuleName]-                        -- ^ All the plugins used while compiling this module.-         }-  deriving( Eq )-        -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints-        -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.--instance Binary Dependencies where-    put_ bh deps = do put_ bh (dep_mods deps)-                      put_ bh (dep_pkgs deps)-                      put_ bh (dep_orphs deps)-                      put_ bh (dep_finsts deps)-                      put_ bh (dep_plgins deps)--    get bh = do ms <- get bh-                ps <- get bh-                os <- get bh-                fis <- get bh-                pl <- get bh-                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,-                               dep_finsts = fis, dep_plgins = pl })--noDependencies :: Dependencies-noDependencies = Deps [] [] [] [] []---- | Records modules for which changes may force recompilation of this module--- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance------ This differs from Dependencies.  A module X may be in the dep_mods of this--- module (via an import chain) but if we don't use anything from X it won't--- appear in our Usage-data Usage-  -- | Module from another package-  = UsagePackageModule {-        usg_mod      :: Module,-           -- ^ External package module depended on-        usg_mod_hash :: Fingerprint,-            -- ^ Cached module fingerprint-        usg_safe :: IsSafeImport-            -- ^ Was this module imported as a safe import-    }-  -- | Module from the current package-  | UsageHomeModule {-        usg_mod_name :: ModuleName,-            -- ^ Name of the module-        usg_mod_hash :: Fingerprint,-            -- ^ Cached module fingerprint-        usg_entities :: [(OccName,Fingerprint)],-            -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.-            -- NB: usages are for parent names only, e.g. type constructors-            -- but not the associated data constructors.-        usg_exports  :: Maybe Fingerprint,-            -- ^ Fingerprint for the export list of this module,-            -- if we directly imported it (and hence we depend on its export list)-        usg_safe :: IsSafeImport-            -- ^ Was this module imported as a safe import-    }                                           -- ^ Module from the current package-  -- | A file upon which the module depends, e.g. a CPP #include, or using TH's-  -- 'addDependentFile'-  | UsageFile {-        usg_file_path  :: FilePath,-        -- ^ External file dependency. From a CPP #include or TH-        -- addDependentFile. Should be absolute.-        usg_file_hash  :: Fingerprint-        -- ^ 'Fingerprint' of the file contents.--        -- Note: We don't consider things like modification timestamps-        -- here, because there's no reason to recompile if the actual-        -- contents don't change.  This previously lead to odd-        -- recompilation behaviors; see #8114-  }-  -- | A requirement which was merged into this one.-  | UsageMergedRequirement {-        usg_mod :: Module,-        usg_mod_hash :: Fingerprint-  }-    deriving( Eq )-        -- The export list field is (Just v) if we depend on the export list:-        --      i.e. we imported the module directly, whether or not we-        --           enumerated the things we imported, or just imported-        --           everything-        -- We need to recompile if M's exports change, because-        -- if the import was    import M,       we might now have a name clash-        --                                      in the importing module.-        -- if the import was    import M(x)     M might no longer export x-        -- The only way we don't depend on the export list is if we have-        --                      import M()-        -- And of course, for modules that aren't imported directly we don't-        -- depend on their export lists--instance Binary Usage where-    put_ bh usg@UsagePackageModule{} = do-        putByte bh 0-        put_ bh (usg_mod usg)-        put_ bh (usg_mod_hash usg)-        put_ bh (usg_safe     usg)--    put_ bh usg@UsageHomeModule{} = do-        putByte bh 1-        put_ bh (usg_mod_name usg)-        put_ bh (usg_mod_hash usg)-        put_ bh (usg_exports  usg)-        put_ bh (usg_entities usg)-        put_ bh (usg_safe     usg)--    put_ bh usg@UsageFile{} = do-        putByte bh 2-        put_ bh (usg_file_path usg)-        put_ bh (usg_file_hash usg)--    put_ bh usg@UsageMergedRequirement{} = do-        putByte bh 3-        put_ bh (usg_mod      usg)-        put_ bh (usg_mod_hash usg)--    get bh = do-        h <- getByte bh-        case h of-          0 -> do-            nm    <- get bh-            mod   <- get bh-            safe  <- get bh-            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }-          1 -> do-            nm    <- get bh-            mod   <- get bh-            exps  <- get bh-            ents  <- get bh-            safe  <- get bh-            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,-                     usg_exports = exps, usg_entities = ents, usg_safe = safe }-          2 -> do-            fp   <- get bh-            hash <- get bh-            return UsageFile { usg_file_path = fp, usg_file_hash = hash }-          3 -> do-            mod <- get bh-            hash <- get bh-            return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }-          i -> error ("Binary.get(Usage): " ++ show i)--{--************************************************************************-*                                                                      *-                The External Package State-*                                                                      *-************************************************************************--}--type PackageTypeEnv          = TypeEnv-type PackageRuleBase         = RuleBase-type PackageInstEnv          = InstEnv-type PackageFamInstEnv       = FamInstEnv-type PackageAnnEnv           = AnnEnv-type PackageCompleteMatchMap = CompleteMatchMap---- | Information about other packages that we have slurped in by reading--- their interface files-data ExternalPackageState-  = EPS {-        eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),-                -- ^ In OneShot mode (only), home-package modules-                -- accumulate in the external package state, and are-                -- sucked in lazily.  For these home-pkg modules-                -- (only) we need to record which are boot modules.-                -- We set this field after loading all the-                -- explicitly-imported interfaces, but before doing-                -- anything else-                ---                -- The 'ModuleName' part is not necessary, but it's useful for-                -- debug prints, and it's convenient because this field comes-                -- direct from 'GHC.Tc.Utils.imp_dep_mods'--        eps_PIT :: !PackageIfaceTable,-                -- ^ The 'ModIface's for modules in external packages-                -- whose interfaces we have opened.-                -- The declarations in these interface files are held in the-                -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'-                -- fields of this record, not in the 'mi_decls' fields of the-                -- interface we have sucked in.-                ---                -- What /is/ in the PIT is:-                ---                -- * The Module-                ---                -- * Fingerprint info-                ---                -- * Its exports-                ---                -- * Fixities-                ---                -- * Deprecations and warnings--        eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),-                -- ^ Cache for 'mi_free_holes'.  Ordinarily, we can rely on-                -- the 'eps_PIT' for this information, EXCEPT that when-                -- we do dependency analysis, we need to look at the-                -- 'Dependencies' of our imports to determine what their-                -- precise free holes are ('moduleFreeHolesPrecise').  We-                -- don't want to repeatedly reread in the interface-                -- for every import, so cache it here.  When the PIT-                -- gets filled in we can drop these entries.--        eps_PTE :: !PackageTypeEnv,-                -- ^ Result of typechecking all the external package-                -- interface files we have sucked in. The domain of-                -- the mapping is external-package modules--        eps_inst_env     :: !PackageInstEnv,   -- ^ The total 'InstEnv' accumulated-                                               -- from all the external-package modules-        eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated-                                               -- from all the external-package modules-        eps_rule_base    :: !PackageRuleBase,  -- ^ The total 'RuleEnv' accumulated-                                               -- from all the external-package modules-        eps_ann_env      :: !PackageAnnEnv,    -- ^ The total 'AnnEnv' accumulated-                                               -- from all the external-package modules-        eps_complete_matches :: !PackageCompleteMatchMap,-                                  -- ^ The total 'CompleteMatchMap' accumulated-                                  -- from all the external-package modules--        eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external-                                                         -- packages, keyed off the module that declared them--        eps_stats :: !EpsStats                 -- ^ Stastics about what was loaded from external packages-  }---- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.--- \"In\" means stuff that is just /read/ from interface files,--- \"Out\" means actually sucked in and type-checked-data EpsStats = EpsStats { n_ifaces_in-                         , n_decls_in, n_decls_out-                         , n_rules_in, n_rules_out-                         , n_insts_in, n_insts_out :: !Int }--addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats--- ^ Add stats for one newly-read interface-addEpsInStats stats n_decls n_insts n_rules-  = stats { n_ifaces_in = n_ifaces_in stats + 1-          , n_decls_in  = n_decls_in stats + n_decls-          , n_insts_in  = n_insts_in stats + n_insts-          , n_rules_in  = n_rules_in stats + n_rules }--{--Names in a NameCache are always stored as a Global, and have the SrcLoc-of their binding locations.--Actually that's not quite right.  When we first encounter the original-name, we might not be at its binding site (e.g. we are reading an-interface file); so we give it 'noSrcLoc' then.  Later, when we find-its binding site, we fix it up.--}--updNameCache :: IORef NameCache-             -> (NameCache -> (NameCache, c))  -- The updating function-             -> IO c-updNameCache ncRef upd_fn-  = atomicModifyIORef' ncRef upd_fn--mkSOName :: Platform -> FilePath -> FilePath-mkSOName platform root-    = case platformOS platform of-      OSMinGW32 ->           root  <.> soExt platform-      _         -> ("lib" ++ root) <.> soExt platform--mkHsSOName :: Platform -> FilePath -> FilePath-mkHsSOName platform root = ("lib" ++ root) <.> soExt platform--soExt :: Platform -> FilePath-soExt platform-    = case platformOS platform of-      OSDarwin  -> "dylib"-      OSMinGW32 -> "dll"-      _         -> "so"--{--************************************************************************-*                                                                      *-                The module graph and ModSummary type-        A ModSummary is a node in the compilation manager's-        dependency graph, and it's also passed to hscMain-*                                                                      *-************************************************************************--}---- | A ModuleGraph contains all the nodes from the home package (only).--- There will be a node for each source module, plus a node for each hi-boot--- module.------ The graph is not necessarily stored in topologically-sorted order.  Use--- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.-data ModuleGraph = ModuleGraph-  { mg_mss :: [ModSummary]-  , mg_non_boot :: ModuleEnv ModSummary-    -- a map of all non-boot ModSummaries keyed by Modules-  , mg_boot :: ModuleSet-    -- a set of boot Modules-  , mg_needs_th_or_qq :: !Bool-    -- does any of the modules in mg_mss require TemplateHaskell or-    -- QuasiQuotes?-  }---- | Determines whether a set of modules requires Template Haskell or--- Quasi Quotes------ Note that if the session's 'DynFlags' enabled Template Haskell when--- 'depanal' was called, then each module in the returned module graph will--- have Template Haskell enabled whether it is actually needed or not.-needsTemplateHaskellOrQQ :: ModuleGraph -> Bool-needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg---- | Map a function 'f' over all the 'ModSummaries'.--- To preserve invariants 'f' can't change the isBoot status.-mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph-mapMG f mg@ModuleGraph{..} = mg-  { mg_mss = map f mg_mss-  , mg_non_boot = mapModuleEnv f mg_non_boot-  }--mgBootModules :: ModuleGraph -> ModuleSet-mgBootModules ModuleGraph{..} = mg_boot--mgModSummaries :: ModuleGraph -> [ModSummary]-mgModSummaries = mg_mss--mgElemModule :: ModuleGraph -> Module -> Bool-mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot---- | Look up a ModSummary in the ModuleGraph-mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary-mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m--emptyMG :: ModuleGraph-emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False--isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool-isTemplateHaskellOrQQNonBoot ms =-  (xopt LangExt.TemplateHaskell (ms_hspp_opts ms)-    || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&-  (isBootSummary ms == NotBoot)---- | Add a ModSummary to ModuleGraph. Assumes that the new ModSummary is--- not an element of the ModuleGraph.-extendMG :: ModuleGraph -> ModSummary -> ModuleGraph-extendMG ModuleGraph{..} ms = ModuleGraph-  { mg_mss = ms:mg_mss-  , mg_non_boot = case isBootSummary ms of-      IsBoot -> mg_non_boot-      NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms-  , mg_boot = case isBootSummary ms of-      NotBoot -> mg_boot-      IsBoot -> extendModuleSet mg_boot (ms_mod ms)-  , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms-  }--mkModuleGraph :: [ModSummary] -> ModuleGraph-mkModuleGraph = foldr (flip extendMG) emptyMG---- | A single node in a 'ModuleGraph'. The nodes of the module graph--- are one of:------ * A regular Haskell source module--- * A hi-boot source module----data ModSummary-   = ModSummary {-        ms_mod          :: Module,-          -- ^ Identity of the module-        ms_hsc_src      :: HscSource,-          -- ^ The module source either plain Haskell or hs-boot-        ms_location     :: ModLocation,-          -- ^ Location of the various files belonging to the module-        ms_hs_date      :: UTCTime,-          -- ^ Timestamp of source file-        ms_obj_date     :: Maybe UTCTime,-          -- ^ Timestamp of object, if we have one-        ms_iface_date   :: Maybe UTCTime,-          -- ^ Timestamp of hi file, if we *only* are typechecking (it is-          -- 'Nothing' otherwise.-          -- See Note [Recompilation checking in -fno-code mode] and #9243-        ms_hie_date   :: Maybe UTCTime,-          -- ^ Timestamp of hie file, if we have one-        ms_srcimps      :: [(Maybe FastString, Located ModuleName)],-          -- ^ Source imports of the module-        ms_textual_imps :: [(Maybe FastString, Located ModuleName)],-          -- ^ Non-source imports of the module from the module *text*-        ms_parsed_mod   :: Maybe HsParsedModule,-          -- ^ The parsed, nonrenamed source, if we have it.  This is also-          -- used to support "inline module syntax" in Backpack files.-        ms_hspp_file    :: FilePath,-          -- ^ Filename of preprocessed source file-        ms_hspp_opts    :: DynFlags,-          -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@-          -- pragmas in the modules source code-        ms_hspp_buf     :: Maybe StringBuffer-          -- ^ The actual preprocessed source, if we have it-     }--ms_installed_mod :: ModSummary -> InstalledModule-ms_installed_mod = fst . getModuleInstantiation . ms_mod--ms_mod_name :: ModSummary -> ModuleName-ms_mod_name = moduleName . ms_mod--ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]-ms_imps ms =-  ms_textual_imps ms ++-  map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))-  where-    mk_additional_import mod_nm = (Nothing, noLoc mod_nm)--home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]-home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,-                                  isLocal mb_pkg ]-  where isLocal Nothing = True-        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special-        isLocal _ = False--ms_home_allimps :: ModSummary -> [ModuleName]-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)---- | Like 'ms_home_imps', but for SOURCE imports.-ms_home_srcimps :: ModSummary -> [Located ModuleName]-ms_home_srcimps = home_imps . ms_srcimps---- | All of the (possibly) home module imports from a--- 'ModSummary'; that is to say, each of these module names--- could be a home import if an appropriately named file--- existed.  (This is in contrast to package qualified--- imports, which are guaranteed not to be home imports.)-ms_home_imps :: ModSummary -> [Located ModuleName]-ms_home_imps = home_imps . ms_imps---- The ModLocation contains both the original source filename and the--- filename of the cleaned-up source file after all preprocessing has been--- done.  The point is that the summariser will have to cpp/unlit/whatever--- all files anyway, and there's no point in doing this twice -- just--- park the result in a temp file, put the name of it in the location,--- and let @compile@ read from that file on the way back up.---- The ModLocation is stable over successive up-sweeps in GHCi, wheres--- the ms_hs_date and imports can, of course, change--msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath-msHsFilePath  ms = expectJust "msHsFilePath" (ml_hs_file  (ms_location ms))-msHiFilePath  ms = ml_hi_file  (ms_location ms)-msObjFilePath ms = ml_obj_file (ms_location ms)--msDynObjFilePath :: ModSummary -> DynFlags -> FilePath-msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)---- | Did this 'ModSummary' originate from a hs-boot file?-isBootSummary :: ModSummary -> IsBootInterface-isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot--instance Outputable ModSummary where-   ppr ms-      = sep [text "ModSummary {",-             nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),-                          text "ms_mod =" <+> ppr (ms_mod ms)-                                <> text (hscSourceString (ms_hsc_src ms)) <> comma,-                          text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),-                          text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),-             char '}'-            ]--showModMsg :: DynFlags -> HscTarget -> Bool -> ModSummary -> String-showModMsg dflags target recomp mod_summary = showSDoc dflags $-   if gopt Opt_HideSourcePaths dflags-      then text mod_str-      else hsep $-         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')-         , char '('-         , text (op $ msHsFilePath mod_summary) <> char ','-         ] ++-         if gopt Opt_BuildDynamicToo dflags-            then [ text obj_file <> char ','-                 , text dyn_file-                 , char ')'-                 ]-            else [ text obj_file, char ')' ]-  where-    op       = normalise-    mod      = moduleName (ms_mod mod_summary)-    mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)-    dyn_file = op $ msDynObjFilePath mod_summary dflags-    obj_file = case target of-                HscInterpreted | recomp -> "interpreted"-                HscNothing              -> "nothing"-                _                       -> (op $ msObjFilePath mod_summary)--{--************************************************************************-*                                                                      *-\subsection{Recompilation}-*                                                                      *-************************************************************************--}---- | Indicates whether a given module's source has been modified since it--- was last compiled.-data SourceModified-  = SourceModified-       -- ^ the source has been modified-  | SourceUnmodified-       -- ^ the source has not been modified.  Compilation may or may-       -- not be necessary, depending on whether any dependencies have-       -- changed since we last compiled.-  | SourceUnmodifiedAndStable-       -- ^ the source has not been modified, and furthermore all of-       -- its (transitive) dependencies are up to date; it definitely-       -- does not need to be recompiled.  This is important for two-       -- reasons: (a) we can omit the version check in checkOldIface,-       -- and (b) if the module used TH splices we don't need to force-       -- recompilation.--{--************************************************************************-*                                                                      *-\subsection{Hpc Support}-*                                                                      *-************************************************************************--}---- | Information about a modules use of Haskell Program Coverage-data HpcInfo-  = HpcInfo-     { hpcInfoTickCount :: Int-     , hpcInfoHash      :: Int-     }-  | NoHpcInfo-     { hpcUsed          :: AnyHpcUsage  -- ^ Is hpc used anywhere on the module \*tree\*?-     }---- | This is used to signal if one of my imports used HPC instrumentation--- even if there is no module-local HPC usage-type AnyHpcUsage = Bool--emptyHpcInfo :: AnyHpcUsage -> HpcInfo-emptyHpcInfo = NoHpcInfo---- | Find out if HPC is used by this module or any of the modules--- it depends upon-isHpcUsed :: HpcInfo -> AnyHpcUsage-isHpcUsed (HpcInfo {})                   = True-isHpcUsed (NoHpcInfo { hpcUsed = used }) = used--{--************************************************************************-*                                                                      *-\subsection{Safe Haskell Support}-*                                                                      *-************************************************************************--This stuff here is related to supporting the Safe Haskell extension,-primarily about storing under what trust type a module has been compiled.--}---- | Is an import a safe import?-type IsSafeImport = Bool---- | Safe Haskell information for 'ModIface'--- Simply a wrapper around SafeHaskellMode to sepperate iface and flags-newtype IfaceTrustInfo = TrustInfo SafeHaskellMode--getSafeMode :: IfaceTrustInfo -> SafeHaskellMode-getSafeMode (TrustInfo x) = x--setSafeMode :: SafeHaskellMode -> IfaceTrustInfo-setSafeMode = TrustInfo--noIfaceTrustInfo :: IfaceTrustInfo-noIfaceTrustInfo = setSafeMode Sf_None--trustInfoToNum :: IfaceTrustInfo -> Word8-trustInfoToNum it-  = case getSafeMode it of-            Sf_None         -> 0-            Sf_Unsafe       -> 1-            Sf_Trustworthy  -> 2-            Sf_Safe         -> 3-            Sf_SafeInferred -> 4-            Sf_Ignore       -> 0--numToTrustInfo :: Word8 -> IfaceTrustInfo-numToTrustInfo 0 = setSafeMode Sf_None-numToTrustInfo 1 = setSafeMode Sf_Unsafe-numToTrustInfo 2 = setSafeMode Sf_Trustworthy-numToTrustInfo 3 = setSafeMode Sf_Safe-numToTrustInfo 4 = setSafeMode Sf_SafeInferred-numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"--instance Outputable IfaceTrustInfo where-    ppr (TrustInfo Sf_None)          = text "none"-    ppr (TrustInfo Sf_Ignore)        = text "none"-    ppr (TrustInfo Sf_Unsafe)        = text "unsafe"-    ppr (TrustInfo Sf_Trustworthy)   = text "trustworthy"-    ppr (TrustInfo Sf_Safe)          = text "safe"-    ppr (TrustInfo Sf_SafeInferred)  = text "safe-inferred"--instance Binary IfaceTrustInfo where-    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust-    get bh = getByte bh >>= (return . numToTrustInfo)--{--************************************************************************-*                                                                      *-\subsection{Parser result}-*                                                                      *-************************************************************************--}--data HsParsedModule = HsParsedModule {-    hpm_module    :: Located HsModule,-    hpm_src_files :: [FilePath],-       -- ^ extra source files (e.g. from #includes).  The lexer collects-       -- these from '# <file> <line>' pragmas, which the C preprocessor-       -- leaves behind.  These files and their timestamps are stored in-       -- the .hi file, so that we can force recompilation if any of-       -- them change (#3589)-    hpm_annotations :: ApiAnns-    -- See note [Api annotations] in GHC.Parser.Annotation-  }--{--************************************************************************-*                                                                      *-\subsection{Linkable stuff}-*                                                                      *-************************************************************************--This stuff is in here, rather than (say) in "GHC.Runtime.Linker", because the "GHC.Runtime.Linker"-stuff is the *dynamic* linker, and isn't present in a stage-1 compiler--}--isObjectLinkable :: Linkable -> Bool-isObjectLinkable l = not (null unlinked) && all isObject unlinked-  where unlinked = linkableUnlinked l-        -- A linkable with no Unlinked's is treated as a BCO.  We can-        -- generate a linkable with no Unlinked's as a result of-        -- compiling a module in HscNothing mode, and this choice-        -- happens to work well with checkStability in module GHC.--linkableObjs :: Linkable -> [FilePath]-linkableObjs l = [ f | DotO f <- linkableUnlinked l ]------------------------------------------------- | Is this an actual file on disk we can link in somehow?-isObject :: Unlinked -> Bool-isObject (DotO _)   = True-isObject (DotA _)   = True-isObject (DotDLL _) = True-isObject _          = False---- | Is this a bytecode linkable with no file on disk?-isInterpretable :: Unlinked -> Bool-isInterpretable = not . isObject---- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object-nameOfObject :: Unlinked -> FilePath-nameOfObject (DotO fn)   = fn-nameOfObject (DotA fn)   = fn-nameOfObject (DotDLL fn) = fn-nameOfObject other       = pprPanic "nameOfObject" (ppr other)---- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable-byteCodeOfObject :: Unlinked -> CompiledByteCode-byteCodeOfObject (BCOs bc _) = bc-byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)-------------------------------------------------- | A list of conlikes which represents a complete pattern match.--- These arise from @COMPLETE@ signatures.---- See Note [Implementation of COMPLETE signatures]-data CompleteMatch = CompleteMatch {-                            completeMatchConLikes :: [Name]-                            -- ^ The ConLikes that form a covering family-                            -- (e.g. Nothing, Just)-                          , completeMatchTyCon :: Name-                            -- ^ The TyCon that they cover (e.g. Maybe)-                          }--instance Outputable CompleteMatch where-  ppr (CompleteMatch cl ty) = text "CompleteMatch:" <+> ppr cl-                                                    <+> dcolon <+> ppr ty---- | A map keyed by the 'completeMatchTyCon' which has type Name.---- See Note [Implementation of COMPLETE signatures]-type CompleteMatchMap = UniqFM Name [CompleteMatch]--mkCompleteMatchMap :: [CompleteMatch] -> CompleteMatchMap-mkCompleteMatchMap = extendCompleteMatchMap emptyUFM--extendCompleteMatchMap :: CompleteMatchMap -> [CompleteMatch]-                       -> CompleteMatchMap-extendCompleteMatchMap = foldl' insertMatch-  where-    insertMatch :: CompleteMatchMap -> CompleteMatch -> CompleteMatchMap-    insertMatch ufm c@(CompleteMatch _ t) = addToUFM_C (++) ufm t [c]--{--Note [Implementation of COMPLETE signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A COMPLETE signature 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 with the CompleteMatch data-type. For example, {-# COMPLETE F, T #-} would be represented as:--  CompleteMatch { complateMatchConLikes = [F, T]-                , completeMatchTyCon    = Boolean }--Note that GHC was able to infer the completeMatchTyCon (Boolean), but for the-cases in which it's ambiguous, you can also explicitly specify it in the source-language by writing this:--  {-# COMPLETE F, T :: Boolean #-}--For efficiency purposes, GHC collects all of the CompleteMatches that it knows-about into a CompleteMatchMap, which is a map that is keyed by the-completeMatchTyCon. In other words, you could have a multiple COMPLETE sets-for the same TyCon:--  {-# COMPLETE F, T1 :: Boolean #-}-  {-# COMPLETE F, T2 :: Boolean #-}--And looking up the values in the CompleteMatchMap associated with Boolean-would give you [CompleteMatch [F, T1] Boolean, CompleteMatch [F, T2] Boolean].-dsGetCompleteMatches in GHC.HsToCore.Quote accomplishes this lookup.--Also see Note [Typechecking Complete Matches] in GHC.Tc.Gen.Bind for a more detailed-explanation for how GHC ensures that all the conlikes in a COMPLETE set are-consistent.--}---- | Foreign language of the phase if the phase deals with a foreign code-phaseForeignLanguage :: Phase -> Maybe ForeignSrcLang-phaseForeignLanguage phase = case phase of-  Phase.Cc           -> Just LangC-  Phase.Ccxx         -> Just LangCxx-  Phase.Cobjc        -> Just LangObjc-  Phase.Cobjcxx      -> Just LangObjcxx-  Phase.HCc          -> Just LangC-  Phase.As _         -> Just LangAsm-  Phase.MergeForeign -> Just RawObject-  _                  -> Nothing------------------------------------------------- Take care, this instance only forces to the degree necessary to--- avoid major space leaks.-instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where-  rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12-                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =-    rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`-    f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq`-    rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23-    `seq` rnf f24--{--************************************************************************-*                                                                      *-\subsection{Extensible Iface Fields}-*                                                                      *-************************************************************************--}--type FieldName = String--newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }--instance Binary ExtensibleFields where-  put_ bh (ExtensibleFields fs) = do-    put_ bh (Map.size fs :: Int)--    -- Put the names of each field, and reserve a space-    -- for a payload pointer after each name:-    header_entries <- forM (Map.toList fs) $ \(name, dat) -> do-      put_ bh name-      field_p_p <- tellBin bh-      put_ bh field_p_p-      return (field_p_p, dat)--    -- Now put the payloads and use the reserved space-    -- to point to the start of each payload:-    forM_ header_entries $ \(field_p_p, dat) -> do-      field_p <- tellBin bh-      putAt bh field_p_p field_p-      seekBin bh field_p-      put_ bh dat--  get bh = do-    n <- get bh :: IO Int--    -- Get the names and field pointers:-    header_entries <- replicateM n $ do-      (,) <$> get bh <*> get bh--    -- Seek to and get each field's payload:-    fields <- forM header_entries $ \(name, field_p) -> do-      seekBin bh field_p-      dat <- get bh-      return (name, dat)--    return . ExtensibleFields . Map.fromList $ fields--instance NFData ExtensibleFields where-  rnf (ExtensibleFields fs) = rnf fs--emptyExtensibleFields :: ExtensibleFields-emptyExtensibleFields = ExtensibleFields Map.empty------------------------------------------------------------------------------------- | Reading--readIfaceField :: Binary a => FieldName -> ModIface -> IO (Maybe a)-readIfaceField name = readIfaceFieldWith name get--readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)-readField name = readFieldWith name get--readIfaceFieldWith :: FieldName -> (BinHandle -> IO a) -> ModIface -> IO (Maybe a)-readIfaceFieldWith name read iface = readFieldWith name read (mi_ext_fields iface)--readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)-readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>-  Map.lookup name (getExtensibleFields fields)------------------------------------------------------------------------------------- | Writing--writeIfaceField :: Binary a => FieldName -> a -> ModIface -> IO ModIface-writeIfaceField name x = writeIfaceFieldWith name (`put_` x)--writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields-writeField name x = writeFieldWith name (`put_` x)--writeIfaceFieldWith :: FieldName -> (BinHandle -> IO ()) -> ModIface -> IO ModIface-writeIfaceFieldWith name write iface = do-  fields <- writeFieldWith name write (mi_ext_fields iface)-  return iface{ mi_ext_fields = fields }--writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields-writeFieldWith name write fields = do-  bh <- openBinMem (1024 * 1024)-  write bh-  ---  bd <- handleData bh-  return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)--deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields-deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs--deleteIfaceField :: FieldName -> ModIface -> ModIface-deleteIfaceField name iface = iface { mi_ext_fields = deleteField name (mi_ext_fields iface) }

− GHC/Driver/Ways.hs

@@ -1,202 +0,0 @@--- | Ways------ The central concept of a "way" is that all objects in a given--- program must be compiled in the same "way". Certain options change--- parameters of the virtual machine, eg. profiling adds an extra word--- to the object header, so profiling objects cannot be linked with--- non-profiling objects.------ After parsing the command-line options, we determine which "way" we--- are building - this might be a combination way, eg. profiling+threaded.------ There are two kinds of ways:---    - RTS only: only affect the runtime system (RTS) and don't affect code---    generation (e.g. threaded, debug)---    - Full ways: affect code generation and the RTS (e.g. profiling, dynamic---    linking)------ We then find the "build-tag" associated with this way, and this--- becomes the suffix used to find .hi files and libraries used in--- this compilation.-module GHC.Driver.Ways-   ( Way(..)-   , hasWay-   , allowed_combination-   , wayGeneralFlags-   , wayUnsetGeneralFlags-   , wayOptc-   , wayOptl-   , wayOptP-   , wayDesc-   , wayRTSOnly-   , wayTag-   , waysTag-   , waysBuildTag-   -- * Host GHC ways-   , hostFullWays-   , hostIsProfiled-   , hostIsDynamic-   )-where--import GHC.Prelude-import GHC.Platform-import GHC.Driver.Flags--import qualified Data.Set as Set-import Data.Set (Set)-import Data.List (intersperse)-import System.IO.Unsafe ( unsafeDupablePerformIO )---- | A way------ Don't change the constructor order as it us used by `waysTag` to create a--- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal).-data Way-  = WayCustom String -- ^ for GHC API clients building custom variants-  | WayThreaded      -- ^ (RTS only) Multithreaded runtime system-  | WayDebug         -- ^ Debugging, enable trace messages and extra checks-  | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports-  | WayEventLog      -- ^ (RTS only) enable event logging-  | WayDyn           -- ^ Dynamic linking-  deriving (Eq, Ord, Show)---- | Test if a ways is enabled-hasWay :: Set Way -> Way -> Bool-hasWay ws w = Set.member w ws---- | Check if a combination of ways is allowed-allowed_combination :: Set Way -> Bool-allowed_combination ways = not disallowed-  where-   disallowed = or [ hasWay ways x && hasWay ways y-                   | (x,y) <- couples-                   ]-   -- List of disallowed couples of ways-   couples = [] -- we don't have any disallowed combination of ways nowadays---- | Unique tag associated to a list of ways-waysTag :: Set Way -> String-waysTag = concat . intersperse "_" . map wayTag . Set.toAscList---- | Unique build-tag associated to a list of ways------ RTS only ways are filtered out because they have no impact on the build.-waysBuildTag :: Set Way -> String-waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws)----- | Unique build-tag associated to a way-wayTag :: Way -> String-wayTag (WayCustom xs) = xs-wayTag WayThreaded    = "thr"-wayTag WayDebug       = "debug"-wayTag WayDyn         = "dyn"-wayTag WayProf        = "p"-wayTag WayEventLog    = "l"---- | Return true for ways that only impact the RTS, not the generated code-wayRTSOnly :: Way -> Bool-wayRTSOnly (WayCustom {}) = False-wayRTSOnly WayDyn         = False-wayRTSOnly WayProf        = False-wayRTSOnly WayThreaded    = True-wayRTSOnly WayDebug       = True-wayRTSOnly WayEventLog    = True--wayDesc :: Way -> String-wayDesc (WayCustom xs) = xs-wayDesc WayThreaded    = "Threaded"-wayDesc WayDebug       = "Debug"-wayDesc WayDyn         = "Dynamic"-wayDesc WayProf        = "Profiling"-wayDesc WayEventLog    = "RTS Event Logging"---- | Turn these flags on when enabling this way-wayGeneralFlags :: Platform -> Way -> [GeneralFlag]-wayGeneralFlags _ (WayCustom {}) = []-wayGeneralFlags _ WayThreaded = []-wayGeneralFlags _ WayDebug    = []-wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]-    -- We could get away without adding -fPIC when compiling the-    -- modules of a program that is to be linked with -dynamic; the-    -- program itself does not need to be position-independent, only-    -- the libraries need to be.  HOWEVER, GHCi links objects into a-    -- .so before loading the .so using the system linker.  Since only-    -- PIC objects can be linked into a .so, we have to compile even-    -- modules of the main program with -fPIC when using -dynamic.-wayGeneralFlags _ WayProf     = []-wayGeneralFlags _ WayEventLog = []---- | Turn these flags off when enabling this way-wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]-wayUnsetGeneralFlags _ (WayCustom {}) = []-wayUnsetGeneralFlags _ WayThreaded = []-wayUnsetGeneralFlags _ WayDebug    = []-wayUnsetGeneralFlags _ WayDyn      = [Opt_SplitSections]-   -- There's no point splitting when we're going to be dynamically linking.-   -- Plus it breaks compilation on OSX x86.-wayUnsetGeneralFlags _ WayProf     = []-wayUnsetGeneralFlags _ WayEventLog = []---- | Pass these options to the C compiler when enabling this way-wayOptc :: Platform -> Way -> [String]-wayOptc _ (WayCustom {}) = []-wayOptc platform WayThreaded = case platformOS platform of-                               OSOpenBSD -> ["-pthread"]-                               OSNetBSD  -> ["-pthread"]-                               _         -> []-wayOptc _ WayDebug      = []-wayOptc _ WayDyn        = []-wayOptc _ WayProf       = ["-DPROFILING"]-wayOptc _ WayEventLog   = ["-DTRACING"]---- | Pass these options to linker when enabling this way-wayOptl :: Platform -> Way -> [String]-wayOptl _ (WayCustom {}) = []-wayOptl platform WayThreaded =-   case platformOS platform of-   -- N.B. FreeBSD cc throws a warning if we pass -pthread without-   -- actually using any pthread symbols.-   OSFreeBSD  -> ["-pthread", "-Wno-unused-command-line-argument"]-   OSOpenBSD  -> ["-pthread"]-   OSNetBSD   -> ["-pthread"]-   _          -> []-wayOptl _ WayDebug      = []-wayOptl _ WayDyn        = []-wayOptl _ WayProf       = []-wayOptl _ WayEventLog   = []---- | Pass these options to the preprocessor when enabling this way-wayOptP :: Platform -> Way -> [String]-wayOptP _ (WayCustom {}) = []-wayOptP _ WayThreaded = []-wayOptP _ WayDebug    = []-wayOptP _ WayDyn      = []-wayOptP _ WayProf     = ["-DPROFILING"]-wayOptP _ WayEventLog = ["-DTRACING"]----- | Consult the RTS to find whether it has been built with profiling enabled.-hostIsProfiled :: Bool-hostIsProfiled = unsafeDupablePerformIO rtsIsProfiledIO /= 0--foreign import ccall unsafe "rts_isProfiled" rtsIsProfiledIO :: IO Int---- | Consult the RTS to find whether GHC itself has been built with--- dynamic linking.  This can't be statically known at compile-time,--- because we build both the static and dynamic versions together with--- -dynamic-too.-hostIsDynamic :: Bool-hostIsDynamic = unsafeDupablePerformIO rtsIsDynamicIO /= 0--foreign import ccall unsafe "rts_isDynamic" rtsIsDynamicIO :: IO Int---- | Return host "full" ways (i.e. ways that have an impact on the compilation,--- not RTS only ways). These ways must be used when compiling codes targeting--- the internal interpreter.-hostFullWays :: Set Way-hostFullWays = Set.unions-   [ if hostIsDynamic  then Set.singleton WayDyn  else Set.empty-   , if hostIsProfiled then Set.singleton WayProf else Set.empty-   ]

GHC/Hs.hs view

@@ -13,12 +13,13 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension+                                      -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data  module GHC.Hs (+        module Language.Haskell.Syntax,         module GHC.Hs.Binds,         module GHC.Hs.Decls,         module GHC.Hs.Expr,@@ -29,9 +30,11 @@         module GHC.Hs.Utils,         module GHC.Hs.Doc,         module GHC.Hs.Extension,+        module GHC.Parser.Annotation,         Fixity, -        HsModule(..),+        HsModule(..), AnnsModule(..),+        HsParsedModule(..) ) where  -- friends:@@ -42,18 +45,21 @@ import GHC.Hs.Expr import GHC.Hs.ImpExp import GHC.Hs.Lit+import Language.Haskell.Syntax import GHC.Hs.Extension+import GHC.Parser.Annotation import GHC.Hs.Pat import GHC.Hs.Type-import GHC.Types.Basic ( Fixity, WarningTxt ) import GHC.Hs.Utils import GHC.Hs.Doc import GHC.Hs.Instances () -- For Data instances  -- others: import GHC.Utils.Outputable+import GHC.Types.Fixity         ( Fixity ) import GHC.Types.SrcLoc-import GHC.Unit.Module ( ModuleName )+import GHC.Unit.Module          ( ModuleName )+import GHC.Unit.Module.Warnings ( WarningTxt )  -- libraries: import Data.Data hiding ( Fixity )@@ -63,13 +69,14 @@ -- All we actually declare here is the top-level structure for a module. data HsModule   = HsModule {+      hsmodAnn :: EpAnn AnnsModule,       hsmodLayout :: LayoutInfo,         -- ^ Layout info for the module.         -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.-      hsmodName :: Maybe (Located ModuleName),+      hsmodName :: Maybe (LocatedA ModuleName),         -- ^ @Nothing@: \"module X where\" is omitted (in which case the next         --     field is Nothing too)-      hsmodExports :: Maybe (Located [LIE GhcPs]),+      hsmodExports :: Maybe (LocatedL [LIE GhcPs]),         -- ^ Export list         --         --  - @Nothing@: export list omitted, so export everything@@ -82,28 +89,28 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'         --                                   ,'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation       hsmodImports :: [LImportDecl GhcPs],         -- ^ We snaffle interesting stuff out of the imported interfaces early         -- on, adding that info to TyDecls/etc; so this list is often empty,         -- downstream.       hsmodDecls :: [LHsDecl GhcPs],         -- ^ Type, class, value, and interface signature decls-      hsmodDeprecMessage :: Maybe (Located WarningTxt),+      hsmodDeprecMessage :: Maybe (LocatedP WarningTxt),         -- ^ reason\/explanation for warning/deprecation of this module         --         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'         --                                   ,'GHC.Parser.Annotation.AnnClose'         -- -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation       hsmodHaddockModHeader :: Maybe LHsDocString         -- ^ Haddock module info and description, unparsed         --         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'         --                                   ,'GHC.Parser.Annotation.AnnClose' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation    }      -- ^ 'GHC.Parser.Annotation.AnnKeywordId's      --@@ -113,17 +120,23 @@      --    'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around      --    hsmodImports,hsmodDecls if this style is used. -     -- For details on above see note [Api annotations] in GHC.Parser.Annotation+     -- For details on above see note [exact print annotations] in GHC.Parser.Annotation  deriving instance Data HsModule +data AnnsModule+  = AnnsModule {+    am_main :: [AddEpAnn],+    am_decls :: AnnList+    } deriving (Data, Eq)+ instance Outputable HsModule where -    ppr (HsModule _ Nothing _ imports decls _ mbDoc)+    ppr (HsModule _ _ Nothing _ imports decls _ mbDoc)       = pp_mb mbDoc $$ pp_nonnull imports                     $$ pp_nonnull decls -    ppr (HsModule _ (Just name) exports imports decls deprec mbDoc)+    ppr (HsModule _ _ (Just name) exports imports decls deprec mbDoc)       = vcat [             pp_mb mbDoc,             case exports of@@ -150,3 +163,13 @@ pp_nonnull :: Outputable t => [t] -> SDoc pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs)++data HsParsedModule = HsParsedModule {+    hpm_module    :: Located HsModule,+    hpm_src_files :: [FilePath]+       -- ^ extra source files (e.g. from #includes).  The lexer collects+       -- these from '# <file> <line>' pragmas, which the C preprocessor+       -- leaves behind.  These files and their timestamps are stored in+       -- the .hi file, so that we can force recompilation if any of+       -- them change (#3589)+  }

GHC/Hs/Binds.hs view

@@ -1,3 +1,17 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -7,46 +21,41 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-}--module GHC.Hs.Binds where+module GHC.Hs.Binds+  ( module Language.Haskell.Syntax.Binds+  , module GHC.Hs.Binds+  ) where  import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, LHsExpr,-                                    MatchGroup, pprFunBind,-                                    GRHSs, pprPatBind )-import {-# SOURCE #-} GHC.Hs.Pat  ( LPat )+import Language.Haskell.Syntax.Binds +import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprFunBind, pprPatBind )+import {-# SOURCE #-} GHC.Hs.Pat  (pprLPat )++import Language.Haskell.Syntax.Extension import GHC.Hs.Extension+import GHC.Parser.Annotation import GHC.Hs.Type-import GHC.Core import GHC.Tc.Types.Evidence import GHC.Core.Type import GHC.Types.Name.Set import GHC.Types.Basic-import GHC.Utils.Outputable+import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Var import GHC.Data.Bag import GHC.Data.FastString import GHC.Data.BooleanFormula (LBooleanFormula)+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Id -import Data.Data hiding ( Fixity )-import Data.List hiding ( foldr )+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Data.List (sortBy) import Data.Function+import Data.Data (Data)  {- ************************************************************************@@ -58,76 +67,14 @@ Global bindings (where clauses) -} --- During renaming, we need bindings where the left-hand sides--- have been renamed but the right-hand sides have not. -- the ...LR datatypes are parametrized by two id types, -- one for the left and one for the right.--- Other than during renaming, these will be the same. --- | Haskell Local Bindings-type HsLocalBinds id = HsLocalBindsLR id id---- | Located Haskell local bindings-type LHsLocalBinds id = Located (HsLocalBinds id)---- | Haskell Local Bindings with separate Left and Right identifier types------ Bindings in a 'let' expression--- or a 'where' clause-data HsLocalBindsLR idL idR-  = HsValBinds-        (XHsValBinds idL idR)-        (HsValBindsLR idL idR)-      -- ^ Haskell Value Bindings--         -- There should be no pattern synonyms in the HsValBindsLR-         -- These are *local* (not top level) bindings-         -- The parser accepts them, however, leaving the-         -- renamer to report them--  | HsIPBinds-        (XHsIPBinds idL idR)-        (HsIPBinds idR)-      -- ^ Haskell Implicit Parameter Bindings--  | EmptyLocalBinds (XEmptyLocalBinds idL idR)-      -- ^ Empty Local Bindings--  | XHsLocalBindsLR-        !(XXHsLocalBindsLR idL idR)--type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = NoExtField-type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = NoExtField+type instance XHsValBinds      (GhcPass pL) (GhcPass pR) = EpAnn AnnList+type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = EpAnn AnnList type instance XEmptyLocalBinds (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsLocalBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon -type LHsLocalBindsLR idL idR = Located (HsLocalBindsLR idL idR)----- | Haskell Value Bindings-type HsValBinds id = HsValBindsLR id id---- | Haskell Value bindings with separate Left and Right identifier types--- (not implicit parameters)--- Used for both top level and nested bindings--- May contain pattern synonym bindings-data HsValBindsLR idL idR-  = -- | Value Bindings In-    ---    -- Before renaming RHS; idR is always RdrName-    -- Not dependency analysed-    -- Recursive by default-    ValBinds-        (XValBinds idL idR)-        (LHsBindsLR idL idR) [LSig idR]--    -- | Value Bindings Out-    ---    -- After renaming RHS; idR can be Name or Id Dependency analysed,-    -- later bindings in the list may depend on earlier ones.-  | XValBindsLR-      !(XXValBindsLR idL idR)- -- --------------------------------------------------------------------- -- Deal with ValBindsOut @@ -137,249 +84,29 @@       [(RecFlag, LHsBinds idL)]       [LSig GhcRn] -type instance XValBinds    (GhcPass pL) (GhcPass pR) = NoExtField+type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey type instance XXValBindsLR (GhcPass pL) (GhcPass pR)             = NHsValBindsLR (GhcPass pL)  -- --------------------------------------------------------------------- --- | Located Haskell Binding-type LHsBind  id = LHsBindLR  id id---- | Located Haskell Bindings-type LHsBinds id = LHsBindsLR id id---- | Haskell Binding-type HsBind   id = HsBindLR   id id---- | Located Haskell Bindings with separate Left and Right identifier types-type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)---- | Located Haskell Binding with separate Left and Right identifier types-type LHsBindLR  idL idR = Located (HsBindLR idL idR)--{- Note [FunBind vs PatBind]-   ~~~~~~~~~~~~~~~~~~~~~~~~~-The distinction between FunBind and PatBind is a bit subtle. FunBind covers-patterns which resemble function bindings and simple variable bindings.--    f x = e-    f !x = e-    f = e-    !x = e          -- FunRhs has SrcStrict-    x `f` y = e     -- FunRhs has Infix--The actual patterns and RHSs of a FunBind are encoding in fun_matches.-The m_ctxt field of each Match in fun_matches will be FunRhs and carries-two bits of information about the match,--  * The mc_fixity field on each Match describes the fixity of the-    function binder in that match.  E.g. this is legal:-         f True False  = e1-         True `f` True = e2--  * The mc_strictness field is used /only/ for nullary FunBinds: ones-    with one Match, which has no pats. For these, it describes whether-    the match is decorated with a bang (e.g. `!x = e`).--By contrast, PatBind represents data constructor patterns, as well as a few-other interesting cases. Namely,--    Just x = e-    (x) = e-    x :: Ty = e--}---- | Haskell Binding with separate Left and Right id's-data HsBindLR idL idR-  = -- | Function-like Binding-    ---    -- FunBind is used for both functions     @f x = e@-    -- and variables                          @f = \x -> e@-    -- and strict variables                   @!x = x + 1@-    ---    -- Reason 1: Special case for type inference: see 'GHC.Tc.Gen.Bind.tcMonoBinds'.-    ---    -- Reason 2: Instance decls can only have FunBinds, which is convenient.-    --           If you change this, you'll need to change e.g. rnMethodBinds-    ---    -- But note that the form                 @f :: a->a = ...@-    -- parses as a pattern binding, just like-    --                                        @(f :: a -> a) = ... @-    ---    -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their-    -- 'MatchContext'. See Note [FunBind vs PatBind] for-    -- details about the relationship between FunBind and PatBind.-    ---    --  'GHC.Parser.Annotation.AnnKeywordId's-    ---    --  - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches-    ---    --  - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',-    --    'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation-    FunBind {--        fun_ext :: XFunBind idL idR,--          -- ^ After the renamer (but before the type-checker), this contains the-          -- locally-bound free variables of this defn. See Note [Bind free vars]-          ---          -- After the type-checker, this contains a coercion from the type of-          -- the MatchGroup to the type of the Id. Example:-          ---          -- @-          --      f :: Int -> forall a. a -> a-          --      f x y = y-          -- @-          ---          -- Then the MatchGroup will have type (Int -> a' -> a')-          -- (with a free type variable a').  The coercion will take-          -- a CoreExpr of this type and convert it to a CoreExpr of-          -- type         Int -> forall a'. a' -> a'-          -- Notice that the coercion captures the free a'.--        fun_id :: Located (IdP idL), -- Note [fun_id in Match] in GHC.Hs.Expr--        fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload--        fun_tick :: [Tickish Id] -- ^ Ticks to put on the rhs, if any-    }--  -- | Pattern Binding-  ---  -- The pattern is never a simple variable;-  -- That case is done by FunBind.-  -- See Note [FunBind vs PatBind] for details about the-  -- relationship between FunBind and PatBind.--  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang',-  --       'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',-  --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | PatBind {-        pat_ext    :: XPatBind idL idR, -- ^ See Note [Bind free vars]-        pat_lhs    :: LPat idL,-        pat_rhs    :: GRHSs idR (LHsExpr idR),-        pat_ticks  :: ([Tickish Id], [[Tickish Id]])-               -- ^ Ticks to put on the rhs, if any, and ticks to put on-               -- the bound variables.-    }--  -- | Variable Binding-  ---  -- Dictionary binding and suchlike.-  -- All VarBinds are introduced by the type checker-  | VarBind {-        var_ext    :: XVarBind idL idR,-        var_id     :: IdP idL,-        var_rhs    :: LHsExpr idR    -- ^ Located only for consistency-    }--  -- | Abstraction Bindings-  | AbsBinds {                      -- Binds abstraction; TRANSLATION-        abs_ext     :: XAbsBinds idL idR,-        abs_tvs     :: [TyVar],-        abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints--       -- | AbsBinds only gets used when idL = idR after renaming,-       -- but these need to be idL's for the collect... code in HsUtil-       -- to have the right type-        abs_exports :: [ABExport idL],--        -- | Evidence bindings-        -- Why a list? See "GHC.Tc.TyCl.Instance"-        -- Note [Typechecking plan for instance declarations]-        abs_ev_binds :: [TcEvBinds],--        -- | Typechecked user bindings-        abs_binds    :: LHsBinds idL,--        abs_sig :: Bool  -- See Note [The abs_sig field of AbsBinds]-    }--  -- | Patterns Synonym Binding-  | PatSynBind-        (XPatSynBind idL idR)-        (PatSynBind idL idR)-        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',-        --          'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual',-        --          'GHC.Parser.Annotation.AnnWhere'-        --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | XHsBindsLR !(XXHsBindsLR idL idR)--data NPatBindTc = NPatBindTc {-     pat_fvs :: NameSet, -- ^ Free variables-     pat_rhs_ty :: Type  -- ^ Type of the GRHSs-     } deriving Data- type instance XFunBind    (GhcPass pL) GhcPs = NoExtField type instance XFunBind    (GhcPass pL) GhcRn = NameSet    -- Free variables type instance XFunBind    (GhcPass pL) GhcTc = HsWrapper  -- See comments on FunBind.fun_ext -type instance XPatBind    GhcPs (GhcPass pR) = NoExtField+type instance XPatBind    GhcPs (GhcPass pR) = EpAnn [AddEpAnn] type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- Free variables-type instance XPatBind    GhcTc (GhcPass pR) = NPatBindTc+type instance XPatBind    GhcTc (GhcPass pR) = Type    -- Type of the GRHSs  type instance XVarBind    (GhcPass pL) (GhcPass pR) = NoExtField type instance XAbsBinds   (GhcPass pL) (GhcPass pR) = NoExtField type instance XPatSynBind (GhcPass pL) (GhcPass pR) = NoExtField type instance XXHsBindsLR (GhcPass pL) (GhcPass pR) = NoExtCon --        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]-        ---        -- Creates bindings for (polymorphic, overloaded) poly_f-        -- in terms of monomorphic, non-overloaded mono_f-        ---        -- Invariants:-        --      1. 'binds' binds mono_f-        --      2. ftvs is a subset of tvs-        --      3. ftvs includes all tyvars free in ds-        ---        -- See Note [AbsBinds]---- | Abstraction Bindings Export-data ABExport p-  = ABE { abe_ext       :: XABE p-        , abe_poly      :: IdP p -- ^ Any INLINE pragma is attached to this Id-        , abe_mono      :: IdP p-        , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]-             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly-        , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas-        }-   | XABExport !(XXABExport p)- type instance XABE       (GhcPass p) = NoExtField type instance XXABExport (GhcPass p) = NoExtCon ---- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',---             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow',---             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@,---             'GHC.Parser.Annotation.AnnClose' @'}'@,---- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | Pattern Synonym binding-data PatSynBind idL idR-  = PSB { psb_ext  :: XPSB idL idR,            -- ^ Post renaming, FVs.-                                               -- See Note [Bind free vars]-          psb_id   :: Located (IdP idL),       -- ^ Name of the pattern synonym-          psb_args :: HsPatSynDetails (Located (IdP idR)),-                                               -- ^ Formal parameter names-          psb_def  :: LPat idR,                -- ^ Right-hand side-          psb_dir  :: HsPatSynDir idR          -- ^ Directionality-     }-   | XPatSynBind !(XXPatSynBind idL idR)--type instance XPSB         (GhcPass idL) GhcPs = NoExtField+type instance XPSB         (GhcPass idL) GhcPs = EpAnn [AddEpAnn] type instance XPSB         (GhcPass idL) GhcRn = NameSet type instance XPSB         (GhcPass idL) GhcTc = NameSet @@ -660,8 +387,8 @@   where      decls :: [(SrcSpan, SDoc)]-    decls = [(loc, ppr sig)  | L loc sig <- sigs] ++-            [(loc, ppr bind) | L loc bind <- bagToList binds]+    decls = [(locA loc, ppr sig)  | L loc sig <- sigs] +++            [(locA loc, ppr bind) | L loc bind <- bagToList binds]      sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls @@ -689,20 +416,20 @@ isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs  emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)-emptyValBindsIn  = ValBinds noExtField emptyBag []+emptyValBindsIn  = ValBinds NoAnnSortKey emptyBag [] emptyValBindsOut = XValBindsLR (NValBinds [] []) -emptyLHsBinds :: LHsBindsLR idL idR+emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR emptyLHsBinds = emptyBag -isEmptyLHsBinds :: LHsBindsLR idL idR -> Bool+isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool isEmptyLHsBinds = isEmptyBag  ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)                -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)-  = ValBinds noExtField (ds1 `unionBags` ds2) (sigs1 ++ sigs2)+  = ValBinds NoAnnSortKey (ds1 `unionBags` ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))                (XValBindsLR (NValBinds ds2 sigs2))   = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))@@ -756,21 +483,35 @@            , nest 2 (pprTcSpecPrags prags)            , pprIfTc @p $ nest 2 (text "wrap:" <+> ppr wrap) ] -instance (OutputableBndrId l, OutputableBndrId r,-         Outputable (XXPatSynBind (GhcPass l) (GhcPass r)))+instance (OutputableBndrId l, OutputableBndrId r)           => Outputable (PatSynBind (GhcPass l) (GhcPass r)) where   ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,             psb_dir = dir })       = ppr_lhs <+> ppr_rhs     where       ppr_lhs = text "pattern" <+> ppr_details-      ppr_simple syntax = syntax <+> ppr pat+      ppr_simple syntax = syntax <+> pprLPat pat        ppr_details = case details of-          InfixCon v1 v2 -> hsep [ppr v1, pprInfixOcc psyn, ppr v2]-          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr vs)+          InfixCon v1 v2 -> hsep [ppr_v v1, pprInfixOcc psyn, ppr_v  v2]+            where+                ppr_v v = case ghcPass @r of+                    GhcPs -> ppr v+                    GhcRn -> ppr v+                    GhcTc -> ppr v+          PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr_v vs)+            where+                ppr_v v = case ghcPass @r of+                    GhcPs -> ppr v+                    GhcRn -> ppr v+                    GhcTc -> ppr v           RecCon vs      -> pprPrefixOcc psyn-                            <> braces (sep (punctuate comma (map ppr vs)))+                            <> braces (sep (punctuate comma (map ppr_v vs)))+            where+                ppr_v v = case ghcPass @r of+                    GhcPs -> ppr v+                    GhcRn -> ppr v+                    GhcTc -> ppr v        ppr_rhs = case dir of           Unidirectional           -> ppr_simple (text "<-")@@ -798,15 +539,6 @@ ************************************************************************ -} --- | Haskell Implicit Parameter Bindings-data HsIPBinds id-  = IPBinds-        (XIPBinds id)-        [LIPBind id]-        -- TcEvBinds       -- Only in typechecker output; binds-        --                 -- uses of the implicit parameters-  | XHsIPBinds !(XXHsIPBinds id)- type instance XIPBinds       GhcPs = NoExtField type instance XIPBinds       GhcRn = NoExtField type instance XIPBinds       GhcTc = TcEvBinds -- binds uses of the@@ -821,31 +553,7 @@ isEmptyIPBindsTc :: HsIPBinds GhcTc -> Bool isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds --- | Located Implicit Parameter Binding-type LIPBind id = Located (IPBind id)--- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a---   list---- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | Implicit parameter bindings.------ These bindings start off as (Left "x") in the parser and stay--- that way until after type-checking when they are replaced with--- (Right d), where "d" is the name of the dictionary holding the--- evidence for the implicit parameter.------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'---- For details on above see note [Api annotations] in GHC.Parser.Annotation-data IPBind id-  = IPBind-        (XCIPBind id)-        (Either (Located HsIPName) (IdP id))-        (LHsExpr id)-  | XIPBind !(XXIPBind id)--type instance XCIPBind    (GhcPass p) = NoExtField+type instance XCIPBind    (GhcPass p) = EpAnn [AddEpAnn] type instance XXIPBind    (GhcPass p) = NoExtCon  instance OutputableBndrId p@@ -865,295 +573,37 @@ \subsection{@Sig@: type signatures and value-modifying user pragmas} *                                                                      * ************************************************************************--It is convenient to lump ``value-modifying'' user-pragmas (e.g.,-``specialise this function to these four types...'') in with type-signatures.  Then all the machinery to move them into place, etc.,-serves for both. -} --- | Located Signature-type LSig pass = Located (Sig pass)---- | Signatures and pragmas-data Sig pass-  =   -- | An ordinary type signature-      ---      -- > f :: Num a => a -> a-      ---      -- After renaming, this list of Names contains the named-      -- wildcards brought into scope by this signature. For a signature-      -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@-      -- untouched, and the named wildcard @_a@ is then replaced with-      -- fresh meta vars in the type. Their names are stored in the type-      -- signature that brought them into scope, in this third field to be-      -- more specific.-      ---      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon',-      --          'GHC.Parser.Annotation.AnnComma'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-    TypeSig-       (XTypeSig pass)-       [Located (IdP pass)]  -- LHS of the signature; e.g.  f,g,h :: blah-       (LHsSigWcType pass)   -- RHS of the signature; can have wildcards--      -- | A pattern synonym type signature-      ---      -- > pattern Single :: () => (Show a) => a -> [a]-      ---      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',-      --           'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall'-      --           'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | PatSynSig (XPatSynSig pass) [Located (IdP pass)] (LHsSigType pass)-      -- P :: forall a b. Req => Prov => ty--      -- | A signature for a class method-      --   False: ordinary class-method signature-      --   True:  generic-default class method signature-      -- e.g.   class C a where-      --          op :: a -> a                   -- Ordinary-      --          default op :: Eq a => a -> a   -- Generic default-      -- No wildcards allowed here-      ---      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',-      --           'GHC.Parser.Annotation.AnnDcolon'-  | ClassOpSig (XClassOpSig pass) Bool [Located (IdP pass)] (LHsSigType pass)--        -- | A type signature in generated code, notably the code-        -- generated for record selectors.  We simply record-        -- the desired Id itself, replete with its name, type-        -- and IdDetails.  Otherwise it's just like a type-        -- signature: there should be an accompanying binding-  | IdSig (XIdSig pass) Id--        -- | An ordinary fixity declaration-        ---        -- >     infixl 8 ***-        ---        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix',-        --           'GHC.Parser.Annotation.AnnVal'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | FixSig (XFixSig pass) (FixitySig pass)--        -- | An inline pragma-        ---        -- > {#- INLINE f #-}-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' :-        --       'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@,-        --       'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen',-        --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde',-        --       'GHC.Parser.Annotation.AnnClose'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | InlineSig   (XInlineSig pass)-                (Located (IdP pass)) -- Function name-                InlinePragma         -- Never defaultInlinePragma--        -- | A specialisation pragma-        ---        -- > {-# SPECIALISE f :: Int -> Int #-}-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --      'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,-        --      'GHC.Parser.Annotation.AnnTilde',-        --      'GHC.Parser.Annotation.AnnVal',-        --      'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@,-        --      'GHC.Parser.Annotation.AnnDcolon'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | SpecSig     (XSpecSig pass)-                (Located (IdP pass)) -- Specialise a function or datatype  ...-                [LHsSigType pass]  -- ... to these types-                InlinePragma       -- The pragma on SPECIALISE_INLINE form.-                                   -- If it's just defaultInlinePragma, then we said-                                   --    SPECIALISE, not SPECIALISE_INLINE--        -- | A specialisation pragma for instance declarations only-        ---        -- > {-# SPECIALISE instance Eq [Int] #-}-        ---        -- (Class tys); should be a specialisation of the-        -- current instance declaration-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --      'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)-                  -- Note [Pragma source text] in GHC.Types.Basic--        -- | A minimal complete definition pragma-        ---        -- > {-# MINIMAL a | (b, c | (d | e)) #-}-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --      'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma',-        --      'GHC.Parser.Annotation.AnnClose'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | MinimalSig (XMinimalSig pass)-               SourceText (LBooleanFormula (Located (IdP pass)))-               -- Note [Pragma source text] in GHC.Types.Basic--        -- | A "set cost centre" pragma for declarations-        ---        -- > {-# SCC funName #-}-        ---        -- or-        ---        -- > {-# SCC funName "cost_centre_name" #-}--  | SCCFunSig  (XSCCFunSig pass)-               SourceText      -- Note [Pragma source text] in GHC.Types.Basic-               (Located (IdP pass))  -- Function name-               (Maybe (Located StringLiteral))-       -- | A complete match pragma-       ---       -- > {-# COMPLETE C, D [:: T] #-}-       ---       -- Used to inform the pattern match checker about additional-       -- complete matchings which, for example, arise from pattern-       -- synonym definitions.-  | CompleteMatchSig (XCompleteMatchSig pass)-                     SourceText-                     (Located [Located (IdP pass)])-                     (Maybe (Located (IdP pass)))-  | XSig !(XXSig pass)+type instance XTypeSig          (GhcPass p) = EpAnn AnnSig+type instance XPatSynSig        (GhcPass p) = EpAnn AnnSig+type instance XClassOpSig       (GhcPass p) = EpAnn AnnSig+type instance XIdSig            (GhcPass p) = NoExtField -- No anns, generated+type instance XFixSig           (GhcPass p) = EpAnn [AddEpAnn]+type instance XInlineSig        (GhcPass p) = EpAnn [AddEpAnn]+type instance XSpecSig          (GhcPass p) = EpAnn [AddEpAnn]+type instance XSpecInstSig      (GhcPass p) = EpAnn [AddEpAnn]+type instance XMinimalSig       (GhcPass p) = EpAnn [AddEpAnn]+type instance XSCCFunSig        (GhcPass p) = EpAnn [AddEpAnn]+type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XTypeSig          (GhcPass p) = NoExtField-type instance XPatSynSig        (GhcPass p) = NoExtField-type instance XClassOpSig       (GhcPass p) = NoExtField-type instance XIdSig            (GhcPass p) = NoExtField-type instance XFixSig           (GhcPass p) = NoExtField-type instance XInlineSig        (GhcPass p) = NoExtField-type instance XSpecSig          (GhcPass p) = NoExtField-type instance XSpecInstSig      (GhcPass p) = NoExtField-type instance XMinimalSig       (GhcPass p) = NoExtField-type instance XSCCFunSig        (GhcPass p) = NoExtField-type instance XCompleteMatchSig (GhcPass p) = NoExtField type instance XXSig             (GhcPass p) = NoExtCon --- | Located Fixity Signature-type LFixitySig pass = Located (FixitySig pass)---- | Fixity Signature-data FixitySig pass = FixitySig (XFixitySig pass) [Located (IdP pass)] Fixity-                    | XFixitySig !(XXFixitySig pass)- type instance XFixitySig  (GhcPass p) = NoExtField type instance XXFixitySig (GhcPass p) = NoExtCon --- | Type checker Specialisation Pragmas------ 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer-data TcSpecPrags-  = IsDefaultMethod     -- ^ Super-specialised: a default method should-                        -- be macro-expanded at every call site-  | SpecPrags [LTcSpecPrag]-  deriving Data---- | Located Type checker Specification Pragmas-type LTcSpecPrag = Located TcSpecPrag---- | Type checker Specification Pragma-data TcSpecPrag-  = SpecPrag-        Id-        HsWrapper-        InlinePragma-  -- ^ The Id to be specialised, a wrapper that specialises the-  -- polymorphic function, and inlining spec for the specialised function-  deriving Data--noSpecPrags :: TcSpecPrags-noSpecPrags = SpecPrags []--hasSpecPrags :: TcSpecPrags -> Bool-hasSpecPrags (SpecPrags ps) = not (null ps)-hasSpecPrags IsDefaultMethod = False--isDefaultMethod :: TcSpecPrags -> Bool-isDefaultMethod IsDefaultMethod = True-isDefaultMethod (SpecPrags {})  = False+data AnnSig+  = AnnSig {+      asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option+      asRest   :: [AddEpAnn]+      } deriving Data  -isFixityLSig :: LSig name -> Bool-isFixityLSig (L _ (FixSig {})) = True-isFixityLSig _                 = False--isTypeLSig :: LSig name -> Bool  -- Type signatures-isTypeLSig (L _(TypeSig {}))    = True-isTypeLSig (L _(ClassOpSig {})) = True-isTypeLSig (L _(IdSig {}))      = True-isTypeLSig _                    = False--isSpecLSig :: LSig name -> Bool-isSpecLSig (L _(SpecSig {})) = True-isSpecLSig _                 = False--isSpecInstLSig :: LSig name -> Bool-isSpecInstLSig (L _ (SpecInstSig {})) = True-isSpecInstLSig _                      = False--isPragLSig :: LSig name -> Bool--- Identifies pragmas-isPragLSig (L _ (SpecSig {}))   = True-isPragLSig (L _ (InlineSig {})) = True-isPragLSig (L _ (SCCFunSig {})) = True-isPragLSig (L _ (CompleteMatchSig {})) = True-isPragLSig _                    = False--isInlineLSig :: LSig name -> Bool--- Identifies inline pragmas-isInlineLSig (L _ (InlineSig {})) = True-isInlineLSig _                    = False--isMinimalLSig :: LSig name -> Bool-isMinimalLSig (L _ (MinimalSig {})) = True-isMinimalLSig _                     = False--isSCCFunSig :: LSig name -> Bool-isSCCFunSig (L _ (SCCFunSig {})) = True-isSCCFunSig _                    = False--isCompleteMatchSig :: LSig name -> Bool-isCompleteMatchSig (L _ (CompleteMatchSig {} )) = True-isCompleteMatchSig _                            = False--hsSigDoc :: Sig name -> SDoc-hsSigDoc (TypeSig {})           = text "type signature"-hsSigDoc (PatSynSig {})         = text "pattern synonym signature"-hsSigDoc (ClassOpSig _ is_deflt _ _)- | is_deflt                     = text "default type signature"- | otherwise                    = text "class method signature"-hsSigDoc (IdSig {})             = text "id signature"-hsSigDoc (SpecSig _ _ _ inl)-                                = ppr inl <+> text "pragma"-hsSigDoc (InlineSig _ _ prag)   = ppr (inlinePragmaSpec prag) <+> text "pragma"-hsSigDoc (SpecInstSig _ src _)-                                = pprWithSourceText src empty <+> text "instance pragma"-hsSigDoc (FixSig {})            = text "fixity declaration"-hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"-hsSigDoc (SCCFunSig {})         = text "SCC pragma"-hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"-hsSigDoc (XSig {})              = text "XSIG TTG extension"--{--Check if signatures overlap; this is used when checking for duplicate-signatures. Since some of the signatures contain a list of names, testing for-equality is not enough -- we have to check if they overlap.--}- instance OutputableBndrId p => Outputable (Sig (GhcPass p)) where     ppr sig = ppr_sig sig -ppr_sig :: (OutputableBndrId p) => Sig (GhcPass p) -> SDoc+ppr_sig :: forall p. OutputableBndrId p+        => Sig (GhcPass p) -> SDoc ppr_sig (TypeSig _ vars ty)  = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig _ is_deflt vars ty)   | is_deflt                 = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)@@ -1165,8 +615,8 @@                                              (interpp'SP ty) inl)     where       pragmaSrc = case spec of-        NoUserInline -> "{-# SPECIALISE"-        _            -> "{-# SPECIALISE_INLINE"+        NoUserInlinePrag -> "{-# SPECIALISE"+        _                -> "{-# SPECIALISE_INLINE" ppr_sig (InlineSig _ var inl)   = pragSrcBrackets (inl_src inl) "{-# INLINE"  (pprInline inl                                    <+> pprPrefixOcc (unLoc var))@@ -1177,13 +627,22 @@ ppr_sig (PatSynSig _ names sig_ty)   = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) ppr_sig (SCCFunSig _ src fn mlabel)-  = pragSrcBrackets src "{-# SCC" (ppr fn <+> maybe empty ppr mlabel )+  = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel )+      where+        ppr_fn = case ghcPass @p of+          GhcPs -> ppr fn+          GhcRn -> ppr fn+          GhcTc -> ppr fn ppr_sig (CompleteMatchSig _ src cs mty)   = pragSrcBrackets src "{-# COMPLETE"-      ((hsep (punctuate comma (map ppr (unLoc cs))))+      ((hsep (punctuate comma (map ppr_n (unLoc cs))))         <+> opt_sig)   where     opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty+    ppr_n n = case ghcPass @p of+        GhcPs -> ppr n+        GhcRn -> ppr n+        GhcTc -> ppr n  instance OutputableBndrId p        => Outputable (FixitySig (GhcPass p)) where@@ -1220,71 +679,29 @@     = text "SPECIALIZE" <+> pprSpec var (text "<type>") inl  pprMinimalSig :: (OutputableBndr name)-              => LBooleanFormula (Located name) -> SDoc+              => LBooleanFormula (GenLocated l name) -> SDoc pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)  {- ************************************************************************ *                                                                      *-\subsection[PatSynBind]{A pattern synonym definition}+\subsection{Anno instances} *                                                                      * ************************************************************************ -} --- | Haskell Pattern Synonym Details-type HsPatSynDetails arg = HsConDetails arg [RecordPatSynField arg]---- See Note [Record PatSyn Fields]--- | Record Pattern Synonym Field-data RecordPatSynField a-  = RecordPatSynField {-      recordPatSynSelectorId :: a  -- Selector name visible in rest of the file-      , recordPatSynPatVar :: a-      -- Filled in by renamer, the name used internally-      -- by the pattern-      } deriving (Data, Functor)----{--Note [Record PatSyn Fields]--Consider the following two pattern synonyms.--pattern P x y = ([x,True], [y,'v'])-pattern Q{ x, y } =([x,True], [y,'v'])--In P, we just have two local binders, x and y.--In Q, we have local binders but also top-level record selectors-x :: ([Bool], [Char]) -> Bool and similarly for y.--It would make sense to support record-like syntax--pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])--when we have a different name for the local and top-level binder-the distinction between the two names clear---}-instance Outputable a => Outputable (RecordPatSynField a) where-    ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v--instance Foldable RecordPatSynField  where-    foldMap f (RecordPatSynField { recordPatSynSelectorId = visible-                                 , recordPatSynPatVar = hidden })-      = f visible `mappend` f hidden+type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA+type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA+type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA -instance Traversable RecordPatSynField where-    traverse f (RecordPatSynField { recordPatSynSelectorId =visible-                                  , recordPatSynPatVar = hidden })-      = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id-                                               , recordPatSynPatVar = pat_var })-          <$> f visible <*> f hidden+-- For CompleteMatchSig+type instance Anno [LocatedN RdrName] = SrcSpan+type instance Anno [LocatedN Name]    = SrcSpan+type instance Anno [LocatedN Id]      = SrcSpan +type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA --- | Haskell Pattern Synonym Direction-data HsPatSynDir id-  = Unidirectional-  | ImplicitBidirectional-  | ExplicitBidirectional (MatchGroup id (LHsExpr id))+type instance Anno StringLiteral = SrcSpan+type instance Anno (LocatedN RdrName) = SrcSpan+type instance Anno (LocatedN Name) = SrcSpan+type instance Anno (LocatedN Id) = SrcSpan

GHC/Hs/Decls.hs view

@@ -1,2613 +1,1198 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable,-             DeriveTraversable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Abstract syntax of global declarations.------ Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,--- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.-module GHC.Hs.Decls (-  -- * Toplevel declarations-  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,-  HsDerivingClause(..), LHsDerivingClause, NewOrData(..), newOrDataToFlavour,-  StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,--  -- ** Class or type declarations-  TyClDecl(..), LTyClDecl, DataDeclRn(..),-  TyClGroup(..),-  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,-  tyClGroupKindSigs,-  isClassDecl, isDataDecl, isSynDecl, tcdName,-  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,-  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,-  tyFamInstDeclName, tyFamInstDeclLName,-  countTyClDecls, pprTyClDeclFlavour,-  tyClDeclLName, tyClDeclTyVars,-  hsDeclHasCusk, famResultKindSignature,-  FamilyDecl(..), LFamilyDecl,--  -- ** Instance declarations-  InstDecl(..), LInstDecl, FamilyInfo(..),-  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,-  TyFamDefltDecl, LTyFamDefltDecl,-  DataFamInstDecl(..), LDataFamInstDecl,-  pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,-  FamInstEqn, LFamInstEqn, FamEqn(..),-  TyFamInstEqn, LTyFamInstEqn, HsTyPats,-  LClsInstDecl, ClsInstDecl(..),--  -- ** Standalone deriving declarations-  DerivDecl(..), LDerivDecl,-  -- ** Deriving strategies-  DerivStrategy(..), LDerivStrategy,-  derivStrategyName, foldDerivStrategy, mapDerivStrategy,-  -- ** @RULE@ declarations-  LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),-  RuleBndr(..),LRuleBndr,-  collectRuleBndrSigTys,-  flattenRuleDecls, pprFullRuleName,-  -- ** @default@ declarations-  DefaultDecl(..), LDefaultDecl,-  -- ** Template haskell declaration splice-  SpliceExplicitFlag(..),-  SpliceDecl(..), LSpliceDecl,-  -- ** Foreign function interface declarations-  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),-  CImportSpec(..),-  -- ** Data-constructor declarations-  ConDecl(..), LConDecl,-  HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta,-  getConNames, getConArgs,-  -- ** Document comments-  DocDecl(..), LDocDecl, docDeclDoc,-  -- ** Deprecations-  WarnDecl(..),  LWarnDecl,-  WarnDecls(..), LWarnDecls,-  -- ** Annotations-  AnnDecl(..), LAnnDecl,-  AnnProvenance(..), annProvenanceName_maybe,-  -- ** Role annotations-  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,-  -- ** Injective type families-  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,-  resultVariableName, familyDeclLName, familyDeclName,--  -- * Grouping-  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,-  hsGroupTopLevelFixitySigs,--  partitionBindsAndSigs,-    ) where---- friends:-import GHC.Prelude--import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, HsSplice, pprExpr,-                                   pprSpliceDecl )-        -- Because Expr imports Decls via HsBracket--import GHC.Hs.Binds-import GHC.Hs.Type-import GHC.Hs.Doc-import GHC.Core.TyCon-import GHC.Types.Basic-import GHC.Core.Coercion-import GHC.Types.ForeignCall-import GHC.Hs.Extension-import GHC.Types.Name-import GHC.Types.Name.Set---- others:-import GHC.Core.Class-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Types.SrcLoc-import GHC.Core.Type--import GHC.Data.Bag-import GHC.Data.Maybe-import Data.Data        hiding (TyCon,Fixity, Infix)--{--************************************************************************-*                                                                      *-\subsection[HsDecl]{Declarations}-*                                                                      *-************************************************************************--}--type LHsDecl p = Located (HsDecl p)-        -- ^ When in a list this may have-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'-        ------ For details on above see note [Api annotations] in GHC.Parser.Annotation---- | A Haskell Declaration-data HsDecl p-  = TyClD      (XTyClD p)      (TyClDecl p)      -- ^ Type or Class Declaration-  | InstD      (XInstD p)      (InstDecl  p)     -- ^ Instance declaration-  | DerivD     (XDerivD p)     (DerivDecl p)     -- ^ Deriving declaration-  | ValD       (XValD p)       (HsBind p)        -- ^ Value declaration-  | SigD       (XSigD p)       (Sig p)           -- ^ Signature declaration-  | KindSigD   (XKindSigD p)   (StandaloneKindSig p) -- ^ Standalone kind signature-  | DefD       (XDefD p)       (DefaultDecl p)   -- ^ 'default' declaration-  | ForD       (XForD p)       (ForeignDecl p)   -- ^ Foreign declaration-  | WarningD   (XWarningD p)   (WarnDecls p)     -- ^ Warning declaration-  | AnnD       (XAnnD p)       (AnnDecl p)       -- ^ Annotation declaration-  | RuleD      (XRuleD p)      (RuleDecls p)     -- ^ Rule declaration-  | SpliceD    (XSpliceD p)    (SpliceDecl p)    -- ^ Splice declaration-                                                 -- (Includes quasi-quotes)-  | DocD       (XDocD p)       (DocDecl)  -- ^ Documentation comment declaration-  | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration-  | XHsDecl    !(XXHsDecl p)--type instance XTyClD      (GhcPass _) = NoExtField-type instance XInstD      (GhcPass _) = NoExtField-type instance XDerivD     (GhcPass _) = NoExtField-type instance XValD       (GhcPass _) = NoExtField-type instance XSigD       (GhcPass _) = NoExtField-type instance XKindSigD   (GhcPass _) = NoExtField-type instance XDefD       (GhcPass _) = NoExtField-type instance XForD       (GhcPass _) = NoExtField-type instance XWarningD   (GhcPass _) = NoExtField-type instance XAnnD       (GhcPass _) = NoExtField-type instance XRuleD      (GhcPass _) = NoExtField-type instance XSpliceD    (GhcPass _) = NoExtField-type instance XDocD       (GhcPass _) = NoExtField-type instance XRoleAnnotD (GhcPass _) = NoExtField-type instance XXHsDecl    (GhcPass _) = NoExtCon--{--Note [Top-level fixity signatures in an HsGroup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An `HsGroup p` stores every top-level fixity declarations in one of two places:--1. hs_fixds :: [LFixitySig p]--   This stores fixity signatures for top-level declarations (e.g., functions,-   data constructors, classes, type families, etc.) as well as fixity-   signatures for class methods written outside of the class, as in this-   example:--     infixl 4 `m1`-     class C1 a where-       m1 :: a -> a -> a--2. hs_tyclds :: [TyClGroup p]--   Each type class can be found in a TyClDecl inside a TyClGroup, and that-   TyClDecl stores the fixity signatures for its methods written inside of the-   class, as in this example:--     class C2 a where-       infixl 4 `m2`-       m2 :: a -> a -> a--The story for fixity signatures for class methods is made slightly complicated-by the fact that they can appear both inside and outside of the class itself,-and both forms of fixity signatures are considered top-level. This matters-in `GHC.Rename.Module.rnSrcDecls`, which must create a fixity environment out-of all top-level fixity signatures before doing anything else. Therefore,-`rnSrcDecls` must be aware of both (1) and (2) above. The-`hsGroupTopLevelFixitySigs` function is responsible for collecting this-information from an `HsGroup`.--One might wonder why we even bother separating top-level fixity signatures-into two places at all. That is, why not just take the fixity signatures-from `hs_tyclds` and put them into `hs_fixds` so that they are all in one-location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`,-which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a-Template Haskell `Dec`. If there are any duplicate signatures between the two-fields, this will result in an error (#17608).--}---- | Partition a list of HsDecls into function/pattern bindings, signatures,--- type family declarations, type family instances, and documentation comments.------ Panics when given a declaration that cannot be put into any of the output--- groups.------ The primary use of this function is to implement--- 'GHC.Parser.PostProcess.cvBindsAndSigs'.-partitionBindsAndSigs-  :: [LHsDecl GhcPs]-  -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],-      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])-partitionBindsAndSigs = go-  where-    go [] = (emptyBag, [], [], [], [], [])-    go ((L l decl) : ds) =-      let (bs, ss, ts, tfis, dfis, docs) = go ds in-      case decl of-        ValD _ b-          -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs)-        SigD _ s-          -> (bs, L l s : ss, ts, tfis, dfis, docs)-        TyClD _ (FamDecl _ t)-          -> (bs, ss, L l t : ts, tfis, dfis, docs)-        InstD _ (TyFamInstD { tfid_inst = tfi })-          -> (bs, ss, ts, L l tfi : tfis, dfis, docs)-        InstD _ (DataFamInstD { dfid_inst = dfi })-          -> (bs, ss, ts, tfis, L l dfi : dfis, docs)-        DocD _ d-          -> (bs, ss, ts, tfis, dfis, L l d : docs)-        _ -> pprPanic "partitionBindsAndSigs" (ppr decl)---- | Haskell Group------ A 'HsDecl' is categorised into a 'HsGroup' before being--- fed to the renamer.-data HsGroup p-  = HsGroup {-        hs_ext    :: XCHsGroup p,-        hs_valds  :: HsValBinds p,-        hs_splcds :: [LSpliceDecl p],--        hs_tyclds :: [TyClGroup p],-                -- A list of mutually-recursive groups;-                -- This includes `InstDecl`s as well;-                -- Parser generates a singleton list;-                -- renamer does dependency analysis--        hs_derivds :: [LDerivDecl p],--        hs_fixds  :: [LFixitySig p],-                -- A list of fixity signatures defined for top-level-                -- declarations and class methods (defined outside of the class-                -- itself).-                -- See Note [Top-level fixity signatures in an HsGroup]--        hs_defds  :: [LDefaultDecl p],-        hs_fords  :: [LForeignDecl p],-        hs_warnds :: [LWarnDecls p],-        hs_annds  :: [LAnnDecl p],-        hs_ruleds :: [LRuleDecls p],--        hs_docs   :: [LDocDecl]-    }-  | XHsGroup !(XXHsGroup p)--type instance XCHsGroup (GhcPass _) = NoExtField-type instance XXHsGroup (GhcPass _) = NoExtCon---emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)-emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }-emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }--hsGroupInstDecls :: HsGroup id -> [LInstDecl id]-hsGroupInstDecls = (=<<) group_instds . hs_tyclds--emptyGroup = HsGroup { hs_ext = noExtField,-                       hs_tyclds = [],-                       hs_derivds = [],-                       hs_fixds = [], hs_defds = [], hs_annds = [],-                       hs_fords = [], hs_warnds = [], hs_ruleds = [],-                       hs_valds = error "emptyGroup hs_valds: Can't happen",-                       hs_splcds = [],-                       hs_docs = [] }---- | The fixity signatures for each top-level declaration and class method--- in an 'HsGroup'.--- See Note [Top-level fixity signatures in an HsGroup]-hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]-hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =-    fixds ++ cls_fixds-  where-    cls_fixds = [ L loc sig-                | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds-                , L loc (FixSig _ sig) <- sigs-                ]--appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)-             -> HsGroup (GhcPass p)-appendGroups-    HsGroup {-        hs_valds  = val_groups1,-        hs_splcds = spliceds1,-        hs_tyclds = tyclds1,-        hs_derivds = derivds1,-        hs_fixds  = fixds1,-        hs_defds  = defds1,-        hs_annds  = annds1,-        hs_fords  = fords1,-        hs_warnds = warnds1,-        hs_ruleds = rulds1,-        hs_docs   = docs1 }-    HsGroup {-        hs_valds  = val_groups2,-        hs_splcds = spliceds2,-        hs_tyclds = tyclds2,-        hs_derivds = derivds2,-        hs_fixds  = fixds2,-        hs_defds  = defds2,-        hs_annds  = annds2,-        hs_fords  = fords2,-        hs_warnds = warnds2,-        hs_ruleds = rulds2,-        hs_docs   = docs2 }-  =-    HsGroup {-        hs_ext    = noExtField,-        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,-        hs_splcds = spliceds1 ++ spliceds2,-        hs_tyclds = tyclds1 ++ tyclds2,-        hs_derivds = derivds1 ++ derivds2,-        hs_fixds  = fixds1 ++ fixds2,-        hs_annds  = annds1 ++ annds2,-        hs_defds  = defds1 ++ defds2,-        hs_fords  = fords1 ++ fords2,-        hs_warnds = warnds1 ++ warnds2,-        hs_ruleds = rulds1 ++ rulds2,-        hs_docs   = docs1  ++ docs2 }--instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where-    ppr (TyClD _ dcl)             = ppr dcl-    ppr (ValD _ binds)            = ppr binds-    ppr (DefD _ def)              = ppr def-    ppr (InstD _ inst)            = ppr inst-    ppr (DerivD _ deriv)          = ppr deriv-    ppr (ForD _ fd)               = ppr fd-    ppr (SigD _ sd)               = ppr sd-    ppr (KindSigD _ ksd)          = ppr ksd-    ppr (RuleD _ rd)              = ppr rd-    ppr (WarningD _ wd)           = ppr wd-    ppr (AnnD _ ad)               = ppr ad-    ppr (SpliceD _ dd)            = ppr dd-    ppr (DocD _ doc)              = ppr doc-    ppr (RoleAnnotD _ ra)         = ppr ra--instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where-    ppr (HsGroup { hs_valds  = val_decls,-                   hs_tyclds = tycl_decls,-                   hs_derivds = deriv_decls,-                   hs_fixds  = fix_decls,-                   hs_warnds = deprec_decls,-                   hs_annds  = ann_decls,-                   hs_fords  = foreign_decls,-                   hs_defds  = default_decls,-                   hs_ruleds = rule_decls })-        = vcat_mb empty-            [ppr_ds fix_decls, ppr_ds default_decls,-             ppr_ds deprec_decls, ppr_ds ann_decls,-             ppr_ds rule_decls,-             if isEmptyValBinds val_decls-                then Nothing-                else Just (ppr val_decls),-             ppr_ds (tyClGroupRoleDecls tycl_decls),-             ppr_ds (tyClGroupKindSigs  tycl_decls),-             ppr_ds (tyClGroupTyClDecls tycl_decls),-             ppr_ds (tyClGroupInstDecls tycl_decls),-             ppr_ds deriv_decls,-             ppr_ds foreign_decls]-        where-          ppr_ds :: Outputable a => [a] -> Maybe SDoc-          ppr_ds [] = Nothing-          ppr_ds ds = Just (vcat (map ppr ds))--          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc-          -- Concatenate vertically with white-space between non-blanks-          vcat_mb _    []             = empty-          vcat_mb gap (Nothing : ds) = vcat_mb gap ds-          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds---- | Located Splice Declaration-type LSpliceDecl pass = Located (SpliceDecl pass)---- | Splice Declaration-data SpliceDecl p-  = SpliceDecl                  -- Top level splice-        (XSpliceDecl p)-        (Located (HsSplice p))-        SpliceExplicitFlag-  | XSpliceDecl !(XXSpliceDecl p)--type instance XSpliceDecl      (GhcPass _) = NoExtField-type instance XXSpliceDecl     (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (SpliceDecl (GhcPass p)) where-   ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f--{--************************************************************************-*                                                                      *-            Type and class declarations-*                                                                      *-************************************************************************--Note [The Naming story]-~~~~~~~~~~~~~~~~~~~~~~~-Here is the story about the implicit names that go with type, class,-and instance decls.  It's a bit tricky, so pay attention!--"Implicit" (or "system") binders-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  Each data type decl defines-        a worker name for each constructor-        to-T and from-T convertors-  Each class decl defines-        a tycon for the class-        a data constructor for that tycon-        the worker for that constructor-        a selector for each superclass--All have occurrence names that are derived uniquely from their parent-declaration.--None of these get separate definitions in an interface file; they are-fully defined by the data or class decl.  But they may *occur* in-interface files, of course.  Any such occurrence must haul in the-relevant type or class decl.--Plan of attack:- - Ensure they "point to" the parent data/class decl-   when loading that decl from an interface file-   (See RnHiFiles.getSysBinders)-- - When typechecking the decl, we build the implicit TyCons and Ids.-   When doing so we look them up in the name cache (GHC.Rename.Env.lookupSysName),-   to ensure correct module and provenance is set--These are the two places that we have to conjure up the magic derived-names.  (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.)--Default methods-~~~~~~~~~~~~~~~- - Occurrence name is derived uniquely from the method name-   E.g. $dmmax-- - If there is a default method name at all, it's recorded in-   the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field.-   (DefMethInfo is defined in GHC.Core.Class)--Source-code class decls and interface-code class decls are treated subtly-differently, which has given me a great deal of confusion over the years.-Here's the deal.  (We distinguish the two cases because source-code decls-have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.--In *source-code* class declarations:-- - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName-   This is done by GHC.Parser.PostProcess.mkClassOpSigDM-- - The renamer renames it to a Name-- - During typechecking, we generate a binding for each $dm for-   which there's a programmer-supplied default method:-        class Foo a where-          op1 :: <type>-          op2 :: <type>-          op1 = ...-   We generate a binding for $dmop1 but not for $dmop2.-   The Class for Foo has a Nothing for op2 and-                         a Just ($dm_op1, VanillaDM) for op1.-   The Name for $dmop2 is simply discarded.--In *interface-file* class declarations:-  - When parsing, we see if there's an explicit programmer-supplied default method-    because there's an '=' sign to indicate it:-        class Foo a where-          op1 = :: <type>       -- NB the '='-          op2   :: <type>-    We use this info to generate a DefMeth with a suitable RdrName for op1,-    and a NoDefMeth for op2-  - The interface file has a separate definition for $dmop1, with unfolding etc.-  - The renamer renames it to a Name.-  - The renamer treats $dmop1 as a free variable of the declaration, so that-    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)-    This doesn't happen for source code class decls, because they *bind* the default method.--Dictionary functions-~~~~~~~~~~~~~~~~~~~~-Each instance declaration gives rise to one dictionary function binding.--The type checker makes up new source-code instance declarations-(e.g. from 'deriving' or generic default methods --- see-GHC.Tc.TyCl.Instance.tcInstDecls1).  So we can't generate the names for-dictionary functions in advance (we don't know how many we need).--On the other hand for interface-file instance declarations, the decl-specifies the name of the dictionary function, and it has a binding elsewhere-in the interface file:-        instance {Eq Int} = dEqInt-        dEqInt :: {Eq Int} <pragma info>--So again we treat source code and interface file code slightly differently.--Source code:-  - Source code instance decls have a Nothing in the (Maybe name) field-    (see data InstDecl below)--  - The typechecker makes up a Local name for the dict fun for any source-code-    instance decl, whether it comes from a source-code instance decl, or whether-    the instance decl is derived from some other construct (e.g. 'deriving').--  - The occurrence name it chooses is derived from the instance decl (just for-    documentation really) --- e.g. dNumInt.  Two dict funs may share a common-    occurrence name, but will have different uniques.  E.g.-        instance Foo [Int]  where ...-        instance Foo [Bool] where ...-    These might both be dFooList--  - The CoreTidy phase externalises the name, and ensures the occurrence name is-    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.--  - We can take this relaxed approach (changing the occurrence name later)-    because dict fun Ids are not captured in a TyCon or Class (unlike default-    methods, say).  Instead, they are kept separately in the InstEnv.  This-    makes it easy to adjust them after compiling a module.  (Once we've finished-    compiling that module, they don't change any more.)---Interface file code:-  - The instance decl gives the dict fun name, so the InstDecl has a (Just name)-    in the (Maybe name) field.--  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we-    suck in the dfun binding--}---- | Located Declaration of a Type or Class-type LTyClDecl pass = Located (TyClDecl pass)---- | A type or class declaration.-data TyClDecl pass-  = -- | @type/data family T :: *->*@-    ---    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-    --             'GHC.Parser.Annotation.AnnData',-    --             'GHC.Parser.Annotation.AnnFamily','GHC.Parser.Annotation.AnnDcolon',-    --             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpenP',-    --             'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnCloseP',-    --             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnRarrow',-    --             'GHC.Parser.Annotation.AnnVbar'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation-    FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }--  | -- | @type@ declaration-    ---    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-    --             'GHC.Parser.Annotation.AnnEqual',--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation-    SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renameer, FVs-            , tcdLName  :: Located (IdP pass)     -- ^ Type constructor-            , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an-                                                  -- associated type these-                                                  -- include outer binders-            , tcdFixity :: LexicalFixity          -- ^ Fixity used in the declaration-            , tcdRhs    :: LHsType pass }         -- ^ RHS of type declaration--  | -- | @data@ declaration-    ---    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',-    --              'GHC.Parser.Annotation.AnnFamily',-    --              'GHC.Parser.Annotation.AnnNewType',-    --              'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnDcolon'-    --              'GHC.Parser.Annotation.AnnWhere',--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation-    DataDecl { tcdDExt     :: XDataDecl pass       -- ^ Post renamer, CUSK flag, FVs-             , tcdLName    :: Located (IdP pass)   -- ^ Type constructor-             , tcdTyVars   :: LHsQTyVars pass      -- ^ Type variables-                              -- See Note [TyVar binders for associated declarations]-             , tcdFixity   :: LexicalFixity        -- ^ Fixity used in the declaration-             , tcdDataDefn :: HsDataDefn pass }--  | ClassDecl { tcdCExt    :: XClassDecl pass,          -- ^ Post renamer, FVs-                tcdCtxt    :: LHsContext pass,          -- ^ Context...-                tcdLName   :: Located (IdP pass),       -- ^ Name of the class-                tcdTyVars  :: LHsQTyVars pass,          -- ^ Class type variables-                tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration-                tcdFDs     :: [LHsFunDep pass],         -- ^ Functional deps-                tcdSigs    :: [LSig pass],              -- ^ Methods' signatures-                tcdMeths   :: LHsBinds pass,            -- ^ Default methods-                tcdATs     :: [LFamilyDecl pass],       -- ^ Associated types;-                tcdATDefs  :: [LTyFamDefltDecl pass],   -- ^ Associated type defaults-                tcdDocs    :: [LDocDecl]                -- ^ Haddock docs-    }-        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass',-        --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',-        --           'GHC.Parser.Annotation.AnnClose'-        --   - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar',-        --                          'GHC.Parser.Annotation.AnnComma'-        --                          'GHC.Parser.Annotation.AnnRarrow'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XTyClDecl !(XXTyClDecl pass)--type LHsFunDep pass = Located (FunDep (Located (IdP pass)))--data DataDeclRn = DataDeclRn-             { tcdDataCusk :: Bool    -- ^ does this have a CUSK?-                 -- See Note [CUSKs: complete user-supplied kind signatures]-             , tcdFVs      :: NameSet }-  deriving Data--{- Note [TyVar binders for associated decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For an /associated/ data, newtype, or type-family decl, the LHsQTyVars-/includes/ outer binders.  For example-    class T a where-       data D a c-       type F a b :: *-       type F a b = a -> a-Here the data decl for 'D', and type-family decl for 'F', both include 'a'-in their LHsQTyVars (tcdTyVars and fdTyVars resp).--Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars.--The idea is that the associated type is really a top-level decl in its-own right.  However we are careful to use the same name 'a', so that-we can match things up.--c.f. Note [Associated type tyvar names] in GHC.Core.Class-     Note [Family instance declaration binders]--}--type instance XFamDecl      (GhcPass _) = NoExtField--type instance XSynDecl      GhcPs = NoExtField-type instance XSynDecl      GhcRn = NameSet -- FVs-type instance XSynDecl      GhcTc = NameSet -- FVs--type instance XDataDecl     GhcPs = NoExtField-type instance XDataDecl     GhcRn = DataDeclRn-type instance XDataDecl     GhcTc = DataDeclRn--type instance XClassDecl    GhcPs = LayoutInfo  -- See Note [Class LayoutInfo]-type instance XClassDecl    GhcRn = NameSet -- FVs-type instance XClassDecl    GhcTc = NameSet -- FVs--{- Note [Class LayoutInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The LayoutInfo is used to associate Haddock comments with parts of the declaration.-Compare the following examples:--    class C a where-      f :: a -> Int-      -- ^ comment on f--    class C a where-      f :: a -> Int-    -- ^ comment on C--Notice how "comment on f" and "comment on C" differ only by indentation level.-Thus we have to record the indentation level of the class declarations.--See also Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock--}--type instance XXTyClDecl    (GhcPass _) = NoExtCon---- Simple classifiers for TyClDecl--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- | @True@ <=> argument is a @data@\/@newtype@--- declaration.-isDataDecl :: TyClDecl pass -> Bool-isDataDecl (DataDecl {}) = True-isDataDecl _other        = False---- | type or type instance declaration-isSynDecl :: TyClDecl pass -> Bool-isSynDecl (SynDecl {})   = True-isSynDecl _other        = False---- | type class-isClassDecl :: TyClDecl pass -> Bool-isClassDecl (ClassDecl {}) = True-isClassDecl _              = False---- | type/data family declaration-isFamilyDecl :: TyClDecl pass -> Bool-isFamilyDecl (FamDecl {})  = True-isFamilyDecl _other        = False---- | type family declaration-isTypeFamilyDecl :: TyClDecl pass -> Bool-isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of-  OpenTypeFamily      -> True-  ClosedTypeFamily {} -> True-  _                   -> False-isTypeFamilyDecl _ = False---- | open type family info-isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool-isOpenTypeFamilyInfo OpenTypeFamily = True-isOpenTypeFamilyInfo _              = False---- | closed type family info-isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool-isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True-isClosedTypeFamilyInfo _                     = False---- | data family declaration-isDataFamilyDecl :: TyClDecl pass -> Bool-isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True-isDataFamilyDecl _other      = False---- Dealing with names--tyFamInstDeclName :: TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)-tyFamInstDeclName = unLoc . tyFamInstDeclLName--tyFamInstDeclLName :: TyFamInstDecl (GhcPass p) -> Located (IdP (GhcPass p))-tyFamInstDeclLName (TyFamInstDecl { tfid_eqn =-                     (HsIB { hsib_body = FamEqn { feqn_tycon = ln }}) })-  = ln--tyClDeclLName :: TyClDecl (GhcPass p) -> Located (IdP (GhcPass p))-tyClDeclLName (FamDecl { tcdFam = fd })     = familyDeclLName fd-tyClDeclLName (SynDecl { tcdLName = ln })   = ln-tyClDeclLName (DataDecl { tcdLName = ln })  = ln-tyClDeclLName (ClassDecl { tcdLName = ln }) = ln--tcdName :: TyClDecl (GhcPass p) -> IdP (GhcPass p)-tcdName = unLoc . tyClDeclLName--tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass-tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs-tyClDeclTyVars d = tcdTyVars d--countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)-        -- class, synonym decls, data, newtype, family decls-countTyClDecls decls- = (count isClassDecl    decls,-    count isSynDecl      decls,  -- excluding...-    count isDataTy       decls,  -- ...family...-    count isNewTy        decls,  -- ...instances-    count isFamilyDecl   decls)- where-   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True-   isDataTy _                                                       = False--   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True-   isNewTy _                                                      = False---- | Does this declaration have a complete, user-supplied kind signature?--- See Note [CUSKs: complete user-supplied kind signatures]-hsDeclHasCusk :: TyClDecl GhcRn -> Bool-hsDeclHasCusk (FamDecl { tcdFam =-    FamilyDecl { fdInfo      = fam_info-               , fdTyVars    = tyvars-               , fdResultSig = L _ resultSig } }) =-    case fam_info of-      ClosedTypeFamily {} -> hsTvbAllKinded tyvars-                          && isJust (famResultKindSignature resultSig)-      _ -> True -- Un-associated open type/data families have CUSKs-hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })-  = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)-hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk-hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars---- Pretty-printing TyClDecl--- ~~~~~~~~~~~~~~~~~~~~~~~~--instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where--    ppr (FamDecl { tcdFam = decl }) = ppr decl-    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity-                 , tcdRhs = rhs })-      = hang (text "type" <+>-              pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+> equals)-          4 (ppr rhs)--    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity-                  , tcdDataDefn = defn })-      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn--    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,-                    tcdFixity = fixity,-                    tcdFDs  = fds,-                    tcdSigs = sigs, tcdMeths = methods,-                    tcdATs = ats, tcdATDefs = at_defs})-      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part-      = top_matter--      | otherwise       -- Laid out-      = vcat [ top_matter <+> text "where"-             , nest 2 $ pprDeclList (map (pprFamilyDecl NotTopLevel . unLoc) ats ++-                                     map (pprTyFamDefltDecl . unLoc) at_defs ++-                                     pprLHsBindsForUser methods sigs) ]-      where-        top_matter = text "class"-                    <+> pp_vanilla_decl_head lclas tyvars fixity context-                    <+> pprFundeps (map unLoc fds)--instance OutputableBndrId p-       => Outputable (TyClGroup (GhcPass p)) where-  ppr (TyClGroup { group_tyclds = tyclds-                 , group_roles = roles-                 , group_kisigs = kisigs-                 , group_instds = instds-                 }-      )-    = hang (text "TyClGroup") 2 $-      ppr kisigs $$-      ppr tyclds $$-      ppr roles $$-      ppr instds--pp_vanilla_decl_head :: (OutputableBndrId p)-   => Located (IdP (GhcPass p))-   -> LHsQTyVars (GhcPass p)-   -> LexicalFixity-   -> LHsContext (GhcPass p)-   -> SDoc-pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context- = hsep [pprLHsContext context, pp_tyvars tyvars]-  where-    pp_tyvars (varl:varsr)-      | fixity == Infix && length varsr > 1-         = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)-                , (ppr.unLoc) (head varsr), char ')'-                , hsep (map (ppr.unLoc) (tail varsr))]-      | fixity == Infix-         = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)-         , hsep (map (ppr.unLoc) varsr)]-      | otherwise = hsep [ pprPrefixOcc (unLoc thing)-                  , hsep (map (ppr.unLoc) (varl:varsr))]-    pp_tyvars [] = pprPrefixOcc (unLoc thing)--pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc-pprTyClDeclFlavour (ClassDecl {})   = text "class"-pprTyClDeclFlavour (SynDecl {})     = text "type"-pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})-  = pprFlavour info <+> text "family"-pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })-  = ppr nd---{- Note [CUSKs: complete user-supplied kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We kind-check declarations differently if they have a complete, user-supplied-kind signature (CUSK). This is because we can safely generalise a CUSKed-declaration before checking all of the others, supporting polymorphic recursion.-See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy-and #9200 for lots of discussion of how we got here.--The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default.-Under -XNoCUSKs, all declarations are treated as if they have no CUSK.-See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst--PRINCIPLE:-  a type declaration has a CUSK iff we could produce a separate kind signature-  for it, just like a type signature for a function,-  looking only at the header of the declaration.--Examples:-  * data T1 (a :: *->*) (b :: *) = ....-    -- Has CUSK; equivalant to   T1 :: (*->*) -> * -> *-- * data T2 a b = ...-   -- No CUSK; we do not want to guess T2 :: * -> * -> *-   -- because the full decl might be   data T a b = MkT (a b)--  * data T3 (a :: k -> *) (b :: *) = ...-    -- CUSK; equivalent to   T3 :: (k -> *) -> * -> *-    -- We lexically generalise over k to get-    --    T3 :: forall k. (k -> *) -> * -> *-    -- The generalisation is here is purely lexical, just like-    --    f3 :: a -> a-    -- means-    --    f3 :: forall a. a -> a--  * data T4 (a :: j k) = ...-     -- CUSK; equivalent to   T4 :: j k -> *-     -- which we lexically generalise to  T4 :: forall j k. j k -> *-     -- and then, if PolyKinds is on, we further generalise to-     --   T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> *-     -- Again this is exactly like what happens as the term level-     -- when you write-     --    f4 :: forall a b. a b -> Int--NOTE THAT-  * A CUSK does /not/ mean that everything about the kind signature is-    fully specified by the user.  Look at T4 and f4: we had to do kind-    inference to figure out the kind-quantification.  But in both cases-    (T4 and f4) that inference is done looking /only/ at the header of T4-    (or signature for f4), not at the definition thereof.--  * The CUSK completely fixes the kind of the type constructor, forever.--  * The precise rules, for each declaration form, for whether a declaration-    has a CUSK are given in the user manual section "Complete user-supplied-    kind signatures and polymorphic recursion".  But they simply implement-    PRINCIPLE above.--  * Open type families are interesting:-      type family T5 a b :: *-    There simply /is/ no accompanying declaration, so that info is all-    we'll ever get.  So we it has a CUSK by definition, and we default-    any un-fixed kind variables to *.--  * Associated types are a bit tricker:-      class C6 a where-         type family T6 a b :: *-         op :: a Int -> Int-    Here C6 does not have a CUSK (in fact we ultimately discover that-    a :: * -> *).  And hence neither does T6, the associated family,-    because we can't fix its kind until we have settled C6.  Another-    way to say it: unlike a top-level, we /may/ discover more about-    a's kind from C6's definition.--  * A data definition with a top-level :: must explicitly bind all-    kind variables to the right of the ::. See test-    dependent/should_compile/KindLevels, which requires this-    case. (Naturally, any kind variable mentioned before the :: should-    not be bound after it.)--    This last point is much more debatable than the others; see-    #15142 comment:22--    Because this is fiddly to check, there is a field in the DataDeclRn-    structure (included in a DataDecl after the renamer) that stores whether-    or not the declaration has a CUSK.--}---{- *********************************************************************-*                                                                      *-                         TyClGroup-        Strongly connected components of-      type, class, instance, and role declarations-*                                                                      *-********************************************************************* -}--{- Note [TyClGroups and dependency analysis]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A TyClGroup represents a strongly connected components of type/class/instance-decls, together with the role annotations for the type/class declarations.--The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order-sequence of strongly-connected components.--Invariants- * The type and class declarations, group_tyclds, may depend on each-   other, or earlier TyClGroups, but not on later ones-- * The role annotations, group_roles, are role-annotations for some or-   all of the types and classes in group_tyclds (only).-- * The instance declarations, group_instds, may (and usually will)-   depend on group_tyclds, or on earlier TyClGroups, but not on later-   ones.--See Note [Dependency analysis of type, class, and instance decls]-in GHC.Rename.Module for more info.--}---- | Type or Class Group-data TyClGroup pass  -- See Note [TyClGroups and dependency analysis]-  = TyClGroup { group_ext    :: XCTyClGroup pass-              , group_tyclds :: [LTyClDecl pass]-              , group_roles  :: [LRoleAnnotDecl pass]-              , group_kisigs :: [LStandaloneKindSig pass]-              , group_instds :: [LInstDecl pass] }-  | XTyClGroup !(XXTyClGroup pass)--type instance XCTyClGroup (GhcPass _) = NoExtField-type instance XXTyClGroup (GhcPass _) = NoExtCon---tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]-tyClGroupTyClDecls = concatMap group_tyclds--tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]-tyClGroupInstDecls = concatMap group_instds--tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]-tyClGroupRoleDecls = concatMap group_roles--tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]-tyClGroupKindSigs = concatMap group_kisigs---{- *********************************************************************-*                                                                      *-               Data and type family declarations-*                                                                      *-********************************************************************* -}--{- Note [FamilyResultSig]-~~~~~~~~~~~~~~~~~~~~~~~~~--This data type represents the return signature of a type family.  Possible-values are:-- * NoSig - the user supplied no return signature:-      type family Id a where ...-- * KindSig - the user supplied the return kind:-      type family Id a :: * where ...-- * TyVarSig - user named the result with a type variable and possibly-   provided a kind signature for that variable:-      type family Id a = r where ...-      type family Id a = (r :: *) where ...--   Naming result of a type family is required if we want to provide-   injectivity annotation for a type family:-      type family Id a = r | r -> a where ...--See also: Note [Injectivity annotation]--Note [Injectivity annotation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A user can declare a type family to be injective:--   type family Id a = r | r -> a where ...-- * The part after the "|" is called "injectivity annotation".- * "r -> a" part is called "injectivity condition"; at the moment terms-   "injectivity annotation" and "injectivity condition" are synonymous-   because we only allow a single injectivity condition.- * "r" is the "LHS of injectivity condition". LHS can only contain the-   variable naming the result of a type family.-- * "a" is the "RHS of injectivity condition". RHS contains space-separated-   type and kind variables representing the arguments of a type-   family. Variables can be omitted if a type family is not injective in-   these arguments. Example:-         type family Foo a b c = d | d -> a c where ...--Note that:- (a) naming of type family result is required to provide injectivity-     annotation- (b) for associated types if the result was named then injectivity annotation-     is mandatory. Otherwise result type variable is indistinguishable from-     associated type default.--It is possible that in the future this syntax will be extended to support-more complicated injectivity annotations. For example we could declare that-if we know the result of Plus and one of its arguments we can determine the-other argument:--   type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...--Here injectivity annotation would consist of two comma-separated injectivity-conditions.--See also Note [Injective type families] in GHC.Core.TyCon--}---- | Located type Family Result Signature-type LFamilyResultSig pass = Located (FamilyResultSig pass)---- | type Family Result Signature-data FamilyResultSig pass = -- see Note [FamilyResultSig]-    NoSig (XNoSig pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | KindSig  (XCKindSig pass) (LHsKind pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-  --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',-  --             'GHC.Parser.Annotation.AnnCloseP'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-  --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',-  --             'GHC.Parser.Annotation.AnnCloseP', 'GHC.Parser.Annotation.AnnEqual'-  | XFamilyResultSig !(XXFamilyResultSig pass)--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation--type instance XNoSig            (GhcPass _) = NoExtField-type instance XCKindSig         (GhcPass _) = NoExtField--type instance XTyVarSig         (GhcPass _) = NoExtField-type instance XXFamilyResultSig (GhcPass _) = NoExtCon----- | Located type Family Declaration-type LFamilyDecl pass = Located (FamilyDecl pass)---- | type Family Declaration-data FamilyDecl pass = FamilyDecl-  { fdExt            :: XCFamilyDecl pass-  , fdInfo           :: FamilyInfo pass              -- type/data, closed/open-  , fdLName          :: Located (IdP pass)           -- type constructor-  , fdTyVars         :: LHsQTyVars pass              -- type variables-                       -- See Note [TyVar binders for associated declarations]-  , fdFixity         :: LexicalFixity                -- Fixity used in the declaration-  , fdResultSig      :: LFamilyResultSig pass        -- result signature-  , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann-  }-  | XFamilyDecl !(XXFamilyDecl pass)-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-  --             'GHC.Parser.Annotation.AnnData', 'GHC.Parser.Annotation.AnnFamily',-  --             'GHC.Parser.Annotation.AnnWhere', 'GHC.Parser.Annotation.AnnOpenP',-  --             'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnCloseP',-  --             'GHC.Parser.Annotation.AnnEqual', 'GHC.Parser.Annotation.AnnRarrow',-  --             'GHC.Parser.Annotation.AnnVbar'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation--type instance XCFamilyDecl    (GhcPass _) = NoExtField-type instance XXFamilyDecl    (GhcPass _) = NoExtCon----- | Located Injectivity Annotation-type LInjectivityAnn pass = Located (InjectivityAnn pass)---- | If the user supplied an injectivity annotation it is represented using--- InjectivityAnn. At the moment this is a single injectivity condition - see--- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity--- condition. `[Located name]` stores the RHS of injectivity condition. Example:------   type family Foo a b c = r | r -> a c where ...------ This will be represented as "InjectivityAnn `r` [`a`, `c`]"-data InjectivityAnn pass-  = InjectivityAnn (Located (IdP pass)) [Located (IdP pass)]-  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-  --             'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation--data FamilyInfo pass-  = DataFamily-  | OpenTypeFamily-     -- | 'Nothing' if we're in an hs-boot file and the user-     -- said "type family Foo x where .."-  | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])---------------- Functions over FamilyDecls -------------familyDeclLName :: FamilyDecl (GhcPass p) -> Located (IdP (GhcPass p))-familyDeclLName (FamilyDecl { fdLName = n }) = n--familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)-familyDeclName = unLoc . familyDeclLName--famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))-famResultKindSignature (NoSig _) = Nothing-famResultKindSignature (KindSig _ ki) = Just ki-famResultKindSignature (TyVarSig _ bndr) =-  case unLoc bndr of-    UserTyVar _ _ _ -> Nothing-    KindedTyVar _ _ _ ki -> Just ki---- | Maybe return name of the result type variable-resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))-resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig-resultVariableName _                = Nothing--------------- Pretty printing FamilyDecls -------------instance OutputableBndrId p-       => Outputable (FamilyDecl (GhcPass p)) where-  ppr = pprFamilyDecl TopLevel--pprFamilyDecl :: (OutputableBndrId p)-              => TopLevelFlag -> FamilyDecl (GhcPass p) -> SDoc-pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon-                                    , fdTyVars = tyvars-                                    , fdFixity = fixity-                                    , fdResultSig = L _ result-                                    , fdInjectivityAnn = mb_inj })-  = vcat [ pprFlavour info <+> pp_top_level <+>-           pp_vanilla_decl_head ltycon tyvars fixity noLHsContext <+>-           pp_kind <+> pp_inj <+> pp_where-         , nest 2 $ pp_eqns ]-  where-    pp_top_level = case top_level of-                     TopLevel    -> text "family"-                     NotTopLevel -> empty--    pp_kind = case result of-                NoSig    _         -> empty-                KindSig  _ kind    -> dcolon <+> ppr kind-                TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr-    pp_inj = case mb_inj of-               Just (L _ (InjectivityAnn lhs rhs)) ->-                 hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]-               Nothing -> empty-    (pp_where, pp_eqns) = case info of-      ClosedTypeFamily mb_eqns ->-        ( text "where"-        , case mb_eqns of-            Nothing   -> text ".."-            Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )-      _ -> (empty, empty)--pprFlavour :: FamilyInfo pass -> SDoc-pprFlavour DataFamily            = text "data"-pprFlavour OpenTypeFamily        = text "type"-pprFlavour (ClosedTypeFamily {}) = text "type"--instance Outputable (FamilyInfo pass) where-  ppr info = pprFlavour info <+> text "family"----{- *********************************************************************-*                                                                      *-               Data types and data constructors-*                                                                      *-********************************************************************* -}---- | Haskell Data type Definition-data HsDataDefn pass   -- The payload of a data type defn-                       -- Used *both* for vanilla data declarations,-                       --       *and* for data family instances-  = -- | Declares a data type or newtype, giving its constructors-    -- @-    --  data/newtype T a = <constrs>-    --  data/newtype instance T [a] = <constrs>-    -- @-    HsDataDefn { dd_ext    :: XCHsDataDefn pass,-                 dd_ND     :: NewOrData,-                 dd_ctxt   :: LHsContext pass,           -- ^ Context-                 dd_cType  :: Maybe (Located CType),-                 dd_kindSig:: Maybe (LHsKind pass),-                     -- ^ Optional kind signature.-                     ---                     -- @(Just k)@ for a GADT-style @data@,-                     -- or @data instance@ decl, with explicit kind sig-                     ---                     -- Always @Nothing@ for H98-syntax decls--                 dd_cons   :: [LConDecl pass],-                     -- ^ Data constructors-                     ---                     -- For @data T a = T1 | T2 a@-                     --   the 'LConDecl's all have 'ConDeclH98'.-                     -- For @data T a where { T1 :: T a }@-                     --   the 'LConDecls' all have 'ConDeclGADT'.--                 dd_derivs :: HsDeriving pass  -- ^ Optional 'deriving' clause--             -- For details on above see note [Api annotations] in GHC.Parser.Annotation-   }-  | XHsDataDefn !(XXHsDataDefn pass)--type instance XCHsDataDefn    (GhcPass _) = NoExtField--type instance XXHsDataDefn    (GhcPass _) = NoExtCon---- | Haskell Deriving clause-type HsDeriving pass = Located [LHsDerivingClause pass]-  -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is-  -- plural because one can specify multiple deriving clauses using the-  -- @-XDerivingStrategies@ language extension.-  ---  -- The list of 'LHsDerivingClause's corresponds to exactly what the user-  -- requested to derive, in order. If no deriving clauses were specified,-  -- the list is empty.--type LHsDerivingClause pass = Located (HsDerivingClause pass)---- | A single @deriving@ clause of a data declaration.------  - 'GHC.Parser.Annotation.AnnKeywordId' :---       'GHC.Parser.Annotation.AnnDeriving', 'GHC.Parser.Annotation.AnnStock',---       'GHC.Parser.Annotation.AnnAnyClass', 'Api.AnnNewtype',---       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'-data HsDerivingClause pass-  -- See Note [Deriving strategies] in GHC.Tc.Deriv-  = HsDerivingClause-    { deriv_clause_ext :: XCHsDerivingClause pass-    , deriv_clause_strategy :: Maybe (LDerivStrategy pass)-      -- ^ The user-specified strategy (if any) to use when deriving-      -- 'deriv_clause_tys'.-    , deriv_clause_tys :: Located [LHsSigType pass]-      -- ^ The types to derive.-      ---      -- It uses 'LHsSigType's because, with @-XGeneralizedNewtypeDeriving@,-      -- we can mention type variables that aren't bound by the datatype, e.g.-      ---      -- > data T b = ... deriving (C [a])-      ---      -- should produce a derived instance for @C [a] (T b)@.-    }-  | XHsDerivingClause !(XXHsDerivingClause pass)--type instance XCHsDerivingClause    (GhcPass _) = NoExtField-type instance XXHsDerivingClause    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (HsDerivingClause (GhcPass p)) where-  ppr (HsDerivingClause { deriv_clause_strategy = dcs-                        , deriv_clause_tys      = L _ dct })-    = hsep [ text "deriving"-           , pp_strat_before-           , pp_dct dct-           , pp_strat_after ]-      where-        -- This complexity is to distinguish between-        --    deriving Show-        --    deriving (Show)-        pp_dct [HsIB { hsib_body = ty }]-                 = ppr (parenthesizeHsType appPrec ty)-        pp_dct _ = parens (interpp'SP dct)--        -- @via@ is unique in that in comes /after/ the class being derived,-        -- so we must special-case it.-        (pp_strat_before, pp_strat_after) =-          case dcs of-            Just (L _ via@ViaStrategy{}) -> (empty, ppr via)-            _                            -> (ppDerivStrategy dcs, empty)---- | Located Standalone Kind Signature-type LStandaloneKindSig pass = Located (StandaloneKindSig pass)--data StandaloneKindSig pass-  = StandaloneKindSig (XStandaloneKindSig pass)-      (Located (IdP pass))  -- Why a single binder? See #16754-      (LHsSigType pass)     -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]-  | XStandaloneKindSig !(XXStandaloneKindSig pass)--type instance XStandaloneKindSig (GhcPass p) = NoExtField-type instance XXStandaloneKindSig (GhcPass p) = NoExtCon--standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)-standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname--{- Note [Wildcards in standalone kind signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Standalone kind signatures enable polymorphic recursion, and it is unclear how-to reconcile this with partial type signatures, so we disallow wildcards in-them.--We reject wildcards in 'rnStandaloneKindSignature' by returning False for-'StandaloneKindSigCtx' in 'wildCardsAllowed'.--The alternative design is to have special treatment for partial standalone kind-signatures, much like we have special treatment for partial type signatures in-terms. However, partial standalone kind signatures are not a proper replacement-for CUSKs, so this would be a separate feature.--}--data NewOrData-  = NewType                     -- ^ @newtype Blah ...@-  | DataType                    -- ^ @data Blah ...@-  deriving( Eq, Data )                -- Needed because Demand derives Eq---- | Convert a 'NewOrData' to a 'TyConFlavour'-newOrDataToFlavour :: NewOrData -> TyConFlavour-newOrDataToFlavour NewType  = NewtypeFlavour-newOrDataToFlavour DataType = DataTypeFlavour----- | Located data Constructor Declaration-type LConDecl pass = Located (ConDecl pass)-      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when-      --   in a GADT constructor list--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation---- |------ @--- data T b = forall a. Eq a => MkT a b---   MkT :: forall b a. Eq a => MkT a b------ data T b where---      MkT1 :: Int -> T Int------ data T = Int `MkT` Int---        | MkT2------ data T a where---      Int `MkT` Int :: T Int--- @------ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',---            'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnCLose',---            'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnVbar',---            'GHC.Parser.Annotation.AnnDarrow','GHC.Parser.Annotation.AnnDarrow',---            'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot'---- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | data Constructor Declaration-data ConDecl pass-  = ConDeclGADT-      { con_g_ext   :: XConDeclGADT pass-      , con_names   :: [Located (IdP pass)]--      -- The following fields describe the type after the '::'-      -- See Note [GADT abstract syntax]-      , con_forall  :: Located Bool    -- ^ True <=> explicit forall-                                         --   False => hsq_explicit is empty-                                         ---                                         -- The 'XRec' is used to anchor API-                                         -- annotations, AnnForall and AnnDot.-      , con_qvars   :: [LHsTyVarBndr Specificity pass]-                       -- Whether or not there is an /explicit/ forall, we still-                       -- need to capture the implicitly-bound type/kind variables--      , con_mb_cxt  :: Maybe (LHsContext pass) -- ^ User-written context (if any)-      , con_args    :: HsConDeclDetails pass   -- ^ Arguments; never InfixCon-      , con_res_ty  :: LHsType pass            -- ^ Result type--      , con_doc     :: Maybe LHsDocString-          -- ^ A possible Haddock comment.-      }--  | ConDeclH98-      { con_ext     :: XConDeclH98 pass-      , con_name    :: Located (IdP pass)--      , con_forall  :: Located Bool-                              -- ^ True <=> explicit user-written forall-                              --     e.g. data T a = forall b. MkT b (b->a)-                              --     con_ex_tvs = {b}-                              -- False => con_ex_tvs is empty-      , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only-      , con_mb_cxt :: Maybe (LHsContext pass)         -- ^ User-written context (if any)-      , con_args   :: HsConDeclDetails pass           -- ^ Arguments; can be InfixCon--      , con_doc       :: Maybe LHsDocString-          -- ^ A possible Haddock comment.-      }-  | XConDecl !(XXConDecl pass)--type instance XConDeclGADT GhcPs = NoExtField-type instance XConDeclGADT GhcRn = [Name] -- Implicitly bound type variables-type instance XConDeclGADT GhcTc = NoExtField--type instance XConDeclH98  (GhcPass _) = NoExtField--type instance XXConDecl (GhcPass _) = NoExtCon--{- Note [GADT abstract syntax]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The types of both forms of GADT constructors are very structured, as they-must consist of the quantified type variables (if provided), followed by the-context (if provided), followed by the argument types (if provided), followed-by the result type. (See "Wrinkle: No nested foralls or contexts" below for-more discussion on the restrictions imposed here.) As a result, instead of-storing the type of a GADT constructor as a single LHsType, we split it up-into its constituent components for easier access.--There are two broad ways to classify GADT constructors:--* Record-syntax constructors. For example:--    data T a where-      K :: forall a. Ord a => { x :: [a], ... } -> T a--* Prefix constructors, which do not use record syntax. For example:--    data T a where-      K :: forall a. Ord a => [a] -> ... -> T a--This distinction is recorded in the `con_args :: HsConDetails pass`, which-tracks if we're dealing with a RecCon or PrefixCon. It is easy to distinguish-the two in the AST since record GADT constructors use HsRecTy. This distinction-is made in GHC.Parser.PostProcess.mkGadtDecl.--It is worth elaborating a bit more on the process of splitting the argument-types of a GADT constructor, since there are some non-obvious details involved.-While splitting the argument types of a record GADT constructor is easy (they-are stored in an HsRecTy), splitting the arguments of a prefix GADT constructor-is trickier. The basic idea is that we must split along the outermost function-arrows ((->) and (%1 ->)) in the type, which GHC.Hs.Type.splitHsFunType-accomplishes. But what about type operators? Consider:--  C :: a :*: b -> a :*: b -> a :+: b--This could parse in many different ways depending on the precedences of each-type operator. In particular, if (:*:) were to have lower precedence than (->),-then it could very well parse like this:--  a :*: ((b -> a) :*: ((b -> a) :+: b)))--This would give the false impression that the whole type is part of one large-return type, with no arguments. Note that we do not fully resolve the exact-precedences of each user-defined type operator until the renamer, so this a-more difficult task for the parser.--Fortunately, there is no risk of the above happening. GHC's parser gives-special treatment to function arrows, and as a result, they are always parsed-with a lower precedence than any other type operator. As a result, the type-above is actually parsed like this:--  (a :*: b) -> ((a :*: b) -> (a :+: b))--While we won't know the exact precedences of (:*:) and (:+:) until the renamer,-all we are concerned about in the parser is identifying the overall shape of-the argument and result types, which we can accomplish by piggybacking on the-special treatment given to function arrows. In a future where function arrows-aren't given special status in the parser, we will likely have to modify-GHC.Parser.PostProcess.mergeOps to preserve this trick.---------- Wrinkle: No nested foralls or contexts--------GADT constructors provide some freedom to change the order of foralls in their-types (see Note [DataCon user type variable binders] in GHC.Core.DataCon), but-this freedom is still limited. GADTs still require that all quantification-occurs "prenex". That is, any explicitly quantified type variables must occur-at the front of the GADT type, followed by any contexts, followed by the body of-the GADT type, in precisely that order. For instance:--  data T where-    MkT1 :: forall a b. (Eq a, Eq b) => a -> b -> T-      -- OK-    MkT2 :: forall a. Eq a => forall b. a -> b -> T-      -- Rejected, `forall b` is nested-    MkT3 :: forall a b. Eq a => Eq b => a -> b -> T-      -- Rejected, `Eq b` is nested-    MkT4 :: Int -> forall a. a -> T-      -- Rejected, `forall a` is nested-    MkT5 :: forall a. Int -> Eq a => a -> T-      -- Rejected, `Eq a` is nested-    MkT6 :: (forall a. a -> T)-      -- Rejected, `forall a` is nested due to the surrounding parentheses-    MkT7 :: (Eq a => a -> t)-      -- Rejected, `Eq a` is nested due to the surrounding parentheses--For the full details, see the "Formal syntax for GADTs" section of the GHC-User's Guide. GHC enforces that GADT constructors do not have nested `forall`s-or contexts in two parts:--1. GHC, in the process of splitting apart a GADT's type,-   extracts out the leading `forall` and context (if they are provided). To-   accomplish this splitting, the renamer uses the-   GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove-   parentheses surrounding the leading `forall` or context (as these-   parentheses can be syntactically significant). If the third result returned-   by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must-   be nested, so they will be rejected.--   Note that this step applies to both prefix and record GADTs alike, as they-   both have syntax which permits `forall`s and contexts. The difference is-   where this step happens:--   * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot-     split until after the type operator fixities have been resolved.-   * For record GADTs, this happens in the parser (in mkGadtDecl).-2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of-   rnConDecl) will then check for nested `forall`s/contexts in the body of a-   prefix GADT type, after it has determined what all of the argument types are.-   This step is necessary to catch examples like MkT4 above, where the nested-   quantification occurs after a visible argument type.--}---- | Haskell data Constructor Declaration Details-type HsConDeclDetails pass-   = HsConDetails (HsScaled pass (LBangType pass)) (Located [LConDeclField pass])--getConNames :: ConDecl GhcRn -> [Located Name]-getConNames ConDeclH98  {con_name  = name}  = [name]-getConNames ConDeclGADT {con_names = names} = names--getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn-getConArgs d = con_args d--hsConDeclArgTys :: HsConDeclDetails pass -> [HsScaled pass (LBangType pass)]-hsConDeclArgTys (PrefixCon tys)    = tys-hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]-hsConDeclArgTys (RecCon flds)      = map (hsLinear . cd_fld_type . unLoc) (unLoc flds)-  -- Remark: with the record syntax, constructors have all their argument-  -- linear, despite the fact that projections do not make sense on linear-  -- constructors. The design here is that the record projection themselves are-  -- typed to take an unrestricted argument (that is the record itself is-  -- unrestricted). By the transfer property, projections are then correct in-  -- that all the non-projected fields have multiplicity Many, and can be dropped.--hsConDeclTheta :: Maybe (LHsContext pass) -> [LHsType pass]-hsConDeclTheta Nothing            = []-hsConDeclTheta (Just (L _ theta)) = theta--pp_data_defn :: (OutputableBndrId p)-                  => (LHsContext (GhcPass p) -> SDoc)   -- Printing the header-                  -> HsDataDefn (GhcPass p)-                  -> SDoc-pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context-                                , dd_cType = mb_ct-                                , dd_kindSig = mb_sig-                                , dd_cons = condecls, dd_derivs = derivings })-  | null condecls-  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig-    <+> pp_derivings derivings--  | otherwise-  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)-       2 (pp_condecls condecls $$ pp_derivings derivings)-  where-    pp_ct = case mb_ct of-               Nothing   -> empty-               Just ct -> ppr ct-    pp_sig = case mb_sig of-               Nothing   -> empty-               Just kind -> dcolon <+> ppr kind-    pp_derivings (L _ ds) = vcat (map ppr ds)--instance OutputableBndrId p-       => Outputable (HsDataDefn (GhcPass p)) where-   ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d--instance OutputableBndrId p-       => Outputable (StandaloneKindSig (GhcPass p)) where-  ppr (StandaloneKindSig _ v ki)-    = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki--instance Outputable NewOrData where-  ppr NewType  = text "newtype"-  ppr DataType = text "data"--pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc-pp_condecls cs-  | gadt_syntax                  -- In GADT syntax-  = hang (text "where") 2 (vcat (map ppr cs))-  | otherwise                    -- In H98 syntax-  = equals <+> sep (punctuate (text " |") (map ppr cs))-  where-    gadt_syntax = case cs of-      []                      -> False-      (L _ ConDeclH98{}  : _) -> False-      (L _ ConDeclGADT{} : _) -> True--instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where-    ppr = pprConDecl--pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc-pprConDecl (ConDeclH98 { con_name = L _ con-                       , con_ex_tvs = ex_tvs-                       , con_mb_cxt = mcxt-                       , con_args = args-                       , con_doc = doc })-  = sep [ ppr_mbDoc doc-        , pprHsForAll (mkHsForAllInvisTele ex_tvs) cxt-        , ppr_details args ]-  where-    -- In ppr_details: let's not print the multiplicities (they are always 1, by-    -- definition) as they do not appear in an actual declaration.-    ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),-                                         pprInfixOcc con,-                                         ppr (hsScaledThing t2)]-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con-                                   : map (pprHsType . unLoc . hsScaledThing) tys)-    ppr_details (RecCon fields)  = pprPrefixOcc con-                                 <+> pprConDeclFields (unLoc fields)-    cxt = fromMaybe noLHsContext mcxt--pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars-                        , con_mb_cxt = mcxt, con_args = args-                        , con_res_ty = res_ty, con_doc = doc })-  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon-    <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt,-              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])-  where-    get_args (PrefixCon args) = map ppr args-    get_args (RecCon fields)  = [pprConDeclFields (unLoc fields)]-    get_args (InfixCon {})    = pprPanic "pprConDecl:GADT" (ppr cons)--    cxt = fromMaybe noLHsContext mcxt--    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)-    ppr_arrow_chain []     = empty--ppr_con_names :: (OutputableBndr a) => [Located a] -> SDoc-ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)--{--************************************************************************-*                                                                      *-                Instance declarations-*                                                                      *-************************************************************************--Note [Type family instance declarations in HsSyn]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The data type FamEqn represents one equation of a type family instance.-Aside from the pass, it is also parameterised over another field, feqn_rhs.-feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType-(for type family instances).--Type family instances also include associated type family default equations.-That is because a default for a type family looks like this:--  class C a where-    type family F a b :: Type-    type F c d = (c,d)   -- Default instance--The default declaration is really just a `type instance` declaration, but one-with particularly simple patterns: they must all be distinct type variables.-That's because we will instantiate it (in an instance declaration for `C`) if-we don't give an explicit instance for `F`. Note that the names of the-variables don't need to match those of the class: it really is like a-free-standing `type instance` declaration.--}------------------- Type synonym family instances ----------------- | Located Type Family Instance Equation-type LTyFamInstEqn pass = Located (TyFamInstEqn pass)-  -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'-  --   when in a list---- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | Haskell Type Patterns-type HsTyPats pass = [LHsTypeArg pass]--{- Note [Family instance declaration binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The feqn_pats field of FamEqn (family instance equation) stores the LHS type-(and kind) patterns. Any type (and kind) variables contained-in these type patterns are bound in the hsib_vars field of the HsImplicitBndrs-in FamInstEqn depending on whether or not an explicit forall is present. In-the case of an explicit forall, the hsib_vars only includes kind variables not-bound in the forall. Otherwise, all type (and kind) variables are bound in-the hsib_vars. In the latter case, note that in particular--* The hsib_vars *includes* any anonymous wildcards.  For example-     type instance F a _ = a-  The hsib_vars will be {a, _}.  Remember that each separate wildcard-  '_' gets its own unique.  In this context wildcards behave just like-  an ordinary type variable, only anonymous.--* The hsib_vars *includes* type variables that are already in scope--   Eg   class C s t where-          type F t p :: *-        instance C w (a,b) where-          type F (a,b) x = x->a-   The hsib_vars of the F decl are {a,b,x}, even though the F decl-   is nested inside the 'instance' decl.--   However after the renamer, the uniques will match up:-        instance C w7 (a8,b9) where-          type F (a8,b9) x10 = x10->a8-   so that we can compare the type pattern in the 'instance' decl and-   in the associated 'type' decl--c.f. Note [TyVar binders for associated decls]--}---- | Type Family Instance Equation-type TyFamInstEqn pass = FamInstEqn pass (LHsType pass)---- | Type family default declarations.--- A convenient synonym for 'TyFamInstDecl'.--- See @Note [Type family instance declarations in HsSyn]@.-type TyFamDefltDecl = TyFamInstDecl---- | Located type family default declarations.-type LTyFamDefltDecl pass = Located (TyFamDefltDecl pass)---- | Located Type Family Instance Declaration-type LTyFamInstDecl pass = Located (TyFamInstDecl pass)---- | Type Family Instance Declaration-newtype TyFamInstDecl pass = TyFamInstDecl { tfid_eqn :: TyFamInstEqn pass }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-    --           'GHC.Parser.Annotation.AnnInstance',--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation------------------- Data family instances ----------------- | Located Data Family Instance Declaration-type LDataFamInstDecl pass = Located (DataFamInstDecl pass)---- | Data Family Instance Declaration-newtype DataFamInstDecl pass-  = DataFamInstDecl { dfid_eqn :: FamInstEqn pass (HsDataDefn pass) }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',-    --           'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnInstance',-    --           'GHC.Parser.Annotation.AnnDcolon'-    --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',-    --           'GHC.Parser.Annotation.AnnClose'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation------------------- Family instances (common types) ----------------- | Located Family Instance Equation-type LFamInstEqn pass rhs = Located (FamInstEqn pass rhs)---- | Family Instance Equation-type FamInstEqn pass rhs = HsImplicitBndrs pass (FamEqn pass rhs)-            -- ^ Here, the @pats@ are type patterns (with kind and type bndrs).-            -- See Note [Family instance declaration binders]---- | Family Equation------ One equation in a type family instance declaration, data family instance--- declaration, or type family default.--- See Note [Type family instance declarations in HsSyn]--- See Note [Family instance declaration binders]-data FamEqn pass rhs-  = FamEqn-       { feqn_ext    :: XCFamEqn pass rhs-       , feqn_tycon  :: Located (IdP pass)-       , feqn_bndrs  :: Maybe [LHsTyVarBndr () pass] -- ^ Optional quantified type vars-       , feqn_pats   :: HsTyPats pass-       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration-       , feqn_rhs    :: rhs-       }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'-  | XFamEqn !(XXFamEqn pass rhs)--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--type instance XCFamEqn    (GhcPass _) r = NoExtField-type instance XXFamEqn    (GhcPass _) r = NoExtCon------------------- Class instances ----------------- | Located Class Instance Declaration-type LClsInstDecl pass = Located (ClsInstDecl pass)---- | Class Instance Declaration-data ClsInstDecl pass-  = ClsInstDecl-      { cid_ext     :: XCClsInstDecl pass-      , cid_poly_ty :: LHsSigType pass    -- Context => Class Instance-type-                                          -- Using a polytype means that the renamer conveniently-                                          -- figures out the quantified type variables for us.-      , cid_binds         :: LHsBinds pass       -- Class methods-      , cid_sigs          :: [LSig pass]         -- User-supplied pragmatic info-      , cid_tyfam_insts   :: [LTyFamInstDecl pass]   -- Type family instances-      , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances-      , cid_overlap_mode  :: Maybe (Located OverlapMode)-         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-         --                                    'GHC.Parser.Annotation.AnnClose',--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-      }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance',-    --           'GHC.Parser.Annotation.AnnWhere',-    --           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XClsInstDecl !(XXClsInstDecl pass)--type instance XCClsInstDecl    (GhcPass _) = NoExtField-type instance XXClsInstDecl    (GhcPass _) = NoExtCon------------------- Instances of all kinds ----------------- | Located Instance Declaration-type LInstDecl pass = Located (InstDecl pass)---- | Instance Declaration-data InstDecl pass  -- Both class and family instances-  = ClsInstD-      { cid_d_ext :: XClsInstD pass-      , cid_inst  :: ClsInstDecl pass }-  | DataFamInstD              -- data family instance-      { dfid_ext  :: XDataFamInstD pass-      , dfid_inst :: DataFamInstDecl pass }-  | TyFamInstD              -- type family instance-      { tfid_ext  :: XTyFamInstD pass-      , tfid_inst :: TyFamInstDecl pass }-  | XInstDecl !(XXInstDecl pass)--type instance XClsInstD     (GhcPass _) = NoExtField-type instance XDataFamInstD (GhcPass _) = NoExtField-type instance XTyFamInstD   (GhcPass _) = NoExtField-type instance XXInstDecl    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (TyFamInstDecl (GhcPass p)) where-  ppr = pprTyFamInstDecl TopLevel--pprTyFamInstDecl :: (OutputableBndrId p)-                 => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc-pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })-   = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn--ppr_instance_keyword :: TopLevelFlag -> SDoc-ppr_instance_keyword TopLevel    = text "instance"-ppr_instance_keyword NotTopLevel = empty--pprTyFamDefltDecl :: (OutputableBndrId p)-                  => TyFamDefltDecl (GhcPass p) -> SDoc-pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel--ppr_fam_inst_eqn :: (OutputableBndrId p)-                 => TyFamInstEqn (GhcPass p) -> SDoc-ppr_fam_inst_eqn (HsIB { hsib_body = FamEqn { feqn_tycon  = L _ tycon-                                            , feqn_bndrs  = bndrs-                                            , feqn_pats   = pats-                                            , feqn_fixity = fixity-                                            , feqn_rhs    = rhs }})-    = pprHsFamInstLHS tycon bndrs pats fixity noLHsContext <+> equals <+> ppr rhs--instance OutputableBndrId p-       => Outputable (DataFamInstDecl (GhcPass p)) where-  ppr = pprDataFamInstDecl TopLevel--pprDataFamInstDecl :: (OutputableBndrId p)-                   => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc-pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                             FamEqn { feqn_tycon  = L _ tycon-                                    , feqn_bndrs  = bndrs-                                    , feqn_pats   = pats-                                    , feqn_fixity = fixity-                                    , feqn_rhs    = defn }}})-  = pp_data_defn pp_hdr defn-  where-    pp_hdr ctxt = ppr_instance_keyword top_lvl-              <+> pprHsFamInstLHS tycon bndrs pats fixity ctxt-                  -- pp_data_defn pretty-prints the kind sig. See #14817.--pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                        FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }}}})-  = ppr nd--pprHsFamInstLHS :: (OutputableBndrId p)-   => IdP (GhcPass p)-   -> Maybe [LHsTyVarBndr () (GhcPass p)]-   -> HsTyPats (GhcPass p)-   -> LexicalFixity-   -> LHsContext (GhcPass p)-   -> SDoc-pprHsFamInstLHS thing bndrs typats fixity mb_ctxt-   = hsep [ pprHsExplicitForAll bndrs-          , pprLHsContext mb_ctxt-          , pp_pats typats ]-   where-     pp_pats (patl:patr:pats)-       | Infix <- fixity-       = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in-         case pats of-           [] -> pp_op_app-           _  -> hsep (parens pp_op_app : map ppr pats)--     pp_pats pats = hsep [ pprPrefixOcc thing-                         , hsep (map ppr pats)]--instance OutputableBndrId p-       => Outputable (ClsInstDecl (GhcPass p)) where-    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds-                     , cid_sigs = sigs, cid_tyfam_insts = ats-                     , cid_overlap_mode = mbOverlap-                     , cid_datafam_insts = adts })-      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part-      = top_matter--      | otherwise       -- Laid out-      = vcat [ top_matter <+> text "where"-             , nest 2 $ pprDeclList $-               map (pprTyFamInstDecl NotTopLevel . unLoc)   ats ++-               map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++-               pprLHsBindsForUser binds sigs ]-      where-        top_matter = text "instance" <+> ppOverlapPragma mbOverlap-                                             <+> ppr inst_ty--ppDerivStrategy :: OutputableBndrId p-                => Maybe (LDerivStrategy (GhcPass p)) -> SDoc-ppDerivStrategy mb =-  case mb of-    Nothing       -> empty-    Just (L _ ds) -> ppr ds--ppOverlapPragma :: Maybe (Located OverlapMode) -> SDoc-ppOverlapPragma mb =-  case mb of-    Nothing           -> empty-    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"-    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"-    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"-    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"-    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"-  where-    maybe_stext NoSourceText     alt = text alt-    maybe_stext (SourceText src) _   = text src <+> text "#-}"---instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where-    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl-    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl-    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl---- Extract the declarations of associated data types from an instance--instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]-instDeclDataFamInsts inst_decls-  = concatMap do_one inst_decls-  where-    do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)]-    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))-      = map unLoc fam_insts-    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]-    do_one (L _ (TyFamInstD {}))                              = []--{--************************************************************************-*                                                                      *-\subsection[DerivDecl]{A stand-alone instance deriving declaration}-*                                                                      *-************************************************************************--}---- | Located stand-alone 'deriving instance' declaration-type LDerivDecl pass = Located (DerivDecl pass)---- | Stand-alone 'deriving instance' declaration-data DerivDecl pass = DerivDecl-        { deriv_ext          :: XCDerivDecl pass-        , deriv_type         :: LHsSigWcType pass-          -- ^ The instance type to derive.-          ---          -- It uses an 'LHsSigWcType' because the context is allowed to be a-          -- single wildcard:-          ---          -- > deriving instance _ => Eq (Foo a)-          ---          -- Which signifies that the context should be inferred.--          -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer.--        , deriv_strategy     :: Maybe (LDerivStrategy pass)-        , deriv_overlap_mode :: Maybe (Located OverlapMode)-         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDeriving',-         --        'GHC.Parser.Annotation.AnnInstance', 'GHC.Parser.Annotation.AnnStock',-         --        'GHC.Parser.Annotation.AnnAnyClass', 'Api.AnnNewtype',-         --        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-        }-  | XDerivDecl !(XXDerivDecl pass)--type instance XCDerivDecl    (GhcPass _) = NoExtField-type instance XXDerivDecl    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (DerivDecl (GhcPass p)) where-    ppr (DerivDecl { deriv_type = ty-                   , deriv_strategy = ds-                   , deriv_overlap_mode = o })-        = hsep [ text "deriving"-               , ppDerivStrategy ds-               , text "instance"-               , ppOverlapPragma o-               , ppr ty ]--{--************************************************************************-*                                                                      *-                Deriving strategies-*                                                                      *-************************************************************************--}---- | A 'Located' 'DerivStrategy'.-type LDerivStrategy pass = Located (DerivStrategy pass)---- | Which technique the user explicitly requested when deriving an instance.-data DerivStrategy pass-  -- See Note [Deriving strategies] in GHC.Tc.Deriv-  = StockStrategy    -- ^ GHC's \"standard\" strategy, which is to implement a-                     --   custom instance for the data type. This only works-                     --   for certain types that GHC knows about (e.g., 'Eq',-                     --   'Show', 'Functor' when @-XDeriveFunctor@ is enabled,-                     --   etc.)-  | AnyclassStrategy -- ^ @-XDeriveAnyClass@-  | NewtypeStrategy  -- ^ @-XGeneralizedNewtypeDeriving@-  | ViaStrategy (XViaStrategy pass)-                     -- ^ @-XDerivingVia@--type instance XViaStrategy GhcPs = LHsSigType GhcPs-type instance XViaStrategy GhcRn = LHsSigType GhcRn-type instance XViaStrategy GhcTc = Type--instance OutputableBndrId p-        => Outputable (DerivStrategy (GhcPass p)) where-    ppr StockStrategy    = text "stock"-    ppr AnyclassStrategy = text "anyclass"-    ppr NewtypeStrategy  = text "newtype"-    ppr (ViaStrategy ty) = text "via" <+> case ghcPass @p of-                                            GhcPs -> ppr ty-                                            GhcRn -> ppr ty-                                            GhcTc -> ppr ty---- | A short description of a @DerivStrategy'@.-derivStrategyName :: DerivStrategy a -> SDoc-derivStrategyName = text . go-  where-    go StockStrategy    = "stock"-    go AnyclassStrategy = "anyclass"-    go NewtypeStrategy  = "newtype"-    go (ViaStrategy {}) = "via"---- | Eliminate a 'DerivStrategy'.-foldDerivStrategy :: (p ~ GhcPass pass)-                  => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r-foldDerivStrategy other _   StockStrategy    = other-foldDerivStrategy other _   AnyclassStrategy = other-foldDerivStrategy other _   NewtypeStrategy  = other-foldDerivStrategy _     via (ViaStrategy t)  = via t---- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,--- return the 'DerivStrategy' unchanged.-mapDerivStrategy :: (p ~ GhcPass pass)-                 => (XViaStrategy p -> XViaStrategy p)-                 -> DerivStrategy p -> DerivStrategy p-mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds--{--************************************************************************-*                                                                      *-\subsection[DefaultDecl]{A @default@ declaration}-*                                                                      *-************************************************************************--There can only be one default declaration per module, but it is hard-for the parser to check that; we pass them all through in the abstract-syntax, and that restriction must be checked in the front end.--}---- | Located Default Declaration-type LDefaultDecl pass = Located (DefaultDecl pass)---- | Default Declaration-data DefaultDecl pass-  = DefaultDecl (XCDefaultDecl pass) [LHsType pass]-        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnDefault',-        --          'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XDefaultDecl !(XXDefaultDecl pass)--type instance XCDefaultDecl    (GhcPass _) = NoExtField-type instance XXDefaultDecl    (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (DefaultDecl (GhcPass p)) where-    ppr (DefaultDecl _ tys)-      = text "default" <+> parens (interpp'SP tys)--{--************************************************************************-*                                                                      *-\subsection{Foreign function interface declaration}-*                                                                      *-************************************************************************--}---- foreign declarations are distinguished as to whether they define or use a--- Haskell name------  * the Boolean value indicates whether the pre-standard deprecated syntax---   has been used---- | Located Foreign Declaration-type LForeignDecl pass = Located (ForeignDecl pass)---- | Foreign Declaration-data ForeignDecl pass-  = ForeignImport-      { fd_i_ext  :: XForeignImport pass   -- Post typechecker, rep_ty ~ sig_ty-      , fd_name   :: Located (IdP pass)    -- defines this name-      , fd_sig_ty :: LHsSigType pass       -- sig_ty-      , fd_fi     :: ForeignImport }--  | ForeignExport-      { fd_e_ext  :: XForeignExport pass   -- Post typechecker, rep_ty ~ sig_ty-      , fd_name   :: Located (IdP pass)    -- uses this name-      , fd_sig_ty :: LHsSigType pass       -- sig_ty-      , fd_fe     :: ForeignExport }-        -- ^-        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign',-        --           'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport',-        --           'GHC.Parser.Annotation.AnnDcolon'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XForeignDecl !(XXForeignDecl pass)--{--    In both ForeignImport and ForeignExport:-        sig_ty is the type given in the Haskell code-        rep_ty is the representation for this type, i.e. with newtypes-               coerced away and type functions evaluated.-    Thus if the declaration is valid, then rep_ty will only use types-    such as Int and IO that we know how to make foreign calls with.--}--type instance XForeignImport   GhcPs = NoExtField-type instance XForeignImport   GhcRn = NoExtField-type instance XForeignImport   GhcTc = Coercion--type instance XForeignExport   GhcPs = NoExtField-type instance XForeignExport   GhcRn = NoExtField-type instance XForeignExport   GhcTc = Coercion--type instance XXForeignDecl    (GhcPass _) = NoExtCon---- Specification Of an imported external entity in dependence on the calling--- convention----data ForeignImport = -- import of a C entity-                     ---                     --  * the two strings specifying a header file or library-                     --   may be empty, which indicates the absence of a-                     --   header or object specification (both are not used-                     --   in the case of `CWrapper' and when `CFunction'-                     --   has a dynamic target)-                     ---                     --  * the calling convention is irrelevant for code-                     --   generation in the case of `CLabel', but is needed-                     --   for pretty printing-                     ---                     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'-                     ---                     CImport  (Located CCallConv) -- ccall or stdcall-                              (Located Safety)  -- interruptible, safe or unsafe-                              (Maybe Header)       -- name of C header-                              CImportSpec          -- details of the C entity-                              (Located SourceText) -- original source text for-                                                   -- the C entity-  deriving Data---- details of an external C entity----data CImportSpec = CLabel    CLabelString     -- import address of a C label-                 | CFunction CCallTarget      -- static or dynamic function-                 | CWrapper                   -- wrapper to expose closures-                                              -- (former f.e.d.)-  deriving Data---- specification of an externally exported entity in dependence on the calling--- convention----data ForeignExport = CExport  (Located CExportSpec) -- contains the calling-                                                    -- convention-                              (Located SourceText)  -- original source text for-                                                    -- the C entity-  deriving Data---- pretty printing of foreign declarations-----instance OutputableBndrId p-       => Outputable (ForeignDecl (GhcPass p)) where-  ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })-    = hang (text "foreign import" <+> ppr fimport <+> ppr n)-         2 (dcolon <+> ppr ty)-  ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =-    hang (text "foreign export" <+> ppr fexport <+> ppr n)-       2 (dcolon <+> ppr ty)--instance Outputable ForeignImport where-  ppr (CImport  cconv safety mHeader spec (L _ srcText)) =-    ppr cconv <+> ppr safety-      <+> pprWithSourceText srcText (pprCEntity spec "")-    where-      pp_hdr = case mHeader of-               Nothing -> empty-               Just (Header _ header) -> ftext header--      pprCEntity (CLabel lbl) _ =-        doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl-      pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =-        if dqNeeded then doubleQuotes ce else empty-          where-            dqNeeded = (take 6 src == "static")-                    || isJust mHeader-                    || not isFun-                    || st /= NoSourceText-            ce =-                  -- We may need to drop leading spaces first-                  (if take 6 src == "static" then text "static" else empty)-              <+> pp_hdr-              <+> (if isFun then empty else text "value")-              <+> (pprWithSourceText st empty)-      pprCEntity (CFunction DynamicTarget) _ =-        doubleQuotes $ text "dynamic"-      pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"--instance Outputable ForeignExport where-  ppr (CExport  (L _ (CExportStatic _ lbl cconv)) _) =-    ppr cconv <+> char '"' <> ppr lbl <> char '"'--{--************************************************************************-*                                                                      *-\subsection{Rewrite rules}-*                                                                      *-************************************************************************--}---- | Located Rule Declarations-type LRuleDecls pass = Located (RuleDecls pass)--  -- Note [Pragma source text] in GHC.Types.Basic--- | Rule Declarations-data RuleDecls pass = HsRules { rds_ext   :: XCRuleDecls pass-                              , rds_src   :: SourceText-                              , rds_rules :: [LRuleDecl pass] }-  | XRuleDecls !(XXRuleDecls pass)--type instance XCRuleDecls    (GhcPass _) = NoExtField-type instance XXRuleDecls    (GhcPass _) = NoExtCon---- | Located Rule Declaration-type LRuleDecl pass = Located (RuleDecl pass)---- | Rule Declaration-data RuleDecl pass-  = HsRule -- Source rule-       { rd_ext  :: XHsRule pass-           -- ^ After renamer, free-vars from the LHS and RHS-       , rd_name :: Located (SourceText,RuleName)-           -- ^ Note [Pragma source text] in "GHC.Types.Basic"-       , rd_act  :: Activation-       , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]-           -- ^ Forall'd type vars-       , rd_tmvs :: [LRuleBndr pass]-           -- ^ Forall'd term vars, before typechecking; after typechecking-           --    this includes all forall'd vars-       , rd_lhs  :: Located (HsExpr pass)-       , rd_rhs  :: Located (HsExpr pass)-       }-    -- ^-    --  - 'GHC.Parser.Annotation.AnnKeywordId' :-    --           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnTilde',-    --           'GHC.Parser.Annotation.AnnVal',-    --           'GHC.Parser.Annotation.AnnClose',-    --           'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot',-    --           'GHC.Parser.Annotation.AnnEqual',-  | XRuleDecl !(XXRuleDecl pass)--data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS-  deriving Data--type instance XHsRule       GhcPs = NoExtField-type instance XHsRule       GhcRn = HsRuleRn-type instance XHsRule       GhcTc = HsRuleRn--type instance XXRuleDecl    (GhcPass _) = NoExtCon--flattenRuleDecls :: [LRuleDecls pass] -> [LRuleDecl pass]-flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls---- | Located Rule Binder-type LRuleBndr pass = Located (RuleBndr pass)---- | Rule Binder-data RuleBndr pass-  = RuleBndr (XCRuleBndr pass)  (Located (IdP pass))-  | RuleBndrSig (XRuleBndrSig pass) (Located (IdP pass)) (HsPatSigType pass)-  | XRuleBndr !(XXRuleBndr pass)-        -- ^-        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --     'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation--type instance XCRuleBndr    (GhcPass _) = NoExtField-type instance XRuleBndrSig  (GhcPass _) = NoExtField-type instance XXRuleBndr    (GhcPass _) = NoExtCon--collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]-collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]--pprFullRuleName :: Located (SourceText, RuleName) -> SDoc-pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)--instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where-  ppr (HsRules { rds_src = st-               , rds_rules = rules })-    = pprWithSourceText st (text "{-# RULES")-          <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"--instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where-  ppr (HsRule { rd_name = name-              , rd_act  = act-              , rd_tyvs = tys-              , rd_tmvs = tms-              , rd_lhs  = lhs-              , rd_rhs  = rhs })-        = sep [pprFullRuleName name <+> ppr act,-               nest 4 (pp_forall_ty tys <+> pp_forall_tm tys-                                        <+> pprExpr (unLoc lhs)),-               nest 6 (equals <+> pprExpr (unLoc rhs)) ]-        where-          pp_forall_ty Nothing     = empty-          pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot-          pp_forall_tm Nothing | null tms = empty-          pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot--instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where-   ppr (RuleBndr _ name) = ppr name-   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)--{--************************************************************************-*                                                                      *-\subsection[DocDecl]{Document comments}-*                                                                      *-************************************************************************--}---- | Located Documentation comment Declaration-type LDocDecl = Located (DocDecl)---- | Documentation comment Declaration-data DocDecl-  = DocCommentNext HsDocString-  | DocCommentPrev HsDocString-  | DocCommentNamed String HsDocString-  | DocGroup Int HsDocString-  deriving Data---- Okay, I need to reconstruct the document comments, but for now:-instance Outputable DocDecl where-  ppr _ = text "<document comment>"--docDeclDoc :: DocDecl -> HsDocString-docDeclDoc (DocCommentNext d) = d-docDeclDoc (DocCommentPrev d) = d-docDeclDoc (DocCommentNamed _ d) = d-docDeclDoc (DocGroup _ d) = d--{--************************************************************************-*                                                                      *-\subsection[DeprecDecl]{Deprecations}-*                                                                      *-************************************************************************--We use exported entities for things to deprecate.--}---- | Located Warning Declarations-type LWarnDecls pass = Located (WarnDecls pass)-- -- Note [Pragma source text] in GHC.Types.Basic--- | Warning pragma Declarations-data WarnDecls pass = Warnings { wd_ext      :: XWarnings pass-                               , wd_src      :: SourceText-                               , wd_warnings :: [LWarnDecl pass]-                               }-  | XWarnDecls !(XXWarnDecls pass)--type instance XWarnings      (GhcPass _) = NoExtField-type instance XXWarnDecls    (GhcPass _) = NoExtCon---- | Located Warning pragma Declaration-type LWarnDecl pass = Located (WarnDecl pass)---- | Warning pragma Declaration-data WarnDecl pass = Warning (XWarning pass) [Located (IdP pass)] WarningTxt-                   | XWarnDecl !(XXWarnDecl pass)--type instance XWarning      (GhcPass _) = NoExtField-type instance XXWarnDecl    (GhcPass _) = NoExtCon---instance OutputableBndr (IdP (GhcPass p))-        => Outputable (WarnDecls (GhcPass p)) where-    ppr (Warnings _ (SourceText src) decls)-      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"-    ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"--instance OutputableBndr (IdP (GhcPass p))-       => Outputable (WarnDecl (GhcPass p)) where-    ppr (Warning _ thing txt)-      = hsep ( punctuate comma (map ppr thing))-              <+> ppr txt--{--************************************************************************-*                                                                      *-\subsection[AnnDecl]{Annotations}-*                                                                      *-************************************************************************--}---- | Located Annotation Declaration-type LAnnDecl pass = Located (AnnDecl pass)---- | Annotation Declaration-data AnnDecl pass = HsAnnotation-                      (XHsAnnotation pass)-                      SourceText -- Note [Pragma source text] in GHC.Types.Basic-                      (AnnProvenance (IdP pass)) (Located (HsExpr pass))-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-      --           'GHC.Parser.Annotation.AnnType'-      --           'GHC.Parser.Annotation.AnnModule'-      --           'GHC.Parser.Annotation.AnnClose'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XAnnDecl !(XXAnnDecl pass)--type instance XHsAnnotation (GhcPass _) = NoExtField-type instance XXAnnDecl     (GhcPass _) = NoExtCon--instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where-    ppr (HsAnnotation _ _ provenance expr)-      = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]---- | Annotation Provenance-data AnnProvenance name = ValueAnnProvenance (Located name)-                        | TypeAnnProvenance (Located name)-                        | ModuleAnnProvenance-deriving instance Functor     AnnProvenance-deriving instance Foldable    AnnProvenance-deriving instance Traversable AnnProvenance-deriving instance (Data pass) => Data (AnnProvenance pass)--annProvenanceName_maybe :: AnnProvenance name -> Maybe name-annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name-annProvenanceName_maybe (TypeAnnProvenance (L _ name))  = Just name-annProvenanceName_maybe ModuleAnnProvenance       = Nothing--pprAnnProvenance :: OutputableBndr name => AnnProvenance name -> SDoc-pprAnnProvenance ModuleAnnProvenance       = text "ANN module"-pprAnnProvenance (ValueAnnProvenance (L _ name))-  = text "ANN" <+> ppr name-pprAnnProvenance (TypeAnnProvenance (L _ name))-  = text "ANN type" <+> ppr name--{--************************************************************************-*                                                                      *-\subsection[RoleAnnot]{Role annotations}-*                                                                      *-************************************************************************--}---- | Located Role Annotation Declaration-type LRoleAnnotDecl pass = Located (RoleAnnotDecl pass)---- See #8185 for more info about why role annotations are--- top-level declarations--- | Role Annotation Declaration-data RoleAnnotDecl pass-  = RoleAnnotDecl (XCRoleAnnotDecl pass)-                  (Located (IdP pass))   -- type constructor-                  [Located (Maybe Role)] -- optional annotations-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',-      --           'GHC.Parser.Annotation.AnnRole'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XRoleAnnotDecl !(XXRoleAnnotDecl pass)--type instance XCRoleAnnotDecl (GhcPass _) = NoExtField-type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon--instance OutputableBndr (IdP (GhcPass p))-       => Outputable (RoleAnnotDecl (GhcPass p)) where-  ppr (RoleAnnotDecl _ ltycon roles)-    = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>-      hsep (map (pp_role . unLoc) roles)-    where-      pp_role Nothing  = underscore-      pp_role (Just r) = ppr r--roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)-roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans     #-} -- Outputable++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- | Abstract syntax of global declarations.+--+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,+-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.+module GHC.Hs.Decls (+  -- * Toplevel declarations+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,+  HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,+  NewOrData(..), newOrDataToFlavour,+  StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,++  -- ** Class or type declarations+  TyClDecl(..), LTyClDecl, DataDeclRn(..),+  TyClGroup(..),+  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,+  tyClGroupKindSigs,+  isClassDecl, isDataDecl, isSynDecl, tcdName,+  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,+  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,+  tyFamInstDeclName, tyFamInstDeclLName,+  countTyClDecls, pprTyClDeclFlavour,+  tyClDeclLName, tyClDeclTyVars,+  hsDeclHasCusk, famResultKindSignature,+  FamilyDecl(..), LFamilyDecl,+  FunDep(..),++  -- ** Instance declarations+  InstDecl(..), LInstDecl, FamilyInfo(..),+  TyFamInstDecl(..), LTyFamInstDecl, instDeclDataFamInsts,+  TyFamDefltDecl, LTyFamDefltDecl,+  DataFamInstDecl(..), LDataFamInstDecl,+  pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  LClsInstDecl, ClsInstDecl(..),++  -- ** Standalone deriving declarations+  DerivDecl(..), LDerivDecl,+  -- ** Deriving strategies+  DerivStrategy(..), LDerivStrategy,+  derivStrategyName, foldDerivStrategy, mapDerivStrategy,+  XViaStrategyPs(..),+  -- ** @RULE@ declarations+  LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),+  HsRuleAnn(..),+  RuleBndr(..),LRuleBndr,+  collectRuleBndrSigTys,+  flattenRuleDecls, pprFullRuleName,+  -- ** @default@ declarations+  DefaultDecl(..), LDefaultDecl,+  -- ** Template haskell declaration splice+  SpliceExplicitFlag(..),+  SpliceDecl(..), LSpliceDecl,+  -- ** Foreign function interface declarations+  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),+  CImportSpec(..),+  -- ** Data-constructor declarations+  ConDecl(..), LConDecl,+  HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,+  getConNames, getRecConArgs_maybe,+  -- ** Document comments+  DocDecl(..), LDocDecl, docDeclDoc,+  -- ** Deprecations+  WarnDecl(..),  LWarnDecl,+  WarnDecls(..), LWarnDecls,+  -- ** Annotations+  AnnDecl(..), LAnnDecl,+  AnnProvenance(..), annProvenanceName_maybe,+  -- ** Role annotations+  RoleAnnotDecl(..), LRoleAnnotDecl, roleAnnotDeclName,+  -- ** Injective type families+  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,+  resultVariableName, familyDeclLName, familyDeclName,++  -- * Grouping+  HsGroup(..),  emptyRdrGroup, emptyRnGroup, appendGroups, hsGroupInstDecls,+  hsGroupTopLevelFixitySigs,++  partitionBindsAndSigs,+    ) where++-- friends:+import GHC.Prelude++import Language.Haskell.Syntax.Decls++import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprSpliceDecl )+        -- Because Expr imports Decls via HsBracket++import GHC.Hs.Binds+import GHC.Hs.Type+import GHC.Hs.Doc+import GHC.Types.Basic+import GHC.Core.Coercion+import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Parser.Annotation+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Fixity++-- others:+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Core.Type+import GHC.Types.ForeignCall++import GHC.Data.Bag+import GHC.Data.Maybe+import Data.Data (Data)++{-+************************************************************************+*                                                                      *+\subsection[HsDecl]{Declarations}+*                                                                      *+************************************************************************+-}++type instance XTyClD      (GhcPass _) = NoExtField+type instance XInstD      (GhcPass _) = NoExtField+type instance XDerivD     (GhcPass _) = NoExtField+type instance XValD       (GhcPass _) = NoExtField+type instance XSigD       (GhcPass _) = NoExtField+type instance XKindSigD   (GhcPass _) = NoExtField+type instance XDefD       (GhcPass _) = NoExtField+type instance XForD       (GhcPass _) = NoExtField+type instance XWarningD   (GhcPass _) = NoExtField+type instance XAnnD       (GhcPass _) = NoExtField+type instance XRuleD      (GhcPass _) = NoExtField+type instance XSpliceD    (GhcPass _) = NoExtField+type instance XDocD       (GhcPass _) = NoExtField+type instance XRoleAnnotD (GhcPass _) = NoExtField+type instance XXHsDecl    (GhcPass _) = NoExtCon++-- | Partition a list of HsDecls into function/pattern bindings, signatures,+-- type family declarations, type family instances, and documentation comments.+--+-- Panics when given a declaration that cannot be put into any of the output+-- groups.+--+-- The primary use of this function is to implement+-- 'GHC.Parser.PostProcess.cvBindsAndSigs'.+partitionBindsAndSigs+  :: [LHsDecl GhcPs]+  -> (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],+      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])+partitionBindsAndSigs = go+  where+    go [] = (emptyBag, [], [], [], [], [])+    go ((L l decl) : ds) =+      let (bs, ss, ts, tfis, dfis, docs) = go ds in+      case decl of+        ValD _ b+          -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs)+        SigD _ s+          -> (bs, L l s : ss, ts, tfis, dfis, docs)+        TyClD _ (FamDecl _ t)+          -> (bs, ss, L l t : ts, tfis, dfis, docs)+        InstD _ (TyFamInstD { tfid_inst = tfi })+          -> (bs, ss, ts, L l tfi : tfis, dfis, docs)+        InstD _ (DataFamInstD { dfid_inst = dfi })+          -> (bs, ss, ts, tfis, L l dfi : dfis, docs)+        DocD _ d+          -> (bs, ss, ts, tfis, dfis, L l d : docs)+        _ -> pprPanic "partitionBindsAndSigs" (ppr decl)++type instance XCHsGroup (GhcPass _) = NoExtField+type instance XXHsGroup (GhcPass _) = NoExtCon+++emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup (GhcPass p)+emptyRdrGroup = emptyGroup { hs_valds = emptyValBindsIn }+emptyRnGroup  = emptyGroup { hs_valds = emptyValBindsOut }++emptyGroup = HsGroup { hs_ext = noExtField,+                       hs_tyclds = [],+                       hs_derivds = [],+                       hs_fixds = [], hs_defds = [], hs_annds = [],+                       hs_fords = [], hs_warnds = [], hs_ruleds = [],+                       hs_valds = error "emptyGroup hs_valds: Can't happen",+                       hs_splcds = [],+                       hs_docs = [] }++-- | The fixity signatures for each top-level declaration and class method+-- in an 'HsGroup'.+-- See Note [Top-level fixity signatures in an HsGroup]+hsGroupTopLevelFixitySigs :: HsGroup (GhcPass p) -> [LFixitySig (GhcPass p)]+hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =+    fixds ++ cls_fixds+  where+    cls_fixds = [ L loc sig+                | L _ ClassDecl{tcdSigs = sigs} <- tyClGroupTyClDecls tyclds+                , L loc (FixSig _ sig) <- sigs+                ]++appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)+             -> HsGroup (GhcPass p)+appendGroups+    HsGroup {+        hs_valds  = val_groups1,+        hs_splcds = spliceds1,+        hs_tyclds = tyclds1,+        hs_derivds = derivds1,+        hs_fixds  = fixds1,+        hs_defds  = defds1,+        hs_annds  = annds1,+        hs_fords  = fords1,+        hs_warnds = warnds1,+        hs_ruleds = rulds1,+        hs_docs   = docs1 }+    HsGroup {+        hs_valds  = val_groups2,+        hs_splcds = spliceds2,+        hs_tyclds = tyclds2,+        hs_derivds = derivds2,+        hs_fixds  = fixds2,+        hs_defds  = defds2,+        hs_annds  = annds2,+        hs_fords  = fords2,+        hs_warnds = warnds2,+        hs_ruleds = rulds2,+        hs_docs   = docs2 }+  =+    HsGroup {+        hs_ext    = noExtField,+        hs_valds  = val_groups1 `plusHsValBinds` val_groups2,+        hs_splcds = spliceds1 ++ spliceds2,+        hs_tyclds = tyclds1 ++ tyclds2,+        hs_derivds = derivds1 ++ derivds2,+        hs_fixds  = fixds1 ++ fixds2,+        hs_annds  = annds1 ++ annds2,+        hs_defds  = defds1 ++ defds2,+        hs_fords  = fords1 ++ fords2,+        hs_warnds = warnds1 ++ warnds2,+        hs_ruleds = rulds1 ++ rulds2,+        hs_docs   = docs1  ++ docs2 }++instance (OutputableBndrId p) => Outputable (HsDecl (GhcPass p)) where+    ppr (TyClD _ dcl)             = ppr dcl+    ppr (ValD _ binds)            = ppr binds+    ppr (DefD _ def)              = ppr def+    ppr (InstD _ inst)            = ppr inst+    ppr (DerivD _ deriv)          = ppr deriv+    ppr (ForD _ fd)               = ppr fd+    ppr (SigD _ sd)               = ppr sd+    ppr (KindSigD _ ksd)          = ppr ksd+    ppr (RuleD _ rd)              = ppr rd+    ppr (WarningD _ wd)           = ppr wd+    ppr (AnnD _ ad)               = ppr ad+    ppr (SpliceD _ dd)            = ppr dd+    ppr (DocD _ doc)              = ppr doc+    ppr (RoleAnnotD _ ra)         = ppr ra++instance (OutputableBndrId p) => Outputable (HsGroup (GhcPass p)) where+    ppr (HsGroup { hs_valds  = val_decls,+                   hs_tyclds = tycl_decls,+                   hs_derivds = deriv_decls,+                   hs_fixds  = fix_decls,+                   hs_warnds = deprec_decls,+                   hs_annds  = ann_decls,+                   hs_fords  = foreign_decls,+                   hs_defds  = default_decls,+                   hs_ruleds = rule_decls })+        = vcat_mb empty+            [ppr_ds fix_decls, ppr_ds default_decls,+             ppr_ds deprec_decls, ppr_ds ann_decls,+             ppr_ds rule_decls,+             if isEmptyValBinds val_decls+                then Nothing+                else Just (ppr val_decls),+             ppr_ds (tyClGroupRoleDecls tycl_decls),+             ppr_ds (tyClGroupKindSigs  tycl_decls),+             ppr_ds (tyClGroupTyClDecls tycl_decls),+             ppr_ds (tyClGroupInstDecls tycl_decls),+             ppr_ds deriv_decls,+             ppr_ds foreign_decls]+        where+          ppr_ds :: Outputable a => [a] -> Maybe SDoc+          ppr_ds [] = Nothing+          ppr_ds ds = Just (vcat (map ppr ds))++          vcat_mb :: SDoc -> [Maybe SDoc] -> SDoc+          -- Concatenate vertically with white-space between non-blanks+          vcat_mb _    []             = empty+          vcat_mb gap (Nothing : ds) = vcat_mb gap ds+          vcat_mb gap (Just d  : ds) = gap $$ d $$ vcat_mb blankLine ds++type instance XSpliceDecl      (GhcPass _) = NoExtField+type instance XXSpliceDecl     (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (SpliceDecl (GhcPass p)) where+   ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f++{-+************************************************************************+*                                                                      *+            Type and class declarations+*                                                                      *+************************************************************************+-}++type instance XFamDecl      (GhcPass _) = NoExtField++type instance XSynDecl      GhcPs = EpAnn [AddEpAnn]+type instance XSynDecl      GhcRn = NameSet -- FVs+type instance XSynDecl      GhcTc = NameSet -- FVs++type instance XDataDecl     GhcPs = EpAnn [AddEpAnn]+type instance XDataDecl     GhcRn = DataDeclRn+type instance XDataDecl     GhcTc = DataDeclRn++type instance XClassDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo)  -- See Note [Class LayoutInfo]+  -- TODO:AZ:tidy up AnnSortKey above+type instance XClassDecl    GhcRn = NameSet -- FVs+type instance XClassDecl    GhcTc = NameSet -- FVs++type instance XXTyClDecl    (GhcPass _) = NoExtCon++type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn]+type instance XXTyFamInstDecl (GhcPass _) = NoExtCon++-- Dealing with names++tyFamInstDeclName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                  => TyFamInstDecl (GhcPass p) -> IdP (GhcPass p)+tyFamInstDeclName = unLoc . tyFamInstDeclLName++tyFamInstDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                   => TyFamInstDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))+tyFamInstDeclLName (TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = ln }})+  = ln++tyClDeclLName :: Anno (IdGhcP p) ~ SrcSpanAnnN+              => TyClDecl (GhcPass p) -> LocatedN (IdP (GhcPass p))+tyClDeclLName (FamDecl { tcdFam = fd })     = familyDeclLName fd+tyClDeclLName (SynDecl { tcdLName = ln })   = ln+tyClDeclLName (DataDecl { tcdLName = ln })  = ln+tyClDeclLName (ClassDecl { tcdLName = ln }) = ln++-- FIXME: tcdName is commonly used by both GHC and third-party tools, so it+-- needs to be polymorphic in the pass+tcdName :: Anno (IdGhcP p) ~ SrcSpanAnnN+        => TyClDecl (GhcPass p) -> IdP (GhcPass p)+tcdName = unLoc . tyClDeclLName++-- | Does this declaration have a complete, user-supplied kind signature?+-- See Note [CUSKs: complete user-supplied kind signatures]+hsDeclHasCusk :: TyClDecl GhcRn -> Bool+hsDeclHasCusk (FamDecl { tcdFam =+    FamilyDecl { fdInfo      = fam_info+               , fdTyVars    = tyvars+               , fdResultSig = L _ resultSig } }) =+    case fam_info of+      ClosedTypeFamily {} -> hsTvbAllKinded tyvars+                          && isJust (famResultKindSignature resultSig)+      _ -> True -- Un-associated open type/data families have CUSKs+hsDeclHasCusk (SynDecl { tcdTyVars = tyvars, tcdRhs = rhs })+  = hsTvbAllKinded tyvars && isJust (hsTyKindSig rhs)+hsDeclHasCusk (DataDecl { tcdDExt = DataDeclRn { tcdDataCusk = cusk }}) = cusk+hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars++-- Pretty-printing TyClDecl+-- ~~~~~~~~~~~~~~~~~~~~~~~~++instance (OutputableBndrId p) => Outputable (TyClDecl (GhcPass p)) where++    ppr (FamDecl { tcdFam = decl }) = ppr decl+    ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                 , tcdRhs = rhs })+      = hang (text "type" <+>+              pp_vanilla_decl_head ltycon tyvars fixity Nothing <+> equals)+          4 (ppr rhs)++    ppr (DataDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdFixity = fixity+                  , tcdDataDefn = defn })+      = pp_data_defn (pp_vanilla_decl_head ltycon tyvars fixity) defn++    ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars,+                    tcdFixity = fixity,+                    tcdFDs  = fds,+                    tcdSigs = sigs, tcdMeths = methods,+                    tcdATs = ats, tcdATDefs = at_defs})+      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part+      = top_matter++      | otherwise       -- Laid out+      = vcat [ top_matter <+> text "where"+             , nest 2 $ pprDeclList (map (ppr . unLoc) ats +++                                     map (pprTyFamDefltDecl . unLoc) at_defs +++                                     pprLHsBindsForUser methods sigs) ]+      where+        top_matter = text "class"+                    <+> pp_vanilla_decl_head lclas tyvars fixity context+                    <+> pprFundeps (map unLoc fds)++instance OutputableBndrId p+       => Outputable (TyClGroup (GhcPass p)) where+  ppr (TyClGroup { group_tyclds = tyclds+                 , group_roles = roles+                 , group_kisigs = kisigs+                 , group_instds = instds+                 }+      )+    = hang (text "TyClGroup") 2 $+      ppr kisigs $$+      ppr tyclds $$+      ppr roles $$+      ppr instds++pp_vanilla_decl_head :: (OutputableBndrId p)+   => XRec (GhcPass p) (IdP (GhcPass p))+   -> LHsQTyVars (GhcPass p)+   -> LexicalFixity+   -> Maybe (LHsContext (GhcPass p))+   -> SDoc+pp_vanilla_decl_head thing (HsQTvs { hsq_explicit = tyvars }) fixity context+ = hsep [pprLHsContext context, pp_tyvars tyvars]+  where+    pp_tyvars (varl:varsr)+      | fixity == Infix && length varsr > 1+         = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)+                , (ppr.unLoc) (head varsr), char ')'+                , hsep (map (ppr.unLoc) (tail varsr))]+      | fixity == Infix+         = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)+         , hsep (map (ppr.unLoc) varsr)]+      | otherwise = hsep [ pprPrefixOcc (unLoc thing)+                  , hsep (map (ppr.unLoc) (varl:varsr))]+    pp_tyvars [] = pprPrefixOcc (unLoc thing)++pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> SDoc+pprTyClDeclFlavour (ClassDecl {})   = text "class"+pprTyClDeclFlavour (SynDecl {})     = text "type"+pprTyClDeclFlavour (FamDecl { tcdFam = FamilyDecl { fdInfo = info }})+  = pprFlavour info <+> text "family"+pprTyClDeclFlavour (DataDecl { tcdDataDefn = HsDataDefn { dd_ND = nd } })+  = ppr nd++instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where+  ppr = pprFunDep++type instance XCFunDep    (GhcPass _) = EpAnn [AddEpAnn]+type instance XXFunDep    (GhcPass _) = NoExtCon++pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc+pprFundeps []  = empty+pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))++pprFunDep :: OutputableBndrId p => FunDep (GhcPass p) -> SDoc+pprFunDep (FunDep _ us vs) = hsep [interppSP us, arrow, interppSP vs]++{- *********************************************************************+*                                                                      *+                         TyClGroup+        Strongly connected components of+      type, class, instance, and role declarations+*                                                                      *+********************************************************************* -}++type instance XCTyClGroup (GhcPass _) = NoExtField+type instance XXTyClGroup (GhcPass _) = NoExtCon+++{- *********************************************************************+*                                                                      *+               Data and type family declarations+*                                                                      *+********************************************************************* -}++type instance XNoSig            (GhcPass _) = NoExtField+type instance XCKindSig         (GhcPass _) = NoExtField++type instance XTyVarSig         (GhcPass _) = NoExtField+type instance XXFamilyResultSig (GhcPass _) = NoExtCon++type instance XCFamilyDecl    (GhcPass _) = EpAnn [AddEpAnn]+type instance XXFamilyDecl    (GhcPass _) = NoExtCon+++------------- Functions over FamilyDecls -----------++familyDeclLName :: FamilyDecl (GhcPass p) -> XRec (GhcPass p) (IdP (GhcPass p))+familyDeclLName (FamilyDecl { fdLName = n }) = n++familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)+familyDeclName = unLoc . familyDeclLName++famResultKindSignature :: FamilyResultSig (GhcPass p) -> Maybe (LHsKind (GhcPass p))+famResultKindSignature (NoSig _) = Nothing+famResultKindSignature (KindSig _ ki) = Just ki+famResultKindSignature (TyVarSig _ bndr) =+  case unLoc bndr of+    UserTyVar _ _ _ -> Nothing+    KindedTyVar _ _ _ ki -> Just ki++-- | Maybe return name of the result type variable+resultVariableName :: FamilyResultSig (GhcPass a) -> Maybe (IdP (GhcPass a))+resultVariableName (TyVarSig _ sig) = Just $ hsLTyVarName sig+resultVariableName _                = Nothing++------------- Pretty printing FamilyDecls -----------++type instance XCInjectivityAnn  (GhcPass _) = EpAnn [AddEpAnn]+type instance XXInjectivityAnn  (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (FamilyDecl (GhcPass p)) where+  ppr (FamilyDecl { fdInfo = info, fdLName = ltycon+                  , fdTopLevel = top_level+                  , fdTyVars = tyvars+                  , fdFixity = fixity+                  , fdResultSig = L _ result+                  , fdInjectivityAnn = mb_inj })+    = vcat [ pprFlavour info <+> pp_top_level <+>+             pp_vanilla_decl_head ltycon tyvars fixity Nothing <+>+             pp_kind <+> pp_inj <+> pp_where+           , nest 2 $ pp_eqns ]+    where+      pp_top_level = case top_level of+                       TopLevel    -> text "family"+                       NotTopLevel -> empty++      pp_kind = case result of+                  NoSig    _         -> empty+                  KindSig  _ kind    -> dcolon <+> ppr kind+                  TyVarSig _ tv_bndr -> text "=" <+> ppr tv_bndr+      pp_inj = case mb_inj of+                 Just (L _ (InjectivityAnn _ lhs rhs)) ->+                   hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]+                 Nothing -> empty+      (pp_where, pp_eqns) = case info of+        ClosedTypeFamily mb_eqns ->+          ( text "where"+          , case mb_eqns of+              Nothing   -> text ".."+              Just eqns -> vcat $ map (ppr_fam_inst_eqn . unLoc) eqns )+        _ -> (empty, empty)++++{- *********************************************************************+*                                                                      *+               Data types and data constructors+*                                                                      *+********************************************************************* -}++type instance XCHsDataDefn    (GhcPass _) = NoExtField+type instance XXHsDataDefn    (GhcPass _) = NoExtCon++type instance XCHsDerivingClause    (GhcPass _) = EpAnn [AddEpAnn]+type instance XXHsDerivingClause    (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (HsDerivingClause (GhcPass p)) where+  ppr (HsDerivingClause { deriv_clause_strategy = dcs+                        , deriv_clause_tys      = L _ dct })+    = hsep [ text "deriving"+           , pp_strat_before+           , ppr dct+           , pp_strat_after ]+      where+        -- @via@ is unique in that in comes /after/ the class being derived,+        -- so we must special-case it.+        (pp_strat_before, pp_strat_after) =+          case dcs of+            Just (L _ via@ViaStrategy{}) -> (empty, ppr via)+            _                            -> (ppDerivStrategy dcs, empty)++type instance XDctSingle (GhcPass _) = NoExtField+type instance XDctMulti  (GhcPass _) = NoExtField+type instance XXDerivClauseTys (GhcPass _) = NoExtCon++instance OutputableBndrId p => Outputable (DerivClauseTys (GhcPass p)) where+  ppr (DctSingle _ ty) = ppr ty+  ppr (DctMulti _ tys) = parens (interpp'SP tys)++type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn]+type instance XStandaloneKindSig GhcRn = NoExtField+type instance XStandaloneKindSig GhcTc = NoExtField++type instance XXStandaloneKindSig (GhcPass p) = NoExtCon++standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p)+standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname++type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn]+type instance XConDeclH98  (GhcPass _) = EpAnn [AddEpAnn]++type instance XXConDecl (GhcPass _) = NoExtCon++getConNames :: ConDecl GhcRn -> [LocatedN Name]+getConNames ConDeclH98  {con_name  = name}  = [name]+getConNames ConDeclGADT {con_names = names} = names++-- | Return @'Just' fields@ if a data constructor declaration uses record+-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors.+-- Otherwise, return 'Nothing'.+getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (LocatedL [LConDeclField GhcRn])+getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of+  PrefixCon{} -> Nothing+  RecCon flds -> Just flds+  InfixCon{}  -> Nothing+getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of+  PrefixConGADT{} -> Nothing+  RecConGADT flds -> Just flds++hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)]+hsConDeclTheta Nothing            = []+hsConDeclTheta (Just (L _ theta)) = theta++pp_data_defn :: (OutputableBndrId p)+                  => (Maybe (LHsContext (GhcPass p)) -> SDoc)   -- Printing the header+                  -> HsDataDefn (GhcPass p)+                  -> SDoc+pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context+                                , dd_cType = mb_ct+                                , dd_kindSig = mb_sig+                                , dd_cons = condecls, dd_derivs = derivings })+  | null condecls+  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig+    <+> pp_derivings derivings++  | otherwise+  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)+       2 (pp_condecls condecls $$ pp_derivings derivings)+  where+    pp_ct = case mb_ct of+               Nothing   -> empty+               Just ct -> ppr ct+    pp_sig = case mb_sig of+               Nothing   -> empty+               Just kind -> dcolon <+> ppr kind+    pp_derivings ds = vcat (map ppr ds)++instance OutputableBndrId p+       => Outputable (HsDataDefn (GhcPass p)) where+   ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d++instance OutputableBndrId p+       => Outputable (StandaloneKindSig (GhcPass p)) where+  ppr (StandaloneKindSig _ v ki)+    = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki++pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc+pp_condecls cs+  | gadt_syntax                  -- In GADT syntax+  = hang (text "where") 2 (vcat (map ppr cs))+  | otherwise                    -- In H98 syntax+  = equals <+> sep (punctuate (text " |") (map ppr cs))+  where+    gadt_syntax = case cs of+      []                      -> False+      (L _ ConDeclH98{}  : _) -> False+      (L _ ConDeclGADT{} : _) -> True++instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where+    ppr = pprConDecl++pprConDecl :: forall p. OutputableBndrId p => ConDecl (GhcPass p) -> SDoc+pprConDecl (ConDeclH98 { con_name = L _ con+                       , con_ex_tvs = ex_tvs+                       , con_mb_cxt = mcxt+                       , con_args = args+                       , con_doc = doc })+  = sep [ ppr_mbDoc doc+        , pprHsForAll (mkHsForAllInvisTele noAnn ex_tvs) mcxt+        , ppr_details args ]+  where+    -- In ppr_details: let's not print the multiplicities (they are always 1, by+    -- definition) as they do not appear in an actual declaration.+    ppr_details (InfixCon t1 t2) = hsep [ppr (hsScaledThing t1),+                                         pprInfixOcc con,+                                         ppr (hsScaledThing t2)]+    ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con+                                    : map (pprHsType . unLoc . hsScaledThing) tys)+    ppr_details (RecCon fields)  = pprPrefixOcc con+                                 <+> pprConDeclFields (unLoc fields)++pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs+                        , con_mb_cxt = mcxt, con_g_args = args+                        , con_res_ty = res_ty, con_doc = doc })+  = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon+    <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,+              ppr_arrow_chain (get_args args ++ [ppr res_ty]) ])+  where+    get_args (PrefixConGADT args) = map ppr args+    get_args (RecConGADT fields)  = [pprConDeclFields (unLoc fields)]++    ppr_arrow_chain (a:as) = sep (a : map (arrow <+>) as)+    ppr_arrow_chain []     = empty++ppr_con_names :: (OutputableBndr a) => [GenLocated l a] -> SDoc+ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)++{-+************************************************************************+*                                                                      *+                Instance declarations+*                                                                      *+************************************************************************+-}++type instance XCFamEqn    (GhcPass _) r = EpAnn [AddEpAnn]+type instance XXFamEqn    (GhcPass _) r = NoExtCon++type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA++----------------- Class instances -------------++type instance XCClsInstDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up+type instance XCClsInstDecl    GhcRn = NoExtField+type instance XCClsInstDecl    GhcTc = NoExtField++type instance XXClsInstDecl    (GhcPass _) = NoExtCon++----------------- Instances of all kinds -------------++type instance XClsInstD     (GhcPass _) = NoExtField++type instance XDataFamInstD GhcPs = EpAnn [AddEpAnn]+type instance XDataFamInstD GhcRn = NoExtField+type instance XDataFamInstD GhcTc = NoExtField++type instance XTyFamInstD   GhcPs = NoExtField+type instance XTyFamInstD   GhcRn = NoExtField+type instance XTyFamInstD   GhcTc = NoExtField++type instance XXInstDecl    (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (TyFamInstDecl (GhcPass p)) where+  ppr = pprTyFamInstDecl TopLevel++pprTyFamInstDecl :: (OutputableBndrId p)+                 => TopLevelFlag -> TyFamInstDecl (GhcPass p) -> SDoc+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqn = eqn })+   = text "type" <+> ppr_instance_keyword top_lvl <+> ppr_fam_inst_eqn eqn++ppr_instance_keyword :: TopLevelFlag -> SDoc+ppr_instance_keyword TopLevel    = text "instance"+ppr_instance_keyword NotTopLevel = empty++pprTyFamDefltDecl :: (OutputableBndrId p)+                  => TyFamDefltDecl (GhcPass p) -> SDoc+pprTyFamDefltDecl = pprTyFamInstDecl NotTopLevel++ppr_fam_inst_eqn :: (OutputableBndrId p)+                 => TyFamInstEqn (GhcPass p) -> SDoc+ppr_fam_inst_eqn (FamEqn { feqn_tycon  = L _ tycon+                         , feqn_bndrs  = bndrs+                         , feqn_pats   = pats+                         , feqn_fixity = fixity+                         , feqn_rhs    = rhs })+    = pprHsFamInstLHS tycon bndrs pats fixity Nothing <+> equals <+> ppr rhs++instance OutputableBndrId p+       => Outputable (DataFamInstDecl (GhcPass p)) where+  ppr = pprDataFamInstDecl TopLevel++pprDataFamInstDecl :: (OutputableBndrId p)+                   => TopLevelFlag -> DataFamInstDecl (GhcPass p) -> SDoc+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_eqn =+                            (FamEqn { feqn_tycon  = L _ tycon+                                    , feqn_bndrs  = bndrs+                                    , feqn_pats   = pats+                                    , feqn_fixity = fixity+                                    , feqn_rhs    = defn })})+  = pp_data_defn pp_hdr defn+  where+    pp_hdr mctxt = ppr_instance_keyword top_lvl+              <+> pprHsFamInstLHS tycon bndrs pats fixity mctxt+                  -- pp_data_defn pretty-prints the kind sig. See #14817.++pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc+pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn =+                       (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})})+  = ppr nd++pprHsFamInstLHS :: (OutputableBndrId p)+   => IdP (GhcPass p)+   -> HsOuterFamEqnTyVarBndrs (GhcPass p)+   -> HsTyPats (GhcPass p)+   -> LexicalFixity+   -> Maybe (LHsContext (GhcPass p))+   -> SDoc+pprHsFamInstLHS thing bndrs typats fixity mb_ctxt+   = hsep [ pprHsOuterFamEqnTyVarBndrs bndrs+          , pprLHsContext mb_ctxt+          , pp_pats typats ]+   where+     pp_pats (patl:patr:pats)+       | Infix <- fixity+       = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in+         case pats of+           [] -> pp_op_app+           _  -> hsep (parens pp_op_app : map ppr pats)++     pp_pats pats = hsep [ pprPrefixOcc thing+                         , hsep (map ppr pats)]++instance OutputableBndrId p+       => Outputable (ClsInstDecl (GhcPass p)) where+    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds+                     , cid_sigs = sigs, cid_tyfam_insts = ats+                     , cid_overlap_mode = mbOverlap+                     , cid_datafam_insts = adts })+      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part+      = top_matter++      | otherwise       -- Laid out+      = vcat [ top_matter <+> text "where"+             , nest 2 $ pprDeclList $+               map (pprTyFamInstDecl NotTopLevel . unLoc)   ats +++               map (pprDataFamInstDecl NotTopLevel . unLoc) adts +++               pprLHsBindsForUser binds sigs ]+      where+        top_matter = text "instance" <+> ppOverlapPragma mbOverlap+                                             <+> ppr inst_ty++ppDerivStrategy :: OutputableBndrId p+                => Maybe (LDerivStrategy (GhcPass p)) -> SDoc+ppDerivStrategy mb =+  case mb of+    Nothing       -> empty+    Just (L _ ds) -> ppr ds++ppOverlapPragma :: Maybe (LocatedP OverlapMode) -> SDoc+ppOverlapPragma mb =+  case mb of+    Nothing           -> empty+    Just (L _ (NoOverlap s))    -> maybe_stext s "{-# NO_OVERLAP #-}"+    Just (L _ (Overlappable s)) -> maybe_stext s "{-# OVERLAPPABLE #-}"+    Just (L _ (Overlapping s))  -> maybe_stext s "{-# OVERLAPPING #-}"+    Just (L _ (Overlaps s))     -> maybe_stext s "{-# OVERLAPS #-}"+    Just (L _ (Incoherent s))   -> maybe_stext s "{-# INCOHERENT #-}"+  where+    maybe_stext NoSourceText     alt = text alt+    maybe_stext (SourceText src) _   = text src <+> text "#-}"+++instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where+    ppr (ClsInstD     { cid_inst  = decl }) = ppr decl+    ppr (TyFamInstD   { tfid_inst = decl }) = ppr decl+    ppr (DataFamInstD { dfid_inst = decl }) = ppr decl++-- Extract the declarations of associated data types from an instance++instDeclDataFamInsts :: [LInstDecl (GhcPass p)] -> [DataFamInstDecl (GhcPass p)]+instDeclDataFamInsts inst_decls+  = concatMap do_one inst_decls+  where+    do_one :: LInstDecl (GhcPass p) -> [DataFamInstDecl (GhcPass p)]+    do_one (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fam_insts } }))+      = map unLoc fam_insts+    do_one (L _ (DataFamInstD { dfid_inst = fam_inst }))      = [fam_inst]+    do_one (L _ (TyFamInstD {}))                              = []++{-+************************************************************************+*                                                                      *+\subsection[DerivDecl]{A stand-alone instance deriving declaration}+*                                                                      *+************************************************************************+-}++type instance XCDerivDecl    (GhcPass _) = EpAnn [AddEpAnn]+type instance XXDerivDecl    (GhcPass _) = NoExtCon++type instance Anno OverlapMode = SrcSpanAnnP++instance OutputableBndrId p+       => Outputable (DerivDecl (GhcPass p)) where+    ppr (DerivDecl { deriv_type = ty+                   , deriv_strategy = ds+                   , deriv_overlap_mode = o })+        = hsep [ text "deriving"+               , ppDerivStrategy ds+               , text "instance"+               , ppOverlapPragma o+               , ppr ty ]++{-+************************************************************************+*                                                                      *+                Deriving strategies+*                                                                      *+************************************************************************+-}++type instance XStockStrategy    GhcPs = EpAnn [AddEpAnn]+type instance XStockStrategy    GhcRn = NoExtField+type instance XStockStrategy    GhcTc = NoExtField++type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn]+type instance XAnyClassStrategy GhcRn = NoExtField+type instance XAnyClassStrategy GhcTc = NoExtField++type instance XNewtypeStrategy  GhcPs = EpAnn [AddEpAnn]+type instance XNewtypeStrategy  GhcRn = NoExtField+type instance XNewtypeStrategy  GhcTc = NoExtField++type instance XViaStrategy GhcPs = XViaStrategyPs+type instance XViaStrategy GhcRn = LHsSigType GhcRn+type instance XViaStrategy GhcTc = Type++data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs)++instance OutputableBndrId p+        => Outputable (DerivStrategy (GhcPass p)) where+    ppr (StockStrategy    _) = text "stock"+    ppr (AnyclassStrategy _) = text "anyclass"+    ppr (NewtypeStrategy  _) = text "newtype"+    ppr (ViaStrategy ty)     = text "via" <+> case ghcPass @p of+                                                GhcPs -> ppr ty+                                                GhcRn -> ppr ty+                                                GhcTc -> ppr ty++instance Outputable XViaStrategyPs where+    ppr (XViaStrategyPs _ t) = ppr t+++-- | Eliminate a 'DerivStrategy'.+foldDerivStrategy :: (p ~ GhcPass pass)+                  => r -> (XViaStrategy p -> r) -> DerivStrategy p -> r+foldDerivStrategy other _   (StockStrategy    _) = other+foldDerivStrategy other _   (AnyclassStrategy _) = other+foldDerivStrategy other _   (NewtypeStrategy  _) = other+foldDerivStrategy _     via (ViaStrategy t)  = via t++-- | Map over the @via@ type if dealing with 'ViaStrategy'. Otherwise,+-- return the 'DerivStrategy' unchanged.+mapDerivStrategy :: (p ~ GhcPass pass)+                 => (XViaStrategy p -> XViaStrategy p)+                 -> DerivStrategy p -> DerivStrategy p+mapDerivStrategy f ds = foldDerivStrategy ds (ViaStrategy . f) ds++{-+************************************************************************+*                                                                      *+\subsection[DefaultDecl]{A @default@ declaration}+*                                                                      *+************************************************************************+-}++type instance XCDefaultDecl    GhcPs = EpAnn [AddEpAnn]+type instance XCDefaultDecl    GhcRn = NoExtField+type instance XCDefaultDecl    GhcTc = NoExtField++type instance XXDefaultDecl    (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (DefaultDecl (GhcPass p)) where+    ppr (DefaultDecl _ tys)+      = text "default" <+> parens (interpp'SP tys)++{-+************************************************************************+*                                                                      *+\subsection{Foreign function interface declaration}+*                                                                      *+************************************************************************+-}++type instance XForeignImport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignImport   GhcRn = NoExtField+type instance XForeignImport   GhcTc = Coercion++type instance XForeignExport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignExport   GhcRn = NoExtField+type instance XForeignExport   GhcTc = Coercion++type instance XXForeignDecl    (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (ForeignDecl (GhcPass p)) where+  ppr (ForeignImport { fd_name = n, fd_sig_ty = ty, fd_fi = fimport })+    = hang (text "foreign import" <+> ppr fimport <+> ppr n)+         2 (dcolon <+> ppr ty)+  ppr (ForeignExport { fd_name = n, fd_sig_ty = ty, fd_fe = fexport }) =+    hang (text "foreign export" <+> ppr fexport <+> ppr n)+       2 (dcolon <+> ppr ty)++{-+************************************************************************+*                                                                      *+\subsection{Rewrite rules}+*                                                                      *+************************************************************************+-}++type instance XCRuleDecls    GhcPs = EpAnn [AddEpAnn]+type instance XCRuleDecls    GhcRn = NoExtField+type instance XCRuleDecls    GhcTc = NoExtField++type instance XXRuleDecls    (GhcPass _) = NoExtCon++type instance XHsRule       GhcPs = EpAnn HsRuleAnn+type instance XHsRule       GhcRn = HsRuleRn+type instance XHsRule       GhcTc = HsRuleRn++type instance XXRuleDecl    (GhcPass _) = NoExtCon++type instance Anno (SourceText, RuleName) = SrcSpan++data HsRuleAnn+  = HsRuleAnn+       { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)+                 -- ^ The locations of 'forall' and '.' for forall'd type vars+                 -- Using AddEpAnn to capture possible unicode variants+       , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)+                 -- ^ The locations of 'forall' and '.' for forall'd term vars+                 -- Using AddEpAnn to capture possible unicode variants+       , ra_rest :: [AddEpAnn]+       } deriving (Data, Eq)++flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)]+flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls++type instance XCRuleBndr    (GhcPass _) = EpAnn [AddEpAnn]+type instance XRuleBndrSig  (GhcPass _) = EpAnn [AddEpAnn]+type instance XXRuleBndr    (GhcPass _) = NoExtCon++instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where+  ppr (HsRules { rds_src = st+               , rds_rules = rules })+    = pprWithSourceText st (text "{-# RULES")+          <+> vcat (punctuate semi (map ppr rules)) <+> text "#-}"++instance (OutputableBndrId p) => Outputable (RuleDecl (GhcPass p)) where+  ppr (HsRule { rd_name = name+              , rd_act  = act+              , rd_tyvs = tys+              , rd_tmvs = tms+              , rd_lhs  = lhs+              , rd_rhs  = rhs })+        = sep [pprFullRuleName name <+> ppr act,+               nest 4 (pp_forall_ty tys <+> pp_forall_tm tys+                                        <+> pprExpr (unLoc lhs)),+               nest 6 (equals <+> pprExpr (unLoc rhs)) ]+        where+          pp_forall_ty Nothing     = empty+          pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot+          pp_forall_tm Nothing | null tms = empty+          pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot++instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where+   ppr (RuleBndr _ name) = ppr name+   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)++{-+************************************************************************+*                                                                      *+\subsection[DeprecDecl]{Deprecations}+*                                                                      *+************************************************************************+-}++type instance XWarnings      GhcPs = EpAnn [AddEpAnn]+type instance XWarnings      GhcRn = NoExtField+type instance XWarnings      GhcTc = NoExtField++type instance XXWarnDecls    (GhcPass _) = NoExtCon++type instance XWarning      (GhcPass _) = EpAnn [AddEpAnn]+type instance XXWarnDecl    (GhcPass _) = NoExtCon+++instance OutputableBndrId p+        => Outputable (WarnDecls (GhcPass p)) where+    ppr (Warnings _ (SourceText src) decls)+      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"+    ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"++instance OutputableBndrId p+       => Outputable (WarnDecl (GhcPass p)) where+    ppr (Warning _ thing txt)+      = hsep ( punctuate comma (map ppr thing))+              <+> ppr txt++{-+************************************************************************+*                                                                      *+\subsection[AnnDecl]{Annotations}+*                                                                      *+************************************************************************+-}++type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma+type instance XXAnnDecl     (GhcPass _) = NoExtCon++instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where+    ppr (HsAnnotation _ _ provenance expr)+      = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]++pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc+pprAnnProvenance ModuleAnnProvenance       = text "ANN module"+pprAnnProvenance (ValueAnnProvenance (L _ name))+  = text "ANN" <+> ppr name+pprAnnProvenance (TypeAnnProvenance (L _ name))+  = text "ANN type" <+> ppr name++{-+************************************************************************+*                                                                      *+\subsection[RoleAnnot]{Role annotations}+*                                                                      *+************************************************************************+-}++type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn]+type instance XCRoleAnnotDecl GhcRn = NoExtField+type instance XCRoleAnnotDecl GhcTc = NoExtField++type instance XXRoleAnnotDecl (GhcPass _) = NoExtCon++type instance Anno (Maybe Role) = SrcSpan++instance OutputableBndr (IdP (GhcPass p))+       => Outputable (RoleAnnotDecl (GhcPass p)) where+  ppr (RoleAnnotDecl _ ltycon roles)+    = text "type role" <+> pprPrefixOcc (unLoc ltycon) <+>+      hsep (map (pp_role . unLoc) roles)+    where+      pp_role Nothing  = underscore+      pp_role (Just r) = ppr r++roleAnnotDeclName :: RoleAnnotDecl (GhcPass p) -> IdP (GhcPass p)+roleAnnotDeclName (RoleAnnotDecl _ (L _ name) _) = name++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsDecl (GhcPass _)) = SrcSpanAnnA+type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA+type instance Anno (FamilyResultSig (GhcPass p)) = SrcSpan+type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (InjectivityAnn (GhcPass p)) = SrcSpan+type instance Anno CType = SrcSpanAnnP+type instance Anno (HsDerivingClause (GhcPass p)) = SrcSpan+type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC+type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA+type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno Bool = SrcSpan+type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL+type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA+type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (DataFamInstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA+type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno DocDecl = SrcSpanAnnA+type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno OverlapMode = SrcSpanAnnP+type instance Anno (DerivStrategy (GhcPass p)) = SrcSpan+type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA+type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (SourceText, RuleName) = SrcSpan+type instance Anno (RuleBndr (GhcPass p)) = SrcSpan+type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA+type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA+type instance Anno (Maybe Role) = SrcSpan

GHC/Hs/Doc.hs view

@@ -1,6 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module GHC.Hs.Doc   ( HsDocString@@ -20,6 +19,8 @@    , ArgDocMap(..)   , emptyArgDocMap++  , ExtractedTHDocs(..)   ) where  #include "HsVersions.h"@@ -28,7 +29,6 @@  import GHC.Utils.Binary import GHC.Utils.Encoding-import GHC.Utils.IO.Unsafe import GHC.Types.Name import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc@@ -36,12 +36,12 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as C8-import qualified Data.ByteString.Internal as BS import Data.Data+import Data.IntMap (IntMap)+import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe-import Foreign  -- | Haskell Documentation String --@@ -69,13 +69,7 @@ isEmptyDocString (HsDocString bs) = BS.null bs  mkHsDocString :: String -> HsDocString-mkHsDocString s =-  inlinePerformIO $ do-    let len = utf8EncodedLength s-    buf <- mallocForeignPtrBytes len-    withForeignPtr buf $ \ptr -> do-      utf8EncodeString ptr s-      pure (HsDocString (BS.fromForeignPtr buf 0 len))+mkHsDocString s = HsDocString (utf8EncodeString s)  -- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. mkHsDocStringUtf8ByteString :: ByteString -> HsDocString@@ -136,21 +130,34 @@ emptyDeclDocMap = DeclDocMap Map.empty  -- | Docs for arguments. E.g. function arguments, method arguments.-newtype ArgDocMap = ArgDocMap (Map Name (Map Int HsDocString))+newtype ArgDocMap = ArgDocMap (Map Name (IntMap HsDocString))  instance Binary ArgDocMap where-  put_ bh (ArgDocMap m) = put_ bh (Map.toList (Map.toAscList <$> m))+  put_ bh (ArgDocMap m) = put_ bh (Map.toList (IntMap.toAscList <$> m))   -- We can't rely on a deterministic ordering of the `Name`s here.   -- See the comments on `Name`'s `Ord` instance for context.-  get bh = ArgDocMap . fmap Map.fromDistinctAscList . Map.fromList <$> get bh+  get bh = ArgDocMap . fmap IntMap.fromDistinctAscList . Map.fromList <$> get bh  instance Outputable ArgDocMap where   ppr (ArgDocMap m) = vcat (map pprPair (Map.toAscList m))     where       pprPair (name, int_map) =         ppr name Outputable.<> colon $$ nest 2 (pprIntMap int_map)-      pprIntMap im = vcat (map pprIPair (Map.toAscList im))+      pprIntMap im = vcat (map pprIPair (IntMap.toAscList im))       pprIPair (i, doc) = ppr i Outputable.<> colon $$ nest 2 (ppr doc)  emptyArgDocMap :: ArgDocMap emptyArgDocMap = ArgDocMap Map.empty++-- | Maps of docs that were added via Template Haskell's @putDoc@.+data ExtractedTHDocs =+  ExtractedTHDocs+    { ethd_mod_header :: Maybe HsDocString+      -- ^ The added module header documentation, if it exists.+    , ethd_decl_docs  :: DeclDocMap+      -- ^ The documentation added to declarations.+    , ethd_arg_docs   :: ArgDocMap+      -- ^ The documentation added to function arguments.+    , ethd_inst_docs  :: DeclDocMap+      -- ^ The documentation added to class and family instances.+    }

GHC/Hs/Dump.hs view

@@ -13,46 +13,72 @@         -- * Dumping ASTs         showAstData,         BlankSrcSpan(..),+        BlankEpAnnotations(..),     ) where  import GHC.Prelude -import Data.Data hiding (Fixity)+import GHC.Hs++import GHC.Core.DataCon+ import GHC.Data.Bag-import GHC.Types.Basic import GHC.Data.FastString import GHC.Types.Name.Set import GHC.Types.Name-import GHC.Core.DataCon import GHC.Types.SrcLoc-import GHC.Hs import GHC.Types.Var+import GHC.Types.SourceText import GHC.Unit.Module import GHC.Utils.Outputable +import Data.Data hiding (Fixity) import qualified Data.ByteString as B -data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan+data BlankSrcSpan = BlankSrcSpan | BlankSrcSpanFile | NoBlankSrcSpan                   deriving (Eq,Show) +data BlankEpAnnotations = BlankEpAnnotations | NoBlankEpAnnotations+                  deriving (Eq,Show)+ -- | Show a GHC syntax tree. This parameterised because it is also used for -- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked -- out, to avoid comparing locations, only structure-showAstData :: Data a => BlankSrcSpan -> a -> SDoc-showAstData b a0 = blankLine $$ showAstData' a0+showAstData :: Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc+showAstData bs ba a0 = blankLine $$ showAstData' a0   where     showAstData' :: Data a => a -> SDoc     showAstData' =       generic               `ext1Q` list-              `extQ` string `extQ` fastString `extQ` srcSpan+              `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan+              `extQ` annotation+              `extQ` annotationModule+              `extQ` annotationAddEpAnn+              `extQ` annotationGrhsAnn+              `extQ` annotationEpAnnHsCase+              `extQ` annotationEpAnnHsLet+              `extQ` annotationAnnList+              `extQ` annotationEpAnnImportDecl+              `extQ` annotationAnnParen+              `extQ` annotationTrailingAnn+              `extQ` annotationEpaLocation+              `extQ` addEpAnn               `extQ` lit `extQ` litr `extQ` litt+              `extQ` sourceText+              `extQ` deltaPos+              `extQ` epaAnchor               `extQ` bytestring               `extQ` name `extQ` occName `extQ` moduleName `extQ` var               `extQ` dataCon               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet               `extQ` fixity               `ext2Q` located+              `extQ` srcSpanAnnA+              `extQ` srcSpanAnnL+              `extQ` srcSpanAnnP+              `extQ` srcSpanAnnC+              `extQ` srcSpanAnnN        where generic :: Data a => a -> SDoc             generic t = parens $ text (showConstr (toConstr t))@@ -63,8 +89,8 @@              fastString :: FastString -> SDoc             fastString s = braces $-                            text "FastString: "-                         <> text (normalize_newlines . show $ s)+                            text "FastString:"+                        <+> text (normalize_newlines . show $ s)              bytestring :: B.ByteString -> SDoc             bytestring = text . normalize_newlines . show@@ -104,43 +130,84 @@                                                , generic x                                                , generic s ] +            sourceText :: SourceText -> SDoc+            sourceText NoSourceText = parens $ text "NoSourceText"+            sourceText (SourceText src) = case bs of+              NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src+              BlankSrcSpanFile -> parens $ text "SourceText" <+> text src+              _                -> parens $ text "SourceText" <+> text "blanked"++            epaAnchor :: EpaLocation -> SDoc+            epaAnchor (EpaSpan r)  = parens $ text "EpaSpan" <+> realSrcSpan r+            epaAnchor (EpaDelta d cs) = case ba of+              NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs+              BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"++            deltaPos :: DeltaPos -> SDoc+            deltaPos (SameLine c) = parens $ text "SameLine" <+> ppr c+            deltaPos (DifferentLine l c) = parens $ text "DifferentLine" <+> ppr l <+> ppr c+             name :: Name -> SDoc-            name nm    = braces $ text "Name: " <> ppr nm+            name nm    = braces $ text "Name:" <+> ppr nm              occName n  =  braces $-                          text "OccName: "-                       <> text (occNameString n)+                          text "OccName:"+                      <+> text (occNameString n)              moduleName :: ModuleName -> SDoc-            moduleName m = braces $ text "ModuleName: " <> ppr m+            moduleName m = braces $ text "ModuleName:" <+> ppr m              srcSpan :: SrcSpan -> SDoc-            srcSpan ss = case b of+            srcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"              NoBlankSrcSpan -> braces $ char ' ' <>                              (hang (ppr ss) 1                                    -- TODO: show annotations here                                    (text ""))+             BlankSrcSpanFile -> braces $ char ' ' <>+                             (hang (pprUserSpan False ss) 1+                                   -- TODO: show annotations here+                                   (text "")) +            realSrcSpan :: RealSrcSpan -> SDoc+            realSrcSpan ss = case bs of+             BlankSrcSpan -> text "{ ss }"+             NoBlankSrcSpan -> braces $ char ' ' <>+                             (hang (ppr ss) 1+                                   -- TODO: show annotations here+                                   (text ""))+             BlankSrcSpanFile -> braces $ char ' ' <>+                             (hang (pprUserRealSpan False ss) 1+                                   -- TODO: show annotations here+                                   (text ""))+++            addEpAnn :: AddEpAnn -> SDoc+            addEpAnn (AddEpAnn a s) = case ba of+             BlankEpAnnotations -> parens+                                      $ text "blanked:" <+> text "AddEpAnn"+             NoBlankEpAnnotations ->+              parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s+             var  :: Var -> SDoc-            var v      = braces $ text "Var: " <> ppr v+            var v      = braces $ text "Var:" <+> ppr v              dataCon :: DataCon -> SDoc-            dataCon c  = braces $ text "DataCon: " <> ppr c+            dataCon c  = braces $ text "DataCon:" <+> ppr c -            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc+            bagRdrName:: Bag (LocatedA (HsBind GhcPs)) -> SDoc             bagRdrName bg =  braces $-                             text "Bag(Located (HsBind GhcPs)):"+                             text "Bag(LocatedA (HsBind GhcPs)):"                           $$ (list . bagToList $ bg) -            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc+            bagName   :: Bag (LocatedA (HsBind GhcRn)) -> SDoc             bagName bg  =  braces $-                           text "Bag(Located (HsBind Name)):"+                           text "Bag(LocatedA (HsBind Name)):"                         $$ (list . bagToList $ bg) -            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc+            bagVar    :: Bag (LocatedA (HsBind GhcTc)) -> SDoc             bagVar bg  =  braces $-                          text "Bag(Located (HsBind Var)):"+                          text "Bag(LocatedA (HsBind Var)):"                        $$ (list . bagToList $ bg)              nameSet ns =  braces $@@ -149,16 +216,88 @@              fixity :: Fixity -> SDoc             fixity fx =  braces $-                         text "Fixity: "-                      <> ppr fx+                         text "Fixity:"+                     <+> ppr fx -            located :: (Data b,Data loc) => GenLocated loc b -> SDoc-            located (L ss a) = parens $-                   case cast ss of-                        Just (s :: SrcSpan) ->-                          srcSpan s-                        Nothing -> text "nnnnnnnn"-                      $$ showAstData' a+            located :: (Data a, Data b) => GenLocated a b -> SDoc+            located (L ss a)+              = parens (text "L"+                        $$ vcat [showAstData' ss, showAstData' a])+++            -- -------------------------++            annotation :: EpAnn [AddEpAnn] -> SDoc+            annotation = annotation' (text "EpAnn [AddEpAnn]")++            annotationModule :: EpAnn AnnsModule -> SDoc+            annotationModule = annotation' (text "EpAnn AnnsModule")++            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc+            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")++            annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc+            annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn")++            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc+            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")++            annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc+            annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet")++            annotationAnnList :: EpAnn AnnList -> SDoc+            annotationAnnList = annotation' (text "EpAnn AnnList")++            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc+            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")++            annotationAnnParen :: EpAnn AnnParen -> SDoc+            annotationAnnParen = annotation' (text "EpAnn AnnParen")++            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc+            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")++            annotationEpaLocation :: EpAnn EpaLocation -> SDoc+            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")++            annotation' :: forall a .(Data a, Typeable a)+                       => SDoc -> EpAnn a -> SDoc+            annotation' tag anns = case ba of+             BlankEpAnnotations -> parens (text "blanked:" <+> tag)+             NoBlankEpAnnotations -> parens $ text (showConstr (toConstr anns))+                                               $$ vcat (gmapQ showAstData' anns)++            -- -------------------------++            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc+            srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA")++            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc+            srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL")++            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc+            srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP")++            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc+            srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC")++            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc+            srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")++            locatedAnn'' :: forall a. (Typeable a, Data a)+              => SDoc -> SrcSpanAnn' a -> SDoc+            locatedAnn'' tag ss = parens $+              case cast ss of+                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->+                  case ba of+                    BlankEpAnnotations+                      -> parens (text "blanked:" <+> tag)+                    NoBlankEpAnnotations+                      -> text "SrcSpanAnn" <+> showAstData' ann+                              <+> srcSpan s+                Nothing -> text "locatedAnn:unmatched" <+> tag+                           <+> (parens $ text (showConstr (toConstr ss)))+  normalize_newlines :: String -> String normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs

GHC/Hs/Expr.hs view

@@ -1,3107 +1,1868 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--}--{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Abstract Haskell syntax for expressions.-module GHC.Hs.Expr where--#include "HsVersions.h"---- friends:-import GHC.Prelude--import GHC.Hs.Decls-import GHC.Hs.Pat-import GHC.Hs.Lit-import GHC.Hs.Extension-import GHC.Hs.Type-import GHC.Hs.Binds---- others:-import GHC.Tc.Types.Evidence-import GHC.Core-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Types.Basic-import GHC.Core.ConLike-import GHC.Types.SrcLoc-import GHC.Unit.Module (ModuleName)-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Core.Type-import GHC.Builtin.Types (mkTupleStr)-import GHC.Tc.Utils.TcType (TcType)-import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)---- libraries:-import Data.Data hiding (Fixity(..))-import qualified Data.Data as Data (Fixity(..))-import qualified Data.Kind-import Data.Maybe (isJust)--import GHCi.RemoteTypes ( ForeignRef )-import qualified Language.Haskell.TH as TH (Q)--{--************************************************************************-*                                                                      *-\subsection{Expressions proper}-*                                                                      *-************************************************************************--}---- * Expressions proper---- | Located Haskell Expression-type LHsExpr p = Located (HsExpr p)-  -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when-  --   in a list--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation------------------------------ | Post-Type checking Expression------ PostTcExpr is an evidence expression attached to the syntax tree by the--- type checker (c.f. postTcType).-type PostTcExpr  = HsExpr GhcTc---- | Post-Type checking Table------ We use a PostTcTable where there are a bunch of pieces of evidence, more--- than is convenient to keep individually.-type PostTcTable = [(Name, PostTcExpr)]----------------------------{- Note [NoSyntaxExpr]-~~~~~~~~~~~~~~~~~~~~~~-Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc)-for several reasons:-- 1. As described in Note [Rebindable if]-- 2. In order to suppress "not in scope: xyz" messages when a bit of-    rebindable syntax does not apply. For example, when using an irrefutable-    pattern in a BindStmt, we don't need a `fail` operator.-- 3. Rebindable syntax might just not make sense. For example, a BodyStmt-    contains the syntax for `guard`, but that's used only in monad comprehensions.-    If we had more of a whiz-bang type system, we might be able to rule this-    case out statically.--}---- | Syntax Expression------ SyntaxExpr is represents the function used in interpreting rebindable--- syntax. In the parser, we have no information to supply; in the renamer,--- we have the name of the function (but see--- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle)--- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'.------ In some contexts, rebindable syntax is not implemented, and so we have--- constructors to represent that possibility in both the renamer and--- typechecker instantiations.------ E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for---      @(>>=)@, and then instantiated by the type checker with its type args---      etc-type family SyntaxExpr p---- Defining SyntaxExpr in two stages allows for better type inference, because--- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,--- noSyntaxExpr would be ambiguous.-type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p--type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where-  SyntaxExprGhc 'Parsed      = NoExtField-  SyntaxExprGhc 'Renamed     = SyntaxExprRn-  SyntaxExprGhc 'Typechecked = SyntaxExprTc---- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].-data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)-    -- Why is the payload not just a Name?-    -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"-                  | NoSyntaxExprRn---- | An expression with wrappers, used for rebindable syntax------ This should desugar to------ > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)--- >                         (syn_arg_wraps[1] arg1) ...------ where the actual arguments come from elsewhere in the AST.-data SyntaxExprTc = SyntaxExprTc { syn_expr      :: HsExpr GhcTc-                                 , syn_arg_wraps :: [HsWrapper]-                                 , syn_res_wrap  :: HsWrapper }-                  | NoSyntaxExprTc  -- See Note [NoSyntaxExpr]---- | This is used for rebindable-syntax pieces that are too polymorphic--- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)-noExpr :: HsExpr (GhcPass p)-noExpr = HsLit noExtField (HsString (SourceText  "noExpr") (fsLit "noExpr"))--noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)-                              -- Before renaming, and sometimes after-                              -- See Note [NoSyntaxExpr]-noSyntaxExpr = case ghcPass @p of-  GhcPs -> noExtField-  GhcRn -> NoSyntaxExprRn-  GhcTc -> NoSyntaxExprTc---- | Make a 'SyntaxExpr GhcRn' from an expression--- Used only in getMonadFailOp.--- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"-mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn-mkSyntaxExpr = SyntaxExprRn---- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the--- renamer).-mkRnSyntaxExpr :: Name -> SyntaxExprRn-mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLoc name--instance Outputable SyntaxExprRn where-  ppr (SyntaxExprRn expr) = ppr expr-  ppr NoSyntaxExprRn      = text "<no syntax expr>"--instance Outputable SyntaxExprTc where-  ppr (SyntaxExprTc { syn_expr      = expr-                    , syn_arg_wraps = arg_wraps-                    , syn_res_wrap  = res_wrap })-    = sdocOption sdocPrintExplicitCoercions $ \print_co ->-      getPprDebug $ \debug ->-      if debug || print_co-      then ppr expr <> braces (pprWithCommas ppr arg_wraps)-                    <> braces (ppr res_wrap)-      else ppr expr--  ppr NoSyntaxExprTc = text "<no syntax expr>"---- | Command Syntax Table (for Arrow syntax)-type CmdSyntaxTable p = [(Name, HsExpr p)]--- See Note [CmdSyntaxTable]--{--Note [CmdSyntaxTable]-~~~~~~~~~~~~~~~~~~~~~-Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps-track of the methods needed for a Cmd.--* Before the renamer, this list is an empty list--* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@-  For example, for the 'arr' method-   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)-   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)-             where @arr_22@ is whatever 'arr' is in scope--* After the type checker, it takes the form [(std_name, <expression>)]-  where <expression> is the evidence for the method.  This evidence is-  instantiated with the class, but is still polymorphic in everything-  else.  For example, in the case of 'arr', the evidence has type-         forall b c. (b->c) -> a b c-  where 'a' is the ambient type of the arrow.  This polymorphism is-  important because the desugarer uses the same evidence at multiple-  different types.--This is Less Cool than what we normally do for rebindable syntax, which is to-make fully-instantiated piece of evidence at every use site.  The Cmd way-is Less Cool because-  * The renamer has to predict which methods are needed.-    See the tedious GHC.Rename.Expr.methodNamesCmd.--  * The desugarer has to know the polymorphic type of the instantiated-    method. This is checked by Inst.tcSyntaxName, but is less flexible-    than the rest of rebindable syntax, where the type is less-    pre-ordained.  (And this flexibility is useful; for example we can-    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)--}---- | A Haskell expression.-data HsExpr p-  = HsVar     (XVar p)-              (Located (IdP p)) -- ^ Variable--                             -- See Note [Located RdrNames]--  | HsUnboundVar (XUnboundVar p)-                 OccName     -- ^ Unbound variable; also used for "holes"-                             --   (_ or _x).-                             -- Turned from HsVar to HsUnboundVar by the-                             --   renamer, when it finds an out-of-scope-                             --   variable or hole.-                             -- Turned into HsVar by type checker, to support-                             --   deferred type errors.--  | HsConLikeOut (XConLikeOut p)-                 ConLike     -- ^ After typechecker only; must be different-                             -- HsVar for pretty printing--  | HsRecFld  (XRecFld p)-              (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector-                                    -- Not in use after typechecking--  | HsOverLabel (XOverLabel p)-                (Maybe (IdP p)) FastString-     -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)-     --   @Just id@ means @RebindableSyntax@ is in use, and gives the id of the-     --   in-scope 'fromLabel'.-     --   NB: Not in use after typechecking--  | HsIPVar   (XIPVar p)-              HsIPName   -- ^ Implicit parameter (not in use after typechecking)-  | HsOverLit (XOverLitE p)-              (HsOverLit p)  -- ^ Overloaded literals--  | HsLit     (XLitE p)-              (HsLit p)      -- ^ Simple (non-overloaded) literals--  | HsLam     (XLam p)-              (MatchGroup p (LHsExpr p))-                       -- ^ Lambda abstraction. Currently always a single match-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --       'GHC.Parser.Annotation.AnnRarrow',--       -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --           'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',-       --           'GHC.Parser.Annotation.AnnClose'--       -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application--  | HsAppType (XAppTypeE p) -- After typechecking: the type argument-              (LHsExpr p)-              (LHsWcType (NoGhcTc p))  -- ^ Visible type application-       ---       -- Explicit type argument; e.g  f @Int x y-       -- NB: Has wildcards, but no implicit quantification-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt',--  -- | Operator applications:-  -- NB Bracketed ops such as (+) come out as Vars.--  -- NB We need an expr for the operator in an OpApp/Section since-  -- the typechecker may need to apply the operator to a few types.--  | OpApp       (XOpApp p)-                (LHsExpr p)       -- left operand-                (LHsExpr p)       -- operator-                (LHsExpr p)       -- right operand--  -- | Negation operator. Contains the negated expression and the name-  -- of 'negate'-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | NegApp      (XNegApp p)-                (LHsExpr p)-                (SyntaxExpr p)--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-  --             'GHC.Parser.Annotation.AnnClose' @')'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsPar       (XPar p)-                (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]--  | SectionL    (XSectionL p)-                (LHsExpr p)    -- operand; see Note [Sections in HsSyn]-                (LHsExpr p)    -- operator-  | SectionR    (XSectionR p)-                (LHsExpr p)    -- operator; see Note [Sections in HsSyn]-                (LHsExpr p)    -- operand--  -- | Used for explicit tuples and sections thereof-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --         'GHC.Parser.Annotation.AnnClose'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  -- Note [ExplicitTuple]-  | ExplicitTuple-        (XExplicitTuple p)-        [LHsTupArg p]-        Boxity--  -- | Used for unboxed sum types-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,-  --          'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@,-  ---  --  There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before-  --  the expression, (arity - alternative) after it-  | ExplicitSum-          (XExplicitSum p)-          ConTag --  Alternative (one-based)-          Arity  --  Sum arity-          (LHsExpr p)--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',-  --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,-  --       'GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsCase      (XCase p)-                (LHsExpr p)-                (MatchGroup p (LHsExpr p))--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',-  --       'GHC.Parser.Annotation.AnnSemi',-  --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',-  --       'GHC.Parser.Annotation.AnnElse',--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsIf        (XIf p)        -- GhcPs: this is a Bool; False <=> do not use-                               --  rebindable syntax-                (LHsExpr p)    --  predicate-                (LHsExpr p)    --  then part-                (LHsExpr p)    --  else part--  -- | Multi-way if-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf'-  --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]--  -- | let(rec)-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',-  --       'GHC.Parser.Annotation.AnnOpen' @'{'@,-  --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsLet       (XLet p)-                (LHsLocalBinds p)-                (LHsExpr  p)--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',-  --             'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',-  --             'GHC.Parser.Annotation.AnnVbar',-  --             'GHC.Parser.Annotation.AnnClose'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsDo        (XDo p)                  -- Type of the whole expression-                (HsStmtContext GhcRn)    -- The parameterisation is unimportant-                                         -- because in this context we never use-                                         -- the PatGuard or ParStmt variant-                (Located [ExprLStmt p]) -- "do":one or more stmts--  -- | Syntactic list: [a,b,c,...]-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-  --              'GHC.Parser.Annotation.AnnClose' @']'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  -- See Note [Empty lists]-  | ExplicitList-                (XExplicitList p)  -- Gives type of components of list-                (Maybe (SyntaxExpr p))-                                   -- For OverloadedLists, the fromListN witness-                [LHsExpr p]--  -- | Record construction-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,-  --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | RecordCon-      { rcon_ext      :: XRecordCon p-      , rcon_con_name :: Located (IdP p)    -- The constructor name;-                                            --  not used after type checking-      , rcon_flds     :: HsRecordBinds p }  -- The fields--  -- | Record update-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,-  --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | RecordUpd-      { rupd_ext  :: XRecordUpd p-      , rupd_expr :: LHsExpr p-      , rupd_flds :: [LHsRecUpdField p]-      }-  -- For a type family, the arg types are of the *instance* tycon,-  -- not the family tycon--  -- | Expression with an explicit type signature. @e :: type@-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | ExprWithTySig-                (XExprWithTySig p)--                (LHsExpr p)-                (LHsSigWcType (NoGhcTc p))--  -- | Arithmetic sequence-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-  --              'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot',-  --              'GHC.Parser.Annotation.AnnClose' @']'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | ArithSeq-                (XArithSeq p)-                (Maybe (SyntaxExpr p))-                                  -- For OverloadedLists, the fromList witness-                (ArithSeqInfo p)--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  ------------------------------------------------------------  -- MetaHaskell Extensions--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --         'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ',-  --         'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsBracket    (XBracket p) (HsBracket p)--    -- See Note [Pending Splices]-  | HsRnBracketOut-      (XRnBracketOut p)-      (HsBracket GhcRn)    -- Output of the renamer is the *original* renamed-                           -- expression, plus-      [PendingRnSplice]    -- _renamed_ splices to be type checked--  | HsTcBracketOut-      (XTcBracketOut p)-      (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument-                           -- to the quote.-      (HsBracket GhcRn)    -- Output of the type checker is the *original*-                           -- renamed expression, plus-      [PendingTcSplice]    -- _typechecked_ splices to be-                           -- pasted back in by the desugarer--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --         'GHC.Parser.Annotation.AnnClose'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsSpliceE  (XSpliceE p) (HsSplice p)--  ------------------------------------------------------------  -- Arrow notation extension--  -- | @proc@ notation for Arrows-  ---  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc',-  --          'GHC.Parser.Annotation.AnnRarrow'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsProc      (XProc p)-                (LPat p)               -- arrow abstraction, proc-                (LHsCmdTop p)          -- body of the abstraction-                                       -- always has an empty stack--  ----------------------------------------  -- static pointers extension-  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic',--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsStatic (XStatic p) -- Free variables of the body-             (LHsExpr p)        -- Body--  ----------------------------------------  -- Haskell program coverage (Hpc) Support--  | HsTick-     (XTick p)-     (Tickish (IdP p))-     (LHsExpr p)                       -- sub-expression--  | HsBinTick-     (XBinTick p)-     Int                                -- module-local tick number for True-     Int                                -- module-local tick number for False-     (LHsExpr p)                        -- sub-expression--  ----------------------------------------  -- Expressions annotated with pragmas, written as {-# ... #-}-  | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)--  | XExpr       !(XXExpr p)-  -- Note [Trees that Grow] extension constructor for the-  -- general idea, and Note [Rebindable syntax and HsExpansion]-  -- for an example of how we use it.---- | Extra data fields for a 'RecordCon', added by the type checker-data RecordConTc = RecordConTc-      { rcon_con_like :: ConLike      -- The data constructor or pattern synonym-      , rcon_con_expr :: PostTcExpr   -- Instantiated constructor function-      }---- | Extra data fields for a 'RecordUpd', added by the type checker-data RecordUpdTc = RecordUpdTc-      { rupd_cons :: [ConLike]-                -- Filled in by the type checker to the-                -- _non-empty_ list of DataCons that have-                -- all the upd'd fields--      , rupd_in_tys  :: [Type]  -- Argument types of *input* record type-      , rupd_out_tys :: [Type]  --             and  *output* record type-                -- For a data family, these are the type args of the-                -- /representation/ type constructor--      , rupd_wrap :: HsWrapper  -- See note [Record Update HsWrapper]-      }---- | HsWrap appears only in typechecker output--- Invariant: The contained Expr is *NOT* itself an HsWrap.--- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr".--- This invariant is maintained by 'GHC.Hs.Utils.mkHsWrap'.--- hs_syn is something like HsExpr or HsCmd-data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper-                            (hs_syn GhcTc) -- the thing that is wrapped--deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)---- -----------------------------------------------------------------------type instance XVar           (GhcPass _) = NoExtField-type instance XUnboundVar    (GhcPass _) = NoExtField-type instance XConLikeOut    (GhcPass _) = NoExtField-type instance XRecFld        (GhcPass _) = NoExtField-type instance XOverLabel     (GhcPass _) = NoExtField-type instance XIPVar         (GhcPass _) = NoExtField-type instance XOverLitE      (GhcPass _) = NoExtField-type instance XLitE          (GhcPass _) = NoExtField-type instance XLam           (GhcPass _) = NoExtField-type instance XLamCase       (GhcPass _) = NoExtField-type instance XApp           (GhcPass _) = NoExtField--type instance XAppTypeE      GhcPs = NoExtField-type instance XAppTypeE      GhcRn = NoExtField-type instance XAppTypeE      GhcTc = Type--type instance XOpApp         GhcPs = NoExtField-type instance XOpApp         GhcRn = Fixity-type instance XOpApp         GhcTc = Fixity--type instance XNegApp        (GhcPass _) = NoExtField-type instance XPar           (GhcPass _) = NoExtField-type instance XSectionL      (GhcPass _) = NoExtField-type instance XSectionR      (GhcPass _) = NoExtField-type instance XExplicitTuple (GhcPass _) = NoExtField--type instance XExplicitSum   GhcPs = NoExtField-type instance XExplicitSum   GhcRn = NoExtField-type instance XExplicitSum   GhcTc = [Type]--type instance XCase          (GhcPass _) = NoExtField--type instance XIf            (GhcPass _) = NoExtField--type instance XMultiIf       GhcPs = NoExtField-type instance XMultiIf       GhcRn = NoExtField-type instance XMultiIf       GhcTc = Type--type instance XLet           (GhcPass _) = NoExtField--type instance XDo            GhcPs = NoExtField-type instance XDo            GhcRn = NoExtField-type instance XDo            GhcTc = Type--type instance XExplicitList  GhcPs = NoExtField-type instance XExplicitList  GhcRn = NoExtField-type instance XExplicitList  GhcTc = Type--type instance XRecordCon     GhcPs = NoExtField-type instance XRecordCon     GhcRn = NoExtField-type instance XRecordCon     GhcTc = RecordConTc--type instance XRecordUpd     GhcPs = NoExtField-type instance XRecordUpd     GhcRn = NoExtField-type instance XRecordUpd     GhcTc = RecordUpdTc--type instance XExprWithTySig (GhcPass _) = NoExtField--type instance XArithSeq      GhcPs = NoExtField-type instance XArithSeq      GhcRn = NoExtField-type instance XArithSeq      GhcTc = PostTcExpr--type instance XBracket       (GhcPass _) = NoExtField--type instance XRnBracketOut  (GhcPass _) = NoExtField-type instance XTcBracketOut  (GhcPass _) = NoExtField--type instance XSpliceE       (GhcPass _) = NoExtField-type instance XProc          (GhcPass _) = NoExtField--type instance XStatic        GhcPs = NoExtField-type instance XStatic        GhcRn = NameSet-type instance XStatic        GhcTc = NameSet--type instance XTick          (GhcPass _) = NoExtField-type instance XBinTick       (GhcPass _) = NoExtField--type instance XPragE         (GhcPass _) = NoExtField--type instance XXExpr         GhcPs       = NoExtCon---- See Note [Rebindable syntax and HsExpansion] below-type instance XXExpr         GhcRn       = HsExpansion (HsExpr GhcRn)-                                                       (HsExpr GhcRn)-type instance XXExpr         GhcTc       = XXExprGhcTc--data XXExprGhcTc-  = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)-  | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))---{--Note [Rebindable syntax and HsExpansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--We implement rebindable syntax (RS) support by performing a desugaring-in the renamer. We transform GhcPs expressions affected by RS into the-appropriate desugared form, but **annotated with the original expression**.--Let us consider a piece of code like:--    {-# LANGUAGE RebindableSyntax #-}-    ifThenElse :: Char -> () -> () -> ()-    ifThenElse _ _ _ = ()-    x = if 'a' then () else True--The parsed AST for the RHS of x would look something like (slightly simplified):--    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))--Upon seeing such an AST with RS on, we could transform it into a-mere function call, as per the RS rules, equivalent to the-following function application:--    ifThenElse 'a' () True--which doesn't typecheck. But GHC would report an error about-not being able to match the third argument's type (Bool) with the-expected type: (), in the expression _as desugared_, i.e in-the aforementioned function application. But the user never-wrote a function application! This would be pretty bad.--To remedy this, instead of transforming the original HsIf-node into mere applications of 'ifThenElse', we keep the-original 'if' expression around too, using the TTG-XExpr extension point to allow GHC to construct an-'HsExpansion' value that will keep track of the original-expression in its first field, and the desugared one in the-second field. The resulting renamed AST would look like:--    L locif (XExpr-      (HsExpanded-        (HsIf (L loca 'a')-              (L loctrue ())-              (L locfalse True)-        )-        (App (L generatedSrcSpan-                (App (L generatedSrcSpan-                        (App (L generatedSrcSpan (Var ifThenElse))-                             (L loca 'a')-                        )-                     )-                     (L loctrue ())-                )-             )-             (L locfalse True)-        )-      )-    )--When comes the time to typecheck the program, we end up calling-tcMonoExpr on the AST above. If this expression gives rise to-a type error, then it will appear in a context line and GHC-will pretty-print it using the 'Outputable (HsExpansion a b)'-instance defined below, which *only prints the original-expression*. This is the gist of the idea, but is not quite-enough to recover the error messages that we had with the-SyntaxExpr-based, typechecking/desugaring-to-core time-implementation of rebindable syntax. The key idea is to decorate-some elements of the desugared expression so as to be able to-give them a special treatment when typechecking the desugared-expression, to print a different context line or skip one-altogether.--Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in-TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we-entered generated code, i.e code fabricated by the compiler when rebinding some-syntax. If someone tries to push some error context line while that field is set-to True, the pushing won't actually happen and the context line is just dropped.-Once we 'setSrcSpan' a real span (for an expression that was in the original-source code), we set 'tcl_in_gen_code' back to False, indicating that we-"emerged from the generated code tunnel", and that the expressions we will be-processing are relevant to report in context lines again.--You might wonder why we store a RealSrcSpan in addition to a Bool in-the TcLclEnv: could we not store a Maybe RealSrcSpan? The problem is-that we still generate constraints when processing generated code,-and a CtLoc must contain a RealSrcSpan -- otherwise, error messages-might appear without source locations. So we keep the RealSrcSpan of-the last location spotted that wasn't generated; it's as good as-we're going to get in generated code. Once we get to sub-trees that-are not generated, then we update the RealSrcSpan appropriately, and-set the tcl_in_gen_code Bool to False.-------A general recipe to follow this approach for new constructs could go as follows:--- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your-  construct, in HsExpr or related syntax data types.-- At renaming-time:-    - take your original node of interest (HsIf above)-    - rename its subexpressions (condition, true branch, false branch above)-    - construct the suitable "rebound"-and-renamed result (ifThenElse call-      above), where the 'SrcSpan' attached to any _fabricated node_ (the-      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'-    - take both the original node and that rebound-and-renamed result and wrap-      them in an XExpr: XExpr (HsExpanded <original node> <desugared>)- - At typechecking-time:-    - remove any logic that was previously dealing with your rebindable-      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.-    - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we-      typecheck the desugared expression while reporting the original one in-      errors---}---- See Note [Rebindable syntax and HsExpansion] just above.-data HsExpansion a b-  = HsExpanded a b-  deriving Data---- | Build a "wrapped" 'HsExpansion' out of an extension constructor,---   and the two components of the expansion: original and desugared---   expressions.------   See Note [Rebindable Syntax and HsExpansion] above for more details.-mkExpanded-  :: (HsExpansion a b -> b) -- ^ XExpr, XCmd, ...-  -> a                      -- ^ source expression ('GhcPs')-  -> b                      -- ^ "desugared" expression-                            --   ('GhcRn')-  -> b                      -- ^ suitably wrapped-                            --   'HsExpansion'-mkExpanded xwrap a b = xwrap (HsExpanded a b)---- | Just print the original expression (the @a@).-instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where-  ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)---- ------------------------------------------------------------------------- | A pragma, written as {-# ... #-}, that may appear within an expression.-data HsPragE p-  = HsPragSCC   (XSCC p)-                SourceText            -- Note [Pragma source text] in GHC.Types.Basic-                StringLiteral         -- "set cost centre" SCC pragma--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-  --       'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@,-  --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal',-  --       'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal',-  --       'GHC.Parser.Annotation.AnnMinus',-  --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon',-  --       'GHC.Parser.Annotation.AnnVal',-  --       'GHC.Parser.Annotation.AnnClose' @'\#-}'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsPragTick                        -- A pragma introduced tick-     (XTickPragma p)-     SourceText                       -- Note [Pragma source text] in GHC.Types.Basic-     (StringLiteral,(Int,Int),(Int,Int))-                                      -- external span for this tick-     ((SourceText,SourceText),(SourceText,SourceText))-        -- Source text for the four integers used in the span.-        -- See note [Pragma source text] in GHC.Types.Basic--  | XHsPragE !(XXPragE p)--type instance XSCC           (GhcPass _) = NoExtField-type instance XCoreAnn       (GhcPass _) = NoExtField-type instance XTickPragma    (GhcPass _) = NoExtField-type instance XXPragE        (GhcPass _) = NoExtCon---- | Located Haskell Tuple Argument------ 'HsTupArg' is used for tuple sections--- @(,a,)@ is represented by--- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@--- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@-type LHsTupArg id = Located (HsTupArg id)--- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'---- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | Haskell Tuple Argument-data HsTupArg id-  = Present (XPresent id) (LHsExpr id)     -- ^ The argument-  | Missing (XMissing id)    -- ^ The argument is missing, but this is its type-  | XTupArg !(XXTupArg id)   -- ^ Note [Trees that Grow] extension point--type instance XPresent         (GhcPass _) = NoExtField--type instance XMissing         GhcPs = NoExtField-type instance XMissing         GhcRn = NoExtField-type instance XMissing         GhcTc = Scaled Type--type instance XXTupArg         (GhcPass _) = NoExtCon--tupArgPresent :: LHsTupArg id -> Bool-tupArgPresent (L _ (Present {})) = True-tupArgPresent (L _ (Missing {})) = False-tupArgPresent (L _ (XTupArg {})) = False--{--Note [Parens in HsSyn]-~~~~~~~~~~~~~~~~~~~~~~-HsPar (and ParPat in patterns, HsParTy in types) is used as follows--  * HsPar is required; the pretty printer does not add parens.--  * HsPars are respected when rearranging operator fixities.-    So   a * (b + c)  means what it says (where the parens are an HsPar)--  * For ParPat and HsParTy the pretty printer does add parens but this should be-    a no-op for ParsedSource, based on the pretty printer round trip feature-    introduced in-    https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c--  * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or-    not they are strictly necessary. This should be addressed when #13238 is-    completed, to be treated the same as HsPar.---Note [Sections in HsSyn]-~~~~~~~~~~~~~~~~~~~~~~~~-Sections should always appear wrapped in an HsPar, thus-         HsPar (SectionR ...)-The parser parses sections in a wider variety of situations-(See Note [Parsing sections]), but the renamer checks for those-parens.  This invariant makes pretty-printing easier; we don't need-a special case for adding the parens round sections.--Note [Rebindable if]-~~~~~~~~~~~~~~~~~~~~-The rebindable syntax for 'if' is a bit special, because when-rebindable syntax is *off* we do not want to treat-   (if c then t else e)-as if it was an application (ifThenElse c t e).  Why not?-Because we allow an 'if' to return *unboxed* results, thus-  if blah then 3# else 4#-whereas that would not be possible using a all to a polymorphic function-(because you can't call a polymorphic function at an unboxed type).--So we use NoSyntaxExpr to mean "use the old built-in typing rule".--A further complication is that, in the `deriving` code, we never want-to use rebindable syntax. So, even in GhcPs, we want to denote whether-to use rebindable syntax or not. This is done via the type instance-for XIf GhcPs.--Note [Record Update HsWrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is a wrapper in RecordUpd which is used for the *required*-constraints for pattern synonyms. This wrapper is created in the-typechecking and is then directly used in the desugaring without-modification.--For example, if we have the record pattern synonym P,-  pattern P :: (Show a) => a -> Maybe a-  pattern P{x} = Just x--  foo = (Just True) { x = False }-then `foo` desugars to something like-  foo = case Just True of-          P x -> P False-hence we need to provide the correct dictionaries to P's matcher on-the RHS so that we can build the expression.--Note [Located RdrNames]-~~~~~~~~~~~~~~~~~~~~~~~-A number of syntax elements have seemingly redundant locations attached to them.-This is deliberate, to allow transformations making use of the API Annotations-to easily correlate a Located Name in the RenamedSource with a Located RdrName-in the ParsedSource.--There are unfortunately enough differences between the ParsedSource and the-RenamedSource that the API Annotations cannot be used directly with-RenamedSource, so this allows a simple mapping to be used based on the location.--Note [ExplicitTuple]-~~~~~~~~~~~~~~~~~~~~-An ExplicitTuple is never just a data constructor like (,,,).-That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least-one `Present` member (and is thus never empty).--A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an-`ExplicitTuple`, and stays that way. This is important for two reasons:--  1. We don't need -XTupleSections for (,,,)-  2. The type variables in (,,,) can be instantiated with visible type application.-     That is,--       (,,)     :: forall a b c. a -> b -> c -> (a,b,c)-       (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c)--     Note that the tuple section has *inferred* arguments, while the data-     constructor has *specified* ones.-     (See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-     for background.)--Sadly, the grammar for this is actually ambiguous, and it's only thanks to the-preference of a shift in a shift/reduce conflict that the parser works as this-Note details. Search for a reference to this Note in GHC.Parser for further-explanation.--Note [Empty lists]-~~~~~~~~~~~~~~~~~~-An empty list could be considered either a data constructor (stored with-HsVar) or an ExplicitList. This Note describes how empty lists flow through the-various phases and why.--Parsing---------An empty list is parsed by the sysdcon nonterminal. It thus comes to life via-HsVar nilDataCon (defined in GHC.Builtin.Types). A freshly-parsed (HsExpr GhcPs) empty list-is never a ExplicitList.--Renaming----------If -XOverloadedLists is enabled, we must type-check the empty list as if it-were a call to fromListN. (This is true regardless of the setting of--XRebindableSyntax.) This is very easy if the empty list is an ExplicitList,-but an annoying special case if it's an HsVar. So the renamer changes a-HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on.-(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr.--Type-checking---------------We want to accept an expression like [] @Int. To do this, we must infer that-[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside.-However, the type-checking for explicit lists works differently: [x,y,z] is never-polymorphic. Instead, we unify the types of x, y, and z together, and use the-unified type as the argument to the cons and nil constructors. Thus, treating-[] as an empty ExplicitList in the type-checker would prevent [] @Int from working.--However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed:-it's just like fromListN 0 [] @Int. Since-  fromListN :: forall list. IsList list => Int -> [Item list] -> list-that expression really should be rejected. Thus, the renamer's behaviour is-exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as-an empty ExplicitList when -XOverloadedLists.--See also #13680, which requested [] @Int to work.--}--instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where-    ppr expr = pprExpr expr---------------------------- pprExpr, pprLExpr, pprBinds call pprDeeper;--- the underscore versions do not-pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-pprLExpr (L _ e) = pprExpr e--pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc-pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e-          | otherwise                           = pprDeeper (ppr_expr e)--isQuietHsExpr :: HsExpr id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsExpr (HsPar {})        = True--- applications don't display anything themselves-isQuietHsExpr (HsApp {})        = True-isQuietHsExpr (HsAppType {})    = True-isQuietHsExpr (OpApp {})        = True-isQuietHsExpr _ = False--pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)-         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc-pprBinds b = pprDeeper (ppr b)--------------------------ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-ppr_lexpr e = ppr_expr (unLoc e)--ppr_expr :: forall p. (OutputableBndrId p)-         => HsExpr (GhcPass p) -> SDoc-ppr_expr (HsVar _ (L _ v))  = pprPrefixOcc v-ppr_expr (HsUnboundVar _ uv)= pprPrefixOcc uv-ppr_expr (HsConLikeOut _ c) = pprPrefixOcc c-ppr_expr (HsIPVar _ v)      = ppr v-ppr_expr (HsOverLabel _ _ l)= char '#' <> ppr l-ppr_expr (HsLit _ lit)      = ppr lit-ppr_expr (HsOverLit _ lit)  = ppr lit-ppr_expr (HsPar _ e)        = parens (ppr_lexpr e)--ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]--ppr_expr e@(HsApp {})        = ppr_apps e []-ppr_expr e@(HsAppType {})    = ppr_apps e []--ppr_expr (OpApp _ e1 op e2)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly--  where-    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens-    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear--    pp_prefixly-      = hang (ppr op) 2 (sep [pp_e1, pp_e2])--    pp_infixly pp_op-      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])--ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e--ppr_expr (SectionL _ expr op)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly-  where-    pp_expr = pprDebugParendExpr opPrec expr--    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])-                       4 (hsep [pp_expr, text "x_ )"])--    pp_infixly v = (sep [pp_expr, v])--ppr_expr (SectionR _ op expr)-  | Just pp_op <- ppr_infix_expr (unLoc op)-  = pp_infixly pp_op-  | otherwise-  = pp_prefixly-  where-    pp_expr = pprDebugParendExpr opPrec expr--    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])-                       4 (pp_expr <> rparen)--    pp_infixly v = sep [v, pp_expr]--ppr_expr (ExplicitTuple _ exprs boxity)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `Solo x`, not `(x)`-  | [L _ (Present _ expr)] <- exprs-  , Boxed <- boxity-  = hsep [text (mkTupleStr Boxed 1), ppr expr]-  | otherwise-  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args $ map unLoc exprs))-  where-    ppr_tup_args []               = []-    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es-    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es--    punc (Present {} : _) = comma <> space-    punc (Missing {} : _) = comma-    punc (XTupArg {} : _) = comma <> space-    punc []               = empty--ppr_expr (ExplicitSum _ alt arity expr)-  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"-  where-    ppr_bars n = hsep (replicate n (char '|'))--ppr_expr (HsLam _ matches)-  = pprMatches matches--ppr_expr (HsLamCase _ matches)-  = sep [ sep [text "\\case"],-          nest 2 (pprMatches matches) ]--ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ [_] }))-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of {")],-          nest 2 (pprMatches matches) <+> char '}']-ppr_expr (HsCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],-          nest 2 (pprMatches matches) ]--ppr_expr (HsIf _ e1 e2 e3)-  = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],-         nest 4 (ppr e2),-         text "else",-         nest 4 (ppr e3)]--ppr_expr (HsMultiIf _ alts)-  = hang (text "if") 3  (vcat (map ppr_alt alts))-  where ppr_alt (L _ (GRHS _ guards expr)) =-          hang vbar 2 (ppr_one one_alt)-          where-            ppr_one [] = panic "ppr_exp HsMultiIf"-            ppr_one (h:t) = hang h 2 (sep t)-            one_alt = [ interpp'SP guards-                      , text "->" <+> pprDeeper (ppr expr) ]-        ppr_alt (L _ (XGRHS x)) = ppr x---- special case: let ... in let ...-ppr_expr (HsLet _ (L _ binds) expr@(L _ (HsLet _ _ _)))-  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),-         ppr_lexpr expr]--ppr_expr (HsLet _ (L _ binds) expr)-  = sep [hang (text "let") 2 (pprBinds binds),-         hang (text "in")  2 (ppr expr)]--ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts--ppr_expr (ExplicitList _ _ exprs)-  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))--ppr_expr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })-  = hang (ppr con_id) 2 (ppr rbinds)--ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = rbinds })-  = hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))--ppr_expr (ExprWithTySig _ expr sig)-  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)-         4 (ppr sig)--ppr_expr (ArithSeq _ _ info) = brackets (ppr info)--ppr_expr (HsSpliceE _ s)         = pprSplice s-ppr_expr (HsBracket _ b)         = pprHsBracket b-ppr_expr (HsRnBracketOut _ e []) = ppr e-ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps-ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e-ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)--ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))-  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]--ppr_expr (HsStatic _ e)-  = hsep [text "static", ppr e]--ppr_expr (HsTick _ tickish exp)-  = pprTicks (ppr exp) $-    ppr tickish <+> ppr_lexpr exp-ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)-  = pprTicks (ppr exp) $-    hcat [text "bintick<",-          ppr tickIdTrue,-          text ",",-          ppr tickIdFalse,-          text ">(",-          ppr exp, text ")"]--ppr_expr (HsRecFld _ f) = ppr f-ppr_expr (XExpr x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-#endif-  GhcRn -> ppr x-  GhcTc -> case x of-    WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn-      (\parens -> if parens then pprExpr e else pprExpr e)-    ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original-                             -- expression (LHsExpr GhcPs), not the-                             -- desugared one (LHsExpr GhcT).--ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc-ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)-ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))-ppr_infix_expr (HsRecFld _ f)       = Just (pprInfixOcc f)-ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)-ppr_infix_expr (XExpr x)            = case (ghcPass @p, x) of-  (GhcPs, _)                              -> Nothing-  (GhcRn, HsExpanded a _)                 -> ppr_infix_expr a-  (GhcTc, WrapExpr (HsWrap _ e))          -> ppr_infix_expr e-  (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a-ppr_infix_expr _ = Nothing--ppr_apps :: (OutputableBndrId p)-         => HsExpr (GhcPass p)-         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]-         -> SDoc-ppr_apps (HsApp _ (L _ fun) arg)        args-  = ppr_apps fun (Left arg : args)-ppr_apps (HsAppType _ (L _ fun) arg)    args-  = ppr_apps fun (Right arg : args)-ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))-  where-    pp (Left arg)                             = ppr arg-    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))-    --   = char '@' <> pprHsType arg-    pp (Right arg)-      = text "@" <> ppr arg--pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc-pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))-  = ppr (src,(n1,n2),(n3,n4))--{--HsSyn records exactly where the user put parens, with HsPar.-So generally speaking we print without adding any parens.-However, some code is internally generated, and in some places-parens are absolutely required; so for these places we use-pprParendLExpr (but don't print double parens of course).--For operator applications we don't add parens, because the operator-fixities should do the job, except in debug mode (-dppr-debug) so we-can see the structure of the parse tree.--}--pprDebugParendExpr :: (OutputableBndrId p)-                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc-pprDebugParendExpr p expr-  = getPprDebug $ \case-      True  -> pprParendLExpr p expr-      False -> pprLExpr         expr--pprParendLExpr :: (OutputableBndrId p)-               => PprPrec -> LHsExpr (GhcPass p) -> SDoc-pprParendLExpr p (L _ e) = pprParendExpr p e--pprParendExpr :: (OutputableBndrId p)-              => PprPrec -> HsExpr (GhcPass p) -> SDoc-pprParendExpr p expr-  | hsExprNeedsParens p expr = parens (pprExpr expr)-  | otherwise                = pprExpr expr-        -- Using pprLExpr makes sure that we go 'deeper'-        -- I think that is usually (always?) right---- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs--- parentheses under precedence @p@.-hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool-hsExprNeedsParens p = go-  where-    go (HsVar{})                      = False-    go (HsUnboundVar{})               = False-    go (HsConLikeOut{})               = False-    go (HsIPVar{})                    = False-    go (HsOverLabel{})                = False-    go (HsLit _ l)                    = hsLitNeedsParens p l-    go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol-    go (HsPar{})                      = False-    go (HsApp{})                      = p >= appPrec-    go (HsAppType {})                 = p >= appPrec-    go (OpApp{})                      = p >= opPrec-    go (NegApp{})                     = p > topPrec-    go (SectionL{})                   = True-    go (SectionR{})                   = True-    go (ExplicitTuple{})              = False-    go (ExplicitSum{})                = False-    go (HsLam{})                      = p > topPrec-    go (HsLamCase{})                  = p > topPrec-    go (HsCase{})                     = p > topPrec-    go (HsIf{})                       = p > topPrec-    go (HsMultiIf{})                  = p > topPrec-    go (HsLet{})                      = p > topPrec-    go (HsDo _ sc _)-      | isComprehensionContext sc     = False-      | otherwise                     = p > topPrec-    go (ExplicitList{})               = False-    go (RecordUpd{})                  = False-    go (ExprWithTySig{})              = p >= sigPrec-    go (ArithSeq{})                   = False-    go (HsPragE{})                    = p >= appPrec-    go (HsSpliceE{})                  = False-    go (HsBracket{})                  = False-    go (HsRnBracketOut{})             = False-    go (HsTcBracketOut{})             = False-    go (HsProc{})                     = p > topPrec-    go (HsStatic{})                   = p >= appPrec-    go (HsTick _ _ (L _ e))           = go e-    go (HsBinTick _ _ _ (L _ e))      = go e-    go (RecordCon{})                  = False-    go (HsRecFld{})                   = False-    go (XExpr x)-      | GhcTc <- ghcPass @p-      = case x of-          WrapExpr      (HsWrap _ e)     -> go e-          ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a-      | GhcRn <- ghcPass @p-      = case x of HsExpanded a _ -> hsExprNeedsParens p a-      | otherwise-      = True----- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,--- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.-parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-parenthesizeHsExpr p le@(L loc e)-  | hsExprNeedsParens p e = L loc (HsPar noExtField le)-  | otherwise             = le--stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e-stripParensLHsExpr e = e--stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)-stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e-stripParensHsExpr e = e--isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool--- True of a single token-isAtomicHsExpr (HsVar {})        = True-isAtomicHsExpr (HsConLikeOut {}) = True-isAtomicHsExpr (HsLit {})        = True-isAtomicHsExpr (HsOverLit {})    = True-isAtomicHsExpr (HsIPVar {})      = True-isAtomicHsExpr (HsOverLabel {})  = True-isAtomicHsExpr (HsUnboundVar {}) = True-isAtomicHsExpr (HsPar _ e)       = isAtomicHsExpr (unLoc e)-isAtomicHsExpr (HsRecFld{})      = True-isAtomicHsExpr (XExpr x)-  | GhcTc <- ghcPass @p          = case x of-      WrapExpr      (HsWrap _ e)     -> isAtomicHsExpr e-      ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a-  | GhcRn <- ghcPass @p          = case x of-      HsExpanded a _         -> isAtomicHsExpr a-isAtomicHsExpr _                 = False--instance Outputable (HsPragE (GhcPass p)) where-  ppr (HsPragSCC _ st (StringLiteral stl lbl)) =-    pprWithSourceText st (text "{-# SCC")-     -- no doublequotes if stl empty, for the case where the SCC was written-     -- without quotes.-    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"-  ppr (HsPragTick _ st (StringLiteral sta s, (v1,v2), (v3,v4)) ((s1,s2),(s3,s4))) =-    pprWithSourceText st (text "{-# GENERATED")-    <+> pprWithSourceText sta (doubleQuotes $ ftext s)-    <+> pprWithSourceText s1 (ppr v1) <+> char ':' <+> pprWithSourceText s2 (ppr v2)-    <+> char '-'-    <+> pprWithSourceText s3 (ppr v3) <+> char ':' <+> pprWithSourceText s4 (ppr v4)-    <+> text "#-}"--{--************************************************************************-*                                                                      *-\subsection{Commands (in arrow abstractions)}-*                                                                      *-************************************************************************--We re-use HsExpr to represent these.--}---- | Located Haskell Command (for arrow syntax)-type LHsCmd id = Located (HsCmd id)---- | Haskell Command (e.g. a "statement" in an Arrow proc block)-data HsCmd id-  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail',-  --          'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail',-  --          'GHC.Parser.Annotation.AnnRarrowtail'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)-        (XCmdArrApp id)  -- type of the arrow expressions f,-                         -- of the form a t t', where arg :: t-        (LHsExpr id)     -- arrow expression, f-        (LHsExpr id)     -- input expression, arg-        HsArrAppType     -- higher-order (-<<) or first-order (-<)-        Bool             -- True => right-to-left (f -< arg)-                         -- False => left-to-right (arg >- f)--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@,-  --         'GHC.Parser.Annotation.AnnCloseB' @'|)'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)-        (XCmdArrForm id)-        (LHsExpr id)     -- The operator.-                         -- After type-checking, a type abstraction to be-                         -- applied to the type of the local environment tuple-        LexicalFixity    -- Whether the operator appeared prefix or infix when-                         -- parsed.-        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that-                         -- were converted from OpApp's by the renamer-        [LHsCmdTop id]   -- argument commands--  | HsCmdApp    (XCmdApp id)-                (LHsCmd id)-                (LHsExpr id)--  | HsCmdLam    (XCmdLam id)-                (MatchGroup id (LHsCmd id))     -- kappa-       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --       'GHC.Parser.Annotation.AnnRarrow',--       -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsCmdPar    (XCmdPar id)-                (LHsCmd id)                     -- parenthesised command-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-    --             'GHC.Parser.Annotation.AnnClose' @')'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsCmdCase   (XCmdCase id)-                (LHsExpr id)-                (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',-    --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,-    --       'GHC.Parser.Annotation.AnnClose' @'}'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsCmdLamCase (XCmdLamCase id)-                 (MatchGroup id (LHsCmd id))    -- bodies are HsCmd's-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-    --       'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,-    --       'GHC.Parser.Annotation.AnnClose' @'}'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsCmdIf     (XCmdIf id)-                (SyntaxExpr id)         -- cond function-                (LHsExpr id)            -- predicate-                (LHsCmd id)             -- then part-                (LHsCmd id)             -- else part-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',-    --       'GHC.Parser.Annotation.AnnSemi',-    --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',-    --       'GHC.Parser.Annotation.AnnElse',--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsCmdLet    (XCmdLet id)-                (LHsLocalBinds id)      -- let(rec)-                (LHsCmd  id)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',-    --       'GHC.Parser.Annotation.AnnOpen' @'{'@,-    --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression-                (Located [CmdLStmt id])-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',-    --             'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',-    --             'GHC.Parser.Annotation.AnnVbar',-    --             'GHC.Parser.Annotation.AnnClose'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | XCmd        !(XXCmd id)     -- Note [Trees that Grow] extension point--type instance XCmdArrApp  GhcPs = NoExtField-type instance XCmdArrApp  GhcRn = NoExtField-type instance XCmdArrApp  GhcTc = Type--type instance XCmdArrForm (GhcPass _) = NoExtField-type instance XCmdApp     (GhcPass _) = NoExtField-type instance XCmdLam     (GhcPass _) = NoExtField-type instance XCmdPar     (GhcPass _) = NoExtField-type instance XCmdCase    (GhcPass _) = NoExtField-type instance XCmdLamCase (GhcPass _) = NoExtField-type instance XCmdIf      (GhcPass _) = NoExtField-type instance XCmdLet     (GhcPass _) = NoExtField--type instance XCmdDo      GhcPs = NoExtField-type instance XCmdDo      GhcRn = NoExtField-type instance XCmdDo      GhcTc = Type--type instance XCmdWrap    (GhcPass _) = NoExtField--type instance XXCmd       GhcPs = NoExtCon-type instance XXCmd       GhcRn = NoExtCon-type instance XXCmd       GhcTc = HsWrap HsCmd-    -- If   cmd :: arg1 --> res-    --      wrap :: arg1 "->" arg2-    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res---- | Haskell Array Application Type-data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp-  deriving Data---{- | Top-level command, introducing a new arrow.-This may occur inside a proc (where the stack is empty) or as an-argument of a command-forming operator.--}---- | Located Haskell Top-level Command-type LHsCmdTop p = Located (HsCmdTop p)---- | Haskell Top-level Command-data HsCmdTop p-  = HsCmdTop (XCmdTop p)-             (LHsCmd p)-  | XCmdTop !(XXCmdTop p)        -- Note [Trees that Grow] extension point--data CmdTopTc-  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack-             Type    -- return type of the command-             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]--type instance XCmdTop  GhcPs = NoExtField-type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]-type instance XCmdTop  GhcTc = CmdTopTc--type instance XXCmdTop (GhcPass _) = NoExtCon--instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where-    ppr cmd = pprCmd cmd---------------------------- pprCmd and pprLCmd call pprDeeper;--- the underscore versions do not-pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc-pprLCmd (L _ c) = pprCmd c--pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc-pprCmd c | isQuietHsCmd c =            ppr_cmd c-         | otherwise      = pprDeeper (ppr_cmd c)--isQuietHsCmd :: HsCmd id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsCmd (HsCmdPar {}) = True--- applications don't display anything themselves-isQuietHsCmd (HsCmdApp {}) = True-isQuietHsCmd _ = False--------------------------ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc-ppr_lcmd c = ppr_cmd (unLoc c)--ppr_cmd :: forall p. (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc-ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)--ppr_cmd (HsCmdApp _ c e)-  = let (fun, args) = collect_args c [e] in-    hang (ppr_lcmd fun) 2 (sep (map ppr args))-  where-    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)-    collect_args fun args = (fun, args)--ppr_cmd (HsCmdLam _ matches)-  = pprMatches matches--ppr_cmd (HsCmdCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],-          nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdLamCase _ matches)-  = sep [ text "\\case", nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdIf _ _ e ct ce)-  = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],-         nest 4 (ppr ct),-         text "else",-         nest 4 (ppr ce)]---- special case: let ... in let ...-ppr_cmd (HsCmdLet _ (L _ binds) cmd@(L _ (HsCmdLet {})))-  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),-         ppr_lcmd cmd]--ppr_cmd (HsCmdLet _ (L _ binds) cmd)-  = sep [hang (text "let") 2 (pprBinds binds),-         hang (text "in")  2 (ppr cmd)]--ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts--ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)-  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]-ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)-  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]-ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)-  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]-ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)-  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]--ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])-  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)-                                         , pprCmdArg (unLoc arg2)])-ppr_cmd (HsCmdArrForm _ op _ _ args)-  = hang (text "(|" <+> ppr_lexpr op)-         4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")-ppr_cmd (XCmd x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-  GhcRn -> ppr x-#endif-  GhcTc -> case x of-    HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))--pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc-pprCmdArg (HsCmdTop _ cmd)-  = ppr_lcmd cmd--instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where-    ppr = pprCmdArg--{--************************************************************************-*                                                                      *-\subsection{Record binds}-*                                                                      *-************************************************************************--}---- | Haskell Record Bindings-type HsRecordBinds p = HsRecFields p (LHsExpr p)--{--************************************************************************-*                                                                      *-\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}-*                                                                      *-************************************************************************--@Match@es are sets of pattern bindings and right hand sides for-functions, patterns or case branches. For example, if a function @g@-is defined as:-\begin{verbatim}-g (x,y) = y-g ((x:ys),y) = y+1,-\end{verbatim}-then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.--It is always the case that each element of an @[Match]@ list has the-same number of @pats@s inside it.  This corresponds to saying that-a function defined by pattern matching must have the same number of-patterns in each equation.--}--data MatchGroup p body-  = MG { mg_ext     :: XMG p body -- Post-typechecker, types of args and result-       , mg_alts    :: Located [LMatch p body]  -- The alternatives-       , mg_origin  :: Origin }-     -- The type is the type of the entire group-     --      t1 -> ... -> tn -> tr-     -- where there are n patterns-  | XMatchGroup !(XXMatchGroup p body)--data MatchGroupTc-  = MatchGroupTc-       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn-       , mg_res_ty  :: Type    -- Type of the result, tr-       } deriving Data--type instance XMG         GhcPs b = NoExtField-type instance XMG         GhcRn b = NoExtField-type instance XMG         GhcTc b = MatchGroupTc--type instance XXMatchGroup (GhcPass _) b = NoExtCon---- | Located Match-type LMatch id body = Located (Match id body)--- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a---   list---- For details on above see note [Api annotations] in GHC.Parser.Annotation-data Match p body-  = Match {-        m_ext :: XCMatch p body,-        m_ctxt :: HsMatchContext (NoGhcTc p),-          -- See note [m_ctxt in Match]-        m_pats :: [LPat p], -- The patterns-        m_grhss :: (GRHSs p body)-  }-  | XMatch !(XXMatch p body)--type instance XCMatch (GhcPass _) b = NoExtField-type instance XXMatch (GhcPass _) b = NoExtCon--instance (OutputableBndrId pr, Outputable body)-            => Outputable (Match (GhcPass pr) body) where-  ppr = pprMatch--{--Note [m_ctxt in Match]-~~~~~~~~~~~~~~~~~~~~~~--A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and-so on.--In order to simplify tooling processing and pretty print output, the provenance-is captured in an HsMatchContext.--This is particularly important for the API Annotations for a multi-equation-FunBind.--The parser initially creates a FunBind with a single Match in it for-every function definition it sees.--These are then grouped together by getMonoBind into a single FunBind,-where all the Matches are combined.--In the process, all the original FunBind fun_id's bar one are-discarded, including the locations.--This causes a problem for source to source conversions via API-Annotations, so the original fun_ids and infix flags are preserved in-the Match, when it originates from a FunBind.--Example infix function definition requiring individual API Annotations--    (&&&  ) [] [] =  []-    xs    &&&   [] =  xs-    (  &&&  ) [] ys =  ys-----}---isInfixMatch :: Match id body -> Bool-isInfixMatch match = case m_ctxt match of-  FunRhs {mc_fixity = Infix} -> True-  _                          -> False--isEmptyMatchGroup :: MatchGroup id body -> Bool-isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms-isEmptyMatchGroup (XMatchGroup {})      = False---- | Is there only one RHS in this list of matches?-isSingletonMatchGroup :: [LMatch id body] -> Bool-isSingletonMatchGroup matches-  | [L _ match] <- matches-  , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match-  = True-  | otherwise-  = False--matchGroupArity :: MatchGroup (GhcPass id) body -> Arity--- Precondition: MatchGroup is non-empty--- This is called before type checking, when mg_arg_tys is not set-matchGroupArity (MG { mg_alts = alts })-  | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)-  | otherwise        = panic "matchGroupArity"--hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]-hsLMatchPats (L _ (Match { m_pats = pats })) = pats---- | Guarded Right-Hand Sides------ GRHSs are used both for pattern bindings and for Matches------  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',---        'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',---        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'---        'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi'---- For details on above see note [Api annotations] in GHC.Parser.Annotation-data GRHSs p body-  = GRHSs {-      grhssExt :: XCGRHSs p body,-      grhssGRHSs :: [LGRHS p body],      -- ^ Guarded RHSs-      grhssLocalBinds :: LHsLocalBinds p -- ^ The where clause-    }-  | XGRHSs !(XXGRHSs p body)--type instance XCGRHSs (GhcPass _) b = NoExtField-type instance XXGRHSs (GhcPass _) b = NoExtCon---- | Located Guarded Right-Hand Side-type LGRHS id body = Located (GRHS id body)---- | Guarded Right Hand Side.-data GRHS p body = GRHS (XCGRHS p body)-                        [GuardLStmt p] -- Guards-                        body           -- Right hand side-                  | XGRHS !(XXGRHS p body)--type instance XCGRHS (GhcPass _) b = NoExtField-type instance XXGRHS (GhcPass _) b = NoExtCon---- We know the list must have at least one @Match@ in it.--pprMatches :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc-pprMatches MG { mg_alts = matches }-    = vcat (map pprMatch (map unLoc (unLoc matches)))-      -- Don't print the type; it's only a place-holder before typechecking---- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext-pprFunBind :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc-pprFunBind matches = pprMatches matches---- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext-pprPatBind :: forall bndr p body. (OutputableBndrId bndr,-                                   OutputableBndrId p,-                                   Outputable body)-           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc-pprPatBind pat (grhss)- = sep [ppr pat,-       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]--pprMatch :: (OutputableBndrId idR, Outputable body)-         => Match (GhcPass idR) body -> SDoc-pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })-  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)-        , nest 2 (pprGRHSs ctxt grhss) ]-  where-    (herald, other_pats)-        = case ctxt of-            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}-                | SrcStrict <- strictness-                -> ASSERT(null pats)     -- A strict variable binding-                   (char '!'<>pprPrefixOcc fun, pats)--                | Prefix <- fixity-                -> (pprPrefixOcc fun, pats) -- f x y z = e-                                            -- Not pprBndr; the AbsBinds will-                                            -- have printed the signature-                | otherwise-                -> case pats of-                     (p1:p2:rest)-                        | null rest -> (pp_infix, [])           -- x &&& y = e-                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e-                        where-                          pp_infix = pprParendLPat opPrec p1-                                     <+> pprInfixOcc fun-                                     <+> pprParendLPat opPrec p2-                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)--            LambdaExpr -> (char '\\', pats)--            _ -> case pats of-                   []    -> (empty, [])-                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case-                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)--pprGRHSs :: (OutputableBndrId idR, Outputable body)-         => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc-pprGRHSs ctxt (GRHSs _ grhss (L _ binds))-  = vcat (map (pprGRHS ctxt . unLoc) grhss)-  -- Print the "where" even if the contents of the binds is empty. Only-  -- EmptyLocalBinds means no "where" keyword- $$ ppUnless (eqEmptyLocalBinds binds)-      (text "where" $$ nest 4 (pprBinds binds))--pprGRHS :: (OutputableBndrId idR, Outputable body)-        => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc-pprGRHS ctxt (GRHS _ [] body)- =  pp_rhs ctxt body--pprGRHS ctxt (GRHS _ guards body)- = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]--pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc-pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)--{--************************************************************************-*                                                                      *-\subsection{Do stmts and list comprehensions}-*                                                                      *-************************************************************************--}---- | Located @do@ block Statement-type LStmt id body = Located (StmtLR id id body)---- | Located Statement with separate Left and Right id's-type LStmtLR idL idR body = Located (StmtLR idL idR body)---- | @do@ block Statement-type Stmt id body = StmtLR id id body---- | Command Located Statement-type CmdLStmt   id = LStmt id (LHsCmd  id)---- | Command Statement-type CmdStmt    id = Stmt  id (LHsCmd  id)---- | Expression Located Statement-type ExprLStmt  id = LStmt id (LHsExpr id)---- | Expression Statement-type ExprStmt   id = Stmt  id (LHsExpr id)---- | Guard Located Statement-type GuardLStmt id = LStmt id (LHsExpr id)---- | Guard Statement-type GuardStmt  id = Stmt  id (LHsExpr id)---- | Ghci Located Statement-type GhciLStmt  id = LStmt id (LHsExpr id)---- | Ghci Statement-type GhciStmt   id = Stmt  id (LHsExpr id)---- The SyntaxExprs in here are used *only* for do-notation and monad--- comprehensions, which have rebindable syntax. Otherwise they are unused.--- | API Annotations when in qualifier lists or guards---  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',---         'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen',---         'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy',---         'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing'---- For details on above see note [Api annotations] in GHC.Parser.Annotation-data StmtLR idL idR body -- body should always be (LHs**** idR)-  = LastStmt  -- Always the last Stmt in ListComp, MonadComp,-              -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr-              -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff-          (XLastStmt idL idR body)-          body-          (Maybe Bool)  -- Whether return was stripped-            -- Just True <=> return with a dollar was stripped by ApplicativeDo-            -- Just False <=> return without a dollar was stripped by ApplicativeDo-            -- Nothing <=> Nothing was stripped-          (SyntaxExpr idR)   -- The return operator-            -- The return operator is used only for MonadComp-            -- For ListComp we use the baked-in 'return'-            -- For DoExpr, MDoExpr, we don't apply a 'return' at all-            -- See Note [Monad Comprehensions]-            -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | BindStmt (XBindStmt idL idR body)-             -- ^ Post renaming has optional fail and bind / (>>=) operator.-             -- Post typechecking, also has multiplicity of the argument-             -- and the result type of the function passed to bind;-             -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T-             -- See Note [The type of bind in Stmts]-             (LPat idL)-             body--  -- | 'ApplicativeStmt' represents an applicative expression built with-  -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the-  -- appropriate applicative expression by the desugarer, but it is intended-  -- to be invisible in error messages.-  ---  -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"-  ---  | ApplicativeStmt-             (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body-             [ ( SyntaxExpr idR-               , ApplicativeArg idL) ]-                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]-             (Maybe (SyntaxExpr idR))  -- 'join', if necessary--  | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type-                                      -- of the RHS (used for arrows)-             body              -- See Note [BodyStmt]-             (SyntaxExpr idR)  -- The (>>) operator-             (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp-                               -- See notes [Monad Comprehensions]--  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet'-  --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@,--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | LetStmt  (XLetStmt idL idR body) (LHsLocalBindsLR idL idR)--  -- ParStmts only occur in a list/monad comprehension-  | ParStmt  (XParStmt idL idR body)    -- Post typecheck,-                                        -- S in (>>=) :: Q -> (R -> S) -> T-             [ParStmtBlock idL idR]-             (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions-             (SyntaxExpr idR)           -- The `>>=` operator-                                        -- See notes [Monad Comprehensions]-            -- After renaming, the ids are the binders-            -- bound by the stmts and used after themp--  | TransStmt {-      trS_ext   :: XTransStmt idL idR body, -- Post typecheck,-                                            -- R in (>>=) :: Q -> (R -> S) -> T-      trS_form  :: TransForm,-      trS_stmts :: [ExprLStmt idL],   -- Stmts to the *left* of the 'group'-                                      -- which generates the tuples to be grouped--      trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map]--      trS_using :: LHsExpr idR,-      trS_by :: Maybe (LHsExpr idR),  -- "by e" (optional)-        -- Invariant: if trS_form = GroupBy, then grp_by = Just e--      trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for-                                      -- the inner monad comprehensions-      trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator-      trS_fmap :: HsExpr idR          -- The polymorphic 'fmap' function for desugaring-                                      -- Only for 'group' forms-                                      -- Just a simple HsExpr, because it's-                                      -- too polymorphic for tcSyntaxOp-    }                                 -- See Note [Monad Comprehensions]--  -- Recursive statement (see Note [How RecStmt works] below)-  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | RecStmt-     { recS_ext :: XRecStmt idL idR body-     , recS_stmts :: [LStmtLR idL idR body]--        -- The next two fields are only valid after renaming-     , recS_later_ids :: [IdP idR]-                         -- The ids are a subset of the variables bound by the-                         -- stmts that are used in stmts that follow the RecStmt--     , recS_rec_ids :: [IdP idR]-                         -- Ditto, but these variables are the "recursive" ones,-                         -- that are used before they are bound in the stmts of-                         -- the RecStmt.-        -- An Id can be in both groups-        -- Both sets of Ids are (now) treated monomorphically-        -- See Note [How RecStmt works] for why they are separate--        -- Rebindable syntax-     , recS_bind_fn :: SyntaxExpr idR -- The bind function-     , recS_ret_fn  :: SyntaxExpr idR -- The return function-     , recS_mfix_fn :: SyntaxExpr idR -- The mfix function-      }-  | XStmtLR !(XXStmtLR idL idR body)---- Extra fields available post typechecking for RecStmt.-data RecStmtTc =-  RecStmtTc-     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T-     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)-     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1-                                  -- with recS_later_ids and recS_rec_ids,-                                  -- and are the expressions that should be-                                  -- returned by the recursion.-                                  -- They may not quite be the Ids themselves,-                                  -- because the Id may be *polymorphic*, but-                                  -- the returned thing has to be *monomorphic*,-                                  -- so they may be type applications--      , recS_ret_ty :: Type        -- The type of-                                   -- do { stmts; return (a,b,c) }-                                   -- With rebindable syntax the type might not-                                   -- be quite as simple as (m (tya, tyb, tyc)).-      }---type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField--type instance XBindStmt        (GhcPass _) GhcPs b = NoExtField-type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn-type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc--data XBindStmtRn = XBindStmtRn-  { xbsrn_bindOp :: SyntaxExpr GhcRn-  , xbsrn_failOp :: FailOperator GhcRn-  }--data XBindStmtTc = XBindStmtTc-  { xbstc_bindOp :: SyntaxExpr GhcTc-  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S-  , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S-  , xbstc_failOp :: FailOperator GhcTc-  }--type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcTc b = Type--type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcTc b = Type--type instance XLetStmt         (GhcPass _) (GhcPass _) b = NoExtField--type instance XParStmt         (GhcPass _) GhcPs b = NoExtField-type instance XParStmt         (GhcPass _) GhcRn b = NoExtField-type instance XParStmt         (GhcPass _) GhcTc b = Type--type instance XTransStmt       (GhcPass _) GhcPs b = NoExtField-type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField-type instance XTransStmt       (GhcPass _) GhcTc b = Type--type instance XRecStmt         (GhcPass _) GhcPs b = NoExtField-type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField-type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc--type instance XXStmtLR         (GhcPass _) (GhcPass _) b = NoExtCon--data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function-  = ThenForm     -- then f               or    then f by e             (depending on trS_by)-  | GroupForm    -- then group using f   or    then group by e using f (depending on trS_by)-  deriving Data---- | Parenthesised Statement Block-data ParStmtBlock idL idR-  = ParStmtBlock-        (XParStmtBlock idL idR)-        [ExprLStmt idL]-        [IdP idR]          -- The variables to be returned-        (SyntaxExpr idR)   -- The return operator-  | XParStmtBlock !(XXParStmtBlock idL idR)--type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField-type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon---- | The fail operator------ This is used for `.. <-` "bind statments" in do notation, including--- non-monadic "binds" in applicative.------ The fail operator is 'Just expr' if it potentially fail monadically. if the--- pattern match cannot fail, or shouldn't fail monadically (regular incomplete--- pattern exception), it is 'Nothing'.------ See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of--- expression in the 'Just' case, and why it is so.------ See Note [Failing pattern matches in Stmts] for which contexts for--- '@BindStmt@'s should use the monadic fail and which shouldn't.-type FailOperator id = Maybe (SyntaxExpr id)---- | Applicative Argument-data ApplicativeArg idL-  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)-    { xarg_app_arg_one  :: XApplicativeArgOne idL-      -- ^ The fail operator, after renaming-      ---      -- The fail operator is needed if this is a BindStmt-      -- where the pattern can fail. E.g.:-      -- (Just a) <- stmt-      -- The fail operator will be invoked if the pattern-      -- match fails.-      -- It is also used for guards in MonadComprehensions.-      -- The fail operator is Nothing-      -- if the pattern match can't fail-    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)-    , arg_expr          :: LHsExpr idL-    , is_body_stmt      :: Bool-      -- ^ True <=> was a BodyStmt,-      -- False <=> was a BindStmt.-      -- See Note [Applicative BodyStmt]-    }-  | ApplicativeArgMany     -- do { stmts; return vars }-    { xarg_app_arg_many :: XApplicativeArgMany idL-    , app_stmts         :: [ExprLStmt idL] -- stmts-    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)-    , bv_pattern        :: LPat idL      -- (v1,...,vn)-    , stmt_context      :: HsStmtContext GhcRn -- context of the do expression-                                               -- used in pprArg-    }-  | XApplicativeArg !(XXApplicativeArg idL)--type instance XApplicativeArgOne GhcPs = NoExtField-type instance XApplicativeArgOne GhcRn = FailOperator GhcRn-type instance XApplicativeArgOne GhcTc = FailOperator GhcTc--type instance XApplicativeArgMany (GhcPass _) = NoExtField-type instance XXApplicativeArg    (GhcPass _) = NoExtCon--{--Note [The type of bind in Stmts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some Stmts, notably BindStmt, keep the (>>=) bind operator.-We do NOT assume that it has type-    (>>=) :: m a -> (a -> m b) -> m b-In some cases (see #303, #1537) it might have a more-exotic type, such as-    (>>=) :: m i j a -> (a -> m j k b) -> m i k b-So we must be careful not to make assumptions about the type.-In particular, the monad may not be uniform throughout.--Note [TransStmt binder map]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-The [(idR,idR)] in a TransStmt behaves as follows:--  * Before renaming: []--  * After renaming:-          [ (x27,x27), ..., (z35,z35) ]-    These are the variables-       bound by the stmts to the left of the 'group'-       and used either in the 'by' clause,-                or     in the stmts following the 'group'-    Each item is a pair of identical variables.--  * After typechecking:-          [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]-    Each pair has the same unique, but different *types*.--Note [BodyStmt]-~~~~~~~~~~~~~~~-BodyStmts are a bit tricky, because what they mean-depends on the context.  Consider the following contexts:--        A do expression of type (m res_ty)-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E any_ty:   do { ....; E; ... }-                E :: m any_ty-          Translation: E >> ...--        A list comprehensions of type [elt_ty]-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E Bool:   [ .. | .... E ]-                        [ .. | ..., E, ... ]-                        [ .. | .... | ..., E | ... ]-                E :: Bool-          Translation: if E then fail else ...--        A guard list, guarding a RHS of type rhs_ty-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E BooParStmtBlockl:   f x | ..., E, ... = ...rhs...-                E :: Bool-          Translation: if E then fail else ...--        A monad comprehension of type (m res_ty)-        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        * BodyStmt E Bool:   [ .. | .... E ]-                E :: Bool-          Translation: guard E >> ...--Array comprehensions are handled like list comprehensions.--Note [How RecStmt works]-~~~~~~~~~~~~~~~~~~~~~~~~-Example:-   HsDo [ BindStmt x ex--        , RecStmt { recS_rec_ids   = [a, c]-                  , recS_stmts     = [ BindStmt b (return (a,c))-                                     , LetStmt a = ...b...-                                     , BindStmt c ec ]-                  , recS_later_ids = [a, b]--        , return (a b) ]--Here, the RecStmt binds a,b,c; but-  - Only a,b are used in the stmts *following* the RecStmt,-  - Only a,c are used in the stmts *inside* the RecStmt-        *before* their bindings--Why do we need *both* rec_ids and later_ids?  For monads they could be-combined into a single set of variables, but not for arrows.  That-follows from the types of the respective feedback operators:--        mfix :: MonadFix m => (a -> m a) -> m a-        loop :: ArrowLoop a => a (b,d) (c,d) -> a b c--* For mfix, the 'a' covers the union of the later_ids and the rec_ids-* For 'loop', 'c' is the later_ids and 'd' is the rec_ids--Note [Typing a RecStmt]-~~~~~~~~~~~~~~~~~~~~~~~-A (RecStmt stmts) types as if you had written--  (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->-                                 do { stmts-                                    ; return (v1,..vn, r1, ..., rm) })--where v1..vn are the later_ids-      r1..rm are the rec_ids--Note [Monad Comprehensions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Monad comprehensions require separate functions like 'return' and-'>>=' for desugaring. These functions are stored in the statements-used in monad comprehensions. For example, the 'return' of the 'LastStmt'-expression is used to lift the body of the monad comprehension:--  [ body | stmts ]-   =>-  stmts >>= \bndrs -> return body--In transform and grouping statements ('then ..' and 'then group ..') the-'return' function is required for nested monad comprehensions, for example:--  [ body | stmts, then f, rest ]-   =>-  f [ env | stmts ] >>= \bndrs -> [ body | rest ]--BodyStmts require the 'Control.Monad.guard' function for boolean-expressions:--  [ body | exp, stmts ]-   =>-  guard exp >> [ body | stmts ]--Parallel statements require the 'Control.Monad.Zip.mzip' function:--  [ body | stmts1 | stmts2 | .. ]-   =>-  mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body--In any other context than 'MonadComp', the fields for most of these-'SyntaxExpr's stay bottom.---Note [Applicative BodyStmt]--(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt-as if it was a BindStmt with a wildcard pattern.  For example,--  do-    x <- A-    B-    return x--is transformed as if it were--  do-    x <- A-    _ <- B-    return x--so it transforms to--  (\(x,_) -> x) <$> A <*> B--But we have to remember when we treat a BodyStmt like a BindStmt,-because in error messages we want to emit the original syntax the user-wrote, not our internal representation.  So ApplicativeArgOne has a-Bool flag that is True when the original statement was a BodyStmt, so-that we can pretty-print it correctly.--}--instance (Outputable (StmtLR idL idL (LHsExpr idL)),-          Outputable (XXParStmtBlock idL idR))-        => Outputable (ParStmtBlock idL idR) where-  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts-  ppr (XParStmtBlock x)          = ppr x--instance (OutputableBndrId pl, OutputableBndrId pr,-          Outputable body)-         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where-    ppr stmt = pprStmt stmt--pprStmt :: forall idL idR body . (OutputableBndrId idL,-                                  OutputableBndrId idR,-                                  Outputable body)-        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc-pprStmt (LastStmt _ expr m_dollar_stripped _)-  = whenPprDebug (text "[last]") <+>-      (case m_dollar_stripped of-        Just True -> text "return $"-        Just False -> text "return"-        Nothing -> empty) <+>-      ppr expr-pprStmt (BindStmt _ pat expr) = hsep [ppr pat, larrow, ppr expr]-pprStmt (LetStmt _ (L _ binds))   = hsep [text "let", pprBinds binds]-pprStmt (BodyStmt _ expr _ _)     = ppr expr-pprStmt (ParStmt _ stmtss _ _)   = sep (punctuate (text " | ") (map ppr stmtss))--pprStmt (TransStmt { trS_stmts = stmts, trS_by = by-                   , trS_using = using, trS_form = form })-  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])--pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids-                 , recS_later_ids = later_ids })-  = text "rec" <+>-    vcat [ ppr_do_stmts segment-         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids-                            , text "later_ids=" <> ppr later_ids])]--pprStmt (ApplicativeStmt _ args mb_join)-  = getPprStyle $ \style ->-      if userStyle style-         then pp_for_user-         else pp_debug-  where-  -- make all the Applicative stuff invisible in error messages by-  -- flattening the whole ApplicativeStmt nest back to a sequence-  -- of statements.-   pp_for_user = vcat $ concatMap flattenArg args--   -- ppr directly rather than transforming here, because we need to-   -- inject a "return" which is hard when we're polymorphic in the id-   -- type.-   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]-   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args-   flattenStmt stmt = [ppr stmt]--   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]-   flattenArg (_, ApplicativeArgOne _ pat expr isBody)-     | isBody =  -- See Note [Applicative BodyStmt]-     [ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr-             :: ExprStmt (GhcPass idL))]-     | otherwise =-     [ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))]-   flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =-     concatMap flattenStmt stmts--   pp_debug =-     let-         ap_expr = sep (punctuate (text " |") (map pp_arg args))-     in-       whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>-       (if lengthAtLeast args 2 then parens else id) ap_expr--   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc-   pp_arg (_, applicativeArg) = ppr applicativeArg---instance (OutputableBndrId idL)-      => Outputable (ApplicativeArg (GhcPass idL)) where-  ppr = pprArg--pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc-pprArg (ApplicativeArgOne _ pat expr isBody)-  | isBody =  -- See Note [Applicative BodyStmt]-    ppr (BodyStmt (panic "pprStmt") expr noSyntaxExpr noSyntaxExpr-            :: ExprStmt (GhcPass idL))-  | otherwise =-    ppr (BindStmt (panic "pprStmt") pat expr :: ExprStmt (GhcPass idL))-pprArg (ApplicativeArgMany _ stmts return pat ctxt) =-     ppr pat <+>-     text "<-" <+>-     ppr (HsDo (panic "pprStmt") ctxt (noLoc-               (stmts ++-                   [noLoc (LastStmt noExtField (noLoc return) Nothing noSyntaxExpr)])))--pprTransformStmt :: (OutputableBndrId p)-                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)-                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc-pprTransformStmt bndrs using by-  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))-        , nest 2 (ppr using)-        , nest 2 (pprBy by)]--pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc-pprTransStmt by using ThenForm-  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]-pprTransStmt by using GroupForm-  = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]--pprBy :: Outputable body => Maybe body -> SDoc-pprBy Nothing  = empty-pprBy (Just e) = text "by" <+> ppr e--pprDo :: (OutputableBndrId p, Outputable body)-      => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc-pprDo (DoExpr m)    stmts =-  ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts-pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts-pprDo ArrowExpr     stmts = text "do"  <+> ppr_do_stmts stmts-pprDo (MDoExpr m)   stmts =-  ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts-pprDo ListComp      stmts = brackets    $ pprComp stmts-pprDo MonadComp     stmts = brackets    $ pprComp stmts-pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt--ppr_module_name_prefix :: Maybe ModuleName -> SDoc-ppr_module_name_prefix = \case-  Nothing -> empty-  Just module_name -> ppr module_name <> char '.'--ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,-                 Outputable body)-             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc--- Print a bunch of do stmts-ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)--pprComp :: (OutputableBndrId p, Outputable body)-        => [LStmt (GhcPass p) body] -> SDoc-pprComp quals     -- Prints:  body | qual1, ..., qualn-  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals-  = if null initStmts-       -- If there are no statements in a list comprehension besides the last-       -- one, we simply treat it like a normal list. This does arise-       -- occasionally in code that GHC generates, e.g., in implementations of-       -- 'range' for derived 'Ix' instances for product datatypes with exactly-       -- one constructor (e.g., see #12583).-       then ppr body-       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)-  | otherwise-  = pprPanic "pprComp" (pprQuals quals)--pprQuals :: (OutputableBndrId p, Outputable body)-         => [LStmt (GhcPass p) body] -> SDoc--- Show list comprehension qualifiers separated by commas-pprQuals quals = interpp'SP quals--{--************************************************************************-*                                                                      *-                Template Haskell quotation brackets-*                                                                      *-************************************************************************--}---- | Haskell Splice-data HsSplice id-   = HsTypedSplice       --  $$z  or $$(f 4)-        (XTypedSplice id)-        SpliceDecoration -- Whether $$( ) variant found, for pretty printing-        (IdP id)         -- A unique name to identify this splice point-        (LHsExpr id)     -- See Note [Pending Splices]--   | HsUntypedSplice     --  $z  or $(f 4)-        (XUntypedSplice id)-        SpliceDecoration -- Whether $( ) variant found, for pretty printing-        (IdP id)         -- A unique name to identify this splice point-        (LHsExpr id)     -- See Note [Pending Splices]--   | HsQuasiQuote        -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice-        (XQuasiQuote id)-        (IdP id)         -- Splice point-        (IdP id)         -- Quoter-        SrcSpan          -- The span of the enclosed string-        FastString       -- The enclosed string--   -- AZ:TODO: use XSplice instead of HsSpliced-   | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in-                -- GHC.Rename.Splice.-                -- This is the result of splicing a splice. It is produced by-                -- the renamer and consumed by the typechecker. It lives only-                -- between the two.-        (XSpliced id)-        ThModFinalizers     -- TH finalizers produced by the splice.-        (HsSplicedThing id) -- The result of splicing-   | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point--newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data)--type instance XTypedSplice   (GhcPass _) = NoExtField-type instance XUntypedSplice (GhcPass _) = NoExtField-type instance XQuasiQuote    (GhcPass _) = NoExtField-type instance XSpliced       (GhcPass _) = NoExtField-type instance XXSplice       GhcPs       = NoExtCon-type instance XXSplice       GhcRn       = NoExtCon-type instance XXSplice       GhcTc       = HsSplicedT---- | A splice can appear with various decorations wrapped around it. This data--- type captures explicitly how it was originally written, for use in the pretty--- printer.-data SpliceDecoration-  = DollarSplice  -- ^ $splice or $$splice-  | BareSplice    -- ^ bare splice-  deriving (Data, Eq, Show)--instance Outputable SpliceDecoration where-  ppr x = text $ show x---isTypedSplice :: HsSplice id -> Bool-isTypedSplice (HsTypedSplice {}) = True-isTypedSplice _                  = False   -- Quasi-quotes are untyped splices---- | Finalizers produced by a splice with--- 'Language.Haskell.TH.Syntax.addModFinalizer'------ See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how--- this is used.----newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]---- A Data instance which ignores the argument of 'ThModFinalizers'.-instance Data ThModFinalizers where-  gunfold _ z _ = z $ ThModFinalizers []-  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix-  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]---- See Note [Running typed splices in the zonker]--- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice`-data DelayedSplice =-  DelayedSplice-    TcLclEnv          -- The local environment to run the splice in-    (LHsExpr GhcRn)   -- The original renamed expression-    TcType            -- The result type of running the splice, unzonked-    (LHsExpr GhcTc)   -- The typechecked expression to run and splice in the result---- A Data instance which ignores the argument of 'DelayedSplice'.-instance Data DelayedSplice where-  gunfold _ _ _ = panic "DelayedSplice"-  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix-  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]---- | Haskell Spliced Thing------ Values that can result from running a splice.-data HsSplicedThing id-    = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression-    | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type-    | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern----- See Note [Pending Splices]-type SplicePointName = Name---- | Pending Renamer Splice-data PendingRnSplice-  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)--data UntypedSpliceFlavour-  = UntypedExpSplice-  | UntypedPatSplice-  | UntypedTypeSplice-  | UntypedDeclSplice-  deriving Data---- | Pending Type-checker Splice-data PendingTcSplice-  = PendingTcSplice SplicePointName (LHsExpr GhcTc)--{--Note [Pending Splices]-~~~~~~~~~~~~~~~~~~~~~~-When we rename an untyped bracket, we name and lift out all the nested-splices, so that when the typechecker hits the bracket, it can-typecheck those nested splices without having to walk over the untyped-bracket code.  So for example-    [| f $(g x) |]-looks like--    HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))--which the renamer rewrites to--    HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))-                   [PendingRnSplice UntypedExpSplice sn (g x)]--* The 'sn' is the Name of the splice point, the SplicePointName--* The PendingRnExpSplice gives the splice that splice-point name maps to;-  and the typechecker can now conveniently find these sub-expressions--* The other copy of the splice, in the second argument of HsSpliceE-                                in the renamed first arg of HsRnBracketOut-  is used only for pretty printing--There are four varieties of pending splices generated by the renamer,-distinguished by their UntypedSpliceFlavour-- * Pending expression splices (UntypedExpSplice), e.g.,-       [|$(f x) + 2|]--   UntypedExpSplice is also used for-     * quasi-quotes, where the pending expression expands to-          $(quoter "...blah...")-       (see GHC.Rename.Splice.makePending, HsQuasiQuote case)--     * cross-stage lifting, where the pending expression expands to-          $(lift x)-       (see GHC.Rename.Splice.checkCrossStageLifting)-- * Pending pattern splices (UntypedPatSplice), e.g.,-       [| \$(f x) -> x |]-- * Pending type splices (UntypedTypeSplice), e.g.,-       [| f :: $(g x) |]-- * Pending declaration (UntypedDeclSplice), e.g.,-       [| let $(f x) in ... |]--There is a fifth variety of pending splice, which is generated by the type-checker:--  * Pending *typed* expression splices, (PendingTcSplice), e.g.,-        [||1 + $$(f 2)||]--It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the-output of the renamer. However, when pretty printing the output of the renamer,-e.g., in a type error message, we *do not* want to print out the pending-splices. In contrast, when pretty printing the output of the type checker, we-*do* want to print the pending splices. So splitting them up seems to make-sense, although I hate to add another constructor to HsExpr.--}--instance OutputableBndrId p-       => Outputable (HsSplicedThing (GhcPass p)) where-  ppr (HsSplicedExpr e) = ppr_expr e-  ppr (HsSplicedTy   t) = ppr t-  ppr (HsSplicedPat  p) = ppr p--instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where-  ppr s = pprSplice s--pprPendingSplice :: (OutputableBndrId p)-                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))--pprSpliceDecl ::  (OutputableBndrId p)-          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc-pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e-pprSpliceDecl e ExplicitSplice   = text "$" <> ppr_splice_decl e-pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e--ppr_splice_decl :: (OutputableBndrId p)-                => HsSplice (GhcPass p) -> SDoc-ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty-ppr_splice_decl e = pprSplice e--pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc-pprSplice (HsTypedSplice _ DollarSplice n e)-  = ppr_splice (text "$$") n e empty-pprSplice (HsTypedSplice _ BareSplice _ _ )-  = panic "Bare typed splice"  -- impossible-pprSplice (HsUntypedSplice _ DollarSplice n e)-  = ppr_splice (text "$")  n e empty-pprSplice (HsUntypedSplice _ BareSplice n e)-  = ppr_splice empty  n e empty-pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s-pprSplice (HsSpliced _ _ thing)         = ppr thing-pprSplice (XSplice x)                   = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-                                            GhcPs -> noExtCon x-                                            GhcRn -> noExtCon x-#endif-                                            GhcTc -> case x of-                                                       HsSplicedT _ -> text "Unevaluated typed splice"--ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc-ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>-                           char '[' <> ppr quoter <> vbar <>-                           ppr quote <> text "|]"--ppr_splice :: (OutputableBndrId p)-           => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc-ppr_splice herald n e trail-    = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail---- | Haskell Bracket-data HsBracket p-  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]-  | PatBr  (XPatBr p)   (LPat p)      -- [p| pat   |]-  | DecBrL (XDecBrL p)  [LHsDecl p]   -- [d| decls |]; result of parser-  | DecBrG (XDecBrG p)  (HsGroup p)   -- [d| decls |]; result of renamer-  | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]-  | VarBr  (XVarBr p)   Bool (IdP p)  -- True: 'x, False: ''T-                                -- (The Bool flag is used only in pprHsBracket)-  | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]-  | XBracket !(XXBracket p)           -- Note [Trees that Grow] extension point--type instance XExpBr      (GhcPass _) = NoExtField-type instance XPatBr      (GhcPass _) = NoExtField-type instance XDecBrL     (GhcPass _) = NoExtField-type instance XDecBrG     (GhcPass _) = NoExtField-type instance XTypBr      (GhcPass _) = NoExtField-type instance XVarBr      (GhcPass _) = NoExtField-type instance XTExpBr     (GhcPass _) = NoExtField-type instance XXBracket   (GhcPass _) = NoExtCon--isTypedBracket :: HsBracket id -> Bool-isTypedBracket (TExpBr {}) = True-isTypedBracket _           = False--instance OutputableBndrId p-          => Outputable (HsBracket (GhcPass p)) where-  ppr = pprHsBracket---pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc-pprHsBracket (ExpBr _ e)   = thBrackets empty (ppr e)-pprHsBracket (PatBr _ p)   = thBrackets (char 'p') (ppr p)-pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)-pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))-pprHsBracket (TypBr _ t)   = thBrackets (char 't') (ppr t)-pprHsBracket (VarBr _ True n)-  = char '\'' <> pprPrefixOcc n-pprHsBracket (VarBr _ False n)-  = text "''" <> pprPrefixOcc n-pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)--thBrackets :: SDoc -> SDoc -> SDoc-thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>-                             pp_body <+> text "|]"--thTyBrackets :: SDoc -> SDoc-thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]")--instance Outputable PendingRnSplice where-  ppr (PendingRnSplice _ n e) = pprPendingSplice n e--instance Outputable PendingTcSplice where-  ppr (PendingTcSplice n e) = pprPendingSplice n e--{--************************************************************************-*                                                                      *-\subsection{Enumerations and list comprehensions}-*                                                                      *-************************************************************************--}---- | Arithmetic Sequence Information-data ArithSeqInfo id-  = From            (LHsExpr id)-  | FromThen        (LHsExpr id)-                    (LHsExpr id)-  | FromTo          (LHsExpr id)-                    (LHsExpr id)-  | FromThenTo      (LHsExpr id)-                    (LHsExpr id)-                    (LHsExpr id)--- AZ: Should ArithSeqInfo have a TTG extension?--instance OutputableBndrId p-         => Outputable (ArithSeqInfo (GhcPass p)) where-    ppr (From e1)             = hcat [ppr e1, pp_dotdot]-    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]-    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]-    ppr (FromThenTo e1 e2 e3)-      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]--pp_dotdot :: SDoc-pp_dotdot = text " .. "--{--************************************************************************-*                                                                      *-\subsection{HsMatchCtxt}-*                                                                      *-************************************************************************--}---- | Haskell Match Context------ Context of a pattern match. This is more subtle than it would seem. See Note--- [Varieties of pattern matches].-data HsMatchContext p-  = FunRhs { mc_fun        :: LIdP p    -- ^ function binder of @f@-           , mc_fixity     :: LexicalFixity -- ^ fixing of @f@-           , mc_strictness :: SrcStrictness -- ^ was @f@ banged?-                                            -- See Note [FunBind vs PatBind]-           }-                                -- ^A pattern matching on an argument of a-                                -- function binding-  | LambdaExpr                  -- ^Patterns of a lambda-  | CaseAlt                     -- ^Patterns and guards on a case alternative-  | IfAlt                       -- ^Guards of a multi-way if alternative-  | ProcExpr                    -- ^Patterns of a proc-  | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e-  | PatBindGuards               -- ^Guards of pattern bindings, e.g.,-                                --    (Just b) | Just _ <- x = e-                                --             | otherwise   = e'--  | RecUpd                      -- ^Record update [used only in GHC.HsToCore.Expr to-                                --    tell matchWrapper what sort of-                                --    runtime error message to generate]--  | StmtCtxt (HsStmtContext p)  -- ^Pattern of a do-stmt, list comprehension,-                                -- pattern guard, etc--  | ThPatSplice            -- ^A Template Haskell pattern splice-  | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]-  | PatSyn                 -- ^A pattern synonym declaration--instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where-  ppr m@(FunRhs{})          = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)-  ppr LambdaExpr            = text "LambdaExpr"-  ppr CaseAlt               = text "CaseAlt"-  ppr IfAlt                 = text "IfAlt"-  ppr ProcExpr              = text "ProcExpr"-  ppr PatBindRhs            = text "PatBindRhs"-  ppr PatBindGuards         = text "PatBindGuards"-  ppr RecUpd                = text "RecUpd"-  ppr (StmtCtxt _)          = text "StmtCtxt _"-  ppr ThPatSplice           = text "ThPatSplice"-  ppr ThPatQuote            = text "ThPatQuote"-  ppr PatSyn                = text "PatSyn"--isPatSynCtxt :: HsMatchContext p -> Bool-isPatSynCtxt ctxt =-  case ctxt of-    PatSyn -> True-    _      -> False---- | Haskell Statement Context.-data HsStmtContext p-  = ListComp-  | MonadComp--  | DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }-  | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression-  | ArrowExpr                        -- ^do-notation in an arrow-command context--  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs-  | PatGuard (HsMatchContext p)      -- ^Pattern guard for specified thing-  | ParStmtCtxt (HsStmtContext p)    -- ^A branch of a parallel stmt-  | TransStmtCtxt (HsStmtContext p)  -- ^A branch of a transform stmt--qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName-qualifiedDoModuleName_maybe ctxt = case ctxt of-  DoExpr m -> m-  MDoExpr m -> m-  _ -> Nothing--isComprehensionContext :: HsStmtContext id -> Bool--- Uses comprehension syntax [ e | quals ]-isComprehensionContext ListComp          = True-isComprehensionContext MonadComp         = True-isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c-isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c-isComprehensionContext _ = False---- | Is this a monadic context?-isMonadStmtContext :: HsStmtContext id -> Bool-isMonadStmtContext MonadComp            = True-isMonadStmtContext DoExpr{}             = True-isMonadStmtContext MDoExpr{}            = True-isMonadStmtContext GhciStmtCtxt         = True-isMonadStmtContext (ParStmtCtxt ctxt)   = isMonadStmtContext ctxt-isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt-isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr--isMonadCompContext :: HsStmtContext id -> Bool-isMonadCompContext MonadComp = True-isMonadCompContext _         = False--matchSeparator :: HsMatchContext p -> SDoc-matchSeparator (FunRhs {})   = text "="-matchSeparator CaseAlt       = text "->"-matchSeparator IfAlt         = text "->"-matchSeparator LambdaExpr    = text "->"-matchSeparator ProcExpr      = text "->"-matchSeparator PatBindRhs    = text "="-matchSeparator PatBindGuards = text "="-matchSeparator (StmtCtxt _)  = text "<-"-matchSeparator RecUpd        = text "=" -- This can be printed by the pattern-                                       -- match checker trace-matchSeparator ThPatSplice  = panic "unused"-matchSeparator ThPatQuote   = panic "unused"-matchSeparator PatSyn       = panic "unused"--pprMatchContext :: Outputable (IdP p)-                => HsMatchContext p -> SDoc-pprMatchContext ctxt-  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt-  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt-  where-    want_an (FunRhs {}) = True  -- Use "an" in front-    want_an ProcExpr    = True-    want_an _           = False--pprMatchContextNoun :: Outputable (IdP id)-                    => HsMatchContext id -> SDoc-pprMatchContextNoun (FunRhs {mc_fun=L _ fun})-                                    = text "equation for"-                                      <+> quotes (ppr fun)-pprMatchContextNoun CaseAlt         = text "case alternative"-pprMatchContextNoun IfAlt           = text "multi-way if alternative"-pprMatchContextNoun RecUpd          = text "record-update construct"-pprMatchContextNoun ThPatSplice     = text "Template Haskell pattern splice"-pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"-pprMatchContextNoun PatBindRhs      = text "pattern binding"-pprMatchContextNoun PatBindGuards   = text "pattern binding guards"-pprMatchContextNoun LambdaExpr      = text "lambda abstraction"-pprMatchContextNoun ProcExpr        = text "arrow abstraction"-pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"-                                      $$ pprAStmtContext ctxt-pprMatchContextNoun PatSyn          = text "pattern synonym declaration"--------------------pprAStmtContext, pprStmtContext :: Outputable (IdP id)-                                => HsStmtContext id -> SDoc-pprAStmtContext ctxt = article <+> pprStmtContext ctxt-  where-    pp_an = text "an"-    pp_a  = text "a"-    article = case ctxt of-                  MDoExpr Nothing -> pp_an-                  GhciStmtCtxt  -> pp_an-                  _             -> pp_a---------------------pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"-pprStmtContext (DoExpr m)      = prependQualified m (text "'do' block")-pprStmtContext (MDoExpr m)     = prependQualified m (text "'mdo' block")-pprStmtContext ArrowExpr       = text "'do' block in an arrow command"-pprStmtContext ListComp        = text "list comprehension"-pprStmtContext MonadComp       = text "monad comprehension"-pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt---- Drop the inner contexts when reporting errors, else we get---     Unexpected transform statement---     in a transformed branch of---          transformed branch of---          transformed branch of monad comprehension-pprStmtContext (ParStmtCtxt c) =-  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])-             (pprStmtContext c)-pprStmtContext (TransStmtCtxt c) =-  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])-             (pprStmtContext c)--prependQualified :: Maybe ModuleName -> SDoc -> SDoc-prependQualified Nothing  t = t-prependQualified (Just _) t = text "qualified" <+> t--instance OutputableBndrId p-      => Outputable (HsStmtContext (GhcPass p)) where-    ppr = pprStmtContext---- Used to generate the string for a *runtime* error message-matchContextErrString :: OutputableBndrId p-                      => HsMatchContext (GhcPass p) -> SDoc-matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun-matchContextErrString CaseAlt                    = text "case"-matchContextErrString IfAlt                      = text "multi-way if"-matchContextErrString PatBindRhs                 = text "pattern binding"-matchContextErrString PatBindGuards              = text "pattern binding guards"-matchContextErrString RecUpd                     = text "record update"-matchContextErrString LambdaExpr                 = text "lambda"-matchContextErrString ProcExpr                   = text "proc"-matchContextErrString ThPatSplice                = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString PatSyn                     = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"-matchContextErrString (StmtCtxt GhciStmtCtxt)      = text "interactive GHCi command"-matchContextErrString (StmtCtxt (DoExpr m))        = prependQualified m (text "'do' block")-matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"-matchContextErrString (StmtCtxt (MDoExpr m))       = prependQualified m (text "'mdo' block")-matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"-matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"--pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)-               => Match (GhcPass idR) body -> SDoc-pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)-                                        <> colon)-                             4 (pprMatch match)--pprStmtInCtxt :: (OutputableBndrId idL,-                  OutputableBndrId idR,-                  Outputable body)-              => HsStmtContext (GhcPass idL)-              -> StmtLR (GhcPass idL) (GhcPass idR) body-              -> SDoc-pprStmtInCtxt ctxt (LastStmt _ e _ _)-  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"-  = hang (text "In the expression:") 2 (ppr e)--pprStmtInCtxt ctxt stmt-  = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)-       2 (ppr_stmt stmt)-  where-    -- For Group and Transform Stmts, don't print the nested stmts!-    ppr_stmt (TransStmt { trS_by = by, trS_using = using-                        , trS_form = form }) = pprTransStmt by using form-    ppr_stmt stmt = pprStmt stmt+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | Abstract Haskell syntax for expressions.+module GHC.Hs.Expr+  ( module Language.Haskell.Syntax.Expr+  , module GHC.Hs.Expr+  ) where++#include "HsVersions.h"++import Language.Haskell.Syntax.Expr++-- friends:+import GHC.Prelude++import GHC.Hs.Decls+import GHC.Hs.Pat+import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Hs.Type+import GHC.Hs.Binds+import GHC.Parser.Annotation++-- others:+import GHC.Tc.Types.Evidence+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import GHC.Core.ConLike+import GHC.Unit.Module (ModuleName)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Core.Type+import GHC.Builtin.Types (mkTupleStr)+import GHC.Tc.Utils.TcType (TcType)+import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)++-- libraries:+import Data.Data hiding (Fixity(..))+import qualified Data.Data as Data (Fixity(..))+import qualified Data.Kind+import Data.Maybe (isJust)+import Data.Void  ( Void )+import Data.Foldable ( toList )++{- *********************************************************************+*                                                                      *+                Expressions proper+*                                                                      *+********************************************************************* -}++-- | Post-Type checking Expression+--+-- PostTcExpr is an evidence expression attached to the syntax tree by the+-- type checker (c.f. postTcType).+type PostTcExpr  = HsExpr GhcTc++-- | Post-Type checking Table+--+-- We use a PostTcTable where there are a bunch of pieces of evidence, more+-- than is convenient to keep individually.+type PostTcTable = [(Name, PostTcExpr)]++-------------------------++-- Defining SyntaxExpr in two stages allows for better type inference, because+-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,+-- noSyntaxExpr would be ambiguous.+type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p++type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where+  SyntaxExprGhc 'Parsed      = NoExtField+  SyntaxExprGhc 'Renamed     = SyntaxExprRn+  SyntaxExprGhc 'Typechecked = SyntaxExprTc++-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].+data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)+    -- Why is the payload not just a Name?+    -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+                  | NoSyntaxExprRn++-- | An expression with wrappers, used for rebindable syntax+--+-- This should desugar to+--+-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)+-- >                         (syn_arg_wraps[1] arg1) ...+--+-- where the actual arguments come from elsewhere in the AST.+data SyntaxExprTc = SyntaxExprTc { syn_expr      :: HsExpr GhcTc+                                 , syn_arg_wraps :: [HsWrapper]+                                 , syn_res_wrap  :: HsWrapper }+                  | NoSyntaxExprTc  -- See Note [NoSyntaxExpr]++-- | This is used for rebindable-syntax pieces that are too polymorphic+-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)+noExpr :: HsExpr (GhcPass p)+noExpr = HsLit noComments (HsString (SourceText  "noExpr") (fsLit "noExpr"))++noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)+                              -- Before renaming, and sometimes after+                              -- See Note [NoSyntaxExpr]+noSyntaxExpr = case ghcPass @p of+  GhcPs -> noExtField+  GhcRn -> NoSyntaxExprRn+  GhcTc -> NoSyntaxExprTc++-- | Make a 'SyntaxExpr GhcRn' from an expression+-- Used only in getMonadFailOp.+-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn+mkSyntaxExpr = SyntaxExprRn++-- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the+-- renamer).+mkRnSyntaxExpr :: Name -> SyntaxExprRn+mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name++instance Outputable SyntaxExprRn where+  ppr (SyntaxExprRn expr) = ppr expr+  ppr NoSyntaxExprRn      = text "<no syntax expr>"++instance Outputable SyntaxExprTc where+  ppr (SyntaxExprTc { syn_expr      = expr+                    , syn_arg_wraps = arg_wraps+                    , syn_res_wrap  = res_wrap })+    = sdocOption sdocPrintExplicitCoercions $ \print_co ->+      getPprDebug $ \debug ->+      if debug || print_co+      then ppr expr <> braces (pprWithCommas ppr arg_wraps)+                    <> braces (ppr res_wrap)+      else ppr expr++  ppr NoSyntaxExprTc = text "<no syntax expr>"++-- | Extra data fields for a 'RecordUpd', added by the type checker+data RecordUpdTc = RecordUpdTc+      { rupd_cons :: [ConLike]+                -- Filled in by the type checker to the+                -- _non-empty_ list of DataCons that have+                -- all the upd'd fields++      , rupd_in_tys  :: [Type]  -- Argument types of *input* record type+      , rupd_out_tys :: [Type]  --             and  *output* record type+                -- For a data family, these are the type args of the+                -- /representation/ type constructor++      , rupd_wrap :: HsWrapper  -- See note [Record Update HsWrapper]+      }++-- | HsWrap appears only in typechecker output+-- Invariant: The contained Expr is *NOT* itself an HsWrap.+-- See Note [Detecting forced eta expansion] in "GHC.HsToCore.Expr".+-- This invariant is maintained by 'GHC.Hs.Utils.mkHsWrap'.+-- hs_syn is something like HsExpr or HsCmd+data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper+                            (hs_syn GhcTc) -- the thing that is wrapped++deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)++type instance HsDoRn (GhcPass _) = GhcRn+type instance HsBracketRn (GhcPass _) = GhcRn+type instance PendingRnSplice' (GhcPass _) = PendingRnSplice+type instance PendingTcSplice' (GhcPass _) = PendingTcSplice++-- ---------------------------------------------------------------------++{- Note [Constructor cannot occur]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some data constructors can't occur in certain phases; e.g. the output+of the type checker never has OverLabel. We signal this by setting+the extension field to Void. For example:+   type instance XOverLabel GhcTc = Void+   dsExpr (HsOverLabel x _) = absurd x++It would be better to omit the pattern match altogether, but we+could only do that if the extension field was strict (#18764)+-}++-- API Annotations types++data EpAnnHsCase = EpAnnHsCase+      { hsCaseAnnCase :: EpaLocation+      , hsCaseAnnOf   :: EpaLocation+      , hsCaseAnnsRest :: [AddEpAnn]+      } deriving Data++data EpAnnUnboundVar = EpAnnUnboundVar+     { hsUnboundBackquotes :: (EpaLocation, EpaLocation)+     , hsUnboundHole       :: EpaLocation+     } deriving Data++type instance XVar           (GhcPass _) = NoExtField+type instance XConLikeOut    (GhcPass _) = NoExtField+type instance XRecFld        (GhcPass _) = NoExtField+type instance XLam           (GhcPass _) = NoExtField++-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOverLabel     GhcPs = EpAnnCO+type instance XOverLabel     GhcRn = EpAnnCO+type instance XOverLabel     GhcTc = Void  -- See Note [Constructor cannot occur]++-- ---------------------------------------------------------------------++type instance XVar           (GhcPass _) = NoExtField++type instance XUnboundVar    GhcPs = EpAnn EpAnnUnboundVar+type instance XUnboundVar    GhcRn = NoExtField+type instance XUnboundVar    GhcTc = HoleExprRef+  -- We really don't need the whole HoleExprRef; just the IORef EvTerm+  -- would be enough. But then deriving a Data instance becomes impossible.+  -- Much, much easier just to define HoleExprRef with a Data instance and+  -- store the whole structure.++type instance XConLikeOut    (GhcPass _) = NoExtField+type instance XRecFld        (GhcPass _) = NoExtField+type instance XIPVar         (GhcPass _) = EpAnnCO+type instance XOverLitE      (GhcPass _) = EpAnnCO+type instance XLitE          (GhcPass _) = EpAnnCO++type instance XLam           (GhcPass _) = NoExtField++type instance XLamCase       (GhcPass _) = EpAnn [AddEpAnn]+type instance XApp           (GhcPass _) = EpAnnCO++type instance XAppTypeE      GhcPs = SrcSpan -- Where the `@` lives+type instance XAppTypeE      GhcRn = NoExtField+type instance XAppTypeE      GhcTc = Type++-- OpApp not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOpApp         GhcPs = EpAnn [AddEpAnn]+type instance XOpApp         GhcRn = Fixity+type instance XOpApp         GhcTc = Void  -- See Note [Constructor cannot occur]++-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XSectionL      GhcPs = EpAnnCO+type instance XSectionR      GhcPs = EpAnnCO+type instance XSectionL      GhcRn = EpAnnCO+type instance XSectionR      GhcRn = EpAnnCO+type instance XSectionL      GhcTc = Void  -- See Note [Constructor cannot occur]+type instance XSectionR      GhcTc = Void  -- See Note [Constructor cannot occur]+++type instance XNegApp        GhcPs = EpAnn [AddEpAnn]+type instance XNegApp        GhcRn = NoExtField+type instance XNegApp        GhcTc = NoExtField++type instance XPar           (GhcPass _) = EpAnn AnnParen++type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn]+type instance XExplicitTuple GhcRn = NoExtField+type instance XExplicitTuple GhcTc = NoExtField++type instance XExplicitSum   GhcPs = EpAnn AnnExplicitSum+type instance XExplicitSum   GhcRn = NoExtField+type instance XExplicitSum   GhcTc = [Type]++type instance XCase          GhcPs = EpAnn EpAnnHsCase+type instance XCase          GhcRn = NoExtField+type instance XCase          GhcTc = NoExtField++type instance XIf            GhcPs = EpAnn AnnsIf+type instance XIf            GhcRn = NoExtField+type instance XIf            GhcTc = NoExtField++type instance XMultiIf       GhcPs = EpAnn [AddEpAnn]+type instance XMultiIf       GhcRn = NoExtField+type instance XMultiIf       GhcTc = Type++type instance XLet           GhcPs = EpAnn AnnsLet+type instance XLet           GhcRn = NoExtField+type instance XLet           GhcTc = NoExtField++type instance XDo            GhcPs = EpAnn AnnList+type instance XDo            GhcRn = NoExtField+type instance XDo            GhcTc = Type++type instance XExplicitList  GhcPs = EpAnn AnnList+type instance XExplicitList  GhcRn = NoExtField+type instance XExplicitList  GhcTc = Type+-- GhcPs: ExplicitList includes all source-level+--   list literals, including overloaded ones+-- GhcRn and GhcTc: ExplicitList used only for list literals+--   that denote Haskell's built-in lists.  Overloaded lists+--   have been expanded away in the renamer+-- See Note [Handling overloaded and rebindable constructs]+-- in  GHC.Rename.Expr++type instance XRecordCon     GhcPs = EpAnn [AddEpAnn]+type instance XRecordCon     GhcRn = NoExtField+type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function++type instance XRecordUpd     GhcPs = EpAnn [AddEpAnn]+type instance XRecordUpd     GhcRn = NoExtField+type instance XRecordUpd     GhcTc = RecordUpdTc++type instance XGetField     GhcPs = EpAnnCO+type instance XGetField     GhcRn = NoExtField+type instance XGetField     GhcTc = Void+-- HsGetField is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XProjection     GhcPs = EpAnn AnnProjection+type instance XProjection     GhcRn = NoExtField+type instance XProjection     GhcTc = Void+-- HsProjection is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn]+type instance XExprWithTySig GhcRn = NoExtField+type instance XExprWithTySig GhcTc = NoExtField++type instance XArithSeq      GhcPs = EpAnn [AddEpAnn]+type instance XArithSeq      GhcRn = NoExtField+type instance XArithSeq      GhcTc = PostTcExpr++type instance XBracket       (GhcPass _) = EpAnn [AddEpAnn]++type instance XRnBracketOut  (GhcPass _) = NoExtField+type instance XTcBracketOut  (GhcPass _) = NoExtField++type instance XSpliceE       (GhcPass _) = EpAnnCO+type instance XProc          (GhcPass _) = EpAnn [AddEpAnn]++type instance XStatic        GhcPs = EpAnn [AddEpAnn]+type instance XStatic        GhcRn = NameSet+type instance XStatic        GhcTc = NameSet++type instance XTick          (GhcPass _) = NoExtField+type instance XBinTick       (GhcPass _) = NoExtField++type instance XPragE         (GhcPass _) = NoExtField++type instance XXExpr         GhcPs       = NoExtCon++-- See Note [Rebindable syntax and HsExpansion] below+type instance XXExpr         GhcRn       = HsExpansion (HsExpr GhcRn)+                                                       (HsExpr GhcRn)+type instance XXExpr         GhcTc       = XXExprGhcTc+++type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL+type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA++data XXExprGhcTc+  = WrapExpr {-# UNPACK #-} !(HsWrap HsExpr)+  | ExpansionExpr {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))++data AnnExplicitSum+  = AnnExplicitSum {+      aesOpen       :: EpaLocation,+      aesBarsBefore :: [EpaLocation],+      aesBarsAfter  :: [EpaLocation],+      aesClose      :: EpaLocation+      } deriving Data++data AnnsLet+  = AnnsLet {+      alLet :: EpaLocation,+      alIn :: EpaLocation+      } deriving Data++data AnnFieldLabel+  = AnnFieldLabel {+      afDot :: Maybe EpaLocation+      } deriving Data++data AnnProjection+  = AnnProjection {+      apOpen  :: EpaLocation, -- ^ '('+      apClose :: EpaLocation  -- ^ ')'+      } deriving Data++data AnnsIf+  = AnnsIf {+      aiIf       :: EpaLocation,+      aiThen     :: EpaLocation,+      aiElse     :: EpaLocation,+      aiThenSemi :: Maybe EpaLocation,+      aiElseSemi :: Maybe EpaLocation+      } deriving Data++-- ---------------------------------------------------------------------++type instance XSCC           (GhcPass _) = EpAnn AnnPragma+type instance XXPragE        (GhcPass _) = NoExtCon++type instance XCHsFieldLabel (GhcPass _) = EpAnn AnnFieldLabel+type instance XXHsFieldLabel (GhcPass _) = NoExtCon++type instance XPresent         (GhcPass _) = EpAnn [AddEpAnn]++type instance XMissing         GhcPs = EpAnn EpaLocation+type instance XMissing         GhcRn = NoExtField+type instance XMissing         GhcTc = Scaled Type++type instance XXTupArg         (GhcPass _) = NoExtCon++tupArgPresent :: HsTupArg (GhcPass p) -> Bool+tupArgPresent (Present {}) = True+tupArgPresent (Missing {}) = False++instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where+    ppr expr = pprExpr expr++-----------------------+-- pprExpr, pprLExpr, pprBinds call pprDeeper;+-- the underscore versions do not+pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+pprLExpr (L _ e) = pprExpr e++pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e+          | otherwise                           = pprDeeper (ppr_expr e)++isQuietHsExpr :: HsExpr id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsExpr (HsPar {})        = True+-- applications don't display anything themselves+isQuietHsExpr (HsApp {})        = True+isQuietHsExpr (HsAppType {})    = True+isQuietHsExpr (OpApp {})        = True+isQuietHsExpr _ = False++pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)+         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc+pprBinds b = pprDeeper (ppr b)++-----------------------+ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+ppr_lexpr e = ppr_expr (unLoc e)++ppr_expr :: forall p. (OutputableBndrId p)+         => HsExpr (GhcPass p) -> SDoc+ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v+ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv+ppr_expr (HsConLikeOut _ c)  = pprPrefixOcc c+ppr_expr (HsRecFld _ f)      = pprPrefixOcc f+ppr_expr (HsIPVar _ v)       = ppr v+ppr_expr (HsOverLabel _ l)   = char '#' <> ppr l+ppr_expr (HsLit _ lit)       = ppr lit+ppr_expr (HsOverLit _ lit)   = ppr lit+ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)++ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]++ppr_expr e@(HsApp {})        = ppr_apps e []+ppr_expr e@(HsAppType {})    = ppr_apps e []++ppr_expr (OpApp _ e1 op e2)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly++  where+    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens+    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear++    pp_prefixly+      = hang (ppr op) 2 (sep [pp_e1, pp_e2])++    pp_infixly pp_op+      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])++ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e++ppr_expr (SectionL _ expr op)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])+                       4 (hsep [pp_expr, text "x_ )"])++    pp_infixly v = (sep [pp_expr, v])++ppr_expr (SectionR _ op expr)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])+                       4 (pp_expr <> rparen)++    pp_infixly v = sep [v, pp_expr]++ppr_expr (ExplicitTuple _ exprs boxity)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `Solo x`, not `(x)`+  | [Present _ expr] <- exprs+  , Boxed <- boxity+  = hsep [text (mkTupleStr Boxed 1), ppr expr]+  | otherwise+  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))+  where+    ppr_tup_args []               = []+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es++    punc (Present {} : _) = comma <> space+    punc (Missing {} : _) = comma+    punc (XTupArg {} : _) = comma <> space+    punc []               = empty++ppr_expr (ExplicitSum _ alt arity expr)+  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"+  where+    ppr_bars n = hsep (replicate n (char '|'))++ppr_expr (HsLam _ matches)+  = pprMatches matches++ppr_expr (HsLamCase _ matches)+  = sep [ sep [text "\\case"],+          nest 2 (pprMatches matches) ]++ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],+          pp_alts ]+  where+    pp_alts | null alts = text "{}"+            | otherwise = nest 2 (pprMatches matches)++ppr_expr (HsIf _ e1 e2 e3)+  = sep [hsep [text "if", nest 2 (ppr e1), ptext (sLit "then")],+         nest 4 (ppr e2),+         text "else",+         nest 4 (ppr e3)]++ppr_expr (HsMultiIf _ alts)+  = hang (text "if") 3  (vcat (map ppr_alt alts))+  where ppr_alt (L _ (GRHS _ guards expr)) =+          hang vbar 2 (ppr_one one_alt)+          where+            ppr_one [] = panic "ppr_exp HsMultiIf"+            ppr_one (h:t) = hang h 2 (sep t)+            one_alt = [ interpp'SP guards+                      , text "->" <+> pprDeeper (ppr expr) ]+        ppr_alt (L _ (XGRHS x)) = ppr x++-- special case: let ... in let ...+ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _)))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),+         ppr_lexpr expr]++ppr_expr (HsLet _ binds expr)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr expr)]++ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts++ppr_expr (ExplicitList _ exprs)+  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))++ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })+  = hang pp_con 2 (ppr rbinds)+  where+    -- con :: ConLikeP (GhcPass p)+    -- so we need case analysis to know to print it+    pp_con = case ghcPass @p of+               GhcPs -> ppr con+               GhcRn -> ppr con+               GhcTc -> ppr con++ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })+  = case flds of+      Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))+      Right pbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))++ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })+  = ppr fexp <> dot <> ppr field++ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds))))++ppr_expr (ExprWithTySig _ expr sig)+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)+         4 (ppr sig)++ppr_expr (ArithSeq _ _ info) = brackets (ppr info)++ppr_expr (HsSpliceE _ s)         = pprSplice s+ppr_expr (HsBracket _ b)         = pprHsBracket b+ppr_expr (HsRnBracketOut _ e []) = ppr e+ppr_expr (HsRnBracketOut _ e ps) = ppr e $$ text "pending(rn)" <+> ppr ps+ppr_expr (HsTcBracketOut _ _wrap e []) = ppr e+ppr_expr (HsTcBracketOut _ _wrap e ps) = ppr e $$ text "pending(tc)" <+> pprIfTc @p (ppr ps)++ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))+  = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]++ppr_expr (HsStatic _ e)+  = hsep [text "static", ppr e]++ppr_expr (HsTick _ tickish exp)+  = pprTicks (ppr exp) $+    ppr tickish <+> ppr_lexpr exp+ppr_expr (HsBinTick _ tickIdTrue tickIdFalse exp)+  = pprTicks (ppr exp) $+    hcat [text "bintick<",+          ppr tickIdTrue,+          text ",",+          ppr tickIdFalse,+          text ">(",+          ppr exp, text ")"]++ppr_expr (XExpr x) = case ghcPass @p of+#if __GLASGOW_HASKELL__ < 811+  GhcPs -> ppr x+#endif+  GhcRn -> ppr x+  GhcTc -> case x of+    WrapExpr (HsWrap co_fn e) -> pprHsWrapper co_fn+      (\parens -> if parens then pprExpr e else pprExpr e)+    ExpansionExpr e -> ppr e -- e is an HsExpansion, we print the original+                             -- expression (LHsExpr GhcPs), not the+                             -- desugared one (LHsExpr GhcT).++ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc+ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)+ppr_infix_expr (HsConLikeOut _ c)   = Just (pprInfixOcc (conLikeName c))+ppr_infix_expr (HsRecFld _ f)       = Just (pprInfixOcc f)+ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)+ppr_infix_expr (XExpr x)            = case (ghcPass @p, x) of+#if __GLASGOW_HASKELL__ < 901+  (GhcPs, _)                              -> Nothing+#endif+  (GhcRn, HsExpanded a _)                 -> ppr_infix_expr a+  (GhcTc, WrapExpr (HsWrap _ e))          -> ppr_infix_expr e+  (GhcTc, ExpansionExpr (HsExpanded a _)) -> ppr_infix_expr a+ppr_infix_expr _ = Nothing++ppr_apps :: (OutputableBndrId p)+         => HsExpr (GhcPass p)+         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]+         -> SDoc+ppr_apps (HsApp _ (L _ fun) arg)        args+  = ppr_apps fun (Left arg : args)+ppr_apps (HsAppType _ (L _ fun) arg)    args+  = ppr_apps fun (Right arg : args)+ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))+  where+    pp (Left arg)                             = ppr arg+    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))+    --   = char '@' <> pprHsType arg+    pp (Right arg)+      = text "@" <> ppr arg+++pprDebugParendExpr :: (OutputableBndrId p)+                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprDebugParendExpr p expr+  = getPprDebug $ \case+      True  -> pprParendLExpr p expr+      False -> pprLExpr         expr++pprParendLExpr :: (OutputableBndrId p)+               => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprParendLExpr p (L _ e) = pprParendExpr p e++pprParendExpr :: (OutputableBndrId p)+              => PprPrec -> HsExpr (GhcPass p) -> SDoc+pprParendExpr p expr+  | hsExprNeedsParens p expr = parens (pprExpr expr)+  | otherwise                = pprExpr expr+        -- Using pprLExpr makes sure that we go 'deeper'+        -- I think that is usually (always?) right++-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs+-- parentheses under precedence @p@.+hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool+hsExprNeedsParens p = go+  where+    go (HsVar{})                      = False+    go (HsUnboundVar{})               = False+    go (HsConLikeOut{})               = False+    go (HsIPVar{})                    = False+    go (HsOverLabel{})                = False+    go (HsLit _ l)                    = hsLitNeedsParens p l+    go (HsOverLit _ ol)               = hsOverLitNeedsParens p ol+    go (HsPar{})                      = False+    go (HsApp{})                      = p >= appPrec+    go (HsAppType {})                 = p >= appPrec+    go (OpApp{})                      = p >= opPrec+    go (NegApp{})                     = p > topPrec+    go (SectionL{})                   = True+    go (SectionR{})                   = True+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go (ExplicitTuple _ [Present{}] Boxed)+                                      = p >= appPrec+    go (ExplicitTuple{})              = False+    go (ExplicitSum{})                = False+    go (HsLam{})                      = p > topPrec+    go (HsLamCase{})                  = p > topPrec+    go (HsCase{})                     = p > topPrec+    go (HsIf{})                       = p > topPrec+    go (HsMultiIf{})                  = p > topPrec+    go (HsLet{})                      = p > topPrec+    go (HsDo _ sc _)+      | isComprehensionContext sc     = False+      | otherwise                     = p > topPrec+    go (ExplicitList{})               = False+    go (RecordUpd{})                  = False+    go (ExprWithTySig{})              = p >= sigPrec+    go (ArithSeq{})                   = False+    go (HsPragE{})                    = p >= appPrec+    go (HsSpliceE{})                  = False+    go (HsBracket{})                  = False+    go (HsRnBracketOut{})             = False+    go (HsTcBracketOut{})             = False+    go (HsProc{})                     = p > topPrec+    go (HsStatic{})                   = p >= appPrec+    go (HsTick _ _ (L _ e))           = go e+    go (HsBinTick _ _ _ (L _ e))      = go e+    go (RecordCon{})                  = False+    go (HsRecFld{})                   = False+    go (HsProjection{})               = True+    go (HsGetField{})                 = False+    go (XExpr x)+      | GhcTc <- ghcPass @p+      = case x of+          WrapExpr      (HsWrap _ e)     -> go e+          ExpansionExpr (HsExpanded a _) -> hsExprNeedsParens p a+      | GhcRn <- ghcPass @p+      = case x of HsExpanded a _ -> hsExprNeedsParens p a+#if __GLASGOW_HASKELL__ <= 900+      | otherwise+      = True+#endif+++-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.+parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+parenthesizeHsExpr p le@(L loc e)+  | hsExprNeedsParens p e = L loc (HsPar noAnn le)+  | otherwise             = le++stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e+stripParensLHsExpr e = e++stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)+stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e+stripParensHsExpr e = e++isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool+-- True of a single token+isAtomicHsExpr (HsVar {})        = True+isAtomicHsExpr (HsConLikeOut {}) = True+isAtomicHsExpr (HsLit {})        = True+isAtomicHsExpr (HsOverLit {})    = True+isAtomicHsExpr (HsIPVar {})      = True+isAtomicHsExpr (HsOverLabel {})  = True+isAtomicHsExpr (HsUnboundVar {}) = True+isAtomicHsExpr (HsRecFld{})      = True+isAtomicHsExpr (XExpr x)+  | GhcTc <- ghcPass @p          = case x of+      WrapExpr      (HsWrap _ e)     -> isAtomicHsExpr e+      ExpansionExpr (HsExpanded a _) -> isAtomicHsExpr a+  | GhcRn <- ghcPass @p          = case x of+      HsExpanded a _         -> isAtomicHsExpr a+isAtomicHsExpr _                 = False++instance Outputable (HsPragE (GhcPass p)) where+  ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =+    pprWithSourceText st (text "{-# SCC")+     -- no doublequotes if stl empty, for the case where the SCC was written+     -- without quotes.+    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"+++{- *********************************************************************+*                                                                      *+             HsExpansion and rebindable syntax+*                                                                      *+********************************************************************* -}++{- Note [Rebindable syntax and HsExpansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We implement rebindable syntax (RS) support by performing a desugaring+in the renamer. We transform GhcPs expressions affected by RS into the+appropriate desugared form, but **annotated with the original expression**.++Let us consider a piece of code like:++    {-# LANGUAGE RebindableSyntax #-}+    ifThenElse :: Char -> () -> () -> ()+    ifThenElse _ _ _ = ()+    x = if 'a' then () else True++The parsed AST for the RHS of x would look something like (slightly simplified):++    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))++Upon seeing such an AST with RS on, we could transform it into a+mere function call, as per the RS rules, equivalent to the+following function application:++    ifThenElse 'a' () True++which doesn't typecheck. But GHC would report an error about+not being able to match the third argument's type (Bool) with the+expected type: (), in the expression _as desugared_, i.e in+the aforementioned function application. But the user never+wrote a function application! This would be pretty bad.++To remedy this, instead of transforming the original HsIf+node into mere applications of 'ifThenElse', we keep the+original 'if' expression around too, using the TTG+XExpr extension point to allow GHC to construct an+'HsExpansion' value that will keep track of the original+expression in its first field, and the desugared one in the+second field. The resulting renamed AST would look like:++    L locif (XExpr+      (HsExpanded+        (HsIf (L loca 'a')+              (L loctrue ())+              (L locfalse True)+        )+        (App (L generatedSrcSpan+                (App (L generatedSrcSpan+                        (App (L generatedSrcSpan (Var ifThenElse))+                             (L loca 'a')+                        )+                     )+                     (L loctrue ())+                )+             )+             (L locfalse True)+        )+      )+    )++When comes the time to typecheck the program, we end up calling+tcMonoExpr on the AST above. If this expression gives rise to+a type error, then it will appear in a context line and GHC+will pretty-print it using the 'Outputable (HsExpansion a b)'+instance defined below, which *only prints the original+expression*. This is the gist of the idea, but is not quite+enough to recover the error messages that we had with the+SyntaxExpr-based, typechecking/desugaring-to-core time+implementation of rebindable syntax. The key idea is to decorate+some elements of the desugared expression so as to be able to+give them a special treatment when typechecking the desugared+expression, to print a different context line or skip one+altogether.++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in+TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we+entered generated code, i.e code fabricated by the compiler when rebinding some+syntax. If someone tries to push some error context line while that field is set+to True, the pushing won't actually happen and the context line is just dropped.+Once we 'setSrcSpan' a real span (for an expression that was in the original+source code), we set 'tcl_in_gen_code' back to False, indicating that we+"emerged from the generated code tunnel", and that the expressions we will be+processing are relevant to report in context lines again.++You might wonder why TcLclEnv has both+   tcl_loc         :: RealSrcSpan+   tcl_in_gen_code :: Bool+Could we not store a Maybe RealSrcSpan? The problem is that we still+generate constraints when processing generated code, and a CtLoc must+contain a RealSrcSpan -- otherwise, error messages might appear+without source locations. So tcl_loc keeps the RealSrcSpan of the last+location spotted that wasn't generated; it's as good as we're going to+get in generated code. Once we get to sub-trees that are not+generated, then we update the RealSrcSpan appropriately, and set the+tcl_in_gen_code Bool to False.++---++A general recipe to follow this approach for new constructs could go as follows:++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your+  construct, in HsExpr or related syntax data types.+- At renaming-time:+    - take your original node of interest (HsIf above)+    - rename its subexpressions (condition, true branch, false branch above)+    - construct the suitable "rebound"-and-renamed result (ifThenElse call+      above), where the 'SrcSpan' attached to any _fabricated node_ (the+      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'+    - take both the original node and that rebound-and-renamed result and wrap+      them in an XExpr: XExpr (HsExpanded <original node> <desugared>)+ - At typechecking-time:+    - remove any logic that was previously dealing with your rebindable+      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.+    - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we+      typecheck the desugared expression while reporting the original one in+      errors+-}++{- Note [Overview of record dot syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is the note that explains all the moving parts for record dot+syntax.++The language extensions @OverloadedRecordDot@ and+@OverloadedRecordUpdate@ (providing "record dot syntax") are+implemented using the techniques of Note [Rebindable syntax and+HsExpansion].++When OverloadedRecordDot is enabled:+- Field selection expressions+  - e.g. foo.bar.baz+  - Have abstract syntax HsGetField+  - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions+- Field selector expressions e.g. (.x.y)+  - Have abstract syntax HsProjection+  - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions++When OverloadedRecordUpdate is enabled:+- Record update expressions+  - e.g. a{foo.bar=1, quux="corge", baz}+  - Have abstract syntax RecordUpd+    - With rupd_flds containting a Right+    - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)+  - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions+    - Note that this is true for all record updates even for those that do not involve '.'++When OverloadedRecordDot is enabled and RebindableSyntax is not+enabled the name 'getField' is resolved to GHC.Records.getField. When+OverloadedRecordDot is enabled and RebindableSyntax is enabled the+name 'getField' is whatever in-scope name that is.++When OverloadedRecordUpd is enabled and RebindableSyntax is not+enabled it is an error for now (temporary while we wait on native+setField support; see+https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When+OverloadedRecordUpd is enabled and RebindableSyntax is enabled the+names 'getField' and 'setField' are whatever in-scope names they are.+-}++-- See Note [Rebindable syntax and HsExpansion] just above.+data HsExpansion a b+  = HsExpanded a b+  deriving Data++-- | Just print the original expression (the @a@).+instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where+  ppr (HsExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)+++{-+************************************************************************+*                                                                      *+\subsection{Commands (in arrow abstractions)}+*                                                                      *+************************************************************************+-}++type instance XCmdArrApp  GhcPs = EpAnn AddEpAnn+type instance XCmdArrApp  GhcRn = NoExtField+type instance XCmdArrApp  GhcTc = Type++type instance XCmdArrForm GhcPs = EpAnn AnnList+type instance XCmdArrForm GhcRn = NoExtField+type instance XCmdArrForm GhcTc = NoExtField++type instance XCmdApp     (GhcPass _) = EpAnnCO+type instance XCmdLam     (GhcPass _) = NoExtField+type instance XCmdPar     (GhcPass _) = EpAnn AnnParen++type instance XCmdCase    GhcPs = EpAnn EpAnnHsCase+type instance XCmdCase    GhcRn = NoExtField+type instance XCmdCase    GhcTc = NoExtField++type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn]++type instance XCmdIf      GhcPs = EpAnn AnnsIf+type instance XCmdIf      GhcRn = NoExtField+type instance XCmdIf      GhcTc = NoExtField++type instance XCmdLet     GhcPs = EpAnn AnnsLet+type instance XCmdLet     GhcRn = NoExtField+type instance XCmdLet     GhcTc = NoExtField++type instance XCmdDo      GhcPs = EpAnn AnnList+type instance XCmdDo      GhcRn = NoExtField+type instance XCmdDo      GhcTc = Type++type instance XCmdWrap    (GhcPass _) = NoExtField++type instance XXCmd       GhcPs = NoExtCon+type instance XXCmd       GhcRn = NoExtCon+type instance XXCmd       GhcTc = HsWrap HsCmd++type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]+  = SrcSpanAnnL++    -- If   cmd :: arg1 --> res+    --      wrap :: arg1 "->" arg2+    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res++data CmdTopTc+  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack+             Type    -- return type of the command+             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]++type instance XCmdTop  GhcPs = NoExtField+type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]+type instance XCmdTop  GhcTc = CmdTopTc++type instance XXCmdTop (GhcPass _) = NoExtCon++instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where+    ppr cmd = pprCmd cmd++-----------------------+-- pprCmd and pprLCmd call pprDeeper;+-- the underscore versions do not+pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+pprLCmd (L _ c) = pprCmd c++pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc+pprCmd c | isQuietHsCmd c =            ppr_cmd c+         | otherwise      = pprDeeper (ppr_cmd c)++isQuietHsCmd :: HsCmd id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsCmd (HsCmdPar {}) = True+-- applications don't display anything themselves+isQuietHsCmd (HsCmdApp {}) = True+isQuietHsCmd _ = False++-----------------------+ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+ppr_lcmd c = ppr_cmd (unLoc c)++ppr_cmd :: forall p. (OutputableBndrId p+                     ) => HsCmd (GhcPass p) -> SDoc+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)++ppr_cmd (HsCmdApp _ c e)+  = let (fun, args) = collect_args c [e] in+    hang (ppr_lcmd fun) 2 (sep (map ppr args))+  where+    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)+    collect_args fun args = (fun, args)++ppr_cmd (HsCmdLam _ matches)+  = pprMatches matches++ppr_cmd (HsCmdCase _ expr matches)+  = sep [ sep [text "case", nest 4 (ppr expr), ptext (sLit "of")],+          nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdLamCase _ matches)+  = sep [ text "\\case", nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdIf _ _ e ct ce)+  = sep [hsep [text "if", nest 2 (ppr e), ptext (sLit "then")],+         nest 4 (ppr ct),+         text "else",+         nest 4 (ppr ce)]++-- special case: let ... in let ...+ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {})))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, ptext (sLit "in")]),+         ppr_lcmd cmd]++ppr_cmd (HsCmdLet _ binds cmd)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr cmd)]++ppr_cmd (HsCmdDo _ (L _ stmts))  = pprDo ArrowExpr stmts++ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]++ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) _ (Just _) [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm _ (L _ (HsVar _ (L _ v))) Infix _    [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc v+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) _ (Just _) [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm _ (L _ (HsConLikeOut _ c)) Infix _    [arg1, arg2])+  = hang (pprCmdArg (unLoc arg1)) 4 (sep [ pprInfixOcc (conLikeName c)+                                         , pprCmdArg (unLoc arg2)])+ppr_cmd (HsCmdArrForm _ op _ _ args)+  = hang (text "(|" <+> ppr_lexpr op)+         4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")+ppr_cmd (XCmd x) = case ghcPass @p of+#if __GLASGOW_HASKELL__ < 811+  GhcPs -> ppr x+  GhcRn -> ppr x+#endif+  GhcTc -> case x of+    HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))++pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc+pprCmdArg (HsCmdTop _ cmd)+  = ppr_lcmd cmd++instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where+    ppr = pprCmdArg++{-+************************************************************************+*                                                                      *+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}+*                                                                      *+************************************************************************+-}++type instance XMG         GhcPs b = NoExtField+type instance XMG         GhcRn b = NoExtField+type instance XMG         GhcTc b = MatchGroupTc++type instance XXMatchGroup (GhcPass _) b = NoExtCon++type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]+type instance XXMatch (GhcPass _) b = NoExtCon++instance (OutputableBndrId pr, Outputable body)+            => Outputable (Match (GhcPass pr) body) where+  ppr = pprMatch++isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool+isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms++-- | Is there only one RHS in this list of matches?+isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool+isSingletonMatchGroup matches+  | [L _ match] <- matches+  , Match { m_grhss = GRHSs { grhssGRHSs = [_] } } <- match+  = True+  | otherwise+  = False++matchGroupArity :: MatchGroup (GhcPass id) body -> Arity+-- Precondition: MatchGroup is non-empty+-- This is called before type checking, when mg_arg_tys is not set+matchGroupArity (MG { mg_alts = alts })+  | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)+  | otherwise        = panic "matchGroupArity"++hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]+hsLMatchPats (L _ (Match { m_pats = pats })) = pats++-- We keep the type checker happy by providing EpAnnComments.  They+-- can only be used if they follow a `where` keyword with no binds,+-- but in that case the comment is attached to the following parsed+-- item. So this can never be used in practice.+type instance XCGRHSs (GhcPass _) _ = EpAnnComments++type instance XXGRHSs (GhcPass _) _ = NoExtCon++data GrhsAnn+  = GrhsAnn {+      ga_vbar :: Maybe EpaLocation, -- TODO:AZ do we need this?+      ga_sep  :: AddEpAnn -- ^ Match separator location+      } deriving (Data)++type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn+                                   -- Location of matchSeparator+                                   -- TODO:AZ does this belong on the GRHS, or GRHSs?++type instance XXGRHS (GhcPass _) b = NoExtCon++pprMatches :: (OutputableBndrId idR, Outputable body)+           => MatchGroup (GhcPass idR) body -> SDoc+pprMatches MG { mg_alts = matches }+    = vcat (map pprMatch (map unLoc (unLoc matches)))+      -- Don't print the type; it's only a place-holder before typechecking++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprFunBind :: (OutputableBndrId idR)+           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc+pprFunBind matches = pprMatches matches++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprPatBind :: forall bndr p . (OutputableBndrId bndr,+                               OutputableBndrId p)+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc+pprPatBind pat grhss+ = sep [ppr pat,+       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]++pprMatch :: (OutputableBndrId idR, Outputable body)+         => Match (GhcPass idR) body -> SDoc+pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })+  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)+        , nest 2 (pprGRHSs ctxt grhss) ]+  where+    (herald, other_pats)+        = case ctxt of+            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}+                | SrcStrict <- strictness+                -> ASSERT(null pats)     -- A strict variable binding+                   (char '!'<>pprPrefixOcc fun, pats)++                | Prefix <- fixity+                -> (pprPrefixOcc fun, pats) -- f x y z = e+                                            -- Not pprBndr; the AbsBinds will+                                            -- have printed the signature+                | otherwise+                -> case pats of+                     (p1:p2:rest)+                        | null rest -> (pp_infix, [])           -- x &&& y = e+                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e+                        where+                          pp_infix = pprParendLPat opPrec p1+                                     <+> pprInfixOcc fun+                                     <+> pprParendLPat opPrec p2+                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++            LambdaExpr -> (char '\\', pats)++            _ -> case pats of+                   []    -> (empty, [])+                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case+                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++pprGRHSs :: (OutputableBndrId idR, Outputable body)+         => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc+pprGRHSs ctxt (GRHSs _ grhss binds)+  = vcat (map (pprGRHS ctxt . unLoc) grhss)+  -- Print the "where" even if the contents of the binds is empty. Only+  -- EmptyLocalBinds means no "where" keyword+ $$ ppUnless (eqEmptyLocalBinds binds)+      (text "where" $$ nest 4 (pprBinds binds))++pprGRHS :: (OutputableBndrId idR, Outputable body)+        => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc+pprGRHS ctxt (GRHS _ [] body)+ =  pp_rhs ctxt body++pprGRHS ctxt (GRHS _ guards body)+ = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]++pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)++instance Outputable GrhsAnn where+  ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s++{-+************************************************************************+*                                                                      *+\subsection{Do stmts and list comprehensions}+*                                                                      *+************************************************************************+-}++-- Extra fields available post typechecking for RecStmt.+data RecStmtTc =+  RecStmtTc+     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T+     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)+     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1+                                  -- with recS_later_ids and recS_rec_ids,+                                  -- and are the expressions that should be+                                  -- returned by the recursion.+                                  -- They may not quite be the Ids themselves,+                                  -- because the Id may be *polymorphic*, but+                                  -- the returned thing has to be *monomorphic*,+                                  -- so they may be type applications++      , recS_ret_ty :: Type        -- The type of+                                   -- do { stmts; return (a,b,c) }+                                   -- With rebindable syntax the type might not+                                   -- be quite as simple as (m (tya, tyb, tyc)).+      }+++type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField++type instance XBindStmt        (GhcPass _) GhcPs b = EpAnn [AddEpAnn]+type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn+type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc++data XBindStmtRn = XBindStmtRn+  { xbsrn_bindOp :: SyntaxExpr GhcRn+  , xbsrn_failOp :: FailOperator GhcRn+  }++data XBindStmtTc = XBindStmtTc+  { xbstc_bindOp :: SyntaxExpr GhcTc+  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_failOp :: FailOperator GhcTc+  }++type instance XApplicativeStmt (GhcPass _) GhcPs b = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcTc b = Type++type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcTc b = Type++type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn]++type instance XParStmt         (GhcPass _) GhcPs b = NoExtField+type instance XParStmt         (GhcPass _) GhcRn b = NoExtField+type instance XParStmt         (GhcPass _) GhcTc b = Type++type instance XTransStmt       (GhcPass _) GhcPs b = EpAnn [AddEpAnn]+type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField+type instance XTransStmt       (GhcPass _) GhcTc b = Type++type instance XRecStmt         (GhcPass _) GhcPs b = EpAnn AnnList+type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField+type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc++type instance XXStmtLR         (GhcPass _) (GhcPass _) b = NoExtCon++type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = NoExtCon++type instance XApplicativeArgOne GhcPs = NoExtField+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc++type instance XApplicativeArgMany (GhcPass _) = NoExtField+type instance XXApplicativeArg    (GhcPass _) = NoExtCon++type instance ApplicativeArgStmCtxPass _ = GhcRn++instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),+          Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))+        => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts++instance (OutputableBndrId pl, OutputableBndrId pr,+                 Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,+          Outputable body)+         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where+    ppr stmt = pprStmt stmt++pprStmt :: forall idL idR body . (OutputableBndrId idL,+                                  OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                                  Outputable body)+        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc+pprStmt (LastStmt _ expr m_dollar_stripped _)+  = whenPprDebug (text "[last]") <+>+      (case m_dollar_stripped of+        Just True -> text "return $"+        Just False -> text "return"+        Nothing -> empty) <+>+      ppr expr+pprStmt (BindStmt _ pat expr)  = pprBindStmt pat expr+pprStmt (LetStmt _ binds)      = hsep [text "let", pprBinds binds]+pprStmt (BodyStmt _ expr _ _)  = ppr expr+pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr stmtss))++pprStmt (TransStmt { trS_stmts = stmts, trS_by = by+                   , trS_using = using, trS_form = form })+  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])++pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids+                 , recS_later_ids = later_ids })+  = text "rec" <+>+    vcat [ ppr_do_stmts (unLoc segment)+         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids+                            , text "later_ids=" <> ppr later_ids])]++pprStmt (ApplicativeStmt _ args mb_join)+  = getPprStyle $ \style ->+      if userStyle style+         then pp_for_user+         else pp_debug+  where+  -- make all the Applicative stuff invisible in error messages by+  -- flattening the whole ApplicativeStmt nest back to a sequence+  -- of statements.+   pp_for_user = vcat $ concatMap flattenArg args++   -- ppr directly rather than transforming here, because we need to+   -- inject a "return" which is hard when we're polymorphic in the id+   -- type.+   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]+   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args+   flattenStmt stmt = [ppr stmt]++   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]+   flattenArg (_, ApplicativeArgOne _ pat expr isBody)+     | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]+     | otherwise = [pprBindStmt pat expr]+   flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =+     concatMap flattenStmt stmts++   pp_debug =+     let+         ap_expr = sep (punctuate (text " |") (map pp_arg args))+     in+       whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>+       (if lengthAtLeast args 2 then parens else id) ap_expr++   pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc+   pp_arg (_, applicativeArg) = ppr applicativeArg++pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc+pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]++instance (OutputableBndrId idL)+      => Outputable (ApplicativeArg (GhcPass idL)) where+  ppr = pprArg++pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc+pprArg (ApplicativeArgOne _ pat expr isBody)+  | isBody = ppr expr -- See Note [Applicative BodyStmt]+  | otherwise = pprBindStmt pat expr+pprArg (ApplicativeArgMany _ stmts return pat ctxt) =+     ppr pat <+>+     text "<-" <+>+     pprDo ctxt (stmts +++                   [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])++pprTransformStmt :: (OutputableBndrId p)+                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc+pprTransformStmt bndrs using by+  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))+        , nest 2 (ppr using)+        , nest 2 (pprBy by)]++pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc+pprTransStmt by using ThenForm+  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]+pprTransStmt by using GroupForm+  = sep [ text "then group", nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)]++pprBy :: Outputable body => Maybe body -> SDoc+pprBy Nothing  = empty+pprBy (Just e) = text "by" <+> ppr e++pprDo :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => HsStmtContext any -> [LStmt (GhcPass p) body] -> SDoc+pprDo (DoExpr m)    stmts =+  ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts+pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts+pprDo ArrowExpr     stmts = text "do"  <+> ppr_do_stmts stmts+pprDo (MDoExpr m)   stmts =+  ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts+pprDo ListComp      stmts = brackets    $ pprComp stmts+pprDo MonadComp     stmts = brackets    $ pprComp stmts+pprDo _             _     = panic "pprDo" -- PatGuard, ParStmtCxt++ppr_module_name_prefix :: Maybe ModuleName -> SDoc+ppr_module_name_prefix = \case+  Nothing -> empty+  Just module_name -> ppr module_name <> char '.'++ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                 Outputable body)+             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc+-- Print a bunch of do stmts+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)++pprComp :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+        => [LStmt (GhcPass p) body] -> SDoc+pprComp quals     -- Prints:  body | qual1, ..., qualn+  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals+  = if null initStmts+       -- If there are no statements in a list comprehension besides the last+       -- one, we simply treat it like a normal list. This does arise+       -- occasionally in code that GHC generates, e.g., in implementations of+       -- 'range' for derived 'Ix' instances for product datatypes with exactly+       -- one constructor (e.g., see #12583).+       then ppr body+       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)+  | otherwise+  = pprPanic "pprComp" (pprQuals quals)++pprQuals :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+         => [LStmt (GhcPass p) body] -> SDoc+-- Show list comprehension qualifiers separated by commas+pprQuals quals = interpp'SP quals++{-+************************************************************************+*                                                                      *+                Template Haskell quotation brackets+*                                                                      *+************************************************************************+-}++newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data)++type instance XTypedSplice   (GhcPass _) = EpAnn [AddEpAnn]+type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn]+type instance XQuasiQuote    (GhcPass _) = NoExtField+type instance XSpliced       (GhcPass _) = NoExtField+type instance XXSplice       GhcPs       = NoExtCon+type instance XXSplice       GhcRn       = NoExtCon+type instance XXSplice       GhcTc       = HsSplicedT++-- See Note [Running typed splices in the zonker]+-- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice`+data DelayedSplice =+  DelayedSplice+    TcLclEnv          -- The local environment to run the splice in+    (LHsExpr GhcRn)   -- The original renamed expression+    TcType            -- The result type of running the splice, unzonked+    (LHsExpr GhcTc)   -- The typechecked expression to run and splice in the result++-- A Data instance which ignores the argument of 'DelayedSplice'.+instance Data DelayedSplice where+  gunfold _ _ _ = panic "DelayedSplice"+  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]++-- | Pending Renamer Splice+data PendingRnSplice+  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)++-- | Pending Type-checker Splice+data PendingTcSplice+  = PendingTcSplice SplicePointName (LHsExpr GhcTc)++{-+Note [Pending Splices]+~~~~~~~~~~~~~~~~~~~~~~+When we rename an untyped bracket, we name and lift out all the nested+splices, so that when the typechecker hits the bracket, it can+typecheck those nested splices without having to walk over the untyped+bracket code.  So for example+    [| f $(g x) |]+looks like++    HsBracket (HsApp (HsVar "f") (HsSpliceE _ (g x)))++which the renamer rewrites to++    HsRnBracketOut (HsApp (HsVar f) (HsSpliceE sn (g x)))+                   [PendingRnSplice UntypedExpSplice sn (g x)]++* The 'sn' is the Name of the splice point, the SplicePointName++* The PendingRnExpSplice gives the splice that splice-point name maps to;+  and the typechecker can now conveniently find these sub-expressions++* The other copy of the splice, in the second argument of HsSpliceE+                                in the renamed first arg of HsRnBracketOut+  is used only for pretty printing++There are four varieties of pending splices generated by the renamer,+distinguished by their UntypedSpliceFlavour++ * Pending expression splices (UntypedExpSplice), e.g.,+       [|$(f x) + 2|]++   UntypedExpSplice is also used for+     * quasi-quotes, where the pending expression expands to+          $(quoter "...blah...")+       (see GHC.Rename.Splice.makePending, HsQuasiQuote case)++     * cross-stage lifting, where the pending expression expands to+          $(lift x)+       (see GHC.Rename.Splice.checkCrossStageLifting)++ * Pending pattern splices (UntypedPatSplice), e.g.,+       [| \$(f x) -> x |]++ * Pending type splices (UntypedTypeSplice), e.g.,+       [| f :: $(g x) |]++ * Pending declaration (UntypedDeclSplice), e.g.,+       [| let $(f x) in ... |]++There is a fifth variety of pending splice, which is generated by the type+checker:++  * Pending *typed* expression splices, (PendingTcSplice), e.g.,+        [||1 + $$(f 2)||]++It would be possible to eliminate HsRnBracketOut and use HsBracketOut for the+output of the renamer. However, when pretty printing the output of the renamer,+e.g., in a type error message, we *do not* want to print out the pending+splices. In contrast, when pretty printing the output of the type checker, we+*do* want to print the pending splices. So splitting them up seems to make+sense, although I hate to add another constructor to HsExpr.+-}++instance OutputableBndrId p+       => Outputable (HsSplicedThing (GhcPass p)) where+  ppr (HsSplicedExpr e) = ppr_expr e+  ppr (HsSplicedTy   t) = ppr t+  ppr (HsSplicedPat  p) = ppr p++instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where+  ppr s = pprSplice s++pprPendingSplice :: (OutputableBndrId p)+                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc+pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))++pprSpliceDecl ::  (OutputableBndrId p)+          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc+pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e+pprSpliceDecl e ExplicitSplice   = text "$" <> ppr_splice_decl e+pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e++ppr_splice_decl :: (OutputableBndrId p)+                => HsSplice (GhcPass p) -> SDoc+ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty+ppr_splice_decl e = pprSplice e++pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc+pprSplice (HsTypedSplice _ DollarSplice n e)+  = ppr_splice (text "$$") n e empty+pprSplice (HsTypedSplice _ BareSplice _ _ )+  = panic "Bare typed splice"  -- impossible+pprSplice (HsUntypedSplice _ DollarSplice n e)+  = ppr_splice (text "$")  n e empty+pprSplice (HsUntypedSplice _ BareSplice n e)+  = ppr_splice empty  n e empty+pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s+pprSplice (HsSpliced _ _ thing)         = ppr thing+pprSplice (XSplice x)                   = case ghcPass @p of+#if __GLASGOW_HASKELL__ < 811+                                            GhcPs -> noExtCon x+                                            GhcRn -> noExtCon x+#endif+                                            GhcTc -> case x of+                                                       HsSplicedT _ -> text "Unevaluated typed splice"++ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc+ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>+                           char '[' <> ppr quoter <> vbar <>+                           ppr quote <> text "|]"++ppr_splice :: (OutputableBndrId p)+           => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc+ppr_splice herald n e trail+    = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail++type instance XExpBr      (GhcPass _) = NoExtField+type instance XPatBr      (GhcPass _) = NoExtField+type instance XDecBrL     (GhcPass _) = NoExtField+type instance XDecBrG     (GhcPass _) = NoExtField+type instance XTypBr      (GhcPass _) = NoExtField+type instance XVarBr      (GhcPass _) = NoExtField+type instance XTExpBr     (GhcPass _) = NoExtField+type instance XXBracket   (GhcPass _) = NoExtCon++instance OutputableBndrId p+          => Outputable (HsBracket (GhcPass p)) where+  ppr = pprHsBracket+++pprHsBracket :: (OutputableBndrId p) => HsBracket (GhcPass p) -> SDoc+pprHsBracket (ExpBr _ e)   = thBrackets empty (ppr e)+pprHsBracket (PatBr _ p)   = thBrackets (char 'p') (ppr p)+pprHsBracket (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)+pprHsBracket (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))+pprHsBracket (TypBr _ t)   = thBrackets (char 't') (ppr t)+pprHsBracket (VarBr _ True n)+  = char '\'' <> pprPrefixOcc (unLoc n)+pprHsBracket (VarBr _ False n)+  = text "''" <> pprPrefixOcc (unLoc n)+pprHsBracket (TExpBr _ e)  = thTyBrackets (ppr e)++thBrackets :: SDoc -> SDoc -> SDoc+thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>+                             pp_body <+> text "|]"++thTyBrackets :: SDoc -> SDoc+thTyBrackets pp_body = text "[||" <+> pp_body <+> ptext (sLit "||]")++instance Outputable PendingRnSplice where+  ppr (PendingRnSplice _ n e) = pprPendingSplice n e++instance Outputable PendingTcSplice where+  ppr (PendingTcSplice n e) = pprPendingSplice n e++{-+************************************************************************+*                                                                      *+\subsection{Enumerations and list comprehensions}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p+         => Outputable (ArithSeqInfo (GhcPass p)) where+    ppr (From e1)             = hcat [ppr e1, pp_dotdot]+    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]+    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]+    ppr (FromThenTo e1 e2 e3)+      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]++pp_dotdot :: SDoc+pp_dotdot = text " .. "++{-+************************************************************************+*                                                                      *+\subsection{HsMatchCtxt}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where+  ppr m@(FunRhs{})          = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)+  ppr LambdaExpr            = text "LambdaExpr"+  ppr CaseAlt               = text "CaseAlt"+  ppr IfAlt                 = text "IfAlt"+  ppr (ArrowMatchCtxt c)    = text "ArrowMatchCtxt" <+> ppr c+  ppr PatBindRhs            = text "PatBindRhs"+  ppr PatBindGuards         = text "PatBindGuards"+  ppr RecUpd                = text "RecUpd"+  ppr (StmtCtxt _)          = text "StmtCtxt _"+  ppr ThPatSplice           = text "ThPatSplice"+  ppr ThPatQuote            = text "ThPatQuote"+  ppr PatSyn                = text "PatSyn"++instance Outputable HsArrowMatchContext where+  ppr ProcExpr     = text "ProcExpr"+  ppr ArrowCaseAlt = text "ArrowCaseAlt"+  ppr KappaExpr    = text "KappaExpr"++-----------------++instance OutputableBndrId p+      => Outputable (HsStmtContext (GhcPass p)) where+    ppr = pprStmtContext++-- Used to generate the string for a *runtime* error message+matchContextErrString :: OutputableBndrId p+                      => HsMatchContext (GhcPass p) -> SDoc+matchContextErrString (FunRhs{mc_fun=L _ fun})   = text "function" <+> ppr fun+matchContextErrString CaseAlt                    = text "case"+matchContextErrString IfAlt                      = text "multi-way if"+matchContextErrString PatBindRhs                 = text "pattern binding"+matchContextErrString PatBindGuards              = text "pattern binding guards"+matchContextErrString RecUpd                     = text "record update"+matchContextErrString LambdaExpr                 = text "lambda"+matchContextErrString (ArrowMatchCtxt c)         = matchArrowContextErrString c+matchContextErrString ThPatSplice                = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString ThPatQuote                 = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString PatSyn                     = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString (StmtCtxt (ParStmtCtxt c))   = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (PatGuard _))      = text "pattern guard"+matchContextErrString (StmtCtxt GhciStmtCtxt)      = text "interactive GHCi command"+matchContextErrString (StmtCtxt (DoExpr m))        = prependQualified m (text "'do' block")+matchContextErrString (StmtCtxt ArrowExpr)         = text "'do' block"+matchContextErrString (StmtCtxt (MDoExpr m))       = prependQualified m (text "'mdo' block")+matchContextErrString (StmtCtxt ListComp)          = text "list comprehension"+matchContextErrString (StmtCtxt MonadComp)         = text "monad comprehension"++matchArrowContextErrString :: HsArrowMatchContext -> SDoc+matchArrowContextErrString ProcExpr     = text "proc"+matchArrowContextErrString ArrowCaseAlt = text "case"+matchArrowContextErrString KappaExpr    = text "kappa"++pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)+               => Match (GhcPass idR) body -> SDoc+pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)+                                        <> colon)+                             4 (pprMatch match)++pprStmtInCtxt :: (OutputableBndrId idL,+                  OutputableBndrId idR,+                  Outputable body,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)+              => HsStmtContext (GhcPass idL)+              -> StmtLR (GhcPass idL) (GhcPass idR) body+              -> SDoc+pprStmtInCtxt ctxt (LastStmt _ e _ _)+  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"+  = hang (text "In the expression:") 2 (ppr e)++pprStmtInCtxt ctxt stmt+  = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)+       2 (ppr_stmt stmt)+  where+    -- For Group and Transform Stmts, don't print the nested stmts!+    ppr_stmt (TransStmt { trS_by = by, trS_using = using+                        , trS_form = form }) = pprTransStmt by using form+    ppr_stmt stmt = pprStmt stmt++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA+type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL+type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL++type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA++type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]+  = SrcSpanAnnL+type instance Anno (HsCmdTop (GhcPass p)) = SrcSpan+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnL+type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA+type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpan+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpan+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr)))) = SrcSpanAnnA++type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA++type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr))))] = SrcSpanAnnL++instance (Anno a ~ SrcSpanAnn' (EpAnn an))+   => WrapXRec (GhcPass p) a where+  wrapXRec = noLocA

GHC/Hs/Expr.hs-boot view

@@ -1,38 +1,27 @@-{-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE TypeFamilies #-}+                                      -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ module GHC.Hs.Expr where -import GHC.Types.SrcLoc     ( Located ) import GHC.Utils.Outputable ( SDoc, Outputable )-import {-# SOURCE #-} GHC.Hs.Pat  ( LPat )-import GHC.Types.Basic  ( SpliceExplicitFlag(..))+import Language.Haskell.Syntax.Pat ( LPat )+import {-# SOURCE #-} GHC.Hs.Pat () -- for Outputable+import GHC.Types.Basic ( SpliceExplicitFlag(..))+import Language.Haskell.Syntax.Expr+  ( HsExpr, LHsExpr+  , HsCmd+  , MatchGroup+  , GRHSs+  , HsSplice+  ) import GHC.Hs.Extension ( OutputableBndrId, GhcPass )-import Data.Kind  ( Type ) -type role HsExpr nominal-type role HsCmd nominal-type role MatchGroup nominal nominal-type role GRHSs nominal nominal-type role HsSplice nominal-data HsExpr (i :: Type)-data HsCmd  (i :: Type)-data HsSplice (i :: Type)-data MatchGroup (a :: Type) (body :: Type)-data GRHSs (a :: Type) (body :: Type)-type family SyntaxExpr (i :: Type)--instance OutputableBndrId p => Outputable (HsExpr (GhcPass p))-instance OutputableBndrId p => Outputable (HsCmd (GhcPass p))--type LHsExpr a = Located (HsExpr a)+instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p))+instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p))  pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc @@ -43,10 +32,9 @@ pprSpliceDecl ::  (OutputableBndrId p)           => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc -pprPatBind :: forall bndr p body. (OutputableBndrId bndr,-                                   OutputableBndrId p,-                                   Outputable body)-           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) body -> SDoc+pprPatBind :: forall bndr p . (OutputableBndrId bndr,+                               OutputableBndrId p)+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc -pprFunBind :: (OutputableBndrId idR, Outputable body)-           => MatchGroup (GhcPass idR) body -> SDoc+pprFunBind :: (OutputableBndrId idR)+           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc

GHC/Hs/Extension.hs view

@@ -1,24 +1,19 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE EmptyCase #-}-{-# LANGUAGE EmptyDataDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeFamilyDependencies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE UndecidableSuperClasses #-}  -- for IsPass; see Note [NoGhcTc]-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE AllowAmbiguousTypes #-}      -- for pprIfTc, etc.+{-# LANGUAGE AllowAmbiguousTypes     #-}      -- for pprIfTc, etc.+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DeriveDataTypeable      #-}+{-# LANGUAGE EmptyDataDeriving       #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE RankNTypes              #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilyDependencies  #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc]+{-# LANGUAGE UndecidableInstances    #-} -- Wrinkle in Note [Trees That Grow]+                                         -- in module Language.Haskell.Syntax.Extension  module GHC.Hs.Extension where @@ -28,46 +23,16 @@ import GHC.Prelude  import Data.Data hiding ( Fixity )+import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.Var-import GHC.Utils.Outputable-import GHC.Types.SrcLoc (Located)--import Data.Kind+import GHC.Utils.Outputable hiding ((<>))+import GHC.Types.SrcLoc (GenLocated(..), unLoc)+import GHC.Utils.Panic+import GHC.Parser.Annotation  {--Note [Trees that grow]-~~~~~~~~~~~~~~~~~~~~~~--See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow--The hsSyn AST is reused across multiple compiler passes. We also have the-Template Haskell AST, and the haskell-src-exts one (outside of GHC)--Supporting multiple passes means the AST has various warts on it to cope with-the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut',-'SigPatOut' etc.--The growable AST will allow each of these variants to be captured explicitly,-such that they only exist in the given compiler pass AST, as selected by the-type parameter to the AST.--In addition it will allow tool writers to define their own extensions to capture-additional information for the tool, in a natural way.--A further goal is to provide a means to harmonise the Template Haskell and-haskell-src-exts ASTs as well.--Wrinkle: In order to print out the AST, we need to know it is Outputable.-We also sometimes need to branch on the particular pass that we're in-(e.g. to print out type information once we know it). In order to allow-both of these actions, we define OutputableBndrId, which gathers the necessary-OutputableBndr and IsPass constraints. The use of this constraint in instances-generally requires UndecidableInstances.--See also Note [IsPass] and Note [NoGhcTc].- Note [IsPass] ~~~~~~~~~~~~~ One challenge with the Trees That Grow approach@@ -102,7 +67,7 @@ able to compare type-checked types for equality, and we don't want to do this with HsType. -This causes wrinkles within the AST, where we normally thing that the whole+This causes wrinkles within the AST, where we normally think that the whole AST travels through the GhcPs --> GhcRn --> GhcTc pipeline as one. So we have the NoGhcTc type family, which just replaces GhcTc with GhcRn, so that user-written types can be preserved (as HsType GhcRn) even in e.g. HsExpr GhcTc.@@ -129,48 +94,23 @@  -} --- | A placeholder type for TTG extension points that are not currently--- unused to represent any particular value.------ This should not be confused with 'NoExtCon', which are found in unused--- extension /constructors/ and therefore should never be inhabited. In--- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of--- some constructor), so it must have an inhabitant to construct AST passes--- that manipulate fields with that extension point as their type.-data NoExtField = NoExtField-  deriving (Data,Eq,Ord)--instance Outputable NoExtField where-  ppr _ = text "NoExtField"---- | Used when constructing a term with an unused extension point.-noExtField :: NoExtField-noExtField = NoExtField---- | Used in TTG extension constructors that have yet to be extended with--- anything. If an extension constructor has 'NoExtCon' as its field, it is--- not intended to ever be constructed anywhere, and any function that consumes--- the extension constructor can eliminate it by way of 'noExtCon'.------ This should not be confused with 'NoExtField', which are found in unused--- extension /points/ (not /constructors/) and therefore can be inhabited.+-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation+type instance XRec (GhcPass p) a = GenLocated (Anno a) a --- See also [NoExtCon and strict fields].-data NoExtCon-  deriving (Data,Eq,Ord)+type instance Anno RdrName = SrcSpanAnnN+type instance Anno Name    = SrcSpanAnnN+type instance Anno Id      = SrcSpanAnnN -instance Outputable NoExtCon where-  ppr = noExtCon+type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),+                          IsPass p) --- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'.-noExtCon :: NoExtCon -> a-noExtCon x = case x of {}+instance UnXRec (GhcPass p) where+  unXRec = unLoc+instance MapXRec (GhcPass p) where+  mapXRec = fmap --- | GHC's L prefixed variants wrap their vanilla variant in this type family,--- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not--- interested in location information can define this instance as @f p@.-type family XRec p (f :: Type -> Type) = r | r -> p f-type instance XRec (GhcPass p) f = Located (f (GhcPass p))+-- instance WrapXRec (GhcPass p) a where+--   wrapXRec = noLocA  {- Note [NoExtCon and strict fields]@@ -197,7 +137,7 @@ type, there is no possible way to reach the right-hand side of the XHsDecl case. As a result, the coverage checker concludes that the XHsDecl case is inaccessible, so it can be removed.-(See Note [Strict argument type constraints] in GHC.HsToCore.PmCheck.Oracle for+(See Note [Strict argument type constraints] in GHC.HsToCore.Pmc.Solver for more on how this works.)  Bottom line: if you add a TTG extension constructor that uses NoExtCon, make@@ -207,9 +147,9 @@ -- | Used as a data type index for the hsSyn AST; also serves -- as a singleton type for Pass data GhcPass (c :: Pass) where-  GhcPs :: GhcPs-  GhcRn :: GhcRn-  GhcTc :: GhcTc+  GhcPs :: GhcPass 'Parsed+  GhcRn :: GhcPass 'Renamed+  GhcTc :: GhcPass 'Typechecked  -- This really should never be entered, but the data-deriving machinery -- needs the instance to exist.@@ -247,8 +187,6 @@ instance IsPass 'Typechecked where   ghcPass = GhcTc --- | Maps the "normal" id type for a given pass-type family IdP p type instance IdP (GhcPass p) = IdGhcP p  -- | Maps the "normal" id type for a given GHC pass@@ -257,514 +195,25 @@   IdGhcP 'Renamed     = Name   IdGhcP 'Typechecked = Id -type LIdP p = Located (IdP p)- -- | Marks that a field uses the GhcRn variant even when the pass -- parameter is GhcTc. Useful for storing HsTypes in GHC.Hs.Exprs, say, because -- HsType GhcTc should never occur. -- See Note [NoGhcTc]-type family NoGhcTc (p :: Type) where-    -- this way, GHC can figure out that the result is a GhcPass-  NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)-  NoGhcTc other          = other +-- Breaking it up this way, GHC can figure out that the result is a GhcPass+type instance NoGhcTc (GhcPass pass) = GhcPass (NoGhcTcPass pass)+ type family NoGhcTcPass (p :: Pass) :: Pass where   NoGhcTcPass 'Typechecked = 'Renamed   NoGhcTcPass other        = other --- =====================================================================--- Type families for the HsBinds extension points---- HsLocalBindsLR type families-type family XHsValBinds      x x'-type family XHsIPBinds       x x'-type family XEmptyLocalBinds x x'-type family XXHsLocalBindsLR x x'---- ValBindsLR type families-type family XValBinds    x x'-type family XXValBindsLR x x'---- HsBindsLR type families-type family XFunBind    x x'-type family XPatBind    x x'-type family XVarBind    x x'-type family XAbsBinds   x x'-type family XPatSynBind x x'-type family XXHsBindsLR x x'---- ABExport type families-type family XABE x-type family XXABExport x---- PatSynBind type families-type family XPSB x x'-type family XXPatSynBind x x'---- HsIPBinds type families-type family XIPBinds    x-type family XXHsIPBinds x---- IPBind type families-type family XCIPBind x-type family XXIPBind x---- Sig type families-type family XTypeSig          x-type family XPatSynSig        x-type family XClassOpSig       x-type family XIdSig            x-type family XFixSig           x-type family XInlineSig        x-type family XSpecSig          x-type family XSpecInstSig      x-type family XMinimalSig       x-type family XSCCFunSig        x-type family XCompleteMatchSig x-type family XXSig             x---- FixitySig type families-type family XFixitySig          x-type family XXFixitySig         x---- StandaloneKindSig type families-type family XStandaloneKindSig  x-type family XXStandaloneKindSig x---- =====================================================================--- Type families for the HsDecls extension points---- HsDecl type families-type family XTyClD       x-type family XInstD       x-type family XDerivD      x-type family XValD        x-type family XSigD        x-type family XKindSigD    x-type family XDefD        x-type family XForD        x-type family XWarningD    x-type family XAnnD        x-type family XRuleD       x-type family XSpliceD     x-type family XDocD        x-type family XRoleAnnotD  x-type family XXHsDecl     x---- ---------------------------------------- HsGroup type families-type family XCHsGroup      x-type family XXHsGroup      x---- ---------------------------------------- SpliceDecl type families-type family XSpliceDecl       x-type family XXSpliceDecl      x---- ---------------------------------------- TyClDecl type families-type family XFamDecl       x-type family XSynDecl       x-type family XDataDecl      x-type family XClassDecl     x-type family XXTyClDecl     x---- ---------------------------------------- TyClGroup type families-type family XCTyClGroup      x-type family XXTyClGroup      x---- ---------------------------------------- FamilyResultSig type families-type family XNoSig            x-type family XCKindSig         x -- Clashes with XKindSig above-type family XTyVarSig         x-type family XXFamilyResultSig x---- ---------------------------------------- FamilyDecl type families-type family XCFamilyDecl      x-type family XXFamilyDecl      x---- ---------------------------------------- HsDataDefn type families-type family XCHsDataDefn      x-type family XXHsDataDefn      x---- ---------------------------------------- HsDerivingClause type families-type family XCHsDerivingClause      x-type family XXHsDerivingClause      x---- ---------------------------------------- ConDecl type families-type family XConDeclGADT   x-type family XConDeclH98    x-type family XXConDecl      x---- ---------------------------------------- FamEqn type families-type family XCFamEqn      x r-type family XXFamEqn      x r---- ---------------------------------------- ClsInstDecl type families-type family XCClsInstDecl      x-type family XXClsInstDecl      x---- ---------------------------------------- ClsInstDecl type families-type family XClsInstD      x-type family XDataFamInstD  x-type family XTyFamInstD    x-type family XXInstDecl     x---- ---------------------------------------- DerivDecl type families-type family XCDerivDecl      x-type family XXDerivDecl      x---- ---------------------------------------- DerivStrategy type family-type family XViaStrategy x---- ---------------------------------------- DefaultDecl type families-type family XCDefaultDecl      x-type family XXDefaultDecl      x---- ---------------------------------------- DefaultDecl type families-type family XForeignImport     x-type family XForeignExport     x-type family XXForeignDecl      x---- ---------------------------------------- RuleDecls type families-type family XCRuleDecls      x-type family XXRuleDecls      x---- ---------------------------------------- RuleDecl type families-type family XHsRule          x-type family XXRuleDecl       x---- ---------------------------------------- RuleBndr type families-type family XCRuleBndr      x-type family XRuleBndrSig    x-type family XXRuleBndr      x---- ---------------------------------------- WarnDecls type families-type family XWarnings        x-type family XXWarnDecls      x---- ---------------------------------------- AnnDecl type families-type family XWarning        x-type family XXWarnDecl      x---- ---------------------------------------- AnnDecl type families-type family XHsAnnotation  x-type family XXAnnDecl      x---- ---------------------------------------- RoleAnnotDecl type families-type family XCRoleAnnotDecl  x-type family XXRoleAnnotDecl  x---- =====================================================================--- Type families for the HsExpr extension points--type family XVar            x-type family XUnboundVar     x-type family XConLikeOut     x-type family XRecFld         x-type family XOverLabel      x-type family XIPVar          x-type family XOverLitE       x-type family XLitE           x-type family XLam            x-type family XLamCase        x-type family XApp            x-type family XAppTypeE       x-type family XOpApp          x-type family XNegApp         x-type family XPar            x-type family XSectionL       x-type family XSectionR       x-type family XExplicitTuple  x-type family XExplicitSum    x-type family XCase           x-type family XIf             x-type family XMultiIf        x-type family XLet            x-type family XDo             x-type family XExplicitList   x-type family XRecordCon      x-type family XRecordUpd      x-type family XExprWithTySig  x-type family XArithSeq       x-type family XBracket        x-type family XRnBracketOut   x-type family XTcBracketOut   x-type family XSpliceE        x-type family XProc           x-type family XStatic         x-type family XTick           x-type family XBinTick        x-type family XPragE          x-type family XXExpr          x--type family XSCC            x-type family XCoreAnn        x-type family XTickPragma     x-type family XXPragE         x--- -----------------------------------------------------------------------type family XUnambiguous        x-type family XAmbiguous          x-type family XXAmbiguousFieldOcc x---- ------------------------------------------------------------------------type family XPresent  x-type family XMissing  x-type family XXTupArg  x---- -----------------------------------------------------------------------type family XTypedSplice   x-type family XUntypedSplice x-type family XQuasiQuote    x-type family XSpliced       x-type family XXSplice       x---- -----------------------------------------------------------------------type family XExpBr      x-type family XPatBr      x-type family XDecBrL     x-type family XDecBrG     x-type family XTypBr      x-type family XVarBr      x-type family XTExpBr     x-type family XXBracket   x---- -----------------------------------------------------------------------type family XCmdTop  x-type family XXCmdTop x---- ---------------------------------------type family XMG           x b-type family XXMatchGroup  x b---- ---------------------------------------type family XCMatch  x b-type family XXMatch  x b---- ---------------------------------------type family XCGRHSs  x b-type family XXGRHSs  x b---- ---------------------------------------type family XCGRHS  x b-type family XXGRHS  x b---- ---------------------------------------type family XLastStmt        x x' b-type family XBindStmt        x x' b-type family XApplicativeStmt x x' b-type family XBodyStmt        x x' b-type family XLetStmt         x x' b-type family XParStmt         x x' b-type family XTransStmt       x x' b-type family XRecStmt         x x' b-type family XXStmtLR         x x' b---- -----------------------------------------------------------------------type family XCmdArrApp  x-type family XCmdArrForm x-type family XCmdApp     x-type family XCmdLam     x-type family XCmdPar     x-type family XCmdCase    x-type family XCmdLamCase x-type family XCmdIf      x-type family XCmdLet     x-type family XCmdDo      x-type family XCmdWrap    x-type family XXCmd       x---- -----------------------------------------------------------------------type family XParStmtBlock  x x'-type family XXParStmtBlock x x'---- -----------------------------------------------------------------------type family XApplicativeArgOne   x-type family XApplicativeArgMany  x-type family XXApplicativeArg     x---- =====================================================================--- Type families for the HsImpExp extension points---- TODO---- =====================================================================--- Type families for the HsLit extension points---- We define a type family for each extension point. This is based on prepending--- 'X' to the constructor name, for ease of reference.-type family XHsChar x-type family XHsCharPrim x-type family XHsString x-type family XHsStringPrim x-type family XHsInt x-type family XHsIntPrim x-type family XHsWordPrim x-type family XHsInt64Prim x-type family XHsWord64Prim x-type family XHsInteger x-type family XHsRat x-type family XHsFloatPrim x-type family XHsDoublePrim x-type family XXLit x--type family XOverLit  x-type family XXOverLit x---- =====================================================================--- Type families for the HsPat extension points--type family XWildPat   x-type family XVarPat    x-type family XLazyPat   x-type family XAsPat     x-type family XParPat    x-type family XBangPat   x-type family XListPat   x-type family XTuplePat  x-type family XSumPat    x-type family XConPat    x-type family XViewPat   x-type family XSplicePat x-type family XLitPat    x-type family XNPat      x-type family XNPlusKPat x-type family XSigPat    x-type family XCoPat     x-type family XXPat      x---- =====================================================================--- Type families for the HsTypes type families--type family XHsQTvs       x-type family XXLHsQTyVars  x---- ---------------------------------------type family XHsIB              x b-type family XXHsImplicitBndrs  x b---- ---------------------------------------type family XHsWC              x b-type family XXHsWildCardBndrs  x b---- ---------------------------------------type family XHsPS x-type family XXHsPatSigType x---- ---------------------------------------type family XForAllTy        x-type family XQualTy          x-type family XTyVar           x-type family XAppTy           x-type family XAppKindTy       x-type family XFunTy           x-type family XListTy          x-type family XTupleTy         x-type family XSumTy           x-type family XOpTy            x-type family XParTy           x-type family XIParamTy        x-type family XStarTy          x-type family XKindSig         x-type family XSpliceTy        x-type family XDocTy           x-type family XBangTy          x-type family XRecTy           x-type family XExplicitListTy  x-type family XExplicitTupleTy x-type family XTyLit           x-type family XWildCardTy      x-type family XXType           x---- -----------------------------------------------------------------------type family XHsForAllVis        x-type family XHsForAllInvis      x-type family XXHsForAllTelescope x---- -----------------------------------------------------------------------type family XUserTyVar   x-type family XKindedTyVar x-type family XXTyVarBndr  x---- -----------------------------------------------------------------------type family XConDeclField  x-type family XXConDeclField x---- -----------------------------------------------------------------------type family XCFieldOcc x-type family XXFieldOcc x---- =====================================================================--- Type families for the HsImpExp type families--type family XCImportDecl       x-type family XXImportDecl       x---- ---------------------------------------type family XIEVar             x-type family XIEThingAbs        x-type family XIEThingAll        x-type family XIEThingWith       x-type family XIEModuleContents  x-type family XIEGroup           x-type family XIEDoc             x-type family XIEDocNamed        x-type family XXIE               x---- ------------------------------------------ =====================================================================--- End of Type family definitions--- =====================================================================- -- |Constraint type to bundle up the requirement for 'OutputableBndr' on both -- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass =   ( OutputableBndr (IdGhcP pass)   , OutputableBndr (IdGhcP (NoGhcTcPass pass))+  , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass))+  , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass)))   , IsPass pass   )

GHC/Hs/ImpExp.hs view

@@ -1,3 +1,11 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,28 +14,23 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension- module GHC.Hs.ImpExp where  import GHC.Prelude  import GHC.Unit.Module        ( ModuleName, IsBootInterface(..) ) import GHC.Hs.Doc             ( HsDocString )-import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc )-import GHC.Types.Basic        ( SourceText(..), StringLiteral(..), pprWithSourceText )-import GHC.Types.FieldLabel   ( FieldLbl(..) )+import GHC.Types.SourceText   ( SourceText(..), StringLiteral(..), pprWithSourceText )+import GHC.Types.FieldLabel   ( FieldLabel )  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.SrcLoc+import Language.Haskell.Syntax.Extension import GHC.Hs.Extension+import GHC.Parser.Annotation+import GHC.Types.Name  import Data.Data import Data.Maybe@@ -43,12 +46,13 @@ -}  -- | Located Import Declaration-type LImportDecl pass = Located (ImportDecl pass)+type LImportDecl pass = XRec pass (ImportDecl pass)         -- ^ When in a list this may have         --         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA  -- | If/how an import is 'qualified'. data ImportDeclQualifiedStyle@@ -60,12 +64,12 @@ -- | Given two possible located 'qualified' tokens, compute a style -- (in a conforming Haskell program only one of the two can be not -- 'Nothing'). This is called from "GHC.Parser".-importDeclQualifiedStyle :: Maybe (Located a)-                         -> Maybe (Located a)-                         -> ImportDeclQualifiedStyle+importDeclQualifiedStyle :: Maybe EpaLocation+                         -> Maybe EpaLocation+                         -> (Maybe EpaLocation, ImportDeclQualifiedStyle) importDeclQualifiedStyle mPre mPost =-  if isJust mPre then QualifiedPre-  else if isJust mPost then QualifiedPost else NotQualified+  if isJust mPre then (mPre, QualifiedPre)+  else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified)  -- | Convenience function to answer the question if an import decl. is -- qualified.@@ -80,15 +84,15 @@   = ImportDecl {       ideclExt       :: XCImportDecl pass,       ideclSourceSrc :: SourceText,-                                 -- Note [Pragma source text] in GHC.Types.Basic-      ideclName      :: Located ModuleName, -- ^ Module name.+                                 -- Note [Pragma source text] in GHC.Types.SourceText+      ideclName      :: XRec pass ModuleName, -- ^ Module name.       ideclPkgQual   :: Maybe StringLiteral,  -- ^ Package qualifier.       ideclSource    :: IsBootInterface,      -- ^ IsBoot <=> {-\# SOURCE \#-} import       ideclSafe      :: Bool,          -- ^ True => safe import       ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.       ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)-      ideclAs        :: Maybe (Located ModuleName),  -- ^ as Module-      ideclHiding    :: Maybe (Bool, Located [LIE pass])+      ideclAs        :: Maybe (XRec pass ModuleName),  -- ^ as Module+      ideclHiding    :: Maybe (Bool, XRec pass [LIE pass])                                        -- ^ (True => hiding, names)     }   | XImportDecl !(XXImportDecl pass)@@ -107,16 +111,37 @@      --    'GHC.Parser.Annotation.AnnClose' attached      --     to location in ideclHiding -     -- For details on above see note [Api annotations] in GHC.Parser.Annotation+     -- For details on above see note [exact print annotations] in GHC.Parser.Annotation -type instance XCImportDecl  (GhcPass _) = NoExtField+type instance XCImportDecl  GhcPs = EpAnn EpAnnImportDecl+type instance XCImportDecl  GhcRn = NoExtField+type instance XCImportDecl  GhcTc = NoExtField+ type instance XXImportDecl  (GhcPass _) = NoExtCon -simpleImportDecl :: ModuleName -> ImportDecl (GhcPass p)+type instance Anno ModuleName = SrcSpanAnnA+type instance Anno [LocatedA (IE (GhcPass p))] = SrcSpanAnnL++-- ---------------------------------------------------------------------++-- API Annotations types++data EpAnnImportDecl = EpAnnImportDecl+  { importDeclAnnImport    :: EpaLocation+  , importDeclAnnPragma    :: Maybe (EpaLocation, EpaLocation)+  , importDeclAnnSafe      :: Maybe EpaLocation+  , importDeclAnnQualified :: Maybe EpaLocation+  , importDeclAnnPackage   :: Maybe EpaLocation+  , importDeclAnnAs        :: Maybe EpaLocation+  } deriving (Data)++-- ---------------------------------------------------------------------++simpleImportDecl :: ModuleName -> ImportDecl GhcPs simpleImportDecl mn = ImportDecl {-      ideclExt       = noExtField,+      ideclExt       = noAnn,       ideclSourceSrc = NoSourceText,-      ideclName      = noLoc mn,+      ideclName      = noLocA mn,       ideclPkgQual   = Nothing,       ideclSource    = NotBoot,       ideclSafe      = False,@@ -126,7 +151,8 @@       ideclHiding    = Nothing     } -instance OutputableBndrId p+instance (OutputableBndrId p+         , Outputable (Anno (IE (GhcPass p))))        => Outputable (ImportDecl (GhcPass p)) where     ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'                     , ideclPkgQual = pkg@@ -141,7 +167,7 @@         pp_implicit True = ptext (sLit ("(implicit)"))          pp_pkg Nothing                    = empty-        pp_pkg (Just (StringLiteral st p))+        pp_pkg (Just (StringLiteral st p _))           = pprWithSourceText st (doubleQuotes (ftext p))          pp_qual QualifiedPre False = text "qualified" -- Prepositive qualifier/prepositive position.@@ -176,29 +202,32 @@ ************************************************************************ -} --- | A name in an import or export specification which may have adornments. Used--- primarily for accurate pretty printing of ParsedSource, and API Annotation--- placement.+-- | A name in an import or export specification which may have+-- adornments. Used primarily for accurate pretty printing of+-- ParsedSource, and API Annotation placement. The+-- 'GHC.Parser.Annotation' is the location of the adornment in+-- the original source. data IEWrappedName name-  = IEName    (Located name)  -- ^ no extra-  | IEPattern (Located name)  -- ^ pattern X-  | IEType    (Located name)  -- ^ type (:+:)+  = IEName                (LocatedN name)  -- ^ no extra+  | IEPattern EpaLocation (LocatedN name)  -- ^ pattern X+  | IEType    EpaLocation (LocatedN name)  -- ^ type (:+:)   deriving (Eq,Data)  -- | Located name with possible adornment -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType', --         'GHC.Parser.Annotation.AnnPattern'-type LIEWrappedName name = Located (IEWrappedName name)--- For details on above see note [Api annotations] in GHC.Parser.Annotation+type LIEWrappedName name = LocatedA (IEWrappedName name)+-- For details on above see note [exact print annotations] in GHC.Parser.Annotation   -- | Located Import or Export-type LIE pass = Located (IE pass)+type LIE pass = XRec pass (IE pass)         -- ^ When in a list this may have         --         --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+type instance Anno (IE (GhcPass p)) = SrcSpanAnnA  -- | Imported or exported entity. data IE pass@@ -212,7 +241,7 @@         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',         --             'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr   | IEThingAll  (XIEThingAll pass) (LIEWrappedName (IdP pass))         -- ^ Imported or exported Thing with All imported or exported@@ -223,14 +252,13 @@         --       'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',         --                                 'GHC.Parser.Annotation.AnnType' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr    | IEThingWith (XIEThingWith pass)                 (LIEWrappedName (IdP pass))                 IEWildcard                 [LIEWrappedName (IdP pass)]-                [Located (FieldLbl (IdP pass))]         -- ^ Imported or exported Thing With given imported or exported         --         -- The thing is a Class/Type and the imported or exported things are@@ -240,83 +268,110 @@         --                                   'GHC.Parser.Annotation.AnnComma',         --                                   'GHC.Parser.Annotation.AnnType' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | IEModuleContents  (XIEModuleContents pass) (Located ModuleName)+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | IEModuleContents  (XIEModuleContents pass) (XRec pass ModuleName)         -- ^ Imported or exported module contents         --         -- (Export Only)         --         -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule' -        -- For details on above see note [Api annotations] in GHC.Parser.Annotation+        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation   | IEGroup             (XIEGroup pass) Int HsDocString -- ^ Doc section heading   | IEDoc               (XIEDoc pass) HsDocString       -- ^ Some documentation   | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc   | XIE !(XXIE pass) -type instance XIEVar             (GhcPass _) = NoExtField-type instance XIEThingAbs        (GhcPass _) = NoExtField-type instance XIEThingAll        (GhcPass _) = NoExtField-type instance XIEThingWith       (GhcPass _) = NoExtField-type instance XIEModuleContents  (GhcPass _) = NoExtField+type instance XIEVar             GhcPs = NoExtField+type instance XIEVar             GhcRn = NoExtField+type instance XIEVar             GhcTc = NoExtField++type instance XIEThingAbs        (GhcPass _) = EpAnn [AddEpAnn]+type instance XIEThingAll        (GhcPass _) = EpAnn [AddEpAnn]++-- See Note [IEThingWith]+type instance XIEThingWith       (GhcPass 'Parsed)      = EpAnn [AddEpAnn]+type instance XIEThingWith       (GhcPass 'Renamed)     = [Located FieldLabel]+type instance XIEThingWith       (GhcPass 'Typechecked) = NoExtField++type instance XIEModuleContents  GhcPs = EpAnn [AddEpAnn]+type instance XIEModuleContents  GhcRn = NoExtField+type instance XIEModuleContents  GhcTc = NoExtField+ type instance XIEGroup           (GhcPass _) = NoExtField type instance XIEDoc             (GhcPass _) = NoExtField type instance XIEDocNamed        (GhcPass _) = NoExtField type instance XXIE               (GhcPass _) = NoExtCon +type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA+ -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)  {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~- A definition like +    {-# LANGUAGE DuplicateRecordFields #-}     module M ( T(MkT, x) ) where       data T = MkT { x :: Int } -gives rise to+gives rise to this in the output of the parser: -    IEThingWith T [MkT] [FieldLabel "x" False x)]           (without DuplicateRecordFields)-    IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)]   (with    DuplicateRecordFields)+    IEThingWith NoExtField T [MkT, x] NoIEWildcard +But in the renamer we need to attach the correct field label,+because the selector Name is mangled (see Note [FieldLabel] in+GHC.Types.FieldLabel).  Hence we change this to:++    IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard++using the TTG extension field to store the list of fields in renamed syntax+only.  (Record fields always appear in this list, regardless of whether+DuplicateRecordFields was in use at the definition site or not.)+ See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -}  ieName :: IE (GhcPass p) -> IdP (GhcPass p)-ieName (IEVar _ (L _ n))              = ieWrappedName n-ieName (IEThingAbs  _ (L _ n))        = ieWrappedName n-ieName (IEThingWith _ (L _ n) _ _ _)  = ieWrappedName n-ieName (IEThingAll  _ (L _ n))        = ieWrappedName n+ieName (IEVar _ (L _ n))            = ieWrappedName n+ieName (IEThingAbs  _ (L _ n))      = ieWrappedName n+ieName (IEThingWith _ (L _ n) _ _)  = ieWrappedName n+ieName (IEThingAll  _ (L _ n))      = ieWrappedName n ieName _ = panic "ieName failed pattern match!"  ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)]-ieNames (IEVar       _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingAbs  _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingAll  _ (L _ n)   )     = [ieWrappedName n]-ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n-                                       : map (ieWrappedName . unLoc) ns+ieNames (IEVar       _ (L _ n)   )   = [ieWrappedName n]+ieNames (IEThingAbs  _ (L _ n)   )   = [ieWrappedName n]+ieNames (IEThingAll  _ (L _ n)   )   = [ieWrappedName n]+ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n+                                     : map (ieWrappedName . unLoc) ns+-- NB the above case does not include names of field selectors ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = [] ieNames (IEDoc            {})     = [] ieNames (IEDocNamed       {})     = [] +ieWrappedLName :: IEWrappedName name -> LocatedN name+ieWrappedLName (IEName      ln) = ln+ieWrappedLName (IEPattern _ ln) = ln+ieWrappedLName (IEType    _ ln) = ln+ ieWrappedName :: IEWrappedName name -> name-ieWrappedName (IEName    (L _ n)) = n-ieWrappedName (IEPattern (L _ n)) = n-ieWrappedName (IEType    (L _ n)) = n+ieWrappedName = unLoc . ieWrappedLName + lieWrappedName :: LIEWrappedName name -> name lieWrappedName (L _ n) = ieWrappedName n -ieLWrappedName :: LIEWrappedName name -> Located name-ieLWrappedName (L l n) = L l (ieWrappedName n)+ieLWrappedName :: LIEWrappedName name -> LocatedN name+ieLWrappedName (L _ n) = ieWrappedLName n  replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2-replaceWrappedName (IEName    (L l _)) n = IEName    (L l n)-replaceWrappedName (IEPattern (L l _)) n = IEPattern (L l n)-replaceWrappedName (IEType    (L l _)) n = IEType    (L l n)+replaceWrappedName (IEName      (L l _)) n = IEName      (L l n)+replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n)+replaceWrappedName (IEType    r (L l _)) n = IEType    r (L l n)  replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2 replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n')@@ -325,10 +380,9 @@     ppr (IEVar       _     var) = ppr (unLoc var)     ppr (IEThingAbs  _   thing) = ppr (unLoc thing)     ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]-    ppr (IEThingWith _ thing wc withs flds)+    ppr (IEThingWith flds thing wc withs)         = ppr (unLoc thing) <> parens (fsep (punctuate comma-                                              (ppWiths ++-                                              map (ppr . flLabel . unLoc) flds)))+                                              (ppWiths ++ ppFields) ))       where         ppWiths =           case wc of@@ -337,6 +391,10 @@               IEWildcard pos ->                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)                 in bs ++ [text ".."] ++ as+        ppFields =+          case ghcPass @p of+            GhcRn -> map ppr flds+            _     -> []     ppr (IEModuleContents _ mod')         = text "module" <+> ppr mod'     ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")@@ -352,9 +410,9 @@   pprInfixOcc  w = pprInfixOcc  (ieWrappedName w)  instance (OutputableBndr name) => Outputable (IEWrappedName name) where-  ppr (IEName    n) = pprPrefixOcc (unLoc n)-  ppr (IEPattern n) = text "pattern" <+> pprPrefixOcc (unLoc n)-  ppr (IEType    n) = text "type"    <+> pprPrefixOcc (unLoc n)+  ppr (IEName      n) = pprPrefixOcc (unLoc n)+  ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n)+  ppr (IEType    _ n) = text "type"    <+> pprPrefixOcc (unLoc n)  pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name

GHC/Hs/Instances.hs view

@@ -32,6 +32,7 @@ import GHC.Hs.Type import GHC.Hs.Pat import GHC.Hs.ImpExp+import GHC.Parser.Annotation  -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs-----------------------------------------@@ -67,6 +68,11 @@ deriving instance Data (ABExport GhcRn) deriving instance Data (ABExport GhcTc) +-- deriving instance DataId p => Data (RecordPatSynField p)+deriving instance Data (RecordPatSynField GhcPs)+deriving instance Data (RecordPatSynField GhcRn)+deriving instance Data (RecordPatSynField GhcTc)+ -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) deriving instance Data (PatSynBind GhcPs GhcPs) deriving instance Data (PatSynBind GhcPs GhcRn)@@ -126,6 +132,11 @@ deriving instance Data (TyClDecl GhcRn) deriving instance Data (TyClDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (FunDep p)+deriving instance Data (FunDep GhcPs)+deriving instance Data (FunDep GhcRn)+deriving instance Data (FunDep GhcTc)+ -- deriving instance (DataIdLR p p) => Data (TyClGroup p) deriving instance Data (TyClGroup GhcPs) deriving instance Data (TyClGroup GhcRn)@@ -161,11 +172,21 @@ deriving instance Data (HsDerivingClause GhcRn) deriving instance Data (HsDerivingClause GhcTc) +-- deriving instance DataIdLR p p => Data (DerivClauseTys p)+deriving instance Data (DerivClauseTys GhcPs)+deriving instance Data (DerivClauseTys GhcRn)+deriving instance Data (DerivClauseTys GhcTc)+ -- deriving instance (DataIdLR p p) => Data (ConDecl p) deriving instance Data (ConDecl GhcPs) deriving instance Data (ConDecl GhcRn) deriving instance Data (ConDecl GhcTc) +-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p)+deriving instance Data (HsConDeclGADTDetails GhcPs)+deriving instance Data (HsConDeclGADTDetails GhcRn)+deriving instance Data (HsConDeclGADTDetails GhcTc)+ -- deriving instance DataIdLR p p   => Data (TyFamInstDecl p) deriving instance Data (TyFamInstDecl GhcPs) deriving instance Data (TyFamInstDecl GhcRn)@@ -237,6 +258,10 @@ deriving instance Data (WarnDecl GhcTc)  -- deriving instance (DataIdLR p p) => Data (AnnDecl p)+deriving instance Data (AnnProvenance GhcPs)+deriving instance Data (AnnProvenance GhcRn)+deriving instance Data (AnnProvenance GhcTc)+ deriving instance Data (AnnDecl GhcPs) deriving instance Data (AnnDecl GhcRn) deriving instance Data (AnnDecl GhcTc)@@ -249,6 +274,14 @@ -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Expr ----------------------------------- +deriving instance Data (FieldLabelStrings GhcPs)+deriving instance Data (FieldLabelStrings GhcRn)+deriving instance Data (FieldLabelStrings GhcTc)++deriving instance Data (HsFieldLabel GhcPs)+deriving instance Data (HsFieldLabel GhcRn)+deriving instance Data (HsFieldLabel GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsPragE p) deriving instance Data (HsPragE GhcPs) deriving instance Data (HsPragE GhcRn)@@ -275,30 +308,46 @@ deriving instance Data (HsCmdTop GhcTc)  -- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)-deriving instance (Data body) => Data (MatchGroup GhcPs body)-deriving instance (Data body) => Data (MatchGroup GhcRn body)-deriving instance (Data body) => Data (MatchGroup GhcTc body)+deriving instance Data (MatchGroup GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (MatchGroup GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (MatchGroup GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (MatchGroup GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (MatchGroup GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (MatchGroup GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (Match      p body)-deriving instance (Data body) => Data (Match      GhcPs body)-deriving instance (Data body) => Data (Match      GhcRn body)-deriving instance (Data body) => Data (Match      GhcTc body)+deriving instance Data (Match      GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (Match      GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (Match      GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (Match      GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (Match      GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (Match      GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (GRHSs      p body)-deriving instance (Data body) => Data (GRHSs     GhcPs body)-deriving instance (Data body) => Data (GRHSs     GhcRn body)-deriving instance (Data body) => Data (GRHSs     GhcTc body)+deriving instance Data (GRHSs     GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (GRHSs     GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (GRHSs     GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (GRHSs     GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (GRHSs     GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (GRHSs     GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (GRHS       p body)-deriving instance (Data body) => Data (GRHS     GhcPs body)-deriving instance (Data body) => Data (GRHS     GhcRn body)-deriving instance (Data body) => Data (GRHS     GhcTc body)+deriving instance Data (GRHS     GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (GRHS     GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (GRHS     GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (GRHS     GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (GRHS     GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (GRHS     GhcTc (LocatedA (HsCmd GhcTc)))  -- deriving instance (DataIdLR p p,Data body) => Data (StmtLR   p p body)-deriving instance (Data body) => Data (StmtLR   GhcPs GhcPs body)-deriving instance (Data body) => Data (StmtLR   GhcPs GhcRn body)-deriving instance (Data body) => Data (StmtLR   GhcRn GhcRn body)-deriving instance (Data body) => Data (StmtLR   GhcTc GhcTc body)+deriving instance Data (StmtLR   GhcPs GhcPs (LocatedA (HsExpr GhcPs)))+deriving instance Data (StmtLR   GhcPs GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (StmtLR   GhcRn GhcRn (LocatedA (HsExpr GhcRn)))+deriving instance Data (StmtLR   GhcTc GhcTc (LocatedA (HsExpr GhcTc)))+deriving instance Data (StmtLR   GhcPs GhcPs (LocatedA (HsCmd GhcPs)))+deriving instance Data (StmtLR   GhcPs GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (StmtLR   GhcRn GhcRn (LocatedA (HsCmd GhcRn)))+deriving instance Data (StmtLR   GhcTc GhcTc (LocatedA (HsCmd GhcTc)))  deriving instance Data RecStmtTc @@ -317,6 +366,8 @@ deriving instance Data (HsStmtContext GhcRn) deriving instance Data (HsStmtContext GhcTc) +deriving instance Data HsArrowMatchContext+ deriving instance Data (HsMatchContext GhcPs) deriving instance Data (HsMatchContext GhcRn) deriving instance Data (HsMatchContext GhcTc)@@ -341,7 +392,6 @@ deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordConTc deriving instance Data RecordUpdTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice@@ -378,7 +428,8 @@  deriving instance Data ListPatTc --- deriving instance (DataIdLR p p, Data body) => Data (HsRecFields p body)+deriving instance (Data a, Data b) => Data (HsRecField' a b)+ deriving instance (Data body) => Data (HsRecFields GhcPs body) deriving instance (Data body) => Data (HsRecFields GhcRn body) deriving instance (Data body) => Data (HsRecFields GhcTc body)@@ -391,11 +442,16 @@ deriving instance Data (LHsQTyVars GhcRn) deriving instance Data (LHsQTyVars GhcTc) --- deriving instance (DataIdLR p p, Data thing) =>Data (HsImplicitBndrs p thing)-deriving instance (Data thing) => Data (HsImplicitBndrs GhcPs thing)-deriving instance (Data thing) => Data (HsImplicitBndrs GhcRn thing)-deriving instance (Data thing) => Data (HsImplicitBndrs GhcTc thing)+-- deriving instance (Data flag, DataIdLR p p) => Data (HsOuterTyVarBndrs p)+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcPs)+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcRn)+deriving instance Data flag => Data (HsOuterTyVarBndrs flag GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsSigType p)+deriving instance Data (HsSigType GhcPs)+deriving instance Data (HsSigType GhcRn)+deriving instance Data (HsSigType GhcTc)+ -- deriving instance (DataIdLR p p, Data thing) =>Data (HsWildCardBndrs p thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcPs thing) deriving instance (Data thing) => Data (HsWildCardBndrs GhcRn thing)@@ -431,9 +487,10 @@ deriving instance Data thing => Data (HsScaled GhcRn thing) deriving instance Data thing => Data (HsScaled GhcTc thing) -deriving instance Data (LHsTypeArg GhcPs)-deriving instance Data (LHsTypeArg GhcRn)-deriving instance Data (LHsTypeArg GhcTc)+deriving instance (Data a, Data b) => Data (HsArg a b)+-- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs)))+-- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn)))+-- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind GhcTc)))  -- deriving instance (DataIdLR p p) => Data (ConDeclField p) deriving instance Data (ConDeclField GhcPs)@@ -466,7 +523,12 @@ deriving instance Eq (IE GhcRn) deriving instance Eq (IE GhcTc) - -- ---------------------------------------------------------------------  deriving instance Data XXExprGhcTc++-- ---------------------------------------------------------------------++deriving instance Data XViaStrategyPs++-- ---------------------------------------------------------------------

GHC/Hs/Lit.hs view

@@ -1,37 +1,40 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, OutputableBndrId+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -\section[HsLit]{Abstract syntax: source-language literals} -} -{-# LANGUAGE CPP, DeriveDataTypeable #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Hs.Lit where+-- | Source-language literals+module GHC.Hs.Lit+  ( module Language.Haskell.Syntax.Lit+  , module GHC.Hs.Lit+  ) where  #include "HsVersions.h"  import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Expr( HsExpr, pprExpr )-import GHC.Types.Basic-   ( IntegralLit(..), FractionalLit(..), negateIntegralLit-   , negateFractionalLit, SourceText(..), pprWithSourceText-   , PprPrec(..), topPrec )+import {-# SOURCE #-} GHC.Hs.Expr( pprExpr )++import Language.Haskell.Syntax.Lit++import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable-import GHC.Data.FastString+import Language.Haskell.Syntax.Extension import GHC.Hs.Extension -import Data.ByteString (ByteString) import Data.Data hiding ( Fixity )  {-@@ -42,45 +45,6 @@ ************************************************************************ -} --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in--- the following--- Note [Trees that grow] in GHC.Hs.Extension for the Xxxxx fields in the following--- | Haskell Literal-data HsLit x-  = HsChar (XHsChar x) {- SourceText -} Char-      -- ^ Character-  | HsCharPrim (XHsCharPrim x) {- SourceText -} Char-      -- ^ Unboxed character-  | HsString (XHsString x) {- SourceText -} FastString-      -- ^ String-  | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString-      -- ^ Packed bytes-  | HsInt (XHsInt x)  IntegralLit-      -- ^ Genuinely an Int; arises from-      -- "GHC.Tc.Deriv.Generate", and from TRANSLATION-  | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer-      -- ^ literal @Int#@-  | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer-      -- ^ literal @Word#@-  | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer-      -- ^ literal @Int64#@-  | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer-      -- ^ literal @Word64#@-  | HsInteger (XHsInteger x) {- SourceText -} Integer Type-      -- ^ Genuinely an integer; arises only-      -- from TRANSLATION (overloaded-      -- literals are done with HsOverLit)-  | HsRat (XHsRat x)  FractionalLit Type-      -- ^ Genuinely a rational; arises only from-      -- TRANSLATION (overloaded literals are-      -- done with HsOverLit)-  | HsFloatPrim (XHsFloatPrim x)   FractionalLit-      -- ^ Unboxed Float-  | HsDoublePrim (XHsDoublePrim x) FractionalLit-      -- ^ Unboxed Double--  | XLit !(XXLit x)- type instance XHsChar       (GhcPass _) = SourceText type instance XHsCharPrim   (GhcPass _) = SourceText type instance XHsString     (GhcPass _) = SourceText@@ -96,32 +60,6 @@ type instance XHsDoublePrim (GhcPass _) = NoExtField type instance XXLit         (GhcPass _) = NoExtCon -instance Eq (HsLit x) where-  (HsChar _ x1)       == (HsChar _ x2)       = x1==x2-  (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2-  (HsString _ x1)     == (HsString _ x2)     = x1==x2-  (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2-  (HsInt _ x1)        == (HsInt _ x2)        = x1==x2-  (HsIntPrim _ x1)    == (HsIntPrim _ x2)    = x1==x2-  (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2-  (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2-  (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2-  (HsInteger _ x1 _)  == (HsInteger _ x2 _)  = x1==x2-  (HsRat _ x1 _)      == (HsRat _ x2 _)      = x1==x2-  (HsFloatPrim _ x1)  == (HsFloatPrim _ x2)  = x1==x2-  (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2-  _                   == _                   = False---- | Haskell Overloaded Literal-data HsOverLit p-  = OverLit {-      ol_ext :: (XOverLit p),-      ol_val :: OverLitVal,-      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]--  | XOverLit-      !(XXOverLit p)- data OverLitTc   = OverLitTc {         ol_rebindable :: Bool, -- Note [ol_rebindable]@@ -134,20 +72,6 @@  type instance XXOverLit (GhcPass _) = NoExtCon --- Note [Literal source text] in GHC.Types.Basic for SourceText fields in--- the following--- | Overloaded Literal Value-data OverLitVal-  = HsIntegral   !IntegralLit            -- ^ Integer-looking literals;-  | HsFractional !FractionalLit          -- ^ Frac-looking literals-  | HsIsString   !SourceText !FastString -- ^ String-looking literals-  deriving Data--negateOverLitVal :: OverLitVal -> OverLitVal-negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)-negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)-negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"- overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit (OverLitTc _ ty) _ _) = ty @@ -180,52 +104,8 @@   a) RebindableSyntax is on   b) the witness for fromInteger/fromRational/fromString      that happens to be in scope isn't the standard one--Note [Overloaded literal witnesses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-*Before* type checking, the HsExpr in an HsOverLit is the-name of the coercion function, 'fromInteger' or 'fromRational'.-*After* type checking, it is a witness for the literal, such as-        (fromInteger 3) or lit_78-This witness should replace the literal.--This dual role is unusual, because we're replacing 'fromInteger' with-a call to fromInteger.  Reason: it allows commoning up of the fromInteger-calls, which wouldn't be possible if the desugarer made the application.--The PostTcType in each branch records the type the overload literal is-found to have. -} --- Comparison operations are needed when grouping literals--- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)-instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where-  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2-  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2-  _ == _ = panic "Eq HsOverLit"--instance Eq OverLitVal where-  (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2-  (HsFractional f1)   == (HsFractional f2)   = f1 == f2-  (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2-  _                   == _                   = False--instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where-  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2-  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2-  compare _ _ = panic "Ord HsOverLit"--instance Ord OverLitVal where-  compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2-  compare (HsIntegral _)      (HsFractional _)    = LT-  compare (HsIntegral _)      (HsIsString _ _)    = LT-  compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2-  compare (HsFractional _)    (HsIntegral   _)    = GT-  compare (HsFractional _)    (HsIsString _ _)    = LT-  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `compare` s2-  compare (HsIsString _ _)    (HsIntegral   _)    = GT-  compare (HsIsString _ _)    (HsFractional _)    = GT- -- Instance specific to GhcPs, need the SourceText instance Outputable (HsLit (GhcPass p)) where     ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)@@ -253,11 +133,6 @@   ppr (OverLit {ol_val=val, ol_witness=witness})         = ppr val <+> (whenPprDebug (parens (pprExpr witness))) -instance Outputable OverLitVal where-  ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))-  ppr (HsFractional f)   = ppr f-  ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)- -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens@@ -278,34 +153,3 @@ pmPprHsLit (HsRat _ f _)      = ppr f pmPprHsLit (HsFloatPrim _ f)  = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d---- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs--- to be parenthesized under precedence @p@.-hsLitNeedsParens :: PprPrec -> HsLit x -> Bool-hsLitNeedsParens p = go-  where-    go (HsChar {})        = False-    go (HsCharPrim {})    = False-    go (HsString {})      = False-    go (HsStringPrim {})  = False-    go (HsInt _ x)        = p > topPrec && il_neg x-    go (HsIntPrim _ x)    = p > topPrec && x < 0-    go (HsWordPrim {})    = False-    go (HsInt64Prim _ x)  = p > topPrec && x < 0-    go (HsWord64Prim {})  = False-    go (HsInteger _ x _)  = p > topPrec && x < 0-    go (HsRat _ x _)      = p > topPrec && fl_neg x-    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x-    go (HsDoublePrim _ x) = p > topPrec && fl_neg x-    go (XLit _)           = False---- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal--- @ol@ needs to be parenthesized under precedence @p@.-hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool-hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv-  where-    go :: OverLitVal -> Bool-    go (HsIntegral x)   = p > topPrec && il_neg x-    go (HsFractional x) = p > topPrec && fl_neg x-    go (HsIsString {})  = False-hsOverLitNeedsParens _ (XOverLit { }) = False

GHC/Hs/Pat.hs view

@@ -1,4 +1,20 @@ +{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveTraversable    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE ViewPatterns         #-}++{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,25 +22,9 @@ \section[PatSyntax]{Abstract Haskell syntax---patterns} -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns      #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Hs.Pat (         Pat(..), LPat,+        EpAnnSumPat(..),         ConPatTc (..),         CoPat (..),         ListPatTc(..),@@ -47,20 +47,27 @@          collectEvVarsPat, collectEvVarsPats, -        pprParendLPat, pprConArgs+        pprParendLPat, pprConArgs,+        pprLPat     ) where  import GHC.Prelude -import {-# SOURCE #-} GHC.Hs.Expr (SyntaxExpr, LHsExpr, HsSplice, pprLExpr, pprSplice)+import Language.Haskell.Syntax.Pat+import Language.Haskell.Syntax.Expr (HsExpr, SyntaxExpr) +import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice)+ -- friends: import GHC.Hs.Binds import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension+import GHC.Parser.Annotation import GHC.Hs.Extension import GHC.Hs.Type import GHC.Tc.Types.Evidence import GHC.Types.Basic+import GHC.Types.SourceText -- others: import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Builtin.Types@@ -77,183 +84,9 @@ import GHC.Types.Name (Name) import GHC.Driver.Session import qualified GHC.LanguageExtensions as LangExt--- libraries:-import Data.Data hiding (TyCon,Fixity)--type LPat p = XRec p Pat---- | Pattern------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'---- For details on above see note [Api annotations] in GHC.Parser.Annotation-data Pat p-  =     ------------ Simple patterns ----------------    WildPat     (XWildPat p)        -- ^ Wildcard Pattern-        -- The sole reason for a type on a WildPat is to-        -- support hsPatType :: Pat Id -> Type--       -- AZ:TODO above comment needs to be updated-  | VarPat      (XVarPat p)-                (Located (IdP p))  -- ^ Variable Pattern--                             -- See Note [Located RdrNames] in GHC.Hs.Expr-  | LazyPat     (XLazyPat p)-                (LPat p)                -- ^ Lazy Pattern-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | AsPat       (XAsPat p)-                (Located (IdP p)) (LPat p)    -- ^ As pattern-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | ParPat      (XParPat p)-                (LPat p)                -- ^ Parenthesised pattern-                                        -- See Note [Parens in HsSyn] in GHC.Hs.Expr-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-    --                                    'GHC.Parser.Annotation.AnnClose' @')'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | BangPat     (XBangPat p)-                (LPat p)                -- ^ Bang pattern-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--        ------------ Lists, tuples, arrays ----------------  | ListPat     (XListPat p)-                [LPat p]-                   -- For OverloadedLists a Just (ty,fn) gives-                   -- overall type of the pattern, and the toList--- function to convert the scrutinee to a list value--    -- ^ Syntactic List-    ---    -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-    --                                    'GHC.Parser.Annotation.AnnClose' @']'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | TuplePat    (XTuplePat p)-                  -- after typechecking, holds the types of the tuple components-                [LPat p]         -- Tuple sub-patterns-                Boxity           -- UnitPat is TuplePat []-        -- You might think that the post typechecking Type was redundant,-        -- because we can get the pattern type by getting the types of the-        -- sub-patterns.-        -- But it's essential-        --      data T a where-        --        T1 :: Int -> T Int-        --      f :: (T a, a) -> Int-        --      f (T1 x, z) = z-        -- When desugaring, we must generate-        --      f = /\a. \v::a.  case v of (t::T a, w::a) ->-        --                       case t of (T1 (x::Int)) ->-        -- Note the (w::a), NOT (w::Int), because we have not yet-        -- refined 'a' to Int.  So we must know that the second component-        -- of the tuple is of type 'a' not Int.  See selectMatchVar-        -- (June 14: I'm not sure this comment is right; the sub-patterns-        --           will be wrapped in CoPats, no?)-    -- ^ Tuple sub-patterns-    ---    -- - 'GHC.Parser.Annotation.AnnKeywordId' :-    --            'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@,-    --            'GHC.Parser.Annotation.AnnClose' @')'@ or  @'#)'@--  | SumPat      (XSumPat p)        -- after typechecker, types of the alternative-                (LPat p)           -- Sum sub-pattern-                ConTag             -- Alternative (one-based)-                Arity              -- Arity (INVARIANT: ≥ 2)-    -- ^ Anonymous sum pattern-    ---    -- - 'GHC.Parser.Annotation.AnnKeywordId' :-    --            'GHC.Parser.Annotation.AnnOpen' @'(#'@,-    --            'GHC.Parser.Annotation.AnnClose' @'#)'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--        ------------ Constructor patterns ----------------  | ConPat {-        pat_con_ext :: XConPat p,-        pat_con     :: Located (ConLikeP p),-        pat_args    :: HsConPatDetails p-    }-    -- ^ Constructor Pattern--        ------------ View patterns ----------------  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | ViewPat       (XViewPat p)     -- The overall type of the pattern-                                   -- (= the argument type of the view function)-                                   -- for hsPatType.-                  (LHsExpr p)-                  (LPat p)-    -- ^ View Pattern--        ------------ Pattern splices ----------------  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@-  --        'GHC.Parser.Annotation.AnnClose' @')'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | SplicePat       (XSplicePat p)-                    (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)--        ------------ Literal and n+k patterns ----------------  | LitPat          (XLitPat p)-                    (HsLit p)           -- ^ Literal Pattern-                                        -- Used for *non-overloaded* literal patterns:-                                        -- Int#, Char#, Int, Char, String, etc.--  | NPat                -- Natural Pattern-                        -- Used for all overloaded literals,-                        -- including overloaded strings with -XOverloadedStrings-                    (XNPat p)            -- Overall type of pattern. Might be-                                         -- different than the literal's type-                                         -- if (==) or negate changes the type-                    (Located (HsOverLit p))     -- ALWAYS positive-                    (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for-                                           -- negative patterns, Nothing-                                           -- otherwise-                    (SyntaxExpr p)       -- Equality checker, of type t->t->Bool--  -- ^ Natural Pattern-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern-                    (Located (IdP p))        -- n+k pattern-                    (Located (HsOverLit p))  -- It'll always be an HsIntegral-                    (HsOverLit p)            -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat-                     -- NB: This could be (PostTc ...), but that induced a-                     -- a new hs-boot file. Not worth it.--                    (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool-                    (SyntaxExpr p)   -- Name of '-' (see GHC.Rename.Env.lookupSyntax)-  -- ^ n+k pattern--        ------------ Pattern type signatures ----------------  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'--  -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | SigPat          (XSigPat p)             -- After typechecker: Type-                    (LPat p)                -- Pattern with a type signature-                    (HsPatSigType (NoGhcTc p)) --  Signature can bind both-                                               --  kind and type vars--    -- ^ Pattern with a type signature--  -- | Trees that Grow extension point for new constructors-  | XPat-      !(XXPat p)+import Data.Data  --- ---------------------------------------------------------------------- data ListPatTc   = ListPatTc       Type                             -- The type of the elements@@ -264,46 +97,56 @@ type instance XWildPat GhcTc = Type  type instance XVarPat  (GhcPass _) = NoExtField-type instance XLazyPat (GhcPass _) = NoExtField-type instance XAsPat   (GhcPass _) = NoExtField-type instance XParPat  (GhcPass _) = NoExtField-type instance XBangPat (GhcPass _) = NoExtField +type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~'+type instance XLazyPat GhcRn = NoExtField+type instance XLazyPat GhcTc = NoExtField++type instance XAsPat   GhcPs = EpAnn [AddEpAnn] -- For '@'+type instance XAsPat   GhcRn = NoExtField+type instance XAsPat   GhcTc = NoExtField++type instance XParPat  (GhcPass _) = EpAnn AnnParen++type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'+type instance XBangPat GhcRn = NoExtField+type instance XBangPat GhcTc = NoExtField+ -- Note: XListPat cannot be extended when using GHC 8.0.2 as the bootstrap -- compiler, as it triggers https://gitlab.haskell.org/ghc/ghc/issues/14396 for -- `SyntaxExpr`-type instance XListPat GhcPs = NoExtField+type instance XListPat GhcPs = EpAnn AnnList type instance XListPat GhcRn = Maybe (SyntaxExpr GhcRn) type instance XListPat GhcTc = ListPatTc -type instance XTuplePat GhcPs = NoExtField+type instance XTuplePat GhcPs = EpAnn [AddEpAnn] type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XConPat GhcPs = NoExtField-type instance XConPat GhcRn = NoExtField-type instance XConPat GhcTc = ConPatTc--type instance XSumPat GhcPs = NoExtField+type instance XSumPat GhcPs = EpAnn EpAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XViewPat GhcPs = NoExtField+type instance XConPat GhcPs = EpAnn [AddEpAnn]+type instance XConPat GhcRn = NoExtField+type instance XConPat GhcTc = ConPatTc++type instance XViewPat GhcPs = EpAnn [AddEpAnn] type instance XViewPat GhcRn = NoExtField type instance XViewPat GhcTc = Type  type instance XSplicePat (GhcPass _) = NoExtField type instance XLitPat    (GhcPass _) = NoExtField -type instance XNPat GhcPs = NoExtField-type instance XNPat GhcRn = NoExtField+type instance XNPat GhcPs = EpAnn [AddEpAnn]+type instance XNPat GhcRn = EpAnn [AddEpAnn] type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = NoExtField+type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = NoExtField+type instance XSigPat GhcPs = EpAnn [AddEpAnn] type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type @@ -312,22 +155,23 @@ type instance XXPat GhcTc = CoPat   -- After typechecking, we add one extra constructor: CoPat -type family ConLikeP x- type instance ConLikeP GhcPs = RdrName -- IdP GhcPs-type instance ConLikeP GhcRn = Name -- IdP GhcRn+type instance ConLikeP GhcRn = Name    -- IdP GhcRn type instance ConLikeP GhcTc = ConLike +type instance XHsRecField _ = EpAnn [AddEpAnn]+ -- --------------------------------------------------------------------- +-- API Annotations types --- | Haskell Constructor Pattern Details-type HsConPatDetails p = HsConDetails (LPat p) (HsRecFields p (LPat p))+data EpAnnSumPat = EpAnnSumPat+      { sumPatParens      :: [AddEpAnn]+      , sumPatVbarsBefore :: [EpaLocation]+      , sumPatVbarsAfter  :: [EpaLocation]+      } deriving Data -hsConPatArgs :: HsConPatDetails p -> [LPat p]-hsConPatArgs (PrefixCon ps)   = ps-hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unLoc) (rec_flds fs)-hsConPatArgs (InfixCon p1 p2) = [p1,p2]+-- ---------------------------------------------------------------------  -- | This is the extension field for ConPat, added after typechecking -- It adds quite a few extra fields, to support elaboration of pattern matching.@@ -375,123 +219,6 @@       co_pat_ty :: Type     } --- | Haskell Record Fields------ HsRecFields is used only for patterns and expressions (not data type--- declarations)-data HsRecFields p arg         -- A bunch of record fields-                                --      { x = 3, y = True }-        -- Used for both expressions and patterns-  = HsRecFields { rec_flds   :: [LHsRecField p arg],-                  rec_dotdot :: Maybe (Located Int) }  -- Note [DotDot fields]-  deriving (Functor, Foldable, Traversable)----- Note [DotDot fields]--- ~~~~~~~~~~~~~~~~~~~~--- The rec_dotdot field means this:---   Nothing => the normal case---   Just n  => the group uses ".." notation,------ In the latter case:------   *before* renamer: rec_flds are exactly the n user-written fields------   *after* renamer:  rec_flds includes *all* fields, with---                     the first 'n' being the user-written ones---                     and the remainder being 'filled in' implicitly---- | Located Haskell Record Field-type LHsRecField' p arg = Located (HsRecField' p arg)---- | Located Haskell Record Field-type LHsRecField  p arg = Located (HsRecField  p arg)---- | Located Haskell Record Update Field-type LHsRecUpdField p   = Located (HsRecUpdField p)---- | Haskell Record Field-type HsRecField    p arg = HsRecField' (FieldOcc p) arg---- | Haskell Record Update Field-type HsRecUpdField p     = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)---- | Haskell Record Field------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual',------ For details on above see note [Api annotations] in GHC.Parser.Annotation-data HsRecField' id arg = HsRecField {-        hsRecFieldLbl :: Located id,-        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning-        hsRecPun      :: Bool           -- ^ Note [Punning]-  } deriving (Data, Functor, Foldable, Traversable)----- Note [Punning]--- ~~~~~~~~~~~~~~--- If you write T { x, y = v+1 }, the HsRecFields will be---      HsRecField x x True ...---      HsRecField y (v+1) False ...--- That is, for "punned" field x is expanded (in the renamer)--- to x=x; but with a punning flag so we can detect it later--- (e.g. when pretty printing)------ If the original field was qualified, we un-qualify it, thus---    T { A.x } means T { A.x = x }----- Note [HsRecField and HsRecUpdField]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- A HsRecField (used for record construction and pattern matching)--- contains an unambiguous occurrence of a field (i.e. a FieldOcc).--- We can't just store the Name, because thanks to--- DuplicateRecordFields this may not correspond to the label the user--- wrote.------ A HsRecUpdField (used for record update) contains a potentially--- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The--- renamer will fill in the selector function if it can, but if the--- selector is ambiguous the renamer will defer to the typechecker.--- After the typechecker, a unique selector will have been determined.------ The renamer produces an Unambiguous result if it can, rather than--- just doing the lookup in the typechecker, so that completely--- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'.------ For example, suppose we have:------     data S = MkS { x :: Int }---     data T = MkT { x :: Int }------     f z = (z { x = 3 }) :: S------ The parsed HsRecUpdField corresponding to the record update will have:------     hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName------ After the renamer, this will become:------     hsRecFieldLbl = Ambiguous   "x" noExtField :: AmbiguousFieldOcc Name------ (note that the Unambiguous constructor is not type-correct here).--- The typechecker will determine the particular selector:------     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id------ See also Note [Disambiguating record fields] in GHC.Tc.Gen.Expr.--hsRecFields :: HsRecFields p arg -> [XCFieldOcc p]-hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)---- Probably won't typecheck at once, things have changed :/-hsRecFieldsArgs :: HsRecFields p arg -> [arg]-hsRecFieldsArgs rbinds = map (hsRecFieldArg . unLoc) (rec_flds rbinds)--hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)-hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl- hsRecFieldId :: HsRecField GhcTc arg -> Located Id hsRecFieldId = hsRecFieldSel @@ -516,6 +243,9 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where     ppr = pprPat +pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc+pprLPat (L _ e) = pprPat e+ -- | Print with type info if -dppr-debug is on pprPatBndr :: OutputableBndr name => name -> SDoc pprPatBndr var@@ -562,13 +292,13 @@ pprPat (LitPat _ s)             = ppr s pprPat (NPat _ l Nothing  _)    = ppr l pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l-pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr n, char '+', ppr k]+pprPat (NPlusKPat _ n k _ _ _)  = hcat [ppr_n, char '+', ppr k]+  where ppr_n = case ghcPass @p of+                  GhcPs -> ppr n+                  GhcRn -> ppr n+                  GhcTc -> ppr n pprPat (SplicePat _ splice)     = pprSplice splice-pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr_ty-  where ppr_ty = case ghcPass @p of-                   GhcPs -> ppr ty-                   GhcRn -> ppr ty-                   GhcTc -> ppr ty+pprPat (SigPat _ pat ty)        = ppr pat <+> dcolon <+> ppr ty pprPat (ListPat _ pats)         = brackets (interpp'SP pats) pprPat (TuplePat _ pats bx)     -- Special-case unary boxed tuples so that they are pretty-printed as@@ -600,6 +330,7 @@                        , cpt_dicts = dicts                        , cpt_binds = binds                        } = ext+ pprPat (XPat ext) = case ghcPass @p of #if __GLASGOW_HASKELL__ < 811   GhcPs -> noExtCon ext@@ -611,33 +342,20 @@       else pprPat pat     where CoPat co pat _ = ext -pprUserCon :: (OutputableBndr con, OutputableBndrId p)+pprUserCon :: (OutputableBndr con, OutputableBndrId p,+                     Outputable (Anno (IdGhcP p)))            => con -> HsConPatDetails (GhcPass p) -> SDoc pprUserCon c (InfixCon p1 p2) = ppr p1 <+> pprInfixOcc c <+> ppr p2 pprUserCon c details          = pprPrefixOcc c <+> pprConArgs details -pprConArgs :: (OutputableBndrId p)+pprConArgs :: (OutputableBndrId p,+                     Outputable (Anno (IdGhcP p)))            => HsConPatDetails (GhcPass p) -> SDoc-pprConArgs (PrefixCon pats) = fsep (map (pprParendLPat appPrec) pats)-pprConArgs (InfixCon p1 p2) = sep [ pprParendLPat appPrec p1-                                  , pprParendLPat appPrec p2 ]-pprConArgs (RecCon rpats)   = ppr rpats--instance (Outputable arg)-      => Outputable (HsRecFields p arg) where-  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })-        = braces (fsep (punctuate comma (map ppr flds)))-  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })-        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))-        where-          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))--instance (Outputable p, Outputable arg)-      => Outputable (HsRecField' p arg) where-  ppr (HsRecField { hsRecFieldLbl = f, hsRecFieldArg = arg,-                    hsRecPun = pun })-    = ppr f <+> (ppUnless pun $ equals <+> ppr arg)-+pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)+  where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)+pprConArgs (InfixCon p1 p2)    = sep [ pprParendLPat appPrec p1+                                     , pprParendLPat appPrec p2 ]+pprConArgs (RecCon rpats)      = ppr rpats  {- ************************************************************************@@ -651,23 +369,23 @@                   [LPat GhcTc] -> [Type] -> LPat GhcTc -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys-  = noLoc $ ConPat { pat_con = noLoc (RealDataCon dc)-                   , pat_args = PrefixCon pats-                   , pat_con_ext = ConPatTc-                     { cpt_tvs = []-                     , cpt_dicts = []-                     , cpt_binds = emptyTcEvBinds-                     , cpt_arg_tys = tys-                     , cpt_wrap = idHsWrapper-                     }-                   }+  = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)+                    , pat_args = PrefixCon [] pats+                    , pat_con_ext = ConPatTc+                      { cpt_tvs = []+                      , cpt_dicts = []+                      , cpt_binds = emptyTcEvBinds+                      , cpt_arg_tys = tys+                      , cpt_wrap = idHsWrapper+                      }+                    }  mkNilPat :: Type -> LPat GhcTc mkNilPat ty = mkPrefixConPat nilDataCon [] [ty]  mkCharLitPat :: SourceText -> Char -> LPat GhcTc mkCharLitPat src c = mkPrefixConPat charDataCon-                          [noLoc $ LitPat noExtField (HsCharPrim src c)] []+                          [noLocA $ LitPat noExtField (HsCharPrim src c)] []  {- ************************************************************************@@ -812,8 +530,6 @@          L _ (PatSynCon _pat)  -> False -- Conservative          L _ (RealDataCon con) ->            isJust (tyConSingleDataCon_maybe (dataConTyCon con))-           -- NB: tyConSingleDataCon_maybe, *not* isProductTyCon, because-           -- the latter is false of existentials. See #4439            && all goL (hsConPatArgs details)     go (LitPat {})         = False     go (NPat {})           = False@@ -878,13 +594,15 @@     go :: Pat (GhcPass p) -> Bool     go (NPlusKPat {})    = p > opPrec     go (SplicePat {})    = False-    go (ConPat { pat_args = ds})+    go (ConPat { pat_args = ds })                          = conPatNeedsParens p ds     go (SigPat {})       = p >= sigPrec     go (ViewPat {})      = True     go (XPat ext)        = case ghcPass @p of+#if __GLASGOW_HASKELL__ < 901       GhcPs -> noExtCon ext       GhcRn -> noExtCon ext+#endif       GhcTc -> go inner         where CoPat _ inner _ = ext     go (WildPat {})      = False@@ -893,7 +611,12 @@     go (BangPat {})      = False     go (ParPat {})       = False     go (AsPat {})        = False-    go (TuplePat {})     = False+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go (TuplePat _ [_] Boxed)+                         = p >= appPrec+    go (TuplePat{})      = False     go (SumPat {})       = False     go (ListPat {})      = False     go (LitPat _ l)      = hsLitNeedsParens p l@@ -901,12 +624,12 @@  -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@.-conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool+conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool conPatNeedsParens p = go   where-    go (PrefixCon args) = p >= appPrec && not (null args)-    go (InfixCon {})    = p >= opPrec-    go (RecCon {})      = False+    go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))+    go (InfixCon {})       = p >= opPrec -- type args should be empty in this case+    go (RecCon {})         = False  -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.@@ -915,7 +638,7 @@                 -> LPat (GhcPass p)                 -> LPat (GhcPass p) parenthesizePat p lpat@(L loc pat)-  | patNeedsParens p pat = L loc (ParPat noExtField lpat)+  | patNeedsParens p pat = L loc (ParPat noAnn lpat)   | otherwise            = lpat  {-@@ -952,3 +675,24 @@     SigPat  _ p _    -> collectEvVarsLPat p     XPat (CoPat _ p _) -> collectEvVarsPat  p     _other_pat       -> emptyBag++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsOverLit (GhcPass p)) = SrcSpan+type instance Anno ConLike = SrcSpanAnnN++type instance Anno (HsRecField' p arg) = SrcSpanAnnA+type instance Anno (HsRecField' (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA+type instance Anno (HsRecField  (GhcPass p) arg) = SrcSpanAnnA++-- type instance Anno (HsRecUpdField p) = SrcSpanAnnA+type instance Anno (HsRecField' (AmbiguousFieldOcc p) (LocatedA (HsExpr p))) = SrcSpanAnnA++type instance Anno (AmbiguousFieldOcc GhcTc) = SrcSpanAnnA

GHC/Hs/Pat.hs-boot view

@@ -1,20 +1,17 @@-{-# LANGUAGE CPP, KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE RoleAnnotations #-}-{-# LANGUAGE TypeFamilies #-}+                                      -- in module Language.Haskell.Syntax.Extension +{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+ module GHC.Hs.Pat where  import GHC.Utils.Outputable-import GHC.Hs.Extension ( OutputableBndrId, GhcPass, XRec )-import Data.Kind+import GHC.Hs.Extension ( OutputableBndrId, GhcPass ) -type role Pat nominal-data Pat (i :: Type)-type LPat i = XRec i Pat+import Language.Haskell.Syntax.Pat -instance OutputableBndrId p => Outputable (Pat (GhcPass p))+instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))++pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc

GHC/Hs/Stats.hs view

@@ -1,22 +1,23 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+ -- | -- Statistics for per-module compilations -- -- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -- -{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.Hs.Stats ( ppSourceStats ) where  import GHC.Prelude  import GHC.Data.Bag import GHC.Hs-import GHC.Utils.Outputable import GHC.Types.SrcLoc++import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic  import Data.Char @@ -136,7 +137,7 @@      data_info (DataDecl { tcdDataDefn = HsDataDefn                                           { dd_cons = cs-                                          , dd_derivs = L _ derivs}})+                                          , dd_derivs = derivs}})         = ( length cs           , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)                    0 derivs )

GHC/Hs/Type.hs view

@@ -1,2084 +1,1246 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---GHC.Hs.Type: Abstract syntax: user-defined types--}--{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ViewPatterns #-}--module GHC.Hs.Type (-        Mult, HsScaled(..),-        hsMult, hsScaledThing,-        HsArrow(..), arrowToHsType,-        hsLinear, hsUnrestricted, isUnrestricted,--        HsType(..), NewHsTypeX(..), LHsType, HsKind, LHsKind,-        HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,-        LHsQTyVars(..),-        HsImplicitBndrs(..),-        HsWildCardBndrs(..),-        HsPatSigType(..), HsPSRn(..),-        LHsSigType, LHsSigWcType, LHsWcType,-        HsTupleSort(..),-        HsContext, LHsContext, noLHsContext,-        HsTyLit(..),-        HsIPName(..), hsIPNameFS,-        HsArg(..), numVisibleArgs,-        LHsTypeArg, lhsTypeArgSrcSpan,-        OutputableBndrFlag,--        LBangType, BangType,-        HsSrcBang(..), HsImplBang(..),-        SrcStrictness(..), SrcUnpackedness(..),-        getBangType, getBangStrictness,--        ConDeclField(..), LConDeclField, pprConDeclFields,--        HsConDetails(..),--        FieldOcc(..), LFieldOcc, mkFieldOcc,-        AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,-        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,-        unambiguousFieldOcc, ambiguousFieldOcc,--        mkAnonWildCardTy, pprAnonWildCard,--        mkHsImplicitBndrs, mkHsWildCardBndrs, mkHsPatSigType, hsImplicitBody,-        mkEmptyImplicitBndrs, mkEmptyWildCardBndrs,-        mkHsForAllVisTele, mkHsForAllInvisTele,-        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,-        isHsKindedTyVar, hsTvbAllKinded, isLHsForAllTy,-        hsScopedTvs, hsWcScopedTvs, dropWildCards,-        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,-        splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,-        splitLHsPatSynTy,-        splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,-        splitLHsSigmaTyInvis, splitLHsGadtTy,-        splitHsFunType, hsTyGetAppHead_maybe,-        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,-        ignoreParens, hsSigType, hsSigWcType, hsPatSigType,-        hsTyKindSig,-        hsConDetailsArgs,-        setHsTyVarBndrFlag, hsTyVarBndrFlag,--        -- Printing-        pprHsType, pprHsForAll, pprHsExplicitForAll,-        pprLHsContext,-        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext-    ) where--#include "HsVersions.h"--import GHC.Prelude--import {-# SOURCE #-} GHC.Hs.Expr ( HsSplice, pprSplice )--import GHC.Hs.Extension--import GHC.Types.Id ( Id )-import GHC.Types.Name( Name, NamedThing(getName) )-import GHC.Types.Name.Reader ( RdrName )-import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),-                         SrcStrictness(..), SrcUnpackedness(..) )-import GHC.Core.TyCo.Rep ( Type(..) )-import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )-import GHC.Core.Type-import GHC.Hs.Doc-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Utils.Misc ( count )--import Data.Data hiding ( Fixity, Prefix, Infix )-import Data.Maybe-import GHC.Parser.Annotation--{--************************************************************************-*                                                                      *-\subsection{Bang annotations}-*                                                                      *-************************************************************************--}---- | Located Bang Type-type LBangType pass = Located (BangType pass)---- | Bang Type------ In the parser, strictness and packedness annotations bind more tightly--- than docstrings. This means that when consuming a 'BangType' (and looking--- for 'HsBangTy') we must be ready to peer behind a potential layer of--- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.-type BangType pass  = HsType pass       -- Bangs are in the HsType data type--getBangType :: LHsType a -> LHsType a-getBangType                 (L _ (HsBangTy _ _ lty))       = lty-getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =-  addCLoc lty lds (HsDocTy x lty lds)-getBangType lty                                            = lty--getBangStrictness :: LHsType a -> HsSrcBang-getBangStrictness                 (L _ (HsBangTy _ s _))     = s-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s-getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)--{--************************************************************************-*                                                                      *-\subsection{Data types}-*                                                                      *-************************************************************************--This is the syntax for types as seen in type signatures.--Note [HsBSig binder lists]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a binder (or pattern) decorated with a type or kind,-   \ (x :: a -> a). blah-   forall (a :: k -> *) (b :: k). blah-Then we use a LHsBndrSig on the binder, so that the-renamer can decorate it with the variables bound-by the pattern ('a' in the first example, 'k' in the second),-assuming that neither of them is in scope already-See also Note [Kind and type-variable binders] in GHC.Rename.HsType--Note [HsType binders]-~~~~~~~~~~~~~~~~~~~~~-The system for recording type and kind-variable binders in HsTypes-is a bit complicated.  Here's how it works.--* In a HsType,-     HsForAllTy   represents an /explicit, user-written/ 'forall'-                   e.g.   forall a b.   {...} or-                          forall a b -> {...}-     HsQualTy     represents an /explicit, user-written/ context-                   e.g.   (Eq a, Show a) => ...-                  The context can be empty if that's what the user wrote-  These constructors represent what the user wrote, no more-  and no less.--* The ForAllTelescope field of HsForAllTy represents whether a forall is-  invisible (e.g., forall a b. {...}, with a dot) or visible-  (e.g., forall a b -> {...}, with an arrow).--* HsTyVarBndr describes a quantified type variable written by the-  user.  For example-     f :: forall a (b :: *).  blah-  here 'a' and '(b::*)' are each a HsTyVarBndr.  A HsForAllTy has-  a list of LHsTyVarBndrs.--* HsImplicitBndrs is a wrapper that gives the implicitly-quantified-  kind and type variables of the wrapped thing.  It is filled in by-  the renamer. For example, if the user writes-     f :: a -> a-  the HsImplicitBinders binds the 'a' (not a HsForAllTy!).-  NB: this implicit quantification is purely lexical: we bind any-      type or kind variables that are not in scope. The type checker-      may subsequently quantify over further kind variables.--* HsWildCardBndrs is a wrapper that binds the wildcard variables-  of the wrapped thing.  It is filled in by the renamer-     f :: _a -> _-  The enclosing HsWildCardBndrs binds the wildcards _a and _.--* HsSigPatType describes types that appear in pattern signatures and-  the signatures of term-level binders in RULES. Like-  HsWildCardBndrs/HsImplicitBndrs, they track the names of wildcard-  variables and implicitly bound type variables. Unlike-  HsImplicitBndrs, however, HsSigPatTypes do not obey the-  forall-or-nothing rule. See Note [Pattern signature binders and scoping].--* The explicit presence of these wrappers specifies, in the HsSyn,-  exactly where implicit quantification is allowed, and where-  wildcards are allowed.--* LHsQTyVars is used in data/class declarations, where the user gives-  explicit *type* variable bindings, but we need to implicitly bind-  *kind* variables.  For example-      class C (a :: k -> *) where ...-  The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars--Note [The wildcard story for types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Types can have wildcards in them, to support partial type signatures,-like       f :: Int -> (_ , _a) -> _a--A wildcard in a type can be--  * An anonymous wildcard,-        written '_'-    In HsType this is represented by HsWildCardTy.-    The renamer leaves it untouched, and it is later given a fresh-    meta tyvar in the typechecker.--  * A named wildcard,-        written '_a', '_foo', etc-    In HsType this is represented by (HsTyVar "_a")-    i.e. a perfectly ordinary type variable that happens-         to start with an underscore--Note carefully:--* When NamedWildCards is off, type variables that start with an-  underscore really /are/ ordinary type variables.  And indeed, even-  when NamedWildCards is on you can bind _a explicitly as an ordinary-  type variable:-        data T _a _b = MkT _b _a-  Or even:-        f :: forall _a. _a -> _b-  Here _a is an ordinary forall'd binder, but (With NamedWildCards)-  _b is a named wildcard.  (See the comments in #10982)--* Named wildcards are bound by the HsWildCardBndrs (for types that obey the-  forall-or-nothing rule) and HsPatSigType (for type signatures in patterns-  and term-level binders in RULES), which wrap types that are allowed to have-  wildcards. Unnamed wildcards, however are left unchanged until typechecking,-  where we give them fresh wild tyvars and determine whether or not to emit-  hole constraints on each wildcard (we don't if it's a visible type/kind-  argument or a type family pattern). See related notes-  Note [Wildcards in visible kind application] and-  Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType.--* After type checking is done, we report what types the wildcards-  got unified with.--Note [Ordering of implicit variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the advent of -XTypeApplications, GHC makes promises about the ordering-of implicit variable quantification. Specifically, we offer that implicitly-quantified variables (such as those in const :: a -> b -> a, without a `forall`)-will occur in left-to-right order of first occurrence. Here are a few examples:--  const :: a -> b -> a       -- forall a b. ...-  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included--  type a <-< b = b -> a-  g :: a <-< b               -- forall a b. ...  type synonyms matter--  class Functor f where-    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...-    -- The f is quantified by the class, so only a and b are considered in fmap--This simple story is complicated by the possibility of dependency: all variables-must come after any variables mentioned in their kinds.--  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...--The k comes first because a depends on k, even though the k appears later than-the a in the code. Thus, GHC does a *stable topological sort* on the variables.-By "stable", we mean that any two variables who do not depend on each other-preserve their existing left-to-right ordering.--Implicitly bound variables are collected by the extract- family of functions-(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in GHC.Rename.HsType.-These functions thus promise to keep left-to-right ordering.-Look for pointers to this note to see the places where the action happens.--Note that we also maintain this ordering in kind signatures. Even though-there's no visible kind application (yet), having implicit variables be-quantified in left-to-right order in kind signatures is nice since:--* It's consistent with the treatment for type signatures.-* It can affect how types are displayed with -fprint-explicit-kinds (see-  #15568 for an example), which is a situation where knowing the order in-  which implicit variables are quantified can be useful.-* In the event that visible kind application is implemented, the order in-  which we would expect implicit variables to be ordered in kinds will have-  already been established.--}---- | Located Haskell Context-type LHsContext pass = Located (HsContext pass)-      -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit'-      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--noLHsContext :: LHsContext pass--- Use this when there is no context in the original program--- It would really be more kosher to use a Maybe, to distinguish---     class () => C a where ...--- from---     class C a where ...-noLHsContext = noLoc []---- | Haskell Context-type HsContext pass = [LHsType pass]---- | Located Haskell Type-type LHsType pass = Located (HsType pass)-      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when-      --   in a list--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | Haskell Kind-type HsKind pass = HsType pass---- | Located Haskell Kind-type LHsKind pass = Located (HsKind pass)-      -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-------------------------------------------------------             LHsQTyVars---  The explicitly-quantified binders in a data/type declaration---- | The type variable binders in an 'HsForAllTy'.--- See also @Note [Variable Specificity and Forall Visibility]@ in--- "GHC.Tc.Gen.HsType".-data HsForAllTelescope pass-  = HsForAllVis -- ^ A visible @forall@ (e.g., @forall a -> {...}@).-                --   These do not have any notion of specificity, so we use-                --   '()' as a placeholder value.-    { hsf_xvis      :: XHsForAllVis pass-    , hsf_vis_bndrs :: [LHsTyVarBndr () pass]-    }-  | HsForAllInvis -- ^ An invisible @forall@ (e.g., @forall a {b} c -> {...}@),-                  --   where each binder has a 'Specificity'.-    { hsf_xinvis       :: XHsForAllInvis pass-    , hsf_invis_bndrs  :: [LHsTyVarBndr Specificity pass]-    }-  | XHsForAllTelescope !(XXHsForAllTelescope pass)--type instance XHsForAllVis   (GhcPass _) = NoExtField-type instance XHsForAllInvis (GhcPass _) = NoExtField--type instance XXHsForAllTelescope (GhcPass _) = NoExtCon---- | Located Haskell Type Variable Binder-type LHsTyVarBndr flag pass = Located (HsTyVarBndr flag pass)-                         -- See Note [HsType binders]---- | Located Haskell Quantified Type Variables-data LHsQTyVars pass   -- See Note [HsType binders]-  = HsQTvs { hsq_ext :: XHsQTvs pass--           , hsq_explicit :: [LHsTyVarBndr () pass]-                -- Explicit variables, written by the user-    }-  | XLHsQTyVars !(XXLHsQTyVars pass)--type HsQTvsRn = [Name]  -- Implicit variables-  -- For example, in   data T (a :: k1 -> k2) = ...-  -- the 'a' is explicit while 'k1', 'k2' are implicit--type instance XHsQTvs GhcPs = NoExtField-type instance XHsQTvs GhcRn = HsQTvsRn-type instance XHsQTvs GhcTc = HsQTvsRn--type instance XXLHsQTyVars  (GhcPass _) = NoExtCon--mkHsForAllVisTele ::-  [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)-mkHsForAllVisTele vis_bndrs =-  HsForAllVis { hsf_xvis = noExtField, hsf_vis_bndrs = vis_bndrs }--mkHsForAllInvisTele ::-  [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)-mkHsForAllInvisTele invis_bndrs =-  HsForAllInvis { hsf_xinvis = noExtField, hsf_invis_bndrs = invis_bndrs }--mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs-mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }--hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass]-hsQTvExplicit = hsq_explicit--emptyLHsQTvs :: LHsQTyVars GhcRn-emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }-----------------------------------------------------            HsImplicitBndrs--- Used to quantify the implicit binders of a type---    * Implicit binders of a type signature (LHsSigType/LHsSigWcType)---    * Patterns in a type/data family instance (HsTyPats)---- | Haskell Implicit Binders-data HsImplicitBndrs pass thing   -- See Note [HsType binders]-  = HsIB { hsib_ext  :: XHsIB pass thing -- after renamer: [Name]-                                         -- Implicitly-bound kind & type vars-                                         -- Order is important; see-                                         -- Note [Ordering of implicit variables]-                                         -- in GHC.Rename.HsType--         , hsib_body :: thing            -- Main payload (type or list of types)-    }-  | XHsImplicitBndrs !(XXHsImplicitBndrs pass thing)--type instance XHsIB              GhcPs _ = NoExtField-type instance XHsIB              GhcRn _ = [Name]-type instance XHsIB              GhcTc _ = [Name]--type instance XXHsImplicitBndrs  (GhcPass _) _ = NoExtCon---- | Haskell Wildcard Binders-data HsWildCardBndrs pass thing-    -- See Note [HsType binders]-    -- See Note [The wildcard story for types]-  = HsWC { hswc_ext :: XHsWC pass thing-                -- after the renamer-                -- Wild cards, only named-                -- See Note [Wildcards in visible kind application]--         , hswc_body :: thing-                -- Main payload (type or list of types)-                -- If there is an extra-constraints wildcard,-                -- it's still there in the hsc_body.-    }-  | XHsWildCardBndrs !(XXHsWildCardBndrs pass thing)--type instance XHsWC              GhcPs b = NoExtField-type instance XHsWC              GhcRn b = [Name]-type instance XHsWC              GhcTc b = [Name]--type instance XXHsWildCardBndrs  (GhcPass _) b = NoExtCon---- | Types that can appear in pattern signatures, as well as the signatures for--- term-level binders in RULES.--- See @Note [Pattern signature binders and scoping]@.------ This is very similar to 'HsSigWcType', but with--- slightly different semantics: see @Note [HsType binders]@.--- See also @Note [The wildcard story for types]@.-data HsPatSigType pass-  = HsPS { hsps_ext  :: XHsPS pass   -- ^ After renamer: 'HsPSRn'-         , hsps_body :: LHsType pass -- ^ Main payload (the type itself)-    }-  | XHsPatSigType !(XXHsPatSigType pass)---- | The extension field for 'HsPatSigType', which is only used in the--- renamer onwards. See @Note [Pattern signature binders and scoping]@.-data HsPSRn = HsPSRn-  { hsps_nwcs    :: [Name] -- ^ Wildcard names-  , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names-  }-  deriving Data--type instance XHsPS GhcPs = NoExtField-type instance XHsPS GhcRn = HsPSRn-type instance XHsPS GhcTc = HsPSRn--type instance XXHsPatSigType (GhcPass _) = NoExtCon---- | Located Haskell Signature Type-type LHsSigType   pass = HsImplicitBndrs pass (LHsType pass)    -- Implicit only---- | Located Haskell Wildcard Type-type LHsWcType    pass = HsWildCardBndrs pass (LHsType pass)    -- Wildcard only---- | Located Haskell Signature Wildcard Type-type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both---- See Note [Representing type signatures]--hsImplicitBody :: HsImplicitBndrs (GhcPass p) thing -> thing-hsImplicitBody (HsIB { hsib_body = body }) = body--hsSigType :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)-hsSigType = hsImplicitBody--hsSigWcType :: LHsSigWcType pass -> LHsType pass-hsSigWcType sig_ty = hsib_body (hswc_body sig_ty)--hsPatSigType :: HsPatSigType pass -> LHsType pass-hsPatSigType = hsps_body--dropWildCards :: LHsSigWcType pass -> LHsSigType pass--- Drop the wildcard part of a LHsSigWcType-dropWildCards sig_ty = hswc_body sig_ty--{- Note [Representing type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-HsSigType is used to represent an explicit user type signature-such as   f :: a -> a-     or   g (x :: a -> a) = x--A HsSigType is just a HsImplicitBndrs wrapping a LHsType.- * The HsImplicitBndrs binds the /implicitly/ quantified tyvars- * The LHsType binds the /explicitly/ quantified tyvars--E.g. For a signature like-   f :: forall (a::k). blah-we get-   HsIB { hsib_vars = [k]-        , hsib_body = HsForAllTy { hst_tele = HsForAllInvis [(a::*)]-                                 , hst_body = blah }-The implicit kind variable 'k' is bound by the HsIB;-the explicitly forall'd tyvar 'a' is bound by the HsForAllTy--Note [Pattern signature binders and scoping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the pattern signatures like those on `t` and `g` in:--   f = let h = \(t :: (b, b) ->-               \(g :: forall a. a -> b) ->-               ...(t :: (Int,Int))...-       in woggle--* The `b` in t's pattern signature is implicitly bound and scopes over-  the signature and the body of the lambda.  It stands for a type (any type);-  indeed we subsequently discover that b=Int.-  (See Note [TyVarTv] in GHC.Tc.Utils.TcMType for more on this point.)-* The `b` in g's pattern signature is an /occurrence/ of the `b` bound by-  t's pattern signature.-* The `a` in `forall a` scopes only over the type `a -> b`, not over the body-  of the lambda.-* There is no forall-or-nothing rule for pattern signatures, which is why the-  type `forall a. a -> b` is permitted in `g`'s pattern signature, even though-  `b` is not explicitly bound.-  See Note [forall-or-nothing rule] in GHC.Rename.HsType.--Similar scoping rules apply to term variable binders in RULES, like in the-following example:--   {-# RULES "h" forall (t :: (b, b)) (g :: forall a. a -> b). h t g = ... #-}--Just like in pattern signatures, the `b` in t's signature is implicitly bound-and scopes over the remainder of the RULE. As a result, the `b` in g's-signature is an occurrence. Moreover, the `a` in `forall a` scopes only over-the type `a -> b`, and the forall-or-nothing rule does not apply.--While quite similar, RULE term binder signatures behave slightly differently-from pattern signatures in two ways:--1. Unlike in pattern signatures, where type variables can stand for any type,-   type variables in RULE term binder signatures are skolems.-   See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType for-   more on this point.--   In this sense, type variables in pattern signatures are quite similar to-   named wildcards, as both can refer to arbitrary types. The main difference-   lies in error reporting: if a named wildcard `_a` in a pattern signature-   stands for Int, then by default GHC will emit a warning stating as much.-   Changing `_a` to `a`, on the other hand, will cause it not to be reported.-2. In the `h` RULE above, only term variables are explicitly bound, so any free-   type variables in the term variables' signatures are implicitly bound.-   This is just like how the free type variables in pattern signatures are-   implicitly bound. If a RULE explicitly binds both term and type variables,-   however, then free type variables in term signatures are /not/ implicitly-   bound. For example, this RULE would be ill scoped:--     {-# RULES "h2" forall b. forall (t :: (b, c)) (g :: forall a. a -> b).-                    h2 t g = ... #-}--   This is because `b` and `c` occur free in the signature for `t`, but only-   `b` was explicitly bound, leaving `c` out of scope. If the RULE had started-   with `forall b c.`, then it would have been accepted.--The types in pattern signatures and RULE term binder signatures are represented-in the AST by HsSigPatType. From the renamer onward, the hsps_ext field (of-type HsPSRn) tracks the names of named wildcards and implicitly bound type-variables so that they can be brought into scope during renaming and-typechecking.--}--mkHsImplicitBndrs :: thing -> HsImplicitBndrs GhcPs thing-mkHsImplicitBndrs x = HsIB { hsib_ext  = noExtField-                           , hsib_body = x }--mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing-mkHsWildCardBndrs x = HsWC { hswc_body = x-                           , hswc_ext  = noExtField }--mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs-mkHsPatSigType x = HsPS { hsps_ext  = noExtField-                        , hsps_body = x }---- Add empty binders.  This is a bit suspicious; what if--- the wrapped thing had free type variables?-mkEmptyImplicitBndrs :: thing -> HsImplicitBndrs GhcRn thing-mkEmptyImplicitBndrs x = HsIB { hsib_ext = []-                              , hsib_body = x }--mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing-mkEmptyWildCardBndrs x = HsWC { hswc_body = x-                              , hswc_ext  = [] }-------------------------------------------------------- | These names are used early on to store the names of implicit--- parameters.  They completely disappear after type-checking.-newtype HsIPName = HsIPName FastString-  deriving( Eq, Data )--hsIPNameFS :: HsIPName -> FastString-hsIPNameFS (HsIPName n) = n--instance Outputable HsIPName where-    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters--instance OutputableBndr HsIPName where-    pprBndr _ n   = ppr n         -- Simple for now-    pprInfixOcc  n = ppr n-    pprPrefixOcc n = ppr n-------------------------------------------------------- | Haskell Type Variable Binder--- The flag annotates the binder. It is 'Specificity' in places where--- explicit specificity is allowed (e.g. x :: forall {a} b. ...) or--- '()' in other places.-data HsTyVarBndr flag pass-  = UserTyVar        -- no explicit kinding-         (XUserTyVar pass)-         flag-         (Located (IdP pass))-        -- See Note [Located RdrNames] in GHC.Hs.Expr--  | KindedTyVar-         (XKindedTyVar pass)-         flag-         (Located (IdP pass))-         (LHsKind pass)  -- The user-supplied kind signature-        -- ^-        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',-        --          'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnClose'--        -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | XTyVarBndr-      !(XXTyVarBndr pass)--type instance XUserTyVar    (GhcPass _) = NoExtField-type instance XKindedTyVar  (GhcPass _) = NoExtField--type instance XXTyVarBndr   (GhcPass _) = NoExtCon---- | Return the attached flag-hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag-hsTyVarBndrFlag (UserTyVar _ fl _)     = fl-hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl---- | Set the attached flag-setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)-  -> HsTyVarBndr flag (GhcPass pass)-setHsTyVarBndrFlag f (UserTyVar x _ l)     = UserTyVar x f l-setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k---- | Does this 'HsTyVarBndr' come with an explicit kind annotation?-isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool-isHsKindedTyVar (UserTyVar {})   = False-isHsKindedTyVar (KindedTyVar {}) = True-isHsKindedTyVar (XTyVarBndr {})  = False---- | Do all type variables in this 'LHsQTyVars' come with kind annotations?-hsTvbAllKinded :: LHsQTyVars pass -> Bool-hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit--instance NamedThing (HsTyVarBndr flag GhcRn) where-  getName (UserTyVar _ _ v) = unLoc v-  getName (KindedTyVar _ _ v _) = unLoc v---- | Haskell Type-data HsType pass-  = HsForAllTy   -- See Note [HsType binders]-      { hst_xforall :: XForAllTy pass-      , hst_tele    :: HsForAllTelescope pass-                                     -- Explicit, user-supplied 'forall a {b} c'-      , hst_body    :: LHsType pass  -- body type-      }-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForall',-      --         'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'-      -- For details on above see note [Api annotations] in "GHC.Parser.Annotation"--  | HsQualTy   -- See Note [HsType binders]-      { hst_xqual :: XQualTy pass-      , hst_ctxt  :: LHsContext pass       -- Context C => blah-      , hst_body  :: LHsType pass }--  | HsTyVar  (XTyVar pass)-              PromotionFlag    -- Whether explicitly promoted,-                               -- for the pretty printer-             (Located (IdP pass))-                  -- Type variable, type constructor, or data constructor-                  -- see Note [Promotions (HsTyVar)]-                  -- See Note [Located RdrNames] in GHC.Hs.Expr-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsAppTy             (XAppTy pass)-                        (LHsType pass)-                        (LHsType pass)-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsAppKindTy         (XAppKindTy pass) -- type level type app-                        (LHsType pass)-                        (LHsKind pass)--  | HsFunTy             (XFunTy pass)-                        (HsArrow pass)-                        (LHsType pass)   -- function type-                        (LHsType pass)-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow',--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsListTy            (XListTy pass)-                        (LHsType pass)  -- Element type-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,-      --         'GHC.Parser.Annotation.AnnClose' @']'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsTupleTy           (XTupleTy pass)-                        HsTupleSort-                        [LHsType pass]  -- Element types (length gives arity)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(' or '(#'@,-    --         'GHC.Parser.Annotation.AnnClose' @')' or '#)'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsSumTy             (XSumTy pass)-                        [LHsType pass]  -- Element types (length gives arity)-    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,-    --         'GHC.Parser.Annotation.AnnClose' '#)'@--    -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsOpTy              (XOpTy pass)-                        (LHsType pass) (Located (IdP pass)) (LHsType pass)-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsParTy             (XParTy pass)-                        (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr-        -- Parenthesis preserved for the precedence re-arrangement in-        -- GHC.Rename.HsType-        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-      --         'GHC.Parser.Annotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsIParamTy          (XIParamTy pass)-                        (Located HsIPName) -- (?x :: ty)-                        (LHsType pass)   -- Implicit parameters as they occur in-                                         -- contexts-      -- ^-      -- > (?x :: ty)-      ---      -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsStarTy            (XStarTy pass)-                        Bool             -- Is this the Unicode variant?-                                         -- Note [HsStarTy]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--  | HsKindSig           (XKindSig pass)-                        (LHsType pass)  -- (ty :: kind)-                        (LHsKind pass)  -- A type with a kind signature-      -- ^-      -- > (ty :: kind)-      ---      -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,-      --         'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsSpliceTy          (XSpliceTy pass)-                        (HsSplice pass)   -- Includes quasi-quotes-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@,-      --         'GHC.Parser.Annotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsDocTy             (XDocTy pass)-                        (LHsType pass) LHsDocString -- A documented type-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsBangTy    (XBangTy pass)-                HsSrcBang (LHsType pass)   -- Bang-style type annotations-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :-      --         'GHC.Parser.Annotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,-      --         'GHC.Parser.Annotation.AnnClose' @'#-}'@-      --         'GHC.Parser.Annotation.AnnBang' @\'!\'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsRecTy     (XRecTy pass)-                [LConDeclField pass]    -- Only in data type declarations-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,-      --         'GHC.Parser.Annotation.AnnClose' @'}'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  -- | HsCoreTy (XCoreTy pass) Type -- An escape hatch for tunnelling a *closed*-  --                                -- Core Type through HsSyn.-  --     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsExplicitListTy       -- A promoted explicit list-        (XExplicitListTy pass)-        PromotionFlag      -- whether explicitly promoted, for pretty printer-        [LHsType pass]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'["@,-      --         'GHC.Parser.Annotation.AnnClose' @']'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsExplicitTupleTy      -- A promoted explicit tuple-        (XExplicitTupleTy pass)-        [LHsType pass]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'("@,-      --         'GHC.Parser.Annotation.AnnClose' @')'@--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsTyLit (XTyLit pass) HsTyLit      -- A promoted numeric literal.-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  | HsWildCardTy (XWildCardTy pass)  -- A type wildcard-      -- See Note [The wildcard story for types]-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation--  -- For adding new constructors via Trees that Grow-  | XHsType-      (XXType pass)--data NewHsTypeX-  = NHsCoreTy Type -- An escape hatch for tunnelling a *closed*-                   -- Core Type through HsSyn.-                   -- See also Note [Typechecking NHsCoreTys] in-                   -- GHC.Tc.Gen.HsType.-    deriving Data-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None--instance Outputable NewHsTypeX where-  ppr (NHsCoreTy ty) = ppr ty--type instance XForAllTy        (GhcPass _) = NoExtField-type instance XQualTy          (GhcPass _) = NoExtField-type instance XTyVar           (GhcPass _) = NoExtField-type instance XAppTy           (GhcPass _) = NoExtField-type instance XFunTy           (GhcPass _) = NoExtField-type instance XListTy          (GhcPass _) = NoExtField-type instance XTupleTy         (GhcPass _) = NoExtField-type instance XSumTy           (GhcPass _) = NoExtField-type instance XOpTy            (GhcPass _) = NoExtField-type instance XParTy           (GhcPass _) = NoExtField-type instance XIParamTy        (GhcPass _) = NoExtField-type instance XStarTy          (GhcPass _) = NoExtField-type instance XKindSig         (GhcPass _) = NoExtField--type instance XAppKindTy       (GhcPass _) = SrcSpan -- Where the `@` lives--type instance XSpliceTy        GhcPs = NoExtField-type instance XSpliceTy        GhcRn = NoExtField-type instance XSpliceTy        GhcTc = Kind--type instance XDocTy           (GhcPass _) = NoExtField-type instance XBangTy          (GhcPass _) = NoExtField-type instance XRecTy           (GhcPass _) = NoExtField--type instance XExplicitListTy  GhcPs = NoExtField-type instance XExplicitListTy  GhcRn = NoExtField-type instance XExplicitListTy  GhcTc = Kind--type instance XExplicitTupleTy GhcPs = NoExtField-type instance XExplicitTupleTy GhcRn = NoExtField-type instance XExplicitTupleTy GhcTc = [Kind]--type instance XTyLit           (GhcPass _) = NoExtField--type instance XWildCardTy      (GhcPass _) = NoExtField--type instance XXType         (GhcPass _) = NewHsTypeX----- Note [Literal source text] in GHC.Types.Basic for SourceText fields in--- the following--- | Haskell Type Literal-data HsTyLit-  = HsNumTy SourceText Integer-  | HsStrTy SourceText FastString-    deriving Data--oneDataConHsTy :: HsType GhcRn-oneDataConHsTy = HsTyVar noExtField NotPromoted (noLoc oneDataConName)--manyDataConHsTy :: HsType GhcRn-manyDataConHsTy = HsTyVar noExtField NotPromoted (noLoc manyDataConName)--isUnrestricted :: HsArrow GhcRn -> Bool-isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName-isUnrestricted _ = False---- | Denotes the type of arrows in the surface language-data HsArrow pass-  = HsUnrestrictedArrow IsUnicodeSyntax-    -- ^ a -> b or a → b-  | HsLinearArrow IsUnicodeSyntax-    -- ^ a %1 -> b or a %1 → b, or a ⊸ b-  | HsExplicitMult IsUnicodeSyntax (LHsType pass)-    -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!-    -- This is how the programmer wrote it). It is stored as an-    -- `HsType` so as to preserve the syntax as written in the-    -- program.---- | Convert an arrow into its corresponding multiplicity. In essence this--- erases the information of whether the programmer wrote an explicit--- multiplicity or a shorthand.-arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn-arrowToHsType (HsUnrestrictedArrow _) = noLoc manyDataConHsTy-arrowToHsType (HsLinearArrow _) = noLoc oneDataConHsTy-arrowToHsType (HsExplicitMult _ p) = p---- | This is used in the syntax. In constructor declaration. It must keep the--- arrow representation.-data HsScaled pass a = HsScaled (HsArrow pass) a--hsMult :: HsScaled pass a -> HsArrow pass-hsMult (HsScaled m _) = m--hsScaledThing :: HsScaled pass a -> a-hsScaledThing (HsScaled _ t) = t---- | When creating syntax we use the shorthands. It's better for printing, also,--- the shorthands work trivially at each pass.-hsUnrestricted, hsLinear :: a -> HsScaled pass a-hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax)-hsLinear = HsScaled (HsLinearArrow NormalSyntax)--instance Outputable a => Outputable (HsScaled pass a) where-   ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t-                            ppr t--instance-      (OutputableBndrId pass) =>-      Outputable (HsArrow (GhcPass pass)) where-  ppr arr = parens (pprHsArrow arr)---- See #18846-pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc-pprHsArrow (HsUnrestrictedArrow _) = arrow-pprHsArrow (HsLinearArrow _) = lollipop-pprHsArrow (HsExplicitMult _ p) = (mulArrow (ppr p))--{--Note [Unit tuples]-~~~~~~~~~~~~~~~~~~-Consider the type-    type instance F Int = ()-We want to parse that "()"-    as HsTupleTy HsBoxedOrConstraintTuple [],-NOT as HsTyVar unitTyCon--Why? Because F might have kind (* -> Constraint), so we when parsing we-don't know if that tuple is going to be a constraint tuple or an ordinary-unit tuple.  The HsTupleSort flag is specifically designed to deal with-that, but it has to work for unit tuples too.--Note [Promotions (HsTyVar)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-HsTyVar: A name in a type or kind.-  Here are the allowed namespaces for the name.-    In a type:-      Var: not allowed-      Data: promoted data constructor-      Tv: type variable-      TcCls before renamer: type constructor, class constructor, or promoted data constructor-      TcCls after renamer: type constructor or class constructor-    In a kind:-      Var, Data: not allowed-      Tv: kind variable-      TcCls: kind constructor or promoted type constructor--  The 'Promoted' field in an HsTyVar captures whether the type was promoted in-  the source code by prefixing an apostrophe.--Note [HsStarTy]-~~~~~~~~~~~~~~~-When the StarIsType extension is enabled, we want to treat '*' and its Unicode-variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser-would mean that when we pretty-print it back, we don't know whether the user-wrote '*' or 'Type', and lose the parse/ppr roundtrip property.--As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type')-and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type).-When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not-involved.---Note [Promoted lists and tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Notice the difference between-   HsListTy    HsExplicitListTy-   HsTupleTy   HsExplicitListTupleTy--E.g.    f :: [Int]                      HsListTy--        g3  :: T '[]                   All these use-        g2  :: T '[True]                  HsExplicitListTy-        g1  :: T '[True,False]-        g1a :: T [True,False]             (can omit ' where unambiguous)--  kind of T :: [Bool] -> *        This kind uses HsListTy!--E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair-        k :: S '(True,False)            HsExplicitTypleTy; S is indexed by-                                           a type-level pair of booleans-        kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy--Note [Distinguishing tuple kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Apart from promotion, tuples can have one of three different kinds:--        x :: (Int, Bool)                -- Regular boxed tuples-        f :: Int# -> (# Int#, Int# #)   -- Unboxed tuples-        g :: (Eq a, Ord a) => a         -- Constraint tuples--For convenience, internally we use a single constructor for all of these,-namely HsTupleTy, but keep track of the tuple kind (in the first argument to-HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing,-because of the #. However, with -XConstraintKinds we can only distinguish-between constraint and boxed tuples during type checking, in general. Hence the-four constructors of HsTupleSort:--        HsUnboxedTuple                  -> Produced by the parser-        HsBoxedTuple                    -> Certainly a boxed tuple-        HsConstraintTuple               -> Certainly a constraint tuple-        HsBoxedOrConstraintTuple        -> Could be a boxed or a constraint-                                        tuple. Produced by the parser only,-                                        disappears after type checking--}---- | Haskell Tuple Sort-data HsTupleSort = HsUnboxedTuple-                 | HsBoxedTuple-                 | HsConstraintTuple-                 | HsBoxedOrConstraintTuple-                 deriving Data---- | Located Constructor Declaration Field-type LConDeclField pass = Located (ConDeclField pass)-      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when-      --   in a list--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation---- | Constructor Declaration Field-data ConDeclField pass  -- Record fields have Haddock docs on them-  = ConDeclField { cd_fld_ext  :: XConDeclField pass,-                   cd_fld_names :: [LFieldOcc pass],-                                   -- ^ See Note [ConDeclField passs]-                   cd_fld_type :: LBangType pass,-                   cd_fld_doc  :: Maybe LHsDocString }-      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'--      -- For details on above see note [Api annotations] in GHC.Parser.Annotation-  | XConDeclField !(XXConDeclField pass)--type instance XConDeclField  (GhcPass _) = NoExtField-type instance XXConDeclField (GhcPass _) = NoExtCon--instance OutputableBndrId p-       => Outputable (ConDeclField (GhcPass p)) where-  ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty---- HsConDetails is used for patterns/expressions *and* for data type--- declarations--- | Haskell Constructor Details-data HsConDetails arg rec-  = PrefixCon [arg]             -- C p1 p2 p3-  | RecCon    rec               -- C { x = p1, y = p2 }-  | InfixCon  arg arg           -- p1 `C` p2-  deriving Data--instance (Outputable arg, Outputable rec)-         => Outputable (HsConDetails arg rec) where-  ppr (PrefixCon args) = text "PrefixCon" <+> ppr args-  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec-  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]--hsConDetailsArgs ::-     HsConDetails (LHsType a) (Located [LConDeclField a])-  -> [LHsType a]-hsConDetailsArgs details = case details of-  InfixCon a b -> [a,b]-  PrefixCon xs -> xs-  RecCon r -> map (cd_fld_type . unLoc) (unLoc r)--{--Note [ConDeclField passs]-~~~~~~~~~~~~~~~~~~~~~~~~~--A ConDeclField contains a list of field occurrences: these always-include the field label as the user wrote it.  After the renamer, it-will additionally contain the identity of the selector function in the-second component.--Due to DuplicateRecordFields, the OccName of the selector function-may have been mangled, which is why we keep the original field label-separately.  For example, when DuplicateRecordFields is enabled--    data T = MkT { x :: Int }--gives--    ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.--}---------------------------- A valid type must have a for-all at the top of the type, or of the fn arg--- types------------------------hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]--- Get the lexically-scoped type variables of a HsSigType---  - the explicitly-given forall'd type variables---  - the named wildcards; see Note [Scoping of named wildcards]--- because they scope in the same way-hsWcScopedTvs sig_ty-  | HsWC { hswc_ext = nwcs, hswc_body = sig_ty1 }  <- sig_ty-  , HsIB { hsib_ext = vars-         , hsib_body = sig_ty2 } <- sig_ty1-  = case sig_ty2 of-      L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}) ->-                                   -- See Note [hsScopedTvs vis_flag]-        vars ++ nwcs ++ hsLTyVarNames tvs-      _                                    -> nwcs--hsScopedTvs :: LHsSigType GhcRn -> [Name]--- Same as hsWcScopedTvs, but for a LHsSigType-hsScopedTvs sig_ty-  | HsIB { hsib_ext = vars-         , hsib_body = sig_ty2 } <- sig_ty-  , L _ (HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }})-      <- sig_ty2                 -- See Note [hsScopedTvs vis_flag]-  = vars ++ hsLTyVarNames tvs-  | otherwise-  = []--{- Note [Scoping of named wildcards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: _a -> _a-  f x = let g :: _a -> _a-            g = ...-        in ...--Currently, for better or worse, the "_a" variables are all the same. So-although there is no explicit forall, the "_a" scopes over the definition.-I don't know if this is a good idea, but there it is.--}--{- Note [hsScopedTvs vis_flag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--XScopedTypeVariables can be defined in terms of a desugaring to--XTypeAbstractions (GHC Proposal #50):--    fn :: forall a b c. tau(a,b,c)            fn :: forall a b c. tau(a,b,c)-    fn = defn(a,b,c)                   ==>    fn @x @y @z = defn(x,y,z)--That is, for every type variable of the leading 'forall' in the type signature,-we add an invisible binder at term level.--This model does not extend to visible forall, as discussed here:--* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412-* https://github.com/ghc-proposals/ghc-proposals/pull/238--The conclusion of these discussions can be summarized as follows:--  > Assuming support for visible 'forall' in terms, consider this example:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn = \a b -> ...-  >-  > The user has written their own binders 'a' and 'b' to stand for 'x' and-  > 'y', and we definitely should not desugar this into:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn x y = \a b -> ...         -- bad!--We cement this design by pattern-matching on HsForAllInvis in hsScopedTvs:--    hsScopedTvs (HsForAllTy { hst_tele = HsForAllInvis { hst_bndrs = ... }-                            , ... }) = ...--At the moment, GHC does not support visible 'forall' in terms. Nevertheless,-it is still possible to write erroneous programs that use visible 'forall's in-terms, such as this example:--    x :: forall a -> a -> a-    x = x--If we do not pattern-match on HsForAllInvis in hsScopedTvs, then `a` would-erroneously be brought into scope over the body of `x` when renaming it.-Although the typechecker would later reject this (see `GHC.Tc.Validity.vdqAllowed`),-it is still possible for this to wreak havoc in the renamer before it gets to-that point (see #17687 for an example of this).-Bottom line: nip problems in the bud by matching on HsForAllInvis from the start.--}------------------------hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)-hsTyVarName (UserTyVar _ _ (L _ n))     = n-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n--hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)-hsLTyVarName = hsTyVarName . unLoc--hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]-hsLTyVarNames = map hsLTyVarName--hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]--- Explicit variables only-hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)--hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]--- All variables-hsAllLTyVarNames (HsQTvs { hsq_ext = kvs-                         , hsq_explicit = tvs })-  = kvs ++ hsLTyVarNames tvs--hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> Located (IdP (GhcPass p))-hsLTyVarLocName = mapLoc hsTyVarName--hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [Located (IdP (GhcPass p))]-hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)---- | Get the kind signature of a type, ignoring parentheses:------   hsTyKindSig   `Maybe                    `   =   Nothing---   hsTyKindSig   `Maybe ::   Type -> Type  `   =   Just  `Type -> Type`---   hsTyKindSig   `Maybe :: ((Type -> Type))`   =   Just  `Type -> Type`------ This is used to extract the result kind of type synonyms with a CUSK:------  type S = (F :: res_kind)---                 ^^^^^^^^----hsTyKindSig :: LHsType pass -> Maybe (LHsKind pass)-hsTyKindSig lty =-  case unLoc lty of-    HsParTy _ lty'    -> hsTyKindSig lty'-    HsKindSig _ _ k   -> Just k-    _                 -> Nothing------------------------ignoreParens :: LHsType pass -> LHsType pass-ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty-ignoreParens ty                   = ty--isLHsForAllTy :: LHsType p -> Bool-isLHsForAllTy (L _ (HsForAllTy {})) = True-isLHsForAllTy _                     = False--{--************************************************************************-*                                                                      *-                Building types-*                                                                      *-************************************************************************--}--mkAnonWildCardTy :: HsType GhcPs-mkAnonWildCardTy = HsWildCardTy noExtField--mkHsOpTy :: LHsType (GhcPass p) -> Located (IdP (GhcPass p))-         -> LHsType (GhcPass p) -> HsType (GhcPass p)-mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2--mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-mkHsAppTy t1 t2-  = addCLoc t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))--mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]-           -> LHsType (GhcPass p)-mkHsAppTys = foldl' mkHsAppTy--mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-              -> LHsType (GhcPass p)-mkHsAppKindTy ext ty k-  = addCLoc ty k (HsAppKindTy ext ty k)--{--************************************************************************-*                                                                      *-                Decomposing HsTypes-*                                                                      *-************************************************************************--}-------------------------------------- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)--- Breaks up any parens in the result type:---      splitHsFunType (a -> (b -> c)) = ([a,b], c)--- It returns API Annotations for any parens removed-splitHsFunType ::-     LHsType (GhcPass p)-  -> ([HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p), [AddAnn])-splitHsFunType ty = go ty []-  where-    go (L l (HsParTy _ ty)) anns-      = go ty (anns ++ mkParensApiAnn l)--    go (L _ (HsFunTy _ mult x y)) anns-      | (args, res, anns') <- go y anns-      = (HsScaled mult x:args, res, anns')--    go other anns = ([], other, anns)---- | Retrieve the name of the \"head\" of a nested type application.--- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more--- thorough. The purpose of this function is to examine instance heads, so it--- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).-hsTyGetAppHead_maybe :: LHsType (GhcPass p)-                     -> Maybe (Located (IdP (GhcPass p)))-hsTyGetAppHead_maybe = go-  where-    go (L _ (HsTyVar _ _ ln))          = Just ln-    go (L _ (HsAppTy _ l _))           = go l-    go (L _ (HsAppKindTy _ t _))       = go t-    go (L _ (HsOpTy _ _ (L loc n) _))  = Just (L loc n)-    go (L _ (HsParTy _ t))             = go t-    go (L _ (HsKindSig _ t _))         = go t-    go _                               = Nothing----------------------------------------------------------------- Arguments in an expression/type after splitting-data HsArg tm ty-  = HsValArg tm   -- Argument is an ordinary expression     (f arg)-  | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty)-                         -- SrcSpan is location of the `@`-  | HsArgPar SrcSpan -- See Note [HsArgPar]--numVisibleArgs :: [HsArg tm ty] -> Arity-numVisibleArgs = count is_vis-  where is_vis (HsValArg _) = True-        is_vis _            = False---- type level equivalent-type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)---- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.-lhsTypeArgSrcSpan :: LHsTypeArg pass -> SrcSpan-lhsTypeArgSrcSpan arg = case arg of-  HsValArg  tm    -> getLoc tm-  HsTypeArg at ty -> at `combineSrcSpans` getLoc ty-  HsArgPar  sp    -> sp--instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where-  ppr (HsValArg tm)    = ppr tm-  ppr (HsTypeArg _ ty) = char '@' <> ppr ty-  ppr (HsArgPar sp)    = text "HsArgPar"  <+> ppr sp-{--Note [HsArgPar]-A HsArgPar indicates that everything to the left of this in the argument list is-enclosed in parentheses together with the function itself. It is necessary so-that we can recreate the parenthesis structure in the original source after-typechecking the arguments.--The SrcSpan is the span of the original HsPar--((f arg1) arg2 arg3) results in an input argument list of-[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]---}-------------------------------------- | Decompose a pattern synonym type signature into its constituent parts.------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsPatSynTy :: LHsType pass-                 -> ( [LHsTyVarBndr Specificity pass]    -- universals-                    , LHsContext pass        -- required constraints-                    , [LHsTyVarBndr Specificity pass]    -- existentials-                    , LHsContext pass        -- provided constraints-                    , LHsType pass)          -- body type-splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)-  where-    (univs, ty1) = splitLHsForAllTyInvis ty-    (reqs,  ty2) = splitLHsQualTy ty1-    (exis,  ty3) = splitLHsForAllTyInvis ty2-    (provs, ty4) = splitLHsQualTy ty3---- | Decompose a sigma type (of the form @forall <tvs>. context => body@)--- into its constituent parts.--- Only splits type variable binders that were--- quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsSigmaTyInvis :: LHsType pass-                     -> ([LHsTyVarBndr Specificity pass], LHsContext pass, LHsType pass)-splitLHsSigmaTyInvis ty-  | (tvs,  ty1) <- splitLHsForAllTyInvis ty-  , (ctxt, ty2) <- splitLHsQualTy ty1-  = (tvs, ctxt, ty2)---- | Decompose a sigma type (of the form @forall <tvs>. context => body@)--- into its constituent parts.--- Only splits type variable binders that were--- quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Unlike 'splitLHsSigmaTyInvis', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsSigmaTyInvis_KP ::-     LHsType pass-  -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass)-splitLHsSigmaTyInvis_KP ty-  | (mb_tvbs, ty1) <- splitLHsForAllTyInvis_KP ty-  , (mb_ctxt, ty2) <- splitLHsQualTy_KP ty1-  = (mb_tvbs, mb_ctxt, ty2)---- | Decompose a GADT type into its constituent parts.--- Returns @(mb_tvbs, mb_ctxt, body)@, where:------ * @mb_tvbs@ are @Just@ the leading @forall@s, if they are provided.---   Otherwise, they are @Nothing@.------ * @mb_ctxt@ is @Just@ the context, if it is provided.---   Otherwise, it is @Nothing@.------ * @body@ is the body of the type after the optional @forall@s and context.------ This function is careful not to look through parentheses.--- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@--- "GHC.Hs.Decls" for why this is important.-splitLHsGadtTy ::-     LHsType pass-  -> (Maybe [LHsTyVarBndr Specificity pass], Maybe (LHsContext pass), LHsType pass)-splitLHsGadtTy = splitLHsSigmaTyInvis_KP---- | Decompose a type of the form @forall <tvs>. body@ into its constituent--- parts. Only splits type variable binders that--- were quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.--- Unlike 'splitLHsSigmaTyInvis', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsForAllTyInvis ::-  LHsType pass -> ([LHsTyVarBndr Specificity pass], LHsType pass)-splitLHsForAllTyInvis ty-  | (mb_tvbs, body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)-  = (fromMaybe [] mb_tvbs, body)---- | Decompose a type of the form @forall <tvs>. body@ into its constituent--- parts. Only splits type variable binders that--- were quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Unlike 'splitLHsForAllTyInvis', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsForAllTyInvis_KP ::-  LHsType pass -> (Maybe [LHsTyVarBndr Specificity pass], LHsType pass)-splitLHsForAllTyInvis_KP lty@(L _ ty) =-  case ty of-    HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }-               , hst_body = body }-      -> (Just tvs, body)-    _ -> (Nothing, lty)---- | Decompose a type of the form @context => body@ into its constituent parts.------ Note that this function looks through parentheses, so it will work on types--- such as @(context => <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsQualTy :: LHsType pass -> (LHsContext pass, LHsType pass)-splitLHsQualTy ty-  | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)-  = (fromMaybe noLHsContext mb_ctxt, body)---- | Decompose a type of the form @context => body@ into its constituent parts.------ Unlike 'splitLHsQualTy', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsQualTy_KP :: LHsType pass -> (Maybe (LHsContext pass), LHsType pass)-splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))-                       = (Just ctxt, body)-splitLHsQualTy_KP body = (Nothing, body)---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into its constituent parts.--- Note that the @[Name]@s returned correspond to either:------ * The implicitly bound type variables (if the type lacks an outermost---   @forall@), or------ * The explicitly bound type variables (if the type has an outermost---   @forall@).------ This function is careful not to look through parentheses.--- See @Note [No nested foralls or contexts in instance types]@--- for why this is important.-splitLHsInstDeclTy :: LHsSigType GhcRn-                   -> ([Name], LHsContext GhcRn, LHsType GhcRn)-splitLHsInstDeclTy (HsIB { hsib_ext = itkvs-                         , hsib_body = inst_ty })-  | (mb_tvs, mb_cxt, body_ty) <- splitLHsSigmaTyInvis_KP inst_ty-  = (itkvs ++ maybe [] hsLTyVarNames mb_tvs, fromMaybe noLHsContext mb_cxt, body_ty)-    -- Because of the forall-or-nothing rule (see Note [forall-or-nothing rule]-    -- in GHC.Rename.HsType), at least one of itkvs (the implicitly bound type-    -- variables) or mb_tvs (the explicitly bound type variables) will be-    -- empty. Still, if ScopedTypeVariables is enabled, we must bring one or-    -- the other into scope over the bodies of the instance methods, so we-    -- simply combine them into a single list.---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into the @instance_head@.-getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)-getLHsInstDeclHead (HsIB { hsib_body = inst_ty })-  | (_mb_tvs, _mb_cxt, body_ty) <- splitLHsSigmaTyInvis_KP inst_ty-  = body_ty---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into the @instance_head@ and--- retrieve the underlying class type constructor (if it exists).-getLHsInstDeclClass_maybe :: LHsSigType (GhcPass p)-                          -> Maybe (Located (IdP (GhcPass p)))--- Works on (LHsSigType GhcPs)-getLHsInstDeclClass_maybe inst_ty-  = do { let head_ty = getLHsInstDeclHead inst_ty-       ; cls <- hsTyGetAppHead_maybe head_ty-       ; return cls }--{--Note [No nested foralls or contexts in instance types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The type at the top of an instance declaration is one of the few places in GHC-where nested `forall`s or contexts are not permitted, even with RankNTypes-enabled. For example, the following will be rejected:--  instance forall a. forall b. Show (Either a b) where ...-  instance Eq a => Eq b => Show (Either a b) where ...-  instance (forall a. Show (Maybe a)) where ...-  instance (Eq a => Show (Maybe a)) where ...--This restriction is partly motivated by an unusual quirk of instance-declarations. Namely, if ScopedTypeVariables is enabled, then the type-variables from the top of an instance will scope over the bodies of the-instance methods, /even if the type variables are implicitly quantified/.-For example, GHC will accept the following:--  instance Monoid a => Monoid (Identity a) where-    mempty = Identity (mempty @a)--Moreover, the type in the top of an instance declaration must obey the-forall-or-nothing rule (see Note [forall-or-nothing rule] in-GHC.Rename.HsType). If instance types allowed nested `forall`s, this could-result in some strange interactions. For example, consider the following:--  class C a where-    m :: Proxy a-  instance (forall a. C (Either a b)) where-    m = Proxy @(Either a b)--Somewhat surprisingly, old versions of GHC would accept the instance above.-Even though the `forall` only quantifies `a`, the outermost parentheses mean-that the `forall` is nested, and per the forall-or-nothing rule, this means-that implicit quantification would occur. Therefore, the `a` is explicitly-bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would-bring /both/ sorts of type variables into scope over the body of `m`.-How utterly confusing!--To avoid this sort of confusion, we simply disallow nested `forall`s in-instance types, which makes things like the instance above become illegal.-For the sake of consistency, we also disallow nested contexts, even though they-don't have the same strange interaction with ScopedTypeVariables.--Just as we forbid nested `forall`s and contexts in normal instance-declarations, we also forbid them in SPECIALISE instance pragmas (#18455).-Unlike normal instance declarations, ScopedTypeVariables don't have any impact-on SPECIALISE instance pragmas, but we use the same validity checks for-SPECIALISE instance pragmas anyway to be consistent.---------- Wrinkle: Derived instances--------`deriving` clauses and standalone `deriving` declarations also permit bringing-type variables into scope, either through explicit or implicit quantification.-Unlike in the tops of instance declarations, however, one does not need to-enable ScopedTypeVariables for this to take effect.--Just as GHC forbids nested `forall`s in the top of instance declarations, it-also forbids them in types involved with `deriving`:--1. In the `via` types in DerivingVia. For example, this is rejected:--     deriving via (forall x. V x) instance C (S x)--   Just like the types in instance declarations, `via` types can also bring-   both implicitly and explicitly bound type variables into scope. As a result,-   we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing-   behavior like in the example below:--     deriving via (forall x. T x y) instance W x y (Foo a b)-     -- Both x and y are brought into scope???-2. In the classes in `deriving` clauses. For example, this is rejected:--     data T = MkT deriving (C1, (forall x. C2 x y))--   This is because the generated instance would look like:--     instance forall x y. C2 x y T where ...--   So really, the same concerns as instance declarations apply here as well.--}--{--************************************************************************-*                                                                      *-                FieldOcc-*                                                                      *-************************************************************************--}---- | Located Field Occurrence-type LFieldOcc pass = Located (FieldOcc pass)---- | Field Occurrence------ Represents an *occurrence* of an unambiguous field.  We store--- both the 'RdrName' the user originally wrote, and after the--- renamer, the selector function.-data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass-                              , rdrNameFieldOcc :: Located RdrName-                                 -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr"-                              }--  | XFieldOcc-      !(XXFieldOcc pass)-deriving instance Eq  (XCFieldOcc (GhcPass p)) => Eq  (FieldOcc (GhcPass p))--type instance XCFieldOcc GhcPs = NoExtField-type instance XCFieldOcc GhcRn = Name-type instance XCFieldOcc GhcTc = Id--type instance XXFieldOcc (GhcPass _) = NoExtCon--instance Outputable (FieldOcc pass) where-  ppr = ppr . rdrNameFieldOcc--mkFieldOcc :: Located RdrName -> FieldOcc GhcPs-mkFieldOcc rdr = FieldOcc noExtField rdr----- | Ambiguous Field Occurrence------ Represents an *occurrence* of a field that is potentially--- ambiguous after the renamer, with the ambiguity resolved by the--- typechecker.  We always store the 'RdrName' that the user--- originally wrote, and store the selector function after the renamer--- (for unambiguous occurrences) or the typechecker (for ambiguous--- occurrences).------ See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat" and--- Note [Disambiguating record fields] in "GHC.Tc.Gen.Expr".--- See Note [Located RdrNames] in "GHC.Hs.Expr"-data AmbiguousFieldOcc pass-  = Unambiguous (XUnambiguous pass) (Located RdrName)-  | Ambiguous   (XAmbiguous pass)   (Located RdrName)-  | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass)--type instance XUnambiguous GhcPs = NoExtField-type instance XUnambiguous GhcRn = Name-type instance XUnambiguous GhcTc = Id--type instance XAmbiguous GhcPs = NoExtField-type instance XAmbiguous GhcRn = NoExtField-type instance XAmbiguous GhcTc = Id--type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon--instance Outputable (AmbiguousFieldOcc (GhcPass p)) where-  ppr = ppr . rdrNameAmbiguousFieldOcc--instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where-  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc-  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc--mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc GhcPs-mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr--rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName-rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr-rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr--selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id-selectorAmbiguousFieldOcc (Unambiguous sel _) = sel-selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel--unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc-unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel-unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel--ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc-ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr--{--************************************************************************-*                                                                      *-\subsection{Pretty printing}-*                                                                      *-************************************************************************--}--class OutputableBndrFlag flag where-    pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc--instance OutputableBndrFlag () where-    pprTyVarBndr (UserTyVar _ _ n)     = ppr n-    pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k]--instance OutputableBndrFlag Specificity where-    pprTyVarBndr (UserTyVar _ SpecifiedSpec n)     = ppr n-    pprTyVarBndr (UserTyVar _ InferredSpec n)      = braces $ ppr n-    pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]-    pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr n, dcolon, ppr k]--instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where-    ppr ty = pprHsType ty--instance Outputable HsTyLit where-    ppr = ppr_tylit--instance OutputableBndrId p-       => Outputable (LHsQTyVars (GhcPass p)) where-    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs--instance OutputableBndrId p-       => Outputable (HsForAllTelescope (GhcPass p)) where-    ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =-      text "HsForAllVis:" <+> ppr bndrs-    ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =-      text "HsForAllInvis:" <+> ppr bndrs--instance (OutputableBndrId p, OutputableBndrFlag flag)-       => Outputable (HsTyVarBndr flag (GhcPass p)) where-    ppr = pprTyVarBndr--instance Outputable thing-       => Outputable (HsImplicitBndrs (GhcPass p) thing) where-    ppr (HsIB { hsib_body = ty }) = ppr ty--instance Outputable thing-       => Outputable (HsWildCardBndrs (GhcPass p) thing) where-    ppr (HsWC { hswc_body = ty }) = ppr ty--instance OutputableBndrId p-       => Outputable (HsPatSigType (GhcPass p)) where-    ppr (HsPS { hsps_body = ty }) = ppr ty--pprAnonWildCard :: SDoc-pprAnonWildCard = char '_'---- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@--- only when @-dppr-debug@ is enabled.-pprHsForAll :: forall p. OutputableBndrId p-            => HsForAllTelescope (GhcPass p)-            -> LHsContext (GhcPass p) -> SDoc-pprHsForAll tele cxt-  = pp_tele tele <+> pprLHsContext cxt-  where-    pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc-    pp_tele tele = case tele of-      HsForAllVis   { hsf_vis_bndrs   = qtvs } -> pp_forall (space <> arrow) qtvs-      HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs--    pp_forall :: forall flag. OutputableBndrFlag flag =>-                 SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc-    pp_forall separator qtvs-      | null qtvs = whenPprDebug (forAllLit <> separator)-      | otherwise = forAllLit <+> interppSP qtvs <> separator---- | Version of 'pprHsForAll' or 'pprHsForAllExtra' that will always print--- @forall.@ when passed @Just []@. Prints nothing if passed 'Nothing'-pprHsExplicitForAll :: (OutputableBndrId p)-                    => Maybe [LHsTyVarBndr () (GhcPass p)] -> SDoc-pprHsExplicitForAll (Just qtvs) = forAllLit <+> interppSP qtvs <> dot-pprHsExplicitForAll Nothing     = empty--pprLHsContext :: (OutputableBndrId p)-              => LHsContext (GhcPass p) -> SDoc-pprLHsContext lctxt-  | null (unLoc lctxt) = empty-  | otherwise          = pprLHsContextAlways lctxt---- For use in a HsQualTy, which always gets printed if it exists.-pprLHsContextAlways :: (OutputableBndrId p)-                    => LHsContext (GhcPass p) -> SDoc-pprLHsContextAlways (L _ ctxt)-  = case ctxt of-      []       -> parens empty             <+> darrow-      [L _ ty] -> ppr_mono_ty ty           <+> darrow-      _        -> parens (interpp'SP ctxt) <+> darrow--pprConDeclFields :: (OutputableBndrId p)-                 => [LConDeclField (GhcPass p)] -> SDoc-pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))-  where-    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,-                                 cd_fld_doc = doc }))-        = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc-    ppr_fld (L _ (XConDeclField x)) = ppr x-    ppr_names [n] = ppr n-    ppr_names ns = sep (punctuate comma (map ppr ns))--{--Note [Printing KindedTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#3830 reminded me that we should really only print the kind-signature on a KindedTyVar if the kind signature was put there by the-programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,-rather than converting to KindedTyVars as before.--(As it happens, the message in #3830 comes out a different way now,-and the problem doesn't show up; but having the flag on a KindedTyVar-seems like the Right Thing anyway.)--}---- Printing works more-or-less as for Types--pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc-pprHsType ty = ppr_mono_ty ty--ppr_mono_lty :: (OutputableBndrId p) => LHsType (GhcPass p) -> SDoc-ppr_mono_lty ty = ppr_mono_ty (unLoc ty)--ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc-ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })-  = sep [pprHsForAll tele noLHsContext, ppr_mono_lty ty]--ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })-  = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]--ppr_mono_ty (HsBangTy _ b ty)   = ppr b <> ppr_mono_lty ty-ppr_mono_ty (HsRecTy _ flds)      = pprConDeclFields flds-ppr_mono_ty (HsTyVar _ prom (L _ name))-  | isPromoted prom = quote (pprPrefixOcc name)-  | otherwise       = pprPrefixOcc name-ppr_mono_ty (HsFunTy _ mult ty1 ty2)   = ppr_fun_ty mult ty1 ty2-ppr_mono_ty (HsTupleTy _ con tys)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `Solo x`, not `(x)`-  | [ty] <- tys-  , BoxedTuple <- std_con-  = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]-  | otherwise-  = tupleParens std_con (pprWithCommas ppr tys)-  where std_con = case con of-                    HsUnboxedTuple -> UnboxedTuple-                    _              -> BoxedTuple-ppr_mono_ty (HsSumTy _ tys)-  = tupleParens UnboxedTuple (pprWithBars ppr tys)-ppr_mono_ty (HsKindSig _ ty kind)-  = ppr_mono_lty ty <+> dcolon <+> ppr kind-ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)-ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)-ppr_mono_ty (HsSpliceTy _ s)      = pprSplice s-ppr_mono_ty (HsExplicitListTy _ prom tys)-  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)-  | otherwise       = brackets (interpp'SP tys)-ppr_mono_ty (HsExplicitTupleTy _ tys)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `'Solo x`, not `'(x)`-  | [ty] <- tys-  = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]-  | otherwise-  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)-ppr_mono_ty (HsTyLit _ t)       = ppr_tylit t-ppr_mono_ty (HsWildCardTy {})   = char '_'--ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')--ppr_mono_ty (HsAppTy _ fun_ty arg_ty)-  = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]-ppr_mono_ty (HsAppKindTy _ ty k)-  = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k-ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)-  = sep [ ppr_mono_lty ty1-        , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]--ppr_mono_ty (HsParTy _ ty)-  = parens (ppr_mono_lty ty)-  -- Put the parens in where the user did-  -- But we still use the precedence stuff to add parens because-  --    toHsType doesn't put in any HsParTys, so we may still need them--ppr_mono_ty (HsDocTy _ ty doc)-  -- AZ: Should we add parens?  Should we introduce "-- ^"?-  = ppr_mono_lty ty <+> ppr (unLoc doc)-  -- we pretty print Haddock comments on types as if they were-  -- postfix operators--ppr_mono_ty (XHsType t) = ppr t-----------------------------ppr_fun_ty :: (OutputableBndrId p)-           => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc-ppr_fun_ty mult ty1 ty2-  = let p1 = ppr_mono_lty ty1-        p2 = ppr_mono_lty ty2-        arr = pprHsArrow mult-    in-    sep [p1, arr <+> p2]-----------------------------ppr_tylit :: HsTyLit -> SDoc-ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)-ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))----- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses--- under precedence @p@.-hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool-hsTypeNeedsParens p = go_hs_ty-  where-    go_hs_ty (HsForAllTy{})           = p >= funPrec-    go_hs_ty (HsQualTy{})             = p >= funPrec-    go_hs_ty (HsBangTy{})             = p > topPrec-    go_hs_ty (HsRecTy{})              = False-    go_hs_ty (HsTyVar{})              = False-    go_hs_ty (HsFunTy{})              = p >= funPrec-    go_hs_ty (HsTupleTy{})            = False-    go_hs_ty (HsSumTy{})              = False-    go_hs_ty (HsKindSig{})            = p >= sigPrec-    go_hs_ty (HsListTy{})             = False-    go_hs_ty (HsIParamTy{})           = p > topPrec-    go_hs_ty (HsSpliceTy{})           = False-    go_hs_ty (HsExplicitListTy{})     = False-    go_hs_ty (HsExplicitTupleTy{})    = False-    go_hs_ty (HsTyLit{})              = False-    go_hs_ty (HsWildCardTy{})         = False-    go_hs_ty (HsStarTy{})             = p >= starPrec-    go_hs_ty (HsAppTy{})              = p >= appPrec-    go_hs_ty (HsAppKindTy{})          = p >= appPrec-    go_hs_ty (HsOpTy{})               = p >= opPrec-    go_hs_ty (HsParTy{})              = False-    go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t-    go_hs_ty (XHsType (NHsCoreTy ty)) = go_core_ty ty--    go_core_ty (TyVarTy{})    = False-    go_core_ty (AppTy{})      = p >= appPrec-    go_core_ty (TyConApp _ args)-      | null args             = False-      | otherwise             = p >= appPrec-    go_core_ty (ForAllTy{})   = p >= funPrec-    go_core_ty (FunTy{})      = p >= funPrec-    go_core_ty (LitTy{})      = False-    go_core_ty (CastTy t _)   = go_core_ty t-    go_core_ty (CoercionTy{}) = False--maybeAddSpace :: [LHsType pass] -> SDoc -> SDoc--- See Note [Printing promoted type constructors]--- in GHC.Iface.Type.  This code implements the same--- logic for printing HsType-maybeAddSpace tys doc-  | (ty : _) <- tys-  , lhsTypeHasLeadingPromotionQuote ty = space <> doc-  | otherwise                          = doc--lhsTypeHasLeadingPromotionQuote :: LHsType pass -> Bool-lhsTypeHasLeadingPromotionQuote ty-  = goL ty-  where-    goL (L _ ty) = go ty--    go (HsForAllTy{})        = False-    go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})-      | L _ (c:_) <- ctxt    = goL c-      | otherwise            = goL body-    go (HsBangTy{})          = False-    go (HsRecTy{})           = False-    go (HsTyVar _ p _)       = isPromoted p-    go (HsFunTy _ _ arg _)   = goL arg-    go (HsListTy{})          = False-    go (HsTupleTy{})         = False-    go (HsSumTy{})           = False-    go (HsOpTy _ t1 _ _)     = goL t1-    go (HsKindSig _ t _)     = goL t-    go (HsIParamTy{})        = False-    go (HsSpliceTy{})        = False-    go (HsExplicitListTy _ p _) = isPromoted p-    go (HsExplicitTupleTy{}) = True-    go (HsTyLit{})           = False-    go (HsWildCardTy{})      = False-    go (HsStarTy{})          = False-    go (HsAppTy _ t _)       = goL t-    go (HsAppKindTy _ t _)   = goL t-    go (HsParTy{})           = False-    go (HsDocTy _ t _)       = goL t-    go (XHsType{})           = False---- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is--- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply--- returns @ty@.-parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)-parenthesizeHsType p lty@(L loc ty)-  | hsTypeNeedsParens p ty = L loc (HsParTy noExtField lty)-  | otherwise              = lty---- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint--- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@--- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply--- returns @ctxt@ unchanged.-parenthesizeHsContext :: PprPrec-                      -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)-parenthesizeHsContext p lctxt@(L loc ctxt) =-  case ctxt of-    [c] -> L loc [parenthesizeHsType p c]-    _   -> lctxt -- Other contexts are already "parenthesized" by virtue of-                 -- being tuples.+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE UndecidableInstances  #-} -- Wrinkle in Note [Trees That Grow]+                                       -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++GHC.Hs.Type: Abstract syntax: user-defined types+-}++module GHC.Hs.Type (+        Mult, HsScaled(..),+        hsMult, hsScaledThing,+        HsArrow(..), arrowToHsType,+        hsLinear, hsUnrestricted, isUnrestricted,++        HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,+        HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,+        LHsQTyVars(..),+        HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,+        HsWildCardBndrs(..),+        HsPatSigType(..), HsPSRn(..),+        HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,+        HsTupleSort(..),+        HsContext, LHsContext, fromMaybeContext,+        HsTyLit(..),+        HsIPName(..), hsIPNameFS,+        HsArg(..), numVisibleArgs,+        LHsTypeArg, lhsTypeArgSrcSpan,+        OutputableBndrFlag,++        LBangType, BangType,+        HsSrcBang(..), HsImplBang(..),+        SrcStrictness(..), SrcUnpackedness(..),+        getBangType, getBangStrictness,++        ConDeclField(..), LConDeclField, pprConDeclFields,++        HsConDetails(..), noTypeArgs,++        FieldOcc(..), LFieldOcc, mkFieldOcc,+        AmbiguousFieldOcc(..), mkAmbiguousFieldOcc,+        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,+        unambiguousFieldOcc, ambiguousFieldOcc,++        mkAnonWildCardTy, pprAnonWildCard,++        hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,+        mkHsOuterImplicit, mkHsOuterExplicit,+        mkHsImplicitSigType, mkHsExplicitSigType,+        mkHsWildCardBndrs, mkHsPatSigType,+        mkEmptyWildCardBndrs,+        mkHsForAllVisTele, mkHsForAllInvisTele,+        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,+        isHsKindedTyVar, hsTvbAllKinded,+        hsScopedTvs, hsWcScopedTvs, dropWildCards,+        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,+        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,+        splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,+        splitLHsPatSynTy,+        splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,+        splitLHsSigmaTyInvis, splitLHsGadtTy,+        splitHsFunType, hsTyGetAppHead_maybe,+        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,+        ignoreParens, hsSigWcType, hsPatSigType,+        hsTyKindSig,+        setHsTyVarBndrFlag, hsTyVarBndrFlag,++        -- Printing+        pprHsType, pprHsForAll,+        pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,+        pprLHsContext,+        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext+    ) where++#include "HsVersions.h"++import GHC.Prelude++import Language.Haskell.Syntax.Type++import {-# SOURCE #-} GHC.Hs.Expr ( pprSplice )++import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Parser.Annotation++import GHC.Types.Id ( Id )+import GHC.Types.SourceText+import GHC.Types.Name( Name, NamedThing(getName) )+import GHC.Types.Name.Reader ( RdrName )+import GHC.Types.Var ( VarBndr )+import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )+import GHC.Core.Type+import GHC.Hs.Doc+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Utils.Outputable++import Data.Maybe++import qualified Data.Semigroup as S++{-+************************************************************************+*                                                                      *+\subsection{Bang annotations}+*                                                                      *+************************************************************************+-}++getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)+getBangType                 (L _ (HsBangTy _ _ lty))       = lty+getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =+  addCLocA lty lds (HsDocTy x lty lds)+getBangType lty                                            = lty++getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang+getBangStrictness                 (L _ (HsBangTy _ s _))     = s+getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s+getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)++{-+************************************************************************+*                                                                      *+\subsection{Data types}+*                                                                      *+************************************************************************+-}++fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt++type instance XHsForAllVis   (GhcPass _) = EpAnnForallTy+                                           -- Location of 'forall' and '->'+type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy+                                           -- Location of 'forall' and '.'++type instance XXHsForAllTelescope (GhcPass _) = NoExtCon++type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn)+  -- ^ Location of 'forall' and '->' for HsForAllVis+  -- Location of 'forall' and '.' for HsForAllInvis++type HsQTvsRn = [Name]  -- Implicit variables+  -- For example, in   data T (a :: k1 -> k2) = ...+  -- the 'a' is explicit while 'k1', 'k2' are implicit++type instance XHsQTvs GhcPs = NoExtField+type instance XHsQTvs GhcRn = HsQTvsRn+type instance XHsQTvs GhcTc = HsQTvsRn++type instance XXLHsQTyVars  (GhcPass _) = NoExtCon++mkHsForAllVisTele ::EpAnnForallTy ->+  [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)+mkHsForAllVisTele an vis_bndrs =+  HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs }++mkHsForAllInvisTele :: EpAnnForallTy+  -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)+mkHsForAllInvisTele an invis_bndrs =+  HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs }++mkHsQTvs :: [LHsTyVarBndr () GhcPs] -> LHsQTyVars GhcPs+mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }++emptyLHsQTvs :: LHsQTyVars GhcRn+emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }++------------------------------------------------+--            HsOuterTyVarBndrs++type instance XHsOuterImplicit GhcPs = NoExtField+type instance XHsOuterImplicit GhcRn = [Name]+type instance XHsOuterImplicit GhcTc = [TyVar]++type instance XHsOuterExplicit GhcPs _    = EpAnnForallTy+type instance XHsOuterExplicit GhcRn _    = NoExtField+type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag]++type instance XXHsOuterTyVarBndrs (GhcPass _) = NoExtCon++type instance XHsWC              GhcPs b = NoExtField+type instance XHsWC              GhcRn b = [Name]+type instance XHsWC              GhcTc b = [Name]++type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon++type instance XHsPS GhcPs = EpAnn EpaLocation+type instance XHsPS GhcRn = HsPSRn+type instance XHsPS GhcTc = HsPSRn++type instance XXHsPatSigType (GhcPass _) = NoExtCon++type instance XHsSig (GhcPass _) = NoExtField+type instance XXHsSigType (GhcPass _) = NoExtCon++hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p+hsSigWcType = sig_body . unXRec @p . hswc_body++dropWildCards :: LHsSigWcType pass -> LHsSigType pass+-- Drop the wildcard part of a LHsSigWcType+dropWildCards sig_ty = hswc_body sig_ty++hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]+hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs+hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs})       = hsLTyVarNames bndrs++hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)+                     -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]+hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs+hsOuterExplicitBndrs (HsOuterImplicit{})                  = []++mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs+mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField}++mkHsOuterExplicit :: EpAnnForallTy -> [LHsTyVarBndr flag GhcPs]+                  -> HsOuterTyVarBndrs flag GhcPs+mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an+                                             , hso_bndrs     = bndrs }++mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs+mkHsImplicitSigType body =+  HsSig { sig_ext   = noExtField+        , sig_bndrs = mkHsOuterImplicit, sig_body = body }++mkHsExplicitSigType :: EpAnnForallTy+                    -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs+                    -> HsSigType GhcPs+mkHsExplicitSigType an bndrs body =+  HsSig { sig_ext = noExtField+        , sig_bndrs = mkHsOuterExplicit an bndrs, sig_body = body }++mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing+mkHsWildCardBndrs x = HsWC { hswc_body = x+                           , hswc_ext  = noExtField }++mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs+mkHsPatSigType ann x = HsPS { hsps_ext  = ann+                            , hsps_body = x }++mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing+mkEmptyWildCardBndrs x = HsWC { hswc_body = x+                              , hswc_ext  = [] }++--------------------------------------------------++type instance XUserTyVar    (GhcPass _) = EpAnn [AddEpAnn]+type instance XKindedTyVar  (GhcPass _) = EpAnn [AddEpAnn]++type instance XXTyVarBndr   (GhcPass _) = NoExtCon++-- | Return the attached flag+hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag+hsTyVarBndrFlag (UserTyVar _ fl _)     = fl+hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl++-- | Set the attached flag+setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)+  -> HsTyVarBndr flag (GhcPass pass)+setHsTyVarBndrFlag f (UserTyVar x _ l)     = UserTyVar x f l+setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k++-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?+hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool+hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit++instance NamedThing (HsTyVarBndr flag GhcRn) where+  getName (UserTyVar _ _ v) = unLoc v+  getName (KindedTyVar _ _ v _) = unLoc v++type instance XForAllTy        (GhcPass _) = NoExtField+type instance XQualTy          (GhcPass _) = NoExtField+type instance XTyVar           (GhcPass _) = EpAnn [AddEpAnn]+type instance XAppTy           (GhcPass _) = NoExtField+type instance XFunTy           (GhcPass _) = EpAnn TrailingAnn -- For the AnnRarrow or AnnLolly+type instance XListTy          (GhcPass _) = EpAnn AnnParen+type instance XTupleTy         (GhcPass _) = EpAnn AnnParen+type instance XSumTy           (GhcPass _) = EpAnn AnnParen+type instance XOpTy            (GhcPass _) = NoExtField+type instance XParTy           (GhcPass _) = EpAnn AnnParen+type instance XIParamTy        (GhcPass _) = EpAnn [AddEpAnn]+type instance XStarTy          (GhcPass _) = NoExtField+type instance XKindSig         (GhcPass _) = EpAnn [AddEpAnn]++type instance XAppKindTy       (GhcPass _) = SrcSpan -- Where the `@` lives++type instance XSpliceTy        GhcPs = NoExtField+type instance XSpliceTy        GhcRn = NoExtField+type instance XSpliceTy        GhcTc = Kind++type instance XDocTy           (GhcPass _) = EpAnn [AddEpAnn]+type instance XBangTy          (GhcPass _) = EpAnn [AddEpAnn]++type instance XRecTy           GhcPs = EpAnn AnnList+type instance XRecTy           GhcRn = NoExtField+type instance XRecTy           GhcTc = NoExtField++type instance XExplicitListTy  GhcPs = EpAnn [AddEpAnn]+type instance XExplicitListTy  GhcRn = NoExtField+type instance XExplicitListTy  GhcTc = Kind++type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn]+type instance XExplicitTupleTy GhcRn = NoExtField+type instance XExplicitTupleTy GhcTc = [Kind]++type instance XTyLit           (GhcPass _) = NoExtField++type instance XWildCardTy      (GhcPass _) = NoExtField++type instance XXType         (GhcPass _) = HsCoreTy+++oneDataConHsTy :: HsType GhcRn+oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)++manyDataConHsTy :: HsType GhcRn+manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName)++isUnrestricted :: HsArrow GhcRn -> Bool+isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName+isUnrestricted _ = False++-- | Convert an arrow into its corresponding multiplicity. In essence this+-- erases the information of whether the programmer wrote an explicit+-- multiplicity or a shorthand.+arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn+arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy+arrowToHsType (HsLinearArrow _ _) = noLocA oneDataConHsTy+arrowToHsType (HsExplicitMult _ _ p) = p++instance+      (OutputableBndrId pass) =>+      Outputable (HsArrow (GhcPass pass)) where+  ppr arr = parens (pprHsArrow arr)++-- See #18846+pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc+pprHsArrow (HsUnrestrictedArrow _) = arrow+pprHsArrow (HsLinearArrow _ _) = lollipop+pprHsArrow (HsExplicitMult _ _ p) = (mulArrow (ppr p))++type instance XConDeclField  (GhcPass _) = EpAnn [AddEpAnn]+type instance XXConDeclField (GhcPass _) = NoExtCon++instance OutputableBndrId p+       => Outputable (ConDeclField (GhcPass p)) where+  ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty++---------------------+hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]+-- Get the lexically-scoped type variables of an LHsSigWcType:+--  - the explicitly-given forall'd type variables;+--    see Note [Lexically scoped type variables]+--  - the named wildcards; see Note [Scoping of named wildcards]+-- because they scope in the same way+hsWcScopedTvs sig_wc_ty+  | HsWC { hswc_ext = nwcs, hswc_body = sig_ty }  <- sig_wc_ty+  , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty+  = nwcs ++ hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)+    -- See Note [hsScopedTvs and visible foralls]++hsScopedTvs :: LHsSigType GhcRn -> [Name]+-- Same as hsWcScopedTvs, but for a LHsSigType+hsScopedTvs (L _ (HsSig{sig_bndrs = outer_bndrs}))+  = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)+    -- See Note [hsScopedTvs and visible foralls]++---------------------+hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)+hsTyVarName (UserTyVar _ _ (L _ n))     = n+hsTyVarName (KindedTyVar _ _ (L _ n) _) = n++hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)+hsLTyVarName = hsTyVarName . unLoc++hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]+hsLTyVarNames = map hsLTyVarName++hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]+-- Explicit variables only+hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)++hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]+-- All variables+hsAllLTyVarNames (HsQTvs { hsq_ext = kvs+                         , hsq_explicit = tvs })+  = kvs ++ hsLTyVarNames tvs++hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))+hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)++hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]+hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs)++-- | Get the kind signature of a type, ignoring parentheses:+--+--   hsTyKindSig   `Maybe                    `   =   Nothing+--   hsTyKindSig   `Maybe ::   Type -> Type  `   =   Just  `Type -> Type`+--   hsTyKindSig   `Maybe :: ((Type -> Type))`   =   Just  `Type -> Type`+--+-- This is used to extract the result kind of type synonyms with a CUSK:+--+--  type S = (F :: res_kind)+--                 ^^^^^^^^+--+hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p))+hsTyKindSig lty =+  case unLoc lty of+    HsParTy _ lty'    -> hsTyKindSig lty'+    HsKindSig _ _ k   -> Just k+    _                 -> Nothing++---------------------+ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty+ignoreParens ty                   = ty++{-+************************************************************************+*                                                                      *+                Building types+*                                                                      *+************************************************************************+-}++mkAnonWildCardTy :: HsType GhcPs+mkAnonWildCardTy = HsWildCardTy noExtField++mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)+         => LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))+         -> LHsType (GhcPass p) -> HsType (GhcPass p)+mkHsOpTy ty1 op ty2 = HsOpTy noExtField ty1 op ty2++mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+mkHsAppTy t1 t2+  = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))++mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]+           -> LHsType (GhcPass p)+mkHsAppTys = foldl' mkHsAppTy++mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+              -> LHsType (GhcPass p)+mkHsAppKindTy ext ty k+  = addCLocAA ty k (HsAppKindTy ext ty k)++{-+************************************************************************+*                                                                      *+                Decomposing HsTypes+*                                                                      *+************************************************************************+-}++---------------------------------+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)+-- Breaks up any parens in the result type:+--      splitHsFunType (a -> (b -> c)) = ([a,b], c)+-- It returns API Annotations for any parens removed+splitHsFunType ::+     LHsType (GhcPass p)+  -> ( [AddEpAnn], EpAnnComments -- The locations of any parens and+                                  -- comments discarded+     , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))+splitHsFunType ty = go ty+  where+    go (L l (HsParTy an ty))+      = let+          (anns, cs, args, res) = splitHsFunType ty+          anns' = anns ++ annParen2AddEpAnn an+          cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an+        in (anns', cs', args, res)++    go (L ll (HsFunTy (EpAnn _ an cs) mult x y))+      | (anns, csy, args, res) <- splitHsFunType y+      = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)+      where+        (L (SrcSpanAnn a l) t) = x+        an' = addTrailingAnnToA l an cs a+        x' = L (SrcSpanAnn an' l) t++    go other = ([], emptyComments, [], other)++-- | Retrieve the name of the \"head\" of a nested type application.+-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more+-- thorough. The purpose of this function is to examine instance heads, so it+-- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).+hsTyGetAppHead_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)+                     => LHsType (GhcPass p)+                     -> Maybe (LocatedN (IdP (GhcPass p)))+hsTyGetAppHead_maybe = go+  where+    go (L _ (HsTyVar _ _ ln))          = Just ln+    go (L _ (HsAppTy _ l _))           = go l+    go (L _ (HsAppKindTy _ t _))       = go t+    go (L _ (HsOpTy _ _ ln _))         = Just ln+    go (L _ (HsParTy _ t))             = go t+    go (L _ (HsKindSig _ t _))         = go t+    go _                               = Nothing++------------------------------------------------------------++-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.+lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan+lhsTypeArgSrcSpan arg = case arg of+  HsValArg  tm    -> getLocA tm+  HsTypeArg at ty -> at `combineSrcSpans` getLocA ty+  HsArgPar  sp    -> sp++--------------------------------++-- | Decompose a pattern synonym type signature into its constituent parts.+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsPatSynTy ::+     LHsSigType (GhcPass p)+  -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals+     , Maybe (LHsContext (GhcPass p))                       -- required constraints+     , [LHsTyVarBndr Specificity (GhcPass p)]               -- existentials+     , Maybe (LHsContext (GhcPass p))                       -- provided constraints+     , LHsType (GhcPass p))                                 -- body type+splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)+  where+    -- split_sig_ty ::+    --      LHsSigType (GhcPass p)+    --   -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p))+    split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) =+      case outer_bndrs of+        -- NB: Use ignoreParens here in order to be consistent with the use of+        -- splitLHsForAllTyInvis below, which also looks through parentheses.+        HsOuterImplicit{}                      -> ([], ignoreParens body)+        HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body)++    (univs,       ty1) = split_sig_ty ty+    (reqs,        ty2) = splitLHsQualTy ty1+    ((_an, exis), ty3) = splitLHsForAllTyInvis ty2+    (provs,       ty4) = splitLHsQualTy ty3++-- | Decompose a sigma type (of the form @forall <tvs>. context => body@)+-- into its constituent parts.+-- Only splits type variable binders that were+-- quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsSigmaTyInvis :: LHsType (GhcPass p)+                     -> ([LHsTyVarBndr Specificity (GhcPass p)]+                        , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))+splitLHsSigmaTyInvis ty+  | ((_an,tvs), ty1) <- splitLHsForAllTyInvis ty+  , (ctxt,      ty2) <- splitLHsQualTy ty1+  = (tvs, ctxt, ty2)++-- | Decompose a GADT type into its constituent parts.+-- Returns @(outer_bndrs, mb_ctxt, body)@, where:+--+-- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost+--   type variable binders. Otherwise, they are 'HsOuterImplicit'.+--+-- * @mb_ctxt@ is @Just@ the context, if it is provided.+--   Otherwise, it is @Nothing@.+--+-- * @body@ is the body of the type after the optional @forall@s and context.+--+-- This function is careful not to look through parentheses.+-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@+-- "GHC.Hs.Decls" for why this is important.+splitLHsGadtTy ::+     LHsSigType GhcPs+  -> (HsOuterSigTyVarBndrs GhcPs, Maybe (LHsContext GhcPs), LHsType GhcPs)+splitLHsGadtTy (L _ sig_ty)+  | (outer_bndrs, rho_ty) <- split_bndrs sig_ty+  , (mb_ctxt, tau_ty)     <- splitLHsQualTy_KP rho_ty+  = (outer_bndrs, mb_ctxt, tau_ty)+  where+    split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)+    split_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =+      (outer_bndrs, body_ty)++-- | Decompose a type of the form @forall <tvs>. body@ into its constituent+-- parts. Only splits type variable binders that+-- were quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+-- Unlike 'splitLHsSigmaTyInvis', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsForAllTyInvis ::+  LHsType (GhcPass pass) -> ( (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])+                            , LHsType (GhcPass pass))+splitLHsForAllTyInvis ty+  | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)+  = (fromMaybe (EpAnnNotUsed,[]) mb_tvbs, body)++-- | Decompose a type of the form @forall <tvs>. body@ into its constituent+-- parts. Only splits type variable binders that+-- were quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Unlike 'splitLHsForAllTyInvis', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsForAllTyInvis_KP ::+  LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])+                            , LHsType (GhcPass pass))+splitLHsForAllTyInvis_KP lty@(L _ ty) =+  case ty of+    HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an+                                          , hsf_invis_bndrs = tvs }+               , hst_body = body }+      -> (Just (an, tvs), body)+    _ -> (Nothing, lty)++-- | Decompose a type of the form @context => body@ into its constituent parts.+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(context => <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsQualTy :: LHsType (GhcPass pass)+               -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))+splitLHsQualTy ty+  | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)+  = (mb_ctxt, body)++-- | Decompose a type of the form @context => body@ into its constituent parts.+--+-- Unlike 'splitLHsQualTy', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))+splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))+                       = (ctxt, body)+splitLHsQualTy_KP body = (Nothing, body)++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into its constituent parts.+-- Note that the @[Name]@s returned correspond to either:+--+-- * The implicitly bound type variables (if the type lacks an outermost+--   @forall@), or+--+-- * The explicitly bound type variables (if the type has an outermost+--   @forall@).+--+-- This function is careful not to look through parentheses.+-- See @Note [No nested foralls or contexts in instance types]@+-- for why this is important.+splitLHsInstDeclTy :: LHsSigType GhcRn+                   -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)+splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =+  (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)+  where+    (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into the @instance_head@.+getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)+getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty}))+  | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty+  = body_ty++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into the @instance_head@ and+-- retrieve the underlying class type constructor (if it exists).+getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)+                          => LHsSigType (GhcPass p)+                          -> Maybe (LocatedN (IdP (GhcPass p)))+-- Works on (LHsSigType GhcPs)+getLHsInstDeclClass_maybe inst_ty+  = do { let head_ty = getLHsInstDeclHead inst_ty+       ; hsTyGetAppHead_maybe head_ty+       }++{-+Note [No nested foralls or contexts in instance types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type at the top of an instance declaration is one of the few places in GHC+where nested `forall`s or contexts are not permitted, even with RankNTypes+enabled. For example, the following will be rejected:++  instance forall a. forall b. Show (Either a b) where ...+  instance Eq a => Eq b => Show (Either a b) where ...+  instance (forall a. Show (Maybe a)) where ...+  instance (Eq a => Show (Maybe a)) where ...++This restriction is partly motivated by an unusual quirk of instance+declarations. Namely, if ScopedTypeVariables is enabled, then the type+variables from the top of an instance will scope over the bodies of the+instance methods, /even if the type variables are implicitly quantified/.+For example, GHC will accept the following:++  instance Monoid a => Monoid (Identity a) where+    mempty = Identity (mempty @a)++Moreover, the type in the top of an instance declaration must obey the+forall-or-nothing rule (see Note [forall-or-nothing rule]).+If instance types allowed nested `forall`s, this could+result in some strange interactions. For example, consider the following:++  class C a where+    m :: Proxy a+  instance (forall a. C (Either a b)) where+    m = Proxy @(Either a b)++Somewhat surprisingly, old versions of GHC would accept the instance above.+Even though the `forall` only quantifies `a`, the outermost parentheses mean+that the `forall` is nested, and per the forall-or-nothing rule, this means+that implicit quantification would occur. Therefore, the `a` is explicitly+bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would+bring /both/ sorts of type variables into scope over the body of `m`.+How utterly confusing!++To avoid this sort of confusion, we simply disallow nested `forall`s in+instance types, which makes things like the instance above become illegal.+For the sake of consistency, we also disallow nested contexts, even though they+don't have the same strange interaction with ScopedTypeVariables.++Just as we forbid nested `forall`s and contexts in normal instance+declarations, we also forbid them in SPECIALISE instance pragmas (#18455).+Unlike normal instance declarations, ScopedTypeVariables don't have any impact+on SPECIALISE instance pragmas, but we use the same validity checks for+SPECIALISE instance pragmas anyway to be consistent.++-----+-- Wrinkle: Derived instances+-----++`deriving` clauses and standalone `deriving` declarations also permit bringing+type variables into scope, either through explicit or implicit quantification.+Unlike in the tops of instance declarations, however, one does not need to+enable ScopedTypeVariables for this to take effect.++Just as GHC forbids nested `forall`s in the top of instance declarations, it+also forbids them in types involved with `deriving`:++1. In the `via` types in DerivingVia. For example, this is rejected:++     deriving via (forall x. V x) instance C (S x)++   Just like the types in instance declarations, `via` types can also bring+   both implicitly and explicitly bound type variables into scope. As a result,+   we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing+   behavior like in the example below:++     deriving via (forall x. T x y) instance W x y (Foo a b)+     -- Both x and y are brought into scope???+2. In the classes in `deriving` clauses. For example, this is rejected:++     data T = MkT deriving (C1, (forall x. C2 x y))++   This is because the generated instance would look like:++     instance forall x y. C2 x y T where ...++   So really, the same concerns as instance declarations apply here as well.+-}++{-+************************************************************************+*                                                                      *+                FieldOcc+*                                                                      *+************************************************************************+-}++type instance XCFieldOcc GhcPs = NoExtField+type instance XCFieldOcc GhcRn = Name+type instance XCFieldOcc GhcTc = Id++type instance XXFieldOcc (GhcPass _) = NoExtCon++mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs+mkFieldOcc rdr = FieldOcc noExtField rdr+++type instance XUnambiguous GhcPs = NoExtField+type instance XUnambiguous GhcRn = Name+type instance XUnambiguous GhcTc = Id++type instance XAmbiguous GhcPs = NoExtField+type instance XAmbiguous GhcRn = NoExtField+type instance XAmbiguous GhcTc = Id++type instance XXAmbiguousFieldOcc (GhcPass _) = NoExtCon++instance Outputable (AmbiguousFieldOcc (GhcPass p)) where+  ppr = ppr . rdrNameAmbiguousFieldOcc++instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where+  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc+  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc++mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs+mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr++rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName+rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr+rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr++selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id+selectorAmbiguousFieldOcc (Unambiguous sel _) = sel+selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel++unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc+unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel+unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel++ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc+ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++class OutputableBndrFlag flag p where+    pprTyVarBndr :: OutputableBndrId p+                 => HsTyVarBndr flag (GhcPass p) -> SDoc++instance OutputableBndrFlag () p where+    pprTyVarBndr (UserTyVar _ _ n) --     = pprIdP n+      = case ghcPass @p of+          GhcPs -> ppr n+          GhcRn -> ppr n+          GhcTc -> ppr n+    pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr_n, dcolon, ppr k]+      where+        ppr_n = case ghcPass @p of+          GhcPs -> ppr n+          GhcRn -> ppr n+          GhcTc -> ppr n++instance OutputableBndrFlag Specificity p where+    pprTyVarBndr (UserTyVar _ SpecifiedSpec n) --     = pprIdP n+      = case ghcPass @p of+          GhcPs -> ppr n+          GhcRn -> ppr n+          GhcTc -> ppr n+    pprTyVarBndr (UserTyVar _ InferredSpec n)      = braces $ ppr_n+      where+        ppr_n = case ghcPass @p of+          GhcPs -> ppr n+          GhcRn -> ppr n+          GhcTc -> ppr n+    pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr_n, dcolon, ppr k]+      where+        ppr_n = case ghcPass @p of+          GhcPs -> ppr n+          GhcRn -> ppr n+          GhcTc -> ppr n+    pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr_n, dcolon, ppr k]+      where+        ppr_n = case ghcPass @p of+          GhcPs -> ppr n+          GhcRn -> ppr n+          GhcTc -> ppr n++instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where+    ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =+      pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body++instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where+    ppr ty = pprHsType ty++instance OutputableBndrId p+       => Outputable (LHsQTyVars (GhcPass p)) where+    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs++instance (OutputableBndrFlag flag p,+          OutputableBndrFlag flag (NoGhcTcPass p),+          OutputableBndrId p)+       => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where+    ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) =+      text "HsOuterImplicit:" <+> case ghcPass @p of+        GhcPs -> ppr imp_tvs+        GhcRn -> ppr imp_tvs+        GhcTc -> ppr imp_tvs+    ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) =+      text "HsOuterExplicit:" <+> ppr exp_tvs++instance OutputableBndrId p+       => Outputable (HsForAllTelescope (GhcPass p)) where+    ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =+      text "HsForAllVis:" <+> ppr bndrs+    ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =+      text "HsForAllInvis:" <+> ppr bndrs++instance (OutputableBndrId p, OutputableBndrFlag flag p)+       => Outputable (HsTyVarBndr flag (GhcPass p)) where+    ppr = pprTyVarBndr++instance Outputable thing+       => Outputable (HsWildCardBndrs (GhcPass p) thing) where+    ppr (HsWC { hswc_body = ty }) = ppr ty++instance (OutputableBndrId p)+       => Outputable (HsPatSigType (GhcPass p)) where+    ppr (HsPS { hsps_body = ty }) = ppr ty++pprAnonWildCard :: SDoc+pprAnonWildCard = char '_'++-- | Prints the explicit @forall@ in a type family equation if one is written.+-- If there is no explicit @forall@, nothing is printed.+pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p+                           => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc+pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty+pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) =+  forAllLit <+> interppSP qtvs <> dot++-- | Prints the outermost @forall@ in a type signature if one is written.+-- If there is no outermost @forall@, nothing is printed.+pprHsOuterSigTyVarBndrs :: OutputableBndrId p+                        => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc+pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty+pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =+  pprHsForAll (mkHsForAllInvisTele noAnn bndrs) Nothing++-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@+-- only when @-dppr-debug@ is enabled.+pprHsForAll :: forall p. OutputableBndrId p+            => HsForAllTelescope (GhcPass p)+            -> Maybe (LHsContext (GhcPass p)) -> SDoc+pprHsForAll tele cxt+  = pp_tele tele <+> pprLHsContext cxt+  where+    pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc+    pp_tele tele = case tele of+      HsForAllVis   { hsf_vis_bndrs   = qtvs } -> pp_forall (space <> arrow) qtvs+      HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs++    pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p)+              => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc+    pp_forall separator qtvs+      | null qtvs = whenPprDebug (forAllLit <> separator)+  -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <>+  -- below needs to be <+>. But it means 94 other test results need to+  -- be updated to match.+      | otherwise = forAllLit <+> interppSP qtvs <> separator++pprLHsContext :: (OutputableBndrId p)+              => Maybe (LHsContext (GhcPass p)) -> SDoc+pprLHsContext Nothing = empty+pprLHsContext (Just lctxt)+  | null (unLoc lctxt) = empty+  | otherwise          = pprLHsContextAlways (Just lctxt)++-- For use in a HsQualTy, which always gets printed if it exists.+pprLHsContextAlways :: (OutputableBndrId p)+                    => Maybe (LHsContext (GhcPass p)) -> SDoc+pprLHsContextAlways Nothing = parens empty <+> darrow+pprLHsContextAlways (Just (L _ ctxt))+  = case ctxt of+      []       -> parens empty             <+> darrow+      [L _ ty] -> ppr_mono_ty ty           <+> darrow+      _        -> parens (interpp'SP ctxt) <+> darrow++pprConDeclFields :: OutputableBndrId p+                 => [LConDeclField (GhcPass p)] -> SDoc+pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))+  where+    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,+                                 cd_fld_doc = doc }))+        = ppr_names ns <+> dcolon <+> ppr ty <+> ppr_mbDoc doc++    ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc+    ppr_names [n] = pprPrefixOcc n+    ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))++{-+Note [Printing KindedTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#3830 reminded me that we should really only print the kind+signature on a KindedTyVar if the kind signature was put there by the+programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,+rather than converting to KindedTyVars as before.++(As it happens, the message in #3830 comes out a different way now,+and the problem doesn't show up; but having the flag on a KindedTyVar+seems like the Right Thing anyway.)+-}++-- Printing works more-or-less as for Types++pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc+pprHsType ty = ppr_mono_ty ty++ppr_mono_lty :: OutputableBndrId p+             => LHsType (GhcPass p) -> SDoc+ppr_mono_lty ty = ppr_mono_ty (unLoc ty)++ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc+ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })+  = sep [pprHsForAll tele Nothing, ppr_mono_lty ty]++ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })+  = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]++ppr_mono_ty (HsBangTy _ b ty)   = ppr b <> ppr_mono_lty ty+ppr_mono_ty (HsRecTy _ flds)      = pprConDeclFields flds+ppr_mono_ty (HsTyVar _ prom (L _ name))+  | isPromoted prom = quote (pprPrefixOcc name)+  | otherwise       = pprPrefixOcc name+ppr_mono_ty (HsFunTy _ mult ty1 ty2)   = ppr_fun_ty mult ty1 ty2+ppr_mono_ty (HsTupleTy _ con tys)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `Solo x`, not `(x)`+  | [ty] <- tys+  , BoxedTuple <- std_con+  = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]+  | otherwise+  = tupleParens std_con (pprWithCommas ppr tys)+  where std_con = case con of+                    HsUnboxedTuple -> UnboxedTuple+                    _              -> BoxedTuple+ppr_mono_ty (HsSumTy _ tys)+  = tupleParens UnboxedTuple (pprWithBars ppr tys)+ppr_mono_ty (HsKindSig _ ty kind)+  = ppr_mono_lty ty <+> dcolon <+> ppr kind+ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)+ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)+ppr_mono_ty (HsSpliceTy _ s)      = pprSplice s+ppr_mono_ty (HsExplicitListTy _ prom tys)+  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)+  | otherwise       = brackets (interpp'SP tys)+ppr_mono_ty (HsExplicitTupleTy _ tys)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `'Solo x`, not `'(x)`+  | [ty] <- tys+  = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]+  | otherwise+  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)+ppr_mono_ty (HsTyLit _ t)       = ppr t+ppr_mono_ty (HsWildCardTy {})   = char '_'++ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')++ppr_mono_ty (HsAppTy _ fun_ty arg_ty)+  = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]+ppr_mono_ty (HsAppKindTy _ ty k)+  = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k+ppr_mono_ty (HsOpTy _ ty1 (L _ op) ty2)+  = sep [ ppr_mono_lty ty1+        , sep [pprInfixOcc op, ppr_mono_lty ty2 ] ]++ppr_mono_ty (HsParTy _ ty)+  = parens (ppr_mono_lty ty)+  -- Put the parens in where the user did+  -- But we still use the precedence stuff to add parens because+  --    toHsType doesn't put in any HsParTys, so we may still need them++ppr_mono_ty (HsDocTy _ ty doc)+  -- AZ: Should we add parens?  Should we introduce "-- ^"?+  = ppr_mono_lty ty <+> ppr (unLoc doc)+  -- we pretty print Haddock comments on types as if they were+  -- postfix operators++ppr_mono_ty (XHsType t) = ppr t++--------------------------+ppr_fun_ty :: (OutputableBndrId p)+           => HsArrow (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc+ppr_fun_ty mult ty1 ty2+  = let p1 = ppr_mono_lty ty1+        p2 = ppr_mono_lty ty2+        arr = pprHsArrow mult+    in+    sep [p1, arr <+> p2]++--------------------------+-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses+-- under precedence @p@.+hsTypeNeedsParens :: PprPrec -> HsType (GhcPass p) -> Bool+hsTypeNeedsParens p = go_hs_ty+  where+    go_hs_ty (HsForAllTy{})           = p >= funPrec+    go_hs_ty (HsQualTy{})             = p >= funPrec+    go_hs_ty (HsBangTy{})             = p > topPrec+    go_hs_ty (HsRecTy{})              = False+    go_hs_ty (HsTyVar{})              = False+    go_hs_ty (HsFunTy{})              = p >= funPrec+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go_hs_ty (HsTupleTy _ con [_])+      = case con of+          HsBoxedOrConstraintTuple   -> p >= appPrec+          HsUnboxedTuple             -> False+    go_hs_ty (HsTupleTy{})            = False+    go_hs_ty (HsSumTy{})              = False+    go_hs_ty (HsKindSig{})            = p >= sigPrec+    go_hs_ty (HsListTy{})             = False+    go_hs_ty (HsIParamTy{})           = p > topPrec+    go_hs_ty (HsSpliceTy{})           = False+    go_hs_ty (HsExplicitListTy{})     = False+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Proxy ('Solo x)`, not `Proxy 'Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go_hs_ty (HsExplicitTupleTy _ [_])+                                      = p >= appPrec+    go_hs_ty (HsExplicitTupleTy{})    = False+    go_hs_ty (HsTyLit{})              = False+    go_hs_ty (HsWildCardTy{})         = False+    go_hs_ty (HsStarTy{})             = p >= starPrec+    go_hs_ty (HsAppTy{})              = p >= appPrec+    go_hs_ty (HsAppKindTy{})          = p >= appPrec+    go_hs_ty (HsOpTy{})               = p >= opPrec+    go_hs_ty (HsParTy{})              = False+    go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t+    go_hs_ty (XHsType ty)             = go_core_ty ty++    go_core_ty (TyVarTy{})    = False+    go_core_ty (AppTy{})      = p >= appPrec+    go_core_ty (TyConApp _ args)+      | null args             = False+      | otherwise             = p >= appPrec+    go_core_ty (ForAllTy{})   = p >= funPrec+    go_core_ty (FunTy{})      = p >= funPrec+    go_core_ty (LitTy{})      = False+    go_core_ty (CastTy t _)   = go_core_ty t+    go_core_ty (CoercionTy{}) = False++maybeAddSpace :: [LHsType (GhcPass p)] -> SDoc -> SDoc+-- See Note [Printing promoted type constructors]+-- in GHC.Iface.Type.  This code implements the same+-- logic for printing HsType+maybeAddSpace tys doc+  | (ty : _) <- tys+  , lhsTypeHasLeadingPromotionQuote ty = space <> doc+  | otherwise                          = doc++lhsTypeHasLeadingPromotionQuote :: LHsType (GhcPass p) -> Bool+lhsTypeHasLeadingPromotionQuote ty+  = goL ty+  where+    goL (L _ ty) = go ty++    go (HsForAllTy{})        = False+    go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})+      | Just (L _ (c:_)) <- ctxt = goL c+      | otherwise            = goL body+    go (HsBangTy{})          = False+    go (HsRecTy{})           = False+    go (HsTyVar _ p _)       = isPromoted p+    go (HsFunTy _ _ arg _)   = goL arg+    go (HsListTy{})          = False+    go (HsTupleTy{})         = False+    go (HsSumTy{})           = False+    go (HsOpTy _ t1 _ _)     = goL t1+    go (HsKindSig _ t _)     = goL t+    go (HsIParamTy{})        = False+    go (HsSpliceTy{})        = False+    go (HsExplicitListTy _ p _) = isPromoted p+    go (HsExplicitTupleTy{}) = True+    go (HsTyLit{})           = False+    go (HsWildCardTy{})      = False+    go (HsStarTy{})          = False+    go (HsAppTy _ t _)       = goL t+    go (HsAppKindTy _ t _)   = goL t+    go (HsParTy{})           = False+    go (HsDocTy _ t _)       = goL t+    go (XHsType{})           = False++-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is+-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply+-- returns @ty@.+parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)+parenthesizeHsType p lty@(L loc ty)+  | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)+  | otherwise              = lty++-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint+-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@+-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply+-- returns @ctxt@ unchanged.+parenthesizeHsContext :: PprPrec+                      -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)+parenthesizeHsContext p lctxt@(L loc ctxt) =+  case ctxt of+    [c] -> L loc [parenthesizeHsType p c]+    _   -> lctxt -- Other contexts are already "parenthesized" by virtue of+                 -- being tuples.+{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (BangType (GhcPass p)) = SrcSpanAnnA+type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC+type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA++type instance Anno (HsTyVarBndr _flag (GhcPass _)) = SrcSpanAnnA+  -- Explicit pass Anno instances needed because of the NoGhcTc field+type instance Anno (HsTyVarBndr _flag GhcPs) = SrcSpanAnnA+type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA+type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA++type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA+type instance Anno HsIPName = SrcSpan+type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA+type instance Anno (FieldOcc (GhcPass p)) = SrcSpan

GHC/Hs/Utils.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-| Module      : GHC.Hs.Utils Description : Generic helpers for the HsSyn type.@@ -28,6 +29,8 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -39,7 +42,7 @@   mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,   mkHsDictLet, mkHsLams,-  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,+  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,   mkHsCmdIf, @@ -48,6 +51,7 @@   nlHsIntLit, nlHsVarApps,   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,   mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,+  mkLocatedList,    -- * Constructing general big tuples   -- $big_tuples@@ -57,9 +61,11 @@   mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,   mkPatSynBind,   isInfixFunBind,+  spanHsLocaLBinds,    -- * Literals   mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,+  mkHsCharPrimLit,    -- * Patterns   mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,@@ -69,7 +75,7 @@    -- * Types   mkHsAppTy, mkHsAppKindTy,-  mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,+  hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv,   nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,    -- * Stmts@@ -79,6 +85,7 @@   emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,   emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,   unitRecStmtTc,+  mkLetStmt,    -- * Template Haskell   mkUntypedSplice, mkTypedSplice,@@ -90,10 +97,11 @@   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,   collectHsIdBinders,   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,+   collectPatBinders, collectPatsBinders,   collectLStmtsBinders, collectStmtsBinders,   collectLStmtBinders, collectStmtBinders,-  CollectPass(..),+  CollectPass(..), CollectFlag(..),    hsLTyClDeclBinders, hsTyClForeignBinders,   hsPatSynSelectors, getPatSynBinds,@@ -113,11 +121,11 @@ import GHC.Hs.Pat import GHC.Hs.Type import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension import GHC.Hs.Extension+import GHC.Parser.Annotation  import GHC.Tc.Types.Evidence-import GHC.Types.Name.Reader-import GHC.Types.Var import GHC.Core.TyCo.Rep import GHC.Core.Multiplicity ( pattern Many ) import GHC.Builtin.Types ( unitTy )@@ -128,19 +136,25 @@ import GHC.Types.Name import GHC.Types.Name.Set hiding ( unitFV ) import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.Var import GHC.Types.Basic import GHC.Types.SrcLoc+import GHC.Types.Fixity+import GHC.Types.SourceText import GHC.Data.FastString-import GHC.Utils.Misc import GHC.Data.Bag-import GHC.Utils.Outputable import GHC.Settings.Constants-import GHC.Parser.Annotation +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import Data.Either import Data.Function-import Data.List+import Data.List ( partition, deleteBy ) import Data.Proxy+import Data.Data (Data)  {- ************************************************************************@@ -156,53 +170,69 @@  -- | @e => (e)@ mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsPar e = L (getLoc e) (HsPar noExtField e)+mkHsPar e = L (getLoc e) (HsPar noAnn e) -mkSimpleMatch :: HsMatchContext (NoGhcTc (GhcPass p))-              -> [LPat (GhcPass p)] -> Located (body (GhcPass p))-              -> LMatch (GhcPass p) (Located (body (GhcPass p)))+mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpanAnnA,+                  Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpan)+              => HsMatchContext (NoGhcTc (GhcPass p))+              -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))+              -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch ctxt pats rhs   = L loc $-    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = pats-          , m_grhss = unguardedGRHSs rhs }+    Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = pats+          , m_grhss = unguardedGRHSs (locA loc) rhs noAnn }   where     loc = case pats of                 []      -> getLoc rhs-                (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)+                (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) -unguardedGRHSs :: Located (body (GhcPass p))-               -> GRHSs (GhcPass p) (Located (body (GhcPass p)))-unguardedGRHSs rhs@(L loc _)-  = GRHSs noExtField (unguardedRHS loc rhs) (noLoc emptyLocalBinds)+unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ SrcSpan+               => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn+               -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))+unguardedGRHSs loc rhs an+  = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds -unguardedRHS :: SrcSpan -> Located (body (GhcPass p))-             -> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]-unguardedRHS loc rhs = [L loc (GRHS noExtField [] rhs)]+unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ SrcSpan+             => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))+             -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]+unguardedRHS an loc rhs = [L loc (GRHS an [] rhs)] -mkMatchGroup :: (XMG name (Located (body name)) ~ NoExtField)-             => Origin -> [LMatch name (Located (body name))]-             -> MatchGroup name (Located (body name))+type AnnoBody p body+  = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField+    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL+    , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA+    )++mkMatchGroup :: AnnoBody p body+             => Origin+             -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+             -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = noExtField-                                 , mg_alts = mkLocatedList matches+                                 , mg_alts = matches                                  , mg_origin = origin } -mkLocatedList ::  [Located a] -> Located [Located a]-mkLocatedList [] = noLoc []-mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms+mkLocatedList :: Semigroup a+  => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]+mkLocatedList [] = noLocA []+mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms  mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsApp = mkHsAppWith addCLoc+mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)  mkHsAppWith   :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))   -> LHsExpr (GhcPass id)   -> LHsExpr (GhcPass id)   -> LHsExpr (GhcPass id)-mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2)+mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2)  mkHsApps   :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-mkHsApps = mkHsAppsWith addCLoc+mkHsApps = mkHsAppsWith addCLocAA  mkHsAppsWith  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))@@ -212,7 +242,7 @@ mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)  mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn-mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct)+mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct)   where     t_body    = hswc_body t     paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }@@ -220,15 +250,14 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: IsPass p-        => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)+mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)         => [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)         -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))   where     matches = mkMatchGroup Generated-                           [mkSimpleMatch LambdaExpr pats' body]+                           (noLocA [mkSimpleMatch LambdaExpr pats' body])     pats' = map (parenthesizePat appPrec) pats  mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc@@ -237,14 +266,18 @@  -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking-mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))-            -> LMatch (GhcPass p) (Located (body (GhcPass p)))+mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ SrcSpan,+                 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpanAnnA)+            => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))+            -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkHsCaseAlt pat expr   = mkSimpleMatch CaseAlt [pat] expr  nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys-  = noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLoc fun_id)))+  = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (noLocA fun_id)))  nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs@@ -254,16 +287,16 @@ -- So @f x@ becomes @(f x)@, but @3@ stays as @3@. mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) mkLHsPar le@(L loc e)-  | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le)+  | hsExprNeedsParens appPrec e = L loc (HsPar noAnn le)   | otherwise                   = le  mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat lp@(L loc p)-  | patNeedsParens appPrec p = L loc (ParPat noExtField lp)+  | patNeedsParens appPrec p = L loc (ParPat noAnn lp)   | otherwise                = lp  nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)-nlParPat p = noLoc (ParPat noExtField p)+nlParPat p = noLocA (ParPat noAnn p)  ------------------------------- -- These are the bits of syntax that contain rebindable names@@ -272,31 +305,49 @@ mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs-mkHsDo         :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> HsExpr GhcPs+mkHsDo         :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs+mkHsDoAnns     :: HsStmtContext GhcRn -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs mkHsComp       :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                -> HsExpr GhcPs+mkHsCompAnns   :: HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+               -> EpAnn AnnList+               -> HsExpr GhcPs -mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)+mkNPat      :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]             -> Pat GhcPs-mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs+mkNPlusKPat :: LocatedN RdrName -> Located (HsOverLit GhcPs) -> EpAnn EpaLocation+            -> Pat GhcPs  -- NB: The following functions all use noSyntaxExpr: the generated expressions --     will not work with rebindable syntax if used after the renamer-mkLastStmt :: IsPass idR => Located (bodyR (GhcPass idR))-           -> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))-mkBodyStmt :: Located (bodyR GhcPs)-           -> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))-mkPsBindStmt :: LPat GhcPs -> Located (bodyR GhcPs)-             -> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))-mkRnBindStmt :: LPat GhcRn -> Located (bodyR GhcRn)-             -> StmtLR GhcRn GhcRn (Located (bodyR GhcRn))-mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)-             -> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))+mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR))+           -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))+mkBodyStmt :: LocatedA (bodyR GhcPs)+           -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))+mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs)+             -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))+mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)+             -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))+mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)+             -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc)) -emptyRecStmt     :: StmtLR (GhcPass idL) GhcPs bodyR-emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR-emptyRecStmtId   :: StmtLR GhcTc GhcTc bodyR-mkRecStmt        :: [LStmtLR (GhcPass idL) GhcPs bodyR]+emptyRecStmt     :: (Anno [GenLocated+                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))+                             (StmtLR (GhcPass idL) GhcPs bodyR)]+                        ~ SrcSpanAnnL)+                 => StmtLR (GhcPass idL) GhcPs bodyR+emptyRecStmtName :: (Anno [GenLocated+                             (Anno (StmtLR GhcRn GhcRn bodyR))+                             (StmtLR GhcRn GhcRn bodyR)]+                        ~ SrcSpanAnnL)+                 => StmtLR GhcRn GhcRn bodyR+emptyRecStmtId   :: Stmt GhcTc (LocatedA (HsCmd GhcTc))+mkRecStmt        :: (Anno [GenLocated+                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))+                             (StmtLR (GhcPass idL) GhcPs bodyR)]+                        ~ SrcSpanAnnL)+                 => EpAnn AnnList+                 -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]                  -> StmtLR (GhcPass idL) GhcPs bodyR  @@ -304,62 +355,70 @@ mkHsFractional   f  = OverLit noExtField (HsFractional     f) noExpr mkHsIsString src s  = OverLit noExtField (HsIsString   src s) noExpr -mkHsDo ctxt stmts = HsDo noExtField ctxt (mkLocatedList stmts)-mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])+mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts+mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts+mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn+mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns   where-    last_stmt = L (getLoc expr) $ mkLastStmt expr+    -- Strip the annotations from the location, they are in the embedded expr+    last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr  -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs-mkHsIf c a b = HsIf noExtField c a b+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf+       -> HsExpr GhcPs+mkHsIf c a b anns = HsIf anns c a b  -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> HsCmd GhcPs-mkHsCmdIf c a b = HsCmdIf noExtField noSyntaxExpr c a b+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf+       -> HsCmd GhcPs+mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b -mkNPat lit neg     = NPat noExtField lit neg noSyntaxExpr-mkNPlusKPat id lit-  = NPlusKPat noExtField id lit (unLoc lit) noSyntaxExpr noSyntaxExpr+mkNPat lit neg anns  = NPat anns lit neg noSyntaxExpr+mkNPlusKPat id lit anns+  = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt    :: [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkTransformStmt    :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkTransformByStmt  :: [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkTransformByStmt  :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupUsingStmt   :: [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkGroupUsingStmt   :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)-emptyTransStmt = TransStmt { trS_ext = noExtField-                           , trS_form = panic "emptyTransStmt: form"-                           , trS_stmts = [], trS_bndrs = []-                           , trS_by = Nothing, trS_using = noLoc noExpr-                           , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr-                           , trS_fmap = noExpr }-mkTransformStmt    ss u   = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }-mkTransformByStmt  ss u b = emptyTransStmt { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }-mkGroupUsingStmt   ss u   = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }-mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }+emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+emptyTransStmt anns = TransStmt { trS_ext = anns+                                , trS_form = panic "emptyTransStmt: form"+                                , trS_stmts = [], trS_bndrs = []+                                , trS_by = Nothing, trS_using = noLocA noExpr+                                , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr+                                , trS_fmap = noExpr }+mkTransformStmt    a ss u   = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }+mkTransformByStmt  a ss u b = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }+mkGroupUsingStmt   a ss u   = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u }+mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }  mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr mkBodyStmt body   = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr-mkPsBindStmt pat body = BindStmt noExtField pat body+mkPsBindStmt ann pat body = BindStmt ann pat body mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr,                                                 xbstc_boundResultType = unitTy,+                                                   -- unitTy is a dummy value+                                                   -- can't panic here: it's forced during zonking                                                 xbstc_boundResultMult = Many,                                                 xbstc_failOp = Nothing }) pat body-  -- don't use placeHolderTypeTc above, because that panics during zonking -emptyRecStmt' :: forall idL idR body. IsPass idR+emptyRecStmt' :: forall idL idR body .+  (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR)               => XRecStmt (GhcPass idL) (GhcPass idR) body               -> StmtLR (GhcPass idL) (GhcPass idR) body emptyRecStmt' tyVal =    RecStmt-     { recS_stmts = [], recS_later_ids = []+     { recS_stmts = wrapXRec @(GhcPass idR) []+     , recS_later_ids = []      , recS_rec_ids = []      , recS_ret_fn = noSyntaxExpr      , recS_mfix_fn = noSyntaxExpr@@ -372,26 +431,29 @@                           , recS_rec_rets = []                           , recS_ret_ty = unitTy } -emptyRecStmt     = emptyRecStmt' noExtField+emptyRecStmt     = emptyRecStmt' noAnn emptyRecStmtName = emptyRecStmt' noExtField emptyRecStmtId   = emptyRecStmt' unitRecStmtTc                                         -- a panic might trigger during zonking-mkRecStmt stmts  = emptyRecStmt { recS_stmts = stmts }+mkRecStmt anns stmts  = (emptyRecStmt' anns) { recS_stmts = stmts } +mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)+mkLetStmt anns binds = LetStmt anns binds+ ------------------------------- -- | A useful function for building @OpApps@.  The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs-mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLoc (HsVar noExtField (noLoc op))) e2+mkHsOpApp e1 op e2 = OpApp noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2  unqualSplice :: RdrName unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs-mkUntypedSplice hasParen e = HsUntypedSplice noExtField hasParen unqualSplice e+mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs+mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e -mkTypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs-mkTypedSplice hasParen e = HsTypedSplice noExtField hasParen unqualSplice e+mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs+mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e  mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs mkHsQuasiQuote quoter span quote@@ -403,7 +465,10 @@ mkHsStringPrimLit :: FastString -> HsLit (GhcPass p) mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs) +mkHsCharPrimLit :: Char -> HsLit (GhcPass p)+mkHsCharPrimLit c = HsChar NoSourceText c + {- ************************************************************************ *                                                                      *@@ -412,50 +477,55 @@ ************************************************************************ -} -nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)-nlHsVar n = noLoc (HsVar noExtField (noLoc n))+nlHsVar :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> LHsExpr (GhcPass p)+nlHsVar n = noLocA (HsVar noExtField (noLocA n)) -nl_HsVar :: IdP (GhcPass id) -> HsExpr (GhcPass id)-nl_HsVar n = HsVar noExtField (noLoc n)+nl_HsVar :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> HsExpr (GhcPass p)+nl_HsVar n = HsVar noExtField (noLocA n)  -- | NB: Only for 'LHsExpr' 'Id'. nlHsDataCon :: DataCon -> LHsExpr GhcTc-nlHsDataCon con = noLoc (HsConLikeOut noExtField (RealDataCon con))+nlHsDataCon con = noLocA (HsConLikeOut noExtField (RealDataCon con))  nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)-nlHsLit n = noLoc (HsLit noExtField n)+nlHsLit n = noLocA (HsLit noComments n)  nlHsIntLit :: Integer -> LHsExpr (GhcPass p)-nlHsIntLit n = noLoc (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))+nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n))) -nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)-nlVarPat n = noLoc (VarPat noExtField (noLoc n))+nlVarPat :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> LPat (GhcPass p)+nlVarPat n = noLocA (VarPat noExtField (noLocA n))  nlLitPat :: HsLit GhcPs -> LPat GhcPs-nlLitPat l = noLoc (LitPat noExtField l)+nlLitPat l = noLocA (LitPat noExtField l)  nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-nlHsApp f x = noLoc (HsApp noExtField f (mkLHsPar x))+nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x))  nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]                -> LHsExpr GhcTc nlHsSyntaxApps (SyntaxExprTc { syn_expr      = fun                              , syn_arg_wraps = arg_wraps                              , syn_res_wrap  = res_wrap }) args-  = mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"+  = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"                                                      mkLHsWrap arg_wraps args)) nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)   -- this function should never be called in scenarios where there is no   -- syntax expr -nlHsApps :: IsPass id => IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)+nlHsApps :: IsSrcSpanAnn p a+         => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p) nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs -nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)-nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExtField (noLoc f))-                                               (map ((HsVar noExtField) . noLoc) xs))+nlHsVarApps :: IsSrcSpanAnn p a+            => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))+                                         (map ((HsVar noExtField) . noLocA) xs))                  where-                   mk f a = HsApp noExtField (noLoc f) (noLoc a)+                   mk f a = HsApp noComments (noLocA f) (noLocA a)  nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars)@@ -464,57 +534,57 @@ nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)  nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs-nlInfixConPat con l r = noLoc $ ConPat-  { pat_con = noLoc con+nlInfixConPat con l r = noLocA $ ConPat+  { pat_con = noLocA con   , pat_args = InfixCon (parenthesizePat opPrec l)                         (parenthesizePat opPrec r)-  , pat_con_ext = noExtField+  , pat_con_ext = noAnn   }  nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs-nlConPat con pats = noLoc $ ConPat-  { pat_con_ext = noExtField-  , pat_con = noLoc con-  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+nlConPat con pats = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA con+  , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)   }  nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn-nlConPatName con pats = noLoc $ ConPat+nlConPatName con pats = noLocA $ ConPat   { pat_con_ext = noExtField-  , pat_con = noLoc con-  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  , pat_con = noLocA con+  , pat_args = PrefixCon [] (map (parenthesizePat appPrec) pats)   }  nlNullaryConPat :: RdrName -> LPat GhcPs-nlNullaryConPat con = noLoc $ ConPat-  { pat_con_ext = noExtField-  , pat_con = noLoc con-  , pat_args = PrefixCon []+nlNullaryConPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA con+  , pat_args = PrefixCon [] []   }  nlWildConPat :: DataCon -> LPat GhcPs-nlWildConPat con = noLoc $ ConPat-  { pat_con_ext = noExtField-  , pat_con = noLoc $ getRdrName con-  , pat_args = PrefixCon $+nlWildConPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA $ getRdrName con+  , pat_args = PrefixCon [] $      replicate (dataConSourceArity con)                nlWildPat   }  -- | Wildcard pattern - after parsing nlWildPat :: LPat GhcPs-nlWildPat  = noLoc (WildPat noExtField )+nlWildPat  = noLocA (WildPat noExtField )  -- | Wildcard pattern - after renaming nlWildPatName :: LPat GhcRn-nlWildPatName  = noLoc (WildPat noExtField )+nlWildPatName  = noLocA (WildPat noExtField )  nlHsDo :: HsStmtContext GhcRn -> [LStmt GhcPs (LHsExpr GhcPs)]        -> LHsExpr GhcPs-nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)+nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))  nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)+nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)  nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)@@ -522,80 +592,89 @@          -> LHsExpr GhcPs nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs -nlHsLam match          = noLoc (HsLam noExtField (mkMatchGroup Generated [match]))-nlHsPar e              = noLoc (HsPar noExtField e)+-- AZ:Is this used?+nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (noLocA [match])))+nlHsPar e     = noLocA (HsPar noAnn e)  -- nlHsIf should generate if-expressions which are NOT subject to -- RebindableSyntax, so the first field of HsIf is False. (#12080) nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs-nlHsIf cond true false = noLoc (HsIf noExtField cond true false)+nlHsIf cond true false = noLocA (HsIf noAnn cond true false)  nlHsCase expr matches-  = noLoc (HsCase noExtField expr (mkMatchGroup Generated matches))-nlList exprs          = noLoc (ExplicitList noExtField Nothing exprs)+  = noLocA (HsCase noAnn expr (mkMatchGroup Generated (noLocA matches)))+nlList exprs          = noLocA (ExplicitList noAnn exprs)  nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-nlHsTyVar :: IdP (GhcPass p)                            -> LHsType (GhcPass p)+nlHsTyVar :: IsSrcSpanAnn p a+          => IdP (GhcPass p)                            -> LHsType (GhcPass p) nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p) -nlHsAppTy f t = noLoc (HsAppTy noExtField f (parenthesizeHsType appPrec t))-nlHsTyVar x   = noLoc (HsTyVar noExtField NotPromoted (noLoc x))-nlHsFunTy a b = noLoc (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b)-nlHsParTy t   = noLoc (HsParTy noExtField t)+nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))+nlHsTyVar x   = noLocA (HsTyVar noAnn NotPromoted (noLocA x))+nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) (parenthesizeHsType funPrec a) b)+nlHsParTy t   = noLocA (HsParTy noAnn t) -nlHsTyConApp :: LexicalFixity -> IdP (GhcPass p)+nlHsTyConApp :: IsSrcSpanAnn p a+             => LexicalFixity -> IdP (GhcPass p)              -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp fixity tycon tys   | Infix <- fixity   , HsValArg ty1 : HsValArg ty2 : rest <- tys-  = foldl' mk_app (noLoc $ HsOpTy noExtField ty1 (noLoc tycon) ty2) rest+  = foldl' mk_app (noLocA $ HsOpTy noExtField ty1 (noLocA tycon) ty2) rest   | otherwise   = foldl' mk_app (nlHsTyVar tycon) tys   where     mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)-    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLoc $ HsParTy noExtField fun) arg+    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg       -- parenthesize things like `(A + B) C`-    mk_app fun (HsValArg ty) = noLoc (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))-    mk_app fun (HsTypeArg _ ki) = noLoc (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))-    mk_app fun (HsArgPar _) = noLoc (HsParTy noExtField fun)+    mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))+    mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))+    mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)  nlHsAppKindTy ::   LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p) nlHsAppKindTy f k-  = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))+  = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))  {- Tuples.  All these functions are *pre-typechecker* because they lack types on the tuple. -} -mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)+mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)+               -> LHsExpr (GhcPass p) -- Makes a pre-typechecker boxed tuple, deals with 1 case-mkLHsTupleExpr [e] = e-mkLHsTupleExpr es-  = noLoc $ ExplicitTuple noExtField (map (noLoc . (Present noExtField)) es) Boxed+mkLHsTupleExpr [e] _ = e+mkLHsTupleExpr es ext+  = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed -mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)-mkLHsVarTuple ids  = mkLHsTupleExpr (map nlHsVar ids)+mkLHsVarTuple :: IsSrcSpanAnn p a+               => [IdP (GhcPass p)]  -> XExplicitTuple (GhcPass p)+              -> LHsExpr (GhcPass p)+mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext  nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs-nlTuplePat pats box = noLoc (TuplePat noExtField pats box)+nlTuplePat pats box = noLocA (TuplePat noAnn pats box) -missingTupArg :: HsTupArg GhcPs-missingTupArg = Missing noExtField+missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs+missingTupArg ann = Missing ann  mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn-mkLHsPatTup []     = noLoc $ TuplePat noExtField [] Boxed+mkLHsPatTup []     = noLocA $ TuplePat noExtField [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats  = L (getLoc (head lpats)) $ TuplePat noExtField lpats Boxed  -- | The Big equivalents for the source tuple expressions-mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)-mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)+mkBigLHsVarTup :: IsSrcSpanAnn p a+               => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)+               -> LHsExpr (GhcPass p)+mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns -mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-mkBigLHsTup = mkChunkified mkLHsTupleExpr+mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id)+            -> LHsExpr (GhcPass id)+mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es  -- | The Big equivalents for the source tuple patterns mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn@@ -652,13 +731,20 @@ *                                                                      * ********************************************************************* -} -mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs-mkLHsSigType ty = mkHsImplicitBndrs ty+-- | Convert an 'LHsType' to an 'LHsSigType'.+hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs+hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of+  HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an+                                        , hsf_invis_bndrs = bndrs }+             , hst_body = body }+    -> mkHsExplicitSigType an bndrs body+  _ -> mkHsImplicitSigType lty -mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs-mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)+-- | Convert an 'LHsType' to an 'LHsSigWcType'.+hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs+hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType -mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))+mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a))                      -> [LSig GhcRn]                      -> NameEnv a mkHsSigEnv get_info sigs@@ -691,8 +777,8 @@ mkClassOpSigs sigs   = map fiddle sigs   where-    fiddle (L loc (TypeSig _ nms ty))-      = L loc (ClassOpSig noExtField False nms (dropWildCards ty))+    fiddle (L loc (TypeSig anns nms ty))+      = L loc (ClassOpSig anns False nms (dropWildCards ty))     fiddle sig = sig  {- *********************************************************************@@ -750,20 +836,20 @@ ************************************************************************ -} -mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]+mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]           -> HsBind GhcPs -- ^ Not infix, with place holders for coercion and free vars mkFunBind origin fn ms   = FunBind { fun_id = fn-            , fun_matches = mkMatchGroup origin ms+            , fun_matches = mkMatchGroup origin (noLocA ms)             , fun_ext = noExtField             , fun_tick = [] } -mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]+mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]              -> HsBind GhcRn -- ^ In Name-land, with empty bind_fvs mkTopFunBind origin fn ms = FunBind { fun_id = fn-                                    , fun_matches = mkMatchGroup origin ms+                                    , fun_matches = mkMatchGroup origin (noLocA ms)                                     , fun_ext  = emptyNameSet -- NB: closed                                                               --     binding                                     , fun_tick = [] }@@ -776,11 +862,11 @@                     VarBind { var_ext = noExtField,                               var_id = var, var_rhs = rhs } -mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)-             -> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs-mkPatSynBind name details lpat dir = PatSynBind noExtField psb+mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs+             -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs+mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb   where-    psb = PSB{ psb_ext = noExtField+    psb = PSB{ psb_ext = anns              , psb_id = name              , psb_args = details              , psb_def = lpat@@ -788,11 +874,30 @@  -- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is -- considered infix.-isInfixFunBind :: HsBindLR id1 id2 -> Bool+isInfixFunBind :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool isInfixFunBind (FunBind { fun_matches = MG _ matches _ })-  = any (isInfixMatch . unLoc) (unLoc matches)+  = any (isInfixMatch . unXRec @id2) (unXRec @id2 matches) isInfixFunBind _ = False +-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds+spanHsLocaLBinds :: (Data (HsLocalBinds (GhcPass p))) => HsLocalBinds (GhcPass p) -> SrcSpan+spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan+spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))+  = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)+  where+    bsSpans :: [SrcSpan]+    bsSpans = map getLocA $ bagToList bs+    sigsSpans :: [SrcSpan]+    sigsSpans = map getLocA sigs+spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))+  = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)+  where+    bsSpans :: [SrcSpan]+    bsSpans = map getLocA $ concatMap (bagToList . snd) bs+    sigsSpans :: [SrcSpan]+    sigsSpans = map getLocA sigs+spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))+  = foldr combineSrcSpans noSrcSpan (map getLocA bs)  ------------ -- | Convenience function using 'mkFunBind'.@@ -800,9 +905,9 @@ mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]                 -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr-  = L loc $ mkFunBind Generated (L loc fun)-              [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr-                       (noLoc emptyLocalBinds)]+  = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)+              [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr+                       emptyLocalBinds]  -- | Make a prefix, non-strict function 'HsMatchContext' mkPrefixFunRhs :: LIdP p -> HsMatchContext p@@ -815,17 +920,17 @@         => HsMatchContext (NoGhcTc (GhcPass p))         -> [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)-        -> Located (HsLocalBinds (GhcPass p))+        -> HsLocalBinds (GhcPass p)         -> LMatch (GhcPass p) (LHsExpr (GhcPass p))-mkMatch ctxt pats expr lbinds-  = noLoc (Match { m_ext   = noExtField-                 , m_ctxt  = ctxt-                 , m_pats  = map paren pats-                 , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds })+mkMatch ctxt pats expr binds+  = noLocA (Match { m_ext   = noAnn+                  , m_ctxt  = ctxt+                  , m_pats  = map paren pats+                  , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })   where-    paren :: Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p))+    paren :: LPat (GhcPass p) -> LPat (GhcPass p)     paren lp@(L l p)-      | patNeedsParens appPrec p = L l (ParPat noExtField lp)+      | patNeedsParens appPrec p = L l (ParPat noAnn lp)       | otherwise                = lp  {-@@ -884,19 +989,19 @@ -- | Should we treat this as an unlifted bind? This will be true for any -- bind that binds an unlifted variable, but we must be careful around -- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage--- information, see Note [Strict binds check] is "GHC.HsToCore.Binds".+-- information, see Note [Strict binds checks] is GHC.HsToCore.Binds. isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds isUnliftedHsBind bind   | AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind   = if has_sig     then any (is_unlifted_id . abe_poly) exports     else any (is_unlifted_id . abe_mono) exports-    -- If has_sig is True we wil never generate a binding for abe_mono,+    -- If has_sig is True we will never generate a binding for abe_mono,     -- so we don't need to worry about it being unlifted. The abe_poly     -- binding might not be: e.g. forall a. Num a => (# a, a #)    | otherwise-  = any is_unlifted_id (collectHsBindBinders bind)+  = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind)   where     is_unlifted_id id = isUnliftedType (idType id) @@ -914,214 +1019,314 @@   = False  collectLocalBinders :: CollectPass (GhcPass idL)-                    => HsLocalBindsLR (GhcPass idL) (GhcPass idR)+                    => CollectFlag (GhcPass idL)+                    -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)                     -> [IdP (GhcPass idL)]-collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds-                                         -- No pattern synonyms here-collectLocalBinders (HsIPBinds {})      = []-collectLocalBinders (EmptyLocalBinds _) = []+collectLocalBinders flag = \case+    HsValBinds _ binds -> collectHsIdBinders flag binds+                          -- No pattern synonyms here+    HsIPBinds {}       -> []+    EmptyLocalBinds _  -> []  collectHsIdBinders :: CollectPass (GhcPass idL)-                   => HsValBindsLR (GhcPass idL) (GhcPass idR)+                   => CollectFlag (GhcPass idL)+                   -> HsValBindsLR (GhcPass idL) (GhcPass idR)                    -> [IdP (GhcPass idL)] -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively-collectHsIdBinders  = collect_hs_val_binders True+collectHsIdBinders flag = collect_hs_val_binders True flag  collectHsValBinders :: CollectPass (GhcPass idL)-                    => HsValBindsLR (GhcPass idL) (GhcPass idR)+                    => CollectFlag (GhcPass idL)+                    -> HsValBindsLR (GhcPass idL) (GhcPass idR)                     -> [IdP (GhcPass idL)]-collectHsValBinders = collect_hs_val_binders False+collectHsValBinders flag = collect_hs_val_binders False flag  collectHsBindBinders :: CollectPass p-                     => HsBindLR p idR+                     => CollectFlag p+                     -> HsBindLR p idR                      -> [IdP p] -- ^ Collect both 'Id's and pattern-synonym binders-collectHsBindBinders b = collect_bind False b []+collectHsBindBinders flag b = collect_bind False flag b []  collectHsBindsBinders :: CollectPass p-                      => LHsBindsLR p idR+                      => CollectFlag p+                      -> LHsBindsLR p idR                       -> [IdP p]-collectHsBindsBinders binds = collect_binds False binds []+collectHsBindsBinders flag binds = collect_binds False flag binds [] -collectHsBindListBinders :: CollectPass p-                         => [LHsBindLR p idR]+collectHsBindListBinders :: forall p idR. CollectPass p+                         => CollectFlag p+                         -> [LHsBindLR p idR]                          -> [IdP p] -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings-collectHsBindListBinders = foldr (collect_bind False . unLoc) []+collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []  collect_hs_val_binders :: CollectPass (GhcPass idL)                        => Bool+                       -> CollectFlag (GhcPass idL)                        -> HsValBindsLR (GhcPass idL) (GhcPass idR)                        -> [IdP (GhcPass idL)]-collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []-collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))-  = collect_out_binds ps binds+collect_hs_val_binders ps flag = \case+    ValBinds _ binds _              -> collect_binds ps flag binds []+    XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds -collect_out_binds :: CollectPass p+collect_out_binds :: forall p. CollectPass p                   => Bool+                  -> CollectFlag p                   -> [(RecFlag, LHsBinds p)]                   -> [IdP p]-collect_out_binds ps = foldr (collect_binds ps . snd) []+collect_out_binds ps flag = foldr (collect_binds ps flag . snd) [] -collect_binds :: CollectPass p+collect_binds :: forall p idR. CollectPass p               => Bool+              -> CollectFlag p               -> LHsBindsLR p idR               -> [IdP p]               -> [IdP p] -- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag-collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds+collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds -collect_bind :: CollectPass p+collect_bind :: forall p idR. CollectPass p              => Bool+             -> CollectFlag p              -> HsBindLR p idR              -> [IdP p]              -> [IdP p]-collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc-collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc-collect_bind _ (VarBind { var_id = f })            acc = f : acc-collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc+collect_bind _ flag (PatBind { pat_lhs = p })           acc = collect_lpat flag p acc+collect_bind _ _ (FunBind { fun_id = f })            acc = unXRec @p f : acc+collect_bind _ _ (VarBind { var_id = f })            acc = f : acc+collect_bind _ _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc         -- I don't think we want the binders from the abe_binds          -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Utils.Zonk-collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = L _ ps })) acc+collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc   | omitPatSyn                  = acc-  | otherwise                   = ps : acc-collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc-collect_bind _ (XHsBindsLR _) acc = acc+  | otherwise                   = unXRec @p ps : acc+collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc+collect_bind _ _ (XHsBindsLR _) acc = acc -collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]+collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL] -- ^ Used exclusively for the bindings of an instance decl which are all -- 'FunBinds'-collectMethodBinders binds = foldr (get . unLoc) [] binds+collectMethodBinders binds = foldr (get . unXRec @idL) [] binds   where     get (FunBind { fun_id = f }) fs = f : fs     get _                        fs = fs        -- Someone else complains about non-FunBinds  ----------------- Statements ---------------------------collectLStmtsBinders :: (CollectPass (GhcPass idL))-                     => [LStmtLR (GhcPass idL) (GhcPass idR) body]-                     -> [IdP (GhcPass idL)]-collectLStmtsBinders = concatMap collectLStmtBinders+--+collectLStmtsBinders+  :: CollectPass (GhcPass idL)+  => CollectFlag (GhcPass idL)+  -> [LStmtLR (GhcPass idL) (GhcPass idR) body]+  -> [IdP (GhcPass idL)]+collectLStmtsBinders flag = concatMap (collectLStmtBinders flag) -collectStmtsBinders :: (CollectPass (GhcPass idL))-                    => [StmtLR (GhcPass idL) (GhcPass idR) body]-                    -> [IdP (GhcPass idL)]-collectStmtsBinders = concatMap collectStmtBinders+collectStmtsBinders+  :: (CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> [StmtLR (GhcPass idL) (GhcPass idR) body]+  -> [IdP (GhcPass idL)]+collectStmtsBinders flag = concatMap (collectStmtBinders flag) -collectLStmtBinders :: (CollectPass (GhcPass idL))-                    => LStmtLR (GhcPass idL) (GhcPass idR) body-                    -> [IdP (GhcPass idL)]-collectLStmtBinders = collectStmtBinders . unLoc+collectLStmtBinders+  :: (CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> LStmtLR (GhcPass idL) (GhcPass idR) body+  -> [IdP (GhcPass idL)]+collectLStmtBinders flag = collectStmtBinders flag . unLoc -collectStmtBinders :: (CollectPass (GhcPass idL))-                   => StmtLR (GhcPass idL) (GhcPass idR) body-                   -> [IdP (GhcPass idL)]+collectStmtBinders+  :: CollectPass (GhcPass idL)+  => CollectFlag (GhcPass idL)+  -> StmtLR (GhcPass idL) (GhcPass idR) body+  -> [IdP (GhcPass idL)]   -- Id Binders for a Stmt... [but what about pattern-sig type vars]?-collectStmtBinders (BindStmt _ pat _)      = collectPatBinders pat-collectStmtBinders (LetStmt _  binds)      = collectLocalBinders (unLoc binds)-collectStmtBinders (BodyStmt {})           = []-collectStmtBinders (LastStmt {})           = []-collectStmtBinders (ParStmt _ xs _ _)      = collectLStmtsBinders-                                    $ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]-collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts-collectStmtBinders (RecStmt { recS_stmts = ss })     = collectLStmtsBinders ss-collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args- where-  collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat-  collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat-  collectArgBinders (_, XApplicativeArg {}) = []+collectStmtBinders flag = \case+    BindStmt _ pat _ -> collectPatBinders flag pat+    LetStmt _  binds -> collectLocalBinders flag binds+    BodyStmt {}      -> []+    LastStmt {}      -> []+    ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]+    TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts+    RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss+    ApplicativeStmt _ args _        -> concatMap collectArgBinders args+        where+         collectArgBinders = \case+            (_, ApplicativeArgOne { app_arg_pattern = pat }) -> collectPatBinders flag pat+            (_, ApplicativeArgMany { bv_pattern = pat })     -> collectPatBinders flag pat   ----------------- Patterns ---------------------------collectPatBinders :: CollectPass p => LPat p -> [IdP p]-collectPatBinders pat = collect_lpat pat [] -collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p]-collectPatsBinders pats = foldr collect_lpat [] pats+collectPatBinders+    :: CollectPass p+    => CollectFlag p+    -> LPat p+    -> [IdP p]+collectPatBinders flag pat = collect_lpat flag pat [] +collectPatsBinders+    :: CollectPass p+    => CollectFlag p+    -> [LPat p]+    -> [IdP p]+collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats++ --------------collect_lpat :: forall pass. (CollectPass pass)-             => LPat pass -> [IdP pass] -> [IdP pass]-collect_lpat p bndrs = collect_pat (unLoc p) bndrs +-- | Indicate if evidence binders have to be collected.+--+-- This type is used as a boolean (should we collect evidence binders or not?)+-- but also to pass an evidence that the AST has been typechecked when we do+-- want to collect evidence binders, otherwise these binders are not available.+--+-- See Note [Dictionary binders in ConPatOut]+data CollectFlag p where+    -- | Don't collect evidence binders+    CollNoDictBinders   :: CollectFlag p+    -- | Collect evidence binders+    CollWithDictBinders :: CollectFlag GhcTc++collect_lpat :: forall p. (CollectPass p)+             => CollectFlag p+             -> LPat p+             -> [IdP p]+             -> [IdP p]+collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs+ collect_pat :: forall p. CollectPass p-            => Pat p+            => CollectFlag p+            -> Pat p             -> [IdP p]             -> [IdP p]-collect_pat pat bndrs = case pat of-  (VarPat _ var)          -> unLoc var : bndrs-  (WildPat _)             -> bndrs-  (LazyPat _ pat)         -> collect_lpat pat bndrs-  (BangPat _ pat)         -> collect_lpat pat bndrs-  (AsPat _ a pat)         -> unLoc a : collect_lpat pat bndrs-  (ViewPat _ _ pat)       -> collect_lpat pat bndrs-  (ParPat _ pat)          -> collect_lpat pat bndrs-  (ListPat _ pats)        -> foldr collect_lpat bndrs pats-  (TuplePat _ pats _)     -> foldr collect_lpat bndrs pats-  (SumPat _ pat _ _)      -> collect_lpat pat bndrs-  (ConPat {pat_args=ps})  -> foldr collect_lpat bndrs (hsConPatArgs ps)+collect_pat flag pat bndrs = case pat of+  VarPat _ var          -> unXRec @p var : bndrs+  WildPat _             -> bndrs+  LazyPat _ pat         -> collect_lpat flag pat bndrs+  BangPat _ pat         -> collect_lpat flag pat bndrs+  AsPat _ a pat         -> unXRec @p a : collect_lpat flag pat bndrs+  ViewPat _ _ pat       -> collect_lpat flag pat bndrs+  ParPat _ pat          -> collect_lpat flag pat bndrs+  ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats+  TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats+  SumPat _ pat _ _      -> collect_lpat flag pat bndrs+  LitPat _ _            -> bndrs+  NPat {}               -> bndrs+  NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs+  SigPat _ pat _        -> collect_lpat flag pat bndrs+  XPat ext              -> collectXXPat (Proxy @p) flag ext bndrs+  SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))+                        -> collect_pat flag pat bndrs+  SplicePat _ _         -> bndrs   -- See Note [Dictionary binders in ConPatOut]-  (LitPat _ _)            -> bndrs-  (NPat {})               -> bndrs-  (NPlusKPat _ n _ _ _ _) -> unLoc n : bndrs-  (SigPat _ pat _)        -> collect_lpat pat bndrs-  (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))-                          -> collect_pat pat bndrs-  (SplicePat _ _)         -> bndrs-  (XPat ext)              -> collectXXPat (Proxy @p) ext bndrs+  ConPat {pat_args=ps}  -> case flag of+    CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+    CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+                           ++ collectEvBinders (cpt_binds (pat_con_ext pat)) +collectEvBinders :: TcEvBinds -> [Id]+collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"++add_ev_bndr :: EvBind -> [Id] -> [Id]+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs+                                       | otherwise = bs+  -- A worry: what about coercion variable binders??++ -- | This class specifies how to collect variable identifiers from extension patterns in the given pass. -- Consumers of the GHC API that define their own passes should feel free to implement instances in order -- to make use of functions which depend on it. -- -- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that -- it can reuse the code in GHC for collecting binders.-class (XRec p Pat ~ Located (Pat p)) => CollectPass p where-  collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p]+class UnXRec p => CollectPass p where+  collectXXPat :: Proxy p -> CollectFlag p -> XXPat p -> [IdP p] -> [IdP p] -instance CollectPass (GhcPass 'Parsed) where-  collectXXPat _ ext = noExtCon ext+instance IsPass p => CollectPass (GhcPass p) where+  collectXXPat _ flag ext =+    case ghcPass @p of+      GhcTc -> let CoPat _ pat _ = ext in collect_pat flag pat+      GhcRn -> noExtCon ext+      GhcPs -> noExtCon ext -instance CollectPass (GhcPass 'Renamed) where-  collectXXPat _ ext = noExtCon ext+{-+Note [Dictionary binders in ConPatOut]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -instance CollectPass (GhcPass 'Typechecked) where-  collectXXPat _ (CoPat _ pat _) = collect_pat pat+Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag+to choose. +1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag. -{--Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do *not* gather (a) dictionary and (b) dictionary bindings as binders-of a ConPatOut pattern.  For most calls it doesn't matter, because-it's pre-typechecker and there are no ConPatOuts.  But it does matter-more in the desugarer; for example, GHC.HsToCore.Utils.mkSelectorBinds uses-collectPatBinders.  In a lazy pattern, for example f ~(C x y) = ...,-we want to generate bindings for x,y but not for dictionaries bound by-C.  (The type checker ensures they would not be used.)+2. In the desugarer, most of the time we don't want to collect evidence binders,+   so we also use CollNoDictBinders flag. -Desugaring of arrow case expressions needs these bindings (see GHC.HsToCore.Arrows-and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its-own pat-binder-collector:+   Example of why it matters: -Here's the problem.  Consider+   In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings+   for x,y but not for dictionaries bound by C.+   (The type checker ensures they would not be used.) -data T a where-   C :: Num a => a -> Int -> T a+   Here's the problem.  Consider -f ~(C (n+1) m) = (n,m)+        data T a where+           C :: Num a => a -> Int -> T a -Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),-and *also* uses that dictionary to match the (n+1) pattern.  Yet, the-variables bound by the lazy pattern are n,m, *not* the dictionary d.-So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the variables bound.+        f ~(C (n+1) m) = (n,m)++   Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),+   and *also* uses that dictionary to match the (n+1) pattern.  Yet, the+   variables bound by the lazy pattern are n,m, *not* the dictionary d.+   So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the+   variables bound.++   So in this case, we do *not* gather (a) dictionary and (b) dictionary+   bindings as binders of a ConPatOut pattern.+++3. On the other hand, desugaring of arrows needs evidence bindings and uses+   CollWithDictBinders flag.++   Consider++        h :: (ArrowChoice a, Arrow a) => Int -> a (Int,Int) Int+        h x = proc (y,z) -> case compare x y of+                        GT -> returnA -< z+x++   The type checker turns the case into++        case compare x y of+          GT { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x++   That is, it attaches the $dNum_123 binding to a ConPatOut in scope.++   During desugaring, evidence binders must be collected because their sets are+   intersected with free variable sets of subsequent commands to create+   (minimal) command environments.  Failing to do it properly leads to bugs+   (e.g., #18950).++   Note: attaching evidence binders to existing ConPatOut may be suboptimal for+   arrows.  In the example above we would prefer to generate:++        case compare x y of+          GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x++   So that the evidence isn't passed into the command environment. This issue+   doesn't arise with desugaring of non-arrow code because the simplifier can+   freely float and inline let-expressions created for evidence binders. But+   with arrow desugaring, the simplifier would have to see through the command+   environment tuple which is more complicated.+ -}  hsGroupBinders :: HsGroup GhcRn -> [Name] hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,                           hs_fords = foreign_decls })-  =  collectHsValBinders val_decls+  =  collectHsValBinders CollNoDictBinders val_decls   ++ hsTyClForeignBinders tycl_decls foreign_decls  hsTyClForeignBinders :: [TyClGroup GhcRn]@@ -1136,13 +1341,13 @@          `mappend`          foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)   where-    getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]+    getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]     getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs  ------------------- hsLTyClDeclBinders :: IsPass p-                   => Located (TyClDecl (GhcPass p))-                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                   => LocatedA (TyClDecl (GhcPass p))+                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) -- ^ Returns all the /binding/ names of the decl.  The first one is -- guaranteed to be the name of the decl. The first component -- represents all binding names except record fields; the second@@ -1166,7 +1371,8 @@      [ L fam_loc fam_name | (L fam_loc (FamilyDecl                                         { fdLName = L _ fam_name })) <- ats ]      ++-     [ L mem_loc mem_name | (L mem_loc (ClassOpSig _ False ns _)) <- sigs+     [ L mem_loc mem_name+                          | (L mem_loc (ClassOpSig _ False ns _)) <- sigs                           , (L _ mem_name) <- ns ]     , []) hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = (L _ name)@@ -1175,37 +1381,39 @@   --------------------hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]+hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)+                      => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)] -- ^ See Note [SrcSpan for binders] hsForeignDeclsBinders foreign_decls-  = [ L decl_loc n+  = [ L (noAnnSrcSpan (locA decl_loc)) n     | L decl_loc (ForeignImport { fd_name = L _ n })         <- foreign_decls]   --------------------hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]+hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _))   = foldr addPatSynSelector [] . unionManyBags $ map snd binds -addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]+addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels-  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind-  = map (unLoc . recordPatSynSelectorId) as ++ sels+  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind+  = map recordPatSynField as ++ sels   | otherwise = sels -getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]+getPatSynBinds :: forall id. UnXRec id+               => [(RecFlag, LHsBinds id)] -> [PatSynBind id id] getPatSynBinds binds   = [ psb | (_, lbinds) <- binds-          , L _ (PatSynBind _ psb) <- bagToList lbinds ]+          , (unXRec @id -> (PatSynBind _ psb)) <- bagToList lbinds ]  ------------------- hsLInstDeclBinders :: IsPass p                    => LInstDecl (GhcPass p)-                   -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsLInstDeclBinders (L _ (ClsInstD                              { cid_inst = ClsInstDecl                                           { cid_datafam_insts = dfis }}))@@ -1218,9 +1426,8 @@ -- | the 'SrcLoc' returned are for the whole declarations, not just the names hsDataFamInstBinders :: IsPass p                      => DataFamInstDecl (GhcPass p)-                     -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                       FamEqn { feqn_rhs = defn }}})+                     -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})   = hsDataDefnBinders defn   -- There can't be repeated symbols because only data instances have binders @@ -1228,7 +1435,7 @@ -- | the 'SrcLoc' returned are for the whole declarations, not just the names hsDataDefnBinders :: IsPass p                   => HsDataDefn (GhcPass p)-                  -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                  -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)]) hsDataDefnBinders (HsDataDefn { dd_cons = cons })   = hsConDeclsBinders cons   -- See Note [Binders in family instances]@@ -1239,7 +1446,7 @@  hsConDeclsBinders :: forall p. IsPass p                   => [LConDecl (GhcPass p)]-                  -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+                  -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])    -- See hsLTyClDeclBinders for what this does    -- The function is boringly complicated because of the records    -- And since we only have equality, we have to be a little careful@@ -1247,7 +1454,7 @@   = go id cons   where     go :: Seen p -> [LConDecl (GhcPass p)]-       -> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+       -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])     go _ [] = ([], [])     go remSeen (r:rs)       -- Don't re-mangle the location of field names, because we don't@@ -1256,29 +1463,36 @@         in case unLoc r of            -- remove only the first occurrence of any seen field in order to            -- avoid circumventing detection of duplicate fields (#9156)-           ConDeclGADT { con_names = names, con_args = args }+           ConDeclGADT { con_names = names, con_g_args = args }              -> (map (L loc . unLoc) names ++ ns, flds ++ fs)              where-                (remSeen', flds) = get_flds remSeen args+                (remSeen', flds) = get_flds_gadt remSeen args                 (ns, fs) = go remSeen' rs             ConDeclH98 { con_name = name, con_args = args }              -> ([L loc (unLoc name)] ++ ns, flds ++ fs)              where-                (remSeen', flds) = get_flds remSeen args+                (remSeen', flds) = get_flds_h98 remSeen args                 (ns, fs) = go remSeen' rs -    get_flds :: Seen p -> HsConDeclDetails (GhcPass p)+    get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)+                 -> (Seen p, [LFieldOcc (GhcPass p)])+    get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds+    get_flds_h98 remSeen _ = (remSeen, [])++    get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)+                  -> (Seen p, [LFieldOcc (GhcPass p)])+    get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds+    get_flds_gadt remSeen _ = (remSeen, [])++    get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]              -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds remSeen (RecCon flds)-       = (remSeen', fld_names)+    get_flds remSeen flds = (remSeen', fld_names)        where           fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))           remSeen' = foldr (.) remSeen                                [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v                                | v <- fld_names]-    get_flds remSeen _-       = (remSeen, [])  {- @@ -1321,27 +1535,27 @@ easier. -} -lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]+lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]                 -> [(SrcSpan, [Name])] lStmtsImplicits = hs_lstmts   where-    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]+    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]               -> [(SrcSpan, [Name])]     hs_lstmts = concatMap (hs_stmt . unLoc) -    hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))+    hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))             -> [(SrcSpan, [Name])]     hs_stmt (BindStmt _ pat _) = lPatImplicits pat     hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args       where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat             do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts-    hs_stmt (LetStmt _ binds)     = hs_local_binds (unLoc binds)+    hs_stmt (LetStmt _ binds)     = hs_local_binds binds     hs_stmt (BodyStmt {})         = []     hs_stmt (LastStmt {})         = []     hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs                                                 , s <- ss]     hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts-    hs_stmt (RecStmt { recS_stmts = ss })     = hs_lstmts ss+    hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss      hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds     hs_local_binds (HsIPBinds {})           = []@@ -1380,10 +1594,10 @@      hs_pat _ = [] -    details :: Located Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]-    details _ (PrefixCon ps)   = hs_lpats ps+    details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]+    details _ (PrefixCon _ ps) = hs_lpats ps     details n (RecCon fs)      =-      [(err_loc, collectPatsBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]+      [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]         ++ hs_lpats explicit_pats        where implicit_pats = map (hsRecFieldArg . unLoc) implicit@@ -1395,6 +1609,6 @@                                                     ,  let  pat_explicit =                                                               maybe True ((i<) . unLoc)                                                                          (rec_dotdot fs)]-            err_loc = maybe (getLoc n) getLoc (rec_dotdot fs)+            err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)      details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2

GHC/HsToCore.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,11 +11,6 @@ The Desugarer: turning HsSyn into Core. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore (     -- * Desugaring operations     deSugar, deSugarExpr@@ -20,54 +20,74 @@  import GHC.Prelude -import GHC.HsToCore.Usage import GHC.Driver.Session-import GHC.Driver.Types+import GHC.Driver.Config+import GHC.Driver.Env+import GHC.Driver.Backend+ import GHC.Hs++import GHC.HsToCore.Usage+import GHC.HsToCore.Monad+import GHC.HsToCore.Expr+import GHC.HsToCore.Binds+import GHC.HsToCore.Foreign.Decl+import GHC.HsToCore.Coverage+import GHC.HsToCore.Docs+ import GHC.Tc.Types import GHC.Tc.Utils.Monad  ( finalSafeMode, fixSafeInstances ) import GHC.Tc.Module ( runTcInteractive )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Name+ import GHC.Core.Type import GHC.Core.TyCon     ( tyConDataCons )-import GHC.Types.Avail import GHC.Core 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-import GHC.HsToCore.Binds-import GHC.HsToCore.Foreign.Decl-import GHC.Builtin.Names-import GHC.Builtin.Types.Prim import GHC.Core.Coercion-import GHC.Builtin.Types import GHC.Core.DataCon ( dataConWrapId ) import GHC.Core.Make-import GHC.Unit.Module-import GHC.Types.Name.Set-import GHC.Types.Name.Env import GHC.Core.Rules-import GHC.Types.Basic import GHC.Core.Opt.Monad ( CoreToDo(..) ) import GHC.Core.Lint     ( endPassIO )-import GHC.Types.Var.Set++import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Builtin.Types+ import GHC.Data.FastString+import GHC.Data.OrdList+ import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Types.SrcLoc-import GHC.HsToCore.Coverage+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad-import GHC.Data.OrdList-import GHC.HsToCore.Docs+import GHC.Utils.Logger -import Data.List+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.ForeignStubs+import GHC.Types.Avail+import GHC.Types.Basic+import GHC.Types.Var.Set+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.TypeEnv+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Name.Ppr+import GHC.Types.HpcInfo++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface++import Data.List (partition) import Data.IORef import Control.Monad( when ) import GHC.Driver.Plugins ( LoadedPlugin(..) )@@ -81,7 +101,7 @@ -}  -- | Main entry point to the desugarer.-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages, Maybe ModGuts)+deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DecoratedSDoc, Maybe ModGuts) -- Can modify PCS by faulting in more declarations  deSugar hsc_env@@ -117,13 +137,14 @@                             })    = do { let dflags = hsc_dflags hsc_env-             print_unqual = mkPrintUnqualified dflags rdr_env-        ; withTiming dflags+             logger = hsc_logger hsc_env+             print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env+        ; withTiming logger dflags                      (text "Desugar"<+>brackets (ppr mod))                      (const ()) $      do { -- Desugar the program         ; let export_set = availsToNameSet exports-              target     = hscTarget dflags+              bcknd      = backend dflags               hpcInfo    = emptyHpcInfo other_hpc_info          ; (binds_cvr, ds_hpc_info, modBreaks)@@ -139,8 +160,8 @@                           ; (ds_fords, foreign_prs) <- dsForeigns fords                           ; ds_rules <- mapMaybeM dsRule rules                           ; let hpc_init-                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info-                                  | otherwise = empty+                                  | gopt Opt_Hpc dflags = hpcInitCode (hsc_dflags hsc_env) mod ds_hpc_info+                                  | otherwise = mempty                           ; return ( ds_ev_binds                                    , foreign_prs `appOL` core_prs `appOL` spec_prs                                    , spec_rules ++ ds_rules@@ -153,7 +174,7 @@      do {       -- Add export flags to bindings           keep_alive <- readIORef keep_var         ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules-              final_prs = addExportFlagsAndRules target export_set keep_alive+              final_prs = addExportFlagsAndRules bcknd export_set keep_alive                                                  rules_for_locals (fromOL all_prs)                final_pgm = combineEvBinds ds_ev_binds final_prs@@ -164,17 +185,20 @@         -- 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 logger 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          ; let used_names = mkUsedNames tcg_env-              pluginModules =-                map lpModule (cachedPlugins (hsc_dflags hsc_env))-        ; deps <- mkDependencies (homeUnitId (hsc_dflags hsc_env))+              pluginModules = map lpModule (hsc_plugins hsc_env)+              home_unit = hsc_home_unit hsc_env+        ; deps <- mkDependencies (homeUnitId home_unit)                                  (map mi_module pluginModules) tcg_env          ; used_th <- readIORef tc_splice_used@@ -190,7 +214,7 @@          ; foreign_files <- readIORef th_foreign_files_var -        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env+        ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env          ; let mod_guts = ModGuts {                 mg_module       = mod,@@ -218,7 +242,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@@ -261,23 +285,23 @@ and Rec the rest. -} -deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)--deSugarExpr hsc_env tc_expr = do {-         let dflags = hsc_dflags hsc_env+deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, Maybe CoreExpr)+deSugarExpr hsc_env tc_expr = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env -       ; showPass dflags "Desugar"+    showPass logger dflags "Desugar" -         -- Do desugaring-       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $+    -- Do desugaring+    (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $                                  dsLExpr tc_expr -       ; case mb_core_expr of-            Nothing   -> return ()-            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"-                         FormatCore (pprCoreExpr expr)+    case mb_core_expr of+       Nothing   -> return ()+       Just expr -> dumpIfSet_dyn logger dflags Opt_D_dump_ds "Desugared"+                    FormatCore (pprCoreExpr expr) -       ; return (msgs, mb_core_expr) }+    return (msgs, mb_core_expr)  {- ************************************************************************@@ -288,9 +312,9 @@ -}  addExportFlagsAndRules-    :: HscTarget -> NameSet -> NameSet -> [CoreRule]+    :: Backend -> NameSet -> NameSet -> [CoreRule]     -> [(Id, t)] -> [(Id, t)]-addExportFlagsAndRules target exports keep_alive rules prs+addExportFlagsAndRules bcknd exports keep_alive rules prs   = mapFst add_one prs   where     add_one bndr = add_rules name (add_export name bndr)@@ -326,7 +350,7 @@         -- isExternalName separates the user-defined top-level names from those         -- introduced by the type checker.     is_exported :: Name -> Bool-    is_exported | targetRetainsAllBindings target = isExternalName+    is_exported | backendRetainsAllBindings bcknd = isExternalName                 | otherwise                       = (`elemNameSet` exports)  {-@@ -379,7 +403,7 @@                       , rd_tmvs = vars                       , rd_lhs  = lhs                       , rd_rhs  = rhs }))-  = putSrcSpanDs loc $+  = putSrcSpanDs (locA loc) $     do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]          ; lhs' <- unsetGOptM Opt_EnableRewriteRules $@@ -403,7 +427,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) $@@ -732,7 +757,7 @@                info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                                `setUnfoldingInfo` mkCompulsoryUnfolding rhs+                                `setUnfoldingInfo` mkCompulsoryUnfolding' rhs               ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar                                   , openAlphaTyVar, openBetaTyVar ] $@@ -740,5 +765,3 @@               id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info        ; return (id, old_expr) }--  where

GHC/HsToCore/Arrows.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,12 +11,6 @@ Desugaring arrow commands -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Arrows ( dsProcExpr ) where  #include "HsVersions.h"@@ -22,11 +21,8 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Monad -import GHC.Hs   hiding (collectPatBinders, collectPatsBinders,-                        collectLStmtsBinders, collectLStmtBinders,-                        collectStmtBinders )+import GHC.Hs import GHC.Tc.Utils.Zonk-import qualified GHC.Hs.Utils as HsUtils  -- NB: The desugarer, which straddles the source and Core worlds, sometimes --     needs to see source types (newtypes etc), and sometimes not@@ -52,10 +48,11 @@ import GHC.Types.Basic import GHC.Builtin.Names import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Data.List.SetOps( assocMaybe )-import Data.List+import Data.List (mapAccumL) import GHC.Utils.Misc import GHC.Types.Unique.DSet @@ -169,10 +166,6 @@ do_premap ids b_ty c_ty d_ty f g    = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g -mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr-mkFailExpr ctxt ty-  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)- -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a mkFstExpr :: Type -> Type -> DsM CoreExpr mkFstExpr a_ty b_ty = do@@ -207,7 +200,7 @@ coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr coreCasePair scrut_var var1 var2 body   = Case (Var scrut_var) scrut_var (exprType body)-         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]+         [Alt (DataAlt (tupleDataCon Boxed 2)) [var1, var2] body]  mkCorePairTy :: Type -> Type -> Type mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]@@ -304,7 +297,8 @@  mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc mkHsEnvStackExpr env_ids stack_id-  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]+  = mkLHsTupleExpr [mkLHsVarTuple env_ids noExtField, nlHsVar stack_id]+                   noExtField  -- Translation of arrow abstraction @@ -320,15 +314,15 @@         -> DsM CoreExpr dsProcExpr pat (L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do     (meth_binds, meth_ids) <- mkCmdEnv ids-    let locals = mkVarSet (collectPatBinders pat)+    let locals = mkVarSet (collectPatBinders CollWithDictBinders pat)     (core_cmd, _free_vars, env_ids)        <- dsfixCmd meth_ids locals unitTy cmd_ty cmd     let env_ty = mkBigCoreVarTupTy env_ids     let env_stk_ty = mkCorePairTy env_ty unitTy     let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr-    fail_expr <- mkFailExpr ProcExpr env_stk_ty+    fail_expr <- mkFailExpr (ArrowMatchCtxt ProcExpr) env_stk_ty     var <- selectSimpleMatchVarL Many pat-    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr+    match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr     let pat_ty = hsLPatType pat     let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty                     (Lam var match_code)@@ -561,14 +555,17 @@     let         left_id  = HsConLikeOut noExtField (RealDataCon left_con)         right_id = HsConLikeOut noExtField (RealDataCon right_con)-        left_expr  ty1 ty2 e = noLoc $ HsApp noExtField-                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLoc $ HsApp noExtField-                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e+        left_expr  ty1 ty2 e = noLocA $ HsApp noComments+                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+        right_expr ty1 ty2 e = noLocA $ HsApp noComments+                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e          -- Prefix each tuple with a distinct series of Left's and Right's,         -- in a balanced way, keeping track of the types. +        merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)+                      -> ([LHsExpr GhcTc], Type, CoreExpr)+                      -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ         merge_branches (builds1, in_ty1, core_exp1)                        (builds2, in_ty2, core_exp2)           = (map (left_expr in_ty1 in_ty2) builds1 ++@@ -597,7 +594,7 @@ dsCmd ids local_vars stack_ty res_ty       (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do   arg_id <- newSysLocalDs arg_mult arg_ty-  let case_cmd  = noLoc $ HsCmdCase noExtField (nlHsVar arg_id) mg+  let case_cmd  = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg   dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids  -- D; ys |-a cmd : stk --> t@@ -606,10 +603,9 @@ -- --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(L _ binds) body)-                                                                    env_ids = do+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do     let-        defined_vars = mkVarSet (collectLocalBinders binds)+        defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds)         local_vars' = defined_vars `unionVarSet` local_vars      (core_body, _free_vars, env_ids')@@ -636,7 +632,7 @@ dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty                                                (L loc stmts))                                                                    env_ids = do-    putSrcSpanDs loc $+    putSrcSpanDsA loc $       dsNoLevPoly stmts_ty         (text "In the do-command:" <+> ppr do_block)     (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids@@ -708,7 +704,7 @@                 DIdSet,         -- subset of local vars that occur free                 [Id])           -- the same local vars as a list, fed back dsfixCmd ids local_vars stk_ty cmd_ty cmd-  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty+  = do { putSrcSpanDs (getLocA cmd) $ dsNoLevPoly cmd_ty            (text "When desugaring the command:" <+> ppr cmd)        ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) } @@ -746,7 +742,7 @@          -> DsM (CoreExpr,      -- desugared expression                  DIdSet)        -- subset of local vars that occur free dsCmdLam ids local_vars stack_ty res_ty pats body env_ids = do-    let pat_vars = mkVarSet (collectPatsBinders pats)+    let pat_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)     let local_vars' = pat_vars `unionVarSet` local_vars         (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty     (core_body, free_vars, env_ids')@@ -762,9 +758,9 @@         in_ty = envStackType env_ids stack_ty         in_ty' = envStackType env_ids' stack_ty' -    fail_expr <- mkFailExpr LambdaExpr in_ty'+    fail_expr <- mkFailExpr (ArrowMatchCtxt KappaExpr) in_ty'     -- match the patterns against the parameters-    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr+    match_code <- matchSimplys (map Var param_ids) (ArrowMatchCtxt KappaExpr) pats core_expr                     fail_expr     -- match the parameters against the top of the old stack     (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code@@ -798,7 +794,7 @@ --              ---> premap (\ (xs) -> ((xs), ())) c  dsCmdDo ids local_vars res_ty [L loc (LastStmt _ body _ _)] env_ids = do-    putSrcSpanDs loc $ dsNoLevPoly res_ty+    putSrcSpanDsA loc $ dsNoLevPoly res_ty                          (text "In the command:" <+> ppr body)     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids     let env_ty = mkBigCoreVarTupTy env_ids@@ -813,7 +809,7 @@         env_ids')  dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do-    let bound_vars  = mkVarSet (collectLStmtBinders stmt)+    let bound_vars  = mkVarSet (collectLStmtBinders CollWithDictBinders stmt)     let local_vars' = bound_vars `unionVarSet` local_vars     (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids@@ -889,7 +885,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd) env_ids = do     let pat_ty = hsLPatType pat     (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd-    let pat_vars = mkVarSet (collectPatBinders pat)+    let pat_vars = mkVarSet (collectPatBinders CollWithDictBinders pat)     let         env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids         env_ty2 = mkBigCoreVarTupTy env_ids2@@ -965,7 +961,7 @@ --                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'  dsCmdStmt ids local_vars out_ids-        (RecStmt { recS_stmts = stmts+        (RecStmt { recS_stmts = L _ stmts                  , recS_later_ids = later_ids, recS_rec_ids = rec_ids                  , recS_ext = RecStmtTc { recS_later_rets = later_rets                                         , recS_rec_rets = rec_rets } })@@ -1126,7 +1122,7 @@   = dsCmdLStmt ids local_vars out_ids stmt env_ids  dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do-    let bound_vars  = mkVarSet (collectLStmtBinders stmt)+    let bound_vars  = mkVarSet (collectLStmtBinders CollWithDictBinders stmt)     let local_vars' = bound_vars `unionVarSet` local_vars     (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts     (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids@@ -1156,41 +1152,45 @@  -- List of leaf expressions, with set of variables bound in each -leavesMatch :: LMatch GhcTc (Located (body GhcTc))-            -> [(Located (body GhcTc), IdSet)]+leavesMatch :: LMatch GhcTc (LocatedA (body GhcTc))+            -> [(LocatedA (body GhcTc), IdSet)] leavesMatch (L _ (Match { m_pats = pats-                        , m_grhss = GRHSs _ grhss (L _ binds) }))+                        , m_grhss = GRHSs _ grhss binds }))   = let-        defined_vars = mkVarSet (collectPatsBinders pats)+        defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)                         `unionVarSet`-                       mkVarSet (collectLocalBinders binds)+                       mkVarSet (collectLocalBinders CollWithDictBinders binds)     in     [(body,-      mkVarSet (collectLStmtsBinders stmts)+      mkVarSet (collectLStmtsBinders CollWithDictBinders stmts)         `unionVarSet` defined_vars)     | L _ (GRHS _ stmts body) <- grhss]  -- Replace the leaf commands in a match  replaceLeavesMatch-        :: Type                                 -- new result type-        -> [Located (body' GhcTc)] -- replacement leaf expressions of that type-        -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command-        -> ([Located (body' GhcTc)],            -- remaining leaf expressions-            LMatch GhcTc (Located (body' GhcTc))) -- updated match+        :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))+           , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))+        => Type                                 -- new result type+        -> [LocatedA (body' GhcTc)] -- replacement leaf expressions of that type+        -> LMatch GhcTc (LocatedA (body GhcTc))  -- the matches of a case command+        -> ([LocatedA (body' GhcTc)],            -- remaining leaf expressions+            LMatch GhcTc (LocatedA (body' GhcTc))) -- updated match replaceLeavesMatch _res_ty leaves                         (L loc                           match@(Match { m_grhss = GRHSs x grhss binds }))   = let         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss     in-    (leaves', L loc (match { m_ext = noExtField, m_grhss = GRHSs x grhss' binds }))+    (leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds }))  replaceLeavesGRHS-        :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type-        -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command-        -> ([Located (body' GhcTc)],              -- remaining leaf expressions-            LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS+        :: ( Anno (Match GhcTc (LocatedA (body' GhcTc))) ~ Anno (Match GhcTc (LocatedA (body GhcTc)))+           , Anno (GRHS GhcTc (LocatedA (body' GhcTc))) ~ Anno (GRHS GhcTc (LocatedA (body GhcTc))))+        => [LocatedA (body' GhcTc)]  -- replacement leaf expressions of that type+        -> LGRHS GhcTc (LocatedA (body GhcTc))     -- rhss of a case command+        -> ([LocatedA (body' GhcTc)],              -- remaining leaf expressions+            LGRHS GhcTc (LocatedA (body' GhcTc)))  -- updated GRHS replaceLeavesGRHS (leaf:leaves) (L loc (GRHS x stmts _))   = (leaves, L loc (GRHS x stmts leaf)) replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"@@ -1205,80 +1205,3 @@     fold_pairs [] = []     fold_pairs [x] = [x]     fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs--{--Note [Dictionary binders in ConPatOut] See also same Note in GHC.Hs.Utils-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The following functions to collect value variables from patterns are-copied from GHC.Hs.Utils, with one change: we also collect the dictionary-bindings (cpt_binds) from ConPatOut.  We need them for cases like--h :: Arrow a => Int -> a (Int,Int) Int-h x = proc (y,z) -> case compare x y of-                GT -> returnA -< z+x--The type checker turns the case into--                case compare x y of-                  GT { p77 = plusInt } -> returnA -< p77 z x--Here p77 is a local binding for the (+) operation.--See comments in GHC.Hs.Utils for why the other version does not include-these bindings.--}--collectPatBinders :: LPat GhcTc -> [Id]-collectPatBinders pat = collectl pat []--collectPatsBinders :: [LPat GhcTc] -> [Id]-collectPatsBinders pats = foldr collectl [] pats------------------------collectl :: LPat GhcTc -> [Id] -> [Id]--- See Note [Dictionary binders in ConPatOut]-collectl (L _ pat) bndrs-  = go pat-  where-    go (VarPat _ (L _ var))       = var : bndrs-    go (WildPat _)                = bndrs-    go (LazyPat _ pat)            = collectl pat bndrs-    go (BangPat _ pat)            = collectl pat bndrs-    go (AsPat _ (L _ a) pat)      = a : collectl pat bndrs-    go (ParPat _ pat)             = collectl pat bndrs--    go (ListPat _ pats)           = foldr collectl bndrs pats-    go (TuplePat _ pats _)        = foldr collectl bndrs pats-    go (SumPat _ pat _ _)         = collectl pat bndrs--    go (ConPat { pat_args = ps-               , pat_con_ext = ConPatTc { cpt_binds = ds }}) =-                                    collectEvBinders ds-                                    ++ foldr collectl bndrs (hsConPatArgs ps)-    go (LitPat _ _)               = bndrs-    go (NPat {})                  = bndrs-    go (NPlusKPat _ (L _ n) _ _ _ _) = n : bndrs--    go (SigPat _ pat _)           = collectl pat bndrs-    go (XPat (CoPat _ pat _))     = collectl (noLoc pat) bndrs-    go (ViewPat _ _ pat)          = collectl pat bndrs-    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)--collectEvBinders :: TcEvBinds -> [Id]-collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs-collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"--add_ev_bndr :: EvBind -> [Id] -> [Id]-add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs-                                       | otherwise = bs-  -- A worry: what about coercion variable binders??--collectLStmtsBinders :: [LStmt GhcTc body] -> [Id]-collectLStmtsBinders = concatMap collectLStmtBinders--collectLStmtBinders :: LStmt GhcTc body -> [Id]-collectLStmtBinders = collectStmtBinders . unLoc--collectStmtBinders :: Stmt GhcTc body -> [Id]-collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids-collectStmtBinders stmt = HsUtils.collectStmtBinders stmt

GHC/HsToCore/Binds.hs view

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -10,16 +16,9 @@ lower levels it is preserved with @let@/@letrec@s). -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Binds    ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec-   , dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule+   , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule    ) where @@ -33,7 +32,7 @@ import GHC.HsToCore.Monad import GHC.HsToCore.GuardedRHSs import GHC.HsToCore.Utils-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )+import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )  import GHC.Hs             -- lots of things import GHC.Core           -- lots of things@@ -42,7 +41,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@@ -54,15 +53,15 @@ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Multiplicity-import GHC.Builtin.Types ( typeNatKind, typeSymbolKind )+import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy ) import GHC.Types.Id-import GHC.Types.Id.Make(proxyHashId) import GHC.Types.Name import GHC.Types.Var.Set import GHC.Core.Rules import GHC.Types.Var.Env import GHC.Types.Var( EvVar ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Unit.Module import GHC.Types.SrcLoc import GHC.Data.Maybe@@ -70,13 +69,14 @@ import GHC.Data.Bag 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 ) import GHC.Utils.Monad import qualified GHC.LanguageExtensions as LangExt import Control.Monad-import Data.List.NonEmpty ( nonEmpty )  {-********************************************************************** *                                                                      *@@ -108,7 +108,7 @@     bang_binds     = filterBag (isBangedHsBind   . unLoc) binds      top_level_err desc (L loc bind)-      = putSrcSpanDs loc $+      = putSrcSpanDs (locA loc) $         errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")                   2 (ppr bind)) @@ -125,7 +125,7 @@ dsLHsBind :: LHsBind GhcTc           -> DsM ([Id], [(Id,CoreExpr)]) dsLHsBind (L loc bind) = do dflags <- getDynFlags-                            putSrcSpanDs loc $ dsHsBind dflags bind+                            putSrcSpanDs (locA loc) $ dsHsBind dflags bind  -- | Desugar a single binding (or group of recursive binds). dsHsBind :: DynFlags@@ -150,14 +150,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@@ -181,10 +181,10 @@           return (force_var, [core_binds]) }  dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss-                         , pat_ext = NPatBindTc _ ty+                         , pat_ext = ty                          , pat_ticks = (rhs_tick, var_ticks) })-  = do  { rhss_deltas <- checkGuardMatches PatBindGuards grhss-        ; body_expr <- dsGuarded grhss ty (nonEmpty 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'@@ -199,11 +199,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 @@ -379,30 +379,31 @@ 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-          NoUserInline -> (gbl_id, rhs)-          NoInline     -> (gbl_id, rhs)-          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)-          Inline       -> inline_pair+          NoUserInlinePrag -> (gbl_id, rhs)+          NoInline         -> (gbl_id, rhs)+          Inlinable        -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+          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@@ -703,8 +704,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 @@ -862,8 +864,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@@ -926,7 +929,7 @@      where (bs, body') = split_lets body      -- handle "unlifted lets" too, needed for "map/coerce"-   split_lets (Case r d _ [(DEFAULT, _, body)])+   split_lets (Case r d _ [Alt DEFAULT _ body])      | isCoVar d      = ((d,r):bs, body')      where (bs, body') = split_lets body@@ -1215,7 +1218,7 @@ dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr -- Return a CoreExpr :: Typeable ty -- This code is tightly coupled to the representation--- of TypeRep, in base library Data.Typeable.Internals+-- of TypeRep, in base library Data.Typeable.Internal dsEvTypeable ty ev   = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable        ; let kind = typeKind ty@@ -1294,16 +1297,16 @@   = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Solver.Interact     do { fun  <- dsLookupGlobalId tr_fun        ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol-       ; let proxy = mkTyApps (Var proxyHashId) [ty_kind, ty]-       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict, proxy ]) }+       ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }   where     ty_kind = typeKind ty      -- tr_fun is the Name of-    --       typeNatTypeRep    :: KnownNat    a => Proxy# a -> TypeRep a-    -- of    typeSymbolTypeRep :: KnownSymbol a => Proxy# a -> TypeRep a-    tr_fun | ty_kind `eqType` typeNatKind    = typeNatTypeRepName+    --       typeNatTypeRep    :: KnownNat    a => TypeRep a+    -- of    typeSymbolTypeRep :: KnownSymbol a => TypeRep a+    tr_fun | ty_kind `eqType` naturalTy      = typeNatTypeRepName            | ty_kind `eqType` typeSymbolKind = typeSymbolTypeRepName+           | ty_kind `eqType` charTy         = typeCharTypeRepName            | otherwise = panic "dsEvTypeable: unknown type lit kind"  ds_ev_typeable ty ev

GHC/HsToCore/Coverage.hs view

@@ -1,51 +1,59 @@+{-# LANGUAGE DeriveFunctor            #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TypeFamilies             #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) Galois, 2006 (c) University of Glasgow, 2007 -} -{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Coverage (addTicksToBinds, hpcInitCode) where  import GHC.Prelude as Prelude +import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Env+ import qualified GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes-import Data.Array import GHC.ByteCode.Types import GHC.Stack.CCS-import GHC.Core.Type import GHC.Hs import GHC.Unit+import GHC.Cmm.CLabel++import GHC.Core.Type+import GHC.Core.TyCon++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.Bag++import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable-import GHC.Driver.Session-import GHC.Core.ConLike-import Control.Monad+import GHC.Utils.Panic+import GHC.Utils.Monad+import GHC.Utils.Logger+ import GHC.Types.SrcLoc-import GHC.Utils.Error+import GHC.Types.Basic+import GHC.Types.Id+import GHC.Types.Var.Set import GHC.Types.Name.Set hiding (FreeVars) import GHC.Types.Name-import GHC.Data.Bag+import GHC.Types.HpcInfo import GHC.Types.CostCentre import GHC.Types.CostCentre.State-import GHC.Core-import GHC.Types.Id-import GHC.Types.Var.Set-import Data.List-import GHC.Data.FastString-import GHC.Driver.Types-import GHC.Core.TyCon-import GHC.Types.Basic-import GHC.Utils.Monad-import GHC.Data.Maybe-import GHC.Cmm.CLabel-import GHC.Utils.Misc+import GHC.Types.ForeignStubs+import GHC.Types.Tickish +import Control.Monad+import Data.List (isSuffixOf, intersperse)+import Data.Array import Data.Time import System.Directory @@ -77,8 +85,9 @@  addTicksToBinds hsc_env mod mod_loc exports tyCons binds   | let dflags = hsc_dflags hsc_env-        passes = coveragePasses dflags, not (null passes),-    Just orig_file <- ml_hs_file mod_loc = do+        passes = coveragePasses dflags+  , not (null passes)+  , Just orig_file <- ml_hs_file mod_loc = do       let  orig_file2 = guessSourceFile binds orig_file @@ -114,7 +123,8 @@      hashNo <- writeMixEntries dflags mod tickCount entries orig_file2      modBreaks <- mkModBreaks hsc_env mod tickCount entries -     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" FormatHaskell+     let logger = hsc_logger hsc_env+     dumpIfSet_dyn logger dflags Opt_D_dump_ticked "HPC" FormatHaskell        (pprLHsBinds binds1)       return (binds1, HpcInfo tickCount hashNo, modBreaks)@@ -126,7 +136,7 @@      -- Try look for a file generated from a .hsc file to a      -- .hs file, by peeking ahead.      let top_pos = catMaybes $ foldr (\ (L pos _) rest ->-                                 srcSpanFileName_maybe pos : rest) [] binds+                               srcSpanFileName_maybe (locA pos) : rest) [] binds      in      case top_pos of         (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name@@ -136,8 +146,9 @@  mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks) mkModBreaks hsc_env mod count entries-  | breakpointsEnabled (hsc_dflags hsc_env) = do-    breakArray <- GHCi.newBreakArray hsc_env (length entries)+  | Just interp <- hsc_interp hsc_env+  , breakpointsEnabled (hsc_dflags hsc_env) = do+    breakArray <- GHCi.newBreakArray interp (length entries)     ccs <- mkCCSArray hsc_env mod count entries     let            locsTicks  = listArray (0,count-1) [ span  | (span,_,_,_)  <- entries ]@@ -155,11 +166,11 @@ mkCCSArray   :: HscEnv -> Module -> Int -> [MixEntry_]   -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray hsc_env modul count entries = do+mkCCSArray hsc_env modul count entries =   case hsc_interp hsc_env of     Just interp | GHCi.interpreterProfiled interp -> do       let module_str = moduleNameString (moduleName modul)-      costcentres <- GHCi.mkCostCentres hsc_env module_str (map mk_one entries)+      costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)       return (listArray (0,count-1) costcentres)      _ -> return (listArray (0,-1) [])@@ -190,7 +201,7 @@         modTime <- getModificationUTCTime filename         let entries' = [ (hpcPos, box)                        | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]-        when (entries' `lengthIsNot` count) $ do+        when (entries' `lengthIsNot` count) $           panic "the number of .mix entries are inconsistent"         let hashNo = mixHash filename modTime tabStop entries'         mixCreate hpc_mod_dir mod_name@@ -260,12 +271,12 @@  addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc) addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,-                                       abs_exports = abs_exports })) = do-  withEnv add_exports $ do-  withEnv add_inlines $ do-  binds' <- addTickLHsBinds binds-  return $ L pos $ bind { abs_binds = binds' }- where+                                       abs_exports = abs_exports })) =+  withEnv add_exports $+    withEnv add_inlines $ do+      binds' <- addTickLHsBinds binds+      return $ L pos $ bind { abs_binds = binds' }+  where    -- in AbsBinds, the Id on each binding is not the actual top-level    -- Id that we are defining, they are related by the abs_exports    -- field of AbsBinds.  So if we're doing TickExportedFunctions we need@@ -303,7 +314,7 @@         addPathEntry name $         addTickMatchGroup False (fun_matches funBind) -  blackListed <- isBlackListed pos+  blackListed <- isBlackListed (locA pos)   exported_names <- liftM exports getEnv    -- We don't want to generate code for blacklisted positions@@ -316,7 +327,7 @@   tick <- if not blackListed &&                shouldTickBind density toplev exported simple inline              then-                bindTick density name pos fvs+                bindTick density name (locA pos) fvs              else                 return Nothing @@ -356,14 +367,14 @@      -- Allocate the ticks -    rhs_tick <- bindTick density name pos fvs+    rhs_tick <- bindTick density name (locA pos) fvs     let rhs_ticks = rhs_tick `mbCons` initial_rhs_ticks      patvar_tickss <- case simplePatId of       Just{} -> return initial_patvar_tickss       Nothing -> do-        let patvars = map getOccString (collectPatBinders lhs)-        patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars+        let patvars = map getOccString (collectPatBinders CollNoDictBinders lhs)+        patvar_ticks <- mapM (\v -> bindTick density v (locA pos) fvs) patvars         return           (zipWith mbCons patvar_ticks                           (initial_patvar_tickss ++ repeat []))@@ -375,7 +386,7 @@ addTickLHsBind patsyn_bind@(L _ (PatSynBind {})) = return patsyn_bind  bindTick-  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe CoreTickish) bindTick density name pos fvs = do   decl_path <- getPathEntry   let@@ -414,7 +425,8 @@     TickCallSites      | isCallSite e0      -> tick_it     _other             -> dont_tick_it  where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0    dont_tick_it = addTickLHsExprNever e  -- Add a tick to an expression which is the RHS of an equation or a binding.@@ -431,7 +443,8 @@      TickCallSites   | isCallSite e0 -> tick_it      _other          -> dont_tick_it  where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0    dont_tick_it = addTickLHsExprNever e  -- The inner expression of an evaluation context:@@ -458,7 +471,8 @@                         | otherwise     -> tick_it      _other -> addTickLHsExprEvalInner e  where-   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   tick_it      = allocTickBox (ExpBox False) False False (locA pos)+                  $ addTickHsExpr e0    dont_tick_it = addTickLHsExprNever e  -- version of addTick that does not actually add a tick,@@ -469,30 +483,30 @@     e1 <- addTickHsExpr e0     return $ L pos e1 --- general heuristic: expressions which do not denote values are good--- break points+-- General heuristic: expressions which are calls (do not denote+-- values) are good break points. isGoodBreakExpr :: HsExpr GhcTc -> Bool-isGoodBreakExpr (HsApp {})     = True-isGoodBreakExpr (HsAppType {}) = True-isGoodBreakExpr (OpApp {})     = True-isGoodBreakExpr _other         = False+isGoodBreakExpr e = isCallSite e  isCallSite :: HsExpr GhcTc -> Bool isCallSite HsApp{}     = True isCallSite HsAppType{} = True-isCallSite OpApp{}     = True-isCallSite _ = False+isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))+                       = isCallSite e+-- NB: OpApp, SectionL, SectionR are all expanded out+isCallSite _           = False  addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addTickLHsExprOptAlt oneOfMany (L pos e0)   = ifDensity TickForCoverage-        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)+        (allocTickBox (ExpBox oneOfMany) False False (locA pos)+          $ addTickHsExpr e0)         (addTickLHsExpr (L pos e0))  addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc) addBinTickLHsExpr boxLabel (L pos e0)   = ifDensity TickForCoverage-        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)+        (allocBinTickBox boxLabel (locA pos) $ addTickHsExpr e0)         (addTickLHsExpr (L pos e0))  @@ -502,24 +516,28 @@ -- 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@(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@(HsVar _ (L _ id))  = do freeVar id; return e+addTickHsExpr e@(HsUnboundVar {})   = 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 {}) = return e+  -- We used to do a freeVar on a pat-syn builder, but actually+  -- such builders are never in the inScope env, which+  -- doesn't include top level bindings+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                 (return fix)@@ -561,9 +579,9 @@   = do { let isOneOfMany = case alts of [_] -> False; _ -> True        ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts        ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x (L l binds) e) =-        bindLocals (collectLocalBinders binds) $-          liftM2 (HsLet x . L l)+addTickHsExpr (HsLet x binds e) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $+          liftM2 (HsLet x)                   (addTickHsLocalBinds binds) -- to think about: !patterns.                   (addTickLHsExprLetBody e) addTickHsExpr (HsDo srcloc cxt (L l stmts))@@ -573,15 +591,8 @@         forQual = case cxt of                     ListComp -> Just $ BinBox QualBinBox                     _        -> Nothing-addTickHsExpr (ExplicitList ty wit es) =-        liftM3 ExplicitList-                (return ty)-                (addTickWit wit)-                (mapM (addTickLHsExpr) es)-             where addTickWit Nothing = return Nothing-                   addTickWit (Just fln)-                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln-                          return (Just fln')+addTickHsExpr (ExplicitList ty es)+  = liftM2 ExplicitList (return ty) (mapM (addTickLHsExpr) es)  addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e @@ -589,10 +600,14 @@   = do { rec_binds' <- addTickHsRecordBinds rec_binds        ; return (expr { rcon_flds = rec_binds' }) } -addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Left flds })   = do { e' <- addTickLHsExpr e        ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }+       ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) }+addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = Right flds' }) }  addTickHsExpr (ExprWithTySig x e ty) =         liftM3 ExprWithTySig@@ -615,16 +630,14 @@ 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 addTickHsExpr e@(HsTcBracketOut  {}) = return e addTickHsExpr e@(HsRnBracketOut  {}) = return e addTickHsExpr e@(HsSpliceE  {})      = return e+addTickHsExpr e@(HsGetField {})      = return e+addTickHsExpr e@(HsProjection {})    = return e addTickHsExpr (HsProc x pat cmdtop) =         liftM2 (HsProc x)                 (addTickLPat pat)@@ -636,13 +649,10 @@         liftM (XExpr . ExpansionExpr . HsExpanded a) $               (addTickHsExpr b) --- Others should never happen in expression content.-addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)--addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)-addTickTupArg (L l (Present x e))  = do { e' <- addTickLHsExpr e-                                        ; return (L l (Present x e')) }-addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))+addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)+addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e+                                  ; return (Present x e') }+addTickTupArg (Missing ty) = return (Missing ty)   addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)@@ -656,19 +666,19 @@              -> TM (Match GhcTc (LHsExpr GhcTc)) addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats                                                , m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders pats) $ do+  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do     gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs     return $ match { m_grhss = gRHSs' }  addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)              -> TM (GRHSs GhcTc (LHsExpr GhcTc))-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (L l local_binds)) = do+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =   bindLocals binders $ do     local_binds' <- addTickHsLocalBinds local_binds     guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded-    return $ GRHSs x guarded' (L l local_binds')+    return $ GRHSs x guarded' local_binds'   where-    binders = collectLocalBinders local_binds+    binders = collectLocalBinders CollNoDictBinders local_binds  addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)             -> TM (GRHS GhcTc (LHsExpr GhcTc))@@ -684,7 +694,7 @@     TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr     TickAllFunctions | isLambda ->        addPathEntry "\\" $-         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $+         allocTickBox (ExpBox False) True{-count-} False{-not top-} (locA pos) $            addTickHsExpr e0     _otherwise ->        addTickLHsExprRHS expr@@ -698,19 +708,19 @@ addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a                -> TM ([ExprLStmt GhcTc], a) addTickLStmts' isGuard lstmts res-  = bindLocals (collectLStmtsBinders lstmts) $+  = bindLocals (collectLStmtsBinders CollNoDictBinders lstmts) $     do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts        ; a <- res        ; return (lstmts', a) }  addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)             -> TM (Stmt GhcTc (LHsExpr GhcTc))-addTickStmt _isGuard (LastStmt x e noret ret) = do+addTickStmt _isGuard (LastStmt x e noret ret) =         liftM3 (LastStmt x)                 (addTickLHsExpr e)                 (pure noret)                 (addTickSyntaxExpr hpcSrcSpan ret)-addTickStmt _isGuard (BindStmt xbs pat e) = do+addTickStmt _isGuard (BindStmt xbs pat e) =         liftM4 (\b f -> BindStmt $ XBindStmtTc                     { xbstc_bindOp = b                     , xbstc_boundResultType = xbstc_boundResultType xbs@@ -721,18 +731,18 @@                 (mapM (addTickSyntaxExpr hpcSrcSpan) (xbstc_failOp xbs))                 (addTickLPat pat)                 (addTickLHsExprRHS e)-addTickStmt isGuard (BodyStmt x e bind' guard') = do+addTickStmt isGuard (BodyStmt x e bind' guard') =         liftM3 (BodyStmt x)                 (addTick isGuard e)                 (addTickSyntaxExpr hpcSrcSpan bind')                 (addTickSyntaxExpr hpcSrcSpan guard')-addTickStmt _isGuard (LetStmt x (L l binds)) = do-        liftM (LetStmt x . L l)+addTickStmt _isGuard (LetStmt x binds) =+        liftM (LetStmt x)                 (addTickHsLocalBinds binds)-addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) =     liftM3 (ParStmt x)         (mapM (addTickStmtAndBinders isGuard) pairs)-        (unLoc <$> addTickLHsExpr (L hpcSrcSpan mzipExpr))+        (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) mzipExpr))         (addTickSyntaxExpr hpcSrcSpan bindExpr) addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do     args' <- mapM (addTickApplicativeArg isGuard) args@@ -747,16 +757,16 @@     t_u <- addTickLHsExprRHS using     t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr     t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr-    t_m <- fmap unLoc (addTickLHsExpr (L hpcSrcSpan liftMExpr))+    t_m <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) liftMExpr))     return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u                   , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }  addTickStmt isGuard stmt@(RecStmt {})-  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)+  = do { stmts' <- addTickLStmts isGuard (unLoc $ recS_stmts stmt)        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }  addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)@@ -778,7 +788,7 @@   addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =     (ApplicativeArgMany x)       <$> addTickLStmts isGuard stmts-      <*> (unLoc <$> addTickLHsExpr (L hpcSrcSpan ret))+      <*> (unLoc <$> addTickLHsExpr (L (noAnnSrcSpan hpcSrcSpan) ret))       <*> addTickLPat pat       <*> pure ctxt @@ -827,7 +837,7 @@ -- There is no location here, so we might need to use a context location?? addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc) addTickSyntaxExpr pos syn@(SyntaxExprTc { syn_expr = x }) = do-        x' <- fmap unLoc (addTickLHsExpr (L pos x))+        x' <- fmap unLoc (addTickLHsExpr (L (noAnnSrcSpan pos) x))         return $ syn { syn_expr = x' } addTickSyntaxExpr _ NoSyntaxExprTc = return NoSyntaxExprTc @@ -871,9 +881,9 @@                 (addBinTickLHsExpr (BinBox CondBinBox) e1)                 (addTickLHsCmd c2)                 (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x (L l binds) c) =-        bindLocals (collectLocalBinders binds) $-          liftM2 (HsCmdLet x . L l)+addTickHsCmd (HsCmdLet x binds c) =+        bindLocals (collectLocalBinders CollNoDictBinders binds) $+          liftM2 (HsCmdLet x)                    (addTickHsLocalBinds binds) -- to think about: !patterns.                    (addTickLHsCmd c) addTickHsCmd (HsCmdDo srcloc (L l stmts))@@ -909,18 +919,18 @@  addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc)) addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders pats) $ do+  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do     gRHSs' <- addTickCmdGRHSs gRHSs     return $ match { m_grhss = gRHSs' }  addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))-addTickCmdGRHSs (GRHSs x guarded (L l local_binds)) = do+addTickCmdGRHSs (GRHSs x guarded local_binds) =   bindLocals binders $ do     local_binds' <- addTickHsLocalBinds local_binds     guarded' <- mapM (liftL addTickCmdGRHS) guarded-    return $ GRHSs x guarded' (L l local_binds')+    return $ GRHSs x guarded' local_binds'   where-    binders = collectLocalBinders local_binds+    binders = collectLocalBinders CollNoDictBinders local_binds  addTickCmdGRHS :: GRHS GhcTc (LHsCmd GhcTc) -> TM (GRHS GhcTc (LHsCmd GhcTc)) -- The *guards* are *not* Cmds, although the body is@@ -944,32 +954,32 @@         a <- res         return (lstmts', a)   where-        binders = collectLStmtsBinders lstmts+        binders = collectLStmtsBinders CollNoDictBinders lstmts  addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))-addTickCmdStmt (BindStmt x pat c) = do+addTickCmdStmt (BindStmt x pat c) =         liftM2 (BindStmt x)                 (addTickLPat pat)                 (addTickLHsCmd c)-addTickCmdStmt (LastStmt x c noret ret) = do+addTickCmdStmt (LastStmt x c noret ret) =         liftM3 (LastStmt x)                 (addTickLHsCmd c)                 (pure noret)                 (addTickSyntaxExpr hpcSrcSpan ret)-addTickCmdStmt (BodyStmt x c bind' guard') = do+addTickCmdStmt (BodyStmt x c bind' guard') =         liftM3 (BodyStmt x)                 (addTickLHsCmd c)                 (addTickSyntaxExpr hpcSrcSpan bind')                 (addTickSyntaxExpr hpcSrcSpan guard')-addTickCmdStmt (LetStmt x (L l binds)) = do-        liftM (LetStmt x . L l)+addTickCmdStmt (LetStmt x binds) =+        liftM (LetStmt x)                 (addTickHsLocalBinds binds) addTickCmdStmt stmt@(RecStmt {})-  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)+  = do { stmts' <- addTickLCmdStmts (unLoc $ recS_stmts stmt)        ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)        ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)        ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)-       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+       ; return (stmt { recS_stmts = noLocA stmts', recS_ret_fn = ret'                       , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTickCmdStmt ApplicativeStmt{} =   panic "ToDo: addTickCmdStmt ApplicativeLastStmt"@@ -982,12 +992,11 @@   = do  { fields' <- mapM addTickHsRecField fields         ; return (HsRecFields fields' dd) } -addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)-                  -> TM (LHsRecField' id (LHsExpr GhcTc))-addTickHsRecField (L l (HsRecField id expr pun))+addTickHsRecField :: LHsRecField' GhcTc id (LHsExpr GhcTc)+                  -> TM (LHsRecField' GhcTc id (LHsExpr GhcTc))+addTickHsRecField (L l (HsRecField x id expr pun))         = do { expr' <- addTickLHsExpr expr-             ; return (L l (HsRecField id expr' pun)) }-+             ; return (L l (HsRecField x id expr' pun)) }  addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc) addTickArithSeqInfo (From e1) =@@ -1038,19 +1047,23 @@ data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes                  deriving (Eq) +sourceNotesEnabled :: DynFlags -> Bool+sourceNotesEnabled dflags =+  (debugLevel dflags > 0) || (gopt Opt_InfoTableMap dflags)+ coveragePasses :: DynFlags -> [TickishType] coveragePasses dflags =     ifa (breakpointsEnabled dflags)          Breakpoints $     ifa (gopt Opt_Hpc dflags)                HpcTicks $     ifa (sccProfilingEnabled dflags &&          profAuto dflags /= NoProfAuto)      ProfNotes $-    ifa (debugLevel dflags > 0)              SourceNotes []+    ifa (sourceNotesEnabled dflags)          SourceNotes []   where ifa f x xs | f         = x:xs                    | otherwise = xs  -- | Should we produce 'Breakpoint' ticks? breakpointsEnabled :: DynFlags -> Bool-breakpointsEnabled dflags = hscTarget dflags == HscInterpreted+breakpointsEnabled dflags = backend dflags == Interpreter  -- | Tickishs that only make sense when their source code location -- refers to the current file. This might not always be true due to@@ -1177,16 +1190,16 @@     (fvs, e) <- getFreeVars m     env <- getEnv     tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L pos (HsTick noExtField tickish (L pos e)))+    return (L (noAnnSrcSpan pos) (HsTick noExtField tickish (L (noAnnSrcSpan pos) e)))   ) (do     e <- m-    return (L pos e)+    return (L (noAnnSrcSpan pos) e)   )  -- the tick application inherits the source position of its -- expression argument to support nested box allocations allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars-              -> TM (Maybe (Tickish Id))+              -> TM (Maybe CoreTickish) allocATickBox boxLabel countEntries topOnly  pos fvs =   ifGoodTickSrcSpan pos (do     let@@ -1200,7 +1213,7 @@   mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]-          -> TM (Tickish Id)+          -> TM CoreTickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do    let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs@@ -1227,7 +1240,7 @@           count = countEntries && gopt Opt_ProfCountEntries dflags       return $ ProfNote cc count True{-scopes-} -    Breakpoints -> Breakpoint <$> addMixEntry me <*> pure ids+    Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids      SourceNotes | RealSrcSpan pos' _ <- pos ->       return $ SourceNote pos' cc_name@@ -1240,7 +1253,7 @@ allocBinTickBox boxLabel pos m = do   env <- getEnv   case tickishType env of-    HpcTicks -> do e <- liftM (L pos) m+    HpcTicks -> do e <- liftM (L (noAnnSrcSpan pos)) m                    ifGoodTickSrcSpan pos                      (mkBinTickBoxHpc boxLabel pos e)                      (return e)@@ -1256,7 +1269,8 @@     <*> pure e   tick <- HpcTick (this_mod env)     <$> addMixEntry (pos,declPath env, [],ExpBox False)-  return $ L pos $ HsTick noExtField tick (L pos binTick)+  let pos' = noAnnSrcSpan pos+  return $ L pos' $ HsTick noExtField tick (L pos' binTick)  mkHpcPos :: SrcSpan -> HpcPos mkHpcPos pos@(RealSrcSpan s _)@@ -1314,10 +1328,10 @@  hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} -} -hpcInitCode :: Module -> HpcInfo -> SDoc-hpcInitCode _ (NoHpcInfo {}) = Outputable.empty-hpcInitCode this_mod (HpcInfo tickCount hashNo)- = vcat+hpcInitCode :: DynFlags -> Module -> HpcInfo -> CStub+hpcInitCode _ _ (NoHpcInfo {}) = mempty+hpcInitCode dflags this_mod (HpcInfo tickCount hashNo)+ = CStub $ vcat     [ text "static void hpc_init_" <> ppr this_mod          <> text "(void) __attribute__((constructor));"     , text "static void hpc_init_" <> ppr this_mod <> text "(void)"@@ -1334,7 +1348,8 @@        ])     ]   where-    tickboxes = ppr (mkHpcTicksLabel $ this_mod)+    platform  = targetPlatform dflags+    tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)      module_name  = hcat (map (text.charToC) $ BS.unpack $                          bytesFS (moduleNameFS (moduleName this_mod)))

GHC/HsToCore/Docs.hs view

@@ -1,5 +1,8 @@ -- | Extract docs from the renamer output so they can be serialized. {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}@@ -14,6 +17,7 @@ import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls+import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Hs.Type import GHC.Hs.Utils@@ -21,17 +25,25 @@ import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Tc.Types+import GHC.Parser.Annotation  import Control.Applicative+import Control.Monad.IO.Class import Data.Bifunctor (first)+import Data.IntMap (IntMap)+import qualified Data.IntMap as IM import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import Data.Semigroup+import GHC.IORef (readIORef)  -- | Extract docs from renamer output.-extractDocs :: TcGblEnv-            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)+-- This is monadic since we need to be able to read documentation added from+-- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'.+extractDocs :: MonadIO m+            => TcGblEnv+            -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)             -- ^             -- 1. Module header             -- 2. Docs on top level declarations@@ -41,8 +53,20 @@                      , tcg_insts = insts                      , tcg_fam_insts = fam_insts                      , tcg_doc_hdr = mb_doc_hdr-                     } =-    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)+                     , tcg_th_docs = th_docs_var+                     } = do+    th_docs <- liftIO $ readIORef th_docs_var+    let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)+        ExtractedTHDocs+          th_doc_hdr+          (DeclDocMap th_doc_map)+          (ArgDocMap th_arg_map)+          (DeclDocMap th_inst_map) = extractTHDocs th_docs+    return+      ( doc_hdr+      , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)+      , ArgDocMap (th_arg_map `unionArgMaps` arg_map)+      )   where     (doc_map, arg_map) = maybe (M.empty, M.empty)                                (mkMaps local_insts)@@ -55,10 +79,10 @@ -- For each declaration, find its names, its subordinates, and its doc strings. mkMaps :: [Name]        -> [(LHsDecl GhcRn, [HsDocString])]-       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))+       -> (Map Name (HsDocString), Map Name (IntMap HsDocString)) mkMaps instances decls =     ( f' (map (nubByName fst) decls')-    , f  (filterMapping (not . M.null) args)+    , f  (filterMapping (not . IM.null) args)     )   where     (decls', args) = unzip (map mappings decls)@@ -74,15 +98,15 @@      mappings :: (LHsDecl GhcRn, [HsDocString])              -> ( [(Name, HsDocString)]-                , [(Name, Map Int (HsDocString))]+                , [(Name, IntMap HsDocString)]                 )-    mappings (L (RealSrcSpan l _) decl, docStrs) =+    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) =            (dm, am)       where         doc = concatDocs docStrs         args = declTypeDocs decl -        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]+        subs :: [(Name, [HsDocString], IntMap HsDocString)]         subs = subordinates instanceMap decl          (subDocs, subArgs) =@@ -92,7 +116,7 @@         subNs = [ n | (n, _, _) <- subs ]         dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]         am = [(n, args) | n <- ns] ++ zip subNs subArgs-    mappings (L (UnhelpfulSpan _) _, _) = ([], [])+    mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])      instanceMap :: Map RealSrcSpan Name     instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]@@ -111,13 +135,11 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -}--getMainDeclBinder :: (CollectPass (GhcPass p))-                  => HsDecl (GhcPass p)-                  -> [IdP (GhcPass p)]+getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))+                  => HsDecl (GhcPass p) -> [IdP (GhcPass p)] getMainDeclBinder (TyClD _ d) = [tcdName d] getMainDeclBinder (ValD _ d) =-  case collectHsBindBinders d of+  case collectHsBindBinders CollNoDictBinders d of     []       -> []     (name:_) -> [name] getMainDeclBinder (SigD _ d) = sigNameNoLoc d@@ -125,21 +147,22 @@ getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = [] getMainDeclBinder _ = [] -sigNameNoLoc :: Sig pass -> [IdP pass]-sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns-sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns-sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns-sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]-sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns++sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]+sigNameNoLoc (TypeSig    _   ns _)         = map (unXRec @pass) ns+sigNameNoLoc (ClassOpSig _ _ ns _)         = map (unXRec @pass) ns+sigNameNoLoc (PatSynSig  _   ns _)         = map (unXRec @pass) ns+sigNameNoLoc (SpecSig    _   n _ _)        = [unXRec @pass n]+sigNameNoLoc (InlineSig  _   n _)          = [unXRec @pass n]+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns sigNameNoLoc _                             = []  -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the -- instanceMap.-getInstLoc :: InstDecl (GhcPass p) -> SrcSpan+getInstLoc :: Anno (IdGhcP p) ~ SrcSpanAnnN => InstDecl (GhcPass p) -> SrcSpan getInstLoc = \case-  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLocA ty   -- The Names of data and type family instances have their SrcSpan's attached   -- to the *type constructor*. For example, the Name "D:R:Foo:Int" would have   -- its SrcSpan attached here:@@ -147,27 +170,27 @@   --   type instance Foo Int = Bool   --                 ^^^   DataFamInstD _ (DataFamInstDecl-    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l+    { dfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l   -- Since CoAxioms' Names refer to the whole line for type family instances   -- in particular, we need to dig a bit deeper to pull out the entire   -- equation. This does not happen for data family instances, for some reason.   TyFamInstD _ (TyFamInstDecl-    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = L l _ }}}) -> l+    { tfid_eqn = FamEqn { feqn_tycon = L l _ }}) -> locA l  -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. subordinates :: Map RealSrcSpan Name              -> HsDecl GhcRn-             -> [(Name, [(HsDocString)], Map Int (HsDocString))]+             -> [(Name, [HsDocString], IntMap HsDocString)] subordinates instMap decl = case decl of   InstD _ (ClsInstD _ d) -> do-    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =+    DataFamInstDecl { dfid_eqn =       FamEqn { feqn_tycon = L l _-             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d-    [ (n, [], M.empty) | Just n <- [lookupSrcSpan l instMap] ] ++ dataSubs defn+             , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d+    [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn -  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))+  InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)   TyClD _ d | isClassDecl d -> classSubs d             | isDataDecl  d -> dataSubs (tcdDataDefn d)@@ -178,7 +201,7 @@                    , name <- getMainDeclBinder d, not (isValD d)                    ]     dataSubs :: HsDataDefn GhcRn-             -> [(Name, [HsDocString], Map Int (HsDocString))]+             -> [(Name, [HsDocString], IntMap HsDocString)]     dataSubs dd = constrs ++ fields ++ derivs       where         cons = map unLoc $ (dd_cons dd)@@ -186,45 +209,56 @@                     , maybeToList $ fmap unLoc $ con_doc c                     , conArgDocs c)                   | c <- cons, cname <- getConNames c ]-        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)-                  | RecCon flds <- map getConArgs cons+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, IM.empty)+                  | Just flds <- map getRecConArgs_maybe cons                   , (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) $-                                unLoc $ dd_derivs dd+        derivs  = [ (instName, [unLoc doc], IM.empty)+                  | (l, doc) <- concatMap (extract_deriv_clause_tys .+                                           deriv_clause_tys . unLoc) $+                                -- unLoc $ dd_derivs dd+                                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 (L l (HsSig{sig_body = L _ ty})) =           case ty of-            -- deriving (forall a. C a {- ^ Doc comment -})-            HsForAllTy{ hst_tele = HsForAllInvis{}-                      , hst_body = L _ (HsDocTy _ _ doc) }-                            -> Just (l, doc)             -- deriving (C a {- ^ Doc comment -})-            HsDocTy _ _ doc -> Just (l, doc)+            HsDocTy _ _ doc -> Just (locA l, doc)             _               -> Nothing  -- | Extract constructor argument docs from inside constructor decls.-conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString)-conArgDocs con = case getConArgs con of-                   PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret)-                   InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1),-                                                unLoc (hsScaledThing arg2)] ++ ret)-                   RecCon _ -> go 1 ret-  where-    go n = M.fromList . catMaybes . zipWith f [n..]-      where-        f n (HsDocTy _ _ lds) = Just (n, unLoc lds)-        f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)-        f _ _ = Nothing+conArgDocs :: ConDecl GhcRn -> IntMap HsDocString+conArgDocs (ConDeclH98{con_args = args}) =+  h98ConArgDocs args+conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =+  gadtConArgDocs args (unLoc res_ty) -    ret = case con of-            ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ]-            _ -> []+h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString+h98ConArgDocs con_args = case con_args of+  PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args+  InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)+                                       , unLoc (hsScaledThing arg2) ]+  RecCon _           -> IM.empty +gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString+gadtConArgDocs con_args res_ty = case con_args of+  PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]+  RecConGADT _       -> con_arg_docs 1 [res_ty]++con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString+con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]+  where+    f n (HsDocTy _ _ lds) = Just (n, unLoc lds)+    f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)+    f _ _ = Nothing+ isValD :: HsDecl a -> Bool isValD (ValD _ _) = True isValD _ = False@@ -232,7 +266,7 @@ -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]-classDecls class_ = filterDecls . collectDocs . sortLocated $ decls+classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls   where     decls = docs ++ defs ++ sigs ++ ats     docs  = mkDecls tcdDocs (DocD noExtField) class_@@ -241,14 +275,14 @@     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_  -- | Extract function argument docs from inside top-level decls.-declTypeDocs :: HsDecl GhcRn -> Map Int (HsDocString)+declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString) declTypeDocs = \case-  SigD  _ (TypeSig _ _ ty)          -> typeDocs (unLoc (hsSigWcType ty))-  SigD  _ (ClassOpSig _ _ _ ty)     -> typeDocs (unLoc (hsSigType ty))-  SigD  _ (PatSynSig _ _ ty)        -> typeDocs (unLoc (hsSigType ty))-  ForD  _ (ForeignImport _ _ ty _)  -> typeDocs (unLoc (hsSigType ty))+  SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))+  SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)+  SigD  _ (PatSynSig _ _ ty)        -> sigTypeDocs (unLoc ty)+  ForD  _ (ForeignImport _ _ ty _)  -> sigTypeDocs (unLoc ty)   TyClD _ (SynDecl { tcdRhs = ty }) -> typeDocs (unLoc ty)-  _                                 -> M.empty+  _                                 -> IM.empty  nubByName :: (a -> Name) -> [a] -> [a] nubByName f ns = go emptyNameSet ns@@ -262,21 +296,25 @@         y = f x  -- | Extract function argument docs from inside types.-typeDocs :: HsType GhcRn -> Map Int (HsDocString)+typeDocs :: HsType GhcRn -> IntMap HsDocString typeDocs = go 0   where     go n = \case       HsForAllTy { hst_body = ty }          -> go n (unLoc ty)       HsQualTy   { hst_body = ty }          -> go n (unLoc ty)-      HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> M.insert n (unLoc x) $ go (n+1) (unLoc ty)+      HsFunTy _ _ (unLoc->HsDocTy _ _ x) ty -> IM.insert n (unLoc x) $ go (n+1) (unLoc ty)       HsFunTy _ _ _ ty                      -> go (n+1) (unLoc ty)-      HsDocTy _ _ doc                       -> M.singleton n (unLoc doc)-      _                                     -> M.empty+      HsDocTy _ _ doc                       -> IM.singleton n (unLoc doc)+      _                                     -> IM.empty +-- | Extract function argument docs from inside types.+sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString+sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)+ -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]-topDecls = filterClasses . filterDecls . collectDocs . sortLocated . ungroup+topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup  -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]@@ -302,14 +340,14 @@ -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it.-collectDocs :: [LHsDecl pass] -> [(LHsDecl pass, [HsDocString])]+collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])] -- ^ This is an example. collectDocs = go [] Nothing   where     go docs mprev decls = case (decls, mprev) of-      ((unLoc->DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds-      ((unLoc->DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds-      ((unLoc->DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds+      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds       (d                                  : ds, Nothing)   -> go docs (Just d) ds       (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds       ([]                                     , Nothing)   -> []@@ -318,8 +356,8 @@     finished decl docs rest = (decl, reverse docs) : rest  -- | Filter out declarations that we don't handle in Haddock-filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]-filterDecls = filter (isHandled . unLoc . fst)+filterDecls :: forall p doc. UnXRec p => [(LHsDecl p, doc)] -> [(LHsDecl p, doc)]+filterDecls = filter (isHandled . unXRec @p . fst)   where     isHandled (ForD _ (ForeignImport {})) = True     isHandled (TyClD {})  = True@@ -333,7 +371,7 @@   -- | Go through all class declarations and filter their sub-declarations-filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)]+filterClasses :: forall p doc. (IsPass p) => [(LHsDecl (GhcPass p), doc)] -> [(LHsDecl (GhcPass p), doc)] filterClasses = map (first (mapLoc filterClass))   where     filterClass (TyClD x c@(ClassDecl {})) =@@ -350,8 +388,67 @@  -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor-mkDecls :: (struct -> [Located decl])+mkDecls :: (struct -> [GenLocated l decl])         -> (decl -> hsDecl)         -> struct-        -> [Located hsDecl]+        -> [GenLocated l hsDecl] mkDecls field con = map (mapLoc con) . field++-- | Extracts out individual maps of documentation added via Template Haskell's+-- @putDoc@.+extractTHDocs :: THDocs+              -> ExtractedTHDocs+extractTHDocs docs =+  -- Split up docs into separate maps for each 'DocLoc' type+  ExtractedTHDocs+    docHeader+    (DeclDocMap (searchDocs decl))+    (ArgDocMap (searchDocs args))+    (DeclDocMap (searchDocs insts))+  where+    docHeader :: Maybe HsDocString+    docHeader+      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)+      | otherwise = Nothing++    isModDoc (ModuleDoc, _) = True+    isModDoc _ = False++    -- Folds over the docs, applying 'f' as the accumulating function.+    -- We use different accumulating functions to sift out the specific types of+    -- documentation+    searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a+    searchDocs f = foldl' f mempty $ M.toList docs++    -- Pick out the declaration docs+    decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc+    decl acc _ = acc++    -- Pick out the instance docs+    insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc+    insts acc _ = acc++    -- Pick out the argument docs+    args :: Map Name (IntMap HsDocString)+         -> (DocLoc, String)+         -> Map Name (IntMap HsDocString)+    args acc ((ArgDoc name i), s) =+      -- Insert the doc for the arg into the argument map for the function. This+      -- means we have to search to see if an map already exists for the+      -- function, and insert the new argument if it exists, or create a new map+      let ds = mkHsDocString s+       in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc+    args acc _ = acc++-- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two+-- maps with values for the same key merge the inner map as well.+-- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.+unionArgMaps :: Map Name (IntMap b)+             -> Map Name (IntMap b)+             -> Map Name (IntMap b)+unionArgMaps a b = M.foldlWithKey go b a+  where+    go acc n newArgMap+      | Just oldArgMap <- M.lookup n acc =+          M.insert n (newArgMap `IM.union` oldArgMap) acc+      | otherwise = M.insert n newArgMap acc

GHC/HsToCore/Expr.hs view

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP          #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,17 +12,9 @@ Desugaring expressions. -} -{-# LANGUAGE CPP, MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Expr    ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds    , dsValBinds, dsLit, dsSyntaxExpr-   , dsHandleMonadicFailure    ) where @@ -32,7 +30,8 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Arrows import GHC.HsToCore.Monad-import GHC.HsToCore.PmCheck ( addTyCsDs, checkGuardMatches )+import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )+import GHC.Types.SourceText import GHC.Types.Name import GHC.Types.Name.Env import GHC.Core.FamInstEnv( topNormaliseType )@@ -65,14 +64,14 @@ import GHC.Types.Basic import GHC.Data.Maybe import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Utils.Misc import GHC.Data.Bag import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Core.PatSyn import Control.Monad-import Data.List.NonEmpty ( nonEmpty )--import qualified GHC.LanguageExtensions as LangExt+import Data.Void( absurd )  {- ************************************************************************@@ -82,11 +81,11 @@ ************************************************************************ -} -dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr-dsLocalBinds (L _   (EmptyLocalBinds _))  body = return body-dsLocalBinds (L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $-                                                 dsValBinds binds body-dsLocalBinds (L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body+dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr+dsLocalBinds (EmptyLocalBinds _)  body = return body+dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $+                                           dsValBinds binds body+dsLocalBinds (HsIPBinds _ binds)  body = dsIPBinds  binds body  ------------------------- -- caller sets location@@ -104,6 +103,7 @@                 -- dependency order; hence Rec         ; foldrM ds_ip_bind inner ip_binds }   where+    ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr     ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body       = do e' <- dsLExpr e            return (Let (NonRec n e') body)@@ -122,7 +122,7 @@         --       could be dict binds in the 'binds'.  (See the notes         --       below.  Then pattern-match would fail.  Urk.)   , isUnliftedHsBind bind-  = putSrcSpanDs loc $+  = putSrcSpanDs (locA loc) $      -- see Note [Strict binds checks] in GHC.HsToCore.Binds     if is_polymorphic bind     then errDsCoreExpr (poly_bind_err bind)@@ -214,11 +214,11 @@        ; return (bindNonRec fun rhs' body) }  dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss-                        , pat_ext = NPatBindTc _ ty }) body+                        , pat_ext = ty }) body   =     -- let C x# y# = rhs in body         -- ==> case rhs of C x# y# -> body-    do { rhs_deltas <- checkGuardMatches PatBindGuards grhss-       ; rhs         <- dsGuarded grhss ty (nonEmpty rhs_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,@@ -239,16 +239,18 @@ ************************************************************************ -} -dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr -dsLExpr (L loc e)-  = putSrcSpanDs loc $-    do { core_expr <- dsExpr e-   -- uncomment this check to test the hsExprType function in GHC.Tc.Utils.Zonk-   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e-   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$-   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )-       ; return core_expr }+-- | Replace the body of the function with this block to test the hsExprType+-- function in GHC.Tc.Utils.Zonk:+-- putSrcSpanDs loc $ do+--   { core_expr <- dsExpr e+--   ; MASSERT2( exprType core_expr `eqType` hsExprType e+--             , ppr e <+> dcolon <+> ppr (hsExprType e) $$+--                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+--   ; return core_expr }+dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr+dsLExpr (L loc e) =+  putSrcSpanDsA loc $ dsExpr e  -- | Variant of 'dsLExpr' that ensures that the result is not levity -- polymorphic. This should be used when the resulting expression will@@ -257,20 +259,27 @@ -- See Note [Levity polymorphism invariants] in "GHC.Core" dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsLExprNoLP (L loc e)-  = putSrcSpanDs loc $+  = putSrcSpanDsA loc $     do { e' <- dsExpr e        ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)        ; 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 (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref+        -- See Note [Holes] in GHC.Tc.Types.Constraint+ 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" +dsExpr (HsGetField x _ _)     = absurd x+dsExpr (HsProjection x _)     = absurd x+ dsExpr (HsLit _ lit)   = do { warnAboutOverflowedLit lit        ; dsLit (convertLit lit) }@@ -287,7 +296,7 @@ dsExpr (NegApp _ (L loc                     (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))                 neg_expr)-  = do { expr' <- putSrcSpanDs loc $ do+  = do { expr' <- putSrcSpanDsA loc $ do           { warnAboutOverflowedOverLit               (lit { ol_val = HsIntegral (negateIntegralLit i) })           ; dsOverLit lit }@@ -327,109 +336,15 @@  That 'g' in the 'in' part is an evidence variable, and when converting to core it must become a CO.---Note [Desugaring operator sections]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Desugaring left sections with -XPostfixOperators is straightforward: convert-(expr `op`) to (op expr).--Without -XPostfixOperators it's a bit more tricky. At first it looks as if we-can convert--    (expr `op`)--naively to--    \x -> op expr x--But no!  expr might be a redex, and we can lose laziness badly this-way.  Consider--    map (expr `op`) xs--for example. If expr were a redex then eta-expanding naively would-result in multiple evaluations where the user might only have expected one.--So we convert instead to--    let y = expr in \x -> op y x--Also, note that we must do this for both right and (perhaps surprisingly) left-sections. Why are left sections necessary? Consider the program (found in #18151),--    seq (True `undefined`) ()--according to the Haskell Report this should reduce to () (as it specifies-desugaring via eta expansion). However, if we fail to eta expand we will rather-bottom. Consequently, we must eta expand even in the case of a left section.--If `expr` is actually just a variable, say, then the simplifier-will inline `y`, eliminating the redundant `let`.--Note that this works even in the case that `expr` is unlifted. In this case-bindNonRec will automatically do the right thing, giving us:--    case expr of y -> (\x -> op y x)--See #18151. -} -dsExpr e@(OpApp _ e1 op e2)-  = -- for the type of y, we need the type of op's 2nd argument-    do { op' <- dsLExpr op-       ; dsWhenNoErrs (mapM dsLExprNoLP [e1, e2])-                      (\exprs' -> mkCoreAppsDs (text "opapp" <+> ppr e) op' exprs') }---- dsExpr (SectionL op expr)  ===  (expr `op`)  ~>  \y -> op expr y------ See Note [Desugaring operator sections].--- N.B. this also must handle postfix operator sections due to -XPostfixOperators.-dsExpr e@(SectionL _ expr op) = do-  postfix_operators <- xoptM LangExt.PostfixOperators-  if postfix_operators then-    -- Desugar (e !) to ((!) e)-    do { op' <- dsLExpr op-       ; dsWhenNoErrs (dsLExprNoLP expr) $ \expr' ->-         mkCoreAppDs (text "sectionl" <+> ppr expr) op' expr' }-  else do-    core_op <- dsLExpr op-    x_core <- dsLExpr expr-    case splitFunTys (exprType core_op) of-      -- Binary operator section-      (x_ty:y_ty:_, _) -> do-        dsWhenNoErrs-          (newSysLocalsDsNoLP [x_ty, y_ty])-          (\[x_id, y_id] ->-            bindNonRec x_id x_core-            $ Lam y_id (mkCoreAppsDs (text "sectionl" <+> ppr e)-                                     core_op [Var x_id, Var y_id]))--      -- Postfix operator section-      (_:_, _) -> do-        return $ mkCoreAppDs (text "sectionl" <+> ppr e) core_op x_core--      _ -> pprPanic "dsExpr(SectionL)" (ppr e)---- dsExpr (SectionR op expr)  === (`op` expr)  ~>  \x -> op x expr------ See Note [Desugaring operator sections].-dsExpr e@(SectionR _ op expr) = do-    core_op <- dsLExpr op-    let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op)-    y_core <- dsLExpr expr-    dsWhenNoErrs (newSysLocalsDsNoLP [x_ty, y_ty])-                 (\[x_id, y_id] -> bindNonRec y_id y_core $-                                   Lam x_id (mkCoreAppsDs (text "sectionr" <+> ppr e)-                                                          core_op [Var x_id, Var y_id]))- dsExpr (ExplicitTuple _ tup_args boxity)-  = do { let go (lam_vars, args) (L _ (Missing (Scaled mult ty)))+  = do { let go (lam_vars, args) (Missing (Scaled mult ty))                     -- For every missing expression, we need                     -- another lambda in the desugaring.                = do { lam_var <- newSysLocalDsNoLP mult ty                     ; return (lam_var : lam_vars, Var lam_var : args) }-             go (lam_vars, args) (L _ (Present _ expr))+             go (lam_vars, args) (Present _ expr)                     -- Expressions that are present don't generate                     -- lambdas, just arguments.                = do { core_expr <- dsLExprNoLP expr@@ -479,9 +394,9 @@   = mkErrorExpr    | otherwise-  = do { let grhss = GRHSs noExtField alts (noLoc emptyLocalBinds)-       ; rhss_deltas  <- checkGuardMatches IfAlt grhss-       ; match_result <- dsGRHSs IfAlt grhss res_ty (nonEmpty rhss_deltas)+  = do { let grhss = GRHSs emptyComments  alts emptyLocalBinds+       ; rhss_nablas  <- pmcGRHSs IfAlt grhss+       ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas        ; error_expr   <- mkErrorExpr        ; extractMatchResult match_result error_expr }   where@@ -494,8 +409,7 @@              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -} -dsExpr (ExplicitList elt_ty wit xs)-  = dsExplicitList elt_ty wit xs+dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs  dsExpr (ArithSeq expr witness seq)   = case witness of@@ -521,7 +435,7 @@      dflags <- getDynFlags     let platform = targetPlatform dflags-    let (line, col) = case loc of+    let (line, col) = case locA loc of            RealSrcSpan r _ ->                             ( srcLocLine $ realSrcSpanStart r                             , srcLocCol  $ realSrcSpanStart r@@ -532,7 +446,7 @@                      , mkIntExprInt platform line, mkIntExprInt platform col                      ] -    putSrcSpanDs loc $ return $+    putSrcSpanDsA loc $ return $       mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]  {-@@ -558,9 +472,9 @@ constructor @C@, setting all of @C@'s fields to bottom. -} -dsExpr (RecordCon { rcon_flds = rbinds-                  , rcon_ext = RecordConTc { rcon_con_expr = con_expr-                                           , rcon_con_like = con_like }})+dsExpr (RecordCon { rcon_con  = L _ con_like+                  , rcon_flds = rbinds+                  , rcon_ext  = con_expr })   = do { con_expr' <- dsExpr con_expr        ; let              (arg_tys, _) = tcSplitFunTys (exprType con_expr')@@ -660,7 +574,7 @@             MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3  (Side note: here (z |> co1) is built by typechecking the scrutinee, so-we ignore it here.  In general the scrutinee is an aribtrary expression.)+we ignore it here.  In general the scrutinee is an arbitrary expression.)  The question is: what is co3, the cast for the RHS?       co3 :: F (Int,t) ~ F (s,t)@@ -675,7 +589,11 @@  -} -dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields+dsExpr RecordUpd { rupd_flds = Right _} =+  -- Not possible due to elimination in the renamer. See Note+  -- [Handling overloaded and rebindable constructs]+  panic "The impossible happened"+dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields                        , rupd_ext = RecordUpdTc                            { rupd_cons = cons_to_upd                            , rupd_in_tys = in_inst_tys@@ -698,7 +616,7 @@         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd         ; ([discrim_var], matching_code)                 <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]-                                      (MG { mg_alts = noLoc alts+                                      (MG { mg_alts = noLocA alts                                           , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty                                           , mg_origin = FromSource                                           })@@ -739,9 +657,17 @@                    -- Record updates consume the source record with multiplicity                    -- Many. Therefore all the fields need to be scaled thus.                  user_tvs  = binderVars $ conLikeUserTyVarBinders con-                 in_subst  = zipTvSubst univ_tvs in_inst_tys-                 out_subst = zipTvSubst univ_tvs out_inst_tys +                 in_subst :: TCvSubst+                 in_subst  = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs+                   -- The in_subst clones the universally quantified type+                   -- variables. It will be used to substitute into types that+                   -- contain existentials, however, so make sure to extend the+                   -- in-scope set with ex_tvs (#20278).++                 out_tv_env :: TvSubstEnv+                 out_tv_env = zipTyEnv univ_tvs out_inst_tys+                 -- I'm not bothering to clone the ex_tvs            ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))            ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)@@ -752,11 +678,11 @@                  mk_val_arg fl pat_arg_id                      = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id) -                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExtField con)+                 inst_con = noLocA $ mkHsWrap wrap (HsConLikeOut noExtField con)                         -- Reconstruct with the WrapId so that unpacking happens                  wrap = mkWpEvVarApps theta_vars                                <.>                         dict_req_wrap                                           <.>-                        mkWpTyApps    [ lookupTyVar out_subst tv+                        mkWpTyApps    [ lookupVarEnv out_tv_env tv                                           `orElse` mkTyVarTy tv                                       | tv <- user_tvs ]                           -- Be sure to use user_tvs (which may be ordered@@ -796,16 +722,16 @@                   req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys -                 pat = noLoc $ ConPat { pat_con = noLoc con-                                      , pat_args = PrefixCon $ map nlVarPat arg_ids-                                      , pat_con_ext = ConPatTc-                                        { cpt_tvs = ex_tvs-                                        , cpt_dicts = eqs_vars ++ theta_vars-                                        , cpt_binds = emptyTcEvBinds-                                        , cpt_arg_tys = in_inst_tys-                                        , cpt_wrap = req_wrap-                                        }-                                      }+                 pat = noLocA $ ConPat { pat_con = noLocA con+                                       , pat_args = PrefixCon [] $ map nlVarPat arg_ids+                                       , pat_con_ext = ConPatTc+                                         { cpt_tvs = ex_tvs+                                         , cpt_dicts = eqs_vars ++ theta_vars+                                         , cpt_binds = emptyTcEvBinds+                                         , cpt_arg_tys = in_inst_tys+                                         , cpt_wrap = req_wrap+                                         }+                                       }            ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }  {- Note [Scrutinee in Record updates]@@ -856,10 +782,18 @@        mkBinaryTickBox ixT ixF e2      } ++-- HsSyn constructs that just shouldn't be here, because+-- the renamer removed them.  See GHC.Rename.Expr.+-- Note [Handling overloaded and rebindable constructs]+dsExpr (HsOverLabel x _) = absurd x+dsExpr (OpApp x _ _ _)   = absurd x+dsExpr (SectionL x _ _)  = absurd x+dsExpr (SectionR x _ _)  = absurd x+ -- HsSyn constructs that just shouldn't be here:-dsExpr (HsBracket     {})  = panic "dsExpr:HsBracket"-dsExpr (HsDo          {})  = panic "dsExpr:HsDo"-dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"+dsExpr (HsBracket   {}) = panic "dsExpr:HsBracket"+dsExpr (HsDo        {}) = panic "dsExpr:HsDo"  ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do@@ -869,15 +803,10 @@         mod_name <- getModule         count <- goptM Opt_ProfCountEntries         let nm = sl_fs cc-        flavour <- ExprCC <$> getCCIndexM nm-        Tick (ProfNote (mkUserCC nm mod_name (getLoc expr) flavour) count True)+        flavour <- ExprCC <$> getCCIndexDsM nm+        Tick (ProfNote (mkUserCC nm mod_name (getLocA 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@@ -962,10 +891,10 @@ maxBuildLength :: Int maxBuildLength = 32 -dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]+dsExplicitList :: Type -> [LHsExpr GhcTc]                -> DsM CoreExpr -- See Note [Desugaring explicit lists]-dsExplicitList elt_ty Nothing xs+dsExplicitList elt_ty xs   = do { dflags <- getDynFlags        ; xs' <- mapM dsLExprNoLP xs        ; if xs' `lengthExceeds` maxBuildLength@@ -981,12 +910,6 @@     mk_build_list xs' (cons, _) (nil, _)       = return (foldr (App . App (Var cons)) (Var nil) xs') -dsExplicitList elt_ty (Just fln) xs-  = do { list <- dsExplicitList elt_ty Nothing xs-       ; dflags <- getDynFlags-       ; let platform = targetPlatform dflags-       ; dsSyntaxExpr fln [mkIntExprInt platform (length xs), list] }- dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr dsArithSeq expr (From from)   = App <$> dsExpr expr <*> dsLExprNoLP from@@ -1021,7 +944,7 @@   = goL stmts   where     goL [] = panic "dsDo"-    goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)+    goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)      go _ (LastStmt _ body _ _) stmts       = ASSERT( null stmts ) dsLExpr body@@ -1041,9 +964,9 @@       = 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 pat match (xbstc_failOp xbs)+            ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)             ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }      go _ (ApplicativeStmt body_ty args mb_join) stmts@@ -1054,17 +977,17 @@                do_arg (ApplicativeArgOne fail_op pat expr _) =                  ((pat, fail_op), dsLExpr expr)                do_arg (ApplicativeArgMany _ stmts ret pat _) =-                 ((pat, Nothing), dsDo ctx (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))+                 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))             ; rhss' <- sequence rhss -           ; body' <- dsLExpr $ noLoc $ HsDo body_ty ctx (noLoc stmts)+           ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)             ; 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 pat match fail_op+                        ; match_code <- dsHandleMonadicFailure ctx pat match fail_op                         ; return (var:vs, match_code)                         } @@ -1076,7 +999,7 @@                Nothing -> return expr                Just join_op -> dsSyntaxExpr join_op [expr] } -    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids+    go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids                     , recS_rec_ids = rec_ids, recS_ret_fn = return_op                     , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op                     , recS_ext = RecStmtTc@@ -1099,19 +1022,19 @@         tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case         rec_tup_pats = map nlVarPat tup_ids         later_pats   = rec_tup_pats-        rets         = map noLoc rec_rets+        rets         = map noLocA rec_rets         mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]-        mfix_arg     = noLoc $ HsLam noExtField-                           (MG { mg_alts = noLoc [mkSimpleMatch+        mfix_arg     = noLocA $ HsLam noExtField+                           (MG { mg_alts = noLocA [mkSimpleMatch                                                     LambdaExpr                                                     [mfix_pat] body]                                , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty                                , mg_origin = Generated })-        mfix_pat     = noLoc $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats-        body         = noLoc $ HsDo body_ty-                                ctx (noLoc (rec_stmts ++ [ret_stmt]))+        mfix_pat     = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats+        body         = noLocA $ HsDo body_ty+                                ctx (noLocA (rec_stmts ++ [ret_stmt]))         ret_app      = nlHsSyntaxApps return_op [mkBigLHsTupId rets]-        ret_stmt     = noLoc $ mkLastStmt ret_app+        ret_stmt     = noLocA $ mkLastStmt ret_app                      -- This LastStmt will be desugared with dsDo,                      -- which ignores the return_op in the LastStmt,                      -- so we must apply the return_op explicitly@@ -1119,31 +1042,6 @@     go _ (ParStmt   {}) _ = panic "dsDo ParStmt"     go _ (TransStmt {}) _ = panic "dsDo TransStmt" -dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr-    -- In a do expression, pattern-match failure just calls-    -- the monadic 'fail' rather than throwing an exception-dsHandleMonadicFailure pat match m_fail_op =-  case shareFailureHandler match of-    MR_Infallible body -> body-    MR_Fallible body -> do-      fail_op <- case m_fail_op of-        -- Note that (non-monadic) list comprehension, pattern guards, etc could-        -- have fallible bindings without an explicit failure op, but this is-        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the-        -- breakdown of regular and special binds.-        Nothing -> pprPanic "missing fail op" $-          text "Pattern match:" <+> ppr pat <+>-          text "is failable, and fail_expr was left unset"-        Just fail_op -> pure fail_op-      dflags <- getDynFlags-      fail_msg <- mkStringExpr (mk_fail_msg dflags pat)-      fail_expr <- dsSyntaxExpr fail_op [fail_msg]-      body fail_expr--mk_fail_msg :: DynFlags -> Located e -> String-mk_fail_msg dflags pat = "Pattern match failure in do expression at " ++-                         showPpr dflags (getLoc pat)- {- ************************************************************************ *                                                                      *@@ -1159,11 +1057,15 @@  dsConLike :: ConLike -> DsM CoreExpr dsConLike (RealDataCon dc) = dsHsVar (dataConWrapId dc)-dsConLike (PatSynCon ps)   = return $ case patSynBuilder ps of-  Just (id, add_void)-    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)-    | otherwise -> Var id-  _ -> pprPanic "dsConLike" (ppr ps)+dsConLike (PatSynCon ps)+  | Just (builder_name, _, add_void) <- patSynBuilder ps+  = do { builder_id <- dsLookupGlobalId builder_name+       ; return (if add_void+                 then mkCoreApp (text "dsConLike" <+> ppr ps)+                                (Var builder_id) (Var voidPrimId)+                 else Var builder_id) }+  | otherwise+  = pprPanic "dsConLike" (ppr ps)  {- ************************************************************************@@ -1192,12 +1094,12 @@            -- Warn about discarding m a things in 'monadic' binding of the same type,            -- but only if we didn't already warn due to Opt_WarnUnusedDoBind            when warn_wrong $-                do { case tcSplitAppTy_maybe norm_elt_ty of-                         Just (elt_m_ty, _)-                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty-                            -> warnDs (Reason Opt_WarnWrongDoBind)-                                      (badMonadBind rhs elt_ty)-                         _ -> return () } } }+                case tcSplitAppTy_maybe norm_elt_ty of+                      Just (elt_m_ty, _)+                         | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty+                         -> warnDs (Reason Opt_WarnWrongDoBind)+                                   (badMonadBind rhs elt_ty)+                      _ -> return () } }    | otherwise   -- RHS does have type of form (m ty), which is weird   = return ()   -- but at least this warning is irrelevant@@ -1265,7 +1167,7 @@   where     go wrap (XExpr (WrapExpr (HsWrap co_fn hs_e)))        = do { wrap' <- dsHsWrapper co_fn-            ; addTyCsDs FromSource (hsWrapDictBinders co_fn) $+            ; addTyCs FromSource (hsWrapDictBinders co_fn) $               go (wrap . wrap') hs_e }     go wrap (HsConLikeOut _ (RealDataCon dc))       = go_head wrap (dataConWrapId dc)

GHC/HsToCore/Expr.hs-boot view

@@ -1,12 +1,10 @@ module GHC.HsToCore.Expr where-import GHC.Hs             ( HsExpr, LHsExpr, LHsLocalBinds, LPat, SyntaxExpr, FailOperator )-import GHC.HsToCore.Monad ( DsM, MatchResult )+import GHC.Hs             ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr )+import GHC.HsToCore.Monad ( DsM ) import GHC.Core           ( CoreExpr )-import GHC.Hs.Extension   ( GhcTc)+import GHC.Hs.Extension ( GhcTc)  dsExpr  :: HsExpr GhcTc -> DsM CoreExpr dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr-dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr--dsHandleMonadicFailure :: LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr+dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr

GHC/HsToCore/Foreign/Call.hs view

@@ -21,15 +21,14 @@  #include "HsVersions.h" - import GHC.Prelude-import GHC.Platform  import GHC.Core  import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make+import GHC.Types.SourceText import GHC.Types.Id.Make import GHC.Types.ForeignCall import GHC.Core.DataCon@@ -38,9 +37,7 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Multiplicity-import GHC.Types.Id   ( Id ) import GHC.Core.Coercion-import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim import GHC.Core.TyCon import GHC.Builtin.Types@@ -50,6 +47,7 @@ import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic  import Data.Maybe @@ -160,7 +158,7 @@               \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))                              prim_arg                              (exprType body)-                             [(DEFAULT,[],body)])+                             [Alt DEFAULT [] body])    -- Data types with a single constructor, which has a single, primitive-typed arg   -- This deals with Int, Float etc; also Ptr, ForeignPtr@@ -170,7 +168,7 @@     do case_bndr <- newSysLocalDs Many arg_ty        prim_arg <- newSysLocalDs Many data_con_arg_ty1        return (Var prim_arg,-               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,[prim_arg],body)]+               \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) [prim_arg] body]               )    -- Byte-arrays, both mutable and otherwise; hack warning@@ -185,7 +183,7 @@   = do case_bndr <- newSysLocalDs Many arg_ty        vars@[_l_var, _r_var, arr_cts_var] <- newSysLocalsDs (map unrestricted data_con_arg_tys)        return (Var arr_cts_var,-               \ body -> Case arg case_bndr (exprType body) [(DataAlt data_con,vars,body)]+               \ body -> Case arg case_bndr (exprType body) [Alt (DataAlt data_con) vars body]               )    | otherwise@@ -276,7 +274,7 @@  mk_alt :: (Expr Var -> [Expr Var] -> Expr Var)        -> (Maybe Type, Expr Var -> Expr Var)-       -> DsM (Type, (AltCon, [Id], Expr Var))+       -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result)   = do -- The ccall returns ()        state_id <- newSysLocalDs Many realWorldStatePrimTy@@ -285,7 +283,7 @@                                      [wrap_result (panic "boxResult")]               ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy]-             the_alt      = (DataAlt (tupleDataCon Unboxed 1), [state_id], the_rhs)+             the_alt      = Alt (DataAlt (tupleDataCon Unboxed 1)) [state_id] the_rhs         return (ccall_res_ty, the_alt) @@ -298,7 +296,7 @@        ; let the_rhs = return_result (Var state_id)                                 [wrap_result (Var result_id)]              ccall_res_ty = mkTupleTy Unboxed [realWorldStatePrimTy, prim_res_ty]-             the_alt      = (DataAlt (tupleDataCon Unboxed 2), [state_id, result_id], the_rhs)+             the_alt      = Alt (DataAlt (tupleDataCon Unboxed 2)) [state_id, result_id] the_rhs        ; return (ccall_res_ty, the_alt) }  @@ -333,8 +331,8 @@        ; let platform = targetPlatform dflags        ; let marshal_bool e                = mkWildCase e (unrestricted intPrimTy) boolTy-                   [ (DEFAULT                     ,[],Var trueDataConId )-                   , (LitAlt (mkLitInt platform 0),[],Var falseDataConId)]+                   [ Alt DEFAULT                        [] (Var trueDataConId )+                   , Alt (LitAlt (mkLitInt platform 0)) [] (Var falseDataConId)]        ; return (Just intPrimTy, marshal_bool) }    -- Newtypes@@ -344,45 +342,23 @@    -- The type might contain foralls (eg. for dummy type arguments,   -- referring to 'Ptr a' is legal).-  | Just (tyvar, rest) <- splitForAllTy_maybe result_ty+  | Just (tyvar, rest) <- splitForAllTyCoVar_maybe result_ty   = do { (maybe_ty, wrapper) <- resultWrapper rest        ; return (maybe_ty, \e -> Lam tyvar (wrapper e)) }    -- Data types with a single constructor, which has a single arg   -- This includes types like Ptr and ForeignPtr   | Just (tycon, tycon_arg_tys) <- maybe_tc_app-  , Just data_con <- isDataProductTyCon_maybe tycon  -- One constructor, no existentials+  , Just data_con <- tyConSingleAlgDataCon_maybe tycon  -- One constructor+  , null (dataConExTyCoVars data_con)                   -- no existentials   , [Scaled _ unwrapped_res_ty] <- dataConInstOrigArgTys data_con tycon_arg_tys  -- One argument-  = do { dflags <- getDynFlags-       ; let platform = targetPlatform dflags-       ; (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty-       ; let narrow_wrapper = maybeNarrow platform tycon-             marshal_con e  = Var (dataConWrapId data_con)+  = do { (maybe_ty, wrapper) <- resultWrapper unwrapped_res_ty+       ; let marshal_con e  = Var (dataConWrapId data_con)                               `mkTyApps` tycon_arg_tys-                              `App` wrapper (narrow_wrapper e)+                              `App` wrapper e        ; return (maybe_ty, marshal_con) }    | otherwise   = pprPanic "resultWrapper" (ppr result_ty)   where     maybe_tc_app = splitTyConApp_maybe result_ty---- When the result of a foreign call is smaller than the word size, we--- need to sign- or zero-extend the result up to the word size.  The C--- standard appears to say that this is the responsibility of the--- caller, not the callee.--maybeNarrow :: Platform -> TyCon -> (CoreExpr -> CoreExpr)-maybeNarrow platform tycon-  | tycon `hasKey` int8TyConKey   = \e -> App (Var (mkPrimOpId Narrow8IntOp)) e-  | tycon `hasKey` int16TyConKey  = \e -> App (Var (mkPrimOpId Narrow16IntOp)) e-  | tycon `hasKey` int32TyConKey-  , platformWordSizeInBytes platform > 4-  = \e -> App (Var (mkPrimOpId Narrow32IntOp)) e--  | tycon `hasKey` word8TyConKey  = \e -> App (Var (mkPrimOpId Narrow8WordOp)) e-  | tycon `hasKey` word16TyConKey = \e -> App (Var (mkPrimOpId Narrow16WordOp)) e-  | tycon `hasKey` word32TyConKey-  , platformWordSizeInBytes platform > 4-  = \e -> App (Var (mkPrimOpId Narrow32WordOp)) e-  | otherwise                     = id

GHC/HsToCore/Foreign/Decl.hs view

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998@@ -6,13 +12,6 @@ Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where  #include "HsVersions.h"@@ -27,9 +26,11 @@  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.Types.ForeignStubs+import GHC.Types.SourceText import GHC.Unit.Module import GHC.Types.Name import GHC.Core.Type@@ -42,7 +43,7 @@  import GHC.Cmm.Expr import GHC.Cmm.Utils-import GHC.Driver.Types+import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types import GHC.Builtin.Types.Prim@@ -52,14 +53,16 @@ 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+import GHC.Utils.Panic import GHC.Driver.Hooks import GHC.Utils.Encoding  import Data.Maybe-import Data.List+import Data.List (unzip4, nub)  {- Desugaring of @foreign@ declarations is naturally split up into@@ -79,9 +82,12 @@ type Binding = (Id, CoreExpr) -- No rec/nonrec structure;                               -- the occurrence analyser will sort it all out -dsForeigns :: [LForeignDecl GhcTc]-           -> DsM (ForeignStubs, OrdList Binding)-dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)+dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding)+dsForeigns fos = do+    hooks <- getHooks+    case dsForeignsHook hooks of+        Nothing -> dsForeigns' fos+        Just h  -> h fos  dsForeigns' :: [LForeignDecl GhcTc]             -> DsM (ForeignStubs, OrdList Binding)@@ -96,13 +102,13 @@         fe_init_code = foreignExportsInitialiser mod fe_ids     --     return (ForeignStubs-             (vcat hs)-             (vcat cs $$ fe_init_code),+             (mconcat hs)+             (mconcat cs `mappend` fe_init_code),             foldr (appOL . toOL) nilOL bindss)   where-   do_ldecl (L loc decl) = putSrcSpanDs loc (do_decl decl)+   do_ldecl (L loc decl) = putSrcSpanDs (locA loc) (do_decl decl) -   do_decl :: ForeignDecl GhcTc -> DsM (SDoc, SDoc, [Id], [Binding])+   do_decl :: ForeignDecl GhcTc -> DsM (CHeader, CStub, [Id], [Binding])    do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do       traceIf (text "fi start" <+> ppr id)       let id' = unLoc id@@ -146,7 +152,7 @@ dsFImport :: Id           -> Coercion           -> ForeignImport-          -> DsM ([Binding], SDoc, SDoc)+          -> DsM ([Binding], CHeader, CStub) dsFImport id co (CImport cconv safety mHeader spec _) =     dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader @@ -156,7 +162,7 @@           -> CCallConv           -> Safety           -> Maybe Header-          -> DsM ([Binding], SDoc, SDoc)+          -> DsM ([Binding], CHeader, CStub) dsCImport id co (CLabel cid) cconv _ _ = do    dflags <- getDynFlags    let ty  = coercionLKind co@@ -173,7 +179,7 @@         rhs' = Cast rhs co         stdcall_info = fun_type_arg_stdcall_info platform cconv ty     in-    return ([(id, rhs')], empty, empty)+    return ([(id, rhs')], mempty, mempty)  dsCImport id co (CFunction target) cconv@PrimCallConv safety _   = dsPrimCall id co (CCall (CCallSpec target cconv safety))@@ -205,11 +211,11 @@ -}  dsFCall :: Id -> Coercion -> ForeignCall -> Maybe Header-        -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)+        -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsFCall fn_id co fcall mDeclHeader = do     let         ty                   = coercionLKind co-        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty+        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty         (arg_tys, io_res_ty) = tcSplitFunTys rho      args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism@@ -285,10 +291,13 @@         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)+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)  {- ************************************************************************@@ -306,11 +315,11 @@ -}  dsPrimCall :: Id -> Coercion -> ForeignCall-           -> DsM ([(Id, Expr TyVar)], SDoc, SDoc)+           -> DsM ([(Id, Expr TyVar)], CHeader, CStub) dsPrimCall fn_id co fcall = do     let         ty                   = coercionLKind co-        (tvs, fun_ty)        = tcSplitForAllTys ty+        (tvs, fun_ty)        = tcSplitForAllInvisTyVars ty         (arg_tys, io_res_ty) = tcSplitFunTys fun_ty      args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism@@ -321,7 +330,7 @@         call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty         rhs      = mkLams tvs (mkLams args call_app)         rhs'     = Cast rhs co-    return ([(fn_id, rhs')], empty, empty)+    return ([(fn_id, rhs')], mempty, mempty)  {- ************************************************************************@@ -351,8 +360,8 @@           -> Bool               -- True => foreign export dynamic                                 --         so invoke IO action that's hanging off                                 --         the first argument's stable pointer-          -> DsM ( SDoc         -- contents of Module_stub.h-                 , SDoc         -- contents of Module_stub.c+          -> DsM ( CHeader      -- contents of Module_stub.h+                 , CStub        -- contents of Module_stub.c                  , String       -- string describing type to pass to createAdj.                  , Int          -- size of args to stub function                  )@@ -410,7 +419,7 @@ {         Capability *cap;         cap = rts_lock();-        rts_evalIO(&cap,+        rts_inCall(&cap,                    rts_apply(rts_apply(deRefStablePtr(s),                                        rts_mkBool(b)), rts_mkInt(i)));         rts_unlock(cap);@@ -421,7 +430,7 @@ dsFExportDynamic :: Id                  -> Coercion                  -> CCallConv-                 -> DsM ([Binding], SDoc, SDoc)+                 -> DsM ([Binding], CHeader, CStub) dsFExportDynamic id co0 cconv = do     mod <- getModule     dflags <- getDynFlags@@ -483,7 +492,7 @@   where   ty                       = coercionLKind co0-  (tvs,sans_foralls)       = tcSplitForAllTys ty+  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty   ([Scaled arg_mult arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls   Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty         -- Must have an IO type; hence Just@@ -511,8 +520,8 @@                -> Type                -> Bool          -- True <=> returns an IO type                -> CCallConv-               -> (SDoc,-                   SDoc,+               -> (CHeader,+                   CStub,                    String,      -- the argument reps                    Int          -- total size of arguments                   )@@ -535,36 +544,15 @@                 SDoc,           -- C type                 Type,           -- Haskell type                 CmmType)]       -- the CmmType-  arg_info  = [ let stg_type = showStgType ty-                    cmm_type = typeCmmType platform (getPrimTyOf ty)-                    stack_type-                      = if int_promote (typeTyCon ty)-                        then text "HsWord"-                        else stg_type-                in-                (arg_cname n stg_type stack_type,+  arg_info  = [ let stg_type = showStgType ty in+                (arg_cname n stg_type,                  stg_type,                  ty,-                 cmm_type)+                typeCmmType platform (getPrimTyOf ty))               | (ty,n) <- zip arg_htys [1::Int ..] ] -  int_promote ty_con-    | ty_con `hasKey` int8TyConKey = True-    | ty_con `hasKey` int16TyConKey = True-    | ty_con `hasKey` int32TyConKey-    , platformWordSizeInBytes platform > 4-    = True-    | ty_con `hasKey` word8TyConKey = True-    | ty_con `hasKey` word16TyConKey = True-    | ty_con `hasKey` word32TyConKey-    , platformWordSizeInBytes platform > 4-    = True-    | otherwise = False---  arg_cname n stg_ty stack_ty-        | libffi    = parens (stg_ty) <> char '*' <>-                      parens (stack_ty <> char '*') <>+  arg_cname n stg_ty+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>                       text "args" <> brackets (int (n-1))         | otherwise = text ('a':show n) @@ -611,7 +599,7 @@   -- Now we can cook up the prototype for the exported function.   pprCconv = ccallConvAttribute cc -  header_bits = text "extern" <+> fun_proto <> semi+  header_bits = CHeader (text "extern" <+> fun_proto <> semi)    fun_args     | null aug_arg_info = text "void"@@ -625,7 +613,7 @@     | otherwise       = cResType <+> pprCconv <+> ftext c_nm <> parens fun_args -  -- the target which will form the root of what we ask rts_evalIO to run+  -- the target which will form the root of what we ask rts_inCall to run   the_cfun      = case maybe_target of           Nothing    -> text "(StgClosure*)deRefStablePtr(the_stableptr)"@@ -633,7 +621,7 @@    cap = text "cap" <> comma -  -- the expression we give to rts_evalIO+  -- the expression we give to rts_inCall   expr_to_run      = foldl' appArg the_cfun arg_info -- NOT aug_arg_info        where@@ -658,7 +646,7 @@     -- finally, the whole darn thing-  c_bits =+  c_bits = CStub $     space $$     extern_decl $$     fun_proto  $$@@ -669,7 +657,7 @@      ,   declareCResult      ,   text "cap = rts_lock();"           -- create the application + perform it.-     ,   text "rts_evalIO" <> parens (+     ,   text "rts_inCall" <> parens (                 char '&' <> cap <>                 text "rts_apply" <> parens (                     cap <>@@ -695,7 +683,7 @@      ]  -foreignExportsInitialiser :: Module -> [Id] -> SDoc+foreignExportsInitialiser :: Module -> [Id] -> CStub foreignExportsInitialiser mod hs_fns =    -- Initialise foreign exports by registering a stable pointer from an    -- __attribute__((constructor)) function.@@ -707,7 +695,7 @@    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)    --    -- See Note [Tracking foreign exports] in rts/ForeignExports.c-   vcat+   CStub $ vcat     [ text "static struct ForeignExportsList" <+> list_symbol <+> equals          <+> braces (            text ".exports = " <+> export_list <> comma <+>@@ -846,6 +834,12 @@  = case typePrimRep1 (getPrimTyOf ty) of      IntRep      -> signed_word      WordRep     -> unsigned_word+     Int8Rep     -> 'B'+     Word8Rep    -> 'b'+     Int16Rep    -> 'S'+     Word16Rep   -> 's'+     Int32Rep    -> 'W'+     Word32Rep   -> 'w'      Int64Rep    -> 'L'      Word64Rep   -> 'l'      AddrRep     -> 'p'

GHC/HsToCore/GuardedRHSs.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,9 +8,6 @@ Matching guarded right-hand-sides (GRHSs) -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.HsToCore.GuardedRHSs ( dsGuarded, dsGRHSs, isTrueLHsExpr ) where  #include "HsVersions.h"@@ -25,17 +24,18 @@  import GHC.HsToCore.Monad import GHC.HsToCore.Utils-import GHC.HsToCore.PmCheck.Types ( Deltas, initDeltas )+import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.Core.Type ( Type ) import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.Multiplicity import Control.Monad ( zipWithM ) import Data.List.NonEmpty ( NonEmpty, toList )  {--@dsGuarded@ is used for pattern bindings.+@dsGuarded@ is used for GRHSs. It desugars: \begin{verbatim}         | g1 -> e1@@ -43,13 +43,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 -> Maybe (NonEmpty Deltas) -> DsM CoreExpr-dsGuarded grhss rhs_ty mb_rhss_deltas = do-    match_result <- dsGRHSs PatBindRhs grhss rhs_ty mb_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 @@ -58,25 +58,28 @@ dsGRHSs :: HsMatchContext GhcRn         -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs         -> Type                        -- ^ Type of RHS-        -> Maybe (NonEmpty Deltas)     -- ^ Refined pattern match checking-                                       --   models, one for each GRHS. Defaults-                                       --   to 'initDeltas' if 'Nothing'.+        -> 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 mb_rhss_deltas+dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas   = ASSERT( notNull grhss )-    do { match_results <- case toList <$> mb_rhss_deltas of-           Nothing          -> mapM     (dsGRHS hs_ctx rhs_ty initDeltas) grhss-           Just rhss_deltas -> ASSERT( length grhss == length rhss_deltas )-                               zipWithM (dsGRHS hs_ctx rhs_ty) rhss_deltas grhss-       ; let match_result1 = foldr1 combineMatchResults match_results-             match_result2 = adjustMatchResultDs (dsLocalBinds binds) match_result1+    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      = 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))-  = updPmDeltas rhs_deltas (matchGuards (map unLoc guards) (PatGuard hs_ctx) 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  {- ************************************************************************@@ -88,6 +91,7 @@  matchGuards :: [GuardStmt GhcTc]     -- Guard             -> HsStmtContext GhcRn   -- Context+            -> Nablas                -- The RHS's covered set for PmCheck             -> LHsExpr GhcTc         -- RHS             -> Type                  -- Type of RHS of guard             -> DsM (MatchResult CoreExpr)@@ -95,8 +99,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 [] _ rhs _-  = do  { core_rhs <- dsLExpr rhs+matchGuards [] _ nablas rhs _+  = do  { core_rhs <- updPmNablas nablas (dsLExpr rhs)         ; return (cantFailMatchResult core_rhs) }          -- BodyStmts must be guards@@ -106,41 +110,41 @@         -- 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 rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx nablas rhs rhs_ty   | Just addTicks <- isTrueLHsExpr e = do-    match_result <- matchGuards stmts ctx rhs rhs_ty+    match_result <- matchGuards stmts ctx nablas rhs rhs_ty     return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do-    match_result <- matchGuards stmts ctx 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 rhs rhs_ty = do-    match_result <- matchGuards stmts ctx 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 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 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"-matchGuards (ParStmt   {} : _) _ _ _ = panic "matchGuards ParStmt"-matchGuards (TransStmt {} : _) _ _ _ = panic "matchGuards TransStmt"-matchGuards (RecStmt   {} : _) _ _ _ = panic "matchGuards RecStmt"-matchGuards (ApplicativeStmt {} : _) _ _ _ =+matchGuards (LastStmt  {} : _) _ _ _ _ = panic "matchGuards LastStmt"+matchGuards (ParStmt   {} : _) _ _ _ _ = panic "matchGuards ParStmt"+matchGuards (TransStmt {} : _) _ _ _ _ = panic "matchGuards TransStmt"+matchGuards (RecStmt   {} : _) _ _ _ _ = panic "matchGuards RecStmt"+matchGuards (ApplicativeStmt {} : _) _ _ _ _ =   panic "matchGuards ApplicativeLastStmt"  {-

GHC/HsToCore/ListComp.hs view

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP            #-}+{-# LANGUAGE TypeFamilies   #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,17 +9,13 @@ Desugaring list comprehensions, monad comprehensions and array comprehensions -} -{-# LANGUAGE CPP, NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.HsToCore.ListComp ( dsListComp, dsMonadComp ) where  #include "HsVersions.h"  import GHC.Prelude -import {-# SOURCE #-} GHC.HsToCore.Expr ( dsHandleMonadicFailure, dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )+import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )  import GHC.Hs import GHC.Tc.Utils.Zonk@@ -35,6 +34,7 @@ import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth ) import GHC.Utils.Misc@@ -88,7 +88,7 @@              list_ty          = mkListTy bndrs_tuple_type               -- really use original bndrs below!-       ; expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty+       ; expr <- dsListComp (stmts ++ [noLocA $ mkLastStmt (mkBigLHsVarTupId bndrs)]) list_ty         ; return (expr, bndrs_tuple_type) } @@ -295,8 +295,8 @@     let         rhs = Lam u1 $               Case (Var u1) u1 res_ty-                   [(DataAlt nilDataCon,  [],       core_list2),-                    (DataAlt consDataCon, [u2, u3], core_match)]+                   [Alt (DataAlt nilDataCon)  []       core_list2+                   ,Alt (DataAlt consDataCon) [u2, u3] core_match]                         -- Increasing order of tag      return (Let (Rec [(h, rhs)]) letrec_body)@@ -423,8 +423,8 @@      mk_case (as, a', as') rest           = Case (Var as) as elt_tuple_list_ty-                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),-                   (DataAlt consDataCon, [a', as'], rest)]+                  [ Alt (DataAlt nilDataCon)  []        (mkNilExpr elt_tuple_ty)+                  , Alt (DataAlt consDataCon) [a', as'] rest]                         -- Increasing order of tag  @@ -479,7 +479,7 @@  dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr dsMcStmts []                      = panic "dsMcStmts"-dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)+dsMcStmts ((L loc stmt) : lstmts) = putSrcSpanDsA loc (dsMcStmt stmt lstmts)  --------------- dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr@@ -616,9 +616,9 @@ 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 pat match fail_op+        ; match_code <- dsHandleMonadicFailure (MonadComp :: HsStmtContext GhcRn) pat match fail_op         ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }  -- Desugar nested monad comprehensions, for example in `then..` constructs@@ -632,7 +632,7 @@                  -> DsM CoreExpr dsInnerMonadComp stmts bndrs ret_op   = dsMcStmts (stmts ++-                 [noLoc (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)])+                 [noLocA (LastStmt noExtField (mkBigLHsVarTupId bndrs) Nothing ret_op)])   -- The `unzip` function for `GroupStmt` in a monad comprehensions

GHC/HsToCore/Match.hs view

@@ -1,20 +1,19 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---The @match@ function--}- {-# LANGUAGE CPP #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @match@ function+-}+ module GHC.HsToCore.Match    ( match, matchEquations, matchWrapper, matchSimply    , matchSinglePat, matchSinglePatVar@@ -28,13 +27,15 @@  import {-#SOURCE#-} GHC.HsToCore.Expr (dsLExpr, dsSyntaxExpr) -import GHC.Types.Basic ( Origin(..) )+import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )+import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs import GHC.Tc.Utils.Zonk import GHC.Tc.Types.Evidence import GHC.Tc.Utils.Monad-import GHC.HsToCore.PmCheck+import GHC.HsToCore.Pmc+import GHC.HsToCore.Pmc.Types ( Nablas, initNablas ) import GHC.Core import GHC.Types.Literal import GHC.Core.Utils@@ -59,12 +60,12 @@ import GHC.Utils.Misc import GHC.Types.Name import GHC.Utils.Outputable-import GHC.Types.Basic ( isGenerated, il_value, fl_value, Boxity(..) )+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM -import Control.Monad( 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@@ -258,7 +259,7 @@   = return [MR_Fallible mk_seq]   where     mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty-                                      [(DEFAULT, [], fail)]+                                      [Alt DEFAULT [] fail]  matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr) -- Real true variables, just like in matchVar, SLPJ p 94@@ -407,7 +408,7 @@  tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })   = do { (wrap, pat') <- tidy1 v orig pat-       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }+       ; return (wrap, eqn { eqn_pats = pat' : pats }) }  tidy1 :: Id                  -- The Id being scrutinised       -> Origin              -- Was this a pattern the user wrote?@@ -452,9 +453,9 @@     -- This is a convenient place to check for unlifted types under a lazy pattern.     -- Doing this check during type-checking is unsatisfactory because we may     -- not fully know the zonked types yet. We sure do here.-  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)         ; unless (null unlifted_bndrs) $-          putSrcSpanDs (getLoc pat) $+          putSrcSpanDs (getLocA pat) $           errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$                        text "Unlifted variables:")                     2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))@@ -513,7 +514,7 @@   = return (idDsWrapper, non_interesting_pat)  ---------------------tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc+tidy_bang_pat :: Id -> Origin -> SrcSpanAnnA -> Pat GhcTc               -> DsM (DsWrapper, Pat GhcTc)  -- Discard par/sig under a bang@@ -566,15 +567,15 @@ tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExtField (L l p))  --------------------push_bang_into_newtype_arg :: SrcSpan+push_bang_into_newtype_arg :: SrcSpanAnnA                            -> Type -- The type of the argument we are pushing                                    -- onto                            -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc -- See Note [Bang patterns and newtypes] -- We are transforming   !(N p)   into   (N !p)-push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))+push_bang_into_newtype_arg l _ty (PrefixCon ts (arg:args))   = ASSERT( null args)-    PrefixCon [L l (BangPat noExtField arg)]+    PrefixCon ts [L l (BangPat noExtField arg)] push_bang_into_newtype_arg l _ty (RecCon rf)   | HsRecFields { rec_flds = L lf fld : flds } <- rf   , HsRecField { hsRecFieldArg = arg } <- fld@@ -583,7 +584,7 @@                                            = L l (BangPat noExtField arg) })] }) push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})   | HsRecFields { rec_flds = [] } <- rf-  = PrefixCon [L l (BangPat noExtField (noLoc (WildPat ty)))]+  = PrefixCon [] [L l (BangPat noExtField (noLocA (WildPat ty)))] push_bang_into_newtype_arg _ _ cd   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -764,81 +765,77 @@                                                 (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.-        ; rhss_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 [] -- Ultimately this will result in passing Nothing-                         -- to dsGRHSs as match_deltas+        -- @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   <- mk_eqn_infos matches rhss_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-    -- rhss_deltas is a flat list, whereas there are multiple GRHSs per match.-    -- mk_eqn_infos will thread rhss_deltas as state through calls to-    -- mk_eqn_info, distributing each rhss_deltas to a GRHS.-    mk_eqn_infos (L _ match : matches) rhss_deltas-      = do { (info, rhss_deltas') <- mk_eqn_info  match   rhss_deltas-           ; infos                <- mk_eqn_infos matches rhss_deltas'-           ; return (info:infos) }-    mk_eqn_infos [] _ = return []     -- Called once per equation in the match, or alternative in the case-    mk_eqn_info (Match { m_pats = pats, m_grhss = grhss }) rhss_deltas-      | GRHSs _ grhss' _  <- grhss, let n_grhss = length grhss'+    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-           -- Split off one Deltas for each GRHS of the current Match from the-           -- flat list of GRHS Deltas *for all matches* (see the call to-           -- checkMatches above).-           ; let (match_deltas, rhss_deltas') = splitAt n_grhss rhss_deltas-           -- The list of Deltas is empty iff we don't perform any coverage-           -- checking, in which case nonEmpty does the right thing by passing-           -- Nothing.-           ; match_result <- dsGRHSs ctxt grhss rhs_ty (NEL.nonEmpty match_deltas)-           ; return ( EqnInfo { eqn_pats = upats-                              , eqn_orig = FromSource-                              , eqn_rhs = match_result }-                    , rhss_deltas' ) }+           -- 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 <- updPmNablas pat_nablas $+                             dsGRHSs ctxt grhss rhs_ty rhss_nablas+           ; return EqnInfo { eqn_pats = upats+                            , eqn_orig = FromSource+                            , eqn_rhs  = match_result } }      handleWarnings = if isGenerated origin                      then discardWarningsDs                      else id +    initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]+    initNablasMatches ms+      = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms++    initNablasGRHSs :: GRHSs GhcTc b -> NonEmpty Nablas+    initNablasGRHSs m = expectJust "GRHSs non-empty"+                      $ NEL.nonEmpty+                      $ replicate (length (grhssGRHSs m)) initNablas++ matchEquations  :: HsMatchContext GhcRn                 -> [MatchId] -> [EquationInfo] -> Type                 -> DsM CoreExpr matchEquations ctxt vars eqns_info rhs_ty-  = do  { let error_doc = matchContextErrString ctxt+  = do  { match_result <- match vars rhs_ty eqns_info -        ; match_result <- match vars rhs_ty eqns_info+        ; fail_expr <- mkFailExpr ctxt rhs_ty -        ; 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 +855,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 +864,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@@ -904,7 +901,7 @@   | PgCon DataCon       -- Constructor patterns (incl list, tuple)   | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]   | PgLit Literal       -- Literal patterns-  | PgN   Rational      -- Overloaded numeric literals;+  | PgN   FractionalLit -- Overloaded numeric literals;                         -- see Note [Don't use Literal for PgN]   | PgOverS FastString  -- Overloaded string literals   | PgNpK Integer       -- n+k patterns@@ -932,7 +929,7 @@ machine's Int# type, and an overloaded literal could meaningfully be larger.  Solution: For pattern grouping purposes, just store the literal directly in-the PgN constructor as a Rational if numeric, and add a PgOverStr constructor+the PgN constructor as a FractionalLit if numeric, and add a PgOverStr constructor for overloaded strings. -} @@ -1018,6 +1015,10 @@                                                 -- eqTypes: See Note [Pattern synonym groups] sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant+        -- Order is significant, match PgN after PgLit+        -- If the exponents are small check for value equality rather than syntactic equality+        -- This is implemented in the Eq instance for FractionalLit, we do this to avoid+        -- computing the value of excessivly large rationals. sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2 sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns] sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2@@ -1065,7 +1066,6 @@     -- the instance for IPName derives using the id, so this works if the     -- above does     exp (HsIPVar _ i) (HsIPVar _ i') = i == i'-    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'     exp (HsOverLit _ l) (HsOverLit _ l') =         -- Overloaded lits are equal if they have the same type         -- and the data is the same.@@ -1111,8 +1111,8 @@     syn_exp _              _              = False      ----------    tup_arg (L _ (Present _ e1)) (L _ (Present _ e2)) = lexp e1 e2-    tup_arg (L _ (Missing (Scaled _ t1)))   (L _ (Missing (Scaled _ t2)))   = eqType t1 t2+    tup_arg (Present _ e1)           (Present _ e2)         = lexp e1 e2+    tup_arg (Missing (Scaled _ t1)) (Missing (Scaled _ t2)) = eqType t1 t2     tup_arg _ _ = False      ---------@@ -1135,8 +1135,17 @@      ---------     ev_term :: EvTerm -> EvTerm -> Bool-    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b-    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b+    ev_term (EvExpr (Var a)) (EvExpr  (Var b))+      = idType a `eqType` idType b+        -- The /type/ of the evidence matters, not its precise proof term.+        -- Caveat: conceivably a sufficiently exotic use of incoherent instances+        -- could make a difference, but remember this is only used within the+        -- pattern matches for a single function, so it's hard to see how that+        -- could really happen.  And we don't want accidentally different proofs+        -- to prevent spotting equalities, and hence degrade pattern-match+        -- overlap checking.+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b))+      = a `eqCoercion` b     ev_term _ _ = False      ---------@@ -1156,12 +1165,14 @@ patGroup _ (BangPat {})                 = PgBang patGroup _ (NPat _ (L _ (OverLit {ol_val=oval})) mb_neg _) =   case (oval, isJust mb_neg) of-   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))-   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))-   (HsFractional r, False) -> PgN (fl_value r)-   (HsFractional r, True ) -> PgN (-fl_value r)-   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)-                          PgOverS s+    (HsIntegral   i, is_neg) -> PgN (integralFractionalLit is_neg (if is_neg+                                                                    then negate (il_value i)+                                                                    else il_value i))+    (HsFractional f, is_neg)+      | is_neg    -> PgN $! negateFractionalLit f+      | otherwise -> PgN f+    (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)+                            PgOverS s patGroup _ (NPlusKPat _ _ (L _ (OverLit {ol_val=oval})) _ _ _) =   case oval of    HsIntegral i -> PgNpK (il_value i)

GHC/HsToCore/Match.hs-boot view

@@ -6,7 +6,7 @@ import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr ) import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr )-import GHC.Hs.Extension ( GhcRn, GhcTc )+import GHC.Hs.Extension ( GhcTc, GhcRn )  match   :: [Id]         -> Type@@ -29,6 +29,7 @@  matchSinglePatVar         :: Id+        -> Maybe CoreExpr         -> HsMatchContext GhcRn         -> LPat GhcTc         -> Type

GHC/HsToCore/Match/Constructor.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,12 +11,6 @@ Pattern-matching constructors -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Match.Constructor ( matchConFamily, matchPatSyn ) where  #include "HsVersions.h"@@ -36,6 +35,7 @@ import GHC.Types.FieldLabel ( flSelector ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import Control.Monad(liftM) import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..))@@ -125,7 +125,7 @@         PatSynCon psyn -> alt{ alt_pat = psyn }         _ -> panic "matchPatSyn: not PatSynCon" -type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))+type ConArgPats = HsConPatDetails GhcTc  matchOneConLike :: [Id]                 -> Type@@ -248,7 +248,7 @@ selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id] selectConMatchVars arg_tys con = case con of                                    (RecCon {}) -> newSysLocalsDsNoLP arg_tys-                                   (PrefixCon ps) -> selectMatchVars (zipMults arg_tys ps)+                                   (PrefixCon _ ps) -> selectMatchVars (zipMults arg_tys ps)                                    (InfixCon p1 p2) -> selectMatchVars (zipMults arg_tys [p1, p2])   where     zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))@@ -258,7 +258,7 @@                           -- are probably never looked at anyway            -> ConArgPats            -> [Pat GhcTc]-conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps+conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2] conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))   | null rpats = map WildPat (map scaledThing arg_tys)

GHC/HsToCore/Match/Literal.hs view

@@ -1,3 +1,11 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE AllowAmbiguousTypes #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,11 +14,6 @@ Pattern-matching literal patterns -} -{-# LANGUAGE CPP, ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.HsToCore.Match.Literal    ( dsLit, dsOverLit, hsLitKey    , tidyLitPat, tidyNPat@@ -35,6 +38,7 @@ import GHC.Hs  import GHC.Types.Id+import GHC.Types.SourceText import GHC.Core import GHC.Core.Make import GHC.Core.TyCon@@ -48,11 +52,10 @@ import GHC.Builtin.Types.Prim import GHC.Types.Literal import GHC.Types.SrcLoc-import Data.Ratio import GHC.Utils.Outputable as Outputable-import GHC.Types.Basic import GHC.Driver.Session import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt import GHC.Core.FamInstEnv ( FamInstEnvs, normaliseType )@@ -62,7 +65,7 @@ import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NEL import Data.Word-import Data.Proxy+import GHC.Real ( Ratio(..), numerator, denominator )  {- ************************************************************************@@ -96,25 +99,134 @@     HsCharPrim   _ c -> return (Lit (LitChar c))     HsIntPrim    _ i -> return (Lit (mkLitIntWrap platform i))     HsWordPrim   _ w -> return (Lit (mkLitWordWrap platform w))-    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap platform i))-    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap platform w))-    HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))-    HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))+    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap i))+    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap w))++    -- This can be slow for very large literals. See Note [FractionalLit representation]+    -- and #15646+    HsFloatPrim  _ fl -> return (Lit (LitFloat (rationalFromFractionalLit fl)))+    HsDoublePrim _ fl -> return (Lit (LitDouble (rationalFromFractionalLit fl)))     HsChar _ c       -> return (mkCharExpr c)     HsString _ str   -> mkStringExprFS str     HsInteger _ i _  -> return (mkIntegerExpr i)     HsInt _ i        -> return (mkIntExpr platform (il_value i))-    HsRat _ (FL _ _ val) ty -> do-      return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])-      where-        num   = mkIntegerExpr (numerator val)-        denom = mkIntegerExpr (denominator val)+    HsRat _ fl ty    -> dsFractionalLitToRational fl ty++{-+Note [FractionalLit representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a fun wrinkle to this, we used to simply compute the value+for these literals and store it as `Rational`. While this might seem+reasonable it meant typechecking literals of extremely large numbers+wasn't possible. This happend for example in #15646.++There a user would write in GHCi e.g. `:t 1e1234111111111111111111111`+which would trip up the compiler. The reason being we would parse it as+<Literal of value n>. Try to compute n, which would run out of memory+for truly large numbers, or take far too long for merely large ones.++To fix this we instead now store the significand and exponent of the+literal instead. Depending on the size of the exponent we then defer+the computation of the Rational value, potentially up to runtime of the+program! There are still cases left were we might compute large rationals+but it's a lot rarer then.++The current state of affairs for large literals is:+* Typechecking: Will produce a FractionalLit+* Desugaring a large overloaded literal to Float/Double *is* done+  at compile time. So can still fail. But this only matters for values too large+  to be represented as float anyway.+* Converting overloaded literals to a value of *Rational* is done at *runtime*.+  If such a value is then demanded at runtime the program might hang or run out of+  memory. But that is perhaps expected and acceptable.+* TH might also evaluate the literal even when overloaded.+  But there a user should be able to work around #15646 by+  generating a call to `mkRationalBase10/2` for large literals instead.+++Note [FractionalLit representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For fractional literals, like 1.3 or 0.79e22, we do /not/ represent+them within the compiler as a Rational.  Doing so would force the+compiler to compute a huge Rational for 2.3e300000000000, at compile+time (#15646)!++So instead we represent fractional literals as a FractionalLit,+in which we record the significand and exponent separately.  Then+we can compute the huge Rational at /runtime/, by emitting code+for+       mkRationalBase10 2.3 300000000000++where mkRationalBase10 is defined in the library GHC.Real++The moving parts are here:++* Parsing, renaming, typechecking: use FractionalLit, in which the+  significand and exponent are represented separately.++* Desugaring.  Remember that a fractional literal like 54.4e20 has type+     Fractional a => a++  - For fractional literals whose type turns out to be Float/Double,+    we desugar to a Float/Double literal at /compile time/.+    This conversion can still fail. But this only matters for values+    too large to be represented as float anyway.  See dsLit in+    GHC.HsToCore.Match.Literal++  - For fractional literals whose type turns out to be Rational, we+    desugar the literal to a call of `mkRationalBase10` (etc for hex+    literals), so that we only compute the Rational at /run time/.  If+    this value is then demanded at runtime the program might hang or+    run out of memory. But that is perhaps expected and acceptable.+    See dsFractionalLitToRational in GHC.HsToCore.Match.Literal++  - For fractional literals whose type isn't one of the above, we just+    call the typeclass method `fromRational`.  But to do that we need+    the rational to give to it, and we compute that at runtime, as+    above.++* Template Haskell definitions are also problematic. While the TH code+  works as expected once it's spliced into a program it will compute the+  value of the large literal.+  But there a user should be able to work around #15646+  by having their TH code generating a call to `mkRationalBase[10/2]` for+  large literals  instead.++-}++-- | See Note [FractionalLit representation]+dsFractionalLitToRational :: FractionalLit -> Type -> DsM CoreExpr+dsFractionalLitToRational fl@FL{ fl_signi = signi, fl_exp = exp, fl_exp_base = base } ty+  -- We compute "small" rationals here and now+  | abs exp <= 100+  = let !val   = rationalFromFractionalLit fl+        !num   = mkIntegerExpr (numerator val)+        !denom = mkIntegerExpr (denominator val)         (ratio_data_con, integer_ty)             = case tcSplitTyConApp ty of                     (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)                                        (head (tyConDataCons tycon), i_ty)                     x -> pprPanic "dsLit" (ppr x)+    in return $! (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])+  -- Large rationals will be computed at runtime.+  | otherwise+  = do+      let mkRationalName = case base of+                             Base2 -> mkRationalBase2Name+                             Base10 -> mkRationalBase10Name+      mkRational <- dsLookupGlobalId mkRationalName+      litR <- dsRational signi+      let litE = mkIntegerExpr exp+      return (mkCoreApps (Var mkRational) [litR, litE]) +dsRational :: Rational -> DsM CoreExpr+dsRational (n :% d) = do+  dcn <- dsLookupDataCon ratioDataConName+  let cn = mkIntegerExpr n+  let dn = mkIntegerExpr d+  return $ mkCoreConApps dcn [Type integerTy, cn, dn]++ dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr -- ^ Post-typechecker, the 'HsExpr' field of an 'OverLit' contains -- (an expression for) the literal value itself.@@ -125,6 +237,7 @@   case shortCutLit platform val ty of     Just expr | not rebindable -> dsExpr expr        -- Note [Literal short cut]     _                          -> dsExpr witness+ {- Note [Literal short cut] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -191,55 +304,64 @@ warnAboutOverflowedLiterals dflags lit  | wopt Opt_WarnOverflowedLiterals dflags  , Just (i, tc) <- lit- =  if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)-+ = if     -- These only show up via the 'HsOverLit' route-    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)-    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)-    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)-    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)-    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)-    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)-    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)-    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)-    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)-    else if tc == naturalTyConName then checkPositive i tc+    | tc == intTyConName        -> check i tc minInt         maxInt+    | tc == wordTyConName       -> check i tc minWord        maxWord+    | tc == int8TyConName       -> check i tc (min' @Int8)   (max' @Int8)+    | tc == int16TyConName      -> check i tc (min' @Int16)  (max' @Int16)+    | tc == int32TyConName      -> check i tc (min' @Int32)  (max' @Int32)+    | tc == int64TyConName      -> check i tc (min' @Int64)  (max' @Int64)+    | tc == word8TyConName      -> check i tc (min' @Word8)  (max' @Word8)+    | tc == word16TyConName     -> check i tc (min' @Word16) (max' @Word16)+    | tc == word32TyConName     -> check i tc (min' @Word32) (max' @Word32)+    | tc == word64TyConName     -> check i tc (min' @Word64) (max' @Word64)+    | tc == naturalTyConName    -> checkPositive i tc      -- These only show up via the 'HsLit' route-    else if tc == intPrimTyConName    then check i tc (Proxy :: Proxy Int)-    else if tc == int8PrimTyConName   then check i tc (Proxy :: Proxy Int8)-    else if tc == int32PrimTyConName  then check i tc (Proxy :: Proxy Int32)-    else if tc == int64PrimTyConName  then check i tc (Proxy :: Proxy Int64)-    else if tc == wordPrimTyConName   then check i tc (Proxy :: Proxy Word)-    else if tc == word8PrimTyConName  then check i tc (Proxy :: Proxy Word8)-    else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)-    else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)+    | tc == intPrimTyConName    -> check i tc minInt         maxInt+    | tc == wordPrimTyConName   -> check i tc minWord        maxWord+    | tc == int8PrimTyConName   -> check i tc (min' @Int8)   (max' @Int8)+    | tc == int16PrimTyConName  -> check i tc (min' @Int16)  (max' @Int16)+    | tc == int32PrimTyConName  -> check i tc (min' @Int32)  (max' @Int32)+    | tc == int64PrimTyConName  -> check i tc (min' @Int64)  (max' @Int64)+    | tc == word8PrimTyConName  -> check i tc (min' @Word8)  (max' @Word8)+    | tc == word16PrimTyConName -> check i tc (min' @Word16) (max' @Word16)+    | tc == word32PrimTyConName -> check i tc (min' @Word32) (max' @Word32)+    | tc == word64PrimTyConName -> check i tc (min' @Word64) (max' @Word64) -    else return ()+    | otherwise -> return ()    | otherwise = return ()   where+    -- use target Int/Word sizes! See #17336+    platform          = targetPlatform dflags+    (minInt,maxInt)   = (platformMinInt platform, platformMaxInt platform)+    (minWord,maxWord) = (0,                       platformMaxWord platform) +    min' :: forall a. (Integral a, Bounded a) => Integer+    min' = fromIntegral (minBound :: a)++    max' :: forall a. (Integral a, Bounded a) => Integer+    max' = fromIntegral (maxBound :: a)+     checkPositive :: Integer -> Name -> DsM ()     checkPositive i tc-      = when (i < 0) $ do+      = when (i < 0) $         warnDs (Reason Opt_WarnOverflowedLiterals)                (vcat [ text "Literal" <+> integer i                        <+> text "is negative but" <+> ppr tc                        <+> ptext (sLit "only supports positive numbers")                      ]) -    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()-    check i tc _proxy-      = when (i < minB || i > maxB) $ do+    check i tc minB maxB+      = when (i < minB || i > maxB) $         warnDs (Reason Opt_WarnOverflowedLiterals)                (vcat [ text "Literal" <+> integer i                        <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")                        <+> integer minB <> text ".." <> integer maxB                      , sug ])       where-        minB = toInteger (minBound :: a)-        maxB = toInteger (maxBound :: a)         sug | minB == -i   -- Note [Suggest NegativeLiterals]             , i > 0             , not (xopt LangExt.NegativeLiterals dflags)@@ -267,35 +389,46 @@   | not $ wopt Opt_WarnEmptyEnumerations dflags   = return ()   -- Numeric Literals-  | Just from_ty@(from,_) <- getLHsIntegralLit fromExpr-  , Just (_, tc)          <- getNormalisedTyconName fam_envs from_ty-  , Just mThn             <- traverse getLHsIntegralLit mThnExpr-  , Just (to,_)           <- getLHsIntegralLit toExpr-  , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()-        check _proxy-          = when (null enumeration) raiseWarning+  | Just from_ty@(from',_) <- getLHsIntegralLit fromExpr+  , Just (_, tc)           <- getNormalisedTyconName fam_envs from_ty+  , Just mThn'             <- traverse getLHsIntegralLit mThnExpr+  , Just (to',_)           <- getLHsIntegralLit toExpr+  = do+      let+        check :: forall a. (Integral a, Num a) => DsM ()+        check = when (null enumeration) raiseWarning           where-            enumeration :: [a]             enumeration = case mThn of-                            Nothing      -> [fromInteger from                    .. fromInteger to]-                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]+              Nothing  -> [from      .. to]+              Just thn -> [from, thn .. to]+            wrap :: forall a. (Integral a, Num a) => Integer -> Integer+            wrap i = toInteger (fromIntegral i :: a)+            from = wrap @a from'+            to   = wrap @a to'+            mThn = fmap (wrap @a . fst) mThn' -  = if      tc == intTyConName    then check (Proxy :: Proxy Int)-    else if tc == int8TyConName   then check (Proxy :: Proxy Int8)-    else if tc == int16TyConName  then check (Proxy :: Proxy Int16)-    else if tc == int32TyConName  then check (Proxy :: Proxy Int32)-    else if tc == int64TyConName  then check (Proxy :: Proxy Int64)-    else if tc == wordTyConName   then check (Proxy :: Proxy Word)-    else if tc == word8TyConName  then check (Proxy :: Proxy Word8)-    else if tc == word16TyConName then check (Proxy :: Proxy Word16)-    else if tc == word32TyConName then check (Proxy :: Proxy Word32)-    else if tc == word64TyConName then check (Proxy :: Proxy Word64)-    else if tc == integerTyConName then check (Proxy :: Proxy Integer)-    else if tc == naturalTyConName then check (Proxy :: Proxy Integer)-      -- We use 'Integer' because otherwise a negative 'Natural' literal-      -- could cause a compile time crash (instead of a runtime one).-      -- See the T10930b test case for an example of where this matters.-    else return ()+      platform <- targetPlatform <$> getDynFlags+         -- Be careful to use target Int/Word sizes! cf #17336+      if | tc == intTyConName     -> case platformWordSize platform of+                                      PW4 -> check @Int32+                                      PW8 -> check @Int64+         | tc == wordTyConName    -> case platformWordSize platform of+                                      PW4 -> check @Word32+                                      PW8 -> check @Word64+         | tc == int8TyConName    -> check @Int8+         | tc == int16TyConName   -> check @Int16+         | tc == int32TyConName   -> check @Int32+         | tc == int64TyConName   -> check @Int64+         | tc == word8TyConName   -> check @Word8+         | tc == word16TyConName  -> check @Word16+         | tc == word32TyConName  -> check @Word32+         | tc == word64TyConName  -> check @Word64+         | tc == integerTyConName -> check @Integer+         | tc == naturalTyConName -> check @Integer+            -- We use 'Integer' because otherwise a negative 'Natural' literal+            -- could cause a compile time crash (instead of a runtime one).+            -- See the T10930b test case for an example of where this matters.+         | otherwise -> return ()    -- Char literals (#18402)   | Just fromChar <- getLHsCharLit fromExpr@@ -312,14 +445,20 @@  getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Type) -- ^ See if the expression is an 'Integral' literal.--- Remember to look through automatically-added tick-boxes! (#8384)-getLHsIntegralLit (L _ (HsPar _ e))            = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsTick _ _ e))         = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e-getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit-getLHsIntegralLit (L _ (HsLit _ lit))          = getSimpleIntegralLit lit-getLHsIntegralLit _ = Nothing+getLHsIntegralLit (L _ e) = go e+  where+    go (HsPar _ e)            = getLHsIntegralLit e+    go (HsOverLit _ over_lit) = getIntegralLit over_lit+    go (HsLit _ lit)          = getSimpleIntegralLit lit +    -- Remember to look through automatically-added tick-boxes! (#8384)+    go (HsTick _ _ e)         = getLHsIntegralLit e+    go (HsBinTick _ _ _ e)    = getLHsIntegralLit e++    -- The literal might be wrapped in a case with -XOverloadedLists+    go (XExpr (WrapExpr (HsWrap _ e))) = go e+    go _ = Nothing+ -- | If 'Integral', extract the value and type of the overloaded literal. -- See Note [Literals and the OverloadedLists extension] getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Type)@@ -436,7 +575,7 @@      mk_con_pat :: DataCon -> HsLit GhcTc -> Pat GhcTc     mk_con_pat con lit-      = unLoc (mkPrefixConPat con [noLoc $ LitPat noExtField lit] [])+      = unLoc (mkPrefixConPat con [noLocA $ LitPat noExtField lit] [])      mb_int_lit :: Maybe Integer     mb_int_lit = case (mb_neg, val) of@@ -511,15 +650,17 @@ -- In the case of the fixed-width numeric types, we need to wrap here -- because Literal has an invariant that the literal is in range, while -- HsLit does not.-hsLitKey platform (HsIntPrim    _ i) = mkLitIntWrap  platform i-hsLitKey platform (HsWordPrim   _ w) = mkLitWordWrap platform w-hsLitKey platform (HsInt64Prim  _ i) = mkLitInt64Wrap  platform i-hsLitKey platform (HsWord64Prim _ w) = mkLitWord64Wrap platform w-hsLitKey _        (HsCharPrim   _ c) = mkLitChar            c-hsLitKey _        (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)-hsLitKey _        (HsDoublePrim _ d) = mkLitDouble          (fl_value d)-hsLitKey _        (HsString _ s)     = LitString (bytesFS s)-hsLitKey _        l                  = pprPanic "hsLitKey" (ppr l)+hsLitKey platform (HsIntPrim    _ i)  = mkLitIntWrap  platform i+hsLitKey platform (HsWordPrim   _ w)  = mkLitWordWrap platform w+hsLitKey _        (HsInt64Prim  _ i)  = mkLitInt64Wrap  i+hsLitKey _        (HsWord64Prim _ w)  = mkLitWord64Wrap w+hsLitKey _        (HsCharPrim   _ c)  = mkLitChar            c+-- This following two can be slow. See Note [FractionalLit representation]+hsLitKey _        (HsFloatPrim  _ fl) = mkLitFloat (rationalFromFractionalLit fl)+hsLitKey _        (HsDoublePrim _ fl) = mkLitDouble (rationalFromFractionalLit fl)++hsLitKey _        (HsString _ s)      = LitString (bytesFS s)+hsLitKey _        l                   = pprPanic "hsLitKey" (ppr l)  {- ************************************************************************

GHC/HsToCore/Monad.hs view

@@ -1,3 +1,10 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,14 +13,6 @@ Monadery used in desugaring -} -{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan- module GHC.HsToCore.Monad (         DsM, mapM, mapAndUnzipM,         initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,@@ -23,18 +22,19 @@         duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,         newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,         newFailLocalDs, newPredVarDs,-        getSrcSpanDs, putSrcSpanDs,+        getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,         mkPrintUnqualifiedDs,         newUnique,         UniqSupply, newUniqueSupply,         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,@@ -57,39 +57,58 @@  import GHC.Prelude -import GHC.Tc.Utils.Monad+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr++import GHC.Hs++import GHC.HsToCore.Types+import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)+ import GHC.Core.FamInstEnv import GHC.Core import GHC.Core.Make  ( unitExpr ) import GHC.Core.Utils ( exprType, isExprLevPoly )-import GHC.Hs+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Multiplicity+ import GHC.IfaceToCore++import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType ( checkForLevPolyX, formatLevPolyErr )+ import GHC.Builtin.Names++import GHC.Data.FastString++import GHC.Unit.Env+import GHC.Unit.External+import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+ import GHC.Types.Name.Reader-import GHC.Driver.Types-import GHC.Data.Bag import GHC.Types.Basic ( Origin )-import GHC.Core.DataCon-import GHC.Core.ConLike-import GHC.Core.TyCon-import GHC.HsToCore.PmCheck.Types+import GHC.Types.SourceFile import GHC.Types.Id-import GHC.Unit.Module-import GHC.Utils.Outputable import GHC.Types.SrcLoc-import GHC.Core.Type-import GHC.Core.Multiplicity+import GHC.Types.TypeEnv import GHC.Types.Unique.Supply import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Driver.Session-import GHC.Utils.Error-import GHC.Data.FastString-import GHC.Types.Unique.FM ( lookupWithDefaultUFM_Directly )+import GHC.Types.Name.Ppr import GHC.Types.Literal ( mkLitString ) import GHC.Types.CostCentre.State+import GHC.Types.TyThing+import GHC.Types.Error +import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Error+ import Data.IORef  {-@@ -195,7 +214,7 @@        }  -- | Run a 'DsM' action inside the 'IO' monad.-initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)+initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) initDs hsc_env tcg_env thing_inside   = do { msg_var <- newIORef emptyMessages        ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env@@ -204,58 +223,63 @@  -- | Build a set of desugarer environments derived from a 'TcGblEnv'. mkDsEnvsFromTcGbl :: MonadIO m-                  => HscEnv -> IORef Messages -> TcGblEnv+                  => HscEnv -> IORef (Messages DecoratedSDoc) -> TcGblEnv                   -> m (DsGblEnv, DsLclEnv) mkDsEnvsFromTcGbl hsc_env msg_var tcg_env   = do { cc_st_var   <- liftIO $ newIORef newCostCentreState-       ; let dflags   = hsc_dflags hsc_env+       ; eps <- liftIO $ hscEPS hsc_env+       ; let unit_env = hsc_unit_env 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-       ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_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 unit_env this_mod rdr_env type_env fam_inst_env                            msg_var cc_st_var complete_matches        } -runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)+runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DecoratedSDoc, Maybe a) runDs hsc_env (ds_gbl, ds_lcl) thing_inside   = do { res    <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl                               (tryM thing_inside)        ; msgs   <- readIORef (ds_msgs ds_gbl)        ; let final_res-               | errorsFound dflags msgs = Nothing-               | Right r <- res          = Just r-               | otherwise               = panic "initDs"+               | errorsFound msgs = Nothing+               | Right r <- res   = Just r+               | otherwise        = panic "initDs"        ; return (msgs, final_res)        }-  where dflags = hsc_dflags hsc_env  -- | Run a 'DsM' action in the context of an existing 'ModGuts'-initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)-initDsWithModGuts hsc_env guts thing_inside+initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DecoratedSDoc, Maybe a)+initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds+                                   , mg_tcs = tycons, mg_fam_insts = fam_insts+                                   , mg_patsyns = patsyns, mg_rdr_env = rdr_env+                                   , mg_fam_inst_env = fam_inst_env+                                   , mg_complete_matches = local_complete_matches+                          }) thing_inside   = do { cc_st_var   <- newIORef newCostCentreState        ; msg_var <- newIORef emptyMessages-       ; 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+       ; eps <- liftIO $ hscEPS hsc_env+       ; let unit_env = hsc_unit_env hsc_env+             type_env = typeEnvFromEntities ids tycons patsyns fam_insts+             complete_matches = hptCompleteSigs hsc_env     -- from the home package+                                ++ local_complete_matches  -- from the current module+                                ++ eps_complete_matches eps -- from imports               bindsToIds (NonRec v _)   = [v]              bindsToIds (Rec    binds) = map fst binds-             ids = concatMap bindsToIds (mg_binds guts)+             ids = concatMap bindsToIds binds -             envs  = mkDsEnvs dflags this_mod rdr_env type_env+             envs  = mkDsEnvs unit_env this_mod rdr_env type_env                               fam_inst_env msg_var cc_st_var                               complete_matches        ; runDs hsc_env envs thing_inside        } -initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)+initTcDsForSolver :: TcM a -> DsM a -- Spin up a TcM context so that we can run the constraint solver -- Returns any error messages generated by the constraint solver -- and (Just res) if no error happened; Nothing if an error happened@@ -270,36 +294,46 @@        ; hsc_env    <- getTopEnv         ; let DsGblEnv { ds_mod = mod-                      , ds_fam_inst_env = fam_inst_env } = gbl+                      , ds_fam_inst_env = fam_inst_env+                      , ds_gbl_rdr_env  = rdr_env }      = gbl+       -- This is *the* use of ds_gbl_rdr_env:+       -- Make sure the solver (used by the pattern-match overlap checker) has+       -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it+       -- knows how to reduce type families, and which newtypes it can unwrap. +              DsLclEnv { dsl_loc = loc }                  = lcl -       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $-         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $-         thing_inside }+       ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $+         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env+                                      , tcg_rdr_env      = rdr_env }) $+         thing_inside+       ; case mb_ret of+           Just ret -> pure ret+           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) } -mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv-         -> IORef Messages -> IORef CostCentreState -> [CompleteMatch]+mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv+         -> IORef (Messages DecoratedSDoc) -> IORef CostCentreState -> CompleteMatches          -> (DsGblEnv, DsLclEnv)-mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var cc_st_var+mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var          complete_matches   = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",                              if_rec_types = Just (mod, return type_env) }         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)                              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_gbl_rdr_env  = rdr_env                            , ds_if_env  = (if_genv, if_lenv)-                           , ds_unqual  = mkPrintUnqualified dflags rdr_env+                           , ds_unqual  = mkPrintUnqualified unit_env 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) @@ -398,14 +432,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 delta = updLclEnv (\env -> env { dsl_deltas = delta })+-- See 'dsl_nablas'.+updPmNablas :: Nablas -> DsM a -> DsM a+updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })  getSrcSpanDs :: DsM SrcSpan getSrcSpanDs = do { env <- getLclEnv@@ -417,16 +451,18 @@ putSrcSpanDs (RealSrcSpan real_span _) thing_inside   = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside +putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a+putSrcSpanDsA loc = putSrcSpanDs (locA loc)+ -- | Emit a warning for the current source location -- NB: Warns whether or not -Wxyz is set warnDs :: WarnReason -> SDoc -> DsM () warnDs reason warn   = do { env <- getGblEnv        ; loc <- getSrcSpanDs-       ; dflags <- getDynFlags        ; let msg = makeIntoWarning reason $-                   mkWarnMsg dflags loc (ds_unqual env) warn-       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }+                   mkWarnMsg loc (ds_unqual env) warn+       ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }  -- | Emit a warning only if the correct WarnReason is set in the DynFlags warnIfSetDs :: WarningFlag -> SDoc -> DsM ()@@ -438,9 +474,8 @@ errDs err   = do  { env <- getGblEnv         ; loc <- getSrcSpanDs-        ; dflags <- getDynFlags-        ; let msg = mkErrMsg dflags loc (ds_unqual env) err-        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }+        ; let msg = mkMsgEnvelope loc (ds_unqual env) err+        ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }  -- | Issue an error, but return the expression for (), so that we can continue -- reporting errors.@@ -478,14 +513,13 @@                   thing_inside        -- Propagate errors-      ; msgs@(warns, errs) <- readMutVar errs_var-      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))+      ; msgs <- readMutVar errs_var+      ; updMutVar (ds_msgs env) (unionMessages msgs)        -- And return       ; case mb_res of            Left _    -> failM-           Right res -> do { dflags <- getDynFlags-                           ; let errs_found = errorsFound dflags msgs+           Right res -> do { let errs_found = errorsFound msgs                            ; return (res, not errs_found) } }  mkPrintUnqualifiedDs :: DsM PrintUnqualified@@ -528,18 +562,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) }@@ -616,3 +641,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

− GHC/HsToCore/PmCheck.hs

@@ -1,1311 +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     #-}--module GHC.HsToCore.PmCheck (-        -- Checking and printing-        checkSingle, checkMatches, checkGuardMatches,-        isMatchContextPmChecked,--        -- See Note [Type and Term Equality Propagation]-        addTyCsDs, addScrutTmCs-    ) where--#include "HsVersions.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.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--{--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.-  | PmBang {-      pm_id          :: !Id-    }--    -- | @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) = 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 a RHS for later pretty-printing in a warning--- message. 'SDoc' for the equation to show, 'Located' for the location.-type RhsInfo = Located SDoc---- | A representation of the desugaring to 'PmGrd's of all clauses of a--- function definition/pattern match/etc.-data GrdTree-  = Rhs !RhsInfo-  | 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 !GrdTree-  -- ^ @Sequence l r@ first matches against @l@, and then matches all-  -- fallen-through values against @r@. Models top-to-bottom semantics of-  -- pattern matching.-  | Empty-  -- ^ A @GrdTree@ that always fails. Most useful for-  -- Note [Checking EmptyCase]. A neutral element to 'Sequence'.---- | The digest of 'checkGrdTree', representing the annotated pattern-match--- tree. 'redundantAndInaccessibleRhss' can figure out redundant and proper--- inaccessible RHSs from this.-data AnnotatedTree-  = AccessibleRhs !Deltas !RhsInfo-  -- ^ A RHS deemed accessible. The 'Deltas' is the (non-empty) set of covered-  -- values.-  | InaccessibleRhs !RhsInfo-  -- ^ 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 !AnnotatedTree !AnnotatedTree-  -- ^ Mirrors 'Sequence' for preserving the skeleton of a 'GrdTree's.-  | EmptyAnn-  -- ^ Mirrors 'Empty' for preserving the skeleton of a 'GrdTree's.--pprRhsInfo :: RhsInfo -> SDoc-pprRhsInfo (L (RealSrcSpan rss _) _) = ppr (srcSpanStartLine rss)-pprRhsInfo (L s _)                   = ppr s--instance Outputable GrdTree where-  ppr (Rhs info)      = text "->" <+> pprRhsInfo 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-  -- Format nested Sequences in blocks "{ grds1; grds2; ... }"-  ppr t@Sequence{}    = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space)-    where-      collect_seqs (Sequence l r) = collect_seqs l ++ collect_seqs r-      collect_seqs t              = [ppr t]-  ppr Empty          = text "<empty case>"--instance Outputable AnnotatedTree where-  ppr (AccessibleRhs _ info) = pprRhsInfo info-  ppr (InaccessibleRhs info) = text "inaccessible" <+> pprRhsInfo info-  ppr (MayDiverge t)         = text "div" <+> ppr t-    -- Format nested Sequences in blocks "{ grds1; grds2; ... }"-  ppr t@SequenceAnn{}        = braces (space <> fsep (punctuate semi (collect_seqs t)) <> space)-    where-      collect_seqs (SequenceAnn l r) = collect_seqs l ++ collect_seqs r-      collect_seqs t                 = [ppr t]-  ppr EmptyAnn               = text "<empty case>"---- | 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 checkGuardMatches.-    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.-checkGuardMatches-  :: HsMatchContext GhcRn         -- ^ Match context, for warning messages-  -> GRHSs GhcTc (LHsExpr GhcTc)  -- ^ The GRHSs to check-  -> DsM [Deltas]                 -- ^ Covered 'Deltas' for each RHS, for long-                                  --   distance info-checkGuardMatches 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 }-    checkMatches dsMatchContext [] [match]---- | 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]                    -- ^ One covered 'Deltas' per RHS, for long-                                     --   distance info.-checkMatches ctxt vars matches = do-  dflags <- getDynFlags-  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  <- mkGrdTreeMany [] <$> mapM (translateMatch fam_insts vars) matches-  res <- checkGrdTree grd_tree missing--  dsPmWarn dflags ctxt vars res--  return (extractRhsDeltas init_deltas (cr_clauses res))---- | Extract the 'Deltas' reaching the RHSs of the 'AnnotatedTree'.--- 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 :: Deltas -> AnnotatedTree -> [Deltas]-extractRhsDeltas orig_deltas = fromOL . go-  where-    go (AccessibleRhs deltas _) = unitOL deltas-    go (InaccessibleRhs _)      = unitOL orig_deltas-    go (MayDiverge t)           = go t-    go (SequenceAnn l r)        = go l Semi.<> go r-    go EmptyAnn                 = nilOL--{- 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  ->-    -- Add the bang in front of the list, because it will happen before any-    -- nested stuff.-    (PmBang x :) <$> translateLPat fam_insts x 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-          bang_grds     = map PmBang   $ 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)--mkGrdTreeRhs :: Located SDoc -> GrdVec -> GrdTree-mkGrdTreeRhs sdoc = foldr Guard (Rhs sdoc)--mkGrdTreeMany :: GrdVec -> [GrdTree] -> GrdTree-mkGrdTreeMany _    []    = Empty-mkGrdTreeMany grds trees = foldr Guard (foldr1 Sequence trees) grds---- 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' <- mapM (translateLGRHS fam_insts match_loc pats) (grhssGRHSs grhss)-  -- tracePm "translateMatch" (vcat [ppr pats, ppr pats', ppr grhss, ppr grhss'])-  return (mkGrdTreeMany pats' grhss')---- -------------------------------------------------------------------------- * Transform source guards (GuardStmt Id) to simpler PmGrds---- | Translate a guarded right-hand side to a single 'GrdTree'-translateLGRHS :: FamInstEnvs -> SrcSpan -> [LPat GhcTc] -> LGRHS GhcTc (LHsExpr GhcTc) -> DsM GrdTree-translateLGRHS fam_insts match_loc pats (L _loc (GRHS _ gs _)) =-  -- _loc apparently points to the match separator that comes after the guards..-  mkGrdTreeRhs loc_sdoc <$> concatMapM (translateGuard fam_insts . unLoc) gs-    where-      loc_sdoc-        | null gs   = L match_loc (sep (map ppr pats))-        | otherwise = L grd_loc   (sep (map ppr 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 'redundantAndInaccessibleRhss' for---     presenting redundant and proper innaccessible RHSs 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) tree) deltas = do-  has_diverged <- addPmCtDeltas deltas (PmBotCt x) >>= isInhabited-  deltas' <- addPmCtDeltas deltas (PmNotBotCt x)-  res <- checkGrdTree' tree deltas'-  pure res{ cr_clauses = applyWhen has_diverged mayDiverge (cr_clauses res) }--- 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-  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 l r) unc_0 = do-  CheckResult l' unc_1 prec_l <- checkGrdTree' l unc_0-  CheckResult r' unc_2 prec_r <- checkGrdTree' r unc_1-  pure CheckResult-    { cr_clauses = SequenceAnn l' r'-    , cr_uncov = unc_2-    , cr_approx = prec_l Semi.<> prec_r }--- Empty: Fall through for all values-checkGrdTree' Empty unc = do-  pure CheckResult-    { cr_clauses = EmptyAnn-    , cr_uncov = unc-    , cr_approx = Precise }---- | 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)--redundantAndInaccessibleRhss :: AnnotatedTree -> ([RhsInfo], [RhsInfo])-redundantAndInaccessibleRhss tree = (fromOL ol_red, fromOL ol_inacc)-  where-    (_ol_acc, ol_inacc, ol_red) = go tree-    -- | Collects RHSs which are-    --    1. accessible-    --    2. proper inaccessible (so we can't delete them)-    --    3. hypothetically redundant (so not only inaccessible RHS, but we can-    --       even safely delete the equation without altering semantics)-    -- See Note [Determining inaccessible clauses]-    go :: AnnotatedTree -> (OrdList RhsInfo, OrdList RhsInfo, OrdList RhsInfo)-    go (AccessibleRhs _ info) = (unitOL info, nilOL, nilOL)-    go (InaccessibleRhs info) = (nilOL,       nilOL, unitOL info) -- presumably redundant-    go (MayDiverge t)         = case go t of-      -- See Note [Determining inaccessible clauses]-      (acc, inacc, red)-        | isNilOL acc && isNilOL inacc -> (nilOL, red, nilOL)-      res                              -> res-    go (SequenceAnn l r)      = go l Semi.<> go r-    go EmptyAnn               = (nilOL,       nilOL, nilOL)--{- 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 'redundantAndInaccessibleRhss'.--}---- | 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) $ do-      unc_examples <- getNFirstUncovered vars (maxPatterns + 1) uncovered-      let exists_r = flag_i && notNull redundant-          exists_i = flag_i && notNull inaccessible-          exists_u = flag_u && notNull unc_examples-          approx   = precision == Approximate--      when (approx && (exists_u || exists_i)) $-        putSrcSpanDs loc (warnDs NoReason approx_msg)--      when exists_r $ forM_ redundant $ \(L l q) -> do-        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)-                               (pprEqn q "is redundant"))-      when exists_i $ forM_ inaccessible $ \(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-    (redundant, inaccessible) = redundantAndInaccessibleRhss clauses--    flag_i = overlapping dflags kind-    flag_u = exhaustive dflags kind-    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---- | 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)

− GHC/HsToCore/PmCheck/Oracle.hs

@@ -1,1785 +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 "HsVersions.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.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 (ensureInhabited delta vi)------------------------------------------- * 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 $$ 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.--}

− GHC/HsToCore/PmCheck/Ppr.hs

@@ -1,222 +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 "HsVersions.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 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

− GHC/HsToCore/PmCheck/Types.hs

@@ -1,595 +0,0 @@-{--Author: George Karachalias <george.karachalias@cs.kuleuven.be>-        Sebastian Graf <sgraf1337@gmail.com>--}--{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ApplicativeDo #-}---- | Types used through-out pattern match checking. This module is mostly there--- to be imported from "GHC.Tc.Types". The exposed API is that of--- "GHC.HsToCore.PmCheck.Oracle" and "GHC.HsToCore.PmCheck".-module GHC.HsToCore.PmCheck.Types (-        -- * Representations for Literals and AltCons-        PmLit(..), PmLitValue(..), PmAltCon(..), pmLitType, pmAltConType,--        -- ** Equality on 'PmAltCon's-        PmEquality(..), eqPmAltCon,--        -- ** Operations on 'PmLit'-        literalToPmLit, negatePmLit, overloadPmLit,-        pmLitAsStringLit, coreExprAsPmLit,--        -- * Caching partially matched COMPLETE sets-        ConLikeSet, PossibleMatches(..),--        -- * PmAltConSet-        PmAltConSet, emptyPmAltConSet, isEmptyPmAltConSet, elemPmAltConSet,-        extendPmAltConSet, pmAltConSetElems,--        -- * A 'DIdEnv' where entries may be shared-        Shared(..), SharedDIdEnv(..), emptySDIE, lookupSDIE, sameRepresentativeSDIE,-        setIndirectSDIE, setEntrySDIE, traverseSDIE,--        -- * The pattern match oracle-        VarInfo(..), TmState(..), TyState(..), Delta(..),-        Deltas(..), initDeltas, liftDeltasM-    ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Utils.Misc-import GHC.Data.Bag-import GHC.Data.FastString-import GHC.Types.Var (EvVar)-import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Unique.DSet-import GHC.Types.Unique.DFM-import GHC.Types.Name-import GHC.Core.DataCon-import GHC.Core.ConLike-import GHC.Utils.Outputable-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.Utils.TcType (evVarPred)--import Numeric (fromRat)-import Data.Foldable (find)-import qualified Data.List.NonEmpty as NonEmpty-import Data.Ratio-import qualified Data.Semigroup as Semi---- | 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--{- 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.PmCheck" 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)-    -- Take care of -XRebindableSyntax. The last argument should be the (only)-    -- integer literal, otherwise we can't really do much about it.-    | [Lit l] <- dropWhile (not . is_lit) args-    -- getOccFS because of -XRebindableSyntax-    , getOccFS (idName x) == getOccFS fromIntegerName-    -> literalToPmLit (literalType l) l >>= overloadPmLit (exprType e)-  (Var x, args)-    -- Similar to fromInteger case-    | [r] <- dropWhile (not . is_ratio) args-    , getOccFS (idName x) == getOccFS fromRationalName-    -> coreExprAsPmLit r >>= overloadPmLit (exprType e)-  (Var x, [Type _ty, _dict, s])-    | idName x == fromStringName-    -- NB: Calls coreExprAsPmLit and then overloadPmLit, so that we return PmLitOverStrings-    -> coreExprAsPmLit s >>= overloadPmLit (exprType e)-  -- These last two cases handle 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--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--type ConLikeSet = UniqDSet ConLike---- | A data type caching the results of 'completeMatchConLikes' with support for--- deletion of constructors that were already matched on.-data PossibleMatches-  = PM (NonEmpty.NonEmpty ConLikeSet)-  -- ^ Each ConLikeSet is a (subset of) the constructors in a COMPLETE set-  -- 'NonEmpty' because the empty case would mean that the type has no COMPLETE-  -- set at all, for which we have 'NoPM'.-  | NoPM-  -- ^ No COMPLETE set for this type (yet). Think of overloaded literals.--instance Outputable PossibleMatches where-  ppr (PM cs) = ppr (NonEmpty.toList cs)-  ppr NoPM = text "<NoPM>"---- | Either @Indirect x@, meaning the value is represented by that of @x@, or--- an @Entry@ containing containing the actual value it represents.-data Shared a-  = Indirect Id-  | Entry a---- | A 'DIdEnv' in which entries can be shared by multiple 'Id's.--- Merge equivalence classes of two Ids by 'setIndirectSDIE' and set the entry--- of an Id with 'setEntrySDIE'.-newtype SharedDIdEnv a-  = SDIE { unSDIE :: DIdEnv (Shared a) }--emptySDIE :: SharedDIdEnv a-emptySDIE = SDIE emptyDVarEnv--lookupReprAndEntrySDIE :: SharedDIdEnv a -> Id -> (Id, Maybe a)-lookupReprAndEntrySDIE sdie@(SDIE env) x = case lookupDVarEnv env x of-  Nothing           -> (x, Nothing)-  Just (Indirect y) -> lookupReprAndEntrySDIE sdie y-  Just (Entry a)    -> (x, Just a)---- | @lookupSDIE env x@ looks up an entry for @x@, looking through all--- 'Indirect's until it finds a shared 'Entry'.-lookupSDIE :: SharedDIdEnv a -> Id -> Maybe a-lookupSDIE sdie x = snd (lookupReprAndEntrySDIE sdie x)---- | Check if two variables are part of the same equivalence class.-sameRepresentativeSDIE :: SharedDIdEnv a -> Id -> Id -> Bool-sameRepresentativeSDIE sdie x y =-  fst (lookupReprAndEntrySDIE sdie x) == fst (lookupReprAndEntrySDIE sdie y)---- | @setIndirectSDIE env x y@ sets @x@'s 'Entry' to @Indirect y@, thereby--- merging @x@'s equivalence class into @y@'s. This will discard all info on--- @x@!-setIndirectSDIE :: SharedDIdEnv a -> Id -> Id -> SharedDIdEnv a-setIndirectSDIE sdie@(SDIE env) x y =-  SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Indirect y)---- | @setEntrySDIE env x a@ sets the 'Entry' @x@ is associated with to @a@,--- thereby modifying its whole equivalence class.-setEntrySDIE :: SharedDIdEnv a -> Id -> a -> SharedDIdEnv a-setEntrySDIE sdie@(SDIE env) x a =-  SDIE $ extendDVarEnv env (fst (lookupReprAndEntrySDIE sdie x)) (Entry a)--traverseSDIE :: forall a b f. Applicative f => (a -> f b) -> SharedDIdEnv a -> f (SharedDIdEnv b)-traverseSDIE f = fmap (SDIE . listToUDFM_Directly) . traverse g . udfmToList . unSDIE-  where-    g :: (Unique, Shared a) -> f (Unique, Shared b)-    g (u, Indirect y) = pure (u,Indirect y)-    g (u, Entry a)    = do-        a' <- f a-        pure (u,Entry a')--instance Outputable a => Outputable (Shared a) where-  ppr (Indirect x) = ppr x-  ppr (Entry a)    = ppr a--instance Outputable a => Outputable (SharedDIdEnv a) where-  ppr (SDIE env) = ppr env---- | 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.PmCheck.Oracle".-data TmState-  = TmSt-  { ts_facts :: !(SharedDIdEnv 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.-  }---- | 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 'PossibleMatches' of a COMPLETE set--- ('vi_cache').------ Subject to Note [The Pos/Neg invariant] in "GHC.HsToCore.PmCheck.Oracle".-data VarInfo-  = VI-  { vi_ty  :: !Type-  -- ^ The type of the variable. Important for rejecting possible GADT-  -- constructors or incompatible pattern synonyms (@Just42 :: Maybe Int@).--  , vi_pos :: ![(PmAltCon, [TyVar], [Id])]-  -- ^ 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_cache :: !PossibleMatches-  -- ^ 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.-  }---- | Not user-facing.-instance Outputable TmState where-  ppr (TmSt state reps) = ppr state $$ ppr reps---- | Not user-facing.-instance Outputable VarInfo where-  ppr (VI ty pos neg cache)-    = braces (hcat (punctuate comma [ppr ty, ppr pos, ppr neg, ppr cache]))---- | Initial state of the term oracle.-initTmState :: TmState-initTmState = TmSt emptySDIE emptyCoreMap---- | The type oracle state. A poor man's 'GHC.Tc.Solver.Monad.InsertSet': The invariant is--- that all constraints in there are mutually compatible.-newtype TyState = TySt (Bag EvVar)---- | Not user-facing.-instance Outputable TyState where-  ppr (TySt evs)-    = braces $ hcat $ punctuate comma $ map (ppr . evVarPred) $ bagToList evs--initTyState :: TyState-initTyState = TySt emptyBag---- | An inert set of canonical (i.e. mutually compatible) term and type--- constraints.-data Delta = MkDelta { delta_ty_st :: TyState    -- Type oracle; things like a~Int-                     , delta_tm_st :: TmState }  -- Term oracle; things like x~Nothing---- | An initial delta that is always satisfiable-initDelta :: Delta-initDelta = MkDelta initTyState initTmState--instance Outputable Delta where-  ppr delta = hang (text "Delta") 2 $ vcat [-      -- intentionally formatted this way enable the dev to comment in only-      -- the info she needs-      ppr (delta_tm_st delta),-      ppr (delta_ty_st delta)-    ]---- | A disjunctive bag of 'Delta's, representing a refinement type.-newtype Deltas = MkDeltas (Bag Delta)--initDeltas :: Deltas-initDeltas = MkDeltas (unitBag initDelta)--instance Outputable Deltas where-  ppr (MkDeltas deltas) = ppr deltas--instance Semigroup Deltas where-  MkDeltas l <> MkDeltas r = MkDeltas (l `unionBags` r)--liftDeltasM :: Monad m => (Delta -> m (Maybe Delta)) -> Deltas -> m Deltas-liftDeltasM f (MkDeltas ds) = MkDeltas . catBagMaybes <$> (traverse f ds)

− GHC/HsToCore/PmCheck/Types.hs-boot

@@ -1,9 +0,0 @@-module GHC.HsToCore.PmCheck.Types where--import GHC.Data.Bag--data Delta--newtype Deltas = MkDeltas (Bag Delta)--initDeltas :: Deltas

+ GHC/HsToCore/Pmc.hs view

@@ -0,0 +1,512 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE LambdaCase        #-}++-- | 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 "HsVersions.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.Env+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++-- 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) ->+    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+  -- Don't look at is_covered: If it is True, all children are redundant anyway,+  -- unless there is a 'considerAccessible', which may break that rule+  -- intentionally. See Note [considerAccessible] in "GHC.HsToCore.Pmc.Check".+  cirb <- cirbsGRHSs grhss+  pure $ addRedundantBangs red_bangs+       -- See Note [Determining inaccessible clauses]+       $ applyWhen may_diverge ensureOneNotRedundant+       $ 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)) ->+        putSrcSpanDs l (warnDs (Reason Opt_WarnRedundantBangPatterns)+                               (pprEqn q "has redundant bang"))++      when exists_r $ forM_ redundant_rhss $ \(SrcInfo (L l q)) ->+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "is redundant"))+      when exists_i $ forM_ inaccessible_rhss $ \(SrcInfo (L l q)) ->+        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+                     pp_tys = pprQuotedList $ map idType vars+                 in  hang+                       (text "Patterns of type" <+> pp_tys <+> text "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.+-}

+ GHC/HsToCore/Pmc/Check.hs view

@@ -0,0 +1,353 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}++-- | 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 "HsVersions.h"++import GHC.Prelude++import GHC.Builtin.Names ( hasKey, considerAccessibleIdKey, trueDataConKey )+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 }+  -- See point (3) of Note [considerAccessible]+  PmCon x (PmAltConLike con) _ _ _+    | x `hasKey` considerAccessibleIdKey+    , con `hasKey` trueDataConKey+    -> pure CheckResult { cr_ret = emptyRedSets { rs_cov = initNablas }+                        , 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!++Note [considerAccessible]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (T18610)++  f :: Bool -> Int+  f x = case (x, x) of+    (True,  True)  -> 1+    (False, False) -> 2+    (True,  False) -> 3 -- Warning: Redundant++The third case is detected as redundant. But it may be the intent of the+programmer to keep the dead code, in order for it not to bitrot or to support+debugging scenarios. But there is no way to communicate that to the+pattern-match checker! The only way is to deactivate pattern-match checking+whole-sale, which is quite annoying. Hence, we define in "GHC.Exts":++  considerAccessible = True++'considerAccessible' is treated specially by the pattern-match checker in that a+guard with it as the scrutinee expression will keep its parent clause alive:++  g :: Bool -> Int+  g x = case (x, x) of+    (True,  True)  -> 1+    (False, False) -> 2+    (True,  False) | GHC.Exts.considerAccessible -> 3 -- No warning++The key bits of the implementation are:++  1. Its definition is recognised as known-key (see "GHC.Builtin.Names").+  2. After "GHC.HsToCore.Pmc.Desugar", the guard will end up as a 'PmCon', where+     the match var is the known-key 'considerAccessible' and the constructor+     against which it matches is 'True'.+  3. We recognise the 'PmCon' in 'GHC.HsToCore.Check.checkGrd' and inflate the+     incoming set of values for all guards downstream to the unconstrained+     'initNablas' set, e.g. /all/ values.+     (The set of values that falls through that particular guard is empty, as+     matching 'considerAccessible' against 'True' can't fail.)++Note that 'considerAccessible' breaks the invariant that incoming sets of values+reaching syntactic children are subsets of that of the syntactic ancestor:+A whole match, like that of the third clause of the example, might have no+incoming value, but its single RHS has incoming values because of (3).++That means the 'is_covered' flag computed in 'GHC.HsToCore.Pmc.cirbsMatch'+is irrelevant and should not be used to flag all children as redundant (which is+what we used to do).++We achieve great benefits with a very simple implementation.+There are caveats, though:++  (A) Putting potentially failing guards /after/ the+      'considerAccessible' guard might lead to weird check results, e.g.,++        h :: Bool -> Int+        h x = case (x, x) of+          (True,  True)  -> 1+          (False, False) -> 2+          (True,  False) | GHC.Exts.considerAccessible, False <- x -> 3+          -- Warning: Not matched: (_, _)++      That *is* fixable, although we would pay with a much more complicated+      implementation.+  (B) If the programmer puts a 'considerAccessible' marker on an accessible+      clause, the checker doesn't warn about it. E.g.,++        f :: Bool -> Int+        f True | considerAccessible = 0+        f False = 1++      will not emit any warning whatsoever. We could implement code that warns+      here, but it wouldn't be as simple as it is now.+-}

+ GHC/HsToCore/Pmc/Desugar.hs view

@@ -0,0 +1,541 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE LambdaCase        #-}++-- | 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 "HsVersions.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.Builtin.Names (rationalTyConName)+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 (isTrueLHsExpr, selectMatchVar)+import GHC.HsToCore.Match.Literal (dsLit, dsOverLit)+import GHC.HsToCore.Monad+import GHC.Core.TyCo.Rep+import GHC.Core.Type+import GHC.Data.Maybe+import qualified GHC.LanguageExtensions as LangExt+import GHC.Utils.Monad (concatMapM)+import GHC.Types.SourceText (FractionalLit(..))+import Control.Monad (zipWithM)+import Data.List (elemIndex)+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE++-- import GHC.Driver.Ppr++-- | 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 (locA 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+           }+         } ->+    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+    pm_lit <- case olit of+      OverLit{ ol_val = val, ol_ext = OverLitTc rebindable _ }+        | not rebindable+        , Just expr <- shortCutLit platform val ty+        -> coreExprAsPmLit <$> dsExpr expr+        | not rebindable+        , (HsFractional f) <- val+        , negates <- if fl_neg f then 1 else 0+        -> do+            rat_tc <- dsLookupTyCon rationalTyConName+            let rat_ty = mkTyConTy rat_tc+            return $ Just $ PmLit rat_ty (PmLitOverRat negates f)+        | otherwise+        -> do+           dsLit <- dsOverLit olit+           let !pmLit = coreExprAsPmLit dsLit :: Maybe PmLit+          --  pprTraceM "desugarPat"+          --     (+          --       text "val" <+> ppr val $$+          --       text "witness" <+> ppr (ol_witness olit) $$+          --       text "dsLit" <+> ppr dsLit $$+          --       text "asPmLit" <+> ppr pmLit+          --     )+           return pmLit++    let lit = case pm_lit of+          Just l -> l+          Nothing -> pprPanic "failed to detect OverLit" (ppr olit)+    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 (locA 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 (locA 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 :: HsLocalBinds GhcTc -> DsM [PmGrd]+desugarLocalBinds (HsValBinds _ (XValBindsLR (NValBinds binds _))) =+  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'.+-}

+ GHC/HsToCore/Pmc/Ppr.hs view

@@ -0,0 +1,210 @@+{-# LANGUAGE CPP #-}++{-# 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 "HsVersions.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.+pprPmVar :: PprPrec -> Id -> PmPprM SDoc+pprPmVar prec x = do+  nabla <- ask+  case lookupSolution nabla x of+    Just (PACA alt _tvs args) -> pprPmAltCon prec alt args+    Nothing                   -> fromMaybe underscore <$> checkRefuts x++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

+ GHC/HsToCore/Pmc/Solver.hs view

@@ -0,0 +1,1964 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}++{-+Authors: George Karachalias <george.karachalias@cs.kuleuven.be>+         Sebastian Graf <sgraf1337@gmail.com>+         Ryan Scott <ryan.gl.scott@gmail.com>+-}++-- | 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 "HsVersions.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.Misc+import GHC.Utils.Monad (allM)+import GHC.Utils.Panic+import GHC.Data.Bag+import GHC.Types.CompleteMatch+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.Expr+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.Core.TyCon.RecWalk+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim (tYPETyCon)+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst (elemTCvSubst)+import GHC.Core.Type+import GHC.Tc.Solver   (tcNormalise, tcCheckGivens, tcCheckWanteds)+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, filterM)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Strict+import Data.Coerce+import Data.Either   (partitionEithers)+import Data.Foldable (foldlM, minimumBy, toList)+import Data.Monoid   (Any(..))+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', or 'Nothing'+-- if there was no change as per the update function.+updRcm :: (CompleteMatch          -> (Bool, CompleteMatch))+       -> ResidualCompleteMatches -> (Maybe ResidualCompleteMatches)+updRcm f (RCM vanilla pragmas)+  | not any_change = Nothing+  | otherwise      = Just (RCM vanilla' pragmas')+  where+    f' ::  CompleteMatch          -> (Any,  CompleteMatch)+    f' = coerce f+    (chgd, vanilla')  = traverse f' vanilla+    (chgds, pragmas') = traverse (traverse f') pragmas+    any_change        = getAny $ chgd `mappend` chgds++-- | A pseudo-'CompleteMatch' for the vanilla complete set of the given data+-- 'TyCon'.+-- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@+vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch+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 vanillaCompleteMatch . 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 :: PmAltCon -> ResidualCompleteMatches -> DsM (Maybe ResidualCompleteMatches)+-- Nothing means the PmAltCon didn't occur in any COMPLETE set.+-- See Note [Shortcutting the inhabitation test] for how this is useful for+-- performance on T17836.+markMatched (PmAltLit _)      _   = pure Nothing -- lits are never part of a COMPLETE set+markMatched (PmAltConLike cl) rcm = do+  rcm' <- addConLikeMatches cl rcm+  let go cm = case lookupUniqDSet (cmConLikes cm) cl of+        Nothing -> (False, cm)+        Just _  -> (True,  cm { cmConLikes = delOneFromUniqDSet (cmConLikes cm) cl })+  pure $ updRcm go 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 as a set of 'ConLike's. For+example, the pragma {-# COMPLETE F, T #-} would be represented as:++  CompleteMatch {F, T} Nothing++What is the Maybe for? Answer: COMPLETE pragmas may optionally specify a+result *type constructor* (cf. T14422):++  class C f where+    foo :: f a -> ()+  pattern P :: C f => f a+  pattern P <- (foo -> ())++  instance C State where+    foo _ = ()+  {-# COMPLETE P :: State #-}++  f :: State a -> ()+  f P = ()+  g :: C f => f a -> ()+  g P = ()++The @:: State@ here means that the types at which the COMPLETE pragma *applies*+is restricted to scrutinee types that are applications of the 'State' TyCon. So+it applies to the match in @f@ but not in @g@ above, resulting in a warning for+the latter but not for the former. The pragma is represented as++  CompleteMatch {P} (Just State)++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 does not apply if for one of its+ConLikes we fail to 'matchConLikeResTy' or the+type of the match variable isn't an application of the optional+result type constructor from the pragma. Why don't we simply+prune inapplicable COMPLETE sets from 'ResidualCompleteMatches'?+The answer is that additional type constraints might make more+COMPLETE sets applicable! Example:++  h :: a -> a :~: Boolean -> ()+  h 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 @h@ is exhaustive, where the COMPLETE set+applies due to refined type information.+-}++-----------------------+-- * Type normalisation++-- | The return value of 'pmTopNormaliseType'+data TopNormaliseTypeResult+  = 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 (NormalisedByConstraints ty)   = (ty,     [],      ty)+tntrGuts (HadRedexes src_ty ds core_ty) = (src_ty, ds, core_ty)++instance Outputable TopNormaliseTypeResult where+  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].+       typ' <- initTcDsForSolver $ tcNormalise inert 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                -> 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 =+  pmTopNormaliseType ty_st ty >>= \case+    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)+       ; mb_new_inert <- initTcDsForSolver $ tcCheckGivens inert evs+         -- return the new inert set and increment the sequence number n+       ; return (TySt (n+1) <$> mb_new_inert) }++-- | 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+    -- | Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,+    -- otherwise return updated entry and `Just x'` if `x` should be marked dirty,+    -- where `x'` is the representative of `x`.+    go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo)+    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+      mb_rcm' <- lift (markMatched nalt rcm)+      pure $ case mb_rcm' of+        -- If nalt could be removed from a COMPLETE set, we'll get back Just and+        -- have to mark x dirty, by returning Just x'.+        Just rcm' -> (Just x',  vi'{ vi_rcm = rcm' })+        -- Otherwise, nalt didn't occur in any residual COMPLETE set and we+        -- don't have to mark it dirty. So we return Nothing, which in the case+        -- above would have compromised precision.+        -- See Note [Shortcutting the inhabitation test], grep for T17836.+        Nothing   -> (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 =+      lift (varNeedsTesting old_ty_st nabla vi) >>= \case+        True -> do+          -- lift $ tracePm "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.+-- Returns `False` when we can skip the inhabitation test, presuming it would+-- say "yes" anyway. See Note [Shortcutting the inhabitation test].+varNeedsTesting :: TyState -> Nabla -> VarInfo -> DsM Bool+varNeedsTesting _         MkNabla{nabla_tm_st=tm_st}     vi+  | elemDVarSet (vi_id vi) (ts_dirty tm_st) = pure True+varNeedsTesting _         _                              vi+  | notNull (vi_pos vi)                     = pure False+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 CompleteMatchs in vi_rcm.+--+-- NB: Does /not/ filter each CompleteMatch 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 x 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 -> CompleteMatch -> MaybeT DsM Nabla+instCompleteSet fuel nabla x cs+  | anyConLikeSolution (`elementOfUniqDSet` (cmConLikes cs)) (vi_pos vi)+  -- No need to instantiate a constructor of this COMPLETE set if we already+  -- have a solution!+  = pure nabla+  | not (completeMatchAppliesAtType (varType x) cs)+  = pure nabla+  | otherwise+  = go nabla (sorted_candidates cs)+  where+    vi = lookupVarInfo (nabla_tm_st nabla) x++    sorted_candidates :: CompleteMatch -> [ConLike]+    sorted_candidates cm+      -- 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+      where cs = cmConLikes cm++    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::match_ty) K@ tries to instantiate @x@ to @K@ by+-- adding the proper constructor constraint.+--+-- See Note [Instantiating a ConLike].+instCon :: Int -> Nabla -> Id -> ConLike -> MaybeT DsM Nabla+instCon fuel nabla@MkNabla{nabla_ty_st = ty_st} x con = MaybeT $ do+  env <- dsGetFamInstEnvs+  let match_ty = idType x+  norm_match_ty <- normaliseSourceTypeWHNF ty_st match_ty+  mb_sigma_univ <- matchConLikeResTy env ty_st norm_match_ty con+  case mb_sigma_univ of+    Just sigma_univ -> do+      let (_univ_tvs, ex_tvs, eq_spec, thetas, _req_theta, field_tys, _con_res_ty)+            = conLikeFullSig con+      -- Following Note [Instantiating a ConLike]:+      -- (1) _req_theta has been tested in 'matchConLikeResTy'+      -- (2) Instantiate fresh existentials+      (sigma_ex, _) <- cloneTyVarBndrs sigma_univ ex_tvs <$> getUniqueSupplyM+      -- (3) Substitute provided constraints bound by the constructor.+      --     These are added to the type oracle as new facts (in a moment)+      let gammas = substTheta sigma_ex (eqSpecPreds eq_spec ++ thetas)+      -- (4) Instantiate fresh term variables as arguments to the constructor+      let field_tys' = substTys sigma_ex $ map scaledThing field_tys+      arg_ids <- mapM mkPmId field_tys'+      tracePm "instCon" $ vcat+        [ ppr x <+> dcolon <+> ppr match_ty+        , text "In WHNF:" <+> ppr (isSourceTypeInWHNF match_ty) <+> ppr norm_match_ty+        , ppr con <+> dcolon <+> text "... ->" <+> ppr _con_res_ty+        , ppr (map (\tv -> ppr tv <+> char '↦' <+> ppr (substTyVar sigma_univ tv)) _univ_tvs)+        , ppr gammas+        , ppr (map (\x -> ppr x <+> dcolon <+> ppr (idType x)) arg_ids)+        , ppr fuel+        ]+      -- (5) Finally add the new constructor 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) -- Matching against match_ty failed. Inhabited!+                                 -- See Note [Instantiating a ConLike].++-- | @matchConLikeResTy _ _ ty K@ tries to match @ty@ against the result+-- type of @K@, @res_ty@. It returns a substitution @s@ for @K@'s universal+-- tyvars such that @s(res_ty)@ equals @ty@ if successful.+--+-- Make sure that @ty@ is normalised before.+--+-- See Note [Matching against a ConLike result type].+matchConLikeResTy :: FamInstEnvs -> TyState -> Type -> ConLike -> DsM (Maybe TCvSubst)+matchConLikeResTy env _              ty (RealDataCon dc) = pure $ do+  (rep_tc, tc_args, _co) <- splitReprTyConApp_maybe env ty+  if rep_tc == dataConTyCon dc+    then Just (zipTCvSubst (dataConUnivTyVars dc) tc_args)+    else Nothing+matchConLikeResTy _   (TySt _ inert) ty (PatSynCon ps) = runMaybeT $ do+  let (univ_tvs,req_theta,_,_,_,con_res_ty) = patSynSig ps+  subst <- MaybeT $ pure $ tcMatchTy con_res_ty ty+  guard $ all (`elemTCvSubst` subst) univ_tvs -- See the Note about T11336b+  if null req_theta+    then pure subst+    else do+      let req_theta' = substTys subst req_theta+      satisfiable <- lift $ initTcDsForSolver $ tcCheckWanteds inert req_theta'+      if satisfiable+        then pure subst+        else mzero++{- Note [Soundness and completeness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Soundness and completeness of the pattern-match checker depends entirely on the+soundness and completeness of the inhabitation test.++Achieving both soundness and completeness at the same time is undecidable.+See also T17977 and Note [Fuel for the inhabitation test].+Losing soundness would make the algorithm pointless; hence we give up on+completeness, but try to get as close as possible (how close is called+the 'precision' of the algorithm).++Soundness means that you+  1. Can remove clauses flagged as redundant without changing program semantics+     (no false positives).+  2. Can be sure that your program is free of incomplete pattern matches+     when the checker doesn't flag any inexhaustive definitions+     (no false negatives).++A complete algorithm would mean that+  1. When a clause can be deleted without changing program semantics, it will+     be flagged as redundant (no false negatives).+  2. A program that is free of incomplete pattern matches will never have a+     definition be flagged as inexhaustive (no false positives).++Via the LYG algorithm, we reduce both these properties to a property on+the inhabitation test of refinementment types:+  *Soundness*:    If the inhabitation test says "no" for a given refinement type+                  Nabla, then it provably has no inhabitant.+  *Completeness*: If the inhabitation test says "yes" for a given refinement type+                  Nabla, then it provably has an inhabitant.+Our test is sound, but incomplete, so there are instances where we say+"yes" but in fact the Nabla is empty. Which entails false positive exhaustivity+and false negative redundancy warnings, as above.++In summary, we have the following correspondence:++Property     | Exhaustiveness warnings | Redundancy warnings | Inhabitation test |+-------------|-------------------------|---------------------|-------------------|+Soundness    | No false negatives      | No false positives  | Only says "no"    |+             |                         |                     | if there is no    |+             |                         |                     | inhabitant        |+Completeness | No false positives      | No false negatives  | Only says "yes"   |+             |                         |                     | if there is an    |+             |                         |                     | inhabitant        |++Note [Shortcutting the inhabitation test]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally, we have to re-test a refinement type for inhabitants whenever we+add a new constraint. Often, we can say "no" early, upon trying to add a+contradicting constraint, see Note [The Pos/Neg invariant]. Still, COMPLETE+sets and type evidence are best handled in a delayed fashion, because of+the recursive nature of the test and our fuel-based approach.+But even then there are some cases in which we can skip the full test,+because we are sure that the refinement type is still inhabited. These+conditions are monitored by 'varNeedsTesting'. It returns++- `True` whenever a full inhabitation test is needed+- `False` whenever the test can be skipped, amounting to an inhabitation test+  that says "yes".++According to Note [Soundness and Completeness], this test will never compromise+soundness: The `True` case just forwards to the actual inhabitation test and the+`False` case amounts to an inhabitation test that is trivially sound, because it+never says "no".++Of course, if the returns says `False`, Completeness (and thus Precision) of the+algorithm is affected, but we get to skip costly inhabitation tests. We try to+trade as little Precision as possible against as much Performance as possible.+Here are the tests, in order:++  1. If a variable is dirty (because of a newly added negative term constraint),+     we have to test.+  2. If a variable has positive information, we don't have to test: The+     positive information acts as constructive proof for inhabitation.+  3. If the type state didn't change, there is no need to test.+  4. If the variable's normalised type didn't change, there is no need to test.+  5. Otherwise, we have to test.++Why (1) before (2)?+-------------------+Consider the reverse for (T18960):+  pattern P x = x+  {-# COMPLETE P :: () #-}+  foo = case () of x@(P _) -> ()+This should be exhaustive. But if we say "We know `x` has solution `()`, so it's+inhabited", then we'll get a warning saying that `()` wasn't matched.+But the match on `P` added the new negative information to the uncovered set,+in the process of which we marked `x` as dirty. By giving the dirty flag a+higher priority than positive info, we get to test again and see that `x` is+uninhabited and the match is exhaustive.++But suppose that `P` wasn't mentioned in any COMPLETE set. Then we simply+don't mark `x` as dirty and will emit a warning again (which we would anyway),+without running a superfluous inhabitation test. That speeds up T17836+considerably.++Why (2) before (3) and (4)?+---------------------------+Simply because (2) is more efficient to test than (3) (not by a lot), which+is more efficient to test than (4), which is still more efficient than running+the full inhabitation test (5).++Note [Fuel for the inhabitation test]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whether or not a type is inhabited is undecidable in general, see also+Note [Soundness and Completeness]. 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.++Note [Matching against a ConLike result type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a ConLike++> C :: forall us. R => ... -> res_ty++is a pattern `C ...` compatible with the type `ty`? Clearly that is the case if+`res_ty` /subsumes/ `ty` and the required constraints `R` (strictly a feature of+pattern synonyms) are satisfiable. In that case, 'matchConLikeResTy' returns a+substitution σ over `us` such that `σ(res_ty) == ty`.++It's surprisingly tricky to implement correctly, and works quite different for+DataCons and PatSynCons:++  * For data cons, we look at `ty` and see if it's a TyCon app `T t1 ... tn`.+    If that is the case, we make sure that `C` is a DataCon of `T` and return+    a substitution mapping `C`'s universal tyvars `us` to `t1`...`tn`.++    Wrinkle: Since `T` might be a data family TyCon, we have to look up its+    representation TyCon before we compare to `C`'s TyCon.+    So we use 'splitReprTyConApp_maybe' instead of 'splitTyConApp_maybe'.++  * For pattern synonyms, we directly match `ty` against `res_ty` to get the+    substitution σ. See Note [Pattern synonym result type] in "GHC.Core.PatSyn".++    Fortunately, we don't have to treat data family TyCons specially:+    Pattern synonyms /never/ apply to a data family representation TyCon.+    We do have to consider the required constraints `σ(R)`, though, as we have+    seen in #19475. That is done by solving them as Wanted constraints given the+    inert set of the current type state (which is part of a Nabla's TySt). Since+    spinning up a constraint solver session is costly, we only do so in the rare+    cases that a pattern synonym actually carries any required constraints.++    We can get into the strange situation that not all universal type variables+    `us` occur in `res_ty`. Example from T11336b:++      instance C Proxy where ...                      -- impl uninteresting+      pattern P :: forall f a. C f => f a -> Proxy a  -- impl uninteresting++      fun :: Proxy a -> ()+      fun (P Proxy) = ()+      fun (P Proxy) = () -- ideally detected as redundant++    `f` is a universal type variable and `C f` the required constraint of+    pattern synonym `P`. But `f` doesn't occur in the result type `Proxy a` of+    `P`, so σ will not even have `f` in its in-scope set. It's a bit unclear+    what to do here; we might want to freshen `f` to `f'` and see if we can+    solve `C f'` as a Wanted constraint, which we most likely can't.+    Hence, we simply skip the freshening and declare the match as failed when+    there is a variable like `f`. For the definition of `fun`, that+    means we will not remember that we matched on `P` and thus will+    not detect its second clause as redundant.++    See Note [Pattern synonym result type] in "GHC.Core.PatSyn" for similar+    oddities.++Note [Instantiating a ConLike]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`instCon` implements the the \(Inst\) function from Figure 8 of the LYG paper.++Given the following type of ConLike `K`++> K :: forall us. R => forall es. P => t1 -> ... -> tn -> res_ty++and a variable `x::match_ty`, it tries to find an instantiation+`K ex_tvs gammas arg_ids :: match_ty` (for fresh `arg_ids`) and ultimately adds+a constructor constraint `K ex_tvs gammas arg_ids <- x` to the given Nabla.++As a first step, it tries (via 'matchConLikeResTy') to match `match_ty` against+`res_ty` and checks that that the required constraints @R@ are satisfiable.+See Note [Matching against a ConLike result type].++If matching /fails/, it trivially (and conservatively) reports "inhabited" by+returning the unrefined input Nabla. After all, the match might have failed due+to incomplete type information in Nabla.+(Type refinement from unpacking GADT constructors might monomorphise `match_ty`+so much that `res_ty` ultimately subsumes it.)++If matching /succeeds/, we get a substitution σ for the (universal)+tyvars `us`. After applying σ, we get++> K @σ(us) :: σ(R) => forall σ(es). σ(P) => σ(t1) -> ... -> σ(tn) -> match_ty++The existentials `es` might still occur in argument types `σ(tn)`, though.+Now 'instCon' performs the following steps:++ 1. It drops the required constraints `σ(R)`, as they have already been+    discharged by 'matchConLikeResTy'.+ 2. It instantiates fresh binders `es'` for the other type variables `es`+    bound by `K` and adds the mapping to σ to get σ', so that we have++    > K @σ(us) @es' :: σ'(P) => σ'(t1) -> ... -> σ'(tn) -> match_ty++ 3. It adds new type constraints from the substituted+    provided constraints @σ'(P)@.+ 4. It substitutes and conjures new binders @arg_ids@ for the argument types+    @σ'(t1) ... σ'(tn)@.+ 5. It adds a term constraint @K es' σ'(P) arg_ids <- x@, which handles+    the details regarding type constraints and unlifted fields.++And finally the extended 'Nabla' is returned if all the constraints were+compatible.+-}++--------------------------------------+-- * 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 (nabla_ty_st nabla) rep_ty rcm+          case NE.nonEmpty (uniqDSetToList . cmConLikes <$> 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 :: TyState -> Type -> ResidualCompleteMatches -> DsM [CompleteMatch]+-- See Note [Implementation of COMPLETE pragmas] on what "applicable" means+pickApplicableCompleteSets ty_st ty rcm = do+  let cl_res_ty_ok :: ConLike -> DsM Bool+      cl_res_ty_ok cl = do+        env <- dsGetFamInstEnvs+        isJust <$> matchConLikeResTy env ty_st ty cl+  let cm_applicable :: CompleteMatch -> DsM Bool+      cm_applicable cm = do+        cls_ok <- allM cl_res_ty_ok (uniqDSetToList (cmConLikes cm))+        let match_ty_ok = completeMatchAppliesAtType ty cm+        pure (cls_ok && match_ty_ok)+  applicable_cms <- filterM cm_applicable (getRcm rcm)+  tracePm "pickApplicableCompleteSets:" $+    vcat+      [ ppr ty+      , ppr rcm+      , ppr applicable_cms+      ]+  return applicable_cms++{- 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.+-}

+ GHC/HsToCore/Pmc/Solver/Types.hs view

@@ -0,0 +1,703 @@+{-# LANGUAGE ApplicativeDo       #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | 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+        CompleteMatch, 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 "HsVersions.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.Expr+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.Types.CompleteMatch (CompleteMatch(..))+import GHC.Types.SourceText (SourceText(..), mkFractionalLit, FractionalLit+                            , fractionalLitFromRational+                            , FractionalExponentBase(..))+import Numeric (fromRat)+import Data.Foldable (find)+import Data.Ratio+import GHC.Real (Ratio(..))+import qualified Data.Semigroup as Semi++-- import GHC.Driver.Ppr++--+-- * 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 they need+      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 CompleteMatch)+  -- ^ 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 [CompleteMatch])+  -- ^ 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 -> [CompleteMatch]+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? -} FractionalLit+  | 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 !(UniqDSet ConLike) ![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 $! fractionalLitFromRational r+    go (PmLitString s)+      | ty `eqType` stringTy = Just v+      | otherwise            = Just (PmLitOverString s)+    go ovRat@PmLitOverRat{}  = Just ovRat+    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]+    -- fromRational <expr>+    | is_rebound_name x fromRationalName+    , [r] <- dropWhile (not . is_ratio) args+    -> coreExprAsPmLit r >>= overloadPmLit (exprType e)++  --Rationals with large exponents+  (Var x, args)+    -- See Note [Detecting overloaded literals with -XRebindableSyntax]+    -- See Note [Dealing with rationals with large exponents]+    -- mkRationalBase* <rational> <exponent>+    | Just exp_base <- is_larg_exp_ratio x+    , [r, Lit exp] <- dropWhile (not . is_ratio) args+    , (Var x, [_ty, Lit n, Lit d]) <- collectArgs r+    , Just dc <- isDataConWorkId_maybe x+    , dataConName dc == ratioDataConName+    -> do+      n' <- isLitValue_maybe n+      d' <- isLitValue_maybe d+      exp' <- isLitValue_maybe exp+      let rational = (abs n') :% d'+      let neg = if n' < 0 then 1 else 0+      let frac = mkFractionalLit NoSourceText False rational exp' exp_base+      Just $ PmLit (exprType e) (PmLitOverRat neg frac)++  (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+    is_larg_exp_ratio x+      | is_rebound_name x mkRationalBase10Name+      = Just Base10+      | is_rebound_name x mkRationalBase2Name+      = Just Base2+      | otherwise+      = Nothing+++    -- 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`).++Note [Dealing with rationals with large exponents]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Rationals with large exponents are *not* desugared to+a simple rational. As that would require us to compute+their value which can be expensive. Rather they desugar+to an expression. For example 1e1000 will desugar to an+expression of the form: `mkRationalWithExponentBase10 (1 :% 1) 1000`++Only overloaded literals desugar to this form however, so we+we can just return a overloaded rational literal.++The most complex case is if we have RebindableSyntax enabled.+By example if we have a pattern like this: `f 3.3 = True`++It will desugar to:+  fromRational+    [TYPE: Rational, mkRationalBase10 (:% @Integer 10 1) (-1)]++The fromRational is properly detected as an overloaded Rational by+coreExprAsPmLit and it's general code for detecting overloaded rationals.+See Note [Detecting overloaded literals with -XRebindableSyntax].++This case then recurses into coreExprAsPmLit passing only the expression+`mkRationalBase10 (:% @Integer 10 1) (-1)`. Which is caught by rationals+with large exponents case. This will return a `PmLitOverRat` literal.++Which is then passed to overloadPmLit which simply returns it as-is since+it's already overloaded.++-}++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 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

+ GHC/HsToCore/Pmc/Types.hs view

@@ -0,0 +1,240 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}++{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>+        Sebastian Graf <sgraf1337@gmail.com>+-}++-- | 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 "HsVersions.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

+ GHC/HsToCore/Pmc/Utils.hs view

@@ -0,0 +1,148 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Utility module for the pattern-match coverage checker.+module GHC.HsToCore.Pmc.Utils (++        tracePm, mkPmId,+        allPmCheckWarnings, overlapping, exhaustive, redundantBang,+        exhaustiveWarningFlag,+        isMatchContextPmChecked, needToRunPmCheck++    ) where++#include "HsVersions.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.Misc+import GHC.Utils.Outputable+import GHC.Utils.Logger+import GHC.HsToCore.Monad++tracePm :: String -> SDoc -> DsM ()+tracePm herald doc = do+  dflags <- getDynFlags+  logger <- getLogger+  printer <- mkPrintUnqualifiedDs+  liftIO $ dumpIfSet_dyn_printer printer logger 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 (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c+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++arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag+arrowMatchContextExhaustiveWarningFlag = \ case+  ProcExpr     -> Just Opt_WarnIncompleteUniPatterns+  ArrowCaseAlt -> Just Opt_WarnIncompletePatterns+  KappaExpr    -> Just Opt_WarnIncompleteUniPatterns++-- | 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.+-}

GHC/HsToCore/Quote.hs view

@@ -1,15 +1,14 @@-{-# LANGUAGE CPP, TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE AllowAmbiguousTypes    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE UndecidableInstances   #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -35,56 +34,68 @@ import GHC.Prelude import GHC.Platform -import {-# SOURCE #-}   GHC.HsToCore.Expr ( dsExpr )+import GHC.Driver.Session +import {-# SOURCE #-} GHC.HsToCore.Expr ( dsExpr ) import GHC.HsToCore.Match.Literal import GHC.HsToCore.Monad+import GHC.HsToCore.Binds  import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Syntax as TH  import GHC.Hs-import GHC.Builtin.Names -import GHC.Unit.Module-import GHC.Types.Id-import GHC.Types.Name hiding( varName, tcName )-import GHC.Builtin.Names.TH-import GHC.Types.Name.Env import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Evidence++import GHC.Core.Class+import GHC.Core.DataCon import GHC.Core.TyCon-import GHC.Builtin.Types import GHC.Core.Multiplicity ( pattern Many ) import GHC.Core import GHC.Core.Make import GHC.Core.Utils-import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Unique-import GHC.Types.Basic++import GHC.Builtin.Names+import GHC.Builtin.Names.TH+import GHC.Builtin.Types++import GHC.Unit.Module+ import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Monad+ import GHC.Data.Bag-import GHC.Driver.Session import GHC.Data.FastString-import GHC.Types.ForeignCall-import GHC.Utils.Misc import GHC.Data.Maybe-import GHC.Utils.Monad-import GHC.Tc.Types.Evidence-import Control.Monad.Trans.Reader-import Control.Monad.Trans.Class-import GHC.Core.Class-import GHC.Driver.Types ( MonadThings )-import GHC.Core.DataCon++import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Unique+import GHC.Types.Basic+import GHC.Types.ForeignCall import GHC.Types.Var-import GHC.HsToCore.Binds+import GHC.Types.Id+import GHC.Types.SourceText+import GHC.Types.Fixity+import GHC.Types.TyThing+import GHC.Types.Name hiding( varName, tcName )+import GHC.Types.Name.Env  import GHC.TypeLits import Data.Kind (Constraint) +import qualified GHC.LanguageExtensions as LangExt+ import Data.ByteString ( unpack ) import Control.Monad-import Data.List+import Data.List (sort, sortBy)+import Data.List.NonEmpty ( NonEmpty(..) ) import Data.Function+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class  data MetaWrappers = MetaWrappers {       -- Applies its argument to a type argument `m` and dictionary `Quote m`@@ -170,7 +181,7 @@     new_bit = mkNameEnv [(n, DsSplice (unLoc e))                         | PendingTcSplice n e <- splices] -    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM n ; return e1 }+    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOccDsM (unLoc n) ; return e1 }     do_brack (ExpBr _ e)   = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }     do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }     do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }@@ -257,7 +268,7 @@ data M a  repTopP :: LPat GhcRn -> MetaM (Core (M TH.Pat))-repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)+repTopP pat = do { ss <- mkGenSyms (collectPatBinders CollNoDictBinders pat)                  ; pat' <- addBinds ss (repLP pat)                  ; wrapGenSyms ss pat' } @@ -275,7 +286,7 @@                         , hs_docs    = docs })  = do { let { bndrs  = hsScopedTvBinders valds                        ++ hsGroupBinders group-                       ++ hsPatSynSelectors valds+                       ++ map extFieldOcc (hsPatSynSelectors valds)             ; instds = tyclds >>= group_instds } ;         ss <- mkGenSyms bndrs ; @@ -321,15 +332,15 @@       }   where     no_splice (L loc _)-      = notHandledL loc "Splices within declaration brackets" empty+      = notHandledL (locA loc) "Splices within declaration brackets" empty     no_default_decl (L loc decl)-      = notHandledL loc "Default declarations" (ppr decl)+      = notHandledL (locA loc) "Default declarations" (ppr decl)     no_warn :: LWarnDecl GhcRn -> MetaM a     no_warn (L loc (Warning _ thing _))-      = notHandledL loc "WARNING and DEPRECATION pragmas" $+      = notHandledL (locA loc) "WARNING and DEPRECATION pragmas" $                     text "Pragma for declaration of" <+> ppr thing     no_doc (L loc _)-      = notHandledL loc "Haddock documentation" empty+      = notHandledL (locA loc) "Haddock documentation" empty  hsScopedTvBinders :: HsValBinds GhcRn -> [Name] -- See Note [Scoped type variables in quotes]@@ -352,7 +363,6 @@   = []  get_scoped_tvs_from_sig :: LHsSigType GhcRn -> [Name]-get_scoped_tvs_from_sig sig   -- Collect both implicit and explicit quantified variables, since   -- the types in instance heads, as well as `via` types in DerivingVia, can   -- bring implicitly quantified type variables into scope, e.g.,@@ -361,10 +371,8 @@   --     m = n @a   --   -- See also Note [Scoped type variables in quotes]-  | HsIB { hsib_ext = implicit_vars-         , hsib_body = hs_ty } <- sig-  , (explicit_vars, _) <- splitLHsForAllTyInvis hs_ty-  = implicit_vars ++ hsLTyVarNames explicit_vars+get_scoped_tvs_from_sig (L _ (HsSig{sig_bndrs = outer_bndrs})) =+  hsOuterTyVarNames outer_bndrs  {- Notes @@ -459,7 +467,7 @@   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->                 repSynDecl tc1 bndrs rhs-       ; return (Just (loc, dec)) }+       ; return (Just (locA loc, dec)) }  repTyClD (L loc (DataDecl { tcdLName = tc                           , tcdTyVars = tvs@@ -467,7 +475,7 @@   = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]        ; dec <- addTyClTyVarBinds tvs $ \bndrs ->                 repDataDefn tc1 (Left bndrs) defn-       ; return (Just (loc, dec)) }+       ; return (Just (locA loc, dec)) }  repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,                              tcdTyVars = tvs, tcdFDs = fds,@@ -484,7 +492,7 @@               ; decls1 <- repListM decTyConName return (ats1 ++ atds1 ++ sigs_binds)               ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1               ; wrapGenSyms ss decls2 }-       ; return $ Just (loc, dec)+       ; return $ Just (locA loc, dec)        }  -------------------------@@ -494,13 +502,17 @@        ; roles1 <- mapM repRole roles        ; roles2 <- coreList roleTyConName roles1        ; dec <- repRoleAnnotD tycon1 roles2-       ; return (loc, dec) }+       ; return (locA loc, dec) }  ------------------------- repKiSigD :: LStandaloneKindSig GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repKiSigD (L loc kisig) =   case kisig of-    StandaloneKindSig _ v ki -> rep_ty_sig kiSigDName loc ki v+    StandaloneKindSig _ v ki -> do+      MkC th_v  <- lookupLOcc v+      MkC th_ki <- repHsSigType ki+      dec       <- rep2 kiSigDName [th_v, th_ki]+      pure (locA loc, dec)  ------------------------- repDataDefn :: Core TH.Name@@ -568,7 +580,7 @@              DataFamily ->                do { kind <- repFamilyResultSigToMaybeKind resultSig                   ; repDataFamilyD tc1 bndrs kind }-       ; return (loc, dec)+       ; return (locA loc, dec)        }  -- | Represent result signature of a type family@@ -585,9 +597,9 @@ repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn                               -> MetaM (Core (Maybe (M TH.Kind))) repFamilyResultSigToMaybeKind (NoSig _) =-    do { coreNothingM kindTyConName }+    coreNothingM kindTyConName repFamilyResultSigToMaybeKind (KindSig _ ki) =-    do { coreJustM kindTyConName =<< repLTy ki }+    coreJustM kindTyConName =<< repLTy ki repFamilyResultSigToMaybeKind TyVarSig{} =     panic "repFamilyResultSigToMaybeKind: unexpected TyVarSig" @@ -595,8 +607,8 @@ repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)                   -> MetaM (Core (Maybe TH.InjectivityAnn)) repInjectivityAnn Nothing =-    do { coreNothing injAnnTyConName }-repInjectivityAnn (Just (L _ (InjectivityAnn lhs rhs))) =+    coreNothing injAnnTyConName+repInjectivityAnn (Just (L _ (InjectivityAnn _ lhs rhs))) =     do { lhs'   <- lookupBinder (unLoc lhs)        ; rhs1   <- mapM (lookupBinder . unLoc) rhs        ; rhs2   <- coreList nameTyConName rhs1@@ -616,7 +628,7 @@ repLFunDeps fds = repList funDepTyConName repLFunDep fds  repLFunDep :: LHsFunDep GhcRn -> MetaM (Core TH.FunDep)-repLFunDep (L _ (xs, ys))+repLFunDep (L _ (FunDep _ xs ys))    = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs         ys' <- repList nameTyConName (lookupBinder . unLoc) ys         repFunDep xs' ys'@@ -626,13 +638,13 @@ repInstD :: LInstDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repInstD (L loc (TyFamInstD { tfid_inst = fi_decl }))   = do { dec <- repTyFamInstD fi_decl-       ; return (loc, dec) }+       ; return (locA loc, dec) } repInstD (L loc (DataFamInstD { dfid_inst = fi_decl }))   = do { dec <- repDataFamInstD fi_decl-       ; return (loc, dec) }+       ; return (locA loc, dec) } repInstD (L loc (ClsInstD { cid_inst = cls_decl }))   = do { dec <- repClsInstD cls_decl-       ; return (loc, dec) }+       ; return (locA loc, dec) }  repClsInstD :: ClsInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds@@ -671,7 +683,7 @@                 do { cxt'     <- repLContext cxt                    ; inst_ty' <- repLTy inst_ty                    ; repDeriv strat' cxt' inst_ty' }-       ; return (loc, dec) }+       ; return (locA loc, dec) }   where     (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty) @@ -681,27 +693,21 @@        ; repTySynInst eqn1 }  repTyFamEqn :: TyFamInstEqn GhcRn -> MetaM (Core (M TH.TySynEqn))-repTyFamEqn (HsIB { hsib_ext = var_names-                  , hsib_body = FamEqn { feqn_tycon = tc_name-                                       , feqn_bndrs = mb_bndrs-                                       , feqn_pats = tys-                                       , feqn_fixity = fixity-                                       , feqn_rhs  = rhs }})+repTyFamEqn (FamEqn { feqn_tycon = tc_name+                    , feqn_bndrs = outer_bndrs+                    , feqn_pats = tys+                    , feqn_fixity = fixity+                    , feqn_rhs  = rhs })   = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = var_names-                             , hsq_explicit = fromMaybe [] mb_bndrs }-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName-                                        repTyVarBndr-                                        mb_bndrs-            ; tys1 <- case fixity of+       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->+         do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys                         Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys                                      ; t1' <- repLTy t1                                      ; t2'  <- repLTy t2                                      ; repTyArgs (repTInfix t1' tc t2') args }             ; rhs1 <- repLTy rhs-            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }+            ; repTySynEqn mb_exp_bndrs tys1 rhs1 } }      where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]            checkTys tys@(HsValArg _:HsValArg _:_) = return tys            checkTys _ = panic "repTyFamEqn:checkTys"@@ -718,32 +724,26 @@  repDataFamInstD :: DataFamInstDecl GhcRn -> MetaM (Core (M TH.Dec)) repDataFamInstD (DataFamInstDecl { dfid_eqn =-                  (HsIB { hsib_ext = var_names-                        , hsib_body = FamEqn { feqn_tycon = tc_name-                                             , feqn_bndrs = mb_bndrs+                                      FamEqn { feqn_tycon = tc_name+                                             , feqn_bndrs = outer_bndrs                                              , feqn_pats  = tys                                              , feqn_fixity = fixity-                                             , feqn_rhs   = defn }})})+                                             , feqn_rhs   = defn }})   = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]-       ; let hs_tvs = HsQTvs { hsq_ext = var_names-                             , hsq_explicit = fromMaybe [] mb_bndrs }-       ; addTyClTyVarBinds hs_tvs $ \ _ ->-         do { mb_bndrs1 <- repMaybeListM tyVarBndrUnitTyConName-                                        repTyVarBndr-                                        mb_bndrs-            ; tys1 <- case fixity of+       ; addHsOuterFamEqnTyVarBinds outer_bndrs $ \mb_exp_bndrs ->+         do { tys1 <- case fixity of                         Prefix -> repTyArgs (repNamedTyCon tc) tys                         Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys                                      ; t1' <- repLTy t1                                      ; t2'  <- repLTy t2                                      ; repTyArgs (repTInfix t1' tc t2') args }-            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }+            ; repDataDefn tc (Right (mb_exp_bndrs, tys1)) defn } }        where checkTys :: [LHsTypeArg GhcRn] -> MetaM [LHsTypeArg GhcRn]             checkTys tys@(HsValArg _: HsValArg _: _) = return tys             checkTys _ = panic "repDataFamInstD:checkTys" -repForD :: Located (ForeignDecl GhcRn) -> MetaM (SrcSpan, Core (M TH.Dec))+repForD :: LForeignDecl GhcRn -> MetaM (SrcSpan, Core (M TH.Dec)) repForD (L loc (ForeignImport { fd_name = name, fd_sig_ty = typ                                   , fd_fi = CImport (L _ cc)                                                     (L _ s) mch cis _ }))@@ -754,7 +754,7 @@       cis' <- conv_cimportspec cis       MkC str <- coreStringLit (static ++ chStr ++ cis')       dec <- rep2 forImpDName [cc', s', str, name', typ']-      return (loc, dec)+      return (locA loc, dec)  where     conv_cimportspec (CLabel cls)       = notHandled "Foreign label" (doubleQuotes (ppr cls))@@ -787,7 +787,7 @@ repSafety PlaySafe = rep2_nw safeName []  repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]-repLFixD (L loc fix_sig) = rep_fix_d loc fix_sig+repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig  rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_fix_d loc (FixitySig _ names (Fixity _ prec dir))@@ -826,7 +826,7 @@                          ; rhs' <- repLE rhs                          ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }            ; wrapGenSyms ss rule  }-       ; return (loc, rule) }+       ; return (locA loc, rule) }  ruleBndrNames :: LRuleBndr GhcRn -> [Name] ruleBndrNames (L _ (RuleBndr _ n))      = [unLoc n]@@ -836,10 +836,10 @@  repRuleBndr :: LRuleBndr GhcRn -> MetaM (Core (M TH.RuleBndr)) repRuleBndr (L _ (RuleBndr _ n))-  = do { MkC n' <- lookupLBinder n+  = do { MkC n' <- lookupNBinder n        ; rep2 ruleVarName [n'] } repRuleBndr (L _ (RuleBndrSig _ n sig))-  = do { MkC n'  <- lookupLBinder n+  = do { MkC n'  <- lookupNBinder n        ; MkC ty' <- repLTy (hsPatSigType sig)        ; rep2 typedRuleVarName [n', ty'] } @@ -848,14 +848,17 @@   = do { target <- repAnnProv ann_prov        ; exp'   <- repE exp        ; dec    <- repPragAnn target exp'-       ; return (loc, dec) }+       ; return (locA loc, dec) } -repAnnProv :: AnnProvenance Name -> MetaM (Core TH.AnnTarget)-repAnnProv (ValueAnnProvenance (L _ n))-  = do { MkC n' <- lift $ globalVar n  -- ANNs are allowed only at top-level+repAnnProv :: AnnProvenance GhcRn -> MetaM (Core TH.AnnTarget)+repAnnProv (ValueAnnProvenance n)+  = do { -- An ANN references an identifier bound elsewhere in the module, so+         -- we must look it up using lookupLOcc (#19377).+         -- Similarly for TypeAnnProvenance (`ANN type`) below.+         MkC n' <- lookupLOcc n        ; rep2_nw valueAnnotationName [ n' ] }-repAnnProv (TypeAnnProvenance (L _ n))-  = do { MkC n' <- lift $ globalVar n+repAnnProv (TypeAnnProvenance n)+  = do { MkC n' <- lookupLOcc n        ; rep2_nw typeAnnotationName [ n' ] } repAnnProv ModuleAnnProvenance   = rep2_nw moduleAnnotationName []@@ -866,45 +869,46 @@  repC :: LConDecl GhcRn -> MetaM (Core (M TH.Con)) repC (L _ (ConDeclH98 { con_name   = con-                      , con_forall = (L _ False)+                      , con_forall = False                       , con_mb_cxt = Nothing                       , con_args   = args }))-  = repDataCon con args+  = repH98DataCon con args  repC (L _ (ConDeclH98 { con_name = con-                      , con_forall = L _ is_existential+                      , con_forall = is_existential                       , con_ex_tvs = con_tvs                       , con_mb_cxt = mcxt                       , con_args = args }))-  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->-         do { c'    <- repDataCon con args+  = addHsTyVarBinds con_tvs $ \ ex_bndrs ->+         do { c'    <- repH98DataCon con args             ; ctxt' <- repMbContext mcxt             ; if not is_existential && isNothing mcxt               then return c'               else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])             }-       } -repC (L _ (ConDeclGADT { con_g_ext  = imp_tvs-                       , con_names  = cons-                       , con_qvars  = exp_tvs+repC (L _ (ConDeclGADT { con_names  = cons+                       , con_bndrs  = L _ outer_bndrs                        , con_mb_cxt = mcxt-                       , con_args   = args+                       , con_g_args = args                        , con_res_ty = res_ty }))-  | null imp_tvs && null exp_tvs -- No implicit or explicit variables+  | null_outer_imp_tvs && null_outer_exp_tvs+                                 -- No implicit or explicit variables   , Nothing <- mcxt              -- No context                                  -- ==> no need for a forall   = repGadtDataCons cons args res_ty    | otherwise-  = addTyVarBinds exp_tvs imp_tvs $ \ ex_bndrs ->+  = addHsOuterSigTyVarBinds outer_bndrs $ \ outer_bndrs' ->              -- See Note [Don't quantify implicit type variables in quotes]     do { c'    <- repGadtDataCons cons args res_ty        ; ctxt' <- repMbContext mcxt-       ; if null exp_tvs && isNothing mcxt+       ; if null_outer_exp_tvs && isNothing mcxt          then return c'-         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }-+         else rep2 forallCName ([unC outer_bndrs', unC ctxt', unC c']) }+  where+    null_outer_imp_tvs = nullOuterImplicit outer_bndrs+    null_outer_exp_tvs = nullOuterExplicit outer_bndrs  repMbContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt)) repMbContext Nothing          = repContext []@@ -937,21 +941,26 @@ -------------------------------------------------------  repDerivs :: HsDeriving GhcRn -> MetaM (Core [M TH.DerivClause])-repDerivs (L _ clauses)+repDerivs clauses   = repListM derivClauseTyConName repDerivClause clauses  repDerivClause :: LHsDerivingClause GhcRn                -> 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 repHsSigType+ rep_meth_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn                     -> MetaM ([GenSymBind], [Core (M TH.Dec)]) -- Represent signatures and methods in class/instance declarations.@@ -978,22 +987,22 @@  rep_sig :: LSig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_sig (L loc (TypeSig _ nms ty))-  = mapM (rep_wc_ty_sig sigDName loc ty) nms+  = mapM (rep_wc_ty_sig sigDName (locA loc) ty) nms rep_sig (L loc (PatSynSig _ nms ty))-  = mapM (rep_patsyn_ty_sig loc ty) nms+  = mapM (rep_patsyn_ty_sig (locA loc) ty) nms rep_sig (L loc (ClassOpSig _ is_deflt nms ty))-  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms-  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms+  | is_deflt     = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms+  | otherwise    = mapM (rep_ty_sig sigDName (locA loc) ty) nms rep_sig d@(L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)-rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d loc fix_sig-rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc+rep_sig (L loc (FixSig _ fix_sig))   = rep_fix_d (locA loc) fix_sig+rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec))-  = concatMapM (\t -> rep_specialise nm t ispec loc) tys-rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc+  = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys+rep_sig (L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty (locA loc) rep_sig (L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty rep_sig (L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _ _st cls mty))-  = rep_complete_sig cls mty loc+  = rep_complete_sig cls mty (locA loc)  -- Desugar the explicit type variable binders in an 'LHsSigType', making -- sure not to gensym them.@@ -1002,18 +1011,25 @@ rep_ty_sig_tvs :: [LHsTyVarBndr Specificity GhcRn]                -> MetaM (Core [M TH.TyVarBndrSpec]) rep_ty_sig_tvs explicit_tvs-  = let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)-                                ; repTyVarBndrWithKind tv name } in-    repListM tyVarBndrSpecTyConName rep_in_scope_tv+  = repListM tyVarBndrSpecTyConName repTyVarBndr              explicit_tvs-         -- NB: Don't pass any implicit type variables to repList above-         -- See Note [Don't quantify implicit type variables in quotes] +-- Desugar the outer type variable binders in an 'LHsSigType', making+-- sure not to gensym them.+-- See Note [Scoped type variables in quotes]+-- and Note [Don't quantify implicit type variables in quotes]+rep_ty_sig_outer_tvs :: HsOuterSigTyVarBndrs GhcRn+                     -> MetaM (Core [M TH.TyVarBndrSpec])+rep_ty_sig_outer_tvs (HsOuterImplicit{}) =+  coreListM tyVarBndrSpecTyConName []+rep_ty_sig_outer_tvs (HsOuterExplicit{hso_bndrs = explicit_tvs}) =+  rep_ty_sig_tvs explicit_tvs+ -- Desugar a top-level type signature. Unlike 'repHsSigType', this -- deliberately avoids gensymming the type variables. -- See Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes]-rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name+rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> LocatedN Name            -> MetaM (SrcSpan, Core (M TH.Dec)) rep_ty_sig mk_sig loc sig_ty nm   = do { nm1 <- lookupLOcc nm@@ -1027,17 +1043,16 @@ -- and Note [Don't quantify implicit type variables in quotes] rep_ty_sig' :: LHsSigType GhcRn             -> MetaM (Core (M TH.Type))-rep_ty_sig' sig_ty-  | HsIB { hsib_body = hs_ty } <- sig_ty-  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis hs_ty-  = do { th_explicit_tvs <- rep_ty_sig_tvs explicit_tvs+rep_ty_sig' (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))+  | (ctxt, tau) <- splitLHsQualTy body+  = do { th_explicit_tvs <- rep_ty_sig_outer_tvs outer_bndrs        ; th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; if null explicit_tvs && null (unLoc ctxt)-            then return th_ty-            else repTForall th_explicit_tvs th_ctxt th_ty }+       ; th_tau  <- repLTy tau+       ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt)+            then return th_tau+            else repTForall th_explicit_tvs th_ctxt th_tau } -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name+rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> LocatedN Name                   -> MetaM (SrcSpan, Core (M TH.Dec)) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in "GHC.ThToHs"@@ -1046,8 +1061,7 @@ -- see Note [Scoped type variables in quotes] -- and Note [Don't quantify implicit type variables in quotes] rep_patsyn_ty_sig loc sig_ty nm-  | HsIB { hsib_body = hs_ty } <- sig_ty-  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty+  | (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy sig_ty   = do { nm1 <- lookupLOcc nm        ; th_univs <- rep_ty_sig_tvs univs        ; th_exis  <- rep_ty_sig_tvs exis@@ -1060,12 +1074,12 @@        ; sig      <- repProto patSynSigDName nm1 ty1        ; return (loc, sig) } -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name+rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> LocatedN Name               -> MetaM (SrcSpan, Core (M TH.Dec)) rep_wc_ty_sig mk_sig loc sig_ty nm   = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm -rep_inline :: Located Name+rep_inline :: LocatedN Name            -> InlinePragma      -- Never defaultInlinePragma            -> SrcSpan            -> MetaM [(SrcSpan, Core (M TH.Dec))]@@ -1078,7 +1092,7 @@        ; return [(loc, pragma)]        } -rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma+rep_specialise :: LocatedN Name -> LHsSigType GhcRn -> InlinePragma                -> SrcSpan                -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_specialise nm ty ispec loc@@ -1103,10 +1117,10 @@        ; return [(loc, pragma)] }  repInline :: InlineSpec -> MetaM (Core TH.Inline)-repInline NoInline     = dataCon noInlineDataConName-repInline Inline       = dataCon inlineDataConName-repInline Inlinable    = dataCon inlinableDataConName-repInline NoUserInline = notHandled "NOUSERINLINE" empty+repInline NoInline         = dataCon noInlineDataConName+repInline Inline           = dataCon inlineDataConName+repInline Inlinable        = dataCon inlinableDataConName+repInline NoUserInlinePrag = notHandled "NOUSERINLINE" empty  repRuleMatch :: RuleMatchInfo -> MetaM (Core TH.RuleMatch) repRuleMatch ConLike = dataCon conLikeDataConName@@ -1119,8 +1133,8 @@                                   ; dataCon' fromPhaseDataConName [arg] } repPhases _                  = dataCon allPhasesDataConName -rep_complete_sig :: Located [Located Name]-                 -> Maybe (Located Name)+rep_complete_sig :: Located [LocatedN Name]+                 -> Maybe (LocatedN Name)                  -> SrcSpan                  -> MetaM [(SrcSpan, Core (M TH.Dec))] rep_complete_sig (L _ cls) mty loc@@ -1155,6 +1169,56 @@ rep_flag SpecifiedSpec = rep2_nw specifiedSpecName [] rep_flag InferredSpec  = rep2_nw inferredSpecName [] +addHsOuterFamEqnTyVarBinds ::+     HsOuterFamEqnTyVarBndrs GhcRn+  -> (Core (Maybe [M TH.TyVarBndrUnit]) -> MetaM (Core (M a)))+  -> MetaM (Core (M a))+addHsOuterFamEqnTyVarBinds outer_bndrs thing_inside = do+  elt_ty <- wrapName tyVarBndrUnitTyConName+  case outer_bndrs of+    HsOuterImplicit{hso_ximplicit = imp_tvs} ->+      addTyClTyVarBinds (mk_qtvs imp_tvs []) $ \_th_exp_bndrs ->+      thing_inside $ coreNothingList elt_ty+    HsOuterExplicit{hso_bndrs = exp_bndrs} ->+      addTyClTyVarBinds (mk_qtvs [] exp_bndrs) $ \th_exp_bndrs ->+      thing_inside $ coreJustList elt_ty th_exp_bndrs+  where+    mk_qtvs imp_tvs exp_tvs = HsQTvs { hsq_ext = imp_tvs+                                     , hsq_explicit = exp_tvs }++addHsOuterSigTyVarBinds ::+     HsOuterSigTyVarBndrs GhcRn+  -> (Core [M TH.TyVarBndrSpec] -> MetaM (Core (M a)))+  -> MetaM (Core (M a))+addHsOuterSigTyVarBinds outer_bndrs thing_inside = case outer_bndrs of+  HsOuterImplicit{hso_ximplicit = imp_tvs} ->+    do th_nil <- coreListM tyVarBndrSpecTyConName []+       addSimpleTyVarBinds imp_tvs $ thing_inside th_nil+  HsOuterExplicit{hso_bndrs = exp_bndrs} ->+    addHsTyVarBinds exp_bndrs thing_inside++-- | If a type implicitly quantifies its outermost type variables, return+-- 'True' if the list of implicitly bound type variables is empty. If a type+-- explicitly quantifies its outermost type variables, always return 'True'.+--+-- This is used in various places to determine if a Template Haskell 'Type'+-- should be headed by a 'ForallT' or not.+nullOuterImplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool+nullOuterImplicit (HsOuterImplicit{hso_ximplicit = imp_tvs}) = null imp_tvs+nullOuterImplicit (HsOuterExplicit{})                        = True+  -- Vacuously true, as there is no implicit quantification++-- | If a type explicitly quantifies its outermost type variables, return+-- 'True' if the list of explicitly bound type variables is empty. If a type+-- implicitly quantifies its outermost type variables, always return 'True'.+--+-- This is used in various places to determine if a Template Haskell 'Type'+-- should be headed by a 'ForallT' or not.+nullOuterExplicit :: HsOuterSigTyVarBndrs GhcRn -> Bool+nullOuterExplicit (HsOuterExplicit{hso_bndrs = exp_bndrs}) = null exp_bndrs+nullOuterExplicit (HsOuterImplicit{})                      = True+  -- Vacuously true, as there is no outermost explicit quantification+ addSimpleTyVarBinds :: [Name]             -- the binders to be added                     -> MetaM (Core (M a)) -- action in the ext env                     -> MetaM (Core (M a))@@ -1170,12 +1234,10 @@ addHsTyVarBinds exp_tvs thing_inside   = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)        ; term <- addBinds fresh_exp_names $-                 do { kbs <- repListM (tyVarBndrName @flag @flag') mk_tv_bndr-                                     (exp_tvs `zip` fresh_exp_names)+                 do { kbs <- repListM (tyVarBndrName @flag @flag') repTyVarBndr+                                      exp_tvs                     ; thing_inside kbs }        ; wrapGenSyms fresh_exp_names term }-  where-    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)  addQTyVarBinds :: LHsQTyVars GhcRn -- the binders to be added                -> (Core [(M (TH.TyVarBndr ()))] -> MetaM (Core (M a))) -- action in the ext env@@ -1214,26 +1276,12 @@             -- This makes things work for family declarations         ; term <- addBinds freshNames $-                 do { kbs <- repListM tyVarBndrUnitTyConName mk_tv_bndr+                 do { kbs <- repListM tyVarBndrUnitTyConName repTyVarBndr                                      (hsQTvExplicit tvs)                     ; m kbs }         ; wrapGenSyms freshNames term }-  where-    mk_tv_bndr :: LHsTyVarBndr () GhcRn -> MetaM (Core (M (TH.TyVarBndr ())))-    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)-                       ; repTyVarBndrWithKind tv v } --- Produce kinded binder constructors from the Haskell tyvar binders----repTyVarBndrWithKind :: RepTV flag flag' => LHsTyVarBndr flag GhcRn-                     -> Core TH.Name -> MetaM (Core (M (TH.TyVarBndr flag')))-repTyVarBndrWithKind (L _ (UserTyVar _ fl _)) nm-  = repPlainTV nm fl-repTyVarBndrWithKind (L _ (KindedTyVar _ fl _ ki)) nm-  = do { ki' <- repLTy ki-       ; repKindedTV nm fl ki' }- -- | Represent a type variable binder repTyVarBndr :: RepTV flag flag'              => LHsTyVarBndr flag GhcRn -> MetaM (Core (M (TH.TyVarBndr flag')))@@ -1247,25 +1295,23 @@  -- represent a type context ---repLContext :: LHsContext GhcRn -> MetaM (Core (M TH.Cxt))-repLContext ctxt = repContext (unLoc ctxt)+repLContext :: Maybe (LHsContext GhcRn) -> MetaM (Core (M TH.Cxt))+repLContext Nothing = repContext []+repLContext (Just ctxt) = repContext (unLoc ctxt)  repContext :: HsContext GhcRn -> MetaM (Core (M TH.Cxt)) repContext ctxt = do preds <- repListM typeTyConName repLTy ctxt                      repCtxt preds  repHsSigType :: LHsSigType GhcRn -> MetaM (Core (M TH.Type))-repHsSigType (HsIB { hsib_ext = implicit_tvs-                   , hsib_body = body })-  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTyInvis body-  = addSimpleTyVarBinds implicit_tvs $-      -- See Note [Don't quantify implicit type variables in quotes]-    addHsTyVarBinds explicit_tvs $ \ th_explicit_tvs ->+repHsSigType (L _ (HsSig { sig_bndrs = outer_bndrs, sig_body = body }))+  | (ctxt, tau) <- splitLHsQualTy body+  = addHsOuterSigTyVarBinds outer_bndrs $ \ th_outer_bndrs ->     do { th_ctxt <- repLContext ctxt-       ; th_ty   <- repLTy ty-       ; if null explicit_tvs && null (unLoc ctxt)-         then return th_ty-         else repTForall th_explicit_tvs th_ctxt th_ty }+       ; th_tau  <- repLTy tau+       ; if nullOuterExplicit outer_bndrs && null (fromMaybeContext ctxt)+         then pure th_tau+         else repTForall th_outer_bndrs th_ctxt th_tau }  -- yield the representation of a list of types repLTys :: [LHsType GhcRn] -> MetaM [Core (M TH.Type)]@@ -1283,7 +1329,7 @@ -- handled separately in repTy. repForallT :: HsType GhcRn -> MetaM (Core (M TH.Type)) repForallT ty- | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLoc ty)+ | (tvs, ctxt, tau) <- splitLHsSigmaTyInvis (noLocA ty)  = addHsTyVarBinds tvs $ \bndrs ->    do { ctxt1  <- repLContext ctxt       ; tau1   <- repLTy tau@@ -1379,6 +1425,9 @@ repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s                             ; rep2 strTyLitName [s']                             }+repTyLit (HsCharTy _ c) = do { c' <- return (mkCharExpr c)+                             ; rep2 charTyLitName [c']+                             }  -- | Represent a type wrapped in a Maybe repMaybeLTy :: Maybe (LHsKind GhcRn)@@ -1425,7 +1474,7 @@ --        unless we can make sure that constructs, which are plainly not --        supported in TH already lead to error messages at an earlier stage repLE :: LHsExpr GhcRn -> MetaM (Core (M TH.Exp))-repLE (L loc e) = mapReaderT (putSrcSpanDs loc) (repE e)+repLE (L loc e) = mapReaderT (putSrcSpanDs (locA loc)) (repE e)  repE :: HsExpr GhcRn -> MetaM (Core (M TH.Exp)) repE (HsVar _ (L _ x)) =@@ -1437,10 +1486,10 @@         Just (DsSplice e)  -> do { e' <- lift $ dsExpr e                                  ; return (MkC e') } } repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar-repE (HsOverLabel _ _ s) = repOverLabel s+repE (HsOverLabel _ s) = repOverLabel s  repE e@(HsRecFld _ f) = case f of-  Unambiguous x _ -> repE (HsVar noExtField (noLoc x))+  Unambiguous x _ -> repE (HsVar noExtField (noLocA x))   Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)          -- Remember, we're desugaring renamer output here, so@@ -1448,6 +1497,7 @@ repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a } repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m+repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e) repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))                    = do { ms' <- mapM repMatchTup ms                         ; core_ms <- coreListM matchTyConName ms'@@ -1483,7 +1533,7 @@   = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts        ; expr' <- repMultiIf (nonEmptyCoreList alts')        ; wrapGenSyms (concat binds) expr' }-repE (HsLet _ (L _ bs) e)       = do { (ss,ds) <- repBinds bs+repE (HsLet _ bs e)             = do { (ss,ds) <- repBinds bs                                      ; e2 <- addBinds ss (repLE e)                                      ; z <- repLetE ds e2                                      ; wrapGenSyms ss z }@@ -1509,10 +1559,10 @@   | otherwise   = notHandled "monad comprehension and [: :]" (ppr e) -repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }+repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitTuple _ es boxity) =-  let tupArgToCoreExp :: LHsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))-      tupArgToCoreExp (L _ a)+  let tupArgToCoreExp :: HsTupArg GhcRn -> MetaM (Core (Maybe (M TH.Exp)))+      tupArgToCoreExp a         | (Present _ e) <- a = do { e' <- repLE e                                   ; coreJustM expTyConName e' }         | otherwise = coreNothingM expTyConName@@ -1529,14 +1579,19 @@  = do { e1 <- repLE e       ; repUnboxedSum e1 alt arity } -repE (RecordCon { rcon_con_name = c, rcon_flds = flds })+repE (RecordCon { rcon_con = c, rcon_flds = flds })  = do { x <- lookupLOcc c;         fs <- repFields flds;         repRecCon x fs }-repE (RecordUpd { rupd_expr = e, rupd_flds = flds })+repE (RecordUpd { rupd_expr = e, rupd_flds = Left flds })  = do { x <- repLE e;         fs <- repUpdFields flds;         repRecUpd x fs }+repE (RecordUpd { rupd_flds = Right _ })+  = do+      -- Not possible due to elimination in the renamer. See Note+      -- [Handling overloaded and rebindable constructs]+      panic "The impossible has happened!"  repE (ExprWithTySig _ e wc_ty)   = addSimpleTyVarBinds (get_scoped_tvs_from_sig sig_ty) $@@ -1569,18 +1624,47 @@                                occ   <- occNameLit uv                                sname <- repNameS occ                                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)+repE (HsGetField _ e (L _ (HsFieldLabel _ (L _ f)))) = do+  e1 <- repLE e+  repGetField e1 f+repE (HsProjection _ xs) = repProjection (fmap (unLoc . hflLabel . unLoc) xs)+repE (XExpr (HsExpanded orig_expr ds_expr))+  = do { rebindable_on <- lift $ xoptM LangExt.RebindableSyntax+       ; if rebindable_on  -- See Note [Quotation and rebindable syntax]+         then repE ds_expr+         else repE orig_expr }+repE e = notHandled "Expression form" (ppr e) +{- Note [Quotation and rebindable syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = [| (* 3) |]++Because of Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr,+the renamer will expand (* 3) to (rightSection (*) 3), regardless of RebindableSyntax.+Then, concerning the TH quotation,++* If RebindableSyntax is off, we want the TH quote to generate the section (* 3),+  as the user originally wrote.++* If RebindableSyntax is on, we perhaps want the TH quote to generate+  (rightSection (*) 3), using whatever 'rightSection' is in scope, because+  (a) RebindableSyntax might not be on in the splicing context+  (b) Even if it is, 'rightSection' might not be in scope+  (c) At least in the case of Typed Template Haskell we should never get+      a type error from the splice.++We consult the module-wide RebindableSyntax flag here. We could instead record+the choice in HsExpanded, but it seems simpler to consult the flag (again).+-}+ ----------------------------------------------------------------------------- -- Building representations of auxiliary structures like Match, Clause, Stmt,  repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Match)) repMatchTup (L _ (Match { m_pats = [p]-                        , m_grhss = GRHSs _ guards (L _ wheres) })) =-  do { ss1 <- mkGenSyms (collectPatBinders p)+                        , m_grhss = GRHSs _ guards wheres })) =+  do { ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)      ; addBinds ss1 $ do {      ; p1 <- repLP p      ; (ss2,ds) <- repBinds wheres@@ -1592,8 +1676,8 @@  repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Clause)) repClauseTup (L _ (Match { m_pats = ps-                         , m_grhss = GRHSs _ guards (L _ wheres) })) =-  do { ss1 <- mkGenSyms (collectPatsBinders ps)+                         , m_grhss = GRHSs _ guards  wheres })) =+  do { ss1 <- mkGenSyms (collectPatsBinders CollNoDictBinders ps)      ; addBinds ss1 $ do {        ps1 <- repLPs ps      ; (ss2,ds) <- repBinds wheres@@ -1676,13 +1760,13 @@ repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> MetaM ([GenSymBind], [Core (M TH.Stmt)]) repSts (BindStmt _ p e : ss) =    do { e2 <- repLE e-      ; ss1 <- mkGenSyms (collectPatBinders p)+      ; ss1 <- mkGenSyms (collectPatBinders CollNoDictBinders p)       ; addBinds ss1 $ do {       ; p1 <- repLP p;       ; (ss2,zs) <- repSts ss       ; z <- repBindSt p1 e2       ; return (ss1++ss2, z : zs) }}-repSts (LetStmt _ (L _ bs) : ss) =+repSts (LetStmt _ bs : ss) =    do { (ss1,ds) <- repBinds bs       ; z <- repLetSt ds       ; (ss2,zs) <- addBinds ss1 (repSts ss)@@ -1711,11 +1795,11 @@        ; z <- repNoBindSt e2        ; return ([], [z]) } repSts (stmt@RecStmt{} : ss)-  = do { let binders = collectLStmtsBinders (recS_stmts stmt)+  = do { let binders = collectLStmtsBinders CollNoDictBinders (unLoc $ recS_stmts stmt)        ; ss1 <- mkGenSyms binders        -- Bring all of binders in the recursive group into scope for the        -- whole group.-       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (unLoc $ recS_stmts stmt))        ; MASSERT(sort ss1 == sort ss1_other)        ; z <- repRecSt (nonEmptyCoreList rss)        ; (ss2,zs) <- addBinds ss1 (repSts ss)@@ -1741,7 +1825,7 @@         }  repBinds (HsValBinds _ decs)- = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders CollNoDictBinders decs }                 -- No need to worry about detailed scopes within                 -- the binding group, because we are talking Names                 -- here, so we can safely treat it as a mutually@@ -1761,7 +1845,7 @@                         panic "rep_implicit_param_bind: post typechecking"       ; rhs' <- repE rhs       ; ipb <- repImplicitParamBind name rhs'-      ; return (loc, ipb) }+      ; return (locA loc, ipb) }  rep_implicit_param_name :: HsIPName -> MetaM (Core String) rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)@@ -1789,31 +1873,31 @@                    fun_matches = MG { mg_alts                            = (L _ [L _ (Match                                    { m_pats = []-                                   , m_grhss = GRHSs _ guards (L _ wheres) }+                                   , m_grhss = GRHSs _ guards wheres }                                       )]) } }))  = do { (ss,wherecore) <- repBinds wheres         ; guardcore <- addBinds ss (repGuards guards)-        ; fn'  <- lookupLBinder fn+        ; fn'  <- lookupNBinder fn         ; p    <- repPvar fn'         ; ans  <- repVal p guardcore wherecore         ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }+        ; return (locA loc, ans') }  rep_bind (L loc (FunBind { fun_id = fn                          , fun_matches = MG { mg_alts = L _ ms } }))  =   do { ms1 <- mapM repClauseTup ms-        ; fn' <- lookupLBinder fn+        ; fn' <- lookupNBinder fn         ; ans <- repFun fn' (nonEmptyCoreList ms1)-        ; return (loc, ans) }+        ; return (locA loc, ans) }  rep_bind (L loc (PatBind { pat_lhs = pat-                         , pat_rhs = GRHSs _ guards (L _ wheres) }))+                         , pat_rhs = GRHSs _ guards wheres }))  =   do { patcore <- repLP pat         ; (ss,wherecore) <- repBinds wheres         ; guardcore <- addBinds ss (repGuards guards)         ; ans  <- repVal patcore guardcore wherecore         ; ans' <- wrapGenSyms ss ans-        ; return (loc, ans') }+        ; return (locA loc, ans') }  rep_bind (L _ (VarBind { var_id = v, var_rhs = e}))  =   do { v' <- lookupBinder v@@ -1829,7 +1913,7 @@                                    , psb_args = args                                    , psb_def  = pat                                    , psb_dir  = dir })))-  = do { syn'      <- lookupLBinder syn+  = do { syn'      <- lookupNBinder syn        ; dir'      <- repPatSynDir dir        ; ss        <- mkGenArgSyms args        ; patSynD'  <- addBinds ss (@@ -1837,20 +1921,20 @@             ; pat'   <- repLP pat             ; repPatSynD syn' args' dir' pat' })        ; patSynD'' <- wrapGenArgSyms args ss patSynD'-       ; return (loc, patSynD'') }+       ; return (locA loc, patSynD'') }   where-    mkGenArgSyms :: HsPatSynDetails (Located Name) -> MetaM [GenSymBind]+    mkGenArgSyms :: HsPatSynDetails GhcRn -> MetaM [GenSymBind]     -- for Record Pattern Synonyms we want to conflate the selector     -- and the pattern-only names in order to provide a nicer TH     -- API. Whereas inside GHC, record pattern synonym selectors and     -- their pattern-only bound right hand sides have different names,     -- we want to treat them the same in TH. This is the reason why we     -- need an adjusted mkGenArgSyms in the `RecCon` case below.-    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)+    mkGenArgSyms (PrefixCon _ args)   = mkGenSyms (map unLoc args)     mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]     mkGenArgSyms (RecCon fields)       = do { let pats = map (unLoc . recordPatSynPatVar) fields-                 sels = map (unLoc . recordPatSynSelectorId) fields+                 sels = map (extFieldOcc . recordPatSynField) fields            ; ss <- mkGenSyms sels            ; return $ replaceNames (zip sels pats) ss } @@ -1858,7 +1942,7 @@       = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats                     , sel == sel' ] -    wrapGenArgSyms :: HsPatSynDetails (Located Name)+    wrapGenArgSyms :: HsPatSynDetails GhcRn                    -> [GenSymBind] -> Core (M TH.Dec) -> MetaM (Core (M TH.Dec))     wrapGenArgSyms (RecCon _) _  dec = return dec     wrapGenArgSyms _          ss dec = wrapGenSyms ss dec@@ -1871,8 +1955,8 @@ repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)   = rep2 patSynDName [syn, args, dir, pat] -repPatSynArgs :: HsPatSynDetails (Located Name) -> MetaM (Core (M TH.PatSynArgs))-repPatSynArgs (PrefixCon args)+repPatSynArgs :: HsPatSynDetails GhcRn -> MetaM (Core (M TH.PatSynArgs))+repPatSynArgs (PrefixCon _ args)   = do { args' <- repList nameTyConName lookupLOcc args        ; repPrefixPatSynArgs args' } repPatSynArgs (InfixCon arg1 arg2)@@ -1880,9 +1964,9 @@        ; arg2' <- lookupLOcc arg2        ; repInfixPatSynArgs arg1' arg2' } repPatSynArgs (RecCon fields)-  = do { sels' <- repList nameTyConName lookupLOcc sels+  = do { sels' <- repList nameTyConName (lookupOcc . extFieldOcc) sels        ; repRecordPatSynArgs sels' }-  where sels = map recordPatSynSelectorId fields+  where sels = map recordPatSynField fields  repPrefixPatSynArgs :: Core [TH.Name] -> MetaM (Core (M TH.PatSynArgs)) repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]@@ -1932,8 +2016,8 @@ repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> MetaM (Core (M TH.Exp)) repLambda (L _ (Match { m_pats = ps                       , m_grhss = GRHSs _ [L _ (GRHS _ [] e)]-                                              (L _ (EmptyLocalBinds _)) } ))- = do { let bndrs = collectPatsBinders ps ;+                                              (EmptyLocalBinds _) } ))+ = do { let bndrs = collectPatsBinders CollNoDictBinders ps ;       ; ss  <- mkGenSyms bndrs       ; lam <- addBinds ss (                 do { xs <- repLPs ps; body <- repLE e; repLam xs body })@@ -1962,7 +2046,7 @@ repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' } repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 } repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }-repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p+repP (AsPat _ x p)      = do { x' <- lookupNBinder x; p1 <- repLP p                              ; repPaspat x' p1 } repP (ParPat _ p)       = repLP p repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }@@ -1978,7 +2062,9 @@ repP (ConPat NoExtField dc details)  = do { con_str <- lookupLOcc dc       ; case details of-         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }+         PrefixCon tyargs ps -> do { qs <- repLPs ps+                                   ; ts <- repListM typeTyConName (repTy . unLoc . hsps_body) tyargs+                                   ; repPcon con_str ts qs }          RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)                             ; repPrec con_str fps }          InfixCon p1 p2 -> do { p1' <- repLP p1;@@ -1990,7 +2076,6 @@    rep_fld (L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)                           ; MkC p <- repLP (hsRecFieldArg fld)                           ; rep2 fieldPatName [v,p] }- repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l                                      ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }@@ -2043,8 +2128,8 @@  -- Look up a locally bound name ---lookupLBinder :: Located Name -> MetaM (Core TH.Name)-lookupLBinder n = lookupBinder (unLoc n)+lookupNBinder :: LocatedN Name -> MetaM (Core TH.Name)+lookupNBinder n = lookupBinder (unLoc n)  lookupBinder :: Name -> MetaM (Core TH.Name) lookupBinder = lookupOcc@@ -2058,7 +2143,7 @@ --  * If it is a global name, generate the "original name" representation (ie, --   the <module>:<name> form) for the associated entity ---lookupLOcc :: Located Name -> MetaM (Core TH.Name)+lookupLOcc :: GenLocated l Name -> MetaM (Core TH.Name) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist lookupLOcc n = lookupOcc (unLoc n)@@ -2211,8 +2296,8 @@                              , mkIntExprInt platform alt                              , mkIntExprInt platform arity ] } -repPcon   :: Core TH.Name -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))-repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]+repPcon   :: Core TH.Name -> Core [(M TH.Type)] -> Core [(M TH.Pat)] -> MetaM (Core (M TH.Pat))+repPcon (MkC s) (MkC ts) (MkC ps) = rep2 conPName [s, ts, ps]  repPrec   :: Core TH.Name -> Core [M (TH.Name, TH.Pat)] -> MetaM (Core (M TH.Pat)) repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]@@ -2243,8 +2328,11 @@  --------------- Expressions ----------------- repVarOrCon :: Name -> Core TH.Name -> MetaM (Core (M TH.Exp))-repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str-                   | otherwise                  = repVar str+repVarOrCon vc str+    | isVarNameSpace ns = repVar str  -- Both type and term variables (#18740)+    | otherwise         = repCon str+  where+    ns = nameNameSpace vc  repVar :: Core TH.Name -> MetaM (Core (M TH.Exp)) repVar (MkC s) = rep2 varEName [s]@@ -2446,14 +2534,14 @@     Nothing -> thing_inside =<< nothing     Just ds ->       case unLoc ds of-        StockStrategy    -> thing_inside =<< just =<< repStockStrategy-        AnyclassStrategy -> thing_inside =<< just =<< repAnyclassStrategy-        NewtypeStrategy  -> thing_inside =<< just =<< repNewtypeStrategy-        ViaStrategy ty   -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $-                            do ty' <- rep_ty_sig' ty-                               via_strat <- repViaStrategy ty'-                               m_via_strat <- just via_strat-                               thing_inside m_via_strat+        StockStrategy    _ -> thing_inside =<< just =<< repStockStrategy+        AnyclassStrategy _ -> thing_inside =<< just =<< repAnyclassStrategy+        NewtypeStrategy  _ -> thing_inside =<< just =<< repNewtypeStrategy+        ViaStrategy ty     -> addSimpleTyVarBinds (get_scoped_tvs_from_sig ty) $+                              do ty' <- rep_ty_sig' ty+                                 via_strat <- repViaStrategy ty'+                                 m_via_strat <- just via_strat+                                 thing_inside m_via_strat   where   nothing = coreNothingM derivStrategyTyConName   just    = coreJustM    derivStrategyTyConName@@ -2574,49 +2662,51 @@ repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) repCtxt (MkC tys) = rep2 cxtName [tys] -repDataCon :: Located Name-           -> HsConDeclDetails GhcRn-           -> MetaM (Core (M TH.Con))-repDataCon con details+repH98DataCon :: LocatedN Name+              -> HsConDeclH98Details GhcRn+              -> MetaM (Core (M TH.Con))+repH98DataCon con details     = do con' <- lookupLOcc con -- See Note [Binders and occurrences]-         repConstr details Nothing [con']+         case details of+           PrefixCon _ ps -> do+             arg_tys <- repPrefixConArgs ps+             rep2 normalCName [unC con', unC arg_tys]+           InfixCon st1 st2 -> do+             arg1 <- repBangTy (hsScaledThing st1)+             arg2 <- repBangTy (hsScaledThing st2)+             rep2 infixCName [unC arg1, unC con', unC arg2]+           RecCon ips -> do+             arg_vtys <- repRecConArgs ips+             rep2 recCName [unC con', unC arg_vtys] -repGadtDataCons :: [Located Name]-                -> HsConDeclDetails GhcRn+repGadtDataCons :: [LocatedN Name]+                -> HsConDeclGADTDetails GhcRn                 -> LHsType GhcRn                 -> MetaM (Core (M TH.Con)) repGadtDataCons cons details res_ty     = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]-         repConstr details (Just res_ty) cons'---- Invariant:---   * for plain H98 data constructors second argument is Nothing and third---     argument is a singleton list---   * for GADTs data constructors second argument is (Just return_type) and---     third argument is a non-empty list-repConstr :: HsConDeclDetails GhcRn-          -> Maybe (LHsType GhcRn)-          -> [Core TH.Name]-          -> MetaM (Core (M TH.Con))-repConstr (PrefixCon ps) Nothing [con]-    = do arg_tys  <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)-         rep2 normalCName [unC con, unC arg_tys]--repConstr (PrefixCon ps) (Just res_ty) cons-    = do arg_tys     <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps)-         res_ty' <- repLTy res_ty-         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']--repConstr (RecCon ips) resTy cons-    = do args     <- concatMapM rep_ip (unLoc ips)-         arg_vtys <- coreListM varBangTypeTyConName args-         case resTy of-           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]-           Just res_ty -> do+         case details of+           PrefixConGADT ps -> do+             arg_tys <- repPrefixConArgs ps              res_ty' <- repLTy res_ty-             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,+             rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty']+           RecConGADT ips -> do+             arg_vtys <- repRecConArgs ips+             res_ty'  <- repLTy res_ty+             rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys,                                 unC res_ty'] +-- Desugar the arguments in a data constructor declared with prefix syntax.+repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)]+                 -> MetaM (Core [M TH.BangType])+repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps)++-- Desugar the arguments in a data constructor declared with record syntax.+repRecConArgs :: LocatedL [LConDeclField GhcRn]+              -> MetaM (Core [M TH.VarBangType])+repRecConArgs ips = do+  args     <- concatMapM rep_ip (unLoc ips)+  coreListM varBangTypeTyConName args     where       rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) @@ -2625,16 +2715,6 @@                           ; MkC ty <- repBangTy  t                           ; rep2 varBangTypeName [v,ty] } -repConstr (InfixCon st1 st2) Nothing [con]-    = do arg1 <- repBangTy (hsScaledThing st1)-         arg2 <- repBangTy (hsScaledThing st2)-         rep2 infixCName [unC arg1, unC con, unC arg2]--repConstr (InfixCon {}) (Just _) _ =-    panic "repConstr: infix GADT constructor should be in a PrefixCon"-repConstr _ _ _ =-    panic "repConstr: invariant violated"- ------------ Types -------------------  repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type)@@ -2751,11 +2831,10 @@  repLiteral :: HsLit GhcRn -> MetaM (Core TH.Lit) repLiteral (HsStringPrim _ bs)-  = do platform <- getPlatform-       word8_ty <- lookupType word8TyConName+  = do word8_ty <- lookupType word8TyConName        let w8s = unpack bs            w8s_expr = map (\w8 -> mkCoreConApps word8DataCon-                                  [mkWordLit platform (toInteger w8)]) w8s+                                  [mkWord8Lit (toInteger w8)]) w8s        rep2_nw stringPrimLName [mkListExpr word8_ty w8s_expr] repLiteral lit   = do lit' <- case lit of@@ -2833,7 +2912,16 @@                     (MkC s) <- coreStringLit $ unpackFS fs                     rep2 labelEName [s] +repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp))+repGetField (MkC exp) fs = do+  MkC s <- coreStringLit $ unpackFS fs+  rep2 getFieldEName [exp,s] +repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp))+repProjection fs = do+  MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs+  rep2 projectionEName [xs]+ ------------ Lists ------------------- -- turn a list of patterns into a single pattern matching a list @@ -2863,6 +2951,9 @@           -> [Core a] -> Core [a] coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es )) +coreListNonEmpty :: Type -> NonEmpty (Core a) -> Core (NonEmpty a)+coreListNonEmpty ty (MkC x :| xs) = MkC $ mkNonEmptyListExpr ty x (map unC xs)+ nonEmptyCoreList :: [Core a] -> Core [a]   -- The list must be non-empty so we can get the element type   -- Otherwise use coreList@@ -2917,23 +3008,11 @@  ------------------- Maybe Lists ------------------ --- Lookup the name and wrap it with the m variable-repMaybeListM :: Name -> (a -> MetaM (Core b))-                        -> Maybe [a] -> MetaM (Core (Maybe [b]))-repMaybeListM tc_name f xs = do-  elt_ty <- wrapName tc_name-  repMaybeListT elt_ty f xs---repMaybeListT :: Type -> (a -> MetaM (Core b))-                        -> Maybe [a] -> MetaM (Core (Maybe [b]))-repMaybeListT elt_ty _ Nothing = coreNothingList elt_ty-repMaybeListT elt_ty f (Just args)-  = do { args1 <- mapM f args-       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }+coreJustList :: Type -> Core [a] -> Core (Maybe [a])+coreJustList elt_ty = coreJust' (mkListTy elt_ty) -coreNothingList :: Type -> MetaM (Core (Maybe [a]))-coreNothingList elt_ty = return $ coreNothing' (mkListTy elt_ty)+coreNothingList :: Type -> Core (Maybe [a])+coreNothingList elt_ty = coreNothing' (mkListTy elt_ty)  ------------ Literals & Variables -------------------

+ GHC/HsToCore/Types.hs view

@@ -0,0 +1,89 @@+{-# 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.Types.Name.Reader (GlobalRdrEnv)+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.Types.ForeignStubs (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_gbl_rdr_env  :: GlobalRdrEnv       -- needed *only* to know what newtype+                                          -- constructors are in scope during+                                          -- pattern-match satisfiability checking+  , ds_unqual  :: PrintUnqualified+  , ds_msgs    :: IORef (Messages DecoratedSDoc) -- 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))

GHC/HsToCore/Usage.hs view

@@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -13,23 +11,36 @@  import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session-import GHC.Driver.Ways-import GHC.Driver.Types++import GHC.Platform+import GHC.Platform.Ways+ import GHC.Tc.Types-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Unit+ import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Fingerprint+import GHC.Utils.Panic++import GHC.Types.Name+import GHC.Types.Name.Set import GHC.Types.Unique.Set import GHC.Types.Unique.FM-import GHC.Utils.Fingerprint++import GHC.Unit+import GHC.Unit.External+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.Imported+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+ import GHC.Data.Maybe-import GHC.Driver.Finder  import Control.Monad (filterM)-import Data.List+import Data.List (sort, sortBy, nub) import Data.IORef import Data.Map (Map) import qualified Data.Map as Map@@ -59,7 +70,7 @@ -- | Extract information from the rename and typecheck phases to produce -- a dependencies information for the module being compiled. ----- The first argument is additional dependencies from plugins+-- The second argument is additional dependencies from plugins mkDependencies :: UnitId -> [Module] -> TcGblEnv -> IO Dependencies mkDependencies iuid pluginModules           (TcGblEnv{ tcg_mod = mod,@@ -173,12 +184,12 @@     LookupFound _ (pkg, _) -> do     -- The plugin is from an external package:     -- search for the library files containing the plugin.-      let searchPaths = collectLibraryPaths dflags [pkg]+      let searchPaths = collectLibraryDirs (ways dflags) [pkg]           useDyn = WayDyn `elem` ways dflags-          suffix = if useDyn then soExt platform else "a"+          suffix = if useDyn then platformSOExt platform else "a"           libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix                     | searchPath <- searchPaths-                    , libLoc     <- packageHsLibs dflags pkg+                    , libLoc     <- unitHsLibs (ghcNameVersion dflags) (ways dflags) pkg                     ]           -- we also try to find plugin library files by adding WayDyn way,           -- if it isn't already present (see trac #15492)@@ -186,10 +197,10 @@             if useDyn               then libLocs               else-                let dflags'  = addWay' WayDyn dflags-                    dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc+                let dflags'  = dflags { targetWays_ = addWay WayDyn (targetWays_ dflags) }+                    dlibLocs = [ searchPath </> platformHsSOName platform dlibLoc                                | searchPath <- searchPaths-                               , dlibLoc    <- packageHsLibs dflags' pkg+                               , dlibLoc    <- unitHsLibs (ghcNameVersion dflags') (ways dflags') pkg                                ]                 in libLocs ++ dlibLocs       files <- filterM doesFileExist paths@@ -215,7 +226,7 @@   where     dflags   = hsc_dflags hsc_env     platform = targetPlatform dflags-    pkgs     = unitState dflags+    pkgs     = hsc_units hsc_env     pNm      = moduleName $ mi_module pluginModule     pPkg     = moduleUnit $ mi_module pluginModule     deps     = map gwib_mod $@@ -251,7 +262,7 @@   where     hpt = hsc_HPT hsc_env     dflags = hsc_dflags hsc_env-    this_pkg = homeUnit dflags+    home_unit = hsc_home_unit hsc_env      used_mods    = moduleEnvKeys ent_map     dir_imp_mods = moduleEnvKeys direct_imports@@ -277,7 +288,7 @@              Just mod ->                 -- See Note [Identity versus semantic module]                 let mod' = if isHoleModule mod-                            then mkModule this_pkg (moduleName mod)+                            then mkHomeModule home_unit (moduleName mod)                             else mod                 -- This lambda function is really just a                 -- specialised (++); originally came about to@@ -297,7 +308,7 @@                                         -- things in *this* module       = Nothing -      | moduleUnit mod /= this_pkg+      | not (isHomeModule home_unit mod)       = Just UsagePackageModule{ usg_mod      = mod,                                  usg_mod_hash = mod_hash,                                  usg_safe     = imp_safe }

GHC/HsToCore/Utils.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -8,12 +13,6 @@ This module exports some utility functions of no great interest. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}- -- | Utility functions for constructing Core syntax, principally for desugaring module GHC.HsToCore.Utils (         EquationInfo(..),@@ -24,12 +23,14 @@         extractMatchResult, combineMatchResults,         adjustMatchResultDs,         shareFailureHandler,+        dsHandleMonadicFailure,         mkCoLetMatchResult, mkViewMatchResult, mkGuardedMatchResult,         matchCanFail, mkEvalMatchResult,         mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, mkCoSynCaseMatchResult,         wrapBind, wrapBinds,          mkErrorAppDs, mkCoreAppDs, mkCoreAppsDs, mkCastDs,+        mkFailExpr,          seqVar, @@ -49,7 +50,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.HsToCore.Match ( matchSimply )-import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr )+import {-# SOURCE #-} GHC.HsToCore.Expr  ( dsLExpr, dsSyntaxExpr )  import GHC.Hs import GHC.Tc.Utils.Zonk@@ -67,7 +68,6 @@ import GHC.Core.PatSyn import GHC.Core.Type import GHC.Core.Coercion-import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Types.Basic import GHC.Core.ConLike@@ -77,9 +77,12 @@ import GHC.Builtin.Names import GHC.Types.Name( isInternalName ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc+import GHC.Types.Tickish import GHC.Utils.Misc import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt @@ -260,7 +263,7 @@  mkEvalMatchResult :: Id -> Type -> MatchResult CoreExpr -> MatchResult CoreExpr mkEvalMatchResult var ty = fmap $ \e ->-  Case (Var var) var ty [(DEFAULT, [], e)]+  Case (Var var) var ty [Alt DEFAULT [] e]  mkGuardedMatchResult :: CoreExpr -> MatchResult CoreExpr -> MatchResult CoreExpr mkGuardedMatchResult pred_expr mr = MR_Fallible $ \fail -> do@@ -276,13 +279,13 @@   where     mk_case fail = do         alts <- mapM (mk_alt fail) sorted_alts-        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))+        return (Case (Var var) var ty (Alt DEFAULT [] fail : alts))      sorted_alts = sortWith fst match_alts       -- Right order for a Case     mk_alt fail (lit, mr)        = ASSERT( not (litIsLifted lit) )          do body <- runMatchResult fail mr-            return (LitAlt lit, [], body)+            return (Alt (LitAlt lit) [] body)  data CaseAlt a = MkCaseAlt{ alt_pat :: a,                             alt_bndrs :: [Var],@@ -321,8 +324,9 @@  mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr mkPatSynCase var ty alt fail = do+    matcher_id <- dsLookupGlobalId matcher_name     matcher <- dsLExpr $ mkLHsWrap wrapper $-                         nlHsTyApp matcher [getRuntimeRep ty, ty]+                         nlHsTyApp matcher_id [getRuntimeRep ty, ty]     cont <- mkCoreLams bndrs <$> runMatchResult fail match_result     return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]   where@@ -330,7 +334,7 @@                alt_bndrs = bndrs,                alt_wrapper = wrapper,                alt_result = match_result} = alt-    (matcher, needs_void_lam) = patSynMatcher psyn+    (matcher_name, _, needs_void_lam) = patSynMatcher psyn      -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn     -- on these extra Void# arguments@@ -366,7 +370,7 @@                      , alt_result = match_result } =       flip adjustMatchResultDs match_result $ \body -> do         case dataConBoxer con of-          Nothing -> return (DataAlt con, args, body)+          Nothing -> return (Alt (DataAlt con) args body)           Just (DCB boxer) -> do             us <- newUniqueSupply             let (rep_ids, binds) = initUs_ us (boxer ty_args args)@@ -374,12 +378,12 @@               -- Upholds the invariant that the binders of a case expression               -- must be scaled by the case multiplicity. See Note [Case               -- expression invariants] in CoreSyn.-            return (DataAlt con, rep_ids', mkLets binds body)+            return (Alt (DataAlt con) rep_ids' (mkLets binds body))      mk_default :: MatchResult (Maybe CoreAlt)     mk_default       | exhaustive_case = MR_Infallible $ return Nothing-      | otherwise       = MR_Fallible $ \fail -> return $ Just (DEFAULT, [], fail)+      | otherwise       = MR_Fallible $ \fail -> return $ Just (Alt DEFAULT [] fail)      mentioned_constructors = mkUniqSet $ map alt_pat sorted_alts     un_mentioned_constructors@@ -409,6 +413,57 @@     return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])  {-+Note [Incompleteness and linearity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The default branch of an incomplete pattern match is compiled to a call+to 'error'.+Because of linearity, we wrap it with an empty case. Example:++f :: a %1 -> Bool -> a+f x True = False++Adding 'f x False = error "Non-exhaustive pattern..."' would violate+the linearity of x.+Instead, we use 'f x False = case error "Non-exhausive pattern..." :: () of {}'.+This case expression accounts for linear variables by assigning bottom usage+(See Note [Bottom as a usage] in GHC.Core.Multiplicity).+This is done in mkFailExpr.+We use '()' instead of the original return type ('a' in this case)+because there might be levity polymorphism, e.g. in++g :: forall (a :: TYPE r). (() -> a) %1 -> Bool -> a+g x True = x ()++adding 'g x False = case error "Non-exhaustive pattern" :: a of {}'+would create an illegal levity-polymorphic case binder.+This is important for pattern synonym matchers, which often look like this 'g'.++Similarly, a hole+h :: a %1 -> a+h x = _+is desugared to 'case error "Hole" :: () of {}'. Test: LinearHole.++Instead of () we could use Data.Void.Void, but that would require+moving Void to GHC.Types: partial pattern matching is used in modules+that are compiled before Data.Void.+We can use () even though it has a constructor, because+Note [Case expression invariants] point 4 in GHC.Core is satisfied+when the scrutinee is bottoming.++You might wonder if this change slows down compilation, but the+performance testsuite did not show up any regressions.++For uniformity, calls to 'error' in both cases are wrapped even if -XLinearTypes+is disabled.+-}++mkFailExpr :: HsMatchContext GhcRn -> Type -> DsM CoreExpr+mkFailExpr ctxt ty+  = do fail_expr <- mkErrorAppDs pAT_ERROR_ID unitTy (matchContextErrString ctxt)+       return $ mkWildCase fail_expr (unrestricted unitTy) ty []+       -- See Note [Incompleteness and linearity]++{- 'mkCoreAppDs' and 'mkCoreAppsDs' handle the special-case desugaring of 'seq'.  Note [Desugaring seq]@@ -453,7 +508,7 @@           I# _ -> ...case b of {True -> fst x; False -> 0}...      We can try to avoid doing this by ensuring that the binder-swap in the-    case happens, so we get his at an early stage:+    case happens, so we get this at an early stage:        case chp of chp2 { I# -> ...chp2... }     But this is fragile.  The real culprit is the source program.  Perhaps we     should have said explicitly@@ -486,13 +541,20 @@ mkCoreAppDs  :: SDoc -> CoreExpr -> CoreExpr -> CoreExpr mkCoreAppDs _ (Var f `App` Type _r `App` Type ty1 `App` Type ty2 `App` arg1) arg2   | f `hasKey` seqIdKey            -- Note [Desugaring seq], points (1) and (2)-  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]+  = Case arg1 case_bndr ty2 [Alt DEFAULT [] arg2]   where     case_bndr = case arg1 of                    Var v1 | isInternalName (idName v1)                           -> v1        -- Note [Desugaring seq], points (2) and (3)                    _      -> mkWildValBinder Many ty1 +mkCoreAppDs _ (Var f `App` Type _r) arg+  | f `hasKey` noinlineIdKey   -- See Note [noinlineId magic] in GHC.Types.Id.Make+  , (fun, args) <- collectArgs arg+  , not (null args)+  = (Var f `App` Type (exprType fun) `App` fun)+    `mkCoreApps` args+ mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in GHC.Core.Make  -- NB: No argument can be levity polymorphic@@ -667,9 +729,9 @@ -} -- Remark: pattern selectors only occur in unrestricted patterns so we are free -- to select Many as the multiplicity of every let-expression introduced.-mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly-                -> LPat GhcTc     -- ^ The pattern-                -> CoreExpr       -- ^ Expression to which the pattern is bound+mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly+                -> LPat GhcTc      -- ^ The pattern+                -> CoreExpr        -- ^ Expression to which the pattern is bound                 -> DsM (Id,[(Id,CoreExpr)])                 -- ^ Id the rhs is bound to, for desugaring strict                 -- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds")@@ -714,7 +776,7 @@            -- Strip the bangs before looking for case (A) or (B)            -- The incoming pattern may well have a bang on it -    binders = collectPatBinders pat'+    binders = collectPatBinders CollNoDictBinders pat'     ticks'  = ticks ++ repeat []      local_binders = map localiseId binders      -- See Note [Localise pattern binders]@@ -736,7 +798,7 @@ is_flat_prod_pat (ConPat { pat_con  = L _ pcon                          , pat_args = ps})   | RealDataCon con <- pcon-  , isProductTyCon (dataConTyCon con)+  , Just _ <- tyConSingleDataCon_maybe (dataConTyCon con)   = all is_triv_lpat (hsConPatArgs ps) is_flat_prod_pat _ = False @@ -759,7 +821,7 @@ ********************************************************************* -}  mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc-mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed+mkLHsPatTup []     = noLocA $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat mkLHsPatTup lpats  = L (getLoc (head lpats)) $                      mkVanillaTuplePat lpats Boxed@@ -773,7 +835,7 @@ mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)  mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc-mkBigLHsTupId = mkChunkified mkLHsTupleExpr+mkBigLHsTupId = mkChunkified (\e -> mkLHsTupleExpr e noExtField)  -- The Big equivalents for the source tuple patterns mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc@@ -853,8 +915,8 @@                       CoreExpr) -- Fail variable applied to realWorld# -- See Note [Failure thunks and CPR] mkFailurePair expr-  = do { fail_fun_var <- newFailLocalDs Many (voidPrimTy `mkVisFunTyMany` ty)-       ; fail_fun_arg <- newSysLocalDs Many voidPrimTy+  = do { fail_fun_var <- newFailLocalDs Many (unboxedUnitTy `mkVisFunTyMany` ty)+       ; fail_fun_arg <- newSysLocalDs Many unboxedUnitTy        ; let real_arg = setOneShotLambda fail_fun_arg        ; return (NonRec fail_fun_var (Lam real_arg expr),                  App (Var fail_fun_var) (Var voidPrimId)) }@@ -896,15 +958,41 @@ it clear that sharing is not an issue.  And that in turn makes it more CPR-friendly.  This matters a lot: if you don't get it right, you lose the tail call property.  For example, see #3403.+-} +dsHandleMonadicFailure :: HsStmtContext GhcRn -> LPat GhcTc -> MatchResult CoreExpr -> FailOperator GhcTc -> DsM CoreExpr+    -- In a do expression, pattern-match failure just calls+    -- the monadic 'fail' rather than throwing an exception+dsHandleMonadicFailure ctx pat match m_fail_op =+  case shareFailureHandler match of+    MR_Infallible body -> body+    MR_Fallible body -> do+      fail_op <- case m_fail_op of+        -- Note that (non-monadic) list comprehension, pattern guards, etc could+        -- have fallible bindings without an explicit failure op, but this is+        -- handled elsewhere. See Note [Failing pattern matches in Stmts] the+        -- breakdown of regular and special binds.+        Nothing -> pprPanic "missing fail op" $+          text "Pattern match:" <+> ppr pat <+>+          text "is failable, and fail_expr was left unset"+        Just fail_op -> pure fail_op+      dflags <- getDynFlags+      fail_msg <- mkStringExpr (mk_fail_msg dflags ctx pat)+      fail_expr <- dsSyntaxExpr fail_op [fail_msg]+      body fail_expr -************************************************************************+mk_fail_msg :: DynFlags -> HsStmtContext GhcRn -> LocatedA e -> String+mk_fail_msg dflags ctx pat+  = showPpr dflags $ text "Pattern match failure in" <+> pprStmtContext ctx+                   <+> text "at" <+> ppr (getLocA pat)++{- ********************************************************************* *                                                                      *               Ticks *                                                                      * ********************************************************************* -} -mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr+mkOptTickBox :: [CoreTickish] -> CoreExpr -> CoreExpr mkOptTickBox = flip (foldr Tick)  mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr@@ -919,8 +1007,8 @@            trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)        --        return $ Case e bndr1 boolTy-                       [ (DataAlt falseDataCon, [], falseBox)-                       , (DataAlt trueDataCon,  [], trueBox)+                       [ Alt (DataAlt falseDataCon) [] falseBox+                       , Alt (DataAlt trueDataCon)  [] trueBox                        ]

GHC/Iface/Binary.hs view

@@ -17,7 +17,7 @@         getSymtabName,         getDictFastString,         CheckHiWay(..),-        TraceBinIFaceReading(..),+        TraceBinIFace(..),         getWithUserData,         putWithUserData, @@ -39,17 +39,16 @@ import GHC.Tc.Utils.Monad import GHC.Builtin.Utils   ( isKnownKeyName, lookupKnownKeyName ) import GHC.Iface.Env-import GHC.Driver.Types import GHC.Unit+import GHC.Unit.Module.ModIface import GHC.Types.Name import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Platform.Profile import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Utils.Panic import GHC.Utils.Binary as Binary import GHC.Types.SrcLoc-import GHC.Utils.Error import GHC.Data.FastMutInt import GHC.Types.Unique import GHC.Utils.Outputable@@ -59,11 +58,9 @@ import GHC.Settings.Constants import GHC.Utils.Misc -import Data.Set (Set) import Data.Array import Data.Array.ST import Data.Array.Unsafe-import Data.Bits import Data.Char import Data.Word import Data.IORef@@ -80,39 +77,34 @@ data CheckHiWay = CheckHiWay | IgnoreHiWay     deriving Eq -data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading-    deriving Eq+data TraceBinIFace+   = TraceBinIFace (SDoc -> IO ())+   | QuietBinIFace  -- | Read an interface file-readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath+readBinIface :: CheckHiWay -> TraceBinIFace -> FilePath              -> TcRnIf a b ModIface readBinIface checkHiWay traceBinIFaceReading hi_path = do     ncu <- mkNameCacheUpdater     dflags <- getDynFlags-    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu+    let profile = targetProfile dflags+    liftIO $ readBinIface_ profile checkHiWay traceBinIFaceReading hi_path ncu  -- | Read an interface file in 'IO'.-readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath+readBinIface_ :: Profile -> CheckHiWay -> TraceBinIFace -> FilePath               -> NameCacheUpdater               -> IO ModIface-readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do-    let platform = targetPlatform dflags--        printer :: SDoc -> IO ()-        printer = case traceBinIFaceReading of-                      TraceBinIFaceReading -> \sd ->-                          putLogMsg dflags-                                    NoReason-                                    SevOutput-                                    noSrcSpan-                                    $ withPprStyle defaultDumpStyle sd-                      QuietBinIFaceReading -> \_ -> return ()+readBinIface_ profile checkHiWay traceBinIFace hi_path ncu = do+    let platform = profilePlatform profile          wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()         wantedGot what wanted got ppr' =-            printer (text what <> text ": " <>+            case traceBinIFace of+               QuietBinIFace         -> return ()+               TraceBinIFace printer -> printer $+                     text what <> text ": " <>                      vcat [text "Wanted " <> ppr' wanted <> text ",",-                           text "got    " <> ppr' got])+                           text "got    " <> ppr' got]          errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()         errorOnMismatch what wanted got =@@ -131,17 +123,17 @@     errorOnMismatch "magic number mismatch: old/corrupt interface file?"         (unFixedLength $ binaryInterfaceMagic platform) (unFixedLength magic) -    -- Check the interface file version and ways.+    -- Check the interface file version and profile tag.     check_ver  <- get bh     let our_ver = show hiVersion     wantedGot "Version" our_ver check_ver text     errorOnMismatch "mismatched interface file versions" our_ver check_ver -    check_way <- get bh-    let way_descr = getWayDescr platform (ways dflags)-    wantedGot "Way" way_descr check_way ppr+    check_tag <- get bh+    let tag = profileBuildTag profile+    wantedGot "Way" tag check_tag ppr     when (checkHiWay == CheckHiWay) $-        errorOnMismatch "mismatched interface file ways" way_descr check_way+        errorOnMismatch "mismatched interface file profile tag" tag check_tag      extFields_p <- get bh @@ -185,21 +177,21 @@     get bh  -- | Write an interface file-writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()-writeBinIface dflags hi_path mod_iface = do+writeBinIface :: Profile -> TraceBinIFace -> FilePath -> ModIface -> IO ()+writeBinIface profile traceBinIface hi_path mod_iface = do     bh <- openBinMem initBinMemSize-    let platform = targetPlatform dflags+    let platform = profilePlatform profile     put_ bh (binaryInterfaceMagic platform) -    -- The version and way descriptor go next+    -- The version and profile tag go next     put_ bh (show hiVersion)-    let way_descr = getWayDescr platform (ways dflags)-    put_  bh way_descr+    let tag = profileBuildTag profile+    put_  bh tag      extFields_p_p <- tellBin bh     put_ bh extFields_p_p -    putWithUserData (debugTraceMsg dflags 3) bh mod_iface+    putWithUserData traceBinIface bh mod_iface      extFields_p <- tellBin bh     putAt bh extFields_p_p extFields_p@@ -213,8 +205,8 @@ -- is necessary if you want to serialise Names or FastStrings. -- It also writes a symbol table and the dictionary. -- This segment should be read using `getWithUserData`.-putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()-putWithUserData log_action bh payload = do+putWithUserData :: Binary a => TraceBinIFace -> BinHandle -> a -> IO ()+putWithUserData traceBinIface bh payload = do     -- Remember where the dictionary pointer will go     dict_p_p <- tellBin bh     -- Placeholder for ptr to dictionary@@ -224,14 +216,12 @@     symtab_p_p <- tellBin bh     put_ bh symtab_p_p     -- Make some initial state-    symtab_next <- newFastMutInt-    writeFastMutInt symtab_next 0+    symtab_next <- newFastMutInt 0     symtab_map <- newIORef emptyUFM     let bin_symtab = BinSymbolTable {                          bin_symtab_next = symtab_next,                          bin_symtab_map  = symtab_map }-    dict_next_ref <- newFastMutInt-    writeFastMutInt dict_next_ref 0+    dict_next_ref <- newFastMutInt 0     dict_map_ref <- newIORef emptyUFM     let bin_dict = BinDictionary {                        bin_dict_next = dict_next_ref,@@ -252,8 +242,11 @@     symtab_next <- readFastMutInt symtab_next     symtab_map  <- readIORef symtab_map     putSymbolTable bh symtab_next symtab_map-    log_action (text "writeBinIface:" <+> int symtab_next-                                <+> text "Names")+    case traceBinIface of+      QuietBinIFace         -> return ()+      TraceBinIFace printer ->+         printer (text "writeBinIface:" <+> int symtab_next+                                        <+> text "Names")      -- NB. write the dictionary after the symbol table, because     -- writing the symbol table may create more dictionary entries.@@ -267,8 +260,11 @@     dict_next <- readFastMutInt dict_next_ref     dict_map  <- readIORef dict_map_ref     putDictionary bh dict_next dict_map-    log_action (text "writeBinIface:" <+> int dict_next-                                <+> text "dict entries")+    case traceBinIface of+      QuietBinIFace         -> return ()+      TraceBinIFace printer ->+         printer (text "writeBinIface:" <+> int dict_next+                                        <+> text "dict entries")   @@ -430,10 +426,3 @@                                 -- indexed by FastString   } -getWayDescr :: Platform -> Set Way -> String-getWayDescr platform ws-  | platformUnregisterised platform = 'u':tag-  | otherwise                       =     tag-  where tag = waysBuildTag ws-        -- if this is an unregisterised build, make sure our interfaces-        -- can't be used by a registerised build.

GHC/Iface/Env.hs view

@@ -16,7 +16,7 @@         ifaceExportNames,          -- Name-cache stuff-        allocateGlobalBinder, updNameCacheTc,+        allocateGlobalBinder, updNameCacheTc, updNameCache,         mkNameCacheUpdater, NameCacheUpdater(..),    ) where @@ -24,22 +24,29 @@  import GHC.Prelude +import GHC.Driver.Env+ import GHC.Tc.Utils.Monad-import GHC.Driver.Types import GHC.Core.Type-import GHC.Types.Var-import GHC.Types.Name-import GHC.Types.Avail+import GHC.Iface.Type+import GHC.Runtime.Context+ import GHC.Unit.Module+import GHC.Unit.Module.ModIface+ import GHC.Data.FastString import GHC.Data.FastString.Env-import GHC.Iface.Type++import GHC.Types.Var+import GHC.Types.Name+import GHC.Types.Avail import GHC.Types.Name.Cache import GHC.Types.Unique.Supply import GHC.Types.SrcLoc  import GHC.Utils.Outputable import Data.List     ( partition )+import Data.IORef  {- *********************************************************@@ -296,3 +303,20 @@   = do  { uniqs <- newUniqueSupply         ; return [ mkInternalName uniq occ noSrcSpan                  | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }++{-+Names in a NameCache are always stored as a Global, and have the SrcLoc+of their binding locations.++Actually that's not quite right.  When we first encounter the original+name, we might not be at its binding site (e.g. we are reading an+interface file); so we give it 'noSrcLoc' then.  Later, when we find+its binding site, we fix it up.+-}++updNameCache :: IORef NameCache+             -> (NameCache -> (NameCache, c))  -- The updating function+             -> IO c+updNameCache ncRef upd_fn+  = atomicModifyIORef' ncRef upd_fn+

GHC/Iface/Ext/Ast.hs view

@@ -1,24 +1,26 @@+{-# LANGUAGE AllowAmbiguousTypes     #-}+{-# LANGUAGE CPP                     #-}+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DeriveDataTypeable      #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE OverloadedStrings       #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- Main functions for .hie file generation -}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE UndecidableSuperClasses #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE TupleSections #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +#include "HsVersions.h"+ module GHC.Iface.Ext.Ast ( mkHieFile, mkHieFileWithSource, getCompressedAsts, enrichHie) where  import GHC.Utils.Outputable(ppr)@@ -29,17 +31,15 @@ import GHC.Data.Bag               ( Bag, bagToList ) import GHC.Types.Basic import GHC.Data.BooleanFormula-import GHC.Core.Class             ( FunDep, className, classSCSelIds )+import GHC.Core.Class             ( className, classSCSelIds ) import GHC.Core.Utils             ( exprType ) import GHC.Core.ConLike           ( conLikeName, ConLike(RealDataCon) ) import GHC.Core.TyCon             ( TyCon, tyConClass_maybe ) import GHC.Core.FVs import GHC.Core.DataCon           ( dataConNonlinearType )-import GHC.HsToCore               ( deSugarExpr ) import GHC.Types.FieldLabel import GHC.Hs-import GHC.Driver.Types-import GHC.Unit.Module            ( ModuleName, ml_hs_file )+import GHC.Driver.Env import GHC.Utils.Monad            ( concatMapM, liftIO ) import GHC.Types.Id               ( isDataConId_maybe ) import GHC.Types.Name             ( Name, nameSrcSpan, nameUnique )@@ -52,27 +52,34 @@ import GHC.Builtin.Types          ( mkListTy, mkSumTy ) import GHC.Tc.Types import GHC.Tc.Types.Evidence-import GHC.Types.Var              ( Id, Var, EvId, varName, setVarName, varType, varUnique )+import GHC.Types.Var              ( Id, Var, EvId, varName, varType, varUnique ) import GHC.Types.Var.Env-import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Iface.Make             ( mkIfaceExports ) import GHC.Utils.Panic+import GHC.Utils.Misc import GHC.Data.Maybe import GHC.Data.FastString  import GHC.Iface.Ext.Types import GHC.Iface.Ext.Utils +import GHC.Unit.Module            ( ModuleName, ml_hs_file )+import GHC.Unit.Module.ModSummary+ import qualified Data.Array as A import qualified Data.ByteString as BS import qualified Data.Map as M import qualified Data.Set as S import Data.Data                  ( Data, Typeable )-import Data.List                  ( foldl1' )+import Data.Void                  ( Void, absurd ) import Control.Monad              ( forM_ ) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class  ( lift )+import GHC.HsToCore.Types+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad  {- Note [Updating HieAst for changes in the GHC AST] @@ -161,7 +168,7 @@ straightforward.  If you are extending the GHC AST, you will need to provide a `ToHie` instance for any new types you may have introduced in the AST. -Here are is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):+Here is an extract from the `ToHie` instance for (LHsExpr (GhcPass p)):    toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of       HsVar _ (L _ var) ->@@ -273,7 +280,7 @@       = addSubstitution mono poly . f     go _ f = f -type HieM = ReaderT NodeOrigin (StateT HieState Hsc)+type HieM = ReaderT NodeOrigin (StateT HieState DsM)  -- | Construct an 'HieFile' from the outputs of the typechecker. mkHieFile :: ModSummary@@ -296,7 +303,9 @@       top_ev_binds = tcg_ev_binds ts       insts = tcg_insts ts       tcs = tcg_tcs ts-  (asts', arr) <- getCompressedAsts tc_binds rs top_ev_binds insts tcs+  hsc_env <- Hsc $ \e w -> return (e, w)+  (_msgs, res) <- liftIO $ initDs hsc_env ts $ getCompressedAsts tc_binds rs top_ev_binds insts tcs+  let (asts',arr) = expectJust "mkHieFileWithSource" res   return $ HieFile       { hie_hs_file = src_file       , hie_module = ms_mod ms@@ -308,13 +317,13 @@       }  getCompressedAsts :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+  -> DsM (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat) getCompressedAsts ts rs top_ev_binds insts tcs = do   asts <- enrichHie ts rs top_ev_binds insts tcs   return $ compressTypes asts  enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]-  -> Hsc (HieASTs Type)+  -> DsM (HieASTs Type) enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =   flip evalStateT initState $ flip runReaderT SourceInfo $ do     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts@@ -342,12 +351,14 @@           , exps           ] -        modulify file xs' = do+        modulify (HiePath file) xs' = do -          top_ev_asts <-+          top_ev_asts :: [HieAST Type] <- do+            let+              l :: SrcSpanAnnA+              l = noAnnSrcSpan (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)             toHie $ EvBindContext ModuleScope Nothing-                  $ L (RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc file 1 1) Nothing)-                  $ EvBinds ev_bs+                  $ L l (EvBinds ev_bs)            (uloc_evs,more_ev_asts) <- getUnlocatedEvBinds file @@ -363,12 +374,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@@ -386,13 +397,17 @@       , toHie $ hs_ruleds grp       ] +getRealSpanA :: SrcSpanAnn' ann -> Maybe Span+getRealSpanA la = getRealSpan (locA la)+ getRealSpan :: SrcSpan -> Maybe Span getRealSpan (RealSrcSpan sp _) = Just sp getRealSpan _ = Nothing -grhss_span :: GRHSs p body -> SrcSpan-grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)-grhss_span (XGRHSs _) = panic "XGRHS has no span"+grhss_span :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan+              , Data (HsLocalBinds (GhcPass p)))+           => GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) -> SrcSpan+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (spanHsLocaLBinds bs) (map getLoc xs)  bindingsOnly :: [Context Name] -> HieM [HieAST a] bindingsOnly [] = pure []@@ -465,13 +480,13 @@ -- things to its right, ala RScoped  -- | Each element scopes over the elements to the right-listScopes :: Scope -> [Located a] -> [RScoped (Located a)]+listScopes :: Scope -> [LocatedA a] -> [RScoped (LocatedA a)] listScopes _ [] = [] listScopes rhsScope [pat] = [RS rhsScope pat] listScopes rhsScope (pat : pats) = RS sc pat : pats'   where     pats'@((RS scope p):_) = listScopes rhsScope pats-    sc = combineScopes scope $ mkScope $ getLoc p+    sc = combineScopes scope $ mkScope $ getLocA p  -- | 'listScopes' specialised to 'PScoped' things patScopes@@ -484,12 +499,24 @@   map (\(RS sc a) -> PS rsp useScope sc a) $     listScopes patScope xs +-- | 'listScopes' specialised to 'HsPatSigType'+tScopes+  :: Scope+  -> Scope+  -> [HsPatSigType (GhcPass a)]+  -> [TScoped (HsPatSigType (GhcPass a))]+tScopes scope rhsScope xs =+  map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $+    listScopes rhsScope (map (\hsps -> L (getLoc $ hsps_body hsps) hsps) xs)+  -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.+  -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.+ -- | 'listScopes' specialised to 'TVScoped' things tvScopes   :: TyVarScope   -> Scope-  -> [LHsTyVarBndr flag a]-  -> [TVScoped (LHsTyVarBndr flag a)]+  -> [LHsTyVarBndr flag (GhcPass a)]+  -> [TVScoped (LHsTyVarBndr flag (GhcPass a))] tvScopes tvScope rhsScope xs =   map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs @@ -512,39 +539,32 @@ -}  class HasLoc a where-  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can-  -- know what their implicit bindings are scoping over+  -- ^ conveniently calculate locations for things without locations attached   loc :: a -> SrcSpan -instance HasLoc thing => HasLoc (TScoped thing) where-  loc (TS _ a) = loc a- instance HasLoc thing => HasLoc (PScoped thing) where   loc (PS _ _ _ a) = loc a -instance HasLoc (LHsQTyVars GhcRn) where-  loc (HsQTvs _ vs) = loc vs--instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where-  loc (HsIB _ a) = loc a-  loc _ = noSrcSpan--instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where-  loc (HsWC _ a) = loc a-  loc _ = noSrcSpan- instance HasLoc (Located a) where   loc (L l _) = l +instance HasLoc (LocatedA a) where+  loc (L la _) = locA la++instance HasLoc (LocatedN a) where+  loc (L la _) = locA la+ instance HasLoc a => HasLoc [a] where   loc [] = noSrcSpan   loc xs = foldl1' combineSrcSpans $ map loc xs -instance HasLoc a => HasLoc (FamEqn s a) where-  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]-  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans-                                              [loc a, loc tvs, loc b, loc c]-  loc _ = noSrcSpan+instance (HasLoc a, HiePass p) => HasLoc (FamEqn (GhcPass p) a) where+  loc (FamEqn _ a outer_bndrs b _ c) = case outer_bndrs of+    HsOuterImplicit{} ->+      foldl1' combineSrcSpans [loc a, loc b, loc c]+    HsOuterExplicit{hso_bndrs = tvs} ->+      foldl1' combineSrcSpans [loc a, loc tvs, loc b, loc c]+ instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where   loc (HsValArg tm) = loc tm   loc (HsTypeArg _ ty) = loc ty@@ -555,21 +575,6 @@     -- Only used for data family instances, so we only need rhs     -- Most probably the rest will be unhelpful anyway -{- Note [Real DataCon Name]-The typechecker substitutes the conLikeWrapId for the name, but we don't want-this showing up in the hieFile, so we replace the name in the Id with the-original datacon name-See also Note [Data Constructor Naming]--}-class HasRealDataConName p where-  getRealDataCon :: XRecordCon p -> Located (IdP p) -> Located (IdP p)--instance HasRealDataConName GhcRn where-  getRealDataCon _ n = n-instance HasRealDataConName GhcTc where-  getRealDataCon RecordConTc{rcon_con_like = con} (L sp var) =-    L sp (setVarName var (conLikeName con))- -- | The main worker class -- See Note [Updating HieAst for changes in the GHC AST] for more information -- on how to add/modify instances for this.@@ -580,6 +585,9 @@ class HasType a where   getTypeNode :: a -> HieM [HieAST Type] +instance ToHie Void where+  toHie v = absurd v+ instance (ToHie a) => ToHie [a] where   toHie = concatMapM toHie @@ -589,14 +597,20 @@ instance (ToHie a) => ToHie (Maybe a) where   toHie = maybe (pure []) toHie -instance ToHie (IEContext (Located ModuleName)) where-  toHie (IEC c (L (RealSrcSpan span _) mname)) = do+instance ToHie (IEContext (LocatedA ModuleName)) where+  toHie (IEC c (L (SrcSpanAnn _ (RealSrcSpan span _)) mname)) = do       org <- ask       pure $ [Node (mkSourcedNodeInfo org $ NodeInfo S.empty [] idents) span []]     where details = mempty{identInfo = S.singleton (IEThing c)}           idents = M.singleton (Left mname) details   toHie _ = pure [] +instance ToHie (Context (Located a)) => ToHie (Context (LocatedN a)) where+  toHie (C c (L l a)) = toHie (C c (L (locA l) a))++instance ToHie (Context (Located a)) => ToHie (Context (LocatedA a)) where+  toHie (C c (L l a)) = toHie (C c (L (locA l) a))+ instance ToHie (Context (Located Var)) where   toHie c = case c of       C context (L (RealSrcSpan span _) name')@@ -655,7 +669,7 @@     EvTypeableTyLit e     -> evVarsOfTermList e evVarsOfTermList (EvFun{}) = [] -instance ToHie (EvBindContext (Located TcEvBinds)) where+instance ToHie (EvBindContext (LocatedA TcEvBinds)) where   toHie (EvBindContext sc sp (L span (EvBinds bs)))     = concatMapM go $ bagToList bs     where@@ -663,40 +677,40 @@           let evDeps = evVarsOfTermList $ eb_rhs evbind               depNames = EvBindDeps $ map varName evDeps           concatM $-            [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScope span)) sp)+            [ toHie (C (EvidenceVarBind (EvLetBind depNames) (combineScopes sc (mkScopeA span)) sp)                                         (L span $ eb_lhs evbind))             , toHie $ map (C EvidenceVarUse . L span) $ evDeps             ]   toHie _ = pure [] -instance ToHie (Located HsWrapper) where+instance ToHie (LocatedA HsWrapper) where   toHie (L osp wrap)     = case wrap of-        (WpLet bs)      -> toHie $ EvBindContext (mkScope osp) (getRealSpan osp) (L osp bs)+        (WpLet bs)      -> toHie $ EvBindContext (mkScopeA osp) (getRealSpanA osp) (L osp bs)         (WpCompose a b) -> concatM $           [toHie (L osp a), toHie (L osp b)]         (WpFun a b _ _) -> concatM $           [toHie (L osp a), toHie (L osp b)]         (WpEvLam a) ->-          toHie $ C (EvidenceVarBind EvWrapperBind (mkScope osp) (getRealSpan osp))+          toHie $ C (EvidenceVarBind EvWrapperBind (mkScopeA osp) (getRealSpanA osp))                 $ L osp a         (WpEvApp a) ->           concatMapM (toHie . C EvidenceVarUse . L osp) $ evVarsOfTermList a         _               -> pure [] -instance HiePass p => HasType (LHsBind (GhcPass p)) where+instance HiePass p => HasType (LocatedA (HsBind (GhcPass p))) where   getTypeNode (L spn bind) =     case hiePass @p of-      HieRn -> makeNode bind spn+      HieRn -> makeNode bind (locA spn)       HieTc ->  case bind of-        FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)-        _ -> makeNode bind spn+        FunBind{fun_id = name} -> makeTypeNode bind (locA spn) (varType $ unLoc name)+        _ -> makeNode bind (locA spn) -instance HiePass p => HasType (Located (Pat (GhcPass p))) where+instance HiePass p => HasType (LocatedA (Pat (GhcPass p))) where   getTypeNode (L spn pat) =     case hiePass @p of-      HieRn -> makeNode pat spn-      HieTc -> makeTypeNode pat spn (hsPatType pat)+      HieRn -> makeNodeA pat spn+      HieTc -> makeTypeNodeA pat spn (hsPatType pat)  -- | This instance tries to construct 'HieAST' nodes which include the type of -- the expression. It is not yet possible to do this efficiently for all@@ -713,13 +727,14 @@ -- expression's type is going to be expensive. -- -- See #16233-instance HiePass p => HasType (LHsExpr (GhcPass p)) where+instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where   getTypeNode e@(L spn e') =     case hiePass @p of-      HieRn -> makeNode e' spn+      HieRn -> makeNodeA e' spn       HieTc ->         -- Some expression forms have their type immediately available         let tyOpt = case e' of+              HsUnboundVar (HER _ ty _) _ -> Just ty               HsLit _ l -> Just (hsLitType l)               HsOverLit _ o -> Just (overLitType o) @@ -729,7 +744,7 @@               HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)               HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy) -              ExplicitList  ty _ _   -> Just (mkListTy ty)+              ExplicitList  ty _     -> Just (mkListTy ty)               ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)               HsDo          ty _ _   -> Just ty               HsMultiIf     ty _     -> Just ty@@ -738,15 +753,16 @@          in         case tyOpt of-          Just t -> makeTypeNode e' spn t+          Just t -> makeTypeNodeA e' spn t           Nothing             | skipDesugaring e' -> fallback             | otherwise -> do-                hs_env <- lift $ lift $ Hsc $ \e w -> return (e,w)-                (_,mbe) <- liftIO $ deSugarExpr hs_env e-                maybe fallback (makeTypeNode e' spn . exprType) mbe+                (e, no_errs) <- lift $ lift $ discardWarningsDs $ askNoErrsDs $ dsLExpr e+                if no_errs+                  then makeTypeNodeA e' spn . exprType $ e+                  else fallback         where-          fallback = makeNode e' spn+          fallback = makeNodeA e' spn            matchGroupType :: MatchGroupTc -> Type           matchGroupType (MatchGroupTc args res) = mkVisFunTys args res@@ -759,7 +775,6 @@           skipDesugaring :: HsExpr GhcTc -> Bool           skipDesugaring e = case e of             HsVar{}             -> False-            HsUnboundVar{}      -> False             HsConLikeOut{}      -> False             HsRecFld{}          -> False             HsOverLabel{}       -> False@@ -774,12 +789,16 @@ class ( IsPass p       , HiePass (NoGhcTcPass p)       , ModifyState (IdGhcP p)-      , Data (GRHS (GhcPass p) (Located (HsExpr (GhcPass p))))+      , Data (GRHS  (GhcPass p) (LocatedA (HsExpr (GhcPass p))))+      , Data (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))+      , Data (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))+      , Data (Stmt  (GhcPass p) (LocatedA (HsExpr (GhcPass p))))+      , Data (Stmt  (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))       , Data (HsExpr (GhcPass p))-      , Data (HsCmd (GhcPass p))+      , Data (HsCmd  (GhcPass p))       , Data (AmbiguousFieldOcc (GhcPass p))       , Data (HsCmdTop (GhcPass p))-      , Data (GRHS (GhcPass p) (Located (HsCmd (GhcPass p))))+      , Data (GRHS (GhcPass p) (LocatedA (HsCmd (GhcPass p))))       , Data (HsSplice (GhcPass p))       , Data (HsLocalBinds (GhcPass p))       , Data (FieldOcc (GhcPass p))@@ -790,7 +809,7 @@       , ToHie (RFContext (Located (FieldOcc (GhcPass p))))       , ToHie (TScoped (LHsWcType (GhcPass (NoGhcTcPass p))))       , ToHie (TScoped (LHsSigWcType (GhcPass (NoGhcTcPass p))))-      , HasRealDataConName (GhcPass p)+      , Anno (IdGhcP p) ~ SrcSpanAnnN       )       => HiePass p where   hiePass :: HiePassEv p@@ -800,18 +819,38 @@ instance HiePass 'Typechecked where   hiePass = HieTc -instance HiePass p => ToHie (BindContext (LHsBind (GhcPass p))) where+instance ToHie (Context (Located NoExtField)) where+  toHie _ = pure []++type AnnoBody p body+  = ( Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                   ~ SrcSpanAnnA+    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+                   ~ SrcSpanAnnL+    , Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                   ~ SrcSpan+    , Anno (StmtLR (GhcPass p) (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA++    , Data (body (GhcPass p))+    , Data (Match (GhcPass p) (LocatedA (body (GhcPass p))))+    , Data (GRHS  (GhcPass p) (LocatedA (body (GhcPass p))))+    , Data (Stmt  (GhcPass p) (LocatedA (body (GhcPass p))))++    , IsPass p+    )++instance HiePass p => ToHie (BindContext (LocatedA (HsBind (GhcPass p)))) where   toHie (BC context scope b@(L span bind)) =     concatM $ getTypeNode b : case bind of       FunBind{fun_id = name, fun_matches = matches, fun_ext = wrap} ->-        [ toHie $ C (ValBind context scope $ getRealSpan span) name+        [ toHie $ C (ValBind context scope $ getRealSpanA span) name         , toHie matches         , case hiePass @p of             HieTc -> toHie $ L span wrap             _ -> pure []         ]       PatBind{pat_lhs = lhs, pat_rhs = rhs} ->-        [ toHie $ PS (getRealSpan span) scope NoScope lhs+        [ toHie $ PS (getRealSpan (locA span)) scope NoScope lhs         , toHie rhs         ]       VarBind{var_rhs = expr} ->@@ -824,26 +863,26 @@                 (toHie $ fmap (BC context scope) binds)         , toHie $ map (L span . abe_wrap) xs         , toHie $-            map (EvBindContext (mkScope span) (getRealSpan span)+            map (EvBindContext (mkScopeA span) (getRealSpanA span)                 . L span) ev_binds         , toHie $             map (C (EvidenceVarBind EvSigBind-                                    (mkScope span)-                                    (getRealSpan span))+                                    (mkScopeA span)+                                    (getRealSpanA span))                 . L span) ev_vars         ]       PatSynBind _ psb ->-        [ toHie $ L span psb -- PatSynBinds only occur at the top level+        [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level         ]  instance ( HiePass p-         , ToHie (Located body)-         , Data body-         ) => ToHie (MatchGroup (GhcPass p) (Located body)) where+         , AnnoBody p body+         , ToHie (LocatedA (body (GhcPass p)))+         ) => ToHie (MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))) where   toHie mg = case mg of     MG{ mg_alts = (L span alts) , mg_origin = origin} ->       local (setOrigin origin) $ concatM-        [ locOnly span+        [ locOnly (locA span)         , toHie alts         ] @@ -861,18 +900,18 @@         ]         where           lhsScope = combineScopes varScope detScope-          varScope = mkLScope var-          patScope = mkScope $ getLoc pat+          varScope = mkLScopeN var+          patScope = mkScopeA $ getLoc pat           detScope = case dets of-            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args-            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)+            (PrefixCon _ args) -> foldr combineScopes NoScope $ map mkLScopeN args+            (InfixCon a b) -> combineScopes (mkLScopeN a) (mkLScopeN b)             (RecCon r) -> foldr go NoScope r           go (RecordPatSynField a b) c = combineScopes c-            $ combineScopes (mkLScope a) (mkLScope b)+            $ combineScopes (mkLScopeN (rdrNameFieldOcc a)) (mkLScopeN b)           detSpan = case detScope of             LocalScope a -> Just a             _ -> Nothing-          toBind (PrefixCon args) = PrefixCon $ map (C Use) args+          toBind (PrefixCon ts args) = ASSERT(null ts) PrefixCon ts $ map (C Use) args           toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)           toBind (RecCon r) = RecCon $ map (PSC detSpan) r @@ -882,9 +921,10 @@     _ -> pure []  instance ( HiePass p-         , Data body-         , ToHie (Located body)-         ) => ToHie (LMatch (GhcPass p) (Located body)) where+         , Data (body (GhcPass p))+         , AnnoBody p body+         , ToHie (LocatedA (body (GhcPass p)))+         ) => ToHie (LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))) where   toHie (L span m ) = concatM $ node : case m of     Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->       [ toHie mctx@@ -894,8 +934,8 @@       ]     where       node = case hiePass @p of-        HieTc -> makeNode m span-        HieRn -> makeNode m span+        HieTc -> makeNodeA m span+        HieRn -> makeNodeA m span  instance HiePass p => ToHie (HsMatchContext (GhcPass p)) where   toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name@@ -908,7 +948,7 @@   toHie (TransStmtCtxt a) = toHie a   toHie _ = pure [] -instance HiePass p => ToHie (PScoped (Located (Pat (GhcPass p)))) where+instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where   toHie (PS rsp scope pscope lpat@(L ospan opat)) =     concatM $ getTypeNode lpat : case opat of       WildPat _ ->@@ -921,7 +961,7 @@         ]       AsPat _ lname pat ->         [ toHie $ C (PatternBind scope-                                 (combineScopes (mkLScope pat) pscope)+                                 (combineScopes (mkLScopeA pat) pscope)                                  rsp)                     lname         , toHie $ PS rsp scope pscope pat@@ -949,12 +989,12 @@             , let ev_binds = cpt_binds ext                   ev_vars = cpt_dicts ext                   wrap = cpt_wrap ext-                  evscope = mkScope ospan `combineScopes` scope `combineScopes` pscope+                  evscope = mkScopeA ospan `combineScopes` scope `combineScopes` pscope                  in concatM [ toHie $ EvBindContext scope rsp $ L ospan ev_binds                             , toHie $ L ospan wrap                             , toHie $ map (C (EvidenceVarBind EvPatternBind evscope rsp)                                           . L ospan) ev_vars-                          ]+                            ]             ]           HieRn ->             [ toHie $ C Use con@@ -978,7 +1018,7 @@         [ toHie $ PS rsp scope pscope pat         , case hiePass @p of             HieTc ->-              let cscope = mkLScope pat in+              let cscope = mkLScopeA pat in                 toHie $ TS (ResolvedScopes [cscope, scope, pscope])                            sig             HieRn -> pure []@@ -994,65 +1034,66 @@           HieRn -> [] #endif     where-      contextify :: a ~ LPat (GhcPass p) => HsConDetails a (HsRecFields (GhcPass p) a)-                 -> HsConDetails (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))-      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args+      contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsPatSigType (NoGhcTc (GhcPass p))) a (HsRecFields (GhcPass p) a)+                 -> HsConDetails (TScoped (HsPatSigType (NoGhcTc (GhcPass p)))) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))+      contextify (PrefixCon tyargs args) = PrefixCon (tScopes scope argscope tyargs) (patScopes rsp scope pscope args)+        where argscope = foldr combineScopes NoScope $ map mkLScopeA args       contextify (InfixCon a b) = InfixCon a' b'         where [a', b'] = patScopes rsp scope pscope [a,b]       contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r       contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a         where-          go (RS fscope (L spn (HsRecField lbl pat pun))) =-            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun+          go :: RScoped (LocatedA (HsRecField' id a1))+                      -> LocatedA (HsRecField' id (PScoped a1)) -- AZ+          go (RS fscope (L spn (HsRecField x lbl pat pun))) =+            L spn $ HsRecField x lbl (PS rsp scope fscope pat) pun           scoped_fds = listScopes pscope fds - instance ToHie (TScoped (HsPatSigType GhcRn)) where   toHie (TS sc (HsPS (HsPSRn wcs tvs) body@(L span _))) = concatM $-      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) (wcs++tvs)+      [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs++tvs)       , toHie body       ]   -- See Note [Scoping Rules for SigPat] -instance ( ToHie (Located body)+instance ( ToHie (LocatedA (body (GhcPass p)))          , HiePass p-         , Data body-         ) => ToHie (GRHSs (GhcPass p) (Located body)) where+         , AnnoBody p body+         ) => ToHie (GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))) where   toHie grhs = concatM $ case grhs of     GRHSs _ grhss binds ->      [ toHie grhss      , toHie $ RS (mkScope $ grhss_span grhs) binds      ] -instance ( ToHie (Located body)-         , HiePass a-         , Data body-         ) => ToHie (LGRHS (GhcPass a) (Located body)) where+instance ( ToHie (LocatedA (body (GhcPass p)))+         , HiePass p+         , AnnoBody p body+         ) => ToHie (Located (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))) where   toHie (L span g) = concatM $ node : case g of     GRHS _ guards body ->-      [ toHie $ listScopes (mkLScope body) guards+      [ toHie $ listScopes (mkLScopeA body) guards       , toHie body       ]     where-      node = case hiePass @a of+      node = case hiePass @p of         HieRn -> makeNode g span         HieTc -> makeNode g span -instance HiePass p => ToHie (LHsExpr (GhcPass p)) where+instance HiePass p => ToHie (LocatedA (HsExpr (GhcPass p))) where   toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of       HsVar _ (L _ var) ->         [ toHie $ C Use (L mspan var)              -- Patch up var location since typechecker removes it         ]-      HsUnboundVar _ _ ->-        []+      HsUnboundVar _ _ -> []  -- there is an unbound name here, but that causes trouble       HsConLikeOut _ con ->         [ toHie $ C Use $ L mspan $ conLikeName con         ]       HsRecFld _ fld ->-        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)+        [ toHie $ RFC RecFieldOcc Nothing (L (locA mspan) fld)         ]-      HsOverLabel _ _ _ -> []+      HsOverLabel {} -> []       HsIPVar _ _ -> []       HsOverLit _ _ -> []       HsLit _ _ -> []@@ -1108,28 +1149,35 @@         [ toHie grhss         ]       HsLet _ binds expr ->-        [ toHie $ RS (mkLScope expr) binds+        [ toHie $ RS (mkLScopeA expr) binds         , toHie expr         ]       HsDo _ _ (L ispan stmts) ->-        [ locOnly ispan+        [ locOnly (locA ispan)         , toHie $ listScopes NoScope stmts         ]-      ExplicitList _ _ exprs ->+      ExplicitList _ exprs ->         [ toHie exprs         ]-      RecordCon {rcon_ext = mrealcon, rcon_con_name = name, rcon_flds = binds} ->-        [ toHie $ C Use (getRealDataCon @(GhcPass p) mrealcon name)-            -- See Note [Real DataCon Name]+      RecordCon { rcon_con = con, rcon_flds = binds} ->+        [ toHie $ C Use $ con_name         , toHie $ RC RecFieldAssign $ binds         ]-      RecordUpd {rupd_expr = expr, rupd_flds = upds}->+        where+          con_name :: LocatedN Name+          con_name = case hiePass @p of       -- Like ConPat+                       HieRn -> con+                       HieTc -> fmap conLikeName con+      RecordUpd {rupd_expr = expr, rupd_flds = Left upds}->         [ toHie expr         , toHie $ map (RC RecFieldAssign) upds         ]+      RecordUpd {rupd_expr = expr, rupd_flds = Right _}->+        [ toHie expr+        ]       ExprWithTySig _ expr sig ->         [ toHie expr-        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig+        , toHie $ TS (ResolvedScopes [mkLScopeA expr]) sig         ]       ArithSeq _ _ info ->         [ toHie info@@ -1164,6 +1212,8 @@       HsSpliceE _ x ->         [ toHie $ L mspan x         ]+      HsGetField {} -> []+      HsProjection {} -> []       XExpr x         | GhcTc <- ghcPass @p         , WrapExpr (HsWrap w a) <- x@@ -1176,23 +1226,24 @@            ]         | otherwise -> [] -instance HiePass p => ToHie (LHsTupArg (GhcPass p)) where-  toHie (L span arg) = concatM $ makeNode arg span : case arg of+-- NOTE: no longer have the location+instance HiePass p => ToHie (HsTupArg (GhcPass p)) where+  toHie arg = concatM $ case arg of     Present _ expr ->       [ toHie expr       ]     Missing _ -> [] -instance ( ToHie (Located body)-         , Data body+instance ( ToHie (LocatedA (body (GhcPass p)))+         , AnnoBody p body          , HiePass p-         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+         ) => ToHie (RScoped (LocatedA (Stmt (GhcPass p) (LocatedA (body (GhcPass p)))))) where   toHie (RS scope (L span stmt)) = concatM $ node : case stmt of       LastStmt _ body _ _ ->         [ toHie body         ]       BindStmt _ pat body ->-        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat+        [ toHie $ PS (getRealSpan $ getLocA body) scope NoScope pat         , toHie body         ]       ApplicativeStmt _ stmts _ ->@@ -1214,34 +1265,60 @@         , toHie using         , toHie by         ]-      RecStmt {recS_stmts = stmts} ->-        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts+      RecStmt {recS_stmts = L _ stmts} ->+        [ toHie $ map (RS $ combineScopes scope (mkScope (locA span))) stmts         ]     where       node = case hiePass @p of-        HieTc -> makeNode stmt span-        HieRn -> makeNode stmt span+        HieTc -> makeNodeA stmt span+        HieRn -> makeNodeA stmt span -instance HiePass p => ToHie (RScoped (LHsLocalBinds (GhcPass p))) where-  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+instance HiePass p => ToHie (RScoped (HsLocalBinds (GhcPass p))) where+  toHie (RS scope binds) = concatM $ makeNode binds (spanHsLocaLBinds binds) : case binds of       EmptyLocalBinds _ -> []       HsIPBinds _ ipbinds -> case ipbinds of-        IPBinds evbinds xs -> let sc = combineScopes scope $ mkScope sp in-          [ case hiePass @p of-              HieTc -> toHie $ EvBindContext sc (getRealSpan sp) $ L sp evbinds+        IPBinds evbinds xs -> let sc = combineScopes scope $ scopeHsLocaLBinds binds+                                  sp :: SrcSpanAnnA+                                  sp = noAnnSrcSpan $ spanHsLocaLBinds binds in+          [+            case hiePass @p of+              HieTc -> toHie $ EvBindContext sc (getRealSpan $ locA sp) $ L sp evbinds               HieRn -> pure []           , toHie $ map (RS sc) xs           ]       HsValBinds _ valBinds ->-        [ toHie $ RS (combineScopes scope $ mkScope sp)+        [+          toHie $ RS (combineScopes scope (scopeHsLocaLBinds binds))                       valBinds         ] -instance HiePass p => ToHie (RScoped (LIPBind (GhcPass p))) where-  toHie (RS scope (L sp bind)) = concatM $ makeNode bind sp : case bind of++scopeHsLocaLBinds :: HsLocalBinds (GhcPass p) -> Scope+scopeHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))+  = foldr combineScopes NoScope (bsScope ++ sigsScope)+  where+    bsScope :: [Scope]+    bsScope = map (mkScopeA . getLoc) $ bagToList bs+    sigsScope :: [Scope]+    sigsScope = map (mkScope . getLocA) sigs+scopeHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))+  = foldr combineScopes NoScope (bsScope ++ sigsScope)+  where+    bsScope :: [Scope]+    bsScope = map (mkScopeA . getLoc) $ concatMap (bagToList . snd) bs+    sigsScope :: [Scope]+    sigsScope = map (mkScope . getLocA) sigs++scopeHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))+  = foldr combineScopes NoScope (map (mkScopeA . getLoc) bs)+scopeHsLocaLBinds (EmptyLocalBinds _) = NoScope+++instance HiePass p => ToHie (RScoped (LocatedA (IPBind (GhcPass p)))) where+  toHie (RS scope (L sp bind)) = concatM $ makeNodeA bind sp : case bind of     IPBind _ (Left _) expr -> [toHie expr]     IPBind _ (Right v) expr ->-      [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpan sp))+      [ toHie $ C (EvidenceVarBind EvImplicitBind scope (getRealSpanA sp))                   $ L sp v       , toHie expr       ]@@ -1265,22 +1342,22 @@   toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields  instance ( ToHie (RFContext (Located label))-         , ToHie arg , HasLoc arg , Data arg+         , ToHie arg, HasLoc arg, Data arg          , Data label-         ) => ToHie (RContext (LHsRecField' label arg)) where-  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of-    HsRecField label expr _ ->+         ) => ToHie (RContext (LocatedA (HsRecField' label arg))) where+  toHie (RC c (L span recfld)) = concatM $ makeNode recfld (locA span) : case recfld of+    HsRecField _ label expr _ ->       [ toHie $ RFC c (getRealSpan $ loc expr) label       , toHie expr       ] -instance ToHie (RFContext (LFieldOcc GhcRn)) where+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 name)       ] -instance ToHie (RFContext (LFieldOcc GhcTc)) where+instance ToHie (RFContext (Located (FieldOcc GhcTc))) where   toHie (RFC c rhs (L nspan f)) = concatM $ case f of     FieldOcc var _ ->       [ toHie $ C (RecField c rhs) (L nspan var)@@ -1313,19 +1390,23 @@     , toHie $ PS Nothing sc NoScope pat     ] -instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where-  toHie (PrefixCon args) = toHie args+instance (ToHie tyarg, ToHie arg, ToHie rec) => ToHie (HsConDetails tyarg arg rec) where+  toHie (PrefixCon tyargs args) = concatM [ toHie tyargs, toHie args ]   toHie (RecCon rec) = toHie rec   toHie (InfixCon a b) = concatM [ toHie a, toHie b] -instance HiePass p => ToHie (LHsCmdTop (GhcPass p)) where+instance ToHie (HsConDeclGADTDetails GhcRn) where+  toHie (PrefixConGADT args) = toHie args+  toHie (RecConGADT rec) = toHie rec++instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where   toHie (L span top) = concatM $ makeNode top span : case top of     HsCmdTop _ cmd ->       [ toHie cmd       ] -instance HiePass p => ToHie (LHsCmd (GhcPass p)) where-  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of+instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where+  toHie (L span cmd) = concatM $ makeNodeA cmd span : case cmd of       HsCmdArrApp _ a b _ _ ->         [ toHie a         , toHie b@@ -1357,11 +1438,11 @@         , toHie c         ]       HsCmdLet _ binds cmd' ->-        [ toHie $ RS (mkLScope cmd') binds+        [ toHie $ RS (mkLScopeA cmd') binds         , toHie cmd'         ]       HsCmdDo _ (L ispan stmts) ->-        [ locOnly ispan+        [ locOnly (locA ispan)         , toHie $ listScopes NoScope stmts         ]       XCmd _ -> []@@ -1378,27 +1459,27 @@     , toHie instances     ] -instance ToHie (LTyClDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (TyClDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       FamDecl {tcdFam = fdecl} ->-        [ toHie (L span fdecl)+        [ toHie ((L span fdecl) :: LFamilyDecl GhcRn)         ]       SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->-        [ toHie $ C (Decl SynDec $ getRealSpan span) name-        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars+        [ toHie $ C (Decl SynDec $ getRealSpanA span) name+        , toHie $ TS (ResolvedScopes [mkScope $ getLocA typ]) vars         , toHie typ         ]       DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->-        [ toHie $ C (Decl DataDec $ getRealSpan span) name+        [ toHie $ C (Decl DataDec $ getRealSpanA span) name         , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars         , toHie defn         ]         where-          quant_scope = mkLScope $ dd_ctxt defn+          quant_scope = mkLScopeA $ fromMaybe (noLocA []) $ dd_ctxt defn           rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc-          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn-          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn-          deriv_sc = mkLScope $ dd_derivs defn+          sig_sc = maybe NoScope mkLScopeA $ dd_kindSig defn+          con_sc = foldr combineScopes NoScope $ map mkLScopeA $ dd_cons defn+          deriv_sc = foldr combineScopes NoScope $ map mkLScope $ dd_derivs defn       ClassDecl { tcdCtxt = context                 , tcdLName = name                 , tcdTyVars = vars@@ -1408,25 +1489,25 @@                 , tcdATs = typs                 , tcdATDefs = deftyps                 } ->-        [ toHie $ C (Decl ClassDec $ getRealSpan span) name+        [ toHie $ C (Decl ClassDec $ getRealSpanA span) name         , toHie context         , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars         , toHie deps-        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs+        , toHie $ map (SC $ SI ClassSig $ getRealSpanA span) sigs         , toHie $ fmap (BC InstanceBind ModuleScope) meths         , toHie typs-        , concatMapM (locOnly . getLoc) deftyps+        , concatMapM (locOnly . getLocA) deftyps         , toHie deftyps         ]         where-          context_scope = mkLScope context+          context_scope = mkLScopeA $ fromMaybe (noLocA []) context           rhs_scope = foldl1' combineScopes $ map mkScope             [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps] -instance ToHie (LFamilyDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      FamilyDecl _ info name vars _ sig inj ->-        [ toHie $ C (Decl FamDec $ getRealSpan span) name+instance ToHie (LocatedA (FamilyDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of+      FamilyDecl _ info _ name vars _ sig inj ->+        [ toHie $ C (Decl FamDec $ getRealSpanA span) name         , toHie $ TS (ResolvedScopes [rhsSpan]) vars         , toHie info         , toHie $ RS injSpan sig@@ -1439,14 +1520,14 @@  instance ToHie (FamilyInfo GhcRn) where   toHie (ClosedTypeFamily (Just eqns)) = concatM $-    [ concatMapM (locOnly . getLoc) eqns+    [ concatMapM (locOnly . getLocA) eqns     , toHie $ map go eqns     ]     where-      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib+      go (L l ib) = TS (ResolvedScopes [mkScopeA l]) ib   toHie _ = pure [] -instance ToHie (RScoped (LFamilyResultSig GhcRn)) where+instance ToHie (RScoped (Located (FamilyResultSig GhcRn))) where   toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of       NoSig _ ->         []@@ -1457,22 +1538,25 @@         [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr         ] -instance ToHie (Located (FunDep (Located Name))) where-  toHie (L span fd@(lhs, rhs)) = concatM $-    [ makeNode fd span+instance ToHie (LocatedA (FunDep GhcRn)) where+  toHie (L span fd@(FunDep _ lhs rhs)) = concatM $+    [ makeNode fd (locA span)     , toHie $ map (C Use) lhs     , toHie $ map (C Use) rhs     ] -instance (ToHie rhs, HasLoc rhs)-    => ToHie (TScoped (FamEqn GhcRn rhs)) where++instance ToHie (TScoped (FamEqn GhcRn (HsDataDefn GhcRn))) where   toHie (TS _ f) = toHie f +instance ToHie (TScoped (FamEqn GhcRn (LocatedA (HsType GhcRn)))) where+  toHie (TS _ f) = toHie f+ instance (ToHie rhs, HasLoc rhs)     => ToHie (FamEqn GhcRn rhs) where-  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $+  toHie fe@(FamEqn _ var outer_bndrs pats _ rhs) = concatM $     [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var-    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+    , toHie $ TVS (ResolvedScopes []) scope outer_bndrs     , toHie pats     , toHie rhs     ]@@ -1480,9 +1564,9 @@           patsScope = mkScope (loc pats)           rhsScope = mkScope (loc rhs) -instance ToHie (LInjectivityAnn GhcRn) where+instance ToHie (Located (InjectivityAnn GhcRn)) where   toHie (L span ann) = concatM $ makeNode ann span : case ann of-      InjectivityAnn lhs rhs ->+      InjectivityAnn _ lhs rhs ->         [ toHie $ C Use lhs         , toHie $ map (C Use) rhs         ]@@ -1495,95 +1579,99 @@     , toHie derivs     ] -instance ToHie (HsDeriving GhcRn) where+instance ToHie (Located [Located (HsDerivingClause GhcRn)]) where   toHie (L span clauses) = concatM     [ locOnly span     , toHie clauses     ] -instance ToHie (LHsDerivingClause GhcRn) where+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 (LocatedC (DerivClauseTys GhcRn)) where+  toHie (L span dct) = concatM $ makeNodeA 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-      StockStrategy -> []-      AnyclassStrategy -> []-      NewtypeStrategy -> []-      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]+      StockStrategy _ -> []+      AnyclassStrategy _ -> []+      NewtypeStrategy _ -> []+      ViaStrategy s -> [ toHie (TS (ResolvedScopes []) s) ] -instance ToHie (Located OverlapMode) where-  toHie (L span _) = locOnly span+instance ToHie (LocatedP OverlapMode) where+  toHie (L span _) = locOnly (locA span)  instance ToHie a => ToHie (HsScaled GhcRn a) where   toHie (HsScaled w t) = concatM [toHie (arrowToHsType w), toHie t] -instance ToHie (LConDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of-      ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars-                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->-        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names-        , concatM $ [ bindingsOnly bindings-                    , toHie $ tvScopes resScope NoScope exp_vars ]+instance ToHie (LocatedA (ConDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of+      ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs+                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->+        [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names+        , case outer_bndrs of+            HsOuterImplicit{hso_ximplicit = imp_vars} ->+              bindingsOnly $ map (C $ TyVarBind (mkScopeA outer_bndrs_loc) resScope)+                             imp_vars+            HsOuterExplicit{hso_bndrs = exp_bndrs} ->+              toHie $ tvScopes resScope NoScope exp_bndrs         , toHie ctx         , toHie args         , toHie typ         ]         where           rhsScope = combineScopes argsScope tyScope-          ctxScope = maybe NoScope mkLScope ctx-          argsScope = condecl_scope args-          tyScope = mkLScope typ+          ctxScope = maybe NoScope mkLScopeA ctx+          argsScope = case args of+            PrefixConGADT xs -> scaled_args_scope xs+            RecConGADT x     -> mkLScopeA x+          tyScope = mkLScopeA typ           resScope = ResolvedScopes [ctxScope, rhsScope]-          bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars       ConDeclH98 { con_name = name, con_ex_tvs = qvars                  , con_mb_cxt = ctx, con_args = dets } ->-        [ toHie $ C (Decl ConDec $ getRealSpan span) name+        [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name         , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars         , toHie ctx         , toHie dets         ]         where           rhsScope = combineScopes ctxScope argsScope-          ctxScope = maybe NoScope mkLScope ctx-          argsScope = condecl_scope dets-    where condecl_scope :: HsConDeclDetails p -> Scope-          condecl_scope args = case args of-            PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs-            InfixCon a b -> combineScopes (mkLScope (hsScaledThing a))-                                          (mkLScope (hsScaledThing b))-            RecCon x -> mkLScope x+          ctxScope = maybe NoScope mkLScopeA ctx+          argsScope = case dets of+            PrefixCon _ xs -> scaled_args_scope xs+            InfixCon a b   -> scaled_args_scope [a, b]+            RecCon x       -> mkLScopeA x+    where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope+          scaled_args_scope = foldr combineScopes NoScope . map (mkLScopeA . hsScaledThing) -instance ToHie (Located [LConDeclField GhcRn]) where+instance ToHie (LocatedL [LocatedA (ConDeclField GhcRn)]) where   toHie (L span decls) = concatM $-    [ locOnly span+    [ locOnly (locA span)     , toHie decls     ] -instance ( HasLoc thing-         , ToHie (TScoped thing)-         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where-  toHie (TS sc (HsIB ibrn a)) = concatM $-      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn+instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsSigType GhcRn)))) where+  toHie (TS sc (HsWC names a)) = concatM $+      [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names       , toHie $ TS sc a       ]     where span = loc a -instance ( HasLoc thing-         , ToHie (TScoped thing)-         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+instance ToHie (TScoped (HsWildCardBndrs GhcRn (LocatedA (HsType GhcRn)))) where   toHie (TS sc (HsWC names a)) = concatM $       [ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names-      , toHie $ TS sc a+      , toHie a       ]     where span = loc a -instance ToHie (LStandaloneKindSig GhcRn) where-  toHie (L sp sig) = concatM [makeNode sig sp, toHie sig]+instance ToHie (LocatedA (StandaloneKindSig GhcRn)) where+  toHie (L sp sig) = concatM [makeNodeA sig sp, toHie sig]  instance ToHie (StandaloneKindSig GhcRn) where   toHie sig = concatM $ case sig of@@ -1592,11 +1680,11 @@       , toHie $ TS (ResolvedScopes []) typ       ] -instance HiePass p => ToHie (SigContext (LSig (GhcPass p))) where+instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where   toHie (SC (SI styp msp) (L sp sig)) =     case hiePass @p of       HieTc -> pure []-      HieRn -> concatM $ makeNode sig sp : case sig of+      HieRn -> concatM $ makeNodeA sig sp : case sig of         TypeSig _ names typ ->           [ toHie $ map (C TyDecl) names           , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ@@ -1607,7 +1695,7 @@           ]         ClassOpSig _ _ names typ ->           [ case styp of-              ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names+              ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpanA sp) names               _  -> toHie $ map (C $ TyDecl) names           , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ           ]@@ -1638,18 +1726,27 @@           , toHie $ fmap (C Use) typ           ] -instance ToHie (LHsType GhcRn) where-  toHie x = toHie $ TS (ResolvedScopes []) x+instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where+  toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span :+      [ toHie (TVS tsc (mkScopeA span) bndrs)+      , toHie body+      ] -instance ToHie (TScoped (LHsType GhcRn)) where-  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of+-- Check this+instance Data flag => ToHie (TVScoped (HsOuterTyVarBndrs flag GhcRn)) where+  toHie (TVS tsc sc bndrs) = case bndrs of+    HsOuterImplicit xs -> bindingsOnly $ map (C $ TyVarBind sc tsc) xs+    HsOuterExplicit _ xs -> toHie $ tvScopes tsc sc xs++instance ToHie (LocatedA (HsType GhcRn)) where+  toHie (L span t) = concatM $ makeNode t (locA span) : case t of       HsForAllTy _ tele body ->-        let scope = mkScope $ getLoc body in+        let scope = mkScope $ getLocA body in         [ case tele of             HsForAllVis { hsf_vis_bndrs = bndrs } ->-              toHie $ tvScopes tsc scope bndrs+              toHie $ tvScopes (ResolvedScopes []) scope bndrs             HsForAllInvis { hsf_invis_bndrs = bndrs } ->-              toHie $ tvScopes tsc scope bndrs+              toHie $ tvScopes (ResolvedScopes []) scope bndrs         , toHie body         ]       HsQualTy _ ctx body ->@@ -1665,7 +1762,7 @@         ]       HsAppKindTy _ ty ki ->         [ toHie ty-        , toHie $ TS (ResolvedScopes []) ki+        , toHie ki         ]       HsFunTy _ w a b ->         [ toHie (arrowToHsType w)@@ -1725,8 +1822,8 @@   toHie (HsTypeArg _ ty) = toHie ty   toHie (HsArgPar sp) = locOnly sp -instance Data flag => ToHie (TVScoped (LHsTyVarBndr flag GhcRn)) where-  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+instance Data flag => ToHie (TVScoped (LocatedA (HsTyVarBndr flag GhcRn))) where+  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNodeA bndr span : case bndr of       UserTyVar _ _ var ->         [ toHie $ C (TyVarBind sc tsc) var         ]@@ -1744,14 +1841,14 @@       varLoc = loc vars       bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits -instance ToHie (LHsContext GhcRn) where+instance ToHie (LocatedC [LocatedA (HsType GhcRn)]) where   toHie (L span tys) = concatM $-      [ locOnly span+      [ locOnly (locA span)       , toHie tys       ] -instance ToHie (LConDeclField GhcRn) where-  toHie (L span field) = concatM $ makeNode field span : case field of+instance ToHie (LocatedA (ConDeclField GhcRn)) where+  toHie (L span field) = concatM $ makeNode field (locA span) : case field of       ConDeclField _ fields typ _ ->         [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields         , toHie typ@@ -1773,8 +1870,8 @@     , toHie c     ] -instance ToHie (LSpliceDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (SpliceDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       SpliceDecl _ splice _ ->         [ toHie splice         ]@@ -1788,8 +1885,8 @@ instance ToHie PendingTcSplice where   toHie _ = pure [] -instance ToHie (LBooleanFormula (Located Name)) where-  toHie (L span form) = concatM $ makeNode form span : case form of+instance ToHie (LBooleanFormula (LocatedN Name)) where+  toHie (L span form) = concatM $ makeNode form (locA span) : case form of       Var a ->         [ toHie $ C Use a         ]@@ -1806,8 +1903,8 @@ instance ToHie (Located HsIPName) where   toHie (L span e) = makeNode e span -instance HiePass p => ToHie (Located (HsSplice (GhcPass p))) where-  toHie (L span sp) = concatM $ makeNode sp span : case sp of+instance HiePass p => ToHie (LocatedA (HsSplice (GhcPass p))) where+  toHie (L span sp) = concatM $ makeNodeA sp span : case sp of       HsTypedSplice _ _ _ expr ->         [ toHie expr         ]@@ -1827,15 +1924,15 @@                      GhcTc -> case x of                                 HsSplicedT _ -> [] -instance ToHie (LRoleAnnotDecl GhcRn) where-  toHie (L span annot) = concatM $ makeNode annot span : case annot of+instance ToHie (LocatedA (RoleAnnotDecl GhcRn)) where+  toHie (L span annot) = concatM $ makeNodeA annot span : case annot of       RoleAnnotDecl _ var roles ->         [ toHie $ C Use var         , concatMapM (locOnly . getLoc) roles         ] -instance ToHie (LInstDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (InstDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       ClsInstD _ d ->         [ toHie $ L span d         ]@@ -1846,55 +1943,59 @@         [ toHie $ L span d         ] -instance ToHie (LClsInstDecl GhcRn) where+instance ToHie (LocatedA (ClsInstDecl GhcRn)) where   toHie (L span decl) = concatM-    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl+    [ toHie $ TS (ResolvedScopes [mkScopeA span]) $ cid_poly_ty decl     , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl-    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl-    , concatMapM (locOnly . getLoc) $ cid_tyfam_insts decl+    , toHie $ map (SC $ SI InstSig $ getRealSpanA span) $ cid_sigs decl+    , concatMapM (locOnly . getLocA) $ cid_tyfam_insts decl     , toHie $ cid_tyfam_insts decl-    , concatMapM (locOnly . getLoc) $ cid_datafam_insts decl+    , concatMapM (locOnly . getLocA) $ cid_datafam_insts decl     , toHie $ cid_datafam_insts decl     , toHie $ cid_overlap_mode decl     ] -instance ToHie (LDataFamInstDecl GhcRn) where-  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d+instance ToHie (LocatedA (DataFamInstDecl GhcRn)) where+  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d -instance ToHie (LTyFamInstDecl GhcRn) where-  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d+instance ToHie (LocatedA (TyFamInstDecl GhcRn)) where+  toHie (L sp (TyFamInstDecl _ d)) = toHie $ TS (ResolvedScopes [mkScopeA sp]) d -instance ToHie (Context a)-         => ToHie (PatSynFieldContext (RecordPatSynField a)) where+instance HiePass p => ToHie (Context (FieldOcc (GhcPass p))) where+  toHie (C c (FieldOcc n (L l _))) = case hiePass @p of+    HieTc -> toHie (C c (L l n))+    HieRn -> toHie (C c (L l n))++instance HiePass p => ToHie (PatSynFieldContext (RecordPatSynField (GhcPass p))) where   toHie (PSC sp (RecordPatSynField a b)) = concatM $     [ toHie $ C (RecField RecFieldDecl sp) a     , toHie $ C Use b     ] -instance ToHie (LDerivDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (DerivDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       DerivDecl _ typ strat overlap ->         [ toHie $ TS (ResolvedScopes []) typ         , toHie strat         , toHie overlap         ] -instance ToHie (LFixitySig GhcRn) where-  toHie (L span sig) = concatM $ makeNode sig span : case sig of+instance ToHie (LocatedA (FixitySig GhcRn)) where+  toHie (L span sig) = concatM $ makeNodeA sig span : case sig of       FixitySig _ vars _ ->         [ toHie $ map (C Use) vars         ] -instance ToHie (LDefaultDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (DefaultDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       DefaultDecl _ typs ->         [ toHie typs         ] -instance ToHie (LForeignDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (ForeignDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->-        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name+        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpanA span) name         , toHie $ TS (ResolvedScopes []) sig         , toHie fi         ]@@ -1917,51 +2018,51 @@     , locOnly b     ] -instance ToHie (LWarnDecls GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (WarnDecls GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       Warnings _ _ warnings ->         [ toHie warnings         ] -instance ToHie (LWarnDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (WarnDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of       Warning _ vars _ ->         [ toHie $ map (C Use) vars         ] -instance ToHie (LAnnDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (AnnDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       HsAnnotation _ _ prov expr ->         [ toHie prov         , toHie expr         ] -instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where+instance ToHie (AnnProvenance GhcRn) where   toHie (ValueAnnProvenance a) = toHie $ C Use a   toHie (TypeAnnProvenance a) = toHie $ C Use a   toHie ModuleAnnProvenance = pure [] -instance ToHie (LRuleDecls GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (RuleDecls GhcRn)) where+  toHie (L span decl) = concatM $ makeNodeA decl span : case decl of       HsRules _ _ rules ->         [ toHie rules         ] -instance ToHie (LRuleDecl GhcRn) where+instance ToHie (LocatedA (RuleDecl GhcRn)) where   toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM-        [ makeNode r span+        [ makeNodeA r span         , locOnly $ getLoc rname         , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs-        , toHie $ map (RS $ mkScope span) bndrs+        , toHie $ map (RS $ mkScope (locA span)) bndrs         , toHie exprA         , toHie exprB         ]     where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc           bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)-          exprA_sc = mkLScope exprA-          exprB_sc = mkLScope exprB+          exprA_sc = mkLScopeA exprA+          exprB_sc = mkLScopeA exprB -instance ToHie (RScoped (LRuleBndr GhcRn)) where+instance ToHie (RScoped (Located (RuleBndr GhcRn))) where   toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of       RuleBndr _ var ->         [ toHie $ C (ValBind RegularBind sc Nothing) var@@ -1971,8 +2072,8 @@         , toHie $ TS (ResolvedScopes [sc]) typ         ] -instance ToHie (LImportDecl GhcRn) where-  toHie (L span decl) = concatM $ makeNode decl span : case decl of+instance ToHie (LocatedA (ImportDecl GhcRn)) where+  toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of       ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->         [ toHie $ IEC Import name         , toHie $ fmap (IEC ImportAs) as@@ -1980,14 +2081,14 @@         ]     where       goIE (hiding, (L sp liens)) = concatM $-        [ locOnly sp+        [ locOnly (locA sp)         , toHie $ map (IEC c) liens         ]         where          c = if hiding then ImportHiding else Import -instance ToHie (IEContext (LIE GhcRn)) where-  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of+instance ToHie (IEContext (LocatedA (IE GhcRn))) where+  toHie (IEC c (L span ie)) = concatM $ makeNode ie (locA span) : case ie of       IEVar _ n ->         [ toHie $ IEC c n         ]@@ -1997,7 +2098,7 @@       IEThingAll _ n ->         [ toHie $ IEC c n         ]-      IEThingWith _ n _ ns flds ->+      IEThingWith flds n _ ns ->         [ toHie $ IEC c n         , toHie $ map (IEC c) ns         , toHie $ map (IEC c) flds@@ -2010,19 +2111,19 @@       IEDocNamed _ _ -> []  instance ToHie (IEContext (LIEWrappedName Name)) where-  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of+  toHie (IEC c (L span iewn)) = concatM $ makeNodeA iewn span : case iewn of       IEName n ->         [ toHie $ C (IEThing c) n         ]-      IEPattern p ->+      IEPattern _ p ->         [ toHie $ C (IEThing c) p         ]-      IEType n ->+      IEType _ n ->         [ toHie $ C (IEThing c) n         ] -instance ToHie (IEContext (Located (FieldLbl Name))) where-  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of-      FieldLabel _ _ n ->-        [ toHie $ C (IEThing c) $ L span n-        ]+instance ToHie (IEContext (Located FieldLabel)) where+  toHie (IEC c (L span lbl)) = concatM+      [ makeNode lbl span+      , toHie $ C (IEThing c) $ L span (flSelector lbl)+      ]

GHC/Iface/Ext/Binary.hs view

@@ -28,6 +28,7 @@ import GHC.Types.Name import GHC.Types.Name.Cache import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Builtin.Utils import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique.Supply    ( takeUniqFromSupply )@@ -97,14 +98,12 @@   put_ bh0 symtab_p_p    -- Make some initial state-  symtab_next <- newFastMutInt-  writeFastMutInt symtab_next 0+  symtab_next <- newFastMutInt 0   symtab_map <- newIORef emptyUFM :: IO (IORef (UniqFM Name (Int, HieName)))   let hie_symtab = HieSymbolTable {                       hie_symtab_next = symtab_next,                       hie_symtab_map  = symtab_map }-  dict_next_ref <- newFastMutInt-  writeFastMutInt dict_next_ref 0+  dict_next_ref <- newFastMutInt 0   dict_map_ref <- newIORef emptyUFM   let hie_dict = HieDictionary {                       hie_dict_next = dict_next_ref,@@ -221,9 +220,7 @@  readHieFileContents :: BinHandle -> NameCacheUpdater -> IO HieFile readHieFileContents bh0 ncu = do--  dict  <- get_dictionary bh0-+  dict <- get_dictionary bh0   -- read the symbol table so we are capable of reading the actual data   bh1 <- do       let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")@@ -235,8 +232,7 @@       return bh1'    -- load the actual data-  hiefile <- get bh1-  return hiefile+  get bh1   where     get_dictionary bin_handle = do       dict_p <- get bin_handle

GHC/Iface/Ext/Debug.hs view

@@ -1,9 +1,9 @@+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE OverloadedStrings  #-}+ {- Functions to validate and check .hie file ASTs generated by GHC. -}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}  module GHC.Iface.Ext.Debug where @@ -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

+ GHC/Iface/Ext/Fields.hs view

@@ -0,0 +1,94 @@+module GHC.Iface.Ext.Fields+   ( ExtensibleFields (..)+   , FieldName+   , emptyExtensibleFields+   -- * Reading+   , readField+   , readFieldWith+   -- * Writing+   , writeField+   , writeFieldWith+   -- * Deletion+   , deleteField+   )+where++import GHC.Prelude+import GHC.Utils.Binary++import Control.Monad+import Data.Map         ( Map )+import qualified Data.Map as Map+import Control.DeepSeq++type FieldName = String++newtype ExtensibleFields = ExtensibleFields { getExtensibleFields :: (Map FieldName BinData) }++instance Binary ExtensibleFields where+  put_ bh (ExtensibleFields fs) = do+    put_ bh (Map.size fs :: Int)++    -- Put the names of each field, and reserve a space+    -- for a payload pointer after each name:+    header_entries <- forM (Map.toList fs) $ \(name, dat) -> do+      put_ bh name+      field_p_p <- tellBin bh+      put_ bh field_p_p+      return (field_p_p, dat)++    -- Now put the payloads and use the reserved space+    -- to point to the start of each payload:+    forM_ header_entries $ \(field_p_p, dat) -> do+      field_p <- tellBin bh+      putAt bh field_p_p field_p+      seekBin bh field_p+      put_ bh dat++  get bh = do+    n <- get bh :: IO Int++    -- Get the names and field pointers:+    header_entries <- replicateM n $+      (,) <$> get bh <*> get bh++    -- Seek to and get each field's payload:+    fields <- forM header_entries $ \(name, field_p) -> do+      seekBin bh field_p+      dat <- get bh+      return (name, dat)++    return . ExtensibleFields . Map.fromList $ fields++instance NFData ExtensibleFields where+  rnf (ExtensibleFields fs) = rnf fs++emptyExtensibleFields :: ExtensibleFields+emptyExtensibleFields = ExtensibleFields Map.empty++--------------------------------------------------------------------------------+-- | Reading++readField :: Binary a => FieldName -> ExtensibleFields -> IO (Maybe a)+readField name = readFieldWith name get++readFieldWith :: FieldName -> (BinHandle -> IO a) -> ExtensibleFields -> IO (Maybe a)+readFieldWith name read fields = sequence $ ((read =<<) . dataHandle) <$>+  Map.lookup name (getExtensibleFields fields)++--------------------------------------------------------------------------------+-- | Writing++writeField :: Binary a => FieldName -> a -> ExtensibleFields -> IO ExtensibleFields+writeField name x = writeFieldWith name (`put_` x)++writeFieldWith :: FieldName -> (BinHandle -> IO ()) -> ExtensibleFields -> IO ExtensibleFields+writeFieldWith name write fields = do+  bh <- openBinMem (1024 * 1024)+  write bh+  --+  bd <- handleData bh+  return $ ExtensibleFields (Map.insert name bd $ getExtensibleFields fields)++deleteField :: FieldName -> ExtensibleFields -> ExtensibleFields+deleteField name (ExtensibleFields fs) = ExtensibleFields $ Map.delete name fs

GHC/Iface/Ext/Types.hs view

@@ -1,22 +1,24 @@+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveTraversable          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PatternSynonyms            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+ {- Types for the .hie file format are defined here.  For more information see https://gitlab.haskell.org/ghc/ghc/wikis/hie-files -}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}+ 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 )@@ -27,6 +29,7 @@ import GHC.Types.Unique import qualified GHC.Utils.Outputable as O ( (<>) ) import GHC.Utils.Misc+import GHC.Utils.Panic  import qualified Data.Array as A import qualified Data.Map as M@@ -210,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@@ -284,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.

GHC/Iface/Ext/Utils.hs view

@@ -8,8 +8,9 @@  import GHC.Prelude -import GHC.Core.Map+import GHC.Core.Map.Type import GHC.Driver.Session    ( DynFlags )+import GHC.Driver.Ppr import GHC.Data.FastString   ( FastString, mkFastString ) import GHC.Iface.Type import GHC.Core.Multiplicity@@ -24,6 +25,7 @@ import GHC.Core.Type import GHC.Types.Var import GHC.Types.Var.Env+import GHC.Parser.Annotation  import GHC.Iface.Ext.Types @@ -54,7 +56,7 @@         this = fmap (pure . (nodeSpan ast,)) $ sourcedNodeIdents $ sourcedNodeInfo ast  renderHieType :: DynFlags -> HieTypeFix -> String-renderHieType dflags ht = renderWithStyle (initSDocContext dflags defaultUserStyle) (ppr $ hieTypeToIface ht)+renderHieType dflags ht = showSDoc dflags (ppr $ hieTypeToIface ht)  resolveVisibility :: Type -> [Type] -> [(Bool,Type)] resolveVisibility kind ty_args@@ -84,7 +86,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'@@ -193,9 +195,8 @@ compressTypes asts = (a, arr)   where     (a, (HTS _ m i)) = flip runState initialHTS $-      for asts $ \typ -> do-        i <- getTypeIndex typ-        return i+      for asts $ \typ ->+        getTypeIndex typ     arr = A.array (0,i-1) (IM.toList m)  recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix@@ -247,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 =@@ -277,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@@ -290,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@@ -303,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@@ -368,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]@@ -514,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@@ -523,6 +524,9 @@   pure [Node e span []] locOnly _ = pure [] +mkScopeA :: SrcSpanAnn' ann -> Scope+mkScopeA l = mkScope (locA l)+ mkScope :: SrcSpan -> Scope mkScope (RealSrcSpan sp _) = LocalScope sp mkScope _ = NoScope@@ -530,6 +534,12 @@ mkLScope :: Located a -> Scope mkLScope = mkScope . getLoc +mkLScopeA :: GenLocated (SrcSpanAnn' a) e -> Scope+mkLScopeA = mkScope . locA . getLoc++mkLScopeN :: LocatedN a -> Scope+mkLScopeN = mkScope . getLocA+ combineScopes :: Scope -> Scope -> Scope combineScopes ModuleScope _ = ModuleScope combineScopes _ ModuleScope = ModuleScope@@ -541,6 +551,14 @@ mkSourcedNodeInfo :: NodeOrigin -> NodeInfo a -> SourcedNodeInfo a mkSourcedNodeInfo org ni = SourcedNodeInfo $ M.singleton org ni +{-# INLINEABLE makeNodeA #-}+makeNodeA+  :: (Monad m, Data a)+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')+  -> SrcSpanAnn' ann         -- ^ return an empty list if this is unhelpful+  -> ReaderT NodeOrigin m [HieAST b]+makeNodeA x spn = makeNode x (locA spn)+ {-# INLINEABLE makeNode #-} makeNode   :: (Monad m, Data a)@@ -556,6 +574,15 @@     cons = mkFastString . show . toConstr $ x     typ = mkFastString . show . typeRepTyCon . typeOf $ x +{-# INLINEABLE makeTypeNodeA #-}+makeTypeNodeA+  :: (Monad m, Data a)+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')+  -> SrcSpanAnnA             -- ^ return an empty list if this is unhelpful+  -> Type                    -- ^ type to associate with the node+  -> ReaderT NodeOrigin m [HieAST Type]+makeTypeNodeA x spn etyp = makeTypeNode x (locA spn) etyp+ {-# INLINEABLE makeTypeNode #-} makeTypeNode   :: (Monad m, Data a)@@ -567,7 +594,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

GHC/Iface/Load.hs view

@@ -2,13 +2,16 @@ (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 --Loading interface files -}  {-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+ {-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Loading interface files module GHC.Iface.Load (         -- Importing one thing         tcLookupImported_maybe, importDecl,@@ -23,68 +26,91 @@         loadInterface,         loadSysInterface, loadUserInterface, loadPluginInterface,         findAndReadIface, readIface, writeIface,-        loadDecls,      -- Should move to GHC.IfaceToCore and be renamed         initExternalPackageState,         moduleFreeHolesPrecise,         needWiredInHomeIface, loadWiredInHomeIface,          pprModIfaceSimple,-        ifaceStats, pprModIface, showIface+        ifaceStats, pprModIface, showIface,++        cannotFindModule    ) where  #include "HsVersions.h"  import GHC.Prelude+import GHC.Platform.Ways+import GHC.Platform.Profile  import {-# SOURCE #-} GHC.IfaceToCore-   ( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst-   , tcIfaceAnnotations, tcIfaceCompleteSigs )+   ( tcIfaceDecls, tcIfaceRules, tcIfaceInst, tcIfaceFamInst+   , tcIfaceAnnotations, tcIfaceCompleteMatches ) +import GHC.Driver.Env import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Driver.Hooks import GHC.Driver.Plugins  import GHC.Iface.Syntax-import GHC.Iface.Env-import GHC.Driver.Types+import GHC.Iface.Ext.Fields+import GHC.Iface.Binary+import GHC.Iface.Rename -import GHC.Types.Basic hiding (SuccessFlag(..)) import GHC.Tc.Utils.Monad  import GHC.Utils.Binary   ( BinData(..) )+import GHC.Utils.Error+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Logger+ import GHC.Settings.Constants+ import GHC.Builtin.Names import GHC.Builtin.Utils import GHC.Builtin.PrimOps    ( allThePrimOps, primOpFixity, primOpOcc )-import GHC.Types.Id.Make      ( seqId, EnableBignumRules(..) )+ import GHC.Core.Rules import GHC.Core.TyCon-import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv++import GHC.Types.Id.Make      ( seqId )+import GHC.Types.Annotations import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Avail+import GHC.Types.Fixity+import GHC.Types.Fixity.Env+import GHC.Types.SourceError+import GHC.Types.SourceText+import GHC.Types.SourceFile+import GHC.Types.SafeHaskell+import GHC.Types.TypeEnv+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet+import GHC.Types.SrcLoc+import GHC.Types.TyThing++import GHC.Unit.External import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Home.ModInfo+import GHC.Unit.Finder+import GHC.Unit.Env+ import GHC.Data.Maybe-import GHC.Utils.Error-import GHC.Driver.Finder-import GHC.Types.Unique.FM-import GHC.Types.SrcLoc-import GHC.Utils.Outputable as Outputable-import GHC.Iface.Binary-import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Data.FastString-import GHC.Utils.Fingerprint-import GHC.Types.FieldLabel-import GHC.Iface.Rename-import GHC.Types.Unique.DSet  import Control.Monad import Control.Exception-import Data.IORef import Data.Map ( toList ) import System.FilePath import System.Directory@@ -115,16 +141,16 @@ also turn out to be needed by the code that e2 expands to. -} -tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+tcLookupImported_maybe :: Name -> TcM (MaybeErr SDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing tcLookupImported_maybe name   = do  { hsc_env <- getTopEnv-        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; mb_thing <- liftIO (lookupType hsc_env name)         ; case mb_thing of             Just thing -> return (Succeeded thing)             Nothing    -> tcImportDecl_maybe name } -tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+tcImportDecl_maybe :: Name -> TcM (MaybeErr SDoc TyThing) -- Entry point for *source-code* uses of importDecl tcImportDecl_maybe name   | Just thing <- wiredInNameTyThing_maybe name@@ -135,7 +161,7 @@   | otherwise   = initIfaceTcRn (importDecl name) -importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)+importDecl :: Name -> IfM lcl (MaybeErr SDoc TyThing) -- Get the TyThing for this Name from an interface file -- It's not a wired-in thing -- the caller caught that importDecl name@@ -277,7 +303,7 @@                        -> ModuleName                        -> IsBootInterface     -- {-# SOURCE #-} ?                        -> Maybe FastString    -- "package", if any-                       -> RnM (MaybeErr MsgDoc ModIface)+                       -> RnM (MaybeErr SDoc ModIface)  loadSrcInterface_maybe doc mod want_boot maybe_pkg   -- We must first find which Module this import refers to.  This involves@@ -290,7 +316,7 @@        ; case res of            Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)            -- TODO: Make sure this error message is good-           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }+           err         -> return (Failed (cannotFindModule hsc_env mod err)) }  -- | Load interface directly for a fully qualified 'Module'.  (This is a fairly -- rare operation, but in particular it is used to load orphan modules@@ -383,7 +409,7 @@  ------------------ loadInterface :: SDoc -> Module -> WhereFrom-              -> IfM lcl (MaybeErr MsgDoc ModIface)+              -> IfM lcl (MaybeErr SDoc ModIface)  -- loadInterface looks in both the HPT and PIT for the required interface -- If not found, it loads it, and puts it in the PIT (always).@@ -400,19 +426,24 @@ loadInterface doc_str mod from   | isHoleModule mod   -- Hole modules get special treatment-  = do dflags <- getDynFlags+  = do hsc_env <- getTopEnv+       let home_unit = hsc_home_unit hsc_env        -- Redo search for our local hole module-       loadInterface doc_str (mkHomeModule dflags (moduleName mod)) from+       loadInterface doc_str (mkHomeModule home_unit (moduleName mod)) from   | otherwise-  = withTimingSilentD (text "loading interface") (pure ()) $-    do  {       -- Read the state+  = do+    logger <- getLogger+    dflags <- getDynFlags+    withTimingSilent logger dflags (text "loading interface") (pure ()) $ do+        {       -- Read the state           (eps,hpt) <- getEpsAndHpt         ; gbl_env <- getGblEnv          ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)                  -- Check whether we have the interface already-        ; dflags <- getDynFlags+        ; hsc_env <- getTopEnv+        ; let home_unit = hsc_home_unit hsc_env         ; case lookupIfaceByModule hpt (eps_PIT eps) mod of {             Just iface                 -> return (Succeeded iface) ;   -- Already loaded@@ -422,7 +453,7 @@             _ -> do {          -- READ THE MODULE IN-        ; read_result <- case (wantHiBootFile dflags eps mod from) of+        ; read_result <- case (wantHiBootFile home_unit eps mod from) of                            Failed err             -> return (Failed err)                            Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod         ; case read_result of {@@ -449,7 +480,7 @@         let             loc_doc = text loc         in-        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $          dontLeakTheHPT $ do @@ -464,18 +495,18 @@         --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,         -- out of the ModIface and put them into the big EPS pools -        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined+        -- NB: *first* we do tcIfaceDecls, so that the provenance of all the locally-defined         ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).         --     If we do loadExport first the wrong info gets into the cache (unless we         --      explicitly tag each export which seems a bit of a bore)          ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas-        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)+        ; new_eps_decls     <- tcIfaceDecls ignore_prags (mi_decls iface)         ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)         ; 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",@@ -493,7 +524,7 @@          ; WARN( bad_boot, ppr mod )           updateEps_  $ \ eps ->-           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig home_unit iface                 then eps            else if bad_boot                 -- See Note [Loading your own hi-boot file]@@ -505,9 +536,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)@@ -530,7 +559,7 @@          ; -- invoke plugins with *full* interface, not final_iface, to ensure           -- that plugins have access to declarations, etc.-          res <- withPlugins dflags (\p -> interfaceLoadAction p) iface+          res <- withPlugins hsc_env (\p -> interfaceLoadAction p) iface         ; return (Succeeded res)     }}}} @@ -592,15 +621,17 @@          -- wrinkle: when we're typechecking in --backpack mode, the          -- instantiation of a signature might reside in the HPT, so          -- this case breaks the assumption that EPS interfaces only-         -- refer to other EPS interfaces.-         -- As a temporary (MP Oct 2021 #20509) we only keep the HPT if it-         -- contains any hole modules.-         -- Quite a few tests in testsuite/tests/backpack break without this+         -- refer to other EPS interfaces. We can detect when we're in+         -- typechecking-only mode by using backend==NoBackend, and+         -- in that case we don't empty the HPT.  (admittedly this is+         -- a bit of a hack, better suggestions welcome). A number of+         -- tests in testsuite/tests/backpack break without this          -- tweak.          keepFor20509 hmi           | isHoleModule (mi_semantic_module (hm_iface hmi)) = True           | otherwise = False-         !hpt | anyHpt keepFor20509 hsc_HPT  = hsc_HPT+         !hpt | backend hsc_dflags == NoBackend = if anyHpt keepFor20509 hsc_HPT then hsc_HPT+                                                                     else emptyHomePackageTable               | otherwise = emptyHomePackageTable        in        HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"@@ -617,12 +648,12 @@ -- | Returns @True@ if a 'ModIface' comes from an external package. -- In this case, we should NOT load it into the EPS; the entities -- should instead come from the local merged signature interface.-is_external_sig :: DynFlags -> ModIface -> Bool-is_external_sig dflags iface =+is_external_sig :: HomeUnit -> ModIface -> Bool+is_external_sig home_unit iface =     -- It's a signature iface...     mi_semantic_module iface /= mi_module iface &&     -- and it's not from the local package-    moduleUnit (mi_module iface) /= homeUnit dflags+    not (isHomeModule home_unit (mi_module iface))  -- | This is an improved version of 'findAndReadIface' which can also -- handle the case when a user requests @p[A=<B>]:M@ but we only@@ -640,12 +671,13 @@ -- we are actually typechecking p.) computeInterface ::        SDoc -> IsBootInterface -> Module-    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+    -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath)) computeInterface doc_str hi_boot_file mod0 = do     MASSERT( not (isHoleModule mod0) )-    dflags <- getDynFlags+    hsc_env <- getTopEnv+    let home_unit = hsc_home_unit hsc_env     case getModuleInstantiation mod0 of-        (imod, Just indef) | homeUnitIsIndefinite dflags -> do+        (imod, Just indef) | isHomeUnitIndefinite home_unit -> do             r <- findAndReadIface doc_str imod mod0 hi_boot_file             case r of                 Succeeded (iface0, path) -> do@@ -671,7 +703,7 @@ -- @p[A=\<A>,B=\<B>]:B@ never includes B. moduleFreeHolesPrecise     :: SDoc -> Module-    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))+    -> TcRnIf gbl lcl (MaybeErr SDoc (UniqDSet ModuleName)) moduleFreeHolesPrecise doc_str mod  | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)  | otherwise =@@ -703,13 +735,13 @@                 return (Succeeded (renameFreeHoles ifhs insts))             Failed err -> return (Failed err) -wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom-               -> MaybeErr MsgDoc IsBootInterface+wantHiBootFile :: HomeUnit -> ExternalPackageState -> Module -> WhereFrom+               -> MaybeErr SDoc IsBootInterface -- Figure out whether we want Foo.hi or Foo.hi-boot-wantHiBootFile dflags eps mod from+wantHiBootFile home_unit eps mod from   = case from of        ImportByUser usr_boot-          | usr_boot == IsBoot && not this_package+          | usr_boot == IsBoot && notHomeModule home_unit mod           -> Failed (badSourceImport mod)           | otherwise -> Succeeded usr_boot @@ -717,10 +749,12 @@           -> Succeeded NotBoot         ImportBySystem-          | not this_package   -- If the module to be imported is not from this package-          -> Succeeded NotBoot -- don't look it up in eps_is_boot, because that is keyed-                               -- on the ModuleName of *home-package* modules only.-                               -- We never import boot modules from other packages!+          | notHomeModule home_unit mod+          -> Succeeded NotBoot+             -- If the module to be imported is not from this package+             -- don't look it up in eps_is_boot, because that is keyed+             -- on the ModuleName of *home-package* modules only.+             -- We never import boot modules from other packages!            | otherwise           -> case lookupUFM (eps_is_boot eps) (moduleName mod) of@@ -730,8 +764,6 @@                   Succeeded NotBoot                      -- The boot-ness of the requested interface,                      -- based on the dependencies in directly-imported modules-  where-    this_package = homeUnit dflags == moduleUnit mod  badSourceImport :: Module -> SDoc badSourceImport mod@@ -755,110 +787,6 @@ addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv addDeclsToPTE pte things = extendNameEnvList pte things -loadDecls :: Bool-          -> [(Fingerprint, IfaceDecl)]-          -> IfL [(Name,TyThing)]-loadDecls ignore_prags ver_decls-   = concatMapM (loadDecl ignore_prags) ver_decls--loadDecl :: Bool                    -- Don't load pragmas into the decl pool-          -> (Fingerprint, IfaceDecl)-          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the-                                    -- TyThings are forkM'd thunks-loadDecl ignore_prags (_version, decl)-  = do  {       -- Populate the name cache with final versions of all-                -- the names associated with the decl-          let main_name = ifName decl--        -- Typecheck the thing, lazily-        -- NB. Firstly, the laziness is there in case we never need the-        -- declaration (in one-shot mode), and secondly it is there so that-        -- we don't look up the occurrence of a name before calling mk_new_bndr-        -- on the binder.  This is important because we must get the right name-        -- which includes its nameParent.--        ; thing <- forkM doc $ do { bumpDeclStats main_name-                                  ; tcIfaceDecl ignore_prags decl }--        -- Populate the type environment with the implicitTyThings too.-        ---        -- Note [Tricky iface loop]-        -- ~~~~~~~~~~~~~~~~~~~~~~~~-        -- Summary: The delicate point here is that 'mini-env' must be-        -- buildable from 'thing' without demanding any of the things-        -- 'forkM'd by tcIfaceDecl.-        ---        -- In more detail: Consider the example-        --      data T a = MkT { x :: T a }-        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]-        -- (plus their workers, wrappers, coercions etc etc)-        ---        -- We want to return an environment-        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]-        -- (where the "MkT" is the *Name* associated with MkT, etc.)-        ---        -- We do this by mapping the implicit_names to the associated-        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and-        -- implicitTyThings, we can use getOccName on the implicit-        -- TyThings to make this association: each Name's OccName should-        -- be the OccName of exactly one implicitTyThing.  So the key is-        -- to define a "mini-env"-        ---        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]-        -- where the 'MkT' here is the *OccName* associated with MkT.-        ---        -- However, there is a subtlety: due to how type checking needs-        -- to be staged, we can't poke on the forkM'd thunks inside the-        -- implicitTyThings while building this mini-env.-        -- If we poke these thunks too early, two problems could happen:-        --    (1) When processing mutually recursive modules across-        --        hs-boot boundaries, poking too early will do the-        --        type-checking before the recursive knot has been tied,-        --        so things will be type-checked in the wrong-        --        environment, and necessary variables won't be in-        --        scope.-        ---        --    (2) Looking up one OccName in the mini_env will cause-        --        others to be looked up, which might cause that-        --        original one to be looked up again, and hence loop.-        ---        -- The code below works because of the following invariant:-        -- getOccName on a TyThing does not force the suspended type-        -- checks in order to extract the name. For example, we don't-        -- poke on the "T a" type of <selector x> on the way to-        -- extracting <selector x>'s OccName. Of course, there is no-        -- reason in principle why getting the OccName should force the-        -- thunks, but this means we need to be careful in-        -- implicitTyThings and its helper functions.-        ---        -- All a bit too finely-balanced for my liking.--        -- This mini-env and lookup function mediates between the-        --'Name's n and the map from 'OccName's to the implicit TyThings-        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]-              lookup n = case lookupOccEnv mini_env (getOccName n) of-                           Just thing -> thing-                           Nothing    ->-                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))--        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)----         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)-        ; return $ (main_name, thing) :-                      -- uses the invariant that implicit_names and-                      -- implicitTyThings are bijective-                      [(n, lookup n) | n <- implicit_names]-        }-  where-    doc = text "Declaration for" <+> ppr (ifName decl)--bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used-bumpDeclStats name-  = do  { traceIf (text "Loading decl for" <+> ppr name)-        ; updateEps_ (\eps -> let stats = eps_stats eps-                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })-        }- {- ********************************************************* *                                                      *@@ -871,7 +799,7 @@ If the sought-for interface is in the current package (as determined by -package-name flag) then it jolly well should already be in the HPT because we process home-package modules in dependency order.  (Except-in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Types).+in one-shot mode; see notes with hsc_HPT decl in GHC.Driver.Env).  It is possible (though hard) to get this error through user behaviour.   * Suppose package P (modules P1, P2) depends on package Q (modules Q1,@@ -896,7 +824,7 @@                  -> Module                  -> IsBootInterface     -- True  <=> Look for a .hi-boot file                                         -- False <=> Look for .hi file-                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+                 -> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))         -- Nothing <=> file not found, or unreadable, or illegible         -- Just x  <=> successfully found and parsed @@ -912,17 +840,21 @@                      nest 4 (text "reason:" <+> doc_str)])         -- Check for GHC.Prim, and return its static interface+       -- See Note [GHC.Prim] in primops.txt.pp.        -- TODO: make this check a function        if mod `installedModuleEq` gHC_PRIM            then do-               iface <- getHooked ghcPrimIfaceHook ghcPrimIface-               return (Succeeded (iface,-                                   "<built in interface for GHC.Prim>"))+               hooks <- getHooks+               let iface = case ghcPrimIfaceHook hooks of+                            Nothing -> ghcPrimIface+                            Just h  -> h+               return (Succeeded (iface, "<built in interface for GHC.Prim>"))            else do                dflags <- getDynFlags                -- Look for the file                hsc_env <- getTopEnv                mb_found <- liftIO (findExactModule hsc_env mod)+               let home_unit  = hsc_home_unit hsc_env                case mb_found of                    InstalledFound loc mod -> do                        -- Found file, so read it@@ -930,7 +862,7 @@                                                            (ml_hi_file loc)                         -- See Note [Home module load error]-                       if moduleUnit mod `unitIdEq` homeUnit dflags &&+                       if isHomeInstalledModule home_unit mod &&                           not (isOneShot (ghcMode dflags))                            then return (Failed (homeModError mod loc))                            else do r <- read_file file_path@@ -938,64 +870,79 @@                                    return r                    err -> do                        traceIf (text "...not found")-                       dflags <- getDynFlags-                       return (Failed (cannotFindInterface dflags-                                           (moduleName mod) err))+                       hsc_env <- getTopEnv+                       let profile = Profile (targetPlatform dflags) (ways dflags)+                       return $ Failed $ cannotFindInterface+                                           (hsc_unit_env hsc_env)+                                           profile+                                           (may_show_locations (hsc_dflags hsc_env))+                                           (moduleName mod)+                                           err     where read_file file_path = do               traceIf (text "readIFace" <+> text file_path)               -- Figure out what is recorded in mi_module.  If this is               -- a fully definite interface, it'll match exactly, but               -- if it's indefinite, the inside will be uninstantiated!-              dflags <- getDynFlags+              unit_state <- hsc_units <$> getTopEnv               let wanted_mod =                     case getModuleInstantiation wanted_mod_with_insts of                         (_, Nothing) -> wanted_mod_with_insts                         (_, Just indef_mod) ->-                          instModuleToModule (unitState dflags)+                          instModuleToModule unit_state                             (uninstantiateInstantiatedModule indef_mod)               read_result <- readIface wanted_mod file_path               case read_result of                 Failed err -> return (Failed (badIfaceFile file_path err))                 Succeeded iface -> return (Succeeded (iface, file_path))                             -- Don't forget to fill in the package name...++          -- Indefinite interfaces are ALWAYS non-dynamic.+          checkBuildDynamicToo (Succeeded (iface, _filePath))+            | not (moduleIsDefinite (mi_module iface)) = return ()+           checkBuildDynamicToo (Succeeded (iface, filePath)) = do+              let load_dynamic = do+                     dflags <- getDynFlags+                     let dynFilePath = addBootSuffix_maybe hi_boot_file+                                     $ replaceExtension filePath (hiSuf dflags)+                     r <- read_file dynFilePath+                     case r of+                         Succeeded (dynIface, _)+                          | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->+                             return ()+                          | otherwise ->+                             do traceIf (text "Dynamic hash doesn't match")+                                setDynamicTooFailed dflags+                         Failed err ->+                             do traceIf (text "Failed to load dynamic interface file:" $$ err)+                                setDynamicTooFailed dflags+               dflags <- getDynFlags-              -- Indefinite interfaces are ALWAYS non-dynamic, and-              -- that's OK.-              let is_definite_iface = moduleIsDefinite (mi_module iface)-              when is_definite_iface $-                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do-                  let ref = canGenerateDynamicToo dflags-                      dynFilePath = addBootSuffix_maybe hi_boot_file-                                  $ replaceExtension filePath (dynHiSuf dflags)-                  r <- read_file dynFilePath-                  case r of-                      Succeeded (dynIface, _)-                       | mi_mod_hash (mi_final_exts iface) == mi_mod_hash (mi_final_exts dynIface) ->-                          return ()-                       | otherwise ->-                          do traceIf (text "Dynamic hash doesn't match")-                             liftIO $ writeIORef ref False-                      Failed err ->-                          do traceIf (text "Failed to load dynamic interface file:" $$ err)-                             liftIO $ writeIORef ref False+              dynamicTooState dflags >>= \case+                DT_Dont   -> return ()+                DT_Failed -> return ()+                DT_Dyn    -> load_dynamic+                DT_OK     -> withDynamicNow load_dynamic+           checkBuildDynamicToo _ = return ()  -- | Write interface file-writeIface :: DynFlags -> FilePath -> ModIface -> IO ()-writeIface dflags hi_file_path new_iface+writeIface :: Logger -> DynFlags -> FilePath -> ModIface -> IO ()+writeIface logger dflags hi_file_path new_iface     = do createDirectoryIfMissing True (takeDirectory hi_file_path)-         writeBinIface dflags hi_file_path new_iface+         let printer = TraceBinIFace (debugTraceMsg logger dflags 3)+             profile = targetProfile dflags+         writeBinIface profile printer hi_file_path new_iface  -- @readIface@ tries just the one file. readIface :: Module -> FilePath-          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)+          -> TcRnIf gbl lcl (MaybeErr SDoc ModIface)         -- Failed err    <=> file not found, or unreadable, or illegible         -- Succeeded iface <=> successfully found and parsed  readIface wanted_mod file_path   = do  { res <- tryMostM $-                 readBinIface CheckHiWay QuietBinIFaceReading file_path+                 readBinIface CheckHiWay QuietBinIFace file_path         ; case res of             Right iface                 -- NB: This check is NOT just a sanity check, it is@@ -1019,8 +966,8 @@ ********************************************************* -} -initExternalPackageState :: DynFlags -> ExternalPackageState-initExternalPackageState dflags+initExternalPackageState :: ExternalPackageState+initExternalPackageState   = EPS {       eps_is_boot          = emptyUFM,       eps_PIT              = emptyPackageIfaceTable,@@ -1028,22 +975,15 @@       eps_PTE              = emptyTypeEnv,       eps_inst_env         = emptyInstEnv,       eps_fam_inst_env     = emptyFamInstEnv,-      eps_rule_base        = mkRuleBase builtinRules',+      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-                           , n_rules_in = length builtinRules', n_rules_out = 0 }+                           , n_rules_in = length builtinRules, n_rules_out = 0 }     }-    where-      enableBignumRules-         | homeUnitId dflags == primUnitId   = EnableBignumRules False-         | homeUnitId dflags == bignumUnitId = EnableBignumRules False-         | otherwise                         = EnableBignumRules True-      builtinRules' = builtinRules enableBignumRules  {- *********************************************************@@ -1053,6 +993,7 @@ ********************************************************* -} +-- See Note [GHC.Prim] in primops.txt.pp. ghcPrimIface :: ModIface ghcPrimIface   = empty_iface {@@ -1065,7 +1006,7 @@   where     empty_iface = emptyFullModIface gHC_PRIM -    -- The fixities listed here for @`seq`@ or @->@ should match+    -- The fixity listed here for @`seq`@ should match     -- those in primops.txt.pp (from which Haddock docs are generated).     fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)              : mapMaybe mkFixity allThePrimOps@@ -1114,29 +1055,40 @@ -- | Read binary interface, and print it out showIface :: HscEnv -> FilePath -> IO () showIface hsc_env filename = do+   let dflags  = hsc_dflags hsc_env+   let logger  = hsc_logger hsc_env+       unit_state = hsc_units hsc_env+       printer = putLogMsg logger dflags NoReason SevOutput noSrcSpan . withPprStyle defaultDumpStyle+    -- skip the hi way check; we don't want to worry about profiled vs.    -- non-profiled interfaces, for example.    iface <- initTcRnIf 's' hsc_env () () $-       readBinIface IgnoreHiWay TraceBinIFaceReading filename-   let dflags = hsc_dflags hsc_env-       -- See Note [Name qualification with --show-iface]+       readBinIface IgnoreHiWay (TraceBinIFace printer) filename++   let -- See Note [Name qualification with --show-iface]        qualifyImportedNames mod _            | mod == mi_module iface = NameUnqual            | otherwise              = NameNotInScope1        print_unqual = QueryQualify qualifyImportedNames                                    neverQualifyModules                                    neverQualifyPackages-   putLogMsg dflags NoReason SevDump noSrcSpan-      $ withPprStyle (mkDumpStyle print_unqual) (pprModIface iface)+   putLogMsg logger dflags NoReason SevDump noSrcSpan+      $ withPprStyle (mkDumpStyle print_unqual)+      $ pprModIface unit_state iface --- Show a ModIface but don't display details; suitable for ModIfaces stored in+-- | Show a ModIface but don't display details; suitable for ModIfaces stored in -- the EPT.-pprModIfaceSimple :: ModIface -> SDoc-pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))+pprModIfaceSimple :: UnitState -> ModIface -> SDoc+pprModIfaceSimple unit_state iface =+    ppr (mi_module iface)+    $$ pprDeps unit_state (mi_deps iface)+    $$ nest 2 (vcat (map pprExport (mi_exports iface))) -pprModIface :: ModIface -> SDoc--- Show a ModIface-pprModIface iface@ModIface{ mi_final_exts = exts }+-- | Show a ModIface+--+-- The UnitState is used to pretty-print units+pprModIface :: UnitState -> ModIface -> SDoc+pprModIface unit_state iface@ModIface{ mi_final_exts = exts }  = vcat [ text "interface"                 <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)                 <+> (if mi_orphan exts then text "[orphan module]" else Outputable.empty)@@ -1156,7 +1108,7 @@         , nest 2 (text "where")         , text "exports:"         , nest 2 (vcat (map pprExport (mi_exports iface)))-        , pprDeps (mi_deps iface)+        , pprDeps unit_state (mi_deps iface)         , vcat (map pprUsage (mi_usages iface))         , vcat (map pprIfaceAnnotation (mi_anns iface))         , pprFixities (mi_fixities iface)@@ -1167,7 +1119,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))@@ -1186,16 +1138,17 @@ -}  pprExport :: IfaceExport -> SDoc-pprExport (Avail n)         = ppr n-pprExport (AvailTC _ [] []) = Outputable.empty-pprExport (AvailTC n ns0 fs)-  = case ns0 of-      (n':ns) | n==n' -> ppr n <> pp_export ns fs-      _               -> ppr n <> vbar <> pp_export ns0 fs+pprExport (Avail n)      = ppr n+pprExport (AvailTC _ []) = Outputable.empty+pprExport avail@(AvailTC n _) =+    ppr n <> mark <> pp_export (availSubordinateGreNames avail)   where-    pp_export []    [] = Outputable.empty-    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))+    mark | availExportsDecl avail = Outputable.empty+         | otherwise              = vbar +    pp_export []    = Outputable.empty+    pp_export names = braces (hsep (map ppr names))+ pprUsage :: Usage -> SDoc pprUsage usage@UsagePackageModule{}   = pprUsageImport usage usg_mod@@ -1220,10 +1173,12 @@         safe | usg_safe usage = text "safe"              | otherwise      = text " -/ " -pprDeps :: Dependencies -> SDoc-pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,-                dep_finsts = finsts })-  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),+-- | Pretty-print unit dependencies+pprDeps :: UnitState -> Dependencies -> SDoc+pprDeps unit_state (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,+                           dep_finsts = finsts })+  = pprWithUnitState unit_state $+    vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),           text "package dependencies:" <+> fsep (map ppr_pkg pkgs),           text "orphans:" <+> fsep (map ppr orphs),           text "family instance modules:" <+> fsep (map ppr finsts)@@ -1279,7 +1234,7 @@   = vcat [text "Bad interface file:" <+> text file,           nest 4 err] -hiModuleNameMismatchWarn :: Module -> Module -> MsgDoc+hiModuleNameMismatchWarn :: Module -> Module -> SDoc hiModuleNameMismatchWarn requested_mod read_mod  | moduleUnit requested_mod == moduleUnit read_mod =     sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,@@ -1309,3 +1264,267 @@            Just file -> space <> parens (text file)            Nothing   -> Outputable.empty)     <+> text "which is not loaded"+++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindInterface :: UnitEnv -> Profile -> ([FilePath] -> SDoc) -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")+                                           (sLit "Ambiguous interface for")++cantFindInstalledErr+    :: PtrString+    -> PtrString+    -> UnitEnv+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> InstalledFindResult+    -> SDoc+cantFindInstalledErr cannot_find _ unit_env profile tried_these mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    home_unit  = ue_home_unit unit_env+    unit_state = ue_units unit_env+    build_tag  = waysBuildTag (profileWays profile)++    more_info+      = case find_result of+            InstalledNoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found" $$ looks_like_srcpkgid pkg++            InstalledNotFound files mb_pkg+                | Just pkg <- mb_pkg, not (isHomeUnitId home_unit pkg)+                -> not_found_in_package pkg files++                | null files+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> tried_these files++            _ -> panic "cantFindInstalledErr"++    looks_like_srcpkgid :: UnitId -> SDoc+    looks_like_srcpkgid pk+     -- Unsafely coerce a unit id (i.e. an installed package component+     -- identifier) into a PackageId and see if it means anything.+     | (pkg:pkgs) <- searchPackageId unit_state (PackageId (unitIdFS pk))+     = parens (text "This unit ID looks like the source package ID;" $$+       text "the real unit ID is" <+> quotes (ftext (unitIdFS (unitId pkg))) $$+       (if null pkgs then Outputable.empty+        else text "and" <+> int (length pkgs) <+> text "other candidates"))+     -- Todo: also check if it looks like a package name!+     | otherwise = Outputable.empty++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++may_show_locations :: DynFlags -> [FilePath] -> SDoc+may_show_locations dflags files+    | null files = Outputable.empty+    | verbosity dflags < 3 =+          text "Use -v (or `:set -v` in ghci) " <>+              text "to see a list of the files searched for."+    | otherwise =+          hang (text "Locations searched:") 2 $ vcat (map text files)++cannotFindModule :: HscEnv -> ModuleName -> FindResult -> SDoc+cannotFindModule hsc_env = cannotFindModule'+    (hsc_dflags   hsc_env)+    (hsc_unit_env hsc_env)+    (targetProfile (hsc_dflags hsc_env))+++cannotFindModule' :: DynFlags -> UnitEnv -> Profile -> ModuleName -> FindResult -> SDoc+cannotFindModule' dflags unit_env profile mod res = pprWithUnitState (ue_units unit_env) $+  cantFindErr (gopt Opt_BuildingCabalPackage dflags)+              (sLit cannotFindMsg)+              (sLit "Ambiguous module name")+              unit_env+              profile+              (may_show_locations dflags)+              mod+              res+  where+    cannotFindMsg =+      case res of+        NotFound { fr_mods_hidden = hidden_mods+                 , fr_pkgs_hidden = hidden_pkgs+                 , fr_unusables = unusables }+          | not (null hidden_mods && null hidden_pkgs && null unusables)+          -> "Could not load module"+        _ -> "Could not find module"++cantFindErr+    :: Bool -- ^ Using Cabal?+    -> PtrString+    -> PtrString+    -> UnitEnv+    -> Profile+    -> ([FilePath] -> SDoc)+    -> ModuleName+    -> FindResult+    -> SDoc+cantFindErr _ _ multiple_found _ _ _ mod_name (FoundMultiple mods)+  | Just pkgs <- unambiguousPackages+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       sep [text "it was found in multiple packages:",+                hsep (map ppr pkgs) ]+    )+  | otherwise+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       vcat (map pprMod mods)+    )+  where+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+        = Just (moduleUnit m : xs)+    unambiguousPackage _ _ = Nothing++    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnit m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.mkUnit) res +++      if f then [text "a package flag"] else []+      )++cantFindErr using_cabal cannot_find _ unit_env profile tried_these mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    home_unit  = ue_home_unit unit_env+    more_info+      = case find_result of+            NoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found"++            NotFound { fr_paths = files, fr_pkg = mb_pkg+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+                     , fr_unusables = unusables, fr_suggestions = suggest }+                | Just pkg <- mb_pkg, not (isHomeUnit home_unit pkg)+                -> not_found_in_package pkg files++                | not (null suggest)+                -> pp_suggestions suggest $$ tried_these files++                | null files && null mod_hiddens &&+                  null pkg_hiddens && null unusables+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> vcat (map pkg_hidden pkg_hiddens) $$+                   vcat (map mod_hidden mod_hiddens) $$+                   vcat (map unusable unusables) $$+                   tried_these files++            _ -> panic "cantFindErr"++    build_tag = waysBuildTag (profileWays profile)++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files++    pkg_hidden :: Unit -> SDoc+    pkg_hidden uid =+        text "It is a member of the hidden package"+        <+> quotes (ppr uid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ pkg_hidden_hint uid++    pkg_hidden_hint uid+     | using_cabal+        = let pkg = expectJust "pkg_hidden" (lookupUnit (ue_units unit_env) uid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (unitPackageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | Just pkg <- lookupUnit (ue_units unit_env) uid+         = text "You can run" <+>+           quotes (text ":set -package " <> ppr (unitPackageName pkg)) <+>+           text "to expose it." $$+           text "(Note: this unloads all the modules in the current scope.)"+     | otherwise = Outputable.empty++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    unusable (pkg, reason)+      = text "It is a member of the package"+      <+> quotes (ppr pkg)+      $$ pprReason (text "which is") reason++    pp_suggestions :: [ModuleSuggestion] -> SDoc+    pp_suggestions sugs+      | null sugs = Outputable.empty+      | otherwise = hang (text "Perhaps you meant")+                       2 (vcat (map pp_sugg sugs))++    -- NB: Prefer the *original* location, and then reexports, and then+    -- package flags when making suggestions.  ToDo: if the original package+    -- also has a reexport, prefer that one+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+      where provenance ModHidden = Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromExposedReexport = res,+                                   fromPackageFlag = f })+              | Just True <- e+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | f && moduleName mod == m+                 = parens (text "from" <+> ppr (moduleUnit mod))+              | (pkg:_) <- res+                 = parens (text "from" <+> ppr (mkUnit pkg)+                    <> comma <+> text "reexporting" <+> ppr mod)+              | f+                 = parens (text "defined via package flags to be"+                    <+> ppr mod)+              | otherwise = Outputable.empty+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+      where provenance ModHidden =  Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigUnit = e,+                                   fromHiddenReexport = rhs })+              | Just False <- e+                 = parens (text "needs flag -package-id"+                    <+> ppr (moduleUnit mod))+              | (pkg:_) <- rhs+                 = parens (text "needs flag -package-id"+                    <+> ppr (mkUnit pkg))+              | otherwise = Outputable.empty

GHC/Iface/Load.hs-boot view

@@ -2,7 +2,7 @@  import GHC.Unit.Module (Module) import GHC.Tc.Utils.Monad (IfM)-import GHC.Driver.Types (ModIface)+import GHC.Unit.Module.ModIface (ModIface) import GHC.Utils.Outputable (SDoc)  loadSysInterface :: SDoc -> Module -> IfM lcl ModIface

GHC/Iface/Make.hs view

@@ -1,11 +1,11 @@+{-# LANGUAGE CPP                      #-}+{-# LANGUAGE NondecreasingIndentation #-}+ {- (c) The University of Glasgow 2006-2008 (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 -} -{-# LANGUAGE CPP, NondecreasingIndentation #-}-{-# LANGUAGE MultiWayIf #-}- -- | Module for constructing @ModIface@ values (interface files), -- writing them to disk and comparing two versions to see if -- recompilation is required.@@ -23,14 +23,21 @@  import GHC.Prelude +import GHC.Hs++import GHC.StgToCmm.Types (CgInfos (..))++import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Monad+ import GHC.Iface.Syntax import GHC.Iface.Recomp import GHC.Iface.Load+import GHC.Iface.Ext.Fields+ import GHC.CoreToIface -import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies )-import GHC.Types.Id-import GHC.Types.Annotations+import qualified GHC.LanguageExtensions as LangExt import GHC.Core import GHC.Core.Class import GHC.Core.TyCon@@ -39,14 +46,20 @@ import GHC.Core.DataCon import GHC.Core.Type import GHC.Core.Multiplicity-import GHC.StgToCmm.Types (CgInfos (..))-import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv-import GHC.Tc.Utils.Monad-import GHC.Hs-import GHC.Driver.Types+import GHC.Core.Unify( RoughMatchTc(..) )++import GHC.Driver.Env+import GHC.Driver.Backend import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Plugins (LoadedPlugin(..))++import GHC.Types.Id+import GHC.Types.Fixity.Env+import GHC.Types.SafeHaskell+import GHC.Types.Annotations import GHC.Types.Var.Env import GHC.Types.Var import GHC.Types.Name@@ -54,20 +67,36 @@ import GHC.Types.Name.Reader import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Unit.Module-import GHC.Utils.Error-import GHC.Utils.Outputable+import GHC.Types.Unique.DSet import GHC.Types.Basic hiding ( SuccessFlag(..) )+import GHC.Types.TypeEnv+import GHC.Types.SourceFile+import GHC.Types.TyThing+import GHC.Types.HpcInfo+import GHC.Types.CompleteMatch++import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc  hiding ( eqListBy )+import GHC.Utils.Logger+ import GHC.Data.FastString import GHC.Data.Maybe+ import GHC.HsToCore.Docs+import GHC.HsToCore.Usage ( mkUsageInfo, mkUsedNames, mkDependencies ) +import GHC.Unit+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.Deps+ import Data.Function import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef-import GHC.Driver.Plugins (LoadedPlugin(..))  {- ************************************************************************@@ -119,7 +148,9 @@       addFingerprints hsc_env partial_iface{ mi_decls = decls }      -- Debug printing-    dumpIfSet_dyn (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText (pprModIface full_iface)+    let unit_state = hsc_units hsc_env+    dumpIfSet_dyn (hsc_logger hsc_env) (hsc_dflags hsc_env) Opt_D_dump_hi "FINAL INTERFACE" FormatText+      (pprModIface unit_state full_iface)      return full_iface @@ -144,7 +175,7 @@  -- | Make an interface from the results of typechecking only.  Useful -- for non-optimising compilation, or where we aren't generating any--- object code at all ('HscNothing').+-- object code at all ('NoBackend'). mkIfaceTc :: HscEnv           -> SafeHaskellMode    -- The safe haskell mode           -> ModDetails         -- gotten from mkBootModDetails, probably@@ -164,10 +195,9 @@                     }   = do           let used_names = mkUsedNames tc_result-          let pluginModules =-                map lpModule (cachedPlugins (hsc_dflags hsc_env))-          deps <- mkDependencies-                    (homeUnitId (hsc_dflags hsc_env))+          let pluginModules = map lpModule (hsc_plugins hsc_env)+          let home_unit = hsc_home_unit hsc_env+          deps <- mkDependencies (homeUnitId home_unit)                     (map mi_module pluginModules) tc_result           let hpc_info = emptyHpcInfo other_hpc_info           used_th <- readIORef tc_splice_used@@ -182,7 +212,7 @@           usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names                       dep_files merged pluginModules -          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result+          (doc_hdr', doc_map, arg_map) <- extractDocs tc_result            let partial_iface = mkIface_ hsc_env                    this_mod hsc_src@@ -215,16 +245,18 @@                       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 --      to expose in the interface    = do-    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)+    let home_unit    = hsc_home_unit hsc_env+        semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod)         entities = typeEnvElts type_env-        decls  = [ tyThingToIfaceDecl (hsc_dflags hsc_env) entity+        show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)+        decls  = [ tyThingToIfaceDecl show_linear_types entity                  | entity <- entities,                    let name = getName entity,                    not (isImplicitTyThing entity),@@ -249,7 +281,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,@@ -278,14 +310,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)@@ -301,8 +333,8 @@      -- scope available. (#5534)      maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv      maybeGlobalRdrEnv rdr_env-         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env-         | otherwise                                   = Nothing+         | backendRetainsAllBindings (backend dflags) = Just rdr_env+         | otherwise                                  = Nothing       ifFamInstTcName = ifFamInstFam @@ -315,8 +347,9 @@ ************************************************************************ -} -mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch-mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc+mkIfaceCompleteMatch :: CompleteMatch -> IfaceCompleteMatch+mkIfaceCompleteMatch (CompleteMatch cls mtc) =+  IfaceCompleteMatch (map conLikeName (uniqDSetToList cls)) (toIfaceTyCon <$> mtc)   {-@@ -341,14 +374,12 @@   where     sort_subs :: AvailInfo -> AvailInfo     sort_subs (Avail n) = Avail n-    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)-    sort_subs (AvailTC n (m:ms) fs)-       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)-       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)+    sort_subs (AvailTC n []) = AvailTC n []+    sort_subs (AvailTC n (m:ms))+       | NormalGreName n==m  = AvailTC n (m:sortBy stableGreNameCmp ms)+       | otherwise = AvailTC n (sortBy stableGreNameCmp (m:ms))        -- Maintain the AvailTC Invariant -    sort_flds = sortBy (stableNameCmp `on` flSelector)- {- Note [Original module] ~~~~~~~~~~~~~~~~~~~~~@@ -375,12 +406,12 @@ ************************************************************************ -} -tyThingToIfaceDecl :: DynFlags -> TyThing -> IfaceDecl+tyThingToIfaceDecl :: Bool -> TyThing -> IfaceDecl tyThingToIfaceDecl _ (AnId id)      = idToIfaceDecl id tyThingToIfaceDecl _ (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon) tyThingToIfaceDecl _ (ACoAxiom ax)  = coAxiomToIfaceDecl ax-tyThingToIfaceDecl dflags (AConLike cl)  = case cl of-    RealDataCon dc -> dataConToIfaceDecl dflags dc -- for ppr purposes only+tyThingToIfaceDecl show_linear_types (AConLike cl)  = case cl of+    RealDataCon dc -> dataConToIfaceDecl show_linear_types dc -- for ppr purposes only     PatSynCon ps   -> patSynToIfaceDecl ps  --------------------------@@ -396,10 +427,10 @@               ifIdInfo    = toIfaceIdInfo (idInfo id) }  ---------------------------dataConToIfaceDecl :: DynFlags -> DataCon -> IfaceDecl-dataConToIfaceDecl dflags dataCon+dataConToIfaceDecl :: Bool -> DataCon -> IfaceDecl+dataConToIfaceDecl show_linear_types dataCon   = IfaceId { ifName      = getName dataCon,-              ifType      = toIfaceType (dataConDisplayType dflags dataCon),+              ifType      = toIfaceType (dataConDisplayType show_linear_types dataCon),               ifIdDetails = IfVanillaId,               ifIdInfo    = [] } @@ -625,7 +656,7 @@                 --                op :: (?x :: String) => a -> a                 -- and          class Baz a where                 --                op :: (Ord a) => a -> a-          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)+          (sel_tyvars, rho_ty) = splitForAllTyCoVars (idType sel_id)           op_ty                = funResultTy rho_ty      toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType@@ -656,34 +687,25 @@ instanceToIfaceInst :: ClsInst -> IfaceClsInst instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag                              , is_cls_nm = cls_name, is_cls = cls-                             , is_tcs = mb_tcs+                             , is_tcs = rough_tcs                              , is_orphan = orph })   = ASSERT( cls_name == className cls )-    IfaceClsInst { ifDFun    = dfun_name,-                ifOFlag   = oflag,-                ifInstCls = cls_name,-                ifInstTys = map do_rough mb_tcs,-                ifInstOrph = orph }-  where-    do_rough Nothing  = Nothing-    do_rough (Just n) = Just (toIfaceTyCon_name n)--    dfun_name = idName dfun_id-+    IfaceClsInst { ifDFun     = idName dfun_id+                 , ifOFlag    = oflag+                 , ifInstCls  = cls_name+                 , ifInstTys  = ifaceRoughMatchTcs rough_tcs+                 , ifInstOrph = orph }  -------------------------- famInstToIfaceFamInst :: FamInst -> IfaceFamInst famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,                                  fi_fam      = fam,-                                 fi_tcs      = roughs })+                                 fi_tcs      = rough_tcs })   = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom                  , ifFamInstFam      = fam-                 , ifFamInstTys      = map do_rough roughs+                 , ifFamInstTys      = ifaceRoughMatchTcs rough_tcs                  , ifFamInstOrph     = orph }   where-    do_rough Nothing  = Nothing-    do_rough (Just n) = Just (toIfaceTyCon_name n)-     fam_decl = tyConName $ coAxiomTyCon axiom     mod = ASSERT( isExternalName (coAxiomName axiom) )           nameModule (coAxiomName axiom)@@ -695,6 +717,12 @@          = NotOrphan (nameOccName fam_decl)          | otherwise          = chooseOrphanAnchor lhs_names++ifaceRoughMatchTcs :: [RoughMatchTc] -> [Maybe IfaceTyCon]+ifaceRoughMatchTcs tcs = map do_rough tcs+  where+    do_rough OtherTc     = Nothing+    do_rough (KnownTc n) = Just (toIfaceTyCon_name n)  -------------------------- coreRuleToIfaceRule :: CoreRule -> IfaceRule

GHC/Iface/Recomp.hs view

@@ -14,33 +14,51 @@  import GHC.Prelude +import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )+ import GHC.Iface.Syntax import GHC.Iface.Recomp.Binary import GHC.Iface.Load import GHC.Iface.Recomp.Flags -import GHC.Types.Annotations import GHC.Core import GHC.Tc.Utils.Monad import GHC.Hs-import GHC.Driver.Types-import GHC.Driver.Finder-import GHC.Driver.Session-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Unit.Module-import GHC.Utils.Error+ import GHC.Data.Graph.Directed-import GHC.Types.SrcLoc+import GHC.Data.Maybe+import GHC.Data.FastString++import GHC.Utils.Error+import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable-import GHC.Types.Unique import GHC.Utils.Misc as Utils hiding ( eqListBy )-import GHC.Data.Maybe import GHC.Utils.Binary import GHC.Utils.Fingerprint import GHC.Utils.Exception++import GHC.Types.Annotations+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.SrcLoc+import GHC.Types.Unique import GHC.Types.Unique.Set+import GHC.Types.Fixity.Env+import GHC.Types.SourceFile++import GHC.Unit.External+import GHC.Unit.Finder import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.Deps  import Control.Monad import Data.Function@@ -48,7 +66,6 @@ import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64)-import GHC.Driver.Plugins ( PluginRecompile(..), PluginWithArgs(..), pluginRecompile', plugins )  --Qualified import so we can define a Semigroup instance -- but it doesn't clash with Outputable.<>@@ -122,7 +139,8 @@  checkOldIface hsc_env mod_summary source_modified maybe_iface   = do  let dflags = hsc_dflags hsc_env-        showPass dflags $+        let logger = hsc_logger hsc_env+        showPass logger dflags $             "Checking old interface for " ++               (showPpr dflags $ ms_mod mod_summary) ++               " (use -ddump-hi-diffs for more details)"@@ -170,7 +188,7 @@             -- If the source has changed and we're in interactive mode,             -- avoid reading an interface; just return the one we might             -- have been supplied with.-            True | not (isObjectTarget $ hscTarget dflags) ->+            True | not (backendProducesObject $ backend dflags) ->                 return (MustCompile, maybe_iface)              -- Try and read the old interface for the current module@@ -213,7 +231,7 @@        -- readIface will have verified that the UnitId matches,        -- but we ALSO must make sure the instantiation matches up.  See        -- test case bkpcabal04!-       ; if moduleUnit (mi_module iface) /= homeUnit (hsc_dflags hsc_env)+       ; if not (isHomeModule home_unit (mi_module iface))             then return (RecompBecause "-this-unit-id changed", Nothing) else do {        ; recomp <- checkFlagHash hsc_env iface        ; if recompileRequired recomp then return (recomp, Nothing) else do {@@ -247,27 +265,28 @@        -- all the dependent modules should be in the HPT already, so it's        -- quite redundant        ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }-       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]+       ; recomp <- checkList [checkModUsage (homeUnitAsUnit home_unit) u+                             | u <- mi_usages iface]        ; return (recomp, Just iface)     }}}}}}}}}}   where-    this_pkg = homeUnit (hsc_dflags hsc_env)+    home_unit = hsc_home_unit hsc_env     -- This is a bit of a hack really     mod_deps :: ModuleNameEnv ModuleNameWithIsBoot     mod_deps = mkModDeps (dep_mods (mi_deps iface))  -- | Check if any plugins are requesting recompilation checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired-checkPlugins hsc iface = liftIO $ do-  new_fingerprint <- fingerprintPlugins hsc+checkPlugins hsc_env iface = liftIO $ do+  new_fingerprint <- fingerprintPlugins hsc_env   let old_fingerprint = mi_plugin_hash (mi_final_exts iface)-  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))+  pr <- mconcat <$> mapM pluginRecompile' (plugins hsc_env)   return $     pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr  fingerprintPlugins :: HscEnv -> IO Fingerprint-fingerprintPlugins hsc_env = do-  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)+fingerprintPlugins hsc_env =+  fingerprintPlugins' $ plugins hsc_env  fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint fingerprintPlugins' plugins = do@@ -330,10 +349,11 @@ -- implementing module has changed. checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired checkHsig mod_summary iface = do-    dflags <- getDynFlags-    let outer_mod = ms_mod mod_summary-        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)-    MASSERT( moduleUnit outer_mod == homeUnit dflags )+    hsc_env <- getTopEnv+    let home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        inner_mod = homeModuleNameInstantiation home_unit (moduleName outer_mod)+    MASSERT( isHomeModule home_unit outer_mod )     case inner_mod == mi_semantic_module iface of         True -> up_to_date (text "implementing module unchanged")         False -> return (RecompBecause "implementing module changed")@@ -358,7 +378,7 @@ checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired checkFlagHash hsc_env iface = do     let old_hash = mi_flag_hash (mi_final_exts iface)-    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)+    new_hash <- liftIO $ fingerprintDynFlags hsc_env                                              (mi_module iface)                                              putNameLiterally     case old_hash == new_hash of@@ -401,12 +421,12 @@ -- If the -unit-id flags change, this can change too. checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired checkMergedSignatures mod_summary iface = do-    dflags <- getDynFlags+    unit_state <- hsc_units <$> getTopEnv     let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]         new_merged = case Map.lookup (ms_mod_name mod_summary)-                                     (requirementContext (unitState dflags)) of+                                     (requirementContext unit_state) of                         Nothing -> []-                        Just r -> sort $ map (instModuleToModule (unitState dflags)) r+                        Just r -> sort $ map (instModuleToModule unit_state) r     if old_merged == new_merged         then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)         else return (RecompBecause "signatures to merge in changed")@@ -430,7 +450,7 @@ -- Returns (RecompBecause <textual reason>) if recompilation is required. checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired checkDependencies hsc_env summary iface- = do+ =    checkList $      [ checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))      , do@@ -447,15 +467,14 @@    prev_dep_mods = dep_mods (mi_deps iface)    prev_dep_plgn = dep_plgins (mi_deps iface)    prev_dep_pkgs = dep_pkgs (mi_deps iface)--   this_pkg = homeUnit (hsc_dflags hsc_env)+   home_unit     = hsc_home_unit hsc_env     dep_missing (mb_pkg, L _ mod) = do      find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)      let reason = moduleNameString mod ++ " changed"      case find_res of         Found _ mod-          | pkg == this_pkg+          | isHomeUnit home_unit pkg            -> if moduleName mod `notElem` map gwib_mod prev_dep_mods ++ prev_dep_plgn                  then do traceHiDiffs $                            text "imported module " <> quotes (ppr mod) <>@@ -481,7 +500,7 @@    isOldHomeDeps = flip Set.member old_deps    checkForNewHomeDependency (L _ mname) = do      let-       mod = mkModule this_pkg mname+       mod = mkHomeModule home_unit mname        str_mname = moduleNameString mname        reason = str_mname ++ " changed"      -- We only want to look at home modules to check if any new home dependency@@ -601,8 +620,7 @@        recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash        if not (recompileRequired recompile)          then return UpToDate-         else do-+         else            -- CHECK EXPORT LIST            checkMaybeHash reason maybe_old_export_hash new_export_hash                (text "  Export list changed") $ do@@ -937,7 +955,7 @@        extend_hash_env :: OccEnv (OccName,Fingerprint)                        -> (Fingerprint,IfaceDecl)                        -> IO (OccEnv (OccName,Fingerprint))-       extend_hash_env env0 (hash,d) = do+       extend_hash_env env0 (hash,d) =           return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0                  (ifaceDeclFingerprints hash d)) @@ -948,7 +966,8 @@    -- when calculating fingerprints, we always need to use canonical    -- ordering for lists of things.  In particular, the mi_deps has various    -- lists of modules and suchlike, so put these all in canonical order:-   let sorted_deps = sortDependencies (mi_deps iface0)+   let sorted_deps :: Dependencies+       sorted_deps = sortDependencies (mi_deps iface0)     -- The export hash of a module depends on the orphan hashes of the    -- orphan modules below us in the dependency tree.  This is the way@@ -1043,7 +1062,7 @@    --   - (some of) dflags    -- it returns two hashes, one that shouldn't change    -- the abi hash and one that should-   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally+   flag_hash <- fingerprintDynFlags hsc_env this_mod putNameLiterally     opt_hash <- fingerprintOptFlags dflags putNameLiterally @@ -1157,11 +1176,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) }  {- ************************************************************************@@ -1430,11 +1449,11 @@         -> (Name -> IO Fingerprint) mkHashFun hsc_env eps name   | isHoleModule orig_mod-  = lookup (mkHomeModule dflags (moduleName orig_mod))+  = lookup (mkHomeModule home_unit (moduleName orig_mod))   | otherwise   = lookup orig_mod   where-      dflags = hsc_dflags hsc_env+      home_unit = hsc_home_unit hsc_env       hpt = hsc_HPT hsc_env       pit = eps_PIT eps       occ = nameOccName name@@ -1443,14 +1462,18 @@         MASSERT2( isExternalName name, ppr name )         iface <- case lookupIfaceByModule hpt pit mod of                   Just iface -> return iface-                  Nothing -> do+                  Nothing ->                       -- This can occur when we're writing out ifaces for                       -- requirements; we didn't do any /real/ typechecking                       -- so there's no guarantee everything is loaded.                       -- Kind of a heinous hack.-                      iface <- initIfaceLoad hsc_env . withException-                            $ loadInterface (text "lookupVers2") mod ImportBySystem-                      return iface+                      initIfaceLoad hsc_env . withException+                          $ withoutDynamicNow+                            -- For some unknown reason, we need to reset the+                            -- dynamicNow bit, otherwise only dynamic+                            -- interfaces are looked up and some tests fail+                            -- (e.g. T16219).+                          $ loadInterface (text "lookupVers2") mod ImportBySystem         return $ snd (mi_hash_fn (mi_final_exts iface) occ `orElse`                   pprPanic "lookupVers1" (ppr mod <+> ppr occ))

GHC/Iface/Recomp/Binary.hs view

@@ -35,8 +35,7 @@ computeFingerprint put_nonbinding_name a = do     bh <- fmap set_user_data $ openBinMem (3*1024) -- just less than a block     put_ bh a-    fp <- fingerprintBinMem bh-    return fp+    fingerprintBinMem bh   where     set_user_data bh =       setUserData bh $ newWriteState put_nonbinding_name putNameLiterally putFS

GHC/Iface/Recomp/Flags.hs view

@@ -10,14 +10,16 @@  import GHC.Prelude -import GHC.Utils.Binary import GHC.Driver.Session-import GHC.Driver.Types+import GHC.Driver.Env++import GHC.Utils.Binary import GHC.Unit.Module import GHC.Types.Name+import GHC.Types.SafeHaskell import GHC.Utils.Fingerprint import GHC.Iface.Recomp.Binary--- import GHC.Utils.Outputable+import GHC.Core.Opt.CallerCC () -- for Binary instances  import GHC.Data.EnumSet as EnumSet import System.FilePath (normalise)@@ -29,14 +31,15 @@ -- NB: The 'Module' parameter is the 'Module' recorded by the -- *interface* file, not the actual 'Module' according to our -- 'DynFlags'.-fingerprintDynFlags :: DynFlags -> Module+fingerprintDynFlags :: HscEnv -> Module                     -> (BinHandle -> Name -> IO ())                     -> IO Fingerprint -fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =-    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing+fingerprintDynFlags hsc_env this_mod nameio =+    let dflags@DynFlags{..} = hsc_dflags hsc_env+        mainis   = if mainModIs hsc_env == this_mod then Just mainFunIs else Nothing                       -- see #5878-        -- pkgopts  = (homeUnit dflags, sort $ packageFlags dflags)+        -- pkgopts  = (homeUnit home_unit, sort $ packageFlags dflags)         safeHs   = setSafeMode safeHaskell         -- oflags   = sort $ filter filterOFlags $ flags dflags @@ -65,7 +68,7 @@         ticky =           map (`gopt` dflags) [Opt_Ticky, Opt_Ticky_Allocd, Opt_Ticky_LNE, Opt_Ticky_Dyn_Thunk] -        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel))+        flags = ((mainis, safeHs, lang, cpp), (paths, prof, ticky, debugLevel, callerCcFilters))      in -- pprTrace "flags" (ppr flags) $        computeFingerprint nameio flags

GHC/Iface/Rename.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -19,40 +18,46 @@  import GHC.Prelude -import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Driver.Types+import GHC.Driver.Env++import GHC.Tc.Utils.Monad++import GHC.Iface.Syntax+import GHC.Iface.Env+import {-# SOURCE #-} GHC.Iface.Load -- a bit vexing+ import GHC.Unit+import GHC.Unit.State+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps++import GHC.Types.SrcLoc import GHC.Types.Unique.FM import GHC.Types.Avail-import GHC.Iface.Syntax+import GHC.Types.Error import GHC.Types.FieldLabel import GHC.Types.Var-import GHC.Utils.Error-+import GHC.Types.Basic import GHC.Types.Name-import GHC.Tc.Utils.Monad+import GHC.Types.Name.Shape++import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Fingerprint-import GHC.Types.Basic+import GHC.Utils.Panic --- a bit vexing-import {-# SOURCE #-} GHC.Iface.Load-import GHC.Driver.Session+import GHC.Data.Bag  import qualified Data.Traversable as T -import GHC.Data.Bag import Data.IORef-import GHC.Types.Name.Shape-import GHC.Iface.Env  tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a tcRnMsgMaybe do_this = do     r <- liftIO $ do_this     case r of         Left errs -> do-            addMessages (emptyBag, errs)+            addMessages (mkMessages errs)             failM         Right x -> return x @@ -69,10 +74,9 @@ failWithRn :: SDoc -> ShIfM a failWithRn doc = do     errs_var <- fmap sh_if_errs getGblEnv-    dflags <- getDynFlags     errs <- readTcRef errs_var     -- TODO: maybe associate this with a source location?-    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)+    writeTcRef errs_var (errs `snocBag` mkPlainMsgEnvelope noSrcSpan doc)     failM  -- | What we have is a generalized ModIface, which corresponds to@@ -97,7 +101,7 @@ -- when loading an interface to merge it into a requirement.) rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape            -> ModIface -> IO (Either ErrorMessages ModIface)-rnModIface hsc_env insts nsubst iface = do+rnModIface hsc_env insts nsubst iface =     initRnIface hsc_env iface insts nsubst $ do         mod <- rnModule (mi_module iface)         sig_of <- case mi_sig_of iface of@@ -139,7 +143,6 @@     -- because ModIface will never contain module reference for itself     -- in these dependencies.     fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do-        dflags <- getDynFlags         -- For holes, its necessary to "see through" the instantiation         -- of the hole to get accurate family instance dependencies.         -- For example, if B imports <A>, and <A> is instantiated with@@ -164,7 +167,7 @@         -- not to do it in this case either...)         --         -- This mistake was bug #15594.-        let mod' = renameHoleModule (unitState dflags) hmap mod+        let mod' = renameHoleModule (hsc_units hsc_env) hmap mod         if isHoleModule mod           then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env                                   $ loadSysInterface (text "rnDepModule") mod'@@ -184,9 +187,8 @@             -> ShIfM a -> IO (Either ErrorMessages a) initRnIface hsc_env iface insts nsubst do_this = do     errs_var <- newIORef emptyBag-    let dflags = hsc_dflags hsc_env-        hsubst = listToUFM insts-        rn_mod = renameHoleModule (unitState dflags) hsubst+    let hsubst = listToUFM insts+        rn_mod = renameHoleModule (hsc_units hsc_env) hsubst         env = ShIfEnv {             sh_if_module = rn_mod (mi_module iface),             sh_if_semantic_module = rn_mod (mi_semantic_module iface),@@ -232,29 +234,34 @@ rnModule :: Rename Module rnModule mod = do     hmap <- getHoleSubst-    dflags <- getDynFlags-    return (renameHoleModule (unitState dflags) hmap mod)+    unit_state <- hsc_units <$> getTopEnv+    return (renameHoleModule unit_state hmap mod)  rnAvailInfo :: Rename AvailInfo-rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n-rnAvailInfo (AvailTC n ns fs) = do+rnAvailInfo (Avail c) = Avail <$> rnGreName c+rnAvailInfo (AvailTC n ns) = do     -- Why don't we rnIfaceGlobal the availName itself?  It may not     -- actually be exported by the module it putatively is from, in     -- which case we won't be able to tell what the name actually     -- is.  But for the availNames they MUST be exported, so they     -- will rename fine.-    ns' <- mapM rnIfaceGlobal ns-    fs' <- mapM rnFieldLabel fs-    case ns' ++ map flSelector fs' of+    ns' <- mapM rnGreName ns+    case ns' of         [] -> panic "rnAvailInfoEmpty AvailInfo"-        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do-                         n' <- setNameModule (Just (nameModule rep)) n-                         return (AvailTC n' ns' fs')+        (rep:rest) -> ASSERT2( all ((== childModule rep) . childModule) rest, ppr rep $$ hcat (map ppr rest) ) do+                         n' <- setNameModule (Just (childModule rep)) n+                         return (AvailTC n' ns')+  where+    childModule = nameModule . greNameMangledName +rnGreName :: Rename GreName+rnGreName (NormalGreName n) = NormalGreName <$> rnIfaceGlobal n+rnGreName (FieldGreName fl) = FieldGreName  <$> rnFieldLabel fl+ rnFieldLabel :: Rename FieldLabel-rnFieldLabel (FieldLabel l b sel) = do-    sel' <- rnIfaceGlobal sel-    return (FieldLabel l b sel')+rnFieldLabel fl = do+    sel' <- rnIfaceGlobal (flSelector fl)+    return (fl { flSelector = sel' })   @@ -297,12 +304,13 @@ rnIfaceGlobal :: Name -> ShIfM Name rnIfaceGlobal n = do     hsc_env <- getTopEnv-    let dflags = hsc_dflags hsc_env+    let unit_state = hsc_units hsc_env+        home_unit  = hsc_home_unit hsc_env     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv     mb_nsubst <- fmap sh_if_shape getGblEnv     hmap <- getHoleSubst     let m = nameModule n-        m' = renameHoleModule (unitState dflags) hmap m+        m' = renameHoleModule unit_state hmap m     case () of        -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,        -- do NOT assume B.hi is available.@@ -341,7 +349,7 @@             -- went from <A> to <B>.             let m'' = if isHoleModule m'                         -- Pull out the local guy!!-                        then mkHomeModule dflags (moduleName m')+                        then mkHomeModule home_unit (moduleName m')                         else m'             iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env                             $ loadSysInterface (text "rnIfaceGlobal") m''@@ -361,9 +369,9 @@ rnIfaceNeverExported :: Name -> ShIfM Name rnIfaceNeverExported name = do     hmap <- getHoleSubst-    dflags <- getDynFlags+    unit_state <- hsc_units <$> getTopEnv     iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv-    let m = renameHoleModule (unitState dflags) hmap $ nameModule name+    let m = renameHoleModule unit_state hmap $ nameModule name     -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.     MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )     setNameModule (Just m) name@@ -406,7 +414,7 @@ rnIfaceClsInst :: Rename IfaceClsInst rnIfaceClsInst cls_inst = do     n <- rnIfaceGlobal (ifInstCls cls_inst)-    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)+    tys <- mapM rnRoughMatchTyCon (ifInstTys cls_inst)      dfun <- rnIfaceNeverExported (ifDFun cls_inst)     return cls_inst { ifInstCls = n@@ -414,14 +422,14 @@                     , ifDFun = dfun                     } -rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)-rnMaybeIfaceTyCon Nothing = return Nothing-rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc+rnRoughMatchTyCon :: Rename (Maybe IfaceTyCon)+rnRoughMatchTyCon Nothing = return Nothing+rnRoughMatchTyCon (Just tc) = Just <$> rnIfaceTyCon tc  rnIfaceFamInst :: Rename IfaceFamInst rnIfaceFamInst d = do     fam <- rnIfaceGlobal (ifFamInstFam d)-    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)+    tys <- mapM rnRoughMatchTyCon (ifFamInstTys d)     axiom <- rnIfaceGlobal (ifFamInstAxiom d)     return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom } @@ -654,8 +662,8 @@ rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis  rnIfaceAlt :: Rename IfaceAlt-rnIfaceAlt (conalt, names, rhs)-     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs+rnIfaceAlt (IfaceAlt conalt names rhs)+     = IfaceAlt <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs  rnIfaceConAlt :: Rename IfaceConAlt rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ

GHC/Iface/Syntax.hs view

@@ -11,7 +11,7 @@          IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),         IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,-        IfaceExpr(..), IfaceAlt, IfaceLetBndr(..), IfaceJoinInfo(..),+        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..),         IfaceBinding(..), IfaceConAlt(..),         IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..),         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,@@ -62,20 +62,23 @@ import GHC.Types.ForeignCall import GHC.Types.Annotations( AnnPayload, AnnTarget ) import GHC.Types.Basic-import GHC.Utils.Outputable as Outputable import GHC.Unit.Module import GHC.Types.SrcLoc-import GHC.Utils.Fingerprint-import GHC.Utils.Binary import GHC.Data.BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import GHC.Types.Var( VarBndr(..), binderVar, tyVarSpecToBinders ) import GHC.Core.TyCon ( Role (..), Injectivity(..), tyConBndrVisArgFlag )-import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,-                       seqList, zipWithEqual ) import GHC.Core.DataCon (SrcStrictness(..), SrcUnpackedness(..))-import GHC.Utils.Lexeme (isLexSym) import GHC.Builtin.Types ( constraintKindTyConName ) +import GHC.Utils.Lexeme (isLexSym)+import GHC.Utils.Fingerprint+import GHC.Utils.Binary+import GHC.Utils.Binary.Typeable ()+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc( dropList, filterByList, notNull, unzipWith, debugIsOn,+                       seqList, zipWithEqual )+ import Control.Monad import System.IO.Unsafe import Control.DeepSeq@@ -192,7 +195,7 @@   | IfDataInstance        IfExtName     -- Axiom name        IfaceTyCon    -- Family TyCon (pretty-printing only, not used in GHC.IfaceToCore)-                     -- see Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing+                     -- see Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr        IfaceAppArgs  -- Arguments of the family TyCon  data IfaceFamTyConFlav@@ -201,7 +204,7 @@   | IfaceClosedSynFamilyTyCon (Maybe (IfExtName, [IfaceAxBranch]))     -- ^ Name of associated axiom and branches for pretty printing purposes,     -- or 'Nothing' for an empty closed family without an axiom-    -- See Note [Pretty printing via Iface syntax] in "GHC.Core.Ppr.TyThing"+    -- See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr"   | IfaceAbstractClosedSynFamilyTyCon   | IfaceBuiltInSynFamTyCon -- for pretty printing purposes only @@ -322,14 +325,12 @@  type IfaceAnnTarget = AnnTarget OccName -data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] IfExtName+data IfaceCompleteMatch = IfaceCompleteMatch [IfExtName] (Maybe IfaceTyCon)  instance Outputable IfaceCompleteMatch where-  ppr (IfaceCompleteMatch cls ty) = text "COMPLETE" <> colon <+> ppr cls-                                                    <+> dcolon <+> ppr ty---+  ppr (IfaceCompleteMatch cls mtc) = text "COMPLETE" <> colon <+> ppr cls <+> case mtc of+    Nothing -> empty+    Just tc -> dcolon <+> ppr tc  -- Here's a tricky case: --   * Compile with -O module A, and B which imports A.f@@ -461,12 +462,13 @@ --  *Excludes* the 'main' name, but *includes* the implicitly-bound names -- Deeply revolting, because it has to predict what gets bound, -- especially the question of whether there's a wrapper for a datacon--- See Note [Implicit TyThings] in GHC.Driver.Types+-- See Note [Implicit TyThings] in GHC.Driver.Env  -- N.B. the set of names returned here *must* match the set of--- TyThings returned by GHC.Driver.Types.implicitTyThings, in the sense that+-- TyThings returned by GHC.Driver.Env.implicitTyThings, in the sense that -- TyThing.getOccName should define a bijection between the two lists.--- This invariant is used in GHC.Iface.Load.loadDecl (see note [Tricky iface loop])+-- This invariant is used in GHC.IfaceToCore.tc_iface_decl_fingerprint (see note+-- [Tricky iface loop]) -- The order of the list does not matter.  ifaceDeclImplicitBndrs (IfaceData {ifName = tc_name, ifCons = cons })@@ -565,7 +567,7 @@   | IfaceSource  RealSrcSpan String        -- from SourceNote   -- no breakpoints: we never export these into interface files -type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)+data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr         -- Note: IfLclName, not IfaceBndr (and same with the case binder)         -- We reconstruct the kind/type of the thing from the context         -- thus saving bulk in interface files@@ -734,7 +736,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The binders in an IfaceDecl are just OccNames, so we don't know what module they come from.  But when we pretty-print a TyThing by converting to an IfaceDecl-(see GHC.Core.Ppr.TyThing), the TyThing may come from some other module so we really need+(see GHC.Types.TyThing.Ppr), the TyThing may come from some other module so we really need the module qualifier.  We solve this by passing in a pretty-printer for the binders. @@ -800,11 +802,11 @@  constraintIfaceKind :: IfaceKind constraintIfaceKind =-  IfaceTyConApp (IfaceTyCon constraintKindTyConName (IfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil+  IfaceTyConApp (IfaceTyCon constraintKindTyConName (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)) IA_Nil  pprIfaceDecl :: ShowSub -> IfaceDecl -> SDoc -- NB: pprIfaceDecl is also used for pretty-printing TyThings in GHCi---     See Note [Pretty-printing TyThings] in GHC.Core.Ppr.TyThing+--     See Note [Pretty-printing TyThings] in GHC.Types.TyThing.Ppr pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,                              ifCtxt = context, ifResKind = kind,                              ifRoles = roles, ifCons = condecls,@@ -1381,7 +1383,7 @@                  , text "ret_ty" <+> pprParendIfaceType ty                  , text "of {}" ]) -pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])+pprIfaceExpr add_par (IfaceCase scrut bndr [IfaceAlt con bs rhs])   = add_par (sep [text "case"                         <+> pprIfaceExpr noParens scrut <+> text "of"                         <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,@@ -1391,7 +1393,7 @@   = add_par (sep [text "case"                         <+> pprIfaceExpr noParens scrut <+> text "of"                         <+> ppr bndr <+> char '{',-                  nest 2 (sep (map ppr_alt alts)) <+> char '}'])+                  nest 2 (sep (map pprIfaceAlt alts)) <+> char '}'])  pprIfaceExpr _       (IfaceCast expr co)   = sep [pprParendIfaceExpr expr,@@ -1413,9 +1415,9 @@ pprIfaceExpr add_par (IfaceTick tickish e)   = add_par (pprIfaceTickish tickish <+> pprIfaceExpr noParens e) -ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc-ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,-                         arrow <+> pprIfaceExpr noParens rhs]+pprIfaceAlt :: IfaceAlt -> SDoc+pprIfaceAlt (IfaceAlt con bs rhs)+  = sep [ppr_con_bs con bs, arrow <+> pprIfaceExpr noParens rhs]  ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)@@ -1461,7 +1463,7 @@                               <> colon <+> ppr unf   ppr (HsInline prag)       = text "Inline:" <+> ppr prag   ppr (HsArity arity)       = text "Arity:" <+> int arity-  ppr (HsStrictness str)    = text "Strictness:" <+> pprIfaceStrictSig str+  ppr (HsStrictness str)    = text "Strictness:" <+> ppr str   ppr (HsCpr cpr)           = text "CPR:" <+> ppr cpr   ppr HsNoCafRefs           = text "HasNoCafRefs"   ppr HsLevity              = text "Never levity-polymorphic"@@ -1744,14 +1746,14 @@ freeNamesIfExpr (IfaceCase s _ alts)   = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts   where-    fn_alt (_con,_bs,r) = freeNamesIfExpr r+    fn_alt (IfaceAlt _con _bs r) = freeNamesIfExpr r      -- Depend on the data constructors.  Just one will do!     -- Note [Tracking data constructors]-    fn_cons []                            = emptyNameSet-    fn_cons ((IfaceDefault    ,_,_) : xs) = fn_cons xs-    fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con-    fn_cons (_                      : _ ) = emptyNameSet+    fn_cons []                                     = emptyNameSet+    fn_cons (IfaceAlt IfaceDefault _ _       : xs) = fn_cons xs+    fn_cons (IfaceAlt (IfaceDataAlt con) _ _ : _ ) = unitNameSet con+    fn_cons (_                               : _ ) = emptyNameSet  freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body)   = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body@@ -2014,13 +2016,13 @@ When we read an interface file, we extend the PTE, a mapping of Names to TyThings, with the declarations we have read. The extension of the PTE is strict in the Names, but not in the TyThings themselves.-GHC.Iface.Load.loadDecl calculates the list of (Name, TyThing) bindings to-add to the PTE. For an IfaceId, there's just one binding to add; and+GHC.IfaceToCore.tcIfaceDecls calculates the list of (Name, TyThing) bindings+to add to the PTE.  For an IfaceId, there's just one binding to add; and the ty, details, and idinfo fields of an IfaceId are used only in the TyThing. So by reading those fields lazily we may be able to save the work of ever having to deserialize them (into IfaceType, etc.). -For IfaceData and IfaceClass, loadDecl creates extra implicit bindings+For IfaceData and IfaceClass, tcIfaceDecls creates extra implicit bindings (the constructors and field selectors of the data declaration, or the methods of the class), whose Names depend on more than just the Name of the type constructor or class itself. So deserializing them lazily@@ -2136,10 +2138,10 @@     get bh = do             h <- getByte bh             case h of-              0 -> do return IfNoBang-              1 -> do return IfStrict-              2 -> do return IfUnpack-              _ -> do { a <- get bh; return (IfUnpackCo a) }+              0 -> return IfNoBang+              1 -> return IfStrict+              2 -> return IfUnpack+              _ -> IfUnpackCo <$> get bh  instance Binary IfaceSrcBang where     put_ bh (IfSrcBang a1 a2) =@@ -2279,6 +2281,16 @@             _ -> do e <- get bh                     return (IfCompulsory e) +instance Binary IfaceAlt where+    put_ bh (IfaceAlt a b c) = do+        put_ bh a+        put_ bh b+        put_ bh c+    get bh = do+        a <- get bh+        b <- get bh+        c <- get bh+        return (IfaceAlt a b c)  instance Binary IfaceExpr where     put_ bh (IfaceLcl aa) = do@@ -2479,7 +2491,7 @@                 return $ IfDataInstance ax pr ty  instance Binary IfaceCompleteMatch where-  put_ bh (IfaceCompleteMatch cs ts) = put_ bh cs >> put_ bh ts+  put_ bh (IfaceCompleteMatch cs mtc) = put_ bh cs >> put_ bh mtc   get bh = IfaceCompleteMatch <$> get bh <*> get bh  @@ -2603,6 +2615,9 @@     IfaceFCall fc ty -> fc `seq` rnf ty     IfaceTick tick e -> rnf tick `seq` rnf e +instance NFData IfaceAlt where+  rnf (IfaceAlt con bndrs rhs) = rnf con `seq` rnf bndrs `seq` rnf rhs+ instance NFData IfaceBinding where   rnf = \case     IfaceNonRec bndr e -> rnf bndr `seq` rnf e@@ -2636,7 +2651,7 @@     IfaceLitAlt lit -> lit `seq` ()  instance NFData IfaceCompleteMatch where-  rnf (IfaceCompleteMatch f1 f2) = rnf f1 `seq` rnf f2+  rnf (IfaceCompleteMatch f1 mtc) = rnf f1 `seq` rnf mtc  instance NFData IfaceRule where   rnf (IfaceRule f1 f2 f3 f4 f5 f6 f7 f8) =

GHC/Iface/Tidy.hs view

@@ -1,13 +1,14 @@+{-# LANGUAGE CPP           #-}+{-# LANGUAGE DeriveFunctor #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  \section{Tidying up Core} -} -{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Iface.Tidy (        mkBootModDetailsTc, tidyProgram    ) where@@ -16,10 +17,16 @@  import GHC.Prelude -import GHC.Tc.Types import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Env++import GHC.Tc.Types+ 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@@ -27,38 +34,50 @@ import GHC.Core.Seq     (seqBinds) import GHC.Core.Lint import GHC.Core.Rules-import GHC.Core.PatSyn-import GHC.Core.ConLike import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )+import GHC.Core.InstEnv+import GHC.Core.Type     ( tidyTopType )+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Core.Class+ import GHC.Iface.Tidy.StaticPtrTable+import GHC.Iface.Env++import GHC.Tc.Utils.Env+import GHC.Tc.Utils.Monad++import GHC.Utils.Outputable+import GHC.Utils.Misc( filterOut )+import GHC.Utils.Panic+import GHC.Utils.Logger as Logger+import qualified GHC.Utils.Error as Err++import GHC.Types.ForeignStubs import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Make ( mkDictSelRhs ) import GHC.Types.Id.Info-import GHC.Core.InstEnv-import GHC.Core.Type     ( tidyTopType ) import GHC.Types.Demand  ( appIsDeadEnd, isTopSig, isDeadEndSig ) import GHC.Types.Cpr     ( mkCprSig, botCpr ) import GHC.Types.Basic import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache+import GHC.Types.Name.Ppr import GHC.Types.Avail-import GHC.Iface.Env-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Monad-import GHC.Core.DataCon-import GHC.Core.TyCon-import GHC.Core.Class+import GHC.Types.Unique.Supply+import GHC.Types.Tickish+import GHC.Types.TypeEnv+ import GHC.Unit.Module-import GHC.Driver.Types+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+ import GHC.Data.Maybe-import GHC.Types.Unique.Supply-import GHC.Utils.Outputable-import GHC.Utils.Misc( filterOut )-import qualified GHC.Utils.Error as Err  import Control.Monad import Data.Function@@ -139,24 +158,25 @@                   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     -- the message is useful to locating oneself in the compilation process.-    Err.withTiming dflags+    Err.withTiming logger 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+    logger = hsc_logger hsc_env      -- Find the LocalIds in the type env that are exported     -- Make them into GlobalIds, and tidy their types@@ -175,10 +195,8 @@      final_tcs  = filterOut isWiredIn tcs                  -- See Note [Drop wired-in things]-    type_env1  = typeEnvFromEntities final_ids final_tcs fam_insts-    insts'     = mkFinalClsInsts type_env1 insts-    pat_syns'  = mkFinalPatSyns  type_env1 pat_syns-    type_env'  = extendTypeEnvWithPatSyns pat_syns' type_env1+    type_env'  = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts+    insts'     = mkFinalClsInsts type_env' insts      -- Default methods have their export flag set (isExportedId),     -- but everything else doesn't (yet), because this is@@ -202,13 +220,6 @@ mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst] mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env)) -mkFinalPatSyns :: TypeEnv -> [PatSyn] -> [PatSyn]-mkFinalPatSyns env = map (updatePatSynIds (lookupFinalId env))--extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv-extendTypeEnvWithPatSyns tidy_patsyns type_env-  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]- globaliseAndTidyBootId :: Id -> Id -- For a LocalId with an External Name, -- makes it into a GlobalId@@ -342,30 +353,30 @@ -}  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+  = Err.withTiming logger dflags                    (text "CoreTidy"<+>brackets (ppr mod))                    (const ()) $     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags-              ; print_unqual = mkPrintUnqualified dflags rdr_env+              ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env               ; implicit_binds = concatMap getImplicitBinds tcs               } @@ -375,18 +386,20 @@         ; 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 hscTarget dflags of+                  case backend dflags of                     -- If we are compiling for the interpreter we will insert                     -- any necessary SPT entries dynamically-                    HscInterpreted -> id+                    Interpreter -> id                     -- otherwise add a C stub to do so                     _              -> (`appendStubC` spt_init_code) @@ -409,10 +422,8 @@                ; final_tcs      = filterOut isWiredIn tcs                                  -- See Note [Drop wired-in things]-              ; type_env       = typeEnvFromEntities final_ids final_tcs fam_insts-              ; tidy_cls_insts = mkFinalClsInsts type_env cls_insts-              ; tidy_patsyns   = mkFinalPatSyns  type_env patsyns-              ; tidy_type_env  = extendTypeEnvWithPatSyns tidy_patsyns type_env+              ; tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts+              ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts               ; tidy_rules     = tidyRules tidy_env trimmed_rules                ; -- See Note [Injecting implicit bindings]@@ -434,15 +445,15 @@           -- If the endPass didn't print the rules, but ddump-rules is           -- on, print now         ; unless (dopt Opt_D_dump_simpl dflags) $-            Err.dumpIfSet_dyn dflags Opt_D_dump_rules+            Logger.dumpIfSet_dyn logger dflags Opt_D_dump_rules               (showSDoc dflags (ppr CoreTidy <+> text "rules"))-              Err.FormatText+              FormatText               (pprRulesForUser tidy_rules)            -- Print one-line size info         ; let cs = coreBindsStats tidy_binds-        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"-            Err.FormatText+        ; Logger.dumpIfSet_dyn logger dflags Opt_D_dump_core_stats "Core Stats"+            FormatText             (text "Tidy size (terms,types,coercions)"              <+> ppr (moduleName mod) <> colon              <+> int (cs_tm cs)@@ -459,17 +470,18 @@                            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     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env  -------------------------- trimId :: Bool -> Id -> Id@@ -806,7 +818,7 @@ dffvExpr (Var v)              = insert v dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2 dffvExpr (Lam v e)            = extendScope v (dffvExpr e)-dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e+dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e dffvExpr (Tick _other e)    = dffvExpr e dffvExpr (Cast e _)           = dffvExpr e dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)@@ -815,8 +827,8 @@ dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as) dffvExpr _other               = return () -dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()-dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)+dffvAlt :: CoreAlt -> DFFV ()+dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r)  dffvBind :: (Id, CoreExpr) -> DFFV () dffvBind(x,r)@@ -1102,43 +1114,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@@ -1150,7 +1160,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!@@ -1163,14 +1173,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@@ -1180,9 +1190,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;@@ -1239,7 +1249,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

GHC/Iface/Tidy/StaticPtrTable.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE ViewPatterns  #-}+ -- | Code generation for the Static Pointer Table -- -- (c) 2014 I/O Tweag@@ -45,7 +47,6 @@ -- > } -- -{-# LANGUAGE ViewPatterns, TupleSections #-} module GHC.Iface.Tidy.StaticPtrTable     ( sptCreateStaticBinds     , sptModuleInitCode@@ -123,26 +124,35 @@ -}  import GHC.Prelude+import GHC.Platform -import GHC.Cmm.CLabel+import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon-import GHC.Driver.Session-import GHC.Driver.Types-import GHC.Types.Id import GHC.Core.Make (mkStringExprFSWith)+import GHC.Core.Type++import GHC.Cmm.CLabel+ import GHC.Unit.Module-import GHC.Types.Name import GHC.Utils.Outputable as Outputable-import GHC.Platform+import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Tc.Utils.Env (lookupGlobal)-import GHC.Core.Type +import GHC.Linker.Types++import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.TyThing+import GHC.Types.ForeignStubs+ import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State-import Data.List+import Data.List (intercalate) import Data.Maybe import GHC.Fingerprint import qualified GHC.LanguageExtensions as LangExt@@ -240,11 +250,11 @@         PW8 -> mkWordLit platform . toInteger      lookupIdHscEnv :: Name -> IO Id-    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=+    lookupIdHscEnv n = lookupType hsc_env n >>=                          maybe (getError n) (return . tyThingId)      lookupDataConHscEnv :: Name -> IO DataCon-    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=+    lookupDataConHscEnv n = lookupType hsc_env n >>=                               maybe (getError n) (return . tyThingDataCon)      getError n = pprPanic "sptCreateStaticBinds.get: not found" $@@ -255,9 +265,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] -> CStub+sptModuleInitCode _        _        [] = mempty+sptModuleInitCode platform this_mod entries = CStub $ 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)"@@ -265,11 +275,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

GHC/Iface/Type.hs view

@@ -14,12 +14,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} -#if !MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)-{-# OPTIONS_GHC -Wno-overlapping-patterns -Wno-incomplete-patterns #-}-  -- N.B. This can be dropped once GHC 8.8 can be dropped as a-  -- bootstrap compiler.-#endif- module GHC.Iface.Type (         IfExtName, IfLclName, @@ -27,7 +21,9 @@         IfaceMCoercion(..),         IfaceUnivCoProv(..),         IfaceMult,-        IfaceTyCon(..), IfaceTyConInfo(..), IfaceTyConSort(..),+        IfaceTyCon(..),+        IfaceTyConInfo(..), mkIfaceTyConInfo,+        IfaceTyConSort(..),         IfaceTyLit(..), IfaceAppArgs(..),         IfaceContext, IfaceBndr(..), IfaceOneShot(..), IfaceLamBndr,         IfaceTvBndr, IfaceIdBndr, IfaceTyConBinder,@@ -77,8 +73,9 @@  import {-# SOURCE #-} GHC.Builtin.Types                                  ( coercibleTyCon, heqTyCon-                                 , liftedRepDataConTyCon, tupleTyConName-                                 , manyDataConTyCon, oneDataConTyCon )+                                 , tupleTyConName+                                 , manyDataConTyCon, oneDataConTyCon+                                 , liftedRepTyCon ) import {-# SOURCE #-} GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy )  import GHC.Core.TyCon hiding ( pprPromotionQuote )@@ -91,6 +88,8 @@ import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Misc+import GHC.Utils.Panic+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isMetaTyVar, isTyConableTyVar )  import Data.Maybe( isJust ) import qualified Data.Semigroup as Semi@@ -154,7 +153,7 @@ -- | A kind of universal type, used for types and kinds. -- -- Any time a 'Type' is pretty-printed, it is first converted to an 'IfaceType'--- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Core.Ppr.TyThing"+-- before being printed. See Note [Pretty printing via Iface syntax] in "GHC.Types.TyThing.Ppr" data IfaceType   = IfaceFreeTyVar TyVar                -- See Note [Free tyvars in IfaceType]   | IfaceTyVar     IfLclName            -- Type/coercion variable only, not tycon@@ -175,6 +174,11 @@        PromotionFlag                 -- A bit like IfaceTyCon        IfaceAppArgs               -- arity = length args           -- For promoted data cons, the kind args are omitted+          -- Why have this? Only for efficiency: IfaceTupleTy can omit the+          -- type arguments, as they can be recreated when deserializing.+          -- In an experiment, removing IfaceTupleTy resulted in a 0.75% regression+          -- in interface file size (in GHC's boot libraries).+          -- See !3987.  type IfaceMult = IfaceType @@ -184,6 +188,7 @@ data IfaceTyLit   = IfaceNumTyLit Integer   | IfaceStrTyLit FastString+  | IfaceCharTyLit Char   deriving (Eq)  type IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis@@ -274,7 +279,7 @@ Nowadays (since Nov 16, 2016) we pretty-print a Type by converting to an IfaceType and pretty printing that.  This eliminates a lot of pretty-print duplication, and it matches what we do with pretty--printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Core.Ppr.TyThing.+printing TyThings. See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr.  It works fine for closed types, but when printing debug traces (e.g. when using -ddump-tc-trace) we print a lot of /open/ types.  These@@ -353,6 +358,13 @@                    , ifaceTyConSort       :: IfaceTyConSort }     deriving (Eq) +-- This smart constructor allows sharing of the two most common+-- cases. See #19194+mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo+mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = IfaceTyConInfo IsPromoted  IfaceNormalTyCon+mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon+mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom        sort+ data IfaceMCoercion   = IfaceMRefl   | IfaceMCo IfaceCoercion@@ -407,16 +419,36 @@ ifaceTyConHasKey :: IfaceTyCon -> Unique -> Bool ifaceTyConHasKey tc key = ifaceTyConName tc `hasKey` key +-- | Given a kind K, is K of the form (TYPE ('BoxedRep 'LiftedRep))? isIfaceLiftedTypeKind :: IfaceKind -> Bool isIfaceLiftedTypeKind (IfaceTyConApp tc IA_Nil)   = isLiftedTypeKindTyConName (ifaceTyConName tc)-isIfaceLiftedTypeKind (IfaceTyConApp tc-                       (IA_Arg (IfaceTyConApp ptr_rep_lifted IA_Nil)-                               Required IA_Nil))-  =  tc `ifaceTyConHasKey` tYPETyConKey-  && ptr_rep_lifted `ifaceTyConHasKey` liftedRepDataConKey+isIfaceLiftedTypeKind (IfaceTyConApp tc1 args1)+  = isIfaceTyConAppLiftedTypeKind tc1 args1 isIfaceLiftedTypeKind _ = False +-- | Given a kind constructor K and arguments A, returns true if+-- both of the following statements are true:+--+-- * K is TYPE+-- * A is a singleton IfaceAppArgs of the form ('BoxedRep 'Lifted)+--+-- For the second condition, we must also check for the type+-- synonym LiftedRep.+isIfaceTyConAppLiftedTypeKind :: IfaceTyCon -> IfaceAppArgs -> Bool+isIfaceTyConAppLiftedTypeKind tc1 args1+  | tc1 `ifaceTyConHasKey` tYPETyConKey+  , IA_Arg soleArg1 Required IA_Nil <- args1+  , IfaceTyConApp rep args2 <- soleArg1 =+    if | rep `ifaceTyConHasKey` boxedRepDataConKey+       , IA_Arg soleArg2 Required IA_Nil <- args2+       , IfaceTyConApp lev IA_Nil <- soleArg2+       , lev `ifaceTyConHasKey` liftedDataConKey -> True+       | rep `ifaceTyConHasKey` liftedRepTyConKey+       , IA_Nil <- args2 -> True+       | otherwise -> False+  | otherwise = False+ splitIfaceSigmaTy :: IfaceType -> ([IfaceForAllBndr], [IfacePredType], IfaceType) -- Mainly for printing purposes --@@ -441,6 +473,7 @@     (theta, tau)   = split_rho rho      split_foralls (IfaceForAllTy bndr ty)+        | isInvisibleArgFlag (binderArgFlag bndr)         = case split_foralls ty of { (bndrs, rho) -> (bndr:bndrs, rho) }     split_foralls rho = ([], rho) @@ -448,6 +481,12 @@         = case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }     split_rho tau = ([], tau) +splitIfaceReqForallTy :: IfaceType -> ([IfaceForAllBndr], IfaceType)+splitIfaceReqForallTy (IfaceForAllTy bndr ty)+  | isVisibleArgFlag (binderArgFlag bndr)+  = case splitIfaceReqForallTy ty of { (bndrs, rho) -> (bndr:bndrs, rho) }+splitIfaceReqForallTy rho = ([], rho)+ suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a] suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs@@ -845,15 +884,15 @@                       return (IfaceTvBndr ab)  instance Binary IfaceOneShot where-    put_ bh IfaceNoOneShot = do+    put_ bh IfaceNoOneShot =             putByte bh 0-    put_ bh IfaceOneShot = do+    put_ bh IfaceOneShot =             putByte bh 1     get bh = do             h <- getByte bh             case h of-              0 -> do return IfaceNoOneShot-              _ -> do return IfaceOneShot+              0 -> return IfaceNoOneShot+              _ -> return IfaceOneShot  -- ----------------------------- Printing IfaceType ------------------------------------ @@ -968,18 +1007,25 @@  This applies to /quantified/ variables like 'w' above.  What about variables that are /free/ in the type being printed, which certainly-happens in error messages.  Suppose (#16074) we are reporting a-mismatch between two skolems+happens in error messages.  Suppose (#16074, #19361) we are reporting a+mismatch between skolems           (a :: RuntimeRep) ~ (b :: RuntimeRep)-We certainly don't want to say "Can't match LiftedRep ~ LiftedRep"!+        or+          (m :: Multiplicity) ~ Many+We certainly don't want to say "Can't match LiftedRep with LiftedRep" or+"Can't match Many with Many"!  But if we are printing the type-    (forall (a :: Type r). blah+    (forall (a :: TYPE r). blah) we do want to turn that (free) r into LiftedRep, so it prints as     (forall a. blah) -Conclusion: keep track of whether we are in the kind of a-binder; only if so, convert free RuntimeRep variables to LiftedRep.+We use isMetaTyVar to distinguish between those two situations:+metavariables are converted, skolem variables are not.++There's one exception though: TyVarTv metavariables should not be defaulted,+as they appear during kind-checking of "newtype T :: TYPE r where..."+(test T18357a). Therefore, we additionally test for isTyConableTyVar. -}  -- | Default 'RuntimeRep' variables to 'LiftedRep', and 'Multiplicity'@@ -1001,65 +1047,68 @@ -- type signatures (e.g. ($)). See Note [Defaulting RuntimeRep variables] -- and #11549 for further discussion. defaultNonStandardVars :: Bool -> Bool -> IfaceType -> IfaceType-defaultNonStandardVars do_runtimereps do_multiplicities ty = go False emptyFsEnv ty+defaultNonStandardVars do_runtimereps do_multiplicities ty = go emptyFsEnv ty   where-    go :: Bool              -- True <=> Inside the kind of a binder-       -> FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables+    go :: FastStringEnv IfaceType -- Set of enclosing forall-ed RuntimeRep/Multiplicity variables        -> IfaceType        -> IfaceType-    go ink subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)+    go subs (IfaceForAllTy (Bndr (IfaceTvBndr (var, var_kind)) argf) ty)      | isInvisibleArgFlag argf  -- Don't default *visible* quantification                                 -- or we get the mess in #13963      , Just substituted_ty <- check_substitution var_kind       = let subs' = extendFsEnv subs var substituted_ty             -- Record that we should replace it with LiftedRep,             -- and recurse, discarding the forall-        in go ink subs' ty+        in go subs' ty -    go ink subs (IfaceForAllTy bndr ty)-      = IfaceForAllTy (go_ifacebndr subs bndr) (go ink subs ty)+    go subs (IfaceForAllTy bndr ty)+      = IfaceForAllTy (go_ifacebndr subs bndr) (go subs ty) -    go _ subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of+    go subs ty@(IfaceTyVar tv) = case lookupFsEnv subs tv of       Just s -> s       Nothing -> ty -    go in_kind _ ty@(IfaceFreeTyVar tv)+    go _ ty@(IfaceFreeTyVar tv)       -- See Note [Defaulting RuntimeRep variables], about free vars-      | in_kind && do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)+      | do_runtimereps && GHC.Core.Type.isRuntimeRepTy (tyVarKind tv)+      , isMetaTyVar tv+      , isTyConableTyVar tv       = liftedRep_ty       | do_multiplicities && GHC.Core.Type.isMultiplicityTy (tyVarKind tv)+      , isMetaTyVar tv+      , isTyConableTyVar tv       = many_ty       | otherwise       = ty -    go ink subs (IfaceTyConApp tc tc_args)-      = IfaceTyConApp tc (go_args ink subs tc_args)+    go subs (IfaceTyConApp tc tc_args)+      = IfaceTyConApp tc (go_args subs tc_args) -    go ink subs (IfaceTupleTy sort is_prom tc_args)-      = IfaceTupleTy sort is_prom (go_args ink subs tc_args)+    go subs (IfaceTupleTy sort is_prom tc_args)+      = IfaceTupleTy sort is_prom (go_args subs tc_args) -    go ink subs (IfaceFunTy af w arg res)-      = IfaceFunTy af (go ink subs w) (go ink subs arg) (go ink subs res)+    go subs (IfaceFunTy af w arg res)+      = IfaceFunTy af (go subs w) (go subs arg) (go subs res) -    go ink subs (IfaceAppTy t ts)-      = IfaceAppTy (go ink subs t) (go_args ink subs ts)+    go subs (IfaceAppTy t ts)+      = IfaceAppTy (go subs t) (go_args subs ts) -    go ink subs (IfaceCastTy x co)-      = IfaceCastTy (go ink subs x) co+    go subs (IfaceCastTy x co)+      = IfaceCastTy (go subs x) co -    go _ _ ty@(IfaceLitTy {}) = ty-    go _ _ ty@(IfaceCoercionTy {}) = ty+    go _ ty@(IfaceLitTy {}) = ty+    go _ ty@(IfaceCoercionTy {}) = ty      go_ifacebndr :: FastStringEnv IfaceType -> IfaceForAllBndr -> IfaceForAllBndr     go_ifacebndr subs (Bndr (IfaceIdBndr (w, n, t)) argf)-      = Bndr (IfaceIdBndr (w, n, go True subs t)) argf+      = Bndr (IfaceIdBndr (w, n, go subs t)) argf     go_ifacebndr subs (Bndr (IfaceTvBndr (n, t)) argf)-      = Bndr (IfaceTvBndr (n, go True subs t)) argf+      = Bndr (IfaceTvBndr (n, go subs t)) argf -    go_args :: Bool -> FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs-    go_args _ _ IA_Nil = IA_Nil-    go_args ink subs (IA_Arg ty argf args)-      = IA_Arg (go ink subs ty) argf (go_args ink subs args)+    go_args :: FastStringEnv IfaceType -> IfaceAppArgs -> IfaceAppArgs+    go_args _ IA_Nil = IA_Nil+    go_args subs (IA_Arg ty argf args)+      = IA_Arg (go subs ty) argf (go_args subs args)      check_substitution :: IfaceType -> Maybe IfaceType     check_substitution (IfaceTyConApp tc _)@@ -1067,15 +1116,18 @@         | do_multiplicities, tc `ifaceTyConHasKey` multiplicityTyConKey = Just many_ty     check_substitution _ = Nothing +-- | The type ('BoxedRep 'Lifted), also known as LiftedRep. liftedRep_ty :: IfaceType liftedRep_ty =-    IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon))-                  IA_Nil-  where dc_name = getName liftedRepDataConTyCon+  IfaceTyConApp liftedRep IA_Nil+  where+    liftedRep :: IfaceTyCon+    liftedRep = IfaceTyCon tc_name (mkIfaceTyConInfo NotPromoted IfaceNormalTyCon)+      where tc_name = getName liftedRepTyCon  many_ty :: IfaceType many_ty =-    IfaceTyConApp (IfaceTyCon dc_name (IfaceTyConInfo IsPromoted IfaceNormalTyCon))+    IfaceTyConApp (IfaceTyCon dc_name (mkIfaceTyConInfo IsPromoted IfaceNormalTyCon))                   IA_Nil   where dc_name = getName manyDataConTyCon @@ -1200,8 +1252,23 @@   = hideNonStandardTypes ppr_fn ty   where     ppr_fn iface_ty =-      let (tvs, theta, tau) = splitIfaceSigmaTy iface_ty-       in ppr_iface_forall_part show_forall tvs theta (ppr tau)+      let (invis_tvs, theta, tau) = splitIfaceSigmaTy iface_ty+          (req_tvs, tau') = splitIfaceReqForallTy tau+          -- splitIfaceSigmaTy is recursive, so it will gather the binders after+          -- the theta, i.e.  forall a. theta => forall b. tau+          -- will give you    ([a,b], theta, tau).+          --+          -- This isn't right when it comes to visible forall (see+          --  testsuite/tests/polykinds/T18522-ppr),+          -- so we split off required binders separately,+          -- using splitIfaceReqForallTy.+          --+          -- An alternative solution would be to make splitIfaceSigmaTy+          -- non-recursive (see #18458).+          -- Then it could handle both invisible and required binders, and+          -- splitIfaceReqForallTy wouldn't be necessary here.+       in ppr_iface_forall_part show_forall invis_tvs theta $+          sep [pprIfaceForAll req_tvs, ppr tau']  pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc pprUserIfaceForAll tvs@@ -1380,9 +1447,7 @@        , isInvisibleArgFlag argf        -> pprIfaceTyList ctxt_prec ty1 ty2 -       | tc `ifaceTyConHasKey` tYPETyConKey-       , IA_Arg (IfaceTyConApp rep IA_Nil) Required IA_Nil <- tys-       , rep `ifaceTyConHasKey` liftedRepDataConKey+       | isIfaceTyConAppLiftedTypeKind tc tys        , print_type_abbreviations  -- See Note [Printing type abbreviations]        -> ppr_kind_type ctxt_prec @@ -1390,8 +1455,10 @@        , IA_Arg (IfaceTyConApp rep IA_Nil) Required args <- tys        , rep `ifaceTyConHasKey` manyDataConKey        , print_type_abbreviations  -- See Note [Printing type abbreviations]-       -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_ty appPrec) $-          appArgsIfaceTypes $ stripInvisArgs (PrintExplicitKinds print_kinds) args)+       -> pprIfacePrefixApp ctxt_prec (parens arrow) (map (ppr_app_arg appPrec) $+          appArgsIfaceTypesArgFlags $ stripInvisArgs (PrintExplicitKinds print_kinds) args)+          -- Use appArgsIfaceTypesArgFlags to print invisible arguments+          -- correctly (#19310)         | tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey        , not debug@@ -1582,7 +1649,7 @@         -- `Solo x`, not `(x)`       | [_] <- args_wo_runtime_reps       , BoxedTuple <- sort-      = let unit_tc_info = IfaceTyConInfo promoted IfaceNormalTyCon+      = let unit_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon             unit_tc = IfaceTyCon (tupleTyConName sort 1) unit_tc_info in         pprPrecIfaceType ctxt_prec $ IfaceTyConApp unit_tc args       | otherwise@@ -1591,6 +1658,7 @@ pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n)+pprIfaceTyLit (IfaceCharTyLit c) = text (show c)  pprIfaceCoercion, pprParendIfaceCoercion :: IfaceCoercion -> SDoc pprIfaceCoercion = ppr_co topPrec@@ -1653,8 +1721,11 @@ ppr_co ctxt_prec (IfaceSymCo co)   = ppr_special_co ctxt_prec (text "Sym") [co] ppr_co ctxt_prec (IfaceTransCo co1 co2)-  = maybeParen ctxt_prec opPrec $-    ppr_co opPrec co1 <+> semi <+> ppr_co opPrec co2+    -- chain nested TransCo+  = let ppr_trans (IfaceTransCo c1 c2) = semi <+> ppr_co topPrec c1 : ppr_trans c2+        ppr_trans c                    = [semi <+> ppr_co opPrec c]+    in maybeParen ctxt_prec opPrec $+        vcat (ppr_co topPrec co1 : ppr_trans co2) ppr_co ctxt_prec (IfaceNthCo d co)   = ppr_special_co ctxt_prec (text "Nth:" <> int d) [co] ppr_co ctxt_prec (IfaceLRCo lr co)@@ -1729,14 +1800,15 @@ instance Binary IfaceTyConInfo where    put_ bh (IfaceTyConInfo i s) = put_ bh i >> put_ bh s -   get bh = IfaceTyConInfo <$> get bh <*> get bh+   get bh = mkIfaceTyConInfo <$> get bh <*> get bh  instance Outputable IfaceTyLit where   ppr = pprIfaceTyLit  instance Binary IfaceTyLit where-  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n-  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n+  put_ bh (IfaceNumTyLit n)   = putByte bh 1 >> put_ bh n+  put_ bh (IfaceStrTyLit n)   = putByte bh 2 >> put_ bh n+  put_ bh (IfaceCharTyLit n)  = putByte bh 3 >> put_ bh n    get bh =     do tag <- getByte bh@@ -1745,6 +1817,8 @@                  ; return (IfaceNumTyLit n) }          2 -> do { n <- get bh                  ; return (IfaceStrTyLit n) }+         3 -> do { n <- get bh+                 ; return (IfaceCharTyLit n) }          _ -> panic ("get IfaceTyLit " ++ show tag)  instance Binary IfaceAppArgs where@@ -1877,7 +1951,7 @@                        return (IfaceLitTy n)  instance Binary IfaceMCoercion where-  put_ bh IfaceMRefl = do+  put_ bh IfaceMRefl =           putByte bh 1   put_ bh (IfaceMCo co) = do           putByte bh 2@@ -2077,6 +2151,7 @@   rnf = \case     IfaceNumTyLit f1 -> rnf f1     IfaceStrTyLit f1 -> rnf f1+    IfaceCharTyLit f1 -> rnf f1  instance NFData IfaceCoercion where   rnf = \case

+ GHC/Iface/UpdateIdInfos.hs view

@@ -0,0 +1,160 @@+{-# LANGUAGE CPP, BangPatterns, Strict, RecordWildCards #-}++module GHC.Iface.UpdateIdInfos+  ( updateModDetailsIdInfos+  ) where++import GHC.Prelude++import GHC.Core+import GHC.Core.InstEnv++import GHC.StgToCmm.Types (CgInfos (..))++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Var+import GHC.Types.TypeEnv+import GHC.Types.TyThing++import GHC.Unit.Module.ModDetails++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++#include "HsVersions.h"++-- | Update CafInfos and LFInfos of all occurrences (in rules, unfoldings, class+-- instances).+--+-- See Note [Conveying CAF-info and LFInfo between modules] in+-- GHC.StgToCmm.Types.+updateModDetailsIdInfos+  :: CgInfos+  -> ModDetails -- ^ ModDetails to update+  -> ModDetails++updateModDetailsIdInfos cg_infos mod_details =+  let+    ModDetails{ md_types = type_env -- for unfoldings+              , md_insts = insts+              , md_rules = rules+              } = mod_details++    -- type TypeEnv = NameEnv TyThing+    type_env' = mapNameEnv (updateTyThingIdInfos type_env' cg_infos) type_env+    -- NB: Knot-tied! The result, type_env', is passed right back into into+    -- updateTyThingIdInfos, so that that occurrences of any Ids (e.g. in+    -- IdInfos, etc) can be looked up in the tidied env++    !insts' = strictMap (updateInstIdInfos type_env' cg_infos) insts+    !rules' = strictMap (updateRuleIdInfos type_env') rules+  in+    mod_details{ md_types = type_env'+               , md_insts = insts'+               , md_rules = rules'+               }++--------------------------------------------------------------------------------+-- Rules+--------------------------------------------------------------------------------++updateRuleIdInfos :: TypeEnv -> CoreRule -> CoreRule+updateRuleIdInfos _ rule@BuiltinRule{} = rule+updateRuleIdInfos type_env Rule{ .. } = Rule { ru_rhs = updateGlobalIds type_env ru_rhs, .. }++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++updateInstIdInfos :: TypeEnv -> CgInfos -> ClsInst -> ClsInst+updateInstIdInfos type_env cg_infos =+    updateClsInstDFun (updateIdUnfolding type_env . updateIdInfo cg_infos)++--------------------------------------------------------------------------------+-- TyThings+--------------------------------------------------------------------------------++updateTyThingIdInfos :: TypeEnv -> CgInfos -> TyThing -> TyThing++updateTyThingIdInfos type_env cg_infos (AnId id) =+    AnId (updateIdUnfolding type_env (updateIdInfo cg_infos id))++updateTyThingIdInfos _ _ other = other -- AConLike, ATyCon, ACoAxiom++--------------------------------------------------------------------------------+-- Unfoldings+--------------------------------------------------------------------------------++updateIdUnfolding :: TypeEnv -> Id -> Id+updateIdUnfolding type_env id =+    case idUnfolding id of+      CoreUnfolding{ .. } ->+        setIdUnfolding id CoreUnfolding{ uf_tmpl = updateGlobalIds type_env uf_tmpl, .. }+      DFunUnfolding{ .. } ->+        setIdUnfolding id DFunUnfolding{ df_args = map (updateGlobalIds type_env) df_args, .. }+      _ -> id++--------------------------------------------------------------------------------+-- Expressions+--------------------------------------------------------------------------------++updateIdInfo :: CgInfos -> Id -> Id+updateIdInfo CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos } id =+    let+      not_caffy = elemNameSet (idName id) non_cafs+      mb_lf_info = lookupNameEnv lf_infos (idName id)++      id1 = if not_caffy then setIdCafInfo id NoCafRefs else id+      id2 = case mb_lf_info of+              Nothing -> id1+              Just lf_info -> setIdLFInfo id1 lf_info+    in+      id2++--------------------------------------------------------------------------------++updateGlobalIds :: NameEnv TyThing -> CoreExpr -> CoreExpr+-- Update occurrences of GlobalIds as directed by 'env'+-- The 'env' maps a GlobalId to a version with accurate CAF info+-- (and in due course perhaps other back-end-related info)+updateGlobalIds env e = go env e+  where+    go_id :: NameEnv TyThing -> Id -> Id+    go_id env var =+      case lookupNameEnv env (varName var) of+        Nothing -> var+        Just (AnId id) -> id+        Just other -> pprPanic "UpdateIdInfos.updateGlobalIds" $+          text "Found a non-Id for Id Name" <+> ppr (varName var) $$+          nest 4 (text "Id:" <+> ppr var $$+                  text "TyThing:" <+> ppr other)++    go :: NameEnv TyThing -> CoreExpr -> CoreExpr+    go env (Var v) = Var (go_id env v)+    go _ e@Lit{} = e+    go env (App e1 e2) = App (go env e1) (go env e2)+    go env (Lam b e) = assertNotInNameEnv env [b] (Lam b (go env e))+    go env (Let bs e) = Let (go_binds env bs) (go env e)+    go env (Case e b ty alts) =+        assertNotInNameEnv env [b] (Case (go env e) b ty (map go_alt alts))+      where+         go_alt (Alt k bs e) = assertNotInNameEnv env bs (Alt k bs (go env e))+    go env (Cast e c) = Cast (go env e) c+    go env (Tick t e) = Tick t (go env e)+    go _ e@Type{} = e+    go _ e@Coercion{} = e++    go_binds :: NameEnv TyThing -> CoreBind -> CoreBind+    go_binds env (NonRec b e) =+      assertNotInNameEnv env [b] (NonRec b (go env e))+    go_binds env (Rec prs) =+      assertNotInNameEnv env (map fst prs) (Rec (mapSnd (go env) prs))++-- In `updateGlobaLIds` Names of local binders should not shadow Name of+-- globals. This assertion is to check that.+assertNotInNameEnv :: NameEnv a -> [Id] -> b -> b+assertNotInNameEnv env ids x = ASSERT(not (any (\id -> elemNameEnv (idName id) env) ids)) x

GHC/IfaceToCore.hs view

@@ -16,8 +16,9 @@         importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,         typecheckIfacesForMerging,         typecheckIfaceForInstantiate,-        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,-        tcIfaceAnnotations, tcIfaceCompleteSigs,+        tcIfaceDecl, tcIfaceDecls,+        tcIfaceInst, tcIfaceFamInst, tcIfaceRules,+        tcIfaceAnnotations, tcIfaceCompleteMatches,         tcIfaceExpr,    -- Desired by HERMIT (#7683)         tcIfaceGlobal,         tcIfaceOneShot@@ -27,60 +28,86 @@  import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.Builtin.Types.Literals(typeNatCoAxiomRules)+import GHC.Builtin.Types+ import GHC.Iface.Syntax import GHC.Iface.Load import GHC.Iface.Env+ import GHC.StgToCmm.Types+ import GHC.Tc.TyCl.Build import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType+ import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.Coercion.Axiom import GHC.Core.FVs import GHC.Core.TyCo.Rep    -- needs to build types & coercions in a knot import GHC.Core.TyCo.Subst ( substTyCoVars )-import GHC.Driver.Types-import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv import GHC.Core+import GHC.Core.Unify( RoughMatchTc(..) ) 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-import GHC.Types.Id.Make-import GHC.Types.Id.Info import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Builtin.Types-import GHC.Types.Literal-import GHC.Types.Var as Var-import GHC.Types.Var.Set-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.Ppr++import GHC.Unit.External import GHC.Unit.Module-import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo+ import GHC.Utils.Outputable-import GHC.Data.Maybe-import GHC.Types.SrcLoc-import GHC.Driver.Session import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Logger++import GHC.Data.Bag+import GHC.Data.Maybe import GHC.Data.FastString-import GHC.Types.Basic hiding ( SuccessFlag(..) ) import GHC.Data.List.SetOps++import GHC.Types.Annotations+import GHC.Types.SourceFile+import GHC.Types.SourceText+import GHC.Types.Basic hiding ( SuccessFlag(..) )+import GHC.Types.CompleteMatch+import GHC.Types.SrcLoc+import GHC.Types.TypeEnv+import GHC.Types.Unique.FM+import GHC.Types.Unique.DSet ( mkUniqDSet )+import GHC.Types.Unique.Supply+import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Id+import GHC.Types.Id.Make+import GHC.Types.Id.Info+import GHC.Types.Tickish+import GHC.Types.TyThing+ import GHC.Fingerprint import qualified GHC.Data.BooleanFormula as BF  import Control.Monad-import qualified Data.Map as Map+import GHC.Parser.Annotation  {- This module takes@@ -166,7 +193,7 @@                 -- Typecheck the decls.  This is done lazily, so that the knot-tying                 -- within this single module works out right.  It's the callers                 -- job to make sure the knot is tied.-        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)+        ; names_w_things <- tcIfaceDecls ignore_prags (mi_decls iface)         ; let type_env = mkNameEnv names_w_things                  -- Now do those rules, instances and annotations@@ -179,7 +206,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),@@ -193,7 +220,7 @@                               , md_rules     = rules                               , md_anns      = anns                               , md_exports   = exports-                              , md_complete_sigs = complete_sigs+                              , md_complete_matches = complete_matches                               }     } @@ -233,7 +260,7 @@                     (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])       in d1 { ifBody = (ifBody d1) {                 ifSigs  = ops,-                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]+                ifMinDef = BF.mkOr [noLocA bf1, noLocA bf2]                 }             } `withRolesFrom` d2     -- It doesn't matter; we'll check for consistency later when@@ -371,8 +398,8 @@                         :: [OccEnv IfaceDecl]         decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs                         ::  OccEnv IfaceDecl-    -- TODO: change loadDecls to accept w/o Fingerprint-    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))+    -- TODO: change tcIfaceDecls to accept w/o Fingerprint+    names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x))                                                   (occEnvElts decl_env))     let global_type_env = mkNameEnv names_w_things     writeMutVar tc_env_var global_type_env@@ -380,9 +407,9 @@     -- OK, now typecheck each ModIface using this environment     details <- forM ifaces $ \iface -> do         -- See Note [Resolving never-exported Names] in GHC.IfaceToCore-        type_env <- fixM $ \type_env -> do+        type_env <- fixM $ \type_env ->             setImplicitEnvM type_env $ do-                decls <- loadDecls ignore_prags (mi_decls iface)+                decls <- tcIfaceDecls ignore_prags (mi_decls iface)                 return (mkNameEnv decls)         -- But note that we use this type_env to typecheck references to DFun         -- in 'IfaceInst'@@ -392,14 +419,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) @@ -420,9 +447,9 @@                         (mi_boot iface) nsubst $ do     ignore_prags <- goptM Opt_IgnoreInterfacePragmas     -- See Note [Resolving never-exported Names] in GHC.IfaceToCore-    type_env <- fixM $ \type_env -> do+    type_env <- fixM $ \type_env ->         setImplicitEnvM type_env $ do-            decls     <- loadDecls ignore_prags (mi_decls iface)+            decls     <- tcIfaceDecls ignore_prags (mi_decls iface)             return (mkNameEnv decls)     -- See Note [rnIfaceNeverExported]     setImplicitEnvM type_env $ do@@ -431,14 +458,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]@@ -848,10 +875,114 @@        ; return $ AConLike . PatSynCon $ patsyn }}}   where      mk_doc n = text "Pattern synonym" <+> ppr n-     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)+     tc_pr :: (IfExtName, Bool) -> IfL (Name, Type, Bool)      tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)-                        ; return (id, b) }+                        ; return (nm, idType id, b) } +tcIfaceDecls :: Bool+          -> [(Fingerprint, IfaceDecl)]+          -> IfL [(Name,TyThing)]+tcIfaceDecls ignore_prags ver_decls+   = concatMapM (tc_iface_decl_fingerprint ignore_prags) ver_decls++tc_iface_decl_fingerprint :: Bool                    -- Don't load pragmas into the decl pool+          -> (Fingerprint, IfaceDecl)+          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the+                                    -- TyThings are forkM'd thunks+tc_iface_decl_fingerprint ignore_prags (_version, decl)+  = do  {       -- Populate the name cache with final versions of all+                -- the names associated with the decl+          let main_name = ifName decl++        -- Typecheck the thing, lazily+        -- NB. Firstly, the laziness is there in case we never need the+        -- declaration (in one-shot mode), and secondly it is there so that+        -- we don't look up the occurrence of a name before calling mk_new_bndr+        -- on the binder.  This is important because we must get the right name+        -- which includes its nameParent.++        ; thing <- forkM doc $ do { bumpDeclStats main_name+                                  ; tcIfaceDecl ignore_prags decl }++        -- Populate the type environment with the implicitTyThings too.+        --+        -- Note [Tricky iface loop]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~+        -- Summary: The delicate point here is that 'mini-env' must be+        -- buildable from 'thing' without demanding any of the things+        -- 'forkM'd by tcIfaceDecl.+        --+        -- In more detail: Consider the example+        --      data T a = MkT { x :: T a }+        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]+        -- (plus their workers, wrappers, coercions etc etc)+        --+        -- We want to return an environment+        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]+        -- (where the "MkT" is the *Name* associated with MkT, etc.)+        --+        -- We do this by mapping the implicit_names to the associated+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and+        -- implicitTyThings, we can use getOccName on the implicit+        -- TyThings to make this association: each Name's OccName should+        -- be the OccName of exactly one implicitTyThing.  So the key is+        -- to define a "mini-env"+        --+        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]+        -- where the 'MkT' here is the *OccName* associated with MkT.+        --+        -- However, there is a subtlety: due to how type checking needs+        -- to be staged, we can't poke on the forkM'd thunks inside the+        -- implicitTyThings while building this mini-env.+        -- If we poke these thunks too early, two problems could happen:+        --    (1) When processing mutually recursive modules across+        --        hs-boot boundaries, poking too early will do the+        --        type-checking before the recursive knot has been tied,+        --        so things will be type-checked in the wrong+        --        environment, and necessary variables won't be in+        --        scope.+        --+        --    (2) Looking up one OccName in the mini_env will cause+        --        others to be looked up, which might cause that+        --        original one to be looked up again, and hence loop.+        --+        -- The code below works because of the following invariant:+        -- getOccName on a TyThing does not force the suspended type+        -- checks in order to extract the name. For example, we don't+        -- poke on the "T a" type of <selector x> on the way to+        -- extracting <selector x>'s OccName. Of course, there is no+        -- reason in principle why getting the OccName should force the+        -- thunks, but this means we need to be careful in+        -- implicitTyThings and its helper functions.+        --+        -- All a bit too finely-balanced for my liking.++        -- This mini-env and lookup function mediates between the+        --'Name's n and the map from 'OccName's to the implicit TyThings+        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]+              lookup n = case lookupOccEnv mini_env (getOccName n) of+                           Just thing -> thing+                           Nothing    ->+                             pprPanic "tc_iface_decl_fingerprint" (ppr main_name <+> ppr n $$ ppr (decl))++        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)++--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)+        ; return $ (main_name, thing) :+                      -- uses the invariant that implicit_names and+                      -- implicitTyThings are bijective+                      [(n, lookup n) | n <- implicit_names]+        }+  where+    doc = text "Declaration for" <+> ppr (ifName decl)++bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used+bumpDeclStats name+  = do  { traceIf (text "Loading decl for" <+> ppr name)+        ; updateEps_ (\eps -> let stats = eps_stats eps+                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })+        }+ tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar) tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1                         ; tvs2' <- mapM tcIfaceTyVar tvs2@@ -1018,13 +1149,17 @@ ************************************************************************ -} +tcRoughTyCon :: Maybe IfaceTyCon -> RoughMatchTc+tcRoughTyCon (Just tc) = KnownTc (ifaceTyConName tc)+tcRoughTyCon Nothing   = OtherTc+ tcIfaceInst :: IfaceClsInst -> IfL ClsInst tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag                           , ifInstCls = cls, ifInstTys = mb_tcs                           , ifInstOrph = orph })   = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $                     fmap tyThingId (tcIfaceImplicit dfun_name)-       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs+       ; let mb_tcs' = map tcRoughTyCon mb_tcs        ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }  tcIfaceFamInst :: IfaceFamInst -> IfL FamInst@@ -1034,7 +1169,7 @@                      tcIfaceCoAxiom axiom_name              -- will panic if branched, but that's OK          ; let axiom'' = toUnbranchedAxiom axiom'-               mb_tcs' = map (fmap ifaceTyConName) mb_tcs+               mb_tcs' = map tcRoughTyCon mb_tcs          ; return (mkImportedFamInst fam mb_tcs' axiom'') }  {-@@ -1075,13 +1210,12 @@                                         bndrs' ++                                         exprsFreeIdsList args')                       ; case lintExpr dflags in_scope rhs' of-                          Nothing       -> return ()-                          Just fail_msg -> do { mod <- getIfModule-                                              ; pprPanic "Iface Lint failure"-                                                  (vcat [ text "In interface for" <+> ppr mod-                                                        , hang doc 2 fail_msg-                                                        , ppr name <+> equals <+> ppr rhs'-                                                        , text "Iface expr =" <+> ppr rhs ]) } }+                          Nothing   -> return ()+                          Just errs -> do+                            logger <- getLogger+                            liftIO $ displayLintResults logger dflags False doc+                                               (pprCoreExpr rhs')+                                               (emptyBag, errs) }                    ; return (bndrs', args', rhs') }         ; let mb_tcs = map ifTopFreeName args         ; this_mod <- getIfModule@@ -1132,10 +1266,9 @@     }  tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)-tcIfaceAnnTarget (NamedTarget occ) = do-    name <- lookupIfaceTop occ-    return $ NamedTarget name-tcIfaceAnnTarget (ModuleTarget mod) = do+tcIfaceAnnTarget (NamedTarget occ) =+    NamedTarget <$> lookupIfaceTop occ+tcIfaceAnnTarget (ModuleTarget mod) =     return $ ModuleTarget mod  {-@@ -1146,12 +1279,28 @@ ************************************************************************ -} -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 mtc) = forkM doc $ do -- See Note [Positioning of forkM]+  conlikes <- mkUniqDSet <$> mapM tcIfaceConLike ms+  mtc' <- traverse tcIfaceTyCon mtc+  return (CompleteMatch conlikes mtc')+  where+    doc = text "COMPLETE sig" <+> ppr ms +{- Note [Positioning of forkM]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be lazy when type checking the interface, since these functions are+called when the interface itself is being loaded, which means it is not in the+PIT yet. If we are not lazy enough, in certain cases we might recursively try to+load the same interface in an infinite loop.++For this reason, the forkM should be around as much of the computation as+possible.+-}+ {- ************************************************************************ *                                                                      *@@ -1203,10 +1352,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@@ -1222,6 +1370,7 @@ tcIfaceTyLit :: IfaceTyLit -> IfL TyLit tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n) tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)+tcIfaceTyLit (IfaceCharTyLit n) = return (CharTyLit n)  {- %************************************************************************@@ -1396,7 +1545,7 @@         return (Tick tickish' expr')  --------------------------tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)+tcIfaceTickish :: IfaceTickish -> IfM lcl CoreTickish tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix) tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push) tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)@@ -1407,30 +1556,30 @@  ------------------------- tcIfaceAlt :: CoreExpr -> Mult -> (TyCon, [Type])-           -> (IfaceConAlt, [FastString], IfaceExpr)-           -> IfL (AltCon, [TyVar], CoreExpr)-tcIfaceAlt _ _ _ (IfaceDefault, names, rhs)+           -> IfaceAlt+           -> IfL CoreAlt+tcIfaceAlt _ _ _ (IfaceAlt IfaceDefault names rhs)   = ASSERT( null names ) do     rhs' <- tcIfaceExpr rhs-    return (DEFAULT, [], rhs')+    return (Alt DEFAULT [] rhs') -tcIfaceAlt _ _ _ (IfaceLitAlt lit, names, rhs)+tcIfaceAlt _ _ _ (IfaceAlt (IfaceLitAlt lit) names rhs)   = ASSERT( null names ) do     lit' <- tcIfaceLit lit     rhs' <- tcIfaceExpr rhs-    return (LitAlt lit', [], rhs')+    return (Alt (LitAlt lit') [] rhs')  -- A case alternative is made quite a bit more complicated -- by the fact that we omit type annotations because we can -- work them out.  True enough, but its not that easy!-tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)+tcIfaceAlt scrut mult (tycon, inst_tys) (IfaceAlt (IfaceDataAlt data_occ) arg_strs rhs)   = do  { con <- tcIfaceDataCon data_occ         ; when (debugIsOn && not (con `elem` tyConDataCons tycon))                (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))         ; tcIfaceDataAlt mult con inst_tys arg_strs rhs }  tcIfaceDataAlt :: Mult -> DataCon -> [Type] -> [FastString] -> IfaceExpr-               -> IfL (AltCon, [TyVar], CoreExpr)+               -> IfL CoreAlt tcIfaceDataAlt mult con inst_tys arg_strs rhs   = do  { us <- newUniqueSupply         ; let uniqs = uniqsFromSupply us@@ -1440,7 +1589,7 @@         ; rhs' <- extendIfaceEnvs  ex_tvs       $                   extendIfaceIdEnv arg_ids      $                   tcIfaceExpr rhs-        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }+        ; return (Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs') }  {- ************************************************************************@@ -1544,13 +1693,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!@@ -1560,7 +1709,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@@ -1598,14 +1747,12 @@       whenGOptM Opt_DoCoreLinting $ do         in_scope <- get_in_scope         dflags   <- getDynFlags+        logger   <- getLogger         case lintUnfolding is_compulsory dflags noSrcLoc in_scope core_expr' of-          Nothing       -> return ()-          Just fail_msg -> do { mod <- getIfModule-                              ; pprPanic "Iface Lint failure"-                                  (vcat [ text "In interface for" <+> ppr mod-                                        , hang doc 2 fail_msg-                                        , ppr name <+> equals <+> ppr core_expr'-                                        , text "Iface expr =" <+> ppr expr ]) }+          Nothing   -> return ()+          Just errs -> liftIO $+            displayLintResults logger dflags False doc+                               (pprCoreExpr core_expr') (emptyBag, errs)     return core_expr'   where     doc = ppWhen is_compulsory (text "Compulsory") <+>@@ -1666,7 +1813,7 @@   where     via_external =  do         { hsc_env <- getTopEnv-        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; mb_thing <- liftIO (lookupType hsc_env name)         ; case mb_thing of {             Just thing -> return thing ;             Nothing    -> do@@ -1751,7 +1898,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) @@ -1759,7 +1906,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

GHC/IfaceToCore.hs-boot view

@@ -3,17 +3,20 @@ import GHC.Prelude import GHC.Iface.Syntax ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule                         , IfaceAnnotation, IfaceCompleteMatch )-import GHC.Core.TyCo.Rep   ( TyThing )+import GHC.Types.TyThing   ( TyThing ) import GHC.Tc.Types        ( IfL ) import GHC.Core.InstEnv    ( ClsInst ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core         ( CoreRule )-import GHC.Driver.Types ( CompleteMatch )+import GHC.Types.CompleteMatch import GHC.Types.Annotations ( Annotation )+import GHC.Types.Name+import GHC.Fingerprint.Type -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]+tcIfaceDecls           :: Bool -> [(Fingerprint, IfaceDecl)] -> IfL [(Name,TyThing)]

+ GHC/Linker.hs view

@@ -0,0 +1,36 @@+module GHC.Linker+   (+   )+where++import GHC.Prelude ()+   -- We need this dummy dependency for the make build system. Otherwise it+   -- tries to load GHC.Types which may not be built yet.++-- Note [Linkers and loaders]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Linkers are used to produce linked objects (.so, executables); loaders are+-- used to link in memory (e.g., in GHCi) with the already loaded libraries+-- (ghc-lib, rts, etc.).+--+-- Linking can usually be done with an external linker program ("ld"), but+-- loading is more tricky:+--+--    * Fully dynamic:+--       when GHC is built as a set of dynamic libraries (ghc-lib, rts, etc.)+--       and the modules to load are also compiled for dynamic linking, a+--       solution is to fully rely on external tools:+--+--       1) link a .so with the external linker+--       2) load the .so with POSIX's "dlopen"+--+--    * When GHC is built as a static program or when libraries we want to load+--    aren't compiled for dynamic linking, GHC uses its own loader ("runtime+--    linker"). The runtime linker is part of the rts (rts/Linker.c).+--+-- Note that within GHC's codebase we often use the word "linker" to refer to+-- the static object loader in the runtime system.+--+-- Loading can be delegated to an external interpreter ("iserv") when+-- -fexternal-interpreter is used.

+ GHC/Linker/Dynamic.hs view

@@ -0,0 +1,260 @@+{-# LANGUAGE CPP #-}++-- | Dynamic linker+module GHC.Linker.Dynamic+   ( linkDynLib+   -- * Platform-specifics+   , libmLinkOpts+   )+where++#include "HsVersions.h"++import GHC.Prelude+import GHC.Platform+import GHC.Platform.Ways++import GHC.Driver.Session++import GHC.Unit.Env+import GHC.Unit.Types+import GHC.Unit.State+import GHC.Linker.MacOS+import GHC.Linker.Unit+import GHC.SysTools.Tasks+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import qualified Data.Set as Set+import System.FilePath++linkDynLib :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()+linkDynLib logger tmpfs dflags0 unit_env o_files dep_packages+ = do+    let platform   = ue_platform unit_env+        os         = platformOS platform++        -- This is a rather ugly hack to fix dynamically linked+        -- GHC on Windows. If GHC is linked with -threaded, then+        -- it links against libHSrts_thr. But if base is linked+        -- against libHSrts, then both end up getting loaded,+        -- and things go wrong. We therefore link the libraries+        -- with the same RTS flags that we link GHC with.+        dflags | OSMinGW32 <- os+               , hostWays `hasWay` WayDyn+               = dflags0 { targetWays_ = hostWays }+               | otherwise+               = dflags0++        verbFlags = getVerbFlags dflags+        o_file = outputFile dflags++    pkgs_with_rts <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)++    let pkg_lib_paths = collectLibraryDirs (ways dflags) pkgs_with_rts+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths+        get_pkg_lib_path_opts l+         | osElfTarget os || osMachOTarget os+         , dynLibLoader dflags == SystemDependent+         , -- Only if we want dynamic libraries+           WayDyn `Set.member` ways dflags+           -- Only use RPath if we explicitly asked for it+         , useXLinkerRPath dflags os+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]+         | otherwise = ["-L" ++ l]++    let lib_paths = libraryPaths dflags+    let lib_path_opts = map ("-L"++) lib_paths++    -- In general we don't want to link our dynamic libs against the RTS+    -- package, because the RTS lib comes in several flavours and we want to be+    -- able to pick the flavour when a binary is linked.+    --+    -- But:+    --   * on Windows we need to link the RTS import lib as Windows does not+    --   allow undefined symbols.+    --+    --   * the RTS library path is still added to the library search path above+    --   in case the RTS is being explicitly linked in (see #3807).+    --+    --   * if -flink-rts is used, we link with the rts.+    --+    let pkgs_without_rts = filter ((/= rtsUnitId) . unitId) pkgs_with_rts+        pkgs+         | OSMinGW32 <- os         = pkgs_with_rts+         | gopt Opt_LinkRts dflags = pkgs_with_rts+         | otherwise               = pkgs_without_rts+        pkg_link_opts = package_hs_libs ++ extra_libs ++ other_flags+          where (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs++        -- probably _stub.o files+        -- and last temporary shared object file+    let extra_ld_inputs = ldInputs dflags++    -- frameworks+    pkg_framework_opts <- getUnitFrameworkOpts unit_env (map unitId pkgs)+    let framework_opts = getFrameworkOpts dflags platform++    case os of+        OSMinGW32 -> do+            -------------------------------------------------------------+            -- Making a DLL+            -------------------------------------------------------------+            let output_fn = case o_file of+                            Just s -> s+                            Nothing -> "HSdll.dll"++            runLink logger tmpfs dflags (+                    map Option verbFlags+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    , Option "-shared"+                    ] +++                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")+                    | gopt Opt_SharedImplib dflags+                    ]+                 ++ map (FileOption "") o_files++                 -- Permit the linker to auto link _symbol to _imp_symbol+                 -- This lets us link against DLLs without needing an "import library"+                 ++ [Option "-Wl,--enable-auto-import"]++                 ++ extra_ld_inputs+                 ++ map Option (+                    lib_path_opts+                 ++ pkg_lib_path_opts+                 ++ pkg_link_opts+                ))+        _ | os == OSDarwin -> do+            -------------------------------------------------------------------+            -- Making a darwin dylib+            -------------------------------------------------------------------+            -- About the options used for Darwin:+            -- -dynamiclib+            --   Apple's way of saying -shared+            -- -undefined dynamic_lookup:+            --   Without these options, we'd have to specify the correct+            --   dependencies for each of the dylibs. Note that we could+            --   (and should) do without this for all libraries except+            --   the RTS; all we need to do is to pass the correct+            --   HSfoo_dyn.dylib files to the link command.+            --   This feature requires Mac OS X 10.3 or later; there is+            --   a similar feature, -flat_namespace -undefined suppress,+            --   which works on earlier versions, but it has other+            --   disadvantages.+            -- -single_module+            --   Build the dynamic library as a single "module", i.e. no+            --   dynamic binding nonsense when referring to symbols from+            --   within the library. The NCG assumes that this option is+            --   specified (on i386, at least).+            -- -install_name+            --   Mac OS/X stores the path where a dynamic library is (to+            --   be) installed in the library itself.  It's called the+            --   "install name" of the library. Then any library or+            --   executable that links against it before it's installed+            --   will search for it in its ultimate install location.+            --   By default we set the install name to the absolute path+            --   at build time, but it can be overridden by the+            --   -dylib-install-name option passed to ghc. Cabal does+            --   this.+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }++            instName <- case dylibInstallName dflags of+                Just n -> return n+                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)+            runLink logger tmpfs dflags (+                    map Option verbFlags+                 ++ [ Option "-dynamiclib"+                    , Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-undefined",+                      Option "dynamic_lookup",+                      Option "-single_module" ]+                 ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]+                     then [ ]+                     else [ Option "-Wl,-read_only_relocs,suppress" ])+                 ++ [ Option "-install_name", Option instName ]+                 ++ map Option lib_path_opts+                 ++ extra_ld_inputs+                 ++ map Option framework_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+                 ++ map Option pkg_framework_opts+                 -- 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 logger dflags pkg_lib_paths output_fn+        _ -> do+            -------------------------------------------------------------------+            -- Making a DSO+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }+                unregisterised = platformUnregisterised (targetPlatform dflags)+            let bsymbolicFlag = -- we need symbolic linking to resolve+                                -- non-PIC intra-package-relocations for+                                -- performance (where symbolic linking works)+                                -- See Note [-Bsymbolic assumptions by GHC]+                                ["-Wl,-Bsymbolic" | not unregisterised]++            runLink logger tmpfs dflags (+                    map Option verbFlags+                 ++ libmLinkOpts+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-shared" ]+                 ++ map Option bsymbolicFlag+                    -- Set the library soname. We use -h rather than -soname as+                    -- Solaris 10 doesn't support the latter:+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]+                 ++ extra_ld_inputs+                 ++ map Option lib_path_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+              )++-- | Some platforms require that we explicitly link against @libm@ if any+-- math-y things are used (which we assume to include all programs). See #14022.+libmLinkOpts :: [Option]+libmLinkOpts =+#if defined(HAVE_LIBM)+  [Option "-lm"]+#else+  []+#endif++{-+Note [-Bsymbolic assumptions by GHC]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GHC has a few assumptions about interaction of relocations in NCG and linker:++1. -Bsymbolic resolves internal references when the shared library is linked,+   which is important for performance.+2. When there is a reference to data in a shared library from the main program,+   the runtime linker relocates the data object into the main program using an+   R_*_COPY relocation.+3. If we used -Bsymbolic, then this results in multiple copies of the data+   object, because some references have already been resolved to point to the+   original instance. This is bad!++We work around [3.] for native compiled code by avoiding the generation of+R_*_COPY relocations.++Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable+-Bsymbolic linking there.++See related tickets: #4210, #15338+-}

+ GHC/Linker/ExtraObj.hs view

@@ -0,0 +1,270 @@+-----------------------------------------------------------------------------+--+-- GHC Extra object linking code+--+-- (c) The GHC Team 2017+--+-----------------------------------------------------------------------------++module GHC.Linker.ExtraObj+   ( mkExtraObj+   , mkExtraObjToLinkIntoBinary+   , mkNoteObjsToLinkIntoBinary+   , checkLinkInfo+   , getLinkInfo+   , getCompilerInfo+   , ghcLinkInfoSectionName+   , ghcLinkInfoNoteName+   , platformSupportsSavingLinkOpts+   , haveRtsOptsFlags+   )+where++import GHC.Prelude+import GHC.Platform++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.State++import GHC.Utils.Asm+import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Driver.Session+import GHC.Driver.Ppr++import qualified GHC.Data.ShortText as ST++import GHC.SysTools.Elf+import GHC.SysTools.Tasks+import GHC.SysTools.Info+import GHC.Linker.Unit++import Control.Monad.IO.Class+import Control.Monad+import Data.Maybe++mkExtraObj :: Logger -> TmpFs -> DynFlags -> UnitState -> Suffix -> String -> IO FilePath+mkExtraObj logger tmpfs dflags unit_state extn xs+ = do cFile <- newTempName logger tmpfs dflags TFL_CurrentModule extn+      oFile <- newTempName logger tmpfs dflags TFL_GhcSession "o"+      writeFile cFile xs+      ccInfo <- liftIO $ getCompilerInfo logger dflags+      runCc Nothing logger tmpfs dflags+            ([Option        "-c",+              FileOption "" cFile,+              Option        "-o",+              FileOption "" oFile]+              ++ if extn /= "s"+                    then cOpts+                    else asmOpts ccInfo)+      return oFile+    where+      -- Pass a different set of options to the C compiler depending one whether+      -- we're compiling C or assembler. When compiling C, we pass the usual+      -- set of include directories and PIC flags.+      cOpts = map Option (picCCOpts dflags)+                    ++ map (FileOption "-I" . ST.unpack)+                            (unitIncludeDirs $ unsafeLookupUnit unit_state rtsUnit)++      -- When compiling assembler code, we drop the usual C options, and if the+      -- compiler is Clang, we add an extra argument to tell Clang to ignore+      -- unused command line options. See trac #11684.+      asmOpts ccInfo =+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                then [Option "-Qunused-arguments"]+                else []++-- When linking a binary, we need to create a C main() function that+-- starts everything off.  This used to be compiled statically as part+-- of the RTS, but that made it hard to change the -rtsopts setting,+-- so now we generate and compile a main() stub as part of every+-- binary and pass the -rtsopts setting directly to the RTS (#5373)+--+-- On Windows, when making a shared library we also may need a DllMain.+--+mkExtraObjToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitState -> IO (Maybe FilePath)+mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state = do+  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $+     logInfo logger dflags $ withPprStyle defaultUserStyle+         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$+          text "    Call hs_init_ghc() from your main() function to set these options.")++  case ghcLink dflags of+    -- Don't try to build the extra object if it is not needed.  Compiling the+    -- extra object assumes the presence of the RTS in the unit database+    -- (because the extra object imports Rts.h) but GHC's build system may try+    -- to build some helper programs before building and registering the RTS!+    -- See #18938 for an example where hp2ps failed to build because of a failed+    -- (unsafe) lookup for the RTS in the unit db.+    _ | gopt Opt_NoHsMain dflags+      -> return Nothing++    LinkDynLib+      | OSMinGW32 <- platformOS (targetPlatform dflags)+      -> mk_extra_obj dllMain++      | otherwise+      -> return Nothing++    _ -> mk_extra_obj exeMain++  where+    mk_extra_obj = fmap Just . mkExtraObj logger tmpfs dflags unit_state "c" . showSDoc dflags++    exeMain = vcat [+        text "#include <Rts.h>",+        text "extern StgClosure ZCMain_main_closure;",+        text "int main(int argc, char *argv[])",+        char '{',+        text " RtsConfig __conf = defaultRtsConfig;",+        text " __conf.rts_opts_enabled = "+            <> text (show (rtsOptsEnabled dflags)) <> semi,+        text " __conf.rts_opts_suggestions = "+            <> text (if rtsOptsSuggestions dflags+                        then "true"+                        else "false") <> semi,+        text "__conf.keep_cafs = "+            <> text (if gopt Opt_KeepCAFs dflags+                       then "true"+                       else "false") <> semi,+        case rtsOpts dflags of+            Nothing   -> Outputable.empty+            Just opts -> text "    __conf.rts_opts= " <>+                          text (show opts) <> semi,+        text " __conf.rts_hs_main = true;",+        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",+        char '}',+        char '\n' -- final newline, to keep gcc happy+        ]++    dllMain = vcat [+        text "#include <Rts.h>",+        text "#include <windows.h>",+        text "#include <stdbool.h>",+        char '\n',+        text "bool",+        text "WINAPI",+        text "DllMain ( HINSTANCE hInstance STG_UNUSED",+        text "        , DWORD reason STG_UNUSED",+        text "        , LPVOID reserved STG_UNUSED",+        text "        )",+        text "{",+        text "  return true;",+        text "}",+        char '\n' -- final newline, to keep gcc happy+        ]++-- Write out the link info section into a new assembly file. Previously+-- this was included as inline assembly in the main.c file but this+-- is pretty fragile. gas gets upset trying to calculate relative offsets+-- that span the .note section (notably .text) when debug info is present+mkNoteObjsToLinkIntoBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [UnitId] -> IO [FilePath]+mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_packages = do+   link_info <- getLinkInfo dflags unit_env dep_packages++   if (platformSupportsSavingLinkOpts (platformOS platform ))+     then fmap (:[]) $ mkExtraObj logger tmpfs dflags unit_state "s" (showSDoc dflags (link_opts link_info))+     else return []++  where+    unit_state = ue_units unit_env+    platform   = ue_platform unit_env+    link_opts info = hcat+        [ -- "link info" section (see Note [LinkInfo section])+          makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info++        -- ALL generated assembly must have this section to disable+        -- executable stacks.  See also+        -- "GHC.CmmToAsm" for another instance+        -- where we need to do this.+        , if platformHasGnuNonexecStack platform+            then text ".section .note.GNU-stack,\"\","+                 <> sectionType platform "progbits" <> char '\n'+            else Outputable.empty+        ]++-- | Return the "link info" string+--+-- See Note [LinkInfo section]+getLinkInfo :: DynFlags -> UnitEnv -> [UnitId] -> IO String+getLinkInfo dflags unit_env dep_packages = do+    package_link_opts <- getUnitLinkOpts dflags unit_env dep_packages+    pkg_frameworks <- if not (platformUsesFrameworks (ue_platform unit_env))+      then return []+      else do+         ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)+         return (collectFrameworks ps)+    let link_info =+             ( package_link_opts+             , pkg_frameworks+             , rtsOpts dflags+             , rtsOptsEnabled dflags+             , gopt Opt_NoHsMain dflags+             , map showOpt (ldInputs dflags)+             , getOpts dflags opt_l+             )+    return (show link_info)++platformSupportsSavingLinkOpts :: OS -> Bool+platformSupportsSavingLinkOpts os+ | os == OSSolaris2 = False -- see #5382+ | otherwise        = osElfTarget os++-- See Note [LinkInfo section]+ghcLinkInfoSectionName :: String+ghcLinkInfoSectionName = ".debug-ghc-link-info"+  -- if we use the ".debug" prefix, then strip will strip it by default++-- Identifier for the note (see Note [LinkInfo section])+ghcLinkInfoNoteName :: String+ghcLinkInfoNoteName = "GHC link info"++-- Returns 'False' if it was, and we can avoid linking, because the+-- previous binary was linked with "the same options".+checkLinkInfo :: Logger -> DynFlags -> UnitEnv -> [UnitId] -> FilePath -> IO Bool+checkLinkInfo logger dflags unit_env pkg_deps exe_file+ | not (platformSupportsSavingLinkOpts (platformOS (ue_platform unit_env)))+ -- ToDo: Windows and OS X do not use the ELF binary format, so+ -- readelf does not work there.  We need to find another way to do+ -- this.+ = return False -- conservatively we should return True, but not+                -- linking in this case was the behaviour for a long+                -- time so we leave it as-is.+ | otherwise+ = do+   link_info <- getLinkInfo dflags unit_env pkg_deps+   debugTraceMsg logger dflags 3 $ text ("Link info: " ++ link_info)+   m_exe_link_info <- readElfNoteAsString logger dflags exe_file+                          ghcLinkInfoSectionName ghcLinkInfoNoteName+   let sameLinkInfo = (Just link_info == m_exe_link_info)+   debugTraceMsg logger dflags 3 $ case m_exe_link_info of+     Nothing -> text "Exe link info: Not found"+     Just s+       | sameLinkInfo -> text ("Exe link info is the same")+       | otherwise    -> text ("Exe link info is different: " ++ s)+   return (not sameLinkInfo)++{- Note [LinkInfo section]+   ~~~~~~~~~~~~~~~~~~~~~~~++The "link info" is a string representing the parameters of the link. We save+this information in the binary, and the next time we link, if nothing else has+changed, we use the link info stored in the existing binary to decide whether+to re-link or not.++The "link info" string is stored in a ELF section called ".debug-ghc-link-info"+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to+not follow the specified record-based format (see #11022).++-}++haveRtsOptsFlags :: DynFlags -> Bool+haveRtsOptsFlags dflags =+        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of+                                       RtsOptsSafeOnly -> False+                                       _ -> True

+ GHC/Linker/Loader.hs view

@@ -0,0 +1,1740 @@+{-# LANGUAGE CPP, TupleSections, RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}++--+--  (c) The University of Glasgow 2002-2006++-- | The loader+--+-- This module deals with the top-level issues of dynamic linking (loading),+-- calling the object-code linker and the byte-code linker where necessary.+module GHC.Linker.Loader+   ( Loader (..)+   , LoaderState (..)+   , initLoaderState+   , uninitializedLoader+   , showLoaderState+   -- * Load & Unload+   , loadExpr+   , loadDecls+   , loadPackages+   , loadModule+   , loadCmdLineLibs+   , loadName+   , unload+   -- * LoadedEnv+   , withExtendedLoadedEnv+   , extendLoadedEnv+   , deleteFromLoadedEnv+   -- * Misc+   , extendLoadedPkgs+   )+where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Settings++import GHC.Platform+import GHC.Platform.Ways++import GHC.Driver.Phases+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr++import GHC.Tc.Utils.Monad++import GHC.Runtime.Interpreter+import GHCi.RemoteTypes++import GHC.Iface.Load++import GHC.ByteCode.Linker+import GHC.ByteCode.Asm+import GHC.ByteCode.Types++import GHC.SysTools++import GHC.Types.Basic+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.Unique.DSet++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps+import GHC.Unit.Home+import GHC.Unit.Home.ModInfo+import GHC.Unit.State as Packages++import qualified GHC.Data.ShortText as ST+import qualified GHC.Data.Maybe as Maybes+import GHC.Data.FastString+import GHC.Data.List.SetOps++import GHC.Linker.MacOS+import GHC.Linker.Dynamic+import GHC.Linker.Types++-- Standard libraries+import Control.Monad++import qualified Data.Set as Set+import Data.Char (isSpace)+import Data.Function ((&))+import Data.IORef+import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)+import Data.Maybe+import Control.Concurrent.MVar+import qualified Control.Monad.Catch as MC++import System.FilePath+import System.Directory+import System.IO.Unsafe+import System.Environment (lookupEnv)++#if defined(mingw32_HOST_OS)+import System.Win32.Info (getSystemDirectory)+#endif++import GHC.Utils.Exception++uninitialised :: a+uninitialised = panic "Loader not initialised"++modifyLoaderState_ :: Interp -> (LoaderState -> IO LoaderState) -> IO ()+modifyLoaderState_ interp f =+  modifyMVar_ (loader_state (interpLoader interp))+    (fmap pure . f . fromMaybe uninitialised)++modifyLoaderState :: Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a+modifyLoaderState interp f =+  modifyMVar (loader_state (interpLoader interp))+    (fmapFst pure . f . fromMaybe uninitialised)+  where fmapFst f = fmap (\(x, y) -> (f x, y))++emptyLoaderState :: LoaderState+emptyLoaderState = LoaderState+   { closure_env = emptyNameEnv+   , itbl_env    = emptyNameEnv+   , pkgs_loaded = init_pkgs+   , bcos_loaded = []+   , objs_loaded = []+   , temp_sos = []+   }+  -- Packages that don't need loading, because the compiler+  -- shares them with the interpreted program.+  --+  -- The linker's symbol table is populated with RTS symbols using an+  -- explicit list.  See rts/Linker.c for details.+  where init_pkgs = [rtsUnitId]++extendLoadedPkgs :: Interp -> [UnitId] -> IO ()+extendLoadedPkgs interp pkgs =+  modifyLoaderState_ interp $ \s ->+      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }++extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()+extendLoadedEnv interp new_bindings =+  modifyLoaderState_ interp $ \pls@LoaderState{..} -> do+    let new_ce = extendClosureEnv closure_env new_bindings+    return $! pls{ closure_env = new_ce }+    -- strictness is important for not retaining old copies of the pls++deleteFromLoadedEnv :: Interp -> [Name] -> IO ()+deleteFromLoadedEnv interp to_remove =+  modifyLoaderState_ interp $ \pls -> do+    let ce = closure_env pls+    let new_ce = delListFromNameEnv ce to_remove+    return pls{ closure_env = new_ce }++-- | Load the module containing the given Name and get its associated 'HValue'.+--+-- Throws a 'ProgramError' if loading fails or the name cannot be found.+loadName :: Interp -> HscEnv -> Name -> IO ForeignHValue+loadName interp hsc_env name = do+  initLoaderState interp hsc_env+  modifyLoaderState interp $ \pls0 -> do+    pls <- if not (isExternalName name)+       then return pls0+       else do+         (pls', ok) <- loadDependencies interp hsc_env pls0 noSrcSpan+                          [nameModule name]+         if failed ok+           then throwGhcExceptionIO (ProgramError "")+           else return pls'++    case lookupNameEnv (closure_env pls) name of+      Just (_,aa) -> return (pls,aa)+      Nothing     -> ASSERT2(isExternalName name, ppr name)+                     do let sym_to_find = nameToCLabel name "closure"+                        m <- lookupClosure interp (unpackFS sym_to_find)+                        r <- case m of+                          Just hvref -> mkFinalizedHValue interp hvref+                          Nothing -> linkFail "GHC.Linker.Loader.loadName"+                                       (unpackFS sym_to_find)+                        return (pls,r)++loadDependencies+  :: Interp+  -> HscEnv+  -> LoaderState+  -> SrcSpan -> [Module]+  -> IO (LoaderState, SuccessFlag)+loadDependencies interp hsc_env pls span needed_mods = do+--   initLoaderState (hsc_dflags hsc_env) dl+   let hpt = hsc_HPT hsc_env+   let dflags = hsc_dflags hsc_env+   -- The interpreter and dynamic linker can only handle object code built+   -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.+   -- So here we check the build tag: if we're building a non-standard way+   -- then we need to find & link object files built the "normal" way.+   maybe_normal_osuf <- checkNonStdWay dflags interp span++   -- Find what packages and linkables are required+   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls+                               maybe_normal_osuf span needed_mods++   -- Link the packages and modules required+   pls1 <- loadPackages' interp hsc_env pkgs pls+   loadModules interp hsc_env pls1 lnks+++-- | Temporarily extend the loaded env.+withExtendedLoadedEnv+  :: (ExceptionMonad m)+  => Interp+  -> [(Name,ForeignHValue)]+  -> m a+  -> m a+withExtendedLoadedEnv interp new_env action+    = MC.bracket (liftIO $ extendLoadedEnv interp new_env)+               (\_ -> reset_old_env)+               (\_ -> action)+    where+        -- Remember that the linker state might be side-effected+        -- during the execution of the IO action, and we don't want to+        -- lose those changes (we might have linked a new module or+        -- package), so the reset action only removes the names we+        -- added earlier.+          reset_old_env = liftIO $+            modifyLoaderState_ interp $ \pls ->+                let cur = closure_env pls+                    new = delListFromNameEnv cur (map fst new_env)+                in return pls{ closure_env = new }+++-- | Display the loader state.+showLoaderState :: Interp -> IO SDoc+showLoaderState interp = do+  ls <- readMVar (loader_state (interpLoader interp))+  let docs = case ls of+        Nothing  -> [ text "Loader not initialised"]+        Just pls -> [ text "Pkgs:" <+> ppr (pkgs_loaded pls)+                    , text "Objs:" <+> ppr (objs_loaded pls)+                    , text "BCOs:" <+> ppr (bcos_loaded pls)+                    ]++  return $ withPprStyle defaultDumpStyle+         $ vcat (text "----- Loader state -----":docs)+++{- **********************************************************************++                        Initialisation++  ********************************************************************* -}++-- | Initialise the dynamic linker.  This entails+--+--  a) Calling the C initialisation procedure,+--+--  b) Loading any packages specified on the command line,+--+--  c) Loading any packages specified on the command line, now held in the+--     @-l@ options in @v_Opt_l@,+--+--  d) Loading any @.o\/.dll@ files specified on the command line, now held+--     in @ldInputs@,+--+--  e) Loading any MacOS frameworks.+--+-- NOTE: This function is idempotent; if called more than once, it does+-- nothing.  This is useful in Template Haskell, where we call it before+-- trying to link.+--+initLoaderState :: Interp -> HscEnv -> IO ()+initLoaderState interp hsc_env = do+  modifyMVar_ (loader_state (interpLoader interp)) $ \pls -> do+    case pls of+      Just  _ -> return pls+      Nothing -> Just <$> reallyInitLoaderState interp hsc_env++reallyInitLoaderState :: Interp -> HscEnv -> IO LoaderState+reallyInitLoaderState interp hsc_env = do+  -- Initialise the linker state+  let pls0 = emptyLoaderState++  -- (a) initialise the C dynamic linker+  initObjLinker interp++  -- (b) Load packages from the command-line (Note [preload packages])+  pls <- loadPackages' interp hsc_env (preloadUnits (hsc_units hsc_env)) pls0++  -- steps (c), (d) and (e)+  loadCmdLineLibs' interp hsc_env pls+++loadCmdLineLibs :: Interp -> HscEnv -> IO ()+loadCmdLineLibs interp hsc_env = do+  initLoaderState interp hsc_env+  modifyLoaderState_ interp $ \pls ->+    loadCmdLineLibs' interp hsc_env pls++loadCmdLineLibs'+  :: Interp+  -> HscEnv+  -> LoaderState+  -> IO LoaderState+loadCmdLineLibs' interp hsc_env pls =+  do+      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs+                           , libraryPaths = lib_paths_base})+            = hsc_dflags hsc_env+      let logger = hsc_logger hsc_env++      -- (c) Link libraries from the command-line+      let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]++      -- On Windows we want to add libpthread by default just as GCC would.+      -- However because we don't know the actual name of pthread's dll we+      -- need to defer this to the locateLib call so we can't initialize it+      -- inside of the rts. Instead we do it here to be able to find the+      -- import library for pthreads. See #13210.+      let platform = targetPlatform dflags+          os       = platformOS platform+          minus_ls = case os of+                       OSMinGW32 -> "pthread" : minus_ls_1+                       _         -> minus_ls_1+      -- See Note [Fork/Exec Windows]+      gcc_paths <- getGCCPaths logger dflags os++      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base++      maybePutStrLn logger dflags "Search directories (user):"+      maybePutStr logger dflags (unlines $ map ("  "++) lib_paths_env)+      maybePutStrLn logger dflags "Search directories (gcc):"+      maybePutStr logger dflags (unlines $ map ("  "++) gcc_paths)++      libspecs+        <- mapM (locateLib interp hsc_env False lib_paths_env gcc_paths) minus_ls++      -- (d) Link .o files from the command-line+      classified_ld_inputs <- mapM (classifyLdInput logger dflags)+                                [ f | FileOption _ f <- cmdline_ld_inputs ]++      -- (e) Link any MacOS frameworks+      let platform = targetPlatform dflags+      let (framework_paths, frameworks) =+            if platformUsesFrameworks platform+             then (frameworkPaths dflags, cmdlineFrameworks dflags)+              else ([],[])++      -- Finally do (c),(d),(e)+      let cmdline_lib_specs = catMaybes classified_ld_inputs+                           ++ libspecs+                           ++ map Framework frameworks+      if null cmdline_lib_specs+         then return pls+         else do+           -- Add directories to library search paths, this only has an effect+           -- on Windows. On Unix OSes this function is a NOP.+           let all_paths = let paths = takeDirectory (pgm_c dflags)+                                     : framework_paths+                                    ++ lib_paths_base+                                    ++ [ takeDirectory dll | DLLPath dll <- libspecs ]+                           in nub $ map normalise paths+           let lib_paths = nub $ lib_paths_base ++ gcc_paths+           all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths+           pathCache <- mapM (addLibrarySearchPath interp) all_paths_env++           let merged_specs = mergeStaticObjects cmdline_lib_specs+           pls1 <- foldM (preloadLib interp hsc_env lib_paths framework_paths) pls+                         merged_specs++           maybePutStr logger dflags "final link ... "+           ok <- resolveObjs interp++           -- DLLs are loaded, reset the search paths+           mapM_ (removeLibrarySearchPath interp) $ reverse pathCache++           if succeeded ok then maybePutStrLn logger dflags "done"+           else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")++           return pls1++-- | Merge runs of consecutive of 'Objects'. This allows for resolution of+-- cyclic symbol references when dynamically linking. Specifically, we link+-- together all of the static objects into a single shared object, avoiding+-- the issue we saw in #13786.+mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]+mergeStaticObjects specs = go [] specs+  where+    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]+    go accum (Objects objs : rest) = go (objs ++ accum) rest+    go accum@(_:_) rest = Objects (reverse accum) : go [] rest+    go [] (spec:rest) = spec : go [] rest+    go [] [] = []++{- Note [preload packages]++Why do we need to preload packages from the command line?  This is an+explanation copied from #2437:++I tried to implement the suggestion from #3560, thinking it would be+easy, but there are two reasons we link in packages eagerly when they+are mentioned on the command line:++  * So that you can link in extra object files or libraries that+    depend on the packages. e.g. ghc -package foo -lbar where bar is a+    C library that depends on something in foo. So we could link in+    foo eagerly if and only if there are extra C libs or objects to+    link in, but....++  * Haskell code can depend on a C function exported by a package, and+    the normal dependency tracking that TH uses can't know about these+    dependencies. The test ghcilink004 relies on this, for example.++I conclude that we need two -package flags: one that says "this is a+package I want to make available", and one that says "this is a+package I want to link in eagerly". Would that be too complicated for+users?+-}++classifyLdInput :: Logger -> DynFlags -> FilePath -> IO (Maybe LibrarySpec)+classifyLdInput logger dflags f+  | isObjectFilename platform f = return (Just (Objects [f]))+  | isDynLibFilename platform f = return (Just (DLLPath f))+  | otherwise          = do+        putLogMsg logger dflags NoReason SevInfo noSrcSpan+            $ withPprStyle defaultUserStyle+            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))+        return Nothing+    where platform = targetPlatform dflags++preloadLib+  :: Interp+  -> HscEnv+  -> [String]+  -> [String]+  -> LoaderState+  -> LibrarySpec+  -> IO LoaderState+preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do+  maybePutStr logger dflags ("Loading object " ++ showLS lib_spec ++ " ... ")+  case lib_spec of+    Objects static_ishs -> do+      (b, pls1) <- preload_statics lib_paths static_ishs+      maybePutStrLn logger dflags (if b  then "done" else "not found")+      return pls1++    Archive static_ish -> do+      b <- preload_static_archive lib_paths static_ish+      maybePutStrLn logger dflags (if b  then "done" else "not found")+      return pls++    DLL dll_unadorned -> do+      maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)+      case maybe_errstr of+         Nothing -> maybePutStrLn logger dflags "done"+         Just mm | platformOS platform /= OSDarwin ->+           preloadFailed mm lib_paths lib_spec+         Just mm | otherwise -> do+           -- As a backup, on Darwin, try to also load a .so file+           -- since (apparently) some things install that way - see+           -- ticket #8770.+           let libfile = ("lib" ++ dll_unadorned) <.> "so"+           err2 <- loadDLL interp libfile+           case err2 of+             Nothing -> maybePutStrLn logger dflags "done"+             Just _  -> preloadFailed mm lib_paths lib_spec+      return pls++    DLLPath dll_path -> do+      do maybe_errstr <- loadDLL interp dll_path+         case maybe_errstr of+            Nothing -> maybePutStrLn logger dflags "done"+            Just mm -> preloadFailed mm lib_paths lib_spec+         return pls++    Framework framework ->+      if platformUsesFrameworks (targetPlatform dflags)+      then do maybe_errstr <- loadFramework interp framework_paths framework+              case maybe_errstr of+                 Nothing -> maybePutStrLn logger dflags "done"+                 Just mm -> preloadFailed mm framework_paths lib_spec+              return pls+      else throwGhcExceptionIO (ProgramError "preloadLib Framework")++  where+    dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env++    platform = targetPlatform dflags++    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()+    preloadFailed sys_errmsg paths spec+       = do maybePutStr logger dflags "failed.\n"+            throwGhcExceptionIO $+              CmdLineError (+                    "user specified .o/.so/.DLL could not be loaded ("+                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "+                    ++ showLS spec ++ "\nAdditional directories searched:"+                    ++ (if null paths then " (none)" else+                        intercalate "\n" (map ("   "++) paths)))++    -- Not interested in the paths in the static case.+    preload_statics _paths names+       = do b <- or <$> mapM doesFileExist names+            if not b then return (False, pls)+                     else if hostIsDynamic+                             then  do pls1 <- dynLoadObjs interp hsc_env pls names+                                      return (True, pls1)+                             else  do mapM_ (loadObj interp) names+                                      return (True, pls)++    preload_static_archive _paths name+       = do b <- doesFileExist name+            if not b then return False+                     else do if hostIsDynamic+                                 then throwGhcExceptionIO $+                                      CmdLineError dynamic_msg+                                 else loadArchive interp name+                             return True+      where+        dynamic_msg = unlines+          [ "User-specified static library could not be loaded ("+            ++ name ++ ")"+          , "Loading static libraries is not supported in this configuration."+          , "Try using a dynamic library instead."+          ]+++{- **********************************************************************++                        Link a byte-code expression++  ********************************************************************* -}++-- | Load a single expression, /including/ first loading packages and+-- modules that this expression depends on.+--+-- Raises an IO exception ('ProgramError') if it can't find a compiled+-- version of the dependents to load.+--+loadExpr :: Interp -> HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue+loadExpr interp hsc_env span root_ul_bco = do+  -- Initialise the linker (if it's not been done already)+  initLoaderState interp hsc_env++  -- Take lock for the actual work.+  modifyLoaderState interp $ \pls0 -> do+    -- Load the packages and modules required+    (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+    if failed ok+      then throwGhcExceptionIO (ProgramError "")+      else do+        -- Load the expression itself+        let ie = itbl_env pls+            ce = closure_env pls++        -- Load the necessary packages and linkables+        let nobreakarray = error "no break array"+            bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]+        resolved <- linkBCO interp ie ce bco_ix nobreakarray root_ul_bco+        [root_hvref] <- createBCOs interp dflags [resolved]+        fhv <- mkFinalizedHValue interp root_hvref+        return (pls, fhv)+  where+     dflags = hsc_dflags hsc_env+     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)++     needed_mods :: [Module]+     needed_mods = [ nameModule n | n <- free_names,+                     isExternalName n,      -- Names from other modules+                     not (isWiredInName n)  -- Exclude wired-in names+                   ]                        -- (see note below)+        -- Exclude wired-in names because we may not have read+        -- their interface files, so getLinkDeps will fail+        -- All wired-in names are in the base package, which we link+        -- by default, so we can safely ignore them here.++dieWith :: DynFlags -> SrcSpan -> SDoc -> IO a+dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))+++checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)+checkNonStdWay dflags interp srcspan+  | ExternalInterp {} <- interpInstance interp = return Nothing+    -- with -fexternal-interpreter we load the .o files, whatever way+    -- they were built.  If they were built for a non-std way, then+    -- we will use the appropriate variant of the iserv binary to load them.++  | hostFullWays == targetFullWays = return Nothing+    -- Only if we are compiling with the same ways as GHC is built+    -- with, can we dynamically load those object files. (see #3604)++  | objectSuf dflags == normalObjectSuffix && not (null targetFullWays)+  = failNonStd dflags srcspan++  | otherwise = return (Just (hostWayTag ++ "o"))+  where+    targetFullWays = fullWays (ways dflags)+    hostWayTag = case waysTag hostFullWays of+                  "" -> ""+                  tag -> tag ++ "_"++normalObjectSuffix :: String+normalObjectSuffix = phaseInputExt StopLn++failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)+failNonStd dflags srcspan = dieWith dflags srcspan $+  text "Cannot load" <+> compWay <+>+     text "objects when GHC is built" <+> ghciWay $$+  text "To fix this, either:" $$+  text "  (1) Use -fexternal-interpreter, or" $$+  text "  (2) Build the program twice: once" <+>+                       ghciWay <> text ", and then" $$+  text "      with" <+> compWay <+>+     text "using -osuf to set a different object file suffix."+    where compWay+            | WayDyn `elem` ways dflags = text "-dynamic"+            | WayProf `elem` ways dflags = text "-prof"+            | otherwise = text "normal"+          ghciWay+            | hostIsDynamic = text "with -dynamic"+            | hostIsProfiled = text "with -prof"+            | otherwise = text "the normal way"++getLinkDeps :: HscEnv -> HomePackageTable+            -> LoaderState+            -> Maybe FilePath                   -- replace object suffices?+            -> SrcSpan                          -- for error messages+            -> [Module]                         -- If you need these+            -> IO ([Linkable], [UnitId])     -- ... then link these first+-- Fails with an IO exception if it can't find enough files++getLinkDeps hsc_env hpt pls replace_osuf span mods+-- Find all the packages and linkables that a set of modules depends on+ = do {+        -- 1.  Find the dependent home-pkg-modules/packages from each iface+        -- (omitting modules from the interactive package, which is already linked)+      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)+                                        emptyUniqDSet emptyUniqDSet;++      ; let {+        -- 2.  Exclude ones already linked+        --      Main reason: avoid findModule calls in get_linkable+            mods_needed = mods_s `minusList` linked_mods     ;+            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;++            linked_mods = map (moduleName.linkableModule)+                                (objs_loaded pls ++ bcos_loaded pls)  }++        -- 3.  For each dependent module, find its linkable+        --     This will either be in the HPT or (in the case of one-shot+        --     compilation) we may need to use maybe_getFileLinkable+      ; let { osuf = objectSuf dflags }+      ; lnks_needed <- mapM (get_linkable osuf) mods_needed++      ; return (lnks_needed, pkgs_needed) }+  where+    dflags = hsc_dflags hsc_env++        -- The ModIface contains the transitive closure of the module dependencies+        -- within the current package, *except* for boot modules: if we encounter+        -- a boot module, we have to find its real interface and discover the+        -- dependencies of that.  Hence we need to traverse the dependency+        -- tree recursively.  See bug #936, testcase ghci/prog007.+    follow_deps :: [Module]             -- modules to follow+                -> UniqDSet ModuleName         -- accum. module dependencies+                -> UniqDSet UnitId          -- accum. package dependencies+                -> IO ([ModuleName], [UnitId]) -- result+    follow_deps []     acc_mods acc_pkgs+        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)+    follow_deps (mod:mods) acc_mods acc_pkgs+        = do+          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $+                        loadInterface msg mod (ImportByUser NotBoot)+          iface <- case mb_iface of+                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))+                    Maybes.Succeeded iface -> return iface++          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod++          let+            pkg = moduleUnit mod+            deps  = mi_deps iface+            home_unit = hsc_home_unit hsc_env++            pkg_deps = dep_pkgs deps+            (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $+              \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->+                m & case is_boot of+                  IsBoot -> Left+                  NotBoot -> Right++            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps+            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)+            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps+          --+          if not (isHomeUnit home_unit pkg)+             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))+             else follow_deps (map (mkHomeModule home_unit) boot_deps' ++ mods)+                              acc_mods' acc_pkgs'+        where+            msg = text "need to link module" <+> ppr mod <+>+                  text "due to use of Template Haskell"+++    link_boot_mod_error mod =+        throwGhcExceptionIO (ProgramError (showSDoc dflags (+            text "module" <+> ppr mod <+>+            text "cannot be linked; it is only available as a boot module")))++    no_obj :: Outputable a => a -> IO b+    no_obj mod = dieWith dflags span $+                     text "cannot find object file for module " <>+                        quotes (ppr mod) $$+                     while_linking_expr++    while_linking_expr = text "while linking an interpreted expression"++        -- This one is a build-system bug++    get_linkable osuf mod_name      -- A home-package module+        | Just mod_info <- lookupHpt hpt mod_name+        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))+        | otherwise+        = do    -- It's not in the HPT because we are in one shot mode,+                -- so use the Finder to get a ModLocation...+             mb_stuff <- findHomeModule hsc_env mod_name+             case mb_stuff of+                  Found loc mod -> found loc mod+                  _ -> no_obj mod_name+        where+            found loc mod = do {+                -- ...and then find the linkable for it+               mb_lnk <- findObjectLinkableMaybe mod loc ;+               case mb_lnk of {+                  Nothing  -> no_obj mod ;+                  Just lnk -> adjust_linkable lnk+              }}++            adjust_linkable lnk+                | Just new_osuf <- replace_osuf = do+                        new_uls <- mapM (adjust_ul new_osuf)+                                        (linkableUnlinked lnk)+                        return lnk{ linkableUnlinked=new_uls }+                | otherwise =+                        return lnk++            adjust_ul new_osuf (DotO file) = do+                MASSERT(osuf `isSuffixOf` file)+                let file_base = fromJust (stripExtension osuf file)+                    new_file = file_base <.> new_osuf+                ok <- doesFileExist new_file+                if (not ok)+                   then dieWith dflags span $+                          text "cannot find object file "+                                <> quotes (text new_file) $$ while_linking_expr+                   else return (DotO new_file)+            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)+            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)+            adjust_ul _ l@(BCOs {}) = return l++++{- **********************************************************************++              Loading a Decls statement++  ********************************************************************* -}++loadDecls :: Interp -> HscEnv -> SrcSpan -> CompiledByteCode -> IO [(Name, ForeignHValue)]+loadDecls interp hsc_env span cbc@CompiledByteCode{..} = do+    -- Initialise the linker (if it's not been done already)+    initLoaderState interp hsc_env++    -- Take lock for the actual work.+    modifyLoaderState interp $ \pls0 -> do+      -- Link the packages and modules required+      (pls, ok) <- loadDependencies interp hsc_env pls0 span needed_mods+      if failed ok+        then throwGhcExceptionIO (ProgramError "")+        else do+          -- Link the expression itself+          let ie = plusNameEnv (itbl_env pls) bc_itbls+              ce = closure_env pls++          -- Link the necessary packages and linkables+          new_bindings <- linkSomeBCOs dflags interp ie ce [cbc]+          nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings+          let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs+                         , itbl_env    = ie }+          return (pls2, nms_fhvs)+  where+    dflags = hsc_dflags hsc_env+    free_names = uniqDSetToList $+      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos++    needed_mods :: [Module]+    needed_mods = [ nameModule n | n <- free_names,+                    isExternalName n,       -- Names from other modules+                    not (isWiredInName n)   -- Exclude wired-in names+                  ]                         -- (see note below)+    -- Exclude wired-in names because we may not have read+    -- their interface files, so getLinkDeps will fail+    -- All wired-in names are in the base package, which we link+    -- by default, so we can safely ignore them here.++{- **********************************************************************++              Loading a single module++  ********************************************************************* -}++loadModule :: Interp -> HscEnv -> Module -> IO ()+loadModule interp hsc_env mod = do+  initLoaderState interp hsc_env+  modifyLoaderState_ interp $ \pls -> do+    (pls', ok) <- loadDependencies interp hsc_env pls noSrcSpan [mod]+    if failed ok+      then throwGhcExceptionIO (ProgramError "could not load module")+      else return pls'++{- **********************************************************************++                Link some linkables+        The linkables may consist of a mixture of+        byte-code modules and object modules++  ********************************************************************* -}++loadModules :: Interp -> HscEnv -> LoaderState -> [Linkable] -> IO (LoaderState, SuccessFlag)+loadModules interp hsc_env pls linkables+  = mask_ $ do  -- don't want to be interrupted by ^C in here++        let (objs, bcos) = partition isObjectLinkable+                              (concatMap partitionLinkable linkables)+        let dflags = hsc_dflags hsc_env++                -- Load objects first; they can't depend on BCOs+        (pls1, ok_flag) <- loadObjects interp hsc_env pls objs++        if failed ok_flag then+                return (pls1, Failed)+          else do+                pls2 <- dynLinkBCOs dflags interp pls1 bcos+                return (pls2, Succeeded)+++-- HACK to support f-x-dynamic in the interpreter; no other purpose+partitionLinkable :: Linkable -> [Linkable]+partitionLinkable li+   = let li_uls = linkableUnlinked li+         li_uls_obj = filter isObject li_uls+         li_uls_bco = filter isInterpretable li_uls+     in+         case (li_uls_obj, li_uls_bco) of+            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},+                           li {linkableUnlinked=li_uls_bco}]+            _ -> [li]++findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable+findModuleLinkable_maybe lis mod+   = case [LM time nm us | LM time nm us <- lis, nm == mod] of+        []   -> Nothing+        [li] -> Just li+        _    -> pprPanic "findModuleLinkable" (ppr mod)++linkableInSet :: Linkable -> [Linkable] -> Bool+linkableInSet l objs_loaded =+  case findModuleLinkable_maybe objs_loaded (linkableModule l) of+        Nothing -> False+        Just m  -> linkableTime l == linkableTime m+++{- **********************************************************************++                The object-code linker++  ********************************************************************* -}++-- | Load the object files and link them+--+-- If the interpreter uses dynamic-linking, build a shared library and load it.+-- Otherwise, use the RTS linker.+loadObjects+  :: Interp+  -> HscEnv+  -> LoaderState+  -> [Linkable]+  -> IO (LoaderState, SuccessFlag)+loadObjects interp hsc_env pls objs = do+        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs+            pls1                     = pls { objs_loaded = objs_loaded' }+            unlinkeds                = concatMap linkableUnlinked new_objs+            wanted_objs              = map nameOfObject unlinkeds++        if interpreterDynamic interp+            then do pls2 <- dynLoadObjs interp hsc_env pls1 wanted_objs+                    return (pls2, Succeeded)+            else do mapM_ (loadObj interp) wanted_objs++                    -- Link them all together+                    ok <- resolveObjs interp++                    -- If resolving failed, unload all our+                    -- object modules and carry on+                    if succeeded ok then+                            return (pls1, Succeeded)+                      else do+                            pls2 <- unload_wkr interp [] pls1+                            return (pls2, Failed)+++-- | Create a shared library containing the given object files and load it.+dynLoadObjs :: Interp -> HscEnv -> LoaderState -> [FilePath] -> IO LoaderState+dynLoadObjs _      _       pls                           []   = return pls+dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do+    let unit_env = hsc_unit_env hsc_env+    let dflags   = hsc_dflags hsc_env+    let logger   = hsc_logger hsc_env+    let tmpfs    = hsc_tmpfs hsc_env+    let platform = ue_platform unit_env+    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]+    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]+    (soFile, libPath , libName) <-+      newTempLibName logger tmpfs dflags TFL_CurrentModule (platformSOExt platform)+    let+        dflags2 = dflags {+                      -- We don't want the original ldInputs in+                      -- (they're already linked in), but we do want+                      -- to link against previous dynLoadObjs+                      -- libraries if there were any, so that the linker+                      -- can resolve dependencies when it loads this+                      -- library.+                      ldInputs =+                           concatMap (\l -> [ Option ("-l" ++ l) ])+                                     (nub $ snd <$> temp_sos)+                        ++ concatMap (\lp -> Option ("-L" ++ lp)+                                          : if useXLinkerRPath dflags (platformOS platform)+                                            then [ Option "-Xlinker"+                                                 , Option "-rpath"+                                                 , Option "-Xlinker"+                                                 , Option lp ]+                                            else [])+                                     (nub $ fst <$> temp_sos)+                        ++ concatMap+                             (\lp -> Option ("-L" ++ lp)+                                  : if useXLinkerRPath dflags (platformOS platform)+                                    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,+                      -- Add -l options and -L options from dflags.+                      --+                      -- When running TH for a non-dynamic way, we still+                      -- need to make -l flags to link against the dynamic+                      -- libraries, so we need to add WayDyn to ways.+                      --+                      -- Even if we're e.g. profiling, we still want+                      -- the vanilla dynamic libraries, so we set the+                      -- ways / build tag to be just WayDyn.+                      targetWays_ = Set.singleton WayDyn,+                      outputFile_ = Just soFile+                  }+    -- link all "loaded packages" so symbols in those can be resolved+    -- Note: We are loading packages with local scope, so to see the+    -- symbols in this link we must link all loaded packages again.+    linkDynLib logger tmpfs dflags2 unit_env objs pkgs_loaded++    -- if we got this far, extend the lifetime of the library file+    changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]+    m <- loadDLL interp soFile+    case m of+        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }+        Just err -> linkFail msg err+  where+    msg = "GHC.Linker.Loader.dynLoadObjs: Loading temp shared object failed"++rmDupLinkables :: [Linkable]    -- Already loaded+               -> [Linkable]    -- New linkables+               -> ([Linkable],  -- New loaded set (including new ones)+                   [Linkable])  -- New linkables (excluding dups)+rmDupLinkables already ls+  = go already [] ls+  where+    go already extras [] = (already, extras)+    go already extras (l:ls)+        | linkableInSet l already = go already     extras     ls+        | otherwise               = go (l:already) (l:extras) ls++{- **********************************************************************++                The byte-code linker++  ********************************************************************* -}+++dynLinkBCOs :: DynFlags -> Interp -> LoaderState -> [Linkable] -> IO LoaderState+dynLinkBCOs dflags interp pls bcos = do++        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos+            pls1                     = pls { bcos_loaded = bcos_loaded' }+            unlinkeds :: [Unlinked]+            unlinkeds                = concatMap linkableUnlinked new_bcos++            cbcs :: [CompiledByteCode]+            cbcs      = map byteCodeOfObject unlinkeds+++            ies        = map bc_itbls cbcs+            gce       = closure_env pls+            final_ie  = foldr plusNameEnv (itbl_env pls) ies++        names_and_refs <- linkSomeBCOs dflags interp final_ie gce cbcs++        -- We only want to add the external ones to the ClosureEnv+        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs++        -- Immediately release any HValueRefs we're not going to add+        freeHValueRefs interp (map snd to_drop)+        -- Wrap finalizers on the ones we want to keep+        new_binds <- makeForeignNamedHValueRefs interp to_add++        return pls1 { closure_env = extendClosureEnv gce new_binds,+                      itbl_env    = final_ie }++-- Link a bunch of BCOs and return references to their values+linkSomeBCOs :: DynFlags+             -> Interp+             -> ItblEnv+             -> ClosureEnv+             -> [CompiledByteCode]+             -> IO [(Name,HValueRef)]+                        -- The returned HValueRefs are associated 1-1 with+                        -- the incoming unlinked BCOs.  Each gives the+                        -- value of the corresponding unlinked BCO++linkSomeBCOs dflags interp ie ce mods = foldr fun do_link mods []+ where+  fun CompiledByteCode{..} inner accum =+    case bc_breaks of+      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)+      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->+                   inner ((breakarray, bc_bcos) : accum)++  do_link [] = return []+  do_link mods = do+    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]+        names = map (unlinkedBCOName . snd) flat+        bco_ix = mkNameEnv (zip names [0..])+    resolved <- sequence [ linkBCO interp ie ce bco_ix breakarray bco+                         | (breakarray, bco) <- flat ]+    hvrefs <- createBCOs interp dflags resolved+    return (zip names hvrefs)++-- | Useful to apply to the result of 'linkSomeBCOs'+makeForeignNamedHValueRefs+  :: Interp -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]+makeForeignNamedHValueRefs interp bindings =+  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue interp hvref) bindings++{- **********************************************************************++                Unload some object modules++  ********************************************************************* -}++-- ---------------------------------------------------------------------------+-- | Unloading old objects ready for a new compilation sweep.+--+-- The compilation manager provides us with a list of linkables that it+-- considers \"stable\", i.e. won't be recompiled this time around.  For+-- each of the modules current linked in memory,+--+--   * if the linkable is stable (and it's the same one -- the user may have+--     recompiled the module on the side), we keep it,+--+--   * otherwise, we unload it.+--+--   * we also implicitly unload all temporary bindings at this point.+--+unload+  :: Interp+  -> HscEnv+  -> [Linkable] -- ^ The linkables to *keep*.+  -> IO ()+unload interp hsc_env linkables+  = mask_ $ do -- mask, so we're safe from Ctrl-C in here++        -- Initialise the linker (if it's not been done already)+        initLoaderState interp hsc_env++        new_pls+            <- modifyLoaderState interp $ \pls -> do+                 pls1 <- unload_wkr interp linkables pls+                 return (pls1, pls1)++        let dflags = hsc_dflags hsc_env+        let logger = hsc_logger hsc_env+        debugTraceMsg logger dflags 3 $+          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)+        debugTraceMsg logger dflags 3 $+          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)+        return ()++unload_wkr+  :: Interp+  -> [Linkable]                -- stable linkables+  -> LoaderState+  -> IO LoaderState+-- Does the core unload business+-- (the wrapper blocks exceptions and deals with the LS get and put)++unload_wkr interp keep_linkables pls@LoaderState{..}  = do+  -- NB. careful strictness here to avoid keeping the old LS when+  -- we're unloading some code.  -fghci-leak-check with the tests in+  -- testsuite/ghci can detect space leaks here.++  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables++      discard keep l = not (linkableInSet l keep)++      (objs_to_unload, remaining_objs_loaded) =+         partition (discard objs_to_keep) objs_loaded+      (bcos_to_unload, remaining_bcos_loaded) =+         partition (discard bcos_to_keep) bcos_loaded++  mapM_ unloadObjs objs_to_unload+  mapM_ unloadObjs bcos_to_unload++  -- If we unloaded any object files at all, we need to purge the cache+  -- of lookupSymbol results.+  when (not (null (objs_to_unload +++                   filter (not . null . linkableObjs) bcos_to_unload))) $+    purgeLookupSymbolCache interp++  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded++      -- 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++      itbl_env'     = filterNameEnv keep_name itbl_env+      closure_env'  = filterNameEnv keep_name closure_env++      !new_pls = pls { itbl_env = itbl_env',+                       closure_env = closure_env',+                       bcos_loaded = remaining_bcos_loaded,+                       objs_loaded = remaining_objs_loaded }++  return new_pls+  where+    unloadObjs :: Linkable -> IO ()+    unloadObjs lnk+        -- The RTS's PEi386 linker currently doesn't support unloading.+      | isWindowsHost = return ()++      | hostIsDynamic = return ()+        -- We don't do any cleanup when linking objects with the+        -- dynamic linker.  Doing so introduces extra complexity for+        -- not much benefit.++      | otherwise+      = mapM_ (unloadObj interp) [f | DotO f <- linkableUnlinked lnk]+                -- The components of a BCO linkable may contain+                -- dot-o files.  Which is very confusing.+                --+                -- But the BCO parts can be unlinked just by+                -- letting go of them (plus of course depopulating+                -- the symbol table which is done in the main body)++{- **********************************************************************++                Loading packages++  ********************************************************************* -}++data LibrarySpec+   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o+                        -- We allow batched loading to ensure that cyclic symbol+                        -- references can be resolved (see #13786).+                        -- For dynamic objects only, try to find the object+                        -- file in all the directories specified in+                        -- v_Library_paths before giving up.++   | Archive FilePath   -- Full path name of a .a file, including trailing .a++   | DLL String         -- "Unadorned" name of a .DLL/.so+                        --  e.g.    On unix     "qt"  denotes "libqt.so"+                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"+                        --  loadDLL is platform-specific and adds the lib/.so/.DLL+                        --  suffixes platform-dependently++   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library+                        -- (ends with .dll or .so).++   | Framework String   -- Only used for darwin, but does no harm++instance Outputable LibrarySpec where+  ppr (Objects objs) = text "Objects" <+> ppr objs+  ppr (Archive a) = text "Archive" <+> text a+  ppr (DLL s) = text "DLL" <+> text s+  ppr (DLLPath f) = text "DLLPath" <+> text f+  ppr (Framework s) = text "Framework" <+> text s++-- If this package is already part of the GHCi binary, we'll already+-- have the right DLLs for this package loaded, so don't try to+-- load them again.+--+-- But on Win32 we must load them 'again'; doing so is a harmless no-op+-- as far as the loader is concerned, but it does initialise the list+-- of DLL handles that rts/Linker.c maintains, and that in turn is+-- used by lookupSymbol.  So we must call addDLL for each library+-- just to get the DLL handle into the list.+partOfGHCi :: [PackageName]+partOfGHCi+ | isWindowsHost || isDarwinHost = []+ | otherwise = map (PackageName . mkFastString)+                   ["base", "template-haskell", "editline"]++showLS :: LibrarySpec -> String+showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"+showLS (Archive nm)   = "(static archive) " ++ nm+showLS (DLL nm)       = "(dynamic) " ++ nm+showLS (DLLPath nm)   = "(dynamic) " ++ nm+showLS (Framework nm) = "(framework) " ++ nm++-- | Load exactly the specified packages, and their dependents (unless of+-- course they are already loaded).  The dependents are loaded+-- automatically, and it doesn't matter what order you specify the input+-- packages.+--+loadPackages :: Interp -> HscEnv -> [UnitId] -> IO ()+-- NOTE: in fact, since each module tracks all the packages it depends on,+--       we don't really need to use the package-config dependencies.+--+-- However we do need the package-config stuff (to find aux libs etc),+-- and following them lets us load libraries in the right order, which+-- perhaps makes the error message a bit more localised if we get a link+-- failure.  So the dependency walking code is still here.++loadPackages interp hsc_env new_pkgs = do+  -- It's probably not safe to try to load packages concurrently, so we take+  -- a lock.+  initLoaderState interp hsc_env+  modifyLoaderState_ interp $ \pls ->+    loadPackages' interp hsc_env new_pkgs pls++loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState+loadPackages' interp hsc_env new_pks pls = do+    pkgs' <- link (pkgs_loaded pls) new_pks+    return $! pls { pkgs_loaded = pkgs' }+  where+     link :: [UnitId] -> [UnitId] -> IO [UnitId]+     link pkgs new_pkgs =+         foldM link_one pkgs new_pkgs++     link_one pkgs new_pkg+        | new_pkg `elem` pkgs   -- Already linked+        = return pkgs++        | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg+        = do {  -- Link dependents first+               pkgs' <- link pkgs (unitDepends pkg_cfg)+                -- Now link the package itself+             ; loadPackage interp hsc_env pkg_cfg+             ; return (new_pkg : pkgs') }++        | otherwise+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))+++loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ()+loadPackage interp hsc_env pkg+   = do+        let dflags    = hsc_dflags hsc_env+        let logger    = hsc_logger hsc_env+            platform  = targetPlatform dflags+            is_dyn    = interpreterDynamic interp+            dirs | is_dyn    = map ST.unpack $ Packages.unitLibraryDynDirs pkg+                 | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg++        let hs_libs   = map ST.unpack $ Packages.unitLibraries pkg+            -- The FFI GHCi import lib isn't needed as+            -- GHC.Linker.Loader + rts/Linker.c link the+            -- interpreted references to FFI to the compiled FFI.+            -- We therefore filter it out so that we don't get+            -- duplicate symbol errors.+            hs_libs'  =  filter ("HSffi" /=) hs_libs++        -- Because of slight differences between the GHC dynamic linker and+        -- the native system linker some packages have to link with a+        -- different list of libraries when using GHCi. Examples include: libs+        -- that are actually gnu ld scripts, and the possibility that the .a+        -- libs do not exactly match the .so/.dll equivalents. So if the+        -- package file provides an "extra-ghci-libraries" field then we use+        -- that instead of the "extra-libraries" field.+            extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)+                                      then Packages.unitExtDepLibsSys pkg+                                      else Packages.unitExtDepLibsGhc pkg)+            linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]+            extra_libs = extdeplibs ++ linkerlibs++        -- See Note [Fork/Exec Windows]+        gcc_paths <- getGCCPaths logger dflags (platformOS platform)+        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs++        hs_classifieds+           <- mapM (locateLib interp hsc_env True  dirs_env gcc_paths) hs_libs'+        extra_classifieds+           <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs+        let classifieds = hs_classifieds ++ extra_classifieds++        -- Complication: all the .so's must be loaded before any of the .o's.+        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+            dlls       = [ dll  | DLL dll        <- classifieds ]+            objs       = [ obj  | Objects objs    <- classifieds+                                , obj <- objs ]+            archs      = [ arch | Archive arch   <- classifieds ]++        -- Add directories to library search paths+        let dll_paths  = map takeDirectory known_dlls+            all_paths  = nub $ map normalise $ dll_paths ++ dirs+        all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths+        pathCache <- mapM (addLibrarySearchPath interp) all_paths_env++        maybePutSDoc logger dflags+            (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")++        -- See comments with partOfGHCi+#if defined(CAN_LOAD_DLL)+        when (unitPackageName pkg `notElem` partOfGHCi) $ do+            loadFrameworks interp platform pkg+            -- See Note [Crash early load_dyn and locateLib]+            -- Crash early if can't load any of `known_dlls`+            mapM_ (load_dyn interp hsc_env True) known_dlls+            -- For remaining `dlls` crash early only when there is surely+            -- no package's DLL around ... (not is_dyn)+            mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls+#endif+        -- After loading all the DLLs, we can load the static objects.+        -- Ordering isn't important here, because we do one final link+        -- step to resolve everything.+        mapM_ (loadObj interp) objs+        mapM_ (loadArchive interp) archs++        maybePutStr logger dflags "linking ... "+        ok <- resolveObjs interp++        -- DLLs are loaded, reset the search paths+        -- Import libraries will be loaded via loadArchive so only+        -- reset the DLL search path after all archives are loaded+        -- as well.+        mapM_ (removeLibrarySearchPath interp) $ reverse pathCache++        if succeeded ok+           then maybePutStrLn logger dflags "done."+           else let errmsg = text "unable to load unit `"+                             <> pprUnitInfoForUser pkg <> text "'"+                 in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))++{-+Note [Crash early load_dyn and locateLib]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a package is "normal" (exposes it's code from more than zero Haskell+modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then+it has it's code compiled and linked into the DLL, which GHCi linker picks+when loading the package's code (see the big comment in the beginning of+`locateLib`).++When loading DLLs, GHCi linker simply calls the system's `dlopen` or+`LoadLibrary` APIs. This is quite different from the case when GHCi linker+loads an object file or static library. When loading an object file or static+library GHCi linker parses them and resolves all symbols "manually".+These object file or static library may reference some external symbols+defined in some external DLLs. And GHCi should know which these+external DLLs are.++But when GHCi loads a DLL, it's the *system* linker who manages all+the necessary dependencies, and it is able to load this DLL not having+any extra info. Thus we don't *have to* crash in this case even if we+are unable to load any supposed dependencies explicitly.++Suppose during GHCi session a client of the package wants to+`foreign import` a symbol which isn't exposed by the package DLL, but+is exposed by such an external (dependency) DLL.+If the DLL isn't *explicitly* loaded because `load_dyn` failed to do+this, then the client code eventually crashes because the GHCi linker+isn't able to locate this symbol (GHCi linker maintains a list of+explicitly loaded DLLs it looks into when trying to find a symbol).++This is why we still should try to load all the dependency DLLs+even though we know that the system linker loads them implicitly when+loading the package DLL.++Why we still keep the `crash_early` opportunity then not allowing such+a permissive behaviour for any DLLs? Well, we, perhaps, improve a user+experience in some cases slightly.++But if it happens there exist other corner cases where our current+usage of `crash_early` flag is overly restrictive, we may lift the+restriction very easily.+-}++-- we have already searched the filesystem; the strings passed to load_dyn+-- can be passed directly to loadDLL.  They are either fully-qualified+-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,+-- loadDLL is going to search the system paths to find the library.+load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO ()+load_dyn interp hsc_env crash_early dll = do+  r <- loadDLL interp dll+  case r of+    Nothing  -> return ()+    Just err ->+      if crash_early+        then cmdLineErrorIO err+        else+          when (wopt Opt_WarnMissedExtraSharedLib dflags)+            $ putLogMsg logger dflags+                (Reason Opt_WarnMissedExtraSharedLib) SevWarning+                  noSrcSpan $ withPprStyle defaultUserStyle (note err)+  where+    dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env+    note err = vcat $ map text+      [ err+      , "It's OK if you don't want to use symbols from it directly."+      , "(the package DLL is loaded by the system linker"+      , " which manages dependencies by itself)." ]++loadFrameworks :: Interp -> Platform -> UnitInfo -> IO ()+loadFrameworks interp platform pkg+    = when (platformUsesFrameworks platform) $ mapM_ load frameworks+  where+    fw_dirs    = map ST.unpack $ Packages.unitExtDepFrameworkDirs pkg+    frameworks = map ST.unpack $ Packages.unitExtDepFrameworks pkg++    load fw = do  r <- loadFramework interp fw_dirs fw+                  case r of+                    Nothing  -> return ()+                    Just err -> cmdLineErrorIO ("can't load framework: "+                                                ++ fw ++ " (" ++ err ++ ")" )++-- Try to find an object file for a given library in the given paths.+-- If it isn't present, we assume that addDLL in the RTS can find it,+-- which generally means that it should be a dynamic library in the+-- standard system search path.+-- For GHCi we tend to prefer dynamic libraries over static ones as+-- they are easier to load and manage, have less overhead.+locateLib+  :: Interp+  -> HscEnv+  -> Bool+  -> [FilePath]+  -> [FilePath]+  -> String+  -> IO LibrarySpec+locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib+  | not is_hs+    -- For non-Haskell libraries (e.g. gmp, iconv):+    --   first look in library-dirs for a dynamic library (on User paths only)+    --   (libfoo.so)+    --   then  try looking for import libraries on Windows (on User paths only)+    --   (.dll.a, .lib)+    --   first look in library-dirs for a dynamic library (on GCC paths only)+    --   (libfoo.so)+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)+    --   then  try looking for import libraries on Windows (on GCC paths only)+    --   (.dll.a, .lib)+    --   then  look in library-dirs for a static library (libfoo.a)+    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)+    --   then  try looking for import libraries on Windows (.dll.a, .lib)+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)+    --   then  try "gcc --print-file-name" to search gcc's search path+    --       for a dynamic library (#5289)+    --   otherwise, assume loadDLL can find it+    --+    --   The logic is a bit complicated, but the rationale behind it is that+    --   loading a shared library for us is O(1) while loading an archive is+    --   O(n). Loading an import library is also O(n) so in general we prefer+    --   shared libraries because they are simpler and faster.+    --+  =+#if defined(CAN_LOAD_DLL)+    findDll   user `orElse`+#endif+    tryImpLib user `orElse`+#if defined(CAN_LOAD_DLL)+    findDll   gcc  `orElse`+    findSysDll     `orElse`+#endif+    tryImpLib gcc  `orElse`+    findArchive    `orElse`+    tryGcc         `orElse`+    assumeDll++  | loading_dynamic_hs_libs -- search for .so libraries first.+  = findHSDll     `orElse`+    findDynObject `orElse`+    assumeDll++  | otherwise+    -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a+  = findObject  `orElse`+    findArchive `orElse`+    assumeDll++   where+     dflags = hsc_dflags hsc_env+     logger = hsc_logger hsc_env+     dirs   = lib_dirs ++ gcc_dirs+     gcc    = False+     user   = True++     obj_file+       | is_hs && loading_profiled_hs_libs = lib <.> "p_o"+       | otherwise = lib <.> "o"+     dyn_obj_file = lib <.> "dyn_o"+     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"+                  , lib <.> "a" -- native code has no lib_tag+                  , "lib" ++ lib, lib+                  ]+     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""++     loading_profiled_hs_libs = interpreterProfiled interp+     loading_dynamic_hs_libs  = interpreterDynamic  interp++     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"+                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"+                    ]++     hs_dyn_lib_name = lib ++ dynLibSuffix (ghcNameVersion dflags)+     hs_dyn_lib_file = platformHsSOName platform hs_dyn_lib_name++     so_name     = platformSOName platform lib+     lib_so_name = "lib" ++ so_name+     dyn_lib_file = case (arch, os) of+                             (ArchX86_64, OSSolaris2) -> "64" </> so_name+                             _ -> so_name++     findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file+     findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file+     findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name+                     in  apply (map local arch_files)+     findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file+     findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs+                     in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file+     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $+                        findSystemLibrary interp so_name+     tryGcc        = let search   = searchForLibUsingGcc logger dflags+                         dllpath  = liftM (fmap DLLPath)+                         short    = dllpath $ search so_name lib_dirs+                         full     = dllpath $ search lib_so_name lib_dirs+                         gcc name = liftM (fmap Archive) $ search name lib_dirs+                         files    = import_libs ++ arch_files+                         dlls     = [short, full]+                         archives = map gcc files+                     in apply $+#if defined(CAN_LOAD_DLL)+                          dlls +++#endif+                          archives+     tryImpLib re = case os of+                       OSMinGW32 ->+                        let dirs' = if re == user then lib_dirs else gcc_dirs+                            implib name = liftM (fmap Archive) $+                                            findFile dirs' name+                        in apply (map implib import_libs)+                       _         -> return Nothing++     -- TH Makes use of the interpreter so this failure is not obvious.+     -- So we are nice and warn/inform users why we fail before we do.+     -- But only for haskell libraries, as C libraries don't have a+     -- profiling/non-profiling distinction to begin with.+     assumeDll+      | is_hs+      , not loading_dynamic_hs_libs+      , interpreterProfiled interp+      = do+          warningMsg logger dflags+            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$+              text " \tTrying dynamic library instead. If this fails try to rebuild" <+>+              text "libraries with profiling support.")+          return (DLL lib)+      | otherwise = return (DLL lib)+     infixr `orElse`+     f `orElse` g = f >>= maybe g return++     apply :: [IO (Maybe a)] -> IO (Maybe a)+     apply []     = return Nothing+     apply (x:xs) = do x' <- x+                       if isJust x'+                          then return x'+                          else apply xs++     platform = targetPlatform dflags+     arch = platformArch platform+     os = platformOS platform++searchForLibUsingGcc :: Logger -> DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)+searchForLibUsingGcc logger dflags so dirs = do+   -- GCC does not seem to extend the library search path (using -L) when using+   -- --print-file-name. So instead pass it a new base location.+   str <- askLd logger dflags (map (FileOption "-B") dirs+                          ++ [Option "--print-file-name", Option so])+   let file = case lines str of+                []  -> ""+                l:_ -> l+   if (file == so)+      then return Nothing+      else do b <- doesFileExist file -- file could be a folder (see #16063)+              return (if b then Just file else Nothing)++-- | Retrieve the list of search directory GCC and the System use to find+--   libraries and components. See Note [Fork/Exec Windows].+getGCCPaths :: Logger -> DynFlags -> OS -> IO [FilePath]+getGCCPaths logger dflags os+  = case os of+      OSMinGW32 ->+        do gcc_dirs <- getGccSearchDirectory logger dflags "libraries"+           sys_dirs <- getSystemDirectories+           return $ nub $ gcc_dirs ++ sys_dirs+      _         -> return []++-- | Cache for the GCC search directories as this can't easily change+--   during an invocation of GHC. (Maybe with some env. variable but we'll)+--   deal with that highly unlikely scenario then.+{-# NOINLINE gccSearchDirCache #-}+gccSearchDirCache :: IORef [(String, [String])]+gccSearchDirCache = unsafePerformIO $ newIORef []++-- Note [Fork/Exec Windows]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- fork/exec is expensive on Windows, for each time we ask GCC for a library we+-- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.+-- So instead get a list of location that GCC would search and use findDirs+-- which hopefully is written in an optimized mannor to take advantage of+-- caching. At the very least we remove the overhead of the fork/exec and waits+-- which dominate a large percentage of startup time on Windows.+getGccSearchDirectory :: Logger -> DynFlags -> String -> IO [FilePath]+getGccSearchDirectory logger dflags key = do+    cache <- readIORef gccSearchDirCache+    case lookup key cache of+      Just x  -> return x+      Nothing -> do+        str <- askLd logger dflags [Option "--print-search-dirs"]+        let line = dropWhile isSpace str+            name = key ++ ": ="+        if null line+          then return []+          else do let val = split $ find name line+                  dirs <- filterM doesDirectoryExist val+                  modifyIORef' gccSearchDirCache ((key, dirs):)+                  return val+      where split :: FilePath -> [FilePath]+            split r = case break (==';') r of+                        (s, []    ) -> [s]+                        (s, (_:xs)) -> s : split xs++            find :: String -> String -> String+            find r x = let lst = lines x+                           val = filter (r `isPrefixOf`) lst+                       in if null val+                             then []+                             else case break (=='=') (head val) of+                                     (_ , [])    -> []+                                     (_, (_:xs)) -> xs++-- | Get a list of system search directories, this to alleviate pressure on+-- the findSysDll function.+getSystemDirectories :: IO [FilePath]+#if defined(mingw32_HOST_OS)+getSystemDirectories = fmap (:[]) getSystemDirectory+#else+getSystemDirectories = return []+#endif++-- | Merge the given list of paths with those in the environment variable+--   given. If the variable does not exist then just return the identity.+addEnvPaths :: String -> [String] -> IO [String]+addEnvPaths name list+  = do -- According to POSIX (chapter 8.3) a zero-length prefix means current+       -- working directory. Replace empty strings in the env variable with+       -- `working_dir` (see also #14695).+       working_dir <- getCurrentDirectory+       values <- lookupEnv name+       case values of+         Nothing  -> return list+         Just arr -> return $ list ++ splitEnv working_dir arr+    where+      splitEnv :: FilePath -> String -> [String]+      splitEnv working_dir value =+        case break (== envListSep) value of+          (x, []    ) ->+            [if null x then working_dir else x]+          (x, (_:xs)) ->+            (if null x then working_dir else x) : splitEnv working_dir xs+#if defined(mingw32_HOST_OS)+      envListSep = ';'+#else+      envListSep = ':'+#endif++-- ----------------------------------------------------------------------------+-- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)+++{- **********************************************************************++                Helper functions++  ********************************************************************* -}++maybePutSDoc :: Logger -> DynFlags -> SDoc -> IO ()+maybePutSDoc logger dflags s+    = when (verbosity dflags > 1) $+          putLogMsg logger dflags+              NoReason+              SevInteractive+              noSrcSpan+              $ withPprStyle defaultUserStyle s++maybePutStr :: Logger -> DynFlags -> String -> IO ()+maybePutStr logger dflags s = maybePutSDoc logger dflags (text s)++maybePutStrLn :: Logger -> DynFlags -> String -> IO ()+maybePutStrLn logger dflags s = maybePutSDoc logger dflags (text s <> text "\n")

+ GHC/Linker/MacOS.hs view

@@ -0,0 +1,176 @@+module GHC.Linker.MacOS+   ( runInjectRPaths+   , getUnitFrameworkOpts+   , getFrameworkOpts+   , loadFramework+   )+where++import GHC.Prelude+import GHC.Platform++import GHC.Driver.Session++import GHC.Unit.Types+import GHC.Unit.State+import GHC.Unit.Env++import GHC.SysTools.Tasks++import GHC.Runtime.Interpreter++import GHC.Utils.Exception+import GHC.Utils.Logger++import Data.List (isPrefixOf, nub, sort, intersperse, intercalate)+import Data.Char+import Data.Maybe+import Control.Monad (join, forM, filterM, void)+import System.Directory (doesFileExist, getHomeDirectory)+import System.FilePath ((</>), (<.>))+import Text.ParserCombinators.ReadP as Parser++-- | 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 truly 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 :: Logger -> DynFlags -> [FilePath] -> FilePath -> IO ()+-- Make sure to honour -fno-use-rpaths if set on darwin as well see #20004+runInjectRPaths _ dflags _ _ | not (gopt Opt_RPath dflags) = return ()+runInjectRPaths logger dflags lib_paths dylib = do+  info <- lines <$> askOtool logger 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 <- lines <$> askOtool logger dflags Nothing [Option "-l", Option dylib]+  let paths = mapMaybe get_rpath info+      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 logger dflags $ map Option $ "-add_rpath":(intersperse "-add_rpath" rpaths) ++ [dylib]++get_rpath :: String -> Maybe FilePath+get_rpath l = case readP_to_S rpath_parser l of+                [(rpath, "")] -> Just rpath+                _ -> Nothing+++rpath_parser :: ReadP FilePath+rpath_parser = do+  skipSpaces+  void $ string "path"+  void $ many1 (satisfy isSpace)+  rpath <- many get+  void $ many1 (satisfy isSpace)+  void $ string "(offset "+  void $ munch1 isDigit+  void $ Parser.char ')'+  skipSpaces+  return rpath+++getUnitFrameworkOpts :: UnitEnv -> [UnitId] -> IO [String]+getUnitFrameworkOpts unit_env dep_packages+  | platformUsesFrameworks (ue_platform unit_env) = do+        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_packages)+        let pkg_framework_path_opts = map ("-F" ++) (collectFrameworksDirs ps)+            pkg_framework_opts      = concat [ ["-framework", fw]+                                             | fw <- collectFrameworks ps+                                             ]+        return (pkg_framework_path_opts ++ pkg_framework_opts)++  | otherwise = return []++getFrameworkOpts :: DynFlags -> Platform -> [String]+getFrameworkOpts dflags platform+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts+  | otherwise = []+  where+    framework_paths     = frameworkPaths dflags+    framework_path_opts = map ("-F" ++) framework_paths++    frameworks     = cmdlineFrameworks dflags+    -- reverse because they're added in reverse order from the cmd line:+    framework_opts = concat [ ["-framework", fw]+                            | fw <- reverse frameworks ]+++{-+Note [macOS Big Sur dynamic libraries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++macOS Big Sur makes the following change to how frameworks are shipped+with the OS:++> New in macOS Big Sur 11 beta, the system ships with a built-in+> dynamic linker cache of all system-provided libraries.  As part of+> this change, copies of dynamic libraries are no longer present on+> the filesystem.  Code that attempts to check for dynamic library+> presence by looking for a file at a path or enumerating a directory+> will fail.  Instead, check for library presence by attempting to+> dlopen() the path, which will correctly check for the library in the+> cache. (62986286)++(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)++Therefore, the previous method of checking whether a library exists+before attempting to load it makes GHC.Linker.MacOS.loadFramework+fail to find frameworks installed at /System/Library/Frameworks.+Instead, any attempt to load a framework at runtime, such as by+passing -framework OpenGL to runghc or running code loading such a+framework with GHCi, fails with a 'not found' message.++GHC.Linker.MacOS.loadFramework now opportunistically loads the+framework libraries without checking for their existence first,+failing only if all attempts to load a given framework from any of the+various possible locations fail.  See also #18446, which this change+addresses.+-}++-- Darwin / MacOS X only: load a framework+-- a framework is a dynamic library packaged inside a directory of the same+-- name. They are searched for in different paths than normal libraries.+loadFramework :: Interp -> [FilePath] -> FilePath -> IO (Maybe String)+loadFramework interp extraPaths rootname+   = do { either_dir <- tryIO getHomeDirectory+        ; let homeFrameworkPath = case either_dir of+                                  Left _ -> []+                                  Right dir -> [dir </> "Library/Frameworks"]+              ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths+        ; errs <- findLoadDLL ps []+        ; return $ fmap (intercalate ", ") errs+        }+   where+     fwk_file = rootname <.> "framework" </> rootname++     -- sorry for the hardcoded paths, I hope they won't change anytime soon:+     defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]++     -- Try to call loadDLL for each candidate path.+     --+     -- See Note [macOS Big Sur dynamic libraries]+     findLoadDLL [] errs =+       -- Tried all our known library paths, but dlopen()+       -- has no built-in paths for frameworks: give up+       return $ Just errs+     findLoadDLL (p:ps) errs =+       do { dll <- loadDLL interp (p </> fwk_file)+          ; case dll of+              Nothing  -> return Nothing+              Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)+          }

+ GHC/Linker/Static.hs view

@@ -0,0 +1,335 @@+module GHC.Linker.Static+   ( linkBinary+   , linkBinary'+   , linkStaticLib+   , exeFileName+   )+where++import GHC.Prelude+import GHC.Platform+import GHC.Platform.Ways+import GHC.Settings++import GHC.SysTools+import GHC.SysTools.Ar++import GHC.Unit.Env+import GHC.Unit.Types+import GHC.Unit.Info+import GHC.Unit.State++import GHC.Utils.Logger+import GHC.Utils.Monad+import GHC.Utils.Misc+import GHC.Utils.TmpFs++import GHC.Linker.MacOS+import GHC.Linker.Unit+import GHC.Linker.Dynamic+import GHC.Linker.ExtraObj+import GHC.Linker.Windows++import GHC.Driver.Session++import System.FilePath+import System.Directory+import Control.Monad+import Data.Maybe++-----------------------------------------------------------------------------+-- Static linking, of .o files++-- The list of packages passed to link is the list of packages on+-- which this program depends, as discovered by the compilation+-- manager.  It is combined with the list of packages that the user+-- specifies on the command line with -package flags.+--+-- In one-shot linking mode, we can't discover the package+-- dependencies (because we haven't actually done any compilation or+-- read any interface files), so the user must explicitly specify all+-- the packages.++{-+Note [-Xlinker -rpath vs -Wl,-rpath]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-Wl takes a comma-separated list of options which in the case of+-Wl,-rpath -Wl,some,path,with,commas parses the path with commas+as separate options.+Buck, the build system, produces paths with commas in them.++-Xlinker doesn't have this disadvantage and as far as I can tell+it is supported by both gcc and clang. Anecdotally nvcc supports+-Xlinker, but not -Wl.+-}++linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()+linkBinary = linkBinary' False++linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()+linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do+    let platform   = ue_platform unit_env+        unit_state = ue_units unit_env+        toolSettings' = toolSettings dflags+        verbFlags = getVerbFlags dflags+        output_fn = exeFileName platform staticLink (outputFile dflags)++    -- get the full list of packages to link with, by combining the+    -- explicit packages with the auto packages and all of their+    -- dependencies, and eliminating duplicates.++    full_output_fn <- if isAbsolute output_fn+                      then return output_fn+                      else do d <- getCurrentDirectory+                              return $ normalise (d </> output_fn)+    pkgs <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)+    let pkg_lib_paths     = collectLibraryDirs (ways dflags) pkgs+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths+        get_pkg_lib_path_opts l+         | osElfTarget (platformOS platform) &&+           dynLibLoader dflags == SystemDependent &&+           WayDyn `elem` ways dflags+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags+                            then "$ORIGIN" </>+                                 (l `makeRelativeTo` full_output_fn)+                            else l+                  -- See Note [-Xlinker -rpath vs -Wl,-rpath]+                  rpath = if useXLinkerRPath dflags (platformOS platform)+                          then ["-Xlinker", "-rpath", "-Xlinker", libpath]+                          else []+                  -- Solaris 11's linker does not support -rpath-link option. It silently+                  -- ignores it and then complains about next option which is -l<some+                  -- dir> as being a directory and not expected object file, E.g+                  -- ld: elf error: file+                  -- /tmp/ghc-src/libraries/base/dist-install/build:+                  -- elf_begin: I/O error: region read: Is a directory+                  rpathlink = if (platformOS platform) == OSSolaris2+                              then []+                              else ["-Xlinker", "-rpath-link", "-Xlinker", l]+              in ["-L" ++ l] ++ rpathlink ++ rpath+         | osMachOTarget (platformOS platform) &&+           dynLibLoader dflags == SystemDependent &&+           WayDyn `elem` ways dflags &&+           useXLinkerRPath dflags (platformOS platform)+            = let libpath = if gopt Opt_RelativeDynlibPaths dflags+                            then "@loader_path" </>+                                 (l `makeRelativeTo` full_output_fn)+                            else l+              in ["-L" ++ l] ++ ["-Xlinker", "-rpath", "-Xlinker", libpath]+         | otherwise = ["-L" ++ l]++    pkg_lib_path_opts <-+      if gopt Opt_SingleLibFolder dflags+      then do+        libs <- getLibs dflags unit_env dep_units+        tmpDir <- newTempDir logger tmpfs dflags+        sequence_ [ copyFile lib (tmpDir </> basename)+                  | (lib, basename) <- libs]+        return [ "-L" ++ tmpDir ]+      else pure pkg_lib_path_opts++    let+      dead_strip+        | gopt Opt_WholeArchiveHsLibs dflags = []+        | otherwise = if osSubsectionsViaSymbols (platformOS platform)+                        then ["-Wl,-dead_strip"]+                        else []+    let lib_paths = libraryPaths dflags+    let lib_path_opts = map ("-L"++) lib_paths++    extraLinkObj <- maybeToList <$> mkExtraObjToLinkIntoBinary logger tmpfs dflags unit_state+    noteLinkObjs <- mkNoteObjsToLinkIntoBinary logger tmpfs dflags unit_env dep_units++    let+      (pre_hs_libs, post_hs_libs)+        | gopt Opt_WholeArchiveHsLibs dflags+        = if platformOS platform == OSDarwin+            then (["-Wl,-all_load"], [])+              -- OS X does not have a flag to turn off -all_load+            else (["-Wl,--whole-archive"], ["-Wl,--no-whole-archive"])+        | otherwise+        = ([],[])++    pkg_link_opts <- do+        (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags unit_env dep_units+        return $ if staticLink+            then package_hs_libs -- If building an executable really means making a static+                                 -- library (e.g. iOS), then we only keep the -l options for+                                 -- HS packages, because libtool doesn't accept other options.+                                 -- In the case of iOS these need to be added by hand to the+                                 -- final link in Xcode.+            else other_flags ++ dead_strip+                  ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs+                  ++ extra_libs+                 -- -Wl,-u,<sym> contained in other_flags+                 -- needs to be put before -l<package>,+                 -- otherwise Solaris linker fails linking+                 -- a binary with unresolved symbols in RTS+                 -- which are defined in base package+                 -- the reason for this is a note in ld(1) about+                 -- '-u' option: "The placement of this option+                 -- on the command line is significant.+                 -- This option must be placed before the library+                 -- that defines the symbol."++    -- frameworks+    pkg_framework_opts <- getUnitFrameworkOpts unit_env dep_units+    let framework_opts = getFrameworkOpts dflags platform++        -- probably _stub.o files+    let extra_ld_inputs = ldInputs dflags++    rc_objs <- case platformOS platform of+      OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn+      _                                       -> return []++    let link dflags args | staticLink = GHC.SysTools.runLibtool logger dflags args+                         | platformOS platform == OSDarwin+                            = do+                                 GHC.SysTools.runLink logger tmpfs dflags args+                                 GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn+                         | otherwise+                            = GHC.SysTools.runLink logger tmpfs dflags args++    link dflags (+                       map GHC.SysTools.Option verbFlags+                      ++ [ GHC.SysTools.Option "-o"+                         , GHC.SysTools.FileOption "" output_fn+                         ]+                      ++ libmLinkOpts+                      ++ map GHC.SysTools.Option (+                         []++                      -- See Note [No PIE when linking]+                      ++ picCCOpts dflags++                      -- Permit the linker to auto link _symbol to _imp_symbol.+                      -- This lets us link against DLLs without needing an "import library".+                      ++ (if platformOS platform == OSMinGW32+                          then ["-Wl,--enable-auto-import"]+                          else [])++                      -- '-no_compact_unwind'+                      -- C++/Objective-C exceptions cannot use optimised+                      -- stack unwinding code. The optimised form is the+                      -- default in Xcode 4 on at least x86_64, and+                      -- without this flag we're also seeing warnings+                      -- like+                      --     ld: warning: could not create compact unwind for .LFB3: non-standard register 5 being saved in prolog+                      -- on x86.+                      ++ (if toolSettings_ldSupportsCompactUnwind toolSettings' &&+                             not staticLink &&+                             (platformOS platform == OSDarwin) &&+                             case platformArch platform of+                               ArchX86     -> True+                               ArchX86_64  -> True+                               ArchARM {}  -> True+                               ArchAArch64 -> True+                               _ -> False+                          then ["-Wl,-no_compact_unwind"]+                          else [])++                      -- '-Wl,-read_only_relocs,suppress'+                      -- ld gives loads of warnings like:+                      --     ld: warning: text reloc in _base_GHCziArr_unsafeArray_info to _base_GHCziArr_unsafeArray_closure+                      -- when linking any program. We're not sure+                      -- whether this is something we ought to fix, but+                      -- for now this flags silences them.+                      ++ (if platformOS   platform == OSDarwin &&+                             platformArch platform == ArchX86 &&+                             not staticLink+                          then ["-Wl,-read_only_relocs,suppress"]+                          else [])++                      ++ (if toolSettings_ldIsGnuLd toolSettings' &&+                             not (gopt Opt_WholeArchiveHsLibs dflags)+                          then ["-Wl,--gc-sections"]+                          else [])++                      ++ o_files+                      ++ lib_path_opts)+                      ++ extra_ld_inputs+                      ++ map GHC.SysTools.Option (+                         rc_objs+                      ++ framework_opts+                      ++ pkg_lib_path_opts+                      ++ extraLinkObj+                      ++ noteLinkObjs+                      ++ pkg_link_opts+                      ++ pkg_framework_opts+                      ++ (if platformOS platform == OSDarwin+                          --  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 [])+                    ))++-- | Linking a static lib will not really link anything. It will merely produce+-- a static archive of all dependent static libraries. The resulting library+-- will still need to be linked with any remaining link flags.+linkStaticLib :: Logger -> DynFlags -> UnitEnv -> [String] -> [UnitId] -> IO ()+linkStaticLib logger dflags unit_env o_files dep_units = do+  let platform  = ue_platform unit_env+      extra_ld_inputs = [ f | FileOption _ f <- ldInputs dflags ]+      modules = o_files ++ extra_ld_inputs+      output_fn = exeFileName platform True (outputFile dflags)++  full_output_fn <- if isAbsolute output_fn+                    then return output_fn+                    else do d <- getCurrentDirectory+                            return $ normalise (d </> output_fn)+  output_exists <- doesFileExist full_output_fn+  (when output_exists) $ removeFile full_output_fn++  pkg_cfgs_init <- mayThrowUnitErr (preloadUnitsInfo' unit_env dep_units)++  let pkg_cfgs+        | gopt Opt_LinkRts dflags+        = pkg_cfgs_init+        | otherwise+        = filter ((/= rtsUnitId) . unitId) pkg_cfgs_init++  archives <- concatMapM (collectArchives dflags) pkg_cfgs++  ar <- foldl mappend+        <$> (Archive <$> mapM loadObj modules)+        <*> mapM loadAr archives++  if toolSettings_ldIsGnuLd (toolSettings dflags)+    then writeGNUAr output_fn $ afilter (not . isGNUSymdef) ar+    else writeBSDAr output_fn $ afilter (not . isBSDSymdef) ar++  -- run ranlib over the archive. write*Ar does *not* create the symbol index.+  runRanlib logger dflags [GHC.SysTools.FileOption "" output_fn]++++-- | Compute the output file name of a program.+--+-- StaticLink boolean is used to indicate if the program is actually a static library+-- (e.g., on iOS).+--+-- Use the provided filename (if any), otherwise use "main.exe" (Windows),+-- "a.out (otherwise without StaticLink set), "liba.a". In every case, add the+-- extension if it is missing.+exeFileName :: Platform -> Bool -> Maybe FilePath -> FilePath+exeFileName platform staticLink output_fn+  | Just s <- output_fn =+      case platformOS platform of+          OSMinGW32 -> s <?.> "exe"+          _         -> if staticLink+                         then s <?.> "a"+                         else s+  | otherwise =+      if platformOS platform == OSMinGW32+      then "main.exe"+      else if staticLink+           then "liba.a"+           else "a.out"+ where s <?.> ext | null (takeExtension s) = s <.> ext+                  | otherwise              = s

+ GHC/Linker/Types.hs view

@@ -0,0 +1,176 @@+-----------------------------------------------------------------------------+--+-- Types for the linkers and the loader+--+-- (c) The University of Glasgow 2019+--+-----------------------------------------------------------------------------++module GHC.Linker.Types+   ( Loader (..)+   , LoaderState (..)+   , uninitializedLoader+   , Linkable(..)+   , Unlinked(..)+   , SptEntry(..)+   , isObjectLinkable+   , linkableObjs+   , isObject+   , nameOfObject+   , isInterpretable+   , byteCodeOfObject+   )+where++import GHC.Prelude+import GHC.Unit                ( UnitId, Module )+import GHC.ByteCode.Types      ( ItblEnv, CompiledByteCode )+import GHC.Fingerprint.Type    ( Fingerprint )+import GHCi.RemoteTypes        ( ForeignHValue )++import GHC.Types.Var           ( Id )+import GHC.Types.Name.Env      ( NameEnv )+import GHC.Types.Name          ( Name )++import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Concurrent.MVar+import Data.Time               ( UTCTime )+++{- **********************************************************************++                        The Loader's state++  ********************************************************************* -}++{-+The loader state *must* match the actual state of the C dynamic linker at all+times.++The MVar used to hold the LoaderState contains a Maybe LoaderState. The MVar+serves to ensure mutual exclusion between multiple loaded copies of the GHC+library. The Maybe may be Nothing to indicate that the linker has not yet been+initialised.++The LoaderState maps Names to actual closures (for interpreted code only), for+use during linking.+-}++newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }++data LoaderState = LoaderState+    { closure_env :: ClosureEnv+        -- ^ Current global mapping from Names to their true values++    , itbl_env    :: !ItblEnv+        -- ^ The current global mapping from RdrNames of DataCons to+        -- info table addresses.+        -- When a new Unlinked is linked into the running image, or an existing+        -- module in the image is replaced, the itbl_env must be updated+        -- appropriately.++    , bcos_loaded :: ![Linkable]+        -- ^ The currently loaded interpreted modules (home package)++    , objs_loaded :: ![Linkable]+        -- ^ And the currently-loaded compiled modules (home package)++    , pkgs_loaded :: ![UnitId]+        -- ^ The currently-loaded packages; always object code+        -- Held, as usual, in dependency order; though I am not sure if+        -- that is really important++    , temp_sos :: ![(FilePath, String)]+        -- ^ We need to remember the name of previous temporary DLL/.so+        -- libraries so we can link them (see #10322)+    }++uninitializedLoader :: IO Loader+uninitializedLoader = Loader <$> newMVar Nothing++type ClosureEnv = NameEnv (Name, ForeignHValue)++-- | Information we can use to dynamically link modules into the compiler+data Linkable = LM {+  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built+                                        -- (i.e. when the bytecodes were produced,+                                        --       or the mod date on the files)+  linkableModule   :: Module,           -- ^ The linkable module itself+  linkableUnlinked :: [Unlinked]+    -- ^ Those files and chunks of code we have yet to link.+    --+    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.+    -- If this list is empty, the Linkable represents a fake linkable, which+    -- is generated with no backend is used to avoid recompiling modules.+    --+    -- ToDo: Do items get removed from this list when they get linked?+ }++instance Outputable Linkable where+  ppr (LM when_made mod unlinkeds)+     = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)+       $$ nest 3 (ppr unlinkeds)++-- | Objects which have yet to be linked by the compiler+data Unlinked+  = DotO FilePath      -- ^ An object file (.o)+  | DotA FilePath      -- ^ Static archive file (.a)+  | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)+  | BCOs CompiledByteCode+         [SptEntry]    -- ^ A byte-code object, lives only in memory. Also+                       -- carries some static pointer table entries which+                       -- should be loaded along with the BCOs.+                       -- See Note [Grant plan for static forms] in+                       -- "GHC.Iface.Tidy.StaticPtrTable".++instance Outputable Unlinked where+  ppr (DotO path)   = text "DotO" <+> text path+  ppr (DotA path)   = text "DotA" <+> text path+  ppr (DotDLL path) = text "DotDLL" <+> text path+  ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt++-- | An entry to be inserted into a module's static pointer table.+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+data SptEntry = SptEntry Id Fingerprint++instance Outputable SptEntry where+  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr+++isObjectLinkable :: Linkable -> Bool+isObjectLinkable l = not (null unlinked) && all isObject unlinked+  where unlinked = linkableUnlinked l+        -- A linkable with no Unlinked's is treated as a BCO.  We can+        -- generate a linkable with no Unlinked's as a result of+        -- compiling a module in NoBackend mode, and this choice+        -- happens to work well with checkStability in module GHC.++linkableObjs :: Linkable -> [FilePath]+linkableObjs l = [ f | DotO f <- linkableUnlinked l ]++-------------------------------------------++-- | Is this an actual file on disk we can link in somehow?+isObject :: Unlinked -> Bool+isObject (DotO _)   = True+isObject (DotA _)   = True+isObject (DotDLL _) = True+isObject _          = False++-- | Is this a bytecode linkable with no file on disk?+isInterpretable :: Unlinked -> Bool+isInterpretable = not . isObject++-- | Retrieve the filename of the linkable if possible. Panic if it is a byte-code object+nameOfObject :: Unlinked -> FilePath+nameOfObject (DotO fn)   = fn+nameOfObject (DotA fn)   = fn+nameOfObject (DotDLL fn) = fn+nameOfObject other       = pprPanic "nameOfObject" (ppr other)++-- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable+byteCodeOfObject :: Unlinked -> CompiledByteCode+byteCodeOfObject (BCOs bc _) = bc+byteCodeOfObject other       = pprPanic "byteCodeOfObject" (ppr other)

+ GHC/Linker/Unit.hs view

@@ -0,0 +1,63 @@++-- | Linking Haskell units+module GHC.Linker.Unit+   ( collectLinkOpts+   , collectArchives+   , getUnitLinkOpts+   , getLibs+   )+where++import GHC.Prelude+import GHC.Platform.Ways+import GHC.Unit.Types+import GHC.Unit.Info+import GHC.Unit.State+import GHC.Unit.Env+import GHC.Utils.Misc++import qualified GHC.Data.ShortText as ST++import GHC.Driver.Session++import Control.Monad+import System.Directory+import System.FilePath++-- | Find all the link options in these and the preload packages,+-- returning (package hs lib options, extra library options, other flags)+getUnitLinkOpts :: DynFlags -> UnitEnv -> [UnitId] -> IO ([String], [String], [String])+getUnitLinkOpts dflags unit_env pkgs = do+    ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs+    return (collectLinkOpts dflags ps)++collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])+collectLinkOpts dflags ps =+    (+        concatMap (map ("-l" ++) . unitHsLibs (ghcNameVersion dflags) (ways dflags)) ps,+        concatMap (map ("-l" ++) . map ST.unpack . unitExtDepLibsSys) ps,+        concatMap (map ST.unpack . unitLinkerOptions) ps+    )++collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]+collectArchives dflags pc =+  filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")+                        | searchPath <- searchPaths+                        , lib <- libs ]+  where searchPaths = ordNub . filter notNull . libraryDirsForWay (ways dflags) $ pc+        libs        = unitHsLibs (ghcNameVersion dflags) (ways dflags) pc ++ map ST.unpack (unitExtDepLibsSys pc)++-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.+libraryDirsForWay :: Ways -> UnitInfo -> [String]+libraryDirsForWay ws+  | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs+  | otherwise        = map ST.unpack . unitLibraryDirs++getLibs :: DynFlags -> UnitEnv -> [UnitId] -> IO [(String,String)]+getLibs dflags unit_env pkgs = do+  ps <- mayThrowUnitErr $ preloadUnitsInfo' unit_env pkgs+  fmap concat . forM ps $ \p -> do+    let candidates = [ (l </> f, f) | l <- collectLibraryDirs (ways dflags) [p]+                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> unitHsLibs (ghcNameVersion dflags) (ways dflags) p ]+    filterM (doesFileExist . fst) candidates+

+ GHC/Linker/Windows.hs view

@@ -0,0 +1,67 @@+module GHC.Linker.Windows+   ( maybeCreateManifest+   )+where++import GHC.Prelude+import GHC.SysTools+import GHC.Driver.Session+import GHC.Utils.TmpFs+import GHC.Utils.Logger++import System.FilePath+import System.Directory++maybeCreateManifest+   :: Logger+   -> TmpFs+   -> DynFlags+   -> FilePath      -- ^ filename of executable+   -> IO [FilePath] -- ^ extra objects to embed, maybe+maybeCreateManifest logger tmpfs dflags exe_filename = do+   let manifest_filename = exe_filename <.> "manifest"+       manifest =+         "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n\+         \  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n\+         \  <assemblyIdentity version=\"1.0.0.0\"\n\+         \     processorArchitecture=\"X86\"\n\+         \     name=\"" ++ dropExtension exe_filename ++ "\"\n\+         \     type=\"win32\"/>\n\n\+         \  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n\+         \    <security>\n\+         \      <requestedPrivileges>\n\+         \        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n\+         \        </requestedPrivileges>\n\+         \       </security>\n\+         \  </trustInfo>\n\+         \</assembly>\n"++   writeFile manifest_filename manifest++   -- Windows will find the manifest file if it is named+   -- foo.exe.manifest. However, for extra robustness, and so that+   -- we can move the binary around, we can embed the manifest in+   -- the binary itself using windres:+   if not (gopt Opt_EmbedManifest dflags)+      then return []+      else do+         rc_filename <- newTempName logger tmpfs dflags TFL_CurrentModule "rc"+         rc_obj_filename <-+           newTempName logger tmpfs dflags TFL_GhcSession (objectSuf dflags)++         writeFile rc_filename $+             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"+               -- magic numbers :-)+               -- show is a bit hackish above, but we need to escape the+               -- backslashes in the path.++         runWindres logger dflags $ map GHC.SysTools.Option $+               ["--input="++rc_filename,+                "--output="++rc_obj_filename,+                "--output-format=coff"]+               -- no FileOptions here: windres doesn't like seeing+               -- backslashes, apparently++         removeFile manifest_filename++         return [rc_obj_filename]

GHC/Llvm/MetaData.hs view

@@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}  module GHC.Llvm.MetaData where

GHC/Llvm/Ppr.hs view

@@ -41,6 +41,7 @@ import Data.Int import Data.List ( intersperse ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique import GHC.Data.FastString

GHC/Llvm/Types.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP        #-} {-# LANGUAGE LambdaCase #-}  --------------------------------------------------------------------------------@@ -18,6 +18,7 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique  -- from NCG

GHC/Parser.y view

@@ -21,4004 +21,4413 @@ -- and then parse that string: -- -- @---     runParser :: DynFlags -> String -> P a -> ParseResult a---     runParser flags str parser = unP parser parseState---     where---       filename = "\<interactive\>"---       location = mkRealSrcLoc (mkFastString filename) 1 1---       buffer = stringToStringBuffer str---       parseState = mkPState flags buffer location--- @-module GHC.Parser-   ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack-   , parseDeclaration, parseExpression, parsePattern-   , parseTypeSignature-   , parseStmt, parseIdentifier-   , parseType, parseHeader-   , parseModuleNoHaddock-   )-where---- base-import Control.Monad    ( unless, liftM, when, (<=<) )-import GHC.Exts-import Data.Char-import Data.Maybe       ( maybeToList )-import Control.Monad    ( mplus )-import Control.Applicative ((<$))-import qualified Prelude -- for happy-generated code---- compiler-import GHC.Hs--import GHC.Driver.Phases  ( HscSource(..) )-import GHC.Driver.Types   ( IsBootInterface(..), WarningTxt(..) )-import GHC.Driver.Session-import GHC.Driver.Backpack.Syntax-import GHC.Unit.Info---- compiler/utils-import GHC.Data.OrdList-import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula(..), mkTrue )-import GHC.Data.FastString-import GHC.Data.Maybe          ( isJust, orElse )-import GHC.Utils.Outputable-import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )-import GHC.Prelude---- compiler/basicTypes-import GHC.Types.Name.Reader-import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, startsWithUnderscore )-import GHC.Core.DataCon          ( DataCon, dataConName )-import GHC.Types.SrcLoc-import GHC.Unit.Module-import GHC.Types.Basic-import GHC.Types.ForeignCall-import GHC.Hs.Doc--import GHC.Core.Type    ( unrestrictedFunTyCon, Mult(..), Specificity(..) )-import GHC.Core.Class   ( FunDep )---- compiler/parser-import GHC.Parser.PostProcess-import GHC.Parser.PostProcess.Haddock-import GHC.Parser.Lexer-import GHC.Parser.Annotation--import GHC.Tc.Types.Evidence  ( emptyTcEvBinds )---- compiler/prelude-import GHC.Builtin.Types.Prim ( eqPrimTyCon )-import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,-                           unboxedUnitTyCon, unboxedUnitDataCon,-                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR,-                           manyDataConTyCon)-}--%expect 232 -- shift/reduce conflicts--{- Last updated: 08 June 2020--If you modify this parser and add a conflict, please update this comment.-You can learn more about the conflicts by passing 'happy' the -i flag:--    happy -agc --strict compiler/GHC/Parser.y -idetailed-info--How is this section formatted? Look up the state the conflict is-reported at, and copy the list of applicable rules (at the top, without the-rule numbers).  Mark *** for the rule that is the conflicting reduction (that-is, the interpretation which is NOT taken).  NB: Happy doesn't print a rule-in a state if it is empty, but you should include it in the list (you can-look these up in the Grammar section of the info file).--Obviously the state numbers are not stable across modifications to the parser,-the idea is to reproduce enough information on each conflict so you can figure-out what happened if the states were renumbered.  Try not to gratuitously move-productions around in this file.-----------------------------------------------------------------------------------state 60 contains 1 shift/reduce conflict.--        context -> btype .-    *** type -> btype .-        type -> btype . '->' ctype--    Conflicts: '->'-----------------------------------------------------------------------------------state 61 contains 46 shift/reduce conflicts.--    *** btype -> tyapps .-        tyapps -> tyapps . tyapp--    Conflicts: '_' ':' '~' '!' '.' '`' '{' '[' '(' '(#' '`' TYPEAPP-      SIMPLEQUOTE VARID CONID VARSYM CONSYM QCONID QVARSYM QCONSYM-      STRING INTEGER TH_ID_SPLICE '$(' TH_QUASIQUOTE TH_QQUASIQUOTE-      and all the special ids.--Example ambiguity:-    'if x then y else z :: F a'--Shift parses as (per longest-parse rule):-    'if x then y else z :: (F a)'-----------------------------------------------------------------------------------state 143 contains 14 shift/reduce conflicts.--        exp -> infixexp . '::' sigtype-        exp -> infixexp . '-<' exp-        exp -> infixexp . '>-' exp-        exp -> infixexp . '-<<' exp-        exp -> infixexp . '>>-' exp-    *** exp -> infixexp .-        infixexp -> infixexp . qop exp10--    Conflicts: ':' '::' '-' '!' '-<' '>-' '-<<' '>>-'-               '.' '`' '*' VARSYM CONSYM QVARSYM QCONSYM--Examples of ambiguity:-    'if x then y else z -< e'-    'if x then y else z :: T'-    'if x then y else z + 1' (NB: '+' is in VARSYM)--Shift parses as (per longest-parse rule):-    'if x then y else (z -< T)'-    'if x then y else (z :: T)'-    'if x then y else (z + 1)'-----------------------------------------------------------------------------------state 146 contains 66 shift/reduce conflicts.--    *** exp10 -> fexp .-        fexp -> fexp . aexp-        fexp -> fexp . TYPEAPP atype--    Conflicts: TYPEAPP and all the tokens that can start an aexp--Examples of ambiguity:-    'if x then y else f z'-    'if x then y else f @ z'--Shift parses as (per longest-parse rule):-    'if x then y else (f z)'-    'if x then y else (f @ z)'-----------------------------------------------------------------------------------state 200 contains 27 shift/reduce conflicts.--        aexp2 -> TH_TY_QUOTE . tyvar-        aexp2 -> TH_TY_QUOTE . gtycon-    *** aexp2 -> TH_TY_QUOTE .--    Conflicts: two single quotes is error syntax with specific error message.--Example of ambiguity:-    'x = '''-    'x = ''a'-    'x = ''T'--Shift parses as (per longest-parse rule):-    'x = ''a'-    'x = ''T'-----------------------------------------------------------------------------------state 294 contains 1 shift/reduce conflicts.--        rule -> STRING . rule_activation rule_forall infixexp '=' exp--    Conflict: '[' (empty rule_activation reduces)--We don't know whether the '[' starts the activation or not: it-might be the start of the declaration with the activation being-empty.  --SDM 1/4/2002--Example ambiguity:-    '{-# RULE [0] f = ... #-}'--We parse this as having a [0] rule activation for rewriting 'f', rather-a rule instructing how to rewrite the expression '[0] f'.-----------------------------------------------------------------------------------state 305 contains 1 shift/reduce conflict.--    *** type -> btype .-        type -> btype . '->' ctype--    Conflict: '->'--Same as state 61 but without contexts.-----------------------------------------------------------------------------------state 349 contains 1 shift/reduce conflicts.--        tup_exprs -> commas . tup_tail-        sysdcon_nolist -> '(' commas . ')'-        commas -> commas . ','--    Conflict: ')' (empty tup_tail reduces)--A tuple section with NO free variables '(,,)' is indistinguishable-from the Haskell98 data constructor for a tuple.  Shift resolves in-favor of sysdcon, which is good because a tuple section will get rejected-if -XTupleSections is not specified.--See also Note [ExplicitTuple] in GHC.Hs.Expr.-----------------------------------------------------------------------------------state 407 contains 1 shift/reduce conflicts.--        tup_exprs -> commas . tup_tail-        sysdcon_nolist -> '(#' commas . '#)'-        commas -> commas . ','--    Conflict: '#)' (empty tup_tail reduces)--Same as State 354 for unboxed tuples.-----------------------------------------------------------------------------------state 416 contains 66 shift/reduce conflicts.--    *** exp10 -> '-' fexp .-        fexp -> fexp . aexp-        fexp -> fexp . TYPEAPP atype--Same as 146 but with a unary minus.-----------------------------------------------------------------------------------state 472 contains 1 shift/reduce conflict.--        oqtycon -> '(' qtyconsym . ')'-    *** qtyconop -> qtyconsym .--    Conflict: ')'--Example ambiguity: 'foo :: (:%)'--Shift means '(:%)' gets parsed as a type constructor, rather than than a-parenthesized infix type expression of length 1.-----------------------------------------------------------------------------------state 665 contains 1 shift/reduce conflicts.--    *** aexp2 -> ipvar .-        dbind -> ipvar . '=' exp--    Conflict: '='--Example ambiguity: 'let ?x ...'--The parser can't tell whether the ?x is the lhs of a normal binding or-an implicit binding.  Fortunately, resolving as shift gives it the only-sensible meaning, namely the lhs of an implicit binding.-----------------------------------------------------------------------------------state 750 contains 1 shift/reduce conflicts.--        rule -> STRING rule_activation . rule_forall infixexp '=' exp--    Conflict: 'forall' (empty rule_forall reduces)--Example ambiguity: '{-# RULES "name" forall = ... #-}'--'forall' is a valid variable name---we don't know whether-to treat a forall on the input as the beginning of a quantifier-or the beginning of the rule itself.  Resolving to shift means-it's always treated as a quantifier, hence the above is disallowed.-This saves explicitly defining a grammar for the rule lhs that-doesn't include 'forall'.-----------------------------------------------------------------------------------state 986 contains 1 shift/reduce conflicts.--        transformqual -> 'then' 'group' . 'using' exp-        transformqual -> 'then' 'group' . 'by' exp 'using' exp-    *** special_id -> 'group' .--    Conflict: 'by'-----------------------------------------------------------------------------------state 1084 contains 1 shift/reduce conflicts.--        rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'-    *** rule_foralls -> 'forall' rule_vars '.' .--    Conflict: 'forall'--Example ambiguity: '{-# RULES "name" forall a. forall ... #-}'--Here the parser cannot tell whether the second 'forall' is the beginning of-a term-level quantifier, for example:--'{-# RULES "name" forall a. forall x. id @a x = x #-}'--or a valid variable named 'forall', for example a function @:: Int -> Int@--'{-# RULES "name" forall a. forall 0 = 0 #-}'--Shift means the parser only allows the former. Also see conflict 753 above.-----------------------------------------------------------------------------------state 1285 contains 1 shift/reduce conflict.--        constrs1 -> constrs1 maybe_docnext '|' . maybe_docprev constr--   Conflict: DOCPREV-----------------------------------------------------------------------------------state 1375 contains 1 shift/reduce conflict.--    *** atype -> tyvar .-        tv_bndr -> '(' tyvar . '::' kind ')'--    Conflict: '::'--Example ambiguity: 'class C a where type D a = ( a :: * ...'--Here the parser cannot tell whether this is specifying a default for the-associated type like:--'class C a where type D a = ( a :: * ); type D a'--or it is an injectivity signature like:--'class C a where type D a = ( r :: * ) | r -> a'--Shift means the parser only allows the latter.------------------------------------------------------------------------------------ API Annotations-----A lot of the productions are now cluttered with calls to-aa,am,ams,amms etc.--These are helper functions to make sure that the locations of the-various keywords such as do / let / in are captured for use by tools-that want to do source to source conversions, such as refactorers or-structured editors.--The helper functions are defined at the bottom of this file.--See-  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and-  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations-for some background.--If you modify the parser and want to ensure that the API annotations are processed-correctly, see the README in (REPO)/utils/check-api-annotations for details on-how to set up a test using the check-api-annotations utility, and interpret the-output it generates.--Note [Parsing lists]-----------------------You might be wondering why we spend so much effort encoding our lists this-way:--importdecls-        : importdecls ';' importdecl-        | importdecls ';'-        | importdecl-        | {- empty -}--This might seem like an awfully roundabout way to declare a list; plus, to add-insult to injury you have to reverse the results at the end.  The answer is that-left recursion prevents us from running out of stack space when parsing long-sequences.  See: https://www.haskell.org/happy/doc/html/sec-sequences.html for-more guidance.--By adding/removing branches, you can affect what lists are accepted.  Here-are the most common patterns, rewritten as regular expressions for clarity:--    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)-    xs : xs ';' x-       | xs ';'-       | x-       | {- empty -}--    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)-    xs : xs ';' x-       | xs ';'-       | x--    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)-    alts : alts1-         | ';' alts-    alts1 : alts1 ';' alt-          | alts1 ';'-          | alt--    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)-    xs : x-       | x ',' xs---- --------------------------------------------------------------------------------}--%token- '_'            { L _ ITunderscore }            -- Haskell keywords- 'as'           { L _ ITas }- 'case'         { L _ ITcase }- 'class'        { L _ ITclass }- 'data'         { L _ ITdata }- 'default'      { L _ ITdefault }- 'deriving'     { L _ ITderiving }- 'else'         { L _ ITelse }- 'hiding'       { L _ IThiding }- 'if'           { L _ ITif }- 'import'       { L _ ITimport }- 'in'           { L _ ITin }- 'infix'        { L _ ITinfix }- 'infixl'       { L _ ITinfixl }- 'infixr'       { L _ ITinfixr }- 'instance'     { L _ ITinstance }- 'let'          { L _ ITlet }- 'module'       { L _ ITmodule }- 'newtype'      { L _ ITnewtype }- 'of'           { L _ ITof }- 'qualified'    { L _ ITqualified }- 'then'         { L _ ITthen }- 'type'         { L _ ITtype }- 'where'        { L _ ITwhere }-- 'forall'       { L _ (ITforall _) }                -- GHC extension keywords- 'foreign'      { L _ ITforeign }- 'export'       { L _ ITexport }- 'label'        { L _ ITlabel }- 'dynamic'      { L _ ITdynamic }- 'safe'         { L _ ITsafe }- 'interruptible' { L _ ITinterruptible }- 'unsafe'       { L _ ITunsafe }- 'family'       { L _ ITfamily }- 'role'         { L _ ITrole }- 'stdcall'      { L _ ITstdcallconv }- 'ccall'        { L _ ITccallconv }- 'capi'         { L _ ITcapiconv }- 'prim'         { L _ ITprimcallconv }- 'javascript'   { L _ ITjavascriptcallconv }- 'proc'         { L _ ITproc }          -- for arrow notation extension- 'rec'          { L _ ITrec }           -- for arrow notation extension- 'group'    { L _ ITgroup }     -- for list transform extension- 'by'       { L _ ITby }        -- for list transform extension- 'using'    { L _ ITusing }     -- for list transform extension- 'pattern'      { L _ ITpattern } -- for pattern synonyms- 'static'       { L _ ITstatic }  -- for static pointers extension- 'stock'        { L _ ITstock }    -- for DerivingStrategies extension- 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension- 'via'          { L _ ITvia }      -- for DerivingStrategies extension-- 'unit'         { L _ ITunit }- 'signature'    { L _ ITsignature }- 'dependency'   { L _ ITdependency }-- '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE- '{-# SPECIALISE'         { L _ (ITspec_prag _) }- '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }- '{-# SOURCE'             { L _ (ITsource_prag _) }- '{-# RULES'              { L _ (ITrules_prag _) }- '{-# SCC'                { L _ (ITscc_prag _)}- '{-# GENERATED'          { L _ (ITgenerated_prag _) }- '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }- '{-# WARNING'            { L _ (ITwarning_prag _) }- '{-# UNPACK'             { L _ (ITunpack_prag _) }- '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }- '{-# ANN'                { L _ (ITann_prag _) }- '{-# MINIMAL'            { L _ (ITminimal_prag _) }- '{-# CTYPE'              { L _ (ITctype _) }- '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }- '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }- '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }- '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }- '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }- '#-}'                    { L _ ITclose_prag }-- '..'           { L _ ITdotdot }                        -- reserved symbols- ':'            { L _ ITcolon }- '::'           { L _ (ITdcolon _) }- '='            { L _ ITequal }- '\\'           { L _ ITlam }- 'lcase'        { L _ ITlcase }- '|'            { L _ ITvbar }- '<-'           { L _ (ITlarrow _) }- '->'           { L _ (ITrarrow _) }- '->.'          { L _ ITlolly }- TIGHT_INFIX_AT { L _ ITat }- '=>'           { L _ (ITdarrow _) }- '-'            { L _ ITminus }- PREFIX_TILDE   { L _ ITtilde }- PREFIX_BANG    { L _ ITbang }- PREFIX_MINUS   { L _ ITprefixminus }- '*'            { L _ (ITstar _) }- '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation- '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation- '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation- '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation- '.'            { L _ ITdot }- PREFIX_AT      { L _ ITtypeApp }- PREFIX_PERCENT { L _ ITpercent }                   -- for linear types-- '{'            { L _ ITocurly }                        -- special symbols- '}'            { L _ ITccurly }- vocurly        { L _ ITvocurly } -- virtual open curly (from layout)- vccurly        { L _ ITvccurly } -- virtual close curly (from layout)- '['            { L _ ITobrack }- ']'            { L _ ITcbrack }- '('            { L _ IToparen }- ')'            { L _ ITcparen }- '(#'           { L _ IToubxparen }- '#)'           { L _ ITcubxparen }- '(|'           { L _ (IToparenbar _) }- '|)'           { L _ (ITcparenbar _) }- ';'            { L _ ITsemi }- ','            { L _ ITcomma }- '`'            { L _ ITbackquote }- SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x-- VARID          { L _ (ITvarid    _) }          -- identifiers- CONID          { L _ (ITconid    _) }- VARSYM         { L _ (ITvarsym   _) }- CONSYM         { L _ (ITconsym   _) }- QVARID         { L _ (ITqvarid   _) }- QCONID         { L _ (ITqconid   _) }- QVARSYM        { L _ (ITqvarsym  _) }- QCONSYM        { L _ (ITqconsym  _) }--- -- QualifiedDo- DO             { L _ (ITdo  _) }- MDO            { L _ (ITmdo _) }-- IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension- LABELVARID     { L _ (ITlabelvarid   _) }-- CHAR           { L _ (ITchar   _ _) }- STRING         { L _ (ITstring _ _) }- INTEGER        { L _ (ITinteger _) }- RATIONAL       { L _ (ITrational _) }-- PRIMCHAR       { L _ (ITprimchar   _ _) }- PRIMSTRING     { L _ (ITprimstring _ _) }- PRIMINTEGER    { L _ (ITprimint    _ _) }- PRIMWORD       { L _ (ITprimword   _ _) }- PRIMFLOAT      { L _ (ITprimfloat  _) }- PRIMDOUBLE     { L _ (ITprimdouble _) }---- Template Haskell-'[|'            { L _ (ITopenExpQuote _ _) }-'[p|'           { L _ ITopenPatQuote  }-'[t|'           { L _ ITopenTypQuote  }-'[d|'           { L _ ITopenDecQuote  }-'|]'            { L _ (ITcloseQuote _) }-'[||'           { L _ (ITopenTExpQuote _) }-'||]'           { L _ ITcloseTExpQuote  }-PREFIX_DOLLAR   { L _ ITdollar }-PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }-TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T-TH_QUASIQUOTE   { L _ (ITquasiQuote _) }-TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }--%monad { P } { >>= } { return }-%lexer { (lexer True) } { L _ ITeof }-  -- Replace 'lexer' above with 'lexerDbg'-  -- to dump the tokens fed to the parser.-%tokentype { (Located Token) }---- Exported parsers-%name parseModuleNoHaddock module-%name parseSignature signature-%name parseImport importdecl-%name parseStatement e_stmt-%name parseDeclaration topdecl-%name parseExpression exp-%name parsePattern pat-%name parseTypeSignature sigdecl-%name parseStmt   maybe_stmt-%name parseIdentifier  identifier-%name parseType ktype-%name parseBackpack backpack-%partial parseHeader header-%%---------------------------------------------------------------------------------- Identifiers; one of the entry points-identifier :: { Located RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }-        | qvarop                        { $1 }-        | qconop                        { $1 }-    | '(' '->' ')'      {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                               [mop $1,mu AnnRarrow $2,mcp $3] }-    | '->'              {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                               [mu AnnRarrow $1] }---------------------------------------------------------------------------------- Backpack stuff--backpack :: { [LHsUnit PackageName] }-         : implicit_top units close { fromOL $2 }-         | '{' units '}'            { fromOL $2 }--units :: { OrdList (LHsUnit PackageName) }-         : units ';' unit { $1 `appOL` unitOL $3 }-         | units ';'      { $1 }-         | unit           { unitOL $1 }--unit :: { LHsUnit PackageName }-        : 'unit' pkgname 'where' unitbody-            { sL1 $1 $ HsUnit { hsunitName = $2-                              , hsunitBody = fromOL $4 } }--unitid :: { LHsUnitId PackageName }-        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }-        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }--msubsts :: { OrdList (LHsModuleSubst PackageName) }-        : msubsts ',' msubst { $1 `appOL` unitOL $3 }-        | msubsts ','        { $1 }-        | msubst             { unitOL $1 }--msubst :: { LHsModuleSubst PackageName }-        : modid '=' moduleid { sLL $1 $> $ ($1, $3) }-        | modid VARSYM modid VARSYM { sLL $1 $> $ ($1, sLL $2 $> $ HsModuleVar $3) }--moduleid :: { LHsModuleId PackageName }-          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar $2 }-          | unitid ':' modid    { sLL $1 $> $ HsModuleId $1 $3 }--pkgname :: { Located PackageName }-        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }-        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }--litpkgname_segment :: { Located FastString }-        : VARID  { sL1 $1 $ getVARID $1 }-        | CONID  { sL1 $1 $ getCONID $1 }-        | special_id { $1 }---- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.--- See Note [Minus tokens] in GHC.Parser.Lexer-HYPHEN :: { [AddAnn] }-      : '-'          { [mj AnnMinus $1 ] }-      | PREFIX_MINUS { [mj AnnMinus $1 ] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "-")-                   then return [mj AnnMinus $1]-                   else do { addError (getLoc $1) $ text "Expected a hyphen"-                           ; return [] } }---litpkgname :: { Located FastString }-        : litpkgname_segment { $1 }-        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.-        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }--mayberns :: { Maybe [LRenaming] }-        : {- empty -} { Nothing }-        | '(' rns ')' { Just (fromOL $2) }--rns :: { OrdList LRenaming }-        : rns ',' rn { $1 `appOL` unitOL $3 }-        | rns ','    { $1 }-        | rn         { unitOL $1 }--rn :: { LRenaming }-        : modid 'as' modid { sLL $1 $> $ Renaming $1 (Just $3) }-        | modid            { sL1 $1    $ Renaming $1 Nothing }--unitbody :: { OrdList (LHsUnitDecl PackageName) }-        : '{'     unitdecls '}'   { $2 }-        | vocurly unitdecls close { $2 }--unitdecls :: { OrdList (LHsUnitDecl PackageName) }-        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }-        | unitdecls ';'         { $1 }-        | unitdecl              { unitOL $1 }--unitdecl :: { LHsUnitDecl PackageName }-        : 'module' maybe_src modid maybemodwarning maybeexports 'where' body-             -- XXX not accurate-             { sL1 $1 $ DeclD-                 (case snd $2 of-                   NotBoot -> HsSrcFile-                   IsBoot  -> HsBootFile)-                 $3-                 (Just $ sL1 $1 (HsModule (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }-        | 'signature' modid maybemodwarning maybeexports 'where' body-             { sL1 $1 $ DeclD-                 HsigFile-                 $2-                 (Just $ sL1 $1 (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }-        | 'module' maybe_src modid-             { sL1 $1 $ DeclD (case snd $2 of-                   NotBoot -> HsSrcFile-                   IsBoot  -> HsBootFile) $3 Nothing }-        | 'signature' modid-             { sL1 $1 $ DeclD HsigFile $2 Nothing }-        | 'dependency' unitid mayberns-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2-                                              , idModRenaming = $3-                                              , idSignatureInclude = False }) }-        | 'dependency' 'signature' unitid-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3-                                              , idModRenaming = Nothing-                                              , idSignatureInclude = True }) }---------------------------------------------------------------------------------- Module Header---- The place for module deprecation is really too restrictive, but if it--- was allowed at its natural place just before 'module', we get an ugly--- s/r conflict with the second alternative. Another solution would be the--- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,--- either, and DEPRECATED is only expected to be used by people who really--- know what they are doing. :-)--signature :: { Located HsModule }-       : 'signature' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)-                              (snd $ sndOf3 $6) $3 Nothing)-                    )-                    ([mj AnnSignature $1, mj AnnWhere $5] ++ fstOf3 $6) }--module :: { Located HsModule }-       : 'module' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                ams (L loc (HsModule (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)-                              (snd $ sndOf3 $6) $3 Nothing)-                    )-                    ([mj AnnModule $1, mj AnnWhere $5] ++ fstOf3 $6) }-        | body2-                {% fileSrcSpan >>= \ loc ->-                   ams (L loc (HsModule (thdOf3 $1) Nothing Nothing-                               (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))-                       (fstOf3 $1) }--missing_module_keyword :: { () }-        : {- empty -}                           {% pushModuleContext }--implicit_top :: { () }-        : {- empty -}                           {% pushModuleContext }--maybemodwarning :: { Maybe (Located WarningTxt) }-    : '{-# DEPRECATED' strings '#-}'-                      {% ajs (sLL $1 $> $ DeprecatedTxt (sL1 $1 (getDEPRECATED_PRAGs $1)) (snd $ unLoc $2))-                             (mo $1:mc $3: (fst $ unLoc $2)) }-    | '{-# WARNING' strings '#-}'-                         {% ajs (sLL $1 $> $ WarningTxt (sL1 $1 (getWARNING_PRAGs $1)) (snd $ unLoc $2))-                                (mo $1:mc $3 : (fst $ unLoc $2)) }-    |  {- empty -}                  { Nothing }--body    :: { ([AddAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo) }-        :  '{'            top '}'      { (moc $1:mcc $3:(fst $2)-                                         , snd $2, ExplicitBraces) }-        |      vocurly    top close    { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) }--body2   :: { ([AddAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo) }-        :  '{' top '}'                          { (moc $1:mcc $3-                                                   :(fst $2), snd $2, ExplicitBraces) }-        |  missing_module_keyword top close     { ([],snd $2, VirtualBraces leftmostColumn) }---top     :: { ([AddAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }-        : semis top1                            { ($1, $2) }--top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }-        : importdecls_semi topdecls_semi        { (reverse $1, cvTopDecls $2) }-        | importdecls_semi topdecls             { (reverse $1, cvTopDecls $2) }-        | importdecls                           { (reverse $1, []) }---------------------------------------------------------------------------------- Module declaration & imports only--header  :: { Located HsModule }-        : 'module' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing-                          )) [mj AnnModule $1,mj AnnWhere $5] }-        | 'signature' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   ams (L loc (HsModule NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing-                          )) [mj AnnModule $1,mj AnnWhere $5] }-        | header_body2-                {% fileSrcSpan >>= \ loc ->-                   return (L loc (HsModule NoLayoutInfo Nothing Nothing $1 [] Nothing-                          Nothing)) }--header_body :: { [LImportDecl GhcPs] }-        :  '{'            header_top            { $2 }-        |      vocurly    header_top            { $2 }--header_body2 :: { [LImportDecl GhcPs] }-        :  '{' header_top                       { $2 }-        |  missing_module_keyword header_top    { $2 }--header_top :: { [LImportDecl GhcPs] }-        :  semis header_top_importdecls         { $2 }--header_top_importdecls :: { [LImportDecl GhcPs] }-        :  importdecls_semi                     { $1 }-        |  importdecls                          { $1 }---------------------------------------------------------------------------------- The Export List--maybeexports :: { (Maybe (Located [LIE GhcPs])) }-        :  '(' exportlist ')'       {% amsL (comb2 $1 $>) ([mop $1,mcp $3] ++ (fst $2)) >>-                                       return (Just (sLL $1 $> (fromOL $ snd $2))) }-        |  {- empty -}              { Nothing }--exportlist :: { ([AddAnn], OrdList (LIE GhcPs)) }-        : exportlist1     { ([], $1) }-        | {- empty -}     { ([], nilOL) }--        -- trailing comma:-        | exportlist1 ',' { ([mj AnnComma $2], $1) }-        | ','             { ([mj AnnComma $1], nilOL) }--exportlist1 :: { OrdList (LIE GhcPs) }-        : exportlist1 ',' export-                          {% (addAnnotation (oll $1) AnnComma (gl $2) ) >>-                              return ($1 `appOL` $3) }-        | export          { $1 }---   -- No longer allow things like [] and (,,,) to be exported-   -- They are built in syntax, always available-export  :: { OrdList (LIE GhcPs) }-        : qcname_ext export_subspec  {% mkModuleImpExp $1 (snd $ unLoc $2)-                                          >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) }-        |  'module' modid            {% amsu (sLL $1 $> (IEModuleContents noExtField $2))-                                             [mj AnnModule $1] }-        |  'pattern' qcon            {% amsu (sLL $1 $> (IEVar noExtField (sLL $1 $> (IEPattern $2))))-                                             [mj AnnPattern $1] }--export_subspec :: { Located ([AddAnn],ImpExpSubSpec) }-        : {- empty -}             { sL0 ([],ImpExpAbs) }-        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))-                                      >>= \(as,ie) -> return $ sLL $1 $>-                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }---qcnames :: { ([AddAnn], [Located ImpExpQcSpec]) }-  : {- empty -}                   { ([],[]) }-  | qcnames1                      { $1 }--qcnames1 :: { ([AddAnn], [Located ImpExpQcSpec]) }     -- A reversed list-        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (head (snd $1)) of-                                                    l@(L _ ImpExpQcWildcard) ->-                                                       return ([mj AnnComma $2, mj AnnDotdot l]-                                                               ,(snd (unLoc $3)  : snd $1))-                                                    l -> (ams (head (snd $1)) [mj AnnComma $2] >>-                                                          return (fst $1 ++ fst (unLoc $3),-                                                                  snd (unLoc $3) : snd $1)) }---        -- Annotations re-added in mkImpExpSubSpec-        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }---- Variable, data constructor or wildcard--- or tagged type constructor-qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) }-        :  qcname_ext               { sL1 $1 ([],$1) }-        |  '..'                     { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard)  }--qcname_ext :: { Located ImpExpQcSpec }-        :  qcname                   { sL1 $1 (ImpExpQcName $1) }-        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2-                                          ; ams (sLL $1 $> (ImpExpQcType n))-                                                [mj AnnType $1] } }--qcname  :: { Located RdrName }  -- Variable or type constructor-        :  qvar                 { $1 } -- Things which look like functions-                                       -- Note: This includes record selectors but-                                       -- also (-.->), see #11432-        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]---------------------------------------------------------------------------------- Import Declarations---- importdecls and topdecls must contain at least one declaration;--- top handles the fact that these may be optional.---- One or more semicolons-semis1  :: { [AddAnn] }-semis1  : semis1 ';'  { mj AnnSemi $2 : $1 }-        | ';'         { [mj AnnSemi $1] }---- Zero or more semicolons-semis   :: { [AddAnn] }-semis   : semis ';'   { mj AnnSemi $2 : $1 }-        | {- empty -} { [] }---- No trailing semicolons, non-empty-importdecls :: { [LImportDecl GhcPs] }-importdecls-        : importdecls_semi importdecl-                                { $2 : $1 }---- May have trailing semicolons, can be empty-importdecls_semi :: { [LImportDecl GhcPs] }-importdecls_semi-        : importdecls_semi importdecl semis1-                                {% ams $2 $3 >> return ($2 : $1) }-        | {- empty -}           { [] }--importdecl :: { LImportDecl GhcPs }-        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec-                {% do {-                  ; let { ; mPreQual = unLoc $4-                          ; mPostQual = unLoc $7 }-                  ; checkImportDecl mPreQual mPostQual-                  ; ams (L (comb5 $1 $6 $7 (snd $8) $9) $-                      ImportDecl { ideclExt = noExtField-                                  , ideclSourceSrc = snd $ fst $2-                                  , ideclName = $6, ideclPkgQual = snd $5-                                  , ideclSource = snd $2, ideclSafe = snd $3-                                  , ideclQualified = importDeclQualifiedStyle mPreQual mPostQual-                                  , ideclImplicit = False-                                  , ideclAs = unLoc (snd $8)-                                  , ideclHiding = unLoc $9 })-                         (mj AnnImport $1 : fst (fst $2) ++ fst $3 ++ fmap (mj AnnQualified) (maybeToList mPreQual)-                                          ++ fst $5 ++ fmap (mj AnnQualified) (maybeToList mPostQual) ++ fst $8)-                  }-                }---maybe_src :: { (([AddAnn],SourceText),IsBootInterface) }-        : '{-# SOURCE' '#-}'        { (([mo $1,mc $2],getSOURCE_PRAGs $1)-                                      , IsBoot) }-        | {- empty -}               { (([],NoSourceText),NotBoot) }--maybe_safe :: { ([AddAnn],Bool) }-        : 'safe'                                { ([mj AnnSafe $1],True) }-        | {- empty -}                           { ([],False) }--maybe_pkg :: { ([AddAnn],Maybe StringLiteral) }-        : STRING  {% do { let { pkgFS = getSTRING $1 }-                        ; unless (looksLikePackageName (unpackFS pkgFS)) $-                             addError (getLoc $1) $ vcat [-                             text "Parse error" <> colon <+> quotes (ppr pkgFS),-                             text "Version number or non-alphanumeric" <+>-                             text "character in package name"]-                        ; return ([mj AnnPackageName $1], Just (StringLiteral (getSTRINGs $1) pkgFS)) } }-        | {- empty -}                           { ([],Nothing) }--optqualified :: { Located (Maybe (Located Token)) }-        : 'qualified'                           { sL1 $1 (Just $1) }-        | {- empty -}                           { noLoc Nothing }--maybeas :: { ([AddAnn],Located (Maybe (Located ModuleName))) }-        : 'as' modid                           { ([mj AnnAs $1]-                                                 ,sLL $1 $> (Just $2)) }-        | {- empty -}                          { ([],noLoc Nothing) }--maybeimpspec :: { Located (Maybe (Bool, Located [LIE GhcPs])) }-        : impspec                  {% let (b, ie) = unLoc $1 in-                                       checkImportSpec ie-                                        >>= \checkedIe ->-                                          return (L (gl $1) (Just (b, checkedIe)))  }-        | {- empty -}              { noLoc Nothing }--impspec :: { Located (Bool, Located [LIE GhcPs]) }-        :  '(' exportlist ')'               {% ams (sLL $1 $> (False,-                                                      sLL $1 $> $ fromOL (snd $2)))-                                                   ([mop $1,mcp $3] ++ (fst $2)) }-        |  'hiding' '(' exportlist ')'      {% ams (sLL $1 $> (True,-                                                      sLL $1 $> $ fromOL (snd $3)))-                                               ([mj AnnHiding $1,mop $2,mcp $4] ++ (fst $3)) }---------------------------------------------------------------------------------- Fixity Declarations--prec    :: { Located (SourceText,Int) }-        : {- empty -}           { noLoc (NoSourceText,9) }-        | INTEGER-                 { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) }--infix   :: { Located FixityDirection }-        : 'infix'                               { sL1 $1 InfixN  }-        | 'infixl'                              { sL1 $1 InfixL  }-        | 'infixr'                              { sL1 $1 InfixR }--ops     :: { Located (OrdList (Located RdrName)) }-        : ops ',' op       {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>-                              return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))}-        | op               { sL1 $1 (unitOL $1) }---------------------------------------------------------------------------------- Top-Level Declarations---- No trailing semicolons, non-empty-topdecls :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl semis1 {% ams $2 $3 >> return ($1 `snocOL` $2) }-        | {- empty -}                  { nilOL }--topdecl :: { LHsDecl GhcPs }-        : cl_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | ty_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | standalone_kind_sig                   { sL1 $1 (KindSigD noExtField (unLoc $1)) }-        | inst_decl                             { sL1 $1 (InstD noExtField (unLoc $1)) }-        | stand_alone_deriving                  { sLL $1 $> (DerivD noExtField (unLoc $1)) }-        | role_annot                            { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }-        | 'default' '(' comma_types0 ')'    {% ams (sLL $1 $> (DefD noExtField (DefaultDecl noExtField $3)))-                                                         [mj AnnDefault $1-                                                         ,mop $2,mcp $4] }-        | 'foreign' fdecl          {% ams (sLL $1 $> (snd $ unLoc $2))-                                           (mj AnnForeign $1:(fst $ unLoc $2)) }-        | '{-# DEPRECATED' deprecations '#-}'   {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getDEPRECATED_PRAGs $1) (fromOL $2)))-                                                       [mo $1,mc $3] }-        | '{-# WARNING' warnings '#-}'          {% ams (sLL $1 $> $ WarningD noExtField (Warnings noExtField (getWARNING_PRAGs $1) (fromOL $2)))-                                                       [mo $1,mc $3] }-        | '{-# RULES' rules '#-}'               {% ams (sLL $1 $> $ RuleD noExtField (HsRules noExtField (getRULES_PRAGs $1) (fromOL $2)))-                                                       [mo $1,mc $3] }-        | annotation { $1 }-        | decl_no_th                            { $1 }--        -- Template Haskell Extension-        -- The $(..) form is one possible form of infixexp-        -- but we treat an arbitrary expression just as if-        -- it had a $(..) wrapped around it-        | infixexp                              {% runECP_P $1 >>= \ $1 ->-                                                   return $ sLL $1 $> $ mkSpliceDecl $1 }---- Type classes----cl_decl :: { LTyClDecl GhcPs }-        : 'class' tycl_hdr fds where_cls-                {% amms (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))-                        (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }---- Type declarations (toplevel)----ty_decl :: { LTyClDecl GhcPs }-           -- ordinary type synonyms-        : 'type' type '=' ktype-                -- Note ktype, not sigtype, on the right of '='-                -- We allow an explicit for-all but we don't insert one-                -- in   type Foo a = (b,b)-                -- Instead we just say b is out of scope-                ---                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% amms (mkTySynonym (comb2 $1 $4) $2 $4)-                        [mj AnnType $1,mj AnnEqual $3] }--           -- type family declarations-        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info-                          where_type_family-                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% amms (mkFamDecl (comb4 $1 $3 $4 $5) (snd $ unLoc $6) $3-                                   (snd $ unLoc $4) (snd $ unLoc $5))-                        (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)-                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6)) }--          -- ordinary data type or newtype declaration-        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings-                {% amms (mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3-                           Nothing (reverse (snd $ unLoc $4))-                                   (fmap reverse $5))-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty-                        ((fst $ unLoc $1):(fst $ unLoc $4)) }--          -- ordinary GADT declaration-        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% amms (mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3-                            (snd $ unLoc $4) (snd $ unLoc $5)-                            (fmap reverse $6) )-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty-                    ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }--          -- data/newtype family-        | 'data' 'family' type opt_datafam_kind_sig-                {% amms (mkFamDecl (comb3 $1 $2 $4) DataFamily $3-                                   (snd $ unLoc $4) Nothing)-                        (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }---- standalone kind signature-standalone_kind_sig :: { LStandaloneKindSig GhcPs }-  : 'type' sks_vars '::' ktype-      {% amms (mkStandaloneKindSig (comb2 $1 $4) $2 $4)-              [mj AnnType $1,mu AnnDcolon $3] }---- See also: sig_vars-sks_vars :: { Located [Located RdrName] }  -- Returned in reverse order-  : sks_vars ',' oqtycon-      {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>-         return (sLL $1 $> ($3 : unLoc $1)) }-  | oqtycon { sL1 $1 [$1] }--inst_decl :: { LInstDecl GhcPs }-        : 'instance' overlap_pragma inst_type where_inst-       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)-             ; let cid = ClsInstDecl { cid_ext = noExtField-                                     , cid_poly_ty = $3, cid_binds = binds-                                     , cid_sigs = mkClassOpSigs sigs-                                     , cid_tyfam_insts = ats-                                     , cid_overlap_mode = $2-                                     , cid_datafam_insts = adts }-             ; ams (L (comb3 $1 (hsSigType $3) $4) (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))-                   (mj AnnInstance $1 : (fst $ unLoc $4)) } }--           -- type instance declarations-        | 'type' 'instance' ty_fam_inst_eqn-                {% ams $3 (fst $ unLoc $3)-                >> amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))-                    (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }--          -- data/newtype instance declaration-        | data_or_newtype 'instance' capi_ctype tycl_hdr_inst constrs-                          maybe_derivings-            {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)-                                      Nothing (reverse (snd  $ unLoc $5))-                                              (fmap reverse $6))-                    ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $4)++(fst $ unLoc $5)) }--          -- GADT instance declaration-        | data_or_newtype 'instance' capi_ctype tycl_hdr_inst opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (snd $ unLoc $4)-                                   (snd $ unLoc $5) (snd $ unLoc $6)-                                   (fmap reverse $7))-                    ((fst $ unLoc $1):mj AnnInstance $2-                       :(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }--overlap_pragma :: { Maybe (Located OverlapMode) }-  : '{-# OVERLAPPABLE'    '#-}' {% ajs (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))-                                       [mo $1,mc $2] }-  | '{-# OVERLAPPING'     '#-}' {% ajs (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))-                                       [mo $1,mc $2] }-  | '{-# OVERLAPS'        '#-}' {% ajs (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))-                                       [mo $1,mc $2] }-  | '{-# INCOHERENT'      '#-}' {% ajs (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))-                                       [mo $1,mc $2] }-  | {- empty -}                 { Nothing }--deriv_strategy_no_via :: { LDerivStrategy GhcPs }-  : 'stock'                     {% ams (sL1 $1 StockStrategy)-                                       [mj AnnStock $1] }-  | 'anyclass'                  {% ams (sL1 $1 AnyclassStrategy)-                                       [mj AnnAnyclass $1] }-  | 'newtype'                   {% ams (sL1 $1 NewtypeStrategy)-                                       [mj AnnNewtype $1] }--deriv_strategy_via :: { LDerivStrategy GhcPs }-  : 'via' ktype             {% ams (sLL $1 $> (ViaStrategy (mkLHsSigType $2)))-                                       [mj AnnVia $1] }--deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }-  : 'stock'                     {% ajs (sL1 $1 StockStrategy)-                                       [mj AnnStock $1] }-  | 'anyclass'                  {% ajs (sL1 $1 AnyclassStrategy)-                                       [mj AnnAnyclass $1] }-  | 'newtype'                   {% ajs (sL1 $1 NewtypeStrategy)-                                       [mj AnnNewtype $1] }-  | deriv_strategy_via          { Just $1 }-  | {- empty -}                 { Nothing }---- Injective type families--opt_injective_info :: { Located ([AddAnn], Maybe (LInjectivityAnn GhcPs)) }-        : {- empty -}               { noLoc ([], Nothing) }-        | '|' injectivity_cond      { sLL $1 $> ([mj AnnVbar $1]-                                                , Just ($2)) }--injectivity_cond :: { LInjectivityAnn GhcPs }-        : tyvarid '->' inj_varids-           {% ams (sLL $1 $> (InjectivityAnn $1 (reverse (unLoc $3))))-                  [mu AnnRarrow $2] }--inj_varids :: { Located [Located RdrName] }-        : inj_varids tyvarid  { sLL $1 $> ($2 : unLoc $1) }-        | tyvarid             { sLL $1 $> [$1]            }---- Closed type families--where_type_family :: { Located ([AddAnn],FamilyInfo GhcPs) }-        : {- empty -}                      { noLoc ([],OpenTypeFamily) }-        | 'where' ty_fam_inst_eqn_list-               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }--ty_fam_inst_eqn_list :: { Located ([AddAnn],Maybe [LTyFamInstEqn GhcPs]) }-        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]-                                                ,Just (unLoc $2)) }-        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in-                                             L loc ([],Just (unLoc $2)) }-        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2-                                                 ,mcc $3],Nothing) }-        | vocurly '..' close               { let (L loc _) = $2 in-                                             L loc ([mj AnnDotdot $2],Nothing) }--ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }-        : ty_fam_inst_eqns ';' ty_fam_inst_eqn-                                      {% let (L loc (anns, eqn)) = $3 in-                                         asl (unLoc $1) $2 (L loc eqn)-                                         >> ams $3 anns-                                         >> return (sLL $1 $> (L loc eqn : unLoc $1)) }-        | ty_fam_inst_eqns ';'        {% addAnnotation (gl $1) AnnSemi (gl $2)-                                         >> return (sLL $1 $>  (unLoc $1)) }-        | ty_fam_inst_eqn             {% let (L loc (anns, eqn)) = $1 in-                                         ams $1 anns-                                         >> return (sLL $1 $> [L loc eqn]) }-        | {- empty -}                 { noLoc [] }--ty_fam_inst_eqn :: { Located ([AddAnn],TyFamInstEqn GhcPs) }-        : 'forall' tv_bndrs '.' type '=' ktype-              {% do { hintExplicitForall $1-                    ; tvb <- fromSpecTyVarBndrs $2-                    ; (eqn,ann) <- mkTyFamInstEqn (Just tvb) $4 $6-                    ; return (sLL $1 $>-                               (mu AnnForall $1:mj AnnDot $3:mj AnnEqual $5:ann,eqn)) } }-        | type '=' ktype-              {% do { (eqn,ann) <- mkTyFamInstEqn Nothing $1 $3-                    ; return (sLL $1 $> (mj AnnEqual $2:ann, eqn))  } }-              -- Note the use of type for the head; this allows-              -- infix type constructors and type patterns---- Associated type family declarations------ * They have a different syntax than on the toplevel (no family special---   identifier).------ * They also need to be separate from instances; otherwise, data family---   declarations without a kind signature cause parsing conflicts with empty---   data declarations.----at_decl_cls :: { LHsDecl GhcPs }-        :  -- data family declarations, with optional 'family' keyword-          'data' opt_family type opt_datafam_kind_sig-                {% amms (liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily $3-                                                  (snd $ unLoc $4) Nothing))-                        (mj AnnData $1:$2++(fst $ unLoc $4)) }--           -- type family declarations, with optional 'family' keyword-           -- (can't use opt_instance because you get shift/reduce errors-        | 'type' type opt_at_kind_inj_sig-               {% amms (liftM mkTyClD-                        (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily $2-                                   (fst . snd $ unLoc $3)-                                   (snd . snd $ unLoc $3)))-                       (mj AnnType $1:(fst $ unLoc $3)) }-        | 'type' 'family' type opt_at_kind_inj_sig-               {% amms (liftM mkTyClD-                        (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily $3-                                   (fst . snd $ unLoc $4)-                                   (snd . snd $ unLoc $4)))-                       (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)) }--           -- default type instances, with optional 'instance' keyword-        | 'type' ty_fam_inst_eqn-                {% ams $2 (fst $ unLoc $2) >>-                   amms (liftM mkInstD (mkTyFamInst (comb2 $1 $2) (snd $ unLoc $2)))-                        (mj AnnType $1:(fst $ unLoc $2)) }-        | 'type' 'instance' ty_fam_inst_eqn-                {% ams $3 (fst $ unLoc $3) >>-                   amms (liftM mkInstD (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3)))-                        (mj AnnType $1:mj AnnInstance $2:(fst $ unLoc $3)) }--opt_family   :: { [AddAnn] }-              : {- empty -}   { [] }-              | 'family'      { [mj AnnFamily $1] }--opt_instance :: { [AddAnn] }-              : {- empty -} { [] }-              | 'instance'  { [mj AnnInstance $1] }---- Associated type instances----at_decl_inst :: { LInstDecl GhcPs }-           -- type instance declarations, with optional 'instance' keyword-        : 'type' opt_instance ty_fam_inst_eqn-                -- Note the use of type for the head; this allows-                -- infix type constructors and type patterns-                {% ams $3 (fst $ unLoc $3) >>-                   amms (mkTyFamInst (comb2 $1 $3) (snd $ unLoc $3))-                        (mj AnnType $1:$2++(fst $ unLoc $3)) }--        -- data/newtype instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype tycl_hdr_inst constrs maybe_derivings-               {% amms (mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (snd $ unLoc $4)-                                    Nothing (reverse (snd $ unLoc $5))-                                            (fmap reverse $6))-                       ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)) }--        -- GADT instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype tycl_hdr_inst opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-                {% amms (mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3-                                (snd $ unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)-                                (fmap reverse $7))-                        ((fst $ unLoc $1):$2++(fst $ unLoc $4)++(fst $ unLoc $5)++(fst $ unLoc $6)) }--data_or_newtype :: { Located (AddAnn, NewOrData) }-        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }-        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }---- Family result/return kind signatures--opt_kind_sig :: { Located ([AddAnn], Maybe (LHsKind GhcPs)) }-        :               { noLoc     ([]               , Nothing) }-        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], Just $2) }--opt_datafam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }-        :               { noLoc     ([]               , noLoc (NoSig noExtField)         )}-        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig noExtField $2))}--opt_tyfam_kind_sig :: { Located ([AddAnn], LFamilyResultSig GhcPs) }-        :              { noLoc     ([]               , noLoc     (NoSig    noExtField)   )}-        | '::' kind    { sLL $1 $> ([mu AnnDcolon $1], sLL $1 $> (KindSig  noExtField $2))}-        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2-                             ; return $ sLL $1 $> ([mj AnnEqual $1] , sLL $1 $> (TyVarSig noExtField tvb))} }--opt_at_kind_inj_sig :: { Located ([AddAnn], ( LFamilyResultSig GhcPs-                                            , Maybe (LInjectivityAnn GhcPs)))}-        :            { noLoc ([], (noLoc (NoSig noExtField), Nothing)) }-        | '::' kind  { sLL $1 $> ( [mu AnnDcolon $1]-                                 , (sLL $2 $> (KindSig noExtField $2), Nothing)) }-        | '='  tv_bndr_no_braces '|' injectivity_cond-                {% do { tvb <- fromSpecTyVarBndr $2-                      ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]-                                           , (sLL $1 $2 (TyVarSig noExtField tvb), Just $4))} }---- tycl_hdr parses the header of a class or data type decl,--- which takes the form---      T a b---      Eq a => T a---      (Eq a, Ord b) => T a b---      T Int [a]                       -- for associated types--- Rather a lot of inlining here, else we get reduce/reduce errors-tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }-        : context '=>' type         {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)-                                       >> (return (sLL $1 $> (Just $1, $3)))-                                    }-        | type                      { sL1 $1 (Nothing, $1) }--tycl_hdr_inst :: { Located ([AddAnn],(Maybe (LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs], LHsType GhcPs)) }-        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1-                                                       >> fromSpecTyVarBndrs $2-                                                         >>= \tvbs -> (addAnnotation (gl $4) (toUnicodeAnn AnnDarrow $5) (gl $5)-                                                             >> return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]-                                                                                  , (Just $4, Just tvbs, $6)))-                                                          )-                                                    }-        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1-                                             ; tvbs <- fromSpecTyVarBndrs $2-                                             ; return (sLL $1 $> ([mu AnnForall $1, mj AnnDot $3]-                                                                 , (Nothing, Just tvbs, $4)))-                                       } }-        | context '=>' type         {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)-                                       >> (return (sLL $1 $>([], (Just $1, Nothing, $3))))-                                    }-        | type                      { sL1 $1 ([], (Nothing, Nothing, $1)) }---capi_ctype :: { Maybe (Located CType) }-capi_ctype : '{-# CTYPE' STRING STRING '#-}'-                       {% ajs (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))-                                        (getSTRINGs $3,getSTRING $3)))-                              [mo $1,mj AnnHeader $2,mj AnnVal $3,mc $4] }--           | '{-# CTYPE'        STRING '#-}'-                       {% ajs (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))-                              [mo $1,mj AnnVal $2,mc $3] }--           |           { Nothing }---------------------------------------------------------------------------------- Stand-alone deriving---- Glasgow extension: stand-alone deriving declarations-stand_alone_deriving :: { LDerivDecl GhcPs }-  : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type-                {% do { let { err = text "in the stand-alone deriving instance"-                                    <> colon <+> quotes (ppr $5) }-                      ; ams (sLL $1 (hsSigType $>)-                                 (DerivDecl noExtField (mkHsWildCardBndrs $5) $2 $4))-                            [mj AnnDeriving $1, mj AnnInstance $3] } }---------------------------------------------------------------------------------- Role annotations--role_annot :: { LRoleAnnotDecl GhcPs }-role_annot : 'type' 'role' oqtycon maybe_roles-          {% amms (mkRoleAnnotDecl (comb3 $1 $3 $4) $3 (reverse (unLoc $4)))-                  [mj AnnType $1,mj AnnRole $2] }---- Reversed!-maybe_roles :: { Located [Located (Maybe FastString)] }-maybe_roles : {- empty -}    { noLoc [] }-            | roles          { $1 }--roles :: { Located [Located (Maybe FastString)] }-roles : role             { sLL $1 $> [$1] }-      | roles role       { sLL $1 $> $ $2 : unLoc $1 }---- read it in as a varid for better error messages-role :: { Located (Maybe FastString) }-role : VARID             { sL1 $1 $ Just $ getVARID $1 }-     | '_'               { sL1 $1 Nothing }---- Pattern synonyms---- Glasgow extension: pattern synonyms-pattern_synonym_decl :: { LHsDecl GhcPs }-        : 'pattern' pattern_synonym_lhs '=' pat-         {%      let (name, args,as ) = $2 in-                 ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4-                                                    ImplicitBidirectional)-               (as ++ [mj AnnPattern $1, mj AnnEqual $3])-         }--        | 'pattern' pattern_synonym_lhs '<-' pat-         {%    let (name, args, as) = $2 in-               ams (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional)-               (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) }--        | 'pattern' pattern_synonym_lhs '<-' pat where_decls-            {% do { let (name, args, as) = $2-                  ; mg <- mkPatSynMatchGroup name (snd $ unLoc $5)-                  ; ams (sLL $1 $> . ValD noExtField $-                           mkPatSynBind name args $4 (ExplicitBidirectional mg))-                       (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) )-                   }}--pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) }-        : con vars0 { ($1, PrefixCon $2, []) }-        | varid conop varid { ($2, InfixCon $1 $3, []) }-        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }--vars0 :: { [Located RdrName] }-        : {- empty -}                 { [] }-        | varid vars0                 { $1 : $2 }--cvars1 :: { [RecordPatSynField (Located RdrName)] }-       : var                          { [RecordPatSynField $1 $1] }-       | var ',' cvars1               {% addAnnotation (getLoc $1) AnnComma (getLoc $2) >>-                                         return ((RecordPatSynField $1 $1) : $3 )}--where_decls :: { Located ([AddAnn]-                         , Located (OrdList (LHsDecl GhcPs))) }-        : 'where' '{' decls '}'       { sLL $1 $> ((mj AnnWhere $1:moc $2-                                           :mcc $4:(fst $ unLoc $3)),sL1 $3 (snd $ unLoc $3)) }-        | 'where' vocurly decls close { L (comb2 $1 $3) ((mj AnnWhere $1:(fst $ unLoc $3))-                                          ,sL1 $3 (snd $ unLoc $3)) }--pattern_synonym_sig :: { LSig GhcPs }-        : 'pattern' con_list '::' sigtype-                   {% ams (sLL $1 $> $ PatSynSig noExtField (unLoc $2) (mkLHsSigType $4))-                          [mj AnnPattern $1, mu AnnDcolon $3] }---------------------------------------------------------------------------------- Nested declarations---- Declaration in class bodies----decl_cls  :: { LHsDecl GhcPs }-decl_cls  : at_decl_cls                 { $1 }-          | decl                        { $1 }--          -- A 'default' signature used with the generic-programming extension-          | 'default' infixexp '::' sigtype-                    {% runECP_P $2 >>= \ $2 ->-                       do { v <- checkValSigLhs $2-                          ; let err = text "in default signature" <> colon <+>-                                      quotes (ppr $2)-                          ; ams (sLL $1 $> $ SigD noExtField $ ClassOpSig noExtField True [v] $ mkLHsSigType $4)-                                [mj AnnDefault $1,mu AnnDcolon $3] } }--decls_cls :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed-          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                                    , unitOL $3))-                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]-                                           >> return (sLL $1 $> (fst $ unLoc $1-                                                                ,(snd $ unLoc $1) `appOL` unitOL $3)) }-          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                                                   ,snd $ unLoc $1))-                                             else ams (lastOL (snd $ unLoc $1)) [mj AnnSemi $2]-                                           >> return (sLL $1 $>  (unLoc $1)) }-          | decl_cls                    { sL1 $1 ([], unitOL $1) }-          | {- empty -}                 { noLoc ([],nilOL) }--decllist_cls-        :: { Located ([AddAnn]-                     , OrdList (LHsDecl GhcPs)-                     , LayoutInfo) }      -- Reversed-        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)-                                             ,snd $ unLoc $2, ExplicitBraces) }-        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }-                                           in L l (anns, decls, VirtualBraces (getVOCURLY $1)) }---- Class body----where_cls :: { Located ([AddAnn]-                       ,(OrdList (LHsDecl GhcPs))    -- Reversed-                       ,LayoutInfo) }-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)-                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }-        | {- empty -}                   { noLoc ([],nilOL,NoLayoutInfo) }---- Declarations in instance bodies----decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }-decl_inst  : at_decl_inst               { sLL $1 $> (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }-           | decl                       { sLL $1 $> (unitOL $1) }--decls_inst :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed-           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                                    , unLoc $3))-                                             else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]-                                           >> return-                                            (sLL $1 $> (fst $ unLoc $1-                                                       ,(snd $ unLoc $1) `appOL` unLoc $3)) }-           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                                                   ,snd $ unLoc $1))-                                             else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]-                                           >> return (sLL $1 $> (unLoc $1)) }-           | decl_inst                  { sL1 $1 ([],unLoc $1) }-           | {- empty -}                { noLoc ([],nilOL) }--decllist_inst-        :: { Located ([AddAnn]-                     , OrdList (LHsDecl GhcPs)) }      -- Reversed-        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }-        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }---- Instance body----where_inst :: { Located ([AddAnn]-                        , OrdList (LHsDecl GhcPs)) }   -- Reversed-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                                             ,(snd $ unLoc $2)) }-        | {- empty -}                   { noLoc ([],nilOL) }---- Declarations in binding groups other than classes and instances----decls   :: { Located ([AddAnn],OrdList (LHsDecl GhcPs)) }-        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)-                                 then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                        , unitOL $3))-                                 else do ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]-                                           >> return (-                                          let { this = unitOL $3;-                                                rest = snd $ unLoc $1;-                                                these = rest `appOL` this }-                                          in rest `seq` this `seq` these `seq`-                                             (sLL $1 $> (fst $ unLoc $1,these))) }-        | decls ';'          {% if isNilOL (snd $ unLoc $1)-                                  then return (sLL $1 $> ((mj AnnSemi $2:(fst $ unLoc $1)-                                                          ,snd $ unLoc $1)))-                                  else ams (lastOL $ snd $ unLoc $1) [mj AnnSemi $2]-                                           >> return (sLL $1 $> (unLoc $1)) }-        | decl                          { sL1 $1 ([], unitOL $1) }-        | {- empty -}                   { noLoc ([],nilOL) }--decllist :: { Located ([AddAnn],Located (OrdList (LHsDecl GhcPs))) }-        : '{'            decls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }-        |     vocurly    decls close   { L (gl $2) (fst $ unLoc $2,sL1 $2 $ snd $ unLoc $2) }---- Binding groups other than those of class and instance declarations----binds   ::  { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }-                                         -- May have implicit parameters-                                                -- No type declarations-        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)-                                  ; return (sL1 $1 (fst $ unLoc $1-                                                    ,sL1 $1 $ HsValBinds noExtField val_binds)) } }--        | '{'            dbinds '}'     { sLL $1 $> ([moc $1,mcc $3]-                                             ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }--        |     vocurly    dbinds close   { L (getLoc $2) ([]-                                            ,sL1 $2 $ HsIPBinds noExtField (IPBinds noExtField (reverse $ unLoc $2))) }---wherebinds :: { Located ([AddAnn],Located (HsLocalBinds GhcPs)) }-                                                -- May have implicit parameters-                                                -- No type declarations-        : 'where' binds                 { sLL $1 $> (mj AnnWhere $1 : (fst $ unLoc $2)-                                             ,snd $ unLoc $2) }-        | {- empty -}                   { noLoc ([],noLoc emptyLocalBinds) }----------------------------------------------------------------------------------- Transformation Rules--rules   :: { OrdList (LRuleDecl GhcPs) }-        :  rules ';' rule              {% addAnnotation (oll $1) AnnSemi (gl $2)-                                          >> return ($1 `snocOL` $3) }-        |  rules ';'                   {% addAnnotation (oll $1) AnnSemi (gl $2)-                                          >> return $1 }-        |  rule                        { unitOL $1 }-        |  {- empty -}                 { nilOL }--rule    :: { LRuleDecl GhcPs }-        : STRING rule_activation rule_foralls infixexp '=' exp-         {%runECP_P $4 >>= \ $4 ->-           runECP_P $6 >>= \ $6 ->-           ams (sLL $1 $> $ HsRule { rd_ext = noExtField-                                   , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)-                                   , rd_act = (snd $2) `orElse` AlwaysActive-                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3-                                   , rd_lhs = $4, rd_rhs = $6 })-               (mj AnnEqual $5 : (fst $2) ++ (fstOf3 $3)) }---- Rules can be specified to be NeverActive, unlike inline/specialize pragmas-rule_activation :: { ([AddAnn],Maybe Activation) }-        : {- empty -}                           { ([],Nothing) }-        | rule_explicit_activation              { (fst $1,Just (snd $1)) }---- This production is used to parse the tilde syntax in pragmas such as---   * {-# INLINE[~2] ... #-}---   * {-# SPECIALISE [~ 001] ... #-}---   * {-# RULES ... [~0] ... g #-}--- Note that it can be written either---   without a space [~1]  (the PREFIX_TILDE case), or---   with    a space [~ 1] (the VARSYM case).--- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-rule_activation_marker :: { [AddAnn] }-      : PREFIX_TILDE { [mj AnnTilde $1] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "~")-                   then return [mj AnnTilde $1]-                   else do { addError (getLoc $1) $ text "Invalid rule activation marker"-                           ; return [] } }--rule_explicit_activation :: { ([AddAnn]-                              ,Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mos $1,mj AnnVal $3,mcs $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }-        | '[' rule_activation_marker ']'-                                { ($2++[mos $1,mcs $3]-                                  ,NeverActive) }--rule_foralls :: { ([AddAnn], Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }-        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2-                                                              in hintExplicitForall $1-                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)-                                                              >> return ([mu AnnForall $1,mj AnnDot $3,-                                                                          mu AnnForall $4,mj AnnDot $6],-                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }-        | 'forall' rule_vars '.'                           { ([mu AnnForall $1,mj AnnDot $3],-                                                              Nothing, mkRuleBndrs $2) }-        | {- empty -}                                      { ([], Nothing, []) }--rule_vars :: { [LRuleTyTmVar] }-        : rule_var rule_vars                    { $1 : $2 }-        | {- empty -}                           { [] }--rule_var :: { LRuleTyTmVar }-        : varid                         { sLL $1 $> (RuleTyTmVar $1 Nothing) }-        | '(' varid '::' ctype ')'      {% ams (sLL $1 $> (RuleTyTmVar $2 (Just $4)))-                                               [mop $1,mu AnnDcolon $3,mcp $5] }--{- Note [Parsing explicit foralls in Rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We really want the above definition of rule_foralls to be:--  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'-               | 'forall' rule_vars '.'-               | {- empty -}--where rule_vars (term variables) can be named "forall", "family", or "role",-but tv_vars (type variables) cannot be. However, such a definition results-in a reduce/reduce conflict. For example, when parsing:-> {-# RULE "name" forall a ... #-}-before the '...' it is impossible to determine whether we should be in the-first or second case of the above.--This is resolved by using rule_vars (which is more general) for both, and-ensuring that type-level quantified variables do not have the names "forall",-"family", or "role" in the function 'checkRuleTyVarBndrNames' in-GHC.Parser.PostProcess.-Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative-to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.--}---------------------------------------------------------------------------------- Warnings and deprecations (c.f. rules)--warnings :: { OrdList (LWarnDecl GhcPs) }-        : warnings ';' warning         {% addAnnotation (oll $1) AnnSemi (gl $2)-                                          >> return ($1 `appOL` $3) }-        | warnings ';'                 {% addAnnotation (oll $1) AnnSemi (gl $2)-                                          >> return $1 }-        | warning                      { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-warning :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-                {% amsu (sLL $1 $> (Warning noExtField (unLoc $1) (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2)))-                     (fst $ unLoc $2) }--deprecations :: { OrdList (LWarnDecl GhcPs) }-        : deprecations ';' deprecation-                                       {% addAnnotation (oll $1) AnnSemi (gl $2)-                                          >> return ($1 `appOL` $3) }-        | deprecations ';'             {% addAnnotation (oll $1) AnnSemi (gl $2)-                                          >> return $1 }-        | deprecation                  { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-deprecation :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-             {% amsu (sLL $1 $> $ (Warning noExtField (unLoc $1) (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2)))-                     (fst $ unLoc $2) }--strings :: { Located ([AddAnn],[Located StringLiteral]) }-    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }-    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }--stringlist :: { Located (OrdList (Located StringLiteral)) }-    : stringlist ',' STRING {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >>-                               return (sLL $1 $> (unLoc $1 `snocOL`-                                                  (L (gl $3) (getStringLiteral $3)))) }-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }-    | {- empty -}           { noLoc nilOL }---------------------------------------------------------------------------------- Annotations-annotation :: { LHsDecl GhcPs }-    : '{-# ANN' name_var aexp '#-}'      {% runECP_P $3 >>= \ $3 ->-                                            ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField-                                            (getANN_PRAGs $1)-                                            (ValueAnnProvenance $2) $3))-                                            [mo $1,mc $4] }--    | '{-# ANN' 'type' tycon aexp '#-}'  {% runECP_P $4 >>= \ $4 ->-                                            ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField-                                            (getANN_PRAGs $1)-                                            (TypeAnnProvenance $3) $4))-                                            [mo $1,mj AnnType $2,mc $5] }--    | '{-# ANN' 'module' aexp '#-}'      {% runECP_P $3 >>= \ $3 ->-                                            ams (sLL $1 $> (AnnD noExtField $ HsAnnotation noExtField-                                                (getANN_PRAGs $1)-                                                 ModuleAnnProvenance $3))-                                                [mo $1,mj AnnModule $2,mc $4] }----------------------------------------------------------------------------------- Foreign import and export declarations--fdecl :: { Located ([AddAnn],HsDecl GhcPs) }-fdecl : 'import' callconv safety fspec-               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->-                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }-      | 'import' callconv        fspec-               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);-                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}-      | 'export' callconv fspec-               {% mkExport $2 (snd $ unLoc $3) >>= \i ->-                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }--callconv :: { Located CCallConv }-          : 'stdcall'                   { sLL $1 $> StdCallConv }-          | 'ccall'                     { sLL $1 $> CCallConv   }-          | 'capi'                      { sLL $1 $> CApiConv    }-          | 'prim'                      { sLL $1 $> PrimCallConv}-          | 'javascript'                { sLL $1 $> JavaScriptCallConv }--safety :: { Located Safety }-        : 'unsafe'                      { sLL $1 $> PlayRisky }-        | 'safe'                        { sLL $1 $> PlaySafe }-        | 'interruptible'               { sLL $1 $> PlayInterruptible }--fspec :: { Located ([AddAnn]-                    ,(Located StringLiteral, Located RdrName, LHsSigType GhcPs)) }-       : STRING var '::' sigtype        { sLL $1 $> ([mu AnnDcolon $3]-                                             ,(L (getLoc $1)-                                                    (getStringLiteral $1), $2, mkLHsSigType $4)) }-       |        var '::' sigtype        { sLL $1 $> ([mu AnnDcolon $2]-                                             ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) }-         -- if the entity string is missing, it defaults to the empty string;-         -- the meaning of an empty entity string depends on the calling-         -- convention---------------------------------------------------------------------------------- Type signatures--opt_sig :: { ([AddAnn], Maybe (LHsType GhcPs)) }-        : {- empty -}                   { ([],Nothing) }-        | '::' sigtype                  { ([mu AnnDcolon $1],Just $2) }--opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) }-             : {- empty -}              { ([], Nothing) }-             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }--sigtype :: { LHsType GhcPs }-        : ctype                            { $1 }--sig_vars :: { Located [Located RdrName] }    -- Returned in reversed order-         : sig_vars ',' var           {% addAnnotation (gl $ head $ unLoc $1)-                                                       AnnComma (gl $2)-                                         >> return (sLL $1 $> ($3 : unLoc $1)) }-         | var                        { sL1 $1 [$1] }--sigtypes1 :: { (OrdList (LHsSigType GhcPs)) }-   : sigtype                 { unitOL (mkLHsSigType $1) }-   | sigtype ',' sigtypes1   {% addAnnotation (gl $1) AnnComma (gl $2)-                                >> return (unitOL (mkLHsSigType $1) `appOL` $3) }---------------------------------------------------------------------------------- Types--unpackedness :: { Located ([AddAnn], SourceText, SrcUnpackedness) }-        : '{-# UNPACK' '#-}'   { sLL $1 $> ([mo $1, mc $2], getUNPACK_PRAGs $1, SrcUnpack) }-        | '{-# NOUNPACK' '#-}' { sLL $1 $> ([mo $1, mc $2], getNOUNPACK_PRAGs $1, SrcNoUnpack) }--forall_telescope :: { Located ([AddAnn], HsForAllTelescope GhcPs) }-        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1-                                       ; pure $ sLL $1 $>-                                           ( [mu AnnForall $1, mu AnnDot $3]-                                           , mkHsForAllInvisTele $2 ) }}-        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1-                                       ; req_tvbs <- fromSpecTyVarBndrs $2-                                       ; pure $ sLL $1 $> $-                                           ( [mu AnnForall $1, mu AnnRarrow $3]-                                           , mkHsForAllVisTele req_tvbs ) }}---- A ktype is a ctype, possibly with a kind annotation-ktype :: { LHsType GhcPs }-        : ctype                { $1 }-        | ctype '::' kind      {% ams (sLL $1 $> $ HsKindSig noExtField $1 $3)-                                      [mu AnnDcolon $2] }---- A ctype is a for-all type-ctype   :: { LHsType GhcPs }-        : forall_telescope ctype      {% let (forall_anns, forall_tele) = unLoc $1 in-                                         ams (sLL $1 $> $-                                              HsForAllTy { hst_tele = forall_tele-                                                         , hst_xforall = noExtField-                                                         , hst_body = $2 })-                                             forall_anns }-        | context '=>' ctype          {% addAnnotation (gl $1) (toUnicodeAnn AnnDarrow $2) (gl $2)-                                         >> return (sLL $1 $> $-                                            HsQualTy { hst_ctxt = $1-                                                     , hst_xqual = noExtField-                                                     , hst_body = $3 }) }-        | ipvar '::' type             {% ams (sLL $1 $> (HsIParamTy noExtField $1 $3))-                                             [mu AnnDcolon $2] }-        | type                        { $1 }--------------------------- Notes for 'context'--- We parse a context as a btype so that we don't get reduce/reduce--- errors in ctype.  The basic problem is that---      (Eq a, Ord a)--- looks so much like a tuple type.  We can't tell until we find the =>--context :: { LHsContext GhcPs }-        :  btype                        {% do { (anns,ctx) <- checkContext $1-                                                ; if null (unLoc ctx)-                                                   then addAnnotation (gl $1) AnnUnit (gl $1)-                                                   else return ()-                                                ; ams ctx anns-                                                } }--{- Note [GADT decl discards annotations]-~~~~~~~~~~~~~~~~~~~~~-The type production for--    btype `->` ctype--add the AnnRarrow annotation twice, in different places.--This is because if the type is processed as usual, it belongs on the annotations-for the type as a whole.--But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and-the top-level annotation will be disconnected. Hence for this specific case it-is connected to the first type too.--}--type :: { LHsType GhcPs }-        : btype                        { $1 }-        | btype '->' ctype             {% ams $1 [mu AnnRarrow $2] -- See Note [GADT decl discards annotations]-                                       >> ams (sLL $1 $> $ HsFunTy noExtField (HsUnrestrictedArrow (toUnicode $2)) $1 $3)-                                              [mu AnnRarrow $2] }--        | btype mult '->' ctype        {% hintLinear (getLoc $2)-                                       >> let (arr, ann) = (unLoc $2) (toUnicode $3)-                                          in (ams $1 [ann,mu AnnRarrow $3] -- See Note [GADT decl discards annotations]-                                             >> ams (sLL $1 $> $ HsFunTy noExtField arr $1 $4)-                                                  [ann,mu AnnRarrow $3]) }--        | btype '->.' ctype            {% hintLinear (getLoc $2)-                                       >> ams $1 [mu AnnLollyU $2] -- See Note [GADT decl discards annotations]-                                       >> ams (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow UnicodeSyntax) $1 $3)-                                              [mu AnnLollyU $2] }--mult :: { Located (IsUnicodeSyntax -> (HsArrow GhcPs, AddAnn)) }-        : PREFIX_PERCENT atype          { sLL $1 $> (\u -> mkMultTy u $1 $2) }--btype :: { LHsType GhcPs }-        : tyapps                        {% mergeOps (unLoc $1) }--tyapps :: { Located [Located TyEl] } -- NB: This list is reversed-        : tyapp                         { sL1 $1 [$1] }-        | tyapps tyapp                  { sLL $1 $> $ $2 : unLoc $1 }--tyapp :: { Located TyEl }-        : atype                         { sL1 $1 $ TyElOpd (unLoc $1) }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_AT atype               { sLL $1 $> $ (TyElKindApp (comb2 $1 $2) $2) }--        | qtyconop                      { sL1 $1 $ TyElOpr (unLoc $1) }-        | tyvarop                       { sL1 $1 $ TyElOpr (unLoc $1) }-        | SIMPLEQUOTE qconop            {% ams (sLL $1 $> $ TyElOpr (unLoc $2))-                                               [mj AnnSimpleQuote $1,mj AnnVal $2] }-        | SIMPLEQUOTE varop             {% ams (sLL $1 $> $ TyElOpr (unLoc $2))-                                               [mj AnnSimpleQuote $1,mj AnnVal $2] }-        | unpackedness                  { sL1 $1 $ TyElUnpackedness (unLoc $1) }--atype :: { LHsType GhcPs }-        : ntgtycon                       { sL1 $1 (HsTyVar noExtField NotPromoted $1) }      -- Not including unit tuples-        | tyvar                          { sL1 $1 (HsTyVar noExtField NotPromoted $1) }      -- (See Note [Unit tuples])-        | '*'                            {% do { warnStarIsType (getLoc $1)-                                               ; return $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE atype             {% ams (sLL $1 $> (mkBangTy SrcLazy $2)) [mj AnnTilde $1] }-        | PREFIX_BANG  atype             {% ams (sLL $1 $> (mkBangTy SrcStrict $2)) [mj AnnBang $1] }--        | '{' fielddecls '}'             {% amms (checkRecordSyntax-                                                    (sLL $1 $> $ HsRecTy noExtField $2))-                                                        -- Constructor sigs only-                                                 [moc $1,mcc $3] }-        | '(' ')'                        {% ams (sLL $1 $> $ HsTupleTy noExtField-                                                    HsBoxedOrConstraintTuple [])-                                                [mop $1,mcp $2] }-        | '(' ktype ',' comma_types1 ')' {% addAnnotation (gl $2) AnnComma-                                                          (gl $3) >>-                                            ams (sLL $1 $> $ HsTupleTy noExtField--                                             HsBoxedOrConstraintTuple ($2 : $4))-                                                [mop $1,mcp $5] }-        | '(#' '#)'                   {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple [])-                                             [mo $1,mc $2] }-        | '(#' comma_types1 '#)'      {% ams (sLL $1 $> $ HsTupleTy noExtField HsUnboxedTuple $2)-                                             [mo $1,mc $3] }-        | '(#' bar_types2 '#)'        {% ams (sLL $1 $> $ HsSumTy noExtField $2)-                                             [mo $1,mc $3] }-        | '[' ktype ']'               {% ams (sLL $1 $> $ HsListTy  noExtField $2) [mos $1,mcs $3] }-        | '(' ktype ')'               {% ams (sLL $1 $> $ HsParTy   noExtField $2) [mop $1,mcp $3] }-        | quasiquote                  { mapLoc (HsSpliceTy noExtField) $1 }-        | splice_untyped              { mapLoc (HsSpliceTy noExtField) $1 }-                                      -- see Note [Promotion] for the followings-        | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] }-        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'-                             {% addAnnotation (gl $3) AnnComma (gl $4) >>-                                ams (sLL $1 $> $ HsExplicitTupleTy noExtField ($3 : $5))-                                    [mj AnnSimpleQuote $1,mop $2,mcp $6] }-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% ams (sLL $1 $> $ HsExplicitListTy noExtField IsPromoted $3)-                                                       [mj AnnSimpleQuote $1,mos $2,mcs $4] }-        | SIMPLEQUOTE var                       {% ams (sLL $1 $> $ HsTyVar noExtField IsPromoted $2)-                                                       [mj AnnSimpleQuote $1,mj AnnName $2] }--        -- Two or more [ty, ty, ty] must be a promoted list type, just as-        -- if you had written '[ty, ty, ty]-        -- (One means a list type, zero means the list type constructor,-        -- so you have to quote those.)-        | '[' ktype ',' comma_types1 ']'  {% addAnnotation (gl $2) AnnComma-                                                           (gl $3) >>-                                             ams (sLL $1 $> $ HsExplicitListTy noExtField NotPromoted ($2 : $4))-                                                 [mos $1,mcs $5] }-        | INTEGER              { sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)-                                                           (il_value (getINTEGER $1)) }-        | STRING               { sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)-                                                                     (getSTRING  $1) }-        | '_'                  { sL1 $1 $ mkAnonWildCardTy }---- An inst_type is what occurs in the head of an instance decl---      e.g.  (Foo a, Gaz b) => Wibble a b--- It's kept as a single type for convenience.-inst_type :: { LHsSigType GhcPs }-        : sigtype                       { mkLHsSigType $1 }--deriv_types :: { [LHsSigType GhcPs] }-        : ktype                         { [mkLHsSigType $1] }--        | ktype ',' deriv_types         {% addAnnotation (gl $1) AnnComma (gl $2)-                                           >> return (mkLHsSigType $1 : $3) }--comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty-        : comma_types1                  { $1 }-        | {- empty -}                   { [] }--comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty-        : ktype                        { [$1] }-        | ktype  ',' comma_types1      {% addAnnotation (gl $1) AnnComma (gl $2)-                                          >> return ($1 : $3) }--bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty-        : ktype  '|' ktype             {% addAnnotation (gl $1) AnnVbar (gl $2)-                                          >> return [$1,$3] }-        | ktype  '|' bar_types2        {% addAnnotation (gl $1) AnnVbar (gl $2)-                                          >> return ($1 : $3) }--tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }-         : tv_bndr tv_bndrs             { $1 : $2 }-         | {- empty -}                  { [] }--tv_bndr :: { LHsTyVarBndr Specificity GhcPs }-        : tv_bndr_no_braces             { $1 }-        | '{' tyvar '}'                 {% ams (sLL $1 $> (UserTyVar noExtField InferredSpec $2))-                                               [moc $1, mcc $3] }-        | '{' tyvar '::' kind '}'       {% ams (sLL $1 $> (KindedTyVar noExtField InferredSpec $2 $4))-                                               [moc $1,mu AnnDcolon $3-                                               ,mcc $5] }--tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }-        : tyvar                         { sL1 $1 (UserTyVar noExtField SpecifiedSpec $1) }-        | '(' tyvar '::' kind ')'       {% ams (sLL $1 $> (KindedTyVar noExtField SpecifiedSpec $2 $4))-                                               [mop $1,mu AnnDcolon $3-                                               ,mcp $5] }--fds :: { Located ([AddAnn],[Located (FunDep (Located RdrName))]) }-        : {- empty -}                   { noLoc ([],[]) }-        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]-                                                 ,reverse (unLoc $2))) }--fds1 :: { Located [Located (FunDep (Located RdrName))] }-        : fds1 ',' fd   {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2)-                           >> return (sLL $1 $> ($3 : unLoc $1)) }-        | fd            { sL1 $1 [$1] }--fd :: { Located (FunDep (Located RdrName)) }-        : varids0 '->' varids0  {% ams (L (comb3 $1 $2 $3)-                                       (reverse (unLoc $1), reverse (unLoc $3)))-                                       [mu AnnRarrow $2] }--varids0 :: { Located [Located RdrName] }-        : {- empty -}                   { noLoc [] }-        | varids0 tyvar                 { sLL $1 $> ($2 : unLoc $1) }---------------------------------------------------------------------------------- Kinds--kind :: { LHsKind GhcPs }-        : ctype                  { $1 }--{- Note [Promotion]-   ~~~~~~~~~~~~~~~~--- Syntax of promoted qualified names-We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified-names. Moreover ticks are only allowed in types, not in kinds, for a-few reasons:-  1. we don't need quotes since we cannot define names in kinds-  2. if one day we merge types and kinds, tick would mean look in DataName-  3. we don't have a kind namespace anyway--- Name resolution-When the user write Zero instead of 'Zero in types, we parse it a-HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We-deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not-bounded in the type level, then we look for it in the term level (we-change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).-And both become a HsTyVar ("Zero", DataName) after the renamer.---}----------------------------------------------------------------------------------- Datatype declarations--gadt_constrlist :: { Located ([AddAnn]-                          ,[LConDecl GhcPs]) } -- Returned in order--        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1-                                                         ,moc $2-                                                         ,mcc $4]-                                                        , unLoc $3) }-        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1]-                                                        , unLoc $3) }-        | {- empty -}                            { noLoc ([],[]) }--gadt_constrs :: { Located [LConDecl GhcPs] }-        : gadt_constr ';' gadt_constrs-                  {% addAnnotation (gl $1) AnnSemi (gl $2)-                     >> return (L (comb2 $1 $3) ($1 : unLoc $3)) }-        | gadt_constr                   { L (gl $1) [$1] }-        | {- empty -}                   { noLoc [] }---- We allow the following forms:---      C :: Eq a => a -> T a---      C :: forall a. Eq a => !a -> T a---      D { x,y :: a } :: T a---      forall a. Eq a => D { x,y :: a } :: T a--gadt_constr :: { LConDecl GhcPs }-    -- see Note [Difference in parsing GADT and data constructors]-    -- Returns a list because of:   C,D :: ty-        : optSemi con_list '::' sigtype-                {% do { (decl, anns) <- mkGadtDecl (unLoc $2) $4-                      ; ams (sLL $2 $> decl)-                            (mu AnnDcolon $3:anns) } }--{- Note [Difference in parsing GADT and data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GADT constructors have simpler syntax than usual data constructors:-in GADTs, types cannot occur to the left of '::', so they cannot be mixed-with constructor names (see Note [Parsing data constructors is hard]).--Due to simplified syntax, GADT constructor names (left-hand side of '::')-use simpler grammar production than usual data constructor names. As a-consequence, GADT constructor names are restricted (names like '(*)' are-allowed in usual data constructors, but not in GADTs).--}--constrs :: { Located ([AddAnn],[LConDecl GhcPs]) }-        : '=' constrs1    { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}--constrs1 :: { Located [LConDecl GhcPs] }-        : constrs1 '|' constr-            {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2)-               >> return (sLL $1 $> ($3 : unLoc $1)) }-        | constr                                          { sL1 $1 [$1] }--constr :: { LConDecl GhcPs }-        : forall context '=>' constr_stuff-                {% ams (let (con,details) = unLoc $4 in-                  (L (comb4 $1 $2 $3 $4) (mkConDeclH98 con-                                             (snd $ unLoc $1)-                                             (Just $2)-                                             details)))-                        (mu AnnDarrow $3:(fst $ unLoc $1)) }-        | forall constr_stuff-                {% ams (let (con,details) = unLoc $2 in-                  (L (comb2 $1 $2) (mkConDeclH98 con-                                            (snd $ unLoc $1)-                                            Nothing   -- No context-                                            details)))-                       (fst $ unLoc $1) }--forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }-        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }-        | {- empty -}                 { noLoc ([], Nothing) }--constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) }-        : tyapps                           {% do { c <- mergeDataCon (unLoc $1)-                                                 ; return $ sL1 $1 c } }--fielddecls :: { [LConDeclField GhcPs] }-        : {- empty -}     { [] }-        | fielddecls1     { $1 }--fielddecls1 :: { [LConDeclField GhcPs] }-        : fielddecl ',' fielddecls1-            {% addAnnotation (gl $1) AnnComma (gl $2) >>-               return ($1 : $3) }-        | fielddecl   { [$1] }--fielddecl :: { LConDeclField GhcPs }-                                              -- A list because of   f,g :: Int-        : sig_vars '::' ctype-            {% ams (L (comb2 $1 $3)-                      (ConDeclField noExtField (reverse (map (\ln@(L l n) -> L l $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))-                   [mu AnnDcolon $2] }---- Reversed!-maybe_derivings :: { HsDeriving GhcPs }-        : {- empty -}             { noLoc [] }-        | derivings               { $1 }---- A list of one or more deriving clauses at the end of a datatype-derivings :: { HsDeriving GhcPs }-        : derivings deriving      { sLL $1 $> $ $2 : unLoc $1 }-        | deriving                { sLL $1 $> [$1] }---- The outer Located is just to allow the caller to--- know the rightmost extremity of the 'deriving' clause-deriving :: { LHsDerivingClause GhcPs }-        : 'deriving' deriv_clause_types-              {% let { full_loc = comb2 $1 $> }-                 in ams (L full_loc $ HsDerivingClause noExtField Nothing $2)-                        [mj AnnDeriving $1] }--        | 'deriving' deriv_strategy_no_via deriv_clause_types-              {% let { full_loc = comb2 $1 $> }-                 in ams (L full_loc $ HsDerivingClause noExtField (Just $2) $3)-                        [mj AnnDeriving $1] }--        | 'deriving' deriv_clause_types deriv_strategy_via-              {% let { full_loc = comb2 $1 $> }-                 in ams (L full_loc $ HsDerivingClause noExtField (Just $3) $2)-                        [mj AnnDeriving $1] }--deriv_clause_types :: { Located [LHsSigType GhcPs] }-        : qtycon              { let { tc = sL1 $1 (HsTyVar noExtField NotPromoted $1) } in-                                sL1 $1 [mkLHsSigType tc] }-        | '(' ')'             {% ams (sLL $1 $> [])-                                     [mop $1,mcp $2] }-        | '(' deriv_types ')' {% ams (sLL $1 $> $2)-                                     [mop $1,mcp $3] }-             -- Glasgow extension: allow partial-             -- applications in derivings---------------------------------------------------------------------------------- Value definitions--{- Note [Declaration/signature overlap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's an awkward overlap with a type signature.  Consider-        f :: Int -> Int = ...rhs...-   Then we can't tell whether it's a type signature or a value-   definition with a result signature until we see the '='.-   So we have to inline enough to postpone reductions until we know.--}--{--  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var-  instead of qvar, we get another shift/reduce-conflict. Consider the-  following programs:--     { (^^) :: Int->Int ; }          Type signature; only var allowed--     { (^^) :: Int->Int = ... ; }    Value defn with result signature;-                                     qvar allowed (because of instance decls)--  We can't tell whether to reduce var to qvar until after we've read the signatures.--}--decl_no_th :: { LHsDecl GhcPs }-        : sigdecl               { $1 }--        | infixexp     opt_sig rhs  {% runECP_P $1 >>= \ $1 ->-                                       do { (ann,r) <- checkValDef $1 (snd $2) $3;-                                        let { l = comb2 $1 $> };-                                        -- Depending upon what the pattern looks like we might get either-                                        -- a FunBind or PatBind back from checkValDef. See Note-                                        -- [FunBind vs PatBind]-                                        case r of {-                                          (FunBind _ n _ _) ->-                                                amsL l (mj AnnFunId n:(fst $2)) >> return () ;-                                          (PatBind _ (L lh _lhs) _rhs _) ->-                                                amsL lh (fst $2) >> return () } ;-                                        _ <- amsL l (ann ++ (fst $ unLoc $3));-                                        return $! (sL l $ ValD noExtField r) } }-        | pattern_synonym_decl  { $1 }--decl    :: { LHsDecl GhcPs }-        : decl_no_th            { $1 }--        -- Why do we only allow naked declaration splices in top-level-        -- declarations and not here? Short answer: because readFail009-        -- fails terribly with a panic in cvBindsAndSigs otherwise.-        | splice_exp            { sLL $1 $> $ mkSpliceDecl $1 }--rhs     :: { Located ([AddAnn],GRHSs GhcPs (LHsExpr GhcPs)) }-        : '=' exp wherebinds    {% runECP_P $2 >>= \ $2 -> return $-                                  sL (comb3 $1 $2 $3)-                                    ((mj AnnEqual $1 : (fst $ unLoc $3))-                                    ,GRHSs noExtField (unguardedRHS (comb3 $1 $2 $3) $2)-                                   (snd $ unLoc $3)) }-        | gdrhs wherebinds      { sLL $1 $>  (fst $ unLoc $2-                                    ,GRHSs noExtField (reverse (unLoc $1))-                                                    (snd $ unLoc $2)) }--gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }-        : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }-        | gdrh                  { sL1 $1 [$1] }--gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }-        : '|' guardquals '=' exp  {% runECP_P $4 >>= \ $4 ->-                                     ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4)-                                         [mj AnnVbar $1,mj AnnEqual $3] }--sigdecl :: { LHsDecl GhcPs }-        :-        -- See Note [Declaration/signature overlap] for why we need infixexp here-          infixexp     '::' sigtype-                        {% do { $1 <- runECP_P $1-                              ; v <- checkValSigLhs $1-                              ; _ <- amsL (comb2 $1 $>) [mu AnnDcolon $2]-                              ; return (sLL $1 $> $ SigD noExtField $-                                  TypeSig noExtField [v] (mkLHsSigWcType $3))} }--        | var ',' sig_vars '::' sigtype-           {% do { let sig = TypeSig noExtField ($1 : reverse (unLoc $3))-                                     (mkLHsSigWcType $5)-                 ; addAnnotation (gl $1) AnnComma (gl $2)-                 ; ams ( sLL $1 $> $ SigD noExtField sig )-                       [mu AnnDcolon $4] } }--        | infix prec ops-              {% checkPrecP $2 $3 >>-                 ams (sLL $1 $> $ SigD noExtField-                        (FixSig noExtField (FixitySig noExtField (fromOL $ unLoc $3)-                                (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1)))))-                     [mj AnnInfix $1,mj AnnVal $2] }--        | pattern_synonym_sig   { sLL $1 $> . SigD noExtField . unLoc $ $1 }--        | '{-# COMPLETE' con_list opt_tyconsig  '#-}'-                {% let (dcolon, tc) = $3-                   in ams-                       (sLL $1 $>-                         (SigD noExtField (CompleteMatchSig noExtField (getCOMPLETE_PRAGs $1) $2 tc)))-                    ([ mo $1 ] ++ dcolon ++ [mc $4]) }--        -- This rule is for both INLINE and INLINABLE pragmas-        | '{-# INLINE' activation qvar '#-}'-                {% ams ((sLL $1 $> $ SigD noExtField (InlineSig noExtField $3-                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)-                                            (snd $2)))))-                       ((mo $1:fst $2) ++ [mc $4]) }--        | '{-# SCC' qvar '#-}'-          {% ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 Nothing)))-                 [mo $1, mc $3] }--        | '{-# SCC' qvar STRING '#-}'-          {% do { scc <- getSCC $3-                ; let str_lit = StringLiteral (getSTRINGs $3) scc-                ; ams (sLL $1 $> (SigD noExtField (SCCFunSig noExtField (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit)))))-                      [mo $1, mc $4] } }--        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'-             {% ams (-                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)-                                             (NoUserInline, FunLike) (snd $2)-                  in sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5) inl_prag))-                    (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }--        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'-             {% ams (sLL $1 $> $ SigD noExtField (SpecSig noExtField $3 (fromOL $5)-                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)-                                               (getSPEC_INLINE $1) (snd $2))))-                       (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) }--        | '{-# SPECIALISE' 'instance' inst_type '#-}'-                {% ams (sLL $1 $>-                                  $ SigD noExtField (SpecInstSig noExtField (getSPEC_PRAGs $1) $3))-                       [mo $1,mj AnnInstance $2,mc $4] }--        -- A minimal complete definition-        | '{-# MINIMAL' name_boolformula_opt '#-}'-            {% ams (sLL $1 $> $ SigD noExtField (MinimalSig noExtField (getMINIMAL_PRAGs $1) $2))-                   [mo $1,mc $3] }--activation :: { ([AddAnn],Maybe Activation) }-        : {- empty -}                           { ([],Nothing) }-        | explicit_activation                   { (fst $1,Just (snd $1)) }--explicit_activation :: { ([AddAnn],Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }---------------------------------------------------------------------------------- Expressions--quasiquote :: { Located (HsSplice GhcPs) }-        : TH_QUASIQUOTE   { let { loc = getLoc $1-                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkUnqual varName quoter }-                            in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }-        | TH_QQUASIQUOTE  { let { loc = getLoc $1-                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkQual varName (qual, quoter) }-                            in sL (getLoc $1) (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }--exp   :: { ECP }-        : infixexp '::' sigtype-                                { ECP $-                                   runECP_PV $1 >>= \ $1 ->-                                   rejectPragmaPV $1 >>-                                   amms (mkHsTySigPV (comb2 $1 $>) $1 $3)-                                       [mu AnnDcolon $2] }-        | infixexp '-<' exp     {% runECP_P $1 >>= \ $1 ->-                                   runECP_P $3 >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3-                                                        HsFirstOrderApp True)-                                       [mu Annlarrowtail $2] }-        | infixexp '>-' exp     {% runECP_P $1 >>= \ $1 ->-                                   runECP_P $3 >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1-                                                      HsFirstOrderApp False)-                                       [mu Annrarrowtail $2] }-        | infixexp '-<<' exp    {% runECP_P $1 >>= \ $1 ->-                                   runECP_P $3 >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   ams (sLL $1 $> $ HsCmdArrApp noExtField $1 $3-                                                      HsHigherOrderApp True)-                                       [mu AnnLarrowtail $2] }-        | infixexp '>>-' exp    {% runECP_P $1 >>= \ $1 ->-                                   runECP_P $3 >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   ams (sLL $1 $> $ HsCmdArrApp noExtField $3 $1-                                                      HsHigherOrderApp False)-                                       [mu AnnRarrowtail $2] }-        | infixexp              { $1 }-        | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]--infixexp :: { ECP }-        : exp10 { $1 }-        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]-                               { ECP $-                                 superInfixOp $-                                 $2 >>= \ $2 ->-                                 runECP_PV $1 >>= \ $1 ->-                                 runECP_PV $3 >>= \ $3 ->-                                 rejectPragmaPV $1 >>-                                 amms (mkHsOpAppPV (comb2 $1 $>) $1 $2 $3)-                                     [mj AnnVal $2] }-                 -- AnnVal annotation for NPlusKPat, which discards the operator--exp10p :: { ECP }-  : exp10            { $1 }-  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]--exp_prag(e) :: { ECP }-  : prag_e e  -- See Note [Pragmas and operator fixity]-      {% runECP_P $2 >>= \ $2 ->-         fmap ecpFromExp $-         ams (sLL $1 $> $ HsPragE noExtField (snd $ unLoc $1) $2)-             (fst $ unLoc $1) }--exp10 :: { ECP }-        : '-' fexp                      { ECP $-                                           runECP_PV $2 >>= \ $2 ->-                                           amms (mkHsNegAppPV (comb2 $1 $>) $2)-                                               [mj AnnMinus $1] }-        | fexp                         { $1 }--optSemi :: { ([Located Token],Bool) }-        : ';'         { ([$1],True) }-        | {- empty -} { ([],False) }--{- Note [Pragmas and operator fixity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'prag_e' is an expression pragma, such as {-# SCC ... #-} or-{-# GENERATED ... #-}.--It must be used with care, or else #15730 happens. Consider this infix-expression:--         1 / 2 / 2--There are two ways to parse it:--    1.   (1 / 2) / 2   =  0.25-    2.   1 / (2 / 2)   =  1.0--Due to the fixity of the (/) operator (assuming it comes from Prelude),-option 1 is the correct parse. However, in the past GHC's parser used to get-confused by the SCC annotation when it occurred in the middle of an infix-expression:--         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2--There are several ways to address this issue, see GHC Proposal #176 for a-detailed exposition:--  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst--The accepted fix is to disallow pragmas that occur within infix expressions.-Infix expressions are assembled out of 'exp10', so 'exp10' must not accept-pragmas. Instead, we accept them in exactly two places:--* at the start of an expression or a parenthesized subexpression:--    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression-    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression--* immediately after the last operator:--    f = 1 / 2 / {-# SCC ann #-} 2--In both cases, the parse does not depend on operator fixity. The second case-may sound unnecessary, but it's actually needed to support a common idiom:--    f $ {-# SCC ann $-} ...---}-prag_e :: { Located ([AddAnn], HsPragE GhcPs) }-      : '{-# SCC' STRING '#-}'      {% do scc <- getSCC $2-                                          ; return $ sLL $1 $>-                                             ([mo $1,mj AnnValStr $2,mc $3],-                                              HsPragSCC noExtField-                                                (getSCC_PRAGs $1)-                                                (StringLiteral (getSTRINGs $2) scc)) }-      | '{-# SCC' VARID  '#-}'      { sLL $1 $> ([mo $1,mj AnnVal $2,mc $3],-                                                  HsPragSCC noExtField-                                                    (getSCC_PRAGs $1)-                                                    (StringLiteral NoSourceText (getVARID $2))) }-      | '{-# GENERATED' STRING INTEGER ':' INTEGER HYPHEN INTEGER ':' INTEGER '#-}'-                                      { let getINT = fromInteger . il_value . getINTEGER in-                                        sLL $1 $> $ ([mo $1,mj AnnVal $2-                                              ,mj AnnVal $3,mj AnnColon $4-                                              ,mj AnnVal $5] ++ $6 ++-                                              [mj AnnVal $7,mj AnnColon $8-                                              ,mj AnnVal $9,mc $10],-                                              HsPragTick noExtField-                                                (getGENERATED_PRAGs $1)-                                                (getStringLiteral $2,-                                                 (getINT $3, getINT $5),-                                                 (getINT $7, getINT $9))-                                                ((getINTEGERs $3, getINTEGERs $5),-                                                 (getINTEGERs $7, getINTEGERs $9) )) }-fexp    :: { ECP }-        : fexp aexp                  { ECP $-                                          superFunArg $-                                          runECP_PV $1 >>= \ $1 ->-                                          runECP_PV $2 >>= \ $2 ->-                                          mkHsAppPV (comb2 $1 $>) $1 $2 }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | fexp PREFIX_AT atype       { ECP $-                                        runECP_PV $1 >>= \ $1 ->-                                        amms (mkHsAppTypePV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }--        | 'static' aexp              {% runECP_P $2 >>= \ $2 ->-                                        fmap ecpFromExp $-                                        ams (sLL $1 $> $ HsStatic noExtField $2)-                                            [mj AnnStatic $1] }-        | aexp                       { $1 }--aexp    :: { ECP }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : qvar TIGHT_INFIX_AT aexp-                                { ECP $-                                   runECP_PV $3 >>= \ $3 ->-                                   amms (mkHsAsPatPV (comb2 $1 $>) $1 $3) [mj AnnAt $2] }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE aexp     { ECP $-                                   runECP_PV $2 >>= \ $2 ->-                                   amms (mkHsLazyPatPV (comb2 $1 $>) $2) [mj AnnTilde $1] }-        | PREFIX_BANG aexp      { ECP $-                                   runECP_PV $2 >>= \ $2 ->-                                   amms (mkHsBangPatPV (comb2 $1 $>) $2) [mj AnnBang $1] }-        | PREFIX_MINUS aexp     { ECP $-                                   runECP_PV $2 >>= \ $2 ->-                                   amms (mkHsNegAppPV (comb2 $1 $>) $2) [mj AnnMinus $1] }--        | '\\' apat apats '->' exp-                   {  ECP $-                      runECP_PV $5 >>= \ $5 ->-                      amms (mkHsLamPV (comb2 $1 $>) (mkMatchGroup FromSource-                            [sLL $1 $> $ Match { m_ext = noExtField-                                               , m_ctxt = LambdaExpr-                                               , m_pats = $2:$3-                                               , m_grhss = unguardedGRHSs $5 }]))-                          [mj AnnLam $1, mu AnnRarrow $4] }-        | 'let' binds 'in' exp          {  ECP $-                                           runECP_PV $4 >>= \ $4 ->-                                           amms (mkHsLetPV (comb2 $1 $>) (snd (unLoc $2)) $4)-                                               (mj AnnLet $1:mj AnnIn $3-                                                 :(fst $ unLoc $2)) }-        | '\\' 'lcase' altslist-            {  ECP $ $3 >>= \ $3 ->-               amms (mkHsLamCasePV (comb2 $1 $>)-                                   (mkMatchGroup FromSource (snd $ unLoc $3)))-                    (mj AnnLam $1:mj AnnCase $2:(fst $ unLoc $3)) }-        | 'if' exp optSemi 'then' exp optSemi 'else' exp-                         {% runECP_P $2 >>= \ $2 ->-                            return $ ECP $-                              runECP_PV $5 >>= \ $5 ->-                              runECP_PV $8 >>= \ $8 ->-                              amms (mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8)-                                  (mj AnnIf $1:mj AnnThen $4-                                     :mj AnnElse $7-                                     :(map (\l -> mj AnnSemi l) (fst $3))-                                    ++(map (\l -> mj AnnSemi l) (fst $6))) }-        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->-                                           fmap ecpFromExp $-                                           ams (sLL $1 $> $ HsMultiIf noExtField-                                                     (reverse $ snd $ unLoc $2))-                                               (mj AnnIf $1:(fst $ unLoc $2)) }-        | 'case' exp 'of' altslist    {% runECP_P $2 >>= \ $2 ->-                                         return $ ECP $-                                           $4 >>= \ $4 ->-                                           amms (mkHsCasePV (comb3 $1 $3 $4) $2 (mkMatchGroup-                                                   FromSource (snd $ unLoc $4)))-                                               (mj AnnCase $1:mj AnnOf $3-                                                  :(fst $ unLoc $4)) }-        -- QualifiedDo.-        | DO  stmtlist               {% do-                                      hintQualifiedDo $1-                                      return $ ECP $-                                        $2 >>= \ $2 ->-                                        amms (mkHsDoPV (comb2 $1 $2)-                                                       (fmap mkModuleNameFS (getDO $1))-                                                       (mapLoc snd $2))-                                             (mj AnnDo $1:(fst $ unLoc $2)) }-        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->-                                       fmap ecpFromExp $-                                       ams (L (comb2 $1 $2)-                                              (mkHsDo (MDoExpr $-                                                        fmap mkModuleNameFS (getMDO $1))-                                                        (snd $ unLoc $2)))-                                           (mj AnnMdo $1:(fst $ unLoc $2)) }-        | 'proc' aexp '->' exp-                       {% (checkPattern <=< runECP_P) $2 >>= \ p ->-                           runECP_P $4 >>= \ $4@cmd ->-                           fmap ecpFromExp $-                           ams (sLL $1 $> $ HsProc noExtField p (sLL $1 $> $ HsCmdTop noExtField cmd))-                                            -- TODO: is LL right here?-                               [mj AnnProc $1,mu AnnRarrow $3] }--        | aexp1                 { $1 }--aexp1   :: { ECP }-        : aexp1 '{' fbinds '}' { ECP $-                                  runECP_PV $1 >>= \ $1 ->-                                  $3 >>= \ $3 ->-                                  amms (mkHsRecordPV (comb2 $1 $>) (comb2 $2 $4) $1 (snd $3))-                                       (moc $2:mcc $4:(fst $3)) }-        | aexp2                { $1 }--aexp2   :: { ECP }-        : qvar                          { ECP $ mkHsVarPV $! $1 }-        | qcon                          { ECP $ mkHsVarPV $! $1 }-        | ipvar                         { ecpFromExp $ sL1 $1 (HsIPVar noExtField $! unLoc $1) }-        | overloaded_label              { ecpFromExp $ sL1 $1 (HsOverLabel noExtField Nothing $! unLoc $1) }-        | literal                       { ECP $ mkHsLitPV $! $1 }--- This will enable overloaded strings permanently.  Normally the renamer turns HsString--- into HsOverLit when -foverloaded-strings is on.---      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)---                                       (getSTRING $1) noExtField) }-        | INTEGER   { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral   (getINTEGER  $1)) }-        | RATIONAL  { ECP $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) }--        -- N.B.: sections get parsed by these next two productions.-        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't-        -- correct Haskell (you'd have to write '((+ 3), (4 -))')-        -- but the less cluttered version fell out of having texps.-        | '(' texp ')'                  { ECP $-                                           runECP_PV $2 >>= \ $2 ->-                                           amms (mkHsParPV (comb2 $1 $>) $2) [mop $1,mcp $3] }-        | '(' tup_exprs ')'             { ECP $-                                           $2 >>= \ $2 ->-                                           amms (mkSumOrTuplePV (comb2 $1 $>) Boxed (snd $2))-                                                ((mop $1:fst $2) ++ [mcp $3]) }--        | '(#' texp '#)'                { ECP $-                                           runECP_PV $2 >>= \ $2 ->-                                           amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (Tuple [L (gl $2) (Just $2)]))-                                                [mo $1,mc $3] }-        | '(#' tup_exprs '#)'           { ECP $-                                           $2 >>= \ $2 ->-                                           amms (mkSumOrTuplePV (comb2 $1 $>) Unboxed (snd $2))-                                                ((mo $1:fst $2) ++ [mc $3]) }--        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) >>= \a -> ams a [mos $1,mcs $3] }-        | '_'               { ECP $ mkHsWildCardPV (getLoc $1) }--        -- Template Haskell Extension-        | splice_untyped { ECP $ mkHsSplicePV $1 }-        | splice_typed   { ecpFromExp $ mapLoc (HsSpliceE noExtField) $1 }--        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }-        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField True  (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] }-        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }-        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ ams (sLL $1 $> $ HsBracket noExtField (VarBr noExtField False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] }-        | TH_TY_QUOTE {- nothing -} {% reportEmptyDoubleQuotes (getLoc $1) }-        | '[|' exp '|]'       {% runECP_P $2 >>= \ $2 ->-                                 fmap ecpFromExp $-                                 ams (sLL $1 $> $ HsBracket noExtField (ExpBr noExtField $2))-                                      (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]-                                                    else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) }-        | '[||' exp '||]'     {% runECP_P $2 >>= \ $2 ->-                                 fmap ecpFromExp $-                                 ams (sLL $1 $> $ HsBracket noExtField (TExpBr noExtField $2))-                                      (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) }-        | '[t|' ktype '|]'    {% fmap ecpFromExp $-                                 ams (sLL $1 $> $ HsBracket noExtField (TypBr noExtField $2)) [mo $1,mu AnnCloseQ $3] }-        | '[p|' infixexp '|]' {% (checkPattern <=< runECP_P) $2 >>= \p ->-                                      fmap ecpFromExp $-                                      ams (sLL $1 $> $ HsBracket noExtField (PatBr noExtField p))-                                          [mo $1,mu AnnCloseQ $3] }-        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $-                                  ams (sLL $1 $> $ HsBracket noExtField (DecBrL noExtField (snd $2)))-                                      (mo $1:mu AnnCloseQ $3:fst $2) }-        | quasiquote          { ECP $ mkHsSplicePV $1 }--        -- arrow notation extension-        | '(|' aexp cmdargs '|)'  {% runECP_P $2 >>= \ $2 ->-                                     fmap ecpFromCmd $-                                     ams (sLL $1 $> $ HsCmdArrForm noExtField $2 Prefix-                                                          Nothing (reverse $3))-                                         [mu AnnOpenB $1,mu AnnCloseB $4] }--splice_exp :: { LHsExpr GhcPs }-        : splice_untyped { mapLoc (HsSpliceE noExtField) $1 }-        | splice_typed   { mapLoc (HsSpliceE noExtField) $1 }--splice_untyped :: { Located (HsSplice GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR aexp2   {% runECP_P $2 >>= \ $2 ->-                                   ams (sLL $1 $> $ mkUntypedSplice DollarSplice $2)-                                       [mj AnnDollar $1] }--splice_typed :: { Located (HsSplice GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR_DOLLAR aexp2-                                {% runECP_P $2 >>= \ $2 ->-                                   ams (sLL $1 $> $ mkTypedSplice DollarSplice $2)-                                       [mj AnnDollarDollar $1] }--cmdargs :: { [LHsCmdTop GhcPs] }-        : cmdargs acmd                  { $2 : $1 }-        | {- empty -}                   { [] }--acmd    :: { LHsCmdTop GhcPs }-        : aexp                  {% runECP_P $1 >>= \ cmd ->-                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->-                                   return (sL1 cmd $ HsCmdTop noExtField cmd) }--cvtopbody :: { ([AddAnn],[LHsDecl GhcPs]) }-        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1-                                                  ,mj AnnCloseC $3],$2) }-        |      vocurly    cvtopdecls0 close    { ([],$2) }--cvtopdecls0 :: { [LHsDecl GhcPs] }-        : topdecls_semi         { cvTopDecls $1 }-        | topdecls              { cvTopDecls $1 }---------------------------------------------------------------------------------- Tuple expressions---- "texp" is short for tuple expressions:--- things that can appear unparenthesized as long as they're--- inside parens or delimitted by commas-texp :: { ECP }-        : exp                           { $1 }--        -- Note [Parsing sections]-        -- ~~~~~~~~~~~~~~~~~~~~~~~-        -- We include left and right sections here, which isn't-        -- technically right according to the Haskell standard.-        -- For example (3 +, True) isn't legal.-        -- However, we want to parse bang patterns like-        --      (!x, !y)-        -- and it's convenient to do so here as a section-        -- Then when converting expr to pattern we unravel it again-        -- Meanwhile, the renamer checks that real sections appear-        -- inside parens.-        | infixexp qop-                             {% runECP_P $1 >>= \ $1 ->-                                runPV (rejectPragmaPV $1) >>-                                runPV $2 >>= \ $2 ->-                                return $ ecpFromExp $-                                sLL $1 $> $ SectionL noExtField $1 $2 }-        | qopm infixexp      { ECP $-                                superInfixOp $-                                runECP_PV $2 >>= \ $2 ->-                                $1 >>= \ $1 ->-                                mkHsSectionR_PV (comb2 $1 $>) $1 $2 }--       -- View patterns get parenthesized above-        | exp '->' texp   { ECP $-                             runECP_PV $1 >>= \ $1 ->-                             runECP_PV $3 >>= \ $3 ->-                             amms (mkHsViewPatPV (comb2 $1 $>) $1 $3) [mu AnnRarrow $2] }---- Always at least one comma or bar.--- Though this can parse just commas (without any expressions), it won't--- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]--- in GHC.Hs.Expr.-tup_exprs :: { forall b. DisambECP b => PV ([AddAnn],SumOrTuple b) }-           : texp commas_tup_tail-                           { runECP_PV $1 >>= \ $1 ->-                             $2 >>= \ $2 ->-                             do { addAnnotation (gl $1) AnnComma (fst $2)-                                ; return ([],Tuple ((sL1 $1 (Just $1)) : snd $2)) } }--           | texp bars   { runECP_PV $1 >>= \ $1 -> return $-                            (mvbars (fst $2), Sum 1  (snd $2 + 1) $1) }--           | commas tup_tail-                 { $2 >>= \ $2 ->-                   do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (fst $1)-                      ; return-                           ([],Tuple (map (\l -> L l Nothing) (fst $1) ++ $2)) } }--           | bars texp bars0-                { runECP_PV $2 >>= \ $2 -> return $-                  (mvbars (fst $1) ++ mvbars (fst $3), Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2) }---- Always starts with commas; always follows an expr-commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Located (Maybe (Located b))]) }-commas_tup_tail : commas tup_tail-        { $2 >>= \ $2 ->-          do { mapM_ (\ll -> addAnnotation ll AnnComma ll) (tail $ fst $1)-             ; return (-            (head $ fst $1-            ,(map (\l -> L l Nothing) (tail $ fst $1)) ++ $2)) } }---- Always follows a comma-tup_tail :: { forall b. DisambECP b => PV [Located (Maybe (Located b))] }-          : texp commas_tup_tail { runECP_PV $1 >>= \ $1 ->-                                   $2 >>= \ $2 ->-                                   addAnnotation (gl $1) AnnComma (fst $2) >>-                                   return ((L (gl $1) (Just $1)) : snd $2) }-          | texp                 { runECP_PV $1 >>= \ $1 ->-                                   return [L (gl $1) (Just $1)] }-          | {- empty -}          { return [noLoc Nothing] }---------------------------------------------------------------------------------- List expressions---- The rules below are little bit contorted to keep lexps left-recursive while--- avoiding another shift/reduce-conflict.--- Never empty.-list :: { forall b. DisambECP b => SrcSpan -> PV (Located b) }-        : texp    { \loc -> runECP_PV $1 >>= \ $1 ->-                            mkHsExplicitListPV loc [$1] }-        | lexps   { \loc -> $1 >>= \ $1 ->-                            mkHsExplicitListPV loc (reverse $1) }-        | texp '..'  { \loc ->    runECP_PV $1 >>= \ $1 ->-                                  ams (L loc $ ArithSeq noExtField Nothing (From $1))-                                      [mj AnnDotdot $2]-                                      >>= ecpFromExp' }-        | texp ',' exp '..' { \loc ->-                                   runECP_PV $1 >>= \ $1 ->-                                   runECP_PV $3 >>= \ $3 ->-                                   ams (L loc $ ArithSeq noExtField Nothing (FromThen $1 $3))-                                       [mj AnnComma $2,mj AnnDotdot $4]-                                       >>= ecpFromExp' }-        | texp '..' exp  { \loc -> runECP_PV $1 >>= \ $1 ->-                                   runECP_PV $3 >>= \ $3 ->-                                   ams (L loc $ ArithSeq noExtField Nothing (FromTo $1 $3))-                                       [mj AnnDotdot $2]-                                       >>= ecpFromExp' }-        | texp ',' exp '..' exp { \loc ->-                                   runECP_PV $1 >>= \ $1 ->-                                   runECP_PV $3 >>= \ $3 ->-                                   runECP_PV $5 >>= \ $5 ->-                                   ams (L loc $ ArithSeq noExtField Nothing (FromThenTo $1 $3 $5))-                                       [mj AnnComma $2,mj AnnDotdot $4]-                                       >>= ecpFromExp' }-        | texp '|' flattenedpquals-             { \loc ->-                checkMonadComp >>= \ ctxt ->-                runECP_PV $1 >>= \ $1 ->-                ams (L loc $ mkHsComp ctxt (unLoc $3) $1)-                    [mj AnnVbar $2]-                    >>= ecpFromExp' }--lexps :: { forall b. DisambECP b => PV [Located b] }-        : lexps ',' texp           { $1 >>= \ $1 ->-                                     runECP_PV $3 >>= \ $3 ->-                                     addAnnotation (gl $ head $ $1)-                                                            AnnComma (gl $2) >>-                                      return (((:) $! $3) $! $1) }-        | texp ',' texp             { runECP_PV $1 >>= \ $1 ->-                                      runECP_PV $3 >>= \ $3 ->-                                      addAnnotation (gl $1) AnnComma (gl $2) >>-                                      return [$3,$1] }---------------------------------------------------------------------------------- List Comprehensions--flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : pquals   { case (unLoc $1) of-                    [qs] -> sL1 $1 qs-                    -- We just had one thing in our "parallel" list so-                    -- we simply return that thing directly--                    qss -> sL1 $1 [sL1 $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |-                                            qs <- qss]-                                            noExpr noSyntaxExpr]-                    -- We actually found some actual parallel lists so-                    -- we wrap them into as a ParStmt-                }--pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }-    : squals '|' pquals-                     {% addAnnotation (gl $ head $ unLoc $1) AnnVbar (gl $2) >>-                        return (sLL $1 $> (reverse (unLoc $1) : unLoc $3)) }-    | squals         { L (getLoc $1) [reverse (unLoc $1)] }--squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last-                                        -- one can "grab" the earlier ones-    : squals ',' transformqual-             {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>-                amsL (comb2 $1 $>) (fst $ unLoc $3) >>-                return (sLL $1 $> [sLL $1 $> ((snd $ unLoc $3) (reverse (unLoc $1)))]) }-    | squals ',' qual-             {% runPV $3 >>= \ $3 ->-                addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >>-                return (sLL $1 $> ($3 : unLoc $1)) }-    | transformqual        {% ams $1 (fst $ unLoc $1) >>-                              return (sLL $1 $> [L (getLoc $1) ((snd $ unLoc $1) [])]) }-    | qual                               {% runPV $1 >>= \ $1 ->-                                            return $ sL1 $1 [$1] }---  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }---  | '{|' pquals '|}'                       { sL1 $1 [$2] }---- It is possible to enable bracketing (associating) qualifier lists--- by uncommenting the lines with {| |} above. Due to a lack of--- consensus on the syntax, this feature is not being used until we--- get user demand.--transformqual :: { Located ([AddAnn],[LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }-                        -- Function is applied to a list of stmts *in order*-    : 'then' exp              {% runECP_P $2 >>= \ $2 -> return $-                                 sLL $1 $> ([mj AnnThen $1], \ss -> (mkTransformStmt ss $2)) }-    | 'then' exp 'by' exp     {% runECP_P $2 >>= \ $2 ->-                                 runECP_P $4 >>= \ $4 ->-                                 return $ sLL $1 $> ([mj AnnThen $1,mj AnnBy  $3],-                                                     \ss -> (mkTransformByStmt ss $2 $4)) }-    | 'then' 'group' 'using' exp-            {% runECP_P $4 >>= \ $4 ->-               return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3],-                                   \ss -> (mkGroupUsingStmt ss $4)) }--    | 'then' 'group' 'by' exp 'using' exp-            {% runECP_P $4 >>= \ $4 ->-               runECP_P $6 >>= \ $6 ->-               return $ sLL $1 $> ([mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5],-                                   \ss -> (mkGroupByUsingStmt ss $4 $6)) }---- Note that 'group' is a special_id, which means that you can enable--- TransformListComp while still using Data.List.group. However, this--- introduces a shift/reduce conflict. Happy chooses to resolve the conflict--- in by choosing the "group by" variant, which is what we want.---------------------------------------------------------------------------------- Guards--guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }--guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->-                               addAnnotation (gl $ head $ unLoc $1) AnnComma-                                             (gl $2) >>-                               return (sLL $1 $> ($3 : unLoc $1)) }-    | qual                  {% runPV $1 >>= \ $1 ->-                               return $ sL1 $1 [$1] }---------------------------------------------------------------------------------- Case alternatives--altslist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }-        : '{'            alts '}'  { $2 >>= \ $2 -> return $-                                     sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))-                                               ,(reverse (snd $ unLoc $2))) }-        |     vocurly    alts  close { $2 >>= \ $2 -> return $-                                       L (getLoc $2) (fst $ unLoc $2-                                        ,(reverse (snd $ unLoc $2))) }-        | '{'                 '}'    { return $ sLL $1 $> ([moc $1,mcc $2],[]) }-        |     vocurly          close { return $ noLoc ([],[]) }--alts    :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }-        : alts1                    { $1 >>= \ $1 -> return $-                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-        | ';' alts                 { $2 >>= \ $2 -> return $-                                     sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2))-                                               ,snd $ unLoc $2) }--alts1   :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }-        : alts1 ';' alt         { $1 >>= \ $1 ->-                                  $3 >>= \ $3 ->-                                     if null (snd $ unLoc $1)-                                     then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                  ,[$3]))-                                     else (ams (head $ snd $ unLoc $1)-                                               (mj AnnSemi $2:(fst $ unLoc $1))-                                           >> return (sLL $1 $> ([],$3 : (snd $ unLoc $1))) ) }-        | alts1 ';'             {  $1 >>= \ $1 ->-                                   if null (snd $ unLoc $1)-                                     then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                  ,snd $ unLoc $1))-                                     else (ams (head $ snd $ unLoc $1)-                                               (mj AnnSemi $2:(fst $ unLoc $1))-                                           >> return (sLL $1 $> ([],snd $ unLoc $1))) }-        | alt                   { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) }--alt     :: { forall b. DisambECP b => PV (LMatch GhcPs (Located b)) }-           : pat alt_rhs  { $2 >>= \ $2 ->-                            ams (sLL $1 $> (Match { m_ext = noExtField-                                                  , m_ctxt = CaseAlt-                                                  , m_pats = [$1]-                                                  , m_grhss = snd $ unLoc $2 }))-                                      (fst $ unLoc $2)}--alt_rhs :: { forall b. DisambECP b => PV (Located ([AddAnn],GRHSs GhcPs (Located b))) }-        : ralt wherebinds           { $1 >>= \alt ->-                                      return $ sLL alt $> (fst $ unLoc $2, GRHSs noExtField (unLoc alt) (snd $ unLoc $2)) }--ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) }-        : '->' exp            { runECP_PV $2 >>= \ $2 ->-                                ams (sLL $1 $> (unguardedRHS (comb2 $1 $2) $2))-                                    [mu AnnRarrow $1] }-        | gdpats              { $1 >>= \gdpats ->-                                return $ sL1 gdpats (reverse (unLoc gdpats)) }--gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (Located b)]) }-        : gdpats gdpat { $1 >>= \gdpats ->-                         $2 >>= \gdpat ->-                         return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }-        | gdpat        { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }---- layout for MultiWayIf doesn't begin with an open brace, because it's hard to--- generate the open brace in addition to the vertical bar in the lexer, and--- we don't need it.-ifgdpats :: { Located ([AddAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }-         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->-                                             return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }-         |     gdpats close               {% runPV $1 >>= \ $1 ->-                                             return $ sL1 $1 ([],unLoc $1) }--gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (Located b)) }-        : '|' guardquals '->' exp-                                   { runECP_PV $4 >>= \ $4 ->-                                     ams (sL (comb2 $1 $>) $ GRHS noExtField (unLoc $2) $4)-                                         [mj AnnVbar $1,mu AnnRarrow $3] }---- 'pat' recognises a pattern, including one with a bang at the top---      e.g.  "!x" or "!(x,y)" or "C a b" etc--- Bangs inside are parsed as infix operator applications, so that--- we parse them right when bang-patterns are off-pat     :: { LPat GhcPs }-pat     :  exp          {% (checkPattern <=< runECP_P) $1 }--bindpat :: { LPat GhcPs }-bindpat :  exp            {% -- See Note [Parser-Validator ReaderT SDoc] in GHC.Parser.PostProcess-                             checkPattern_msg (text "Possibly caused by a missing 'do'?")-                                              (runECP_PV $1) }--apat   :: { LPat GhcPs }-apat    : aexp                  {% (checkPattern <=< runECP_P) $1 }--apats  :: { [LPat GhcPs] }-        : apat apats            { $1 : $2 }-        | {- empty -}           { [] }---------------------------------------------------------------------------------- Statement sequences--stmtlist :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) }-        : '{'           stmts '}'       { $2 >>= \ $2 -> return $-                                          sLL $1 $> ((moc $1:mcc $3:(fst $ unLoc $2))-                                             ,(reverse $ snd $ unLoc $2)) } -- AZ:performance of reverse?-        |     vocurly   stmts close     { $2 >>= \ $2 -> return $-                                          L (gl $2) (fst $ unLoc $2-                                                    ,reverse $ snd $ unLoc $2) }----      do { ;; s ; s ; ; s ;; }--- The last Stmt should be an expression, but that's hard to enforce--- here, because we need too much lookahead if we see do { e ; }--- So we use BodyStmts throughout, and switch the last one over--- in ParseUtils.checkDo instead--stmts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LStmt GhcPs (Located b)])) }-        : stmts ';' stmt  { $1 >>= \ $1 ->-                            $3 >>= \ $3 ->-                            if null (snd $ unLoc $1)-                              then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1)-                                                     ,$3 : (snd $ unLoc $1)))-                              else do-                               { ams (head $ snd $ unLoc $1) [mj AnnSemi $2]-                               ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(snd $ unLoc $1)) }}--        | stmts ';'     {  $1 >>= \ $1 ->-                           if null (snd $ unLoc $1)-                             then return (sLL $1 $> (mj AnnSemi $2:(fst $ unLoc $1),snd $ unLoc $1))-                             else do-                               { ams (head $ snd $ unLoc $1)-                                               [mj AnnSemi $2]-                               ; return $1 }-          }-        | stmt                   { $1 >>= \ $1 ->-                                   return $ sL1 $1 ([],[$1]) }-        | {- empty -}            { return $ noLoc ([],[]) }----- For typing stmts at the GHCi prompt, where--- the input may consist of just comments.-maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }-        : stmt                          {% fmap Just (runPV $1) }-        | {- nothing -}                 { Nothing }---- For GHC API.-e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }-        : stmt                          {% runPV $1 }--stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }-        : qual                          { $1 }-        | 'rec' stmtlist                {  $2 >>= \ $2 ->-                                           ams (sLL $1 $> $ mkRecStmt (snd $ unLoc $2))-                                               (mj AnnRec $1:(fst $ unLoc $2)) }--qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }-    : bindpat '<-' exp                   { runECP_PV $3 >>= \ $3 ->-                                           ams (sLL $1 $> $ mkPsBindStmt $1 $3)-                                               [mu AnnLarrow $2] }-    | exp                                { runECP_PV $1 >>= \ $1 ->-                                           return $ sL1 $1 $ mkBodyStmt $1 }-    | 'let' binds                        { ams (sLL $1 $> $ LetStmt noExtField (snd $ unLoc $2))-                                               (mj AnnLet $1:(fst $ unLoc $2)) }---------------------------------------------------------------------------------- Record Field Update/Construction--fbinds  :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) }-        : fbinds1                       { $1 }-        | {- empty -}                   { return ([],([], Nothing)) }--fbinds1 :: { forall b. DisambECP b => PV ([AddAnn],([LHsRecField GhcPs (Located b)], Maybe SrcSpan)) }-        : fbind ',' fbinds1-                 { $1 >>= \ $1 ->-                   $3 >>= \ $3 ->-                   addAnnotation (gl $1) AnnComma (gl $2) >>-                   return (case $3 of (ma,(flds, dd)) -> (ma,($1 : flds, dd))) }-        | fbind                         { $1 >>= \ $1 ->-                                          return ([],([$1], Nothing)) }-        | '..'                          { return ([mj AnnDotdot $1],([],   Just (getLoc $1))) }--fbind   :: { forall b. DisambECP b => PV (LHsRecField GhcPs (Located b)) }-        : qvar '=' texp  { runECP_PV $3 >>= \ $3 ->-                           ams  (sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) $3 False)-                                [mj AnnEqual $2] }-                        -- RHS is a 'texp', allowing view patterns (#6038)-                        -- and, incidentally, sections.  Eg-                        -- f (R { x = show -> s }) = ...--        | qvar          { placeHolderPunRhs >>= \rhs ->-                          return $ sLL $1 $> $ HsRecField (sL1 $1 $ mkFieldOcc $1) rhs True }-                        -- In the punning case, use a place-holder-                        -- The renamer fills in the final value---------------------------------------------------------------------------------- Implicit Parameter Bindings--dbinds  :: { Located [LIPBind GhcPs] }-        : dbinds ';' dbind-                      {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>-                         return (let { this = $3; rest = unLoc $1 }-                              in rest `seq` this `seq` sLL $1 $> (this : rest)) }-        | dbinds ';'  {% addAnnotation (gl $ last $ unLoc $1) AnnSemi (gl $2) >>-                         return (sLL $1 $> (unLoc $1)) }-        | dbind                        { let this = $1 in this `seq` sL1 $1 [this] }---      | {- empty -}                  { [] }--dbind   :: { LIPBind GhcPs }-dbind   : ipvar '=' exp                {% runECP_P $3 >>= \ $3 ->-                                          ams (sLL $1 $> (IPBind noExtField (Left $1) $3))-                                              [mj AnnEqual $2] }--ipvar   :: { Located HsIPName }-        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }---------------------------------------------------------------------------------- Overloaded labels--overloaded_label :: { Located FastString }-        : LABELVARID          { sL1 $1 (getLABELVARID $1) }---------------------------------------------------------------------------------- Warnings and deprecations--name_boolformula_opt :: { LBooleanFormula (Located RdrName) }-        : name_boolformula          { $1 }-        | {- empty -}               { noLoc mkTrue }--name_boolformula :: { LBooleanFormula (Located RdrName) }-        : name_boolformula_and                      { $1 }-        | name_boolformula_and '|' name_boolformula-                           {% aa $1 (AnnVbar, $2)-                              >> return (sLL $1 $> (Or [$1,$3])) }--name_boolformula_and :: { LBooleanFormula (Located RdrName) }-        : name_boolformula_and_list-                  { sLL (head $1) (last $1) (And ($1)) }--name_boolformula_and_list :: { [LBooleanFormula (Located RdrName)] }-        : name_boolformula_atom                               { [$1] }-        | name_boolformula_atom ',' name_boolformula_and_list-            {% aa $1 (AnnComma, $2) >> return ($1 : $3) }--name_boolformula_atom :: { LBooleanFormula (Located RdrName) }-        : '(' name_boolformula ')'  {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] }-        | name_var                  { sL1 $1 (Var $1) }--namelist :: { Located [Located RdrName] }-namelist : name_var              { sL1 $1 [$1] }-         | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >>-                                    return (sLL $1 $> ($1 : unLoc $3)) }--name_var :: { Located RdrName }-name_var : var { $1 }-         | con { $1 }---------------------------------------------- Data constructors--- There are two different productions here as lifted list constructors--- are parsed differently.--qcon_nowiredlist :: { Located RdrName }-        : gen_qcon                     { $1 }-        | sysdcon_nolist               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }--qcon :: { Located RdrName }-  : gen_qcon              { $1}-  | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }--gen_qcon :: { Located RdrName }-  : qconid                { $1 }-  | '(' qconsym ')'       {% ams (sLL $1 $> (unLoc $2))-                                   [mop $1,mj AnnVal $2,mcp $3] }--con     :: { Located RdrName }-        : conid                 { $1 }-        | '(' consym ')'        {% ams (sLL $1 $> (unLoc $2))-                                       [mop $1,mj AnnVal $2,mcp $3] }-        | sysdcon               { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) }--con_list :: { Located [Located RdrName] }-con_list : con                  { sL1 $1 [$1] }-         | con ',' con_list     {% addAnnotation (gl $1) AnnComma (gl $2) >>-                                   return (sLL $1 $> ($1 : unLoc $3)) }---- See Note [ExplicitTuple] in GHC.Hs.Expr-sysdcon_nolist :: { Located DataCon }  -- Wired in data constructors-        : '(' ')'               {% ams (sLL $1 $> unitDataCon) [mop $1,mcp $2] }-        | '(' commas ')'        {% ams (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))-                                       (mop $1:mcp $3:(mcommas (fst $2))) }-        | '(#' '#)'             {% ams (sLL $1 $> $ unboxedUnitDataCon) [mo $1,mc $2] }-        | '(#' commas '#)'      {% ams (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))-                                       (mo $1:mc $3:(mcommas (fst $2))) }---- See Note [Empty lists] in GHC.Hs.Expr-sysdcon :: { Located DataCon }-        : sysdcon_nolist                 { $1 }-        | '[' ']'               {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] }--conop :: { Located RdrName }-        : consym                { $1 }-        | '`' conid '`'         {% ams (sLL $1 $> (unLoc $2))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }--qconop :: { Located RdrName }-        : qconsym               { $1 }-        | '`' qconid '`'        {% ams (sLL $1 $> (unLoc $2))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }--------------------------------------------------------------------------------- Type constructors----- See Note [Unit tuples] in GHC.Hs.Type for the distinction--- between gtycon and ntgtycon-gtycon :: { Located RdrName }  -- A "general" qualified tycon, including unit tuples-        : ntgtycon                     { $1 }-        | '(' ')'                      {% ams (sLL $1 $> $ getRdrName unitTyCon)-                                              [mop $1,mcp $2] }-        | '(#' '#)'                    {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon)-                                              [mo $1,mc $2] }--ntgtycon :: { Located RdrName }  -- A "general" qualified tycon, excluding unit tuples-        : oqtycon               { $1 }-        | '(' commas ')'        {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed-                                                        (snd $2 + 1)))-                                       (mop $1:mcp $3:(mcommas (fst $2))) }-        | '(#' commas '#)'      {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed-                                                        (snd $2 + 1)))-                                       (mo $1:mc $3:(mcommas (fst $2))) }-        | '(' '->' ')'          {% ams (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                       [mop $1,mu AnnRarrow $2,mcp $3] }-        | '[' ']'               {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] }--oqtycon :: { Located RdrName }  -- An "ordinary" qualified tycon;-                                -- These can appear in export lists-        : qtycon                        { $1 }-        | '(' qtyconsym ')'             {% ams (sLL $1 $> (unLoc $2))-                                               [mop $1,mj AnnVal $2,mcp $3] }--oqtycon_no_varcon :: { Located RdrName }  -- Type constructor which cannot be mistaken-                                          -- for variable constructor in export lists-                                          -- see Note [Type constructors in export list]-        :  qtycon            { $1 }-        | '(' QCONSYM ')'    {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }-                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }-        | '(' CONSYM ')'     {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }-                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }-        | '(' ':' ')'        {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! consDataCon_RDR }-                                in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] }--{- Note [Type constructors in export list]-~~~~~~~~~~~~~~~~~~~~~-Mixing type constructors and data constructors in export lists introduces-ambiguity in grammar: e.g. (*) may be both a type constructor and a function.---XExplicitNamespaces allows to disambiguate by explicitly prefixing type-constructors with 'type' keyword.--This ambiguity causes reduce/reduce conflicts in parser, which are always-resolved in favour of data constructors. To get rid of conflicts we demand-that ambiguous type constructors (those, which are formed by the same-productions as variable constructors) are always prefixed with 'type' keyword.-Unambiguous type constructors may occur both with or without 'type' keyword.--Note that in the parser we still parse data constructors as type-constructors. As such, they still end up in the type constructor namespace-until after renaming when we resolve the proper namespace for each exported-child.--}--qtyconop :: { Located RdrName } -- Qualified or unqualified-        : qtyconsym                     { $1 }-        | '`' qtycon '`'                {% ams (sLL $1 $> (unLoc $2))-                                               [mj AnnBackquote $1,mj AnnVal $2-                                               ,mj AnnBackquote $3] }--qtycon :: { Located RdrName }   -- Qualified or unqualified-        : QCONID            { sL1 $1 $! mkQual tcClsName (getQCONID $1) }-        | tycon             { $1 }--tycon   :: { Located RdrName }  -- Unqualified-        : CONID                   { sL1 $1 $! mkUnqual tcClsName (getCONID $1) }--qtyconsym :: { Located RdrName }-        : QCONSYM            { sL1 $1 $! mkQual tcClsName (getQCONSYM $1) }-        | QVARSYM            { sL1 $1 $! mkQual tcClsName (getQVARSYM $1) }-        | tyconsym           { $1 }--tyconsym :: { Located RdrName }-        : CONSYM                { sL1 $1 $! mkUnqual tcClsName (getCONSYM $1) }-        | VARSYM                { sL1 $1 $!-                                    -- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types-                                    if getVARSYM $1 == fsLit "~"-                                      then eqTyCon_RDR-                                      else mkUnqual tcClsName (getVARSYM $1) }-        | ':'                   { sL1 $1 $! consDataCon_RDR }-        | '-'                   { sL1 $1 $! mkUnqual tcClsName (fsLit "-") }-        | '.'                   { sL1 $1 $! mkUnqual tcClsName (fsLit ".") }----------------------------------------------------------------------------------- Operators--op      :: { Located RdrName }   -- used in infix decls-        : varop                 { $1 }-        | conop                 { $1 }-        | '->'                  { sL1 $1 $ getRdrName unrestrictedFunTyCon }--varop   :: { Located RdrName }-        : varsym                { $1 }-        | '`' varid '`'         {% ams (sLL $1 $> (unLoc $2))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }--qop     :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections-        : qvarop                { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { $1 }--qopm    :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections-        : qvaropm               { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { $1 }--hole_op :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections-hole_op : '`' '_' '`'           { amms (mkHsInfixHolePV (comb2 $1 $>))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }--qvarop :: { Located RdrName }-        : qvarsym               { $1 }-        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }--qvaropm :: { Located RdrName }-        : qvarsym_no_minus      { $1 }-        | '`' qvarid '`'        {% ams (sLL $1 $> (unLoc $2))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }---------------------------------------------------------------------------------- Type variables--tyvar   :: { Located RdrName }-tyvar   : tyvarid               { $1 }--tyvarop :: { Located RdrName }-tyvarop : '`' tyvarid '`'       {% ams (sLL $1 $> (unLoc $2))-                                       [mj AnnBackquote $1,mj AnnVal $2-                                       ,mj AnnBackquote $3] }--tyvarid :: { Located RdrName }-        : VARID            { sL1 $1 $! mkUnqual tvName (getVARID $1) }-        | special_id       { sL1 $1 $! mkUnqual tvName (unLoc $1) }-        | 'unsafe'         { sL1 $1 $! mkUnqual tvName (fsLit "unsafe") }-        | 'safe'           { sL1 $1 $! mkUnqual tvName (fsLit "safe") }-        | 'interruptible'  { sL1 $1 $! mkUnqual tvName (fsLit "interruptible") }-        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]---------------------------------------------------------------------------------- Variables--var     :: { Located RdrName }-        : varid                 { $1 }-        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))-                                       [mop $1,mj AnnVal $2,mcp $3] }--qvar    :: { Located RdrName }-        : qvarid                { $1 }-        | '(' varsym ')'        {% ams (sLL $1 $> (unLoc $2))-                                       [mop $1,mj AnnVal $2,mcp $3] }-        | '(' qvarsym1 ')'      {% ams (sLL $1 $> (unLoc $2))-                                       [mop $1,mj AnnVal $2,mcp $3] }--- We've inlined qvarsym here so that the decision about--- whether it's a qvar or a var can be postponed until--- *after* we see the close paren.--qvarid :: { Located RdrName }-        : varid               { $1 }-        | QVARID              { sL1 $1 $! mkQual varName (getQVARID $1) }---- Note that 'role' and 'family' get lexed separately regardless of--- the use of extensions. However, because they are listed here,--- this is OK and they can be used as normal varids.--- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer-varid :: { Located RdrName }-        : VARID            { sL1 $1 $! mkUnqual varName (getVARID $1) }-        | special_id       { sL1 $1 $! mkUnqual varName (unLoc $1) }-        | 'unsafe'         { sL1 $1 $! mkUnqual varName (fsLit "unsafe") }-        | 'safe'           { sL1 $1 $! mkUnqual varName (fsLit "safe") }-        | 'interruptible'  { sL1 $1 $! mkUnqual varName (fsLit "interruptible")}-        | 'forall'         { sL1 $1 $! mkUnqual varName (fsLit "forall") }-        | 'family'         { sL1 $1 $! mkUnqual varName (fsLit "family") }-        | 'role'           { sL1 $1 $! mkUnqual varName (fsLit "role") }-        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]--qvarsym :: { Located RdrName }-        : varsym                { $1 }-        | qvarsym1              { $1 }--qvarsym_no_minus :: { Located RdrName }-        : varsym_no_minus       { $1 }-        | qvarsym1              { $1 }--qvarsym1 :: { Located RdrName }-qvarsym1 : QVARSYM              { sL1 $1 $ mkQual varName (getQVARSYM $1) }--varsym :: { Located RdrName }-        : varsym_no_minus       { $1 }-        | '-'                   { sL1 $1 $ mkUnqual varName (fsLit "-") }--varsym_no_minus :: { Located RdrName } -- varsym not including '-'-        : VARSYM               { sL1 $1 $ mkUnqual varName (getVARSYM $1) }-        | special_sym          { sL1 $1 $ mkUnqual varName (unLoc $1) }----- These special_ids are treated as keywords in various places,--- but as ordinary ids elsewhere.   'special_id' collects all these--- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and--- 'anyclass', whose treatment differs depending on context-special_id :: { Located FastString }-special_id-        : 'as'                  { sL1 $1 (fsLit "as") }-        | 'qualified'           { sL1 $1 (fsLit "qualified") }-        | 'hiding'              { sL1 $1 (fsLit "hiding") }-        | 'export'              { sL1 $1 (fsLit "export") }-        | 'label'               { sL1 $1 (fsLit "label")  }-        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }-        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }-        | 'ccall'               { sL1 $1 (fsLit "ccall") }-        | 'capi'                { sL1 $1 (fsLit "capi") }-        | 'prim'                { sL1 $1 (fsLit "prim") }-        | 'javascript'          { sL1 $1 (fsLit "javascript") }-        | 'group'               { sL1 $1 (fsLit "group") }-        | 'stock'               { sL1 $1 (fsLit "stock") }-        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }-        | 'via'                 { sL1 $1 (fsLit "via") }-        | 'unit'                { sL1 $1 (fsLit "unit") }-        | 'dependency'          { sL1 $1 (fsLit "dependency") }-        | 'signature'           { sL1 $1 (fsLit "signature") }--special_sym :: { Located FastString }-special_sym : '.'       { sL1 $1 (fsLit ".") }-            | '*'       { sL1 $1 (fsLit (starSym (isUnicode $1))) }---------------------------------------------------------------------------------- Data constructors--qconid :: { Located RdrName }   -- Qualified or unqualified-        : conid              { $1 }-        | QCONID             { sL1 $1 $! mkQual dataName (getQCONID $1) }--conid   :: { Located RdrName }-        : CONID                { sL1 $1 $ mkUnqual dataName (getCONID $1) }--qconsym :: { Located RdrName }  -- Qualified or unqualified-        : consym               { $1 }-        | QCONSYM              { sL1 $1 $ mkQual dataName (getQCONSYM $1) }--consym :: { Located RdrName }-        : CONSYM              { sL1 $1 $ mkUnqual dataName (getCONSYM $1) }--        -- ':' means only list cons-        | ':'                { sL1 $1 $ consDataCon_RDR }----------------------------------------------------------------------------------- Literals--literal :: { Located (HsLit GhcPs) }-        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }-        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)-                                                    $ getSTRING $1 }-        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)-                                                    $ getPRIMINTEGER $1 }-        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)-                                                    $ getPRIMWORD $1 }-        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)-                                                    $ getPRIMCHAR $1 }-        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)-                                                    $ getPRIMSTRING $1 }-        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }-        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }---------------------------------------------------------------------------------- Layout--close :: { () }-        : vccurly               { () } -- context popped in lexer.-        | error                 {% popContext }---------------------------------------------------------------------------------- Miscellaneous (mostly renamings)--modid   :: { Located ModuleName }-        : CONID                 { sL1 $1 $ mkModuleNameFS (getCONID $1) }-        | QCONID                { sL1 $1 $ let (mod,c) = getQCONID $1 in-                                  mkModuleNameFS-                                   (mkFastString-                                     (unpackFS mod ++ '.':unpackFS c))-                                }--commas :: { ([SrcSpan],Int) }   -- One or more commas-        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }-        | ','                    { ([gl $1],1) }--bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars-        : bars                   { $1 }-        |                        { ([], 0) }--bars :: { ([SrcSpan],Int) }     -- One or more bars-        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }-        | '|'                    { ([gl $1],1) }--{-happyError :: P a-happyError = srcParseFail--getVARID        (L _ (ITvarid    x)) = x-getCONID        (L _ (ITconid    x)) = x-getVARSYM       (L _ (ITvarsym   x)) = x-getCONSYM       (L _ (ITconsym   x)) = x-getDO           (L _ (ITdo      x)) = x-getMDO          (L _ (ITmdo     x)) = x-getQVARID       (L _ (ITqvarid   x)) = x-getQCONID       (L _ (ITqconid   x)) = x-getQVARSYM      (L _ (ITqvarsym  x)) = x-getQCONSYM      (L _ (ITqconsym  x)) = x-getIPDUPVARID   (L _ (ITdupipvarid   x)) = x-getLABELVARID   (L _ (ITlabelvarid   x)) = x-getCHAR         (L _ (ITchar   _ x)) = x-getSTRING       (L _ (ITstring _ x)) = x-getINTEGER      (L _ (ITinteger x))  = x-getRATIONAL     (L _ (ITrational x)) = x-getPRIMCHAR     (L _ (ITprimchar _ x)) = x-getPRIMSTRING   (L _ (ITprimstring _ x)) = x-getPRIMINTEGER  (L _ (ITprimint  _ x)) = x-getPRIMWORD     (L _ (ITprimword _ x)) = x-getPRIMFLOAT    (L _ (ITprimfloat x)) = x-getPRIMDOUBLE   (L _ (ITprimdouble x)) = x-getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)-getSPEC_INLINE  (L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)-getSPEC_INLINE  (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)-getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x-getVOCURLY      (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l--getINTEGERs     (L _ (ITinteger (IL src _ _))) = src-getCHARs        (L _ (ITchar       src _)) = src-getSTRINGs      (L _ (ITstring     src _)) = src-getPRIMCHARs    (L _ (ITprimchar   src _)) = src-getPRIMSTRINGs  (L _ (ITprimstring src _)) = src-getPRIMINTEGERs (L _ (ITprimint    src _)) = src-getPRIMWORDs    (L _ (ITprimword   src _)) = src---- See Note [Pragma source text] in "GHC.Types.Basic" for the following-getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src-getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src-getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src-getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src-getRULES_PRAGs        (L _ (ITrules_prag        src)) = src-getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src-getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src-getSCC_PRAGs          (L _ (ITscc_prag          src)) = src-getGENERATED_PRAGs    (L _ (ITgenerated_prag    src)) = src-getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src-getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src-getANN_PRAGs          (L _ (ITann_prag          src)) = src-getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src-getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src-getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src-getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src-getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src-getCTYPEs             (L _ (ITctype             src)) = src--getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l)--isUnicode :: Located Token -> Bool-isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax-isUnicode (L _ ITlolly)               = True-isUnicode _                           = False--hasE :: Located Token -> Bool-hasE (L _ (ITopenExpQuote HasE _)) = True-hasE (L _ (ITopenTExpQuote HasE))  = True-hasE _                             = False--getSCC :: Located Token -> P FastString-getSCC lt = do let s = getSTRING lt-                   err = "Spaces are not allowed in SCCs"-               -- We probably actually want to be more restrictive than this-               if ' ' `elem` unpackFS s-                   then addFatalError (getLoc lt) (text err)-                   else return s---- Utilities for combining source spans-comb2 :: Located a -> Located b -> SrcSpan-comb2 a b = a `seq` b `seq` combineLocs a b--comb3 :: Located a -> Located b -> Located c -> SrcSpan-comb3 a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))--comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan-comb4 a b c d = a `seq` b `seq` c `seq` d `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-                combineSrcSpans (getLoc c) (getLoc d))--comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan-comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))---- strict constructor version:-{-# INLINE sL #-}-sL :: SrcSpan -> a -> Located a-sL span a = span `seq` a `seq` L span a---- See Note [Adding location info] for how these utility functions are used---- replaced last 3 CPP macros in this file-{-# INLINE sL0 #-}-sL0 :: a -> Located a-sL0 = L noSrcSpan       -- #define L0   L noSrcSpan--{-# INLINE sL1 #-}-sL1 :: Located a -> b -> Located b-sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sLL #-}-sLL :: Located a -> Located b -> c -> Located c-sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)--{- Note [Adding location info]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~--This is done using the three functions below, sL0, sL1-and sLL.  Note that these functions were mechanically-converted from the three macros that used to exist before,-namely L0, L1 and LL.--They each add a SrcSpan to their argument.--   sL0  adds 'noSrcSpan', used for empty productions-     -- This doesn't seem to work anymore -=chak--   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan-        from that token.--   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from-        the first and last tokens.--These suffice for the majority of cases.  However, we must be-especially careful with empty productions: sLL won't work if the first-or last token on the lhs can represent an empty span.  In these cases,-we have to calculate the span using more of the tokens from the lhs, eg.--        | 'newtype' tycl_hdr '=' newconstr deriving-                { L (comb3 $1 $4 $5)-                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }--We provide comb3 and comb4 functions which are useful in such cases.--Be careful: there's no checking that you actually got this right, the-only symptom will be that the SrcSpans of your syntax will be-incorrect.---}---- Make a source location for the file.  We're a bit lazy here and just--- make a point SrcSpan at line 1, column 0.  Strictly speaking we should--- try to find the span of the whole file (ToDo).-fileSrcSpan :: P SrcSpan-fileSrcSpan = do-  l <- getRealSrcLoc;-  let loc = mkSrcLoc (srcLocFile l) 1 1;-  return (mkSrcSpan loc loc)---- Hint about linear types-hintLinear :: SrcSpan -> P ()-hintLinear span = do-  linearEnabled <- getBit LinearTypesBit-  unless linearEnabled $ addError span $-    text "Enable LinearTypes to allow linear functions"---- Hint about the MultiWayIf extension-hintMultiWayIf :: SrcSpan -> P ()-hintMultiWayIf span = do-  mwiEnabled <- getBit MultiWayIfBit-  unless mwiEnabled $ addError span $-    text "Multi-way if-expressions need MultiWayIf turned on"---- Hint about explicit-forall-hintExplicitForall :: Located Token -> P ()-hintExplicitForall tok = do-    forall   <- getBit ExplicitForallBit-    rulePrag <- getBit InRulePragBit-    unless (forall || rulePrag) $ addError (getLoc tok) $ vcat-      [ text "Illegal symbol" <+> quotes forallSymDoc <+> text "in type"-      , text "Perhaps you intended to use RankNTypes or a similar language"-      , text "extension to enable explicit-forall syntax:" <+>-        forallSymDoc <+> text "<tvs>. <type>"-      ]-  where-    forallSymDoc = text (forallSym (isUnicode tok))---- Hint about qualified-do-hintQualifiedDo :: Located Token -> P ()-hintQualifiedDo tok = do-    qualifiedDo   <- getBit QualifiedDoBit-    case maybeQDoDoc of-      Just qdoDoc | not qualifiedDo ->-        addError (getLoc tok) $ vcat-          [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"-          , text "Perhaps you intended to use QualifiedDo"-          ]-      _ -> return ()-  where-    maybeQDoDoc = case unLoc tok of-      ITdo (Just m) -> Just $ ftext m <> text ".do"-      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"-      t -> Nothing---- When two single quotes don't followed by tyvar or gtycon, we report the--- error as empty character literal, or TH quote that missing proper type--- variable or constructor. See #13450.-reportEmptyDoubleQuotes :: SrcSpan -> P a-reportEmptyDoubleQuotes span = do-    thQuotes <- getBit ThQuotesBit-    if thQuotes-      then addFatalError span $ vcat-        [ text "Parser error on `''`"-        , text "Character literals may not be empty"-        , text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"-        , text "but the type variable or constructor is missing"-        ]-      else addFatalError span $ vcat-        [ text "Parser error on `''`"-        , text "Character literals may not be empty"-        ]--{--%************************************************************************-%*                                                                      *-        Helper functions for generating annotations in the parser-%*                                                                      *-%************************************************************************--For the general principles of the following routines, see Note [Api annotations]-in GHC.Parser.Annotation---}---- |Construct an AddAnn from the annotation keyword and the location--- of the keyword itself-mj :: AnnKeywordId -> Located e -> AddAnn-mj a l = AddAnn a (gl l)----- |Construct an AddAnn from the annotation keyword and the Located Token. If--- the token has a unicode equivalent and this has been used, provide the--- unicode variant of the annotation.-mu :: AnnKeywordId -> Located Token -> AddAnn-mu a lt@(L l t) = AddAnn (toUnicodeAnn a lt) l---- | If the 'Token' is using its unicode variant return the unicode variant of---   the annotation-toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId-toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a--toUnicode :: Located Token -> IsUnicodeSyntax-toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax--gl :: Located a -> SrcSpan-gl = getLoc---- |Add an annotation to the located element, and return the located--- element as a pass through-aa :: Located a -> (AnnKeywordId, Located c) -> P (Located a)-aa a@(L l _) (b,s) = addAnnotation l b (gl s) >> return a---- |Add an annotation to a located element resulting from a monadic action-am :: P (Located a) -> (AnnKeywordId, Located b) -> P (Located a)-am a (b,s) = do-  av@(L l _) <- a-  addAnnotation l b (gl s)-  return av---- | Add a list of AddAnns to the given AST element.  For example,--- the parsing rule for @let@ looks like:------ @---      | 'let' binds 'in' exp    {% ams (sLL $1 $> $ HsLet (snd $ unLoc $2) $4)---                                       (mj AnnLet $1:mj AnnIn $3---                                         :(fst $ unLoc $2)) }--- @------ This adds an AnnLet annotation for @let@, an AnnIn for @in@, as well--- as any annotations that may arise in the binds. This will include open--- and closing braces if they are used to delimit the let expressions.----ams :: MonadP m => Located a -> [AddAnn] -> m (Located a)-ams a@(L l _) bs = addAnnsAt l bs >> return a--amsL :: SrcSpan -> [AddAnn] -> P ()-amsL sp bs = addAnnsAt sp bs >> return ()---- |Add all [AddAnn] to an AST element, and wrap it in a 'Just'-ajs :: MonadP m => Located a -> [AddAnn] -> m (Maybe (Located a))-ajs a bs = Just <$> ams a bs---- |Add a list of AddAnns to the given AST element, where the AST element is the---  result of a monadic action-amms :: MonadP m => m (Located a) -> [AddAnn] -> m (Located a)-amms a bs = do { av@(L l _) <- a-               ; addAnnsAt l bs-               ; return av }---- |Add a list of AddAnns to the AST element, and return the element as a---  OrdList-amsu :: Located a -> [AddAnn] -> P (OrdList (Located a))-amsu a@(L l _) bs = addAnnsAt l bs >> return (unitOL a)---- |Synonyms for AddAnn versions of AnnOpen and AnnClose-mo,mc :: Located Token -> AddAnn-mo ll = mj AnnOpen ll-mc ll = mj AnnClose ll--moc,mcc :: Located Token -> AddAnn-moc ll = mj AnnOpenC ll-mcc ll = mj AnnCloseC ll--mop,mcp :: Located Token -> AddAnn-mop ll = mj AnnOpenP ll-mcp ll = mj AnnCloseP ll--mos,mcs :: Located Token -> AddAnn-mos ll = mj AnnOpenS ll-mcs ll = mj AnnCloseS ll---- |Given a list of the locations of commas, provide a [AddAnn] with an AnnComma---  entry for each SrcSpan-mcommas :: [SrcSpan] -> [AddAnn]-mcommas = map (AddAnn AnnCommaTuple)---- |Given a list of the locations of '|'s, provide a [AddAnn] with an AnnVbar---  entry for each SrcSpan-mvbars :: [SrcSpan] -> [AddAnn]-mvbars = map (AddAnn AnnVbar)---- |Get the location of the last element of a OrdList, or noSrcSpan-oll :: OrdList (Located a) -> SrcSpan-oll l =-  if isNilOL l then noSrcSpan-               else getLoc (lastOL l)---- |Add a semicolon annotation in the right place in a list. If the--- leading list is empty, add it to the tail-asl :: [Located a] -> Located b -> Located a -> P ()-asl [] (L ls _) (L l _) = addAnnotation l          AnnSemi ls-asl (x:_xs) (L ls _) _x = addAnnotation (getLoc x) AnnSemi ls---- | Parse a Haskell module with Haddock comments.--- This is done in two steps:------ * 'parseModuleNoHaddock' to build the AST--- * 'addHaddockToModule' to insert Haddock comments into it------ This is the only parser entry point that deals with Haddock comments.--- The other entry points ('parseDeclaration', 'parseExpression', etc) do--- not insert them into the AST.-parseModule :: P (Located HsModule)-parseModule = parseModuleNoHaddock >>= addHaddockToModule+--     runParser :: ParserOpts -> String -> P a -> ParseResult a+--     runParser opts str parser = unP parser parseState+--     where+--       filename = "\<interactive\>"+--       location = mkRealSrcLoc (mkFastString filename) 1 1+--       buffer = stringToStringBuffer str+--       parseState = initParserState opts buffer location+-- @+module GHC.Parser+   ( parseModule, parseSignature, parseImport, parseStatement, parseBackpack+   , parseDeclaration, parseExpression, parsePattern+   , parseTypeSignature+   , parseStmt, parseIdentifier+   , parseType, parseHeader+   , parseModuleNoHaddock+   )+where++-- base+import Control.Monad    ( unless, liftM, when, (<=<) )+import GHC.Exts+import Data.Maybe       ( maybeToList )+import Data.List.NonEmpty ( NonEmpty((:|)) )+import qualified Data.List.NonEmpty as NE+import qualified Prelude -- for happy-generated code++import GHC.Prelude++import GHC.Hs++import GHC.Driver.Backpack.Syntax++import GHC.Unit.Info+import GHC.Unit.Module+import GHC.Unit.Module.Warnings++import GHC.Data.OrdList+import GHC.Data.BooleanFormula ( BooleanFormula(..), LBooleanFormula, mkTrue )+import GHC.Data.FastString+import GHC.Data.Maybe          ( orElse )++import GHC.Utils.Outputable+import GHC.Utils.Misc          ( looksLikePackageName, fstOf3, sndOf3, thdOf3 )+import GHC.Utils.Panic+import GHC.Prelude++import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occNameFS, mkVarOcc, occNameString)+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.ForeignCall+import GHC.Types.SourceFile+import GHC.Types.SourceText++import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) )+import GHC.Core.Class   ( FunDep )+import GHC.Core.DataCon ( DataCon, dataConName )++import GHC.Parser.PostProcess+import GHC.Parser.PostProcess.Haddock+import GHC.Parser.Lexer+import GHC.Parser.Annotation+import GHC.Parser.Errors++import GHC.Builtin.Types ( unitTyCon, unitDataCon, tupleTyCon, tupleDataCon, nilDataCon,+                           unboxedUnitTyCon, unboxedUnitDataCon,+                           listTyCon_RDR, consDataCon_RDR, eqTyCon_RDR)++import qualified Data.Semigroup as Semi+}++%expect 0 -- shift/reduce conflicts++{- Note [shift/reduce conflicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'happy' tool turns this grammar into an efficient parser that follows the+shift-reduce parsing model. There's a parse stack that contains items parsed so+far (both terminals and non-terminals). Every next token produced by the lexer+results in one of two actions:++  SHIFT:    push the token onto the parse stack++  REDUCE:   pop a few items off the parse stack and combine them+            with a function (reduction rule)++However, sometimes it's unclear which of the two actions to take.+Consider this code example:++    if x then y else f z++There are two ways to parse it:++    (if x then y else f) z+    if x then y else (f z)++How is this determined? At some point, the parser gets to the following state:++  parse stack:  'if' exp 'then' exp 'else' "f"+  next token:   "z"++Scenario A (simplified):++  1. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp+             next token:  "z"+        (Note that "f" reduced to exp here)++  2. REDUCE, parse stack: exp+             next token:  "z"++  3. SHIFT,  parse stack: exp "z"+             next token:  ...++  4. REDUCE, parse stack: exp+             next token:  ...++  This way we get:  (if x then y else f) z++Scenario B (simplified):++  1. SHIFT,  parse stack: 'if' exp 'then' exp 'else' "f" "z"+             next token:  ...++  2. REDUCE, parse stack: 'if' exp 'then' exp 'else' exp+             next token:  ...++  3. REDUCE, parse stack: exp+             next token:  ...++  This way we get:  if x then y else (f z)++The end result is determined by the chosen action. When Happy detects this, it+reports a shift/reduce conflict. At the top of the file, we have the following+directive:++  %expect 0++It means that we expect no unresolved shift/reduce conflicts in this grammar.+If you modify the grammar and get shift/reduce conflicts, follow the steps+below to resolve them.++STEP ONE+  is to figure out what causes the conflict.+  That's where the -i flag comes in handy:++      happy -agc --strict compiler/GHC/Parser.y -idetailed-info++  By analysing the output of this command, in a new file `detailed-info`, you+  can figure out which reduction rule causes the issue. At the top of the+  generated report, you will see a line like this:++      state 147 contains 67 shift/reduce conflicts.++  Scroll down to section State 147 (in your case it could be a different+  state). The start of the section lists the reduction rules that can fire+  and shows their context:++        exp10 -> fexp .                 (rule 492)+        fexp -> fexp . aexp             (rule 498)+        fexp -> fexp . PREFIX_AT atype  (rule 499)++  And then, for every token, it tells you the parsing action:++        ']'            reduce using rule 492+        '::'           reduce using rule 492+        '('            shift, and enter state 178+        QVARID         shift, and enter state 44+        DO             shift, and enter state 182+        ...++  But if you look closer, some of these tokens also have another parsing action+  in parentheses:++        QVARID    shift, and enter state 44+                   (reduce using rule 492)++  That's how you know rule 492 is causing trouble.+  Scroll back to the top to see what this rule is:++        ----------------------------------+        Grammar+        ----------------------------------+        ...+        ...+        exp10 -> fexp                (492)+        optSemi -> ';'               (493)+        ...+        ...++  Hence the shift/reduce conflict is caused by this parser production:++        exp10 :: { ECP }+                : '-' fexp    { ... }+                | fexp        { ... }    -- problematic rule++STEP TWO+  is to mark the problematic rule with the %shift pragma. This signals to+  'happy' that any shift/reduce conflicts involving this rule must be resolved+  in favor of a shift. There's currently no dedicated pragma to resolve in+  favor of the reduce.++STEP THREE+  is to add a dedicated Note for this specific conflict, as is done for all+  other conflicts below.+-}++{- Note [%shift: rule_activation -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    rule -> STRING . rule_activation rule_foralls infixexp '=' exp++Example:+    {-# RULES "name" [0] f = rhs #-}++Ambiguity:+    If we reduced, then we'd get an empty activation rule, and [0] would be+    parsed as part of the left-hand side expression.++    We shift, so [0] is parsed as an activation rule.+-}++{- Note [%shift: rule_foralls -> 'forall' rule_vars '.']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'+    rule_foralls -> 'forall' rule_vars '.' .++Example:+    {-# RULES "name" forall a1. forall a2. lhs = rhs #-}++Ambiguity:+    Same as in Note [%shift: rule_foralls -> {- empty -}]+    but for the second 'forall'.+-}++{- Note [%shift: rule_foralls -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    rule -> STRING rule_activation . rule_foralls infixexp '=' exp++Example:+    {-# RULES "name" forall a1. lhs = rhs #-}++Ambiguity:+    If we reduced, then we would get an empty rule_foralls; the 'forall', being+    a valid term-level identifier, would be parsed as part of the left-hand+    side expression.++    We shift, so the 'forall' is parsed as part of rule_foralls.+-}++{- Note [%shift: type -> btype]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    context -> btype .+    type -> btype .+    type -> btype . '->' ctype+    type -> btype . '->.' ctype++Example:+    a :: Maybe Integer -> Bool++Ambiguity:+    If we reduced, we would get:   (a :: Maybe Integer) -> Bool+    We shift to get this instead:  a :: (Maybe Integer -> Bool)+-}++{- Note [%shift: infixtype -> ftype]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    infixtype -> ftype .+    infixtype -> ftype . tyop infixtype+    ftype -> ftype . tyarg+    ftype -> ftype . PREFIX_AT tyarg++Example:+    a :: Maybe Integer++Ambiguity:+    If we reduced, we would get:    (a :: Maybe) Integer+    We shift to get this instead:   a :: (Maybe Integer)+-}++{- Note [%shift: atype -> tyvar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    atype -> tyvar .+    tv_bndr_no_braces -> '(' tyvar . '::' kind ')'++Example:+    class C a where type D a = (a :: Type ...++Ambiguity:+    If we reduced, we could specify a default for an associated type like this:++      class C a where type D a+                      type D a = (a :: Type)++    But we shift in order to allow injectivity signatures like this:++      class C a where type D a = (r :: Type) | r -> a+-}++{- Note [%shift: exp -> infixexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp -> infixexp . '::' sigtype+    exp -> infixexp . '-<' exp+    exp -> infixexp . '>-' exp+    exp -> infixexp . '-<<' exp+    exp -> infixexp . '>>-' exp+    exp -> infixexp .+    infixexp -> infixexp . qop exp10p++Examples:+    1) if x then y else z -< e+    2) if x then y else z :: T+    3) if x then y else z + 1   -- (NB: '+' is in VARSYM)++Ambiguity:+    If we reduced, we would get:++      1) (if x then y else z) -< e+      2) (if x then y else z) :: T+      3) (if x then y else z) + 1++    We shift to get this instead:++      1) if x then y else (z -< e)+      2) if x then y else (z :: T)+      3) if x then y else (z + 1)+-}++{- Note [%shift: exp10 -> '-' fexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp10 -> '-' fexp .+    fexp -> fexp . aexp+    fexp -> fexp . PREFIX_AT atype++Examples & Ambiguity:+    Same as in Note [%shift: exp10 -> fexp],+    but with a '-' in front.+-}++{- Note [%shift: exp10 -> fexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp10 -> fexp .+    fexp -> fexp . aexp+    fexp -> fexp . PREFIX_AT atype++Examples:+    1) if x then y else f z+    2) if x then y else f @z++Ambiguity:+    If we reduced, we would get:++      1) (if x then y else f) z+      2) (if x then y else f) @z++    We shift to get this instead:++      1) if x then y else (f z)+      2) if x then y else (f @z)+-}++{- Note [%shift: aexp2 -> ipvar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    aexp2 -> ipvar .+    dbind -> ipvar . '=' exp++Example:+    let ?x = ...++Ambiguity:+    If we reduced, ?x would be parsed as the LHS of a normal binding,+    eventually producing an error.++    We shift, so it is parsed as the LHS of an implicit binding.+-}++{- Note [%shift: aexp2 -> TH_TY_QUOTE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    aexp2 -> TH_TY_QUOTE . tyvar+    aexp2 -> TH_TY_QUOTE . gtycon+    aexp2 -> TH_TY_QUOTE .++Examples:+    1) x = ''+    2) x = ''a+    3) x = ''T++Ambiguity:+    If we reduced, the '' would result in reportEmptyDoubleQuotes even when+    followed by a type variable or a type constructor. But the only reason+    this reduction rule exists is to improve error messages.++    Naturally, we shift instead, so that ''a and ''T work as expected.+-}++{- Note [%shift: tup_tail -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    tup_exprs -> commas . tup_tail+    sysdcon_nolist -> '(' commas . ')'+    sysdcon_nolist -> '(#' commas . '#)'+    commas -> commas . ','++Example:+    (,,)++Ambiguity:+    A tuple section with no components is indistinguishable from the Haskell98+    data constructor for a tuple.++    If we reduced, (,,) would be parsed as a tuple section.+    We shift, so (,,) is parsed as a data constructor.++    This is preferable because we want to accept (,,) without -XTupleSections.+    See also Note [ExplicitTuple] in GHC.Hs.Expr.+-}++{- Note [%shift: qtyconop -> qtyconsym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    oqtycon -> '(' qtyconsym . ')'+    qtyconop -> qtyconsym .++Example:+    foo :: (:%)++Ambiguity:+    If we reduced, (:%) would be parsed as a parenthehsized infix type+    expression without arguments, resulting in the 'failOpFewArgs' error.++    We shift, so it is parsed as a type constructor.+-}++{- Note [%shift: special_id -> 'group']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    transformqual -> 'then' 'group' . 'using' exp+    transformqual -> 'then' 'group' . 'by' exp 'using' exp+    special_id -> 'group' .++Example:+    [ ... | then group by dept using groupWith+          , then take 5 ]++Ambiguity:+    If we reduced, 'group' would be parsed as a term-level identifier, just as+    'take' in the other clause.++    We shift, so it is parsed as part of the 'group by' clause introduced by+    the -XTransformListComp extension.+-}++{- Note [%shift: activation -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'+    activation -> {- empty -}+    activation -> explicit_activation++Example:++    {-# INLINE [0] Something #-}++Ambiguity:+    We don't know whether the '[' is the start of the activation or the beginning+    of the [] data constructor.+    We parse this as having '[0]' activation for inlining 'Something', rather than+    empty activation and inlining '[0] Something'.+-}++{- Note [Parser API Annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A lot of the productions are now cluttered with calls to+aa,am,acs,acsA etc.++These are helper functions to make sure that the locations of the+various keywords such as do / let / in are captured for use by tools+that want to do source to source conversions, such as refactorers or+structured editors.++The helper functions are defined at the bottom of this file.++See+  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and+  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations+for some background.++-}++{- Note [Parsing lists]+~~~~~~~~~~~~~~~~~~~~~~~+You might be wondering why we spend so much effort encoding our lists this+way:++importdecls+        : importdecls ';' importdecl+        | importdecls ';'+        | importdecl+        | {- empty -}++This might seem like an awfully roundabout way to declare a list; plus, to add+insult to injury you have to reverse the results at the end.  The answer is that+left recursion prevents us from running out of stack space when parsing long+sequences.  See: https://www.haskell.org/happy/doc/html/sec-sequences.html for+more guidance.++By adding/removing branches, you can affect what lists are accepted.  Here+are the most common patterns, rewritten as regular expressions for clarity:++    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)+    xs : xs ';' x+       | xs ';'+       | x+       | {- empty -}++    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)+    xs : xs ';' x+       | xs ';'+       | x++    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)+    alts : alts1+         | ';' alts+    alts1 : alts1 ';' alt+          | alts1 ';'+          | alt++    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)+    xs : x+       | x ',' xs+-}++%token+ '_'            { L _ ITunderscore }            -- Haskell keywords+ 'as'           { L _ ITas }+ 'case'         { L _ ITcase }+ 'class'        { L _ ITclass }+ 'data'         { L _ ITdata }+ 'default'      { L _ ITdefault }+ 'deriving'     { L _ ITderiving }+ 'else'         { L _ ITelse }+ 'hiding'       { L _ IThiding }+ 'if'           { L _ ITif }+ 'import'       { L _ ITimport }+ 'in'           { L _ ITin }+ 'infix'        { L _ ITinfix }+ 'infixl'       { L _ ITinfixl }+ 'infixr'       { L _ ITinfixr }+ 'instance'     { L _ ITinstance }+ 'let'          { L _ ITlet }+ 'module'       { L _ ITmodule }+ 'newtype'      { L _ ITnewtype }+ 'of'           { L _ ITof }+ 'qualified'    { L _ ITqualified }+ 'then'         { L _ ITthen }+ 'type'         { L _ ITtype }+ 'where'        { L _ ITwhere }++ 'forall'       { L _ (ITforall _) }                -- GHC extension keywords+ 'foreign'      { L _ ITforeign }+ 'export'       { L _ ITexport }+ 'label'        { L _ ITlabel }+ 'dynamic'      { L _ ITdynamic }+ 'safe'         { L _ ITsafe }+ 'interruptible' { L _ ITinterruptible }+ 'unsafe'       { L _ ITunsafe }+ 'family'       { L _ ITfamily }+ 'role'         { L _ ITrole }+ 'stdcall'      { L _ ITstdcallconv }+ 'ccall'        { L _ ITccallconv }+ 'capi'         { L _ ITcapiconv }+ 'prim'         { L _ ITprimcallconv }+ 'javascript'   { L _ ITjavascriptcallconv }+ 'proc'         { L _ ITproc }          -- for arrow notation extension+ 'rec'          { L _ ITrec }           -- for arrow notation extension+ 'group'    { L _ ITgroup }     -- for list transform extension+ 'by'       { L _ ITby }        -- for list transform extension+ 'using'    { L _ ITusing }     -- for list transform extension+ 'pattern'      { L _ ITpattern } -- for pattern synonyms+ 'static'       { L _ ITstatic }  -- for static pointers extension+ 'stock'        { L _ ITstock }    -- for DerivingStrategies extension+ 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension+ 'via'          { L _ ITvia }      -- for DerivingStrategies extension++ 'unit'         { L _ ITunit }+ 'signature'    { L _ ITsignature }+ 'dependency'   { L _ ITdependency }++ '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE+ '{-# SPECIALISE'         { L _ (ITspec_prag _) }+ '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }+ '{-# SOURCE'             { L _ (ITsource_prag _) }+ '{-# RULES'              { L _ (ITrules_prag _) }+ '{-# SCC'                { L _ (ITscc_prag _)}+ '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }+ '{-# WARNING'            { L _ (ITwarning_prag _) }+ '{-# UNPACK'             { L _ (ITunpack_prag _) }+ '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }+ '{-# ANN'                { L _ (ITann_prag _) }+ '{-# MINIMAL'            { L _ (ITminimal_prag _) }+ '{-# CTYPE'              { L _ (ITctype _) }+ '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }+ '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }+ '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }+ '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }+ '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }+ '#-}'                    { L _ ITclose_prag }++ '..'           { L _ ITdotdot }                        -- reserved symbols+ ':'            { L _ ITcolon }+ '::'           { L _ (ITdcolon _) }+ '='            { L _ ITequal }+ '\\'           { L _ ITlam }+ 'lcase'        { L _ ITlcase }+ '|'            { L _ ITvbar }+ '<-'           { L _ (ITlarrow _) }+ '->'           { L _ (ITrarrow _) }+ '->.'          { L _ ITlolly }+ TIGHT_INFIX_AT { L _ ITat }+ '=>'           { L _ (ITdarrow _) }+ '-'            { L _ ITminus }+ PREFIX_TILDE   { L _ ITtilde }+ PREFIX_BANG    { L _ ITbang }+ PREFIX_MINUS   { L _ ITprefixminus }+ '*'            { L _ (ITstar _) }+ '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation+ '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation+ '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation+ '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation+ '.'            { L _ ITdot }+ PREFIX_PROJ    { L _ (ITproj True) }               -- RecordDotSyntax+ TIGHT_INFIX_PROJ { L _ (ITproj False) }            -- RecordDotSyntax+ PREFIX_AT      { L _ ITtypeApp }+ PREFIX_PERCENT { L _ ITpercent }                   -- for linear types++ '{'            { L _ ITocurly }                        -- special symbols+ '}'            { L _ ITccurly }+ vocurly        { L _ ITvocurly } -- virtual open curly (from layout)+ vccurly        { L _ ITvccurly } -- virtual close curly (from layout)+ '['            { L _ ITobrack }+ ']'            { L _ ITcbrack }+ '('            { L _ IToparen }+ ')'            { L _ ITcparen }+ '(#'           { L _ IToubxparen }+ '#)'           { L _ ITcubxparen }+ '(|'           { L _ (IToparenbar _) }+ '|)'           { L _ (ITcparenbar _) }+ ';'            { L _ ITsemi }+ ','            { L _ ITcomma }+ '`'            { L _ ITbackquote }+ SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x++ VARID          { L _ (ITvarid    _) }          -- identifiers+ CONID          { L _ (ITconid    _) }+ VARSYM         { L _ (ITvarsym   _) }+ CONSYM         { L _ (ITconsym   _) }+ QVARID         { L _ (ITqvarid   _) }+ QCONID         { L _ (ITqconid   _) }+ QVARSYM        { L _ (ITqvarsym  _) }+ QCONSYM        { L _ (ITqconsym  _) }+++ -- QualifiedDo+ DO             { L _ (ITdo  _) }+ MDO            { L _ (ITmdo _) }++ IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension+ LABELVARID     { L _ (ITlabelvarid   _) }++ CHAR           { L _ (ITchar   _ _) }+ STRING         { L _ (ITstring _ _) }+ INTEGER        { L _ (ITinteger _) }+ RATIONAL       { L _ (ITrational _) }++ PRIMCHAR       { L _ (ITprimchar   _ _) }+ PRIMSTRING     { L _ (ITprimstring _ _) }+ PRIMINTEGER    { L _ (ITprimint    _ _) }+ PRIMWORD       { L _ (ITprimword   _ _) }+ PRIMFLOAT      { L _ (ITprimfloat  _) }+ PRIMDOUBLE     { L _ (ITprimdouble _) }++-- Template Haskell+'[|'            { L _ (ITopenExpQuote _ _) }+'[p|'           { L _ ITopenPatQuote  }+'[t|'           { L _ ITopenTypQuote  }+'[d|'           { L _ ITopenDecQuote  }+'|]'            { L _ (ITcloseQuote _) }+'[||'           { L _ (ITopenTExpQuote _) }+'||]'           { L _ ITcloseTExpQuote  }+PREFIX_DOLLAR   { L _ ITdollar }+PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }+TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T+TH_QUASIQUOTE   { L _ (ITquasiQuote _) }+TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }++%monad { P } { >>= } { return }+%lexer { (lexer True) } { L _ ITeof }+  -- Replace 'lexer' above with 'lexerDbg'+  -- to dump the tokens fed to the parser.+%tokentype { (Located Token) }++-- Exported parsers+%name parseModuleNoHaddock module+%name parseSignature signature+%name parseImport importdecl+%name parseStatement e_stmt+%name parseDeclaration topdecl+%name parseExpression exp+%name parsePattern pat+%name parseTypeSignature sigdecl+%name parseStmt   maybe_stmt+%name parseIdentifier  identifier+%name parseType ktype+%name parseBackpack backpack+%partial parseHeader header+%%++-----------------------------------------------------------------------------+-- Identifiers; one of the entry points+identifier :: { LocatedN RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }+        | qvarop                        { $1 }+        | qconop                        { $1 }+    | '(' '->' ')'      {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                 (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+    | '->'              {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                 (NameAnnRArrow (glAA $1) []) }++-----------------------------------------------------------------------------+-- Backpack stuff++backpack :: { [LHsUnit PackageName] }+         : implicit_top units close { fromOL $2 }+         | '{' units '}'            { fromOL $2 }++units :: { OrdList (LHsUnit PackageName) }+         : units ';' unit { $1 `appOL` unitOL $3 }+         | units ';'      { $1 }+         | unit           { unitOL $1 }++unit :: { LHsUnit PackageName }+        : 'unit' pkgname 'where' unitbody+            { sL1 $1 $ HsUnit { hsunitName = $2+                              , hsunitBody = fromOL $4 } }++unitid :: { LHsUnitId PackageName }+        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }+        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }++msubsts :: { OrdList (LHsModuleSubst PackageName) }+        : msubsts ',' msubst { $1 `appOL` unitOL $3 }+        | msubsts ','        { $1 }+        | msubst             { unitOL $1 }++msubst :: { LHsModuleSubst PackageName }+        : modid '=' moduleid { sLL (reLoc $1) $> $ (reLoc $1, $3) }+        | modid VARSYM modid VARSYM { sLL (reLoc $1) $> $ (reLoc $1, sLL $2 $> $ HsModuleVar (reLoc $3)) }++moduleid :: { LHsModuleId PackageName }+          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar (reLoc $2) }+          | unitid ':' modid    { sLL $1 (reLoc $>) $ HsModuleId $1 (reLoc $3) }++pkgname :: { Located PackageName }+        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }+        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }++litpkgname_segment :: { Located FastString }+        : VARID  { sL1 $1 $ getVARID $1 }+        | CONID  { sL1 $1 $ getCONID $1 }+        | special_id { $1 }++-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.+-- See Note [Minus tokens] in GHC.Parser.Lexer+HYPHEN :: { [AddEpAnn] }+      : '-'          { [mj AnnMinus $1 ] }+      | PREFIX_MINUS { [mj AnnMinus $1 ] }+      | VARSYM  {% if (getVARSYM $1 == fsLit "-")+                   then return [mj AnnMinus $1]+                   else do { addError $ PsError PsErrExpectedHyphen [] (getLoc $1)+                           ; return [] } }+++litpkgname :: { Located FastString }+        : litpkgname_segment { $1 }+        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.+        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ appendFS (unLoc $1) (consFS '-' (unLoc $3)) }++mayberns :: { Maybe [LRenaming] }+        : {- empty -} { Nothing }+        | '(' rns ')' { Just (fromOL $2) }++rns :: { OrdList LRenaming }+        : rns ',' rn { $1 `appOL` unitOL $3 }+        | rns ','    { $1 }+        | rn         { unitOL $1 }++rn :: { LRenaming }+        : modid 'as' modid { sLL (reLoc $1) (reLoc $>) $ Renaming (reLoc $1) (Just (reLoc $3)) }+        | modid            { sL1 (reLoc $1)            $ Renaming (reLoc $1) Nothing }++unitbody :: { OrdList (LHsUnitDecl PackageName) }+        : '{'     unitdecls '}'   { $2 }+        | vocurly unitdecls close { $2 }++unitdecls :: { OrdList (LHsUnitDecl PackageName) }+        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }+        | unitdecls ';'         { $1 }+        | unitdecl              { unitOL $1 }++unitdecl :: { LHsUnitDecl PackageName }+        : 'module' maybe_src modid maybemodwarning maybeexports 'where' body+             -- XXX not accurate+             { sL1 $1 $ DeclD+                 (case snd $2 of+                   NotBoot -> HsSrcFile+                   IsBoot  -> HsBootFile)+                 (reLoc $3)+                 (Just $ sL1 $1 (HsModule noAnn (thdOf3 $7) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7) $4 Nothing)) }+        | 'signature' modid maybemodwarning maybeexports 'where' body+             { sL1 $1 $ DeclD+                 HsigFile+                 (reLoc $2)+                 (Just $ sL1 $1 (HsModule noAnn (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6) $3 Nothing)) }+        | 'module' maybe_src modid+             { sL1 $1 $ DeclD (case snd $2 of+                   NotBoot -> HsSrcFile+                   IsBoot  -> HsBootFile) (reLoc $3) Nothing }+        | 'signature' modid+             { sL1 $1 $ DeclD HsigFile (reLoc $2) Nothing }+        | 'dependency' unitid mayberns+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2+                                              , idModRenaming = $3+                                              , idSignatureInclude = False }) }+        | 'dependency' 'signature' unitid+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3+                                              , idModRenaming = Nothing+                                              , idSignatureInclude = True }) }++-----------------------------------------------------------------------------+-- Module Header++-- The place for module deprecation is really too restrictive, but if it+-- was allowed at its natural place just before 'module', we get an ugly+-- s/r conflict with the second alternative. Another solution would be the+-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,+-- either, and DEPRECATED is only expected to be used by people who really+-- know what they are doing. :-)++signature :: { Located HsModule }+       : 'signature' modid maybemodwarning maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                acs (\cs-> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6)) cs)+                              (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)+                              (snd $ sndOf3 $6) $3 Nothing))+                    ) }++module :: { Located HsModule }+       : 'module' modid maybemodwarning maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6)) cs)+                               (thdOf3 $6) (Just $2) $4 (fst $ sndOf3 $6)+                              (snd $ sndOf3 $6) $3 Nothing)+                    )) }+        | body2+                {% fileSrcSpan >>= \ loc ->+                   acsFinal (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1)) cs)+                                (thdOf3 $1) Nothing Nothing+                               (fst $ sndOf3 $1) (snd $ sndOf3 $1) Nothing Nothing))) }++missing_module_keyword :: { () }+        : {- empty -}                           {% pushModuleContext }++implicit_top :: { () }+        : {- empty -}                           {% pushModuleContext }++maybemodwarning :: { Maybe (LocatedP WarningTxt) }+    : '{-# DEPRECATED' strings '#-}'+                      {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (snd $ unLoc $2))+                              (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }+    | '{-# WARNING' strings '#-}'+                         {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt (sL1 $1 $ getWARNING_PRAGs $1) (snd $ unLoc $2))+                                 (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2))}+    |  {- empty -}                  { Nothing }++body    :: { (AnnList+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,LayoutInfo) }+        :  '{'            top '}'      { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)+                                         , snd $2, ExplicitBraces) }+        |      vocurly    top close    { (AnnList Nothing Nothing Nothing [] (fst $2)+                                         , snd $2, VirtualBraces (getVOCURLY $1)) }++body2   :: { (AnnList+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,LayoutInfo) }+        :  '{' top '}'                          { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2)+                                                  , snd $2, ExplicitBraces) }+        |  missing_module_keyword top close     { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) }+++top     :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }+        : semis top1                            { (reverse $1, $2) }++top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }+        : importdecls_semi topdecls_cs_semi        { (reverse $1, cvTopDecls $2) }+        | importdecls_semi topdecls_cs             { (reverse $1, cvTopDecls $2) }+        | importdecls                              { (reverse $1, []) }++-----------------------------------------------------------------------------+-- Module declaration & imports only++header  :: { Located HsModule }+        : 'module' modid maybemodwarning maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)+                              NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing+                          ))) }+        | 'signature' modid maybemodwarning maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   acs (\cs -> (L loc (HsModule (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] (AnnList Nothing Nothing Nothing [] [])) cs)+                           NoLayoutInfo (Just $2) $4 $6 [] $3 Nothing+                          ))) }+        | header_body2+                {% fileSrcSpan >>= \ loc ->+                   return (L loc (HsModule noAnn NoLayoutInfo Nothing Nothing $1 [] Nothing+                          Nothing)) }++header_body :: { [LImportDecl GhcPs] }+        :  '{'            header_top            { $2 }+        |      vocurly    header_top            { $2 }++header_body2 :: { [LImportDecl GhcPs] }+        :  '{' header_top                       { $2 }+        |  missing_module_keyword header_top    { $2 }++header_top :: { [LImportDecl GhcPs] }+        :  semis header_top_importdecls         { $2 }++header_top_importdecls :: { [LImportDecl GhcPs] }+        :  importdecls_semi                     { $1 }+        |  importdecls                          { $1 }++-----------------------------------------------------------------------------+-- The Export List++maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }+        :  '(' exportlist ')'       {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2))+                                        (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }+        |  {- empty -}              { Nothing }++exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }+        : exportlist1     { ([], $1) }+        | {- empty -}     { ([], nilOL) }++        -- trailing comma:+        | exportlist1 ',' {% case $1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (gl $2)+                                 return ([], snocOL hs t')}+        | ','             { ([mj AnnComma $1], nilOL) }++exportlist1 :: { OrdList (LIE GhcPs) }+        : exportlist1 ',' export+                          {% let ls = $1+                             in if isNilOL ls+                                  then return (ls `appOL` $3)+                                  else case ls of+                                         SnocOL hs t -> do+                                           t' <- addTrailingCommaA t (gl $2)+                                           return (snocOL hs t' `appOL` $3)}+        | export          { $1 }+++   -- No longer allow things like [] and (,,,) to be exported+   -- They are built in syntax, always available+export  :: { OrdList (LIE GhcPs) }+        : qcname_ext export_subspec  {% mkModuleImpExp (fst $ unLoc $2) $1 (snd $ unLoc $2)+                                          >>= \ie -> fmap (unitOL . reLocA) (return (sLL (reLoc $1) $> ie)) }+        |  'module' modid            {% fmap (unitOL . reLocA) (acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (EpAnn (glR $1) [mj AnnModule $1] cs) $2))) }+        |  'pattern' qcon            { unitOL (reLocA (sLL $1 (reLocN $>)+                                              (IEVar noExtField (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2))))) }++export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }+        : {- empty -}             { sL0 ([],ImpExpAbs) }+        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))+                                      >>= \(as,ie) -> return $ sLL $1 $>+                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }++qcnames :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }+  : {- empty -}                   { ([],[]) }+  | qcnames1                      { $1 }++qcnames1 :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }     -- A reversed list+        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (snd $1) of+                                                    (l@(L la ImpExpQcWildcard):t) ->+                                                       do { l' <- addTrailingCommaA l (gl $2)+                                                          ; return ([mj AnnDotdot (reLoc l),+                                                                     mj AnnComma $2]+                                                                   ,(snd (unLoc $3)  : l' : t)) }+                                                    (l:t) ->+                                                       do { l' <- addTrailingCommaA l (gl $2)+                                                          ; return (fst $1 ++ fst (unLoc $3)+                                                                   , snd (unLoc $3) : l' : t)} }++        -- Annotations re-added in mkImpExpSubSpec+        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }++-- Variable, data constructor or wildcard+-- or tagged type constructor+qcname_ext_w_wildcard :: { Located ([AddEpAnn], LocatedA ImpExpQcSpec) }+        :  qcname_ext               { sL1A $1 ([],$1) }+        |  '..'                     { sL1  $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard)  }++qcname_ext :: { LocatedA ImpExpQcSpec }+        :  qcname                   { reLocA $ sL1N $1 (ImpExpQcName $1) }+        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2+                                          ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glAA $1) n) }}++qcname  :: { LocatedN RdrName }  -- Variable or type constructor+        :  qvar                 { $1 } -- Things which look like functions+                                       -- Note: This includes record selectors but+                                       -- also (-.->), see #11432+        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]++-----------------------------------------------------------------------------+-- Import Declarations++-- importdecls and topdecls must contain at least one declaration;+-- top handles the fact that these may be optional.++-- One or more semicolons+semis1  :: { Located [TrailingAnn] }+semis1  : semis1 ';'  { sLL $1 $> $ if isZeroWidthSpan (gl $2) then (unLoc $1) else (AddSemiAnn (glAA $2) : (unLoc $1)) }+        | ';'         { sL1 $1 $ msemi $1 }++-- Zero or more semicolons+semis   :: { [TrailingAnn] }+semis   : semis ';'   { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }+        | {- empty -} { [] }++-- No trailing semicolons, non-empty+importdecls :: { [LImportDecl GhcPs] }+importdecls+        : importdecls_semi importdecl+                                { $2 : $1 }++-- May have trailing semicolons, can be empty+importdecls_semi :: { [LImportDecl GhcPs] }+importdecls_semi+        : importdecls_semi importdecl semis1+                                {% do { i <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)+                                      ; return (i : $1)} }+        | {- empty -}           { [] }++importdecl :: { LImportDecl GhcPs }+        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec+                {% do {+                  ; let { ; mPreQual = unLoc $4+                          ; mPostQual = unLoc $7 }+                  ; checkImportDecl mPreQual mPostQual+                  ; let anns+                         = EpAnnImportDecl+                             { importDeclAnnImport    = glAA $1+                             , importDeclAnnPragma    = fst $ fst $2+                             , importDeclAnnSafe      = fst $3+                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual+                             , importDeclAnnPackage   = fst $5+                             , importDeclAnnAs        = fst $8+                             }+                  ; fmap reLocA $ acs (\cs -> L (comb5 $1 (reLoc $6) $7 (snd $8) $9) $+                      ImportDecl { ideclExt = EpAnn (glR $1) anns cs+                                  , ideclSourceSrc = snd $ fst $2+                                  , ideclName = $6, ideclPkgQual = snd $5+                                  , ideclSource = snd $2, ideclSafe = snd $3+                                  , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual+                                  , ideclImplicit = False+                                  , ideclAs = unLoc (snd $8)+                                  , ideclHiding = unLoc $9 })+                  }+                }+++maybe_src :: { ((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface) }+        : '{-# SOURCE' '#-}'        { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1)+                                      , IsBoot) }+        | {- empty -}               { ((Nothing,NoSourceText),NotBoot) }++maybe_safe :: { (Maybe EpaLocation,Bool) }+        : 'safe'                                { (Just (glAA $1),True) }+        | {- empty -}                           { (Nothing,      False) }++maybe_pkg :: { (Maybe EpaLocation,Maybe StringLiteral) }+        : STRING  {% do { let { pkgFS = getSTRING $1 }+                        ; unless (looksLikePackageName (unpackFS pkgFS)) $+                             addError $ PsError (PsErrInvalidPackageName pkgFS) [] (getLoc $1)+                        ; return (Just (glAA $1), Just (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }+        | {- empty -}                           { (Nothing,Nothing) }++optqualified :: { Located (Maybe EpaLocation) }+        : 'qualified'                           { sL1 $1 (Just (glAA $1)) }+        | {- empty -}                           { noLoc Nothing }++maybeas :: { (Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))) }+        : 'as' modid                           { (Just (glAA $1)+                                                 ,sLL $1 (reLoc $>) (Just $2)) }+        | {- empty -}                          { (Nothing,noLoc Nothing) }++maybeimpspec :: { Located (Maybe (Bool, LocatedL [LIE GhcPs])) }+        : impspec                  {% let (b, ie) = unLoc $1 in+                                       checkImportSpec ie+                                        >>= \checkedIe ->+                                          return (L (gl $1) (Just (b, checkedIe)))  }+        | {- empty -}              { noLoc Nothing }++impspec :: { Located (Bool, LocatedL [LIE GhcPs]) }+        :  '(' exportlist ')'               {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)+                                                               (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])+                                                  ; return $ sLL $1 $> (False, es)} }+        |  'hiding' '(' exportlist ')'      {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)+                                                               (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])+                                                  ; return $ sLL $1 $> (True, es)} }++-----------------------------------------------------------------------------+-- Fixity Declarations++prec    :: { Located (SourceText,Int) }+        : {- empty -}           { noLoc (NoSourceText,9) }+        | INTEGER+                 { sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1))) }++infix   :: { Located FixityDirection }+        : 'infix'                               { sL1 $1 InfixN  }+        | 'infixl'                              { sL1 $1 InfixL  }+        | 'infixr'                              { sL1 $1 InfixR }++ops     :: { Located (OrdList (LocatedN RdrName)) }+        : ops ',' op       {% case (unLoc $1) of+                                SnocOL hs t -> do+                                  t' <- addTrailingCommaN t (gl $2)+                                  return (sLL $1 (reLocN $>) (snocOL hs t' `appOL` unitOL $3)) }+        | op               { sL1N $1 (unitOL $1) }++-----------------------------------------------------------------------------+-- Top-Level Declarations++-- No trailing semicolons, non-empty+topdecls :: { OrdList (LHsDecl GhcPs) }+        : topdecls_semi topdecl        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_semi :: { OrdList (LHsDecl GhcPs) }+        : topdecls_semi topdecl semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)+                                             ; return ($1 `snocOL` t) }}+        | {- empty -}                  { nilOL }+++-----------------------------------------------------------------------------+-- Each topdecl accumulates prior comments+-- No trailing semicolons, non-empty+topdecls_cs :: { OrdList (LHsDecl GhcPs) }+        : topdecls_cs_semi topdecl_cs        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }+        : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)+                                                   ; return ($1 `snocOL` t) }}+        | {- empty -}                  { nilOL }++-- Each topdecl accumulates prior comments+topdecl_cs :: { LHsDecl GhcPs }+topdecl_cs : topdecl {% commentsPA $1 }++-----------------------------------------------------------------------------+topdecl :: { LHsDecl GhcPs }+        : cl_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }+        | ty_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }+        | standalone_kind_sig                   { sL1 $1 (KindSigD noExtField (unLoc $1)) }+        | inst_decl                             { sL1 $1 (InstD noExtField (unLoc $1)) }+        | stand_alone_deriving                  { sL1 $1 (DerivD noExtField (unLoc $1)) }+        | role_annot                            { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }+        | 'default' '(' comma_types0 ')'        {% acsA (\cs -> sLL $1 $>+                                                    (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }+        | 'foreign' fdecl                       {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }+        | '{-# DEPRECATED' deprecations '#-}'   {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getDEPRECATED_PRAGs $1) (fromOL $2))) }+        | '{-# WARNING' warnings '#-}'          {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings (EpAnn (glR $1) [mo $1,mc $3] cs) (getWARNING_PRAGs $1) (fromOL $2))) }+        | '{-# RULES' rules '#-}'               {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules (EpAnn (glR $1) [mo $1,mc $3] cs) (getRULES_PRAGs $1) (reverse $2))) }+        | annotation { $1 }+        | decl_no_th                            { $1 }++        -- Template Haskell Extension+        -- The $(..) form is one possible form of infixexp+        -- but we treat an arbitrary expression just as if+        -- it had a $(..) wrapped around it+        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->+                                                    do { d <- mkSpliceDecl $1+                                                       ; commentsPA d }}++-- Type classes+--+cl_decl :: { LTyClDecl GhcPs }+        : 'class' tycl_hdr fds where_cls+                {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))+                        (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }++-- Type declarations (toplevel)+--+ty_decl :: { LTyClDecl GhcPs }+           -- ordinary type synonyms+        : 'type' type '=' ktype+                -- Note ktype, not sigtype, on the right of '='+                -- We allow an explicit for-all but we don't insert one+                -- in   type Foo a = (b,b)+                -- Instead we just say b is out of scope+                --+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% mkTySynonym (comb2A $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }++           -- type family declarations+        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info+                          where_type_family+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% mkFamDecl (comb5 $1 (reLoc $3) $4 $5 $6) (snd $ unLoc $6) TopLevel $3+                                   (snd $ unLoc $4) (snd $ unLoc $5)+                           (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)+                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }++          -- ordinary data type or newtype declaration+        | data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings+                {% mkTyData (comb4 $1 $3 $4 $5) (snd $ unLoc $1) $2 $3+                           Nothing (reverse (snd $ unLoc $4))+                                   (fmap reverse $5)+                           ((fst $ unLoc $1):(fst $ unLoc $4)) }+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty++          -- ordinary GADT declaration+        | data_or_newtype capi_ctype tycl_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% mkTyData (comb4 $1 $3 $5 $6) (snd $ unLoc $1) $2 $3+                            (snd $ unLoc $4) (snd $ unLoc $5)+                            (fmap reverse $6)+                            ((fst $ unLoc $1):(fst $ unLoc $4)++(fst $ unLoc $5)) }+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty++          -- data/newtype family+        | 'data' 'family' type opt_datafam_kind_sig+                {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3+                                   (snd $ unLoc $4) Nothing+                          (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }++-- standalone kind signature+standalone_kind_sig :: { LStandaloneKindSig GhcPs }+  : 'type' sks_vars '::' sigktype+      {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4+               [mj AnnType $1,mu AnnDcolon $3]}++-- See also: sig_vars+sks_vars :: { Located [LocatedN RdrName] }  -- Returned in reverse order+  : sks_vars ',' oqtycon+      {% case unLoc $1 of+           (h:t) -> do+             h' <- addTrailingCommaN h (gl $2)+             return (sLL $1 (reLocN $>) ($3 : h' : t)) }+  | oqtycon { sL1N $1 [$1] }++inst_decl :: { LInstDecl GhcPs }+        : 'instance' overlap_pragma inst_type where_inst+       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)+             ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4))+             ; let cid cs = ClsInstDecl+                                     { cid_ext = (EpAnn (glR $1) anns cs, NoAnnSortKey)+                                     , cid_poly_ty = $3, cid_binds = binds+                                     , cid_sigs = mkClassOpSigs sigs+                                     , cid_tyfam_insts = ats+                                     , cid_overlap_mode = $2+                                     , cid_datafam_insts = adts }+             ; acsA (\cs -> L (comb3 $1 (reLoc $3) $4)+                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))+                   } }++           -- type instance declarations+        | 'type' 'instance' ty_fam_inst_eqn+                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)+                        (mj AnnType $1:mj AnnInstance $2:[]) }++          -- data/newtype instance declaration+        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs+                          maybe_derivings+            {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)+                                      Nothing (reverse (snd  $ unLoc $5))+                                              (fmap reverse $6)+                      ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }++          -- GADT instance declaration+        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)+                                   (snd $ unLoc $5) (snd $ unLoc $6)+                                   (fmap reverse $7)+                     ((fst $ unLoc $1):mj AnnInstance $2+                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }++overlap_pragma :: { Maybe (LocatedP OverlapMode) }+  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | {- empty -}                 { Nothing }++deriv_strategy_no_via :: { LDerivStrategy GhcPs }+  : 'stock'                     {% acs (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }+  | 'anyclass'                  {% acs (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }+  | 'newtype'                   {% acs (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }++deriv_strategy_via :: { LDerivStrategy GhcPs }+  : 'via' sigktype          {% acs (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)+                                                                           $2))) }++deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }+  : 'stock'                     {% fmap Just $ acs (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }+  | 'anyclass'                  {% fmap Just $ acs (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }+  | 'newtype'                   {% fmap Just $ acs (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }+  | deriv_strategy_via          { Just $1 }+  | {- empty -}                 { Nothing }++-- Injective type families++opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }+        : {- empty -}               { noLoc ([], Nothing) }+        | '|' injectivity_cond      { sLL $1 $> ([mj AnnVbar $1]+                                                , Just ($2)) }++injectivity_cond :: { LInjectivityAnn GhcPs }+        : tyvarid '->' inj_varids+           {% acs (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }++inj_varids :: { Located [LocatedN RdrName] }+        : inj_varids tyvarid  { sLL $1 (reLocN $>) ($2 : unLoc $1) }+        | tyvarid             { sL1N  $1 [$1]               }++-- Closed type families++where_type_family :: { Located ([AddEpAnn],FamilyInfo GhcPs) }+        : {- empty -}                      { noLoc ([],OpenTypeFamily) }+        | 'where' ty_fam_inst_eqn_list+               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }++ty_fam_inst_eqn_list :: { Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]) }+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]+                                                ,Just (unLoc $2)) }+        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in+                                             L loc ([],Just (unLoc $2)) }+        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2+                                                 ,mcc $3],Nothing) }+        | vocurly '..' close               { let (L loc _) = $2 in+                                             L loc ([mj AnnDotdot $2],Nothing) }++ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }+        : ty_fam_inst_eqns ';' ty_fam_inst_eqn+                                      {% let (L loc eqn) = $3 in+                                         case unLoc $1 of+                                           [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl $2)+                                             return (sLLlA $1 $> ($3 : h' : t)) }+        | ty_fam_inst_eqns ';'        {% case unLoc $1 of+                                           [] -> return (sLL $1 $> (unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl $2)+                                             return (sLL $1 $>  (h':t)) }+        | ty_fam_inst_eqn             { sLLAA $1 $> [$1] }+        | {- empty -}                 { noLoc [] }++ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }+        : 'forall' tv_bndrs '.' type '=' ktype+              {% do { hintExplicitForall $1+                    ; tvbs <- fromSpecTyVarBndrs $2+                    ; let loc = comb2A $1 $>+                    ; cs <- getCommentsFor loc+                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}+        | type '=' ktype+              {% mkTyFamInstEqn (comb2A (reLoc $1) $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }+              -- Note the use of type for the head; this allows+              -- infix type constructors and type patterns++-- Associated type family declarations+--+-- * They have a different syntax than on the toplevel (no family special+--   identifier).+--+-- * They also need to be separate from instances; otherwise, data family+--   declarations without a kind signature cause parsing conflicts with empty+--   data declarations.+--+at_decl_cls :: { LHsDecl GhcPs }+        :  -- data family declarations, with optional 'family' keyword+          'data' opt_family type opt_datafam_kind_sig+                {% liftM mkTyClD (mkFamDecl (comb3 $1 (reLoc $3) $4) DataFamily NotTopLevel $3+                                                  (snd $ unLoc $4) Nothing+                        (mj AnnData $1:$2++(fst $ unLoc $4))) }++           -- type family declarations, with optional 'family' keyword+           -- (can't use opt_instance because you get shift/reduce errors+        | 'type' type opt_at_kind_inj_sig+               {% liftM mkTyClD+                        (mkFamDecl (comb3 $1 (reLoc $2) $3) OpenTypeFamily NotTopLevel $2+                                   (fst . snd $ unLoc $3)+                                   (snd . snd $ unLoc $3)+                         (mj AnnType $1:(fst $ unLoc $3)) )}+        | 'type' 'family' type opt_at_kind_inj_sig+               {% liftM mkTyClD+                        (mkFamDecl (comb3 $1 (reLoc $3) $4) OpenTypeFamily NotTopLevel $3+                                   (fst . snd $ unLoc $4)+                                   (snd . snd $ unLoc $4)+                         (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}++           -- default type instances, with optional 'instance' keyword+        | 'type' ty_fam_inst_eqn+                {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2)+                          [mj AnnType $1]) }+        | 'type' 'instance' ty_fam_inst_eqn+                {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3)+                              (mj AnnType $1:mj AnnInstance $2:[]) )}++opt_family   :: { [AddEpAnn] }+              : {- empty -}   { [] }+              | 'family'      { [mj AnnFamily $1] }++opt_instance :: { [AddEpAnn] }+              : {- empty -} { [] }+              | 'instance'  { [mj AnnInstance $1] }++-- Associated type instances+--+at_decl_inst :: { LInstDecl GhcPs }+           -- type instance declarations, with optional 'instance' keyword+        : 'type' opt_instance ty_fam_inst_eqn+                -- Note the use of type for the head; this allows+                -- infix type constructors and type patterns+                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)+                          (mj AnnType $1:$2) }++        -- data/newtype instance declaration, with optional 'instance' keyword+        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings+               {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)+                                    Nothing (reverse (snd $ unLoc $5))+                                            (fmap reverse $6)+                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)) }++        -- GADT instance declaration, with optional 'instance' keyword+        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+                {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3+                                (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)+                                (fmap reverse $7)+                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }++data_or_newtype :: { Located (AddEpAnn, NewOrData) }+        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }+        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }++-- Family result/return kind signatures++opt_kind_sig :: { Located ([AddEpAnn], Maybe (LHsKind GhcPs)) }+        :               { noLoc     ([]               , Nothing) }+        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) }++opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }+        :               { noLoc     ([]               , noLoc (NoSig noExtField)         )}+        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig noExtField $2))}++opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }+        :              { noLoc     ([]               , noLoc     (NoSig    noExtField)   )}+        | '::' kind    { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLL $1 (reLoc $>) (KindSig  noExtField $2))}+        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2+                             ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLL $1 (reLoc $>) (TyVarSig noExtField tvb))} }++opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs+                                            , Maybe (LInjectivityAnn GhcPs)))}+        :            { noLoc ([], (noLoc (NoSig noExtField), Nothing)) }+        | '::' kind  { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]+                                 , (sL1A $> (KindSig noExtField $2), Nothing)) }+        | '='  tv_bndr_no_braces '|' injectivity_cond+                {% do { tvb <- fromSpecTyVarBndr $2+                      ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]+                                           , (sLL $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }++-- tycl_hdr parses the header of a class or data type decl,+-- which takes the form+--      T a b+--      Eq a => T a+--      (Eq a, Ord b) => T a b+--      T Int [a]                       -- for associated types+-- Rather a lot of inlining here, else we get reduce/reduce errors+tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }+        : context '=>' type         {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) }+        | type                      { sL1A $1 (Nothing, $1) }++datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }+        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1+                                                       >> fromSpecTyVarBndrs $2+                                                         >>= \tvbs ->+                                                             (acs (\cs -> (sLL $1 (reLoc $>)+                                                                                  (Just ( addTrailingDarrowC $4 $5 cs)+                                                                                        , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))+                                                    }+        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1+                                             ; tvbs <- fromSpecTyVarBndrs $2+                                             ; let loc = comb2 $1 (reLoc $>)+                                             ; cs <- getCommentsFor loc+                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))+                                       } }+        | context '=>' type         {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }+        | type                      { sL1A $1 (Nothing, mkHsOuterImplicit, $1) }+++capi_ctype :: { Maybe (LocatedP CType) }+capi_ctype : '{-# CTYPE' STRING STRING '#-}'+                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))+                                        (getSTRINGs $3,getSTRING $3)))+                              (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }++           | '{-# CTYPE'        STRING '#-}'+                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))+                              (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }++           |           { Nothing }++-----------------------------------------------------------------------------+-- Stand-alone deriving++-- Glasgow extension: stand-alone deriving declarations+stand_alone_deriving :: { LDerivDecl GhcPs }+  : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type+                {% do { let { err = text "in the stand-alone deriving instance"+                                    <> colon <+> quotes (ppr $5) }+                      ; acsA (\cs -> sLL $1 (reLoc $>)+                                 (DerivDecl (EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}++-----------------------------------------------------------------------------+-- Role annotations++role_annot :: { LRoleAnnotDecl GhcPs }+role_annot : 'type' 'role' oqtycon maybe_roles+          {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))+                   [mj AnnType $1,mj AnnRole $2] }++-- Reversed!+maybe_roles :: { Located [Located (Maybe FastString)] }+maybe_roles : {- empty -}    { noLoc [] }+            | roles          { $1 }++roles :: { Located [Located (Maybe FastString)] }+roles : role             { sLL $1 $> [$1] }+      | roles role       { sLL $1 $> $ $2 : unLoc $1 }++-- read it in as a varid for better error messages+role :: { Located (Maybe FastString) }+role : VARID             { sL1 $1 $ Just $ getVARID $1 }+     | '_'               { sL1 $1 Nothing }++-- Pattern synonyms++-- Glasgow extension: pattern synonyms+pattern_synonym_decl :: { LHsDecl GhcPs }+        : 'pattern' pattern_synonym_lhs '=' pat+         {%      let (name, args, as ) = $2 in+                 acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4+                                                    ImplicitBidirectional+                      (EpAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }++        | 'pattern' pattern_synonym_lhs '<-' pat+         {%    let (name, args, as) = $2 in+               acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 Unidirectional+                       (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }++        | 'pattern' pattern_synonym_lhs '<-' pat where_decls+            {% do { let (name, args, as) = $2+                  ; mg <- mkPatSynMatchGroup name $5+                  ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $+                           mkPatSynBind name args $4 (ExplicitBidirectional mg)+                            (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))+                   }}++pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) }+        : con vars0 { ($1, PrefixCon noTypeArgs $2, []) }+        | varid conop varid { ($2, InfixCon $1 $3, []) }+        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }++vars0 :: { [LocatedN RdrName] }+        : {- empty -}                 { [] }+        | varid vars0                 { $1 : $2 }++cvars1 :: { [RecordPatSynField GhcPs] }+       : var                          { [RecordPatSynField (mkFieldOcc $1) $1] }+       | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)+                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}++where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }+        : 'where' '{' decls '}'       {% amsrl (sLL $1 $> (snd $ unLoc $3))+                                              (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }+        | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))+                                              (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}++pattern_synonym_sig :: { LSig GhcPs }+        : 'pattern' con_list '::' sigtype+                   {% acsA (\cs -> sLL $1 (reLoc $>)+                                $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)+                                  (unLoc $2) $4) }++qvarcon :: { LocatedN RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }++-----------------------------------------------------------------------------+-- Nested declarations++-- Declaration in class bodies+--+decl_cls  :: { LHsDecl GhcPs }+decl_cls  : at_decl_cls                 { $1 }+          | decl                        { $1 }++          -- A 'default' signature used with the generic-programming extension+          | 'default' infixexp '::' sigtype+                    {% runPV (unECP $2) >>= \ $2 ->+                       do { v <- checkValSigLhs $2+                          ; let err = text "in default signature" <> colon <+>+                                      quotes (ppr $2)+                          ; acsA (\cs -> sLL $1 (reLoc $>) $ SigD noExtField $ ClassOpSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}++decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed+          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)+                                             then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                    , unitOL $3))+                                            else case (snd $ unLoc $1) of+                                              SnocOL hs t -> do+                                                 t' <- addTrailingSemiA t (gl $2)+                                                 return (sLLlA $1 $> (fst $ unLoc $1+                                                                , snocOL hs t' `appOL` unitOL $3)) }+          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                                   ,snd $ unLoc $1))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl $2)+                                                  return (sLL $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t')) }+          | decl_cls                    { sL1A $1 ([], unitOL $1) }+          | {- empty -}                 { noLoc ([],nilOL) }++decllist_cls+        :: { Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)+                     , LayoutInfo) }      -- Reversed+        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)+                                             ,snd $ unLoc $2, ExplicitBraces) }+        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }+                                           in L l (anns, decls, VirtualBraces (getVOCURLY $1)) }++-- Class body+--+where_cls :: { Located ([AddEpAnn]+                       ,(OrdList (LHsDecl GhcPs))    -- Reversed+                       ,LayoutInfo) }+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)+                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }+        | {- empty -}                   { noLoc ([],nilOL,NoLayoutInfo) }++-- Declarations in instance bodies+--+decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }+decl_inst  : at_decl_inst               { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }+           | decl                       { sL1A $1 (unitOL $1) }++decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed+           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                    , unLoc $3))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl $2)+                                                  return (sLL $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t' `appOL` unLoc $3)) }+           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                                   ,snd $ unLoc $1))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl $2)+                                                  return (sLL $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t')) }+           | decl_inst                  { sL1 $1 ([],unLoc $1) }+           | {- empty -}                { noLoc ([],nilOL) }++decllist_inst+        :: { Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)) }      -- Reversed+        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }+        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }++-- Instance body+--+where_inst :: { Located ([AddEpAnn]+                        , OrdList (LHsDecl GhcPs)) }   -- Reversed+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                                             ,(snd $ unLoc $2)) }+        | {- empty -}                   { noLoc ([],nilOL) }++-- Declarations in binding groups other than classes and instances+--+decls   :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }+        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)+                                 then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (msemi $2)+                                                        , unitOL $3))+                                 else case (snd $ unLoc $1) of+                                   SnocOL hs t -> do+                                      t' <- addTrailingSemiA t (gl $2)+                                      let { this = unitOL $3;+                                            rest = snocOL hs t';+                                            these = rest `appOL` this }+                                      return (rest `seq` this `seq` these `seq`+                                                 (sLLlA $1 $> (fst $ unLoc $1, these))) }+        | decls ';'          {% if isNilOL (snd $ unLoc $1)+                                  then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemi $2)+                                                          ,snd $ unLoc $1)))+                                  else case (snd $ unLoc $1) of+                                    SnocOL hs t -> do+                                       t' <- addTrailingSemiA t (gl $2)+                                       return (sLL $1 $> (fst $ unLoc $1+                                                      , snocOL hs t')) }+        | decl                          { sL1A $1 ([], unitOL $1) }+        | {- empty -}                   { noLoc ([],nilOL) }++decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }+        : '{'            decls '}'     { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)+                                                   ,sL1 $2 $ snd $ unLoc $2) }+        |     vocurly    decls close   { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)+                                                   ,sL1 $2 $ snd $ unLoc $2) }++-- Binding groups other than those of class and instance declarations+--+binds   ::  { Located (HsLocalBinds GhcPs) }+                                         -- May have implicit parameters+                                                -- No type declarations+        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)+                                  ; cs <- getCommentsFor (gl $1)+                                  ; return (sL1 $1 $ HsValBinds (EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }++        | '{'            dbinds '}'     {% acs (\cs -> (L (comb3 $1 $2 $3)+                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }++        |     vocurly    dbinds close   {% acs (\cs -> (L (gl $2)+                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }+++wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }+                                                -- May have implicit parameters+                                                -- No type declarations+        : 'where' binds                 {% do { r <- acs (\cs ->+                                                (sLL $1 $> (annBinds (mj AnnWhere $1) cs (unLoc $2))))+                                              ; return $ Just r} }+        | {- empty -}                   { Nothing }++-----------------------------------------------------------------------------+-- Transformation Rules++rules   :: { [LRuleDecl GhcPs] } -- Reversed+        :  rules ';' rule              {% case $1 of+                                            [] -> return ($3:$1)+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl $2)+                                              return ($3:h':t) }+        |  rules ';'                   {% case $1 of+                                            [] -> return $1+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl $2)+                                              return (h':t) }+        |  rule                        { [$1] }+        |  {- empty -}                 { [] }++rule    :: { LRuleDecl GhcPs }+        : STRING rule_activation rule_foralls infixexp '=' exp+         {%runPV (unECP $4) >>= \ $4 ->+           runPV (unECP $6) >>= \ $6 ->+           acsA (\cs -> (sLLlA $1 $> $ HsRule+                                   { rd_ext = EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs+                                   , rd_name = L (gl $1) (getSTRINGs $1, getSTRING $1)+                                   , rd_act = (snd $2) `orElse` AlwaysActive+                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3+                                   , rd_lhs = $4, rd_rhs = $6 })) }++-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas+rule_activation :: { ([AddEpAnn],Maybe Activation) }+        -- See Note [%shift: rule_activation -> {- empty -}]+        : {- empty -} %shift                    { ([],Nothing) }+        | rule_explicit_activation              { (fst $1,Just (snd $1)) }++-- This production is used to parse the tilde syntax in pragmas such as+--   * {-# INLINE[~2] ... #-}+--   * {-# SPECIALISE [~ 001] ... #-}+--   * {-# RULES ... [~0] ... g #-}+-- Note that it can be written either+--   without a space [~1]  (the PREFIX_TILDE case), or+--   with    a space [~ 1] (the VARSYM case).+-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+rule_activation_marker :: { [AddEpAnn] }+      : PREFIX_TILDE { [mj AnnTilde $1] }+      | VARSYM  {% if (getVARSYM $1 == fsLit "~")+                   then return [mj AnnTilde $1]+                   else do { addError $ PsError PsErrInvalidRuleActivationMarker [] (getLoc $1)+                           ; return [] } }++rule_explicit_activation :: { ([AddEpAnn]+                              ,Activation) }  -- In brackets+        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }+        | '[' rule_activation_marker INTEGER ']'+                                { ($2++[mos $1,mj AnnVal $3,mcs $4]+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }+        | '[' rule_activation_marker ']'+                                { ($2++[mos $1,mcs $3]+                                  ,NeverActive) }++rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }+        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2+                                                              in hintExplicitForall $1+                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)+                                                              >> return (\anns -> HsRuleAnn+                                                                          (Just (mu AnnForall $1,mj AnnDot $3))+                                                                          (Just (mu AnnForall $4,mj AnnDot $6))+                                                                          anns,+                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }++        -- See Note [%shift: rule_foralls -> 'forall' rule_vars '.']+        | 'forall' rule_vars '.' %shift                    { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,+                                                              Nothing, mkRuleBndrs $2) }+        -- See Note [%shift: rule_foralls -> {- empty -}]+        | {- empty -}            %shift                    { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }++rule_vars :: { [LRuleTyTmVar] }+        : rule_var rule_vars                    { $1 : $2 }+        | {- empty -}                           { [] }++rule_var :: { LRuleTyTmVar }+        : varid                         { sL1N $1 (RuleTyTmVar noAnn $1 Nothing) }+        | '(' varid '::' ctype ')'      {% acs (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }++{- Note [Parsing explicit foralls in Rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We really want the above definition of rule_foralls to be:++  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'+               | 'forall' rule_vars '.'+               | {- empty -}++where rule_vars (term variables) can be named "forall", "family", or "role",+but tv_vars (type variables) cannot be. However, such a definition results+in a reduce/reduce conflict. For example, when parsing:+> {-# RULE "name" forall a ... #-}+before the '...' it is impossible to determine whether we should be in the+first or second case of the above.++This is resolved by using rule_vars (which is more general) for both, and+ensuring that type-level quantified variables do not have the names "forall",+"family", or "role" in the function 'checkRuleTyVarBndrNames' in+GHC.Parser.PostProcess.+Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative+to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.+-}++-----------------------------------------------------------------------------+-- Warnings and deprecations (c.f. rules)++warnings :: { OrdList (LWarnDecl GhcPs) }+        : warnings ';' warning         {% if isNilOL $1+                                           then return ($1 `appOL` $3)+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t' `appOL` $3) }+        | warnings ';'                 {% if isNilOL $1+                                           then return $1+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t') }+        | warning                      { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+warning :: { OrdList (LWarnDecl GhcPs) }+        : namelist strings+                {% fmap unitOL $ acsA (\cs -> sLL $1 $>+                     (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)+                              (WarningTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }++deprecations :: { OrdList (LWarnDecl GhcPs) }+        : deprecations ';' deprecation+                                       {% if isNilOL $1+                                           then return ($1 `appOL` $3)+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t' `appOL` $3) }+        | deprecations ';'             {% if isNilOL $1+                                           then return $1+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t') }+        | deprecation                  { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+deprecation :: { OrdList (LWarnDecl GhcPs) }+        : namelist strings+             {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)+                                          (DeprecatedTxt (noLoc NoSourceText) $ snd $ unLoc $2))) }++strings :: { Located ([AddEpAnn],[Located StringLiteral]) }+    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }+    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }++stringlist :: { Located (OrdList (Located StringLiteral)) }+    : stringlist ',' STRING {% if isNilOL (unLoc $1)+                                then return (sLL $1 $> (unLoc $1 `snocOL`+                                                  (L (gl $3) (getStringLiteral $3))))+                                else case (unLoc $1) of+                                   SnocOL hs t -> do+                                     let { t' = addTrailingCommaS t (glAA $2) }+                                     return (sLL $1 $> (snocOL hs t' `snocOL`+                                                  (L (gl $3) (getStringLiteral $3))))++}+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }+    | {- empty -}           { noLoc nilOL }++-----------------------------------------------------------------------------+-- Annotations+annotation :: { LHsDecl GhcPs }+    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->+                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation+                                            (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs)+                                            (getANN_PRAGs $1)+                                            (ValueAnnProvenance $2) $3)) }++    | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->+                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation+                                            (EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs)+                                            (getANN_PRAGs $1)+                                            (TypeAnnProvenance $3) $4)) }++    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->+                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation+                                                (EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs)+                                                (getANN_PRAGs $1)+                                                 ModuleAnnProvenance $3)) }++-----------------------------------------------------------------------------+-- Foreign import and export declarations++fdecl :: { Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs) }+fdecl : 'import' callconv safety fspec+               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->+                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }+      | 'import' callconv        fspec+               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);+                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}+      | 'export' callconv fspec+               {% mkExport $2 (snd $ unLoc $3) >>= \i ->+                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }++callconv :: { Located CCallConv }+          : 'stdcall'                   { sLL $1 $> StdCallConv }+          | 'ccall'                     { sLL $1 $> CCallConv   }+          | 'capi'                      { sLL $1 $> CApiConv    }+          | 'prim'                      { sLL $1 $> PrimCallConv}+          | 'javascript'                { sLL $1 $> JavaScriptCallConv }++safety :: { Located Safety }+        : 'unsafe'                      { sLL $1 $> PlayRisky }+        | 'safe'                        { sLL $1 $> PlaySafe }+        | 'interruptible'               { sLL $1 $> PlayInterruptible }++fspec :: { Located ([AddEpAnn]+                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }+       : STRING var '::' sigtype        { sLL $1 (reLoc $>) ([mu AnnDcolon $3]+                                             ,(L (getLoc $1)+                                                    (getStringLiteral $1), $2, $4)) }+       |        var '::' sigtype        { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2]+                                             ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }+         -- if the entity string is missing, it defaults to the empty string;+         -- the meaning of an empty entity string depends on the calling+         -- convention++-----------------------------------------------------------------------------+-- Type signatures++opt_sig :: { Maybe (AddEpAnn, LHsType GhcPs) }+        : {- empty -}                   { Nothing }+        | '::' ctype                    { Just (mu AnnDcolon $1, $2) }++opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }+             : {- empty -}              { ([], Nothing) }+             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }++-- Like ktype, but for types that obey the forall-or-nothing rule.+-- See Note [forall-or-nothing rule] in GHC.Hs.Type.+sigktype :: { LHsSigType GhcPs }+        : sigtype              { $1 }+        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $+                                               sLLa  (reLoc $1) (reLoc $>) $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }++-- Like ctype, but for types that obey the forall-or-nothing rule.+-- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the+-- logic in ctype here, we simply reuse the ctype production and perform+-- surgery on the LHsType it returns to turn it into an LHsSigType.+sigtype :: { LHsSigType GhcPs }+        : ctype                            { hsTypeToHsSigType $1 }++sig_vars :: { Located [LocatedN RdrName] }    -- Returned in reversed order+         : sig_vars ',' var           {% case unLoc $1 of+                                           [] -> return (sLL $1 (reLocN $>) ($3 : unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingCommaN h (gl $2)+                                             return (sLL $1 (reLocN $>) ($3 : h' : t)) }+         | var                        { sL1N $1 [$1] }++sigtypes1 :: { OrdList (LHsSigType GhcPs) }+   : sigtype                 { unitOL $1 }+   | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (gl $2)+                                   ; return $ unitOL st `appOL` $3 } }+-----------------------------------------------------------------------------+-- Types++unpackedness :: { Located UnpackednessPragma }+        : '{-# UNPACK' '#-}'   { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }+        | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }++forall_telescope :: { Located (HsForAllTelescope GhcPs) }+        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1+                                       ; acs (\cs -> (sLL $1 $> $+                                           mkHsForAllInvisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}+        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1+                                       ; req_tvbs <- fromSpecTyVarBndrs $2+                                       ; acs (\cs -> (sLL $1 $> $+                                           mkHsForAllVisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}++-- A ktype is a ctype, possibly with a kind annotation+ktype :: { LHsType GhcPs }+        : ctype                { $1 }+        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }++-- A ctype is a for-all type+ctype   :: { LHsType GhcPs }+        : forall_telescope ctype      { reLocA $ sLL $1 (reLoc $>) $+                                              HsForAllTy { hst_tele = unLoc $1+                                                         , hst_xforall = noExtField+                                                         , hst_body = $2 } }+        | context '=>' ctype          {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $+                                            HsQualTy { hst_ctxt = Just (addTrailingDarrowC $1 $2 cs)+                                                     , hst_xqual = NoExtField+                                                     , hst_body = $3 })) }++        | ipvar '::' type             {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) $1 $3)) }+        | type                        { $1 }++----------------------+-- Notes for 'context'+-- We parse a context as a btype so that we don't get reduce/reduce+-- errors in ctype.  The basic problem is that+--      (Eq a, Ord a)+-- looks so much like a tuple type.  We can't tell until we find the =>++context :: { LHsContext GhcPs }+        :  btype                        {% checkContext $1 }++{- Note [GADT decl discards annotations]+~~~~~~~~~~~~~~~~~~~~~+The type production for++    btype `->` ctype++add the AnnRarrow annotation twice, in different places.++This is because if the type is processed as usual, it belongs on the annotations+for the type as a whole.++But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and+the top-level annotation will be disconnected. Hence for this specific case it+is connected to the first type too.+-}++type :: { LHsType GhcPs }+        -- See Note [%shift: type -> btype]+        : btype %shift                 { $1 }+        | btype '->' ctype             {% acsA (\cs -> sLL (reLoc $1) (reLoc $>)+                                            $ HsFunTy (EpAnn (glAR $1) (mau $2) cs) (HsUnrestrictedArrow (toUnicode $2)) $1 $3) }++        | btype mult '->' ctype        {% hintLinear (getLoc $2)+                                       >> let arr = (unLoc $2) (toUnicode $3)+                                          in acsA (\cs -> sLL (reLoc $1) (reLoc $>)+                                           $ HsFunTy (EpAnn (glAR $1) (mau $3) cs) arr $1 $4) }++        | btype '->.' ctype            {% hintLinear (getLoc $2) >>+                                          acsA (\cs -> sLL (reLoc $1) (reLoc $>)+                                            $ HsFunTy (EpAnn (glAR $1) (mlu $2) cs) (HsLinearArrow UnicodeSyntax Nothing) $1 $3) }+                                              -- [mu AnnLollyU $2] }++mult :: { Located (IsUnicodeSyntax -> HsArrow GhcPs) }+        : PREFIX_PERCENT atype          { sLL $1 (reLoc $>) (\u -> mkMultTy u $1 $2) }++btype :: { LHsType GhcPs }+        : infixtype                     {% runPV $1 }++infixtype :: { forall b. DisambTD b => PV (LocatedA b) }+        -- See Note [%shift: infixtype -> ftype]+        : ftype %shift                  { $1 }+        | ftype tyop infixtype          { $1 >>= \ $1 ->+                                          $3 >>= \ $3 ->+                                          do { when (looksLikeMult $1 $2 $3) $ hintLinear (getLocA $2)+                                             ; mkHsOpTyPV $1 $2 $3 } }+        | unpackedness infixtype        { $2 >>= \ $2 ->+                                          mkUnpackednessPV $1 $2 }++ftype :: { forall b. DisambTD b => PV (LocatedA b) }+        : atype                         { mkHsAppTyHeadPV $1 }+        | tyop                          { failOpFewArgs $1 }+        | ftype tyarg                   { $1 >>= \ $1 ->+                                          mkHsAppTyPV $1 $2 }+        | ftype PREFIX_AT atype         { $1 >>= \ $1 ->+                                          mkHsAppKindTyPV $1 (getLoc $2) $3 }++tyarg :: { LHsType GhcPs }+        : atype                         { $1 }+        | unpackedness atype            {% addUnpackednessP $1 $2 }++tyop :: { LocatedN RdrName }+        : qtyconop                      { $1 }+        | tyvarop                       { $1 }+        | SIMPLEQUOTE qconop            {% amsrn (sLL $1 (reLoc $>) (unLoc $2))+                                                 (NameAnnQuote (glAA $1) (gl $2) []) }+        | SIMPLEQUOTE varop             {% amsrn (sLL $1 (reLoc $>) (unLoc $2))+                                                 (NameAnnQuote (glAA $1) (gl $2) []) }++atype :: { LHsType GhcPs }+        : ntgtycon                       {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- Not including unit tuples+        -- See Note [%shift: atype -> tyvar]+        | tyvar %shift                   {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- (See Note [Unit tuples])+        | '*'                            {% do { warnStarIsType (getLoc $1)+                                               ; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | PREFIX_TILDE atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }+        | PREFIX_BANG  atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }++        | '{' fielddecls '}'             {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))+                                               ; checkRecordSyntax decls }}+                                                        -- Constructor sigs only+        | '(' ')'                        {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)+                                                    HsBoxedOrConstraintTuple []) }+        | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)+                                               ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)+                                                        HsBoxedOrConstraintTuple (h : $4)) }}+        | '(#' '#)'                   {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }+        | '(#' comma_types1 '#)'      {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }+        | '(#' bar_types2 '#)'        {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }+        | '[' ktype ']'               {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }+        | '(' ktype ')'               {% acsA (\cs -> sLL $1 $> $ HsParTy  (EpAnn (glR $1) (AnnParen AnnParens       (glAA $1) (glAA $3)) cs) $2) }+        | quasiquote                  { mapLocA (HsSpliceTy noExtField) $1 }+        | splice_untyped              { mapLocA (HsSpliceTy noExtField) $1 }+                                      -- see Note [Promotion] for the followings+        | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }+        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'+                             {% do { h <- addTrailingCommaA $3 (gl $4)+                                   ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }+        | SIMPLEQUOTE var                       {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }++        -- Two or more [ty, ty, ty] must be a promoted list type, just as+        -- if you had written '[ty, ty, ty]+        -- (One means a list type, zero means the list type constructor,+        -- so you have to quote those.)+        | '[' ktype ',' comma_types1 ']'  {% do { h <- addTrailingCommaA $2 (gl $3)+                                                ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}+        | INTEGER              { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)+                                                           (il_value (getINTEGER $1)) }+        | CHAR                 { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)+                                                                        (getCHAR $1) }+        | STRING               { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)+                                                                     (getSTRING  $1) }+        | '_'                  { reLocA $ sL1 $1 $ mkAnonWildCardTy }++-- An inst_type is what occurs in the head of an instance decl+--      e.g.  (Foo a, Gaz b) => Wibble a b+-- It's kept as a single type for convenience.+inst_type :: { LHsSigType GhcPs }+        : sigtype                       { $1 }++deriv_types :: { [LHsSigType GhcPs] }+        : sigktype                      { [$1] }++        | sigktype ',' deriv_types      {% do { h <- addTrailingCommaA $1 (gl $2)+                                           ; return (h : $3) } }++comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty+        : comma_types1                  { $1 }+        | {- empty -}                   { [] }++comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty+        : ktype                        { [$1] }+        | ktype  ',' comma_types1      {% do { h <- addTrailingCommaA $1 (gl $2)+                                             ; return (h : $3) }}++bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty+        : ktype  '|' ktype             {% do { h <- addTrailingVbarA $1 (gl $2)+                                             ; return [h,$3] }}+        | ktype  '|' bar_types2        {% do { h <- addTrailingVbarA $1 (gl $2)+                                             ; return (h : $3) }}++tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }+         : tv_bndr tv_bndrs             { $1 : $2 }+         | {- empty -}                  { [] }++tv_bndr :: { LHsTyVarBndr Specificity GhcPs }+        : tv_bndr_no_braces             { $1 }+        | '{' tyvar '}'                 {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [moc $1, mcc $3] cs) InferredSpec $2)) }+        | '{' tyvar '::' kind '}'       {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }++tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }+        : tyvar                         {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }+        | '(' tyvar '::' kind ')'       {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }++fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }+        : {- empty -}                   { noLoc ([],[]) }+        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]+                                                 ,reverse (unLoc $2))) }++fds1 :: { Located [LHsFunDep GhcPs] }+        : fds1 ',' fd   {%+                           do { let (h:t) = unLoc $1 -- Safe from fds1 rules+                              ; h' <- addTrailingCommaA h (gl $2)+                              ; return (sLLlA $1 $> ($3 : h' : t)) }}+        | fd            { sL1A $1 [$1] }++fd :: { LHsFunDep GhcPs }+        : varids0 '->' varids0  {% acsA (\cs -> L (comb3 $1 $2 $3)+                                       (FunDep (EpAnn (glR $1) [mu AnnRarrow $2] cs)+                                               (reverse (unLoc $1))+                                               (reverse (unLoc $3)))) }++varids0 :: { Located [LocatedN RdrName] }+        : {- empty -}                   { noLoc [] }+        | varids0 tyvar                 { sLL $1 (reLocN $>) ($2 : (unLoc $1)) }++-----------------------------------------------------------------------------+-- Kinds++kind :: { LHsKind GhcPs }+        : ctype                  { $1 }++{- Note [Promotion]+   ~~~~~~~~~~~~~~~~++- Syntax of promoted qualified names+We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified+names. Moreover ticks are only allowed in types, not in kinds, for a+few reasons:+  1. we don't need quotes since we cannot define names in kinds+  2. if one day we merge types and kinds, tick would mean look in DataName+  3. we don't have a kind namespace anyway++- Name resolution+When the user write Zero instead of 'Zero in types, we parse it a+HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We+deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not+bounded in the type level, then we look for it in the term level (we+change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).+And both become a HsTyVar ("Zero", DataName) after the renamer.++-}+++-----------------------------------------------------------------------------+-- Datatype declarations++gadt_constrlist :: { Located ([AddEpAnn]+                          ,[LConDecl GhcPs]) } -- Returned in order++        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $+                                                      L (comb2 $1 $3)+                                                        ([mj AnnWhere $1+                                                         ,moc $2+                                                         ,mcc $4]+                                                        , unLoc $3) }+        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $+                                                      L (comb2 $1 $3)+                                                        ([mj AnnWhere $1]+                                                        , unLoc $3) }+        | {- empty -}                            { noLoc ([],[]) }++gadt_constrs :: { Located [LConDecl GhcPs] }+        : gadt_constr ';' gadt_constrs+                  {% do { h <- addTrailingSemiA $1 (gl $2)+                        ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }}+        | gadt_constr                   { L (glA $1) [$1] }+        | {- empty -}                   { noLoc [] }++-- We allow the following forms:+--      C :: Eq a => a -> T a+--      C :: forall a. Eq a => !a -> T a+--      D { x,y :: a } :: T a+--      forall a. Eq a => D { x,y :: a } :: T a++gadt_constr :: { LConDecl GhcPs }+    -- see Note [Difference in parsing GADT and data constructors]+    -- Returns a list because of:   C,D :: ty+    -- TODO:AZ capture the optSemi. Why leading?+        : optSemi con_list '::' sigtype+                {% mkGadtDecl (comb2A $2 $>) (unLoc $2) $4 [mu AnnDcolon $3] }++{- Note [Difference in parsing GADT and data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GADT constructors have simpler syntax than usual data constructors:+in GADTs, types cannot occur to the left of '::', so they cannot be mixed+with constructor names (see Note [Parsing data constructors is hard]).++Due to simplified syntax, GADT constructor names (left-hand side of '::')+use simpler grammar production than usual data constructor names. As a+consequence, GADT constructor names are restricted (names like '(*)' are+allowed in usual data constructors, but not in GADTs).+-}++constrs :: { Located ([AddEpAnn],[LConDecl GhcPs]) }+        : '=' constrs1    { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}++constrs1 :: { Located [LConDecl GhcPs] }+        : constrs1 '|' constr+            {% do { let (h:t) = unLoc $1+                  ; h' <- addTrailingVbarA h (gl $2)+                  ; return (sLLlA $1 $> ($3 : h' : t)) }}+        | constr                         { sL1A $1 [$1] }++constr :: { LConDecl GhcPs }+        : forall context '=>' constr_stuff+                {% acsA (\cs -> let (con,details) = unLoc $4 in+                  (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98+                                                       (EpAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4))+                                                                    (mu AnnDarrow $3:(fst $ unLoc $1)) cs)+                                                       con+                                                       (snd $ unLoc $1)+                                                       (Just $2)+                                                       details))) }+        | forall constr_stuff+                {% acsA (\cs -> let (con,details) = unLoc $2 in+                  (L (comb2 $1 $2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs)+                                                      con+                                                      (snd $ unLoc $1)+                                                      Nothing   -- No context+                                                      details))) }++forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }+        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }+        | {- empty -}                 { noLoc ([], Nothing) }++constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }+        : infixtype       {% fmap (reLoc. (mapLoc (\b -> (dataConBuilderCon b,+                                                          dataConBuilderDetails b))))+                                     (runPV $1) }++fielddecls :: { [LConDeclField GhcPs] }+        : {- empty -}     { [] }+        | fielddecls1     { $1 }++fielddecls1 :: { [LConDeclField GhcPs] }+        : fielddecl ',' fielddecls1+            {% do { h <- addTrailingCommaA $1 (gl $2)+                  ; return (h : $3) }}+        | fielddecl   { [$1] }++fielddecl :: { LConDeclField GhcPs }+                                              -- A list because of   f,g :: Int+        : sig_vars '::' ctype+            {% acsA (\cs -> L (comb2 $1 (reLoc $3))+                      (ConDeclField (EpAnn (glR $1) [mu AnnDcolon $2] cs)+                                    (reverse (map (\ln@(L l n) -> L (locA l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}++-- Reversed!+maybe_derivings :: { Located (HsDeriving GhcPs) }+        : {- empty -}             { noLoc [] }+        | derivings               { $1 }++-- A list of one or more deriving clauses at the end of a datatype+derivings :: { Located (HsDeriving GhcPs) }+        : derivings deriving      { sLL $1 $> ($2 : unLoc $1) } -- AZ: order?+        | deriving                { sLL $1 $> [$1] }++-- The outer Located is just to allow the caller to+-- know the rightmost extremity of the 'deriving' clause+deriving :: { LHsDerivingClause GhcPs }+        : 'deriving' deriv_clause_types+              {% let { full_loc = comb2A $1 $> }+                 in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }++        | 'deriving' deriv_strategy_no_via deriv_clause_types+              {% let { full_loc = comb2A $1 $> }+                 in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }++        | 'deriving' deriv_clause_types deriv_strategy_via+              {% let { full_loc = comb2 $1 $> }+                 in acs (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }++deriv_clause_types :: { LDerivClauseTys GhcPs }+        : qtycon              { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $+                                           sL1 (reLocL $1) $ HsTyVar noAnn NotPromoted $1 } in+                                sL1 (reLocC $1) (DctSingle noExtField tc) }+        | '(' ')'             {% amsrc (sLL $1 $> (DctMulti noExtField []))+                                       (AnnContext Nothing [glAA $1] [glAA $2]) }+        | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2))+                                       (AnnContext Nothing [glAA $1] [glAA $3])}++-----------------------------------------------------------------------------+-- Value definitions++{- Note [Declaration/signature overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's an awkward overlap with a type signature.  Consider+        f :: Int -> Int = ...rhs...+   Then we can't tell whether it's a type signature or a value+   definition with a result signature until we see the '='.+   So we have to inline enough to postpone reductions until we know.+-}++{-+  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+  instead of qvar, we get another shift/reduce-conflict. Consider the+  following programs:++     { (^^) :: Int->Int ; }          Type signature; only var allowed++     { (^^) :: Int->Int = ... ; }    Value defn with result signature;+                                     qvar allowed (because of instance decls)++  We can't tell whether to reduce var to qvar until after we've read the signatures.+-}++decl_no_th :: { LHsDecl GhcPs }+        : sigdecl               { $1 }++        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->+                                       do { let { l = comb2Al $1 $> }+                                          ; r <- checkValDef l $1 $2 $3;+                                        -- Depending upon what the pattern looks like we might get either+                                        -- a FunBind or PatBind back from checkValDef. See Note+                                        -- [FunBind vs PatBind]+                                          ; cs <- getCommentsFor l+                                          ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }+        | pattern_synonym_decl  { $1 }++decl    :: { LHsDecl GhcPs }+        : decl_no_th            { $1 }++        -- Why do we only allow naked declaration splices in top-level+        -- declarations and not here? Short answer: because readFail009+        -- fails terribly with a panic in cvBindsAndSigs otherwise.+        | splice_exp            {% mkSpliceDecl $1 }++rhs     :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }+        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 ->+                                  do { let L l (bs, csw) = adaptWhereBinds $3+                                     ; let loc = (comb3 $1 (reLoc $2) (L l bs))+                                     ; acs (\cs ->+                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)+                                                      bs)) } }+        | gdrhs wherebinds      {% do { let {L l (bs, csw) = adaptWhereBinds $2}+                                      ; acs (\cs -> sL (comb2 $1 (L l bs))+                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}++gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }+        : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }+        | gdrh                  { sL1 $1 [$1] }++gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }+        : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->+                                     acs (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }++sigdecl :: { LHsDecl GhcPs }+        :+        -- See Note [Declaration/signature overlap] for why we need infixexp here+          infixexp     '::' sigtype+                        {% do { $1 <- runPV (unECP $1)+                              ; v <- checkValSigLhs $1+                              ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $+                                  TypeSig (EpAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }++        | var ',' sig_vars '::' sigtype+           {% do { v <- addTrailingCommaN $1 (gl $2)+                 ; let sig cs = TypeSig (EpAnn (glNR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3))+                                      (mkHsWildCardBndrs $5)+                 ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }}++        | infix prec ops+              {% checkPrecP $2 $3 >>+                 acsA (\cs -> sLL $1 $> $ SigD noExtField+                        (FixSig (EpAnn (glR $1) [mj AnnInfix $1,mj AnnVal $2] cs) (FixitySig noExtField (fromOL $ unLoc $3)+                                (Fixity (fst $ unLoc $2) (snd $ unLoc $2) (unLoc $1))))) }++        | pattern_synonym_sig   { sL1 $1 . SigD noExtField . unLoc $ $1 }++        | '{-# COMPLETE' con_list opt_tyconsig  '#-}'+                {% let (dcolon, tc) = $3+                   in acsA+                       (\cs -> sLL $1 $>+                         (SigD noExtField (CompleteMatchSig (EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs) (getCOMPLETE_PRAGs $1) $2 tc))) }++        -- This rule is for both INLINE and INLINABLE pragmas+        | '{-# INLINE' activation qvarcon '#-}'+                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3+                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)+                                            (snd $2))))) }++        | '{-# SCC' qvar '#-}'+          {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $3] cs) (getSCC_PRAGs $1) $2 Nothing))) }++        | '{-# SCC' qvar STRING '#-}'+          {% do { scc <- getSCC $3+                ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing+                ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig (EpAnn (glR $1) [mo $1, mc $4] cs) (getSCC_PRAGs $1) $2 (Just ( sL1 $3 str_lit))))) }}++        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'+             {% acsA (\cs ->+                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)+                                             (NoUserInlinePrag, FunLike) (snd $2)+                  in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }++        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'+             {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)+                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)+                                               (getSPEC_INLINE $1) (snd $2)))) }++        | '{-# SPECIALISE' 'instance' inst_type '#-}'+                {% acsA (\cs -> sLL $1 $>+                                  $ SigD noExtField (SpecInstSig (EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs) (getSPEC_PRAGs $1) $3)) }++        -- A minimal complete definition+        | '{-# MINIMAL' name_boolformula_opt '#-}'+            {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig (EpAnn (glR $1) [mo $1,mc $3] cs) (getMINIMAL_PRAGs $1) $2)) }++activation :: { ([AddEpAnn],Maybe Activation) }+        -- See Note [%shift: activation -> {- empty -}]+        : {- empty -} %shift                    { ([],Nothing) }+        | explicit_activation                   { (fst $1,Just (snd $1)) }++explicit_activation :: { ([AddEpAnn],Activation) }  -- In brackets+        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }+        | '[' rule_activation_marker INTEGER ']'+                                { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }++-----------------------------------------------------------------------------+-- Expressions++quasiquote :: { Located (HsSplice GhcPs) }+        : TH_QUASIQUOTE   { let { loc = getLoc $1+                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1+                                ; quoterId = mkUnqual varName quoter }+                            in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }+        | TH_QQUASIQUOTE  { let { loc = getLoc $1+                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1+                                ; quoterId = mkQual varName (qual, quoter) }+                            in sL1 $1 (mkHsQuasiQuote quoterId (mkSrcSpanPs quoteSpan) quote) }++exp   :: { ECP }+        : infixexp '::' ctype+                                { ECP $+                                   unECP $1 >>= \ $1 ->+                                   rejectPragmaPV $1 >>+                                   mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3+                                          [(mu AnnDcolon $2)] }+        | infixexp '-<' exp     {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3+                                                        HsFirstOrderApp True) }+        | infixexp '>-' exp     {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1+                                                      HsFirstOrderApp False) }+        | infixexp '-<<' exp    {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3+                                                      HsHigherOrderApp True) }+        | infixexp '>>-' exp    {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1+                                                      HsHigherOrderApp False) }+        -- See Note [%shift: exp -> infixexp]+        | infixexp %shift       { $1 }+        | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]++infixexp :: { ECP }+        : exp10 { $1 }+        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]+                               { ECP $+                                 superInfixOp $+                                 $2 >>= \ $2 ->+                                 unECP $1 >>= \ $1 ->+                                 unECP $3 >>= \ $3 ->+                                 rejectPragmaPV $1 >>+                                 (mkHsOpAppPV (comb2A (reLoc $1) $3) $1 $2 $3) }+                 -- AnnVal annotation for NPlusKPat, which discards the operator++exp10p :: { ECP }+  : exp10            { $1 }+  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]++exp_prag(e) :: { ECP }+  : prag_e e  -- See Note [Pragmas and operator fixity]+      {% runPV (unECP $2) >>= \ $2 ->+         fmap ecpFromExp $+         return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) }++exp10 :: { ECP }+        -- See Note [%shift: exp10 -> '-' fexp]+        : '-' fexp %shift               { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkHsNegAppPV (comb2A $1 $>) $2+                                                 [mj AnnMinus $1] }+        -- See Note [%shift: exp10 -> fexp]+        | fexp %shift                  { $1 }++optSemi :: { (Maybe EpaLocation,Bool) }+        : ';'         { (msemim $1,True) }+        | {- empty -} { (Nothing,False) }++{- Note [Pragmas and operator fixity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'prag_e' is an expression pragma, such as {-# SCC ... #-}.++It must be used with care, or else #15730 happens. Consider this infix+expression:++         1 / 2 / 2++There are two ways to parse it:++    1.   (1 / 2) / 2   =  0.25+    2.   1 / (2 / 2)   =  1.0++Due to the fixity of the (/) operator (assuming it comes from Prelude),+option 1 is the correct parse. However, in the past GHC's parser used to get+confused by the SCC annotation when it occurred in the middle of an infix+expression:++         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2++There are several ways to address this issue, see GHC Proposal #176 for a+detailed exposition:++  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst++The accepted fix is to disallow pragmas that occur within infix expressions.+Infix expressions are assembled out of 'exp10', so 'exp10' must not accept+pragmas. Instead, we accept them in exactly two places:++* at the start of an expression or a parenthesized subexpression:++    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression+    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression++* immediately after the last operator:++    f = 1 / 2 / {-# SCC ann #-} 2++In both cases, the parse does not depend on operator fixity. The second case+may sound unnecessary, but it's actually needed to support a common idiom:++    f $ {-# SCC ann $-} ...++-}+prag_e :: { Located (HsPragE GhcPs) }+      : '{-# SCC' STRING '#-}'      {% do { scc <- getSCC $2+                                          ; acs (\cs -> (sLL $1 $>+                                             (HsPragSCC+                                                (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs)+                                                (getSCC_PRAGs $1)+                                                (StringLiteral (getSTRINGs $2) scc Nothing))))} }+      | '{-# SCC' VARID  '#-}'      {% acs (\cs -> (sLL $1 $>+                                             (HsPragSCC+                                               (EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs)+                                               (getSCC_PRAGs $1)+                                               (StringLiteral NoSourceText (getVARID $2) Nothing)))) }++fexp    :: { ECP }+        : fexp aexp                  { ECP $+                                          superFunArg $+                                          unECP $1 >>= \ $1 ->+                                          unECP $2 >>= \ $2 ->+                                          mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc $1) $>) $1 $2 }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | fexp PREFIX_AT atype       { ECP $+                                        unECP $1 >>= \ $1 ->+                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (getLoc $2) $3 }++        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->+                                        fmap ecpFromExp $+                                        acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (EpAnn (glR $1) [mj AnnStatic $1] cs) $2) }++        | aexp                       { $1 }++aexp    :: { ECP }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : qvar TIGHT_INFIX_AT aexp+                                { ECP $+                                   unECP $3 >>= \ $3 ->+                                     mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 $3 [mj AnnAt $2] }+++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | PREFIX_TILDE aexp     { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsLazyPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnTilde $1] }+        | PREFIX_BANG aexp      { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsBangPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnBang $1] }+        | PREFIX_MINUS aexp     { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }++        | '\\' apat apats '->' exp+                   {  ECP $+                      unECP $5 >>= \ $5 ->+                      mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource+                            (reLocA $ sLLlA $1 $>+                            [reLocA $ sLLlA $1 $>+                                         $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs+                                                 , m_ctxt = LambdaExpr+                                                 , m_pats = $2:$3+                                                 , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (EpAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) emptyComments) }])) }+        | 'let' binds 'in' exp          {  ECP $+                                           unECP $4 >>= \ $4 ->+                                           mkHsLetPV (comb2A $1 $>) (unLoc $2) $4+                                                 (AnnsLet (glAA $1) (glAA $3)) }+        | '\\' 'lcase' altslist+            {  ECP $ $3 >>= \ $3 ->+                 mkHsLamCasePV (comb2 $1 (reLoc $>)) $3 [mj AnnLam $1,mj AnnCase $2] }+        | 'if' exp optSemi 'then' exp optSemi 'else' exp+                         {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->+                            return $ ECP $+                              unECP $5 >>= \ $5 ->+                              unECP $8 >>= \ $8 ->+                              mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8+                                    (AnnsIf+                                      { aiIf = glAA $1+                                      , aiThen = glAA $4+                                      , aiElse = glAA $7+                                      , aiThenSemi = fst $3+                                      , aiElseSemi = fst $6})}++        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->+                                           fmap ecpFromExp $+                                           acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)+                                                     (reverse $ snd $ unLoc $2)) }+        | 'case' exp 'of' altslist    {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->+                                         return $ ECP $+                                           $4 >>= \ $4 ->+                                           mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4+                                                (EpAnnHsCase (glAA $1) (glAA $3) []) }+        -- QualifiedDo.+        | DO  stmtlist               {% do+                                      hintQualifiedDo $1+                                      return $ ECP $+                                        $2 >>= \ $2 ->+                                        mkHsDoPV (comb2A $1 $2)+                                                 (fmap mkModuleNameFS (getDO $1))+                                                 $2+                                                 (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) }+        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->+                                       fmap ecpFromExp $+                                       acsA (\cs -> L (comb2A $1 $2)+                                              (mkHsDoAnns (MDoExpr $+                                                          fmap mkModuleNameFS (getMDO $1))+                                                          $2+                                           (EpAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }+        | 'proc' aexp '->' exp+                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->+                           runPV (unECP $4) >>= \ $4@cmd ->+                           fmap ecpFromExp $+                           acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLlA $1 $> $ HsCmdTop noExtField cmd)) }++        | aexp1                 { $1 }++aexp1   :: { ECP }+        : aexp1 '{' fbinds '}' { ECP $+                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->+                                   unECP $1 >>= \ $1 ->+                                   $3 >>= \ $3 ->+                                   mkHsRecordPV overloaded (comb2 (reLoc $1) $>) (comb2 $2 $4) $1 $3+                                        [moc $2,mcc $4]+                               }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | aexp1 TIGHT_INFIX_PROJ field+            {% runPV (unECP $1) >>= \ $1 ->+               fmap ecpFromExp $ acsa (\cs ->+                 let fl = sLL $2 $> (HsFieldLabel ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in+                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) $>) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }+++        | aexp2                { $1 }++aexp2   :: { ECP }+        : qvar                          { ECP $ mkHsVarPV $! $1 }+        | qcon                          { ECP $ mkHsVarPV $! $1 }+        -- See Note [%shift: aexp2 -> ipvar]+        | ipvar %shift                  {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) }+        | overloaded_label              {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) $! unLoc $1)) }+        | literal                       { ECP $ pvA (mkHsLitPV $! $1) }+-- This will enable overloaded strings permanently.  Normally the renamer turns HsString+-- into HsOverLit when -foverloaded-strings is on.+--      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)+--                                       (getSTRING $1) noExtField) }+        | INTEGER   { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsIntegral   (getINTEGER  $1)) }+        | RATIONAL  { ECP $ pvA $ mkHsOverLitPV (sL1 $1 $ mkHsFractional (getRATIONAL $1)) }++        -- N.B.: sections get parsed by these next two productions.+        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't+        -- correct Haskell (you'd have to write '((+ 3), (4 -))')+        -- but the less cluttered version fell out of having texps.+        | '(' texp ')'                  { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkHsParPV (comb2 $1 $>) $2 (AnnParen AnnParens (glAA $1) (glAA $3)) }+        | '(' tup_exprs ')'             { ECP $+                                           $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2+                                                [mop $1,mcp $3]}++        -- This case is only possible when 'OverloadedRecordDotBit' is enabled.+        | '(' projection ')'            { ECP $+                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))+                                            >>= ecpFromExp'+                                        }++        | '(#' texp '#)'                { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])+                                                 [moh $1,mch $3] }+        | '(#' tup_exprs '#)'           { ECP $+                                           $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2+                                                [moh $1,mch $3] }++        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) }+        | '_'               { ECP $ pvA $ mkHsWildCardPV (getLoc $1) }++        -- Template Haskell Extension+        | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }+        | splice_typed   { ecpFromExp $ mapLoc (HsSpliceE noAnn) (reLocA $1) }++        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }+        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }+        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }+        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }+        -- See Note [%shift: aexp2 -> TH_TY_QUOTE]+        | TH_TY_QUOTE %shift    {% reportEmptyDoubleQuotes (getLoc $1) }+        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->+                                 fmap ecpFromExp $+                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]+                                                                                         else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }+        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->+                                 fmap ecpFromExp $+                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) (TExpBr noExtField $2)) }+        | '[t|' ktype '|]'    {% fmap ecpFromExp $+                                 acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }+        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->+                                      fmap ecpFromExp $+                                      acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }+        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $+                                  acsA (\cs -> sLL $1 $> $ HsBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }+        | quasiquote          { ECP $ pvA $ mkHsSplicePV $1 }++        -- arrow notation extension+        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->+                                      fmap ecpFromCmd $+                                      acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix+                                                           Nothing (reverse $3)) }++projection :: { Located (NonEmpty (Located (HsFieldLabel GhcPs))) }+projection+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer+        : projection TIGHT_INFIX_PROJ field+                             {% acs (\cs -> sLL $1 $> ((sLL $2 $> $ HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }+        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 $> ((sLL $1 $> $ HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }++splice_exp :: { LHsExpr GhcPs }+        : splice_untyped { mapLoc (HsSpliceE noAnn) (reLocA $1) }+        | splice_typed   { mapLoc (HsSpliceE noAnn) (reLocA $1) }++splice_untyped :: { Located (HsSplice GhcPs) }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->+                                   acs (\cs -> sLLlA $1 $> $ mkUntypedSplice (EpAnn (glR $1) [mj AnnDollar $1] cs) DollarSplice $2) }++splice_typed :: { Located (HsSplice GhcPs) }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : PREFIX_DOLLAR_DOLLAR aexp2+                                {% runPV (unECP $2) >>= \ $2 ->+                                   acs (\cs -> sLLlA $1 $> $ mkTypedSplice (EpAnn (glR $1) [mj AnnDollarDollar $1] cs) DollarSplice $2) }++cmdargs :: { [LHsCmdTop GhcPs] }+        : cmdargs acmd                  { $2 : $1 }+        | {- empty -}                   { [] }++acmd    :: { LHsCmdTop GhcPs }+        : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->+                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->+                                   return (sL1A cmd $ HsCmdTop noExtField cmd) }++cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }+        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1+                                                  ,mj AnnCloseC $3],$2) }+        |      vocurly    cvtopdecls0 close    { ([],$2) }++cvtopdecls0 :: { [LHsDecl GhcPs] }+        : topdecls_semi         { cvTopDecls $1 }+        | topdecls              { cvTopDecls $1 }++-----------------------------------------------------------------------------+-- Tuple expressions++-- "texp" is short for tuple expressions:+-- things that can appear unparenthesized as long as they're+-- inside parens or delimited by commas+texp :: { ECP }+        : exp                           { $1 }++        -- Note [Parsing sections]+        -- ~~~~~~~~~~~~~~~~~~~~~~~+        -- We include left and right sections here, which isn't+        -- technically right according to the Haskell standard.+        -- For example (3 +, True) isn't legal.+        -- However, we want to parse bang patterns like+        --      (!x, !y)+        -- and it's convenient to do so here as a section+        -- Then when converting expr to pattern we unravel it again+        -- Meanwhile, the renamer checks that real sections appear+        -- inside parens.+        | infixexp qop+                             {% runPV (unECP $1) >>= \ $1 ->+                                runPV (rejectPragmaPV $1) >>+                                runPV $2 >>= \ $2 ->+                                return $ ecpFromExp $+                                reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }+        | qopm infixexp      { ECP $+                                superInfixOp $+                                unECP $2 >>= \ $2 ->+                                $1 >>= \ $1 ->+                                pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }++       -- View patterns get parenthesized above+        | exp '->' texp   { ECP $+                             unECP $1 >>= \ $1 ->+                             unECP $3 >>= \ $3 ->+                             mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }++-- Always at least one comma or bar.+-- Though this can parse just commas (without any expressions), it won't+-- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]+-- in GHC.Hs.Expr.+tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }+           : texp commas_tup_tail+                           { unECP $1 >>= \ $1 ->+                             $2 >>= \ $2 ->+                             do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]+                                ; return (Tuple (Right t : snd $2)) } }+           | commas tup_tail+                 { $2 >>= \ $2 ->+                   do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (EpaSpan $ rs ll) emptyComments))) (fst $1) }+                      ; return (Tuple (cos ++ $2)) } }++           | texp bars   { unECP $1 >>= \ $1 -> return $+                            (Sum 1  (snd $2 + 1) $1 [] (fst $2)) }++           | bars texp bars0+                { unECP $2 >>= \ $2 -> return $+                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2 (fst $1) (fst $3)) }++-- Always starts with commas; always follows an expr+commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }+commas_tup_tail : commas tup_tail+        { $2 >>= \ $2 ->+          do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (EpaSpan $ rs l) emptyComments))) (tail $ fst $1) }+             ; return ((head $ fst $1, cos ++ $2)) } }++-- Always follows a comma+tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] }+          : texp commas_tup_tail { unECP $1 >>= \ $1 ->+                                   $2 >>= \ $2 ->+                                   do { t <- amsA $1 [AddCommaAnn (EpaSpan $ rs $ fst $2)]+                                      ; return (Right t : snd $2) } }+          | texp                 { unECP $1 >>= \ $1 ->+                                   return [Right $1] }+          -- See Note [%shift: tup_tail -> {- empty -}]+          | {- empty -} %shift   { return [Left noAnn] }++-----------------------------------------------------------------------------+-- List expressions++-- The rules below are little bit contorted to keep lexps left-recursive while+-- avoiding another shift/reduce-conflict.+-- Never empty.+list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b) }+        : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->+                            mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) }+        | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->+                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) }+        | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->+                                  acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1))+                                      >>= ecpFromExp' }+        | texp ',' exp '..' { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3))+                                       >>= ecpFromExp' }+        | texp '..' exp  { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3))+                                       >>= ecpFromExp' }+        | texp ',' exp '..' exp { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   unECP $5 >>= \ $5 ->+                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5))+                                       >>= ecpFromExp' }+        | texp '|' flattenedpquals+             { \loc (ao,ac) ->+                checkMonadComp >>= \ ctxt ->+                unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2)+                ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs))+                    >>= ecpFromExp' } }++lexps :: { forall b. DisambECP b => PV [LocatedA b] }+        : lexps ',' texp           { $1 >>= \ $1 ->+                                     unECP $3 >>= \ $3 ->+                                     case $1 of+                                       (h:t) -> do+                                         h' <- addTrailingCommaA h (gl $2)+                                         return (((:) $! $3) $! (h':t)) }+        | texp ',' texp             { unECP $1 >>= \ $1 ->+                                      unECP $3 >>= \ $3 ->+                                      do { h <- addTrailingCommaA $1 (gl $2)+                                         ; return [$3,h] }}++-----------------------------------------------------------------------------+-- List Comprehensions++flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : pquals   { case (unLoc $1) of+                    [qs] -> sL1 $1 qs+                    -- We just had one thing in our "parallel" list so+                    -- we simply return that thing directly++                    qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |+                                            qs <- qss]+                                            noExpr noSyntaxExpr]+                    -- We actually found some actual parallel lists so+                    -- we wrap them into as a ParStmt+                }++pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }+    : squals '|' pquals+                     {% case unLoc $1 of+                          (h:t) -> do+                            h' <- addTrailingVbarA h (gl $2)+                            return (sLL $1 $> (reverse (h':t) : unLoc $3)) }+    | squals         { L (getLoc $1) [reverse (unLoc $1)] }++squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last+                                        -- one can "grab" the earlier ones+    : squals ',' transformqual+             {% case unLoc $1 of+                  (h:t) -> do+                    h' <- addTrailingCommaA h (gl $2)+                    return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) }+    | squals ',' qual+             {% runPV $3 >>= \ $3 ->+                case unLoc $1 of+                  (h:t) -> do+                    h' <- addTrailingCommaA h (gl $2)+                    return (sLL $1 (reLoc $>) ($3 : (h':t))) }+    | transformqual        {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) }+    | qual                               {% runPV $1 >>= \ $1 ->+                                            return $ sL1A $1 [$1] }+--  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }+--  | '{|' pquals '|}'                       { sL1 $1 [$2] }++-- It is possible to enable bracketing (associating) qualifier lists+-- by uncommenting the lines with {| |} above. Due to a lack of+-- consensus on the syntax, this feature is not being used until we+-- get user demand.++transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }+                        -- Function is applied to a list of stmts *in order*+    : 'then' exp              {% runPV (unECP $2) >>= \ $2 ->+                                 acs (\cs->+                                 sLLlA $1 $> (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen $1] cs) ss $2))) }+    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->+                                 runPV (unECP $4) >>= \ $4 ->+                                 acs (\cs -> sLLlA $1 $> (+                                                     \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) }+    | 'then' 'group' 'using' exp+            {% runPV (unECP $4) >>= \ $4 ->+               acs (\cs -> sLLlA $1 $> (+                                   \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) }++    | 'then' 'group' 'by' exp 'using' exp+            {% runPV (unECP $4) >>= \ $4 ->+               runPV (unECP $6) >>= \ $6 ->+               acs (\cs -> sLLlA $1 $> (+                                   \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) }++-- Note that 'group' is a special_id, which means that you can enable+-- TransformListComp while still using Data.List.group. However, this+-- introduces a shift/reduce conflict. Happy chooses to resolve the conflict+-- in by choosing the "group by" variant, which is what we want.++-----------------------------------------------------------------------------+-- Guards++guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }++guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->+                               case unLoc $1 of+                                 (h:t) -> do+                                   h' <- addTrailingCommaA h (gl $2)+                                   return (sLL $1 (reLoc $>) ($3 : (h':t))) }+    | qual                  {% runPV $1 >>= \ $1 ->+                               return $ sL1A $1 [$1] }++-----------------------------------------------------------------------------+-- Case alternatives++altslist :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }+        : '{'            alts '}'  { $2 >>= \ $2 -> amsrl+                                     (sLL $1 $> (reverse (snd $ unLoc $2)))+                                               (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }+        |     vocurly    alts  close { $2 >>= \ $2 -> amsrl+                                       (L (getLoc $2) (reverse (snd $ unLoc $2)))+                                        (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }+        | '{'                 '}'    { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }+        |     vocurly          close { return $ noLocA [] }++alts    :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }+        : alts1                    { $1 >>= \ $1 -> return $+                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+        | ';' alts                 { $2 >>= \ $2 -> return $+                                     sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) )+                                               ,snd $ unLoc $2) }++alts1   :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }+        : alts1 ';' alt         { $1 >>= \ $1 ->+                                  $3 >>= \ $3 ->+                                     case snd $ unLoc $1 of+                                       [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                       ,[$3]))+                                       (h:t) -> do+                                         h' <- addTrailingSemiA h (gl $2)+                                         return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }+        | alts1 ';'             {  $1 >>= \ $1 ->+                                     case snd $ unLoc $1 of+                                       [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                       ,[]))+                                       (h:t) -> do+                                         h' <- addTrailingSemiA h (gl $2)+                                         return (sLL $1 $> (fst $ unLoc $1, h' : t)) }+        | alt                   { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }++alt     :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }+           : pat alt_rhs  { $2 >>= \ $2 ->+                            acsA (\cs -> sLL (reLoc $1) $>+                                           (Match { m_ext = (EpAnn (glAR $1) [] cs)+                                                  , m_ctxt = CaseAlt+                                                  , m_pats = [$1]+                                                  , m_grhss = unLoc $2 }))}++alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }+        : ralt wherebinds           { $1 >>= \alt ->+                                      do { let {L l (bs, csw) = adaptWhereBinds $2}+                                         ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }}++ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }+        : '->' exp            { unECP $2 >>= \ $2 ->+                                acs (\cs -> sLLlA $1 $> (unguardedRHS (EpAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }+        | gdpats              { $1 >>= \gdpats ->+                                return $ sL1 gdpats (reverse (unLoc gdpats)) }++gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }+        : gdpats gdpat { $1 >>= \gdpats ->+                         $2 >>= \gdpat ->+                         return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }+        | gdpat        { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }++-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to+-- generate the open brace in addition to the vertical bar in the lexer, and+-- we don't need it.+ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }+         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->+                                             return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }+         |     gdpats close               {% runPV $1 >>= \ $1 ->+                                             return $ sL1 $1 ([],unLoc $1) }++gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }+        : '|' guardquals '->' exp+                                   { unECP $4 >>= \ $4 ->+                                     acs (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }++-- 'pat' recognises a pattern, including one with a bang at the top+--      e.g.  "!x" or "!(x,y)" or "C a b" etc+-- Bangs inside are parsed as infix operator applications, so that+-- we parse them right when bang-patterns are off+pat     :: { LPat GhcPs }+pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }++bindpat :: { LPat GhcPs }+bindpat :  exp            {% -- See Note [Parser-Validator Hint] in GHC.Parser.PostProcess+                             checkPattern_hints [SuggestMissingDo]+                                              (unECP $1) }++apat   :: { LPat GhcPs }+apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }++apats  :: { [LPat GhcPs] }+        : apat apats            { $1 : $2 }+        | {- empty -}           { [] }++-----------------------------------------------------------------------------+-- Statement sequences++stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }+        : '{'           stmts '}'       { $2 >>= \ $2 -> amsrl+                                          (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }+        |     vocurly   stmts close     { $2 >>= \ $2 -> amsrl+                                          (L (gl $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ glR $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }++--      do { ;; s ; s ; ; s ;; }+-- The last Stmt should be an expression, but that's hard to enforce+-- here, because we need too much lookahead if we see do { e ; }+-- So we use BodyStmts throughout, and switch the last one over+-- in ParseUtils.checkDo instead++stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])) }+        : stmts ';' stmt  { $1 >>= \ $1 ->+                            $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->+                            case (snd $ unLoc $1) of+                              [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2)+                                                     ,$3   : (snd $ unLoc $1)))+                              (h:t) -> do+                               { h' <- addTrailingSemiA h (gl $2)+                               ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }}++        | stmts ';'     {  $1 >>= \ $1 ->+                           case (snd $ unLoc $1) of+                             [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))+                             (h:t) -> do+                               { h' <- addTrailingSemiA h (gl $2)+                               ; return $ sL1 $1 (fst $ unLoc $1,h':t) }}+        | stmt                   { $1 >>= \ $1 ->+                                   return $ sL1A $1 (nilOL,[$1]) }+        | {- empty -}            { return $ noLoc (nilOL,[]) }+++-- For typing stmts at the GHCi prompt, where+-- the input may consist of just comments.+maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }+        : stmt                          {% fmap Just (runPV $1) }+        | {- nothing -}                 { Nothing }++-- For GHC API.+e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }+        : stmt                          {% runPV $1 }++stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }+        : qual                          { $1 }+        | 'rec' stmtlist                {  $2 >>= \ $2 ->+                                           acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt+                                                 (EpAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)+                                                  $2)) }++qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }+    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->+                                           acsA (\cs -> sLLlA (reLoc $1) $>+                                            $ mkPsBindStmt (EpAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) }+    | exp                                { unECP $1 >>= \ $1 ->+                                           return $ sL1 $1 $ mkBodyStmt $1 }+    | 'let' binds                        { acsA (\cs -> (sLL $1 $>+                                                $ mkLetStmt (EpAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) }++-----------------------------------------------------------------------------+-- Record Field Update/Construction++fbinds  :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }+        : fbinds1                       { $1 }+        | {- empty -}                   { return ([], Nothing) }++fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }+        : fbind ',' fbinds1+                 { $1 >>= \ $1 ->+                   $3 >>= \ $3 -> do+                   h <- addTrailingCommaFBind $1 (gl $2)+                   return (case $3 of (flds, dd) -> (h : flds, dd)) }+        | fbind                         { $1 >>= \ $1 ->+                                          return ([$1], Nothing) }+        | '..'                          { return ([],   Just (getLoc $1)) }++fbind   :: { forall b. DisambECP b => PV (Fbind b) }+        : qvar '=' texp  { unECP $3 >>= \ $3 ->+                           fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsRecField (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1N $1 $ mkFieldOcc $1) $3 False) }+                        -- RHS is a 'texp', allowing view patterns (#6038)+                        -- and, incidentally, sections.  Eg+                        -- f (R { x = show -> s }) = ...++        | qvar          { placeHolderPunRhs >>= \rhs ->+                          fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsRecField (EpAnn (glNR $1) [] cs) (sL1N $1 $ mkFieldOcc $1) rhs True) }+                        -- In the punning case, use a place-holder+                        -- The renamer fills in the final value++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        -- AZ: need to pull out the let block into a helper+        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp+                        { do+                            let top = sL1 $1 $ HsFieldLabel noAnn $1+                                ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)+                                lf' = comb2 $2 (L lf ())+                                fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t+                                final = last fields+                                l = comb2 $1 $3+                                isPun = False+                            $5 <- unECP $5+                            fmap Right $ mkHsProjUpdatePV (comb2 $1 (reLoc $5)) (L l fields) $5 isPun+                                            [mj AnnEqual $4]+                        }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        -- AZ: need to pull out the let block into a helper+        | field TIGHT_INFIX_PROJ fieldToUpdate+                        { do+                            let top =  sL1 $1 $ HsFieldLabel noAnn $1+                                ((L lf (HsFieldLabel _ f)):t) = reverse (unLoc $3)+                                lf' = comb2 $2 (L lf ())+                                fields = top : L lf' (HsFieldLabel (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t+                                final = last fields+                                l = comb2 $1 $3+                                isPun = True+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLoc final) (mkRdrUnqual . mkVarOcc . unpackFS . unLoc . hflLabel . unLoc $ final))+                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []+                        }++fieldToUpdate :: { Located [Located (HsFieldLabel GhcPs)] }+fieldToUpdate+        -- See Note [Whitespace-sensitive operator parsing] in Lexer.x+        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLoc $3) >>= \cs ->+                                                     return (sLL $1 $> ((sLL $2 $> (HsFieldLabel (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }+        | field       {% getCommentsFor (getLoc $1) >>= \cs ->+                        return (sL1 $1 [sL1 $1 (HsFieldLabel (EpAnn (glR $1) (AnnFieldLabel Nothing) cs) $1)]) }++-----------------------------------------------------------------------------+-- Implicit Parameter Bindings++dbinds  :: { Located [LIPBind GhcPs] } -- reversed+        : dbinds ';' dbind+                      {% case unLoc $1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (gl $2)+                             return (let { this = $3; rest = h':t }+                                in rest `seq` this `seq` sLL $1 (reLoc $>) (this : rest)) }+        | dbinds ';'  {% case unLoc $1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (gl $2)+                             return (sLL $1 $> (h':t)) }+        | dbind                        { let this = $1 in this `seq` (sL1 (reLoc $1) [this]) }+--      | {- empty -}                  { [] }++dbind   :: { LIPBind GhcPs }+dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->+                                          acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (Left $1) $3)) }++ipvar   :: { Located HsIPName }+        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }++-----------------------------------------------------------------------------+-- Overloaded labels++overloaded_label :: { Located FastString }+        : LABELVARID          { sL1 $1 (getLABELVARID $1) }++-----------------------------------------------------------------------------+-- Warnings and deprecations++name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }+        : name_boolformula          { $1 }+        | {- empty -}               { noLocA mkTrue }++name_boolformula :: { LBooleanFormula (LocatedN RdrName) }+        : name_boolformula_and                      { $1 }+        | name_boolformula_and '|' name_boolformula+                           {% do { h <- addTrailingVbarL $1 (gl $2)+                                 ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } }++name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }+        : name_boolformula_and_list+                  { reLocA $ sLLAA (head $1) (last $1) (And ($1)) }++name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }+        : name_boolformula_atom                               { [$1] }+        | name_boolformula_atom ',' name_boolformula_and_list+            {% do { h <- addTrailingCommaL $1 (gl $2)+                  ; return (h : $3) } }++name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }+        : '(' name_boolformula ')'  {% amsrl (sLL $1 $> (Parens $2))+                                      (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }+        | name_var                  { reLocA $ sL1N $1 (Var $1) }++namelist :: { Located [LocatedN RdrName] }+namelist : name_var              { sL1N $1 [$1] }+         | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)+                                       ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}++name_var :: { LocatedN RdrName }+name_var : var { $1 }+         | con { $1 }++-----------------------------------------+-- Data constructors+-- There are two different productions here as lifted list constructors+-- are parsed differently.++qcon_nowiredlist :: { LocatedN RdrName }+        : gen_qcon                     { $1 }+        | sysdcon_nolist               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }++qcon :: { LocatedN RdrName }+  : gen_qcon              { $1}+  | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }++gen_qcon :: { LocatedN RdrName }+  : qconid                { $1 }+  | '(' qconsym ')'       {% amsrn (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }++con     :: { LocatedN RdrName }+        : conid                 { $1 }+        | '(' consym ')'        {% amsrn (sLL $1 $> (unLoc $2))+                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }+        | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }++con_list :: { Located [LocatedN RdrName] }+con_list : con                  { sL1N $1 [$1] }+         | con ',' con_list     {% do { h <- addTrailingCommaN $1 (gl $2)+                                      ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}++-- See Note [ExplicitTuple] in GHC.Hs.Expr+sysdcon_nolist :: { LocatedN DataCon }  -- Wired in data constructors+        : '(' ')'               {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }+        | '(' commas ')'        {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))+                                       (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }+        | '(#' '#)'             {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }+        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))+                                       (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }++-- See Note [Empty lists] in GHC.Hs.Expr+sysdcon :: { LocatedN DataCon }+        : sysdcon_nolist                 { $1 }+        | '[' ']'               {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }++conop :: { LocatedN RdrName }+        : consym                { $1 }+        | '`' conid '`'         {% amsrn (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++qconop :: { LocatedN RdrName }+        : qconsym               { $1 }+        | '`' qconid '`'        {% amsrn (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++----------------------------------------------------------------------------+-- Type constructors+++-- See Note [Unit tuples] in GHC.Hs.Type for the distinction+-- between gtycon and ntgtycon+gtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, including unit tuples+        : ntgtycon                     { $1 }+        | '(' ')'                      {% amsrn (sLL $1 $> $ getRdrName unitTyCon)+                                                 (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }+        | '(#' '#)'                    {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon)+                                                 (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }++ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit tuples+        : oqtycon               { $1 }+        | '(' commas ')'        {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed+                                                        (snd $2 + 1)))+                                       (NameAnnCommas NameParens (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }+        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed+                                                        (snd $2 + 1)))+                                       (NameAnnCommas NameParensHash (glAA $1) (map (EpaSpan . realSrcSpan) (fst $2)) (glAA $3) []) }+        | '(' '->' ')'          {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                       (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | '[' ']'               {% amsrn (sLL $1 $> $ listTyCon_RDR)+                                       (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }++oqtycon :: { LocatedN RdrName }  -- An "ordinary" qualified tycon;+                                -- These can appear in export lists+        : qtycon                        { $1 }+        | '(' qtyconsym ')'             {% amsrn (sLL $1 $> (unLoc $2))+                                                  (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }++oqtycon_no_varcon :: { LocatedN RdrName }  -- Type constructor which cannot be mistaken+                                          -- for variable constructor in export lists+                                          -- see Note [Type constructors in export list]+        :  qtycon            { $1 }+        | '(' QCONSYM ')'    {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }+                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | '(' CONSYM ')'     {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }+                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | '(' ':' ')'        {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! consDataCon_RDR }+                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }++{- Note [Type constructors in export list]+~~~~~~~~~~~~~~~~~~~~~+Mixing type constructors and data constructors in export lists introduces+ambiguity in grammar: e.g. (*) may be both a type constructor and a function.++-XExplicitNamespaces allows to disambiguate by explicitly prefixing type+constructors with 'type' keyword.++This ambiguity causes reduce/reduce conflicts in parser, which are always+resolved in favour of data constructors. To get rid of conflicts we demand+that ambiguous type constructors (those, which are formed by the same+productions as variable constructors) are always prefixed with 'type' keyword.+Unambiguous type constructors may occur both with or without 'type' keyword.++Note that in the parser we still parse data constructors as type+constructors. As such, they still end up in the type constructor namespace+until after renaming when we resolve the proper namespace for each exported+child.+-}++qtyconop :: { LocatedN RdrName } -- Qualified or unqualified+        -- See Note [%shift: qtyconop -> qtyconsym]+        : qtyconsym %shift              { $1 }+        | '`' qtycon '`'                {% amsrn (sLL $1 $> (unLoc $2))+                                                 (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++qtycon :: { LocatedN RdrName }   -- Qualified or unqualified+        : QCONID            { sL1n $1 $! mkQual tcClsName (getQCONID $1) }+        | tycon             { $1 }++tycon   :: { LocatedN RdrName }  -- Unqualified+        : CONID                   { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }++qtyconsym :: { LocatedN RdrName }+        : QCONSYM            { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }+        | QVARSYM            { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }+        | tyconsym           { $1 }++tyconsym :: { LocatedN RdrName }+        : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }+        | VARSYM                { sL1n $1 $!+                                    -- See Note [eqTyCon (~) is built-in syntax] in GHC.Builtin.Types+                                    if getVARSYM $1 == fsLit "~"+                                      then eqTyCon_RDR+                                      else mkUnqual tcClsName (getVARSYM $1) }+        | ':'                   { sL1n $1 $! consDataCon_RDR }+        | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }+        | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }++-- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.+-- These can appear in `ANN type` declarations (#19374).+otycon :: { LocatedN RdrName }+        : tycon                 { $1 }+        | '(' tyconsym ')'      {% amsrn (sLL $1 $> (unLoc $2))+                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }++-----------------------------------------------------------------------------+-- Operators++op      :: { LocatedN RdrName }   -- used in infix decls+        : varop                 { $1 }+        | conop                 { $1 }+        | '->'                  { sL1n $1 $ getRdrName unrestrictedFunTyCon }++varop   :: { LocatedN RdrName }+        : varsym                { $1 }+        | '`' varid '`'         {% amsrn (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++qop     :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections+        : qvarop                { mkHsVarOpPV $1 }+        | qconop                { mkHsConOpPV $1 }+        | hole_op               { pvN $1 }++qopm    :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections+        : qvaropm               { mkHsVarOpPV $1 }+        | qconop                { mkHsConOpPV $1 }+        | hole_op               { pvN $1 }++hole_op :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections+hole_op : '`' '_' '`'           { mkHsInfixHolePV (comb2 $1 $>)+                                         (\cs -> EpAnn (glR $1) (EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }++qvarop :: { LocatedN RdrName }+        : qvarsym               { $1 }+        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++qvaropm :: { LocatedN RdrName }+        : qvarsym_no_minus      { $1 }+        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++-----------------------------------------------------------------------------+-- Type variables++tyvar   :: { LocatedN RdrName }+tyvar   : tyvarid               { $1 }++tyvarop :: { LocatedN RdrName }+tyvarop : '`' tyvarid '`'       {% amsrn (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }++tyvarid :: { LocatedN RdrName }+        : VARID            { sL1n $1 $! mkUnqual tvName (getVARID $1) }+        | special_id       { sL1n $1 $! mkUnqual tvName (unLoc $1) }+        | 'unsafe'         { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }+        | 'safe'           { sL1n $1 $! mkUnqual tvName (fsLit "safe") }+        | 'interruptible'  { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }+        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'+        -- in GHC.Parser.PostProcess+        -- See Note [Parsing explicit foralls in Rules]++-----------------------------------------------------------------------------+-- Variables++var     :: { LocatedN RdrName }+        : varid                 { $1 }+        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }++qvar    :: { LocatedN RdrName }+        : qvarid                { $1 }+        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }+        | '(' qvarsym1 ')'      {% amsrn (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }+-- We've inlined qvarsym here so that the decision about+-- whether it's a qvar or a var can be postponed until+-- *after* we see the close paren.++field :: { Located FastString  }+      : VARID { sL1 $1 $! getVARID $1 }++qvarid :: { LocatedN RdrName }+        : varid               { $1 }+        | QVARID              { sL1n $1 $! mkQual varName (getQVARID $1) }++-- Note that 'role' and 'family' get lexed separately regardless of+-- the use of extensions. However, because they are listed here,+-- this is OK and they can be used as normal varids.+-- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer+varid :: { LocatedN RdrName }+        : VARID            { sL1n $1 $! mkUnqual varName (getVARID $1) }+        | special_id       { sL1n $1 $! mkUnqual varName (unLoc $1) }+        | 'unsafe'         { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }+        | 'safe'           { sL1n $1 $! mkUnqual varName (fsLit "safe") }+        | 'interruptible'  { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}+        | 'forall'         { sL1n $1 $! mkUnqual varName (fsLit "forall") }+        | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }+        | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }+        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'+        -- in GHC.Parser.PostProcess+        -- See Note [Parsing explicit foralls in Rules]++qvarsym :: { LocatedN RdrName }+        : varsym                { $1 }+        | qvarsym1              { $1 }++qvarsym_no_minus :: { LocatedN RdrName }+        : varsym_no_minus       { $1 }+        | qvarsym1              { $1 }++qvarsym1 :: { LocatedN RdrName }+qvarsym1 : QVARSYM              { sL1n $1 $ mkQual varName (getQVARSYM $1) }++varsym :: { LocatedN RdrName }+        : varsym_no_minus       { $1 }+        | '-'                   { sL1n $1 $ mkUnqual varName (fsLit "-") }++varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'+        : VARSYM               { sL1n $1 $ mkUnqual varName (getVARSYM $1) }+        | special_sym          { sL1n $1 $ mkUnqual varName (unLoc $1) }+++-- These special_ids are treated as keywords in various places,+-- but as ordinary ids elsewhere.   'special_id' collects all these+-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and+-- 'anyclass', whose treatment differs depending on context+special_id :: { Located FastString }+special_id+        : 'as'                  { sL1 $1 (fsLit "as") }+        | 'qualified'           { sL1 $1 (fsLit "qualified") }+        | 'hiding'              { sL1 $1 (fsLit "hiding") }+        | 'export'              { sL1 $1 (fsLit "export") }+        | 'label'               { sL1 $1 (fsLit "label")  }+        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }+        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }+        | 'ccall'               { sL1 $1 (fsLit "ccall") }+        | 'capi'                { sL1 $1 (fsLit "capi") }+        | 'prim'                { sL1 $1 (fsLit "prim") }+        | 'javascript'          { sL1 $1 (fsLit "javascript") }+        -- See Note [%shift: special_id -> 'group']+        | 'group' %shift        { sL1 $1 (fsLit "group") }+        | 'stock'               { sL1 $1 (fsLit "stock") }+        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }+        | 'via'                 { sL1 $1 (fsLit "via") }+        | 'unit'                { sL1 $1 (fsLit "unit") }+        | 'dependency'          { sL1 $1 (fsLit "dependency") }+        | 'signature'           { sL1 $1 (fsLit "signature") }++special_sym :: { Located FastString }+special_sym : '.'       { sL1 $1 (fsLit ".") }+            | '*'       { sL1 $1 (fsLit (starSym (isUnicode $1))) }++-----------------------------------------------------------------------------+-- Data constructors++qconid :: { LocatedN RdrName }   -- Qualified or unqualified+        : conid              { $1 }+        | QCONID             { sL1n $1 $! mkQual dataName (getQCONID $1) }++conid   :: { LocatedN RdrName }+        : CONID                { sL1n $1 $ mkUnqual dataName (getCONID $1) }++qconsym :: { LocatedN RdrName }  -- Qualified or unqualified+        : consym               { $1 }+        | QCONSYM              { sL1n $1 $ mkQual dataName (getQCONSYM $1) }++consym :: { LocatedN RdrName }+        : CONSYM              { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }++        -- ':' means only list cons+        | ':'                { sL1n $1 $ consDataCon_RDR }+++-----------------------------------------------------------------------------+-- Literals++literal :: { Located (HsLit GhcPs) }+        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }+        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)+                                                    $ getSTRING $1 }+        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)+                                                    $ getPRIMINTEGER $1 }+        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)+                                                    $ getPRIMWORD $1 }+        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)+                                                    $ getPRIMCHAR $1 }+        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)+                                                    $ getPRIMSTRING $1 }+        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }+        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }++-----------------------------------------------------------------------------+-- Layout++close :: { () }+        : vccurly               { () } -- context popped in lexer.+        | error                 {% popContext }++-----------------------------------------------------------------------------+-- Miscellaneous (mostly renamings)++modid   :: { LocatedA ModuleName }+        : CONID                 { sL1a $1 $ mkModuleNameFS (getCONID $1) }+        | QCONID                { sL1a $1 $ let (mod,c) = getQCONID $1 in+                                  mkModuleNameFS+                                   (mkFastString+                                     (unpackFS mod ++ '.':unpackFS c))+                                }++commas :: { ([SrcSpan],Int) }   -- One or more commas+        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }+        | ','                    { ([gl $1],1) }++bars0 :: { ([EpaLocation],Int) }     -- Zero or more bars+        : bars                   { $1 }+        |                        { ([], 0) }++bars :: { ([EpaLocation],Int) }     -- One or more bars+        : bars '|'               { ((fst $1)++[glAA $2],snd $1 + 1) }+        | '|'                    { ([glAA $1],1) }++{+happyError :: P a+happyError = srcParseFail++getVARID        (L _ (ITvarid    x)) = x+getCONID        (L _ (ITconid    x)) = x+getVARSYM       (L _ (ITvarsym   x)) = x+getCONSYM       (L _ (ITconsym   x)) = x+getDO           (L _ (ITdo      x)) = x+getMDO          (L _ (ITmdo     x)) = x+getQVARID       (L _ (ITqvarid   x)) = x+getQCONID       (L _ (ITqconid   x)) = x+getQVARSYM      (L _ (ITqvarsym  x)) = x+getQCONSYM      (L _ (ITqconsym  x)) = x+getIPDUPVARID   (L _ (ITdupipvarid   x)) = x+getLABELVARID   (L _ (ITlabelvarid   x)) = x+getCHAR         (L _ (ITchar   _ x)) = x+getSTRING       (L _ (ITstring _ x)) = x+getINTEGER      (L _ (ITinteger x))  = x+getRATIONAL     (L _ (ITrational x)) = x+getPRIMCHAR     (L _ (ITprimchar _ x)) = x+getPRIMSTRING   (L _ (ITprimstring _ x)) = x+getPRIMINTEGER  (L _ (ITprimint  _ x)) = x+getPRIMWORD     (L _ (ITprimword _ x)) = x+getPRIMFLOAT    (L _ (ITprimfloat x)) = x+getPRIMDOUBLE   (L _ (ITprimdouble x)) = x+getINLINE       (L _ (ITinline_prag _ inl conl)) = (inl,conl)+getSPEC_INLINE  (L _ (ITspec_inline_prag _ True))  = (Inline,  FunLike)+getSPEC_INLINE  (L _ (ITspec_inline_prag _ False)) = (NoInline,FunLike)+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x+getVOCURLY      (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l++getINTEGERs     (L _ (ITinteger (IL src _ _))) = src+getCHARs        (L _ (ITchar       src _)) = src+getSTRINGs      (L _ (ITstring     src _)) = src+getPRIMCHARs    (L _ (ITprimchar   src _)) = src+getPRIMSTRINGs  (L _ (ITprimstring src _)) = src+getPRIMINTEGERs (L _ (ITprimint    src _)) = src+getPRIMWORDs    (L _ (ITprimword   src _)) = src++-- See Note [Pragma source text] in "GHC.Types.Basic" for the following+getINLINE_PRAGs       (L _ (ITinline_prag       src _ _)) = src+getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src+getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src+getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src+getRULES_PRAGs        (L _ (ITrules_prag        src)) = src+getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src+getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src+getSCC_PRAGs          (L _ (ITscc_prag          src)) = src+getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src+getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src+getANN_PRAGs          (L _ (ITann_prag          src)) = src+getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src+getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src+getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src+getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src+getCTYPEs             (L _ (ITctype             src)) = src++getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing++isUnicode :: Located Token -> Bool+isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax+isUnicode (L _ ITlolly)               = True+isUnicode _                           = False++hasE :: Located Token -> Bool+hasE (L _ (ITopenExpQuote HasE _)) = True+hasE (L _ (ITopenTExpQuote HasE))  = True+hasE _                             = False++getSCC :: Located Token -> P FastString+getSCC lt = do let s = getSTRING lt+               -- We probably actually want to be more restrictive than this+               if ' ' `elem` unpackFS s+                   then addFatalError $ PsError PsErrSpaceInSCC [] (getLoc lt)+                   else return s++-- Utilities for combining source spans+comb2 :: Located a -> Located b -> SrcSpan+comb2 a b = a `seq` b `seq` combineLocs a b++-- Utilities for combining source spans+comb2A :: Located a -> LocatedAn t b -> SrcSpan+comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)++comb2N :: Located a -> LocatedN b -> SrcSpan+comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)++comb2Al :: LocatedAn t a -> Located b -> SrcSpan+comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b++comb3 :: Located a -> Located b -> Located c -> SrcSpan+comb3 a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))++comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan+comb3A a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))++comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan+comb3N a b c = a `seq` b `seq` c `seq`+    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))++comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan+comb4 a b c d = a `seq` b `seq` c `seq` d `seq`+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $+                combineSrcSpans (getLoc c) (getLoc d))++comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan+comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`+    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $+       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))++-- strict constructor version:+{-# INLINE sL #-}+sL :: l -> a -> GenLocated l a+sL loc a = loc `seq` a `seq` L loc a++-- See Note [Adding location info] for how these utility functions are used++-- replaced last 3 CPP macros in this file+{-# INLINE sL0 #-}+sL0 :: a -> Located a+sL0 = L noSrcSpan       -- #define L0   L noSrcSpan++{-# INLINE sL1 #-}+sL1 :: GenLocated l a -> b -> GenLocated l b+sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1A #-}+sL1A :: LocatedAn t a -> b -> Located b+sL1A x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1N #-}+sL1N :: LocatedN a -> b -> Located b+sL1N x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1a #-}+sL1a :: Located a -> b -> LocatedAn t b+sL1a x = sL (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1n #-}+sL1n :: Located a -> b -> LocatedN b+sL1n x = L (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sLL #-}+sLL :: Located a -> Located b -> c -> Located c+sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLa #-}+sLLa :: Located a -> Located b -> c -> LocatedAn t c+sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLlA #-}+sLLlA :: Located a -> LocatedAn t b -> c -> Located c+sLLlA x y = sL (comb2A x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLAl #-}+sLLAl :: LocatedAn t a -> Located b -> c -> Located c+sLLAl x y = sL (comb2A y x) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLAA #-}+sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c+sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL   sL (comb2 $1 $>)+++{- Note [Adding location info]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~++This is done using the three functions below, sL0, sL1+and sLL.  Note that these functions were mechanically+converted from the three macros that used to exist before,+namely L0, L1 and LL.++They each add a SrcSpan to their argument.++   sL0  adds 'noSrcSpan', used for empty productions+     -- This doesn't seem to work anymore -=chak++   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan+        from that token.++   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from+        the first and last tokens.++These suffice for the majority of cases.  However, we must be+especially careful with empty productions: sLL won't work if the first+or last token on the lhs can represent an empty span.  In these cases,+we have to calculate the span using more of the tokens from the lhs, eg.++        | 'newtype' tycl_hdr '=' newconstr deriving+                { L (comb3 $1 $4 $5)+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }++We provide comb3 and comb4 functions which are useful in such cases.++Be careful: there's no checking that you actually got this right, the+only symptom will be that the SrcSpans of your syntax will be+incorrect.++-}++-- Make a source location for the file.  We're a bit lazy here and just+-- make a point SrcSpan at line 1, column 0.  Strictly speaking we should+-- try to find the span of the whole file (ToDo).+fileSrcSpan :: P SrcSpan+fileSrcSpan = do+  l <- getRealSrcLoc;+  let loc = mkSrcLoc (srcLocFile l) 1 1;+  return (mkSrcSpan loc loc)++-- Hint about linear types+hintLinear :: MonadP m => SrcSpan -> m ()+hintLinear span = do+  linearEnabled <- getBit LinearTypesBit+  unless linearEnabled $ addError $ PsError PsErrLinearFunction [] span++-- Does this look like (a %m)?+looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool+looksLikeMult ty1 l_op ty2+  | Unqual op_name <- unLoc l_op+  , occNameFS op_name == fsLit "%"+  , Just ty1_pos <- getBufSpan (getLocA ty1)+  , Just pct_pos <- getBufSpan (getLocA l_op)+  , Just ty2_pos <- getBufSpan (getLocA ty2)+  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos+  , bufSpanEnd pct_pos == bufSpanStart ty2_pos+  = True+  | otherwise = False++-- Hint about the MultiWayIf extension+hintMultiWayIf :: SrcSpan -> P ()+hintMultiWayIf span = do+  mwiEnabled <- getBit MultiWayIfBit+  unless mwiEnabled $ addError $ PsError PsErrMultiWayIf [] span++-- Hint about explicit-forall+hintExplicitForall :: Located Token -> P ()+hintExplicitForall tok = do+    forall   <- getBit ExplicitForallBit+    rulePrag <- getBit InRulePragBit+    unless (forall || rulePrag) $ addError $ PsError (PsErrExplicitForall (isUnicode tok)) [] (getLoc tok)++-- Hint about qualified-do+hintQualifiedDo :: Located Token -> P ()+hintQualifiedDo tok = do+    qualifiedDo   <- getBit QualifiedDoBit+    case maybeQDoDoc of+      Just qdoDoc | not qualifiedDo ->+        addError $ PsError (PsErrIllegalQualifiedDo qdoDoc) [] (getLoc tok)+      _ -> return ()+  where+    maybeQDoDoc = case unLoc tok of+      ITdo (Just m) -> Just $ ftext m <> text ".do"+      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"+      t -> Nothing++-- When two single quotes don't followed by tyvar or gtycon, we report the+-- error as empty character literal, or TH quote that missing proper type+-- variable or constructor. See #13450.+reportEmptyDoubleQuotes :: SrcSpan -> P a+reportEmptyDoubleQuotes span = do+    thQuotes <- getBit ThQuotesBit+    addFatalError $ PsError (PsErrEmptyDoubleQuotes thQuotes) [] span++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************++For the general principles of the following routines, see Note [exact print annotations]+in GHC.Parser.Annotation++-}++-- |Construct an AddEpAnn from the annotation keyword and the location+-- of the keyword itself+mj :: AnnKeywordId -> Located e -> AddEpAnn+mj a l = AddEpAnn a (EpaSpan $ rs $ gl l)++mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn+mjN a l = AddEpAnn a (EpaSpan $ rs $ glN l)++-- |Construct an AddEpAnn from the annotation keyword and the location+-- of the keyword itself, provided the span is not zero width+mz :: AnnKeywordId -> Located e -> [AddEpAnn]+mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (EpaSpan $ rs $ gl l)]++msemi :: Located e -> [TrailingAnn]+msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (EpaSpan $ rs $ gl l)]++msemim :: Located e -> Maybe EpaLocation+msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (EpaSpan $ rs $ gl l)++-- |Construct an AddEpAnn from the annotation keyword and the Located Token. If+-- the token has a unicode equivalent and this has been used, provide the+-- unicode variant of the annotation.+mu :: AnnKeywordId -> Located Token -> AddEpAnn+mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (EpaSpan $ rs l)++mau :: Located Token -> TrailingAnn+mau lt@(L l t) = if isUnicode lt then AddRarrowAnnU (EpaSpan $ rs l)+                                 else AddRarrowAnn  (EpaSpan $ rs l)++mlu :: Located Token -> TrailingAnn+mlu lt@(L l t) = AddLollyAnnU (EpaSpan $ rs l)++-- | If the 'Token' is using its unicode variant return the unicode variant of+--   the annotation+toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId+toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a++toUnicode :: Located Token -> IsUnicodeSyntax+toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax++gl :: GenLocated l a -> l+gl = getLoc++glA :: LocatedAn t a -> SrcSpan+glA = getLocA++glN :: LocatedN a -> SrcSpan+glN = getLocA++glR :: Located a -> Anchor+glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor++glAA :: Located a -> EpaLocation+glAA = EpaSpan <$> realSrcSpan . getLoc++glRR :: Located a -> RealSrcSpan+glRR = realSrcSpan . getLoc++glAR :: LocatedAn t a -> Anchor+glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor++glNR :: LocatedN a -> Anchor+glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor++glNRR :: LocatedN a -> EpaLocation+glNRR = EpaSpan <$> realSrcSpan . getLocA++anc :: RealSrcSpan -> Anchor+anc r = Anchor r UnchangedAnchor++acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)+acs a = do+  let (L l _) = a emptyComments+  cs <- getCommentsFor l+  return (a cs)++-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.+acsFinal :: (EpAnnComments -> Located a) -> P (Located a)+acsFinal a = do+  let (L l _) = a emptyComments+  cs <- getCommentsFor l+  csf <- getFinalCommentsFor l+  meof <- getEofPos+  let ce = case meof of+             Nothing  -> EpaComments []+             Just (pos, gap) -> EpaCommentsBalanced [] [L (realSpanAsAnchor pos) (EpaComment EpaEofComment gap)]+  return (a (cs Semi.<> csf Semi.<> ce))++acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)+acsa a = do+  let (L l _) = a emptyComments+  cs <- getCommentsFor (locA l)+  return (a cs)++acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)+acsA a = reLocA <$> acs a++acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP+acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a+               ; return (ecpFromExp $ expr) }++amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)+amsA (L l a) bs = do+  cs <- getCommentsFor (locA l)+  return (L (addAnnsA l bs cs) a)++amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)+amsAl (L l a) loc bs = do+  cs <- getCommentsFor loc+  return (L (addAnnsA l bs cs) a)++amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a)+amsrc a@(L l _) bs = do+  cs <- getCommentsFor l+  return (reAnnC bs cs a)++amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a)+amsrl a@(L l _) bs = do+  cs <- getCommentsFor l+  return (reAnnL bs cs a)++amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a)+amsrp a@(L l _) bs = do+  cs <- getCommentsFor l+  return (reAnnL bs cs a)++amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)+amsrn (L l a) an = do+  cs <- getCommentsFor l+  let ann = (EpAnn (spanAsAnchor l) an cs)+  return (L (SrcSpanAnn ann l) a)++-- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose+mo,mc :: Located Token -> AddEpAnn+mo ll = mj AnnOpen ll+mc ll = mj AnnClose ll++moc,mcc :: Located Token -> AddEpAnn+moc ll = mj AnnOpenC ll+mcc ll = mj AnnCloseC ll++mop,mcp :: Located Token -> AddEpAnn+mop ll = mj AnnOpenP ll+mcp ll = mj AnnCloseP ll++moh,mch :: Located Token -> AddEpAnn+moh ll = mj AnnOpenPH ll+mch ll = mj AnnClosePH ll++mos,mcs :: Located Token -> AddEpAnn+mos ll = mj AnnOpenS ll+mcs ll = mj AnnCloseS ll++pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)+pvA a = do { av <- a+           ; return (reLocA av) }++pvN :: MonadP m => m (Located a) -> m (LocatedN a)+pvN a = do { (L l av) <- a+           ; return (L (noAnnSrcSpan l) av) }++pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)+pvL a = do { av <- a+           ; return (reLoc av) }++-- | Parse a Haskell module with Haddock comments.+-- This is done in two steps:+--+-- * 'parseModuleNoHaddock' to build the AST+-- * 'addHaddockToModule' to insert Haddock comments into it+--+-- This is the only parser entry point that deals with Haddock comments.+-- The other entry points ('parseDeclaration', 'parseExpression', etc) do+-- not insert them into the AST.+parseModule :: P (Located HsModule)+parseModule = parseModuleNoHaddock >>= addHaddockToModule++commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)+commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc++-- | Instead of getting the *enclosed* comments, this includes the+-- *preceding* ones.  It is used at the top level to get comments+-- between top level declarations.+commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)+commentsPA la@(L l a) = do+  cs <- getPriorCommentsFor (getLocA la)+  return (L (addCommentsToSrcAnn l cs) a)++rs :: SrcSpan -> RealSrcSpan+rs (RealSrcSpan l _) = l+rs _ = panic "Parser should only have RealSrcSpan"++hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList+hsDoAnn (L l _) (L ll _) kw+  = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (EpaSpan $ rs l)] []++listAsAnchor :: [LocatedAn t a] -> Anchor+listAsAnchor [] = spanAsAnchor noSrcSpan+listAsAnchor (L l _:_) = spanAsAnchor (locA l)++-- -------------------------------------++addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)+addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)+addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)++addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn++addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn++addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingCommaA  la span = addTrailingAnnA la span AddCommaAnn++addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)+addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do+  -- cs <- getCommentsFor l+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let+    anns' = if isZeroWidthSpan ss+              then anns+              else addTrailingAnnToA l (ta (EpaSpan $ rs ss)) cs anns+  return (L (SrcSpanAnn anns' l) a)++-- -------------------------------------++addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)+addTrailingVbarL  la span = addTrailingAnnL la (AddVbarAnn (EpaSpan $ rs span))++addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)+addTrailingCommaL  la span = addTrailingAnnL la (AddCommaAnn (EpaSpan $ rs span))++addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)+addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do+  cs <- getCommentsFor l+  let anns' = addTrailingAnnToL l ta cs anns+  return (L (SrcSpanAnn anns' l) a)++-- -------------------------------------++-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation+addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)+addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do+  -- cs <- getCommentsFor l+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let anns' = if isZeroWidthSpan span+                then anns+                else addTrailingCommaToN l anns (EpaSpan $ rs span)+  return (L (SrcSpanAnn anns' l) a)++addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral+addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) })++-- -------------------------------------++addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a+addTrailingDarrowC (L (SrcSpanAnn EpAnnNotUsed l) a) lt cs =+  let+    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax+  in L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a+addTrailingDarrowC (L (SrcSpanAnn (EpAnn lr (AnnContext _ o c) csc) l) a) lt cs =+  let+    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax+  in L (SrcSpanAnn (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a++-- -------------------------------------++-- We need a location for the where binds, when computing the SrcSpan+-- for the AST element using them.  Where there is a span, we return+-- it, else noLoc, which is ignored in the comb2 call.+adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))+                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)+adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)+adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)+ }

GHC/Parser/Annotation.hs view

@@ -1,418 +1,1277 @@-{-# LANGUAGE DeriveDataTypeable #-}--module GHC.Parser.Annotation (-  getAnnotation, getAndRemoveAnnotation,-  getAnnotationComments,getAndRemoveAnnotationComments,-  ApiAnns(..),-  ApiAnnKey,-  AnnKeywordId(..),-  AddAnn(..),mkParensApiAnn,-  AnnotationComment(..),-  IsUnicodeSyntax(..),-  unicodeAnn,-  HasE(..),-  LRdrName -- Exists for haddocks only-  ) where--import GHC.Prelude--import GHC.Types.Name.Reader-import GHC.Utils.Outputable-import GHC.Types.SrcLoc-import qualified Data.Map as Map-import Data.Data---{--Note [Api annotations]-~~~~~~~~~~~~~~~~~~~~~~-Given a parse tree of a Haskell module, how can we reconstruct-the original Haskell source code, retaining all whitespace and-source code comments?  We need to track the locations of all-elements from the original source: this includes keywords such as-'let' / 'in' / 'do' etc as well as punctuation such as commas and-braces, and also comments.  We collectively refer to this-metadata as the "API annotations".--Rather than annotate the resulting parse tree with these locations-directly (this would be a major change to some fairly core data-structures in GHC), we instead capture locations for these elements in a-structure separate from the parse tree, and returned in the-pm_annotations field of the ParsedModule type.--The full ApiAnns type is--> data ApiAnns =->  ApiAnns->    { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan],->      apiAnnEofPos :: Maybe RealSrcSpan,->      apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment],->      apiAnnRogueComments :: [RealLocated AnnotationComment]->    }--NON-COMMENT ELEMENTS--Intuitively, every AST element directly contains a bag of keywords-(keywords can show up more than once in a node: a semicolon i.e. newline-can show up multiple times before the next AST element), each of which-needs to be associated with its location in the original source code.--Consequently, the structure that records non-comment elements is logically-a two level map, from the RealSrcSpan of the AST element containing it, to-a map from keywords ('AnnKeyWord') to all locations of the keyword directly-in the AST element:--> type ApiAnnKey = (RealSrcSpan,AnnKeywordId)->-> Map.Map ApiAnnKey [RealSrcSpan]--So--> let x = 1 in 2 *x--would result in the AST element--  L span (HsLet (binds for x = 1) (2 * x))--and the annotations--  (span,AnnLet) having the location of the 'let' keyword-  (span,AnnEqual) having the location of the '=' sign-  (span,AnnIn)  having the location of the 'in' keyword--For any given element in the AST, there is only a set number of-keywords that are applicable for it (e.g., you'll never see an-'import' keyword associated with a let-binding.)  The set of allowed-keywords is documented in a comment associated with the constructor-of a given AST element, although the ground truth is in GHC.Parser-and GHC.Parser.PostProcess (which actually add the annotations; see #13012).--COMMENT ELEMENTS--Every comment is associated with a *located* AnnotationComment.-We associate comments with the lowest (most specific) AST element-enclosing them:--> Map.Map RealSrcSpan [RealLocated AnnotationComment]--PARSER STATE--There are three fields in PState (the parser state) which play a role-with annotations.-->  annotations :: [(ApiAnnKey,[RealSrcSpan])],->  comment_q :: [RealLocated AnnotationComment],->  annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]--The 'annotations' and 'annotations_comments' fields are simple: they simply-accumulate annotations that will end up in 'ApiAnns' at the end-(after they are passed to Map.fromList).--The 'comment_q' field captures comments as they are seen in the token stream,-so that when they are ready to be allocated via the parser they are-available (at the time we lex a comment, we don't know what the enclosing-AST node of it is, so we can't associate it with a RealSrcSpan in-annotations_comments).--PARSER EMISSION OF ANNOTATIONS--The parser interacts with the lexer using the function--> addAnnotation :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()--which takes the AST element RealSrcSpan, the annotation keyword and the-target RealSrcSpan.--This adds the annotation to the `annotations` field of `PState` and-transfers any comments in `comment_q` WHICH ARE ENCLOSED by-the RealSrcSpan of this element to the `annotations_comments`-field.  (Comments which are outside of this annotation are deferred-until later. 'allocateComments' in 'Lexer' is responsible for-making sure we only attach comments that actually fit in the 'SrcSpan'.)--The wiki page describing this feature is-https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations---}--- ------------------------------------------------------------------------- If you update this, update the Note [Api annotations] above-data ApiAnns =-  ApiAnns-    { apiAnnItems :: Map.Map ApiAnnKey [RealSrcSpan],-      apiAnnEofPos :: Maybe RealSrcSpan,-      apiAnnComments :: Map.Map RealSrcSpan [RealLocated AnnotationComment],-      apiAnnRogueComments :: [RealLocated AnnotationComment]-    }---- If you update this, update the Note [Api annotations] above-type ApiAnnKey = (RealSrcSpan,AnnKeywordId)----- ------------------------------------------------------------------------- | Encapsulated call to addAnnotation, requiring only the SrcSpan of---   the AST construct the annotation belongs to; together with the---   AnnKeywordId, this is the key of the annotation map.------   This type is useful for places in the parser where it is not yet---   known what SrcSpan an annotation should be added to.  The most---   common situation is when we are parsing a list: the annotations---   need to be associated with the AST element that *contains* the---   list, not the list itself.  'AddAnn' lets us defer adding the---   annotations until we finish parsing the list and are now parsing---   the enclosing element; we then apply the 'AddAnn' to associate---   the annotations.  Another common situation is where a common fragment of---   the AST has been factored out but there is no separate AST node for---   this fragment (this occurs in class and data declarations). In this---   case, the annotation belongs to the parent data declaration.------   The usual way an 'AddAnn' is created is using the 'mj' ("make jump")---   function, and then it can be discharged using the 'ams' function.-data AddAnn = AddAnn AnnKeywordId SrcSpan---- |Given a 'SrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate--- 'AddAnn' values for the opening and closing bordering on the start--- and end of the span-mkParensApiAnn :: SrcSpan -> [AddAnn]-mkParensApiAnn (UnhelpfulSpan _)  = []-mkParensApiAnn (RealSrcSpan ss _) = [AddAnn AnnOpenP lo,AddAnn AnnCloseP lc]-  where-    f = srcSpanFile ss-    sl = srcSpanStartLine ss-    sc = srcSpanStartCol ss-    el = srcSpanEndLine ss-    ec = srcSpanEndCol ss-    lo = RealSrcSpan (mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))) Nothing-    lc = RealSrcSpan (mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss))        Nothing---- ------------------------------------------------------------------------ | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'--- of the annotated AST element, and the known type of the annotation.-getAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId -> [RealSrcSpan]-getAnnotation anns span ann =-  case Map.lookup ann_key ann_items of-    Nothing -> []-    Just ss -> ss-  where ann_items = apiAnnItems anns-        ann_key = (span,ann)---- | Retrieve a list of annotation 'SrcSpan's based on the 'SrcSpan'--- of the annotated AST element, and the known type of the annotation.--- The list is removed from the annotations.-getAndRemoveAnnotation :: ApiAnns -> RealSrcSpan -> AnnKeywordId-                       -> ([RealSrcSpan],ApiAnns)-getAndRemoveAnnotation anns span ann =-  case Map.lookup ann_key ann_items of-    Nothing -> ([],anns)-    Just ss -> (ss,anns{ apiAnnItems = Map.delete ann_key ann_items })-  where ann_items = apiAnnItems anns-        ann_key = (span,ann)---- |Retrieve the comments allocated to the current 'SrcSpan'------  Note: A given 'SrcSpan' may appear in multiple AST elements,---  beware of duplicates-getAnnotationComments :: ApiAnns -> RealSrcSpan -> [RealLocated AnnotationComment]-getAnnotationComments anns span =-  case Map.lookup span (apiAnnComments anns) of-    Just cs -> cs-    Nothing -> []---- |Retrieve the comments allocated to the current 'SrcSpan', and--- remove them from the annotations-getAndRemoveAnnotationComments :: ApiAnns -> RealSrcSpan-                               -> ([RealLocated AnnotationComment],ApiAnns)-getAndRemoveAnnotationComments anns span =-  case Map.lookup span ann_comments of-    Just cs -> (cs, anns{ apiAnnComments = Map.delete span ann_comments })-    Nothing -> ([], anns)-  where ann_comments = apiAnnComments anns---- ------------------------------------------------------------------------ | API Annotations exist so that tools can perform source to source--- conversions of Haskell code. They are used to keep track of the--- various syntactic keywords that are not captured in the existing--- AST.------ The annotations, together with original source comments are made--- available in the @'pm_annotations'@ field of @'GHC.ParsedModule'@.--- Comments are only retained if @'Opt_KeepRawTokenStream'@ is set in--- @'GHC.Driver.Session.DynFlags'@ before parsing.------ The wiki page describing this feature is--- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations------ Note: in general the names of these are taken from the--- corresponding token, unless otherwise noted--- See note [Api annotations] above for details of the usage-data AnnKeywordId-    = AnnAnyclass-    | AnnAs-    | AnnAt-    | AnnBang  -- ^ '!'-    | AnnBackquote -- ^ '`'-    | AnnBy-    | AnnCase -- ^ case or lambda case-    | AnnClass-    | AnnClose -- ^  '\#)' or '\#-}'  etc-    | AnnCloseB -- ^ '|)'-    | AnnCloseBU -- ^ '|)', unicode variant-    | AnnCloseC -- ^ '}'-    | AnnCloseQ  -- ^ '|]'-    | AnnCloseQU -- ^ '|]', unicode variant-    | AnnCloseP -- ^ ')'-    | AnnCloseS -- ^ ']'-    | AnnColon-    | AnnComma -- ^ as a list separator-    | AnnCommaTuple -- ^ in a RdrName for a tuple-    | AnnDarrow -- ^ '=>'-    | AnnDarrowU -- ^ '=>', unicode variant-    | AnnData-    | AnnDcolon -- ^ '::'-    | AnnDcolonU -- ^ '::', unicode variant-    | AnnDefault-    | AnnDeriving-    | AnnDo-    | AnnDot    -- ^ '.'-    | AnnDotdot -- ^ '..'-    | AnnElse-    | AnnEqual-    | AnnExport-    | AnnFamily-    | AnnForall-    | AnnForallU -- ^ Unicode variant-    | AnnForeign-    | AnnFunId -- ^ for function name in matches where there are-               -- multiple equations for the function.-    | AnnGroup-    | AnnHeader -- ^ for CType-    | AnnHiding-    | AnnIf-    | AnnImport-    | AnnIn-    | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'-    | AnnInstance-    | AnnLam-    | AnnLarrow     -- ^ '<-'-    | AnnLarrowU    -- ^ '<-', unicode variant-    | AnnLet-    | AnnLollyU     -- ^ The '⊸' unicode arrow-    | AnnMdo-    | AnnMinus -- ^ '-'-    | AnnModule-    | AnnPercentOne -- ^ '%1' -- for HsLinearArrow-    | AnnNewtype-    | AnnName -- ^ where a name loses its location in the AST, this carries it-    | AnnOf-    | AnnOpen    -- ^ '(\#' or '{-\# LANGUAGE' etc-    | AnnOpenB   -- ^ '(|'-    | AnnOpenBU  -- ^ '(|', unicode variant-    | AnnOpenC   -- ^ '{'-    | AnnOpenE   -- ^ '[e|' or '[e||'-    | AnnOpenEQ  -- ^ '[|'-    | AnnOpenEQU -- ^ '[|', unicode variant-    | AnnOpenP   -- ^ '('-    | AnnOpenS   -- ^ '['-    | AnnDollar          -- ^ prefix '$'   -- TemplateHaskell-    | AnnDollarDollar    -- ^ prefix '$$'  -- TemplateHaskell-    | AnnPackageName-    | AnnPattern-    | AnnPercent -- ^ '%' -- for HsExplicitMult-    | AnnProc-    | AnnQualified-    | AnnRarrow -- ^ '->'-    | AnnRarrowU -- ^ '->', unicode variant-    | AnnRec-    | AnnRole-    | AnnSafe-    | AnnSemi -- ^ ';'-    | AnnSimpleQuote -- ^ '''-    | AnnSignature-    | AnnStatic -- ^ 'static'-    | AnnStock-    | AnnThen-    | AnnThTyQuote -- ^ double '''-    | AnnTilde -- ^ '~'-    | AnnType-    | AnnUnit -- ^ '()' for types-    | AnnUsing-    | AnnVal  -- ^ e.g. INTEGER-    | AnnValStr  -- ^ String value, will need quotes when output-    | AnnVbar -- ^ '|'-    | AnnVia -- ^ 'via'-    | AnnWhere-    | Annlarrowtail -- ^ '-<'-    | AnnlarrowtailU -- ^ '-<', unicode variant-    | Annrarrowtail -- ^ '->'-    | AnnrarrowtailU -- ^ '->', unicode variant-    | AnnLarrowtail -- ^ '-<<'-    | AnnLarrowtailU -- ^ '-<<', unicode variant-    | AnnRarrowtail -- ^ '>>-'-    | AnnRarrowtailU -- ^ '>>-', unicode variant-    deriving (Eq, Ord, Data, Show)--instance Outputable AnnKeywordId where-  ppr x = text (show x)---- -----------------------------------------------------------------------data AnnotationComment =-  -- Documentation annotations-    AnnDocCommentNext  String     -- ^ something beginning '-- |'-  | AnnDocCommentPrev  String     -- ^ something beginning '-- ^'-  | AnnDocCommentNamed String     -- ^ something beginning '-- $'-  | AnnDocSection      Int String -- ^ a section heading-  | AnnDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)-  | AnnLineComment     String     -- ^ comment starting by "--"-  | AnnBlockComment    String     -- ^ comment in {- -}-    deriving (Eq, Ord, Data, Show)--- Note: these are based on the Token versions, but the Token type is--- defined in GHC.Parser.Lexer and bringing it in here would create a loop--instance Outputable AnnotationComment where-  ppr x = text (show x)---- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',---             'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma',---             'GHC.Parser.Annotation.AnnRarrow'---             'GHC.Parser.Annotation.AnnTilde'---   - May have 'GHC.Parser.Annotation.AnnComma' when in a list-type LRdrName = Located RdrName----- | Certain tokens can have alternate representations when unicode syntax is--- enabled. This flag is attached to those tokens in the lexer so that the--- original source representation can be reproduced in the corresponding--- 'ApiAnnotation'-data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax-    deriving (Eq, Ord, Data, Show)---- | Convert a normal annotation into its unicode equivalent one-unicodeAnn :: AnnKeywordId -> AnnKeywordId-unicodeAnn AnnForall     = AnnForallU-unicodeAnn AnnDcolon     = AnnDcolonU-unicodeAnn AnnLarrow     = AnnLarrowU-unicodeAnn AnnRarrow     = AnnRarrowU-unicodeAnn AnnDarrow     = AnnDarrowU-unicodeAnn Annlarrowtail = AnnlarrowtailU-unicodeAnn Annrarrowtail = AnnrarrowtailU-unicodeAnn AnnLarrowtail = AnnLarrowtailU-unicodeAnn AnnRarrowtail = AnnRarrowtailU-unicodeAnn AnnOpenB      = AnnOpenBU-unicodeAnn AnnCloseB     = AnnCloseBU-unicodeAnn AnnOpenEQ     = AnnOpenEQU-unicodeAnn AnnCloseQ     = AnnCloseQU-unicodeAnn ann           = ann----- | Some template haskell tokens have two variants, one with an `e` the other--- not:------ >  [| or [e|--- >  [|| or [e||------ This type indicates whether the 'e' is present or not.-data HasE = HasE | NoE-     deriving (Eq, Ord, Data, Show)+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}++module GHC.Parser.Annotation (+  -- * Core Exact Print Annotation types+  AnnKeywordId(..),+  EpaComment(..), EpaCommentTok(..),+  IsUnicodeSyntax(..),+  unicodeAnn,+  HasE(..),++  -- * In-tree Exact Print Annotations+  AddEpAnn(..),+  EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,+  DeltaPos(..), deltaPos, getDeltaLine,++  EpAnn(..), Anchor(..), AnchorOperation(..),+  spanAsAnchor, realSpanAsAnchor,+  noAnn,++  -- ** Comments in Annotations++  EpAnnComments(..), LEpaComment, emptyComments,+  getFollowingComments, setFollowingComments, setPriorComments,+  EpAnnCO,++  -- ** Annotations in 'GenLocated'+  LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,+  SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,+  SrcSpanAnn'(..), SrcAnn,++  -- ** Annotation data types used in 'GenLocated'++  AnnListItem(..), AnnList(..),+  AnnParen(..), ParenType(..), parenTypeKws,+  AnnPragma(..),+  AnnContext(..),+  NameAnn(..), NameAdornment(..),+  NoEpAnns(..),+  AnnSortKey(..),++  -- ** Trailing annotations in lists+  TrailingAnn(..), addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,++  -- ** Utilities for converting between different 'GenLocated' when+  -- ** we do not care about the annotations.+  la2na, na2la, n2l, l2n, l2l, la2la,+  reLoc, reLocA, reLocL, reLocC, reLocN,++  la2r, realSrcSpan,++  -- ** Building up annotations+  extraToAnnList, reAnn,+  reAnnL, reAnnC,+  addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorR, widenLocatedAn,++  -- ** Querying annotations+  getLocAnn,+  epAnnAnns, epAnnAnnsL,+  annParen2AddEpAnn,+  epAnnComments,++  -- ** Working with locations of annotations+  sortLocatedA,+  mapLocA,+  combineLocsA,+  combineSrcSpansA,+  addCLocA, addCLocAA,++  -- ** Constructing 'GenLocated' annotation types when we do not care+  -- about annotations.+  noLocA, getLocA,+  noSrcSpanA,+  noAnnSrcSpan,++  -- ** Working with comments in annotations+  noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,+  addCommentsToEpAnn, setCommentsEpAnn,+  transferAnnsA, commentsOnlyA, removeCommentsA,++  placeholderRealSpan,+  ) where++import GHC.Prelude++import Data.Data+import Data.Function (on)+import Data.List (sortBy)+import Data.Semigroup+import GHC.Data.FastString+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Utils.Binary+import GHC.Utils.Outputable hiding ( (<>) )+import GHC.Utils.Panic++{-+Note [exact print annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a parse tree of a Haskell module, how can we reconstruct+the original Haskell source code, retaining all whitespace and+source code comments?  We need to track the locations of all+elements from the original source: this includes keywords such as+'let' / 'in' / 'do' etc as well as punctuation such as commas and+braces, and also comments.  We collectively refer to this+metadata as the "exact print annotations".++NON-COMMENT ELEMENTS++Intuitively, every AST element directly contains a bag of keywords+(keywords can show up more than once in a node: a semicolon i.e. newline+can show up multiple times before the next AST element), each of which+needs to be associated with its location in the original source code.++These keywords are recorded directly in the AST element in which they+occur, for the GhcPs phase.++For any given element in the AST, there is only a set number of+keywords that are applicable for it (e.g., you'll never see an+'import' keyword associated with a let-binding.)  The set of allowed+keywords is documented in a comment associated with the constructor+of a given AST element, although the ground truth is in GHC.Parser+and GHC.Parser.PostProcess (which actually add the annotations).++COMMENT ELEMENTS++We associate comments with the lowest (most specific) AST element+enclosing them++PARSER STATE++There are three fields in PState (the parser state) which play a role+with annotation comments.++>  comment_q :: [LEpaComment],+>  header_comments :: Maybe [LEpaComment],+>  eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token++The 'comment_q' field captures comments as they are seen in the token stream,+so that when they are ready to be allocated via the parser they are+available.++The 'header_comments' capture the comments coming at the top of the+source file.  They are moved there from the `comment_q` when comments+are allocated for the first top-level declaration.++The 'eof_pos' captures the final location in the file, and the+location of the immediately preceding token to the last location, so+that the exact-printer can work out how far to advance to add the+trailing whitespace.++PARSER EMISSION OF ANNOTATIONS++The parser interacts with the lexer using the functions++> getCommentsFor      :: (MonadP m) => SrcSpan -> m EpAnnComments+> getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+> getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments++The 'getCommentsFor' function is the one used most often.  It takes+the AST element SrcSpan and removes and returns any comments in the+'comment_q' that are inside the span. 'allocateComments' in 'Lexer' is+responsible for making sure we only return comments that actually fit+in the 'SrcSpan'.++The 'getPriorCommentsFor' function is used for top-level declarations,+and removes and returns any comments in the 'comment_q' that either+precede or are included in the given SrcSpan. This is to ensure that+preceding documentation comments are kept together with the+declaration they belong to.++The 'getFinalCommentsFor' function is called right at the end when EOF+is hit. This drains the 'comment_q' completely, and returns the+'header_comments', remaining 'comment_q' entries and the+'eof_pos'. These values are inserted into the 'HsModule' AST element.++The wiki page describing this feature is+https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations++-}++-- --------------------------------------------------------------------++-- | Exact print annotations exist so that tools can perform source to+-- source conversions of Haskell code. They are used to keep track of+-- the various syntactic keywords that are not otherwise captured in the+-- AST.+--+-- The wiki page describing this feature is+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations+-- https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow/in-tree-api-annotations+--+-- Note: in general the names of these are taken from the+-- corresponding token, unless otherwise noted+-- See note [exact print annotations] above for details of the usage+data AnnKeywordId+    = AnnAnyclass+    | AnnAs+    | AnnAt+    | AnnBang  -- ^ '!'+    | AnnBackquote -- ^ '`'+    | AnnBy+    | AnnCase -- ^ case or lambda case+    | AnnClass+    | AnnClose -- ^  '\#)' or '\#-}'  etc+    | AnnCloseB -- ^ '|)'+    | AnnCloseBU -- ^ '|)', unicode variant+    | AnnCloseC -- ^ '}'+    | AnnCloseQ  -- ^ '|]'+    | AnnCloseQU -- ^ '|]', unicode variant+    | AnnCloseP -- ^ ')'+    | AnnClosePH -- ^ '\#)'+    | AnnCloseS -- ^ ']'+    | AnnColon+    | AnnComma -- ^ as a list separator+    | AnnCommaTuple -- ^ in a RdrName for a tuple+    | AnnDarrow -- ^ '=>'+    | AnnDarrowU -- ^ '=>', unicode variant+    | AnnData+    | AnnDcolon -- ^ '::'+    | AnnDcolonU -- ^ '::', unicode variant+    | AnnDefault+    | AnnDeriving+    | AnnDo+    | AnnDot    -- ^ '.'+    | AnnDotdot -- ^ '..'+    | AnnElse+    | AnnEqual+    | AnnExport+    | AnnFamily+    | AnnForall+    | AnnForallU -- ^ Unicode variant+    | AnnForeign+    | AnnFunId -- ^ for function name in matches where there are+               -- multiple equations for the function.+    | AnnGroup+    | AnnHeader -- ^ for CType+    | AnnHiding+    | AnnIf+    | AnnImport+    | AnnIn+    | AnnInfix -- ^ 'infix' or 'infixl' or 'infixr'+    | AnnInstance+    | AnnLam+    | AnnLarrow     -- ^ '<-'+    | AnnLarrowU    -- ^ '<-', unicode variant+    | AnnLet+    | AnnLollyU     -- ^ The '⊸' unicode arrow+    | AnnMdo+    | AnnMinus -- ^ '-'+    | AnnModule+    | AnnNewtype+    | AnnName -- ^ where a name loses its location in the AST, this carries it+    | AnnOf+    | AnnOpen    -- ^ '{-\# DEPRECATED' etc. Opening of pragmas where+                 -- the capitalisation of the string can be changed by+                 -- the user. The actual text used is stored in a+                 -- 'SourceText' on the relevant pragma item.+    | AnnOpenB   -- ^ '(|'+    | AnnOpenBU  -- ^ '(|', unicode variant+    | AnnOpenC   -- ^ '{'+    | AnnOpenE   -- ^ '[e|' or '[e||'+    | AnnOpenEQ  -- ^ '[|'+    | AnnOpenEQU -- ^ '[|', unicode variant+    | AnnOpenP   -- ^ '('+    | AnnOpenS   -- ^ '['+    | AnnOpenPH  -- ^ '(\#'+    | AnnDollar          -- ^ prefix '$'   -- TemplateHaskell+    | AnnDollarDollar    -- ^ prefix '$$'  -- TemplateHaskell+    | AnnPackageName+    | AnnPattern+    | AnnPercent    -- ^ '%'  -- for HsExplicitMult+    | AnnPercentOne -- ^ '%1' -- for HsLinearArrow+    | AnnProc+    | AnnQualified+    | AnnRarrow -- ^ '->'+    | AnnRarrowU -- ^ '->', unicode variant+    | AnnRec+    | AnnRole+    | AnnSafe+    | AnnSemi -- ^ ';'+    | AnnSimpleQuote -- ^ '''+    | AnnSignature+    | AnnStatic -- ^ 'static'+    | AnnStock+    | AnnThen+    | AnnThTyQuote -- ^ double '''+    | AnnTilde -- ^ '~'+    | AnnType+    | AnnUnit -- ^ '()' for types+    | AnnUsing+    | AnnVal  -- ^ e.g. INTEGER+    | AnnValStr  -- ^ String value, will need quotes when output+    | AnnVbar -- ^ '|'+    | AnnVia -- ^ 'via'+    | AnnWhere+    | Annlarrowtail -- ^ '-<'+    | AnnlarrowtailU -- ^ '-<', unicode variant+    | Annrarrowtail -- ^ '->'+    | AnnrarrowtailU -- ^ '->', unicode variant+    | AnnLarrowtail -- ^ '-<<'+    | AnnLarrowtailU -- ^ '-<<', unicode variant+    | AnnRarrowtail -- ^ '>>-'+    | AnnRarrowtailU -- ^ '>>-', unicode variant+    deriving (Eq, Ord, Data, Show)++instance Outputable AnnKeywordId where+  ppr x = text (show x)++-- | Certain tokens can have alternate representations when unicode syntax is+-- enabled. This flag is attached to those tokens in the lexer so that the+-- original source representation can be reproduced in the corresponding+-- 'EpAnnotation'+data IsUnicodeSyntax = UnicodeSyntax | NormalSyntax+    deriving (Eq, Ord, Data, Show)++-- | Convert a normal annotation into its unicode equivalent one+unicodeAnn :: AnnKeywordId -> AnnKeywordId+unicodeAnn AnnForall     = AnnForallU+unicodeAnn AnnDcolon     = AnnDcolonU+unicodeAnn AnnLarrow     = AnnLarrowU+unicodeAnn AnnRarrow     = AnnRarrowU+unicodeAnn AnnDarrow     = AnnDarrowU+unicodeAnn Annlarrowtail = AnnlarrowtailU+unicodeAnn Annrarrowtail = AnnrarrowtailU+unicodeAnn AnnLarrowtail = AnnLarrowtailU+unicodeAnn AnnRarrowtail = AnnRarrowtailU+unicodeAnn AnnOpenB      = AnnOpenBU+unicodeAnn AnnCloseB     = AnnCloseBU+unicodeAnn AnnOpenEQ     = AnnOpenEQU+unicodeAnn AnnCloseQ     = AnnCloseQU+unicodeAnn ann           = ann+++-- | Some template haskell tokens have two variants, one with an `e` the other+-- not:+--+-- >  [| or [e|+-- >  [|| or [e||+--+-- This type indicates whether the 'e' is present or not.+data HasE = HasE | NoE+     deriving (Eq, Ord, Data, Show)++-- ---------------------------------------------------------------------++data EpaComment =+  EpaComment+    { ac_tok :: EpaCommentTok+    , ac_prior_tok :: RealSrcSpan+    -- ^ The location of the prior token, used in exact printing.  The+    -- 'EpaComment' appears as an 'LEpaComment' containing its+    -- location.  The difference between the end of the prior token+    -- and the start of this location is used for the spacing when+    -- exact printing the comment.+    }+    deriving (Eq, Ord, Data, Show)++data EpaCommentTok =+  -- Documentation annotations+    EpaDocCommentNext  String     -- ^ something beginning '-- |'+  | EpaDocCommentPrev  String     -- ^ something beginning '-- ^'+  | EpaDocCommentNamed String     -- ^ something beginning '-- $'+  | EpaDocSection      Int String -- ^ a section heading+  | EpaDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)+  | EpaLineComment     String     -- ^ comment starting by "--"+  | EpaBlockComment    String     -- ^ comment in {- -}+  | EpaEofComment                 -- ^ empty comment, capturing+                                  -- location of EOF++  -- See #19697 for a discussion of EpaEofComment's use and how it+  -- should be removed in favour of capturing it in the location for+  -- 'Located HsModule' in the parser.++    deriving (Eq, Ord, Data, Show)+-- Note: these are based on the Token versions, but the Token type is+-- defined in GHC.Parser.Lexer and bringing it in here would create a loop++instance Outputable EpaComment where+  ppr x = text (show x)++-- ---------------------------------------------------------------------++-- | Captures an annotation, storing the @'AnnKeywordId'@ and its+-- location.  The parser only ever inserts @'EpaLocation'@ fields with a+-- RealSrcSpan being the original location of the annotation in the+-- source file.+-- The @'EpaLocation'@ can also store a delta position if the AST has been+-- modified and needs to be pretty printed again.+-- The usual way an 'AddEpAnn' is created is using the 'mj' ("make+-- jump") function, and then it can be inserted into the appropriate+-- annotation.+data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq)++-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the+-- @'EpaSpan'@ variant, giving the exact location of the original item+-- in the parsed source.  This can be replaced by the @'EpaDelta'@+-- version, to provide a position for the item relative to the end of+-- the previous item in the source.  This is useful when editing an+-- AST prior to exact printing the changed one. The list of comments+-- in the @'EpaDelta'@ variant captures any comments between the prior+-- output and the thing being marked here, since we cannot otherwise+-- sort the relative order.+data EpaLocation = EpaSpan !RealSrcSpan+                 | EpaDelta !DeltaPos ![LEpaComment]+               deriving (Data,Eq,Ord)++-- | Spacing between output items when exact printing.  It captures+-- the spacing from the current print position on the page to the+-- position required for the thing about to be printed.  This is+-- either on the same line in which case is is simply the number of+-- spaces to emit, or it is some number of lines down, with a given+-- column offset.  The exact printing algorithm keeps track of the+-- column offset pertaining to the current anchor position, so the+-- `deltaColumn` is the additional spaces to add in this case.  See+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for+-- details.+data DeltaPos+  = SameLine { deltaColumn :: !Int }+  | DifferentLine+      { deltaLine   :: !Int, -- ^ deltaLine should always be > 0+        deltaColumn :: !Int+      } deriving (Show,Eq,Ord,Data)++-- | Smart constructor for a 'DeltaPos'. It preserves the invariant+-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.+deltaPos :: Int -> Int -> DeltaPos+deltaPos l c = case l of+  0 -> SameLine c+  _ -> DifferentLine l c++getDeltaLine :: DeltaPos -> Int+getDeltaLine (SameLine _) = 0+getDeltaLine (DifferentLine r _) = r++-- | Used in the parser only, extract the 'RealSrcSpan' from an+-- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the+-- partial function is safe.+epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan+epaLocationRealSrcSpan (EpaSpan r) = r+epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"++epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation+epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l)+epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc)++instance Outputable EpaLocation where+  ppr (EpaSpan r) = text "EpaSpan" <+> ppr r+  ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs++instance Outputable AddEpAnn where+  ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss++instance Ord AddEpAnn where+  compare (AddEpAnn kw1 loc1) (AddEpAnn kw2 loc2) = compare (loc1, kw1) (loc2,kw2)++-- ---------------------------------------------------------------------++-- | The exact print annotations (EPAs) are kept in the HsSyn AST for+--   the GhcPs phase. We do not always have EPAs though, only for code+--   that has been parsed as they do not exist for generated+--   code. This type captures that they may be missing.+--+-- A goal of the annotations is that an AST can be edited, including+-- moving subtrees from one place to another, duplicating them, and so+-- on.  This means that each fragment must be self-contained.  To this+-- end, each annotated fragment keeps track of the anchor position it+-- was originally captured at, being simply the start span of the+-- topmost element of the ast fragment.  This gives us a way to later+-- re-calculate all Located items in this layer of the AST, as well as+-- any annotations captured. The comments associated with the AST+-- fragment are also captured here.+--+-- The 'ann' type parameter allows this general structure to be+-- specialised to the specific set of locations of original exact+-- print annotation elements.  So for 'HsLet' we have+--+--    type instance XLet GhcPs = EpAnn AnnsLet+--    data AnnsLet+--      = AnnsLet {+--          alLet :: EpaLocation,+--          alIn :: EpaLocation+--          } deriving Data+--+-- The spacing between the items under the scope of a given EpAnn is+-- normally derived from the original 'Anchor'.  But if a sub-element+-- is not in its original position, the required spacing can be+-- directly captured in the 'anchor_op' field of the 'entry' Anchor.+-- This allows us to freely move elements around, and stitch together+-- new AST fragments out of old ones, and have them still printed out+-- in a precise way.+data EpAnn ann+  = EpAnn { entry   :: Anchor+           -- ^ Base location for the start of the syntactic element+           -- holding the annotations.+           , anns     :: ann -- ^ Annotations added by the Parser+           , comments :: EpAnnComments+              -- ^ Comments enclosed in the SrcSpan of the element+              -- this `EpAnn` is attached to+           }+  | EpAnnNotUsed -- ^ No Annotation for generated code,+                  -- e.g. from TH, deriving, etc.+        deriving (Data, Eq, Functor)++-- | An 'Anchor' records the base location for the start of the+-- syntactic element holding the annotations, and is used as the point+-- of reference for calculating delta positions for contained+-- annotations.+-- It is also normally used as the reference point for the spacing of+-- the element relative to its container. If it is moved, that+-- relationship is tracked in the 'anchor_op' instead.++data Anchor = Anchor        { anchor :: RealSrcSpan+                                 -- ^ Base location for the start of+                                 -- the syntactic element holding+                                 -- the annotations.+                            , anchor_op :: AnchorOperation }+        deriving (Data, Eq, Show)++-- | If tools modify the parsed source, the 'MovedAnchor' variant can+-- directly provide the spacing for this item relative to the previous+-- one when printing. This allows AST fragments with a particular+-- anchor to be freely moved, without worrying about recalculating the+-- appropriate anchor span.+data AnchorOperation = UnchangedAnchor+                     | MovedAnchor DeltaPos+        deriving (Data, Eq, Show)+++spanAsAnchor :: SrcSpan -> Anchor+spanAsAnchor s  = Anchor (realSrcSpan s) UnchangedAnchor++realSpanAsAnchor :: RealSrcSpan -> Anchor+realSpanAsAnchor s  = Anchor s UnchangedAnchor++-- ---------------------------------------------------------------------++-- | When we are parsing we add comments that belong a particular AST+-- element, and print them together with the element, interleaving+-- them into the output stream.  But when editing the AST to move+-- fragments around it is useful to be able to first separate the+-- comments into those occuring before the AST element and those+-- following it.  The 'EpaCommentsBalanced' constructor is used to do+-- this. The GHC parser will only insert the 'EpaComments' form.+data EpAnnComments = EpaComments+                        { priorComments :: ![LEpaComment] }+                    | EpaCommentsBalanced+                        { priorComments :: ![LEpaComment]+                        , followingComments :: ![LEpaComment] }+        deriving (Data, Eq)++type LEpaComment = GenLocated Anchor EpaComment++emptyComments :: EpAnnComments+emptyComments = EpaComments []++-- ---------------------------------------------------------------------+-- Annotations attached to a 'SrcSpan'.+-- ---------------------------------------------------------------------++-- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with+-- an extra annotation type. This is mapped to a specific `GenLocated`+-- usage in the AST through the `XRec` and `Anno` type families.+data SrcSpanAnn' a = SrcSpanAnn { ann :: a, locA :: SrcSpan }+        deriving (Data, Eq)+-- See Note [XRec and Anno in the AST]++-- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\''+type SrcAnn ann = SrcSpanAnn' (EpAnn ann)++type LocatedA = GenLocated SrcSpanAnnA+type LocatedN = GenLocated SrcSpanAnnN++type LocatedL = GenLocated SrcSpanAnnL+type LocatedP = GenLocated SrcSpanAnnP+type LocatedC = GenLocated SrcSpanAnnC++type SrcSpanAnnA = SrcAnn AnnListItem+type SrcSpanAnnN = SrcAnn NameAnn++type SrcSpanAnnL = SrcAnn AnnList+type SrcSpanAnnP = SrcAnn AnnPragma+type SrcSpanAnnC = SrcAnn AnnContext++-- | General representation of a 'GenLocated' type carrying a+-- parameterised annotation type.+type LocatedAn an = GenLocated (SrcAnn an)++{-+Note [XRec and Anno in the AST]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The exact print annotations are captured directly inside the AST, using+TTG extension points. However certain annotations need to be captured+on the Located versions too.  While there is a general form for these,+captured in the type SrcSpanAnn', there are also specific usages in+different contexts.++Some of the particular use cases are++1) RdrNames, which can have additional items such as backticks or parens++2) Items which occur in lists, and the annotation relates purely+to its usage inside a list.++See the section above this note for the rest.++The Anno type family maps the specific SrcSpanAnn' variant for a given+item.++So++  type instance XRec (GhcPass p) a = GenLocated (Anno a) a+  type instance Anno RdrName = SrcSpanAnnN+  type LocatedN = GenLocated SrcSpanAnnN++meaning we can have type LocatedN RdrName++-}++-- ---------------------------------------------------------------------+-- Annotations for items in a list+-- ---------------------------------------------------------------------++-- | Captures the location of punctuation occuring between items,+-- normally in a list.  It is captured as a trailing annotation.+data TrailingAnn+  = AddSemiAnn EpaLocation    -- ^ Trailing ';'+  | AddCommaAnn EpaLocation   -- ^ Trailing ','+  | AddVbarAnn EpaLocation    -- ^ Trailing '|'+  | AddRarrowAnn EpaLocation  -- ^ Trailing '->'+  | AddRarrowAnnU EpaLocation -- ^ Trailing '->', unicode variant+  | AddLollyAnnU EpaLocation  -- ^ Trailing '⊸'+  deriving (Data,Eq, Ord)++instance Outputable TrailingAnn where+  ppr (AddSemiAnn ss)    = text "AddSemiAnn"    <+> ppr ss+  ppr (AddCommaAnn ss)   = text "AddCommaAnn"   <+> ppr ss+  ppr (AddVbarAnn ss)    = text "AddVbarAnn"    <+> ppr ss+  ppr (AddRarrowAnn ss)  = text "AddRarrowAnn"  <+> ppr ss+  ppr (AddRarrowAnnU ss) = text "AddRarrowAnnU" <+> ppr ss+  ppr (AddLollyAnnU ss)  = text "AddLollyAnnU"  <+> ppr ss++-- | Annotation for items appearing in a list. They can have one or+-- more trailing punctuations items, such as commas or semicolons.+data AnnListItem+  = AnnListItem {+      lann_trailing  :: [TrailingAnn]+      }+  deriving (Data, Eq)++-- ---------------------------------------------------------------------+-- Annotations for the context of a list of items+-- ---------------------------------------------------------------------++-- | Annotation for the "container" of a list. This captures+-- surrounding items such as braces if present, and introductory+-- keywords such as 'where'.+data AnnList+  = AnnList {+      al_anchor    :: Maybe Anchor, -- ^ start point of a list having layout+      al_open      :: Maybe AddEpAnn,+      al_close     :: Maybe AddEpAnn,+      al_rest      :: [AddEpAnn], -- ^ context, such as 'where' keyword+      al_trailing  :: [TrailingAnn] -- ^ items appearing after the+                                    -- list, such as '=>' for a+                                    -- context+      } deriving (Data,Eq)++-- ---------------------------------------------------------------------+-- Annotations for parenthesised elements, such as tuples, lists+-- ---------------------------------------------------------------------++-- | exact print annotation for an item having surrounding "brackets", such as+-- tuples or lists+data AnnParen+  = AnnParen {+      ap_adornment :: ParenType,+      ap_open      :: EpaLocation,+      ap_close     :: EpaLocation+      } deriving (Data)++-- | Detail of the "brackets" used in an 'AnnParen' exact print annotation.+data ParenType+  = AnnParens       -- ^ '(', ')'+  | AnnParensHash   -- ^ '(#', '#)'+  | AnnParensSquare -- ^ '[', ']'+  deriving (Eq, Ord, Data)++-- | Maps the 'ParenType' to the related opening and closing+-- AnnKeywordId. Used when actually printing the item.+parenTypeKws :: ParenType -> (AnnKeywordId, AnnKeywordId)+parenTypeKws AnnParens       = (AnnOpenP, AnnCloseP)+parenTypeKws AnnParensHash   = (AnnOpenPH, AnnClosePH)+parenTypeKws AnnParensSquare = (AnnOpenS, AnnCloseS)++-- ---------------------------------------------------------------------++-- | Exact print annotation for the 'Context' data type.+data AnnContext+  = AnnContext {+      ac_darrow    :: Maybe (IsUnicodeSyntax, EpaLocation),+                      -- ^ location and encoding of the '=>', if present.+      ac_open      :: [EpaLocation], -- ^ zero or more opening parentheses.+      ac_close     :: [EpaLocation]  -- ^ zero or more closing parentheses.+      } deriving (Data)+++-- ---------------------------------------------------------------------+-- Annotations for names+-- ---------------------------------------------------------------------++-- | exact print annotations for a 'RdrName'.  There are many kinds of+-- adornment that can be attached to a given 'RdrName'. This type+-- captures them, as detailed on the individual constructors.+data NameAnn+  -- | Used for a name with an adornment, so '`foo`', '(bar)'+  = NameAnn {+      nann_adornment :: NameAdornment,+      nann_open      :: EpaLocation,+      nann_name      :: EpaLocation,+      nann_close     :: EpaLocation,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @(,,,)@, or @(#,,,#)#+  | NameAnnCommas {+      nann_adornment :: NameAdornment,+      nann_open      :: EpaLocation,+      nann_commas    :: [EpaLocation],+      nann_close     :: EpaLocation,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @()@, @(##)@, @[]@+  | NameAnnOnly {+      nann_adornment :: NameAdornment,+      nann_open      :: EpaLocation,+      nann_close     :: EpaLocation,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for @->@, as an identifier+  | NameAnnRArrow {+      nann_name      :: EpaLocation,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used for an item with a leading @'@. The annotation for+  -- unquoted item is stored in 'nann_quoted'.+  | NameAnnQuote {+      nann_quote     :: EpaLocation,+      nann_quoted    :: SrcSpanAnnN,+      nann_trailing  :: [TrailingAnn]+      }+  -- | Used when adding a 'TrailingAnn' to an existing 'LocatedN'+  -- which has no Api Annotation (via the 'EpAnnNotUsed' constructor.+  | NameAnnTrailing {+      nann_trailing  :: [TrailingAnn]+      }+  deriving (Data, Eq)++-- | A 'NameAnn' can capture the locations of surrounding adornments,+-- such as parens or backquotes. This data type identifies what+-- particular pair are being used.+data NameAdornment+  = NameParens -- ^ '(' ')'+  | NameParensHash -- ^ '(#' '#)'+  | NameBackquotes -- ^ '`'+  | NameSquare -- ^ '[' ']'+  deriving (Eq, Ord, Data)++-- ---------------------------------------------------------------------++-- | exact print annotation used for capturing the locations of+-- annotations in pragmas.+data AnnPragma+  = AnnPragma {+      apr_open      :: AddEpAnn,+      apr_close     :: AddEpAnn,+      apr_rest      :: [AddEpAnn]+      } deriving (Data,Eq)++-- ---------------------------------------------------------------------+-- | Captures the sort order of sub elements. This is needed when the+-- sub-elements have been split (as in a HsLocalBind which holds separate+-- binds and sigs) or for infix patterns where the order has been+-- re-arranged. It is captured explicitly so that after the Delta phase a+-- SrcSpan is used purely as an index into the annotations, allowing+-- transformations of the AST including the introduction of new Located+-- items or re-arranging existing ones.+data AnnSortKey+  = NoAnnSortKey+  | AnnSortKey [RealSrcSpan]+  deriving (Data, Eq)++-- ---------------------------------------------------------------------+++-- | Helper function used in the parser to add a 'TrailingAnn' items+-- to an existing annotation.+addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments+                  -> EpAnn AnnList -> EpAnn AnnList+addTrailingAnnToL s t cs EpAnnNotUsed+  = EpAnn (spanAsAnchor s) (AnnList (Just $ spanAsAnchor s) Nothing Nothing [] [t]) cs+addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n)+                               , comments = comments n <> cs }+  where+    -- See Note [list append in addTrailing*]+    addTrailing n = n { al_trailing = al_trailing n ++ [t]}++-- | Helper function used in the parser to add a 'TrailingAnn' items+-- to an existing annotation.+addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments+                  -> EpAnn AnnListItem -> EpAnn AnnListItem+addTrailingAnnToA s t cs EpAnnNotUsed+  = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs+addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n)+                               , comments = comments n <> cs }+  where+    -- See Note [list append in addTrailing*]+    addTrailing n = n { lann_trailing = lann_trailing n ++ [t] }++-- | Helper function used in the parser to add a comma location to an+-- existing annotation.+addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn+addTrailingCommaToN s EpAnnNotUsed l+  = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments+addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }+  where+    -- See Note [list append in addTrailing*]+    addTrailing :: NameAnn -> EpaLocation -> NameAnn+    addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]}++{-+Note [list append in addTrailing*]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The addTrailingAnnToL, addTrailingAnnToA and addTrailingCommaToN+functions are used to add a separator for an item when it occurs in a+list.  So they are used to capture a comma, vbar, semicolon and similar.++In general, a given element will have zero or one of these.  In+extreme (test) cases, there may be multiple semicolons.++In exact printing we sometimes convert the EpaLocation variant for an+trailing annotation to the EpaDelta variant, which cannot be sorted.++Hence it is critical that these annotations are captured in the order+they appear in the original source file.++And so we use the less efficient list append to preserve the order,+knowing that in most cases the original list is empty.+-}++-- ---------------------------------------------------------------------++-- |Helper function (temporary) during transition of names+--  Discards any annotations+l2n :: LocatedAn a1 a2 -> LocatedN a2+l2n (L la a) = L (noAnnSrcSpan (locA la)) a++n2l :: LocatedN a -> LocatedA a+n2l (L la a) = L (na2la la) a++-- |Helper function (temporary) during transition of names+--  Discards any annotations+la2na :: SrcSpanAnn' a -> SrcSpanAnnN+la2na l = noAnnSrcSpan (locA l)++-- |Helper function (temporary) during transition of names+--  Discards any annotations+la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2+la2la (L la a) = L (noAnnSrcSpan (locA la)) a++l2l :: SrcSpanAnn' a -> SrcAnn ann+l2l l = noAnnSrcSpan (locA l)++-- |Helper function (temporary) during transition of names+--  Discards any annotations+na2la :: SrcSpanAnn' a -> SrcAnn ann+na2la l = noAnnSrcSpan (locA l)++reLoc :: LocatedAn a e -> Located e+reLoc (L (SrcSpanAnn _ l) a) = L l a++reLocA :: Located e -> LocatedAn ann e+reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)++reLocL :: LocatedN e -> LocatedA e+reLocL (L l a) = (L (na2la l) a)++reLocC :: LocatedN e -> LocatedC e+reLocC (L l a) = (L (na2la l) a)++reLocN :: LocatedN a -> Located a+reLocN (L (SrcSpanAnn _ l) a) = L l a++-- ---------------------------------------------------------------------++realSrcSpan :: SrcSpan -> RealSrcSpan+realSrcSpan (RealSrcSpan s _) = s+realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary+  where+    l = mkRealSrcLoc (fsLit "foo") (-1) (-1)++la2r :: SrcSpanAnn' a -> RealSrcSpan+la2r l = realSrcSpan (locA l)++extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList+extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t++reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a+reAnn anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem anns) cs) l) a++reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a+reAnnC anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a++reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e+reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a++getLocAnn :: Located a  -> SrcSpanAnnA+getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l+++getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan+getLocA (L (SrcSpanAnn _ l) _) = l++noLocA :: a -> LocatedAn an a+noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)++noAnnSrcSpan :: SrcSpan -> SrcAnn ann+noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l++noSrcSpanA :: SrcAnn ann+noSrcSpanA = noAnnSrcSpan noSrcSpan++-- | Short form for 'EpAnnNotUsed'+noAnn :: EpAnn a+noAnn = EpAnnNotUsed+++addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn]+addAnns (EpAnn l as1 cs) as2 cs2+  = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2)+addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed+addAnns EpAnnNotUsed [] (EpaCommentsBalanced [] []) = EpAnnNotUsed+addAnns EpAnnNotUsed as cs = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) as cs++-- AZ:TODO use widenSpan here too+addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA+addAnnsA (SrcSpanAnn (EpAnn l as1 cs) loc) as2 cs2+  = SrcSpanAnn (EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)) loc+addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaComments [])+  = SrcSpanAnn EpAnnNotUsed loc+addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaCommentsBalanced [] [])+  = SrcSpanAnn EpAnnNotUsed loc+addAnnsA (SrcSpanAnn EpAnnNotUsed loc) as cs+  = SrcSpanAnn (EpAnn (spanAsAnchor loc) (AnnListItem as) cs) loc++-- | The annotations need to all come after the anchor.  Make sure+-- this is the case.+widenSpan :: SrcSpan -> [AddEpAnn] -> SrcSpan+widenSpan s as = foldl combineSrcSpans s (go as)+  where+    go [] = []+    go (AddEpAnn _ (EpaSpan s):rest) = RealSrcSpan s Nothing : go rest+    go (AddEpAnn _ (EpaDelta _ _):rest) = go rest++-- | The annotations need to all come after the anchor.  Make sure+-- this is the case.+widenRealSpan :: RealSrcSpan -> [AddEpAnn] -> RealSrcSpan+widenRealSpan s as = foldl combineRealSrcSpans s (go as)+  where+    go [] = []+    go (AddEpAnn _ (EpaSpan s):rest) = s : go rest+    go (AddEpAnn _ (EpaDelta _ _):rest) =     go rest++widenAnchor :: Anchor -> [AddEpAnn] -> Anchor+widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op++widenAnchorR :: Anchor -> RealSrcSpan -> Anchor+widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op++widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an+widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as)++epAnnAnnsL :: EpAnn a -> [a]+epAnnAnnsL EpAnnNotUsed = []+epAnnAnnsL (EpAnn _ anns _) = [anns]++epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn]+epAnnAnns EpAnnNotUsed = []+epAnnAnns (EpAnn _ anns _) = anns++annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn]+annParen2AddEpAnn EpAnnNotUsed = []+annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _)+  = [AddEpAnn ai o, AddEpAnn ac c]+  where+    (ai,ac) = parenTypeKws pt++epAnnComments :: EpAnn an -> EpAnnComments+epAnnComments EpAnnNotUsed = EpaComments []+epAnnComments (EpAnn _ _ cs) = cs++-- ---------------------------------------------------------------------+-- sortLocatedA :: [LocatedA a] -> [LocatedA a]+sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]+sortLocatedA = sortBy (leftmost_smallest `on` getLocA)++mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b+mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)++-- AZ:TODO: move this somewhere sane++combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a+combineLocsA (L a _) (L b _) = combineSrcSpansA a b++combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a+combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)+  = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of+      SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l+      SrcSpanAnn (EpAnn anc an cs) l ->+        SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l++-- | Combine locations from two 'Located' things and add them to a third thing+addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3+addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c++addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3+addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c++-- ---------------------------------------------------------------------+-- Utilities for manipulating EpAnnComments+-- ---------------------------------------------------------------------++getFollowingComments :: EpAnnComments -> [LEpaComment]+getFollowingComments (EpaComments _) = []+getFollowingComments (EpaCommentsBalanced _ cs) = cs++setFollowingComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+setFollowingComments (EpaComments ls) cs           = EpaCommentsBalanced ls cs+setFollowingComments (EpaCommentsBalanced ls _) cs = EpaCommentsBalanced ls cs++setPriorComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments+setPriorComments (EpaComments _) cs            = EpaComments cs+setPriorComments (EpaCommentsBalanced _ ts) cs = EpaCommentsBalanced cs ts++-- ---------------------------------------------------------------------+-- Comment-only annotations+-- ---------------------------------------------------------------------++-- TODO:AZ I think EpAnnCO is not needed+type EpAnnCO = EpAnn NoEpAnns -- ^ Api Annotations for comments only++data NoEpAnns = NoEpAnns+  deriving (Data,Eq,Ord)++noComments ::EpAnnCO+noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments++-- TODO:AZ get rid of this+placeholderRealSpan :: RealSrcSpan+placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1))++comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO+comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs++-- ---------------------------------------------------------------------+-- Utilities for managing comments in an `EpAnn a` structure.+-- ---------------------------------------------------------------------++-- | Add additional comments to a 'SrcAnn', used for manipulating the+-- AST prior to exact printing the changed one.+addCommentsToSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann+addCommentsToSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs+  = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc+addCommentsToSrcAnn (SrcSpanAnn (EpAnn a an cs) loc) cs'+  = SrcSpanAnn (EpAnn a an (cs <> cs')) loc++-- | Replace any existing comments on a 'SrcAnn', used for manipulating the+-- AST prior to exact printing the changed one.+setCommentsSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann+setCommentsSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs+  = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc+setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs+  = SrcSpanAnn (EpAnn a an cs) loc++-- | Add additional comments, used for manipulating the+-- AST prior to exact printing the changed one.+addCommentsToEpAnn :: (Monoid a)+  => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a+addCommentsToEpAnn loc EpAnnNotUsed cs+  = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs+addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs)++-- | Replace any existing comments, used for manipulating the+-- AST prior to exact printing the changed one.+setCommentsEpAnn :: (Monoid a)+  => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a+setCommentsEpAnn loc EpAnnNotUsed cs+  = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs+setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs++-- | Transfer comments and trailing items from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)+transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to+  = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to')+  where+    to' = case to of+      (SrcSpanAnn EpAnnNotUsed loc)+        ->  SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc+      (SrcSpanAnn (EpAnn a an' cs') loc)+        -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc++-- | Remove the exact print annotations payload, leaving only the+-- anchor and comments.+commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann+commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc+commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)++-- | Remove the comments, leaving the exact print annotations payload+removeCommentsA :: SrcAnn ann -> SrcAnn ann+removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc+removeCommentsA (SrcSpanAnn (EpAnn a an _) loc)+  = (SrcSpanAnn (EpAnn a an emptyComments) loc)++-- ---------------------------------------------------------------------+-- Semigroup instances, to allow easy combination of annotaion elements+-- ---------------------------------------------------------------------++instance (Semigroup an) => Semigroup (SrcSpanAnn' an) where+  (SrcSpanAnn a1 l1) <> (SrcSpanAnn a2 l2) = SrcSpanAnn (a1 <> a2) (combineSrcSpans l1 l2)+   -- The critical part about the location is its left edge, and all+   -- annotations must follow it. So we combine them which yields the+   -- largest span++instance (Semigroup a) => Semigroup (EpAnn a) where+  EpAnnNotUsed <> x = x+  x <> EpAnnNotUsed = x+  (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2)+   -- The critical part about the anchor is its left edge, and all+   -- annotations must follow it. So we combine them which yields the+   -- largest span++instance Ord Anchor where+  compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2++instance Semigroup Anchor where+  Anchor r1 o1 <> Anchor r2 _ = Anchor (combineRealSrcSpans r1 r2) o1++instance Semigroup EpAnnComments where+  EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2)+  EpaComments cs1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) as2+  EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1+  EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2)+++instance (Monoid a) => Monoid (EpAnn a) where+  mempty = EpAnnNotUsed++instance Semigroup AnnListItem where+  (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)++instance Monoid AnnListItem where+  mempty = AnnListItem []+++instance Semigroup AnnList where+  (AnnList a1 o1 c1 r1 t1) <> (AnnList a2 o2 c2 r2 t2)+    = AnnList (a1 <> a2) (c o1 o2) (c c1 c2) (r1 <> r2) (t1 <> t2)+    where+      -- Left biased combination for the open and close annotations+      c Nothing x = x+      c x Nothing = x+      c f _       = f++instance Monoid AnnList where+  mempty = AnnList Nothing Nothing Nothing [] []++instance Semigroup NameAnn where+  _ <> _ = panic "semigroup nameann"++instance Monoid NameAnn where+  mempty = NameAnnTrailing []+++instance Semigroup AnnSortKey where+  NoAnnSortKey <> x = x+  x <> NoAnnSortKey = x+  AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)++instance Monoid AnnSortKey where+  mempty = NoAnnSortKey++instance (Outputable a) => Outputable (EpAnn a) where+  ppr (EpAnn l a c)  = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c+  ppr EpAnnNotUsed = text "EpAnnNotUsed"++instance Outputable Anchor where+  ppr (Anchor a o)        = text "Anchor" <+> ppr a <+> ppr o++instance Outputable AnchorOperation where+  ppr UnchangedAnchor   = text "UnchangedAnchor"+  ppr (MovedAnchor d)   = text "MovedAnchor" <+> ppr d++instance Outputable DeltaPos where+  ppr (SameLine c) = text "SameLine" <+> ppr c+  ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c++instance Outputable (GenLocated Anchor EpaComment) where+  ppr (L l c) = text "L" <+> ppr l <+> ppr c++instance Outputable EpAnnComments where+  ppr (EpaComments cs) = text "EpaComments" <+> ppr cs+  ppr (EpaCommentsBalanced cs ts) = text "EpaCommentsBalanced" <+> ppr cs <+> ppr ts++instance (NamedThing (Located a)) => NamedThing (LocatedAn an a) where+  getName (L l a) = getName (L (locA l) a)++instance Outputable AnnContext where+  ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c++instance Outputable AnnSortKey where+  ppr NoAnnSortKey    = text "NoAnnSortKey"+  ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls++instance Outputable IsUnicodeSyntax where+  ppr = text . show++instance Binary a => Binary (LocatedL a) where+  -- We do not serialise the annotations+    put_ bh (L l x) = do+            put_ bh (locA l)+            put_ bh x++    get bh = do+            l <- get bh+            x <- get bh+            return (L (noAnnSrcSpan l) x)++instance (Outputable a) => Outputable (SrcSpanAnn' a) where+  ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l++instance (Outputable a, Outputable e)+     => Outputable (GenLocated (SrcSpanAnn' a) e) where+  ppr = pprLocated++instance Outputable AnnListItem where+  ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts++instance Outputable NameAdornment where+  ppr NameParens     = text "NameParens"+  ppr NameParensHash = text "NameParensHash"+  ppr NameBackquotes = text "NameBackquotes"+  ppr NameSquare     = text "NameSquare"++instance Outputable NameAnn where+  ppr (NameAnn a o n c t)+    = text "NameAnn" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t+  ppr (NameAnnCommas a o n c t)+    = text "NameAnnCommas" <+> ppr a <+> ppr o <+> ppr n <+> ppr c <+> ppr t+  ppr (NameAnnOnly a o c t)+    = text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t+  ppr (NameAnnRArrow n t)+    = text "NameAnnRArrow" <+> ppr n <+> ppr t+  ppr (NameAnnQuote q n t)+    = text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t+  ppr (NameAnnTrailing t)+    = text "NameAnnTrailing" <+> ppr t++instance Outputable AnnList where+  ppr (AnnList a o c r t)+    = text "AnnList" <+> ppr a <+> ppr o <+> ppr c <+> ppr r <+> ppr t++instance Outputable AnnPragma where+  ppr (AnnPragma o c r) = text "AnnPragma" <+> ppr o <+> ppr c <+> ppr r

GHC/Parser/CharClass.hs view

@@ -18,7 +18,6 @@  import GHC.Prelude -import Data.Bits        ( Bits((.&.),(.|.)) ) import Data.Char        ( ord, chr ) import Data.Word import GHC.Utils.Panic

+ GHC/Parser/Errors.hs view

@@ -0,0 +1,430 @@+module GHC.Parser.Errors+   ( PsWarning(..)+   , TransLayoutReason(..)+   , OperatorWhitespaceSymbol(..)+   , OperatorWhitespaceOccurrence(..)+   , NumUnderscoreReason(..)+   , PsError(..)+   , PsErrorDesc(..)+   , LexErr(..)+   , CmmParserError(..)+   , LexErrKind(..)+   , Hint(..)+   , StarIsType (..)+   )+where++import GHC.Prelude+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader (RdrName)+import GHC.Types.Name.Occurrence (OccName)+import GHC.Parser.Types+import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Hs.Expr+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Hs.Lit+import GHC.Hs.Decls+import GHC.Core.Coercion.Axiom (Role)+import GHC.Utils.Outputable (SDoc)+import GHC.Data.FastString+import GHC.Unit.Module.Name++-- | A warning that might arise during parsing.+data PsWarning++     -- | Warn when tabulations are found+   = PsWarnTab+      { tabFirst :: !SrcSpan -- ^ First occurrence of a tab+      , tabCount :: !Word    -- ^ Number of other occurrences+      }++   | PsWarnTransitionalLayout !SrcSpan !TransLayoutReason+      -- ^ Transitional layout warnings++   | PsWarnUnrecognisedPragma !SrcSpan+      -- ^ Unrecognised pragma++   | PsWarnHaddockInvalidPos !SrcSpan+      -- ^ Invalid Haddock comment position++   | PsWarnHaddockIgnoreMulti !SrcSpan+      -- ^ Multiple Haddock comment for the same entity++   | PsWarnStarBinder !SrcSpan+      -- ^ Found binding occurrence of "*" while StarIsType is enabled++   | PsWarnStarIsType !SrcSpan+      -- ^ Using "*" for "Type" without StarIsType enabled++   | PsWarnImportPreQualified !SrcSpan+      -- ^ Pre qualified import with 'WarnPrepositiveQualifiedModule' enabled++   | PsWarnOperatorWhitespaceExtConflict !SrcSpan !OperatorWhitespaceSymbol+   | PsWarnOperatorWhitespace !SrcSpan !FastString !OperatorWhitespaceOccurrence++-- | The operator symbol in the 'WarnOperatorWhitespaceExtConflict' warning.+data OperatorWhitespaceSymbol+   = OperatorWhitespaceSymbol_PrefixPercent+   | OperatorWhitespaceSymbol_PrefixDollar+   | OperatorWhitespaceSymbol_PrefixDollarDollar++-- | The operator occurrence type in the 'WarnOperatorWhitespace' warning.+data OperatorWhitespaceOccurrence+   = OperatorWhitespaceOccurrence_Prefix+   | OperatorWhitespaceOccurrence_Suffix+   | OperatorWhitespaceOccurrence_TightInfix++data TransLayoutReason+   = TransLayout_Where -- ^ "`where' clause at the same depth as implicit layout block"+   | TransLayout_Pipe  -- ^ "`|' at the same depth as implicit layout block")++data PsError = PsError+   { errDesc  :: !PsErrorDesc   -- ^ Error description+   , errHints :: ![Hint]      -- ^ Hints+   , errLoc   :: !SrcSpan     -- ^ Error position+   }++data PsErrorDesc+   = PsErrLambdaCase+      -- ^ LambdaCase syntax used without the extension enabled++   | PsErrNumUnderscores !NumUnderscoreReason+      -- ^ Underscores in literals without the extension enabled++   | PsErrPrimStringInvalidChar+      -- ^ Invalid character in primitive string++   | PsErrMissingBlock+      -- ^ Missing block++   | PsErrLexer !LexErr !LexErrKind+      -- ^ Lexer error++   | PsErrSuffixAT+      -- ^ Suffix occurrence of `@`++   | PsErrParse !String+      -- ^ Parse errors++   | PsErrCmmLexer+      -- ^ Cmm lexer error++   | PsErrUnsupportedBoxedSumExpr !(SumOrTuple (HsExpr GhcPs))+      -- ^ Unsupported boxed sum in expression++   | PsErrUnsupportedBoxedSumPat !(SumOrTuple (PatBuilder GhcPs))+      -- ^ Unsupported boxed sum in pattern++   | PsErrUnexpectedQualifiedConstructor !RdrName+      -- ^ Unexpected qualified constructor++   | PsErrTupleSectionInPat+      -- ^ Tuple section in pattern context++   | PsErrIllegalBangPattern !(Pat GhcPs)+      -- ^ Bang-pattern without BangPattterns enabled++   | PsErrOpFewArgs !StarIsType !RdrName+      -- ^ Operator applied to too few arguments++   | PsErrImportQualifiedTwice+      -- ^ Import: multiple occurrences of 'qualified'++   | PsErrImportPostQualified+      -- ^ Post qualified import without 'ImportQualifiedPost'++   | PsErrIllegalExplicitNamespace+      -- ^ Explicit namespace keyword without 'ExplicitNamespaces'++   | PsErrVarForTyCon !RdrName+      -- ^ Expecting a type constructor but found a variable++   | PsErrIllegalPatSynExport+      -- ^ Illegal export form allowed by PatternSynonyms++   | PsErrMalformedEntityString+      -- ^ Malformed entity string++   | PsErrDotsInRecordUpdate+      -- ^ Dots used in record update++   | PsErrPrecedenceOutOfRange !Int+      -- ^ Precedence out of range++   | PsErrOverloadedRecordDotInvalid+      -- ^ Invalid use of record dot syntax `.'++   | PsErrOverloadedRecordUpdateNotEnabled+      -- ^ `OverloadedRecordUpdate` is not enabled.++   | PsErrOverloadedRecordUpdateNoQualifiedFields+      -- ^ Can't use qualified fields when OverloadedRecordUpdate is enabled.++   | PsErrInvalidDataCon !(HsType GhcPs)+      -- ^ Cannot parse data constructor in a data/newtype declaration++   | PsErrInvalidInfixDataCon !(HsType GhcPs) !RdrName !(HsType GhcPs)+      -- ^ Cannot parse data constructor in a data/newtype declaration++   | PsErrUnpackDataCon+      -- ^ UNPACK applied to a data constructor++   | PsErrUnexpectedKindAppInDataCon !DataConBuilder !(HsType GhcPs)+      -- ^ Unexpected kind application in data/newtype declaration++   | PsErrInvalidRecordCon !(PatBuilder GhcPs)+      -- ^ Not a record constructor++   | PsErrIllegalUnboxedStringInPat !(HsLit GhcPs)+      -- ^ Illegal unboxed string literal in pattern++   | PsErrDoNotationInPat+      -- ^ Do-notation in pattern++   | PsErrIfTheElseInPat+      -- ^ If-then-else syntax in pattern++   | PsErrLambdaCaseInPat+      -- ^ Lambda-case in pattern++   | PsErrCaseInPat+      -- ^ case..of in pattern++   | PsErrLetInPat+      -- ^ let-syntax in pattern++   | PsErrLambdaInPat+      -- ^ Lambda-syntax in pattern++   | PsErrArrowExprInPat !(HsExpr GhcPs)+      -- ^ Arrow expression-syntax in pattern++   | PsErrArrowCmdInPat !(HsCmd GhcPs)+      -- ^ Arrow command-syntax in pattern++   | PsErrArrowCmdInExpr !(HsCmd GhcPs)+      -- ^ Arrow command-syntax in expression++   | PsErrViewPatInExpr !(LHsExpr GhcPs) !(LHsExpr GhcPs)+      -- ^ View-pattern in expression++   | PsErrTypeAppWithoutSpace !RdrName !(LHsExpr GhcPs)+      -- ^ Type-application without space before '@'++   | PsErrLazyPatWithoutSpace !(LHsExpr GhcPs)+      -- ^ Lazy-pattern ('~') without space after it++   | PsErrBangPatWithoutSpace !(LHsExpr GhcPs)+      -- ^ Bang-pattern ('!') without space after it++   | PsErrUnallowedPragma !(HsPragE GhcPs)+      -- ^ Pragma not allowed in this position++   | PsErrQualifiedDoInCmd !ModuleName+      -- ^ Qualified do block in command++   | PsErrInvalidInfixHole+      -- ^ Invalid infix hole, expected an infix operator++   | PsErrSemiColonsInCondExpr+      -- ^ Unexpected semi-colons in conditional expression+         !(HsExpr GhcPs) -- ^ conditional expr+         !Bool           -- ^ "then" semi-colon?+         !(HsExpr GhcPs) -- ^ "then" expr+         !Bool           -- ^ "else" semi-colon?+         !(HsExpr GhcPs) -- ^ "else" expr++   | PsErrSemiColonsInCondCmd+      -- ^ Unexpected semi-colons in conditional command+         !(HsExpr GhcPs) -- ^ conditional expr+         !Bool           -- ^ "then" semi-colon?+         !(HsCmd GhcPs)  -- ^ "then" expr+         !Bool           -- ^ "else" semi-colon?+         !(HsCmd GhcPs)  -- ^ "else" expr++   | PsErrAtInPatPos+      -- ^ @-operator in a pattern position++   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)+      -- ^ Unexpected lambda command in function application++   | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs)+      -- ^ Unexpected case command in function application++   | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)+      -- ^ Unexpected if command in function application++   | PsErrLetCmdInFunAppCmd !(LHsCmd GhcPs)+      -- ^ Unexpected let command in function application++   | PsErrDoCmdInFunAppCmd !(LHsCmd GhcPs)+      -- ^ Unexpected do command in function application++   | PsErrDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)+      -- ^ Unexpected do block in function application++   | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs)+      -- ^ Unexpected mdo block in function application++   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)+      -- ^ Unexpected lambda expression in function application++   | PsErrCaseInFunAppExpr !(LHsExpr GhcPs)+      -- ^ Unexpected case expression in function application++   | PsErrLambdaCaseInFunAppExpr !(LHsExpr GhcPs)+      -- ^ Unexpected lambda-case expression in function application++   | PsErrLetInFunAppExpr !(LHsExpr GhcPs)+      -- ^ Unexpected let expression in function application++   | PsErrIfInFunAppExpr !(LHsExpr GhcPs)+      -- ^ Unexpected if expression in function application++   | PsErrProcInFunAppExpr !(LHsExpr GhcPs)+      -- ^ Unexpected proc expression in function application++   | PsErrMalformedTyOrClDecl !(LHsType GhcPs)+      -- ^ Malformed head of type or class declaration++   | PsErrIllegalWhereInDataDecl+      -- ^ Illegal 'where' keyword in data declaration++   | PsErrIllegalDataTypeContext !(LHsContext GhcPs)+      -- ^ Illegal datatyp context++   | PsErrParseErrorOnInput !OccName+      -- ^ Parse error on input++   | PsErrMalformedDecl !SDoc !RdrName+      -- ^ Malformed ... declaration for ...++   | PsErrUnexpectedTypeAppInDecl !(LHsType GhcPs) !SDoc !RdrName+      -- ^ Unexpected type application in a declaration++   | PsErrNotADataCon !RdrName+      -- ^ Not a data constructor++   | PsErrRecordSyntaxInPatSynDecl !(LPat GhcPs)+      -- ^ Record syntax used in pattern synonym declaration++   | PsErrEmptyWhereInPatSynDecl !RdrName+      -- ^ Empty 'where' clause in pattern-synonym declaration++   | PsErrInvalidWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)+      -- ^ Invalid binding name in 'where' clause of pattern-synonym declaration++   | PsErrNoSingleWhereBindInPatSynDecl !RdrName !(HsDecl GhcPs)+      -- ^ Multiple bindings in 'where' clause of pattern-synonym declaration++   | PsErrDeclSpliceNotAtTopLevel !(SpliceDecl GhcPs)+      -- ^ Declaration splice not a top-level++   | PsErrInferredTypeVarNotAllowed+      -- ^ Inferred type variables not allowed here++   | PsErrMultipleNamesInStandaloneKindSignature [LIdP GhcPs]+      -- ^ Multiple names in standalone kind signatures++   | PsErrIllegalImportBundleForm+      -- ^ Illegal import bundle form++   | PsErrIllegalRoleName !FastString [Role]+      -- ^ Illegal role name++   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)+      -- ^ Invalid type signature++   | PsErrUnexpectedTypeInDecl !(LHsType GhcPs) !SDoc !RdrName [LHsTypeArg GhcPs] !SDoc+      -- ^ Unexpected type in declaration++   | PsErrExpectedHyphen+      -- ^ Expected a hyphen++   | PsErrSpaceInSCC+      -- ^ Found a space in a SCC++   | PsErrEmptyDoubleQuotes !Bool-- Is TH on?+      -- ^ Found two single quotes++   | PsErrInvalidPackageName !FastString+      -- ^ Invalid package name++   | PsErrInvalidRuleActivationMarker+      -- ^ Invalid rule activation marker++   | PsErrLinearFunction+      -- ^ Linear function found but LinearTypes not enabled++   | PsErrMultiWayIf+      -- ^ Multi-way if-expression found but MultiWayIf not enabled++   | PsErrExplicitForall !Bool -- is Unicode forall?+      -- ^ Explicit forall found but no extension allowing it is enabled++   | PsErrIllegalQualifiedDo !SDoc+      -- ^ Found qualified-do without QualifiedDo enabled++   | PsErrCmmParser !CmmParserError+      -- ^ Cmm parser error++   | PsErrIllegalTraditionalRecordSyntax !SDoc+      -- ^ Illegal traditional record syntax+      --+      -- TODO: distinguish errors without using SDoc++   | PsErrParseErrorInCmd !SDoc+      -- ^ Parse error in command+      --+      -- TODO: distinguish errors without using SDoc++   | PsErrParseErrorInPat !SDoc+      -- ^ Parse error in pattern+      --+      -- TODO: distinguish errors without using SDoc+++newtype StarIsType = StarIsType Bool++data NumUnderscoreReason+   = NumUnderscore_Integral+   | NumUnderscore_Float+   deriving (Show,Eq,Ord)++data Hint+   = SuggestTH+   | SuggestRecursiveDo+   | SuggestDo+   | SuggestMissingDo+   | SuggestLetInDo+   | SuggestPatternSynonyms+   | SuggestInfixBindMaybeAtPat !RdrName+   | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors+++data LexErrKind+   = LexErrKind_EOF        -- ^ End of input+   | LexErrKind_UTF8       -- ^ UTF-8 decoding error+   | LexErrKind_Char !Char -- ^ Error at given character+   deriving (Show,Eq,Ord)++data LexErr+   = LexError               -- ^ Lexical error+   | LexUnknownPragma       -- ^ Unknown pragma+   | LexErrorInPragma       -- ^ Lexical error in pragma+   | LexNumEscapeRange      -- ^ Numeric escape sequence out of range+   | LexStringCharLit       -- ^ Llexical error in string/character literal+   | LexStringCharLitEOF    -- ^ Unexpected end-of-file in string/character literal+   | LexUnterminatedComment -- ^ Unterminated `{-'+   | LexUnterminatedOptions -- ^ Unterminated OPTIONS pragma+   | LexUnterminatedQQ      -- ^ Unterminated quasiquotation++-- | Errors from the Cmm parser+data CmmParserError+   = CmmUnknownPrimitive    !FastString -- ^ Unknown Cmm primitive+   | CmmUnknownMacro        !FastString -- ^ Unknown macro+   | CmmUnknownCConv        !String     -- ^ Unknown calling convention+   | CmmUnrecognisedSafety  !String     -- ^ Unrecognised safety+   | CmmUnrecognisedHint    !String     -- ^ Unrecognised hint

+ GHC/Parser/Errors/Ppr.hs view

@@ -0,0 +1,620 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}++module GHC.Parser.Errors.Ppr+   ( pprWarning+   , pprError+   )+where++import GHC.Prelude+import GHC.Driver.Flags+import GHC.Parser.Errors+import GHC.Parser.Types+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader (starInfo, rdrNameOcc, opIsAt, mkUnqual)+import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName)+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Data.FastString+import GHC.Hs.Expr (prependQualified,HsExpr(..))+import GHC.Hs.Type (pprLHsContext)+import GHC.Builtin.Names (allNameStrings)+import GHC.Builtin.Types (filterCTuple)++mkParserErr :: SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc+mkParserErr span doc = MsgEnvelope+   { errMsgSpan        = span+   , errMsgContext     = alwaysQualify+   , errMsgDiagnostic  = mkDecorated [doc]+   , errMsgSeverity    = SevError+   , errMsgReason      = NoReason+   }++mkParserWarn :: WarningFlag -> SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc+mkParserWarn flag span doc = MsgEnvelope+   { errMsgSpan        = span+   , errMsgContext     = alwaysQualify+   , errMsgDiagnostic  = mkDecorated [doc]+   , errMsgSeverity    = SevWarning+   , errMsgReason      = Reason flag+   }++pprWarning :: PsWarning -> MsgEnvelope DecoratedSDoc+pprWarning = \case+   PsWarnTab loc tc+      -> mkParserWarn Opt_WarnTabs loc $+          text "Tab character found here"+            <> (if tc == 1+                then text ""+                else text ", and in" <+> speakNOf (fromIntegral (tc - 1)) (text "further location"))+            <> text "."+            $+$ text "Please use spaces instead."++   PsWarnTransitionalLayout loc reason+      -> mkParserWarn Opt_WarnAlternativeLayoutRuleTransitional loc $+            text "transitional layout will not be accepted in the future:"+            $$ text (case reason of+               TransLayout_Where -> "`where' clause at the same depth as implicit layout block"+               TransLayout_Pipe  -> "`|' at the same depth as implicit layout block"+            )++   PsWarnUnrecognisedPragma loc+      -> mkParserWarn Opt_WarnUnrecognisedPragmas loc $+            text "Unrecognised pragma"++   PsWarnHaddockInvalidPos loc+      -> mkParserWarn Opt_WarnInvalidHaddock loc $+            text "A Haddock comment cannot appear in this position and will be ignored."++   PsWarnHaddockIgnoreMulti loc+      -> mkParserWarn Opt_WarnInvalidHaddock loc $+            text "Multiple Haddock comments for a single entity are not allowed." $$+            text "The extraneous comment will be ignored."++   PsWarnStarBinder loc+      -> mkParserWarn Opt_WarnStarBinder loc $+            text "Found binding occurrence of" <+> quotes (text "*")+            <+> text "yet StarIsType is enabled."+         $$ text "NB. To use (or export) this operator in"+            <+> text "modules with StarIsType,"+         $$ text "    including the definition module, you must qualify it."++   PsWarnStarIsType loc+      -> mkParserWarn Opt_WarnStarIsType loc $+             text "Using" <+> quotes (text "*")+             <+> text "(or its Unicode variant) to mean"+             <+> quotes (text "Data.Kind.Type")+          $$ text "relies on the StarIsType extension, which will become"+          $$ text "deprecated in the future."+          $$ text "Suggested fix: use" <+> quotes (text "Type")+           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."++   PsWarnImportPreQualified loc+      -> mkParserWarn Opt_WarnPrepositiveQualifiedModule loc $+            text "Found" <+> quotes (text "qualified")+             <+> text "in prepositive position"+         $$ text "Suggested fix: place " <+> quotes (text "qualified")+             <+> text "after the module name instead."+         $$ text "To allow this, enable language extension 'ImportQualifiedPost'"++   PsWarnOperatorWhitespaceExtConflict loc sym+      -> mkParserWarn Opt_WarnOperatorWhitespaceExtConflict loc $+         let mk_prefix_msg operator_symbol extension_name syntax_meaning =+                  text "The prefix use of a" <+> quotes (text operator_symbol)+                    <+> text "would denote" <+> text syntax_meaning+               $$ nest 2 (text "were the" <+> text extension_name <+> text "extension enabled.")+               $$ text "Suggested fix: add whitespace after the"+                    <+> quotes (text operator_symbol) <> char '.'+         in+         case sym of+           OperatorWhitespaceSymbol_PrefixPercent -> mk_prefix_msg "%" "LinearTypes" "a multiplicity annotation"+           OperatorWhitespaceSymbol_PrefixDollar -> mk_prefix_msg "$" "TemplateHaskell" "an untyped splice"+           OperatorWhitespaceSymbol_PrefixDollarDollar -> mk_prefix_msg "$$" "TemplateHaskell" "a typed splice"+++   PsWarnOperatorWhitespace loc sym occ_type+      -> mkParserWarn Opt_WarnOperatorWhitespace loc $+         let mk_msg occ_type_str =+                  text "The" <+> text occ_type_str <+> text "use of a" <+> quotes (ftext sym)+                    <+> text "might be repurposed as special syntax"+               $$ nest 2 (text "by a future language extension.")+               $$ text "Suggested fix: add whitespace around it."+         in+         case occ_type of+           OperatorWhitespaceOccurrence_Prefix -> mk_msg "prefix"+           OperatorWhitespaceOccurrence_Suffix -> mk_msg "suffix"+           OperatorWhitespaceOccurrence_TightInfix -> mk_msg "tight infix"++pprError :: PsError -> MsgEnvelope DecoratedSDoc+pprError err = mkParserErr (errLoc err) $ vcat+   (pp_err (errDesc err) : map pp_hint (errHints err))++pp_err :: PsErrorDesc -> SDoc+pp_err = \case+   PsErrLambdaCase+      -> text "Illegal lambda-case (use LambdaCase)"++   PsErrNumUnderscores reason+      -> text $ case reason of+            NumUnderscore_Integral -> "Use NumericUnderscores to allow underscores in integer literals"+            NumUnderscore_Float    -> "Use NumericUnderscores to allow underscores in floating literals"++   PsErrPrimStringInvalidChar+      -> text "primitive string literal must contain only characters <= \'\\xFF\'"++   PsErrMissingBlock+      -> text "Missing block"++   PsErrLexer err kind+      -> hcat+         [ text $ case err of+            LexError               -> "lexical error"+            LexUnknownPragma       -> "unknown pragma"+            LexErrorInPragma       -> "lexical error in pragma"+            LexNumEscapeRange      -> "numeric escape sequence out of range"+            LexStringCharLit       -> "lexical error in string/character literal"+            LexStringCharLitEOF    -> "unexpected end-of-file in string/character literal"+            LexUnterminatedComment -> "unterminated `{-'"+            LexUnterminatedOptions -> "unterminated OPTIONS pragma"+            LexUnterminatedQQ      -> "unterminated quasiquotation"+++         , text $ case kind of+            LexErrKind_EOF    -> " at end of input"+            LexErrKind_UTF8   -> " (UTF-8 decoding error)"+            LexErrKind_Char c -> " at character " ++ show c+         ]++   PsErrSuffixAT+      -> text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."++   PsErrParse token+      | null token+      -> text "parse error (possibly incorrect indentation or mismatched brackets)"++      | otherwise+      -> text "parse error on input" <+> quotes (text token)++   PsErrCmmLexer+      -> text "Cmm lexical error"++   PsErrUnsupportedBoxedSumExpr s+      -> hang (text "Boxed sums not supported:") 2+              (pprSumOrTuple Boxed s)++   PsErrUnsupportedBoxedSumPat s+      -> hang (text "Boxed sums not supported:") 2+              (pprSumOrTuple Boxed s)++   PsErrUnexpectedQualifiedConstructor v+      -> hang (text "Expected an unqualified type constructor:") 2+              (ppr v)++   PsErrTupleSectionInPat+      -> text "Tuple section in pattern context"++   PsErrIllegalBangPattern e+      -> text "Illegal bang-pattern (use BangPatterns):" $$ ppr e++   PsErrOpFewArgs (StarIsType star_is_type) op+      -> text "Operator applied to too few arguments:" <+> ppr op+         $$ starInfo star_is_type op++   PsErrImportQualifiedTwice+      -> text "Multiple occurrences of 'qualified'"++   PsErrImportPostQualified+      -> text "Found" <+> quotes (text "qualified")+          <+> text "in postpositive position. "+         $$ text "To allow this, enable language extension 'ImportQualifiedPost'"++   PsErrIllegalExplicitNamespace+      -> text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"++   PsErrVarForTyCon name+      -> text "Expecting a type constructor but found a variable,"+           <+> quotes (ppr name) <> text "."+         $$ if isSymOcc $ rdrNameOcc name+            then text "If" <+> quotes (ppr name) <+> text "is a type constructor"+                  <+> text "then enable ExplicitNamespaces and use the 'type' keyword."+            else empty++   PsErrIllegalPatSynExport+      -> text "Illegal export form (use PatternSynonyms to enable)"++   PsErrMalformedEntityString+      -> text "Malformed entity string"++   PsErrDotsInRecordUpdate+      -> text "You cannot use `..' in a record update"++   PsErrPrecedenceOutOfRange i+      -> text "Precedence out of range: " <> int i++   PsErrOverloadedRecordDotInvalid+      -> text "Use of OverloadedRecordDot '.' not valid ('.' isn't allowed when constructing records or in record patterns)"++   PsErrOverloadedRecordUpdateNoQualifiedFields+      -> text "Fields cannot be qualified when OverloadedRecordUpdate is enabled"++   PsErrOverloadedRecordUpdateNotEnabled+      -> text "OverloadedRecordUpdate needs to be enabled"++   PsErrInvalidDataCon t+      -> hang (text "Cannot parse data constructor in a data/newtype declaration:") 2+              (ppr t)++   PsErrInvalidInfixDataCon lhs tc rhs+      -> hang (text "Cannot parse an infix data constructor in a data/newtype declaration:")+            2 (ppr lhs <+> ppr tc <+> ppr rhs)++   PsErrUnpackDataCon+      -> text "{-# UNPACK #-} cannot be applied to a data constructor."++   PsErrUnexpectedKindAppInDataCon lhs ki+      -> hang (text "Unexpected kind application in a data/newtype declaration:") 2+              (ppr lhs <+> text "@" <> ppr ki)++   PsErrInvalidRecordCon p+      -> text "Not a record constructor:" <+> ppr p++   PsErrIllegalUnboxedStringInPat lit+      -> text "Illegal unboxed string literal in pattern:" $$ ppr lit++   PsErrDoNotationInPat+      -> text "do-notation in pattern"++   PsErrIfTheElseInPat+      -> text "(if ... then ... else ...)-syntax in pattern"++   PsErrLambdaCaseInPat+      -> text "(\\case ...)-syntax in pattern"++   PsErrCaseInPat+      -> text "(case ... of ...)-syntax in pattern"++   PsErrLetInPat+      -> text "(let ... in ...)-syntax in pattern"++   PsErrLambdaInPat+      -> text "Lambda-syntax in pattern."+         $$ text "Pattern matching on functions is not possible."++   PsErrArrowExprInPat e+      -> text "Expression syntax in pattern:" <+> ppr e++   PsErrArrowCmdInPat c+      -> text "Command syntax in pattern:" <+> ppr c++   PsErrArrowCmdInExpr c+      -> vcat+         [ text "Arrow command found where an expression was expected:"+         , nest 2 (ppr c)+         ]++   PsErrViewPatInExpr a b+      -> sep [ text "View pattern in expression context:"+             , nest 4 (ppr a <+> text "->" <+> ppr b)+             ]++   PsErrTypeAppWithoutSpace v e+      -> sep [ text "@-pattern in expression context:"+             , nest 4 (pprPrefixOcc v <> text "@" <> ppr e)+             ]+         $$ text "Type application syntax requires a space before '@'"+++   PsErrLazyPatWithoutSpace e+      -> sep [ text "Lazy pattern in expression context:"+             , nest 4 (text "~" <> ppr e)+             ]+         $$ text "Did you mean to add a space after the '~'?"++   PsErrBangPatWithoutSpace e+      -> sep [ text "Bang pattern in expression context:"+             , nest 4 (text "!" <> ppr e)+             ]+         $$ text "Did you mean to add a space after the '!'?"++   PsErrUnallowedPragma prag+      -> hang (text "A pragma is not allowed in this position:") 2+              (ppr prag)++   PsErrQualifiedDoInCmd m+      -> hang (text "Parse error in command:") 2 $+            text "Found a qualified" <+> ppr m <> text ".do block in a command, but"+            $$ text "qualified 'do' is not supported in commands."++   PsErrParseErrorInCmd s+      -> hang (text "Parse error in command:") 2 s++   PsErrParseErrorInPat s+      -> text "Parse error in pattern:" <+> s+++   PsErrInvalidInfixHole+      -> text "Invalid infix hole, expected an infix operator"++   PsErrSemiColonsInCondExpr c st t se e+      -> text "Unexpected semi-colons in conditional:"+         $$ nest 4 expr+         $$ text "Perhaps you meant to use DoAndIfThenElse?"+         where+            pprOptSemi True  = semi+            pprOptSemi False = empty+            expr = text "if"   <+> ppr c <> pprOptSemi st <+>+                   text "then" <+> ppr t <> pprOptSemi se <+>+                   text "else" <+> ppr e++   PsErrSemiColonsInCondCmd c st t se e+      -> text "Unexpected semi-colons in conditional:"+         $$ nest 4 expr+         $$ text "Perhaps you meant to use DoAndIfThenElse?"+         where+            pprOptSemi True  = semi+            pprOptSemi False = empty+            expr = text "if"   <+> ppr c <> pprOptSemi st <+>+                   text "then" <+> ppr t <> pprOptSemi se <+>+                   text "else" <+> ppr e+++   PsErrAtInPatPos+      -> text "Found a binding for the"+         <+> quotes (text "@")+         <+> text "operator in a pattern position."+         $$ perhaps_as_pat++   PsErrLambdaCmdInFunAppCmd a+      -> pp_unexpected_fun_app (text "lambda command") a++   PsErrCaseCmdInFunAppCmd a+      -> pp_unexpected_fun_app (text "case command") a++   PsErrIfCmdInFunAppCmd a+      -> pp_unexpected_fun_app (text "if command") a++   PsErrLetCmdInFunAppCmd a+      -> pp_unexpected_fun_app (text "let command") a++   PsErrDoCmdInFunAppCmd a+      -> pp_unexpected_fun_app (text "do command") a++   PsErrDoInFunAppExpr m a+      -> pp_unexpected_fun_app (prependQualified m (text "do block")) a++   PsErrMDoInFunAppExpr m a+      -> pp_unexpected_fun_app (prependQualified m (text "mdo block")) a++   PsErrLambdaInFunAppExpr a+      -> pp_unexpected_fun_app (text "lambda expression") a++   PsErrCaseInFunAppExpr a+      -> pp_unexpected_fun_app (text "case expression") a++   PsErrLambdaCaseInFunAppExpr a+      -> pp_unexpected_fun_app (text "lambda-case expression") a++   PsErrLetInFunAppExpr a+      -> pp_unexpected_fun_app (text "let expression") a++   PsErrIfInFunAppExpr a+      -> pp_unexpected_fun_app (text "if expression") a++   PsErrProcInFunAppExpr a+      -> pp_unexpected_fun_app (text "proc expression") a++   PsErrMalformedTyOrClDecl ty+      -> text "Malformed head of type or class declaration:"+         <+> ppr ty++   PsErrIllegalWhereInDataDecl+      -> vcat+            [ text "Illegal keyword 'where' in data declaration"+            , text "Perhaps you intended to use GADTs or a similar language"+            , text "extension to enable syntax: data T where"+            ]++   PsErrIllegalTraditionalRecordSyntax s+      -> text "Illegal record syntax (use TraditionalRecordSyntax):"+         <+> s++   PsErrParseErrorOnInput occ+      -> text "parse error on input" <+> ftext (occNameFS occ)++   PsErrIllegalDataTypeContext c+      -> text "Illegal datatype context (use DatatypeContexts):"+         <+> pprLHsContext (Just c)++   PsErrMalformedDecl what for+      -> text "Malformed" <+> what+         <+> text "declaration for" <+> quotes (ppr for)++   PsErrUnexpectedTypeAppInDecl ki what for+      -> vcat [ text "Unexpected type application"+                <+> text "@" <> ppr ki+              , text "In the" <+> what+                <+> text "declaration for"+                <+> quotes (ppr for)+              ]++   PsErrNotADataCon name+      -> text "Not a data constructor:" <+> quotes (ppr name)++   PsErrRecordSyntaxInPatSynDecl pat+      -> text "record syntax not supported for pattern synonym declarations:"+         $$ ppr pat++   PsErrEmptyWhereInPatSynDecl patsyn_name+      -> text "pattern synonym 'where' clause cannot be empty"+         $$ text "In the pattern synonym declaration for: "+            <+> ppr (patsyn_name)++   PsErrInvalidWhereBindInPatSynDecl patsyn_name decl+      -> text "pattern synonym 'where' clause must bind the pattern synonym's name"+         <+> quotes (ppr patsyn_name) $$ ppr decl++   PsErrNoSingleWhereBindInPatSynDecl _patsyn_name decl+      -> text "pattern synonym 'where' clause must contain a single binding:"+         $$ ppr decl++   PsErrDeclSpliceNotAtTopLevel d+      -> hang (text "Declaration splices are allowed only"+               <+> text "at the top level:")+           2 (ppr d)++   PsErrInferredTypeVarNotAllowed+      -> text "Inferred type variables are not allowed here"++   PsErrIllegalRoleName role nearby+      -> text "Illegal role name" <+> quotes (ppr role)+         $$ case nearby of+             []  -> empty+             [r] -> text "Perhaps you meant" <+> quotes (ppr r)+             -- will this last case ever happen??+             _   -> hang (text "Perhaps you meant one of these:")+                         2 (pprWithCommas (quotes . ppr) nearby)++   PsErrMultipleNamesInStandaloneKindSignature vs+      -> vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")+                2 (pprWithCommas ppr vs)+              , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details."+              ]++   PsErrIllegalImportBundleForm+      -> text "Illegal import form, this syntax can only be used to bundle"+         $+$ text "pattern synonyms with types in module exports."++   PsErrInvalidTypeSignature lhs+      -> text "Invalid type signature:"+         <+> ppr lhs+         <+> text ":: ..."+         $$ text hint+         where+         hint | foreign_RDR `looks_like` lhs+              = "Perhaps you meant to use ForeignFunctionInterface?"+              | default_RDR `looks_like` lhs+              = "Perhaps you meant to use DefaultSignatures?"+              | pattern_RDR `looks_like` lhs+              = "Perhaps you meant to use PatternSynonyms?"+              | otherwise+              = "Should be of form <variable> :: <type>"++         -- A common error is to forget the ForeignFunctionInterface flag+         -- so check for that, and suggest.  cf #3805+         -- Sadly 'foreign import' still barfs 'parse error' because+         --  'import' is a keyword+         -- looks_like :: RdrName -> LHsExpr GhcPs -> Bool -- AZ+         looks_like s (L _ (HsVar _ (L _ v))) = v == s+         looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs+         looks_like _ _                       = False++         foreign_RDR = mkUnqual varName (fsLit "foreign")+         default_RDR = mkUnqual varName (fsLit "default")+         pattern_RDR = mkUnqual varName (fsLit "pattern")++   PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where+      -> vcat [ text "Unexpected type" <+> quotes (ppr t)+              , text "In the" <+> what+                <+> ptext (sLit "declaration for") <+> quotes tc'+              , vcat[ (text "A" <+> what+                       <+> ptext (sLit "declaration should have form"))+              , nest 2+                (what+                 <+> tc'+                 <+> hsep (map text (takeList tparms allNameStrings))+                 <+> equals_or_where) ] ]+          where+            -- Avoid printing a constraint tuple in the error message. Print+            -- a plain old tuple instead (since that's what the user probably+            -- wrote). See #14907+            tc' = ppr $ filterCTuple tc++   PsErrCmmParser cmm_err -> case cmm_err of+      CmmUnknownPrimitive name     -> text "unknown primitive" <+> ftext name+      CmmUnknownMacro fun          -> text "unknown macro" <+> ftext fun+      CmmUnknownCConv cconv        -> text "unknown calling convention:" <+> text cconv+      CmmUnrecognisedSafety safety -> text "unrecognised safety" <+> text safety+      CmmUnrecognisedHint hint     -> text "unrecognised hint:" <+> text hint++   PsErrExpectedHyphen+      -> text "Expected a hyphen"++   PsErrSpaceInSCC+      -> text "Spaces are not allowed in SCCs"++   PsErrEmptyDoubleQuotes th_on+      -> if th_on then vcat (msg ++ th_msg) else vcat msg+         where+            msg    = [ text "Parser error on `''`"+                     , text "Character literals may not be empty"+                     ]+            th_msg = [ text "Or perhaps you intended to use quotation syntax of TemplateHaskell,"+                     , text "but the type variable or constructor is missing"+                     ]++   PsErrInvalidPackageName pkg+      -> vcat+            [ text "Parse error" <> colon <+> quotes (ftext pkg)+            , text "Version number or non-alphanumeric" <+>+              text "character in package name"+            ]++   PsErrInvalidRuleActivationMarker+      -> text "Invalid rule activation marker"++   PsErrLinearFunction+      -> text "Enable LinearTypes to allow linear functions"++   PsErrMultiWayIf+      -> text "Multi-way if-expressions need MultiWayIf turned on"++   PsErrExplicitForall is_unicode+      -> vcat+         [ text "Illegal symbol" <+> quotes (forallSym is_unicode) <+> text "in type"+         , text "Perhaps you intended to use RankNTypes or a similar language"+         , text "extension to enable explicit-forall syntax:" <+>+           forallSym is_unicode <+> text "<tvs>. <type>"+         ]+         where+          forallSym True  = text "∀"+          forallSym False = text "forall"++   PsErrIllegalQualifiedDo qdoDoc+      -> vcat+         [ text "Illegal qualified" <+> quotes qdoDoc <+> text "block"+         , text "Perhaps you intended to use QualifiedDo"+         ]++pp_unexpected_fun_app :: Outputable a => SDoc -> a -> SDoc+pp_unexpected_fun_app e a =+   text "Unexpected " <> e <> text " in function application:"+    $$ nest 4 (ppr a)+    $$ text "You could write it with parentheses"+    $$ text "Or perhaps you meant to enable BlockArguments?"++pp_hint :: Hint -> SDoc+pp_hint = \case+   SuggestTH              -> text "Perhaps you intended to use TemplateHaskell"+   SuggestDo              -> text "Perhaps this statement should be within a 'do' block?"+   SuggestMissingDo       -> text "Possibly caused by a missing 'do'?"+   SuggestRecursiveDo     -> text "Perhaps you intended to use RecursiveDo"+   SuggestLetInDo         -> text "Perhaps you need a 'let' in a 'do' block?"+                             $$ text "e.g. 'let x = 5' instead of 'x = 5'"+   SuggestPatternSynonyms -> text "Perhaps you intended to use PatternSynonyms"++   SuggestInfixBindMaybeAtPat fun+      -> text "In a function binding for the"+            <+> quotes (ppr fun)+            <+> text "operator."+         $$ if opIsAt fun+               then perhaps_as_pat+               else empty+   TypeApplicationsInPatternsOnlyDataCons ->+     text "Type applications in patterns are only allowed on data constructors."++perhaps_as_pat :: SDoc+perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"

@@ -1,5 +1,4 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE CPP          #-} {-# LANGUAGE TypeFamilies #-}  -----------------------------------------------------------------------------@@ -27,70 +26,78 @@ import GHC.Prelude  import GHC.Platform-import GHC.Driver.Types++import GHC.Driver.Session+import GHC.Driver.Config++import GHC.Parser.Errors.Ppr+import GHC.Parser.Errors import GHC.Parser           ( parseHeader ) import GHC.Parser.Lexer-import GHC.Data.FastString+ import GHC.Hs import GHC.Unit.Module import GHC.Builtin.Names-import GHC.Data.StringBuffer++import GHC.Types.Error hiding ( getErrorMessages, getWarningMessages ) import GHC.Types.SrcLoc-import GHC.Driver.Session-import GHC.Utils.Error+import GHC.Types.SourceError+import GHC.Types.SourceText+ import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable-import GHC.Data.Maybe-import GHC.Data.Bag         ( emptyBag, listToBag, unitBag )+import GHC.Utils.Panic import GHC.Utils.Monad import GHC.Utils.Exception as Exception-import GHC.Types.Basic-import qualified GHC.LanguageExtensions as LangExt +import GHC.Data.StringBuffer+import GHC.Data.Maybe+import GHC.Data.Bag         ( Bag, listToBag, unitBag, isEmptyBag )+import GHC.Data.FastString+ import Control.Monad import System.IO import System.IO.Unsafe-import Data.List+import Data.List (partition)  ------------------------------------------------------------------------------  -- | Parse the imports of a source file. -- -- Throws a 'SourceError' if parsing fails.-getImports :: DynFlags+getImports :: ParserOpts   -- ^ Parser options+           -> Bool         -- ^ Implicit Prelude?            -> StringBuffer -- ^ Parse this.            -> FilePath     -- ^ Filename the buffer came from.  Used for                            --   reporting parse error locations.            -> FilePath     -- ^ The original source filename (used for locations                            --   in the function result)            -> IO (Either-               ErrorMessages+               (Bag PsError)                ([(Maybe FastString, Located ModuleName)],                 [(Maybe FastString, Located ModuleName)],                 Located ModuleName))               -- ^ The source imports and normal imports (with optional package               -- names from -XPackageImports), and the module name.-getImports dflags buf filename source_filename = do+getImports popts implicit_prelude buf filename source_filename = do   let loc  = mkRealSrcLoc (mkFastString filename) 1 1-  case unP parseHeader (mkPState dflags buf loc) of+  case unP parseHeader (initParserState popts buf loc) of     PFailed pst ->         -- assuming we're not logging warnings here as per below-      return $ Left $ getErrorMessages pst dflags+      return $ Left $ getErrorMessages pst     POk pst rdr_module -> fmap Right $ do-      let _ms@(_warns, errs) = getMessages pst dflags+      let (_warns, errs) = getMessages pst       -- don't log warnings: they'll be reported when we parse the file       -- for real.  See #2500.-          ms = (emptyBag, errs)-      -- logWarnings warns-      if errorsFound dflags ms-        then throwIO $ mkSrcErr errs+      if not (isEmptyBag errs)+        then throwIO $ mkSrcErr (fmap pprError errs)         else           let   hsmod = unLoc rdr_module                 mb_mod = hsmodName hsmod                 imps = hsmodImports hsmod                 main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)                                        1 1)-                mod = mb_mod `orElse` L main_loc mAIN_NAME+                mod = mb_mod `orElse` L (noAnnSrcSpan main_loc) mAIN_NAME                 (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps                 -- GHC.Prim doesn't exist physically, so don't go looking for it.@@ -98,14 +105,13 @@                                         . ideclName . unLoc)                                        ord_idecls -                implicit_prelude = xopt LangExt.ImplicitPrelude dflags                 implicit_imports = mkPrelImports (unLoc mod) main_loc                                                  implicit_prelude imps-                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)+                convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), reLoc (ideclName i))               in               return (map convImport src_idecls,                       map convImport (implicit_imports ++ ordinary_imps),-                      mod)+                      reLoc mod)  mkPrelImports :: ModuleName               -> SrcSpan    -- Attribute the "import Prelude" to this location@@ -123,24 +129,29 @@   = []   | otherwise = [preludeImportDecl]   where-      explicit_prelude_import-       = notNull [ () | L _ (ImportDecl { ideclName = mod-                                        , ideclPkgQual = Nothing })-                          <- import_decls-                      , unLoc mod == pRELUDE_NAME ]+      explicit_prelude_import = any is_prelude_import import_decls +      is_prelude_import (L _ decl) =+        unLoc (ideclName decl) == pRELUDE_NAME+        -- allow explicit "base" package qualifier (#19082, #17045)+        && case ideclPkgQual decl of+            Nothing -> True+            Just b  -> sl_fs b == unitIdFS baseUnitId+++      loc' = noAnnSrcSpan loc       preludeImportDecl :: LImportDecl GhcPs       preludeImportDecl-        = L loc $ ImportDecl { ideclExt       = noExtField,-                               ideclSourceSrc = NoSourceText,-                               ideclName      = L loc pRELUDE_NAME,-                               ideclPkgQual   = Nothing,-                               ideclSource    = NotBoot,-                               ideclSafe      = False,  -- Not a safe import-                               ideclQualified = NotQualified,-                               ideclImplicit  = True,   -- Implicit!-                               ideclAs        = Nothing,-                               ideclHiding    = Nothing  }+        = L loc' $ ImportDecl { ideclExt       = noAnn,+                                ideclSourceSrc = NoSourceText,+                                ideclName      = L loc' pRELUDE_NAME,+                                ideclPkgQual   = Nothing,+                                ideclSource    = NotBoot,+                                ideclSafe      = False,  -- Not a safe import+                                ideclQualified = NotQualified,+                                ideclImplicit  = True,   -- Implicit!+                                ideclAs        = Nothing,+                                ideclHiding    = Nothing  }  -------------------------------------------------------------- -- Get options@@ -158,7 +169,7 @@               (hClose)               (\handle -> do                   opts <- fmap (getOptions' dflags)-                               (lazyGetToks dflags' filename handle)+                               (lazyGetToks (initParserOpts dflags') filename handle)                   seqList opts $ return opts)     where -- We don't need to get haddock doc tokens when we're just           -- getting the options from pragmas, and lazily lexing them@@ -174,15 +185,16 @@ -- blockSize = 17 -- for testing :-) blockSize = 1024 -lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]-lazyGetToks dflags filename handle = do+lazyGetToks :: ParserOpts -> FilePath -> Handle -> IO [Located Token]+lazyGetToks popts filename handle = do   buf <- hGetStringBufferBlock handle blockSize-  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize+  let prag_state = initPragState popts buf loc+  unsafeInterleaveIO $ lazyLexBuf handle prag_state False blockSize  where   loc  = mkRealSrcLoc (mkFastString filename) 1 1    lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]-  lazyLexBuf handle state eof size = do+  lazyLexBuf handle state eof size =     case unP (lexer False return) state of       POk state' t -> do         -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())@@ -212,9 +224,10 @@        unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size  -getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]-getToks dflags filename buf = lexAll (pragState dflags buf loc)+getToks :: ParserOpts -> FilePath -> StringBuffer -> [Located Token]+getToks popts filename buf = lexAll pstate  where+  pstate = initPragState popts buf loc   loc  = mkRealSrcLoc (mkFastString filename) 1 1    lexAll state = case unP (lexer False return) state of@@ -231,7 +244,7 @@            -> FilePath     -- ^ Source filename.  Used for location info.            -> [Located String] -- ^ Parsed options. getOptions dflags buf filename-    = getOptions' dflags (getToks dflags filename buf)+    = getOptions' dflags (getToks (initParserOpts dflags) filename buf)  -- The token parser is written manually because Happy can't -- return a partial result when it encounters a lexer error.@@ -247,7 +260,7 @@               | IToptions_prag str <- unLoc open               , ITclose_prag       <- unLoc close               = case toArgs str of-                  Left _err -> optionsParseError str dflags $   -- #15053+                  Left _err -> optionsParseError str $   -- #15053                                  combineSrcSpans (getLoc open) (getLoc close)                   Right args -> map (L (getLoc open)) args ++ parseToks xs           parseToks (open:close:xs)@@ -256,8 +269,8 @@               = map (L (getLoc open)) ["-#include",removeSpaces str] ++                 parseToks xs           parseToks (open:close:xs)-              | ITdocOptions str <- unLoc open-              , ITclose_prag     <- unLoc close+              | ITdocOptions str _ <- unLoc open+              , ITclose_prag       <- unLoc close               = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]                 ++ parseToks xs           parseToks (open:xs)@@ -272,10 +285,10 @@                 case rest of                   (L _loc ITcomma):more -> parseLanguage more                   (L _loc ITclose_prag):more -> parseToks more-                  (L loc _):_ -> languagePragParseError dflags loc+                  (L loc _):_ -> languagePragParseError loc                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"           parseLanguage (tok:_)-              = languagePragParseError dflags (getLoc tok)+              = languagePragParseError (getLoc tok)           parseLanguage []               = panic "getOptions'.parseLanguage(2) went past eof token" @@ -296,12 +309,12 @@ -- -- Throws a 'SourceError' if the input list is non-empty claiming that the -- input flags are unknown.-checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()-checkProcessArgsResult dflags flags+checkProcessArgsResult :: MonadIO m => [Located String] -> m ()+checkProcessArgsResult flags   = when (notNull flags) $       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags     where mkMsg (L loc flag)-              = mkPlainErrMsg dflags loc $+              = mkPlainMsgEnvelope loc $                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>                    text flag) @@ -316,11 +329,11 @@     else unsupportedExtnError dflags l ext'   where     ext' = unpackFS ext-    supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags+    supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags -languagePragParseError :: DynFlags -> SrcSpan -> a-languagePragParseError dflags loc =-    throwErr dflags loc $+languagePragParseError :: SrcSpan -> a+languagePragParseError loc =+    throwErr loc $        vcat [ text "Cannot parse LANGUAGE pragma"             , text "Expecting comma-separated list of language options,"             , text "each starting with a capital letter"@@ -328,34 +341,34 @@  unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a unsupportedExtnError dflags loc unsup =-    throwErr dflags loc $+    throwErr loc $         text "Unsupported extension: " <> text unsup $$         if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)   where-     supported = supportedLanguagesAndExtensions $ platformMini $ targetPlatform dflags+     supported = supportedLanguagesAndExtensions $ platformArchOS $ targetPlatform dflags      suggestions = fuzzyMatch unsup supported  -optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages-optionsErrorMsgs dflags unhandled_flags flags_lines _filename-  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))+optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages DecoratedSDoc+optionsErrorMsgs unhandled_flags flags_lines _filename+  = mkMessages $ listToBag (map mkMsg unhandled_flags_lines)   where unhandled_flags_lines :: [Located String]         unhandled_flags_lines = [ L l f                                 | f <- unhandled_flags                                 , L l f' <- flags_lines                                 , f == f' ]         mkMsg (L flagSpan flag) =-            GHC.Utils.Error.mkPlainErrMsg dflags flagSpan $+            mkPlainMsgEnvelope flagSpan $                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag -optionsParseError :: String -> DynFlags -> SrcSpan -> a     -- #15053-optionsParseError str dflags loc =-  throwErr dflags loc $+optionsParseError :: String -> SrcSpan -> a     -- #15053+optionsParseError str loc =+  throwErr loc $       vcat [ text "Error while parsing OPTIONS_GHC pragma."            , text "Expecting whitespace-separated list of GHC options."            , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"            , text ("Input was: " ++ show str) ] -throwErr :: DynFlags -> SrcSpan -> SDoc -> a                -- #15053-throwErr dflags loc doc =-  throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc+throwErr :: SrcSpan -> SDoc -> a                -- #15053+throwErr loc doc =+  throw $ mkSrcErr $ unitBag $ mkPlainMsgEnvelope loc doc

GHC/Parser/Lexer.x view

@@ -42,6 +42,7 @@  { {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} @@ -49,33 +50,35 @@ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.Parser.Lexer (-   Token(..), lexer, lexerDbg, pragState, mkPState, mkPStatePure, PState(..),-   P(..), ParseResult(..), mkParserFlags, mkParserFlags', ParserFlags(..),-   appendWarning,-   appendError,-   allocateComments,+   Token(..), lexer, lexerDbg,+   ParserOpts(..), mkParserOpts,+   PState (..), initParserState, initPragState,+   P(..), ParseResult(..),+   allocateComments, allocatePriorComments, allocateFinalComments,    MonadP(..),-   getRealSrcLoc, getPState, withHomeUnitId,+   getRealSrcLoc, getPState,    failMsgP, failLocMsgP, srcParseFail,    getErrorMessages, getMessages,    popContext, pushModuleContext, setLastToken, setSrcLoc,    activeContext, nextIsEOF,    getLexState, popLexState, pushLexState,    ExtBits(..),-   xtest,+   xtest, xunset, xset,    lexTokenStream,-   addAnnsAt,+   mkParensEpAnn,+   getCommentsFor, getPriorCommentsFor, getFinalCommentsFor,+   getEofPos,    commentToAnnotation,    HdkComment(..),+   warnopt,   ) where  import GHC.Prelude  -- base import Control.Monad-import Data.Bits import Data.Char-import Data.List+import Data.List (stripPrefix, isInfixOf, partition) import Data.Maybe import Data.Word @@ -91,32 +94,27 @@ import Data.Map (Map) import qualified Data.Map as Map --- compiler/utils+-- compiler import GHC.Data.Bag import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.StringBuffer import GHC.Data.FastString import GHC.Types.Unique.FM import GHC.Data.Maybe import GHC.Data.OrdList-import GHC.Utils.Misc ( readRational, readHexRational )---- compiler/main-import GHC.Utils.Error-import GHC.Driver.Session as DynFlags+import GHC.Utils.Misc ( readSignificandExponentPair, readHexSignificandExponentPair ) --- compiler/basicTypes import GHC.Types.SrcLoc-import GHC.Unit-import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..),-                         IntegralLit(..), FractionalLit(..),-                         SourceText(..) )+import GHC.Types.SourceText+import GHC.Types.Basic ( InlineSpec(..), RuleMatchInfo(..)) import GHC.Hs.Doc --- compiler/parser import GHC.Parser.CharClass  import GHC.Parser.Annotation+import GHC.Driver.Flags+import GHC.Parser.Errors }  -- -----------------------------------------------------------------------------@@ -357,7 +355,7 @@ }  <0,option_prags> {-  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas (text "Unrecognised pragma")+  "{-#"  { warnThen Opt_WarnUnrecognisedPragmas PsWarnUnrecognisedPragma                     (nested_comment lexToken) } } @@ -620,6 +618,19 @@ --            |               |   ordinary operator or type operator, --            |               |   e.g.  xs ~ 3, (~ x), Int ~ Bool --  ----------+---------------+------------------------------------------+--    .       |  prefix       | ITproj True+--            |               |   field projection,+--            |               |   e.g.  .x+--            |  tight infix  | ITproj False+--            |               |   field projection,+--            |               |   e.g. r.x+--            |  suffix       | ITdot+--            |               |   function composition,+--            |               |   e.g. f. g+--            |  loose infix  | ITdot+--            |               |   function composition,+--            |               |   e.g.  f . g+--  ----------+---------------+------------------------------------------ --    $  $$   |  prefix       | ITdollar, ITdollardollar --            |               |   untyped or typed Template Haskell splice, --            |               |   e.g.  $(f x), $$(f x), $$"str"@@ -745,7 +756,6 @@   | ITline_prag         SourceText  -- not usually produced, see 'UsePosPragsBit'   | ITcolumn_prag       SourceText  -- not usually produced, see 'UsePosPragsBit'   | ITscc_prag          SourceText-  | ITgenerated_prag    SourceText   | ITunpack_prag       SourceText   | ITnounpack_prag     SourceText   | ITann_prag          SourceText@@ -782,6 +792,7 @@   | ITpercent  -- Prefix (%) only, e.g. a %1 -> b   | ITstar              IsUnicodeSyntax   | ITdot+  | ITproj Bool -- Extension: OverloadedRecordDotBit    | ITbiglam                    -- GHC-extension symbols @@ -860,21 +871,38 @@   | ITunknown String             -- ^ Used when the lexer can't make sense of it   | ITeof                        -- ^ end of file token -  -- Documentation annotations-  | ITdocCommentNext  String     -- ^ something beginning @-- |@-  | ITdocCommentPrev  String     -- ^ something beginning @-- ^@-  | ITdocCommentNamed String     -- ^ something beginning @-- $@-  | ITdocSection      Int String -- ^ a section heading-  | ITdocOptions      String     -- ^ doc options (prune, ignore-exports, etc)-  | ITlineComment     String     -- ^ comment starting by "--"-  | ITblockComment    String     -- ^ comment in {- -}+  -- Documentation annotations. See Note [PsSpan in Comments]+  | ITdocCommentNext  String     PsSpan -- ^ something beginning @-- |@+  | ITdocCommentPrev  String     PsSpan -- ^ something beginning @-- ^@+  | ITdocCommentNamed String     PsSpan -- ^ something beginning @-- $@+  | ITdocSection      Int String PsSpan -- ^ a section heading+  | ITdocOptions      String     PsSpan -- ^ doc options (prune, ignore-exports, etc)+  | ITlineComment     String     PsSpan -- ^ comment starting by "--"+  | ITblockComment    String     PsSpan -- ^ comment in {- -}    deriving Show  instance Outputable Token where   ppr x = text (show x) +{- Note [PsSpan in Comments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When using the Api Annotations to exact print a modified AST, managing+the space before a comment is important.  The PsSpan in the comment+token allows this to happen. +We also need to track the space before the end of file. The normal+mechanism of using the previous token does not work, as the ITeof is+synthesised to come at the same location of the last token, and the+normal previous token updating has by then updated the required+location.++We track this using a 2-back location, prev_loc2. This adds extra+processing to every single token, which is a performance hit for+something needed only at the end of the file. This needs+improving. Perhaps a backward scan on eof?+-}+ {- Note [Minus tokens] ~~~~~~~~~~~~~~~~~~~~~~ A minus sign can be used in prefix form (-x) and infix form (a - b).@@ -1087,7 +1115,7 @@ failLinePrag1 span _buf _len = do   b <- getBit InNestedCommentBit   if b then return (L span ITcomment_line_prag)-       else lexError "lexical error in pragma"+       else lexError LexErrorInPragma  -- See Note [Nested comment line pragmas] popLinePrag1 :: Action@@ -1108,7 +1136,7 @@                  Layout prev_off _ : _ -> prev_off < offset                  _                     -> True       if isOK then pop_and open_brace span buf len-              else addFatalError (mkSrcSpanPs span) (text "Missing block")+              else addFatalError $ PsError PsErrMissingBlock [] (mkSrcSpanPs span)  pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState@@ -1281,8 +1309,12 @@ lineCommentToken :: Action lineCommentToken span buf len = do   b <- getBit RawTokenStreamBit-  if b then strtoken ITlineComment span buf len else lexToken+  if b then do+         lt <- getLastLocComment+         strtoken (\s -> ITlineComment s lt) span buf len+       else lexToken + {-   nested comments require traversing by hand, they can't be parsed   using regular expressions.@@ -1293,7 +1325,8 @@   go (reverse $ lexemeToString buf len) (1::Int) input   where     go commentAcc 0 input = do-      let finalizeComment str = (Nothing, ITblockComment str)+      l <- getLastLocComment+      let finalizeComment str = (Nothing, ITblockComment str l)       commentEnd cont input commentAcc finalizeComment buf span     go commentAcc n input = case alexGetChar' input of       Nothing -> errBrace input (psRealSpan span)@@ -1388,32 +1421,33 @@                  -> P (PsLocated Token) withLexedDocType lexDocComment = do   input@(AI _ buf) <- getInput+  l <- getLastLocComment   case prevChar buf ' ' of     -- The `Bool` argument to lexDocComment signals whether or not the next     -- line of input might also belong to this doc comment.-    '|' -> lexDocComment input mkHdkCommentNext True-    '^' -> lexDocComment input mkHdkCommentPrev True-    '$' -> lexDocComment input mkHdkCommentNamed True-    '*' -> lexDocSection 1 input+    '|' -> lexDocComment input (mkHdkCommentNext l) True+    '^' -> lexDocComment input (mkHdkCommentPrev l) True+    '$' -> lexDocComment input (mkHdkCommentNamed l) True+    '*' -> lexDocSection l 1 input     _ -> panic "withLexedDocType: Bad doc type"  where-    lexDocSection n input = case alexGetChar' input of-      Just ('*', input) -> lexDocSection (n+1) input-      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection n) False+    lexDocSection l n input = case alexGetChar' input of+      Just ('*', input) -> lexDocSection l (n+1) input+      Just (_,   _)     -> lexDocComment input (mkHdkCommentSection l n) False       Nothing -> do setInput input; lexToken -- eof reached, lex it normally -mkHdkCommentNext, mkHdkCommentPrev :: String -> (HdkComment, Token)-mkHdkCommentNext str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str)-mkHdkCommentPrev str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str)+mkHdkCommentNext, mkHdkCommentPrev :: PsSpan -> String -> (HdkComment, Token)+mkHdkCommentNext loc str = (HdkCommentNext (mkHsDocString str), ITdocCommentNext str loc)+mkHdkCommentPrev loc str = (HdkCommentPrev (mkHsDocString str), ITdocCommentPrev str loc) -mkHdkCommentNamed :: String -> (HdkComment, Token)-mkHdkCommentNamed str =+mkHdkCommentNamed :: PsSpan -> String -> (HdkComment, Token)+mkHdkCommentNamed loc str =   let (name, rest) = break isSpace str-  in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str)+  in (HdkCommentNamed name (mkHsDocString rest), ITdocCommentNamed str loc) -mkHdkCommentSection :: Int -> String -> (HdkComment, Token)-mkHdkCommentSection n str =-  (HdkCommentSection n (mkHsDocString str), ITdocSection n str)+mkHdkCommentSection :: PsSpan -> Int -> String -> (HdkComment, Token)+mkHdkCommentSection loc n str =+  (HdkCommentSection n (mkHsDocString str), ITdocSection n str loc)  -- RULES pragmas turn on the forall and '.' keywords, and we turn them -- off again at the end of the pragma.@@ -1487,7 +1521,7 @@   commentEnd lexToken input commentAcc finalizeComment buf span  errBrace :: AlexInput -> RealSrcSpan -> P a-errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) "unterminated `{-'"+errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedComment LexErrKind_EOF) [])  open_brace, close_brace :: Action open_brace span _str _len = do@@ -1542,12 +1576,11 @@     Just (ITcase, _) -> do       lastTk <- getLastTk       keyword <- case lastTk of-        Just ITlam -> do+        Just (L _ ITlam) -> do           lambdaCase <- getBit LambdaCaseBit           unless lambdaCase $ do             pState <- getPState-            addError (mkSrcSpanPs (last_loc pState)) $ text-                     "Illegal lambda-case (use LambdaCase)"+            addError $ PsError PsErrLambdaCase [] (mkSrcSpanPs (last_loc pState))           return ITlcase         _ -> return ITcase       maybe_layout keyword@@ -1577,65 +1610,102 @@  -- See Note [Whitespace-sensitive operator parsing] varsym_prefix :: Action-varsym_prefix = sym $ \exts s ->-  if | s == fsLit "@"  -- regardless of TypeApplications for better error messages-     -> return ITtypeApp-     | LinearTypesBit `xtest` exts, s == fsLit "%"-     -> return ITpercent-     | ThQuotesBit `xtest` exts, s == fsLit "$"-     -> return ITdollar-     | ThQuotesBit `xtest` exts, s == fsLit "$$"-     -> return ITdollardollar-     | s == fsLit "-"   -- Only when LexicalNegation is on, otherwise we get ITminus and-                        -- don't hit this code path. See Note [Minus tokens]-     -> return ITprefixminus+varsym_prefix = sym $ \span exts s ->+  let warnExtConflict errtok =+        do { addWarning Opt_WarnOperatorWhitespaceExtConflict $+               PsWarnOperatorWhitespaceExtConflict (mkSrcSpanPs span) errtok+           ; return (ITvarsym s) }+  in+  if | s == fsLit "@" ->+         return ITtypeApp  -- regardless of TypeApplications for better error messages+     | s == fsLit "%" ->+         if xtest LinearTypesBit exts+         then return ITpercent+         else warnExtConflict OperatorWhitespaceSymbol_PrefixPercent+     | s == fsLit "$" ->+         if xtest ThQuotesBit exts+         then return ITdollar+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollar+     | s == fsLit "$$" ->+         if xtest ThQuotesBit exts+         then return ITdollardollar+         else warnExtConflict OperatorWhitespaceSymbol_PrefixDollarDollar+     | s == fsLit "-" ->+         return ITprefixminus -- Only when LexicalNegation is on, otherwise we get ITminus+                              -- and don't hit this code path. See Note [Minus tokens]+     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts ->+         return (ITproj True) -- e.g. '(.x)'+     | s == fsLit "." -> return ITdot      | s == fsLit "!" -> return ITbang      | s == fsLit "~" -> return ITtilde-     | otherwise -> return (ITvarsym s)+     | otherwise ->+         do { addWarning Opt_WarnOperatorWhitespace $+                PsWarnOperatorWhitespace (mkSrcSpanPs span) s+                  OperatorWhitespaceOccurrence_Prefix+            ; return (ITvarsym s) }  -- See Note [Whitespace-sensitive operator parsing] varsym_suffix :: Action-varsym_suffix = sym $ \_ s ->-  if | s == fsLit "@"-     -> failMsgP "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."-     | otherwise -> return (ITvarsym s)+varsym_suffix = sym $ \span _ s ->+  if | s == fsLit "@" -> failMsgP (PsError PsErrSuffixAT [])+     | s == fsLit "." -> return ITdot+     | otherwise ->+         do { addWarning Opt_WarnOperatorWhitespace $+                PsWarnOperatorWhitespace (mkSrcSpanPs span) s+                  OperatorWhitespaceOccurrence_Suffix+            ; return (ITvarsym s) }  -- See Note [Whitespace-sensitive operator parsing] varsym_tight_infix :: Action-varsym_tight_infix = sym $ \_ s ->+varsym_tight_infix = sym $ \span exts s ->   if | s == fsLit "@" -> return ITat-     | otherwise -> return (ITvarsym s)+     | s == fsLit ".", OverloadedRecordDotBit `xtest` exts  -> return (ITproj False)+     | s == fsLit "." -> return ITdot+     | otherwise ->+         do { addWarning Opt_WarnOperatorWhitespace $+                PsWarnOperatorWhitespace (mkSrcSpanPs span) s+                  OperatorWhitespaceOccurrence_TightInfix+            ;  return (ITvarsym s) }  -- See Note [Whitespace-sensitive operator parsing] varsym_loose_infix :: Action-varsym_loose_infix = sym (\_ s -> return $ ITvarsym s)+varsym_loose_infix = sym $ \_ _ s ->+  if | s == fsLit "."+     -> return ITdot+     | otherwise+     -> return $ ITvarsym s  consym :: Action-consym = sym (\_exts s -> return $ ITconsym s)+consym = sym (\_span _exts s -> return $ ITconsym s) -sym :: (ExtsBitmap -> FastString -> P Token) -> Action+sym :: (PsSpan -> ExtsBitmap -> FastString -> P Token) -> Action sym con span buf len =   case lookupUFM reservedSymsFM fs of-    Just (keyword, NormalSyntax, 0) ->-      return $ L span keyword+    Just (keyword, NormalSyntax, 0) -> do+      exts <- getExts+      if fs == fsLit "." &&+         exts .&. (xbit OverloadedRecordDotBit) /= 0 &&+         xtest OverloadedRecordDotBit exts+      then L span <$!> con span exts fs  -- Process by varsym_*.+      else return $ L span keyword     Just (keyword, NormalSyntax, i) -> do       exts <- getExts       if exts .&. i /= 0         then return $ L span keyword-        else L span <$!> con exts fs+        else L span <$!> con span exts fs     Just (keyword, UnicodeSyntax, 0) -> do       exts <- getExts       if xtest UnicodeSyntaxBit exts         then return $ L span keyword-        else L span <$!> con exts fs+        else L span <$!> con span exts fs     Just (keyword, UnicodeSyntax, i) -> do       exts <- getExts       if exts .&. i /= 0 && xtest UnicodeSyntaxBit exts         then return $ L span keyword-        else L span <$!> con exts fs+        else L span <$!> con span exts fs     Nothing -> do       exts <- getExts-      L span <$!> con exts fs+      L span <$!> con span exts fs   where     !fs = lexemeToFastString buf len @@ -1650,8 +1720,7 @@   let src = lexemeToString buf len   when ((not numericUnderscores) && ('_' `elem` src)) $ do     pState <- getPState-    addError (mkSrcSpanPs (last_loc pState)) $ text-             "Use NumericUnderscores to allow underscores in integer literals"+    addError $ PsError (PsErrNumUnderscores NumUnderscore_Integral) [] (mkSrcSpanPs (last_loc pState))   return $ L span $ itint (SourceText src)        $! transint $ parseUnsignedInteger        (offsetBytes transbuf buf) (subtract translen len) radix char_to_int@@ -1685,15 +1754,14 @@ octal = (8,octDecDigit) hexadecimal = (16,hexDigit) --- readRational can understand negative rationals, exponents, everything.+-- readSignificandExponentPair can understand negative rationals, exponents, everything. tok_frac :: Int -> (String -> Token) -> Action tok_frac drop f span buf len = do   numericUnderscores <- getBit NumericUnderscoresBit  -- #14473   let src = lexemeToString buf (len-drop)   when ((not numericUnderscores) && ('_' `elem` src)) $ do     pState <- getPState-    addError (mkSrcSpanPs (last_loc pState)) $ text-             "Use NumericUnderscores to allow underscores in floating literals"+    addError $ PsError (PsErrNumUnderscores NumUnderscore_Float) [] (mkSrcSpanPs (last_loc pState))   return (L span $! (f $! src))  tok_float, tok_primfloat, tok_primdouble :: String -> Token@@ -1702,18 +1770,20 @@ tok_primfloat    str = ITprimfloat  $! readFractionalLit str tok_primdouble   str = ITprimdouble $! readFractionalLit str -readFractionalLit :: String -> FractionalLit-readFractionalLit str = ((FL $! (SourceText str)) $! is_neg) $! readRational str-                        where is_neg = case str of ('-':_) -> True-                                                   _       -> False-readHexFractionalLit :: String -> FractionalLit-readHexFractionalLit str =-  FL { fl_text  = SourceText str-     , fl_neg   = case str of+readFractionalLit, readHexFractionalLit :: String -> FractionalLit+readHexFractionalLit = readFractionalLitX readHexSignificandExponentPair Base2+readFractionalLit = readFractionalLitX readSignificandExponentPair Base10++readFractionalLitX :: (String -> (Integer, Integer))+                   -> FractionalExponentBase+                   -> String -> FractionalLit+readFractionalLitX readStr b str =+  mkSourceFractionalLit str is_neg i e b+  where+    is_neg = case str of                     '-' : _ -> True-                    _       -> False-     , fl_value = readHexRational str-     }+                    _      -> False+    (i, e) = readStr str  -- ----------------------------------------------------------------------------- -- Layout processing@@ -1844,27 +1914,33 @@ -- ----------------------------------------------------------------------------- -- Options, includes and language pragmas. + lex_string_prag :: (String -> Token) -> Action-lex_string_prag mkTok span _buf _len+lex_string_prag mkTok = lex_string_prag_comment mkTok'+  where+    mkTok' s _ = mkTok s++lex_string_prag_comment :: (String -> PsSpan -> Token) -> Action+lex_string_prag_comment mkTok span _buf _len     = do input <- getInput          start <- getParsedLoc-         tok <- go [] input+         l <- getLastLocComment+         tok <- go l [] input          end <- getParsedLoc          return (L (mkPsSpan start end) tok)-    where go acc input+    where go l acc input               = if isString input "#-}"                    then do setInput input-                           return (mkTok (reverse acc))+                           return (mkTok (reverse acc) l)                    else case alexGetChar input of-                          Just (c,i) -> go (c:acc) i+                          Just (c,i) -> go l (c:acc) i                           Nothing -> err input           isString _ [] = True           isString i (x:xs)               = case alexGetChar i of                   Just (c,i') | c == x    -> isString i' xs                   _other -> False-          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) "unterminated options pragma"-+          err (AI end _) = failLocMsgP (realSrcSpanStart (psRealSpan span)) (psRealLoc end) (PsError (PsErrLexer LexUnterminatedOptions LexErrKind_EOF) [])  -- ----------------------------------------------------------------------------- -- Strings & Chars@@ -1901,8 +1977,8 @@                 setInput i                 when (any (> '\xFF') s') $ do                   pState <- getPState-                  addError (mkSrcSpanPs (last_loc pState)) $ text-                     "primitive string literal must contain only characters <= \'\\xFF\'"+                  let err = PsError PsErrPrimStringInvalidChar [] (mkSrcSpanPs (last_loc pState))+                  addError err                 return (ITprimstring (SourceText s') (unsafeMkByteString s'))               _other ->                 return (ITstring (SourceText s') (mkFastString s'))@@ -2058,7 +2134,7 @@             Just (c,input') | is_digit c -> do                let i' = i*base + conv c                if i' > 0x10ffff-                  then setInput input >> lexError "numeric escape sequence out of range"+                  then setInput input >> lexError LexNumEscapeRange                   else read i' input'             _other -> do               setInput input; return (chr i)@@ -2107,12 +2183,12 @@ -- a correct location to the user, but also so we can detect UTF-8 decoding -- errors if they occur. lit_error :: AlexInput -> P a-lit_error i = do setInput i; lexError "lexical error in string/character literal"+lit_error i = do setInput i; lexError LexStringCharLit  getCharOrFail :: AlexInput -> P Char getCharOrFail i =  do   case alexGetChar' i of-        Nothing -> lexError "unexpected end-of-file in string/character literal"+        Nothing -> lexError LexStringCharLitEOF         Just (c,i)  -> do setInput i; return c  -- -----------------------------------------------------------------------------@@ -2163,7 +2239,8 @@ quasiquote_error :: RealSrcLoc -> P a quasiquote_error start = do   (AI end buf) <- getInput-  reportLexError start (psRealLoc end) buf "unterminated quasiquotation"+  reportLexError start (psRealLoc end) buf+    (\k -> PsError (PsErrLexer LexUnterminatedQQ k) [])  -- ----------------------------------------------------------------------------- -- Warnings@@ -2173,9 +2250,9 @@     addTabWarning (psRealSpan srcspan)     lexToken -warnThen :: WarningFlag -> SDoc -> Action -> Action-warnThen option warning action srcspan buf len = do-    addWarning option (RealSrcSpan (psRealSpan srcspan) Nothing) warning+warnThen :: WarningFlag -> (SrcSpan -> PsWarning) -> Action -> Action+warnThen flag warning action srcspan buf len = do+    addWarning flag (warning (RealSrcSpan (psRealSpan srcspan) Nothing))     action srcspan buf len  -- -----------------------------------------------------------------------------@@ -2210,14 +2287,14 @@              --   a non-empty bag of errors.  -- | Test whether a 'WarningFlag' is set-warnopt :: WarningFlag -> ParserFlags -> Bool+warnopt :: WarningFlag -> ParserOpts -> Bool warnopt f options = f `EnumSet.member` pWarningFlags options --- | The subset of the 'DynFlags' used by the parser.--- See 'mkParserFlags' or 'mkParserFlags'' for ways to construct this.-data ParserFlags = ParserFlags {-    pWarningFlags   :: EnumSet WarningFlag-  , pHomeUnitId     :: UnitId      -- ^ unit currently being compiled+-- | Parser options.+--+-- See 'mkParserOpts' to construct this.+data ParserOpts = ParserOpts+  { pWarningFlags   :: EnumSet WarningFlag -- ^ enabled warning flags   , pExtsBitmap     :: !ExtsBitmap -- ^ bitmap of permitted extensions   } @@ -2232,15 +2309,17 @@  data PState = PState {         buffer     :: StringBuffer,-        options    :: ParserFlags,-        -- This needs to take DynFlags as an argument until-        -- we have a fix for #10143-        messages   :: DynFlags -> Messages,+        options    :: ParserOpts,+        warnings   :: Bag PsWarning,+        errors     :: Bag PsError,         tab_first  :: Maybe RealSrcSpan, -- pos of first tab warning in the file-        tab_count  :: !Int,              -- number of tab warnings in the file-        last_tk    :: Maybe Token,-        last_loc   :: PsSpan,      -- pos of previous token-        last_len   :: !Int,        -- len of previous token+        tab_count  :: !Word,             -- number of tab warnings in the file+        last_tk    :: Maybe (PsLocated Token), -- last non-comment token+        prev_loc   :: PsSpan,      -- pos of previous token, including comments,+        prev_loc2  :: PsSpan,      -- pos of two back token, including comments,+                                   -- see Note [PsSpan in Comments]+        last_loc   :: PsSpan,      -- pos of current token+        last_len   :: !Int,        -- len of current token         loc        :: PsLoc,       -- current loc (end of prev token + 1)         context    :: [LayoutContext],         lex_state  :: [Int],@@ -2267,11 +2346,10 @@         -- The next three are used to implement Annotations giving the         -- locations of 'noise' tokens in the source, so that users of         -- the GHC API can do source to source conversions.-        -- See note [Api annotations] in GHC.Parser.Annotation-        annotations :: [(ApiAnnKey,[RealSrcSpan])],-        eof_pos :: Maybe RealSrcSpan,-        comment_q :: [RealLocated AnnotationComment],-        annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])],+        -- See note [exact print annotations] in GHC.Parser.Annotation+        eof_pos :: Maybe (RealSrcSpan, RealSrcSpan), -- pos, gap to prior token+        header_comments :: Maybe [LEpaComment],+        comment_q :: [LEpaComment],          -- Haddock comments accumulated in ascending order of their location         -- (BufPos). We use OrdList to get O(1) snoc.@@ -2285,6 +2363,12 @@         -- Getting rid of last_loc would require finding another way to         -- implement pushCurrentContext (which is only called from one place). +        -- AZ question: setLastToken which sets last_loc and last_len+        -- is called whan processing AlexToken, immediately prior to+        -- calling the action in the token.  So from the perspective+        -- of the action, it is the *current* token.  Do I understand+        -- correctly?+ data ALRContext = ALRNoLayout Bool{- does it contain commas? -}                               Bool{- is it a 'let' block? -}                 | ALRLayout ALRLayout Int@@ -2315,21 +2399,18 @@                 POk s1 a         -> (unP (k a)) s1                 PFailed s1 -> PFailed s1 -failMsgP :: String -> P a-failMsgP msg = do+failMsgP :: (SrcSpan -> PsError) -> P a+failMsgP f = do   pState <- getPState-  addFatalError (mkSrcSpanPs (last_loc pState)) (text msg)+  addFatalError (f (mkSrcSpanPs (last_loc pState))) -failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a-failLocMsgP loc1 loc2 str =-  addFatalError (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing) (text str)+failLocMsgP :: RealSrcLoc -> RealSrcLoc -> (SrcSpan -> PsError) -> P a+failLocMsgP loc1 loc2 f =+  addFatalError (f (RealSrcSpan (mkRealSrcSpan loc1 loc2) Nothing))  getPState :: P PState getPState = P $ \s -> POk s s -withHomeUnitId :: (UnitId -> a) -> P a-withHomeUnitId f = P $ \s@(PState{options = o}) -> POk s (f (pHomeUnitId o))- getExts :: P ExtsBitmap getExts = P $ \s -> POk s (pExtsBitmap . options $ s) @@ -2354,8 +2435,8 @@ addSrcFile :: FastString -> P () addSrcFile f = P $ \s -> POk s{ srcfiles = f : srcfiles s } () -setEofPos :: RealSrcSpan -> P ()-setEofPos span = P $ \s -> POk s{ eof_pos = Just span } ()+setEofPos :: RealSrcSpan -> RealSrcSpan -> P ()+setEofPos span gap = P $ \s -> POk s{ eof_pos = Just (span, gap) } ()  setLastToken :: PsSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s {@@ -2363,14 +2444,31 @@   last_len=len   } () -setLastTk :: Token -> P ()-setLastTk tk = P $ \s -> POk s { last_tk = Just tk } ()+setLastTk :: PsLocated Token -> P ()+setLastTk tk@(L l _) = P $ \s -> POk s { last_tk = Just tk+                                       , prev_loc = l+                                       , prev_loc2 = prev_loc s} () -getLastTk :: P (Maybe Token)+setLastComment :: PsLocated Token -> P ()+setLastComment (L l _) = P $ \s -> POk s { prev_loc = l+                                         , prev_loc2 = prev_loc s} ()++getLastTk :: P (Maybe (PsLocated Token)) getLastTk = P $ \s@(PState { last_tk = last_tk }) -> POk s last_tk -data AlexInput = AI PsLoc StringBuffer+-- see Note [PsSpan in Comments]+getLastLocComment :: P PsSpan+getLastLocComment = P $ \s@(PState { prev_loc = prev_loc }) -> POk s prev_loc +-- see Note [PsSpan in Comments]+getLastLocEof :: P PsSpan+getLastLocEof = P $ \s@(PState { prev_loc2 = prev_loc2 }) -> POk s prev_loc2++getLastLoc :: P PsSpan+getLastLoc = P $ \s@(PState { last_loc = last_loc }) -> POk s last_loc++data AlexInput = AI !PsLoc !StringBuffer+ {- Note [Unicode in Alex] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2572,6 +2670,12 @@ xtest :: ExtBits -> ExtsBitmap -> Bool xtest ext xmap = testBit xmap (fromEnum ext) +xset :: ExtBits -> ExtsBitmap -> ExtsBitmap+xset ext xmap = setBit xmap (fromEnum ext)++xunset :: ExtBits -> ExtsBitmap -> ExtsBitmap+xunset ext xmap = clearBit xmap (fromEnum ext)+ -- | Various boolean flags, mostly language extensions, that impact lexing and -- parsing. Note that a handful of these can change during lexing/parsing. data ExtBits@@ -2622,6 +2726,8 @@   | ImportQualifiedPostBit   | LinearTypesBit   | NoLexicalNegationBit   -- See Note [Why not LexicalNegationBit]+  | OverloadedRecordDotBit+  | OverloadedRecordUpdateBit    -- Flags that are updated once parsing starts   | InRulePragBit@@ -2632,22 +2738,10 @@     -- tokens of their own.   deriving Enum ------- PState for parsing options pragmas----pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState-pragState dynflags buf loc = (mkPState dynflags buf loc) {-                                 lex_state = [bol, option_prags, 0]-                             }--{-# INLINE mkParserFlags' #-}-mkParserFlags'+{-# INLINE mkParserOpts #-}+mkParserOpts   :: EnumSet WarningFlag        -- ^ warnings flags enabled   -> EnumSet LangExt.Extension  -- ^ permitted language extensions enabled-  -> UnitId                     -- ^ id of the unit currently being compiled   -> Bool                       -- ^ are safe imports on?   -> Bool                       -- ^ keeping Haddock comment tokens   -> Bool                       -- ^ keep regular comment tokens@@ -2657,13 +2751,12 @@   -- the internal position kept by the parser. Otherwise, those pragmas are   -- lexed as 'ITline_prag' and 'ITcolumn_prag' tokens. -  -> ParserFlags--- ^ Given exactly the information needed, set up the 'ParserFlags'-mkParserFlags' warningFlags extensionFlags homeUnitId+  -> ParserOpts+-- ^ Given exactly the information needed, set up the 'ParserOpts'+mkParserOpts warningFlags extensionFlags   safeImports isHaddock rawTokStream usePosPrags =-    ParserFlags {+    ParserOpts {       pWarningFlags = warningFlags-    , pHomeUnitId   = homeUnitId     , pExtsBitmap   = safeHaskellBit .|. langExtBits .|. optBits     }   where@@ -2710,7 +2803,9 @@       .|. GadtSyntaxBit               `xoptBit` LangExt.GADTSyntax       .|. ImportQualifiedPostBit      `xoptBit` LangExt.ImportQualifiedPost       .|. LinearTypesBit              `xoptBit` LangExt.LinearTypes-      .|. NoLexicalNegationBit     `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]+      .|. NoLexicalNegationBit        `xoptNotBit` LangExt.LexicalNegation -- See Note [Why not LexicalNegationBit]+      .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot+      .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).     optBits =           HaddockBit        `setBitIf` isHaddock       .|. RawTokenStreamBit `setBitIf` rawTokStream@@ -2723,32 +2818,25 @@     b `setBitIf` cond | cond      = xbit b                       | otherwise = 0 --- | Extracts the flag information needed for parsing-mkParserFlags :: DynFlags -> ParserFlags-mkParserFlags =-  mkParserFlags'-    <$> DynFlags.warningFlags-    <*> DynFlags.extensionFlags-    <*> DynFlags.homeUnitId-    <*> safeImportsOn-    <*> gopt Opt_Haddock-    <*> gopt Opt_KeepRawTokenStream-    <*> const True---- | Creates a parse state from a 'DynFlags' value-mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState-mkPState flags = mkPStatePure (mkParserFlags flags)+-- | Set parser options for parsing OPTIONS pragmas+initPragState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initPragState options buf loc = (initParserState options buf loc)+   { lex_state = [bol, option_prags, 0]+   } --- | Creates a parse state from a 'ParserFlags' value-mkPStatePure :: ParserFlags -> StringBuffer -> RealSrcLoc -> PState-mkPStatePure options buf loc =+-- | Creates a parse state from a 'ParserOpts' value+initParserState :: ParserOpts -> StringBuffer -> RealSrcLoc -> PState+initParserState options buf loc =   PState {       buffer        = buf,       options       = options,-      messages      = const emptyMessages,+      errors        = emptyBag,+      warnings      = emptyBag,       tab_first     = Nothing,       tab_count     = 0,       last_tk       = Nothing,+      prev_loc      = mkPsSpan init_loc init_loc,+      prev_loc2     = mkPsSpan init_loc init_loc,       last_loc      = mkPsSpan init_loc init_loc,       last_len      = 0,       loc           = init_loc,@@ -2761,10 +2849,9 @@       alr_context = [],       alr_expecting_ocurly = Nothing,       alr_justClosedExplicitLetBlock = False,-      annotations = [],       eof_pos = Nothing,+      header_comments = Nothing,       comment_q = [],-      annotations_comments = [],       hdk_comments = nilOL     }   where init_loc = PsLoc loc (BufPos 0)@@ -2791,67 +2878,77 @@   --   to the accumulator and parsing continues. This allows GHC to report   --   more than one parse error per file.   ---  addError :: SrcSpan -> SDoc -> m ()+  addError :: PsError -> m ()+   -- | Add a warning to the accumulator.   --   Use 'getMessages' to get the accumulated warnings.-  addWarning :: WarningFlag -> SrcSpan -> SDoc -> m ()+  addWarning :: WarningFlag -> PsWarning -> m ()+   -- | Add a fatal error. This will be the last error reported by the parser, and   --   the parser will not produce any result, ending in a 'PFailed' state.-  addFatalError :: SrcSpan -> SDoc -> m a+  addFatalError :: PsError -> m a+   -- | Check if a given flag is currently set in the bitmap.   getBit :: ExtBits -> m Bool-  -- | Given a location and a list of AddAnn, apply them all to the location.-  addAnnotation :: SrcSpan          -- SrcSpan of enclosing AST construct-                -> AnnKeywordId     -- The first two parameters are the key-                -> SrcSpan          -- The location of the keyword itself-                -> m ()+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that belong within the given span+  allocateCommentsP :: RealSrcSpan -> m EpAnnComments+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that come before or within the given span+  allocatePriorCommentsP :: RealSrcSpan -> m EpAnnComments+  -- | Go through the @comment_q@ in @PState@ and remove all comments+  -- that come after the given span+  allocateFinalCommentsP :: RealSrcSpan -> m EpAnnComments -appendError-  :: SrcSpan-  -> SDoc-  -> (DynFlags -> Messages)-  -> (DynFlags -> Messages)-appendError srcspan msg m =-  \d ->-    let (ws, es) = m d-        errormsg = mkErrMsg d srcspan alwaysQualify msg-        es' = es `snocBag` errormsg-    in (ws, es')+instance MonadP P where+  addError err+   = P $ \s -> POk s { errors = err `consBag` errors s} () -appendWarning-  :: ParserFlags-  -> WarningFlag-  -> SrcSpan-  -> SDoc-  -> (DynFlags -> Messages)-  -> (DynFlags -> Messages)-appendWarning o option srcspan warning m =-  \d ->-    let (ws, es) = m d-        warning' = makeIntoWarning (Reason option) $-           mkWarnMsg d srcspan alwaysQualify warning-        ws' = if warnopt option o then ws `snocBag` warning' else ws-    in (ws', es)+  addWarning option w+   = P $ \s -> if warnopt option (options s)+                  then POk (s { warnings = w `consBag` warnings s }) ()+                  else POk s () -instance MonadP P where-  addError srcspan msg-   = P $ \s@PState{messages=m} ->-             POk s{messages=appendError srcspan msg m} ()-  addWarning option srcspan warning-   = P $ \s@PState{messages=m, options=o} ->-             POk s{messages=appendWarning o option srcspan warning m} ()-  addFatalError span msg =-    addError span msg >> P PFailed+  addFatalError err =+    addError err >> P PFailed+   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)                          in b `seq` POk s b-  addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) = do-    addAnnotationOnly l a v-    allocateCommentsP l-  addAnnotation _ _ _ = return ()+  allocateCommentsP ss = P $ \s ->+    let (comment_q', newAnns) = allocateComments ss (comment_q s) in+      POk s {+         comment_q = comment_q'+       } (EpaComments newAnns)+  allocatePriorCommentsP ss = P $ \s ->+    let (header_comments', comment_q', newAnns)+             = allocatePriorComments ss (comment_q s) (header_comments s) in+      POk s {+         header_comments = header_comments',+         comment_q = comment_q'+       } (EpaComments newAnns)+  allocateFinalCommentsP ss = P $ \s ->+    let (header_comments', comment_q', newAnns)+             = allocateFinalComments ss (comment_q s) (header_comments s) in+      POk s {+         header_comments = header_comments',+         comment_q = comment_q'+       } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns)) -addAnnsAt :: MonadP m => SrcSpan -> [AddAnn] -> m ()-addAnnsAt l = mapM_ (\(AddAnn a v) -> addAnnotation l a v)+getCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getCommentsFor (RealSrcSpan l _) = allocateCommentsP l+getCommentsFor _ = return emptyComments +getPriorCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getPriorCommentsFor (RealSrcSpan l _) = allocatePriorCommentsP l+getPriorCommentsFor _ = return emptyComments++getFinalCommentsFor :: (MonadP m) => SrcSpan -> m EpAnnComments+getFinalCommentsFor (RealSrcSpan l _) = allocateFinalCommentsP l+getFinalCommentsFor _ = return emptyComments++getEofPos :: P (Maybe (RealSrcSpan, RealSrcSpan))+getEofPos = P $ \s@(PState { eof_pos = pos }) -> POk s pos+ addTabWarning :: RealSrcSpan -> P () addTabWarning srcspan  = P $ \s@PState{tab_first=tf, tab_count=tc, options=o} ->@@ -2862,32 +2959,23 @@                 else s        in POk s' () -mkTabWarning :: PState -> DynFlags -> Maybe ErrMsg-mkTabWarning PState{tab_first=tf, tab_count=tc} d =-  let middle = if tc == 1-        then text ""-        else text ", and in" <+> speakNOf (tc - 1) (text "further location")-      message = text "Tab character found here"-                <> middle-                <> text "."-                $+$ text "Please use spaces instead."-  in fmap (\s -> makeIntoWarning (Reason Opt_WarnTabs) $-                 mkWarnMsg d (RealSrcSpan s Nothing) alwaysQualify message) tf- -- | Get a bag of the errors that have been accumulated so far. --   Does not take -Werror into account.-getErrorMessages :: PState -> DynFlags -> ErrorMessages-getErrorMessages PState{messages=m} d =-  let (_, es) = m d in es+getErrorMessages :: PState -> Bag PsError+getErrorMessages p = errors p  -- | Get the warnings and errors accumulated so far. --   Does not take -Werror into account.-getMessages :: PState -> DynFlags -> Messages-getMessages p@PState{messages=m} d =-  let (ws, es) = m d-      tabwarning = mkTabWarning p d-      ws' = maybe ws (`consBag` ws) tabwarning-  in (ws', es)+getMessages :: PState -> (Bag PsWarning, Bag PsError)+getMessages p =+  let ws = warnings p+      -- we add the tabulation warning on the fly because+      -- we count the number of occurrences of tab characters+      ws' = case tab_first p of+               Nothing -> ws+               Just tf -> PsWarnTab (RealSrcSpan tf Nothing) (tab_count p)+                           `consBag` ws+  in (ws', errors p)  getContext :: P [LayoutContext] getContext = P $ \s@PState{context=ctx} -> POk s ctx@@ -2902,7 +2990,7 @@         (_:tl) ->           POk s{ context = tl } ()         []     ->-          unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s+          unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s  -- Push a new layout context at the indentation of the last token read. pushCurrentContext :: GenSemic -> P ()@@ -2929,48 +3017,47 @@ -- Construct a parse error  srcParseErr-  :: ParserFlags+  :: ParserOpts   -> StringBuffer       -- current buffer (placed just after the last token)   -> Int                -- length of the previous token-  -> MsgDoc-srcParseErr options buf len-  = if null token-         then text "parse error (possibly incorrect indentation or mismatched brackets)"-         else text "parse error on input" <+> quotes (text token)-              $$ ppWhen (not th_enabled && token == "$") -- #7396-                        (text "Perhaps you intended to use TemplateHaskell")-              $$ ppWhen (token == "<-")-                        (if mdoInLast100-                           then text "Perhaps you intended to use RecursiveDo"-                           else text "Perhaps this statement should be within a 'do' block?")-              $$ ppWhen (token == "=" && doInLast100) -- #15849-                        (text "Perhaps you need a 'let' in a 'do' block?"-                         $$ text "e.g. 'let x = 5' instead of 'x = 5'")-              $$ ppWhen (not ps_enabled && pattern == "pattern ") -- #12429-                        (text "Perhaps you intended to use PatternSynonyms")-  where token = lexemeToString (offsetBytes (-len) buf) len-        pattern = decodePrevNChars 8 buf-        last100 = decodePrevNChars 100 buf-        doInLast100 = "do" `isInfixOf` last100-        mdoInLast100 = "mdo" `isInfixOf` last100-        th_enabled = ThQuotesBit `xtest` pExtsBitmap options-        ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options+  -> SrcSpan+  -> PsError+srcParseErr options buf len loc = PsError (PsErrParse token) suggests loc+  where+   token = lexemeToString (offsetBytes (-len) buf) len+   pattern = decodePrevNChars 8 buf+   last100 = decodePrevNChars 100 buf+   doInLast100 = "do" `isInfixOf` last100+   mdoInLast100 = "mdo" `isInfixOf` last100+   th_enabled = ThQuotesBit `xtest` pExtsBitmap options+   ps_enabled = PatternSynonymsBit `xtest` pExtsBitmap options +   sug c s = if c then Just s else Nothing+   sug_th  = sug (not th_enabled && token == "$")          SuggestTH              -- #7396+   sug_rdo = sug (token == "<-" && mdoInLast100)           SuggestRecursiveDo+   sug_do  = sug (token == "<-" && not mdoInLast100)       SuggestDo+   sug_let = sug (token == "=" && doInLast100)             SuggestLetInDo         -- #15849+   sug_pat = sug (not ps_enabled && pattern == "pattern ") SuggestPatternSynonyms -- #12429+   suggests+         | null token = []+         | otherwise  = catMaybes [sug_th, sug_rdo, sug_do, sug_let, sug_pat]+ -- Report a parse failure, giving the span of the previous token as -- the location of the error.  This is the entry point for errors -- detected during parsing. srcParseFail :: P a srcParseFail = P $ \s@PState{ buffer = buf, options = o, last_len = len,                             last_loc = last_loc } ->-    unP (addFatalError (mkSrcSpanPs last_loc) (srcParseErr o buf len)) s+    unP (addFatalError $ srcParseErr o buf len (mkSrcSpanPs last_loc)) s  -- A lexical error is reported at a particular position in the source file, -- not over a token range.-lexError :: String -> P a-lexError str = do+lexError :: LexErr -> P a+lexError e = do   loc <- getRealSrcLoc   (AI end buf) <- getInput-  reportLexError loc (psRealLoc end) buf str+  reportLexError loc (psRealLoc end) buf+    (\k -> PsError (PsErrLexer e k) [])  -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a@@ -3086,9 +3173,7 @@              (ITwhere, ALRLayout _ col : ls, _)               | newLine && thisCol == col && transitional ->                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional-                               (mkSrcSpanPs thisLoc)-                               (transitionalAlternativeLayoutWarning-                                    "`where' clause at the same depth as implicit layout block")+                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Where                     setALRContext ls                     setNextToken t                     -- Note that we use lastLoc, as we may need to close@@ -3098,9 +3183,7 @@              (ITvbar, ALRLayout _ col : ls, _)               | newLine && thisCol == col && transitional ->                  do addWarning Opt_WarnAlternativeLayoutRuleTransitional-                               (mkSrcSpanPs thisLoc)-                               (transitionalAlternativeLayoutWarning-                                    "`|' at the same depth as implicit layout block")+                      $ PsWarnTransitionalLayout (mkSrcSpanPs thisLoc) TransLayout_Pipe                     setALRContext ls                     setNextToken t                     -- Note that we use lastLoc, as we may need to close@@ -3167,11 +3250,6 @@              -- the other ITwhere case omitted; general case below covers it              (_, _, _) -> return t -transitionalAlternativeLayoutWarning :: String -> SDoc-transitionalAlternativeLayoutWarning msg-    = text "transitional layout will not be accepted in the future:"-   $$ text msg- isALRopen :: Token -> Bool isALRopen ITcase          = True isALRopen ITif            = True@@ -3222,11 +3300,13 @@   case alexScanUser exts inp sc of     AlexEOF -> do         let span = mkPsSpan loc1 loc1-        setEofPos (psRealSpan span)+        lt <- getLastLocEof+        setEofPos (psRealSpan span) (psRealSpan lt)         setLastToken span 0         return (L span ITeof)     AlexError (AI loc2 buf) ->-        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf "lexical error"+        reportLexError (psRealLoc loc1) (psRealLoc loc2) buf+          (\k -> PsError (PsErrLexer LexError k) [])     AlexSkip inp2 _ -> do         setInput inp2         lexToken@@ -3237,34 +3317,38 @@         span `seq` setLastToken span bytes         lt <- t span buf bytes         let lt' = unLoc lt-        unless (isComment lt') (setLastTk lt')+        if (isComment lt') then setLastComment lt else setLastTk lt         return lt -reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a-reportLexError loc1 loc2 buf str-  | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input")+reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> (LexErrKind -> SrcSpan -> PsError) -> P a+reportLexError loc1 loc2 buf f+  | atEnd buf = failLocMsgP loc1 loc2 (f LexErrKind_EOF)   | otherwise =   let c = fst (nextChar buf)   in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar#-     then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)")-     else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c)+     then failLocMsgP loc2 loc2 (f LexErrKind_UTF8)+     else failLocMsgP loc1 loc2 (f (LexErrKind_Char c)) -lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token]-lexTokenStream buf loc dflags = unP go initState{ options = opts' }-    where dflags' = gopt_set (gopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream-          initState@PState{ options = opts } = mkPState dflags' buf loc-          opts' = opts{ pExtsBitmap = complement (xbit UsePosPragsBit) .&. pExtsBitmap opts }-          go = do-            ltok <- lexer False return-            case ltok of-              L _ ITeof -> return []-              _ -> liftM (ltok:) go+lexTokenStream :: ParserOpts -> StringBuffer -> RealSrcLoc -> ParseResult [Located Token]+lexTokenStream opts buf loc = unP go initState{ options = opts' }+    where+    new_exts  = xunset HaddockBit        -- disable Haddock+                $ xunset UsePosPragsBit  -- parse LINE/COLUMN pragmas as tokens+                $ xset RawTokenStreamBit -- include comments+                $ pExtsBitmap opts+    opts'     = opts { pExtsBitmap = new_exts }+    initState = initParserState opts' buf loc+    go = do+      ltok <- lexer False return+      case ltok of+        L _ ITeof -> return []+        _ -> liftM (ltok:) go  linePrags = Map.singleton "line" linePrag  fileHeaderPrags = Map.fromList([("options", lex_string_prag IToptions_prag),                                  ("options_ghc", lex_string_prag IToptions_prag),-                                 ("options_haddock", lex_string_prag ITdocOptions),+                                 ("options_haddock", lex_string_prag_comment ITdocOptions),                                  ("language", token ITlanguage_prag),                                  ("include", lex_string_prag ITinclude_prag)]) @@ -3291,7 +3375,6 @@      ("warning", strtoken (\s -> ITwarning_prag (SourceText s))),      ("deprecated", strtoken (\s -> ITdeprecated_prag (SourceText s))),      ("scc", strtoken (\s -> ITscc_prag (SourceText s))),-     ("generated", strtoken (\s -> ITgenerated_prag (SourceText s))),      ("unpack", strtoken (\s -> ITunpack_prag (SourceText s))),      ("nounpack", strtoken (\s -> ITnounpack_prag (SourceText s))),      ("ann", strtoken (\s -> ITann_prag (SourceText s))),@@ -3319,7 +3402,7 @@ dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of                                        Just found -> found span buf len-                                       Nothing -> lexError "unknown pragma"+                                       Nothing -> lexError LexUnknownPragma  known_pragma :: Map String Action -> AlexAccPred ExtsBitmap known_pragma prags _ (AI _ startbuf) _ (AI _ curbuf)@@ -3351,61 +3434,93 @@ -}  -addAnnotationOnly :: RealSrcSpan -> AnnKeywordId -> RealSrcSpan -> P ()-addAnnotationOnly l a v = P $ \s -> POk s {-  annotations = ((l,a), [v]) : annotations s-  } ()-+-- |Given a 'RealSrcSpan' that surrounds a 'HsPar' or 'HsParTy', generate+-- 'AddEpAnn' values for the opening and closing bordering on the start+-- and end of the span+mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo),AddEpAnn AnnCloseP (EpaSpan lc))+  where+    f = srcSpanFile ss+    sl = srcSpanStartLine ss+    sc = srcSpanStartCol ss+    el = srcSpanEndLine ss+    ec = srcSpanEndCol ss+    lo = mkRealSrcSpan (realSrcSpanStart ss)        (mkRealSrcLoc f sl (sc+1))+    lc = mkRealSrcSpan (mkRealSrcLoc f el (ec - 1)) (realSrcSpanEnd ss)  queueComment :: RealLocated Token -> P() queueComment c = P $ \s -> POk s {   comment_q = commentToAnnotation c : comment_q s   } () --- | Go through the @comment_q@ in @PState@ and remove all comments--- that belong within the given span-allocateCommentsP :: RealSrcSpan -> P ()-allocateCommentsP ss = P $ \s ->-  let (comment_q', newAnns) = allocateComments ss (comment_q s) in-    POk s {-       comment_q = comment_q'-     , annotations_comments = newAnns ++ (annotations_comments s)-     } ()- allocateComments   :: RealSrcSpan-  -> [RealLocated AnnotationComment]-  -> ([RealLocated AnnotationComment], [(RealSrcSpan,[RealLocated AnnotationComment])])+  -> [LEpaComment]+  -> ([LEpaComment], [LEpaComment]) allocateComments ss comment_q =   let-    (before,rest)  = break (\(L l _) -> isRealSubspanOf l ss) comment_q-    (middle,after) = break (\(L l _) -> not (isRealSubspanOf l ss)) rest+    (before,rest)  = break (\(L l _) -> isRealSubspanOf (anchor l) ss) comment_q+    (middle,after) = break (\(L l _) -> not (isRealSubspanOf (anchor l) ss)) rest     comment_q' = before ++ after-    newAnns = if null middle then []-                             else [(ss,middle)]+    newAnns = middle   in     (comment_q', newAnns) +allocatePriorComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> Maybe [LEpaComment]+  -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])+allocatePriorComments ss comment_q mheader_comments =+  let+    cmp (L l _) = anchor l <= ss+    (before,after) = partition cmp comment_q+    newAnns = before+    comment_q'= after+  in+    case mheader_comments of+      Nothing -> (Just newAnns, comment_q', [])+      Just _ -> (mheader_comments, comment_q', newAnns) -commentToAnnotation :: RealLocated Token -> RealLocated AnnotationComment-commentToAnnotation (L l (ITdocCommentNext s))  = L l (AnnDocCommentNext s)-commentToAnnotation (L l (ITdocCommentPrev s))  = L l (AnnDocCommentPrev s)-commentToAnnotation (L l (ITdocCommentNamed s)) = L l (AnnDocCommentNamed s)-commentToAnnotation (L l (ITdocSection n s))    = L l (AnnDocSection n s)-commentToAnnotation (L l (ITdocOptions s))      = L l (AnnDocOptions s)-commentToAnnotation (L l (ITlineComment s))     = L l (AnnLineComment s)-commentToAnnotation (L l (ITblockComment s))    = L l (AnnBlockComment s)+allocateFinalComments+  :: RealSrcSpan+  -> [LEpaComment]+  -> Maybe [LEpaComment]+  -> (Maybe [LEpaComment], [LEpaComment], [LEpaComment])+allocateFinalComments ss comment_q mheader_comments =+  let+    cmp (L l _) = anchor l <= ss+    (before,after) = partition cmp comment_q+    newAnns = after+    comment_q'= before+  in+    case mheader_comments of+      Nothing -> (Just newAnns,    [], comment_q')+      Just _ -> (mheader_comments, [], comment_q' ++ newAnns)++commentToAnnotation :: RealLocated Token -> LEpaComment+commentToAnnotation (L l (ITdocCommentNext s ll))  = mkLEpaComment l ll (EpaDocCommentNext s)+commentToAnnotation (L l (ITdocCommentPrev s ll))  = mkLEpaComment l ll (EpaDocCommentPrev s)+commentToAnnotation (L l (ITdocCommentNamed s ll)) = mkLEpaComment l ll (EpaDocCommentNamed s)+commentToAnnotation (L l (ITdocSection n s ll))    = mkLEpaComment l ll (EpaDocSection n s)+commentToAnnotation (L l (ITdocOptions s ll))      = mkLEpaComment l ll (EpaDocOptions s)+commentToAnnotation (L l (ITlineComment s ll))     = mkLEpaComment l ll (EpaLineComment s)+commentToAnnotation (L l (ITblockComment s ll))    = mkLEpaComment l ll (EpaBlockComment s) commentToAnnotation _                           = panic "commentToAnnotation" +-- see Note [PsSpan in Comments]+mkLEpaComment :: RealSrcSpan -> PsSpan -> EpaCommentTok -> LEpaComment+mkLEpaComment l ll tok = L (realSpanAsAnchor l) (EpaComment tok (psRealSpan ll))+ -- ---------------------------------------------------------------------  isComment :: Token -> Bool-isComment (ITlineComment     _)   = True-isComment (ITblockComment    _)   = True-isComment (ITdocCommentNext  _)   = True-isComment (ITdocCommentPrev  _)   = True-isComment (ITdocCommentNamed _)   = True-isComment (ITdocSection      _ _) = True-isComment (ITdocOptions      _)   = True+isComment (ITlineComment     _ _)   = True+isComment (ITblockComment    _ _)   = True+isComment (ITdocCommentNext  _ _)   = True+isComment (ITdocCommentPrev  _ _)   = True+isComment (ITdocCommentNamed _ _)   = True+isComment (ITdocSection      _ _ _) = True+isComment (ITdocOptions      _ _)   = True isComment _ = False }

GHC/Parser/PostProcess.hs view

@@ -1,3089 +1,2993 @@------  (c) The University of Glasgow 2002-2006------- Functions over HsSyn specialised to RdrName.--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module GHC.Parser.PostProcess (-        mkHsOpApp,-        mkHsIntegral, mkHsFractional, mkHsIsString,-        mkHsDo, mkSpliceDecl,-        mkRoleAnnotDecl,-        mkClassDecl,-        mkTyData, mkDataFamInst,-        mkTySynonym, mkTyFamInstEqn,-        mkStandaloneKindSig,-        mkTyFamInst,-        mkFamDecl, mkLHsSigType,-        mkInlinePragma,-        mkPatSynMatchGroup,-        mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp-        mkTyClD, mkInstD,-        mkRdrRecordCon, mkRdrRecordUpd,-        setRdrNameSpace,-        filterCTuple,-        fromSpecTyVarBndr, fromSpecTyVarBndrs,--        cvBindGroup,-        cvBindsAndSigs,-        cvTopDecls,-        placeHolderPunRhs,--        -- Stuff to do with Foreign declarations-        mkImport,-        parseCImport,-        mkExport,-        mkExtName,    -- RdrName -> CLabelString-        mkGadtDecl,   -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName-        mkConDeclH98,--        -- Bunch of functions in the parser monad for-        -- checking and constructing values-        checkImportDecl,-        checkExpBlockArguments, checkCmdBlockArguments,-        checkPrecP,           -- Int -> P Int-        checkContext,         -- HsType -> P HsContext-        checkPattern,         -- HsExp -> P HsPat-        checkPattern_msg,-        checkMonadComp,       -- P (HsStmtContext GhcPs)-        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl-        checkValSigLhs,-        LRuleTyTmVar, RuleTyTmVar(..),-        mkRuleBndrs, mkRuleTyVarBndrs,-        checkRuleTyVarBndrNames,-        checkRecordSyntax,-        checkEmptyGADTs,-        addFatalError, hintBangPat,-        TyEl(..), mergeOps, mergeDataCon,-        mkBangTy,-        mkMultTy,--        -- Help with processing exports-        ImpExpSubSpec(..),-        ImpExpQcSpec(..),-        mkModuleImpExp,-        mkTypeImpExp,-        mkImpExpSubSpec,-        checkImportSpec,--        -- Token symbols-        forallSym,-        starSym,--        -- Warnings and errors-        warnStarIsType,-        warnPrepositiveQualifiedModule,-        failOpFewArgs,-        failOpNotEnabledImportQualifiedPost,-        failOpImportQualifiedTwice,--        SumOrTuple (..),--        -- Expression/command/pattern ambiguity resolution-        PV,-        runPV,-        ECP(ECP, runECP_PV),-        runECP_P,-        DisambInfixOp(..),-        DisambECP(..),-        ecpFromExp,-        ecpFromCmd,-        PatBuilder-    ) where--import GHC.Prelude-import GHC.Hs           -- Lots of it-import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )-import GHC.Core.DataCon        ( DataCon, dataConTyCon )-import GHC.Core.ConLike        ( ConLike(..) )-import GHC.Core.Coercion.Axiom ( Role, fsFromRole )-import GHC.Types.Name.Reader-import GHC.Types.Name-import GHC.Unit.Module (ModuleName)-import GHC.Types.Basic-import GHC.Parser.Lexer-import GHC.Utils.Lexeme ( isLexCon )-import GHC.Core.Type    ( TyThing(..), unrestrictedFunTyCon, Specificity(..) )-import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,-                          nilDataConName, nilDataConKey,-                          listTyConName, listTyConKey, eqTyCon_RDR,-                          tupleTyConName, cTupleTyConNameArity_maybe )-import GHC.Types.ForeignCall-import GHC.Builtin.Names ( allNameStrings )-import GHC.Types.SrcLoc-import GHC.Types.Unique ( hasKey )-import GHC.Data.OrdList ( OrdList, fromOL )-import GHC.Utils.Outputable as Outputable-import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Utils.Misc-import GHC.Parser.Annotation-import Data.List-import GHC.Driver.Session ( WarningFlag(..), DynFlags )-import GHC.Utils.Error ( Messages )--import Control.Monad-import Text.ParserCombinators.ReadP as ReadP-import Data.Char-import qualified Data.Monoid as Monoid-import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )-import Data.Kind       ( Type )--#include "HsVersions.h"---{- **********************************************************************--  Construction functions for Rdr stuff--  ********************************************************************* -}---- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and--- datacon by deriving them from the name of the class.  We fill in the names--- for the tycon and datacon corresponding to the class, by deriving them--- from the name of the class itself.  This saves recording the names in the--- interface file (which would be equally good).---- Similarly for mkConDecl, mkClassOpSig and default-method names.----         *** See Note [The Naming story] in GHC.Hs.Decls ****--mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)-mkTyClD (L loc d) = L loc (TyClD noExtField d)--mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)-mkInstD (L loc d) = L loc (InstD noExtField d)--mkClassDecl :: SrcSpan-            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)-            -> Located (a,[LHsFunDep GhcPs])-            -> OrdList (LHsDecl GhcPs)-            -> LayoutInfo-            -> P (LTyClDecl GhcPs)--mkClassDecl loc (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo-  = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls-       ; let cxt = fromMaybe (noLoc []) mcxt-       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr-       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan-       ; (tyvars,annst) <- checkTyVars (text "class") whereDots cls tparams-       ; addAnnsAt loc annst -- Add any API Annotations to the top SrcSpan-       ; return (L loc (ClassDecl { tcdCExt = layoutInfo-                                  , tcdCtxt = cxt-                                  , tcdLName = cls, tcdTyVars = tyvars-                                  , tcdFixity = fixity-                                  , tcdFDs = snd (unLoc fds)-                                  , tcdSigs = mkClassOpSigs sigs-                                  , tcdMeths = binds-                                  , tcdATs = ats, tcdATDefs = at_defs-                                  , tcdDocs  = docs })) }--mkTyData :: SrcSpan-         -> NewOrData-         -> Maybe (Located CType)-         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)-         -> Maybe (LHsKind GhcPs)-         -> [LConDecl GhcPs]-         -> HsDeriving GhcPs-         -> P (LTyClDecl GhcPs)-mkTyData loc new_or_data cType (L _ (mcxt, tycl_hdr))-         ksig data_cons maybe_deriv-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr-       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan-       ; (tyvars, anns) <- checkTyVars (ppr new_or_data) equalsDots tc tparams-       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan-       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv-       ; return (L loc (DataDecl { tcdDExt = noExtField,-                                   tcdLName = tc, tcdTyVars = tyvars,-                                   tcdFixity = fixity,-                                   tcdDataDefn = defn })) }--mkDataDefn :: NewOrData-           -> Maybe (Located CType)-           -> Maybe (LHsContext GhcPs)-           -> Maybe (LHsKind GhcPs)-           -> [LConDecl GhcPs]-           -> HsDeriving GhcPs-           -> P (HsDataDefn GhcPs)-mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv-  = do { checkDatatypeContext mcxt-       ; let cxt = fromMaybe (noLoc []) mcxt-       ; return (HsDataDefn { dd_ext = noExtField-                            , dd_ND = new_or_data, dd_cType = cType-                            , dd_ctxt = cxt-                            , dd_cons = data_cons-                            , dd_kindSig = ksig-                            , dd_derivs = maybe_deriv }) }---mkTySynonym :: SrcSpan-            -> LHsType GhcPs  -- LHS-            -> LHsType GhcPs  -- RHS-            -> P (LTyClDecl GhcPs)-mkTySynonym loc lhs rhs-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan-       ; (tyvars, anns) <- checkTyVars (text "type") equalsDots tc tparams-       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan-       ; return (L loc (SynDecl { tcdSExt = noExtField-                                , tcdLName = tc, tcdTyVars = tyvars-                                , tcdFixity = fixity-                                , tcdRhs = rhs })) }--mkStandaloneKindSig-  :: SrcSpan-  -> Located [Located RdrName] -- LHS-  -> LHsKind GhcPs             -- RHS-  -> P (LStandaloneKindSig GhcPs)-mkStandaloneKindSig loc lhs rhs =-  do { vs <- mapM check_lhs_name (unLoc lhs)-     ; v <- check_singular_lhs (reverse vs)-     ; return $ L loc $ StandaloneKindSig noExtField v (mkLHsSigType rhs) }-  where-    check_lhs_name v@(unLoc->name) =-      if isUnqual name && isTcOcc (rdrNameOcc name)-      then return v-      else addFatalError (getLoc v) $-           hang (text "Expected an unqualified type constructor:") 2 (ppr v)-    check_singular_lhs vs =-      case vs of-        [] -> panic "mkStandaloneKindSig: empty left-hand side"-        [v] -> return v-        _ -> addFatalError (getLoc lhs) $-             vcat [ hang (text "Standalone kind signatures do not support multiple names at the moment:")-                       2 (pprWithCommas ppr vs)-                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/16754 for details." ]--mkTyFamInstEqn :: Maybe [LHsTyVarBndr () GhcPs]-               -> LHsType GhcPs-               -> LHsType GhcPs-               -> P (TyFamInstEqn GhcPs,[AddAnn])-mkTyFamInstEqn bndrs lhs rhs-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; return (mkHsImplicitBndrs-                  (FamEqn { feqn_ext    = noExtField-                          , feqn_tycon  = tc-                          , feqn_bndrs  = bndrs-                          , feqn_pats   = tparams-                          , feqn_fixity = fixity-                          , feqn_rhs    = rhs }),-                 ann) }--mkDataFamInst :: SrcSpan-              -> NewOrData-              -> Maybe (Located CType)-              -> (Maybe ( LHsContext GhcPs), Maybe [LHsTyVarBndr () GhcPs]-                        , LHsType GhcPs)-              -> Maybe (LHsKind GhcPs)-              -> [LConDecl GhcPs]-              -> HsDeriving GhcPs-              -> P (LInstDecl GhcPs)-mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)-              ksig data_cons maybe_deriv-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr-       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan-       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv-       ; return (L loc (DataFamInstD noExtField (DataFamInstDecl (mkHsImplicitBndrs-                  (FamEqn { feqn_ext    = noExtField-                          , feqn_tycon  = tc-                          , feqn_bndrs  = bndrs-                          , feqn_pats   = tparams-                          , feqn_fixity = fixity-                          , feqn_rhs    = defn }))))) }--mkTyFamInst :: SrcSpan-            -> TyFamInstEqn GhcPs-            -> P (LInstDecl GhcPs)-mkTyFamInst loc eqn-  = return (L loc (TyFamInstD noExtField (TyFamInstDecl eqn)))--mkFamDecl :: SrcSpan-          -> FamilyInfo GhcPs-          -> LHsType GhcPs                   -- LHS-          -> Located (FamilyResultSig GhcPs) -- Optional result signature-          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation-          -> P (LTyClDecl GhcPs)-mkFamDecl loc info lhs ksig injAnn-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; addAnnsAt loc ann -- Add any API Annotations to the top SrcSpan-       ; (tyvars, anns) <- checkTyVars (ppr info) equals_or_where tc tparams-       ; addAnnsAt loc anns -- Add any API Annotations to the top SrcSpan-       ; return (L loc (FamDecl noExtField (FamilyDecl-                                           { fdExt       = noExtField-                                           , fdInfo      = info, fdLName = tc-                                           , fdTyVars    = tyvars-                                           , fdFixity    = fixity-                                           , fdResultSig = ksig-                                           , fdInjectivityAnn = injAnn }))) }-  where-    equals_or_where = case info of-                        DataFamily          -> empty-                        OpenTypeFamily      -> empty-                        ClosedTypeFamily {} -> whereDots--mkSpliceDecl :: LHsExpr GhcPs -> HsDecl GhcPs--- If the user wrote---      [pads| ... ]   then return a QuasiQuoteD---      $(e)           then return a SpliceD--- but if she wrote, say,---      f x            then behave as if she'd written $(f x)---                     ie a SpliceD------ Typed splices are not allowed at the top level, thus we do not represent them--- as spliced declaration.  See #10945-mkSpliceDecl lexpr@(L loc expr)-  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr-  = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)--  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr-  = SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)--  | otherwise-  = SpliceD noExtField (SpliceDecl noExtField (L loc (mkUntypedSplice BareSplice lexpr))-                              ImplicitSplice)--mkRoleAnnotDecl :: SrcSpan-                -> Located RdrName                -- type being annotated-                -> [Located (Maybe FastString)]      -- roles-                -> P (LRoleAnnotDecl GhcPs)-mkRoleAnnotDecl loc tycon roles-  = do { roles' <- mapM parse_role roles-       ; return $ L loc $ RoleAnnotDecl noExtField tycon roles' }-  where-    role_data_type = dataTypeOf (undefined :: Role)-    all_roles = map fromConstr $ dataTypeConstrs role_data_type-    possible_roles = [(fsFromRole role, role) | role <- all_roles]--    parse_role (L loc_role Nothing) = return $ L loc_role Nothing-    parse_role (L loc_role (Just role))-      = case lookup role possible_roles of-          Just found_role -> return $ L loc_role $ Just found_role-          Nothing         ->-            let nearby = fuzzyLookup (unpackFS role)-                  (mapFst unpackFS possible_roles)-            in-            addFatalError loc_role-              (text "Illegal role name" <+> quotes (ppr role) $$-               suggestions nearby)--    suggestions []   = empty-    suggestions [r]  = text "Perhaps you meant" <+> quotes (ppr r)-      -- will this last case ever happen??-    suggestions list = hang (text "Perhaps you meant one of these:")-                       2 (pprWithCommas (quotes . ppr) list)---- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to--- binders without annotations. Only accepts specified variables, and errors if--- any of the provided binders has an 'InferredSpec' annotation.-fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]-fromSpecTyVarBndrs = mapM fromSpecTyVarBndr---- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without--- annotations. Only accepts specified variables, and errors if the provided--- binder has an 'InferredSpec' annotation.-fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)-fromSpecTyVarBndr bndr = case bndr of-  (L loc (UserTyVar xtv flag idp))     -> (check_spec flag loc)-                                          >> return (L loc $ UserTyVar xtv () idp)-  (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)-                                          >> return (L loc $ KindedTyVar xtv () idp k)-  where-    check_spec :: Specificity -> SrcSpan -> P ()-    check_spec SpecifiedSpec _   = return ()-    check_spec InferredSpec  loc = addFatalError loc-                                   (text "Inferred type variables are not allowed here")--{- **********************************************************************--  #cvBinds-etc# Converting to @HsBinds@, etc.--  ********************************************************************* -}---- | Function definitions are restructured here. Each is assumed to be recursive--- initially, and non recursive definitions are discovered by the dependency--- analyser.-----  | Groups together bindings for a single function-cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]-cvTopDecls decls = getMonoBindAll (fromOL decls)---- Declaration list may only contain value bindings and signatures.-cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)-cvBindGroup binding-  = do { (mbs, sigs, fam_ds, tfam_insts-         , dfam_insts, _) <- cvBindsAndSigs binding-       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)-         return $ ValBinds noExtField mbs sigs }--cvBindsAndSigs :: OrdList (LHsDecl GhcPs)-  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]-          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])--- Input decls contain just value bindings and signatures--- and in case of class or instance declarations also--- associated type declarations. They might also contain Haddock comments.-cvBindsAndSigs fb = do-  fb' <- drop_bad_decls (fromOL fb)-  return (partitionBindsAndSigs (getMonoBindAll fb'))-  where-    -- cvBindsAndSigs is called in several places in the parser,-    -- and its items can be produced by various productions:-    ---    --    * decl       (when parsing a where clause or a let-expression)-    --    * decl_inst  (when parsing an instance declaration)-    --    * decl_cls   (when parsing a class declaration)-    ---    -- partitionBindsAndSigs can handle almost all declaration forms produced-    -- by the aforementioned productions, except for SpliceD, which we filter-    -- out here (in drop_bad_decls).-    ---    -- We're not concerned with every declaration form possible, such as those-    -- produced by the topdecl parser production, because cvBindsAndSigs is not-    -- called on top-level declarations.-    drop_bad_decls [] = return []-    drop_bad_decls (L l (SpliceD _ d) : ds) = do-      addError l $-        hang (text "Declaration splices are allowed only" <+>-              text "at the top level:")-           2 (ppr d)-      drop_bad_decls ds-    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds---------------------------------------------------------------------------------- Group function bindings into equation groups--getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]-  -> (LHsBind GhcPs, [LHsDecl GhcPs])--- Suppose      (b',ds') = getMonoBind b ds---      ds is a list of parsed bindings---      b is a MonoBinds that has just been read off the front---- Then b' is the result of grouping more equations from ds that--- belong with b into a single MonoBinds, and ds' is the depleted--- list of parsed bindings.------ All Haddock comments between equations inside the group are--- discarded.------ No AndMonoBinds or EmptyMonoBinds here; just single equations--getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)-                             , fun_matches =-                               MG { mg_alts = (L _ mtchs1) } }))-            binds-  | has_args mtchs1-  = go mtchs1 loc1 binds []-  where-    go mtchs loc-       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)-                                 , fun_matches =-                                    MG { mg_alts = (L _ mtchs2) } })))-         : binds) _-        | f1 == f2 = go (mtchs2 ++ mtchs)-                        (combineSrcSpans loc loc2) binds []-    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls-        = let doc_decls' = doc_decl : doc_decls-          in go mtchs (combineSrcSpans loc loc2) binds doc_decls'-    go mtchs loc binds doc_decls-        = ( L loc (makeFunBind fun_id1 (reverse mtchs))-          , (reverse doc_decls) ++ binds)-        -- Reverse the final matches, to get it back in the right order-        -- Do the same thing with the trailing doc comments--getMonoBind bind binds = (bind, binds)---- Group together adjacent FunBinds for every function.-getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]-getMonoBindAll [] = []-getMonoBindAll (L l (ValD _ b) : ds) =-  let (L l' b', ds') = getMonoBind (L l b) ds-  in L l' (ValD noExtField b') : getMonoBindAll ds'-getMonoBindAll (d : ds) = d : getMonoBindAll ds--has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool-has_args []                                  = panic "GHC.Parser.PostProcess.has_args"-has_args (L _ (Match { m_pats = args }) : _) = not (null args)-        -- Don't group together FunBinds if they have-        -- no arguments.  This is necessary now that variable bindings-        -- with no arguments are now treated as FunBinds rather-        -- than pattern bindings (tests/rename/should_fail/rnfail002).--{- **********************************************************************--  #PrefixToHS-utils# Utilities for conversion--  ********************************************************************* -}--{- Note [Parsing data constructors is hard]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The problem with parsing data constructors is that they look a lot like types.-Compare:--  (s1)   data T = C t1 t2-  (s2)   type T = C t1 t2--Syntactically, there's little difference between these declarations, except in-(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.--This similarity would pose no problem if we knew ahead of time if we are-parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple-(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing-data constructors, and in other contexts (e.g. 'type' declarations) assume we-are parsing type constructors.--This simple rule does not work because of two problematic cases:--  (p1)   data T = C t1 t2 :+ t3-  (p2)   data T = C t1 t2 => t3--In (p1) we encounter (:+) and it turns out we are parsing an infix data-declaration, so (C t1 t2) is a type and 'C' is a type constructor.-In (p2) we encounter (=>) and it turns out we are parsing an existential-context, so (C t1 t2) is a constraint and 'C' is a type constructor.--As the result, in order to determine whether (C t1 t2) declares a data-constructor, a type, or a context, we would need unlimited lookahead which-'happy' is not so happy with.--To further complicate matters, the interpretation of (!) and (~) is different-in constructors and types:--  (b1)   type T = C ! D-  (b2)   data T = C ! D-  (b3)   data T = C ! D => E--In (b1) and (b3), (!) is a type operator with two arguments: 'C' and 'D'. At-the same time, in (b2) it is a strictness annotation: 'C' is a data constructor-with a single strict argument 'D'. For the programmer, these cases are usually-easy to tell apart due to whitespace conventions:--  (b2)   data T = C !D         -- no space after the bang hints that-                               -- it is a strictness annotation--For the parser, on the other hand, this whitespace does not matter. We cannot-tell apart (b2) from (b3) until we encounter (=>), so it requires unlimited-lookahead.--The solution that accounts for all of these issues is to initially parse data-declarations and types as a reversed list of TyEl:--  data TyEl = TyElOpr RdrName-            | TyElOpd (HsType GhcPs)-            | ...--For example, both occurrences of (C ! D) in the following example are parsed-into equal lists of TyEl:--  data T = C ! D => C ! D   results in   [ TyElOpd (HsTyVar "D")-                                         , TyElOpr "!"-                                         , TyElOpd (HsTyVar "C") ]--Note that elements are in reverse order. Also, 'C' is parsed as a type-constructor (HsTyVar) even when it is a data constructor. We fix this in-`tyConToDataCon`.--By the time the list of TyEl is assembled, we have looked ahead enough to-decide whether to reduce using `mergeOps` (for types) or `mergeDataCon` (for-data constructors). These functions are where the actual job of parsing is-done.---}---- | Reinterpret a type constructor, including type operators, as a data---   constructor.--- See Note [Parsing data constructors is hard]-tyConToDataCon :: SrcSpan -> RdrName -> Either (SrcSpan, SDoc) (Located RdrName)-tyConToDataCon loc tc-  | isTcOcc occ || isDataOcc occ-  , isLexCon (occNameFS occ)-  = return (L loc (setRdrNameSpace tc srcDataName))--  | otherwise-  = Left (loc, msg)-  where-    occ = rdrNameOcc tc-    msg = text "Not a data constructor:" <+> quotes (ppr tc)--mkPatSynMatchGroup :: Located RdrName-                   -> Located (OrdList (LHsDecl GhcPs))-                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))-mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) =-    do { matches <- mapM fromDecl (fromOL decls)-       ; when (null matches) (wrongNumberErr loc)-       ; return $ mkMatchGroup FromSource matches }-  where-    fromDecl (L loc decl@(ValD _ (PatBind _-                         pat@(L _ (ConPat NoExtField ln@(L _ name) details))-                               rhs _))) =-        do { unless (name == patsyn_name) $-               wrongNameBindingErr loc decl-           ; match <- case details of-               PrefixCon pats -> return $ Match { m_ext = noExtField-                                                , m_ctxt = ctxt, m_pats = pats-                                                , m_grhss = rhs }-                   where-                     ctxt = FunRhs { mc_fun = ln-                                   , mc_fixity = Prefix-                                   , mc_strictness = NoSrcStrict }--               InfixCon p1 p2 -> return $ Match { m_ext = noExtField-                                                , m_ctxt = ctxt-                                                , m_pats = [p1, p2]-                                                , m_grhss = rhs }-                   where-                     ctxt = FunRhs { mc_fun = ln-                                   , mc_fixity = Infix-                                   , mc_strictness = NoSrcStrict }--               RecCon{} -> recordPatSynErr loc pat-           ; return $ L loc match }-    fromDecl (L loc decl) = extraDeclErr loc decl--    extraDeclErr loc decl =-        addFatalError loc $-        text "pattern synonym 'where' clause must contain a single binding:" $$-        ppr decl--    wrongNameBindingErr loc decl =-      addFatalError loc $-      text "pattern synonym 'where' clause must bind the pattern synonym's name"-      <+> quotes (ppr patsyn_name) $$ ppr decl--    wrongNumberErr loc =-      addFatalError loc $-      text "pattern synonym 'where' clause cannot be empty" $$-      text "In the pattern synonym declaration for: " <+> ppr (patsyn_name)--recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a-recordPatSynErr loc pat =-    addFatalError loc $-    text "record syntax not supported for pattern synonym declarations:" $$-    ppr pat--mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]-                -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs-                -> ConDecl GhcPs--mkConDeclH98 name mb_forall mb_cxt args-  = ConDeclH98 { con_ext    = noExtField-               , con_name   = name-               , con_forall = noLoc $ isJust mb_forall-               , con_ex_tvs = mb_forall `orElse` []-               , con_mb_cxt = mb_cxt-               , con_args   = args-               , con_doc    = Nothing }---- | Construct a GADT-style data constructor from the constructor names and--- their type. Some interesting aspects of this function:------ * This splits up the constructor type into its quantified type variables (if---   provided), context (if provided), argument types, and result type, and---   records whether this is a prefix or record GADT constructor. See---   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.-mkGadtDecl :: [Located RdrName]-           -> LHsType GhcPs-           -> P (ConDecl GhcPs, [AddAnn])-mkGadtDecl names ty = do-  let (args, res_ty, anns)-        | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty-        = (RecCon (L loc rf), res_ty, [])-        | otherwise-        = let (arg_types, res_type, anns) = splitHsFunType body_ty-          in (PrefixCon arg_types, res_type, anns)--  pure ( ConDeclGADT { con_g_ext  = noExtField-                     , con_names  = names-                     , con_forall = L (getLoc ty) $ isJust mtvs-                     , con_qvars  = fromMaybe [] mtvs-                     , con_mb_cxt = mcxt-                     , con_args   = args-                     , con_res_ty = res_ty-                     , con_doc    = Nothing }-       , anns )-  where-    (mtvs, mcxt, body_ty) = splitLHsGadtTy ty--setRdrNameSpace :: RdrName -> NameSpace -> RdrName--- ^ This rather gruesome function is used mainly by the parser.--- When parsing:------ > data T a = T | T1 Int------ we parse the data constructors as /types/ because of parser ambiguities,--- so then we need to change the /type constr/ to a /data constr/------ The exact-name case /can/ occur when parsing:------ > data [] a = [] | a : [a]------ For the exact-name case we return an original name.-setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)-setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)-setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)-setRdrNameSpace (Exact n)    ns-  | Just thing <- wiredInNameTyThing_maybe n-  = setWiredInNameSpace thing ns-    -- Preserve Exact Names for wired-in things,-    -- notably tuples and lists--  | isExternalName n-  = Orig (nameModule n) occ--  | otherwise   -- This can happen when quoting and then-                -- splicing a fixity declaration for a type-  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))-  where-    occ = setOccNameSpace ns (nameOccName n)--setWiredInNameSpace :: TyThing -> NameSpace -> RdrName-setWiredInNameSpace (ATyCon tc) ns-  | isDataConNameSpace ns-  = ty_con_data_con tc-  | isTcClsNameSpace ns-  = Exact (getName tc)      -- No-op--setWiredInNameSpace (AConLike (RealDataCon dc)) ns-  | isTcClsNameSpace ns-  = data_con_ty_con dc-  | isDataConNameSpace ns-  = Exact (getName dc)      -- No-op--setWiredInNameSpace thing ns-  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)--ty_con_data_con :: TyCon -> RdrName-ty_con_data_con tc-  | isTupleTyCon tc-  , Just dc <- tyConSingleDataCon_maybe tc-  = Exact (getName dc)--  | tc `hasKey` listTyConKey-  = Exact nilDataConName--  | otherwise  -- See Note [setRdrNameSpace for wired-in names]-  = Unqual (setOccNameSpace srcDataName (getOccName tc))--data_con_ty_con :: DataCon -> RdrName-data_con_ty_con dc-  | let tc = dataConTyCon dc-  , isTupleTyCon tc-  = Exact (getName tc)--  | dc `hasKey` nilDataConKey-  = Exact listTyConName--  | otherwise  -- See Note [setRdrNameSpace for wired-in names]-  = Unqual (setOccNameSpace tcClsName (getOccName dc))---- | Replaces constraint tuple names with corresponding boxed ones.-filterCTuple :: RdrName -> RdrName-filterCTuple (Exact n)-  | Just arity <- cTupleTyConNameArity_maybe n-  = Exact $ tupleTyConName BoxedTuple arity-filterCTuple rdr = rdr---{- Note [setRdrNameSpace for wired-in names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In GHC.Types, which declares (:), we have-  infixr 5 :-The ambiguity about which ":" is meant is resolved by parsing it as a-data constructor, but then using dataTcOccs to try the type constructor too;-and that in turn calls setRdrNameSpace to change the name-space of ":" to-tcClsName.  There isn't a corresponding ":" type constructor, but it's painful-to make setRdrNameSpace partial, so we just make an Unqual name instead. It-really doesn't matter!--}--eitherToP :: Either (SrcSpan, SDoc) a -> P a--- Adapts the Either monad to the P monad-eitherToP (Left (loc, doc)) = addFatalError loc doc-eitherToP (Right thing)     = return thing--checkTyVars :: SDoc -> SDoc -> Located RdrName -> [LHsTypeArg GhcPs]-            -> P ( LHsQTyVars GhcPs  -- the synthesized type variables-                 , [AddAnn] )        -- action which adds annotations--- ^ Check whether the given list of type parameters are all type variables--- (possibly with a kind signature).-checkTyVars pp_what equals_or_where tc tparms-  = do { (tvs, anns) <- fmap unzip $ mapM check tparms-       ; return (mkHsQTvs tvs, concat anns) }-  where-    check (HsTypeArg _ ki@(L loc _))-                              = addFatalError loc $-                                      vcat [ text "Unexpected type application" <+>-                                            text "@" <> ppr ki-                                          , text "In the" <+> pp_what <+>-                                            ptext (sLit "declaration for") <+> quotes (ppr tc)]-    check (HsValArg ty) = chkParens [] ty-    check (HsArgPar sp) = addFatalError sp $-                          vcat [text "Malformed" <+> pp_what-                            <+> text "declaration for" <+> quotes (ppr tc)]-        -- Keep around an action for adjusting the annotations of extra parens-    chkParens :: [AddAnn] -> LHsType GhcPs-              -> P (LHsTyVarBndr () GhcPs, [AddAnn])-    chkParens acc (L l (HsParTy _ ty)) = chkParens (mkParensApiAnn l ++ acc) ty-    chkParens acc ty = do-      tv <- chk ty-      return (tv, reverse acc)--        -- Check that the name space is correct!-    chk :: LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)-    chk (L l (HsKindSig _ (L lv (HsTyVar _ _ (L _ tv))) k))-        | isRdrTyVar tv    = return (L l (KindedTyVar noExtField () (L lv tv) k))-    chk (L l (HsTyVar _ _ (L ltv tv)))-        | isRdrTyVar tv    = return (L l (UserTyVar noExtField () (L ltv tv)))-    chk t@(L loc _)-        = addFatalError loc $-                vcat [ text "Unexpected type" <+> quotes (ppr t)-                     , text "In the" <+> pp_what-                       <+> ptext (sLit "declaration for") <+> quotes tc'-                     , vcat[ (text "A" <+> pp_what-                              <+> ptext (sLit "declaration should have form"))-                     , nest 2-                       (pp_what-                        <+> tc'-                        <+> hsep (map text (takeList tparms allNameStrings))-                        <+> equals_or_where) ] ]--    -- Avoid printing a constraint tuple in the error message. Print-    -- a plain old tuple instead (since that's what the user probably-    -- wrote). See #14907-    tc' = ppr $ fmap filterCTuple tc----whereDots, equalsDots :: SDoc--- Second argument to checkTyVars-whereDots  = text "where ..."-equalsDots = text "= ..."--checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()-checkDatatypeContext Nothing = return ()-checkDatatypeContext (Just c)-    = do allowed <- getBit DatatypeContextsBit-         unless allowed $-             addError (getLoc c)-                 (text "Illegal datatype context (use DatatypeContexts):"-                  <+> pprLHsContext c)--type LRuleTyTmVar = Located RuleTyTmVar-data RuleTyTmVar = RuleTyTmVar (Located RdrName) (Maybe (LHsType GhcPs))--- ^ Essentially a wrapper for a @RuleBndr GhcPs@---- turns RuleTyTmVars into RuleBnrs - this is straightforward-mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]-mkRuleBndrs = fmap (fmap cvt_one)-  where cvt_one (RuleTyTmVar v Nothing)    = RuleBndr    noExtField v-        cvt_one (RuleTyTmVar v (Just sig)) =-          RuleBndrSig noExtField v (mkHsPatSigType sig)---- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting-mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]-mkRuleTyVarBndrs = fmap (fmap cvt_one)-  where cvt_one (RuleTyTmVar v Nothing)-          = UserTyVar noExtField () (fmap tm_to_ty v)-        cvt_one (RuleTyTmVar v (Just sig))-          = KindedTyVar noExtField () (fmap tm_to_ty v) sig-    -- takes something in namespace 'varName' to something in namespace 'tvName'-        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)-        tm_to_ty _ = panic "mkRuleTyVarBndrs"---- See note [Parsing explicit foralls in Rules] in Parser.y-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()-checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)-  where check (L loc (Unqual occ)) = do-          when ((occNameString occ ==) `any` ["forall","family","role"])-               (addFatalError loc (text $ "parse error on input "-                                    ++ occNameString occ))-        check _ = panic "checkRuleTyVarBndrNames"--checkRecordSyntax :: (MonadP m, Outputable a) => Located a -> m (Located a)-checkRecordSyntax lr@(L loc r)-    = do allowed <- getBit TraditionalRecordSyntaxBit-         unless allowed $ addError loc $-           text "Illegal record syntax (use TraditionalRecordSyntax):" <+> ppr r-         return lr---- | Check if the gadt_constrlist is empty. Only raise parse error for--- `data T where` to avoid affecting existing error message, see #8258.-checkEmptyGADTs :: Located ([AddAnn], [LConDecl GhcPs])-                -> P (Located ([AddAnn], [LConDecl GhcPs]))-checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.-    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax-         unless gadtSyntax $ addError span $ vcat-           [ text "Illegal keyword 'where' in data declaration"-           , text "Perhaps you intended to use GADTs or a similar language"-           , text "extension to enable syntax: data T where"-           ]-         return gadts-checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.--checkTyClHdr :: Bool               -- True  <=> class header-                                   -- False <=> type header-             -> LHsType GhcPs-             -> P (Located RdrName,      -- the head symbol (type or class name)-                   [LHsTypeArg GhcPs],      -- parameters of head symbol-                   LexicalFixity,        -- the declaration is in infix format-                   [AddAnn]) -- API Annotation for HsParTy when stripping parens--- Well-formedness check and decomposition of type and class heads.--- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])---              Int :*: Bool   into    (:*:, [Int, Bool])--- returning the pieces-checkTyClHdr is_cls ty-  = goL ty [] [] Prefix-  where-    goL (L l ty) acc ann fix = go l ty acc ann fix--    -- workaround to define '*' despite StarIsType-    go lp (HsParTy _ (L l (HsStarTy _ isUni))) acc ann fix-      = do { warnStarBndr l-           ; let name = mkOccName tcClsName (starSym isUni)-           ; return (L l (Unqual name), acc, fix, (ann ++ mkParensApiAnn lp)) }--    go _ (HsTyVar _ _ ltc@(L _ tc)) acc ann fix-      | isRdrTc tc               = return (ltc, acc, fix, ann)-    go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ann _fix-      | isRdrTc tc               = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, ann)-    go l (HsParTy _ ty)    acc ann fix = goL ty acc (ann ++mkParensApiAnn l) fix-    go _ (HsAppTy _ t1 t2) acc ann fix = goL t1 (HsValArg t2:acc) ann fix-    go _ (HsAppKindTy l ty ki) acc ann fix = goL ty (HsTypeArg l ki:acc) ann fix-    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ann fix-      = return (L l (nameRdrName tup_name), map HsValArg ts, fix, ann)-      where-        arity = length ts-        tup_name | is_cls    = cTupleTyConName arity-                 | otherwise = getName (tupleTyCon Boxed arity)-          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)-    go l _ _ _ _-      = addFatalError l (text "Malformed head of type or class declaration:"-                          <+> ppr ty)---- | Yield a parse error if we have a function applied directly to a do block--- etc. and BlockArguments is not enabled.-checkExpBlockArguments :: LHsExpr GhcPs -> PV ()-checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()-(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)-  where-    checkExpr :: LHsExpr GhcPs -> PV ()-    checkExpr expr = do-     case unLoc expr of-      HsDo _ (DoExpr m) _ -> check (prependQualified m (text "do block")) expr-      HsDo _ (MDoExpr m) _ -> check (prependQualified m (text "mdo block")) expr-      HsLam {} -> check (text "lambda expression") expr-      HsCase {} -> check (text "case expression") expr-      HsLamCase {} -> check (text "lambda-case expression") expr-      HsLet {} -> check (text "let expression") expr-      HsIf {} -> check (text "if expression") expr-      HsProc {} -> check (text "proc expression") expr-      _ -> return ()--    checkCmd :: LHsCmd GhcPs -> PV ()-    checkCmd cmd = case unLoc cmd of-      HsCmdLam {} -> check (text "lambda command") cmd-      HsCmdCase {} -> check (text "case command") cmd-      HsCmdIf {} -> check (text "if command") cmd-      HsCmdLet {} -> check (text "let command") cmd-      HsCmdDo {} -> check (text "do command") cmd-      _ -> return ()--    check :: Outputable a => SDoc -> Located a -> PV ()-    check element a = do-      blockArguments <- getBit BlockArgumentsBit-      unless blockArguments $-        addError (getLoc a) $-          text "Unexpected " <> element <> text " in function application:"-           $$ nest 4 (ppr a)-           $$ text "You could write it with parentheses"-           $$ text "Or perhaps you meant to enable BlockArguments?"---- | Validate the context constraints and break up a context into a list--- of predicates.------ @---     (Eq a, Ord b)        -->  [Eq a, Ord b]---     Eq a                 -->  [Eq a]---     (Eq a)               -->  [Eq a]---     (((Eq a)))           -->  [Eq a]--- @-checkContext :: LHsType GhcPs -> P ([AddAnn],LHsContext GhcPs)-checkContext (L l orig_t)-  = check [] (L l orig_t)- where-  check anns (L lp (HsTupleTy _ HsBoxedOrConstraintTuple ts))-    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can-    -- be used as context constraints.-    = return (anns ++ mkParensApiAnn lp,L l ts)                -- Ditto ()--  check anns (L lp1 (HsParTy _ ty))-                                  -- to be sure HsParTy doesn't get into the way-       = check anns' ty-         where anns' = if l == lp1 then anns-                                   else (anns ++ mkParensApiAnn lp1)--  -- no need for anns, returning original-  check _anns _t = return ([],L l [L l orig_t])--checkImportDecl :: Maybe (Located Token)-                -> Maybe (Located Token)-                -> P ()-checkImportDecl mPre mPost = do-  let whenJust mg f = maybe (pure ()) f mg--  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit--  -- Error if 'qualified' found in postpositive position and-  -- 'ImportQualifiedPost' is not in effect.-  whenJust mPost $ \post ->-    when (not importQualifiedPostEnabled) $-      failOpNotEnabledImportQualifiedPost (getLoc post)--  -- Error if 'qualified' occurs in both pre and postpositive-  -- positions.-  whenJust mPost $ \post ->-    when (isJust mPre) $-      failOpImportQualifiedTwice (getLoc post)--  -- Warn if 'qualified' found in prepositive position and-  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.-  whenJust mPre $ \pre ->-    warnPrepositiveQualifiedModule (getLoc pre)---- ---------------------------------------------------------------------------- Checking Patterns.---- We parse patterns as expressions and check for valid patterns below,--- converting the expression into a pattern at the same time.--checkPattern :: Located (PatBuilder GhcPs) -> P (LPat GhcPs)-checkPattern = runPV . checkLPat--checkPattern_msg :: SDoc -> PV (Located (PatBuilder GhcPs)) -> P (LPat GhcPs)-checkPattern_msg msg pp = runPV_msg msg (pp >>= checkLPat)--checkLPat :: Located (PatBuilder GhcPs) -> PV (LPat GhcPs)-checkLPat e@(L l _) = checkPat l e []--checkPat :: SrcSpan -> Located (PatBuilder GhcPs) -> [LPat GhcPs]-         -> PV (LPat GhcPs)-checkPat loc (L l e@(PatBuilderVar (L _ c))) args-  | isRdrDataCon c = return . L loc $ ConPat-      { pat_con_ext = noExtField-      , pat_con = L l c-      , pat_args = PrefixCon args-      }-  | not (null args) && patIsRec c =-      localPV_msg (\_ -> text "Perhaps you intended to use RecursiveDo") $-      patFail l (ppr e)-checkPat loc (L _ (PatBuilderApp f e)) args-  = do p <- checkLPat e-       checkPat loc f (p : args)-checkPat loc (L _ e) []-  = do p <- checkAPat loc e-       return (L loc p)-checkPat loc e _-  = patFail loc (ppr e)--checkAPat :: SrcSpan -> PatBuilder GhcPs -> PV (Pat GhcPs)-checkAPat loc e0 = do- nPlusKPatterns <- getBit NPlusKPatternsBit- case e0 of-   PatBuilderPat p -> return p-   PatBuilderVar x -> return (VarPat noExtField x)--   -- Overloaded numeric patterns (e.g. f 0 x = x)-   -- Negation is recorded separately, so that the literal is zero or +ve-   -- NB. Negative *primitive* literals are already handled by the lexer-   PatBuilderOverLit pos_lit -> return (mkNPat (L loc pos_lit) Nothing)--   -- n+k patterns-   PatBuilderOpApp-           (L nloc (PatBuilderVar (L _ n)))-           (L _ plus)-           (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))-                      | nPlusKPatterns && (plus == plus_RDR)-                      -> return (mkNPlusKPat (L nloc n) (L lloc lit))--   -- Improve error messages for the @-operator when the user meant an @-pattern-   PatBuilderOpApp _ op _ | opIsAt (unLoc op) -> do-     addError (getLoc op) $-       text "Found a binding for the" <+> quotes (ppr op) <+> text "operator in a pattern position." $$-       perhaps_as_pat-     return (WildPat noExtField)--   PatBuilderOpApp l (L cl c) r-     | isRdrDataCon c -> do-         l <- checkLPat l-         r <- checkLPat r-         return $ ConPat-           { pat_con_ext = noExtField-           , pat_con = L cl c-           , pat_args = InfixCon l r-           }--   PatBuilderPar e    -> checkLPat e >>= (return . (ParPat noExtField))-   _           -> patFail loc (ppr e0)--placeHolderPunRhs :: DisambECP b => PV (Located b)--- The RHS of a punned record field will be filled in by the renamer--- It's better not to make it an error, in case we want to print it when--- debugging-placeHolderPunRhs = mkHsVarPV (noLoc pun_RDR)--plus_RDR, pun_RDR :: RdrName-plus_RDR = mkUnqual varName (fsLit "+") -- Hack-pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")--checkPatField :: LHsRecField GhcPs (Located (PatBuilder GhcPs))-              -> PV (LHsRecField GhcPs (LPat GhcPs))-checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)-                             return (L l (fld { hsRecFieldArg = p }))--patFail :: SrcSpan -> SDoc -> PV a-patFail loc e = addFatalError loc $ text "Parse error in pattern:" <+> ppr e--patIsRec :: RdrName -> Bool-patIsRec e = e == mkUnqual varName (fsLit "rec")--opIsAt :: RdrName -> Bool-opIsAt e = e == mkUnqual varName (fsLit "@")-------------------------------------------------------------------------------- Check Equation Syntax--checkValDef :: Located (PatBuilder GhcPs)-            -> Maybe (LHsType GhcPs)-            -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))-            -> P ([AddAnn],HsBind GhcPs)--checkValDef lhs (Just sig) grhss-        -- x :: ty = rhs  parses as a *pattern* binding-  = do lhs' <- runPV $ mkHsTySigPV (combineLocs lhs sig) lhs sig >>= checkLPat-       checkPatBind lhs' grhss--checkValDef lhs Nothing g@(L l (_,grhss))-  = do  { mb_fun <- isFunLhs lhs-        ; case mb_fun of-            Just (fun, is_infix, pats, ann) ->-              checkFunBind NoSrcStrict ann (getLoc lhs)-                           fun is_infix pats (L l grhss)-            Nothing -> do-              lhs' <- checkPattern lhs-              checkPatBind lhs' g }--checkFunBind :: SrcStrictness-             -> [AddAnn]-             -> SrcSpan-             -> Located RdrName-             -> LexicalFixity-             -> [Located (PatBuilder GhcPs)]-             -> Located (GRHSs GhcPs (LHsExpr GhcPs))-             -> P ([AddAnn],HsBind GhcPs)-checkFunBind strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)-  = do  ps <- runPV_msg param_hint (mapM checkLPat pats)-        let match_span = combineSrcSpans lhs_loc rhs_span-        -- Add back the annotations stripped from any HsPar values in the lhs-        -- mapM_ (\a -> a match_span) ann-        return (ann, makeFunBind fun-                  [L match_span (Match { m_ext = noExtField-                                       , m_ctxt = FunRhs-                                           { mc_fun    = fun-                                           , mc_fixity = is_infix-                                           , mc_strictness = strictness }-                                       , m_pats = ps-                                       , m_grhss = grhss })])-        -- The span of the match covers the entire equation.-        -- That isn't quite right, but it'll do for now.-  where-    param_hint-      | Infix <- is_infix-      = text "In a function binding for the" <+> quotes (ppr fun) <+> text "operator." $$-        if opIsAt (unLoc fun) then perhaps_as_pat else empty-      | otherwise = empty--perhaps_as_pat :: SDoc-perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"--makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]-            -> HsBind GhcPs--- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too-makeFunBind fn ms-  = FunBind { fun_ext = noExtField,-              fun_id = fn,-              fun_matches = mkMatchGroup FromSource ms,-              fun_tick = [] }---- See Note [FunBind vs PatBind]-checkPatBind :: LPat GhcPs-             -> Located (a,GRHSs GhcPs (LHsExpr GhcPs))-             -> P ([AddAnn],HsBind GhcPs)-checkPatBind lhs (L rhs_span (_,grhss))-    | BangPat _ p <- unLoc lhs-    , VarPat _ v <- unLoc p-    = return ([], makeFunBind v [L match_span (m v)])-  where-    match_span = combineSrcSpans (getLoc lhs) rhs_span-    m v = Match { m_ext = noExtField-                , m_ctxt = FunRhs { mc_fun    = v-                                  , mc_fixity = Prefix-                                  , mc_strictness = SrcStrict }-                , m_pats = []-                , m_grhss = grhss }--checkPatBind lhs (L _ (_,grhss))-  = return ([],PatBind noExtField lhs grhss ([],[]))--checkValSigLhs :: LHsExpr GhcPs -> P (Located RdrName)-checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))-  | isUnqual v-  , not (isDataOcc (rdrNameOcc v))-  = return lrdr--checkValSigLhs lhs@(L l _)-  = addFatalError l ((text "Invalid type signature:" <+>-                       ppr lhs <+> text ":: ...")-                      $$ text hint)-  where-    hint | foreign_RDR `looks_like` lhs-         = "Perhaps you meant to use ForeignFunctionInterface?"-         | default_RDR `looks_like` lhs-         = "Perhaps you meant to use DefaultSignatures?"-         | pattern_RDR `looks_like` lhs-         = "Perhaps you meant to use PatternSynonyms?"-         | otherwise-         = "Should be of form <variable> :: <type>"--    -- A common error is to forget the ForeignFunctionInterface flag-    -- so check for that, and suggest.  cf #3805-    -- Sadly 'foreign import' still barfs 'parse error' because-    --  'import' is a keyword-    looks_like s (L _ (HsVar _ (L _ v))) = v == s-    looks_like s (L _ (HsApp _ lhs _))   = looks_like s lhs-    looks_like _ _                       = False--    foreign_RDR = mkUnqual varName (fsLit "foreign")-    default_RDR = mkUnqual varName (fsLit "default")-    pattern_RDR = mkUnqual varName (fsLit "pattern")--checkDoAndIfThenElse-  :: (Outputable a, Outputable b, Outputable c)-  => Located a -> Bool -> b -> Bool -> Located c -> PV ()-checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr- | semiThen || semiElse-    = do doAndIfThenElse <- getBit DoAndIfThenElseBit-         unless doAndIfThenElse $ do-             addError (combineLocs guardExpr elseExpr)-                            (text "Unexpected semi-colons in conditional:"-                          $$ nest 4 expr-                          $$ text "Perhaps you meant to use DoAndIfThenElse?")- | otherwise            = return ()-    where pprOptSemi True  = semi-          pprOptSemi False = empty-          expr = text "if"   <+> ppr guardExpr <> pprOptSemi semiThen <+>-                 text "then" <+> ppr thenExpr  <> pprOptSemi semiElse <+>-                 text "else" <+> ppr elseExpr--isFunLhs :: Located (PatBuilder GhcPs)-      -> P (Maybe (Located RdrName, LexicalFixity, [Located (PatBuilder GhcPs)],[AddAnn]))--- A variable binding is parsed as a FunBind.--- Just (fun, is_infix, arg_pats) if e is a function LHS-isFunLhs e = go e [] []- where-   go (L loc (PatBuilderVar (L _ f))) es ann-       | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, ann))-   go (L _ (PatBuilderApp f e)) es       ann = go f (e:es) ann-   go (L l (PatBuilderPar e))   es@(_:_) ann = go e es (ann ++ mkParensApiAnn l)-   go (L loc (PatBuilderOpApp l (L loc' op) r)) es ann-        | not (isRdrDataCon op)         -- We have found the function!-        = return (Just (L loc' op, Infix, (l:r:es), ann))-        | otherwise                     -- Infix data con; keep going-        = do { mb_l <- go l es ann-             ; case mb_l of-                 Just (op', Infix, j : k : es', ann')-                   -> return (Just (op', Infix, j : op_app : es', ann'))-                   where-                     op_app = L loc (PatBuilderOpApp k-                               (L loc' op) r)-                 _ -> return Nothing }-   go _ _ _ = return Nothing---- | Either an operator or an operand.-data TyEl = TyElOpr RdrName | TyElOpd (HsType GhcPs)-          | TyElKindApp SrcSpan (LHsType GhcPs)-          -- See Note [TyElKindApp SrcSpan interpretation]-          | TyElUnpackedness ([AddAnn], SourceText, SrcUnpackedness)---{- Note [TyElKindApp SrcSpan interpretation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A TyElKindApp captures type application written in haskell as--    @ Foo--where Foo is some type.--The SrcSpan reflects both elements, and there are AnnAt and AnnVal API-Annotations attached to this SrcSpan for the specific locations of-each within it.--}--instance Outputable TyEl where-  ppr (TyElOpr name) = ppr name-  ppr (TyElOpd ty) = ppr ty-  ppr (TyElKindApp _ ki) = text "@" <> ppr ki-  ppr (TyElUnpackedness (_, _, unpk)) = ppr unpk---- | Extract a strictness/unpackedness annotation from the front of a reversed--- 'TyEl' list.-pUnpackedness-  :: [Located TyEl] -- reversed TyEl-  -> Maybe ( SrcSpan-           , [AddAnn]-           , SourceText-           , SrcUnpackedness-           , [Located TyEl] {- remaining TyEl -})-pUnpackedness (L l x1 : xs)-  | TyElUnpackedness (anns, prag, unpk) <- x1-  = Just (l, anns, prag, unpk, xs)-pUnpackedness _ = Nothing--pBangTy-  :: LHsType GhcPs  -- a type to be wrapped inside HsBangTy-  -> [Located TyEl] -- reversed TyEl-  -> ( Bool           {- has a strict mark been consumed? -}-     , LHsType GhcPs  {- the resulting BangTy -}-     , P ()           {- add annotations -}-     , [Located TyEl] {- remaining TyEl -})-pBangTy lt@(L l1 _) xs =-  case pUnpackedness xs of-    Nothing -> (False, lt, pure (), xs)-    Just (l2, anns, prag, unpk, xs') ->-      let bl = combineSrcSpans l1 l2-          (anns2, bt) = addUnpackedness (prag, unpk) lt-      in (True, L bl bt, addAnnsAt bl (anns ++ anns2), xs')--mkBangTy :: SrcStrictness -> LHsType GhcPs -> HsType GhcPs-mkBangTy strictness =-  HsBangTy noExtField (HsSrcBang NoSourceText NoSrcUnpack strictness)--addUnpackedness :: (SourceText, SrcUnpackedness) -> LHsType GhcPs -> ([AddAnn], HsType GhcPs)-addUnpackedness (prag, unpk) (L l (HsBangTy x bang t))-  | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang-  = let-      anns = case strictness of-        SrcLazy     -> [AddAnn AnnTilde (srcSpanFirstCharacter l)]-        SrcStrict   -> [AddAnn AnnBang  (srcSpanFirstCharacter l)]-        NoSrcStrict -> []-    in (anns, HsBangTy x (HsSrcBang prag unpk strictness) t)-addUnpackedness (prag, unpk) t-  = ([], HsBangTy noExtField (HsSrcBang prag unpk NoSrcStrict) t)---- | Merge a /reversed/ and /non-empty/ soup of operators and operands---   into a type.------ User input: @F x y + G a b * X@--- Input to 'mergeOps': [X, *, b, a, G, +, y, x, F]--- Output corresponds to what the user wrote assuming all operators are of the--- same fixity and right-associative.------ It's a bit silly that we're doing it at all, as the renamer will have to--- rearrange this, and it'd be easier to keep things separate.------ See Note [Parsing data constructors is hard]-mergeOps :: [Located TyEl] -> P (LHsType GhcPs)-mergeOps ((L l1 (TyElOpd t)) : xs)-  | (_, t', addAnns, xs') <- pBangTy (L l1 t) xs-  , null xs' -- We accept a BangTy only when there are no preceding TyEl.-  = addAnns >> return t'-mergeOps all_xs = go (0 :: Int) [] id all_xs-  where-    -- NB. When modifying clauses in 'go', make sure that the reasoning in-    -- Note [Non-empty 'acc' in mergeOps clause [end]] is still correct.--    -- clause [unpk]:-    -- handle (NO)UNPACK pragmas-    go k acc ops_acc ((L l (TyElUnpackedness (anns, unpkSrc, unpk))):xs) =-      if not (null acc) && null xs-      then do { acc' <- eitherToP $ mergeOpsAcc acc-              ; let a = ops_acc acc'-                    strictMark = HsSrcBang unpkSrc unpk NoSrcStrict-                    bl = combineSrcSpans l (getLoc a)-                    bt = HsBangTy noExtField strictMark a-              ; addAnnsAt bl anns-              ; return (L bl bt) }-      else addFatalError l unpkError-      where-        unpkSDoc = case unpkSrc of-          NoSourceText -> ppr unpk-          SourceText str -> text str <> text " #-}"-        unpkError-          | not (null xs) = unpkSDoc <+> text "cannot appear inside a type."-          | null acc && k == 0 = unpkSDoc <+> text "must be applied to a type."-          | otherwise =-              -- See Note [Impossible case in mergeOps clause [unpk]]-              panic "mergeOps.UNPACK: impossible position"--    -- clause [opr]:-    -- when we encounter an operator, we must have accumulated-    -- something for its rhs, and there must be something left-    -- to build its lhs.-    go k acc ops_acc ((L l (TyElOpr op)):xs) =-      if null acc || null (filter isTyElOpd xs)-        then failOpFewArgs (L l op)-        else do { acc' <- eitherToP (mergeOpsAcc acc)-                ; go (k + 1) [] (\c -> mkLHsOpTy c (L l op) (ops_acc acc')) xs }-      where-        isTyElOpd (L _ (TyElOpd _)) = True-        isTyElOpd _ = False--    -- clause [opd]:-    -- whenever an operand is encountered, it is added to the accumulator-    go k acc ops_acc ((L l (TyElOpd a)):xs) = go k (HsValArg (L l a):acc) ops_acc xs--    -- clause [tyapp]:-    -- whenever a type application is encountered, it is added to the accumulator-    go k acc ops_acc ((L _ (TyElKindApp l a)):xs) = go k (HsTypeArg l a:acc) ops_acc xs--    -- clause [end]-    -- See Note [Non-empty 'acc' in mergeOps clause [end]]-    go _ acc ops_acc [] = do { acc' <- eitherToP (mergeOpsAcc acc)-                             ; return (ops_acc acc') }--mergeOpsAcc :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]-         -> Either (SrcSpan, SDoc) (LHsType GhcPs)-mergeOpsAcc [] = panic "mergeOpsAcc: empty input"-mergeOpsAcc (HsTypeArg _ (L loc ki):_)-  = Left (loc, text "Unexpected type application:" <+> ppr ki)-mergeOpsAcc (HsValArg ty : xs) = go1 ty xs-  where-    go1 :: LHsType GhcPs-        -> [HsArg (LHsType GhcPs) (LHsKind GhcPs)]-        -> Either (SrcSpan, SDoc) (LHsType GhcPs)-    go1 lhs []     = Right lhs-    go1 lhs (x:xs) = case x of-        HsValArg ty -> go1 (mkHsAppTy lhs ty) xs-        HsTypeArg loc ki -> let ty = mkHsAppKindTy loc lhs ki-                            in go1 ty xs-        HsArgPar _ -> go1 lhs xs-mergeOpsAcc (HsArgPar _: xs) = mergeOpsAcc xs--{- Note [Impossible case in mergeOps clause [unpk]]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This case should never occur. Let us consider all possible-variations of 'acc', 'xs', and 'k':--  acc          xs        k-==============================-  null   |    null       0      -- "must be applied to a type"-  null   |  not null     0      -- "must be applied to a type"-not null |    null       0      -- successful parse-not null |  not null     0      -- "cannot appear inside a type"-  null   |    null      >0      -- handled in clause [opr]-  null   |  not null    >0      -- "cannot appear inside a type"-not null |    null      >0      -- successful parse-not null |  not null    >0      -- "cannot appear inside a type"--The (null acc && null xs && k>0) case is handled in clause [opr]-by the following check:--    if ... || null (filter isTyElOpd xs)-     then failOpFewArgs (L l op)--We know that this check has been performed because k>0, and by-the time we reach the end of the list (null xs), the only way-for (null acc) to hold is that there was not a single TyElOpd-between the operator and the end of the list. But this case is-caught by the check and reported as 'failOpFewArgs'.--}--{- Note [Non-empty 'acc' in mergeOps clause [end]]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In clause [end] we need to know that 'acc' is non-empty to call 'mergeAcc'-without a check.--Running 'mergeOps' with an empty input list is forbidden, so we do not consider-this possibility. This means we'll hit at least one other clause before we-reach clause [end].--* Clauses [unpk] and [doc] do not call 'go' recursively, so we cannot hit-  clause [end] from there.-* Clause [opd] makes 'acc' non-empty, so if we hit clause [end] after it, 'acc'-  will be non-empty.-* Clause [opr] checks that (filter isTyElOpd xs) is not null - so we are going-  to hit clause [opd] at least once before we reach clause [end], making 'acc'-  non-empty.-* There are no other clauses.--Therefore, it is safe to omit a check for non-emptiness of 'acc' in clause-[end].---}--pInfixSide :: [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])-pInfixSide ((L l (TyElOpd t)):xs)-  | (True, t', addAnns, xs') <- pBangTy (L l t) xs-  = Just (t', addAnns, xs')-pInfixSide (el:xs1)-  | Just t1 <- pLHsTypeArg el-  = go [t1] xs1-   where-     go :: [HsArg (LHsType GhcPs) (LHsKind GhcPs)]-        -> [Located TyEl] -> Maybe (LHsType GhcPs, P (), [Located TyEl])-     go acc (el:xs)-       | Just t <- pLHsTypeArg el-       = go (t:acc) xs-     go acc xs = case mergeOpsAcc acc of-       Left _ -> Nothing-       Right acc' -> Just (acc', pure (), xs)-pInfixSide _ = Nothing--pLHsTypeArg :: Located TyEl -> Maybe (HsArg (LHsType GhcPs) (LHsKind GhcPs))-pLHsTypeArg (L l (TyElOpd a)) = Just (HsValArg (L l a))-pLHsTypeArg (L _ (TyElKindApp l a)) = Just (HsTypeArg l a)-pLHsTypeArg _ = Nothing--orErr :: Maybe a -> b -> Either b a-orErr (Just a) _ = Right a-orErr Nothing b = Left b---- | Merge a /reversed/ and /non-empty/ soup of operators and operands---   into a data constructor.------ User input: @C !A B -- ^ doc@--- Input to 'mergeDataCon': ["doc", B, !A, C]--- Output: (C, PrefixCon [!A, B], "doc")------ See Note [Parsing data constructors is hard]-mergeDataCon-      :: [Located TyEl]-      -> P ( Located RdrName         -- constructor name-           , HsConDeclDetails GhcPs  -- constructor field information-           )-mergeDataCon all_xs =-  do { (addAnns, a) <- eitherToP res-     ; addAnns-     ; return a }-  where-    -- The result of merging the list of reversed TyEl into a-    -- data constructor, along with [AddAnn].-    res = goFirst all_xs--    goFirst [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]-      = do { data_con <- tyConToDataCon l tc-           ; return (pure (), (data_con, PrefixCon [])) }-    goFirst ((L l (TyElOpd (HsRecTy _ fields))):xs)-      | [ L l' (TyElOpd (HsTyVar _ _ (L _ tc))) ] <- xs-      = do { data_con <- tyConToDataCon l' tc-           ; return (pure (), (data_con, RecCon (L l fields))) }-    goFirst [L l (TyElOpd (HsTupleTy _ HsBoxedOrConstraintTuple ts))]-      = return ( pure ()-               , ( L l (getRdrName (tupleDataCon Boxed (length ts)))-                 , PrefixCon (map hsLinear ts) ) )-    goFirst ((L l (TyElOpd t)):xs)-      | (_, t', addAnns, xs') <- pBangTy (L l t) xs-      = go addAnns [t'] xs'-    goFirst (L l (TyElKindApp _ _):_)-      = goInfix Monoid.<> Left (l, kindAppErr)-    goFirst xs-      = go (pure ()) [] xs--    go addAnns ts [ L l (TyElOpd (HsTyVar _ _ (L _ tc))) ]-      = do { data_con <- tyConToDataCon l tc-           ; return (addAnns, (data_con, PrefixCon (map hsLinear ts))) }-    go addAnns ts ((L l (TyElOpd t)):xs)-      | (_, t', addAnns', xs') <- pBangTy (L l t) xs-      = go (addAnns >> addAnns') (t':ts) xs'-    go _ _ ((L _ (TyElOpr _)):_) =-      -- Encountered an operator: backtrack to the beginning and attempt-      -- to parse as an infix definition.-      goInfix-    go _ _ (L l (TyElKindApp _ _):_) =  goInfix Monoid.<> Left (l, kindAppErr)-    go _ _ _ = Left malformedErr-      where-        malformedErr =-          ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs)-          , text "Cannot parse data constructor" <+>-            text "in a data/newtype declaration:" $$-            nest 2 (hsep . reverse $ map ppr all_xs))--    goInfix =-      do { let xs0 = all_xs-         ; (rhs, rhs_addAnns, xs1) <- pInfixSide xs0 `orErr` malformedErr-         ; (op, xs3) <- case xs1 of-              (L l (TyElOpr op)) : xs3 ->-                do { data_con <- tyConToDataCon l op-                   ; return (data_con, xs3) }-              _ -> Left malformedErr-         ; (lhs, lhs_addAnns, xs5) <- pInfixSide xs3 `orErr` malformedErr-         ; unless (null xs5) (Left malformedErr)-         ; let addAnns = lhs_addAnns >> rhs_addAnns-         ; return (addAnns, (op, InfixCon (hsLinear lhs) (hsLinear rhs))) }-      where-        malformedErr =-          ( foldr combineSrcSpans noSrcSpan (map getLoc all_xs)-          , text "Cannot parse an infix data constructor" <+>-            text "in a data/newtype declaration:" $$-            nest 2 (hsep . reverse $ map ppr all_xs))--    kindAppErr =-      text "Unexpected kind application" <+>-      text "in a data/newtype declaration:" $$-      nest 2 (hsep . reverse $ map ppr all_xs)-------------------------------------------------------------------------------- | Check for monad comprehensions------ If the flag MonadComprehensions is set, return a 'MonadComp' context,--- otherwise use the usual 'ListComp' context--checkMonadComp :: PV (HsStmtContext GhcRn)-checkMonadComp = do-    monadComprehensions <- getBit MonadComprehensionsBit-    return $ if monadComprehensions-                then MonadComp-                else ListComp---- ---------------------------------------------------------------------------- Expression/command/pattern ambiguity.--- See Note [Ambiguous syntactic categories]------- See Note [Parser-Validator]--- See Note [Ambiguous syntactic categories]------ This newtype is required to avoid impredicative types in monadic--- productions. That is, in a production that looks like------    | ... {% return (ECP ...) }------ we are dealing with---    P ECP--- whereas without a newtype we would be dealing with---    P (forall b. DisambECP b => PV (Located b))----newtype ECP =-  ECP { runECP_PV :: forall b. DisambECP b => PV (Located b) }--runECP_P :: DisambECP b => ECP -> P (Located b)-runECP_P p = runPV (runECP_PV p)--ecpFromExp :: LHsExpr GhcPs -> ECP-ecpFromExp a = ECP (ecpFromExp' a)--ecpFromCmd :: LHsCmd GhcPs -> ECP-ecpFromCmd a = ECP (ecpFromCmd' a)---- | Disambiguate infix operators.--- See Note [Ambiguous syntactic categories]-class DisambInfixOp b where-  mkHsVarOpPV :: Located RdrName -> PV (Located b)-  mkHsConOpPV :: Located RdrName -> PV (Located b)-  mkHsInfixHolePV :: SrcSpan -> PV (Located b)--instance DisambInfixOp (HsExpr GhcPs) where-  mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)-  mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)-  mkHsInfixHolePV l = return $ L l hsHoleExpr--instance DisambInfixOp RdrName where-  mkHsConOpPV (L l v) = return $ L l v-  mkHsVarOpPV (L l v) = return $ L l v-  mkHsInfixHolePV l =-    addFatalError l $ text "Invalid infix hole, expected an infix operator"---- | Disambiguate constructs that may appear when we do not know ahead of time whether we are--- parsing an expression, a command, or a pattern.--- See Note [Ambiguous syntactic categories]-class b ~ (Body b) GhcPs => DisambECP b where-  -- | See Note [Body in DisambECP]-  type Body b :: Type -> Type-  -- | Return a command without ambiguity, or fail in a non-command context.-  ecpFromCmd' :: LHsCmd GhcPs -> PV (Located b)-  -- | Return an expression without ambiguity, or fail in a non-expression context.-  ecpFromExp' :: LHsExpr GhcPs -> PV (Located b)-  -- | Disambiguate "\... -> ..." (lambda)-  mkHsLamPV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)-  -- | Disambiguate "let ... in ..."-  mkHsLetPV :: SrcSpan -> LHsLocalBinds GhcPs -> Located b -> PV (Located b)-  -- | Infix operator representation-  type InfixOp b-  -- | Bring superclass constraints on InfixOp into scope.-  -- See Note [UndecidableSuperClasses for associated types]-  superInfixOp :: (DisambInfixOp (InfixOp b) => PV (Located b )) -> PV (Located b)-  -- | Disambiguate "f # x" (infix operator)-  mkHsOpAppPV :: SrcSpan -> Located b -> Located (InfixOp b) -> Located b -> PV (Located b)-  -- | Disambiguate "case ... of ..."-  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> MatchGroup GhcPs (Located b) -> PV (Located b)-  -- | Disambiguate @\\case ...@ (lambda case)-  mkHsLamCasePV :: SrcSpan -> MatchGroup GhcPs (Located b) -> PV (Located b)-  -- | Function argument representation-  type FunArg b-  -- | Bring superclass constraints on FunArg into scope.-  -- See Note [UndecidableSuperClasses for associated types]-  superFunArg :: (DisambECP (FunArg b) => PV (Located b)) -> PV (Located b)-  -- | Disambiguate "f x" (function application)-  mkHsAppPV :: SrcSpan -> Located b -> Located (FunArg b) -> PV (Located b)-  -- | Disambiguate "f @t" (visible type application)-  mkHsAppTypePV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)-  -- | Disambiguate "if ... then ... else ..."-  mkHsIfPV :: SrcSpan-         -> LHsExpr GhcPs-         -> Bool  -- semicolon?-         -> Located b-         -> Bool  -- semicolon?-         -> Located b-         -> PV (Located b)-  -- | Disambiguate "do { ... }" (do notation)-  mkHsDoPV ::-    SrcSpan ->-    Maybe ModuleName ->-    Located [LStmt GhcPs (Located b)] ->-    PV (Located b)-  -- | Disambiguate "( ... )" (parentheses)-  mkHsParPV :: SrcSpan -> Located b -> PV (Located b)-  -- | Disambiguate a variable "f" or a data constructor "MkF".-  mkHsVarPV :: Located RdrName -> PV (Located b)-  -- | Disambiguate a monomorphic literal-  mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)-  -- | Disambiguate an overloaded literal-  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)-  -- | Disambiguate a wildcard-  mkHsWildCardPV :: SrcSpan -> PV (Located b)-  -- | Disambiguate "a :: t" (type annotation)-  mkHsTySigPV :: SrcSpan -> Located b -> LHsType GhcPs -> PV (Located b)-  -- | Disambiguate "[a,b,c]" (list syntax)-  mkHsExplicitListPV :: SrcSpan -> [Located b] -> PV (Located b)-  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)-  mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)-  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)-  mkHsRecordPV ::-    SrcSpan ->-    SrcSpan ->-    Located b ->-    ([LHsRecField GhcPs (Located b)], Maybe SrcSpan) ->-    PV (Located b)-  -- | Disambiguate "-a" (negation)-  mkHsNegAppPV :: SrcSpan -> Located b -> PV (Located b)-  -- | Disambiguate "(# a)" (right operator section)-  mkHsSectionR_PV :: SrcSpan -> Located (InfixOp b) -> Located b -> PV (Located b)-  -- | Disambiguate "(a -> b)" (view pattern)-  mkHsViewPatPV :: SrcSpan -> LHsExpr GhcPs -> Located b -> PV (Located b)-  -- | Disambiguate "a@b" (as-pattern)-  mkHsAsPatPV :: SrcSpan -> Located RdrName -> Located b -> PV (Located b)-  -- | Disambiguate "~a" (lazy pattern)-  mkHsLazyPatPV :: SrcSpan -> Located b -> PV (Located b)-  -- | Disambiguate "!a" (bang pattern)-  mkHsBangPatPV :: SrcSpan -> Located b -> PV (Located b)-  -- | Disambiguate tuple sections and unboxed sums-  mkSumOrTuplePV :: SrcSpan -> Boxity -> SumOrTuple b -> PV (Located b)-  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas-  rejectPragmaPV :: Located b -> PV ()---{- Note [UndecidableSuperClasses for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(This Note is about the code in GHC, not about the user code that we are parsing)--Assume we have a class C with an associated type T:--  class C a where-    type T a-    ...--If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:--  {-# LANGUAGE UndecidableSuperClasses #-}-  class C (T a) => C a where-    type T a-    ...--Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes-making GHC loop. The workaround is to bring this constraint into scope-manually with a helper method:--  class C a where-    type T a-    superT :: (C (T a) => r) -> r--In order to avoid ambiguous types, 'r' must mention 'a'.--For consistency, we use this approach for all constraints on associated types,-even when -XUndecidableSuperClasses are not required.--}--{- Note [Body in DisambECP]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that-require their argument to take a form of (body GhcPs) for some (body :: Type ->-*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the-superclass constraints of DisambECP.--The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop-this requirement. It is possible and would allow removing the type index of-PatBuilder, but leads to worse type inference, breaking some code in the-typechecker.--}--instance DisambECP (HsCmd GhcPs) where-  type Body (HsCmd GhcPs) = HsCmd-  ecpFromCmd' = return-  ecpFromExp' (L l e) = cmdFail l (ppr e)-  mkHsLamPV l mg = return $ L l (HsCmdLam noExtField mg)-  mkHsLetPV l bs e = return $ L l (HsCmdLet noExtField bs e)-  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs-  superInfixOp m = m-  mkHsOpAppPV l c1 op c2 = do-    let cmdArg c = L (getLoc c) $ HsCmdTop noExtField c-    return $ L l $ HsCmdArrForm noExtField op Infix Nothing [cmdArg c1, cmdArg c2]-  mkHsCasePV l c mg = return $ L l (HsCmdCase noExtField c mg)-  mkHsLamCasePV l mg = return $ L l (HsCmdLamCase noExtField mg)-  type FunArg (HsCmd GhcPs) = HsExpr GhcPs-  superFunArg m = m-  mkHsAppPV l c e = do-    checkCmdBlockArguments c-    checkExpBlockArguments e-    return $ L l (HsCmdApp noExtField c e)-  mkHsAppTypePV l c t = cmdFail l (ppr c <+> text "@" <> ppr t)-  mkHsIfPV l c semi1 a semi2 b = do-    checkDoAndIfThenElse c semi1 a semi2 b-    return $ L l (mkHsCmdIf c a b)-  mkHsDoPV l Nothing stmts = return $ L l (HsCmdDo noExtField stmts)-  mkHsDoPV l (Just m)    _ =-    cmdFail l $-      text "Found a qualified" <+> ppr m <> text ".do block in a command, but"-      $$ text "qualified 'do' is not supported in commands."-  mkHsParPV l c = return $ L l (HsCmdPar noExtField c)-  mkHsVarPV (L l v) = cmdFail l (ppr v)-  mkHsLitPV (L l a) = cmdFail l (ppr a)-  mkHsOverLitPV (L l a) = cmdFail l (ppr a)-  mkHsWildCardPV l = cmdFail l (text "_")-  mkHsTySigPV l a sig = cmdFail l (ppr a <+> text "::" <+> ppr sig)-  mkHsExplicitListPV l xs = cmdFail l $-    brackets (fsep (punctuate comma (map ppr xs)))-  mkHsSplicePV (L l sp) = cmdFail l (ppr sp)-  mkHsRecordPV l _ a (fbinds, ddLoc) = cmdFail l $-    ppr a <+> ppr (mk_rec_fields fbinds ddLoc)-  mkHsNegAppPV l a = cmdFail l (text "-" <> ppr a)-  mkHsSectionR_PV l op c = cmdFail l $-    let pp_op = fromMaybe (panic "cannot print infix operator")-                          (ppr_infix_expr (unLoc op))-    in pp_op <> ppr c-  mkHsViewPatPV l a b = cmdFail l $-    ppr a <+> text "->" <+> ppr b-  mkHsAsPatPV l v c = cmdFail l $-    pprPrefixOcc (unLoc v) <> text "@" <> ppr c-  mkHsLazyPatPV l c = cmdFail l $-    text "~" <> ppr c-  mkHsBangPatPV l c = cmdFail l $-    text "!" <> ppr c-  mkSumOrTuplePV l boxity a = cmdFail l (pprSumOrTuple boxity a)-  rejectPragmaPV _ = return ()--cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError loc $-  hang (text "Parse error in command:") 2 (ppr e)--instance DisambECP (HsExpr GhcPs) where-  type Body (HsExpr GhcPs) = HsExpr-  ecpFromCmd' (L l c) = do-    addError l $ vcat-      [ text "Arrow command found where an expression was expected:",-        nest 2 (ppr c) ]-    return (L l hsHoleExpr)-  ecpFromExp' = return-  mkHsLamPV l mg = return $ L l (HsLam noExtField mg)-  mkHsLetPV l bs c = return $ L l (HsLet noExtField bs c)-  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs-  superInfixOp m = m-  mkHsOpAppPV l e1 op e2 = do-    return $ L l $ OpApp noExtField e1 op e2-  mkHsCasePV l e mg = return $ L l (HsCase noExtField e mg)-  mkHsLamCasePV l mg = return $ L l (HsLamCase noExtField mg)-  type FunArg (HsExpr GhcPs) = HsExpr GhcPs-  superFunArg m = m-  mkHsAppPV l e1 e2 = do-    checkExpBlockArguments e1-    checkExpBlockArguments e2-    return $ L l (HsApp noExtField e1 e2)-  mkHsAppTypePV l e t = do-    checkExpBlockArguments e-    return $ L l (HsAppType noExtField e (mkHsWildCardBndrs t))-  mkHsIfPV l c semi1 a semi2 b = do-    checkDoAndIfThenElse c semi1 a semi2 b-    return $ L l (mkHsIf c a b)-  mkHsDoPV l mod stmts = return $ L l (HsDo noExtField (DoExpr mod) stmts)-  mkHsParPV l e = return $ L l (HsPar noExtField e)-  mkHsVarPV v@(getLoc -> l) = return $ L l (HsVar noExtField v)-  mkHsLitPV (L l a) = return $ L l (HsLit noExtField a)-  mkHsOverLitPV (L l a) = return $ L l (HsOverLit noExtField a)-  mkHsWildCardPV l = return $ L l hsHoleExpr-  mkHsTySigPV l a sig = return $ L l (ExprWithTySig noExtField a (mkLHsSigWcType sig))-  mkHsExplicitListPV l xs = return $ L l (ExplicitList noExtField Nothing xs)-  mkHsSplicePV sp = return $ mapLoc (HsSpliceE noExtField) sp-  mkHsRecordPV l lrec a (fbinds, ddLoc) = do-    r <- mkRecConstrOrUpdate a lrec (fbinds, ddLoc)-    checkRecordSyntax (L l r)-  mkHsNegAppPV l a = return $ L l (NegApp noExtField a noSyntaxExpr)-  mkHsSectionR_PV l op e = return $ L l (SectionR noExtField op e)-  mkHsViewPatPV l a b = patSynErr "View pattern" l (ppr a <+> text "->" <+> ppr b) empty-  mkHsAsPatPV l v e =-    patSynErr "@-pattern" l (pprPrefixOcc (unLoc v) <> text "@" <> ppr e) $-    text "Type application syntax requires a space before '@'"-  mkHsLazyPatPV l e = patSynErr "Lazy pattern" l (text "~" <> ppr e) $-    text "Did you mean to add a space after the '~'?"-  mkHsBangPatPV l e = patSynErr "Bang pattern" l (text "!" <> ppr e) $-    text "Did you mean to add a space after the '!'?"-  mkSumOrTuplePV = mkSumOrTupleExpr-  rejectPragmaPV (L _ (OpApp _ _ _ e)) =-    -- assuming left-associative parsing of operators-    rejectPragmaPV e-  rejectPragmaPV (L l (HsPragE _ prag _)) =-    addError l $-      hang (text "A pragma is not allowed in this position:") 2 (ppr prag)-  rejectPragmaPV _ = return ()--patSynErr :: String -> SrcSpan -> SDoc -> SDoc -> PV (LHsExpr GhcPs)-patSynErr item l e explanation =-  do { addError l $-        sep [text item <+> text "in expression context:",-             nest 4 (ppr e)] $$-        explanation-     ; return (L l hsHoleExpr) }--hsHoleExpr :: HsExpr (GhcPass id)-hsHoleExpr = HsUnboundVar noExtField (mkVarOcc "_")---- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]-data PatBuilder p-  = PatBuilderPat (Pat p)-  | PatBuilderPar (Located (PatBuilder p))-  | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))-  | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))-  | PatBuilderVar (Located RdrName)-  | PatBuilderOverLit (HsOverLit GhcPs)--instance Outputable (PatBuilder GhcPs) where-  ppr (PatBuilderPat p) = ppr p-  ppr (PatBuilderPar (L _ p)) = parens (ppr p)-  ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2-  ppr (PatBuilderOpApp (L _ p1) op (L _ p2)) = ppr p1 <+> ppr op <+> ppr p2-  ppr (PatBuilderVar v) = ppr v-  ppr (PatBuilderOverLit l) = ppr l--instance DisambECP (PatBuilder GhcPs) where-  type Body (PatBuilder GhcPs) = PatBuilder-  ecpFromCmd' (L l c) =-    addFatalError l $-      text "Command syntax in pattern:" <+> ppr c-  ecpFromExp' (L l e) =-    addFatalError l $-      text "Expression syntax in pattern:" <+> ppr e-  mkHsLamPV l _ = addFatalError l $-    text "Lambda-syntax in pattern." $$-    text "Pattern matching on functions is not possible."-  mkHsLetPV l _ _ = addFatalError l $ text "(let ... in ...)-syntax in pattern"-  type InfixOp (PatBuilder GhcPs) = RdrName-  superInfixOp m = m-  mkHsOpAppPV l p1 op p2 = return $ L l $ PatBuilderOpApp p1 op p2-  mkHsCasePV l _ _ = addFatalError l $ text "(case ... of ...)-syntax in pattern"-  mkHsLamCasePV l _ = addFatalError l $ text "(\\case ...)-syntax in pattern"-  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs-  superFunArg m = m-  mkHsAppPV l p1 p2 = return $ L l (PatBuilderApp p1 p2)-  mkHsAppTypePV l _ _ = addFatalError l $-    text "Type applications in patterns are not yet supported"-  mkHsIfPV l _ _ _ _ _ = addFatalError l $ text "(if ... then ... else ...)-syntax in pattern"-  mkHsDoPV l _ _ = addFatalError l $ text "do-notation in pattern"-  mkHsParPV l p = return $ L l (PatBuilderPar p)-  mkHsVarPV v@(getLoc -> l) = return $ L l (PatBuilderVar v)-  mkHsLitPV lit@(L l a) = do-    checkUnboxedStringLitPat lit-    return $ L l (PatBuilderPat (LitPat noExtField a))-  mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)-  mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))-  mkHsTySigPV l b sig = do-    p <- checkLPat b-    return $ L l (PatBuilderPat (SigPat noExtField p (mkHsPatSigType sig)))-  mkHsExplicitListPV l xs = do-    ps <- traverse checkLPat xs-    return (L l (PatBuilderPat (ListPat noExtField ps)))-  mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))-  mkHsRecordPV l _ a (fbinds, ddLoc) = do-    r <- mkPatRec a (mk_rec_fields fbinds ddLoc)-    checkRecordSyntax (L l r)-  mkHsNegAppPV l (L lp p) = do-    lit <- case p of-      PatBuilderOverLit pos_lit -> return (L lp pos_lit)-      _ -> patFail l (text "-" <> ppr p)-    return $ L l (PatBuilderPat (mkNPat lit (Just noSyntaxExpr)))-  mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)-  mkHsViewPatPV l a b = do-    p <- checkLPat b-    return $ L l (PatBuilderPat (ViewPat noExtField a p))-  mkHsAsPatPV l v e = do-    p <- checkLPat e-    return $ L l (PatBuilderPat (AsPat noExtField v p))-  mkHsLazyPatPV l e = do-    p <- checkLPat e-    return $ L l (PatBuilderPat (LazyPat noExtField p))-  mkHsBangPatPV l e = do-    p <- checkLPat e-    let pb = BangPat noExtField p-    hintBangPat l pb-    return $ L l (PatBuilderPat pb)-  mkSumOrTuplePV = mkSumOrTuplePat-  rejectPragmaPV _ = return ()--checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()-checkUnboxedStringLitPat (L loc lit) =-  case lit of-    HsStringPrim _ _  -- Trac #13260-      -> addFatalError loc (text "Illegal unboxed string literal in pattern:" $$ ppr lit)-    _ -> return ()--mkPatRec ::-  Located (PatBuilder GhcPs) ->-  HsRecFields GhcPs (Located (PatBuilder GhcPs)) ->-  PV (PatBuilder GhcPs)-mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd)-  | isRdrDataCon (unLoc c)-  = do fs <- mapM checkPatField fs-       return $ PatBuilderPat $ ConPat-         { pat_con_ext = noExtField-         , pat_con = c-         , pat_args = RecCon (HsRecFields fs dd)-         }-mkPatRec p _ =-  addFatalError (getLoc p) $ text "Not a record constructor:" <+> ppr p--{- Note [Ambiguous syntactic categories]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--There are places in the grammar where we do not know whether we are parsing an-expression or a pattern without unlimited lookahead (which we do not have in-'happy'):--View patterns:--    f (Con a b     ) = ...  -- 'Con a b' is a pattern-    f (Con a b -> x) = ...  -- 'Con a b' is an expression--do-notation:--    do { Con a b <- x } -- 'Con a b' is a pattern-    do { Con a b }      -- 'Con a b' is an expression--Guards:--    x | True <- p && q = ...  -- 'True' is a pattern-    x | True           = ...  -- 'True' is an expression--Top-level value/function declarations (FunBind/PatBind):--    f ! a         -- TH splice-    f ! a = ...   -- function declaration--    Until we encounter the = sign, we don't know if it's a top-level-    TemplateHaskell splice where ! is used, or if it's a function declaration-    where ! is bound.--There are also places in the grammar where we do not know whether we are-parsing an expression or a command:--    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression-    proc x -> do { (stuff) }        -- 'stuff' is a command--    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'-    as an expression or a command.--In fact, do-notation is subject to both ambiguities:--    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression-    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern-    proc x -> do { (stuff) }             -- 'stuff' is a command--There are many possible solutions to this problem. For an overview of the ones-we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]--The solution that keeps basic definitions (such as HsExpr) clean, keeps the-concerns local to the parser, and does not require duplication of hsSyn types,-or an extra pass over the entire AST, is to parse into an overloaded-parser-validator (a so-called tagless final encoding):--    class DisambECP b where ...-    instance DisambECP (HsCmd GhcPs) where ...-    instance DisambECP (HsExp GhcPs) where ...-    instance DisambECP (PatBuilder GhcPs) where ...--The 'DisambECP' class contains functions to build and validate 'b'. For example,-to add parentheses we have:--  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)--'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for-expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,-see Note [PatBuilder]).--Consider the 'alts' production used to parse case-of alternatives:--  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--We abstract over LHsExpr GhcPs, and it becomes:--  alts :: { forall b. DisambECP b => PV (Located ([AddAnn],[LMatch GhcPs (Located b)])) }-    : alts1     { $1 >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { $2 >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Compared to the initial definition, the added bits are:--    forall b. DisambECP b => PV ( ... ) -- in the type signature-    $1 >>= \ $1 -> return $             -- in one reduction rule-    $2 >>= \ $2 -> return $             -- in another reduction rule--The overhead is constant relative to the size of the rest of the reduction-rule, so this approach scales well to large parser productions.--Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding-position and shadows the previous $1. We can do this because internally-'happy' desugars $n to happy_var_n, and the rationale behind this idiom-is to be able to write (sLL $1 $>) later on. The alternative would be to-write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer-to the last fresh name as $>.--}---{- Note [Resolving parsing ambiguities: non-taken alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Alternative I, extra constructors in GHC.Hs.Expr--------------------------------------------------We could add extra constructors to HsExpr to represent command-specific and-pattern-specific syntactic constructs. Under this scheme, we parse patterns-and commands as expressions and rejig later.  This is what GHC used to do, and-it polluted 'HsExpr' with irrelevant constructors:--  * for commands: 'HsArrForm', 'HsArrApp'-  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'--(As of now, we still do that for patterns, but we plan to fix it).--There are several issues with this:--  * The implementation details of parsing are leaking into hsSyn definitions.--  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.--  * HsExpr is arbitrarily selected as the extension basis. Why not extend-    HsCmd or HsPat with extra constructors instead?--Alternative II, extra constructors in GHC.Hs.Expr for GhcPs-------------------------------------------------------------We could address some of the problems with Alternative I by using Trees That-Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to-the output of parsing, not to its intermediate results, so we wouldn't want-them there either.--Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs-----------------------------------------------------------------We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.-Unfortunately, creating a new pass would significantly bloat conversion code-and slow down the compiler by adding another linear-time pass over the entire-AST. For example, in order to build HsExpr GhcPrePs, we would need to build-HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds-GhcPrePs.---Alternative IV, sum type and bottom-up data flow--------------------------------------------------Expressions and commands are disjoint. There are no user inputs that could be-interpreted as either an expression or a command depending on outer context:--  5        -- definitely an expression-  x -< y   -- definitely a command--Even though we have both 'HsLam' and 'HsCmdLam', we can look at-the body to disambiguate:--  \p -> 5        -- definitely an expression-  \p -> x -< y   -- definitely a command--This means we could use a bottom-up flow of information to determine-whether we are parsing an expression or a command, using a sum type-for intermediate results:--  Either (LHsExpr GhcPs) (LHsCmd GhcPs)--There are two problems with this:--  * We cannot handle the ambiguity between expressions and-    patterns, which are not disjoint.--  * Bottom-up flow of information leads to poor error messages. Consider--        if ... then 5 else (x -< y)--    Do we report that '5' is not a valid command or that (x -< y) is not a-    valid expression?  It depends on whether we want the entire node to be-    'HsIf' or 'HsCmdIf', and this information flows top-down, from the-    surrounding parsing context (are we in 'proc'?)--Alternative V, backtracking with parser combinators-----------------------------------------------------One might think we could sidestep the issue entirely by using a backtracking-parser and doing something along the lines of (try pExpr <|> pPat).--Turns out, this wouldn't work very well, as there can be patterns inside-expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns-(e.g. view patterns). To handle this, we would need to backtrack while-backtracking, and unbound levels of backtracking lead to very fragile-performance.--Alternative VI, an intermediate data type-------------------------------------------There are common syntactic elements of expressions, commands, and patterns-(e.g. all of them must have balanced parentheses), and we can capture this-common structure in an intermediate data type, Frame:--data Frame-  = FrameVar RdrName-    -- ^ Identifier: Just, map, BS.length-  | FrameTuple [LTupArgFrame] Boxity-    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)-  | FrameTySig LFrame (LHsSigWcType GhcPs)-    -- ^ Type signature: x :: ty-  | FramePar (SrcSpan, SrcSpan) LFrame-    -- ^ Parentheses-  | FrameIf LFrame LFrame LFrame-    -- ^ If-expression: if p then x else y-  | FrameCase LFrame [LFrameMatch]-    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }-  | FrameDo (HsStmtContext GhcRn) [LFrameStmt]-    -- ^ Do-expression: do { s1; a <- s2; s3 }-  ...-  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression-  | FramePat (HsPat GhcPs)     -- unambiguously a pattern-  | FrameCommand (HsCmd GhcPs) -- unambiguously a command--To determine which constructors 'Frame' needs to have, we take the union of-intersections between HsExpr, HsCmd, and HsPat.--The intersection between HsPat and HsExpr:--  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...-  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...-  --------------------------------------------------------------------  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...--The intersection between HsCmd and HsExpr:--  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar-  HsExpr = HsIf    | HsCase    | HsDo    | HsPar-  -------------------------------------------------  Frame = FrameIf  | FrameCase | FrameDo | FramePar--The intersection between HsCmd and HsPat:--  HsPat  = ParPat   | ...-  HsCmd  = HsCmdPar | ...-  ------------------------  Frame  = FramePar | ...--Take the union of each intersection and this yields the final 'Frame' data-type. The problem with this approach is that we end up duplicating a good-portion of hsSyn:--    Frame         for  HsExpr, HsPat, HsCmd-    TupArgFrame   for  HsTupArg-    FrameMatch    for  Match-    FrameStmt     for  StmtLR-    FrameGRHS     for  GRHS-    FrameGRHSs    for  GRHSs-    ...--Alternative VII, a product type---------------------------------We could avoid the intermediate representation of Alternative VI by parsing-into a product of interpretations directly:--    -- See Note [Parser-Validator]-    type ExpCmdPat = ( PV (LHsExpr GhcPs)-                     , PV (LHsCmd GhcPs)-                     , PV (LHsPat GhcPs) )--This means that in positions where we do not know whether to produce-expression, a pattern, or a command, we instead produce a parser-validator for-each possible option.--Then, as soon as we have parsed far enough to resolve the ambiguity, we pick-the appropriate component of the product, discarding the rest:--    checkExpOf3 (e, _, _) = e  -- interpret as an expression-    checkCmdOf3 (_, c, _) = c  -- interpret as a command-    checkPatOf3 (_, _, p) = p  -- interpret as a pattern--We can easily define ambiguities between arbitrary subsets of interpretations.-For example, when we know ahead of type that only an expression or a command is-possible, but not a pattern, we can use a smaller type:--    -- See Note [Parser-Validator]-    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))--    checkExpOf2 (e, _) = e  -- interpret as an expression-    checkCmdOf2 (_, c) = c  -- interpret as a command--However, there is a slight problem with this approach, namely code duplication-in parser productions. Consider the 'alts' production used to parse case-of-alternatives:--  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Under the new scheme, we have to completely duplicate its type signature and-each reduction rule:--  alts :: { ( PV (Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression-            , PV (Located ([AddAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command-            ) }-    : alts1-        { ( checkExpOf2 $1 >>= \ $1 ->-            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)-          , checkCmdOf2 $1 >>= \ $1 ->-            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)-          ) }-    | ';' alts-        { ( checkExpOf2 $2 >>= \ $2 ->-            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)-          , checkCmdOf2 $2 >>= \ $2 ->-            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)-          ) }--And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',-'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!--Alternative VIII, a function from a GADT------------------------------------------We could avoid code duplication of the Alternative VII by representing the product-as a function from a GADT:--    data ExpCmdG b where-      ExpG :: ExpCmdG HsExpr-      CmdG :: ExpCmdG HsCmd--    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))--    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)-    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)-    checkExp f = f ExpG  -- interpret as an expression-    checkCmd f = f CmdG  -- interpret as a command--Consider the 'alts' production used to parse case-of alternatives:--  alts :: { Located ([AddAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--We abstract over LHsExpr, and it becomes:--  alts :: { forall b. ExpCmdG b -> PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1-        { \tag -> $1 tag >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts-        { \tag -> $2 tag >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Note that 'ExpCmdG' is a singleton type, the value is completely-determined by the type:--  when (b~HsExpr),  tag = ExpG-  when (b~HsCmd),   tag = CmdG--This is a clear indication that we can use a class to pass this value behind-the scenes:--  class    ExpCmdI b      where expCmdG :: ExpCmdG b-  instance ExpCmdI HsExpr where expCmdG = ExpG-  instance ExpCmdI HsCmd  where expCmdG = CmdG--And now the 'alts' production is simplified, as we no longer need to-thread 'tag' explicitly:--  alts :: { forall b. ExpCmdI b => PV (Located ([AddAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1     { $1 >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { $2 >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--This encoding works well enough, but introduces an extra GADT unlike the-tagless final encoding, and there's no need for this complexity.---}--{- Note [PatBuilder]-~~~~~~~~~~~~~~~~~~~~-Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,-so we introduce the notion of a PatBuilder.--Consider a pattern like this:--  Con a b c--We parse arguments to "Con" one at a time in the  fexp aexp  parser production,-building the result with mkHsAppPV, so the intermediate forms are:--  1. Con-  2. Con a-  3. Con a b-  4. Con a b c--In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like-this (pseudocode):--  1. "Con"-  2. HsApp "Con" "a"-  3. HsApp (HsApp "Con" "a") "b"-  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"--Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have-instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for-the intermediate forms.--We also need an intermediate representation to postpone disambiguation between-FunBind and PatBind. Consider:--  a `Con` b = ...-  a `fun` b = ...--How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We-learn this by inspecting an intermediate representation in 'isFunLhs' and-seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate-representation capable of representing both a FunBind and a PatBind, so Pat is-insufficient.--PatBuilder is an extension of Pat that is capable of representing intermediate-parsing results for patterns and function bindings:--  data PatBuilder p-    = PatBuilderPat (Pat p)-    | PatBuilderApp (Located (PatBuilder p)) (Located (PatBuilder p))-    | PatBuilderOpApp (Located (PatBuilder p)) (Located RdrName) (Located (PatBuilder p))-    ...--It can represent any pattern via 'PatBuilderPat', but it also has a variety of-other constructors which were added by following a simple principle: we never-pattern match on the pattern stored inside 'PatBuilderPat'.--}-------------------------------------------------------------------------------- Miscellaneous utilities---- | Check if a fixity is valid. We support bypassing the usual bound checks--- for some special operators.-checkPrecP-        :: Located (SourceText,Int)             -- ^ precedence-        -> Located (OrdList (Located RdrName))  -- ^ operators-        -> P ()-checkPrecP (L l (_,i)) (L _ ol)- | 0 <= i, i <= maxPrecedence = pure ()- | all specialOp ol = pure ()- | otherwise = addFatalError l (text ("Precedence out of range: " ++ show i))-  where-    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs-    specialOp op = unLoc op `elem` [ eqTyCon_RDR-                                   , getRdrName unrestrictedFunTyCon ]--mkRecConstrOrUpdate-        :: LHsExpr GhcPs-        -> SrcSpan-        -> ([LHsRecField GhcPs (LHsExpr GhcPs)], Maybe SrcSpan)-        -> PV (HsExpr GhcPs)--mkRecConstrOrUpdate (L l (HsVar _ (L _ c))) _ (fs,dd)-  | isRdrDataCon c-  = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd))-mkRecConstrOrUpdate exp _ (fs,dd)-  | Just dd_loc <- dd = addFatalError dd_loc (text "You cannot use `..' in a record update")-  | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs))--mkRdrRecordUpd :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> HsExpr GhcPs-mkRdrRecordUpd exp flds-  = RecordUpd { rupd_ext  = noExtField-              , rupd_expr = exp-              , rupd_flds = flds }--mkRdrRecordCon :: Located RdrName -> HsRecordBinds GhcPs -> HsExpr GhcPs-mkRdrRecordCon con flds-  = RecordCon { rcon_ext = noExtField, rcon_con_name = con, rcon_flds = flds }--mk_rec_fields :: [LHsRecField id arg] -> Maybe SrcSpan -> HsRecFields id arg-mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }-mk_rec_fields fs (Just s)  = HsRecFields { rec_flds = fs-                                     , rec_dotdot = Just (L s (length fs)) }--mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs-mk_rec_upd_field (HsRecField (L loc (FieldOcc _ rdr)) arg pun)-  = HsRecField (L loc (Unambiguous noExtField rdr)) arg pun--mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation-               -> InlinePragma--- The (Maybe Activation) is because the user can omit--- the activation spec (and usually does)-mkInlinePragma src (inl, match_info) mb_act-  = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.Basic-                 , inl_inline = inl-                 , inl_sat    = Nothing-                 , inl_act    = act-                 , inl_rule   = match_info }-  where-    act = case mb_act of-            Just act -> act-            Nothing  -> -- No phase specified-                        case inl of-                          NoInline -> NeverActive-                          _other   -> AlwaysActive---------------------------------------------------------------------------------- utilities for foreign declarations---- construct a foreign import declaration----mkImport :: Located CCallConv-         -> Located Safety-         -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)-         -> P (HsDecl GhcPs)-mkImport cconv safety (L loc (StringLiteral esrc entity), v, ty) =-    case unLoc cconv of-      CCallConv          -> mkCImport-      CApiConv           -> mkCImport-      StdCallConv        -> mkCImport-      PrimCallConv       -> mkOtherImport-      JavaScriptCallConv -> mkOtherImport-  where-    -- Parse a C-like entity string of the following form:-    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"-    -- If 'cid' is missing, the function name 'v' is used instead as symbol-    -- name (cf section 8.5.1 in Haskell 2010 report).-    mkCImport = do-      let e = unpackFS entity-      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of-        Nothing         -> addFatalError loc (text "Malformed entity string")-        Just importSpec -> returnSpec importSpec--    -- currently, all the other import conventions only support a symbol name in-    -- the entity string. If it is missing, we use the function name instead.-    mkOtherImport = returnSpec importSpec-      where-        entity'    = if nullFS entity-                        then mkExtName (unLoc v)-                        else entity-        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)-        importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)--    returnSpec spec = return $ ForD noExtField $ ForeignImport-          { fd_i_ext  = noExtField-          , fd_name   = v-          , fd_sig_ty = ty-          , fd_fi     = spec-          }------ the string "foo" is ambiguous: either a header or a C identifier.  The--- C identifier case comes first in the alternatives below, so we pick--- that one.-parseCImport :: Located CCallConv -> Located Safety -> FastString -> String-             -> Located SourceText-             -> Maybe ForeignImport-parseCImport cconv safety nm str sourceText =- listToMaybe $ map fst $ filter (null.snd) $-     readP_to_S parse str- where-   parse = do-       skipSpaces-       r <- choice [-          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),-          string "wrapper" >> return (mk Nothing CWrapper),-          do optional (token "static" >> skipSpaces)-             ((mk Nothing <$> cimp nm) +++-              (do h <- munch1 hdr_char-                  skipSpaces-                  mk (Just (Header (SourceText h) (mkFastString h)))-                      <$> cimp nm))-         ]-       skipSpaces-       return r--   token str = do _ <- string str-                  toks <- look-                  case toks of-                      c : _-                       | id_char c -> pfail-                      _            -> return ()--   mk h n = CImport cconv safety h n sourceText--   hdr_char c = not (isSpace c)-   -- header files are filenames, which can contain-   -- pretty much any char (depending on the platform),-   -- so just accept any non-space character-   id_first_char c = isAlpha    c || c == '_'-   id_char       c = isAlphaNum c || c == '_'--   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)-             +++ (do isFun <- case unLoc cconv of-                               CApiConv ->-                                  option True-                                         (do token "value"-                                             skipSpaces-                                             return False)-                               _ -> return True-                     cid' <- cid-                     return (CFunction (StaticTarget NoSourceText cid'-                                        Nothing isFun)))-          where-            cid = return nm +++-                  (do c  <- satisfy id_first_char-                      cs <-  many (satisfy id_char)-                      return (mkFastString (c:cs)))----- construct a foreign export declaration----mkExport :: Located CCallConv-         -> (Located StringLiteral, Located RdrName, LHsSigType GhcPs)-         -> P (HsDecl GhcPs)-mkExport (L lc cconv) (L le (StringLiteral esrc entity), v, ty)- = return $ ForD noExtField $-   ForeignExport { fd_e_ext = noExtField, fd_name = v, fd_sig_ty = ty-                 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))-                                   (L le esrc) }-  where-    entity' | nullFS entity = mkExtName (unLoc v)-            | otherwise     = entity---- Supplying the ext_name in a foreign decl is optional; if it--- isn't there, the Haskell name is assumed. Note that no transformation--- of the Haskell name is then performed, so if you foreign export (++),--- it's external name will be "++". Too bad; it's important because we don't--- want z-encoding (e.g. names with z's in them shouldn't be doubled)----mkExtName :: RdrName -> CLabelString-mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))------------------------------------------------------------------------------------- Help with module system imports/exports--data ImpExpSubSpec = ImpExpAbs-                   | ImpExpAll-                   | ImpExpList [Located ImpExpQcSpec]-                   | ImpExpAllWith [Located ImpExpQcSpec]--data ImpExpQcSpec = ImpExpQcName (Located RdrName)-                  | ImpExpQcType (Located RdrName)-                  | ImpExpQcWildcard--mkModuleImpExp :: Located ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)-mkModuleImpExp (L l specname) subs =-  case subs of-    ImpExpAbs-      | isVarNameSpace (rdrNameSpace name)-                       -> return $ IEVar noExtField (L l (ieNameFromSpec specname))-      | otherwise      -> IEThingAbs noExtField . L l <$> nameT-    ImpExpAll          -> IEThingAll noExtField . L l <$> nameT-    ImpExpList xs      ->-      (\newName -> IEThingWith noExtField (L l newName)-        NoIEWildcard (wrapped xs) []) <$> nameT-    ImpExpAllWith xs                       ->-      do allowed <- getBit PatternSynonymsBit-         if allowed-          then-            let withs = map unLoc xs-                pos   = maybe NoIEWildcard IEWildcard-                          (findIndex isImpExpQcWildcard withs)-                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs-            in (\newName-                        -> IEThingWith noExtField (L l newName) pos ies [])-               <$> nameT-          else addFatalError l-            (text "Illegal export form (use PatternSynonyms to enable)")-  where-    name = ieNameVal specname-    nameT =-      if isVarNameSpace (rdrNameSpace name)-        then addFatalError l-              (text "Expecting a type constructor but found a variable,"-               <+> quotes (ppr name) <> text "."-              $$ if isSymOcc $ rdrNameOcc name-                   then text "If" <+> quotes (ppr name)-                        <+> text "is a type constructor"-           <+> text "then enable ExplicitNamespaces and use the 'type' keyword."-                   else empty)-        else return $ ieNameFromSpec specname--    ieNameVal (ImpExpQcName ln)  = unLoc ln-    ieNameVal (ImpExpQcType ln)  = unLoc ln-    ieNameVal (ImpExpQcWildcard) = panic "ieNameVal got wildcard"--    ieNameFromSpec (ImpExpQcName ln)  = IEName ln-    ieNameFromSpec (ImpExpQcType ln)  = IEType ln-    ieNameFromSpec (ImpExpQcWildcard) = panic "ieName got wildcard"--    wrapped = map (mapLoc ieNameFromSpec)--mkTypeImpExp :: Located RdrName   -- TcCls or Var name space-             -> P (Located RdrName)-mkTypeImpExp name =-  do allowed <- getBit ExplicitNamespacesBit-     unless allowed $ addError (getLoc name) $-       text "Illegal keyword 'type' (use ExplicitNamespaces to enable)"-     return (fmap (`setRdrNameSpace` tcClsName) name)--checkImportSpec :: Located [LIE GhcPs] -> P (Located [LIE GhcPs])-checkImportSpec ie@(L _ specs) =-    case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of-      [] -> return ie-      (l:_) -> importSpecError l-  where-    importSpecError l =-      addFatalError l-        (text "Illegal import form, this syntax can only be used to bundle"-        $+$ text "pattern synonyms with types in module exports.")---- In the correct order-mkImpExpSubSpec :: [Located ImpExpQcSpec] -> P ([AddAnn], ImpExpSubSpec)-mkImpExpSubSpec [] = return ([], ImpExpList [])-mkImpExpSubSpec [L _ ImpExpQcWildcard] =-  return ([], ImpExpAll)-mkImpExpSubSpec xs =-  if (any (isImpExpQcWildcard . unLoc) xs)-    then return $ ([], ImpExpAllWith xs)-    else return $ ([], ImpExpList xs)--isImpExpQcWildcard :: ImpExpQcSpec -> Bool-isImpExpQcWildcard ImpExpQcWildcard = True-isImpExpQcWildcard _                = False---------------------------------------------------------------------------------- Warnings and failures--warnPrepositiveQualifiedModule :: SrcSpan -> P ()-warnPrepositiveQualifiedModule span =-  addWarning Opt_WarnPrepositiveQualifiedModule span msg-  where-    msg = text "Found" <+> quotes (text "qualified")-           <+> text "in prepositive position"-       $$ text "Suggested fix: place " <+> quotes (text "qualified")-           <+> text "after the module name instead."--failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failOpNotEnabledImportQualifiedPost loc = addError loc msg-  where-    msg = text "Found" <+> quotes (text "qualified")-          <+> text "in postpositive position. "-      $$ text "To allow this, enable language extension 'ImportQualifiedPost'"--failOpImportQualifiedTwice :: SrcSpan -> P ()-failOpImportQualifiedTwice loc = addError loc msg-  where-    msg = text "Multiple occurrences of 'qualified'"--warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addWarning Opt_WarnStarIsType span msg-  where-    msg =  text "Using" <+> quotes (text "*")-           <+> text "(or its Unicode variant) to mean"-           <+> quotes (text "Data.Kind.Type")-        $$ text "relies on the StarIsType extension, which will become"-        $$ text "deprecated in the future."-        $$ text "Suggested fix: use" <+> quotes (text "Type")-           <+> text "from" <+> quotes (text "Data.Kind") <+> text "instead."--warnStarBndr :: SrcSpan -> P ()-warnStarBndr span = addWarning Opt_WarnStarBinder span msg-  where-    msg =  text "Found binding occurrence of" <+> quotes (text "*")-           <+> text "yet StarIsType is enabled."-        $$ text "NB. To use (or export) this operator in"-           <+> text "modules with StarIsType,"-        $$ text "    including the definition module, you must qualify it."--failOpFewArgs :: Located RdrName -> P a-failOpFewArgs (L loc op) =-  do { star_is_type <- getBit StarIsTypeBit-     ; let msg = too_few $$ starInfo star_is_type op-     ; addFatalError loc msg }-  where-    too_few = text "Operator applied to too few arguments:" <+> ppr op---------------------------------------------------------------------------------- Misc utils--data PV_Context =-  PV_Context-    { pv_options :: ParserFlags-    , pv_hint :: SDoc  -- See Note [Parser-Validator Hint]-    }--data PV_Accum =-  PV_Accum-    { pv_messages :: DynFlags -> Messages-    , pv_annotations :: [(ApiAnnKey,[RealSrcSpan])]-    , pv_comment_q :: [RealLocated AnnotationComment]-    , pv_annotations_comments :: [(RealSrcSpan,[RealLocated AnnotationComment])]-    }--data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum---- See Note [Parser-Validator]-newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }--instance Functor PV where-  fmap = liftM--instance Applicative PV where-  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)-  (<*>) = ap--instance Monad PV where-  m >>= f = PV $ \ctx acc ->-    case unPV m ctx acc of-      PV_Ok acc' a -> unPV (f a) ctx acc'-      PV_Failed acc' -> PV_Failed acc'--runPV :: PV a -> P a-runPV = runPV_msg empty--runPV_msg :: SDoc -> PV a -> P a-runPV_msg msg m =-  P $ \s ->-    let-      pv_ctx = PV_Context-        { pv_options = options s-        , pv_hint = msg }-      pv_acc = PV_Accum-        { pv_messages = messages s-        , pv_annotations = annotations s-        , pv_comment_q = comment_q s-        , pv_annotations_comments = annotations_comments s }-      mkPState acc' =-        s { messages = pv_messages acc'-          , annotations = pv_annotations acc'-          , comment_q = pv_comment_q acc'-          , annotations_comments = pv_annotations_comments acc' }-    in-      case unPV m pv_ctx pv_acc of-        PV_Ok acc' a -> POk (mkPState acc') a-        PV_Failed acc' -> PFailed (mkPState acc')--localPV_msg :: (SDoc -> SDoc) -> PV a -> PV a-localPV_msg f m =-  let modifyHint ctx = ctx{pv_hint = f (pv_hint ctx)} in-  PV (\ctx acc -> unPV m (modifyHint ctx) acc)--instance MonadP PV where-  addError srcspan msg =-    PV $ \ctx acc@PV_Accum{pv_messages=m} ->-      let msg' = msg $$ pv_hint ctx in-      PV_Ok acc{pv_messages=appendError srcspan msg' m} ()-  addWarning option srcspan warning =-    PV $ \PV_Context{pv_options=o} acc@PV_Accum{pv_messages=m} ->-      PV_Ok acc{pv_messages=appendWarning o option srcspan warning m} ()-  addFatalError srcspan msg =-    addError srcspan msg >> PV (const PV_Failed)-  getBit ext =-    PV $ \ctx acc ->-      let b = ext `xtest` pExtsBitmap (pv_options ctx) in-      PV_Ok acc $! b-  addAnnotation (RealSrcSpan l _) a (RealSrcSpan v _) =-    PV $ \_ acc ->-      let-        (comment_q', new_ann_comments) = allocateComments l (pv_comment_q acc)-        annotations_comments' = new_ann_comments ++ pv_annotations_comments acc-        annotations' = ((l,a), [v]) : pv_annotations acc-        acc' = acc-          { pv_annotations = annotations'-          , pv_comment_q = comment_q'-          , pv_annotations_comments = annotations_comments' }-      in-        PV_Ok acc' ()-  addAnnotation _ _ _ = return ()--{- Note [Parser-Validator]-~~~~~~~~~~~~~~~~~~~~~~~~~~--When resolving ambiguities, we need to postpone failure to make a choice later.-For example, if we have ambiguity between some A and B, our parser could be--  abParser :: P (Maybe A, Maybe B)--This way we can represent four possible outcomes of parsing:--    (Just a, Nothing)       -- definitely A-    (Nothing, Just b)       -- definitely B-    (Just a, Just b)        -- either A or B-    (Nothing, Nothing)      -- neither A nor B--However, if we want to report informative parse errors, accumulate warnings,-and add API annotations, we are better off using 'P' instead of 'Maybe':--  abParser :: P (P A, P B)--So we have an outer layer of P that consumes the input and builds the inner-layer, which validates the input.--For clarity, we introduce the notion of a parser-validator: a parser that does-not consume any input, but may fail or use other effects. Thus we have:--  abParser :: P (PV A, PV B)---}--{- Note [Parser-Validator Hint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A PV computation is parametrized by a hint for error messages, which can be set-depending on validation context. We use this in checkPattern to fix #984.--Consider this example, where the user has forgotten a 'do':--  f _ = do-    x <- computation-    case () of-      _ ->-        result <- computation-        case () of () -> undefined--GHC parses it as follows:--  f _ = do-    x <- computation-    (case () of-      _ ->-        result) <- computation-        case () of () -> undefined--Note that this fragment is parsed as a pattern:--  case () of-    _ ->-      result--We attempt to detect such cases and add a hint to the error messages:--  T984.hs:6:9:-    Parse error in pattern: case () of { _ -> result }-    Possibly caused by a missing 'do'?--The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed-as the 'pv_hint' field 'PV_Context'. When validating in a context other than-'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has-no effect on the error messages.---}---- | Hint about bang patterns, assuming @BangPatterns@ is off.-hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()-hintBangPat span e = do-    bang_on <- getBit BangPatBit-    unless bang_on $-      addError span-        (text "Illegal bang-pattern (use BangPatterns):" $$ ppr e)--data SumOrTuple b-  = Sum ConTag Arity (Located b)-  | Tuple [Located (Maybe (Located b))]--pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc-pprSumOrTuple boxity = \case-    Sum alt arity e ->-      parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)-              <+> parClose-    Tuple xs ->-      parOpen <> (fcat . punctuate comma $ map (maybe empty ppr . unLoc) xs)-              <> parClose-  where-    ppr_bars n = hsep (replicate n (Outputable.char '|'))-    (parOpen, parClose) =-      case boxity of-        Boxed -> (text "(", text ")")-        Unboxed -> (text "(#", text "#)")--mkSumOrTupleExpr :: SrcSpan -> Boxity -> SumOrTuple (HsExpr GhcPs) -> PV (LHsExpr GhcPs)---- Tuple-mkSumOrTupleExpr l boxity (Tuple es) =-    return $ L l (ExplicitTuple noExtField (map toTupArg es) boxity)-  where-    toTupArg :: Located (Maybe (LHsExpr GhcPs)) -> LHsTupArg GhcPs-    toTupArg = mapLoc (maybe missingTupArg (Present noExtField))---- Sum-mkSumOrTupleExpr l Unboxed (Sum alt arity e) =-    return $ L l (ExplicitSum noExtField alt arity e)-mkSumOrTupleExpr l Boxed a@Sum{} =-    addFatalError l (hang (text "Boxed sums not supported:") 2-                      (pprSumOrTuple Boxed a))--mkSumOrTuplePat :: SrcSpan -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> PV (Located (PatBuilder GhcPs))---- Tuple-mkSumOrTuplePat l boxity (Tuple ps) = do-  ps' <- traverse toTupPat ps-  return $ L l (PatBuilderPat (TuplePat noExtField ps' boxity))-  where-    toTupPat :: Located (Maybe (Located (PatBuilder GhcPs))) -> PV (LPat GhcPs)-    -- Ignore the element location so that the error message refers to the-    -- entire tuple. See #19504 (and the discussion) for details.-    toTupPat (L _ p) = case p of-      Nothing -> addFatalError l (text "Tuple section in pattern context")-      Just p' -> checkLPat p'---- Sum-mkSumOrTuplePat l Unboxed (Sum alt arity p) = do-   p' <- checkLPat p-   return $ L l (PatBuilderPat (SumPat noExtField p' alt arity))-mkSumOrTuplePat l Boxed a@Sum{} =-    addFatalError l (hang (text "Boxed sums not supported:") 2-                      (pprSumOrTuple Boxed a))--mkLHsOpTy :: LHsType GhcPs -> Located RdrName -> LHsType GhcPs -> LHsType GhcPs-mkLHsOpTy x op y =-  let loc = getLoc x `combineSrcSpans` getLoc op `combineSrcSpans` getLoc y-  in L loc (mkHsOpTy x op y)--mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> (HsArrow GhcPs, AddAnn)-mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1)))-  -- See #18888 for the use of (SourceText "1") above-  = (HsLinearArrow u, AddAnn AnnPercentOne (combineLocs tok t))-mkMultTy u tok t = (HsExplicitMult u t, AddAnn AnnPercent (getLoc tok))---------------------------------------------------------------------------------- Token symbols--starSym :: Bool -> String-starSym True = "★"-starSym False = "*"--forallSym :: Bool -> String-forallSym True = "∀"-forallSym False = "forall"+{-# LANGUAGE CPP               #-}+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE ViewPatterns      #-}+{-# LANGUAGE LambdaCase        #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++--+--  (c) The University of Glasgow 2002-2006+--++-- Functions over HsSyn specialised to RdrName.++module GHC.Parser.PostProcess (+        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot+        mkHsOpApp,+        mkHsIntegral, mkHsFractional, mkHsIsString,+        mkHsDo, mkSpliceDecl,+        mkRoleAnnotDecl,+        mkClassDecl,+        mkTyData, mkDataFamInst,+        mkTySynonym, mkTyFamInstEqn,+        mkStandaloneKindSig,+        mkTyFamInst,+        mkFamDecl,+        mkInlinePragma,+        mkPatSynMatchGroup,+        mkRecConstrOrUpdate,+        mkTyClD, mkInstD,+        mkRdrRecordCon, mkRdrRecordUpd,+        setRdrNameSpace,+        fromSpecTyVarBndr, fromSpecTyVarBndrs,+        annBinds,++        cvBindGroup,+        cvBindsAndSigs,+        cvTopDecls,+        placeHolderPunRhs,++        -- Stuff to do with Foreign declarations+        mkImport,+        parseCImport,+        mkExport,+        mkExtName,    -- RdrName -> CLabelString+        mkGadtDecl,   -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName+        mkConDeclH98,++        -- Bunch of functions in the parser monad for+        -- checking and constructing values+        checkImportDecl,+        checkExpBlockArguments, checkCmdBlockArguments,+        checkPrecP,           -- Int -> P Int+        checkContext,         -- HsType -> P HsContext+        checkPattern,         -- HsExp -> P HsPat+        checkPattern_hints,+        checkMonadComp,       -- P (HsStmtContext GhcPs)+        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl+        checkValSigLhs,+        LRuleTyTmVar, RuleTyTmVar(..),+        mkRuleBndrs, mkRuleTyVarBndrs,+        checkRuleTyVarBndrNames,+        checkRecordSyntax,+        checkEmptyGADTs,+        addFatalError, hintBangPat,+        mkBangTy,+        UnpackednessPragma(..),+        mkMultTy,++        -- Help with processing exports+        ImpExpSubSpec(..),+        ImpExpQcSpec(..),+        mkModuleImpExp,+        mkTypeImpExp,+        mkImpExpSubSpec,+        checkImportSpec,++        -- Token symbols+        starSym,++        -- Warnings and errors+        warnStarIsType,+        warnPrepositiveQualifiedModule,+        failOpFewArgs,+        failOpNotEnabledImportQualifiedPost,+        failOpImportQualifiedTwice,++        SumOrTuple (..),++        -- Expression/command/pattern ambiguity resolution+        PV,+        runPV,+        ECP(ECP, unECP),+        DisambInfixOp(..),+        DisambECP(..),+        ecpFromExp,+        ecpFromCmd,+        PatBuilder,++        -- Type/datacon ambiguity resolution+        DisambTD(..),+        addUnpackednessP,+        dataConBuilderCon,+        dataConBuilderDetails,+    ) where++import GHC.Prelude+import GHC.Hs           -- Lots of it+import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )+import GHC.Core.DataCon        ( DataCon, dataConTyCon )+import GHC.Core.ConLike        ( ConLike(..) )+import GHC.Core.Coercion.Axiom ( Role, fsFromRole )+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Unit.Module (ModuleName)+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Parser.Types+import GHC.Parser.Lexer+import GHC.Parser.Errors+import GHC.Utils.Lexeme ( isLexCon )+import GHC.Types.TyThing+import GHC.Core.Type    ( unrestrictedFunTyCon, Specificity(..) )+import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,+                          nilDataConName, nilDataConKey,+                          listTyConName, listTyConKey, eqTyCon_RDR )+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc+import GHC.Types.Unique ( hasKey )+import GHC.Data.OrdList+import GHC.Utils.Outputable as Outputable+import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.Bag+import GHC.Utils.Misc+import Data.Either+import Data.List+import Data.Foldable+import GHC.Driver.Flags ( WarningFlag(..) )+import qualified Data.Semigroup as Semi+import GHC.Utils.Panic++import Control.Monad+import Text.ParserCombinators.ReadP as ReadP+import Data.Char+import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )+import Data.Kind       ( Type )+import Data.List.NonEmpty (NonEmpty)++#include "HsVersions.h"++{- **********************************************************************++  Construction functions for Rdr stuff++  ********************************************************************* -}++-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and+-- datacon by deriving them from the name of the class.  We fill in the names+-- for the tycon and datacon corresponding to the class, by deriving them+-- from the name of the class itself.  This saves recording the names in the+-- interface file (which would be equally good).++-- Similarly for mkConDecl, mkClassOpSig and default-method names.++--         *** See Note [The Naming story] in GHC.Hs.Decls ****++mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)+mkTyClD (L loc d) = L loc (TyClD noExtField d)++mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)+mkInstD (L loc d) = L loc (InstD noExtField d)++mkClassDecl :: SrcSpan+            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)+            -> Located (a,[LHsFunDep GhcPs])+            -> OrdList (LHsDecl GhcPs)+            -> LayoutInfo+            -> [AddEpAnn]+            -> P (LTyClDecl GhcPs)++mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn+  = do { let loc = noAnnSrcSpan loc'+       ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls+       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr+       ; tyvars <- checkTyVars (text "class") whereDots cls tparams+       ; cs <- getCommentsFor (locA loc) -- Get any remaining comments+       ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs+       ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo)+                                  , tcdCtxt = mcxt+                                  , tcdLName = cls, tcdTyVars = tyvars+                                  , tcdFixity = fixity+                                  , tcdFDs = snd (unLoc fds)+                                  , tcdSigs = mkClassOpSigs sigs+                                  , tcdMeths = binds+                                  , tcdATs = ats, tcdATDefs = at_defs+                                  , tcdDocs  = docs })) }++mkTyData :: SrcSpan+         -> NewOrData+         -> Maybe (LocatedP CType)+         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)+         -> Maybe (LHsKind GhcPs)+         -> [LConDecl GhcPs]+         -> Located (HsDeriving GhcPs)+         -> [AddEpAnn]+         -> P (LTyClDecl GhcPs)+mkTyData loc' new_or_data cType (L _ (mcxt, tycl_hdr))+         ksig data_cons (L _ maybe_deriv) annsIn+  = do { let loc = noAnnSrcSpan loc'+       ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr+       ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams+       ; cs <- getCommentsFor (locA loc) -- Get any remaining comments+       ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs+       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+       ; return (L loc (DataDecl { tcdDExt = anns',+                                   tcdLName = tc, tcdTyVars = tyvars,+                                   tcdFixity = fixity,+                                   tcdDataDefn = defn })) }++mkDataDefn :: NewOrData+           -> Maybe (LocatedP CType)+           -> Maybe (LHsContext GhcPs)+           -> Maybe (LHsKind GhcPs)+           -> [LConDecl GhcPs]+           -> HsDeriving GhcPs+           -> P (HsDataDefn GhcPs)+mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+  = do { checkDatatypeContext mcxt+       ; return (HsDataDefn { dd_ext = noExtField+                            , dd_ND = new_or_data, dd_cType = cType+                            , dd_ctxt = mcxt+                            , dd_cons = data_cons+                            , dd_kindSig = ksig+                            , dd_derivs = maybe_deriv }) }+++mkTySynonym :: SrcSpan+            -> LHsType GhcPs  -- LHS+            -> LHsType GhcPs  -- RHS+            -> [AddEpAnn]+            -> P (LTyClDecl GhcPs)+mkTySynonym loc lhs rhs annsIn+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs+       ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]+       ; tyvars <- checkTyVars (text "type") equalsDots tc tparams+       ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]+       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)+       ; return (L (noAnnSrcSpan loc) (SynDecl+                                { tcdSExt = anns'+                                , tcdLName = tc, tcdTyVars = tyvars+                                , tcdFixity = fixity+                                , tcdRhs = rhs })) }++mkStandaloneKindSig+  :: SrcSpan+  -> Located [LocatedN RdrName]   -- LHS+  -> LHsSigType GhcPs             -- RHS+  -> [AddEpAnn]+  -> P (LStandaloneKindSig GhcPs)+mkStandaloneKindSig loc lhs rhs anns =+  do { vs <- mapM check_lhs_name (unLoc lhs)+     ; v <- check_singular_lhs (reverse vs)+     ; cs <- getCommentsFor loc+     ; return $ L (noAnnSrcSpan loc)+       $ StandaloneKindSig (EpAnn (spanAsAnchor loc) anns cs) v rhs }+  where+    check_lhs_name v@(unLoc->name) =+      if isUnqual name && isTcOcc (rdrNameOcc name)+      then return v+      else addFatalError $ PsError (PsErrUnexpectedQualifiedConstructor (unLoc v)) [] (getLocA v)+    check_singular_lhs vs =+      case vs of+        [] -> panic "mkStandaloneKindSig: empty left-hand side"+        [v] -> return v+        _ -> addFatalError $ PsError (PsErrMultipleNamesInStandaloneKindSignature vs) [] (getLoc lhs)++mkTyFamInstEqn :: SrcSpan+               -> HsOuterFamEqnTyVarBndrs GhcPs+               -> LHsType GhcPs+               -> LHsType GhcPs+               -> [AddEpAnn]+               -> P (LTyFamInstEqn GhcPs)+mkTyFamInstEqn loc bndrs lhs rhs anns+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs+       ; cs <- getCommentsFor loc+       ; return (L (noAnnSrcSpan loc) $ FamEqn+                        { feqn_ext    = EpAnn (spanAsAnchor loc) (anns `mappend` ann) cs+                        , feqn_tycon  = tc+                        , feqn_bndrs  = bndrs+                        , feqn_pats   = tparams+                        , feqn_fixity = fixity+                        , feqn_rhs    = rhs })}++mkDataFamInst :: SrcSpan+              -> NewOrData+              -> Maybe (LocatedP CType)+              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs+                        , LHsType GhcPs)+              -> Maybe (LHsKind GhcPs)+              -> [LConDecl GhcPs]+              -> Located (HsDeriving GhcPs)+              -> [AddEpAnn]+              -> P (LInstDecl GhcPs)+mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)+              ksig data_cons (L _ maybe_deriv) anns+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr+       ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan+       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments+       ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+       ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl+                  (FamEqn { feqn_ext    = anns'+                          , feqn_tycon  = tc+                          , feqn_bndrs  = bndrs+                          , feqn_pats   = tparams+                          , feqn_fixity = fixity+                          , feqn_rhs    = defn })))) }++mkTyFamInst :: SrcSpan+            -> TyFamInstEqn GhcPs+            -> [AddEpAnn]+            -> P (LInstDecl GhcPs)+mkTyFamInst loc eqn anns = do+  cs <- getCommentsFor loc+  return (L (noAnnSrcSpan loc) (TyFamInstD noExtField+              (TyFamInstDecl (EpAnn (spanAsAnchor loc) anns cs) eqn)))++mkFamDecl :: SrcSpan+          -> FamilyInfo GhcPs+          -> TopLevelFlag+          -> LHsType GhcPs                   -- LHS+          -> Located (FamilyResultSig GhcPs) -- Optional result signature+          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation+          -> [AddEpAnn]+          -> P (LTyClDecl GhcPs)+mkFamDecl loc info topLevel lhs ksig injAnn annsIn+  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs+       ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]+       ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams+       ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]+       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)+       ; return (L (noAnnSrcSpan loc) (FamDecl noExtField+                                         (FamilyDecl+                                           { fdExt       = anns'+                                           , fdTopLevel  = topLevel+                                           , fdInfo      = info, fdLName = tc+                                           , fdTyVars    = tyvars+                                           , fdFixity    = fixity+                                           , fdResultSig = ksig+                                           , fdInjectivityAnn = injAnn }))) }+  where+    equals_or_where = case info of+                        DataFamily          -> empty+                        OpenTypeFamily      -> empty+                        ClosedTypeFamily {} -> whereDots++mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)+-- If the user wrote+--      [pads| ... ]   then return a QuasiQuoteD+--      $(e)           then return a SpliceD+-- but if they wrote, say,+--      f x            then behave as if they'd written $(f x)+--                     ie a SpliceD+--+-- Typed splices are not allowed at the top level, thus we do not represent them+-- as spliced declaration.  See #10945+mkSpliceDecl lexpr@(L loc expr)+  | HsSpliceE _ splice@(HsUntypedSplice {}) <- expr = do+    cs <- getCommentsFor (locA loc)+    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)++  | HsSpliceE _ splice@(HsQuasiQuote {}) <- expr = do+    cs <- getCommentsFor (locA loc)+    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) ExplicitSplice)++  | otherwise = do+    cs <- getCommentsFor (locA loc)+    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField+                                 (L loc (mkUntypedSplice noAnn BareSplice lexpr))+                                       ImplicitSplice)++mkRoleAnnotDecl :: SrcSpan+                -> LocatedN RdrName                -- type being annotated+                -> [Located (Maybe FastString)]    -- roles+                -> [AddEpAnn]+                -> P (LRoleAnnotDecl GhcPs)+mkRoleAnnotDecl loc tycon roles anns+  = do { roles' <- mapM parse_role roles+       ; cs <- getCommentsFor loc+       ; return $ L (noAnnSrcSpan loc)+         $ RoleAnnotDecl (EpAnn (spanAsAnchor loc) anns cs) tycon roles' }+  where+    role_data_type = dataTypeOf (undefined :: Role)+    all_roles = map fromConstr $ dataTypeConstrs role_data_type+    possible_roles = [(fsFromRole role, role) | role <- all_roles]++    parse_role (L loc_role Nothing) = return $ L loc_role Nothing+    parse_role (L loc_role (Just role))+      = case lookup role possible_roles of+          Just found_role -> return $ L loc_role $ Just found_role+          Nothing         ->+            let nearby = fuzzyLookup (unpackFS role)+                  (mapFst unpackFS possible_roles)+            in+            addFatalError $ PsError (PsErrIllegalRoleName role nearby) [] loc_role++-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to+-- binders without annotations. Only accepts specified variables, and errors if+-- any of the provided binders has an 'InferredSpec' annotation.+fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]+fromSpecTyVarBndrs = mapM fromSpecTyVarBndr++-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without+-- annotations. Only accepts specified variables, and errors if the provided+-- binder has an 'InferredSpec' annotation.+fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)+fromSpecTyVarBndr bndr = case bndr of+  (L loc (UserTyVar xtv flag idp))     -> (check_spec flag loc)+                                          >> return (L loc $ UserTyVar xtv () idp)+  (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)+                                          >> return (L loc $ KindedTyVar xtv () idp k)+  where+    check_spec :: Specificity -> SrcSpanAnnA -> P ()+    check_spec SpecifiedSpec _   = return ()+    check_spec InferredSpec  loc = addFatalError $ PsError PsErrInferredTypeVarNotAllowed [] (locA loc)++-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@+annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs+  -> (HsLocalBinds GhcPs, Maybe EpAnnComments)+annBinds a cs (HsValBinds an bs)  = (HsValBinds (add_where a an cs) bs, Nothing)+annBinds a cs (HsIPBinds an bs)   = (HsIPBinds (add_where a an cs) bs, Nothing)+annBinds _ cs  (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)++add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList+add_where an@(AddEpAnn _ (EpaSpan rs)) (EpAnn a (AnnList anc o c r t) cs) cs2+  | valid_anchor (anchor a)+  = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)+  | otherwise+  = EpAnn (patch_anchor rs a)+          (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)+add_where an@(AddEpAnn _ (EpaSpan rs)) EpAnnNotUsed cs+  = EpAnn (Anchor rs UnchangedAnchor)+           (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs+add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"+ -- EpaDelta should only be used for transformations++valid_anchor :: RealSrcSpan -> Bool+valid_anchor r = srcSpanStartLine r >= 0++-- If the decl list for where binds is empty, the anchor ends up+-- invalid. In this case, use the parent one+patch_anchor :: RealSrcSpan -> Anchor -> Anchor+patch_anchor r1 (Anchor r0 op) = Anchor r op+  where+    r = if srcSpanStartLine r0 < 0 then r1 else r0++{- **********************************************************************++  #cvBinds-etc# Converting to @HsBinds@, etc.++  ********************************************************************* -}++-- | Function definitions are restructured here. Each is assumed to be recursive+-- initially, and non recursive definitions are discovered by the dependency+-- analyser.+++--  | Groups together bindings for a single function+cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]+cvTopDecls decls = getMonoBindAll (fromOL decls)++-- Declaration list may only contain value bindings and signatures.+cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)+cvBindGroup binding+  = do { (mbs, sigs, fam_ds, tfam_insts+         , dfam_insts, _) <- cvBindsAndSigs binding+       ; ASSERT( null fam_ds && null tfam_insts && null dfam_insts)+         return $ ValBinds NoAnnSortKey mbs sigs }++cvBindsAndSigs :: OrdList (LHsDecl GhcPs)+  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]+          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])+-- Input decls contain just value bindings and signatures+-- and in case of class or instance declarations also+-- associated type declarations. They might also contain Haddock comments.+cvBindsAndSigs fb = do+  fb' <- drop_bad_decls (fromOL fb)+  return (partitionBindsAndSigs (getMonoBindAll fb'))+  where+    -- cvBindsAndSigs is called in several places in the parser,+    -- and its items can be produced by various productions:+    --+    --    * decl       (when parsing a where clause or a let-expression)+    --    * decl_inst  (when parsing an instance declaration)+    --    * decl_cls   (when parsing a class declaration)+    --+    -- partitionBindsAndSigs can handle almost all declaration forms produced+    -- by the aforementioned productions, except for SpliceD, which we filter+    -- out here (in drop_bad_decls).+    --+    -- We're not concerned with every declaration form possible, such as those+    -- produced by the topdecl parser production, because cvBindsAndSigs is not+    -- called on top-level declarations.+    drop_bad_decls [] = return []+    drop_bad_decls (L l (SpliceD _ d) : ds) = do+      addError $ PsError (PsErrDeclSpliceNotAtTopLevel d) [] (locA l)+      drop_bad_decls ds+    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds++-----------------------------------------------------------------------------+-- Group function bindings into equation groups++getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]+  -> (LHsBind GhcPs, [LHsDecl GhcPs])+-- Suppose      (b',ds') = getMonoBind b ds+--      ds is a list of parsed bindings+--      b is a MonoBinds that has just been read off the front++-- Then b' is the result of grouping more equations from ds that+-- belong with b into a single MonoBinds, and ds' is the depleted+-- list of parsed bindings.+--+-- All Haddock comments between equations inside the group are+-- discarded.+--+-- No AndMonoBinds or EmptyMonoBinds here; just single equations++getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)+                             , fun_matches =+                               MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))+            binds+  | has_args m1+  = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []+  where+    go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA+       -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]+       -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ+    go mtchs loc+       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)+                                 , fun_matches =+                                    MG { mg_alts = (L _ [L lm2 mtchs2]) } })))+         : binds) _+        | f1 == f2 =+          let (loc2', lm2') = transferAnnsA loc2 lm2+          in go (L lm2' mtchs2 : mtchs)+                        (combineSrcSpansA loc loc2') binds []+    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls+        = let doc_decls' = doc_decl : doc_decls+          in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'+    go mtchs loc binds doc_decls+        = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs))+          , (reverse doc_decls) ++ binds)+        -- Reverse the final matches, to get it back in the right order+        -- Do the same thing with the trailing doc comments++getMonoBind bind binds = (bind, binds)++-- Group together adjacent FunBinds for every function.+getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]+getMonoBindAll [] = []+getMonoBindAll (L l (ValD _ b) : ds) =+  let (L l' b', ds') = getMonoBind (L l b) ds+  in L l' (ValD noExtField b') : getMonoBindAll ds'+getMonoBindAll (d : ds) = d : getMonoBindAll ds++has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool+has_args []                                  = panic "GHC.Parser.PostProcess.has_args"+has_args (L _ (Match { m_pats = args }) : _) = not (null args)+        -- Don't group together FunBinds if they have+        -- no arguments.  This is necessary now that variable bindings+        -- with no arguments are now treated as FunBinds rather+        -- than pattern bindings (tests/rename/should_fail/rnfail002).++{- **********************************************************************++  #PrefixToHS-utils# Utilities for conversion++  ********************************************************************* -}++{- Note [Parsing data constructors is hard]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The problem with parsing data constructors is that they look a lot like types.+Compare:++  (s1)   data T = C t1 t2+  (s2)   type T = C t1 t2++Syntactically, there's little difference between these declarations, except in+(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.++This similarity would pose no problem if we knew ahead of time if we are+parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple+(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing+data constructors, and in other contexts (e.g. 'type' declarations) assume we+are parsing type constructors.++This simple rule does not work because of two problematic cases:++  (p1)   data T = C t1 t2 :+ t3+  (p2)   data T = C t1 t2 => t3++In (p1) we encounter (:+) and it turns out we are parsing an infix data+declaration, so (C t1 t2) is a type and 'C' is a type constructor.+In (p2) we encounter (=>) and it turns out we are parsing an existential+context, so (C t1 t2) is a constraint and 'C' is a type constructor.++As the result, in order to determine whether (C t1 t2) declares a data+constructor, a type, or a context, we would need unlimited lookahead which+'happy' is not so happy with.+-}++-- | Reinterpret a type constructor, including type operators, as a data+--   constructor.+-- See Note [Parsing data constructors is hard]+tyConToDataCon :: LocatedN RdrName -> Either PsError (LocatedN RdrName)+tyConToDataCon (L loc tc)+  | isTcOcc occ || isDataOcc occ+  , isLexCon (occNameFS occ)+  = return (L loc (setRdrNameSpace tc srcDataName))++  | otherwise+  = Left $ PsError (PsErrNotADataCon tc) [] (locA loc)+  where+    occ = rdrNameOcc tc++mkPatSynMatchGroup :: LocatedN RdrName+                   -> LocatedL (OrdList (LHsDecl GhcPs))+                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))+mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =+    do { matches <- mapM fromDecl (fromOL decls)+       ; when (null matches) (wrongNumberErr (locA loc))+       ; return $ mkMatchGroup FromSource (L ld matches) }+  where+    fromDecl (L loc decl@(ValD _ (PatBind _+                                 -- AZ: where should these anns come from?+                         pat@(L _ (ConPat noAnn ln@(L _ name) details))+                               rhs _))) =+        do { unless (name == patsyn_name) $+               wrongNameBindingErr (locA loc) decl+           ; match <- case details of+               PrefixCon _ pats -> return $ Match { m_ext = noAnn+                                                  , m_ctxt = ctxt, m_pats = pats+                                                  , m_grhss = rhs }+                   where+                     ctxt = FunRhs { mc_fun = ln+                                   , mc_fixity = Prefix+                                   , mc_strictness = NoSrcStrict }++               InfixCon p1 p2 -> return $ Match { m_ext = noAnn+                                                , m_ctxt = ctxt+                                                , m_pats = [p1, p2]+                                                , m_grhss = rhs }+                   where+                     ctxt = FunRhs { mc_fun = ln+                                   , mc_fixity = Infix+                                   , mc_strictness = NoSrcStrict }++               RecCon{} -> recordPatSynErr (locA loc) pat+           ; return $ L loc match }+    fromDecl (L loc decl) = extraDeclErr (locA loc) decl++    extraDeclErr loc decl =+        addFatalError $ PsError (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl) [] loc++    wrongNameBindingErr loc decl =+      addFatalError $ PsError (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl) [] loc++    wrongNumberErr loc =+      addFatalError $ PsError (PsErrEmptyWhereInPatSynDecl patsyn_name) [] loc++recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a+recordPatSynErr loc pat =+    addFatalError $ PsError (PsErrRecordSyntaxInPatSynDecl pat) [] loc++mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]+                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs+                -> ConDecl GhcPs++mkConDeclH98 ann name mb_forall mb_cxt args+  = ConDeclH98 { con_ext    = ann+               , con_name   = name+               , con_forall = isJust mb_forall+               , con_ex_tvs = mb_forall `orElse` []+               , con_mb_cxt = mb_cxt+               , con_args   = args+               , con_doc    = Nothing }++-- | Construct a GADT-style data constructor from the constructor names and+-- their type. Some interesting aspects of this function:+--+-- * This splits up the constructor type into its quantified type variables (if+--   provided), context (if provided), argument types, and result type, and+--   records whether this is a prefix or record GADT constructor. See+--   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.+mkGadtDecl :: SrcSpan+           -> [LocatedN RdrName]+           -> LHsSigType GhcPs+           -> [AddEpAnn]+           -> P (LConDecl GhcPs)+mkGadtDecl loc names ty annsIn = do+  cs <- getCommentsFor loc+  let l = noAnnSrcSpan loc++  let (args, res_ty, annsa, csa)+        | L ll (HsFunTy af _w (L loc' (HsRecTy an rf)) res_ty) <- body_ty+        = let+            an' = addTrailingAnnToL (locA loc') (anns af) (comments af) an+          in ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf), res_ty+             , [], epAnnComments (ann ll))+        | otherwise+        = let (anns, cs, arg_types, res_type) = splitHsFunType body_ty+          in (PrefixConGADT arg_types, res_type, anns, cs)++      an = case outer_bndrs of+        _                -> EpAnn (spanAsAnchor loc) (annsIn ++ annsa) (cs Semi.<> csa)++  pure $ L l ConDeclGADT+                     { con_g_ext  = an+                     , con_names  = names+                     , con_bndrs  = L (getLoc ty) outer_bndrs+                     , con_mb_cxt = mcxt+                     , con_g_args = args+                     , con_res_ty = res_ty+                     , con_doc    = Nothing }+  where+    (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty++setRdrNameSpace :: RdrName -> NameSpace -> RdrName+-- ^ This rather gruesome function is used mainly by the parser.+-- When parsing:+--+-- > data T a = T | T1 Int+--+-- we parse the data constructors as /types/ because of parser ambiguities,+-- so then we need to change the /type constr/ to a /data constr/+--+-- The exact-name case /can/ occur when parsing:+--+-- > data [] a = [] | a : [a]+--+-- For the exact-name case we return an original name.+setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)+setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)+setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)+setRdrNameSpace (Exact n)    ns+  | Just thing <- wiredInNameTyThing_maybe n+  = setWiredInNameSpace thing ns+    -- Preserve Exact Names for wired-in things,+    -- notably tuples and lists++  | isExternalName n+  = Orig (nameModule n) occ++  | otherwise   -- This can happen when quoting and then+                -- splicing a fixity declaration for a type+  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))+  where+    occ = setOccNameSpace ns (nameOccName n)++setWiredInNameSpace :: TyThing -> NameSpace -> RdrName+setWiredInNameSpace (ATyCon tc) ns+  | isDataConNameSpace ns+  = ty_con_data_con tc+  | isTcClsNameSpace ns+  = Exact (getName tc)      -- No-op++setWiredInNameSpace (AConLike (RealDataCon dc)) ns+  | isTcClsNameSpace ns+  = data_con_ty_con dc+  | isDataConNameSpace ns+  = Exact (getName dc)      -- No-op++setWiredInNameSpace thing ns+  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)++ty_con_data_con :: TyCon -> RdrName+ty_con_data_con tc+  | isTupleTyCon tc+  , Just dc <- tyConSingleDataCon_maybe tc+  = Exact (getName dc)++  | tc `hasKey` listTyConKey+  = Exact nilDataConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace srcDataName (getOccName tc))++data_con_ty_con :: DataCon -> RdrName+data_con_ty_con dc+  | let tc = dataConTyCon dc+  , isTupleTyCon tc+  = Exact (getName tc)++  | dc `hasKey` nilDataConKey+  = Exact listTyConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace tcClsName (getOccName dc))++++{- Note [setRdrNameSpace for wired-in names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC.Types, which declares (:), we have+  infixr 5 :+The ambiguity about which ":" is meant is resolved by parsing it as a+data constructor, but then using dataTcOccs to try the type constructor too;+and that in turn calls setRdrNameSpace to change the name-space of ":" to+tcClsName.  There isn't a corresponding ":" type constructor, but it's painful+to make setRdrNameSpace partial, so we just make an Unqual name instead. It+really doesn't matter!+-}++eitherToP :: MonadP m => Either PsError a -> m a+-- Adapts the Either monad to the P monad+eitherToP (Left err)    = addFatalError err+eitherToP (Right thing) = return thing++checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]+            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables+-- ^ Check whether the given list of type parameters are all type variables+-- (possibly with a kind signature).+checkTyVars pp_what equals_or_where tc tparms+  = do { tvs <- mapM check tparms+       ; return (mkHsQTvs tvs) }+  where+    check (HsTypeArg _ ki@(L loc _)) = addFatalError $ PsError (PsErrUnexpectedTypeAppInDecl ki pp_what (unLoc tc)) [] (locA loc)+    check (HsValArg ty) = chkParens [] [] emptyComments ty+    check (HsArgPar sp) = addFatalError $ PsError (PsErrMalformedDecl pp_what (unLoc tc)) [] sp+        -- Keep around an action for adjusting the annotations of extra parens+    chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs+              -> P (LHsTyVarBndr () GhcPs)+    chkParens ops cps cs (L l (HsParTy an ty))+      = let+          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)+        in+          chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) ty+    chkParens ops cps cs ty = chk ops cps cs ty++        -- Check that the name space is correct!+    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> LHsType GhcPs -> P (LHsTyVarBndr () GhcPs)+    chk ops cps cs (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))+        | isRdrTyVar tv+            = let+                an = (reverse ops) ++ cps+              in+                return (L (widenLocatedAn (l Semi.<> annt) an)+                       (KindedTyVar (addAnns (annk Semi.<> ann) an cs) () (L lv tv) k))+    chk ops cps cs (L l (HsTyVar ann _ (L ltv tv)))+        | isRdrTyVar tv+            = let+                an = (reverse ops) ++ cps+              in+                return (L (widenLocatedAn l an)+                                     (UserTyVar (addAnns ann an cs) () (L ltv tv)))+    chk _ _ _ t@(L loc _)+        = addFatalError $ PsError (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where) [] (locA loc)+++whereDots, equalsDots :: SDoc+-- Second argument to checkTyVars+whereDots  = text "where ..."+equalsDots = text "= ..."++checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()+checkDatatypeContext Nothing = return ()+checkDatatypeContext (Just c)+    = do allowed <- getBit DatatypeContextsBit+         unless allowed $ addError $ PsError (PsErrIllegalDataTypeContext c) [] (getLocA c)++type LRuleTyTmVar = Located RuleTyTmVar+data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))+-- ^ Essentially a wrapper for a @RuleBndr GhcPs@++-- turns RuleTyTmVars into RuleBnrs - this is straightforward+mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]+mkRuleBndrs = fmap (fmap cvt_one)+  where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v+        cvt_one (RuleTyTmVar ann v (Just sig)) =+          RuleBndrSig ann v (mkHsPatSigType noAnn sig)++-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting+mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]+mkRuleTyVarBndrs = fmap cvt_one+  where cvt_one (L l (RuleTyTmVar ann v Nothing))+          = L (noAnnSrcSpan l) (UserTyVar ann () (fmap tm_to_ty v))+        cvt_one (L l (RuleTyTmVar ann v (Just sig)))+          = L (noAnnSrcSpan l) (KindedTyVar ann () (fmap tm_to_ty v) sig)+    -- takes something in namespace 'varName' to something in namespace 'tvName'+        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)+        tm_to_ty _ = panic "mkRuleTyVarBndrs"++-- See note [Parsing explicit foralls in Rules] in Parser.y+checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()+checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)+  where check (L loc (Unqual occ)) =+          -- TODO: don't use string here, OccName has a Unique/FastString+          when ((occNameString occ ==) `any` ["forall","family","role"])+            (addFatalError $ PsError (PsErrParseErrorOnInput occ) [] (locA loc))+        check _ = panic "checkRuleTyVarBndrNames"++checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)+checkRecordSyntax lr@(L loc r)+    = do allowed <- getBit TraditionalRecordSyntaxBit+         unless allowed $ addError $ PsError (PsErrIllegalTraditionalRecordSyntax (ppr r)) [] (locA loc)+         return lr++-- | Check if the gadt_constrlist is empty. Only raise parse error for+-- `data T where` to avoid affecting existing error message, see #8258.+checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])+                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))+checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.+    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax+         unless gadtSyntax $ addError $ PsError PsErrIllegalWhereInDataDecl [] span+         return gadts+checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.++checkTyClHdr :: Bool               -- True  <=> class header+                                   -- False <=> type header+             -> LHsType GhcPs+             -> P (LocatedN RdrName,     -- the head symbol (type or class name)+                   [LHsTypeArg GhcPs],   -- parameters of head symbol+                   LexicalFixity,        -- the declaration is in infix format+                   [AddEpAnn])           -- API Annotation for HsParTy+                                         -- when stripping parens+-- Well-formedness check and decomposition of type and class heads.+-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])+--              Int :*: Bool   into    (:*:, [Int, Bool])+-- returning the pieces+checkTyClHdr is_cls ty+  = goL ty [] [] [] Prefix+  where+    goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix++    -- workaround to define '*' despite StarIsType+    go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix+      = do { addWarning Opt_WarnStarBinder (PsWarnStarBinder (locA l))+           ; let name = mkOccName tcClsName (starSym isUni)+           ; let a' = newAnns l an+           ; return (L a' (Unqual name), acc, fix+                    , (reverse ops') ++ cps') }++    go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix+      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps)+    go _ (HsOpTy _ t1 ltc@(L _ tc) t2) acc ops cps _fix+      | isRdrTc tc               = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)+    go l (HsParTy _ ty)    acc ops cps fix = goL ty acc (o:ops) (c:cps) fix+      where+        (o,c) = mkParensEpAnn (realSrcSpan l)+    go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix+    go _ (HsAppKindTy l ty ki) acc ops cps fix = goL ty (HsTypeArg l ki:acc) ops cps fix+    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix+      = return (L (noAnnSrcSpan l) (nameRdrName tup_name)+               , map HsValArg ts, fix, (reverse ops)++cps)+      where+        arity = length ts+        tup_name | is_cls    = cTupleTyConName arity+                 | otherwise = getName (tupleTyCon Boxed arity)+          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)+    go l _ _ _ _ _+      = addFatalError $ PsError (PsErrMalformedTyOrClDecl ty) [] l++    -- Combine the annotations from the HsParTy and HsStarTy into a+    -- new one for the LocatedN RdrName+    newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN+    newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =+      let+        lr = combineRealSrcSpans (realSrcSpan l) (anchor as)+        -- lr = widenAnchorR as (realSrcSpan l)+        an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c []) cs)+      in SrcSpanAnn an (RealSrcSpan lr Nothing)+    newAnns _ EpAnnNotUsed = panic "missing AnnParen"+    newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =+      let+        lr = combineRealSrcSpans (anchor ap) (anchor as)+        an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (EpaSpan $ realSrcSpan l) c ta) (csp Semi.<> cs))+      in SrcSpanAnn an (RealSrcSpan lr Nothing)++-- | Yield a parse error if we have a function applied directly to a do block+-- etc. and BlockArguments is not enabled.+checkExpBlockArguments :: LHsExpr GhcPs -> PV ()+checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)+  where+    checkExpr :: LHsExpr GhcPs -> PV ()+    checkExpr expr = case unLoc expr of+      HsDo _ (DoExpr m) _  -> check (PsErrDoInFunAppExpr m)     expr+      HsDo _ (MDoExpr m) _ -> check (PsErrMDoInFunAppExpr m)    expr+      HsLam {}             -> check PsErrLambdaInFunAppExpr     expr+      HsCase {}            -> check PsErrCaseInFunAppExpr       expr+      HsLamCase {}         -> check PsErrLambdaCaseInFunAppExpr expr+      HsLet {}             -> check PsErrLetInFunAppExpr        expr+      HsIf {}              -> check PsErrIfInFunAppExpr         expr+      HsProc {}            -> check PsErrProcInFunAppExpr       expr+      _                    -> return ()++    checkCmd :: LHsCmd GhcPs -> PV ()+    checkCmd cmd = case unLoc cmd of+      HsCmdLam {}  -> check PsErrLambdaCmdInFunAppCmd cmd+      HsCmdCase {} -> check PsErrCaseCmdInFunAppCmd   cmd+      HsCmdIf {}   -> check PsErrIfCmdInFunAppCmd     cmd+      HsCmdLet {}  -> check PsErrLetCmdInFunAppCmd    cmd+      HsCmdDo {}   -> check PsErrDoCmdInFunAppCmd     cmd+      _            -> return ()++    check err a = do+      blockArguments <- getBit BlockArgumentsBit+      unless blockArguments $+        addError $ PsError (err a) [] (getLocA a)++-- | Validate the context constraints and break up a context into a list+-- of predicates.+--+-- @+--     (Eq a, Ord b)        -->  [Eq a, Ord b]+--     Eq a                 -->  [Eq a]+--     (Eq a)               -->  [Eq a]+--     (((Eq a)))           -->  [Eq a]+-- @+checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)+checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =+  check ([],[],emptyComments) orig_t+ where+  check :: ([EpaLocation],[EpaLocation],EpAnnComments)+        -> LHsType GhcPs -> P (LHsContext GhcPs)+  check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))+    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can+    -- be used as context constraints.+    -- Ditto ()+    = do+        let (op,cp,cs') = case ann' of+              EpAnnNotUsed -> ([],[],emptyComments)+              EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs)+        return (L (SrcSpanAnn (EpAnn (spanAsAnchor l)+                              -- Append parens so that the original order in the source is maintained+                               (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts)++  check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))+                                  -- to be sure HsParTy doesn't get into the way+    = do+        let (op,cp,cs') = case ann' of+                    EpAnnNotUsed -> ([],[],emptyComments)+                    EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs)+        check (op++opi,cp++cpi,cs' Semi.<> csi) ty++  -- No need for anns, returning original+  check (_opi,_cpi,_csi) _t =+                 return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) emptyComments) l) [orig_t])++checkImportDecl :: Maybe EpaLocation+                -> Maybe EpaLocation+                -> P ()+checkImportDecl mPre mPost = do+  let whenJust mg f = maybe (pure ()) f mg++  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit++  -- Error if 'qualified' found in postpositive position and+  -- 'ImportQualifiedPost' is not in effect.+  whenJust mPost $ \post ->+    when (not importQualifiedPostEnabled) $+      failOpNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)++  -- Error if 'qualified' occurs in both pre and postpositive+  -- positions.+  whenJust mPost $ \post ->+    when (isJust mPre) $+      failOpImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Nothing)++  -- Warn if 'qualified' found in prepositive position and+  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.+  whenJust mPre $ \pre ->+    warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Nothing)++-- -------------------------------------------------------------------------+-- Checking Patterns.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)+checkPattern = runPV . checkLPat++checkPattern_hints :: [Hint] -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)+checkPattern_hints hints pp = runPV_hints hints (pp >>= checkLPat)++checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)+checkLPat e@(L l _) = checkPat l e [] []++checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]+         -> PV (LPat GhcPs)+checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args+  | isRdrDataCon c = return . L loc $ ConPat+      { pat_con_ext = noAnn -- AZ: where should this come from?+      , pat_con = L ln c+      , pat_args = PrefixCon tyargs args+      }+  | not (null tyargs) =+      add_hint TypeApplicationsInPatternsOnlyDataCons $+      patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs])+  | not (null args) && patIsRec c =+      add_hint SuggestRecursiveDo $+      patFail (locA l) (ppr e)+checkPat loc (L _ (PatBuilderAppType f t)) tyargs args =+  checkPat loc f (t : tyargs) args+checkPat loc (L _ (PatBuilderApp f e)) [] args = do+  p <- checkLPat e+  checkPat loc f [] (p : args)+checkPat loc (L l e) [] [] = do+  p <- checkAPat loc e+  return (L l p)+checkPat loc e _ _ = patFail (locA loc) (ppr e)++checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)+checkAPat loc e0 = do+ nPlusKPatterns <- getBit NPlusKPatternsBit+ case e0 of+   PatBuilderPat p -> return p+   PatBuilderVar x -> return (VarPat noExtField x)++   -- Overloaded numeric patterns (e.g. f 0 x = x)+   -- Negation is recorded separately, so that the literal is zero or +ve+   -- NB. Negative *primitive* literals are already handled by the lexer+   PatBuilderOverLit pos_lit -> return (mkNPat (L (locA loc) pos_lit) Nothing noAnn)++   -- n+k patterns+   PatBuilderOpApp+           (L _ (PatBuilderVar (L nloc n)))+           (L l plus)+           (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))+           (EpAnn anc _ cs)+                     | nPlusKPatterns && (plus == plus_RDR)+                     -> return (mkNPlusKPat (L nloc n) (L (locA lloc) lit)+                                (EpAnn anc (epaLocationFromSrcAnn l) cs))++   -- Improve error messages for the @-operator when the user meant an @-pattern+   PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do+     addError $ PsError PsErrAtInPatPos [] (getLocA op)+     return (WildPat noExtField)++   PatBuilderOpApp l (L cl c) r anns+     | isRdrDataCon c -> do+         l <- checkLPat l+         r <- checkLPat r+         return $ ConPat+           { pat_con_ext = anns+           , pat_con = L cl c+           , pat_args = InfixCon l r+           }++   PatBuilderPar e an@(AnnParen pt o c) -> do+     (L l p) <- checkLPat e+     let aa = [AddEpAnn ai o, AddEpAnn ac c]+         (ai,ac) = parenTypeKws pt+     return (ParPat (EpAnn (spanAsAnchor $ (widenSpan (locA l) aa)) an emptyComments) (L l p))+   _           -> patFail (locA loc) (ppr e0)++placeHolderPunRhs :: DisambECP b => PV (LocatedA b)+-- The RHS of a punned record field will be filled in by the renamer+-- It's better not to make it an error, in case we want to print it when+-- debugging+placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)++plus_RDR, pun_RDR :: RdrName+plus_RDR = mkUnqual varName (fsLit "+") -- Hack+pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")++checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))+              -> PV (LHsRecField GhcPs (LPat GhcPs))+checkPatField (L l fld) = do p <- checkLPat (hsRecFieldArg fld)+                             return (L l (fld { hsRecFieldArg = p }))++patFail :: SrcSpan -> SDoc -> PV a+patFail loc e = addFatalError $ PsError (PsErrParseErrorInPat e) [] loc++patIsRec :: RdrName -> Bool+patIsRec e = e == mkUnqual varName (fsLit "rec")++---------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SrcSpan+            -> LocatedA (PatBuilder GhcPs)+            -> Maybe (AddEpAnn, LHsType GhcPs)+            -> Located (GRHSs GhcPs (LHsExpr GhcPs))+            -> P (HsBind GhcPs)++checkValDef loc lhs (Just (sigAnn, sig)) grhss+        -- x :: ty = rhs  parses as a *pattern* binding+  = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn]+                        >>= checkLPat+       checkPatBind loc [] lhs' grhss++checkValDef loc lhs Nothing g+  = do  { mb_fun <- isFunLhs lhs+        ; case mb_fun of+            Just (fun, is_infix, pats, ann) ->+              checkFunBind NoSrcStrict loc ann+                           fun is_infix pats g+            Nothing -> do+              lhs' <- checkPattern lhs+              checkPatBind loc [] lhs' g }++checkFunBind :: SrcStrictness+             -> SrcSpan+             -> [AddEpAnn]+             -> LocatedN RdrName+             -> LexicalFixity+             -> [LocatedA (PatBuilder GhcPs)]+             -> Located (GRHSs GhcPs (LHsExpr GhcPs))+             -> P (HsBind GhcPs)+checkFunBind strictness locF ann fun is_infix pats (L _ grhss)+  = do  ps <- runPV_hints param_hints (mapM checkLPat pats)+        let match_span = noAnnSrcSpan $ locF+        cs <- getCommentsFor locF+        return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)+                 [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs+                                      , m_ctxt = FunRhs+                                          { mc_fun    = fun+                                          , mc_fixity = is_infix+                                          , mc_strictness = strictness }+                                      , m_pats = ps+                                      , m_grhss = grhss })]))+        -- The span of the match covers the entire equation.+        -- That isn't quite right, but it'll do for now.+  where+    param_hints+      | Infix <- is_infix = [SuggestInfixBindMaybeAtPat (unLoc fun)]+      | otherwise         = []++makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]+            -> HsBind GhcPs+-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too+makeFunBind fn ms+  = FunBind { fun_ext = noExtField,+              fun_id = fn,+              fun_matches = mkMatchGroup FromSource ms,+              fun_tick = [] }++-- See Note [FunBind vs PatBind]+checkPatBind :: SrcSpan+             -> [AddEpAnn]+             -> LPat GhcPs+             -> Located (GRHSs GhcPs (LHsExpr GhcPs))+             -> P (HsBind GhcPs)+checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))+                        (L _match_span grhss)+      = return (makeFunBind v (L (noAnnSrcSpan loc)+                [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)]))+  where+    m a v = Match { m_ext = a+                  , m_ctxt = FunRhs { mc_fun    = v+                                    , mc_fixity = Prefix+                                    , mc_strictness = SrcStrict }+                  , m_pats = []+                 , m_grhss = grhss }++checkPatBind loc annsIn lhs (L _ grhss) = do+  cs <- getCommentsFor loc+  return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss ([],[]))++checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)+checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))+  | isUnqual v+  , not (isDataOcc (rdrNameOcc v))+  = return lrdr++checkValSigLhs lhs@(L l _)+  = addFatalError $ PsError (PsErrInvalidTypeSignature lhs) [] (locA l)++checkDoAndIfThenElse+  :: (Outputable a, Outputable b, Outputable c)+  => (a -> Bool -> b -> Bool -> c -> PsErrorDesc)+  -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()+checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr+ | semiThen || semiElse = do+      doAndIfThenElse <- getBit DoAndIfThenElseBit+      let e   = err (unLoc guardExpr)+                    semiThen (unLoc thenExpr)+                    semiElse (unLoc elseExpr)+          loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)++      unless doAndIfThenElse $ addError (PsError e [] loc)+  | otherwise = return ()++isFunLhs :: LocatedA (PatBuilder GhcPs)+      -> P (Maybe (LocatedN RdrName, LexicalFixity,+                   [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))+-- A variable binding is parsed as a FunBind.+-- Just (fun, is_infix, arg_pats) if e is a function LHS+isFunLhs e = go e [] [] []+ where+   go (L _ (PatBuilderVar (L loc f))) es ops cps+       | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))+   go (L _ (PatBuilderApp f e)) es       ops cps = go f (e:es) ops cps+   go (L l (PatBuilderPar e _)) es@(_:_) ops cps+                                      = let+                                          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)+                                        in+                                          go e es (o:ops) (c:cps)+   go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps+        | not (isRdrDataCon op)         -- We have found the function!+        = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps)))+        | otherwise                     -- Infix data con; keep going+        = do { mb_l <- go l es ops cps+             ; case mb_l of+                 Just (op', Infix, j : k : es', anns')+                   -> return (Just (op', Infix, j : op_app : es', anns'))+                   where+                     op_app = L loc (PatBuilderOpApp k+                               (L loc' op) r (EpAnn loca (reverse ops++cps) cs))+                 _ -> return Nothing }+   go _ _ _ _ = return Nothing++mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs+mkBangTy anns strictness =+  HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness)++-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.+data UnpackednessPragma =+  UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness++-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.+addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)+addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do+    let l' = combineSrcSpans lprag (getLocA ty)+    cs <- getCommentsFor l'+    let an = EpAnn (spanAsAnchor l') anns cs+        t' = addUnpackedness an ty+    return (L (noAnnSrcSpan l') t')+  where+    -- If we have a HsBangTy that only has a strictness annotation,+    -- such as ~T or !T, then add the pragma to the existing HsBangTy.+    --+    -- Otherwise, wrap the type in a new HsBangTy constructor.+    addUnpackedness an (L _ (HsBangTy x bang t))+      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang+      = HsBangTy (addAnns an (epAnnAnns x) (epAnnComments x)) (HsSrcBang prag unpk strictness) t+    addUnpackedness an t+      = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t++---------------------------------------------------------------------------+-- | Check for monad comprehensions+--+-- If the flag MonadComprehensions is set, return a 'MonadComp' context,+-- otherwise use the usual 'ListComp' context++checkMonadComp :: PV (HsStmtContext GhcRn)+checkMonadComp = do+    monadComprehensions <- getBit MonadComprehensionsBit+    return $ if monadComprehensions+                then MonadComp+                else ListComp++-- -------------------------------------------------------------------------+-- Expression/command/pattern ambiguity.+-- See Note [Ambiguous syntactic categories]+--++-- See Note [Ambiguous syntactic categories]+--+-- This newtype is required to avoid impredicative types in monadic+-- productions. That is, in a production that looks like+--+--    | ... {% return (ECP ...) }+--+-- we are dealing with+--    P ECP+-- whereas without a newtype we would be dealing with+--    P (forall b. DisambECP b => PV (Located b))+--+newtype ECP =+  ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) }++ecpFromExp :: LHsExpr GhcPs -> ECP+ecpFromExp a = ECP (ecpFromExp' a)++ecpFromCmd :: LHsCmd GhcPs -> ECP+ecpFromCmd a = ECP (ecpFromCmd' a)++-- The 'fbinds' parser rule produces values of this type. See Note+-- [RecordDotSyntax field updates].+type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))++-- | Disambiguate infix operators.+-- See Note [Ambiguous syntactic categories]+class DisambInfixOp b where+  mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)+  mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)+  mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)++instance DisambInfixOp (HsExpr GhcPs) where+  mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)+  mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)+  mkHsInfixHolePV l ann = do+    cs <- getCommentsFor l+    return $ L l (hsHoleExpr (ann cs))++instance DisambInfixOp RdrName where+  mkHsConOpPV (L l v) = return $ L l v+  mkHsVarOpPV (L l v) = return $ L l v+  mkHsInfixHolePV l _ = addFatalError $ PsError PsErrInvalidInfixHole [] l++type AnnoBody b+  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpan+    , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL+    , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA+    , Anno [LocatedA (StmtLR GhcPs GhcPs+                       (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL+    )++-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are+-- parsing an expression, a command, or a pattern.+-- See Note [Ambiguous syntactic categories]+class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where+  -- | See Note [Body in DisambECP]+  type Body b :: Type -> Type+  -- | Return a command without ambiguity, or fail in a non-command context.+  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)+  -- | Return an expression without ambiguity, or fail in a non-expression context.+  ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)+  mkHsProjUpdatePV :: SrcSpan -> Located [Located (HsFieldLabel GhcPs)]+    -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))+  -- | Disambiguate "\... -> ..." (lambda)+  mkHsLamPV+    :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)+  -- | Disambiguate "let ... in ..."+  mkHsLetPV+    :: SrcSpan -> HsLocalBinds GhcPs -> LocatedA b -> AnnsLet -> PV (LocatedA b)+  -- | Infix operator representation+  type InfixOp b+  -- | Bring superclass constraints on InfixOp into scope.+  -- See Note [UndecidableSuperClasses for associated types]+  superInfixOp+    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)+  -- | Disambiguate "f # x" (infix operator)+  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b+              -> PV (LocatedA b)+  -- | Disambiguate "case ... of ..."+  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])+             -> EpAnnHsCase -> PV (LocatedA b)+  mkHsLamCasePV :: SrcSpan -> (LocatedL [LMatch GhcPs (LocatedA b)])+                -> [AddEpAnn]+                -> PV (LocatedA b)+  -- | Function argument representation+  type FunArg b+  -- | Bring superclass constraints on FunArg into scope.+  -- See Note [UndecidableSuperClasses for associated types]+  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)+  -- | Disambiguate "f x" (function application)+  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)+  -- | Disambiguate "f @t" (visible type application)+  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate "if ... then ... else ..."+  mkHsIfPV :: SrcSpan+         -> LHsExpr GhcPs+         -> Bool  -- semicolon?+         -> LocatedA b+         -> Bool  -- semicolon?+         -> LocatedA b+         -> AnnsIf+         -> PV (LocatedA b)+  -- | Disambiguate "do { ... }" (do notation)+  mkHsDoPV ::+    SrcSpan ->+    Maybe ModuleName ->+    LocatedL [LStmt GhcPs (LocatedA b)] ->+    AnnList ->+    PV (LocatedA b)+  -- | Disambiguate "( ... )" (parentheses)+  mkHsParPV :: SrcSpan -> LocatedA b -> AnnParen -> PV (LocatedA b)+  -- | Disambiguate a variable "f" or a data constructor "MkF".+  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)+  -- | Disambiguate a monomorphic literal+  mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)+  -- | Disambiguate an overloaded literal+  mkHsOverLitPV :: Located (HsOverLit GhcPs) -> PV (Located b)+  -- | Disambiguate a wildcard+  mkHsWildCardPV :: SrcSpan -> PV (Located b)+  -- | Disambiguate "a :: t" (type annotation)+  mkHsTySigPV+    :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "[a,b,c]" (list syntax)+  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)+  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)+  mkHsSplicePV :: Located (HsSplice GhcPs) -> PV (Located b)+  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)+  mkHsRecordPV ::+    Bool -> -- Is OverloadedRecordUpdate in effect?+    SrcSpan ->+    SrcSpan ->+    LocatedA b ->+    ([Fbind b], Maybe SrcSpan) ->+    [AddEpAnn] ->+    PV (LocatedA b)+  -- | Disambiguate "-a" (negation)+  mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "(# a)" (right operator section)+  mkHsSectionR_PV+    :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b)+  -- | Disambiguate "(a -> b)" (view pattern)+  mkHsViewPatPV+    :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "a@b" (as-pattern)+  mkHsAsPatPV+    :: SrcSpan -> LocatedN RdrName -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "~a" (lazy pattern)+  mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "!a" (bang pattern)+  mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate tuple sections and unboxed sums+  mkSumOrTuplePV+    :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas+  rejectPragmaPV :: LocatedA b -> PV ()++{- Note [UndecidableSuperClasses for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This Note is about the code in GHC, not about the user code that we are parsing)++Assume we have a class C with an associated type T:++  class C a where+    type T a+    ...++If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:++  {-# LANGUAGE UndecidableSuperClasses #-}+  class C (T a) => C a where+    type T a+    ...++Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes+making GHC loop. The workaround is to bring this constraint into scope+manually with a helper method:++  class C a where+    type T a+    superT :: (C (T a) => r) -> r++In order to avoid ambiguous types, 'r' must mention 'a'.++For consistency, we use this approach for all constraints on associated types,+even when -XUndecidableSuperClasses are not required.+-}++{- Note [Body in DisambECP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that+require their argument to take a form of (body GhcPs) for some (body :: Type ->+*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the+superclass constraints of DisambECP.++The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop+this requirement. It is possible and would allow removing the type index of+PatBuilder, but leads to worse type inference, breaking some code in the+typechecker.+-}++instance DisambECP (HsCmd GhcPs) where+  type Body (HsCmd GhcPs) = HsCmd+  ecpFromCmd' = return+  ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+  mkHsLamPV l mg = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))+  mkHsLetPV l bs e anns = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) anns cs) bs e)+  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs+  superInfixOp m = m+  mkHsOpAppPV l c1 op c2 = do+    let cmdArg c = L (getLocA c) $ HsCmdTop noExtField c+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]+  mkHsCasePV l c (L lm m) anns = do+    cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)+  mkHsLamCasePV l (L lm m) anns = do+    cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) mg)+  type FunArg (HsCmd GhcPs) = HsExpr GhcPs+  superFunArg m = m+  mkHsAppPV l c e = do+    cs <- getCommentsFor (locA l)+    checkCmdBlockArguments c+    checkExpBlockArguments e+    return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e)+  mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)+  mkHsIfPV l c semi1 a semi2 b anns = do+    checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (EpAnn (spanAsAnchor l) anns cs))+  mkHsDoPV l Nothing stmts anns = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)+  mkHsDoPV l (Just m)    _ _ = addFatalError $ PsError (PsErrQualifiedDoInCmd m) [] l+  mkHsParPV l c ann = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) ann cs) c)+  mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)+  mkHsLitPV (L l a) = cmdFail l (ppr a)+  mkHsOverLitPV (L l a) = cmdFail l (ppr a)+  mkHsWildCardPV l = cmdFail l (text "_")+  mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)+  mkHsExplicitListPV l xs _ = cmdFail l $+    brackets (fsep (punctuate comma (map ppr xs)))+  mkHsSplicePV (L l sp) = cmdFail l (ppr sp)+  mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do+    let (fs, ps) = partitionEithers fbinds+    if not (null ps)+      then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+      else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)+  mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)+  mkHsSectionR_PV l op c = cmdFail l $+    let pp_op = fromMaybe (panic "cannot print infix operator")+                          (ppr_infix_expr (unLoc op))+    in pp_op <> ppr c+  mkHsViewPatPV l a b _ = cmdFail l $+    ppr a <+> text "->" <+> ppr b+  mkHsAsPatPV l v c _ = cmdFail l $+    pprPrefixOcc (unLoc v) <> text "@" <> ppr c+  mkHsLazyPatPV l c _ = cmdFail l $+    text "~" <> ppr c+  mkHsBangPatPV l c _ = cmdFail l $+    text "!" <> ppr c+  mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)+  rejectPragmaPV _ = return ()++cmdFail :: SrcSpan -> SDoc -> PV a+cmdFail loc e = addFatalError $ PsError (PsErrParseErrorInCmd e) [] loc++instance DisambECP (HsExpr GhcPs) where+  type Body (HsExpr GhcPs) = HsExpr+  ecpFromCmd' (L l c) = do+    addError $ PsError (PsErrArrowCmdInExpr c) [] (locA l)+    return (L l (hsHoleExpr noAnn))+  ecpFromExp' = return+  mkHsProjUpdatePV l fields arg isPun anns = do+    cs <- getCommentsFor l+    return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)+  mkHsLamPV l mg = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsLam NoExtField (mg cs))+  mkHsLetPV l bs c anns = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) anns cs) bs c)+  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs+  superInfixOp m = m+  mkHsOpAppPV l e1 op e2 = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2+  mkHsCasePV l e (L lm m) anns = do+    cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)+  mkHsLamCasePV l (L lm m) anns = do+    cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) mg)+  type FunArg (HsExpr GhcPs) = HsExpr GhcPs+  superFunArg m = m+  mkHsAppPV l e1 e2 = do+    cs <- getCommentsFor (locA l)+    checkExpBlockArguments e1+    checkExpBlockArguments e2+    return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2)+  mkHsAppTypePV l e la t = do+    checkExpBlockArguments e+    return $ L l (HsAppType la e (mkHsWildCardBndrs t))+  mkHsIfPV l c semi1 a semi2 b anns = do+    checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (mkHsIf c a b (EpAnn (spanAsAnchor l) anns cs))+  mkHsDoPV l mod stmts anns = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts)+  mkHsParPV l e ann = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) ann cs) e)+  mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)+  mkHsLitPV (L l a) = do+    cs <- getCommentsFor l+    return $ L l (HsLit (comment (realSrcSpan l) cs) a)+  mkHsOverLitPV (L l a) = do+    cs <- getCommentsFor l+    return $ L l (HsOverLit (comment (realSrcSpan l) cs) a)+  mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn)+  mkHsTySigPV l a sig anns = do+    cs <- getCommentsFor (locA l)+    return $ L l (ExprWithTySig (EpAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig))+  mkHsExplicitListPV l xs anns = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs)+  mkHsSplicePV sp@(L l _) = do+    cs <- getCommentsFor l+    return $ mapLoc (HsSpliceE (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp+  mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do+    cs <- getCommentsFor l+    r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs)+    checkRecordSyntax (L (noAnnSrcSpan l) r)+  mkHsNegAppPV l a anns = do+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr)+  mkHsSectionR_PV l op e = do+    cs <- getCommentsFor l+    return $ L l (SectionR (comment (realSrcSpan l) cs) op e)+  mkHsViewPatPV l a b _ = addError (PsError (PsErrViewPatInExpr a b) [] l)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkHsAsPatPV l v e   _ = addError (PsError (PsErrTypeAppWithoutSpace (unLoc v) e) [] l)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkHsLazyPatPV l e   _ = addError (PsError (PsErrLazyPatWithoutSpace e) [] l)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkHsBangPatPV l e   _ = addError (PsError (PsErrBangPatWithoutSpace e) [] l)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkSumOrTuplePV = mkSumOrTupleExpr+  rejectPragmaPV (L _ (OpApp _ _ _ e)) =+    -- assuming left-associative parsing of operators+    rejectPragmaPV e+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ PsError (PsErrUnallowedPragma prag) [] (locA l)+  rejectPragmaPV _                        = return ()++hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs+hsHoleExpr anns = HsUnboundVar anns (mkVarOcc "_")++type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpan+type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL+type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA+type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs))) = SrcSpanAnnA++instance DisambECP (PatBuilder GhcPs) where+  type Body (PatBuilder GhcPs) = PatBuilder+  ecpFromCmd' (L l c)    = addFatalError $ PsError (PsErrArrowCmdInPat c) [] (locA l)+  ecpFromExp' (L l e)    = addFatalError $ PsError (PsErrArrowExprInPat e) [] (locA l)+  mkHsLamPV l _          = addFatalError $ PsError PsErrLambdaInPat [] l+  mkHsLetPV l _ _ _      = addFatalError $ PsError PsErrLetInPat [] l+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+  type InfixOp (PatBuilder GhcPs) = RdrName+  superInfixOp m = m+  mkHsOpAppPV l p1 op p2 = do+    cs <- getCommentsFor l+    let anns = EpAnn (spanAsAnchor l) [] cs+    return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns+  mkHsCasePV l _ _ _     = addFatalError $ PsError PsErrCaseInPat [] l+  mkHsLamCasePV l _ _    = addFatalError $ PsError PsErrLambdaCaseInPat [] l+  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs+  superFunArg m = m+  mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)+  mkHsAppTypePV l p la t = do+    cs <- getCommentsFor (locA l)+    let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs+    return $ L l (PatBuilderAppType p (mkHsPatSigType anns t))+  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l+  mkHsDoPV l _ _ _       = addFatalError $ PsError PsErrDoNotationInPat [] l+  mkHsParPV l p an       = return $ L (noAnnSrcSpan l) (PatBuilderPar p an)+  mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)+  mkHsLitPV lit@(L l a) = do+    checkUnboxedStringLitPat lit+    return $ L l (PatBuilderPat (LitPat noExtField a))+  mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)+  mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))+  mkHsTySigPV l b sig anns = do+    p <- checkLPat b+    cs <- getCommentsFor (locA l)+    return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig)))+  mkHsExplicitListPV l xs anns = do+    ps <- traverse checkLPat xs+    cs <- getCommentsFor l+    return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps)))+  mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))+  mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do+    let (fs, ps) = partitionEithers fbinds+    if not (null ps)+     then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] l+     else do+       cs <- getCommentsFor l+       r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)+       checkRecordSyntax (L (noAnnSrcSpan l) r)+  mkHsNegAppPV l (L lp p) anns = do+    lit <- case p of+      PatBuilderOverLit pos_lit -> return (L (locA lp) pos_lit)+      _ -> patFail l (text "-" <> ppr p)+    cs <- getCommentsFor l+    let an = EpAnn (spanAsAnchor l) anns cs+    return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))+  mkHsSectionR_PV l op p = patFail l (pprInfixOcc (unLoc op) <> ppr p)+  mkHsViewPatPV l a b anns = do+    p <- checkLPat b+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p))+  mkHsAsPatPV l v e a = do+    p <- checkLPat e+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) a cs) v p))+  mkHsLazyPatPV l e a = do+    p <- checkLPat e+    cs <- getCommentsFor l+    return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (EpAnn (spanAsAnchor l) a cs) p))+  mkHsBangPatPV l e an = do+    p <- checkLPat e+    cs <- getCommentsFor l+    let pb = BangPat (EpAnn (spanAsAnchor l) an cs) p+    hintBangPat l pb+    return $ L (noAnnSrcSpan l) (PatBuilderPat pb)+  mkSumOrTuplePV = mkSumOrTuplePat+  rejectPragmaPV _ = return ()++checkUnboxedStringLitPat :: Located (HsLit GhcPs) -> PV ()+checkUnboxedStringLitPat (L loc lit) =+  case lit of+    HsStringPrim _ _  -- Trac #13260+      -> addFatalError $ PsError (PsErrIllegalUnboxedStringInPat lit) [] loc+    _ -> return ()++mkPatRec ::+  LocatedA (PatBuilder GhcPs) ->+  HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->+  EpAnn [AddEpAnn] ->+  PV (PatBuilder GhcPs)+mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns+  | isRdrDataCon (unLoc c)+  = do fs <- mapM checkPatField fs+       return $ PatBuilderPat $ ConPat+         { pat_con_ext = anns+         , pat_con = c+         , pat_args = RecCon (HsRecFields fs dd)+         }+mkPatRec p _ _ =+  addFatalError $ PsError (PsErrInvalidRecordCon (unLoc p)) [] (getLocA p)++-- | Disambiguate constructs that may appear when we do not know+-- ahead of time whether we are parsing a type or a newtype/data constructor.+--+-- See Note [Ambiguous syntactic categories] for the general idea.+--+-- See Note [Parsing data constructors is hard] for the specific issue this+-- particular class is solving.+--+class DisambTD b where+  -- | Process the head of a type-level function/constructor application,+  -- i.e. the @H@ in @H a b c@.+  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f x@ (function application or prefix data constructor).+  mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f \@t@ (visible kind application)+  mkHsAppKindTyPV :: LocatedA b -> SrcSpan -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f \# x@ (infix operator)+  mkHsOpTyPV :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)+  mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)++instance DisambTD (HsType GhcPs) where+  mkHsAppTyHeadPV = return+  mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)+  mkHsAppKindTyPV t l_at ki = return (mkHsAppKindTy l_at t ki)+  mkHsOpTyPV t1 op t2 = return (mkLHsOpTy t1 op t2)+  mkUnpackednessPV = addUnpackednessP++dataConBuilderCon :: DataConBuilder -> LocatedN RdrName+dataConBuilderCon (PrefixDataConBuilder _ dc) = dc+dataConBuilderCon (InfixDataConBuilder _ dc _) = dc++dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs++-- Detect when the record syntax is used:+--   data T = MkT { ... }+dataConBuilderDetails (PrefixDataConBuilder flds _)+  | [L l_t (HsRecTy an fields)] <- toList flds+  = RecCon (L (SrcSpanAnn an (locA l_t)) fields)++-- Normal prefix constructor, e.g.  data T = MkT A B C+dataConBuilderDetails (PrefixDataConBuilder flds _)+  = PrefixCon noTypeArgs (map hsLinear (toList flds))++-- Infix constructor, e.g. data T = Int :! Bool+dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)+  = InfixCon (hsLinear lhs) (hsLinear rhs)++instance DisambTD DataConBuilder where+  mkHsAppTyHeadPV = tyToDataConBuilder++  mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =+    return $+      L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))+        (PrefixDataConBuilder (flds `snocOL` t) fn)+  mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =+    -- This case is impossible because of the way+    -- the grammar in Parser.y is written (see infixtype/ftype).+    panic "mkHsAppTyPV: InfixDataConBuilder"++  mkHsAppKindTyPV lhs l_at ki =+    addFatalError $ PsError (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki)) [] l_at++  mkHsOpTyPV lhs tc rhs = do+      check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative+      data_con <- eitherToP $ tyConToDataCon tc+      return $ L l (InfixDataConBuilder lhs data_con rhs)+    where+      l = combineLocsA lhs rhs+      check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)+      check_no_ops (HsOpTy{}) =+        addError $ PsError (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs)) [] (locA l)+      check_no_ops _ = return ()++  mkUnpackednessPV unpk constr_stuff+    | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff+    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool+      --   we apply {-# UNPACK #-} to the LHS+      do lhs' <- addUnpackednessP unpk lhs+         let l = combineLocsA (reLocA unpk) constr_stuff+         return $ L l (InfixDataConBuilder lhs' data_con rhs)+    | otherwise =+      do addError $ PsError PsErrUnpackDataCon [] (getLoc unpk)+         return constr_stuff++tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)+tyToDataConBuilder (L l (HsTyVar _ NotPromoted v)) = do+  data_con <- eitherToP $ tyConToDataCon v+  return $ L l (PrefixDataConBuilder nilOL data_con)+tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do+  let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))+  return $ L l (PrefixDataConBuilder (toOL ts) data_con)+tyToDataConBuilder t =+  addFatalError $ PsError (PsErrInvalidDataCon (unLoc t)) [] (getLocA t)++{- Note [Ambiguous syntactic categories]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are places in the grammar where we do not know whether we are parsing an+expression or a pattern without unlimited lookahead (which we do not have in+'happy'):++View patterns:++    f (Con a b     ) = ...  -- 'Con a b' is a pattern+    f (Con a b -> x) = ...  -- 'Con a b' is an expression++do-notation:++    do { Con a b <- x } -- 'Con a b' is a pattern+    do { Con a b }      -- 'Con a b' is an expression++Guards:++    x | True <- p && q = ...  -- 'True' is a pattern+    x | True           = ...  -- 'True' is an expression++Top-level value/function declarations (FunBind/PatBind):++    f ! a         -- TH splice+    f ! a = ...   -- function declaration++    Until we encounter the = sign, we don't know if it's a top-level+    TemplateHaskell splice where ! is used, or if it's a function declaration+    where ! is bound.++There are also places in the grammar where we do not know whether we are+parsing an expression or a command:++    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression+    proc x -> do { (stuff) }        -- 'stuff' is a command++    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'+    as an expression or a command.++In fact, do-notation is subject to both ambiguities:++    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression+    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern+    proc x -> do { (stuff) }             -- 'stuff' is a command++There are many possible solutions to this problem. For an overview of the ones+we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]++The solution that keeps basic definitions (such as HsExpr) clean, keeps the+concerns local to the parser, and does not require duplication of hsSyn types,+or an extra pass over the entire AST, is to parse into an overloaded+parser-validator (a so-called tagless final encoding):++    class DisambECP b where ...+    instance DisambECP (HsCmd GhcPs) where ...+    instance DisambECP (HsExp GhcPs) where ...+    instance DisambECP (PatBuilder GhcPs) where ...++The 'DisambECP' class contains functions to build and validate 'b'. For example,+to add parentheses we have:++  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)++'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for+expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,+see Note [PatBuilder]).++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr GhcPs, and it becomes:++  alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Compared to the initial definition, the added bits are:++    forall b. DisambECP b => PV ( ... ) -- in the type signature+    $1 >>= \ $1 -> return $             -- in one reduction rule+    $2 >>= \ $2 -> return $             -- in another reduction rule++The overhead is constant relative to the size of the rest of the reduction+rule, so this approach scales well to large parser productions.++Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding+position and shadows the previous $1. We can do this because internally+'happy' desugars $n to happy_var_n, and the rationale behind this idiom+is to be able to write (sLL $1 $>) later on. The alternative would be to+write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer+to the last fresh name as $>.++Finally, we instantiate the polymorphic type to a concrete one, and run the+parser-validator, for example:++    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }+    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }+            : stmt {% runPV $1 }++In e_stmt, three things happen:++  1. we instantiate: b ~ HsExpr GhcPs+  2. we embed the PV computation into P by using runPV+  3. we run validation by using a monadic production, {% ... }++At this point the ambiguity is resolved.+-}+++{- Note [Resolving parsing ambiguities: non-taken alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Alternative I, extra constructors in GHC.Hs.Expr+------------------------------------------------+We could add extra constructors to HsExpr to represent command-specific and+pattern-specific syntactic constructs. Under this scheme, we parse patterns+and commands as expressions and rejig later.  This is what GHC used to do, and+it polluted 'HsExpr' with irrelevant constructors:++  * for commands: 'HsArrForm', 'HsArrApp'+  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'++(As of now, we still do that for patterns, but we plan to fix it).++There are several issues with this:++  * The implementation details of parsing are leaking into hsSyn definitions.++  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.++  * HsExpr is arbitrarily selected as the extension basis. Why not extend+    HsCmd or HsPat with extra constructors instead?++Alternative II, extra constructors in GHC.Hs.Expr for GhcPs+-----------------------------------------------------------+We could address some of the problems with Alternative I by using Trees That+Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to+the output of parsing, not to its intermediate results, so we wouldn't want+them there either.++Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs+---------------------------------------------------------------+We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.+Unfortunately, creating a new pass would significantly bloat conversion code+and slow down the compiler by adding another linear-time pass over the entire+AST. For example, in order to build HsExpr GhcPrePs, we would need to build+HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds+GhcPrePs.+++Alternative IV, sum type and bottom-up data flow+------------------------------------------------+Expressions and commands are disjoint. There are no user inputs that could be+interpreted as either an expression or a command depending on outer context:++  5        -- definitely an expression+  x -< y   -- definitely a command++Even though we have both 'HsLam' and 'HsCmdLam', we can look at+the body to disambiguate:++  \p -> 5        -- definitely an expression+  \p -> x -< y   -- definitely a command++This means we could use a bottom-up flow of information to determine+whether we are parsing an expression or a command, using a sum type+for intermediate results:++  Either (LHsExpr GhcPs) (LHsCmd GhcPs)++There are two problems with this:++  * We cannot handle the ambiguity between expressions and+    patterns, which are not disjoint.++  * Bottom-up flow of information leads to poor error messages. Consider++        if ... then 5 else (x -< y)++    Do we report that '5' is not a valid command or that (x -< y) is not a+    valid expression?  It depends on whether we want the entire node to be+    'HsIf' or 'HsCmdIf', and this information flows top-down, from the+    surrounding parsing context (are we in 'proc'?)++Alternative V, backtracking with parser combinators+---------------------------------------------------+One might think we could sidestep the issue entirely by using a backtracking+parser and doing something along the lines of (try pExpr <|> pPat).++Turns out, this wouldn't work very well, as there can be patterns inside+expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns+(e.g. view patterns). To handle this, we would need to backtrack while+backtracking, and unbound levels of backtracking lead to very fragile+performance.++Alternative VI, an intermediate data type+-----------------------------------------+There are common syntactic elements of expressions, commands, and patterns+(e.g. all of them must have balanced parentheses), and we can capture this+common structure in an intermediate data type, Frame:++data Frame+  = FrameVar RdrName+    -- ^ Identifier: Just, map, BS.length+  | FrameTuple [LTupArgFrame] Boxity+    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)+  | FrameTySig LFrame (LHsSigWcType GhcPs)+    -- ^ Type signature: x :: ty+  | FramePar (SrcSpan, SrcSpan) LFrame+    -- ^ Parentheses+  | FrameIf LFrame LFrame LFrame+    -- ^ If-expression: if p then x else y+  | FrameCase LFrame [LFrameMatch]+    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }+  | FrameDo (HsStmtContext GhcRn) [LFrameStmt]+    -- ^ Do-expression: do { s1; a <- s2; s3 }+  ...+  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression+  | FramePat (HsPat GhcPs)     -- unambiguously a pattern+  | FrameCommand (HsCmd GhcPs) -- unambiguously a command++To determine which constructors 'Frame' needs to have, we take the union of+intersections between HsExpr, HsCmd, and HsPat.++The intersection between HsPat and HsExpr:++  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...+  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...+  -------------------------------------------------------------------+  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...++The intersection between HsCmd and HsExpr:++  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar+  HsExpr = HsIf    | HsCase    | HsDo    | HsPar+  ------------------------------------------------+  Frame = FrameIf  | FrameCase | FrameDo | FramePar++The intersection between HsCmd and HsPat:++  HsPat  = ParPat   | ...+  HsCmd  = HsCmdPar | ...+  -----------------------+  Frame  = FramePar | ...++Take the union of each intersection and this yields the final 'Frame' data+type. The problem with this approach is that we end up duplicating a good+portion of hsSyn:++    Frame         for  HsExpr, HsPat, HsCmd+    TupArgFrame   for  HsTupArg+    FrameMatch    for  Match+    FrameStmt     for  StmtLR+    FrameGRHS     for  GRHS+    FrameGRHSs    for  GRHSs+    ...++Alternative VII, a product type+-------------------------------+We could avoid the intermediate representation of Alternative VI by parsing+into a product of interpretations directly:++    type ExpCmdPat = ( PV (LHsExpr GhcPs)+                     , PV (LHsCmd GhcPs)+                     , PV (LHsPat GhcPs) )++This means that in positions where we do not know whether to produce+expression, a pattern, or a command, we instead produce a parser-validator for+each possible option.++Then, as soon as we have parsed far enough to resolve the ambiguity, we pick+the appropriate component of the product, discarding the rest:++    checkExpOf3 (e, _, _) = e  -- interpret as an expression+    checkCmdOf3 (_, c, _) = c  -- interpret as a command+    checkPatOf3 (_, _, p) = p  -- interpret as a pattern++We can easily define ambiguities between arbitrary subsets of interpretations.+For example, when we know ahead of type that only an expression or a command is+possible, but not a pattern, we can use a smaller type:++    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))++    checkExpOf2 (e, _) = e  -- interpret as an expression+    checkCmdOf2 (_, c) = c  -- interpret as a command++However, there is a slight problem with this approach, namely code duplication+in parser productions. Consider the 'alts' production used to parse case-of+alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Under the new scheme, we have to completely duplicate its type signature and+each reduction rule:++  alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression+            , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command+            ) }+    : alts1+        { ( checkExpOf2 $1 >>= \ $1 ->+            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)+          , checkCmdOf2 $1 >>= \ $1 ->+            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)+          ) }+    | ';' alts+        { ( checkExpOf2 $2 >>= \ $2 ->+            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)+          , checkCmdOf2 $2 >>= \ $2 ->+            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)+          ) }++And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',+'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!++Alternative VIII, a function from a GADT+----------------------------------------+We could avoid code duplication of the Alternative VII by representing the product+as a function from a GADT:++    data ExpCmdG b where+      ExpG :: ExpCmdG HsExpr+      CmdG :: ExpCmdG HsCmd++    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))++    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)+    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)+    checkExp f = f ExpG  -- interpret as an expression+    checkCmd f = f CmdG  -- interpret as a command++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr, and it becomes:++  alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1+        { \tag -> $1 tag >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts+        { \tag -> $2 tag >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Note that 'ExpCmdG' is a singleton type, the value is completely+determined by the type:++  when (b~HsExpr),  tag = ExpG+  when (b~HsCmd),   tag = CmdG++This is a clear indication that we can use a class to pass this value behind+the scenes:++  class    ExpCmdI b      where expCmdG :: ExpCmdG b+  instance ExpCmdI HsExpr where expCmdG = ExpG+  instance ExpCmdI HsCmd  where expCmdG = CmdG++And now the 'alts' production is simplified, as we no longer need to+thread 'tag' explicitly:++  alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++This encoding works well enough, but introduces an extra GADT unlike the+tagless final encoding, and there's no need for this complexity.++-}++{- Note [PatBuilder]+~~~~~~~~~~~~~~~~~~~~+Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,+so we introduce the notion of a PatBuilder.++Consider a pattern like this:++  Con a b c++We parse arguments to "Con" one at a time in the  fexp aexp  parser production,+building the result with mkHsAppPV, so the intermediate forms are:++  1. Con+  2. Con a+  3. Con a b+  4. Con a b c++In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like+this (pseudocode):++  1. "Con"+  2. HsApp "Con" "a"+  3. HsApp (HsApp "Con" "a") "b"+  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"++Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have+instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for+the intermediate forms.++We also need an intermediate representation to postpone disambiguation between+FunBind and PatBind. Consider:++  a `Con` b = ...+  a `fun` b = ...++How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We+learn this by inspecting an intermediate representation in 'isFunLhs' and+seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate+representation capable of representing both a FunBind and a PatBind, so Pat is+insufficient.++PatBuilder is an extension of Pat that is capable of representing intermediate+parsing results for patterns and function bindings:++  data PatBuilder p+    = PatBuilderPat (Pat p)+    | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))+    | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))+    ...++It can represent any pattern via 'PatBuilderPat', but it also has a variety of+other constructors which were added by following a simple principle: we never+pattern match on the pattern stored inside 'PatBuilderPat'.+-}++---------------------------------------------------------------------------+-- Miscellaneous utilities++-- | Check if a fixity is valid. We support bypassing the usual bound checks+-- for some special operators.+checkPrecP+        :: Located (SourceText,Int)              -- ^ precedence+        -> Located (OrdList (LocatedN RdrName))  -- ^ operators+        -> P ()+checkPrecP (L l (_,i)) (L _ ol)+ | 0 <= i, i <= maxPrecedence = pure ()+ | all specialOp ol = pure ()+ | otherwise = addFatalError $ PsError (PsErrPrecedenceOutOfRange i) [] l+  where+    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs+    specialOp op = unLoc op `elem` [ eqTyCon_RDR+                                   , getRdrName unrestrictedFunTyCon ]++mkRecConstrOrUpdate+        :: Bool+        -> LHsExpr GhcPs+        -> SrcSpan+        -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)+        -> EpAnn [AddEpAnn]+        -> PV (HsExpr GhcPs)+mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns+  | isRdrDataCon c+  = do+      let (fs, ps) = partitionEithers fbinds+      if not (null ps)+        then addFatalError $ PsError PsErrOverloadedRecordDotInvalid [] (getLocA (head ps))+        else return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)+mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns+  | Just dd_loc <- dd = addFatalError $ PsError PsErrDotsInRecordUpdate [] dd_loc+  | otherwise = mkRdrRecordUpd overloaded_update exp fs anns++mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)+mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do+  -- We do not need to know if OverloadedRecordDot is in effect. We do+  -- however need to know if OverloadedRecordUpdate (passed in+  -- overloaded_on) is in effect because it affects the Left/Right nature+  -- of the RecordUpd value we calculate.+  let (fs, ps) = partitionEithers fbinds+      fs' = map (fmap mk_rec_upd_field) fs+  case overloaded_on of+    False | not $ null ps ->+      -- A '.' was found in an update and OverloadedRecordUpdate isn't on.+      addFatalError $ PsError PsErrOverloadedRecordUpdateNotEnabled [] (locA loc)+    False ->+      -- This is just a regular record update.+      return RecordUpd {+        rupd_ext = anns+      , rupd_expr = exp+      , rupd_flds = Left fs' }+    True -> do+      let qualifiedFields =+            [ L l lbl | L _ (HsRecField _ (L l lbl) _ _) <- fs'+                      , isQual . rdrNameAmbiguousFieldOcc $ lbl+            ]+      if not $ null qualifiedFields+        then+          addFatalError $ PsError PsErrOverloadedRecordUpdateNoQualifiedFields [] (getLoc (head qualifiedFields))+        else -- This is a RecordDotSyntax update.+          return RecordUpd {+            rupd_ext = anns+           , rupd_expr = exp+           , rupd_flds = Right (toProjUpdates fbinds) }+  where+    toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]+    toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })++    -- Convert a top-level field update like {foo=2} or {bar} (punned)+    -- to a projection update.+    recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs+    recFieldToProjUpdate (L l (HsRecField anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =+        -- The idea here is to convert the label to a singleton [FastString].+        let f = occNameFS . rdrNameOcc $ rdr+            fl = HsFieldLabel noAnn (L lf f) -- AZ: what about the ann?+            lf = locA loc+        in mkRdrProjUpdate l (L lf [L lf fl]) (punnedVar f) pun anns+        where+          -- If punning, compute HsVar "f" otherwise just arg. This+          -- has the effect that sentinel HsVar "pun-rhs" is replaced+          -- by HsVar "f" here, before the update is written to a+          -- setField expressions.+          punnedVar :: FastString -> LHsExpr GhcPs+          punnedVar f  = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f++mkRdrRecordCon+  :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs+mkRdrRecordCon con flds anns+  = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds }++mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg+mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }+mk_rec_fields fs (Just s)  = HsRecFields { rec_flds = fs+                                     , rec_dotdot = Just (L s (length fs)) }++mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs+mk_rec_upd_field (HsRecField noAnn (L loc (FieldOcc _ rdr)) arg pun)+  = HsRecField noAnn (L loc (Unambiguous noExtField rdr)) arg pun++mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation+               -> InlinePragma+-- The (Maybe Activation) is because the user can omit+-- the activation spec (and usually does)+mkInlinePragma src (inl, match_info) mb_act+  = InlinePragma { inl_src = src -- Note [Pragma source text] in GHC.Types.SourceText+                 , inl_inline = inl+                 , inl_sat    = Nothing+                 , inl_act    = act+                 , inl_rule   = match_info }+  where+    act = case mb_act of+            Just act -> act+            Nothing  -> -- No phase specified+                        case inl of+                          NoInline -> NeverActive+                          _other   -> AlwaysActive++-----------------------------------------------------------------------------+-- utilities for foreign declarations++-- construct a foreign import declaration+--+mkImport :: Located CCallConv+         -> Located Safety+         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)+         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)+mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =+    case unLoc cconv of+      CCallConv          -> mkCImport+      CApiConv           -> mkCImport+      StdCallConv        -> mkCImport+      PrimCallConv       -> mkOtherImport+      JavaScriptCallConv -> mkOtherImport+  where+    -- Parse a C-like entity string of the following form:+    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"+    -- If 'cid' is missing, the function name 'v' is used instead as symbol+    -- name (cf section 8.5.1 in Haskell 2010 report).+    mkCImport = do+      let e = unpackFS entity+      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of+        Nothing         -> addFatalError $ PsError PsErrMalformedEntityString [] loc+        Just importSpec -> returnSpec importSpec++    -- currently, all the other import conventions only support a symbol name in+    -- the entity string. If it is missing, we use the function name instead.+    mkOtherImport = returnSpec importSpec+      where+        entity'    = if nullFS entity+                        then mkExtName (unLoc v)+                        else entity+        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)+        importSpec = CImport cconv safety Nothing funcTarget (L loc esrc)++    returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport+          { fd_i_ext  = ann+          , fd_name   = v+          , fd_sig_ty = ty+          , fd_fi     = spec+          }++++-- the string "foo" is ambiguous: either a header or a C identifier.  The+-- C identifier case comes first in the alternatives below, so we pick+-- that one.+parseCImport :: Located CCallConv -> Located Safety -> FastString -> String+             -> Located SourceText+             -> Maybe ForeignImport+parseCImport cconv safety nm str sourceText =+ listToMaybe $ map fst $ filter (null.snd) $+     readP_to_S parse str+ where+   parse = do+       skipSpaces+       r <- choice [+          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),+          string "wrapper" >> return (mk Nothing CWrapper),+          do optional (token "static" >> skipSpaces)+             ((mk Nothing <$> cimp nm) ++++              (do h <- munch1 hdr_char+                  skipSpaces+                  mk (Just (Header (SourceText h) (mkFastString h)))+                      <$> cimp nm))+         ]+       skipSpaces+       return r++   token str = do _ <- string str+                  toks <- look+                  case toks of+                      c : _+                       | id_char c -> pfail+                      _            -> return ()++   mk h n = CImport cconv safety h n sourceText++   hdr_char c = not (isSpace c)+   -- header files are filenames, which can contain+   -- pretty much any char (depending on the platform),+   -- so just accept any non-space character+   id_first_char c = isAlpha    c || c == '_'+   id_char       c = isAlphaNum c || c == '_'++   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)+             +++ (do isFun <- case unLoc cconv of+                               CApiConv ->+                                  option True+                                         (do token "value"+                                             skipSpaces+                                             return False)+                               _ -> return True+                     cid' <- cid+                     return (CFunction (StaticTarget NoSourceText cid'+                                        Nothing isFun)))+          where+            cid = return nm ++++                  (do c  <- satisfy id_first_char+                      cs <-  many (satisfy id_char)+                      return (mkFastString (c:cs)))+++-- construct a foreign export declaration+--+mkExport :: Located CCallConv+         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)+         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)+mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)+ = return $ \ann -> ForD noExtField $+   ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty+                 , fd_fe = CExport (L lc (CExportStatic esrc entity' cconv))+                                   (L le esrc) }+  where+    entity' | nullFS entity = mkExtName (unLoc v)+            | otherwise     = entity++-- Supplying the ext_name in a foreign decl is optional; if it+-- isn't there, the Haskell name is assumed. Note that no transformation+-- of the Haskell name is then performed, so if you foreign export (++),+-- it's external name will be "++". Too bad; it's important because we don't+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)+--+mkExtName :: RdrName -> CLabelString+mkExtName rdrNm = mkFastString (occNameString (rdrNameOcc rdrNm))++--------------------------------------------------------------------------------+-- Help with module system imports/exports++data ImpExpSubSpec = ImpExpAbs+                   | ImpExpAll+                   | ImpExpList [LocatedA ImpExpQcSpec]+                   | ImpExpAllWith [LocatedA ImpExpQcSpec]++data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)+                  | ImpExpQcType EpaLocation (LocatedN RdrName)+                  | ImpExpQcWildcard++mkModuleImpExp :: [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)+mkModuleImpExp anns (L l specname) subs = do+  cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments+  let ann = EpAnn (spanAsAnchor $ locA l) anns cs+  case subs of+    ImpExpAbs+      | isVarNameSpace (rdrNameSpace name)+                       -> return $ IEVar noExtField (L l (ieNameFromSpec specname))+      | otherwise      -> IEThingAbs ann . L l <$> nameT+    ImpExpAll          -> IEThingAll ann . L l <$> nameT+    ImpExpList xs      ->+      (\newName -> IEThingWith ann (L l newName)+        NoIEWildcard (wrapped xs)) <$> nameT+    ImpExpAllWith xs                       ->+      do allowed <- getBit PatternSynonymsBit+         if allowed+          then+            let withs = map unLoc xs+                pos   = maybe NoIEWildcard IEWildcard+                          (findIndex isImpExpQcWildcard withs)+                ies :: [LocatedA (IEWrappedName RdrName)]+                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs+            in (\newName+                        -> IEThingWith ann (L l newName) pos ies)+               <$> nameT+          else addFatalError $ PsError PsErrIllegalPatSynExport [] (locA l)+  where+    name = ieNameVal specname+    nameT =+      if isVarNameSpace (rdrNameSpace name)+        then addFatalError $ PsError (PsErrVarForTyCon name) [] (locA l)+        else return $ ieNameFromSpec specname++    ieNameVal (ImpExpQcName ln)   = unLoc ln+    ieNameVal (ImpExpQcType _ ln) = unLoc ln+    ieNameVal (ImpExpQcWildcard)  = panic "ieNameVal got wildcard"++    ieNameFromSpec (ImpExpQcName   ln) = IEName   ln+    ieNameFromSpec (ImpExpQcType r ln) = IEType r ln+    ieNameFromSpec (ImpExpQcWildcard)  = panic "ieName got wildcard"++    wrapped = map (mapLoc ieNameFromSpec)++mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space+             -> P (LocatedN RdrName)+mkTypeImpExp name =+  do allowed <- getBit ExplicitNamespacesBit+     unless allowed $ addError $ PsError PsErrIllegalExplicitNamespace [] (getLocA name)+     return (fmap (`setRdrNameSpace` tcClsName) name)++checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])+checkImportSpec ie@(L _ specs) =+    case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of+      [] -> return ie+      (l:_) -> importSpecError (locA l)+  where+    importSpecError l =+      addFatalError $ PsError PsErrIllegalImportBundleForm [] l++-- In the correct order+mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)+mkImpExpSubSpec [] = return ([], ImpExpList [])+mkImpExpSubSpec [L la ImpExpQcWildcard] =+  return ([AddEpAnn AnnDotdot (EpaSpan $ la2r la)], ImpExpAll)+mkImpExpSubSpec xs =+  if (any (isImpExpQcWildcard . unLoc) xs)+    then return $ ([], ImpExpAllWith xs)+    else return $ ([], ImpExpList xs)++isImpExpQcWildcard :: ImpExpQcSpec -> Bool+isImpExpQcWildcard ImpExpQcWildcard = True+isImpExpQcWildcard _                = False++-----------------------------------------------------------------------------+-- Warnings and failures++warnPrepositiveQualifiedModule :: SrcSpan -> P ()+warnPrepositiveQualifiedModule span =+  addWarning Opt_WarnPrepositiveQualifiedModule (PsWarnImportPreQualified span)++failOpNotEnabledImportQualifiedPost :: SrcSpan -> P ()+failOpNotEnabledImportQualifiedPost loc = addError $ PsError PsErrImportPostQualified [] loc++failOpImportQualifiedTwice :: SrcSpan -> P ()+failOpImportQualifiedTwice loc = addError $ PsError PsErrImportQualifiedTwice [] loc++warnStarIsType :: SrcSpan -> P ()+warnStarIsType span = addWarning Opt_WarnStarIsType (PsWarnStarIsType span)++failOpFewArgs :: MonadP m => LocatedN RdrName -> m a+failOpFewArgs (L loc op) =+  do { star_is_type <- getBit StarIsTypeBit+     ; addFatalError $ PsError (PsErrOpFewArgs (StarIsType star_is_type) op) [] (locA loc) }++-----------------------------------------------------------------------------+-- Misc utils++data PV_Context =+  PV_Context+    { pv_options :: ParserOpts+    , pv_hints   :: [Hint]  -- See Note [Parser-Validator Hint]+    }++data PV_Accum =+  PV_Accum+    { pv_warnings        :: Bag PsWarning+    , pv_errors          :: Bag PsError+    , pv_header_comments :: Maybe [LEpaComment]+    , pv_comment_q       :: [LEpaComment]+    }++data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum++-- During parsing, we make use of several monadic effects: reporting parse errors,+-- accumulating warnings, adding API annotations, and checking for extensions. These+-- effects are captured by the 'MonadP' type class.+--+-- Sometimes we need to postpone some of these effects to a later stage due to+-- ambiguities described in Note [Ambiguous syntactic categories].+-- We could use two layers of the P monad, one for each stage:+--+--   abParser :: forall x. DisambAB x => P (P x)+--+-- The outer layer of P consumes the input and builds the inner layer, which+-- validates the input. But this type is not particularly helpful, as it obscures+-- the fact that the inner layer of P never consumes any input.+--+-- For clarity, we introduce the notion of a parser-validator: a parser that does+-- not consume any input, but may fail or use other effects. Thus we have:+--+--   abParser :: forall x. DisambAB x => P (PV x)+--+newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }++instance Functor PV where+  fmap = liftM++instance Applicative PV where+  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)+  (<*>) = ap++instance Monad PV where+  m >>= f = PV $ \ctx acc ->+    case unPV m ctx acc of+      PV_Ok acc' a -> unPV (f a) ctx acc'+      PV_Failed acc' -> PV_Failed acc'++runPV :: PV a -> P a+runPV = runPV_hints []++runPV_hints :: [Hint] -> PV a -> P a+runPV_hints hints m =+  P $ \s ->+    let+      pv_ctx = PV_Context+        { pv_options = options s+        , pv_hints   = hints }+      pv_acc = PV_Accum+        { pv_warnings = warnings s+        , pv_errors   = errors s+        , pv_header_comments = header_comments s+        , pv_comment_q = comment_q s }+      mkPState acc' =+        s { warnings = pv_warnings acc'+          , errors   = pv_errors acc'+          , comment_q = pv_comment_q acc' }+    in+      case unPV m pv_ctx pv_acc of+        PV_Ok acc' a -> POk (mkPState acc') a+        PV_Failed acc' -> PFailed (mkPState acc')++add_hint :: Hint -> PV a -> PV a+add_hint hint m =+  let modifyHint ctx = ctx{pv_hints = pv_hints ctx ++ [hint]} in+  PV (\ctx acc -> unPV m (modifyHint ctx) acc)++instance MonadP PV where+  addError err@(PsError e hints loc) =+    PV $ \ctx acc ->+      let err' | null (pv_hints ctx) = err+               | otherwise           = PsError e (hints ++ pv_hints ctx) loc+      in PV_Ok acc{pv_errors = err' `consBag` pv_errors acc} ()+  addWarning option w =+    PV $ \ctx acc ->+      if warnopt option (pv_options ctx)+         then PV_Ok acc{pv_warnings= w `consBag` pv_warnings acc} ()+         else PV_Ok acc ()+  addFatalError err =+    addError err >> PV (const PV_Failed)+  getBit ext =+    PV $ \ctx acc ->+      let b = ext `xtest` pExtsBitmap (pv_options ctx) in+      PV_Ok acc $! b+  allocateCommentsP ss = PV $ \_ s ->+    let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in+      PV_Ok s {+         pv_comment_q = comment_q'+       } (EpaComments newAnns)+  allocatePriorCommentsP ss = PV $ \_ s ->+    let (header_comments', comment_q', newAnns)+          = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in+      PV_Ok s {+         pv_header_comments = header_comments',+         pv_comment_q = comment_q'+       } (EpaComments newAnns)+  allocateFinalCommentsP ss = PV $ \_ s ->+    let (header_comments', comment_q', newAnns)+          = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in+      PV_Ok s {+         pv_header_comments = header_comments',+         pv_comment_q = comment_q'+       } (EpaCommentsBalanced (fromMaybe [] header_comments') (reverse newAnns))++{- Note [Parser-Validator Hint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A PV computation is parametrized by a hint for error messages, which can be set+depending on validation context. We use this in checkPattern to fix #984.++Consider this example, where the user has forgotten a 'do':++  f _ = do+    x <- computation+    case () of+      _ ->+        result <- computation+        case () of () -> undefined++GHC parses it as follows:++  f _ = do+    x <- computation+    (case () of+      _ ->+        result) <- computation+        case () of () -> undefined++Note that this fragment is parsed as a pattern:++  case () of+    _ ->+      result++We attempt to detect such cases and add a hint to the error messages:++  T984.hs:6:9:+    Parse error in pattern: case () of { _ -> result }+    Possibly caused by a missing 'do'?++The "Possibly caused by a missing 'do'?" suggestion is the hint that is passed+as the 'pv_hints' field 'PV_Context'. When validating in a context other than+'bindpat' (a pattern to the left of <-), we set the hint to 'empty' and it has+no effect on the error messages.++-}++-- | Hint about bang patterns, assuming @BangPatterns@ is off.+hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()+hintBangPat span e = do+    bang_on <- getBit BangPatBit+    unless bang_on $+      addError $ PsError (PsErrIllegalBangPattern e) [] span++mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)+                 -> [AddEpAnn]+                 -> PV (LHsExpr GhcPs)++-- Tuple+mkSumOrTupleExpr l boxity (Tuple es) anns = do+    cs <- getCommentsFor (locA l)+    return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity)+  where+    toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs+    toTupArg (Left ann) = missingTupArg ann+    toTupArg (Right a)  = Present noAnn a++-- Sum+-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =+--     return $ L l (ExplicitSum noExtField alt arity e)+mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do+    let an = case anns of+               [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] ->+                 AnnExplicitSum o barsp barsa c+               _ -> panic "mkSumOrTupleExpr"+    cs <- getCommentsFor (locA l)+    return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e)+mkSumOrTupleExpr l Boxed a@Sum{} _ =+    addFatalError $ PsError (PsErrUnsupportedBoxedSumExpr a) [] (locA l)++mkSumOrTuplePat+  :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]+  -> PV (LocatedA (PatBuilder GhcPs))++-- Tuple+mkSumOrTuplePat l boxity (Tuple ps) anns = do+  ps' <- traverse toTupPat ps+  cs <- getCommentsFor (locA l)+  return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity))+  where+    toTupPat :: Either (EpAnn EpaLocation) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)+    -- Ignore the element location so that the error message refers to the+    -- entire tuple. See #19504 (and the discussion) for details.+    toTupPat p = case p of+      Left _ -> addFatalError $ PsError PsErrTupleSectionInPat [] (locA l)+      Right p' -> checkLPat p'++-- Sum+mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do+   p' <- checkLPat p+   cs <- getCommentsFor (locA l)+   let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs+   return $ L l (PatBuilderPat (SumPat an p' alt arity))+mkSumOrTuplePat l Boxed a@Sum{} _ =+    addFatalError $ PsError (PsErrUnsupportedBoxedSumPat a) [] (locA l)++mkLHsOpTy :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs+mkLHsOpTy x op y =+  let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y+  in L loc (mkHsOpTy x op y)++mkMultTy :: IsUnicodeSyntax -> Located Token -> LHsType GhcPs -> HsArrow GhcPs+mkMultTy u tok t@(L _ (HsTyLit _ (HsNumTy (SourceText "1") 1)))+  -- See #18888 for the use of (SourceText "1") above+  = HsLinearArrow u (Just $ AddEpAnn AnnPercentOne (EpaSpan $ realSrcSpan $ combineLocs tok (reLoc t)))+mkMultTy u tok t = HsExplicitMult u (Just $ AddEpAnn AnnPercent (EpaSpan $ realSrcSpan $ getLoc tok)) t++-----------------------------------------------------------------------------+-- Token symbols++starSym :: Bool -> String+starSym True = "★"+starSym False = "*"++-----------------------------------------+-- Bits and pieces for RecordDotSyntax.++mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> Located (HsFieldLabel GhcPs)+  -> EpAnnCO -> LHsExpr GhcPs+mkRdrGetField loc arg field anns =+  L loc HsGetField {+      gf_ext = anns+    , gf_expr = arg+    , gf_field = field+    }++mkRdrProjection :: NonEmpty (Located (HsFieldLabel GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs+mkRdrProjection flds anns =+  HsProjection {+      proj_ext = anns+    , proj_flds = flds+    }++mkRdrProjUpdate :: SrcSpanAnnA -> Located [Located (HsFieldLabel GhcPs)]+                -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn]+                -> LHsRecProj GhcPs (LHsExpr GhcPs)+mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"+mkRdrProjUpdate loc (L l flds) arg isPun anns =+  L loc HsRecField {+      hsRecFieldAnn = anns+    , hsRecFieldLbl = L l (FieldLabelStrings flds)+    , hsRecFieldArg = arg+    , hsRecPun = isPun+  }

GHC/Parser/PostProcess/Haddock.hs view

@@ -1,13 +1,13 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ApplicativeDo              #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE DerivingVia                #-}+{-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}  {- | This module implements 'addHaddockToModule', which inserts Haddock     comments accumulated during parsing into the AST (#17544).@@ -52,9 +52,10 @@ import GHC.Prelude hiding (mod)  import GHC.Hs+ import GHC.Types.SrcLoc-import GHC.Driver.Session ( WarningFlag(..) )-import GHC.Utils.Outputable hiding ( (<>) )+import GHC.Driver.Flags ( WarningFlag(..) )+import GHC.Utils.Panic import GHC.Data.Bag  import Data.Semigroup@@ -70,6 +71,7 @@ import qualified Data.Monoid  import GHC.Parser.Lexer+import GHC.Parser.Errors import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))  {- Note [Adding Haddock comments to the syntax tree]@@ -108,7 +110,7 @@ We search for comments after  HsTyVar "Int"  and until the next syntactic element, in this case  HsTyVar "Bool". -Ignoring the "->" allows us to accomodate alternative coding styles:+Ignoring the "->" allows us to accommodate alternative coding styles:    f :: Int ->   -- ^ comment on argument        Bool     -- ^ comment on result@@ -190,12 +192,9 @@  reportHdkWarning :: HdkWarn -> P () reportHdkWarning (HdkWarnInvalidComment (L l _)) =-  addWarning Opt_WarnInvalidHaddock (mkSrcSpanPs l) $-    text "A Haddock comment cannot appear in this position and will be ignored."+  addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockInvalidPos (mkSrcSpanPs l) reportHdkWarning (HdkWarnExtraComment (L l _)) =-  addWarning Opt_WarnInvalidHaddock l $-    text "Multiple Haddock comments for a single entity are not allowed." $$-    text "The extraneous comment will be ignored."+  addWarning Opt_WarnInvalidHaddock $ PsWarnHaddockIgnoreMulti l  collectHdkWarnings :: HdkSt -> [HdkWarn] collectHdkWarnings HdkSt{ hdk_st_pending, hdk_st_warnings } =@@ -250,10 +249,10 @@     -- Only do this when the module header exists.     headerDocs <-       for @Maybe (hsmodName mod) $ \(L l_name _) ->-      extendHdkA l_name $ liftHdkA $ do+      extendHdkA (locA l_name) $ liftHdkA $ do         -- todo: register keyword location of 'module', see Note [Register keyword location]         docs <--          inLocRange (locRangeTo (getBufPos (srcSpanStart l_name))) $+          inLocRange (locRangeTo (getBufPos (srcSpanStart (locA l_name)))) $           takeHdkComments mkDocNext         selectDocString docs @@ -301,15 +300,15 @@ --    import I (a, b, c)         -- do not use here! -- -- Imports cannot have documentation comments anyway.-instance HasHaddock (Located [LIE GhcPs]) where+instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where   addHaddock (L l_exports exports) =-    extendHdkA l_exports $ do+    extendHdkA (locA l_exports) $ do       exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports-      registerLocHdkA (srcLocSpan (srcSpanEnd l_exports)) -- Do not consume comments after the closing parenthesis+      registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis       pure $ L l_exports exports'  -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'.-instance HasHaddock (LIE GhcPs) where+instance HasHaddock (LocatedA (IE GhcPs)) where   addHaddock a = a <$ registerHdkA a  {- Add Haddock items to a list of non-Haddock items.@@ -386,10 +385,10 @@         let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }         in hoistHdkA (inLocRange loc_range) -instance HasHaddock (LHsDecl GhcPs) where+instance HasHaddock (LocatedA (HsDecl GhcPs)) where   addHaddock ldecl =-    extendHdkA (getLoc ldecl) $-    traverse @Located addHaddock ldecl+    extendHdkA (getLocA ldecl) $+    traverse @LocatedA addHaddock ldecl  -- Process documentation comments *inside* a declaration, for example: --@@ -422,10 +421,10 @@   --      :: Int  -- ^ Comment on Int   --      -> Bool -- ^ Comment on Bool   ---  addHaddock (SigD _ (TypeSig _ names t)) = do+  addHaddock (SigD _ (TypeSig x names t)) = do       traverse_ registerHdkA names       t' <- addHaddock t-      pure (SigD noExtField (TypeSig noExtField names t'))+      pure (SigD noExtField (TypeSig x names t'))    -- Pattern synonym type signatures:   --@@ -433,10 +432,10 @@   --      :: Bool       -- ^ Comment on Bool   --      -> Maybe Bool -- ^ Comment on Maybe Bool   ---  addHaddock (SigD _ (PatSynSig _ names t)) = do+  addHaddock (SigD _ (PatSynSig x names t)) = do     traverse_ registerHdkA names     t' <- addHaddock t-    pure (SigD noExtField (PatSynSig noExtField names t'))+    pure (SigD noExtField (PatSynSig x names t'))    -- Class method signatures and default signatures:   --@@ -449,10 +448,10 @@   --        => Maybe x -- ^ Comment on Maybe x   --        -> IO ()   -- ^ Comment on IO ()   ---  addHaddock (SigD _ (ClassOpSig _ is_dflt names t)) = do+  addHaddock (SigD _ (ClassOpSig x is_dflt names t)) = do     traverse_ registerHdkA names     t' <- addHaddock t-    pure (SigD noExtField (ClassOpSig noExtField is_dflt names t'))+    pure (SigD noExtField (ClassOpSig x is_dflt names t'))    -- Data/newtype declarations:   --@@ -470,14 +469,14 @@   --     deriving newtype (Eq  {- ^ Comment on Eq  N -})   --     deriving newtype (Ord {- ^ Comment on Ord N -})   ---  addHaddock (TyClD _ decl)-    | DataDecl { tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl+  addHaddock (TyClD x decl)+    | DataDecl { tcdDExt, tcdLName, tcdTyVars, tcdFixity, tcdDataDefn = defn } <- decl     = do         registerHdkA tcdLName         defn' <- addHaddock defn         pure $-          TyClD noExtField (DataDecl {-            tcdDExt = noExtField,+          TyClD x (DataDecl {+            tcdDExt,             tcdLName, tcdTyVars, tcdFixity,             tcdDataDefn = defn' }) @@ -490,7 +489,7 @@   --      -- ^ Comment on the second method   --   addHaddock (TyClD _ decl)-    | ClassDecl { tcdCExt = tcdLayout,+    | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout),                   tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,                   tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl     = do@@ -501,7 +500,7 @@           flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])         pure $           let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls'-              decl' = ClassDecl { tcdCExt = tcdLayout+              decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout)                                 , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs                                 , tcdSigs = tcdSigs'                                 , tcdMeths = tcdMeths'@@ -516,21 +515,20 @@   --    data instance D Bool = ...     (same as data/newtype declarations)   --   addHaddock (InstD _ decl)-    | DataFamInstD { dfid_inst } <- decl+    | DataFamInstD { dfid_ext, dfid_inst } <- decl     , DataFamInstDecl { dfid_eqn } <- dfid_inst     = do       dfid_eqn' <- case dfid_eqn of-        HsIB _ (FamEqn { feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs })+        FamEqn { feqn_ext, feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity, feqn_rhs }           -> do             registerHdkA feqn_tycon             feqn_rhs' <- addHaddock feqn_rhs-            pure $-              HsIB noExtField (FamEqn {-                feqn_ext = noExtField,+            pure $ FamEqn {+                feqn_ext,                 feqn_tycon, feqn_bndrs, feqn_pats, feqn_fixity,-                feqn_rhs = feqn_rhs' })+                feqn_rhs = feqn_rhs' }       pure $ InstD noExtField (DataFamInstD {-        dfid_ext = noExtField,+        dfid_ext,         dfid_inst = DataFamInstDecl { dfid_eqn = dfid_eqn' } })    -- Type synonyms:@@ -538,14 +536,14 @@   --    type T = Int -- ^ Comment on Int   --   addHaddock (TyClD _ decl)-    | SynDecl { tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl+    | SynDecl { tcdSExt, tcdLName, tcdTyVars, tcdFixity, tcdRhs } <- decl     = do         registerHdkA tcdLName         -- todo: register keyword location of '=', see Note [Register keyword location]         tcdRhs' <- addHaddock tcdRhs         pure $           TyClD noExtField (SynDecl {-            tcdSExt = noExtField,+            tcdSExt,             tcdLName, tcdTyVars, tcdFixity,             tcdRhs = tcdRhs' }) @@ -594,7 +592,7 @@  -- Process the deriving clauses of a data/newtype declaration. -- Not used for standalone deriving.-instance HasHaddock (HsDeriving GhcPs) where+instance HasHaddock (Located [Located (HsDerivingClause GhcPs)]) where   addHaddock lderivs =     extendHdkA (getLoc lderivs) $     traverse @Located addHaddock lderivs@@ -606,12 +604,12 @@ --    deriving (Ord {- ^ Comment on Ord N -}) via Down N -- -- Not used for standalone deriving.-instance HasHaddock (LHsDerivingClause GhcPs) where+instance HasHaddock (Located (HsDerivingClause GhcPs)) where   addHaddock lderiv =     extendHdkA (getLoc lderiv) $     for @Located lderiv $ \deriv ->     case deriv of-      HsDerivingClause { deriv_clause_strategy, deriv_clause_tys } -> do+      HsDerivingClause { deriv_clause_ext, deriv_clause_strategy, deriv_clause_tys } -> do         let           -- 'stock', 'anyclass', and 'newtype' strategies come           -- before the clause types.@@ -625,15 +623,34 @@               Just (L l (ViaStrategy _)) -> (pure (), registerLocHdkA l)               Just (L l _) -> (registerLocHdkA l, pure ())         register_strategy_before-        deriv_clause_tys' <--          extendHdkA (getLoc deriv_clause_tys) $-          traverse @Located addHaddock deriv_clause_tys+        deriv_clause_tys' <- addHaddock deriv_clause_tys         register_strategy_after         pure HsDerivingClause-          { deriv_clause_ext = noExtField,+          { deriv_clause_ext,             deriv_clause_strategy,             deriv_clause_tys = deriv_clause_tys' } +-- Process the types in a single deriving clause, which may come in one of the+-- following forms:+--+--    1. A singular type constructor:+--          deriving Eq -- ^ Comment on Eq+--+--    2. A list of comma-separated types surrounded by enclosing parentheses:+--          deriving ( Eq  -- ^ Comment on Eq+--                   , C a -- ^ Comment on C a+--                   )+instance HasHaddock (LocatedC (DerivClauseTys GhcPs)) where+  addHaddock (L l_dct dct) =+    extendHdkA (locA l_dct) $+    case dct of+      DctSingle x ty -> do+        ty' <- addHaddock ty+        pure $ L l_dct $ DctSingle x ty'+      DctMulti x tys -> do+        tys' <- addHaddock tys+        pure $ L l_dct $ DctMulti x tys'+ -- Process a single data constructor declaration, which may come in one of the -- following forms: --@@ -668,47 +685,46 @@ --                     bool_field :: Bool }  -- ^ Comment on bool_field --                -> T ---instance HasHaddock (LConDecl GhcPs) where+instance HasHaddock (LocatedA (ConDecl GhcPs)) where   addHaddock (L l_con_decl con_decl) =-    extendHdkA l_con_decl $+    extendHdkA (locA l_con_decl) $     case con_decl of-      ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do+      ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do         -- discardHasInnerDocs is ok because we don't need this info for GADTs.-        con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names))-        con_args' <--          case con_args of-            PrefixCon ts -> PrefixCon <$> addHaddock ts-            RecCon (L l_rec flds) -> do+        con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (head con_names))+        con_g_args' <-+          case con_g_args of+            PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts+            RecConGADT (L l_rec flds) -> do               -- discardHasInnerDocs is ok because we don't need this info for GADTs.               flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds-              pure $ RecCon (L l_rec flds')-            InfixCon _ _ -> panic "ConDeclGADT InfixCon"+              pure $ RecConGADT (L l_rec flds')         con_res_ty' <- addHaddock con_res_ty         pure $ L l_con_decl $-          ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt,+          ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt,                         con_doc = con_doc',-                        con_args = con_args',+                        con_g_args = con_g_args',                         con_res_ty = con_res_ty' }       ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->-        addConTrailingDoc (srcSpanEnd l_con_decl) $+        addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $         case con_args of-          PrefixCon ts -> do-            con_doc' <- getConDoc (getLoc con_name)+          PrefixCon _ ts -> do+            con_doc' <- getConDoc (getLocA con_name)             ts' <- traverse addHaddockConDeclFieldTy ts             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,                            con_doc = con_doc',-                           con_args = PrefixCon ts' }+                           con_args = PrefixCon noTypeArgs ts' }           InfixCon t1 t2 -> do             t1' <- addHaddockConDeclFieldTy t1-            con_doc' <- getConDoc (getLoc con_name)+            con_doc' <- getConDoc (getLocA con_name)             t2' <- addHaddockConDeclFieldTy t2             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,                            con_doc = con_doc',                            con_args = InfixCon t1' t2' }           RecCon (L l_rec flds) -> do-            con_doc' <- getConDoc (getLoc con_name)+            con_doc' <- getConDoc (getLocA con_name)             flds' <- traverse addHaddockConDeclField flds             pure $ L l_con_decl $               ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,@@ -766,8 +782,8 @@   :: HsScaled GhcPs (LHsType GhcPs)   -> ConHdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy (HsScaled mult (L l t)) =-  WriterT $ extendHdkA l $ liftHdkA $ do-    mDoc <- getPrevNextDoc l+  WriterT $ extendHdkA (locA l) $ liftHdkA $ do+    mDoc <- getPrevNextDoc (locA l)     return (HsScaled mult (mkLHsDocTy (L l t) mDoc),             HasInnerDocs (isJust mDoc)) @@ -777,8 +793,8 @@   :: LConDeclField GhcPs   -> ConHdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) =-  WriterT $ extendHdkA l_fld $ liftHdkA $ do-    cd_fld_doc <- getPrevNextDoc l_fld+  WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do+    cd_fld_doc <- getPrevNextDoc (locA l_fld)     return (L l_fld (fld { cd_fld_doc }),             HasInnerDocs (isJust cd_fld_doc)) @@ -849,9 +865,9 @@                     doc <- selectDocString trailingDocs                     return $ L l' (con_fld { cd_fld_doc = doc })               con_args' <- case con_args con_decl of-                x@(PrefixCon [])    -> x <$ reportExtraDocs trailingDocs+                x@(PrefixCon _ [])  -> x <$ reportExtraDocs trailingDocs                 x@(RecCon (L _ [])) -> x <$ reportExtraDocs trailingDocs-                PrefixCon ts -> PrefixCon <$> mapLastM mk_doc_ty ts+                PrefixCon _ ts -> PrefixCon noTypeArgs <$> mapLastM mk_doc_ty ts                 InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2                 RecCon (L l_rec flds) -> do                   flds' <- mapLastM mk_doc_fld flds@@ -911,11 +927,18 @@ instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where   addHaddock (HsScaled mult a) = HsScaled mult <$> addHaddock a -instance HasHaddock (LHsSigWcType GhcPs) where+instance HasHaddock a => HasHaddock (HsWildCardBndrs GhcPs a) where   addHaddock (HsWC _ t) = HsWC noExtField <$> addHaddock t -instance HasHaddock (LHsSigType GhcPs) where-  addHaddock (HsIB _ t) = HsIB noExtField <$> addHaddock t+instance HasHaddock (LocatedA (HsSigType GhcPs)) where+  addHaddock (L l (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =+    extendHdkA (locA l) $ do+      case outer_bndrs of+        HsOuterImplicit{} -> pure ()+        HsOuterExplicit{hso_bndrs = bndrs} ->+          registerLocHdkA (getLHsTyVarBndrsLoc bndrs)+      body' <- addHaddock body+      pure $ L l $ HsSig noExtField outer_bndrs body'  -- Process a type, adding documentation comments to function arguments -- and the result. Many formatting styles are supported.@@ -944,22 +967,22 @@ -- -- This is achieved by simply ignoring (not registering the location of) the -- function arrow (->).-instance HasHaddock (LHsType GhcPs) where+instance HasHaddock (LocatedA (HsType GhcPs)) where   addHaddock (L l t) =-    extendHdkA l $+    extendHdkA (locA l) $     case t of        -- forall a b c. t-      HsForAllTy _ tele body -> do+      HsForAllTy x tele body -> do         registerLocHdkA (getForAllTeleLoc tele)         body' <- addHaddock body-        pure $ L l (HsForAllTy noExtField tele body')+        pure $ L l (HsForAllTy x tele body')        -- (Eq a, Num a) => t-      HsQualTy _ lhs rhs -> do-        registerHdkA lhs+      HsQualTy x mlhs rhs -> do+        traverse_ registerHdkA mlhs         rhs' <- addHaddock rhs-        pure $ L l (HsQualTy noExtField lhs rhs')+        pure $ L l (HsQualTy x mlhs rhs')        -- arg -> res       HsFunTy u mult lhs rhs -> do@@ -969,7 +992,7 @@        -- other types       _ -> liftHdkA $ do-        mDoc <- getPrevNextDoc l+        mDoc <- getPrevNextDoc (locA l)         return (mkLHsDocTy (L l t) mDoc)  {- *********************************************************************@@ -1122,8 +1145,8 @@ -- A small wrapper over registerLocHdkA. -- -- See Note [Adding Haddock comments to the syntax tree].-registerHdkA :: Located a -> HdkA ()-registerHdkA a = registerLocHdkA (getLoc a)+registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()+registerHdkA a = registerLocHdkA (getLocA a)  -- Modify the action of a HdkA computation. hoistHdkA :: (HdkM a -> HdkM b) -> HdkA a -> HdkA b@@ -1279,11 +1302,11 @@ mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl layout_info a = mapLoc (DocD noExtField) <$> mkDocDecl layout_info a -mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe LDocDecl+mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment)   | indent_mismatch = Nothing   | otherwise =-    Just $ L (mkSrcSpanPs l_comment) $+    Just $ L (noAnnSrcSpan $ mkSrcSpanPs l_comment) $       case hdk_comment of         HdkCommentNext doc -> DocCommentNext doc         HdkCommentPrev doc -> DocCommentPrev doc@@ -1322,7 +1345,7 @@     HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)     HdkCommentNext doc -> Just $ L l (IEDoc noExtField doc)     _ -> Nothing-  where l = mkSrcSpanPs l_comment+  where l = noAnnSrcSpan $ mkSrcSpanPs l_comment  mkDocNext :: PsLocated HdkComment -> Maybe LHsDocString mkDocNext (L l (HdkCommentNext doc)) = Just $ L (mkSrcSpanPs l) doc@@ -1444,15 +1467,17 @@  mkLHsDocTy :: LHsType GhcPs -> Maybe LHsDocString -> LHsType GhcPs mkLHsDocTy t Nothing = t-mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noExtField t doc)+mkLHsDocTy t (Just doc) = L (getLoc t) (HsDocTy noAnn t doc)  getForAllTeleLoc :: HsForAllTelescope GhcPs -> SrcSpan getForAllTeleLoc tele =-  foldr combineSrcSpans noSrcSpan $   case tele of-    HsForAllVis{ hsf_vis_bndrs } -> map getLoc hsf_vis_bndrs-    HsForAllInvis { hsf_invis_bndrs } -> map getLoc hsf_invis_bndrs+    HsForAllVis{ hsf_vis_bndrs } -> getLHsTyVarBndrsLoc hsf_vis_bndrs+    HsForAllInvis { hsf_invis_bndrs } -> getLHsTyVarBndrsLoc hsf_invis_bndrs +getLHsTyVarBndrsLoc :: [LHsTyVarBndr flag GhcPs] -> SrcSpan+getLHsTyVarBndrsLoc bndrs = foldr combineSrcSpans noSrcSpan $ map getLocA bndrs+ -- | The inverse of 'partitionBindsAndSigs' that merges partitioned items back -- into a flat list. Elements are put back into the order in which they -- appeared in the original program before partitioning, using BufPos to order@@ -1461,22 +1486,25 @@ -- Precondition (unchecked): the input lists are already sorted. flattenBindsAndSigs   :: (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs],-      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl])+      [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])   -> [LHsDecl GhcPs] flattenBindsAndSigs (all_bs, all_ss, all_ts, all_tfis, all_dfis, all_docs) =   -- 'cmpBufSpan' is safe here with the following assumptions:   ---  -- * 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'-  -- * 'partitionBindsAndSigs' does not discard this 'BufSpan'-  mergeListsBy cmpBufSpan [+  -- - 'LHsDecl' produced by 'decl_cls' in Parser.y always have a 'BufSpan'+  -- - 'partitionBindsAndSigs' does not discard this 'BufSpan'+  mergeListsBy cmpBufSpanA [     mapLL (\b -> ValD noExtField b) (bagToList all_bs),     mapLL (\s -> SigD noExtField s) all_ss,     mapLL (\t -> TyClD noExtField (FamDecl noExtField t)) all_ts,     mapLL (\tfi -> InstD noExtField (TyFamInstD noExtField tfi)) all_tfis,-    mapLL (\dfi -> InstD noExtField (DataFamInstD noExtField dfi)) all_dfis,+    mapLL (\dfi -> InstD noExtField (DataFamInstD noAnn dfi)) all_dfis,     mapLL (\d -> DocD noExtField d) all_docs   ] +cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering+cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)+ {- ********************************************************************* *                                                                      * *                   General purpose utilities                          *@@ -1488,7 +1516,7 @@ mcons = maybe id (:)  -- Map a function over a list of located items.-mapLL :: (a -> b) -> [Located a] -> [Located b]+mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b] mapLL f = map (mapLoc f)  {- Note [Old solution: Haddock in the grammar]@@ -1515,7 +1543,7 @@ and sometimes it simply made it hard to modify and extend the grammar.  Another issue was that sometimes Haddock would fail to parse code-that GHC could parse succesfully:+that GHC could parse successfully:    class BadIndent where     f :: a -> Int

+ GHC/Parser/Types.hs view

@@ -0,0 +1,106 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleInstances #-}++module GHC.Parser.Types+   ( SumOrTuple(..)+   , pprSumOrTuple+   , PatBuilder(..)+   , DataConBuilder(..)+   )+where++import GHC.Prelude+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Name.Reader+import GHC.Hs.Extension+import GHC.Hs.Lit+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Utils.Outputable as Outputable+import GHC.Data.OrdList++import Data.Foldable+import GHC.Parser.Annotation+import Language.Haskell.Syntax++data SumOrTuple b+  = Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation]+  -- ^ Last two are the locations of the '|' before and after the payload+  | Tuple [Either (EpAnn EpaLocation) (LocatedA b)]++pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc+pprSumOrTuple boxity = \case+    Sum alt arity e _ _ ->+      parOpen <+> ppr_bars (alt - 1) <+> ppr e <+> ppr_bars (arity - alt)+              <+> parClose+    Tuple xs ->+      parOpen <> (fcat . punctuate comma $ map ppr_tup xs)+              <> parClose+  where+    ppr_tup (Left _)  = empty+    ppr_tup (Right e) = ppr e++    ppr_bars n = hsep (replicate n (Outputable.char '|'))+    (parOpen, parClose) =+      case boxity of+        Boxed -> (text "(", text ")")+        Unboxed -> (text "(#", text "#)")+++-- | See Note [Ambiguous syntactic categories] and Note [PatBuilder]+data PatBuilder p+  = PatBuilderPat (Pat p)+  | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen+  | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))+  | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs)+  | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)+                    (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn])+  | PatBuilderVar (LocatedN RdrName)+  | PatBuilderOverLit (HsOverLit GhcPs)++instance Outputable (PatBuilder GhcPs) where+  ppr (PatBuilderPat p) = ppr p+  ppr (PatBuilderPar (L _ p) _) = parens (ppr p)+  ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2+  ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t+  ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2+  ppr (PatBuilderVar v) = ppr v+  ppr (PatBuilderOverLit l) = ppr l++-- | An accumulator to build a prefix data constructor,+--   e.g. when parsing @MkT A B C@, the accumulator will evolve as follows:+--+--  @+--  1. PrefixDataConBuilder []        MkT+--  2. PrefixDataConBuilder [A]       MkT+--  3. PrefixDataConBuilder [A, B]    MkT+--  4. PrefixDataConBuilder [A, B, C] MkT+--  @+--+--  There are two reasons we have a separate builder type instead of using+--  @HsConDeclDetails GhcPs@ directly:+--+--  1. It's faster, because 'OrdList' gives us constant-time snoc.+--  2. Having a separate type helps ensure that we don't forget to finalize a+--     'RecTy' into a 'RecCon' (we do that in 'dataConBuilderDetails').+--+--  See Note [PatBuilder] for another builder type used in the parser.+--  Here the technique is similar, but the motivation is different.+data DataConBuilder+  = PrefixDataConBuilder+      (OrdList (LHsType GhcPs))  -- Data constructor fields+      (LocatedN RdrName)         -- Data constructor name+  | InfixDataConBuilder+      (LHsType GhcPs)    -- LHS field+      (LocatedN RdrName) -- Data constructor name+      (LHsType GhcPs)    -- RHS field++instance Outputable DataConBuilder where+  ppr (PrefixDataConBuilder flds data_con) =+    hang (ppr data_con) 2 (sep (map ppr (toList flds)))+  ppr (InfixDataConBuilder lhs data_con rhs) =+    ppr lhs <+> ppr data_con <+> ppr rhs++type instance Anno [LocatedA (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL

+ GHC/Parser/Utils.hs view

@@ -0,0 +1,58 @@+module GHC.Parser.Utils+    ( isStmt+    , hasImport+    , isImport+    , isDecl+    )+where++import GHC.Prelude+import GHC.Hs+import GHC.Data.StringBuffer+import GHC.Data.FastString+import GHC.Types.SrcLoc++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)+++-- | Returns @True@ if passed string is a statement.+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 :: ParserOpts -> String -> Bool+hasImport pflags stmt =+  case parseThing Parser.parseModule pflags stmt of+    Lexer.POk _ thing -> hasImports thing+    Lexer.PFailed _ -> False+  where+    hasImports = not . null . hsmodImports . unLoc++-- | Returns @True@ if passed string is an import declaration.+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 :: ParserOpts -> String -> Bool+isDecl pflags stmt =+  case parseThing Parser.parseDeclaration pflags stmt of+    Lexer.POk _ thing ->+      case unLoc thing of+        SpliceD _ _ -> False+        _ -> True+    Lexer.PFailed _ -> False++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.initParserState opts buf loc)

+ GHC/Platform.hs view

@@ -0,0 +1,325 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE LambdaCase #-}++-- | Platform description+module GHC.Platform+   ( Platform (..)+   , PlatformWordSize(..)+   , platformArch+   , platformOS+   , ArchOS(..)+   , Arch(..)+   , OS(..)+   , ArmISA(..)+   , ArmISAExt(..)+   , ArmABI(..)+   , PPC_64ABI(..)+   , ByteOrder(..)+   , target32Bit+   , isARM+   , osElfTarget+   , osMachOTarget+   , osSubsectionsViaSymbols+   , platformUsesFrameworks+   , platformWordSizeInBytes+   , platformWordSizeInBits+   , platformMinInt+   , platformMaxInt+   , platformMaxWord+   , platformInIntRange+   , platformInWordRange+   , platformCConvNeedsExtension+   , PlatformMisc(..)+   , SseVersion (..)+   , BmiVersion (..)+   -- * Platform constants+   , PlatformConstants(..)+   , lookupPlatformConstants+   , platformConstants+   -- * Shared libraries+   , platformSOName+   , platformHsSOName+   , platformSOExt+   , genericPlatform+   )+where++import Prelude -- See Note [Why do we import Prelude here?]++import GHC.Read+import GHC.ByteOrder (ByteOrder(..))+import GHC.Platform.Constants+import GHC.Platform.ArchOS+import GHC.Utils.Panic.Plain++import Data.Word+import Data.Int+import System.FilePath+import System.Directory++-- | Platform description+--+-- This is used to describe platforms so that we can generate code for them.+data Platform = Platform+   { platformArchOS                   :: !ArchOS           -- ^ Architecture and OS+   , platformWordSize                 :: !PlatformWordSize -- ^ Word size+   , platformByteOrder                :: !ByteOrder        -- ^ Byte order (endianness)+   , platformUnregisterised           :: !Bool+   , platformHasGnuNonexecStack       :: !Bool+   , platformHasIdentDirective        :: !Bool+   , platformHasSubsectionsViaSymbols :: !Bool+   , platformIsCrossCompiling         :: !Bool+   , platformLeadingUnderscore        :: !Bool             -- ^ Symbols need underscore prefix+   , platformTablesNextToCode         :: !Bool+      -- ^ Determines whether we will be compiling info tables that reside just+      --   before the entry code, or with an indirection to the entry code. See+      --   TABLES_NEXT_TO_CODE in includes/rts/storage/InfoTables.h.+   , platform_constants               :: !(Maybe PlatformConstants)+      -- ^ Constants such as structure offsets, type sizes, etc.+   }+   deriving (Read, Show, Eq)++platformConstants :: Platform -> PlatformConstants+platformConstants platform = case platform_constants platform of+  Nothing -> panic "Platform constants not available!"+  Just c  -> c++genericPlatform :: Platform+genericPlatform = Platform+   { platformArchOS                  = ArchOS ArchX86_64 OSLinux+   , platformWordSize                = PW8+   , platformByteOrder               = LittleEndian+   , platformUnregisterised          = False+   , platformHasGnuNonexecStack      = False+   , platformHasIdentDirective       = False+   , platformHasSubsectionsViaSymbols= False+   , platformIsCrossCompiling        = False+   , platformLeadingUnderscore       = False+   , platformTablesNextToCode        = True+   , platform_constants               = Nothing+   }++data PlatformWordSize+  = PW4 -- ^ A 32-bit platform+  | PW8 -- ^ A 64-bit platform+  deriving (Eq, Ord)++instance Show PlatformWordSize where+  show PW4 = "4"+  show PW8 = "8"++instance Read PlatformWordSize where+  readPrec = do+    i :: Int <- readPrec+    case i of+      4 -> return PW4+      8 -> return PW8+      other -> fail ("Invalid PlatformWordSize: " ++ show other)++platformWordSizeInBytes :: Platform -> Int+platformWordSizeInBytes p =+    case platformWordSize p of+      PW4 -> 4+      PW8 -> 8++platformWordSizeInBits :: Platform -> Int+platformWordSizeInBits p = platformWordSizeInBytes p * 8++-- | Platform architecture+platformArch :: Platform -> Arch+platformArch platform = case platformArchOS platform of+   ArchOS arch _ -> arch++-- | Platform OS+platformOS :: Platform -> OS+platformOS platform = case platformArchOS platform of+   ArchOS _ os -> os++isARM :: Arch -> Bool+isARM (ArchARM {}) = True+isARM ArchAArch64  = True+isARM _ = False++-- | This predicate tells us whether the platform is 32-bit.+target32Bit :: Platform -> Bool+target32Bit p =+    case platformWordSize p of+      PW4 -> True+      PW8 -> False++-- | This predicate tells us whether the OS supports ELF-like shared libraries.+osElfTarget :: OS -> Bool+osElfTarget OSLinux     = True+osElfTarget OSFreeBSD   = True+osElfTarget OSDragonFly = True+osElfTarget OSOpenBSD   = True+osElfTarget OSNetBSD    = True+osElfTarget OSSolaris2  = True+osElfTarget OSDarwin    = False+osElfTarget OSMinGW32   = False+osElfTarget OSKFreeBSD  = True+osElfTarget OSHaiku     = True+osElfTarget OSQNXNTO    = False+osElfTarget OSAIX       = False+osElfTarget OSHurd      = True+osElfTarget OSUnknown   = False+ -- Defaulting to False is safe; it means don't rely on any+ -- ELF-specific functionality.  It is important to have a default for+ -- portability, otherwise we have to answer this question for every+ -- new platform we compile on (even unreg).++-- | This predicate tells us whether the OS support Mach-O shared libraries.+osMachOTarget :: OS -> Bool+osMachOTarget OSDarwin = True+osMachOTarget _ = False++osUsesFrameworks :: OS -> Bool+osUsesFrameworks OSDarwin = True+osUsesFrameworks _        = False++platformUsesFrameworks :: Platform -> Bool+platformUsesFrameworks = osUsesFrameworks . platformOS++osSubsectionsViaSymbols :: OS -> Bool+osSubsectionsViaSymbols OSDarwin = True+osSubsectionsViaSymbols _        = False++-- | Minimum representable Int value for the given platform+platformMinInt :: Platform -> Integer+platformMinInt p = case platformWordSize p of+   PW4 -> toInteger (minBound :: Int32)+   PW8 -> toInteger (minBound :: Int64)++-- | Maximum representable Int value for the given platform+platformMaxInt :: Platform -> Integer+platformMaxInt p = case platformWordSize p of+   PW4 -> toInteger (maxBound :: Int32)+   PW8 -> toInteger (maxBound :: Int64)++-- | Maximum representable Word value for the given platform+platformMaxWord :: Platform -> Integer+platformMaxWord p = case platformWordSize p of+   PW4 -> toInteger (maxBound :: Word32)+   PW8 -> toInteger (maxBound :: Word64)++-- | Test if the given Integer is representable with a platform Int+platformInIntRange :: Platform -> Integer -> Bool+platformInIntRange platform x = x >= platformMinInt platform && x <= platformMaxInt platform++-- | Test if the given Integer is representable with a platform Word+platformInWordRange :: Platform -> Integer -> Bool+platformInWordRange platform x = x >= 0 && x <= platformMaxWord platform++-- | For some architectures the C calling convention is that any+-- integer shorter than 64 bits is replaced by its 64 bits+-- representation using sign or zero extension.+platformCConvNeedsExtension :: Platform -> Bool+platformCConvNeedsExtension platform = case platformArch platform of+  ArchPPC_64 _ -> True+  ArchS390X    -> True+  ArchRISCV64  -> True+  _            -> False+++--------------------------------------------------+-- Instruction sets+--------------------------------------------------++-- | x86 SSE instructions+data SseVersion+   = SSE1+   | SSE2+   | SSE3+   | SSE4+   | SSE42+   deriving (Eq, Ord)++-- | x86 BMI (bit manipulation) instructions+data BmiVersion+   = BMI1+   | BMI2+   deriving (Eq, Ord)++-- | Platform-specific settings formerly hard-coded in Config.hs.+--+-- These should probably be all be triaged whether they can be computed from+-- other settings or belong in another another place (like 'Platform' above).+data PlatformMisc = PlatformMisc+  { -- TODO Recalculate string from richer info?+    platformMisc_targetPlatformString :: String+  , platformMisc_ghcWithInterpreter   :: Bool+  , platformMisc_ghcWithSMP           :: Bool+  , platformMisc_ghcRTSWays           :: String+  , platformMisc_libFFI               :: Bool+  , platformMisc_ghcRtsWithLibdw      :: Bool+  , platformMisc_llvmTarget           :: String+  }++platformSOName :: Platform -> FilePath -> FilePath+platformSOName platform root = case platformOS platform of+   OSMinGW32 ->           root  <.> platformSOExt platform+   _         -> ("lib" ++ root) <.> platformSOExt platform++platformHsSOName :: Platform -> FilePath -> FilePath+platformHsSOName platform root = ("lib" ++ root) <.> platformSOExt platform++platformSOExt :: Platform -> FilePath+platformSOExt platform+    = case platformOS platform of+      OSDarwin  -> "dylib"+      OSMinGW32 -> "dll"+      _         -> "so"++-- Note [Platform constants]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The RTS is partly written in C, hence we use an external C compiler to build+-- it. Thus GHC must somehow retrieve some information about the produced code+-- (sizes of types, offsets of struct fields, etc.) to produce compatible code.+--+-- This is the role of utils/deriveConstants utility: it produces a C+-- source, compiles it with the same toolchain that will be used to build the+-- RTS, and finally retrieves the constants from the built artefact. We can't+-- directly run the produced program because we may be cross-compiling.+--+-- These constants are then stored in DerivedConstants.h header file that is+-- bundled with the RTS unit. This file is directly imported by Cmm codes and it+-- is also read by GHC. deriveConstants also produces the Haskell definition of+-- the PlatformConstants datatype and the Haskell parser for the+-- DerivedConstants.h file.+--+-- For quite some time, constants used by GHC were globally installed in+-- ${libdir}/platformConstants but now GHC reads the DerivedConstants.h header+-- bundled with the RTS unit. GHC detects when it builds the RTS unit itself and+-- in this case it loads the header from the include-dirs passed on the+-- command-line.+--+-- Note that GHC doesn't parse every "#define SOME_CONSTANT 123" individually.+-- Instead there is a single #define that contains all the constants useful to+-- GHC in a comma separated list:+--+--    #define HS_CONSTANTS "123,45,..."+--+-- Note that GHC mustn't directly import DerivedConstants.h as these constants+-- are only valid for a specific target platform and we want GHC to be target+-- agnostic.+--+++-- | Try to locate "DerivedConstants.h" file in the given dirs and to parse the+-- PlatformConstants from it.+--+-- See Note [Platform constants]+lookupPlatformConstants :: [FilePath] -> IO (Maybe PlatformConstants)+lookupPlatformConstants include_dirs = find_constants include_dirs+  where+    try_parse d = do+        let p = d </> "DerivedConstants.h"+        doesFileExist p >>= \case+          True  -> Just <$> parseConstantsHeader p+          False -> return Nothing++    find_constants []     = return Nothing+    find_constants (x:xs) = try_parse x >>= \case+        Nothing -> find_constants xs+        Just c  -> return (Just c)

+ GHC/Platform/Constants.hs view

@@ -0,0 +1,298 @@+module GHC.Platform.Constants where++import Prelude+import Data.Char++data PlatformConstants = PlatformConstants {+      pc_CONTROL_GROUP_CONST_291 :: {-# UNPACK #-} !Int,+      pc_STD_HDR_SIZE :: {-# UNPACK #-} !Int,+      pc_PROF_HDR_SIZE :: {-# UNPACK #-} !Int,+      pc_BLOCK_SIZE :: {-# UNPACK #-} !Int,+      pc_BLOCKS_PER_MBLOCK :: {-# UNPACK #-} !Int,+      pc_TICKY_BIN_COUNT :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR2 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR3 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR4 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR5 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR6 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR7 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR8 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR9 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rR10 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rF1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rF2 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rF3 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rF4 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rF5 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rF6 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rD1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rD2 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rD3 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rD4 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rD5 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rD6 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rXMM1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rXMM2 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rXMM3 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rXMM4 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rXMM5 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rXMM6 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rYMM1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rYMM2 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rYMM3 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rYMM4 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rYMM5 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rYMM6 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rZMM1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rZMM2 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rZMM3 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rZMM4 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rZMM5 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rZMM6 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rL1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rSp :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rSpLim :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rHp :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rHpLim :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rCCCS :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rCurrentTSO :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rCurrentNursery :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgRegTable_rHpAlloc :: {-# UNPACK #-} !Int,+      pc_OFFSET_stgEagerBlackholeInfo :: {-# UNPACK #-} !Int,+      pc_OFFSET_stgGCEnter1 :: {-# UNPACK #-} !Int,+      pc_OFFSET_stgGCFun :: {-# UNPACK #-} !Int,+      pc_OFFSET_Capability_r :: {-# UNPACK #-} !Int,+      pc_OFFSET_bdescr_start :: {-# UNPACK #-} !Int,+      pc_OFFSET_bdescr_free :: {-# UNPACK #-} !Int,+      pc_OFFSET_bdescr_blocks :: {-# UNPACK #-} !Int,+      pc_OFFSET_bdescr_flags :: {-# UNPACK #-} !Int,+      pc_SIZEOF_CostCentreStack :: {-# UNPACK #-} !Int,+      pc_OFFSET_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,+      pc_REP_CostCentreStack_mem_alloc :: {-# UNPACK #-} !Int,+      pc_OFFSET_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,+      pc_REP_CostCentreStack_scc_count :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgHeader_ccs :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgHeader_ldvw :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgSMPThunkHeader :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgEntCounter_allocs :: {-# UNPACK #-} !Int,+      pc_REP_StgEntCounter_allocs :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgEntCounter_allocd :: {-# UNPACK #-} !Int,+      pc_REP_StgEntCounter_allocd :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgEntCounter_registeredp :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgEntCounter_link :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgSmallMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgArrBytes_NoHdr :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgArrBytes_bytes :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgTSO_alloc_limit :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgTSO_cccs :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgTSO_stackobj :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgStack_sp :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgStack_stack :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgUpdateFrame_updatee :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,+      pc_REP_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgFunInfoExtraRev :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,+      pc_REP_StgFunInfoExtraRev_arity :: {-# UNPACK #-} !Int,+      pc_MAX_SPEC_SELECTEE_SIZE :: {-# UNPACK #-} !Int,+      pc_MAX_SPEC_AP_SIZE :: {-# UNPACK #-} !Int,+      pc_MIN_PAYLOAD_SIZE :: {-# UNPACK #-} !Int,+      pc_MIN_INTLIKE :: {-# UNPACK #-} !Int,+      pc_MAX_INTLIKE :: {-# UNPACK #-} !Int,+      pc_MIN_CHARLIKE :: {-# UNPACK #-} !Int,+      pc_MAX_CHARLIKE :: {-# UNPACK #-} !Int,+      pc_MUT_ARR_PTRS_CARD_BITS :: {-# UNPACK #-} !Int,+      pc_MAX_Vanilla_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Float_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Double_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Long_REG :: {-# UNPACK #-} !Int,+      pc_MAX_XMM_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Real_Vanilla_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Real_Float_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Real_Double_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Real_XMM_REG :: {-# UNPACK #-} !Int,+      pc_MAX_Real_Long_REG :: {-# UNPACK #-} !Int,+      pc_RESERVED_C_STACK_BYTES :: {-# UNPACK #-} !Int,+      pc_RESERVED_STACK_WORDS :: {-# UNPACK #-} !Int,+      pc_AP_STACK_SPLIM :: {-# UNPACK #-} !Int,+      pc_WORD_SIZE :: {-# UNPACK #-} !Int,+      pc_CINT_SIZE :: {-# UNPACK #-} !Int,+      pc_CLONG_SIZE :: {-# UNPACK #-} !Int,+      pc_CLONG_LONG_SIZE :: {-# UNPACK #-} !Int,+      pc_BITMAP_BITS_SHIFT :: {-# UNPACK #-} !Int,+      pc_TAG_BITS :: {-# UNPACK #-} !Int,+      pc_LDV_SHIFT :: {-# UNPACK #-} !Int,+      pc_ILDV_CREATE_MASK :: !Integer,+      pc_ILDV_STATE_CREATE :: !Integer,+      pc_ILDV_STATE_USE :: !Integer+  } deriving (Show,Read,Eq)+++parseConstantsHeader :: FilePath -> IO PlatformConstants+parseConstantsHeader fp = do+  s <- readFile fp+  let def = "#define HS_CONSTANTS \""+      find [] xs = xs+      find _  [] = error $ "Couldn't find " ++ def ++ " in " ++ fp+      find (d:ds) (x:xs)+        | d == x    = find ds xs+        | otherwise = find def xs++      readVal' :: Bool -> Integer -> String -> [Integer]+      readVal' n     c (x:xs) = case x of+        '"' -> [if n then negate c else c]+        '-' -> readVal' True c xs+        ',' -> (if n then negate c else c) : readVal' False 0 xs+        _   -> readVal' n (c*10 + fromIntegral (ord x - ord '0')) xs+      readVal' n     c []     = [if n then negate c else c]++      readVal = readVal' False 0++  return $! case readVal (find def s) of+    [v0,v1,v2,v3,v4,v5,v6,v7,v8,v9,v10,v11,v12,v13,v14,v15+     ,v16,v17,v18,v19,v20,v21,v22,v23,v24,v25,v26,v27,v28,v29,v30,v31+     ,v32,v33,v34,v35,v36,v37,v38,v39,v40,v41,v42,v43,v44,v45,v46,v47+     ,v48,v49,v50,v51,v52,v53,v54,v55,v56,v57,v58,v59,v60,v61,v62,v63+     ,v64,v65,v66,v67,v68,v69,v70,v71,v72,v73,v74,v75,v76,v77,v78,v79+     ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95+     ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111+     ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127+     ] -> PlatformConstants+            { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0+            , pc_STD_HDR_SIZE = fromIntegral v1+            , pc_PROF_HDR_SIZE = fromIntegral v2+            , pc_BLOCK_SIZE = fromIntegral v3+            , pc_BLOCKS_PER_MBLOCK = fromIntegral v4+            , pc_TICKY_BIN_COUNT = fromIntegral v5+            , pc_OFFSET_StgRegTable_rR1 = fromIntegral v6+            , pc_OFFSET_StgRegTable_rR2 = fromIntegral v7+            , pc_OFFSET_StgRegTable_rR3 = fromIntegral v8+            , pc_OFFSET_StgRegTable_rR4 = fromIntegral v9+            , pc_OFFSET_StgRegTable_rR5 = fromIntegral v10+            , pc_OFFSET_StgRegTable_rR6 = fromIntegral v11+            , pc_OFFSET_StgRegTable_rR7 = fromIntegral v12+            , pc_OFFSET_StgRegTable_rR8 = fromIntegral v13+            , pc_OFFSET_StgRegTable_rR9 = fromIntegral v14+            , pc_OFFSET_StgRegTable_rR10 = fromIntegral v15+            , pc_OFFSET_StgRegTable_rF1 = fromIntegral v16+            , pc_OFFSET_StgRegTable_rF2 = fromIntegral v17+            , pc_OFFSET_StgRegTable_rF3 = fromIntegral v18+            , pc_OFFSET_StgRegTable_rF4 = fromIntegral v19+            , pc_OFFSET_StgRegTable_rF5 = fromIntegral v20+            , pc_OFFSET_StgRegTable_rF6 = fromIntegral v21+            , pc_OFFSET_StgRegTable_rD1 = fromIntegral v22+            , pc_OFFSET_StgRegTable_rD2 = fromIntegral v23+            , pc_OFFSET_StgRegTable_rD3 = fromIntegral v24+            , pc_OFFSET_StgRegTable_rD4 = fromIntegral v25+            , pc_OFFSET_StgRegTable_rD5 = fromIntegral v26+            , pc_OFFSET_StgRegTable_rD6 = fromIntegral v27+            , pc_OFFSET_StgRegTable_rXMM1 = fromIntegral v28+            , pc_OFFSET_StgRegTable_rXMM2 = fromIntegral v29+            , pc_OFFSET_StgRegTable_rXMM3 = fromIntegral v30+            , pc_OFFSET_StgRegTable_rXMM4 = fromIntegral v31+            , pc_OFFSET_StgRegTable_rXMM5 = fromIntegral v32+            , pc_OFFSET_StgRegTable_rXMM6 = fromIntegral v33+            , pc_OFFSET_StgRegTable_rYMM1 = fromIntegral v34+            , pc_OFFSET_StgRegTable_rYMM2 = fromIntegral v35+            , pc_OFFSET_StgRegTable_rYMM3 = fromIntegral v36+            , pc_OFFSET_StgRegTable_rYMM4 = fromIntegral v37+            , pc_OFFSET_StgRegTable_rYMM5 = fromIntegral v38+            , pc_OFFSET_StgRegTable_rYMM6 = fromIntegral v39+            , pc_OFFSET_StgRegTable_rZMM1 = fromIntegral v40+            , pc_OFFSET_StgRegTable_rZMM2 = fromIntegral v41+            , pc_OFFSET_StgRegTable_rZMM3 = fromIntegral v42+            , pc_OFFSET_StgRegTable_rZMM4 = fromIntegral v43+            , pc_OFFSET_StgRegTable_rZMM5 = fromIntegral v44+            , pc_OFFSET_StgRegTable_rZMM6 = fromIntegral v45+            , pc_OFFSET_StgRegTable_rL1 = fromIntegral v46+            , pc_OFFSET_StgRegTable_rSp = fromIntegral v47+            , pc_OFFSET_StgRegTable_rSpLim = fromIntegral v48+            , pc_OFFSET_StgRegTable_rHp = fromIntegral v49+            , pc_OFFSET_StgRegTable_rHpLim = fromIntegral v50+            , pc_OFFSET_StgRegTable_rCCCS = fromIntegral v51+            , pc_OFFSET_StgRegTable_rCurrentTSO = fromIntegral v52+            , pc_OFFSET_StgRegTable_rCurrentNursery = fromIntegral v53+            , pc_OFFSET_StgRegTable_rHpAlloc = fromIntegral v54+            , pc_OFFSET_stgEagerBlackholeInfo = fromIntegral v55+            , pc_OFFSET_stgGCEnter1 = fromIntegral v56+            , pc_OFFSET_stgGCFun = fromIntegral v57+            , pc_OFFSET_Capability_r = fromIntegral v58+            , pc_OFFSET_bdescr_start = fromIntegral v59+            , pc_OFFSET_bdescr_free = fromIntegral v60+            , pc_OFFSET_bdescr_blocks = fromIntegral v61+            , pc_OFFSET_bdescr_flags = fromIntegral v62+            , pc_SIZEOF_CostCentreStack = fromIntegral v63+            , pc_OFFSET_CostCentreStack_mem_alloc = fromIntegral v64+            , pc_REP_CostCentreStack_mem_alloc = fromIntegral v65+            , pc_OFFSET_CostCentreStack_scc_count = fromIntegral v66+            , pc_REP_CostCentreStack_scc_count = fromIntegral v67+            , pc_OFFSET_StgHeader_ccs = fromIntegral v68+            , pc_OFFSET_StgHeader_ldvw = fromIntegral v69+            , pc_SIZEOF_StgSMPThunkHeader = fromIntegral v70+            , pc_OFFSET_StgEntCounter_allocs = fromIntegral v71+            , pc_REP_StgEntCounter_allocs = fromIntegral v72+            , pc_OFFSET_StgEntCounter_allocd = fromIntegral v73+            , pc_REP_StgEntCounter_allocd = fromIntegral v74+            , pc_OFFSET_StgEntCounter_registeredp = fromIntegral v75+            , pc_OFFSET_StgEntCounter_link = fromIntegral v76+            , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77+            , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78+            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v79+            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v80+            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v81+            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v82+            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v83+            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v84+            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v85+            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v86+            , pc_OFFSET_StgTSO_cccs = fromIntegral v87+            , pc_OFFSET_StgTSO_stackobj = fromIntegral v88+            , pc_OFFSET_StgStack_sp = fromIntegral v89+            , pc_OFFSET_StgStack_stack = fromIntegral v90+            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v91+            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v92+            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v93+            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v94+            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v95+            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v96+            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v97+            , pc_MAX_SPEC_AP_SIZE = fromIntegral v98+            , pc_MIN_PAYLOAD_SIZE = fromIntegral v99+            , pc_MIN_INTLIKE = fromIntegral v100+            , pc_MAX_INTLIKE = fromIntegral v101+            , pc_MIN_CHARLIKE = fromIntegral v102+            , pc_MAX_CHARLIKE = fromIntegral v103+            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v104+            , pc_MAX_Vanilla_REG = fromIntegral v105+            , pc_MAX_Float_REG = fromIntegral v106+            , pc_MAX_Double_REG = fromIntegral v107+            , pc_MAX_Long_REG = fromIntegral v108+            , pc_MAX_XMM_REG = fromIntegral v109+            , pc_MAX_Real_Vanilla_REG = fromIntegral v110+            , pc_MAX_Real_Float_REG = fromIntegral v111+            , pc_MAX_Real_Double_REG = fromIntegral v112+            , pc_MAX_Real_XMM_REG = fromIntegral v113+            , pc_MAX_Real_Long_REG = fromIntegral v114+            , pc_RESERVED_C_STACK_BYTES = fromIntegral v115+            , pc_RESERVED_STACK_WORDS = fromIntegral v116+            , pc_AP_STACK_SPLIM = fromIntegral v117+            , pc_WORD_SIZE = fromIntegral v118+            , pc_CINT_SIZE = fromIntegral v119+            , pc_CLONG_SIZE = fromIntegral v120+            , pc_CLONG_LONG_SIZE = fromIntegral v121+            , pc_BITMAP_BITS_SHIFT = fromIntegral v122+            , pc_TAG_BITS = fromIntegral v123+            , pc_LDV_SHIFT = fromIntegral v124+            , pc_ILDV_CREATE_MASK = v125+            , pc_ILDV_STATE_CREATE = v126+            , pc_ILDV_STATE_USE = v127+            }+    _ -> error "Invalid platform constants"+

+ GHC/Platform/Profile.hs view

@@ -0,0 +1,52 @@+-- | Platform profiles+module GHC.Platform.Profile+   ( Profile (..)+   , profileBuildTag+   , profileConstants+   , profileIsProfiling+   , profileWordSizeInBytes+   )+where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways++-- | A platform profile fully describes the kind of objects that are generated+-- for a platform.+--+-- 'Platform' doesn't fully describe the ABI of an object. Compiler ways+-- (profiling, debug, dynamic) also modify the ABI.+--+data Profile = Profile+   { profilePlatform :: !Platform -- ^ Platform+   , profileWays     :: !Ways     -- ^ Ways+   }++-- | Get platform constants+profileConstants :: Profile -> PlatformConstants+{-# INLINE profileConstants #-}+profileConstants profile = platformConstants (profilePlatform profile)++-- | Is profiling enabled+profileIsProfiling :: Profile -> Bool+{-# INLINE profileIsProfiling #-}+profileIsProfiling profile = profileWays profile `hasWay` WayProf++-- | Word size in bytes+profileWordSizeInBytes :: Profile -> Int+{-# INLINE profileWordSizeInBytes #-}+profileWordSizeInBytes profile = platformWordSizeInBytes (profilePlatform profile)++-- | Unique build tag for the profile+profileBuildTag :: Profile -> String+profileBuildTag profile+    -- profiles using unregisterised convention are not binary compatible with+    -- those that don't. Make sure to make it apparent in the tag so that our+    -- interface files can't be mismatched by mistake.+  | platformUnregisterised platform = 'u':wayTag+  | otherwise                       =     wayTag+  where+   platform = profilePlatform profile+   wayTag   = waysBuildTag (profileWays profile)

+ GHC/Platform/RISCV64.hs view

@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module GHC.Platform.RISCV64 where++import GHC.Prelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_riscv64 1+#include "../../../includes/CodeGen.Platform.hs"+

GHC/Platform/Reg.hs view

@@ -30,7 +30,9 @@ import GHC.Prelude  import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Platform.Reg.Class import Data.List (intersect) @@ -179,7 +181,7 @@ data Reg         = RegVirtual !VirtualReg         | RegReal    !RealReg-        deriving (Eq, Ord)+        deriving (Eq, Ord, Show)  regSingle :: RegNo -> Reg regSingle regNo = RegReal (realRegSingle regNo)

GHC/Platform/Reg/Class.hs view

@@ -8,6 +8,7 @@  import GHC.Utils.Outputable as Outputable import GHC.Types.Unique+import GHC.Builtin.Uniques   -- | The class of a register.

GHC/Platform/Regs.hs view

@@ -15,6 +15,7 @@ import qualified GHC.Platform.SPARC      as SPARC import qualified GHC.Platform.X86        as X86 import qualified GHC.Platform.X86_64     as X86_64+import qualified GHC.Platform.RISCV64    as RISCV64 import qualified GHC.Platform.NoRegs     as NoRegs  -- | Returns 'True' if this global register is stored in a caller-saves@@ -31,6 +32,7 @@    ArchSPARC   -> SPARC.callerSaves    ArchARM {}  -> ARM.callerSaves    ArchAArch64 -> AArch64.callerSaves+   ArchRISCV64 -> RISCV64.callerSaves    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.callerSaves@@ -53,6 +55,7 @@    ArchSPARC   -> SPARC.activeStgRegs    ArchARM {}  -> ARM.activeStgRegs    ArchAArch64 -> AArch64.activeStgRegs+   ArchRISCV64 -> RISCV64.activeStgRegs    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.activeStgRegs@@ -70,6 +73,7 @@    ArchSPARC   -> SPARC.haveRegBase    ArchARM {}  -> ARM.haveRegBase    ArchAArch64 -> AArch64.haveRegBase+   ArchRISCV64 -> RISCV64.haveRegBase    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.haveRegBase@@ -87,6 +91,7 @@    ArchSPARC   -> SPARC.globalRegMaybe    ArchARM {}  -> ARM.globalRegMaybe    ArchAArch64 -> AArch64.globalRegMaybe+   ArchRISCV64 -> RISCV64.globalRegMaybe    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.globalRegMaybe@@ -104,6 +109,7 @@    ArchSPARC   -> SPARC.freeReg    ArchARM {}  -> ARM.freeReg    ArchAArch64 -> AArch64.freeReg+   ArchRISCV64 -> RISCV64.freeReg    arch     | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->         PPC.freeReg

+ GHC/Platform/Ways.hs view

@@ -0,0 +1,272 @@+{-# LANGUAGE CPP #-}++-- | Ways+--+-- The central concept of a "way" is that all objects in a given+-- program must be compiled in the same "way". Certain options change+-- parameters of the virtual machine, eg. profiling adds an extra word+-- to the object header, so profiling objects cannot be linked with+-- non-profiling objects.+--+-- After parsing the command-line options, we determine which "way" we+-- are building - this might be a combination way, eg. profiling+threaded.+--+-- There are two kinds of ways:+--    - RTS only: only affect the runtime system (RTS) and don't affect code+--    generation (e.g. threaded, debug)+--    - Full ways: affect code generation and the RTS (e.g. profiling, dynamic+--    linking)+--+-- We then find the "build-tag" associated with this way, and this+-- becomes the suffix used to find .hi files and libraries used in+-- this compilation.+module GHC.Platform.Ways+   ( Way(..)+   , Ways+   , hasWay+   , addWay+   , allowed_combination+   , wayGeneralFlags+   , wayUnsetGeneralFlags+   , wayOptc+   , wayOptl+   , wayOptP+   , wayDesc+   , wayRTSOnly+   , wayTag+   , waysTag+   , waysBuildTag+   , fullWays+   , rtsWays+   -- * Host GHC ways+   , hostWays+   , hostFullWays+   , hostIsProfiled+   , hostIsDynamic+   , hostIsThreaded+   , hostIsDebugged+   , hostIsTracing+   )+where++#include "HsVersions.h"++import GHC.Prelude+import GHC.Platform+import GHC.Driver.Flags++import qualified Data.Set as Set+import Data.Set (Set)+import Data.List (intersperse)++-- | A way+--+-- Don't change the constructor order as it us used by `waysTag` to create a+-- unique tag (e.g. thr_debug_p) which is expected by other tools (e.g. Cabal).+data Way+  = WayCustom String -- ^ for GHC API clients building custom variants+  | WayThreaded      -- ^ (RTS only) Multithreaded runtime system+  | WayDebug         -- ^ Debugging, enable trace messages and extra checks+  | WayProf          -- ^ Profiling, enable cost-centre stacks and profiling reports+  | WayTracing       -- ^ (RTS only) enable event logging (tracing)+  | WayDyn           -- ^ Dynamic linking+  deriving (Eq, Ord, Show)++type Ways = Set Way++-- | Test if a ways is enabled+hasWay :: Ways -> Way -> Bool+hasWay ws w = Set.member w ws++-- | Add a way+addWay :: Way -> Ways -> Ways+addWay = Set.insert++-- | Check if a combination of ways is allowed+allowed_combination :: Ways -> Bool+allowed_combination ways = not disallowed+  where+   disallowed = or [ hasWay ways x && hasWay ways y+                   | (x,y) <- couples+                   ]+   -- List of disallowed couples of ways+   couples = [] -- we don't have any disallowed combination of ways nowadays++-- | Unique tag associated to a list of ways+waysTag :: Ways -> String+waysTag = concat . intersperse "_" . map wayTag . Set.toAscList++-- | Unique build-tag associated to a list of ways+--+-- RTS only ways are filtered out because they have no impact on the build.+waysBuildTag :: Ways -> String+waysBuildTag ws = waysTag (Set.filter (not . wayRTSOnly) ws)+++-- | Unique build-tag associated to a way+wayTag :: Way -> String+wayTag (WayCustom xs) = xs+wayTag WayThreaded    = "thr"+wayTag WayDebug       = "debug"+wayTag WayDyn         = "dyn"+wayTag WayProf        = "p"+wayTag WayTracing     = "l" -- "l" for "logging"++-- | Return true for ways that only impact the RTS, not the generated code+wayRTSOnly :: Way -> Bool+wayRTSOnly (WayCustom {}) = False+wayRTSOnly WayDyn         = False+wayRTSOnly WayProf        = False+wayRTSOnly WayThreaded    = True+wayRTSOnly WayDebug       = True+wayRTSOnly WayTracing     = True++-- | Filter ways that have an impact on compilation+fullWays :: Ways -> Ways+fullWays ws = Set.filter (not . wayRTSOnly) ws++-- | Filter RTS-only ways (ways that don't have an impact on compilation)+rtsWays :: Ways -> Ways+rtsWays ws = Set.filter wayRTSOnly ws++wayDesc :: Way -> String+wayDesc (WayCustom xs) = xs+wayDesc WayThreaded    = "Threaded"+wayDesc WayDebug       = "Debug"+wayDesc WayDyn         = "Dynamic"+wayDesc WayProf        = "Profiling"+wayDesc WayTracing     = "Tracing"++-- | Turn these flags on when enabling this way+wayGeneralFlags :: Platform -> Way -> [GeneralFlag]+wayGeneralFlags _ (WayCustom {}) = []+wayGeneralFlags _ WayThreaded = []+wayGeneralFlags _ WayDebug    = []+wayGeneralFlags _ WayDyn      = [Opt_PIC, Opt_ExternalDynamicRefs]+    -- We could get away without adding -fPIC when compiling the+    -- modules of a program that is to be linked with -dynamic; the+    -- program itself does not need to be position-independent, only+    -- the libraries need to be.  HOWEVER, GHCi links objects into a+    -- .so before loading the .so using the system linker.  Since only+    -- PIC objects can be linked into a .so, we have to compile even+    -- modules of the main program with -fPIC when using -dynamic.+wayGeneralFlags _ WayProf     = []+wayGeneralFlags _ WayTracing  = []++-- | Turn these flags off when enabling this way+wayUnsetGeneralFlags :: Platform -> Way -> [GeneralFlag]+wayUnsetGeneralFlags _ (WayCustom {}) = []+wayUnsetGeneralFlags _ WayThreaded = []+wayUnsetGeneralFlags _ WayDebug    = []+wayUnsetGeneralFlags _ WayDyn      = [Opt_SplitSections]+   -- There's no point splitting when we're going to be dynamically linking.+   -- Plus it breaks compilation on OSX x86.+wayUnsetGeneralFlags _ WayProf     = []+wayUnsetGeneralFlags _ WayTracing  = []++-- | Pass these options to the C compiler when enabling this way+wayOptc :: Platform -> Way -> [String]+wayOptc _ (WayCustom {}) = []+wayOptc platform WayThreaded = case platformOS platform of+                               OSOpenBSD -> ["-pthread"]+                               OSNetBSD  -> ["-pthread"]+                               _         -> []+wayOptc _ WayDebug      = []+wayOptc _ WayDyn        = []+wayOptc _ WayProf       = ["-DPROFILING"]+wayOptc _ WayTracing    = ["-DTRACING"]++-- | Pass these options to linker when enabling this way+wayOptl :: Platform -> Way -> [String]+wayOptl _ (WayCustom {}) = []+wayOptl platform WayThreaded =+   case platformOS platform of+   -- N.B. FreeBSD cc throws a warning if we pass -pthread without+   -- actually using any pthread symbols.+   OSFreeBSD  -> ["-pthread", "-Wno-unused-command-line-argument"]+   OSOpenBSD  -> ["-pthread"]+   OSNetBSD   -> ["-pthread"]+   _          -> []+wayOptl _ WayDebug      = []+wayOptl _ WayDyn        = []+wayOptl _ WayProf       = []+wayOptl _ WayTracing    = []++-- | Pass these options to the preprocessor when enabling this way+wayOptP :: Platform -> Way -> [String]+wayOptP _ (WayCustom {}) = []+wayOptP _ WayThreaded = []+wayOptP _ WayDebug    = []+wayOptP _ WayDyn      = []+wayOptP _ WayProf     = ["-DPROFILING"]+wayOptP _ WayTracing  = ["-DTRACING"]+++-- | Consult the RTS to find whether it has been built with profiling enabled.+hostIsProfiled :: Bool+hostIsProfiled = rtsIsProfiled_ /= 0++foreign import ccall unsafe "rts_isProfiled" rtsIsProfiled_ :: Int++-- | Consult the RTS to find whether GHC itself has been built with+-- dynamic linking.  This can't be statically known at compile-time,+-- because we build both the static and dynamic versions together with+-- -dynamic-too.+hostIsDynamic :: Bool+hostIsDynamic = rtsIsDynamic_ /= 0++foreign import ccall unsafe "rts_isDynamic" rtsIsDynamic_ :: Int++-- we need this until the bootstrap GHC is always recent enough+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)++-- | Consult the RTS to find whether it is threaded.+hostIsThreaded :: Bool+hostIsThreaded = rtsIsThreaded_ /= 0++foreign import ccall unsafe "rts_isThreaded" rtsIsThreaded_ :: Int++-- | Consult the RTS to find whether it is debugged.+hostIsDebugged :: Bool+hostIsDebugged = rtsIsDebugged_ /= 0++foreign import ccall unsafe "rts_isDebugged" rtsIsDebugged_ :: Int++-- | Consult the RTS to find whether it is tracing.+hostIsTracing :: Bool+hostIsTracing = rtsIsTracing_ /= 0++foreign import ccall unsafe "rts_isTracing" rtsIsTracing_ :: Int+++#else++hostIsThreaded :: Bool+hostIsThreaded = False++hostIsDebugged :: Bool+hostIsDebugged = False++hostIsTracing :: Bool+hostIsTracing = False++#endif+++-- | Host ways.+hostWays :: Ways+hostWays = Set.unions+   [ if hostIsDynamic  then Set.singleton WayDyn      else Set.empty+   , if hostIsProfiled then Set.singleton WayProf     else Set.empty+   , if hostIsThreaded then Set.singleton WayThreaded else Set.empty+   , if hostIsDebugged then Set.singleton WayDebug    else Set.empty+   , if hostIsTracing  then Set.singleton WayTracing  else Set.empty+   ]++-- | Host "full" ways (i.e. ways that have an impact on the compilation,+-- not RTS only ways).+--+-- These ways must be used when compiling codes targeting the internal+-- interpreter.+hostFullWays :: Ways+hostFullWays = fullWays hostWays

GHC/Plugins.hs view

@@ -26,13 +26,14 @@    , module GHC.Core.Rules    , module GHC.Types.Annotations    , module GHC.Driver.Session+   , module GHC.Driver.Ppr    , module GHC.Unit.State    , module GHC.Unit.Module    , module GHC.Core.Type    , module GHC.Core.TyCon    , module GHC.Core.Coercion    , module GHC.Builtin.Types-   , module GHC.Driver.Types+   , module GHC.Driver.Env    , module GHC.Types.Basic    , module GHC.Types.Var.Set    , module GHC.Types.Var.Env@@ -46,9 +47,15 @@    , module GHC.Serialized    , module GHC.Types.SrcLoc    , module GHC.Utils.Outputable+   , module GHC.Utils.Panic    , module GHC.Types.Unique.Supply    , module GHC.Data.FastString    , module GHC.Tc.Errors.Hole.FitTypes   -- for hole-fit plugins+   , module GHC.Unit.Module.ModGuts+   , module GHC.Unit.Module.ModSummary+   , module GHC.Unit.Module.ModIface+   , module GHC.Types.Meta+   , module GHC.Types.SourceError    , -- * Getting 'Name's      thNameToGhcName    )@@ -58,6 +65,8 @@ import GHC.Driver.Plugins  -- Variable naming+import GHC.Types.TyThing+import GHC.Types.SourceError import GHC.Types.Name.Reader import GHC.Types.Name.Occurrence  hiding  ( varName {- conflicts with Var.varName -} ) import GHC.Types.Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )@@ -76,23 +85,24 @@ import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )        -- These names are also exported by Type --- Core "extras" import GHC.Core.Rules import GHC.Types.Annotations+import GHC.Types.Meta --- Pipeline-related stuff import GHC.Driver.Session import GHC.Unit.State --- Important GHC types import GHC.Unit.Module+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface import GHC.Core.Type hiding {- conflict with GHC.Core.Subst -}                 ( substTy, extendTvSubst, extendTvSubstList, isInScope ) import GHC.Core.Coercion hiding {- conflict with GHC.Core.Subst -}                 ( substCo ) import GHC.Core.TyCon import GHC.Builtin.Types-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Types.Basic  -- Collections and maps@@ -111,6 +121,8 @@ import GHC.Serialized import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Driver.Ppr import GHC.Types.Unique.Supply import GHC.Types.Unique ( Unique, Uniquable(..) ) import GHC.Data.FastString

GHC/Prelude.hs view

@@ -10,15 +10,17 @@ --   * Is compiled with -XNoImplicitPrelude --   * Explicitly imports GHC.Prelude -module GHC.Prelude (module X) where+module GHC.Prelude+  (module X+  ,module Bits+  ,shiftL, shiftR+  ) where + -- We export the 'Semigroup' class but w/o the (<>) operator to avoid -- clashing with the (Outputable.<>) operator which is heavily used -- through GHC's code-base. -import Prelude as X hiding ((<>))-import Data.Foldable as X (foldl')- {- Note [Why do we import Prelude here?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -31,3 +33,55 @@     giving a smoother development experience when adding new     extensions. -}++import Prelude as X hiding ((<>))+import Data.Foldable as X (foldl')++#if MIN_VERSION_base(4,16,0)+import GHC.Bits as Bits hiding (shiftL, shiftR)+# if defined(DEBUG)+import qualified GHC.Bits as Bits (shiftL, shiftR)+# endif++#else+--base <4.15+import Data.Bits as Bits hiding (shiftL, shiftR)+# if defined(DEBUG)+import qualified Data.Bits as Bits (shiftL, shiftR)+# endif+#endif++{- Note [Default to unsafe shifts inside GHC]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The safe shifts can introduce branches which come+at the cost of performance. We still want the additional+debugability for debug builds. So we define it as one or the+other depending on the DEBUG setting.++Why do we then continue on to re-export the rest of Data.Bits?+If we would not what is likely to happen is:+* Someone imports Data.Bits, uses xor. Things are fine.+* They add a shift and get an ambigious definition error.+* The are puzzled for a bit.+* They either:+  + Remove the import of Data.Bits and get an error because xor is not in scope.+  + Add the hiding clause to the Data.Bits import for the shifts.++Either is quite annoying. Simply re-exporting all of Data.Bits avoids this+making for a smoother developer experience. At the cost of having a few more+names in scope at all time. But that seems like a fair tradeoff.++See also #19618+-}++-- We always want the Data.Bits method to show up for rules etc.+{-# INLINE shiftL #-}+{-# INLINE shiftR #-}+shiftL, shiftR :: Bits.Bits a => a -> Int -> a+#if defined(DEBUG)+shiftL = Bits.shiftL+shiftR = Bits.shiftR+#else+shiftL = Bits.unsafeShiftL+shiftR = Bits.unsafeShiftR+#endif

GHC/Rename/Bind.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} {-# LANGUAGE TypeFamilies #-} @@ -31,7 +32,7 @@  import GHC.Prelude -import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr, rnStmts )+import {-# SOURCE #-} GHC.Rename.Expr( rnExpr, rnLExpr, rnStmts )  import GHC.Hs import GHC.Tc.Utils.Monad@@ -40,13 +41,14 @@ import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Fixity-import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn-                        , checkDupRdrNames, warnUnusedLocalBinds+import GHC.Rename.Utils ( HsDocContext(..), mapFvRn+                        , checkDupRdrNames, checkDupRdrNamesN, warnUnusedLocalBinds                         , checkUnusedRecordWildcard                         , checkDupAndShadowedNames, bindLocalNamesFV                         , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Driver.Session import GHC.Unit.Module+import GHC.Types.FieldLabel import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set@@ -58,6 +60,7 @@ import GHC.Data.Bag import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique.Set import GHC.Data.Maybe          ( orElse ) import GHC.Data.OrdList@@ -222,13 +225,13 @@  rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds _ ip_binds ) = do-    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds+    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstMA rnIPBind) ip_binds     return (IPBinds noExtField ip_binds', plusFVs fvs_s)  rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind _ ~(Left n) expr) = do     (expr',fvExpr) <- rnLExpr expr-    return (IPBind noExtField (Left n) expr', fvExpr)+    return (IPBind noAnn (Left n) expr', fvExpr)  {- ************************************************************************@@ -264,7 +267,7 @@          --   import A(f)          --   g = let f = ... in f          -- should.-       ; let bound_names = collectHsValBinders binds'+       ; let bound_names = collectHsValBinders CollNoDictBinders binds'              -- There should be only Ids, but if there are any bogus              -- pattern synonyms, we'll collect them anyway, so that              -- we don't generate subsequent out-of-scope messages@@ -280,10 +283,10 @@               -> HsValBinds GhcPs               -> RnM (HsValBindsLR GhcRn GhcPs) rnValBindsLHS topP (ValBinds x mbinds sigs)-  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds+  = do { mbinds' <- mapBagM (wrapLocMA (rnBindLHS topP doc)) mbinds        ; return $ ValBinds x mbinds' sigs }   where-    bndrs = collectHsBindsBinders mbinds+    bndrs = collectHsBindsBinders CollNoDictBinders mbinds     doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs  rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)@@ -427,15 +430,15 @@  rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })   | isTopRecNameMaker name_maker-  = do { addLocM checkConName rdrname-       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already-       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }+  = do { addLocMA checkConName rdrname+       ; name <- lookupLocatedTopBndrRnN rdrname -- Should be in scope already+       ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }    | otherwise  -- Pattern synonym, not at top level   = do { addErr localPatternSynonymErr  -- Complain, but make up a fake                                         -- name so that we can carry on        ; name <- applyNameMaker name_maker rdrname-       ; return (PatSynBind x psb{ psb_ext = noExtField, psb_id = name }) }+       ; return (PatSynBind x psb{ psb_ext = noAnn, psb_id = name }) }   where     localPatternSynonymErr :: SDoc     localPatternSynonymErr@@ -448,7 +451,7 @@         -> LHsBindLR GhcRn GhcPs         -> RnM (LHsBind GhcRn, [Name], Uses) rnLBind sig_fn (L loc bind)-  = setSrcSpan loc $+  = setSrcSpanA loc $     do { (bind', bndrs, dus) <- rnBind sig_fn bind        ; return (L loc bind', bndrs, dus) } @@ -470,7 +473,7 @@                 -- Keep locally-defined Names                 -- As well as dependency analysis, we need these for the                 -- MonoLocalBinds test in GHC.Tc.Gen.Bind.decideGeneralisationPlan-              bndrs = collectPatBinders pat+              bndrs = collectPatBinders CollNoDictBinders pat               bind' = bind { pat_rhs  = grhss'                            , pat_ext = fvs' } @@ -606,7 +609,7 @@   where     env = mkHsSigEnv get_scoped_tvs sigs -    get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])+    get_scoped_tvs :: LSig GhcRn -> Maybe ([LocatedN Name], [Name])     -- Returns (binders, scoped tvs for those binders)     get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))       = Just (names, hsScopedTvs sig_ty)@@ -629,7 +632,7 @@  where    add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv    add_one_sig env (L loc (FixitySig _ names fixity)) =-     foldlM add_one env [ (loc,name_loc,name,fixity)+     foldlM add_one env [ (locA loc,locA name_loc,name,fixity)                         | L name_loc name <- names ]     add_one env (loc, name_loc, name,fixity) = do@@ -678,10 +681,10 @@          -- so that the binding locations are reported          -- from the left-hand side             case details of-               PrefixCon vars ->-                   do { checkDupRdrNames vars+               PrefixCon _ vars ->+                   do { checkDupRdrNamesN vars                       ; names <- mapM lookupPatSynBndr vars-                      ; return ( (pat', PrefixCon names)+                      ; return ( (pat', PrefixCon noTypeArgs names)                                , mkFVs (map unLoc names)) }                InfixCon var1 var2 ->                    do { checkDupRdrNames [var1, var2]@@ -691,13 +694,15 @@                       ; return ( (pat', InfixCon name1 name2)                                , mkFVs (map unLoc [name1, name2])) }                RecCon vars ->-                   do { checkDupRdrNames (map recordPatSynSelectorId vars)+                   do { checkDupRdrNames (map (rdrNameFieldOcc . recordPatSynField) vars)+                      ; fls <- lookupConstructorFields name+                      ; let fld_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]                       ; let rnRecordPatSynField-                              (RecordPatSynField { recordPatSynSelectorId = visible+                              (RecordPatSynField { recordPatSynField  = visible                                                  , recordPatSynPatVar = hidden })-                              = do { visible' <- lookupLocatedTopBndrRn visible+                              = do { let visible' = lookupField fld_env visible                                    ; hidden'  <- lookupPatSynBndr hidden-                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'+                                   ; return $ RecordPatSynField { recordPatSynField  = visible'                                                                 , recordPatSynPatVar = hidden' } }                       ; names <- mapM rnRecordPatSynField  vars                       ; return ( (pat', RecCon names)@@ -725,7 +730,7 @@                           , psb_ext = fvs' }               selector_names = case details' of                                  RecCon names ->-                                  map (unLoc . recordPatSynSelectorId) names+                                  map (extFieldOcc . recordPatSynField) names                                  _ -> []          ; fvs' `seq` -- See Note [Free-variable space leak]@@ -734,7 +739,7 @@       }   where     -- See Note [Renaming pattern synonym variables]-    lookupPatSynBndr = wrapLocM lookupLocalOccRn+    lookupPatSynBndr = wrapLocMA lookupLocalOccRn      patternSynonymErr :: SDoc     patternSynonymErr@@ -839,7 +844,7 @@ --   * the default method bindings in a class decl --   * the method bindings in an instance decl rnMethodBinds is_cls_decl cls ktv_names binds sigs-  = do { checkDupRdrNames (collectMethodBinders binds)+  = do { checkDupRdrNamesN (collectMethodBinders binds)              -- Check that the same method is not given twice in the              -- same instance decl      instance C T where              --                       f x = ...@@ -860,11 +865,11 @@        --       (==) :: a -> a -> a        --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}        ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs-             bound_nms = mkNameSet (collectHsBindsBinders binds')+             bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds')              sig_ctxt | is_cls_decl = ClsDeclCtxt cls                       | otherwise   = InstDeclCtxt bound_nms        ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags-       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $+       ; (other_sigs',      sig_fvs) <- bindLocalNamesFV ktv_names $                                         renameSigs sig_ctxt other_sigs         -- Rename the bindings RHSs.  Again there's an issue about whether the@@ -884,8 +889,8 @@                 -> LHsBindsLR GhcRn GhcPs                 -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest-  = setSrcSpan loc $ do-    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name+  = setSrcSpanA loc $ do+    do { sel_name <- wrapLocMA (lookupInstDeclBndr cls (text "method")) name                      -- We use the selector name as the binder        ; let bind' = bind { fun_id = sel_name, fun_ext = noExtField }        ; return (L loc bind' `consBag` rest ) }@@ -893,7 +898,7 @@ -- Report error for all other forms of bindings -- This is why we use a fold rather than map rnMethodBindLHS is_cls_decl _ (L loc bind) rest-  = do { addErrAt loc $+  = do { addErrAt (locA loc) $          vcat [ what <+> text "not allowed in" <+> decl_sort               , nest 2 (ppr bind) ]        ; return rest }@@ -932,7 +937,7 @@          ; checkDupMinimalSigs sigs -        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs+        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstMA (renameSig ctxt)) sigs          ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'         ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced@@ -954,18 +959,18 @@   = return (IdSig noExtField x, emptyFVs)    -- Actually this never occurs  renameSig ctxt sig@(TypeSig _ vs ty)-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+  = do  { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs         ; let doc = TypeSigCtx (ppr_sig_bndrs vs)         ; (new_ty, fvs) <- rnHsSigWcType doc ty-        ; return (TypeSig noExtField new_vs new_ty, fvs) }+        ; return (TypeSig noAnn new_vs new_ty, fvs) }  renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)   = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures         ; when (is_deflt && not defaultSigs_on) $           addErr (defaultSigErr sig)-        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs+        ; new_v <- mapM (lookupSigOccRnN ctxt sig) vs         ; (new_ty, fvs) <- rnHsSigType ty_ctxt TypeLevel ty-        ; return (ClassOpSig noExtField is_deflt new_v new_ty, fvs) }+        ; return (ClassOpSig noAnn is_deflt new_v new_ty, fvs) }   where     (v1:_) = vs     ty_ctxt = GenericCtx (text "a class method signature for"@@ -980,7 +985,7 @@           -- GHC.Hs.Type).         ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type")             (getLHsInstDeclHead new_ty)-        ; return (SpecInstSig noExtField src new_ty,fvs) }+        ; return (SpecInstSig noAnn src new_ty,fvs) }   where     doc = SpecInstSigCtx     inf_msg = Just (text "Inferred type variables are not allowed")@@ -992,9 +997,9 @@ renameSig ctxt sig@(SpecSig _ v tys inl)   = do  { new_v <- case ctxt of                      TopSigCtxt {} -> lookupLocatedOccRn v-                     _             -> lookupSigOccRn ctxt sig v+                     _             -> lookupSigOccRnN ctxt sig v         ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys-        ; return (SpecSig noExtField new_v new_ty inl, fvs) }+        ; return (SpecSig noAnn new_v new_ty inl, fvs) }   where     ty_ctxt = GenericCtx (text "a SPECIALISE signature for"                           <+> quotes (ppr v))@@ -1003,28 +1008,28 @@            ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }  renameSig ctxt sig@(InlineSig _ v s)-  = do  { new_v <- lookupSigOccRn ctxt sig v-        ; return (InlineSig noExtField new_v s, emptyFVs) }+  = do  { new_v <- lookupSigOccRnN ctxt sig v+        ; return (InlineSig noAnn new_v s, emptyFVs) }  renameSig ctxt (FixSig _ fsig)   = do  { new_fsig <- rnSrcFixityDecl ctxt fsig-        ; return (FixSig noExtField new_fsig, emptyFVs) }+        ; return (FixSig noAnn new_fsig, emptyFVs) }  renameSig ctxt sig@(MinimalSig _ s (L l bf))-  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf-       return (MinimalSig noExtField s (L l new_bf), emptyFVs)+  = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf+       return (MinimalSig noAnn s (L l new_bf), emptyFVs)  renameSig ctxt sig@(PatSynSig _ vs ty)-  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+  = do  { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs         ; (ty', fvs) <- rnHsSigType ty_ctxt TypeLevel ty-        ; return (PatSynSig noExtField new_vs ty', fvs) }+        ; return (PatSynSig noAnn new_vs ty', fvs) }   where     ty_ctxt = GenericCtx (text "a pattern synonym signature for"                           <+> ppr_sig_bndrs vs)  renameSig ctxt sig@(SCCFunSig _ st v s)-  = do  { new_v <- lookupSigOccRn ctxt sig v-        ; return (SCCFunSig noExtField st new_v s, emptyFVs) }+  = do  { new_v <- lookupSigOccRnN ctxt sig v+        ; return (SCCFunSig noAnn st new_v s, emptyFVs) }  -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn@@ -1033,11 +1038,11 @@        new_mty  <- traverse lookupLocatedOccRn mty         this_mod <- fmap tcg_mod getGblEnv-       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do+       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $          -- Why 'any'? See Note [Orphan COMPLETE pragmas]          addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError -       return (CompleteMatchSig noExtField s (L l new_bf) new_mty, emptyFVs)+       return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs)   where     orphanError :: SDoc     orphanError =@@ -1067,7 +1072,7 @@ complexity of supporting them properly doesn't seem worthwhile. -} -ppr_sig_bndrs :: [Located RdrName] -> SDoc+ppr_sig_bndrs :: [LocatedN RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)  okHsSig :: HsSigCtxt -> LSig (GhcPass a) -> Bool@@ -1112,7 +1117,7 @@      (CompleteMatchSig {}, _)              -> False  --------------------findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]+findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors@@ -1124,6 +1129,7 @@ findDupSigs sigs   = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)   where+    expand_sig :: Sig GhcPs -> [(LocatedN RdrName, Sig GhcPs)] -- AZ     expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)     expand_sig sig@(InlineSig _ n _)             = [(n,sig)]     expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]@@ -1132,6 +1138,7 @@     expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]     expand_sig _ = [] +    matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ     matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2     mtch (FixSig {})           (FixSig {})         = True     mtch (InlineSig {})        (InlineSig {})      = True@@ -1156,45 +1163,59 @@ ************************************************************************ -} -rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext GhcRn-             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-             -> MatchGroup GhcPs (Located (body GhcPs))-             -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)-rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })+type AnnoBody body+  = ( Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL+    , Anno [LocatedA (Match GhcPs (LocatedA (body GhcPs)))] ~ SrcSpanAnnL+    , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA+    , Anno (Match GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan+    , Anno (GRHS GhcPs (LocatedA (body GhcPs))) ~ SrcSpan+    , Outputable (body GhcPs)+    )++rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn+             -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))+             -> MatchGroup GhcPs (LocatedA (body GhcPs))+             -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars)+rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })   = do { empty_case_ok <- xoptM LangExt.EmptyCase        ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms-       ; return (mkMatchGroup origin new_ms, ms_fvs) }+       ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) } -rnMatch :: Outputable (body GhcPs) => HsMatchContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> LMatch GhcPs (Located (body GhcPs))-        -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)-rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)+rnMatch :: AnnoBody body+        => HsMatchContext GhcRn+        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))+        -> LMatch GhcPs (LocatedA (body GhcPs))+        -> RnM (LMatch GhcRn (LocatedA (body GhcRn)), FreeVars)+rnMatch ctxt rnBody = wrapLocFstMA (rnMatch' ctxt rnBody) -rnMatch' :: Outputable (body GhcPs) => HsMatchContext GhcRn-         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-         -> Match GhcPs (Located (body GhcPs))-         -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)+rnMatch' :: (AnnoBody body)+         => HsMatchContext GhcRn+         -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))+         -> Match GhcPs (LocatedA (body GhcPs))+         -> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })-  = do  { -- Note that there are no local fixity decls for matches-        ; rnPats ctxt pats      $ \ pats' -> do+  = rnPats ctxt pats $ \ pats' -> do         { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss         ; let mf' = case (ctxt, mf) of                       (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })                                             -> mf { mc_fun = L lf funid }                       _                     -> ctxt-        ; return (Match { m_ext = noExtField, m_ctxt = mf', m_pats = pats'-                        , m_grhss = grhss'}, grhss_fvs ) }}+        ; return (Match { m_ext = noAnn, m_ctxt = mf', m_pats = pats'+                        , m_grhss = grhss'}, grhss_fvs ) }  emptyCaseErr :: HsMatchContext GhcRn -> SDoc-emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)+emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)                        2 (text "Use EmptyCase to allow this")   where-    pp_ctxt = case ctxt of-                CaseAlt    -> text "case expression"-                LambdaExpr -> text "\\case expression"-                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt+    pp_ctxt :: HsMatchContext GhcRn -> SDoc+    pp_ctxt c = case c of+      CaseAlt       -> text "case expression"+      LambdaExpr    -> text "\\case expression"+      ArrowMatchCtxt ArrowCaseAlt -> text "case expression"+      ArrowMatchCtxt KappaExpr    -> text "kappa abstraction"+      _             -> text "(unexpected)" <+> pprMatchContextNoun c  {- ************************************************************************@@ -1204,34 +1225,36 @@ ************************************************************************ -} -rnGRHSs :: HsMatchContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> GRHSs GhcPs (Located (body GhcPs))-        -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)-rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))+rnGRHSs :: AnnoBody body+        => HsMatchContext GhcRn+        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))+        -> GRHSs GhcPs (LocatedA (body GhcPs))+        -> RnM (GRHSs GhcRn (LocatedA (body GhcRn)), FreeVars)+rnGRHSs ctxt rnBody (GRHSs _ grhss binds)   = rnLocalBindsAndThen binds   $ \ binds' _ -> do     (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss-    return (GRHSs noExtField grhss' (L l binds'), fvGRHSs)+    return (GRHSs emptyComments grhss' binds', fvGRHSs) -rnGRHS :: HsMatchContext GhcRn-       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-       -> LGRHS GhcPs (Located (body GhcPs))-       -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)+rnGRHS :: AnnoBody body+       => HsMatchContext GhcRn+       -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))+       -> LGRHS GhcPs (LocatedA (body GhcPs))+       -> RnM (LGRHS GhcRn (LocatedA (body GhcRn)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)  rnGRHS' :: HsMatchContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> GRHS GhcPs (Located (body GhcPs))-        -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)+        -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))+        -> GRHS GhcPs (LocatedA (body GhcPs))+        -> RnM (GRHS GhcRn (LocatedA (body GhcRn)), FreeVars) rnGRHS' ctxt rnBody (GRHS _ guards rhs)   = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards-        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->+        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnExpr guards $ \ _ ->                                     rnBody rhs          ; unless (pattern_guards_allowed || is_standard_guard guards')                  (addWarn NoReason (nonStdGuardErr guards')) -        ; return (GRHS noExtField guards' rhs', fvs) }+        ; return (GRHS noAnn guards' rhs', fvs) }   where         -- Standard Haskell 1.4 guards are just a single boolean         -- expression, rather than a list of qualifiers as in the@@ -1263,9 +1286,9 @@       = do names <- concatMapM lookup_one fnames            return (FixitySig noExtField names fixity) -    lookup_one :: Located RdrName -> RnM [Located Name]+    lookup_one :: LocatedN RdrName -> RnM [LocatedN Name]     lookup_one (L name_loc rdr_name)-      = setSrcSpan name_loc $+      = setSrcSpanA name_loc $                     -- This lookup will fail if the name is not defined in the                     -- same binding group as this fixity declaration.         do names <- lookupLocalTcNames sig_ctxt what rdr_name@@ -1280,13 +1303,13 @@ ************************************************************************ -} -dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()+dupSigDeclErr :: NonEmpty (LocatedN RdrName, Sig GhcPs) -> RnM () dupSigDeclErr pairs@((L loc name, sig) :| _)-  = addErrAt loc $+  = addErrAt (locA loc) $     vcat [ text "Duplicate" <+> what_it_is            <> text "s for" <+> quotes (ppr name)          , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest-                                       $ map (getLoc . fst)+                                       $ map (getLocA . fst)                                        $ toList pairs)          ]   where@@ -1294,7 +1317,7 @@  misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig)-  = addErrAt loc $+  = addErrAt (locA loc) $     sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]  defaultSigErr :: Sig GhcPs -> SDoc@@ -1307,7 +1330,9 @@   = hang (text "Bindings in hs-boot files are not allowed")        2 (ppr mbinds) -nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc+nonStdGuardErr :: (Outputable body,+                   Anno (Stmt GhcRn body) ~ SrcSpanAnnA)+               => [LStmtLR GhcRn GhcRn body] -> SDoc nonStdGuardErr guards   = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")        4 (interpp'SP guards)@@ -1319,8 +1344,8 @@  dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _)-  = addErrAt loc $+  = addErrAt (locA loc) $     vcat [ text "Multiple minimal complete definitions"-         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLoc sigs)+         , text "at" <+> vcat (map ppr $ sortBy SrcLoc.leftmost_smallest $ map getLocA sigs)          , text "Combine alternative minimal complete definitions with `|'" ] dupMinimalSigErr [] = panic "dupMinimalSigErr"

− GHC/Rename/Doc.hs

@@ -1,25 +0,0 @@-{-# LANGUAGE ViewPatterns #-}--module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where--import GHC.Prelude--import GHC.Tc.Types-import GHC.Hs-import GHC.Types.SrcLoc---rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)-rnMbLHsDoc mb_doc = case mb_doc of-  Just doc -> do-    doc' <- rnLHsDoc doc-    return (Just doc')-  Nothing -> return Nothing--rnLHsDoc :: LHsDocString -> RnM LHsDocString-rnLHsDoc (L pos doc) = do-  doc' <- rnHsDoc doc-  return (L pos doc')--rnHsDoc :: HsDocString -> RnM HsDocString-rnHsDoc = pure

GHC/Rename/Env.hs view

@@ -1,3 +1,9 @@+{-# LANGUAGE CPP            #-}+{-# LANGUAGE DeriveFunctor  #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 @@ -5,33 +11,38 @@  -} -{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}- module GHC.Rename.Env (         newTopSrcBinder,-        lookupLocatedTopBndrRn, lookupTopBndrRn,++        lookupLocatedTopBndrRn, lookupLocatedTopBndrRnN, lookupTopBndrRn,+         lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,         lookupLocalOccRn_maybe, lookupInfoOccRn,         lookupLocalOccThLvl_maybe, lookupLocalOccRn,         lookupTypeOccRn,         lookupGlobalOccRn, lookupGlobalOccRn_maybe,-        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, +        AmbiguousResult(..),+        lookupExprOccRn,+        lookupRecFieldOcc,+        lookupRecFieldOcc_update,+         ChildLookupResult(..),         lookupSubBndrOcc_helper,         combineChildLookupResult, -- Called by lookupChildrenExport -        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,-        lookupSigCtxtOccRn,+        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, lookupSigOccRnN,+        lookupSigCtxtOccRn, lookupSigCtxtOccRnN, -        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,+        lookupInstDeclBndr, lookupFamInstName,         lookupConstructorFields,          lookupGreAvailRn,          -- Rebindable Syntax-        lookupSyntax, lookupSyntaxExpr, lookupSyntaxName, lookupSyntaxNames,-        lookupIfThenElse, lookupReboundIf,+        lookupSyntax, lookupSyntaxExpr, lookupSyntaxNames,+        lookupSyntaxName,+        lookupIfThenElse,          -- QualifiedDo         lookupQualifiedDoExpr, lookupQualifiedDo,@@ -54,27 +65,27 @@ import GHC.Iface.Env import GHC.Hs import GHC.Types.Name.Reader-import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad-import GHC.Parser.PostProcess ( filterCTuple, setRdrNameSpace )-import GHC.Builtin.RebindableNames+import GHC.Parser.PostProcess ( setRdrNameSpace ) import GHC.Builtin.Types import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Env import GHC.Types.Avail import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Warnings  ( WarningTxt, pprWarningTxtForMsg ) import GHC.Core.ConLike import GHC.Core.DataCon import GHC.Core.TyCon-import GHC.Utils.Error  ( MsgDoc ) import GHC.Builtin.Names( rOOT_MAIN )-import GHC.Types.Basic  ( pprWarningTxtForMsg, TopLevelFlag(..), TupleSort(..) )+import GHC.Types.Basic  ( TopLevelFlag(..), TupleSort(..) ) import GHC.Types.SrcLoc as SrcLoc import GHC.Utils.Outputable as Outputable import GHC.Types.Unique.Set ( uniqSetAny ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Maybe import GHC.Driver.Session import GHC.Data.FastString@@ -86,8 +97,10 @@ import qualified Data.Semigroup as Semi import Data.Either      ( partitionEithers ) import Data.List        ( find, sortBy )+import qualified Data.List.NonEmpty as NE import Control.Arrow    ( first ) import Data.Function+import GHC.Types.FieldLabel  {- *********************************************************@@ -155,7 +168,7 @@ Note [Handling of deprecations] -} -newTopSrcBinder :: Located RdrName -> RnM Name+newTopSrcBinder :: LocatedN RdrName -> RnM Name newTopSrcBinder (L loc rdr_name)   | Just name <- isExact_maybe rdr_name   =     -- This is here to catch@@ -170,7 +183,7 @@     if isExternalName name then       do { this_mod <- getModule          ; unless (this_mod == nameModule name)-                  (addErrAt loc (badOrigBinding rdr_name))+                  (addErrAt (locA loc) (badOrigBinding rdr_name))          ; return name }     else   -- See Note [Binders in Template Haskell] in "GHC.ThToHs"       do { this_mod <- getModule@@ -179,7 +192,7 @@   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name   = do  { this_mod <- getModule         ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)-                 (addErrAt loc (badOrigBinding rdr_name))+                 (addErrAt (locA loc) (badOrigBinding rdr_name))         -- When reading External Core we get Orig names as binders,         -- but they should agree with the module gotten from the monad         --@@ -197,11 +210,11 @@         -- the RdrName, not from the environment.  In principle, it'd be fine to         -- have an arbitrary mixture of external core definitions in a single module,         -- (apart from module-initialisation issues, perhaps).-        ; newGlobalBinder rdr_mod rdr_occ loc }+        ; newGlobalBinder rdr_mod rdr_occ (locA loc) }    | otherwise   = do  { when (isQual rdr_name)-                 (addErrAt loc (badQualBndrErr rdr_name))+                 (addErrAt (locA loc) (badQualBndrErr rdr_name))                 -- Binders should not be qualified; if they are, and with a different                 -- module name, we get a confusing "M.T is not in scope" error later @@ -210,11 +223,11 @@                 -- We are inside a TH bracket, so make an *Internal* name                 -- See Note [Top-level Names in Template Haskell decl quotes] in GHC.Rename.Names              do { uniq <- newUnique-                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }+                ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) }           else              do { this_mod <- getModule-                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)-                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr (locA loc))+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (locA loc) }         }  {-@@ -263,7 +276,7 @@          ; env <- getGlobalRdrEnv         ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of-            [gre] -> return (gre_name gre)+            [gre] -> return (greMangledName gre)             _     -> do -- Ambiguous (can't happen) or unbound                         traceRn "lookupTopBndrRN fail" (ppr rdr_name)                         unboundName WL_LocalTop rdr_name@@ -272,10 +285,13 @@ lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn +lookupLocatedTopBndrRnN :: LocatedN RdrName -> RnM (LocatedN Name)+lookupLocatedTopBndrRnN = wrapLocMA lookupTopBndrRn+ -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames]. -- This never adds an error, but it may return one, see -- Note [Errors in lookup functions]-lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)+lookupExactOcc_either :: Name -> RnM (Either SDoc Name) lookupExactOcc_either name   | Just thing <- wiredInNameTyThing_maybe name   , Just tycon <- case thing of@@ -303,9 +319,9 @@                               Nothing  -> []              gres = [ gre | occ <- main_occ : demoted_occs                           , gre <- lookupGlobalRdrEnv env occ-                          , gre_name gre == name ]+                          , greMangledName gre == name ]        ; case gres of-           [gre] -> return (Right (gre_name gre))+           [gre] -> return (Right (greMangledName gre))             []    -> -- See Note [Splicing Exact names]                     do { lcl_env <- getLocalRdrEnv@@ -322,13 +338,13 @@            gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]        } -sameNameErr :: [GlobalRdrElt] -> MsgDoc+sameNameErr :: [GlobalRdrElt] -> SDoc sameNameErr [] = panic "addSameNameErr: empty list" sameNameErr gres@(_ : _)   = hang (text "Same exact name in multiple name-spaces:")        2 (vcat (map pp_one sorted_names) $$ th_hint)   where-    sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map gre_name gres)+    sorted_names = sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan) (map greMangledName gres)     pp_one name       = hang (pprNameSpace (occNameSpace (getOccName name))               <+> quotes (ppr name) <> comma)@@ -374,12 +390,12 @@     doc = what <+> text "of class" <+> quotes (ppr cls)  ------------------------------------------------lookupFamInstName :: Maybe Name -> Located RdrName-                  -> RnM (Located Name)+lookupFamInstName :: Maybe Name -> LocatedN RdrName+                  -> RnM (LocatedN Name) -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f GHC.Rename.Bind.rnMethodBind-  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr+  = wrapLocMA (lookupInstDeclBndr cls (text "associated type")) tc_rdr lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*   = lookupLocatedOccRn tc_rdr @@ -431,7 +447,7 @@            NotExactOrOrig     -> k }  data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name-                       | ExactOrOrigError MsgDoc -- ^ The RdrName was an Exact+                       | ExactOrOrigError SDoc -- ^ The RdrName was an Exact                                                  -- or Orig, but there was an                                                  -- error looking up the Name                        | NotExactOrOrig -- ^ The RdrName is neither an Exact nor@@ -460,8 +476,8 @@ places where we want to attempt looking up a name, but it's not the end of the world if we don't find it. -For example, see lookupThName_maybe: It calls lookupGlobalOccRn_maybe multiple-times for varying names in different namespaces. lookupGlobalOccRn_maybe should+For example, see lookupThName_maybe: It calls lookupOccRn_maybe multiple+times for varying names in different namespaces. lookupOccRn_maybe should therefore never attach an error, instead just return a Nothing.  For these _maybe/_either variant functions then, avoid calling further lookup@@ -475,7 +491,7 @@ -- flag is on, take account of the data constructor name to -- disambiguate which field to use. ----- See Note [DisambiguateRecordFields].+-- See Note [DisambiguateRecordFields] and Note [NoFieldSelectors]. lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual                                 -- Just con => use data con to disambiguate                   -> RdrName@@ -489,23 +505,58 @@        ; env <- getGlobalRdrEnv        ; let lbl      = occNameFS (rdrNameOcc rdr_name)              mb_field = do fl <- find ((== lbl) . flLabel) flds-                           -- We have the label, now check it is in-                           -- scope (with the correct qualifier if-                           -- there is one, hence calling pickGREs).+                           -- We have the label, now check it is in scope.  If+                           -- there is a qualifier, use pickGREs to check that+                           -- the qualifier is correct, and return the filtered+                           -- GRE so we get import usage right (see #17853).                            gre <- lookupGRE_FieldLabel env fl-                           guard (not (isQual rdr_name-                                         && null (pickGREs rdr_name [gre])))-                           return (fl, gre)+                           if isQual rdr_name+                             then do gre' <- listToMaybe (pickGREs rdr_name [gre])+                                     return (fl, gre')+                              else return (fl, gre)        ; case mb_field of            Just (fl, gre) -> do { addUsedGRE True gre                                 ; return (flSelector fl) }-           Nothing        -> lookupGlobalOccRn rdr_name }+           Nothing        -> lookupGlobalOccRn' WantBoth rdr_name }              -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]   | otherwise   -- This use of Global is right as we are looking up a selector which   -- can only be defined at the top level.-  = lookupGlobalOccRn rdr_name+  = lookupGlobalOccRn' WantBoth rdr_name +-- | Look up an occurrence of a field in a record update, returning the selector+-- name.+--+-- Unlike construction and pattern matching with @-XDisambiguateRecordFields@+-- (see 'lookupRecFieldOcc'), there is no data constructor to help disambiguate,+-- so this may be ambiguous if the field is in scope multiple times.  However we+-- ignore non-fields in scope with the same name if @-XDisambiguateRecordFields@+-- is on (see Note [DisambiguateRecordFields for updates]).+--+-- Here a field is in scope even if @NoFieldSelectors@ was enabled at its+-- definition site (see Note [NoFieldSelectors]).+lookupRecFieldOcc_update+  :: DuplicateRecordFields+  -> RdrName+  -> RnM AmbiguousResult+lookupRecFieldOcc_update dup_fields_ok rdr_name = do+    disambig_ok <- xoptM LangExt.DisambiguateRecordFields+    let want | disambig_ok = WantField+             | otherwise   = WantBoth+    mr <- lookupGlobalOccRn_overloaded dup_fields_ok want rdr_name+    case mr of+        Just r  -> return r+        Nothing  -- Try again if we previously looked only for fields, see+                 -- Note [DisambiguateRecordFields for updates]+          | disambig_ok -> do mr' <- lookupGlobalOccRn_overloaded dup_fields_ok WantBoth rdr_name+                              case mr' of+                                  Just r -> return r+                                  Nothing -> unbound+          | otherwise   -> unbound+  where+    unbound = UnambiguousGre . NormalGreName <$> unboundName WL_Global rdr_name++ {- Note [DisambiguateRecordFields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we are looking up record fields in record construction or pattern@@ -551,6 +602,42 @@ is unqualified.  +Note [DisambiguateRecordFields for updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are looking up record fields in record update, we can take advantage of+the fact that we know we are looking for a field, even though we do not know the+data constructor name (as in Note [DisambiguateRecordFields]), provided the+-XDisambiguateRecordFields flag is on.++For example, consider:++   module N where+     f = ()++   {-# LANGUAGE DisambiguateRecordFields #-}+   module M where+     import N (f)+     data T = MkT { f :: Int }+     t = MkT { f = 1 }  -- unambiguous because MkT determines which field we mean+     u = t { f = 2 }    -- unambiguous because we ignore the non-field 'f'++This works by lookupRecFieldOcc_update using 'WantField :: FieldsOrSelectors'+when looking up the field name, so that 'filterFieldGREs' will later ignore any+non-fields in scope.  Of course, if a record update has two fields in scope with+the same name, it is still ambiguous.++If we do not find anything when looking only for fields, we try again allowing+fields or non-fields.  This leads to a better error message if the user+mistakenly tries to use a non-field name in a record update:++    f = ()+    e x = x { f = () }++Unlike with constructors or pattern-matching, we do not allow the module+qualifier to be omitted, because we do not have a data constructor from which to+determine it.++ Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Whenever we fail to find the field or it is not in scope, mb_field@@ -594,7 +681,7 @@ lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name   | isUnboundName parent     -- Avoid an error cascade-  = return (FoundName NoParent (mkUnboundNameRdr rdr_name))+  = return (FoundChild NoParent (NormalGreName (mkUnboundNameRdr rdr_name)))    | otherwise = do   gre_env <- getGlobalRdrEnv@@ -620,20 +707,9 @@     where         -- Convert into FieldLabel if necessary         checkFld :: GlobalRdrElt -> RnM ChildLookupResult-        checkFld g@GRE{gre_name, gre_par} = do+        checkFld g@GRE{gre_name,gre_par} = do           addUsedGRE warn_if_deprec g-          return $ case gre_par of-            FldParent _ mfs ->-              FoundFL  (fldParentToFieldLabel gre_name mfs)-            _ -> FoundName gre_par gre_name--        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel-        fldParentToFieldLabel name mfs =-          case mfs of-            Nothing ->-              let fs = occNameFS (nameOccName name)-              in FieldLabel fs False name-            Just fs -> FieldLabel fs True name+          return $ FoundChild gre_par gre_name          -- Called when we find no matching GREs after disambiguation but         -- there are three situations where this happens.@@ -648,31 +724,29 @@         noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult         noMatchingParentErr original_gres = do           traceRn "npe" (ppr original_gres)-          overload_ok <- xoptM LangExt.DuplicateRecordFields+          dup_fields_ok <- xoptM LangExt.DuplicateRecordFields           case original_gres of             [] ->  return NameNotFound             [g] -> return $ IncorrectParent parent-                              (gre_name g) (ppr $ gre_name g)+                              (gre_name g)                               [p | Just p <- [getParent g]]-            gss@(g:_:_) ->-              if all isRecFldGRE gss && overload_ok+            gss@(g:gss'@(_:_)) ->+              if all isRecFldGRE gss && dup_fields_ok                 then return $                       IncorrectParent parent                         (gre_name g)-                        (ppr $ expectJust "noMatchingParentErr" (greLabel g))                         [p | x <- gss, Just p <- [getParent x]]-                else mkNameClashErr gss+                else mkNameClashErr $ g NE.:| gss' -        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        mkNameClashErr :: NE.NonEmpty GlobalRdrElt -> RnM ChildLookupResult         mkNameClashErr gres = do           addNameClashErrRn rdr_name gres-          return (FoundName (gre_par (head gres)) (gre_name (head gres)))+          return (FoundChild (gre_par (NE.head gres)) (gre_name (NE.head gres)))          getParent :: GlobalRdrElt -> Maybe Name         getParent (GRE { gre_par = p } ) =           case p of             ParentIs cur_parent -> Just cur_parent-            FldParent { par_is = cur_parent } -> Just cur_parent             NoParent -> Nothing          picked_gres :: [GlobalRdrElt] -> DisambigInfo@@ -702,7 +776,7 @@           -- The GRE has no parent. It could be a pattern synonym.        | DisambiguatedOccurrence GlobalRdrElt           -- The parent of the GRE is the correct parent-       | AmbiguousOccurrence [GlobalRdrElt]+       | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt)           -- For example, two normal identifiers with the same name are in           -- scope. They will both be resolved to "UniqueOccurrence" and the           -- monoid will combine them to this failing case.@@ -722,13 +796,13 @@   NoOccurrence <> m = m   m <> NoOccurrence = m   UniqueOccurrence g <> UniqueOccurrence g'-    = AmbiguousOccurrence [g, g']+    = AmbiguousOccurrence $ g NE.:| [g']   UniqueOccurrence g <> AmbiguousOccurrence gs-    = AmbiguousOccurrence (g:gs)+    = AmbiguousOccurrence (g `NE.cons` gs)   AmbiguousOccurrence gs <> UniqueOccurrence g'-    = AmbiguousOccurrence (g':gs)+    = AmbiguousOccurrence (g' `NE.cons` gs)   AmbiguousOccurrence gs <> AmbiguousOccurrence gs'-    = AmbiguousOccurrence (gs ++ gs')+    = AmbiguousOccurrence (gs Semi.<> gs')  instance Monoid DisambigInfo where   mempty = NoOccurrence@@ -740,11 +814,9 @@ data ChildLookupResult       = NameNotFound                --  We couldn't find a suitable name       | IncorrectParent Name        -- Parent-                        Name        -- Name of thing we were looking for-                        SDoc        -- How to print the name+                        GreName     -- Child we were looking for                         [Name]      -- List of possible parents-      | FoundName Parent Name       --  We resolved to a normal name-      | FoundFL FieldLabel          --  We resolved to a FL+      | FoundChild Parent GreName   --  We resolved to a child  -- | Specialised version of msum for RnM ChildLookupResult combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult@@ -757,27 +829,25 @@  instance Outputable ChildLookupResult where   ppr NameNotFound = text "NameNotFound"-  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n-  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls-  ppr (IncorrectParent p n td ns) = text "IncorrectParent"-                                  <+> hsep [ppr p, ppr n, td, ppr ns]+  ppr (FoundChild p n) = text "Found:" <+> ppr p <+> ppr n+  ppr (IncorrectParent p n ns) = text "IncorrectParent"+                                  <+> hsep [ppr p, ppr n, ppr ns]  lookupSubBndrOcc :: Bool                  -> Name     -- Parent                  -> SDoc                  -> RdrName-                 -> RnM (Either MsgDoc Name)+                 -> RnM (Either SDoc Name) -- Find all the things the rdr-name maps to -- and pick the one with the right parent namep lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do   res <--    lookupExactOrOrig rdr_name (FoundName NoParent) $+    lookupExactOrOrig rdr_name (FoundChild NoParent . NormalGreName) $       -- This happens for built-in classes, see mod052 for example       lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name   case res of     NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))-    FoundName _p n -> return (Right n)-    FoundFL fl  ->  return (Right (flSelector fl))+    FoundChild _p child -> return (Right (greNameMangledName child))     IncorrectParent {}          -- See [Mismatched class methods and associated type families]          -- in TcInstDecls.@@ -921,8 +991,9 @@ -}  -lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)-lookupLocatedOccRn = wrapLocM lookupOccRn+lookupLocatedOccRn :: GenLocated (SrcSpanAnn' ann) RdrName+                   -> TcRn (GenLocated (SrcSpanAnn' ann) Name)+lookupLocatedOccRn = wrapLocMA lookupOccRn  lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Just look in the local environment@@ -954,6 +1025,7 @@            Nothing   -> unboundName WL_LocalOnly rdr_name }  -- lookupTypeOccRn looks up an optionally promoted RdrName.+-- Used for looking up type variables. lookupTypeOccRn :: RdrName -> RnM Name -- see Note [Demotion] lookupTypeOccRn rdr_name@@ -1005,6 +1077,17 @@            , text "instead of"            , quotes (ppr name) <> dot ] +-- If the given RdrName can be promoted to the type level and its promoted variant is in scope,+-- lookup_promoted returns the corresponding type-level Name.+-- Otherwise, the function returns Nothing.+-- See Note [Promotion] below.+lookup_promoted :: RdrName -> RnM (Maybe Name)+lookup_promoted rdr_name+  | Just promoted_rdr <- promoteRdrName rdr_name+  = lookupOccRn_maybe promoted_rdr+  | otherwise+  = return Nothing+ badVarInType :: RdrName -> RnM Name badVarInType rdr_name   = do { addErr (text "Illegal promoted term variable in a type:"@@ -1040,6 +1123,26 @@  The final result (after the renamer) will be:   HsTyVar ("Zero", DataName)++Note [Promotion]+~~~~~~~~~~~~~~~+When the user mentions a type constructor or a type variable in a+term-level context, then we report that a value identifier was expected+instead of a type-level one. That makes error messages more precise.+Previously, such errors contained only the info that a given value was out of scope (#18740).+We promote the namespace of RdrName and look up after that+(see the functions promotedRdrName and lookup_promoted).++In particular, we have the following error message+  • Illegal term-level use of the type constructor ‘Int’+      imported from ‘Prelude’ (and originally defined in ‘GHC.Types’)+  • In the first argument of ‘id’, namely ‘Int’+    In the expression: id Int+    In an equation for ‘x’: x = id Int++when the user writes the following declaration++  x = id Int -}  lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName@@ -1049,21 +1152,38 @@       [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name       , globalLookup rdr_name ] +-- Used outside this module only by TH name reification (lookupName, lookupThName_maybe) lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id -lookupOccRn_overloaded :: Bool -> RdrName-                       -> RnM (Maybe (Either Name [Name]))-lookupOccRn_overloaded overload_ok-  = lookupOccRnX_maybe global_lookup Left-      where-        global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))-        global_lookup n =-          runMaybeT . msum . map MaybeT $-            [ lookupGlobalOccRn_overloaded overload_ok n-            , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]-+-- | Look up a 'RdrName' used as a variable in an expression.+--+-- This may be a local variable, global variable, or one or more record selector+-- functions.  It will not return record fields created with the+-- @NoFieldSelectors@ extension (see Note [NoFieldSelectors]).  The+-- 'DuplicateRecordFields' argument controls whether ambiguous fields will be+-- allowed (resulting in an 'AmbiguousFields' result being returned).+--+-- If the name is not in scope at the term level, but its promoted equivalent is+-- in scope at the type level, the lookup will succeed (so that the type-checker+-- can report a more informative error later).  See Note [Promotion].+--+lookupExprOccRn+  :: DuplicateRecordFields -> RdrName+  -> RnM (Maybe AmbiguousResult)+lookupExprOccRn dup_fields_ok rdr_name+  = do { mb_name <- lookupOccRnX_maybe global_lookup (UnambiguousGre . NormalGreName) rdr_name+       ; case mb_name of+           Nothing   -> fmap @Maybe (UnambiguousGre . NormalGreName) <$> lookup_promoted rdr_name+                        -- See Note [Promotion].+                        -- We try looking up the name as a+                        -- type constructor or type variable, if+                        -- we failed to look up the name at the term level.+           p         -> return p } +  where+    global_lookup :: RdrName -> RnM (Maybe AmbiguousResult)+    global_lookup = lookupGlobalOccRn_overloaded dup_fields_ok WantNormal  lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- Looks up a RdrName occurrence in the top-level@@ -1072,31 +1192,38 @@ -- No filter function; does not report an error on failure -- See Note [Errors in lookup functions] -- Uses addUsedRdrName to record use and deprecations+--+-- Used directly only by getLocalNonValBinders (new_assoc). lookupGlobalOccRn_maybe rdr_name =-  lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base rdr_name)+  lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base WantNormal rdr_name)  lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment.  Adds an error message if the RdrName is not in scope. -- You usually want to use "lookupOccRn" which also looks in the local -- environment.-lookupGlobalOccRn rdr_name =+--+-- Used by exports_from_avail+lookupGlobalOccRn = lookupGlobalOccRn' WantNormal++lookupGlobalOccRn' :: FieldsOrSelectors -> RdrName -> RnM Name+lookupGlobalOccRn' fos rdr_name =   lookupExactOrOrig rdr_name id $ do-    mn <- lookupGlobalOccRn_base rdr_name+    mn <- lookupGlobalOccRn_base fos rdr_name     case mn of       Just n -> return n       Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)                     ; unboundName WL_Global rdr_name } --- Looks up a RdrName occurence in the GlobalRdrEnv and with+-- Looks up a RdrName occurrence in the GlobalRdrEnv and with -- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first. -- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like -- 'Data.Map.elems' is typed, even if you didn't import Data.Map-lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name)-lookupGlobalOccRn_base rdr_name =+lookupGlobalOccRn_base :: FieldsOrSelectors -> RdrName -> RnM (Maybe Name)+lookupGlobalOccRn_base fos rdr_name =   runMaybeT . msum . map MaybeT $-    [ fmap gre_name <$> lookupGreRn_maybe rdr_name-    , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]+    [ fmap greMangledName <$> lookupGreRn_maybe fos rdr_name+    , fmap greNameMangledName <$> lookupOneQualifiedNameGHCi fos rdr_name ]                       -- This test is not expensive,                       -- and only happens for failed lookups @@ -1111,62 +1238,164 @@ lookupInfoOccRn rdr_name =   lookupExactOrOrig rdr_name (:[]) $     do { rdr_env <- getGlobalRdrEnv-       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)-       ; qual_ns <- lookupQualifiedNameGHCi rdr_name+       ; let ns = map greMangledName (lookupGRE_RdrName' rdr_name rdr_env)+       ; qual_ns <- map greNameMangledName <$> lookupQualifiedNameGHCi WantBoth rdr_name        ; return (ns ++ (qual_ns `minusList` ns)) }  -- | Like 'lookupOccRn_maybe', but with a more informative result if -- the 'RdrName' happens to be a record selector: -----   * Nothing         -> name not in scope (no error reported)---   * Just (Left x)   -> name uniquely refers to x,---                        or there is a name clash (reported)---   * Just (Right xs) -> name refers to one or more record selectors;---                        if overload_ok was False, this list will be---                        a singleton.--lookupGlobalOccRn_overloaded :: Bool -> RdrName-                             -> RnM (Maybe (Either Name [Name]))-lookupGlobalOccRn_overloaded overload_ok rdr_name =-  lookupExactOrOrig_maybe rdr_name (fmap Left) $-     do  { res <- lookupGreRn_helper rdr_name-         ; case res of-                GreNotFound  -> return Nothing-                OneNameMatch gre -> do-                  let wrapper = if isRecFldGRE gre then Right . (:[]) else Left-                  return $ Just (wrapper (gre_name gre))-                MultipleNames gres  | all isRecFldGRE gres && overload_ok ->-                  -- Don't record usage for ambiguous selectors-                  -- until we know which is meant-                  return $ Just (Right (map gre_name gres))-                MultipleNames gres  -> do+--   * Nothing                 -> name not in scope (no error reported)+--   * Just (UnambiguousGre x) -> name uniquely refers to x,+--                                or there is a name clash (reported)+--   * Just AmbiguousFields    -> name refers to two or more record fields+--                                (no error reported)+--+-- See Note [ Unbound vs Ambiguous Names ].+lookupGlobalOccRn_overloaded :: DuplicateRecordFields -> FieldsOrSelectors -> RdrName+                             -> RnM (Maybe AmbiguousResult)+lookupGlobalOccRn_overloaded dup_fields_ok fos rdr_name =+  lookupExactOrOrig_maybe rdr_name (fmap (UnambiguousGre . NormalGreName)) $+    do { res <- lookupGreRn_helper fos rdr_name+       ; case res of+           GreNotFound -> fmap UnambiguousGre <$> lookupOneQualifiedNameGHCi fos rdr_name+           OneNameMatch gre -> return $ Just (UnambiguousGre (gre_name gre))+           MultipleNames gres+             | all isRecFldGRE gres+             , dup_fields_ok == DuplicateRecordFields -> return $ Just AmbiguousFields+             | otherwise -> do                   addNameClashErrRn rdr_name gres-                  return (Just (Left (gre_name (head gres)))) }+                  return (Just (UnambiguousGre (gre_name (NE.head gres)))) }  +-- | Result of looking up an occurrence that might be an ambiguous field.+data AmbiguousResult+    = UnambiguousGre GreName+    -- ^ Occurrence picked out a single name, which may or may not belong to a+    -- field (or might be unbound, if an error has been reported already, per+    -- Note [ Unbound vs Ambiguous Names ]).+    | AmbiguousFields+    -- ^ Occurrence picked out two or more fields, and no non-fields.  For now+    -- this is allowed by DuplicateRecordFields in certain circumstances, as the+    -- type-checker may be able to disambiguate later.+++{-+Note [NoFieldSelectors]+~~~~~~~~~~~~~~~~~~~~~~~+The NoFieldSelectors extension allows record fields to be defined without+bringing the corresponding selector functions into scope.  However, such fields+may still be used in contexts such as record construction, pattern matching or+update. This requires us to distinguish contexts in which selectors are required+from those in which any field may be used.  For example:++  {-# LANGUAGE NoFieldSelectors #-}+  module M (T(foo), foo) where  -- T(foo) refers to the field,+                                -- unadorned foo to the value binding+    data T = MkT { foo :: Int }+    foo = ()++    bar = foo -- refers to the value binding, field ignored++  module N where+    import M (T(..))+    baz = MkT { foo = 3 } -- refers to the field+    oops = foo -- an error: the field is in scope but the value binding is not++Each 'FieldLabel' indicates (in the 'flHasFieldSelector' field) whether the+FieldSelectors extension was enabled in the defining module.  This allows them+to be filtered out by 'filterFieldGREs'.++Even when NoFieldSelectors is in use, we still generate selector functions+internally. For example, the expression+   getField @"foo" t+or (with dot-notation)+   t.foo+extracts the `foo` field of t::T, and hence needs the selector function+(see Note [HasField instances] in GHC.Tc.Instance.Class).  In order to avoid+name clashes with normal bindings reusing the names, selector names for such+fields are mangled just as for DuplicateRecordFields (see Note [FieldLabel] in+GHC.Types.FieldLabel).+++In many of the name lookup functions in this module we pass a FieldsOrSelectors+value, indicating what we are looking for:++ * WantNormal: fields are in scope only if they have an accompanying selector+   function, e.g. we are looking up a variable in an expression+   (lookupExprOccRn).++ * WantBoth: any name or field will do, regardless of whether the selector+   function is available, e.g. record updates (lookupRecFieldOcc_update) with+   NoDisambiguateRecordFields.++ * WantField: any field will do, regardless of whether the selector function is+   available, but ignoring any non-field names, e.g. record updates+   (lookupRecFieldOcc_update) with DisambiguateRecordFields.++-----------------------------------------------------------------------------------+  Context                                  FieldsOrSelectors+-----------------------------------------------------------------------------------+  Record construction/pattern match        WantBoth if NoDisambiguateRecordFields+  e.g. MkT { foo = 3 }                     (DisambiguateRecordFields is separate)++  Record update                            WantBoth if NoDisambiguateRecordFields+  e.g. e { foo = 3 }                       WantField if DisambiguateRecordFields++  :info in GHCi                            WantBoth++  Variable occurrence in expression        WantNormal+  Type variable, data constructor+  Pretty much everything else+-----------------------------------------------------------------------------------+-}++-- | When looking up GREs, we may or may not want to include fields that were+-- defined in modules with @NoFieldSelectors@ enabled.  See Note+-- [NoFieldSelectors].+data FieldsOrSelectors+    = WantNormal -- ^ Include normal names, and fields with selectors, but+                 -- ignore fields without selectors.+    | WantBoth   -- ^ Include normal names and all fields (regardless of whether+                 -- they have selectors).+    | WantField  -- ^ Include only fields, with or without selectors, ignoring+                 -- any non-fields in scope.+  deriving Eq++filterFieldGREs :: FieldsOrSelectors -> [GlobalRdrElt] -> [GlobalRdrElt]+filterFieldGREs fos = filter (allowGreName fos . gre_name)++allowGreName :: FieldsOrSelectors -> GreName -> Bool+allowGreName WantBoth   _                 = True+allowGreName WantNormal (FieldGreName fl) = flHasFieldSelector fl == FieldSelectors+allowGreName WantNormal (NormalGreName _) = True+allowGreName WantField  (FieldGreName  _) = True+allowGreName WantField  (NormalGreName _) = False++ -------------------------------------------------- --      Lookup in the Global RdrEnv of the module --------------------------------------------------  data GreLookupResult = GreNotFound                      | OneNameMatch GlobalRdrElt-                     | MultipleNames [GlobalRdrElt]+                     | MultipleNames (NE.NonEmpty GlobalRdrElt) -lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)+lookupGreRn_maybe :: FieldsOrSelectors -> RdrName -> RnM (Maybe GlobalRdrElt) -- Look up the RdrName in the GlobalRdrEnv --   Exactly one binding: records it as "used", return (Just gre) --   No bindings:         return Nothing --   Many bindings:       report "ambiguous", return an arbitrary (Just gre) -- Uses addUsedRdrName to record use and deprecations-lookupGreRn_maybe rdr_name+lookupGreRn_maybe fos rdr_name   = do-      res <- lookupGreRn_helper rdr_name+      res <- lookupGreRn_helper fos rdr_name       case res of         OneNameMatch gre ->  return $ Just gre         MultipleNames gres -> do           traceRn "lookupGreRn_maybe:NameClash" (ppr gres)           addNameClashErrRn rdr_name gres-          return $ Just (head gres)+          return $ Just (NE.head gres)         GreNotFound -> return Nothing  {-@@ -1198,14 +1427,16 @@   -- Internal Function-lookupGreRn_helper :: RdrName -> RnM GreLookupResult-lookupGreRn_helper rdr_name+lookupGreRn_helper :: FieldsOrSelectors -> RdrName -> RnM GreLookupResult+lookupGreRn_helper fos rdr_name   = do  { env <- getGlobalRdrEnv-        ; case lookupGRE_RdrName rdr_name env of+        ; case filterFieldGREs fos (lookupGRE_RdrName' rdr_name env) of             []    -> return GreNotFound             [gre] -> do { addUsedGRE True gre                         ; return (OneNameMatch gre) }-            gres  -> return (MultipleNames gres) }+            -- Don't record usage for ambiguous names+            -- until we know which is meant+            (gre:gres) -> return (MultipleNames (gre NE.:| gres)) }  lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo) -- Used in export lists@@ -1213,7 +1444,7 @@ -- Uses addUsedRdrName to record use and deprecations lookupGreAvailRn rdr_name   = do-      mb_gre <- lookupGreRn_helper rdr_name+      mb_gre <- lookupGreRn_helper WantNormal rdr_name       case mb_gre of         GreNotFound ->           do@@ -1228,7 +1459,7 @@                         -- Returning an unbound name here prevents an error                         -- cascade         OneNameMatch gre ->-          return (gre_name gre, availFromGRE gre)+          return (greMangledName gre, availFromGRE gre)   {-@@ -1285,7 +1516,7 @@     imp_gres = filterOut isLocalGRE gres  warnIfDeprecated :: GlobalRdrElt -> RnM ()-warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })+warnIfDeprecated gre@(GRE { gre_imp = iss })   | (imp_spec : _) <- iss   = do { dflags <- getDynFlags        ; this_mod <- getModule@@ -1301,6 +1532,7 @@   = return ()   where     occ = greOccName gre+    name = greMangledName gre     name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name     doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly") @@ -1321,7 +1553,6 @@   = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,     case gre_par gre of                      -- or its parent, is warn'd        ParentIs  p              -> mi_warn_fn (mi_final_exts iface) (nameOccName p)-       FldParent { par_is = p } -> mi_warn_fn (mi_final_exts iface) (nameOccName p)        NoParent                 -> Nothing  {-@@ -1371,12 +1602,49 @@ We DON'T do this Safe Haskell as we need to check imports. We can and should instead check the qualified import but at the moment this requires some refactoring so leave as a TODO++Note [DuplicateRecordFields and -fimplicit-import-qualified]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When DuplicateRecordFields is used, a single module can export the same OccName+multiple times, for example:++  module M where+    data S = MkS { foo :: Int }+    data T = MkT { foo :: Int }++Now if we refer to M.foo via -fimplicit-import-qualified, we need to report an+ambiguity error.+ -}  +-- | Like 'lookupQualifiedNameGHCi' but returning at most one name, reporting an+-- ambiguity error if there are more than one.+lookupOneQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM (Maybe GreName)+lookupOneQualifiedNameGHCi fos rdr_name = do+    gnames <- lookupQualifiedNameGHCi fos rdr_name+    case gnames of+      []              -> return Nothing+      [gname]         -> return (Just gname)+      (gname:gnames') -> do addNameClashErrRn rdr_name (toGRE gname NE.:| map toGRE gnames')+                            return (Just (NormalGreName (mkUnboundNameRdr rdr_name)))+  where+    -- Fake a GRE so we can report a sensible name clash error if+    -- -fimplicit-import-qualified is used with a module that exports the same+    -- field name multiple times (see+    -- Note [DuplicateRecordFields and -fimplicit-import-qualified]).+    toGRE gname = GRE { gre_name = gname, gre_par = NoParent, gre_lcl = False, gre_imp = [is] }+    is = ImpSpec { is_decl = ImpDeclSpec { is_mod = mod, is_as = mod, is_qual = True, is_dloc = noSrcSpan }+                 , is_item = ImpAll }+    -- If -fimplicit-import-qualified succeeded, the name must be qualified.+    (mod, _) = fromMaybe (pprPanic "lookupOneQualifiedNameGHCi" (ppr rdr_name)) (isQual_maybe rdr_name) -lookupQualifiedNameGHCi :: RdrName -> RnM [Name]-lookupQualifiedNameGHCi rdr_name++-- | Look up *all* the names to which the 'RdrName' may refer in GHCi (using+-- @-fimplicit-import-qualified@).  This will normally be zero or one, but may+-- be more in the presence of @DuplicateRecordFields@.+lookupQualifiedNameGHCi :: FieldsOrSelectors -> RdrName -> RnM [GreName]+lookupQualifiedNameGHCi fos rdr_name   = -- We want to behave as we would for a source file import here,     -- and respect hiddenness of modules/packages, hence loadSrcInterface.     do { dflags  <- getDynFlags@@ -1392,10 +1660,14 @@       = do { res <- loadSrcInterface_maybe doc mod NotBoot Nothing            ; case res of                 Succeeded iface-                  -> return [ name+                  -> return [ gname                             | avail <- mi_exports iface-                            , name  <- availNames avail-                            , nameOccName name == occ ]+                            , gname <- availGreNames avail+                            , occName gname == occ+                            -- Include a field if it has a selector or we are looking for all fields;+                            -- see Note [NoFieldSelectors].+                            , allowGreName fos gname+                            ]                  _ -> -- Either we couldn't load the interface, or                      -- we could but we didn't find the name in it@@ -1474,16 +1746,34 @@  lookupSigOccRn :: HsSigCtxt                -> Sig GhcPs-               -> Located RdrName -> RnM (Located Name)+               -> LocatedA RdrName -> RnM (LocatedA Name) lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) +lookupSigOccRnN :: HsSigCtxt+               -> Sig GhcPs+               -> LocatedN RdrName -> RnM (LocatedN Name)+lookupSigOccRnN ctxt sig = lookupSigCtxtOccRnN ctxt (hsSigDoc sig)++ -- | Lookup a name in relation to the names in a 'HsSigCtxt'+lookupSigCtxtOccRnN :: HsSigCtxt+                    -> SDoc         -- ^ description of thing we're looking up,+                                   -- like "type family"+                    -> LocatedN RdrName -> RnM (LocatedN Name)+lookupSigCtxtOccRnN ctxt what+  = wrapLocMA $ \ rdr_name ->+    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name+       ; case mb_name of+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Right name -> return name }++-- | Lookup a name in relation to the names in a 'HsSigCtxt' lookupSigCtxtOccRn :: HsSigCtxt                    -> SDoc         -- ^ description of thing we're looking up,                                    -- like "type family"-                   -> Located RdrName -> RnM (Located Name)+                   -> LocatedA RdrName -> RnM (LocatedA Name) lookupSigCtxtOccRn ctxt what-  = wrapLocM $ \ rdr_name ->+  = wrapLocMA $ \ rdr_name ->     do { mb_name <- lookupBindGroupOcc ctxt what rdr_name        ; case mb_name of            Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }@@ -1491,7 +1781,7 @@  lookupBindGroupOcc :: HsSigCtxt                    -> SDoc-                   -> RdrName -> RnM (Either MsgDoc Name)+                   -> RdrName -> RnM (Either SDoc Name) -- Looks up the RdrName, expecting it to resolve to one of the -- bound names passed in.  If not, return an appropriate error message --@@ -1533,14 +1823,14 @@                                   filter (\n -> nameSpacesRelated                                                   (rdrNameSpace rdr_name)                                                   (nameNameSpace n))-                                $ map gre_name+                                $ map greMangledName                                 $ filter isLocalGRE                                 $ globalRdrEnvElts env                  candidates_msg = candidates names_in_scope-           ; case filter (keep_me . gre_name) all_gres of+           ; case filter (keep_me . greMangledName) all_gres of                [] | null all_gres -> bale_out_with candidates_msg                   | otherwise     -> bale_out_with local_msg-               (gre:_)            -> return (Right (gre_name gre)) }+               (gre:_)            -> return (Right (greMangledName gre)) }      lookup_group bound_names  -- Look in the local envt (not top level)       = do { mname <- lookupLocalOccRn_maybe rdr_name@@ -1562,7 +1852,7 @@                            <+> quotes (ppr rdr_name) <+> text "is declared"      -- Identify all similar names and produce a message listing them-    candidates :: [Name] -> MsgDoc+    candidates :: [Name] -> SDoc     candidates names_in_scope       = case similar_names of           []  -> Outputable.empty@@ -1683,40 +1973,42 @@ checks the type of the user thing against the type of the standard thing. -} -lookupIfThenElse :: Bool  -- False <=> don't use rebindable syntax under any conditions-                 -> RnM (SyntaxExpr GhcRn, FreeVars)--- Different to lookupSyntax because in the non-rebindable--- case we desugar directly rather than calling an existing function--- Hence the (Maybe (SyntaxExpr GhcRn)) return type-lookupIfThenElse maybe_use_rs+lookupIfThenElse :: RnM (Maybe Name)+-- Looks up "ifThenElse" if rebindable syntax is on+lookupIfThenElse   = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not (rebindable_on && maybe_use_rs)-         then return (NoSyntaxExprRn, emptyFVs)+       ; if not rebindable_on+         then return Nothing          else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))-                 ; return ( mkRnSyntaxExpr ite-                          , unitFV ite ) } }+                 ; return (Just ite) } } -lookupSyntaxName :: Name                      -- ^ The standard name-                 -> RnM (Name, FreeVars)      -- ^ Possibly a non-standard name+lookupSyntaxName :: Name                 -- ^ The standard name+                 -> RnM (Name, FreeVars) -- ^ Possibly a non-standard name+-- Lookup a Name that may be subject to Rebindable Syntax (RS).+--+-- - When RS is off, just return the supplied (standard) Name+--+-- - When RS is on, look up the OccName of the supplied Name; return+--   what we find, or the supplied Name if there is nothing in scope lookupSyntaxName std_name-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if not rebindable_on then-           return (std_name, emptyFVs)-         else-            -- Get the similarly named thing from the local environment-           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))-              ; return (usr_name, unitFV usr_name) } }+  = do { rebind <- xoptM LangExt.RebindableSyntax+       ; if not rebind+         then return (std_name, emptyFVs)+         else do { nm <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+                 ; return (nm, unitFV nm) } }  lookupSyntaxExpr :: Name                          -- ^ The standard name                  -> RnM (HsExpr GhcRn, FreeVars)  -- ^ Possibly a non-standard name lookupSyntaxExpr std_name-  = fmap (first nl_HsVar) $ lookupSyntaxName std_name+  = do { (name, fvs) <- lookupSyntaxName std_name+       ; return (nl_HsVar name, fvs) }  lookupSyntax :: Name                             -- The standard name              -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard                                                  -- name lookupSyntax std_name-  = fmap (first mkSyntaxExpr) $ lookupSyntaxExpr std_name+  = do { (expr, fvs) <- lookupSyntaxExpr std_name+       ; return (mkSyntaxExpr expr, fvs) }  lookupSyntaxNames :: [Name]                         -- Standard names      -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames@@ -1724,11 +2016,12 @@ lookupSyntaxNames std_names   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if not rebindable_on then-             return (map (HsVar noExtField . noLoc) std_names, emptyFVs)+             return (map (HsVar noExtField . noLocA) std_names, emptyFVs)         else           do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names-             ; return (map (HsVar noExtField . noLoc) usr_names, mkFVs usr_names) } }+             ; return (map (HsVar noExtField . noLocA) usr_names, mkFVs usr_names) } } + {- Note [QualifiedDo] ~~~~~~~~~~~~~~~~~~@@ -1773,33 +2066,7 @@       Just modName -> lookupNameWithQualifier std_name modName  --- Lookup a locally-rebound name for Rebindable Syntax (RS).------ - When RS is off, 'lookupRebound' just returns 'Nothing', whatever---   name it is given.------ - When RS is on, we always try to return a 'Just', and GHC errors out---   if no suitable name is found in the environment.------ 'Nothing' really is "reserved" and means that rebindable syntax is off.-lookupRebound :: FastString -> RnM (Maybe (Located Name))-lookupRebound nameStr = do-  rebind <- xoptM LangExt.RebindableSyntax-  if rebind-    -- If repetitive lookups ever become a problem perormance-wise,-    -- we could lookup all the names we will ever care about just once-    -- at the beginning and stick them in the environment, possibly-    -- populating that "cache" lazily too.-    then (\nm -> Just (L (nameSrcSpan nm) nm)) <$>-         lookupOccRn (mkVarUnqual nameStr)-    else pure Nothing---- | Lookup an @ifThenElse@ binding (see 'lookupRebound').-lookupReboundIf :: RnM (Maybe (Located Name))-lookupReboundIf = lookupRebound reboundIfSymbol- -- Error messages-  opDeclErr :: RdrName -> SDoc opDeclErr n

GHC/Rename/Expr.hs view

@@ -1,3 +1,13 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -10,18 +20,9 @@ free variables. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- module GHC.Rename.Expr (-        rnLExpr, rnExpr, rnStmts+        rnLExpr, rnExpr, rnStmts,+        AnnoBody    ) where  #include "HsVersions.h"@@ -48,16 +49,18 @@ import GHC.Driver.Session import GHC.Builtin.Names -import GHC.Types.Basic+import GHC.Types.FieldLabel+import GHC.Types.Fixity+import GHC.Types.Id.Make import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Unique.Set-import Data.List-import Data.Maybe (isJust, isNothing)+import GHC.Types.SourceText import GHC.Utils.Misc import GHC.Data.List.SetOps ( removeDups ) import GHC.Utils.Error+import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable import GHC.Types.SrcLoc import GHC.Data.FastString@@ -65,11 +68,101 @@ import GHC.Builtin.Types ( nilDataConName ) import qualified GHC.LanguageExtensions as LangExt +import Data.List (unzip4, minimumBy)+import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Maybe (isJust, isNothing) import Control.Arrow (first) import Data.Ord import Data.Array import qualified Data.List.NonEmpty as NE +{- Note [Handling overloaded and rebindable constructs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For overloaded constructs (overloaded literals, lists, strings), and+rebindable constructs (e.g. if-then-else), our general plan is this,+using overloaded labels #foo as an example:++* In the RENAMER: transform+      HsOverLabel "foo"+      ==> XExpr (HsExpansion (HsOverLabel #foo)+                             (fromLabel `HsAppType` "foo"))+  We write this more compactly in concrete-syntax form like this+      #foo  ==>  fromLabel @"foo"++  Recall that in (HsExpansion orig expanded), 'orig' is the original term+  the user wrote, and 'expanded' is the expanded or desugared version+  to be typechecked.++* In the TYPECHECKER: typecheck the expansion, in this case+      fromLabel @"foo"+  The typechecker (and desugarer) will never see HsOverLabel++In effect, the renamer does a bit of desugaring. Recall GHC.Hs.Expr+Note [Rebindable syntax and HsExpansion], which describes the use of HsExpansion.++RebindableSyntax:+  If RebindableSyntax is off we use the built-in 'fromLabel', defined in+     GHC.Builtin.Names.fromLabelClassOpName+  If RebindableSyntax if ON, we look up "fromLabel" in the environment+     to get whichever one is in scope.+This is accomplished by lookupSyntaxName, and it applies to all the+constructs below.++Here are the constructs that we transform in this way. Some are uniform,+but several have a little bit of special treatment:++* HsIf (if-the-else)+     if b then e1 else e2  ==>  ifThenElse b e1 e2+  We do this /only/ if rebindable syntax is on, because the coverage+  checker looks for HsIf (see GHC.HsToCore.Coverage.addTickHsExpr)+  That means the typechecker and desugarer need to understand HsIf+  for the non-rebindable-syntax case.++* OverLabel (overloaded labels, #lbl)+     #lbl  ==>  fromLabel @"lbl"+  As ever, we use lookupSyntaxName to look up 'fromLabel'+  See Note [Overloaded labels]++* ExplicitList (explicit lists [a,b,c])+  When (and only when) OverloadedLists is on+     [e1,e2]  ==>  fromListN 2 [e1,e2]+  NB: the type checker and desugarer still see ExplicitList,+      but to them it always means the built-in lists.++* SectionL and SectionR (left and right sections)+     (`op` e) ==> rightSection op e+     (e `op`) ==> leftSection  (op e)+  where `leftSection` and `rightSection` are levity-polymorphic+  wired-in Ids. See Note [Left and right sections]++* It's a bit painful to transform `OpApp e1 op e2` to a `HsExpansion`+  form, because the renamer does precedence rearrangement after name+  resolution.  So the renamer leaves an OpApp as an OpApp.++  The typechecker turns `OpApp` into a use of `HsExpansion`+  on the fly, in GHC.Tc.Gen.Head.splitHsApps.  RebindableSyntax+  does not affect this.++Note [Overloaded labels]+~~~~~~~~~~~~~~~~~~~~~~~~+For overloaded labels, note that we /only/ apply `fromLabel` to the+Symbol argument, so the resulting expression has type+    fromLabel @"foo" :: forall a. IsLabel "foo" a => a+Now ordinary Visible Type Application can be used to instantiate the 'a':+the user may have written (#foo @Int).++Notice that this all works fine in a kind-polymorphic setting (#19154).+Suppose we have+    fromLabel :: forall {k1} {k2} (a:k1). blah++Then we want to instantiate those inferred quantifiers k1,k2, before+type-applying to "foo", so we get+    fromLabel @Symbol @blah @"foo" ...++And those inferred kind quantifiers will indeed be instantiated when we+typecheck the renamed-syntax call (fromLabel @"foo").+-}+ {- ************************************************************************ *                                                                      *@@ -93,65 +186,69 @@ -- Variables. We look up the variable and return the resulting name.  rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)-rnLExpr = wrapLocFstM rnExpr+rnLExpr = wrapLocFstMA rnExpr  rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)+finishHsVar :: LocatedA Name -> RnM (HsExpr GhcRn, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name)  = do { this_mod <- getModule       ; when (nameIsLocalOrFrom this_mod name) $         checkThLocalName name-      ; return (HsVar noExtField (L l name), unitFV name) }+      ; return (HsVar noExtField (L (la2na l) name), unitFV name) }  rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)-rnUnboundVar v- = do { if isUnqual v-        then -- Treat this as a "hole"-             -- Do not fail right now; instead, return HsUnboundVar-             -- and let the type checker report the error-             return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)+rnUnboundVar v =+  if isUnqual v+  then -- Treat this as a "hole"+       -- Do not fail right now; instead, return HsUnboundVar+       -- and let the type checker report the error+       return (HsUnboundVar noExtField (rdrNameOcc v), emptyFVs)          else -- Fail immediately (qualified name)              do { n <- reportUnboundName v-                ; return (HsVar noExtField (noLoc n), emptyFVs) } }+                ; return (HsVar noExtField (noLocA n), emptyFVs) }  rnExpr (HsVar _ (L l v))-  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields-       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v-       ; dflags <- getDynFlags+  = do { dflags <- getDynFlags+       ; let dup_fields_ok = xopt_DuplicateRecordFields dflags+       ; mb_name <- lookupExprOccRn dup_fields_ok v+        ; case mb_name of {            Nothing -> rnUnboundVar v ;-           Just (Left name)+           Just (UnambiguousGre (NormalGreName name))               | name == nilDataConName -- Treat [] as an ExplicitList, so that                                        -- OverloadedLists works correctly                                        -- Note [Empty lists] in GHC.Hs.Expr               , xopt LangExt.OverloadedLists dflags-              -> rnExpr (ExplicitList noExtField Nothing [])+              -> rnExpr (ExplicitList noAnn [])                | otherwise-              -> finishHsVar (L l name) ;-            Just (Right [s]) ->-              return ( HsRecFld noExtField (Unambiguous s (L l v) ), unitFV s) ;-           Just (Right fs@(_:_:_)) ->-              return ( HsRecFld noExtField (Ambiguous noExtField (L l v))-                     , mkFVs fs);-           Just (Right [])         -> panic "runExpr/HsVar" } }+              -> finishHsVar (L (na2la l) name) ;+            Just (UnambiguousGre (FieldGreName fl)) ->+              let sel_name = flSelector fl in+              return ( HsRecFld noExtField (Unambiguous sel_name (L l v) ), unitFV sel_name) ;+            Just AmbiguousFields ->+              return ( HsRecFld noExtField (Ambiguous noExtField (L l v) ), emptyFVs) } } + rnExpr (HsIPVar x v)   = return (HsIPVar x v, emptyFVs) -rnExpr (HsUnboundVar x v)-  = return (HsUnboundVar x v, emptyFVs)+rnExpr (HsUnboundVar _ v)+  = return (HsUnboundVar noExtField v, emptyFVs) -rnExpr (HsOverLabel x _ v)-  = do { rebindable_on <- xoptM LangExt.RebindableSyntax-       ; if rebindable_on-         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))-                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }-         else return (HsOverLabel x Nothing v, emptyFVs) }+-- HsOverLabel: see Note [Handling overloaded and rebindable constructs]+rnExpr (HsOverLabel _ v)+  = do { (from_label, fvs) <- lookupSyntaxName fromLabelClassOpName+       ; return ( mkExpandedExpr (HsOverLabel noAnn v) $+                  HsAppType noExtField (genLHsVar from_label) hs_ty_arg+                , fvs ) }+  where+    hs_ty_arg = mkEmptyWildCardBndrs $ wrapGenSpan $+                HsTyLit noExtField (HsStrTy NoSourceText v)  rnExpr (HsLit x lit@(HsString src s))   = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings@@ -169,20 +266,21 @@   = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]        ; case mb_neg of               Nothing -> return (HsOverLit x lit', fvs)-              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))-                                 , fvs ) }+              Just neg ->+                 return (HsApp noComments (noLocA neg) (noLocA (HsOverLit x lit'))+                        , fvs ) }  rnExpr (HsApp x fun arg)   = do { (fun',fvFun) <- rnLExpr fun        ; (arg',fvArg) <- rnLExpr arg        ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) } -rnExpr (HsAppType x fun arg)+rnExpr (HsAppType _ fun arg)   = do { type_app <- xoptM LangExt.TypeApplications        ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg        ; (fun',fvFun) <- rnLExpr fun        ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg-       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }+       ; return (HsAppType NoExtField fun' arg', fvFun `plusFV` fvArg) }  rnExpr (OpApp _ e1 op e2)   = do  { (e1', fv_e1) <- rnLExpr e1@@ -213,6 +311,27 @@        ; return (final_e, fv_e `plusFV` fv_neg) }  ------------------------------------------+-- Record dot syntax++rnExpr (HsGetField _ e f)+ = do { (getField, fv_getField) <- lookupSyntaxName getFieldName+      ; (e, fv_e) <- rnLExpr e+      ; let f' = rnHsFieldLabel f+      ; return ( mkExpandedExpr+                   (HsGetField noExtField e f')+                   (mkGetField getField e (fmap (unLoc . hflLabel) f'))+               , fv_e `plusFV` fv_getField ) }++rnExpr (HsProjection _ fs)+  = do { (getField, fv_getField) <- lookupSyntaxName getFieldName+       ; circ <- lookupOccRn compose_RDR+       ; let fs' = fmap rnHsFieldLabel fs+       ; return ( mkExpandedExpr+                    (HsProjection noExtField fs')+                    (mkProjection getField circ (fmap (fmap (unLoc . hflLabel)) fs'))+                , unitFV circ `plusFV` fv_getField) }++------------------------------------------ -- Template Haskell extensions rnExpr e@(HsBracket _ br_body) = rnBracket e br_body @@ -245,7 +364,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@@ -255,105 +373,131 @@   = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches        ; return (HsLamCase x matches', fvs_ms) } -rnExpr (HsCase x expr matches)+rnExpr (HsCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr        ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches-       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }+       ; return (HsCase noExtField new_expr new_matches, e_fvs `plusFV` ms_fvs) } -rnExpr (HsLet x (L l binds) expr)+rnExpr (HsLet _ binds expr)   = rnLocalBindsAndThen binds $ \binds' _ -> do       { (expr',fvExpr) <- rnLExpr expr-      ; return (HsLet x (L l binds') expr', fvExpr) }+      ; return (HsLet noExtField binds' expr', fvExpr) } -rnExpr (HsDo x do_or_lc (L l stmts))+rnExpr (HsDo _ do_or_lc (L l stmts))   = do  { ((stmts', _), fvs) <--           rnStmtsWithPostProcessing do_or_lc rnLExpr+           rnStmtsWithPostProcessing do_or_lc rnExpr              postProcessStmtsForApplicativeDo stmts              (\ _ -> return ((), emptyFVs))-        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }+        ; return ( HsDo noExtField do_or_lc (L l stmts'), fvs ) } -rnExpr (ExplicitList x _  exps)-  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists-        ; (exps', fvs) <- rnExprs exps-        ; if opt_OverloadedLists-           then do {-            ; (from_list_n_name, fvs') <- lookupSyntax fromListNName-            ; return (ExplicitList x (Just from_list_n_name) exps'-                     , fvs `plusFV` fvs') }-           else-            return  (ExplicitList x Nothing exps', fvs) }+-- ExplicitList: see Note [Handling overloaded and rebindable constructs]+rnExpr (ExplicitList _ exps)+  = do  { (exps', fvs) <- rnExprs exps+        ; opt_OverloadedLists <- xoptM LangExt.OverloadedLists+        ; if not opt_OverloadedLists+          then return  (ExplicitList noExtField exps', fvs)+          else+    do { (from_list_n_name, fvs') <- lookupSyntaxName fromListNName+       ; let rn_list  = ExplicitList noExtField exps'+             lit_n    = mkIntegralLit (length exps)+             hs_lit   = wrapGenSpan (HsLit noAnn (HsInt noExtField lit_n))+             exp_list = genHsApps from_list_n_name [hs_lit, wrapGenSpan rn_list]+       ; return ( mkExpandedExpr rn_list exp_list+                , fvs `plusFV` fvs') } } -rnExpr (ExplicitTuple x tup_args boxity)+rnExpr (ExplicitTuple _ tup_args boxity)   = do { checkTupleSection tup_args-       ; checkTupSize (length tup_args)        ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args-       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }+       ; return (ExplicitTuple noExtField tup_args' boxity, plusFVs fvs) }   where-    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e-                                      ; return (L l (Present x e'), fvs) }-    rnTupArg (L l (Missing _)) = return (L l (Missing noExtField)-                                        , emptyFVs)+    rnTupArg (Present x e) = do { (e',fvs) <- rnLExpr e+                                ; return (Present x e', fvs) }+    rnTupArg (Missing _) = return (Missing noExtField, emptyFVs) -rnExpr (ExplicitSum x alt arity expr)+rnExpr (ExplicitSum _ alt arity expr)   = do { (expr', fvs) <- rnLExpr expr-       ; return (ExplicitSum x alt arity expr', fvs) }+       ; return (ExplicitSum noExtField alt arity expr', fvs) } -rnExpr (RecordCon { rcon_con_name = con_id+rnExpr (RecordCon { rcon_con = con_id                   , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })   = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id        ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds        ; (flds', fvss) <- mapAndUnzipM rn_field flds        ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }        ; return (RecordCon { rcon_ext = noExtField-                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }+                           , rcon_con = con_lname, rcon_flds = rec_binds' }                 , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }   where-    mk_hs_var l n = HsVar noExtField (L l n)+    mk_hs_var l n = HsVar noExtField (L (noAnnSrcSpan l) n)     rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)                             ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }  rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })-  = do  { (expr', fvExpr) <- rnLExpr expr-        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds-        ; return (RecordUpd { rupd_ext = noExtField, rupd_expr = expr'-                            , rupd_flds = rbinds' }-                 , fvExpr `plusFV` fvRbinds) }+  = case rbinds of+      Left flds -> -- 'OverloadedRecordUpdate' is not in effect. Regular record update.+        do  { ; (e, fv_e) <- rnLExpr expr+              ; (rs, fv_rs) <- rnHsRecUpdFields flds+              ; return ( RecordUpd noExtField e (Left rs), fv_e `plusFV` fv_rs )+            }+      Right flds ->  -- 'OverloadedRecordUpdate' is in effect. Record dot update desugaring.+        do { ; unlessXOptM LangExt.RebindableSyntax $+                 addErr $ text "RebindableSyntax is required if OverloadedRecordUpdate is enabled."+             ; let punnedFields = [fld | (L _ fld) <- flds, hsRecPun fld]+             ; punsEnabled <-xoptM LangExt.RecordPuns+             ; unless (null punnedFields || punsEnabled) $+                 addErr $ text "For this to work enable NamedFieldPuns."+             ; (getField, fv_getField) <- lookupSyntaxName getFieldName+             ; (setField, fv_setField) <- lookupSyntaxName setFieldName+             ; (e, fv_e) <- rnLExpr expr+             ; (us, fv_us) <- rnHsUpdProjs flds+             ; return ( mkExpandedExpr+                          (RecordUpd noExtField e (Right us))+                          (mkRecordDotUpd getField setField e us)+                         , plusFVs [fv_getField, fv_setField, fv_e, fv_us] )+             }  rnExpr (ExprWithTySig _ expr pty)   = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty         ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $                              rnLExpr expr         ; return (ExprWithTySig noExtField expr' pty', fvExpr `plusFV` fvTy) }++-- HsIf: see Note [Handling overloaded and rebindable constructs]+-- Because of the coverage checker it is most convenient /not/ to+-- expand HsIf; unless we are in rebindable syntax. rnExpr (HsIf _ p b1 b2)-  = do { (p', fvP) <- rnLExpr p+  = do { (p',  fvP)  <- rnLExpr p        ; (b1', fvB1) <- rnLExpr b1        ; (b2', fvB2) <- rnLExpr b2-       ; mifteName <- lookupReboundIf-       ; let subFVs = plusFVs [fvP, fvB1, fvB2]-       ; return $ case mifteName of-           -- RS is off, we keep an 'HsIf' node around-           Nothing ->-             (HsIf noExtField  p' b1' b2', subFVs)-           -- See Note [Rebindable syntax and HsExpansion].-           Just ifteName ->-             let ifteExpr = rebindIf ifteName p' b1' b2'-             in (ifteExpr, plusFVs [unitFV (unLoc ifteName), subFVs])-       }-rnExpr (HsMultiIf x alts)+       ; let fvs_if = plusFVs [fvP, fvB1, fvB2]+             rn_if  = HsIf noExtField  p' b1' b2'++       -- Deal with rebindable syntax+       -- See Note [Handling overloaded and rebindable constructs]+       ; mb_ite <- lookupIfThenElse+       ; case mb_ite of+            Nothing  -- Non rebindable-syntax case+              -> return (rn_if, fvs_if)++            Just ite_name   -- Rebindable-syntax case+              -> do { let ds_if = genHsApps ite_name [p', b1', b2']+                          fvs   = plusFVs [fvs_if, unitFV ite_name]+                    ; return (mkExpandedExpr rn_if ds_if, fvs) } }++rnExpr (HsMultiIf _ alts)   = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts-       -- ; return (HsMultiIf ty alts', fvs) }-       ; return (HsMultiIf x alts', fvs) }+       ; return (HsMultiIf noExtField alts', fvs) } -rnExpr (ArithSeq x _ seq)+rnExpr (ArithSeq _ _ seq)   = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists        ; (new_seq, fvs) <- rnArithSeq seq        ; if opt_OverloadedLists            then do {             ; (from_list_name, fvs') <- lookupSyntax fromListName-            ; return (ArithSeq x (Just from_list_name) new_seq+            ; return (ArithSeq noExtField (Just from_list_name) new_seq                      , fvs `plusFV` fvs') }            else-            return (ArithSeq x Nothing new_seq, fvs) }+            return (ArithSeq noExtField Nothing new_seq, fvs) }  {- ************************************************************************@@ -390,43 +534,190 @@     let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr     return (HsStatic fvExpr' expr', fvExpr) -{--************************************************************************+{- ********************************************************************* *                                                                      *         Arrow notation *                                                                      *-************************************************************************--}+********************************************************************* -}  rnExpr (HsProc x pat body)   = newArrowScope $-    rnPat ProcExpr pat $ \ pat' -> do+    rnPat (ArrowMatchCtxt ProcExpr) pat $ \ pat' -> do       { (body',fvBody) <- rnCmdTop body       ; return (HsProc x pat' body', fvBody) }  rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)         -- HsWrap -------------------------- See Note [Parsing sections] in GHC.Parser+{- *********************************************************************+*                                                                      *+        Operator sections+*                                                                      *+********************************************************************* -}++ rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)+-- See Note [Parsing sections] in GHC.Parser+-- Also see Note [Handling overloaded and rebindable constructs]+ rnSection section@(SectionR x op expr)+  -- See Note [Left and right sections]   = do  { (op', fvs_op)     <- rnLExpr op         ; (expr', fvs_expr) <- rnLExpr expr         ; checkSectionPrec InfixR section op' expr'-        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }+        ; let rn_section = SectionR x op' expr'+              ds_section = genHsApps rightSectionName [op',expr']+        ; return ( mkExpandedExpr rn_section ds_section+                 , fvs_op `plusFV` fvs_expr) }  rnSection section@(SectionL x expr op)+  -- See Note [Left and right sections]   = do  { (expr', fvs_expr) <- rnLExpr expr         ; (op', fvs_op)     <- rnLExpr op         ; checkSectionPrec InfixL section op' expr'-        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }+        ; postfix_ops <- xoptM LangExt.PostfixOperators+                        -- Note [Left and right sections]+        ; let rn_section = SectionL x expr' op'+              ds_section+                | postfix_ops = HsApp noAnn op' expr'+                | otherwise   = genHsApps leftSectionName+                                   [wrapGenSpan $ HsApp noAnn op' expr']+        ; return ( mkExpandedExpr rn_section ds_section+                 , fvs_op `plusFV` fvs_expr) }  rnSection other = pprPanic "rnSection" (ppr other) +{- Note [Left and right sections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dealing with left sections (x *) and right sections (* x) is+surprisingly fiddly.  We expand like this+     (`op` e) ==> rightSection op e+     (e `op`) ==> leftSection  (op e)++Using an auxiliary function in this way avoids the awkwardness of+generating a lambda, esp if `e` is a redex, so we *don't* want+to generate `(\x -> op x e)`. See Historical+Note [Desugaring operator sections]++Here are their definitions:+   leftSection :: forall r1 r2 n (a:TYPE r1) (b:TYPE r2).+                  (a %n-> b) -> a %n-> b+   leftSection f x = f x++   rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c+   rightSection f y x = f x y++Note the wrinkles:++* We do /not/ use lookupSyntaxName, which would make left and right+  section fall under RebindableSyntax.  Reason: it would be a user-+  facing change, and there are some tricky design choices (#19354).+  Plus, infix operator applications would be trickier to make+  rebindable, so it'd be inconsistent to do so for sections.++  TL;DR: we still us the renamer-expansion mechanism for operator+  sections , but only to eliminate special-purpose code paths in the+  renamer and desugarer.++* leftSection and rightSection must be levity-polymorphic, to allow+  (+# 4#) and (4# +#) to work. See GHC.Types.Id.Make.+  Note [Wired-in Ids for rebindable syntax] in++* leftSection and rightSection must be multiplicity-polymorphic.+  (Test linear/should_compile/OldList showed this up.)++* Because they are levity-polymorphic, we have to define them+  as wired-in Ids, with compulsory inlining.  See+  GHC.Types.Id.Make.leftSectionId, rightSectionId.++* leftSection is just ($) really; but unlike ($) it is+  levity polymorphic in the result type, so we can write+  `(x +#)`, say.++* The type of leftSection must have an arrow in its first argument,+  because (x `ord`) should be rejected, because ord does not take two+  arguments++* It's important that we define leftSection in an eta-expanded way,+  (i.e. not leftSection f = f), so that+      (True `undefined`) `seq` ()+      = (leftSection (undefined True) `seq` ())+  evaluates to () and not undefined++* If PostfixOperators is ON, then we expand a left section like this:+      (e `op`)  ==>   op e+  with no auxiliary function at all.  Simple!+++Historical Note [Desugaring operator sections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note explains some historical trickiness in desugaring left and+right sections.  That trickiness has completely disappeared now that+we desugar to calls to 'leftSection` and `rightSection`, but I'm+leaving it here to remind us how nice the new story is.++Desugaring left sections with -XPostfixOperators is straightforward: convert+(expr `op`) to (op expr).++Without -XPostfixOperators it's a bit more tricky. At first it looks as if we+can convert++    (expr `op`)++naively to++    \x -> op expr x++But no!  expr might be a redex, and we can lose laziness badly this+way.  Consider++    map (expr `op`) xs++for example. If expr were a redex then eta-expanding naively would+result in multiple evaluations where the user might only have expected one.++So we convert instead to++    let y = expr in \x -> op y x++Also, note that we must do this for both right and (perhaps surprisingly) left+sections. Why are left sections necessary? Consider the program (found in #18151),++    seq (True `undefined`) ()++according to the Haskell Report this should reduce to () (as it specifies+desugaring via eta expansion). However, if we fail to eta expand we will rather+bottom. Consequently, we must eta expand even in the case of a left section.++If `expr` is actually just a variable, say, then the simplifier+will inline `y`, eliminating the redundant `let`.++Note that this works even in the case that `expr` is unlifted. In this case+bindNonRec will automatically do the right thing, giving us:++    case expr of y -> (\x -> op y x)++See #18151.+-}+ {- ************************************************************************ *                                                                      *+        Field Labels+*                                                                      *+************************************************************************+-}++rnHsFieldLabel :: Located (HsFieldLabel GhcPs) -> Located (HsFieldLabel GhcRn)+rnHsFieldLabel (L l (HsFieldLabel x label)) = L l (HsFieldLabel x label)++rnFieldLabelStrings :: FieldLabelStrings GhcPs -> FieldLabelStrings GhcRn+rnFieldLabelStrings (FieldLabelStrings fls) = FieldLabelStrings (map rnHsFieldLabel fls)++{-+************************************************************************+*                                                                      *         Arrow commands *                                                                      * ************************************************************************@@ -442,6 +733,7 @@ rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop'  where+  rnCmdTop' :: HsCmdTop GhcPs -> RnM (HsCmdTop GhcRn, FreeVars)   rnCmdTop' (HsCmdTop _ cmd)    = do { (cmd', fvCmd) <- rnLCmd cmd         ; let cmd_names = [arrAName, composeAName, firstAName] ++@@ -453,14 +745,14 @@                   fvCmd `plusFV` cmd_fvs) }  rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)-rnLCmd = wrapLocFstM rnCmd+rnLCmd = wrapLocFstMA rnCmd  rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) -rnCmd (HsCmdArrApp x arrow arg ho rtl)+rnCmd (HsCmdArrApp _ arrow arg ho rtl)   = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)        ; (arg',fvArg) <- rnLExpr arg-       ; return (HsCmdArrApp x arrow' arg' ho rtl,+       ; return (HsCmdArrApp noExtField arrow' arg' ho rtl,                  fvArrow `plusFV` fvArg) }   where     select_arrow_scope tc = case ho of@@ -483,49 +775,56 @@        ; final_e <- mkOpFormRn arg1' op' fixity arg2'        ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } -rnCmd (HsCmdArrForm x op f fixity cmds)+rnCmd (HsCmdArrForm _ op f fixity cmds)   = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)        ; (cmds',fvCmds) <- rnCmdArgs cmds-       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }+       ; return ( HsCmdArrForm noExtField op' f fixity cmds'+                , fvOp `plusFV` fvCmds) }  rnCmd (HsCmdApp x fun arg)   = do { (fun',fvFun) <- rnLCmd  fun        ; (arg',fvArg) <- rnLExpr arg        ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) } -rnCmd (HsCmdLam x matches)-  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches-       ; return (HsCmdLam x matches', fvMatch) }+rnCmd (HsCmdLam _ matches)+  = do { (matches', fvMatch) <- rnMatchGroup (ArrowMatchCtxt KappaExpr) rnLCmd matches+       ; return (HsCmdLam noExtField matches', fvMatch) }  rnCmd (HsCmdPar x e)   = do  { (e', fvs_e) <- rnLCmd e         ; return (HsCmdPar x e', fvs_e) } -rnCmd (HsCmdCase x expr matches)+rnCmd (HsCmdCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr-       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches-       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }+       ; (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches+       ; return (HsCmdCase noExtField new_expr new_matches+                , e_fvs `plusFV` ms_fvs) }  rnCmd (HsCmdLamCase x matches)-  = do { (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches+  = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches        ; return (HsCmdLamCase x new_matches, ms_fvs) } -rnCmd (HsCmdIf x _ p b1 b2)+rnCmd (HsCmdIf _ _ p b1 b2)   = do { (p', fvP) <- rnLExpr p        ; (b1', fvB1) <- rnLCmd b1        ; (b2', fvB2) <- rnLCmd b2-       ; (mb_ite, fvITE) <- lookupIfThenElse True-       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])} -rnCmd (HsCmdLet x (L l binds) cmd)+       ; mb_ite <- lookupIfThenElse+       ; let (ite, fvITE) = case mb_ite of+                Just ite_name -> (mkRnSyntaxExpr ite_name, unitFV ite_name)+                Nothing       -> (NoSyntaxExprRn,          emptyFVs)++       ; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}++rnCmd (HsCmdLet _ binds cmd)   = rnLocalBindsAndThen binds $ \ binds' _ -> do       { (cmd',fvExpr) <- rnLCmd cmd-      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }+      ; return (HsCmdLet noExtField binds' cmd', fvExpr) } -rnCmd (HsCmdDo x (L l stmts))+rnCmd (HsCmdDo _ (L l stmts))   = do  { ((stmts', _), fvs) <--            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))-        ; return ( HsCmdDo x (L l stmts'), fvs ) }+            rnStmts ArrowExpr rnCmd stmts (\ _ -> return ((), emptyFVs))+        ; return ( HsCmdDo noExtField (L l stmts'), fvs ) }  --------------------------------------------------- type CmdNeeds = FreeVars        -- Only inhabitants are@@ -581,18 +880,18 @@ methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs  ----------------------------------------------------methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars+methodNamesStmts :: [LStmtLR GhcRn GhcRn (LHsCmd GhcRn)] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)  ----------------------------------------------------methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars+methodNamesLStmt :: LStmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc  methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd methodNamesStmt (BindStmt _ _ cmd)             = methodNamesLCmd cmd-methodNamesStmt (RecStmt { recS_stmts = stmts }) =+methodNamesStmt (RecStmt { recS_stmts = L _ stmts }) =   methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt {})                   = emptyFVs methodNamesStmt (ParStmt {})                   = emptyFVs@@ -660,35 +959,42 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism. -} +type AnnoBody body+  = ( Outputable (body GhcPs)+    , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA+    )+ -- | Rename some Stmts-rnStmts :: Outputable (body GhcPs)+rnStmts :: AnnoBody body         => HsStmtContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> (body GhcPs -> RnM (body GhcRn, FreeVars))            -- ^ How to rename the body of each statement (e.g. rnLExpr)-        -> [LStmt GhcPs (Located (body GhcPs))]+        -> [LStmt GhcPs (LocatedA (body GhcPs))]            -- ^ Statements         -> ([Name] -> RnM (thing, FreeVars))            -- ^ if these statements scope over something, this renames it            -- and returns the result.-        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts  -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing-        :: Outputable (body GhcPs)+        :: AnnoBody body         => HsStmtContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> (body GhcPs -> RnM (body GhcRn, FreeVars))            -- ^ How to rename the body of each statement (e.g. rnLExpr)         -> (HsStmtContext GhcRn-              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]-              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))+              -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]+              -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars))            -- ^ postprocess the statements-        -> [LStmt GhcPs (Located (body GhcPs))]+        -> [LStmt GhcPs (LocatedA (body GhcPs))]            -- ^ Statements         -> ([Name] -> RnM (thing, FreeVars))            -- ^ if these statements scope over something, this renames it            -- and returns the result.-        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars) rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside  = do { ((stmts', thing), fvs) <-           rnStmtsWithFreeVars ctxt rnBody stmts thing_inside@@ -720,17 +1026,17 @@ -- | strip the FreeVars annotations from statements noPostProcessStmts   :: HsStmtContext GhcRn-  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]-  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)+  -> [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]+  -> RnM ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)  -rnStmtsWithFreeVars :: Outputable (body GhcPs)+rnStmtsWithFreeVars :: AnnoBody body         => HsStmtContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> [LStmt GhcPs (Located (body GhcPs))]+        -> ((body GhcPs) -> RnM ((body GhcRn), FreeVars))+        -> [LStmt GhcPs (LocatedA (body GhcPs))]         -> ([Name] -> RnM (thing, FreeVars))-        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)+        -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)                , FreeVars) -- Each Stmt body is annotated with its FreeVars, so that -- we can rearrange statements for ApplicativeDo.@@ -746,7 +1052,7 @@ rnStmtsWithFreeVars mDoExpr@MDoExpr{} rnBody stmts thing_inside    -- Deal with mdo   = -- Behave like do { rec { ...all but last... }; last }     do { ((stmts1, (stmts2, thing)), fvs)-           <- rnStmt mDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->+           <- rnStmt mDoExpr rnBody (noLocA $ mkRecStmt noAnn (noLocA all_but_last)) $ \ _ ->               do { last_stmt' <- checkLastStmt mDoExpr last_stmt                  ; rnStmt mDoExpr rnBody last_stmt' thing_inside }         ; return (((stmts1 ++ stmts2), thing), fvs) }@@ -755,13 +1061,13 @@  rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside   | null lstmts-  = setSrcSpan loc $+  = setSrcSpanA loc $     do { lstmt' <- checkLastStmt ctxt lstmt        ; rnStmt ctxt rnBody lstmt' thing_inside }    | otherwise   = do { ((stmts1, (stmts2, thing)), fvs)-            <- setSrcSpan loc                         $+            <- setSrcSpanA loc                  $                do { checkStmt ctxt lstmt                   ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->                     rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->@@ -783,28 +1089,27 @@    entirely. So, for list comprehensions, the fail function is set to 'Nothing'    for clarity. - * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo-   expressions) we want pattern match failure to be desugared to the appropriate-   'fail' function (either that of Monad or MonadFail, depending on whether-   -XMonadFailDesugaring is enabled.)+* In the case of monadic contexts (e.g. monad comprehensions, do, and mdo+   expressions) we want pattern match failure to be desugared to the+   'fail' function (from MonadFail type class).  At one point we failed to make this distinction, leading to #11216. -} -rnStmt :: Outputable (body GhcPs)+rnStmt :: AnnoBody body        => HsStmtContext GhcRn-       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+       -> (body GhcPs -> RnM (body GhcRn, FreeVars))           -- ^ How to rename the body of the statement-       -> LStmt GhcPs (Located (body GhcPs))+       -> LStmt GhcPs (LocatedA (body GhcPs))           -- ^ The statement        -> ([Name] -> RnM (thing, FreeVars))           -- ^ Rename the stuff that this statement scopes over-       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)+       -> RnM ( ([(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)], thing)               , FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside+rnStmt ctxt rnBody (L loc (LastStmt _ (L lb body) noret _)) thing_inside   = do  { (body', fv_expr) <- rnBody body         ; (ret_op, fvs1) <- if isMonadCompContext ctxt                             then lookupStmtName ctxt returnMName@@ -815,10 +1120,10 @@                             -- #15607          ; (thing,  fvs3) <- thing_inside []-        ; return (([(L loc (LastStmt noExtField body' noret ret_op), fv_expr)]+        ; return (([(L loc (LastStmt noExtField (L lb body') noret ret_op), fv_expr)]                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside+rnStmt ctxt rnBody (L loc (BodyStmt _ (L lb body) _ _)) thing_inside   = do  { (body', fv_expr) <- rnBody body         ; (then_op, fvs1)  <- lookupQualifiedDoStmtName ctxt thenMName @@ -830,10 +1135,10 @@                               -- Here "gd" is a guard          ; (thing, fvs3)    <- thing_inside []-        ; return ( ([(L loc (BodyStmt noExtField body' then_op guard_op), fv_expr)]+        ; return ( ([(L loc (BodyStmt noExtField (L lb body') then_op guard_op), fv_expr)]                   , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } -rnStmt ctxt rnBody (L loc (BindStmt _ pat body)) thing_inside+rnStmt ctxt rnBody (L loc (BindStmt _ pat (L lb body))) thing_inside   = do  { (body', fv_expr) <- rnBody body                 -- The binders do not scope over the expression         ; (bind_op, fvs1) <- lookupQualifiedDoStmtName ctxt bindMName@@ -841,21 +1146,21 @@         ; (fail_op, fvs2) <- monadFailOp pat ctxt          ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do-        { (thing, fvs3) <- thing_inside (collectPatBinders pat')+        { (thing, fvs3) <- thing_inside (collectPatBinders CollNoDictBinders pat')         ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }-        ; return (( [( L loc (BindStmt xbsrn pat' body'), fv_expr )]+        ; return (( [( L loc (BindStmt xbsrn pat' (L lb body')), fv_expr )]                   , thing),                   fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}        -- fv_expr shouldn't really be filtered by the rnPatsAndThen         -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside-  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do-        { (thing, fvs) <- thing_inside (collectLocalBinders binds')-        ; return ( ([(L loc (LetStmt noExtField (L l binds')), bind_fvs)], thing)-                 , fvs) }  }+rnStmt _ _ (L loc (LetStmt _ binds)) thing_inside+  =     rnLocalBindsAndThen binds $ \binds' bind_fvs -> do+        { (thing, fvs) <- thing_inside (collectLocalBinders CollNoDictBinders binds')+        ; return ( ([(L loc (LetStmt noAnn binds'), bind_fvs)], thing)+                 , fvs) } -rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside+rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = L _ rec_stmts })) thing_inside   = do  { (return_op, fvs1)  <- lookupQualifiedDoStmtName ctxt returnMName         ; (mfix_op,   fvs2)  <- lookupQualifiedDoStmtName ctxt mfixName         ; (bind_op,   fvs3)  <- lookupQualifiedDoStmtName ctxt bindMName@@ -879,7 +1184,7 @@                               segs           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]         ; (thing, fvs_later) <- thing_inside bndrs-        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+        ; let (rec_stmts', fvs) = segmentRecStmts (locA loc) ctxt empty_rec_stmt segs fvs_later         -- We aren't going to try to group RecStmts with         -- ApplicativeDo, so attaching empty FVs is fine.         ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)@@ -901,7 +1206,7 @@          -- Rename the stmts and the 'by' expression          -- Keep track of the variables mentioned in the 'by' expression        ; ((stmts', (by', used_bndrs, thing)), fvs2)-             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->+             <- rnStmts (TransStmtCtxt ctxt) rnExpr stmts $ \ bndrs ->                 do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by                    ; (thing, fvs_thing) <- thing_inside bndrs                    ; let fvs = fvs_by `plusFV` fvs_thing@@ -953,7 +1258,7 @@      rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)       = do { ((stmts', (used_bndrs, segs', thing)), fvs)-                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->+                    <- rnStmts ctxt rnExpr stmts $ \ bndrs ->                        setLocalRdrEnv env       $ do                        { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs                        ; let used_bndrs = filter (`elemNameSet` fvs) bndrs@@ -988,12 +1293,12 @@   = do { rebindable_on <- xoptM LangExt.RebindableSyntax        ; if rebindable_on          then do { fm <- lookupOccRn (nameRdrName name)-                 ; return (HsVar noExtField (noLoc fm), unitFV fm) }+                 ; return (HsVar noExtField (noLocA fm), unitFV fm) }          else not_rebindable }   | otherwise   = not_rebindable   where-    not_rebindable = return (HsVar noExtField (noLoc name), emptyFVs)+    not_rebindable = return (HsVar noExtField (noLocA name), emptyFVs)  -- | Is this a context where we respect RebindableSyntax? -- but ListComp are never rebindable@@ -1049,14 +1354,13 @@   -- wrapper that does both the left- and right-hand sides-rnRecStmtsAndThen :: Outputable (body GhcPs) =>+rnRecStmtsAndThen :: AnnoBody body =>                      HsStmtContext GhcRn-                  -> (Located (body GhcPs)-                  -> RnM (Located (body GhcRn), FreeVars))-                  -> [LStmt GhcPs (Located (body GhcPs))]+                  -> (body GhcPs -> RnM (body GhcRn, FreeVars))+                  -> [LStmt GhcPs (LocatedA (body GhcPs))]                          -- assumes that the FreeVars returned includes                          -- the FreeVars of the Segments-                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]+                  -> ([Segment (LStmt GhcRn (LocatedA (body GhcRn)))]                       -> RnM (a, FreeVars))                   -> RnM (a, FreeVars) rnRecStmtsAndThen ctxt rnBody s cont@@ -1067,7 +1371,7 @@         ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s            --    ...bring them and their fixities into scope-        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)+        ; let bound_names = collectLStmtsBinders CollNoDictBinders (map fst new_lhs_and_fv)               -- Fake uses of variables introduced implicitly (warning suppression, see #4404)               rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)               implicit_uses = mkNameSet $ concatMap snd $ rec_uses@@ -1086,7 +1390,7 @@ collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l =     foldr (\ s -> \acc -> case s of-            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->+            (L _ (LetStmt _ (HsValBinds _ (ValBinds _ _ sigs)))) ->               foldr (\ sig -> \ acc -> case sig of                                          (L loc (FixSig _ s)) -> (L loc s) : acc                                          _ -> acc) acc sigs@@ -1094,12 +1398,12 @@  -- left-hand sides -rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv-                -> LStmt GhcPs body+rn_rec_stmt_lhs :: AnnoBody body => MiniFixityEnv+                -> LStmt GhcPs (LocatedA (body GhcPs))                    -- rename LHS, and return its FVs                    -- Warning: we will only need the FreeVars below in the case of a BindStmt,                    -- so we don't bother to compute it accurately in the other cases-                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]+                -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]  rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))   = return [(L loc (BodyStmt noExtField body a b), emptyFVs)]@@ -1111,20 +1415,20 @@   = do       -- should the ctxt be MDo instead?       (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat-      return [(L loc (BindStmt noExtField pat' body), fv_pat)]+      return [(L loc (BindStmt noAnn pat' body), fv_pat)] -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))+rn_rec_stmt_lhs _ (L _ (LetStmt _ binds@(HsIPBinds {})))   = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))+rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (HsValBinds x binds)))     = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds-         return [(L loc (LetStmt noExtField (L l (HsValBinds x binds'))),+         return [(L loc (LetStmt noAnn (HsValBinds x binds')),                  -- Warning: this is bogus; see function invariant                  emptyFVs                  )]  -- XXX Do we need to do something with the return and mfix names?-rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec+rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = L _ stmts }))  -- Flatten Rec inside Rec     = rn_rec_stmts_lhs fix_env stmts  rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo@@ -1136,15 +1440,15 @@ rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet   = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))+rn_rec_stmt_lhs _ (L _ (LetStmt _ (EmptyLocalBinds _)))   = panic "rn_rec_stmt LetStmt EmptyLocalBinds" -rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv-                 -> [LStmt GhcPs body]-                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]+rn_rec_stmts_lhs :: AnnoBody body => MiniFixityEnv+                 -> [LStmt GhcPs (LocatedA (body GhcPs))]+                 -> RnM [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)] rn_rec_stmts_lhs fix_env stmts   = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts-       ; let boundNames = collectLStmtsBinders (map fst ls)+       ; let boundNames = collectLStmtsBinders CollNoDictBinders (map fst ls)             -- First do error checking: we need to check for dups here because we             -- don't bind all of the variables from the Stmt at once             -- with bindLocatedLocals.@@ -1154,48 +1458,48 @@  -- right-hand-sides -rn_rec_stmt :: (Outputable (body GhcPs)) =>+rn_rec_stmt :: AnnoBody body =>                HsStmtContext GhcRn-            -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+            -> (body GhcPs -> RnM (body GhcRn, FreeVars))             -> [Name]-            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)-            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]+            -> (LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)+            -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))]         -- Rename a Stmt that is inside a RecStmt (or mdo)         -- Assumes all binders are already in scope         -- Turns each stmt into a singleton Stmt-rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ body noret _), _)+rn_rec_stmt ctxt rnBody _ (L loc (LastStmt _ (L lb body) noret _), _)   = do  { (body', fv_expr) <- rnBody body         ; (ret_op, fvs1)   <- lookupQualifiedDo ctxt returnMName         ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,-                   L loc (LastStmt noExtField body' noret ret_op))] }+                   L loc (LastStmt noExtField (L lb body') noret ret_op))] } -rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ body _ _), _)+rn_rec_stmt ctxt rnBody _ (L loc (BodyStmt _ (L lb body) _ _), _)   = do { (body', fvs) <- rnBody body        ; (then_op, fvs1) <- lookupQualifiedDo ctxt thenMName        ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,-                 L loc (BodyStmt noExtField body' then_op noSyntaxExpr))] }+                 L loc (BodyStmt noExtField (L lb body') then_op noSyntaxExpr))] } -rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' body), fv_pat)+rn_rec_stmt ctxt rnBody _ (L loc (BindStmt _ pat' (L lb body)), fv_pat)   = do { (body', fv_expr) <- rnBody body        ; (bind_op, fvs1) <- lookupQualifiedDo ctxt bindMName         ; (fail_op, fvs2) <- getMonadFailOp ctxt -       ; let bndrs = mkNameSet (collectPatBinders pat')+       ; let bndrs = mkNameSet (collectPatBinders CollNoDictBinders pat')              fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2        ; let xbsrn = XBindStmtRn { xbsrn_bindOp = bind_op, xbsrn_failOp = fail_op }        ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,-                  L loc (BindStmt xbsrn pat' body'))] }+                  L loc (BindStmt xbsrn pat' (L lb body')))] } -rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)+rn_rec_stmt _ _ _ (L _ (LetStmt _ binds@(HsIPBinds {})), _)   = failWith (badIpBinds (text "an mdo expression") binds) -rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)+rn_rec_stmt _ _ all_bndrs (L loc (LetStmt _ (HsValBinds x binds')), _)   = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'            -- fixities and unused are handled above in rnRecStmtsAndThen        ; let fvs = allUses du_binds        ; return [(duDefs du_binds, fvs, emptyNameSet,-                 L loc (LetStmt noExtField (L l (HsValBinds x binds'))))] }+                 L loc (LetStmt noAnn (HsValBinds x binds')))] }  -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ _ stmt@(L _ (RecStmt {}), _)@@ -1207,27 +1511,28 @@ rn_rec_stmt _ _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo   = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) -rn_rec_stmt _ _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)+rn_rec_stmt _ _ _ (L _ (LetStmt _ (EmptyLocalBinds _)), _)   = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"  rn_rec_stmt _ _ _ stmt@(L _ (ApplicativeStmt {}), _)   = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: Outputable (body GhcPs) =>+rn_rec_stmts :: AnnoBody body =>                 HsStmtContext GhcRn-             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+             -> (body GhcPs -> RnM (body GhcRn, FreeVars))              -> [Name]-             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]-             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]+             -> [(LStmtLR GhcRn GhcPs (LocatedA (body GhcPs)), FreeVars)]+             -> RnM [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] rn_rec_stmts ctxt rnBody bndrs stmts   = do { segs_s <- mapM (rn_rec_stmt ctxt rnBody bndrs) stmts        ; return (concat segs_s) }  ----------------------------------------------segmentRecStmts :: SrcSpan -> HsStmtContext GhcRn-                -> Stmt GhcRn body-                -> [Segment (LStmt GhcRn body)] -> FreeVars-                -> ([LStmt GhcRn body], FreeVars)+segmentRecStmts :: AnnoBody body+                => SrcSpan -> HsStmtContext GhcRn+                -> Stmt GhcRn (LocatedA (body GhcRn))+                -> [Segment (LStmt GhcRn (LocatedA (body GhcRn)))] -> FreeVars+                -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)  segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later   | null segs@@ -1242,8 +1547,8 @@                 --         used 'after' the RecStmt    | otherwise-  = ([ L loc $-       empty_rec_stmt { recS_stmts = ss+  = ([ L (noAnnSrcSpan loc) $+       empty_rec_stmt { recS_stmts = noLocA ss                       , recS_later_ids = nameSetElemsStable                                            (defs `intersectNameSet` fvs_later)                       , recS_rec_ids   = nameSetElemsStable@@ -1360,12 +1665,12 @@           not_needed (defs,_,_,_) = disjointNameSet defs uses  -----------------------------------------------------segsToStmts :: Stmt GhcRn body+segsToStmts :: Stmt GhcRn (LocatedA (body GhcRn))                                   -- A RecStmt with the SyntaxOps filled in-            -> [Segment [LStmt GhcRn body]]+            -> [Segment [LStmt GhcRn (LocatedA (body GhcRn))]]                                   -- Each Segment has a non-empty list of Stmts             -> FreeVars           -- Free vars used 'later'-            -> ([LStmt GhcRn body], FreeVars)+            -> ([LStmt GhcRn (LocatedA (body GhcRn))], FreeVars)  segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later@@ -1375,7 +1680,7 @@     (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later     new_stmt | non_rec   = head ss              | otherwise = L (getLoc (head ss)) rec_stmt-    rec_stmt = empty_rec_stmt { recS_stmts     = ss+    rec_stmt = empty_rec_stmt { recS_stmts     = noLocA ss                               , recS_later_ids = nameSetElemsStable used_later                               , recS_rec_ids   = nameSetElemsStable fwds }           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]@@ -1738,19 +2043,19 @@              }, emptyFVs)    stmtTreeArg ctxt tail_fvs tree = do      let stmts = flattenStmtTree tree-         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)+         pvarset = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)                      `intersectNameSet` tail_fvs          pvars = nameSetElemsStable pvarset            -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]          pat = mkBigLHsVarPatTup pvars-         tup = mkBigLHsVarTup pvars+         tup = mkBigLHsVarTup pvars noExtField      (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset      (mb_ret, fvs1) <-         if | L _ ApplicativeStmt{} <- last stmts' ->              return (unLoc tup, emptyNameSet)            | otherwise -> do              (ret, _) <- lookupQualifiedDoExpr ctxt returnMName-             let expr = HsApp noExtField (noLoc ret) tup+             let expr = HsApp noComments (noLocA ret) tup              return (expr, emptyFVs)      return ( ApplicativeArgMany               { xarg_app_arg_many = noExtField@@ -1769,7 +2074,7 @@   -> [[(ExprLStmt GhcRn, FreeVars)]] segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)   where-    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)+    allvars = mkNameSet (concatMap (collectStmtBinders CollNoDictBinders . unLoc . fst) stmts)      -- We would rather not have a segment that just has LetStmts in     -- it, so combine those with an adjacent segment where possible.@@ -1809,7 +2114,7 @@       | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)       | otherwise      = (pvars, fvs')       where fvs' = fvs `intersectNameSet` allvars-            pvars = mkNameSet (collectStmtBinders (unLoc stmt))+            pvars = mkNameSet (collectStmtBinders CollNoDictBinders (unLoc stmt))      isStrictPatternBind :: ExprLStmt GhcRn -> Bool     isStrictPatternBind (L _ (BindStmt _ pat _)) = isStrictPattern pat@@ -1876,7 +2181,7 @@                                          not (isIrrefutableHsPat dflags pat) hasRefutablePattern _ _ = False -isLetStmt :: LStmt a b -> Bool+isLetStmt :: LStmt (GhcPass a) b -> Bool isLetStmt (L _ LetStmt{}) = True isLetStmt _ = False @@ -1902,10 +2207,10 @@       _other -> (stmts,[])  slurpIndependentStmts-   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]-   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts-            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts-            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )+   :: [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)]+   -> Maybe ( [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- LetStmts+            , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] -- BindStmts+            , [(LStmt GhcRn (LocatedA (body GhcRn)), FreeVars)] ) slurpIndependentStmts stmts = go [] [] emptyNameSet stmts  where   -- If we encounter a BindStmt that doesn't depend on a previous BindStmt@@ -1917,7 +2222,7 @@     | disjointNameSet bndrs fvs && not (isStrictPattern pat)     = go lets ((L loc (BindStmt xbs pat body), fvs) : indep)          bndrs' rest-    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)+    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders CollNoDictBinders pat)   -- If we encounter a LetStmt that doesn't depend on a BindStmt in this   -- group, then move it to the beginning, so that it doesn't interfere with   -- grouping more BindStmts.@@ -1958,7 +2263,7 @@                 ; return (Just join_op, fvs) }            else              return (Nothing, emptyNameSet)-       ; let applicative_stmt = noLoc $ ApplicativeStmt noExtField+       ; let applicative_stmt = noLocA $ ApplicativeStmt noExtField                (zip (fmap_op : repeat ap_op) args)                mb_join        ; return ( applicative_stmt : body_stmts@@ -2020,9 +2325,9 @@ emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt  -----------------------checkLastStmt :: Outputable (body GhcPs) => HsStmtContext GhcRn-              -> LStmt GhcPs (Located (body GhcPs))-              -> RnM (LStmt GhcPs (Located (body GhcPs)))+checkLastStmt :: AnnoBody body => HsStmtContext GhcRn+              -> LStmt GhcPs (LocatedA (body GhcPs))+              -> RnM (LStmt GhcPs (LocatedA (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt)   = case ctxt of       ListComp  -> check_comp@@ -2051,7 +2356,7 @@  -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext GhcRn-          -> LStmt GhcPs (Located (body GhcPs))+          -> LStmt GhcPs (LocatedA (body GhcPs))           -> RnM () checkStmt ctxt (L _ stmt)   = do { dflags <- getDynFlags@@ -2078,7 +2383,7 @@  okStmt, okDoStmt, okCompStmt, okParStmt    :: DynFlags -> HsStmtContext GhcRn-   -> Stmt GhcPs (Located (body GhcPs)) -> Validity+   -> Stmt GhcPs (LocatedA (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to a generic error message @@ -2095,7 +2400,7 @@       TransStmtCtxt ctxt -> okStmt dflags ctxt stmt  --------------okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity+okPatGuardStmt :: Stmt GhcPs (LocatedA (body GhcPs)) -> Validity okPatGuardStmt stmt   = case stmt of       BodyStmt {} -> IsValid@@ -2106,8 +2411,8 @@ ------------- okParStmt dflags ctxt stmt   = case stmt of-      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid-      _                              -> okStmt dflags ctxt stmt+      LetStmt _ (HsIPBinds {}) -> emptyInvalid+      _                        -> okStmt dflags ctxt stmt  ---------------- okDoStmt dflags ctxt stmt@@ -2138,7 +2443,7 @@        ApplicativeStmt {} -> emptyInvalid  ----------checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()+checkTupleSection :: [HsTupArg GhcPs] -> RnM () checkTupleSection args   = do  { tuple_section <- xoptM LangExt.TupleSections         ; checkErr (all tupArgPresent args || tuple_section) msg }@@ -2228,34 +2533,123 @@         arg_name <- newSysName arg_lit         let arg_syn_expr = nlHsVar arg_name             body :: LHsExpr GhcRn =-              nlHsApp (noLoc failExpr)-                      (nlHsApp (noLoc $ fromStringExpr) arg_syn_expr)+              nlHsApp (noLocA failExpr)+                      (nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)         let failAfterFromStringExpr :: HsExpr GhcRn =-              unLoc $ mkHsLam [noLoc $ VarPat noExtField $ noLoc arg_name] body+              unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body         let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =               mkSyntaxExpr failAfterFromStringExpr         return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)       | otherwise = lookupQualifiedDo ctxt failMName --- Rebinding 'if's to 'ifThenElse' applications.---++{- *********************************************************************+*                                                                      *+              Generating code for HsExpanded+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++genHsApps :: Name -> [LHsExpr GhcRn] -> HsExpr GhcRn+genHsApps fun args = foldl genHsApp (genHsVar fun) args++genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn+genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg++genLHsVar :: Name -> LHsExpr GhcRn+genLHsVar nm = wrapGenSpan $ genHsVar nm++genHsVar :: Name -> HsExpr GhcRn+genHsVar nm = HsVar noExtField $ wrapGenSpan nm++genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn+genAppType expr = HsAppType noExtField (wrapGenSpan expr) . mkEmptyWildCardBndrs . wrapGenSpan++genHsTyLit :: FastString -> HsType GhcRn+genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText++wrapGenSpan :: a -> LocatedAn an a+-- Wrap something in a "generatedSrcSpan" -- See Note [Rebindable syntax and HsExpansion]-rebindIf-  :: Located Name  -- 'Name' for the 'ifThenElse' function we will rebind to-  -> LHsExpr GhcRn -- renamed condition-  -> LHsExpr GhcRn -- renamed true branch-  -> LHsExpr GhcRn -- renamed false branch-  -> HsExpr GhcRn  -- rebound if expression-rebindIf ifteName p b1 b2 =-  let ifteOrig = HsIf noExtField p b1 b2-      ifteFun  = L generatedSrcSpan (HsVar noExtField ifteName)-                 -- ifThenElse var-      ifteApp  = mkHsAppsWith (\_ _ e -> L generatedSrcSpan e)-                              ifteFun-                              [p, b1, b2]-                 -- desugared_if_expr =-                 --   ifThenElse desugared_predicate-                 --              desugared_true_branch-                 --              desugared_false_branch-  in mkExpanded XExpr ifteOrig (unLoc ifteApp)-     -- (source_if_expr, desugared_if_expr)+wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x++-- | Build a 'HsExpansion' out of an extension constructor,+--   and the two components of the expansion: original and+--   desugared expressions.+mkExpandedExpr+  :: HsExpr GhcRn           -- ^ source expression+  -> HsExpr GhcRn           -- ^ expanded expression+  -> HsExpr GhcRn           -- ^ suitably wrapped 'HsExpansion'+mkExpandedExpr a b = XExpr (HsExpanded a b)++-----------------------------------------+-- Bits and pieces for RecordDotSyntax.+--+-- See Note [Overview of record dot syntax] in GHC.Hs.Expr.++-- mkGetField arg field calcuates a get_field @field arg expression.+-- e.g. z.x = mkGetField z x = get_field @x z+mkGetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+mkGetField get_field arg field = unLoc (head $ mkGet get_field [arg] field)++-- mkSetField a field b calculates a set_field @field expression.+-- e.g mkSetSetField a field b = set_field @"field" a b (read as "set field 'field' on a to b").+mkSetField :: Name -> LHsExpr GhcRn -> Located FieldLabelString -> LHsExpr GhcRn -> HsExpr GhcRn+mkSetField set_field a (L _ field) b =+  genHsApp (genHsApp (genHsVar set_field `genAppType` genHsTyLit field)  a) b++mkGet :: Name -> [LHsExpr GhcRn] -> Located FieldLabelString -> [LHsExpr GhcRn]+mkGet get_field l@(r : _) (L _ field) =+  wrapGenSpan (genHsApp (genHsVar get_field `genAppType` genHsTyLit field) r) : l+mkGet _ [] _ = panic "mkGet : The impossible has happened!"++mkSet :: Name -> LHsExpr GhcRn -> (Located FieldLabelString, LHsExpr GhcRn) -> LHsExpr GhcRn+mkSet set_field acc (field, g) = wrapGenSpan (mkSetField set_field g field acc)++-- mkProjection fields calculates a projection.+-- e.g. .x = mkProjection [x] = getField @"x"+--      .x.y = mkProjection [.x, .y] = (.y) . (.x) = getField @"y" . getField @"x"+mkProjection :: Name -> Name -> NonEmpty (Located FieldLabelString) -> HsExpr GhcRn+mkProjection getFieldName circName (field :| fields) = foldl' f (proj field) fields+  where+    f :: HsExpr GhcRn -> Located FieldLabelString -> HsExpr GhcRn+    f acc field = genHsApps circName $ map wrapGenSpan [proj field, acc]++    proj :: Located FieldLabelString -> HsExpr GhcRn+    proj (L _ f) = genHsVar getFieldName `genAppType` genHsTyLit f++-- mkProjUpdateSetField calculates functions representing dot notation record updates.+-- e.g. Suppose an update like foo.bar = 1.+--      We calculate the function \a -> setField @"foo" a (setField @"bar" (getField @"foo" a) 1).+mkProjUpdateSetField :: Name -> Name -> LHsRecProj GhcRn (LHsExpr GhcRn) -> (LHsExpr GhcRn -> LHsExpr GhcRn)+mkProjUpdateSetField get_field set_field (L _ (HsRecField { hsRecFieldLbl = (L _ (FieldLabelStrings flds')), hsRecFieldArg = arg } ))+  = let {+      ; flds = map (fmap (unLoc . hflLabel)) flds'+      ; final = last flds  -- quux+      ; fields = init flds   -- [foo, bar, baz]+      ; getters = \a -> foldl' (mkGet get_field) [a] fields  -- Ordered from deep to shallow.+          -- [getField@"baz"(getField@"bar"(getField@"foo" a), getField@"bar"(getField@"foo" a), getField@"foo" a, a]+      ; zips = \a -> (final, head (getters a)) : zip (reverse fields) (tail (getters a)) -- Ordered from deep to shallow.+          -- [("quux", getField@"baz"(getField@"bar"(getField@"foo" a)), ("baz", getField@"bar"(getField@"foo" a)), ("bar", getField@"foo" a), ("foo", a)]+      }+    in (\a -> foldl' (mkSet set_field) arg (zips a))+          -- setField@"foo" (a) (setField@"bar" (getField @"foo" (a))(setField@"baz" (getField @"bar" (getField @"foo" (a)))(setField@"quux" (getField @"baz" (getField @"bar" (getField @"foo" (a))))(quux))))++mkRecordDotUpd :: Name -> Name -> LHsExpr GhcRn -> [LHsRecUpdProj GhcRn] -> HsExpr GhcRn+mkRecordDotUpd get_field set_field exp updates = foldl' fieldUpdate (unLoc exp) updates+  where+    fieldUpdate :: HsExpr GhcRn -> LHsRecUpdProj GhcRn -> HsExpr GhcRn+    fieldUpdate acc lpu =  unLoc $ (mkProjUpdateSetField get_field set_field lpu) (wrapGenSpan acc)++rnHsUpdProjs :: [LHsRecUpdProj GhcPs] -> RnM ([LHsRecUpdProj GhcRn], FreeVars)+rnHsUpdProjs us = do+  (u, fvs) <- unzip <$> mapM rnRecUpdProj us+  pure (u, plusFVs fvs)+  where+    rnRecUpdProj :: LHsRecUpdProj GhcPs -> RnM (LHsRecUpdProj GhcRn, FreeVars)+    rnRecUpdProj (L l (HsRecField _ fs arg pun))+      = do { (arg, fv) <- rnLExpr arg+           ; return $ (L l (HsRecField { hsRecFieldAnn = noAnn+                                       , hsRecFieldLbl = fmap rnFieldLabelStrings fs+                                       , hsRecFieldArg = arg+                                       , hsRecPun = pun}), fv) }

GHC/Rename/Expr.hs-boot view

@@ -1,17 +1,27 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-} module GHC.Rename.Expr where import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars ) import GHC.Tc.Types-import GHC.Types.SrcLoc   ( Located ) import GHC.Utils.Outputable  ( Outputable ) +rnExpr :: HsExpr GhcPs+        -> RnM (HsExpr GhcRn, FreeVars)+ rnLExpr :: LHsExpr GhcPs         -> RnM (LHsExpr GhcRn, FreeVars) +type AnnoBody body+  = ( Outputable (body GhcPs)+    , Anno (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcRn GhcPs (LocatedA (body GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA+    ) rnStmts :: --forall thing body.-           Outputable (body GhcPs) => HsStmtContext GhcRn-        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))-        -> [LStmt GhcPs (Located (body GhcPs))]+           AnnoBody body => HsStmtContext GhcRn+        -> (body GhcPs -> RnM (body GhcRn, FreeVars))+        -> [LStmt GhcPs (LocatedA (body GhcPs))]         -> ([Name] -> RnM (thing, FreeVars))-        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+        -> RnM (([LStmt GhcRn (LocatedA (body GhcRn))], thing), FreeVars)

GHC/Rename/Fixity.hs view

@@ -1,11 +1,8 @@-{-# LANGUAGE ViewPatterns #-}- {-- This module contains code which maintains and manipulates the fixity environment during renaming.- -}+ module GHC.Rename.Fixity    ( MiniFixityEnv    , addLocalFixities@@ -13,28 +10,35 @@    , lookupFixityRn_help    , lookupFieldFixityRn    , lookupTyFixityRn-   )-where+   ) where  import GHC.Prelude  import GHC.Iface.Load import GHC.Hs-import GHC.Types.Name.Reader-import GHC.Driver.Types import GHC.Tc.Utils.Monad++import GHC.Unit.Module+import GHC.Unit.Module.ModIface++import GHC.Types.Fixity.Env import GHC.Types.Name import GHC.Types.Name.Env-import GHC.Unit.Module-import GHC.Types.Basic  ( Fixity(..), FixityDirection(..), minPrecedence,-                          defaultFixity, SourceText(..) )+import GHC.Types.Name.Reader+import GHC.Types.Fixity+import GHC.Types.SourceText import GHC.Types.SrcLoc+ import GHC.Utils.Outputable+import GHC.Utils.Panic+ import GHC.Data.Maybe-import Data.List-import Data.Function    ( on )+ import GHC.Rename.Unbound +import Data.List (groupBy)+import Data.Function    ( on )+ {- ********************************************************* *                                                      *@@ -177,7 +181,7 @@     doc = text "Checking fixity for" <+> ppr name  ----------------lookupTyFixityRn :: Located Name -> RnM Fixity+lookupTyFixityRn :: LocatedN Name -> RnM Fixity lookupTyFixityRn = lookupFixityRn . unLoc  -- | Look up the fixity of a (possibly ambiguous) occurrence of a record field@@ -207,7 +211,7 @@         ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)                   >> return (Fixity NoSourceText minPrecedence InfixL) -    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)+    lookup_gre_fixity gre = lookupFixityRn' (greMangledName gre) (greOccName gre)      ambiguous_fixity_err rn ambigs       = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)

GHC/Rename/HsType.hs view

@@ -1,21 +1,24 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}- module GHC.Rename.HsType (         -- Type related stuff         rnHsType, rnLHsType, rnLHsTypes, rnContext,         rnHsKind, rnLHsKind, rnLHsTypeArgs,-        rnHsSigType, rnHsWcType,-        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsPatSigType,+        rnHsSigType, rnHsWcType, rnHsPatSigTypeBindingVars,+        HsPatSigTypeScoping(..), rnHsSigWcType, rnHsPatSigType,         newTyVarNameRn,         rnConDeclFields,+        lookupField,         rnLTyVar,          rnScaledLHsType,@@ -26,51 +29,54 @@         checkPrecMatch, checkSectionPrec,          -- Binding related stuff-        bindHsForAllTelescope,+        bindHsOuterTyVarBndrs, bindHsForAllTelescope,         bindLHsTyVarBndr, bindLHsTyVarBndrs, WarnUnusedForalls(..),-        rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars,+        rnImplicitTvOccs, bindSigTyVarsFV, bindHsQTyVars,         FreeKiTyVars,         extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,-        extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars,-        extractHsTvBndrs, extractHsTyArgRdrKiTyVars,-        extractHsScaledTysRdrTyVars,-        forAllOrNothing, nubL+        extractHsTysRdrTyVars, extractRdrKindSigVars,+        extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,+        extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,+        nubL, nubN   ) where  import GHC.Prelude  import {-# SOURCE #-} GHC.Rename.Splice( rnSpliceType ) +import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Driver.Session import GHC.Hs-import GHC.Rename.Doc    ( rnLHsDoc, rnMbLHsDoc ) import GHC.Rename.Env import GHC.Rename.Utils  ( HsDocContext(..), inHsDocContext, withHsDocContext                          , mapFvRn, pprHsDocContext, bindLocalNamesFV-                         , typeAppErr, newLocalBndrRn, checkDupRdrNames+                         , typeAppErr, newLocalBndrRn, checkDupRdrNamesN                          , checkShadowedRdrNames ) import GHC.Rename.Fixity ( lookupFieldFixityRn, lookupFixityRn                          , lookupTyFixityRn )+import GHC.Rename.Unbound ( notInScopeErr ) 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-                        , Fixity(..), FixityDirection(..), LexicalFixity(..)-                        , TypeOrKind(..) )+import GHC.Types.Fixity ( compareFixity, negateFixity+                        , Fixity(..), FixityDirection(..), LexicalFixity(..) )+import GHC.Types.Basic  ( TypeOrKind(..) ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt -import Data.List          ( nubBy, partition )-import Control.Monad      ( unless, when )+import Data.List (sortBy, nubBy, partition)+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))+import Control.Monad  #include "HsVersions.h" @@ -85,7 +91,7 @@ ********************************************************* -} -data HsSigWcTypeScoping+data HsPatSigTypeScoping   = AlwaysBind     -- ^ Always bind any free tyvars of the given type, regardless of whether we     -- have a forall at the top.@@ -106,10 +112,6 @@     -- variables. If a RULE explicitly quantifies its type variables, then     -- 'NeverBind' is used instead. See also     -- @Note [Pattern signature binders and scoping]@ in "GHC.Hs.Type".-  | BindUnlessForall-    -- ^ Unless there's forall at the top, do the same thing as 'AlwaysBind'.-    -- This is only ever used in places where the \"@forall@-or-nothing\" rule-    -- is in effect. See @Note [forall-or-nothing rule]@.   | NeverBind     -- ^ Never bind any free tyvars. This is used for RULES that have both     -- explicit type and term variable binders, e.g.:@@ -127,13 +129,19 @@ rnHsSigWcType :: HsDocContext               -> LHsSigWcType GhcPs               -> RnM (LHsSigWcType GhcRn, FreeVars)-rnHsSigWcType doc (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})-  = rn_hs_sig_wc_type BindUnlessForall doc hs_ty $ \nwcs imp_tvs body ->-    let ib_ty = HsIB { hsib_ext = imp_tvs, hsib_body = body  }-        wc_ty = HsWC { hswc_ext = nwcs,    hswc_body = ib_ty } in-    pure (wc_ty, emptyFVs)+rnHsSigWcType doc (HsWC { hswc_body =+    sig_ty@(L loc (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty })) })+  = do { free_vars <- filterInScopeM (extract_lhs_sig_ty sig_ty)+       ; (nwc_rdrs', imp_tv_nms) <- partition_nwcs free_vars+       ; let nwc_rdrs = nubL nwc_rdrs'+       ; bindHsOuterTyVarBndrs doc Nothing imp_tv_nms outer_bndrs $ \outer_bndrs' ->+    do { (wcs, body_ty', fvs) <- rnWcBody doc nwc_rdrs body_ty+       ; pure ( HsWC  { hswc_ext = wcs, hswc_body = L loc $+                HsSig { sig_ext = noExtField+                      , sig_bndrs = outer_bndrs', sig_body = body_ty' }}+              , fvs) } } -rnHsPatSigType :: HsSigWcTypeScoping+rnHsPatSigType :: HsPatSigTypeScoping                -> HsDocContext                -> HsPatSigType GhcPs                -> (HsPatSigType GhcRn -> RnM (a, FreeVars))@@ -148,33 +156,20 @@ rnHsPatSigType scoping ctx sig_ty thing_inside   = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables        ; checkErr ty_sig_okay (unexpectedPatSigTypeErr sig_ty)-       ; rn_hs_sig_wc_type scoping ctx (hsPatSigType sig_ty) $-         \nwcs imp_tvs body ->-    do { let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }-             sig_ty'   = HsPS { hsps_ext = sig_names, hsps_body = body }-       ; thing_inside sig_ty'-       } }---- The workhorse for rnHsSigWcType and rnHsPatSigType.-rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext-                  -> LHsType GhcPs-                  -> ([Name]    -- Wildcard names-                      -> [Name] -- Implicitly bound type variable names-                      -> LHsType GhcRn-                      -> RnM (a, FreeVars))-                  -> RnM (a, FreeVars)-rn_hs_sig_wc_type scoping ctxt hs_ty thing_inside-  = do { free_vars <- filterInScopeM (extractHsTyRdrTyVars hs_ty)+       ; free_vars <- filterInScopeM (extractHsTyRdrTyVars pat_sig_ty)        ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars-       ; let nwc_rdrs = nubL nwc_rdrs'-       ; implicit_bndrs <- case scoping of-           AlwaysBind       -> pure tv_rdrs-           BindUnlessForall -> forAllOrNothing (isLHsForAllTy hs_ty) tv_rdrs-           NeverBind        -> pure []-       ; rnImplicitBndrs Nothing implicit_bndrs $ \ vars ->-    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty-       ; (res, fvs2) <- thing_inside wcs vars hs_ty'+       ; let nwc_rdrs = nubN nwc_rdrs'+             implicit_bndrs = case scoping of+               AlwaysBind -> tv_rdrs+               NeverBind  -> []+       ; rnImplicitTvOccs Nothing implicit_bndrs $ \ imp_tvs ->+    do { (nwcs, pat_sig_ty', fvs1) <- rnWcBody ctx nwc_rdrs pat_sig_ty+       ; let sig_names = HsPSRn { hsps_nwcs = nwcs, hsps_imp_tvs = imp_tvs }+             sig_ty'   = HsPS { hsps_ext = sig_names, hsps_body = pat_sig_ty' }+       ; (res, fvs2) <- thing_inside sig_ty'        ; return (res, fvs1 `plusFV` fvs2) } }+  where+    pat_sig_ty = hsPatSigType sig_ty  rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty })@@ -185,7 +180,58 @@        ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }        ; return (sig_ty', fvs) } -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs+-- Similar to rnHsWcType, but rather than requiring free variables in the type to+-- already be in scope, we are going to require them not to be in scope,+-- and we bind them.+rnHsPatSigTypeBindingVars :: HsDocContext+                          -> HsPatSigType GhcPs+                          -> (HsPatSigType GhcRn -> RnM (r, FreeVars))+                          -> RnM (r, FreeVars)+rnHsPatSigTypeBindingVars ctxt sigType thing_inside = case sigType of+  (HsPS { hsps_body = hs_ty }) -> do+    rdr_env <- getLocalRdrEnv+    let (varsInScope, varsNotInScope) =+          partition (inScope rdr_env . unLoc) (extractHsTyRdrTyVars hs_ty)+    -- TODO: Resolve and remove this comment.+    -- This next bit is in some contention. The original proposal #126+    -- (https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0126-type-applications-in-patterns.rst)+    -- says that in-scope variables are fine here: don't bind them, just use+    -- the existing vars, like in type signatures. An amendment #291+    -- (https://github.com/ghc-proposals/ghc-proposals/pull/291) says that the+    -- use of an in-scope variable should *shadow* an in-scope tyvar, like in+    -- terms. In an effort to make forward progress, the current implementation+    -- just rejects any use of an in-scope variable, meaning GHC will accept+    -- a subset of programs common to both variants. If this comment still exists+    -- in mid-to-late 2021 or thereafter, we have done a poor job on following+    -- up on this point.+    -- Example:+    --   f :: forall a. ...+    --   f (MkT @a ...) = ...+    -- Should the inner `a` refer to the outer one? shadow it? We are, as yet, undecided,+    -- so we currently reject.+    when (not (null varsInScope)) $+      addErr $+        vcat+          [ text "Type variable" <> plural varsInScope+            <+> hcat (punctuate (text ",") (map (quotes . ppr) varsInScope))+            <+> isOrAre varsInScope+            <+> text "already in scope."+          , text "Type applications in patterns must bind fresh variables, without shadowing."+          ]+    (wcVars, ibVars) <- partition_nwcs varsNotInScope+    rnImplicitTvBndrs ctxt Nothing ibVars $ \ ibVars' -> do+      (wcVars', hs_ty', fvs) <- rnWcBody ctxt wcVars hs_ty+      let sig_ty = HsPS+            { hsps_body = hs_ty'+            , hsps_ext = HsPSRn+              { hsps_nwcs    = wcVars'+              , hsps_imp_tvs = ibVars'+              }+            }+      (res, fvs') <- thing_inside sig_ty+      return (res, fvs `plusFV` fvs')++rnWcBody :: HsDocContext -> [LocatedN RdrName] -> LHsType GhcPs          -> RnM ([Name], LHsType GhcRn, FreeVars) rnWcBody ctxt nwc_rdrs hs_ty   = do { nwcs <- mapM newLocalBndrRn nwc_rdrs@@ -198,7 +244,7 @@        ; return (nwcs, hs_ty', fvs) }   where     rn_lty env (L loc hs_ty)-      = setSrcSpan loc $+      = setSrcSpanA loc $         do { (hs_ty', fvs) <- rn_ty env hs_ty            ; return (L loc hs_ty', fvs) } @@ -211,26 +257,35 @@                                 , hst_tele = tele', hst_body = hs_body' }                     , fvs) } -    rn_ty env (HsQualTy { hst_ctxt = L cx hs_ctxt+    rn_ty env (HsQualTy { hst_ctxt = m_ctxt                         , hst_body = hs_ty })-      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      | Just (L cx hs_ctxt) <- m_ctxt+      , Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt       , L lx (HsWildCardTy _)  <- ignoreParens hs_ctxt_last       = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1-           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1+           ; setSrcSpanA lx $ checkExtraConstraintWildCard env hs_ctxt1            ; let hs_ctxt' = hs_ctxt1' ++ [L lx (HsWildCardTy noExtField)]            ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = L cx hs_ctxt', hst_body = hs_ty' }+                              , hst_ctxt = Just (L cx hs_ctxt')+                              , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } -      | otherwise+      | Just (L cx hs_ctxt) <- m_ctxt       = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt            ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty            ; return (HsQualTy { hst_xqual = noExtField-                              , hst_ctxt = L cx hs_ctxt'+                              , hst_ctxt = Just (L cx hs_ctxt')                               , hst_body = hs_ty' }                     , fvs1 `plusFV` fvs2) } +      | Nothing <- m_ctxt+      = do { (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_xqual = noExtField+                              , hst_ctxt = Nothing+                              , hst_body = hs_ty' }+                    , fvs2) }+     rn_ty env hs_ty = rnHsTyKi env hs_ty      rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })@@ -283,7 +338,7 @@ -- FreeKiTyVars in the argument and returns them in a separate list. -- When the extension is disabled, the function returns the argument -- and empty list.  See Note [Renaming named wild cards]-partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)+partition_nwcs :: FreeKiTyVars -> RnM ([LocatedN RdrName], FreeKiTyVars) partition_nwcs free_vars   = do { wildcards_enabled <- xoptM LangExt.NamedWildCards        ; return $@@ -291,7 +346,7 @@            then partition is_wildcard free_vars            else ([], free_vars) }   where-     is_wildcard :: Located RdrName -> Bool+     is_wildcard :: LocatedN RdrName -> Bool      is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))  {- Note [Renaming named wild cards]@@ -309,7 +364,7 @@  ********************************************************* *                                                       *-           HsSigtype (i.e. no wildcards)+           HsSigType (i.e. no wildcards) *                                                       * ****************************************************** -} @@ -319,68 +374,44 @@             -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards-rnHsSigType ctx level (HsIB { hsib_body = hs_ty })-  = do { traceRn "rnHsSigType" (ppr hs_ty)-       ; rdr_env <- getLocalRdrEnv-       ; vars0 <- forAllOrNothing (isLHsForAllTy hs_ty)-           $ filterInScope rdr_env-           $ extractHsTyRdrTyVars hs_ty-       ; rnImplicitBndrs Nothing vars0 $ \ vars ->-    do { (body', fvs) <- rnLHsTyKi (mkTyKiEnv ctx level RnTypeBody) hs_ty+rnHsSigType ctx level+    (L loc sig_ty@(HsSig { sig_bndrs = outer_bndrs, sig_body = body }))+  = setSrcSpanA loc $+    do { traceRn "rnHsSigType" (ppr sig_ty)+       ; case outer_bndrs of+           HsOuterExplicit{} -> checkPolyKinds env sig_ty+           HsOuterImplicit{} -> pure ()+       ; imp_vars <- filterInScopeM $ extractHsTyRdrTyVars body+       ; bindHsOuterTyVarBndrs ctx Nothing imp_vars outer_bndrs $ \outer_bndrs' ->+    do { (body', fvs) <- rnLHsTyKi env body -       ; return ( HsIB { hsib_ext = vars-                       , hsib_body = body' }+       ; return ( L loc $ HsSig { sig_ext = noExtField+                                , sig_bndrs = outer_bndrs', sig_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.---- | 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.-forAllOrNothing :: Bool-                -- ^ True <=> explicit forall-                -- E.g.  f :: forall a. a->b-                --  we do not want to bring 'b' into scope, hence True-                -- But   f :: a -> b-                --  we want to bring both 'a' and 'b' into scope, hence False-                -> FreeKiTyVars-                -- ^ Free vars of the type-                -> RnM FreeKiTyVars-forAllOrNothing has_outer_forall fvs = case has_outer_forall of-  True -> do-    traceRn "forAllOrNothing" $ text "has explicit outer forall"-    pure []-  False -> do-    traceRn "forAllOrNothing" $ text "no explicit forall. implicit binders:" <+> ppr fvs-    pure fvs+  where+    env = mkTyKiEnv ctx level RnTypeBody -rnImplicitBndrs :: Maybe assoc-                -- ^ @'Just' _@ => an associated type decl-                -> FreeKiTyVars-                -- ^ Surface-syntax free vars that we will implicitly bind.-                -- May have duplicates, which are removed here.-                -> ([Name] -> RnM (a, FreeVars))-                -> RnM (a, FreeVars)-rnImplicitBndrs mb_assoc implicit_vs_with_dups thing_inside-  = do { let implicit_vs = nubL implicit_vs_with_dups+-- | Create new renamed type variables corresponding to source-level ones.+-- Duplicates are permitted, but will be removed. This is intended especially for+-- the case of handling the implicitly bound free variables of a type signature.+rnImplicitTvOccs :: Maybe assoc+                 -- ^ @'Just' _@ => an associated type decl+                 -> FreeKiTyVars+                 -- ^ Surface-syntax free vars that we will implicitly bind.+                 -- May have duplicates, which are removed here.+                 -> ([Name] -> RnM (a, FreeVars))+                 -> RnM (a, FreeVars)+rnImplicitTvOccs mb_assoc implicit_vs_with_dups thing_inside+  = do { let implicit_vs = nubN implicit_vs_with_dups -       ; traceRn "rnImplicitBndrs" $+       ; traceRn "rnImplicitTvOccs" $          vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]           -- Use the currently set SrcSpan as the new source location for each Name.          -- See Note [Source locations for implicitly bound type variables].        ; loc <- getSrcSpanM-       ; vars <- mapM (newTyVarNameRn mb_assoc . L loc . unLoc) implicit_vs+       ; let loc' = noAnnSrcSpan loc+       ; vars <- mapM (newTyVarNameRn mb_assoc . L loc' . unLoc) implicit_vs         ; bindLocalNamesFV vars $          thing_inside vars }@@ -388,7 +419,7 @@ {- Note [Source locations for implicitly bound type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When bringing implicitly bound type variables into scope (in rnImplicitBndrs),+When bringing implicitly bound type variables into scope (in rnImplicitTvOccs), we do something peculiar: we drop the original SrcSpan attached to each variable and replace it with the currently set SrcSpan. Moreover, this new SrcSpan is usually /less/ precise than the original one, and that's OK. To see@@ -408,6 +439,31 @@ sites. This is less precise, but more accurate. -} +-- | Create fresh type variables for binders, disallowing multiple occurrences of the same variable. Similar to `rnImplicitTvOccs` except that duplicate occurrences will+-- result in an error, and the source locations of the variables are not adjusted, as these variable occurrences are themselves the binding sites for the type variables,+-- rather than the variables being implicitly bound by a signature.+rnImplicitTvBndrs :: HsDocContext+                  -> Maybe assoc+                  -- ^ @'Just' _@ => an associated type decl+                  -> FreeKiTyVars+                  -- ^ Surface-syntax free vars that we will implicitly bind.+                  -- Duplicate variables will cause a compile-time error regarding repeated bindings.+                  -> ([Name] -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+rnImplicitTvBndrs ctx mb_assoc implicit_vs_with_dups thing_inside+  = do { implicit_vs <- forM (NE.groupBy eqLocated $ sortBy cmpLocated $ implicit_vs_with_dups) $ \case+           (x :| []) -> return x+           (x :| _) -> do addErr $ text "Variable" <+> text "`" <> ppr x <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."+                          return x++       ; traceRn "rnImplicitTvBndrs" $+         vcat [ ppr implicit_vs_with_dups, ppr implicit_vs ]++       ; vars <- mapM (newTyVarNameRn mb_assoc) implicit_vs++       ; bindLocalNamesFV vars $+         thing_inside vars }+ {- ****************************************************** *                                                       *            LHsType and HsType@@ -418,9 +474,9 @@ rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. -Note [QualTy in kinds]+Note [HsQualTy in kinds] ~~~~~~~~~~~~~~~~~~~~~~-I was wondering whether QualTy could occur only at TypeLevel.  But no,+I was wondering whether HsQualTy could occur only at TypeLevel.  But no, we can have a qualified type in a kind too. Here is an example:    type family F a where@@ -443,9 +499,9 @@       Expected kind: G Bool         Actual kind: F Bool -However: in a kind, the constraints in the QualTy must all be+However: in a kind, the constraints in the HsQualTy must all be equalities; or at least, any kinds with a class constraint are-uninhabited.+uninhabited. See Note [Constraints in kinds] in GHC.Core.TyCo.Rep. -}  data RnTyKiEnv@@ -521,22 +577,23 @@ rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args  ---------------rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs-              -> RnM (LHsContext GhcRn, FreeVars)-rnTyKiContext env (L loc cxt)+rnTyKiContext :: RnTyKiEnv -> Maybe (LHsContext GhcPs)+              -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnTyKiContext _ Nothing = return (Nothing, emptyFVs)+rnTyKiContext env (Just (L loc cxt))   = do { traceRn "rncontext" (ppr cxt)        ; let env' = env { rtke_what = RnConstraint }        ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt-       ; return (L loc cxt', fvs) }+       ; return (Just $ L loc cxt', fvs) } -rnContext :: HsDocContext -> LHsContext GhcPs-          -> RnM (LHsContext GhcRn, FreeVars)+rnContext :: HsDocContext -> Maybe (LHsContext GhcPs)+          -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta  -------------- rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty)-  = setSrcSpan loc $+  = setSrcSpanA loc $     do { (ty', fvs) <- rnHsTyKi env ty        ; return (L loc ty', fvs) } @@ -551,7 +608,9 @@                 , fvs) } }  rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })-  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]+  = do { data_kinds <- xoptM LangExt.DataKinds -- See Note [HsQualTy in kinds]+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env ty))        ; (ctxt', fvs1) <- rnTyKiContext env lctxt        ; (tau',  fvs2) <- rnLHsTyKi env tau        ; return (HsQualTy { hst_xqual = noExtField, hst_ctxt = ctxt'@@ -567,25 +626,24 @@            -- Any type variable at the kind level is illegal without the use            -- of PolyKinds (see #14710)        ; name <- rnTyVar env rdr_name-       ; return (HsTyVar noExtField ip (L loc name), unitFV name) }+       ; return (HsTyVar noAnn ip (L loc name), unitFV name) }  rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)-  = setSrcSpan (getLoc l_op) $+  = setSrcSpan (getLocA l_op) $     do  { (l_op', fvs1) <- rnHsTyOp env ty l_op         ; 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)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsParTy noExtField ty', fvs) }+       ; return (HsParTy noAnn ty', fvs) } -rnHsTyKi env (HsBangTy _ b ty)+rnHsTyKi env (HsBangTy x b ty)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsBangTy noExtField b ty', fvs) }+       ; return (HsBangTy x b ty', fvs) }  rnHsTyKi env ty@(HsRecTy _ flds)   = do { let ctxt = rtke_ctxt env@@ -602,59 +660,51 @@  rnHsTyKi env (HsFunTy u 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 u w a b+       ; return (HsFunTy u mult' ty1' ty2'+                , plusFVs [fvs1, fvs2, w_fvs]) } -rnHsTyKi env listTy@(HsListTy _ ty)+rnHsTyKi env listTy@(HsListTy x ty)   = do { data_kinds <- xoptM LangExt.DataKinds        ; when (not data_kinds && isRnKindLevel env)               (addErr (dataKindsErr env listTy))        ; (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsListTy noExtField ty', fvs) }+       ; return (HsListTy x ty', fvs) } -rnHsTyKi env t@(HsKindSig _ ty k)-  = do { checkPolyKinds env t-       ; kind_sigs_ok <- xoptM LangExt.KindSignatures+rnHsTyKi env (HsKindSig x ty k)+  = do { kind_sigs_ok <- xoptM LangExt.KindSignatures        ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)        ; (ty', lhs_fvs) <- rnLHsTyKi env ty        ; (k', sig_fvs)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k-       ; return (HsKindSig noExtField ty' k', lhs_fvs `plusFV` sig_fvs) }+       ; return (HsKindSig x ty' k', lhs_fvs `plusFV` sig_fvs) }  -- Unboxed tuples are allowed to have poly-typed arguments.  These -- sometimes crop up as a result of CPR worker-wrappering dictionaries.-rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)+rnHsTyKi env tupleTy@(HsTupleTy x tup_con tys)   = do { data_kinds <- xoptM LangExt.DataKinds        ; when (not data_kinds && isRnKindLevel env)               (addErr (dataKindsErr env tupleTy))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsTupleTy noExtField tup_con tys', fvs) }+       ; return (HsTupleTy x tup_con tys', fvs) } -rnHsTyKi env sumTy@(HsSumTy _ tys)+rnHsTyKi env sumTy@(HsSumTy x tys)   = do { data_kinds <- xoptM LangExt.DataKinds        ; when (not data_kinds && isRnKindLevel env)               (addErr (dataKindsErr env sumTy))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys-       ; return (HsSumTy noExtField tys', fvs) }+       ; return (HsSumTy x tys', fvs) }  -- Ensure that a type-level integer is nonnegative (#8306, #8412) rnHsTyKi env tyLit@(HsTyLit _ t)   = do { data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env tyLit))        ; when (negLit t) (addErr negLitErr)-       ; checkPolyKinds env tyLit        ; return (HsTyLit noExtField t, emptyFVs) }   where     negLit (HsStrTy _ _) = False     negLit (HsNumTy _ i) = i < 0+    negLit (HsCharTy _ _) = False     negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit  rnHsTyKi env (HsAppTy _ ty1 ty2)@@ -669,10 +719,10 @@        ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k        ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi env t@(HsIParamTy _ n ty)+rnHsTyKi env t@(HsIParamTy x n ty)   = do { notInKinds env t        ; (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsIParamTy noExtField n ty', fvs) }+       ; return (HsIParamTy x n ty', fvs) }  rnHsTyKi _ (HsStarTy _ isUni)   = return (HsStarTy noExtField isUni, emptyFVs)@@ -680,26 +730,33 @@ rnHsTyKi _ (HsSpliceTy _ sp)   = rnSpliceType sp -rnHsTyKi env (HsDocTy _ ty haddock_doc)+rnHsTyKi env (HsDocTy x ty haddock_doc)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; haddock_doc' <- rnLHsDoc haddock_doc-       ; return (HsDocTy noExtField ty' haddock_doc', fvs) }+       ; return (HsDocTy x ty' haddock_doc, fvs) } -rnHsTyKi _ (XHsType (NHsCoreTy ty))-  = return (XHsType (NHsCoreTy ty), emptyFVs)-    -- The emptyFVs probably isn't quite right-    -- but I don't think it matters+-- See Note [Renaming HsCoreTys]+rnHsTyKi env (XHsType ty)+  = do mapM_ (check_in_scope . nameRdrName) fvs_list+       return (XHsType ty, fvs)+  where+    fvs_list = map getName $ tyCoVarsOfTypeList ty+    fvs = mkFVs fvs_list +    check_in_scope :: RdrName -> RnM ()+    check_in_scope rdr_name = do+      mb_name <- lookupLocalOccRn_maybe rdr_name+      when (isNothing mb_name) $+        addErr $ withHsDocContext (rtke_ctxt env) $+        notInScopeErr rdr_name+ rnHsTyKi env ty@(HsExplicitListTy _ ip tys)-  = do { checkPolyKinds env ty-       ; data_kinds <- xoptM LangExt.DataKinds+  = do { data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys        ; return (HsExplicitListTy noExtField ip tys', fvs) }  rnHsTyKi env ty@(HsExplicitTupleTy _ tys)-  = do { checkPolyKinds env ty-       ; data_kinds <- xoptM LangExt.DataKinds+  = do { data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys        ; return (HsExplicitTupleTy noExtField tys', fvs) }@@ -710,10 +767,43 @@  rnHsArrow :: RnTyKiEnv -> HsArrow GhcPs -> RnM (HsArrow GhcRn, FreeVars) rnHsArrow _env (HsUnrestrictedArrow u) = return (HsUnrestrictedArrow u, emptyFVs)-rnHsArrow _env (HsLinearArrow u) = return (HsLinearArrow u, emptyFVs)-rnHsArrow env (HsExplicitMult u p)-  = (\(mult, fvs) -> (HsExplicitMult u mult, fvs)) <$> rnLHsTyKi env p+rnHsArrow _env (HsLinearArrow u a) = return (HsLinearArrow u a, emptyFVs)+rnHsArrow env (HsExplicitMult u a p)+  = (\(mult, fvs) -> (HsExplicitMult u a mult, fvs)) <$> rnLHsTyKi env p +{-+Note [Renaming HsCoreTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.+As such, there's not much to be done in order to rename an HsCoreTy,+since it's already been renamed to some extent. However, in an attempt to+detect ill-formed HsCoreTys, the renamer checks to see if all free type+variables in an HsCoreTy are in scope. To see why this can matter, consider+this example from #18914:++  type T f = forall a. f a++  class C f where+    m :: T f++  newtype N f a = MkN (f a)+    deriving C++Because of #18914, a previous GHC would generate the following code:++  instance C f => C (N f) where+    m :: T (N f)+    m = coerce @(f a)   -- The type within @(...) is an HsCoreTy+               @(N f a) -- So is this+               (m @f)++There are two HsCoreTys in play—(f a) and (N f a)—both of which have+`f` and `a` as free type variables. The `f` is in scope from the instance head,+but `a` is completely unbound, which is what led to #18914. To avoid this sort+of mistake going forward, the renamer will now detect that `a` is unbound and+throw an error accordingly.+-}+ -------------- rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name rnTyVar env rdr_name@@ -721,7 +811,7 @@        ; checkNamedWildCard env name        ; return name } -rnLTyVar :: Located RdrName -> RnM (Located Name)+rnLTyVar :: LocatedN RdrName -> RnM (LocatedN Name) -- Called externally; does not deal with wildcards rnLTyVar (L loc rdr_name)   = do { tyvar <- lookupTypeOccRn rdr_name@@ -729,8 +819,8 @@  -------------- rnHsTyOp :: Outputable a-         => RnTyKiEnv -> a -> Located RdrName-         -> RnM (Located Name, FreeVars)+         => RnTyKiEnv -> a -> LocatedN RdrName+         -> RnM (LocatedN Name, FreeVars) rnHsTyOp env overall_ty (L loc op)   = do { ops_ok <- xoptM LangExt.TypeOperators        ; op' <- rnTyVar env op@@ -873,7 +963,7 @@         ; let -- See Note [bindHsQTyVars examples] for what              -- all these various things are doing-             bndrs, implicit_kvs :: [Located RdrName]+             bndrs, implicit_kvs :: [LocatedN RdrName]              bndrs        = map hsLTyVarLocName hs_tv_bndrs              implicit_kvs = filterFreeVarsToBind bndrs $                bndr_kv_occs ++ body_kv_occs@@ -889,12 +979,12 @@                 , text "body_remaining" <+> ppr body_remaining                 ] -       ; rnImplicitBndrs mb_assoc implicit_kvs $ \ implicit_kv_nms' ->+       ; rnImplicitTvOccs mb_assoc implicit_kvs $ \ implicit_kv_nms' ->          bindLHsTyVarBndrs doc NoWarnUnusedForalls mb_assoc hs_tv_bndrs $ \ rn_bndrs ->            -- This is the only call site for bindLHsTyVarBndrs where we pass            -- NoWarnUnusedForalls, which suppresses -Wunused-foralls warnings.            -- See Note [Suppress -Wunused-foralls when binding LHsQTyVars].-    do { let -- The SrcSpan that rnImplicitBndrs will attach to each Name will+    do { let -- The SrcSpan that rnImplicitTvOccs will attach to each Name will              -- span the entire declaration to which the LHsQTyVars belongs,              -- which will be reflected in warning and error messages. We can              -- be a little more precise than that by pointing to the location@@ -914,11 +1004,19 @@     --     --   class C (a :: j) (b :: k) where     --            ^^^^^^^^^^^^^^^-    bndrs_loc = case map getLoc hs_tv_bndrs ++ map getLoc body_kv_occs of+    bndrs_loc = case map get_bndr_loc hs_tv_bndrs ++ map getLocA body_kv_occs of       []         -> panic "bindHsQTyVars.bndrs_loc"       [loc]      -> loc       (loc:locs) -> loc `combineSrcSpans` last locs +    -- The in-tree API annotations extend the LHsTyVarBndr location to+    -- include surrounding parens. for error messages to be+    -- compatible, we recreate the location from the contents+    get_bndr_loc :: LHsTyVarBndr () GhcPs -> SrcSpan+    get_bndr_loc (L _ (UserTyVar   _ _ ln)) = getLocA ln+    get_bndr_loc (L _ (KindedTyVar _ _ ln lk))+      = combineSrcSpans (getLocA ln) (getLocA lk)+ {- Note [bindHsQTyVars examples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -948,7 +1046,7 @@   bring Names into scope.  * bndr_kv_occs, body_kv_occs, and implicit_kvs can contain duplicates. All-  duplicate occurrences are removed when we bind them with rnImplicitBndrs.+  duplicate occurrences are removed when we bind them with rnImplicitTvOccs.  Finally, you may wonder why filterFreeVarsToBind removes in-scope variables from bndr/body_kv_occs.  How can anything be in scope?  Answer:@@ -1041,6 +1139,28 @@ -Wunused-foralls warnings in exactly one place: in bindHsQTyVars. -} +bindHsOuterTyVarBndrs :: OutputableBndrFlag flag 'Renamed+                      => HsDocContext+                      -> Maybe assoc+                         -- ^ @'Just' _@ => an associated type decl+                      -> FreeKiTyVars+                      -> HsOuterTyVarBndrs flag GhcPs+                      -> (HsOuterTyVarBndrs flag GhcRn -> RnM (a, FreeVars))+                      -> RnM (a, FreeVars)+bindHsOuterTyVarBndrs doc mb_cls implicit_vars outer_bndrs thing_inside =+  case outer_bndrs of+    HsOuterImplicit{} ->+      rnImplicitTvOccs mb_cls implicit_vars $ \implicit_vars' ->+        thing_inside $ HsOuterImplicit { hso_ximplicit = implicit_vars' }+    HsOuterExplicit{hso_bndrs = exp_bndrs} ->+      -- Note: If we pass mb_cls instead of Nothing below, bindLHsTyVarBndrs+      -- will use class variables for any names the user meant to bring in+      -- scope here. This is an explicit forall, so we want fresh names, not+      -- class variables. Thus: always pass Nothing.+      bindLHsTyVarBndrs doc WarnUnusedForalls Nothing exp_bndrs $ \exp_bndrs' ->+        thing_inside $ HsOuterExplicit { hso_xexplicit = noExtField+                                       , hso_bndrs     = exp_bndrs' }+ bindHsForAllTelescope :: HsDocContext                       -> HsForAllTelescope GhcPs                       -> (HsForAllTelescope GhcRn -> RnM (a, FreeVars))@@ -1049,10 +1169,10 @@   case tele of     HsForAllVis { hsf_vis_bndrs = bndrs } ->       bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->-        thing_inside $ mkHsForAllVisTele bndrs'+        thing_inside $ mkHsForAllVisTele noAnn bndrs'     HsForAllInvis { hsf_invis_bndrs = bndrs } ->       bindLHsTyVarBndrs doc WarnUnusedForalls Nothing bndrs $ \bndrs' ->-        thing_inside $ mkHsForAllInvisTele bndrs'+        thing_inside $ mkHsForAllInvisTele noAnn bndrs'  -- | Should GHC warn if a quantified type variable goes unused? Usually, the -- answer is \"yes\", but in the particular case of binding 'LHsQTyVars', we@@ -1067,7 +1187,7 @@     WarnUnusedForalls   -> "WarnUnusedForalls"     NoWarnUnusedForalls -> "NoWarnUnusedForalls" -bindLHsTyVarBndrs :: (OutputableBndrFlag flag)+bindLHsTyVarBndrs :: (OutputableBndrFlag flag 'Renamed)                   => HsDocContext                   -> WarnUnusedForalls                   -> Maybe a               -- Just _  => an associated type decl@@ -1076,7 +1196,7 @@                   -> RnM (b, FreeVars) bindLHsTyVarBndrs doc wuf mb_assoc tv_bndrs thing_inside   = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)-       ; checkDupRdrNames tv_names_w_loc+       ; checkDupRdrNamesN tv_names_w_loc        ; go tv_bndrs thing_inside }   where     tv_names_w_loc = map hsLTyVarLocName tv_bndrs@@ -1115,7 +1235,7 @@            ; return (b, fvs1 `plusFV` fvs2) }  newTyVarNameRn :: Maybe a -- associated class-               -> Located RdrName -> RnM Name+               -> LocatedN RdrName -> RnM Name newTyVarNameRn mb_assoc lrdr@(L _ rdr)   = do { rdr_env <- getLocalRdrEnv        ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of@@ -1150,18 +1270,17 @@ rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs         -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField _ names ty haddock_doc))-  = do { let new_names = map (fmap lookupField) names+  = do { let new_names = map (fmap (lookupField fl_env)) names        ; (new_ty, fvs) <- rnLHsTyKi env ty-       ; new_haddock_doc <- rnMbLHsDoc haddock_doc-       ; return (L l (ConDeclField noExtField new_names new_ty new_haddock_doc)+       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc)                 , fvs) }++lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn+lookupField fl_env (FieldOcc _ (L lr rdr)) =+    FieldOcc (flSelector fl) (L lr rdr)   where-    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn-    lookupField (FieldOcc _ (L lr rdr)) =-        FieldOcc (flSelector fl) (L lr rdr)-      where-        lbl = occNameFS $ rdrNameOcc rdr-        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl+    lbl = occNameFS $ rdrNameOcc rdr+    fl  = expectJust "lookupField" $ lookupFsEnv fl_env lbl  {- ************************************************************************@@ -1185,46 +1304,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 :: LocatedN 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 :: LocatedN Name -> Fixity -> LHsType GhcRn+            -> LocatedN Name -> Fixity -> LHsType GhcRn+            -> LHsType GhcRn -> SrcSpanAnnA             -> 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 (noLocA 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  @@ -1246,7 +1360,7 @@     new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2     return (OpApp fix1 e11 op1 (L loc' new_e))   where-    loc'= combineLocs e12 e2+    loc'= combineLocsA e12 e2     (nofix_error, associate_right) = compareFixity fix1 fix2  ---------------------------@@ -1260,7 +1374,7 @@   = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2        return (NegApp noExtField (L loc' new_e) neg_name)   where-    loc' = combineLocs neg_arg e2+    loc' = combineLocsA neg_arg e2     (nofix_error, associate_right) = compareFixity negateFixity fix2  ---------------------------@@ -1316,8 +1430,7 @@  -- Parser initially makes negation bind more tightly than any other operator -- And "deriving" code should respect this (use HsPar if not)-mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)-           -> RnM (HsExpr (GhcPass id))+mkNegAppRn :: LHsExpr GhcRn -> SyntaxExpr GhcRn -> RnM (HsExpr GhcRn) mkNegAppRn neg_arg neg_name   = ASSERT( not_op_app (unLoc neg_arg) )     return (NegApp noExtField neg_arg neg_name)@@ -1345,7 +1458,7 @@   | associate_right   = do new_c <- mkOpFormRn a12 op2 fix2 a2        return (HsCmdArrForm noExtField op1 f (Just fix1)-               [a11, L loc (HsCmdTop [] (L loc new_c))])+               [a11, L loc (HsCmdTop [] (L (noAnnSrcSpan loc) new_c))])         -- TODO: locs are wrong   where     (nofix_error, associate_right) = compareFixity fix1 fix2@@ -1356,7 +1469,7 @@   ---------------------------------------mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn+mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn              -> RnM (Pat GhcRn)  mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2@@ -1413,7 +1526,7 @@     check (L _ (Match { m_pats = (L l1 p1)                                : (L l2 p2)                                : _ }))-      = setSrcSpan (combineSrcSpans l1 l2) $+      = setSrcSpan (locA $ combineSrcSpansA l1 l2) $         do checkPrec op p1 False            checkPrec op p2 True @@ -1521,7 +1634,7 @@  badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty)-  = setSrcSpan loc $ addErr $+  = setSrcSpanA loc $ addErr $     withHsDocContext doc $     hang (text "Illegal kind signature:" <+> quotes (ppr ty))        2 (text "Perhaps you intended to use KindSignatures")@@ -1534,12 +1647,12 @@     pp_what | isRnKindLevel env = text "kind"             | otherwise          = text "type" -warnUnusedForAll :: OutputableBndrFlag flag+warnUnusedForAll :: OutputableBndrFlag flag 'Renamed                  => HsDocContext -> LHsTyVarBndr flag GhcRn -> FreeVars -> TcM () warnUnusedForAll doc (L loc tv) used_names   = whenWOptM Opt_WarnUnusedForalls $     unless (hsTyVarName tv `elemNameSet` used_names) $-    addWarnAt (Reason Opt_WarnUnusedForalls) loc $+    addWarnAt (Reason Opt_WarnUnusedForalls) (locA loc) $     vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)          , inHsDocContext doc ] @@ -1582,7 +1695,7 @@  It is common for lists of free type variables to contain duplicates. For example, in `f :: a -> a`, the free type variable list is [a, a]. When these-implicitly bound variables are brought into scope (with rnImplicitBndrs),+implicitly bound variables are brought into scope (with rnImplicitTvOccs), duplicates are removed with nubL.  Note [Ordering of implicit variables]@@ -1704,7 +1817,7 @@ -- These lists are guaranteed to preserve left-to-right ordering of -- the types the variables were extracted from. See also -- Note [Ordering of implicit variables].-type FreeKiTyVars = [Located RdrName]+type FreeKiTyVars = [LocatedN RdrName]  -- | Filter out any type and kind variables that are already in scope in the -- the supplied LocalRdrEnv. Note that this includes named wildcards, which@@ -1742,9 +1855,6 @@ extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars extractHsTyRdrTyVars ty = extract_lty ty [] -extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars-extractHsScaledTysRdrTyVars args acc = foldr (\(HsScaled m ty) -> extract_lty ty . extract_hs_arrow m) acc args- -- | Extracts the free type/kind variables from the kind signature of a HsType. --   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. -- The left-to-right order of variables is preserved.@@ -1782,6 +1892,15 @@   TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k   _ -> [] +-- | Extracts free type and kind variables from an argument in a GADT+-- constructor, returning variable occurrences in left-to-right order.+-- See @Note [Ordering of implicit variables]@.+extractConDeclGADTDetailsTyVars ::+  HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars+extractConDeclGADTDetailsTyVars con_args = case con_args of+  PrefixConGADT args    -> extract_scaled_ltys args+  RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds+ -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order: --@@ -1793,9 +1912,18 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })   = maybe [] extractHsTyRdrTyVars ksig -extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars-extract_lctxt ctxt = extract_ltys (unLoc ctxt)+extract_lctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> FreeKiTyVars+extract_lctxt Nothing     = id+extract_lctxt (Just ctxt) = extract_ltys (unLoc ctxt) +extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)]+                    -> FreeKiTyVars -> FreeKiTyVars+extract_scaled_ltys args acc = foldr extract_scaled_lty acc args++extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs)+                   -> FreeKiTyVars -> FreeKiTyVars+extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc+ extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys @@ -1840,9 +1968,13 @@       -- We deal with these separately in rnLHsTypeWithWildCards       HsWildCardTy {}             -> acc +extract_lhs_sig_ty :: LHsSigType GhcPs -> FreeKiTyVars+extract_lhs_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body})) =+  extractHsOuterTvBndrs outer_bndrs $ extract_lty body []+ extract_hs_arrow :: HsArrow GhcPs -> FreeKiTyVars ->                    FreeKiTyVars-extract_hs_arrow (HsExplicitMult _ p) acc = extract_lty p acc+extract_hs_arrow (HsExplicitMult _ _ p) acc = extract_lty p acc extract_hs_arrow _ acc = acc  extract_hs_for_all_telescope :: HsForAllTelescope GhcPs@@ -1856,11 +1988,13 @@     HsForAllInvis { hsf_invis_bndrs = bndrs } ->       extract_hs_tv_bndrs bndrs acc_vars body_fvs -extractHsTvBndrs :: [LHsTyVarBndr flag GhcPs]-                 -> FreeKiTyVars       -- Free in body-                 -> FreeKiTyVars       -- Free in result-extractHsTvBndrs tv_bndrs body_fvs-  = extract_hs_tv_bndrs tv_bndrs [] body_fvs+extractHsOuterTvBndrs :: HsOuterTyVarBndrs flag GhcPs+                      -> FreeKiTyVars -- Free in body+                      -> FreeKiTyVars -- Free in result+extractHsOuterTvBndrs outer_bndrs body_fvs =+  case outer_bndrs of+    HsOuterImplicit{}                  -> body_fvs+    HsOuterExplicit{hso_bndrs = bndrs} -> extract_hs_tv_bndrs bndrs [] body_fvs  extract_hs_tv_bndrs :: [LHsTyVarBndr flag GhcPs]                     -> FreeKiTyVars  -- Accumulator@@ -1891,14 +2025,14 @@     foldr extract_lty []           [k | L _ (KindedTyVar _ _ _ k) <- tv_bndrs] -extract_tv :: Located RdrName -> FreeKiTyVars -> FreeKiTyVars+extract_tv :: LocatedN RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc =   if isRdrTyVar (unLoc tv) then tv:acc else acc  -- Deletes duplicates in a list of Located things. This is used to: -- -- * Delete duplicate occurrences of implicitly bound type/kind variables when---   bringing them into scope (in rnImplicitBndrs).+--   bringing them into scope (in rnImplicitTvOccs). -- -- * Delete duplicate occurrences of named wildcards (in rn_hs_sig_wc_type and --   rnHsWcType).@@ -1908,8 +2042,11 @@ -- relies on to maintain the left-to-right ordering of implicitly quantified -- type variables. -- See Note [Ordering of implicit variables].-nubL :: Eq a => [Located a] -> [Located a]+nubL :: Eq a => [GenLocated l a] -> [GenLocated l a] nubL = nubBy eqLocated++nubN :: Eq a => [LocatedN a] -> [LocatedN a]+nubN = nubBy eqLocated  -- | Filter out any potential implicit binders that are either -- already in scope, or are explicitly bound in the binder.

GHC/Rename/Module.hs view

@@ -1,18 +1,17 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  Main pass of renamer -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Rename.Module (         rnSrcDecls, addTcgDUs, findSplice     ) where@@ -31,20 +30,19 @@ import GHC.Rename.Bind import GHC.Rename.Env import GHC.Rename.Utils ( HsDocContext(..), mapFvRn, bindLocalNames-                        , checkDupRdrNames, bindLocalNamesFV+                        , checkDupRdrNamesN, bindLocalNamesFV                         , checkShadowedRdrNames, warnUnusedTypePatterns-                        , extendTyVarEnvFVRn, newLocalBndrsRn+                        , newLocalBndrsRn                         , withHsDocContext, noNestedForallsContextsErr                         , addNoNestedForallsContextsErr, checkInferredVars ) import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr ) import GHC.Rename.Names-import GHC.Rename.Doc   ( rnHsDoc, rnMbLHsDoc ) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad  import GHC.Types.ForeignCall ( CCallTarget(..) )-import GHC.Unit.Module-import GHC.Driver.Types ( Warnings(..), plusWarns )+import GHC.Unit+import GHC.Unit.Module.Warnings import GHC.Builtin.Names( applicativeClassName, pureAName, thenAName                         , monadClassName, returnMName, thenMName                         , semigroupClassName, sappendName@@ -61,7 +59,8 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Driver.Session import GHC.Utils.Misc   ( debugIsOn, lengthExceeds, partitionWith )-import GHC.Driver.Types ( HscEnv, hsc_dflags )+import GHC.Utils.Panic+import GHC.Driver.Env ( HscEnv(..), hsc_home_unit) import GHC.Data.List.SetOps ( findDupsEq, removeDups, equivClasses ) import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)                                , stronglyConnCompFromEdgedVerticesUniq )@@ -74,7 +73,7 @@ import Data.List ( mapAccumL ) import qualified Data.List.NonEmpty as NE import Data.List.NonEmpty ( NonEmpty(..) )-import Data.Maybe ( isNothing, isJust, fromMaybe, mapMaybe )+import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) import Data.Function ( on ) @@ -134,7 +133,9 @@    --      Need to do this before (D2) because rnTopBindsLHS    --      looks up those pattern synonyms (#9889) -   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {+   dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags ;+   has_sel <- xopt_FieldSelectors <$> getDynFlags ;+   extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env $ \pat_syn_bndrs -> do {     -- (D2) Rename the left-hand sides of the value bindings.    --     This depends on everything from (B) being in scope.@@ -142,8 +143,9 @@    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;     -- Bind the LHSes (and their fixities) in the global rdr environment-   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders-                                                    -- They are already in scope+   let { id_bndrs = collectHsIdBinders CollNoDictBinders new_lhs } ;+                    -- Excludes pattern-synonym binders+                    -- They are already in scope    traceRn "rnSrcDecls" (ppr id_bndrs) ;    tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;    setEnvs tc_envs $ do {@@ -198,8 +200,6 @@    (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;    (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;    (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;-      -- Haddock docs; no free vars-   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;     last_tcg_env <- getGblEnv ;    -- (I) Compute the results and return@@ -215,7 +215,7 @@                              hs_annds  = rn_ann_decls,                              hs_defds  = rn_default_decls,                              hs_ruleds = rn_rule_decls,-                             hs_docs   = rn_docs } ;+                             hs_docs   = docs } ;          tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;@@ -241,30 +241,8 @@ -- but there doesn't seem anywhere very logical to put it. addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } -rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)-rnList f xs = mapFvRn (wrapLocFstM f) xs--{--*********************************************************-*                                                       *-        HsDoc stuff-*                                                       *-*********************************************************--}--rnDocDecl :: DocDecl -> RnM DocDecl-rnDocDecl (DocCommentNext doc) = do-  rn_doc <- rnHsDoc doc-  return (DocCommentNext rn_doc)-rnDocDecl (DocCommentPrev doc) = do-  rn_doc <- rnHsDoc doc-  return (DocCommentPrev rn_doc)-rnDocDecl (DocCommentNamed str doc) = do-  rn_doc <- rnHsDoc doc-  return (DocCommentNamed str rn_doc)-rnDocDecl (DocGroup lev doc) = do-  rn_doc <- rnHsDoc doc-  return (DocGroup lev rn_doc)+rnList :: (a -> RnM (b, FreeVars)) -> [LocatedA a] -> RnM ([LocatedA b], FreeVars)+rnList f xs = mapFvRn (wrapLocFstMA f) xs  {- *********************************************************@@ -288,9 +266,9 @@ rnSrcWarnDecls bndr_set decls'   = do { -- check for duplicates        ; mapM_ (\ dups -> let ((L loc rdr) :| (lrdr':_)) = dups-                          in addErrAt loc (dupWarnDecl lrdr' rdr))+                          in addErrAt (locA loc) (dupWarnDecl lrdr' rdr))                warn_rdr_dups-       ; pairs_s <- mapM (addLocM rn_deprec) decls+       ; pairs_s <- mapM (addLocMA rn_deprec) decls        ; return (WarnSome ((concat pairs_s))) }  where    decls = concatMap (wd_warnings . unLoc) decls'@@ -308,18 +286,18 @@    warn_rdr_dups = findDupRdrNames                    $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls -findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]+findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))  -- look for duplicates among the OccNames; -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements -dupWarnDecl :: Located RdrName -> RdrName -> SDoc+dupWarnDecl :: LocatedN RdrName -> RdrName -> SDoc -- Located RdrName -> DeprecDecl RdrName -> SDoc dupWarnDecl d rdr_name   = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),-          text "also at " <+> ppr (getLoc d)]+          text "also at " <+> ppr (getLocA d)]  {- *********************************************************@@ -335,13 +313,16 @@     do { (provenance', provenance_fvs) <- rnAnnProvenance provenance        ; (expr', expr_fvs) <- setStage (Splice Untyped) $                               rnLExpr expr-       ; return (HsAnnotation noExtField s provenance' expr',+       ; return (HsAnnotation noAnn s provenance' expr',                  provenance_fvs `plusFV` expr_fvs) } -rnAnnProvenance :: AnnProvenance RdrName-                -> RnM (AnnProvenance Name, FreeVars)+rnAnnProvenance :: AnnProvenance GhcPs+                -> RnM (AnnProvenance GhcRn, FreeVars) rnAnnProvenance provenance = do-    provenance' <- traverse lookupTopBndrRn provenance+    provenance' <- case provenance of+      ValueAnnProvenance n -> ValueAnnProvenance <$> lookupLocatedTopBndrRnN n+      TypeAnnProvenance n  -> TypeAnnProvenance  <$> lookupLocatedTopBndrRnN n+      ModuleAnnProvenance  -> return ModuleAnnProvenance     return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))  {-@@ -370,12 +351,12 @@ rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })   = do { topEnv :: HscEnv <- getTopEnv-       ; name' <- lookupLocatedTopBndrRn name+       ; name' <- lookupLocatedTopBndrRnN name        ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) TypeLevel ty          -- Mark any PackageTarget style imports as coming from the current package-       ; let unitId = homeUnit $ hsc_dflags topEnv-             spec'  = patchForeignImport unitId spec+       ; let home_unit = hsc_home_unit topEnv+             spec'  = patchForeignImport (homeUnitAsUnit home_unit) spec         ; return (ForeignImport { fd_i_ext = noExtField                                , fd_name = name', fd_sig_ty = ty'@@ -452,10 +433,12 @@ checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () checkCanonicalInstances cls poly_ty mbinds = do     whenWOptM Opt_WarnNonCanonicalMonadInstances-        checkCanonicalMonadInstances+        $ checkCanonicalMonadInstances+        "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return"      whenWOptM Opt_WarnNonCanonicalMonoidInstances-        checkCanonicalMonoidInstances+        $ checkCanonicalMonoidInstances+        "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"    where     -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance@@ -471,33 +454,33 @@     --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).     --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).     ---    checkCanonicalMonadInstances-      | cls == applicativeClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+    checkCanonicalMonadInstances refURL+      | cls == applicativeClassName =+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id = L _ name                           , fun_matches = mg }                       | name == pureAName, isAliasMG mg == Just returnMName-                      -> addWarnNonCanonicalMethod1+                      -> addWarnNonCanonicalMethod1 refURL                             Opt_WarnNonCanonicalMonadInstances "pure" "return"                        | name == thenAName, isAliasMG mg == Just thenMName-                      -> addWarnNonCanonicalMethod1+                      -> addWarnNonCanonicalMethod1 refURL                             Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"                    _ -> return () -      | cls == monadClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+      | cls == monadClassName =+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id = L _ name                           , fun_matches = mg }                       | name == returnMName, isAliasMG mg /= Just pureAName-                      -> addWarnNonCanonicalMethod2+                      -> addWarnNonCanonicalMethod2 refURL                             Opt_WarnNonCanonicalMonadInstances "return" "pure"                        | name == thenMName, isAliasMG mg /= Just thenAName-                      -> addWarnNonCanonicalMethod2+                      -> addWarnNonCanonicalMethod2 refURL                             Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"                    _ -> return ()@@ -517,26 +500,27 @@     --     --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).     ---    checkCanonicalMonoidInstances-      | cls == semigroupClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+    checkCanonicalMonoidInstances refURL+      | cls == semigroupClassName =+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id      = L _ name                           , fun_matches = mg }                       | name == sappendName, isAliasMG mg == Just mappendName-                      -> addWarnNonCanonicalMethod1+                      -> addWarnNonCanonicalMethod1 refURL                             Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"                    _ -> return () -      | cls == monoidClassName  = do-          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do+      | cls == monoidClassName =+          forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpanA loc $               case mbind of                   FunBind { fun_id = L _ name                           , fun_matches = mg }                       | name == mappendName, isAliasMG mg /= Just sappendName-                      -> addWarnNonCanonicalMethod2NoDefault-                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"+                      -> addWarnNonCanonicalMethod2 refURL+                            Opt_WarnNonCanonicalMonoidInstances+                            "mappend" "(<>)"                    _ -> return () @@ -548,12 +532,12 @@     isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []                                              , m_grhss = grhss })])}         | GRHSs _ [L _ (GRHS _ [] body)] lbinds <- grhss-        , EmptyLocalBinds _ <- unLoc lbinds+        , EmptyLocalBinds _ <- lbinds         , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)     isAliasMG _ = Nothing      -- got "lhs = rhs" but expected something different-    addWarnNonCanonicalMethod1 flag lhs rhs = do+    addWarnNonCanonicalMethod1 refURL flag lhs rhs =         addWarn (Reason flag) $ vcat                        [ text "Noncanonical" <+>                          quotes (text (lhs ++ " = " ++ rhs)) <+>@@ -562,29 +546,26 @@                        , text "Move definition from" <+>                          quotes (text rhs) <+>                          text "to" <+> quotes (text lhs)+                       , text "See also:" <+>+                         text refURL                        ]      -- expected "lhs = rhs" but got something else-    addWarnNonCanonicalMethod2 flag lhs rhs = do+    addWarnNonCanonicalMethod2 refURL flag lhs rhs =         addWarn (Reason flag) $ vcat                        [ text "Noncanonical" <+>                          quotes (text lhs) <+>                          text "definition detected"                        , instDeclCtxt1 poly_ty+                       , quotes (text lhs) <+>+                         text "will eventually be removed in favour of" <+>+                         quotes (text rhs)                        , text "Either remove definition for" <+>-                         quotes (text lhs) <+> text "or define as" <+>-                         quotes (text (lhs ++ " = " ++ rhs))-                       ]--    -- like above, but method has no default impl-    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do-        addWarn (Reason flag) $ vcat-                       [ text "Noncanonical" <+>-                         quotes (text lhs) <+>-                         text "definition detected"-                       , instDeclCtxt1 poly_ty-                       , text "Define as" <+>+                         quotes (text lhs) <+> text "(recommended)" <+>+                         text "or define as" <+>                          quotes (text (lhs ++ " = " ++ rhs))+                       , text "See also:" <+>+                         text refURL                        ]      -- stolen from GHC.Tc.TyCl.Instance@@ -616,7 +597,7 @@              eith_cls = case hsTyGetAppHead_maybe head_ty' of                Just (L _ cls) -> Right cls                Nothing        -> Left-                 ( getLoc head_ty'+                 ( getLocA head_ty'                  , hang (text "Illegal head of an instance declaration:"                            <+> quotes (ppr head_ty'))                       2 (vcat [ text "Instance heads must be of the form"@@ -647,7 +628,7 @@        -- Both need to have the instance type variables in scope        ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)        ; ((ats', adts'), more_fvs)-             <- extendTyVarEnvFVRn ktv_names $+             <- bindLocalNamesFV ktv_names $                 do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats                    ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts                    ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }@@ -683,36 +664,41 @@       addErrAt l $ withHsDocContext ctxt err_msg       pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) -rnFamInstEqn :: HsDocContext-             -> AssocTyFamInfo-             -> FreeKiTyVars-             -- ^ Kind variables from the equation's RHS to be implicitly bound-             -- if no explicit forall.-             -> FamInstEqn GhcPs rhs-             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))-             -> RnM (FamInstEqn GhcRn rhs', FreeVars)-rnFamInstEqn doc atfi rhs_kvars-    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon-                               , feqn_bndrs  = mb_bndrs-                               , feqn_pats   = pats-                               , feqn_fixity = fixity-                               , feqn_rhs    = payload }}) rn_payload+rnFamEqn :: HsDocContext+         -> AssocTyFamInfo+         -> FreeKiTyVars+         -- ^ Additional kind variables to implicitly bind if there is no+         --   explicit forall. (See the comments on @all_imp_vars@ below for a+         --   more detailed explanation.)+         -> FamEqn GhcPs rhs+         -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))+         -> RnM (FamEqn GhcRn rhs', FreeVars)+rnFamEqn doc atfi extra_kvars+    (FamEqn { feqn_tycon  = tycon+            , feqn_bndrs  = outer_bndrs+            , feqn_pats   = pats+            , feqn_fixity = fixity+            , feqn_rhs    = payload }) rn_payload   = do { tycon' <- lookupFamInstName mb_cls tycon           -- all_imp_vars represent the implicitly bound type variables. This is          -- empty if we have an explicit `forall` (see-         -- Note [forall-or-nothing rule] in GHC.Rename.HsType), which means+         -- Note [forall-or-nothing rule] in GHC.Hs.Type), which means          -- ignoring:          ---         -- - pat_kity_vars_with_dups, the variables mentioned in the LHS of-         --   the equation, and-         -- - rhs_kvars, the kind variables mentioned in an outermost kind-         --   signature on the RHS of the equation. (See-         --   Note [Implicit quantification in type synonyms] in-         --   GHC.Rename.HsType for why these are implicitly quantified in the-         --   absence of an explicit forall).+         -- - pat_kity_vars, the free variables mentioned in the type patterns+         --   on the LHS of the equation, and+         -- - extra_kvars, which is one of the following:+         --   * For type family instances, extra_kvars are the free kind+         --     variables mentioned in an outermost kind signature on the RHS+         --     of the equation.+         --     (See Note [Implicit quantification in type synonyms] in+         --     GHC.Rename.HsType.)+         --   * For data family instances, extra_kvars are the free kind+         --     variables mentioned in the explicit return kind, if one is+         --     provided. (e.g., the `k` in `data instance T :: k -> Type`).          ---         -- For example:+         -- Some examples:          --          -- @          -- type family F a b@@ -720,36 +706,38 @@          --   -- all_imp_vars = []          -- type instance F [(a, b)] c = a -> b -> c          --   -- all_imp_vars = [a, b, c]+         --+         -- type family G :: Maybe a+         -- type instance forall a. G = (Nothing :: Maybe a)+         --   -- all_imp_vars = []+         -- type instance G = (Nothing :: Maybe a)+         --   -- all_imp_vars = [a]+         --+         -- data family H :: k -> Type+         -- data instance forall k. H :: k -> Type where ...+         --   -- all_imp_vars = []+         -- data instance H :: k -> Type where ...+         --   -- all_imp_vars = [k]          -- @-       ; all_imp_vars <- forAllOrNothing (isJust mb_bndrs) $-           -- No need to filter out explicit binders (the 'mb_bndrs = Just-           -- explicit_bndrs' case) because there must be none if we're going-           -- to implicitly bind anything, per the previous comment.-           pat_kity_vars_with_dups ++ rhs_kvars+       ; let all_imp_vars = pat_kity_vars ++ extra_kvars -       ; rnImplicitBndrs mb_cls all_imp_vars $ \all_imp_var_names' ->-         bindLHsTyVarBndrs doc WarnUnusedForalls-                           Nothing (fromMaybe [] mb_bndrs) $ \bndrs' ->-         -- Note: If we pass mb_cls instead of Nothing here,-         --  bindLHsTyVarBndrs will use class variables for any names-         --  the user meant to bring in scope here. This is an explicit-         --  forall, so we want fresh names, not class variables.-         --  Thus: always pass Nothing+       ; bindHsOuterTyVarBndrs doc mb_cls all_imp_vars outer_bndrs $ \rn_outer_bndrs ->     do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats        ; (payload', rhs_fvs) <- rn_payload doc payload            -- Report unused binders on the LHS           -- See Note [Unused type variables in family instances]-       ; let -- The SrcSpan that rnImplicitBndrs will attach to each Name will+       ; let -- The SrcSpan that bindHsOuterFamEqnTyVarBndrs will attach to each+             -- implicitly bound type variable Name in outer_bndrs' will              -- span the entire type family instance, which will be reflected in              -- -Wunused-type-patterns warnings. We can be a little more precise              -- than that by pointing to the LHS of the instance instead, which              -- is what lhs_loc corresponds to.-             all_imp_var_names = map (`setNameLoc` lhs_loc) all_imp_var_names'+             rn_outer_bndrs' = mapHsOuterImplicit (map (`setNameLoc` lhs_loc))+                                                  rn_outer_bndrs -             groups :: [NonEmpty (Located RdrName)]-             groups = equivClasses cmpLocated $-                      pat_kity_vars_with_dups+             groups :: [NonEmpty (LocatedN RdrName)]+             groups = equivClasses cmpLocated pat_kity_vars        ; nms_dups <- mapM (lookupOccRn . unLoc) $                         [ tv | (tv :| (_:_)) <- groups ]              -- Add to the used variables@@ -759,10 +747,24 @@              --     of the instance decl.  See              --     Note [Unused type variables in family instances]        ; let nms_used = extendNameSetList rhs_fvs $-                           inst_tvs ++ nms_dups-             all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'+                           nms_dups {- (a) -} ++ inst_head_tvs {- (b) -}+             all_nms = hsOuterTyVarNames rn_outer_bndrs'        ; warnUnusedTypePatterns all_nms nms_used +         -- For associated family instances, if a type variable from the+         -- parent instance declaration is mentioned on the RHS of the+         -- associated family instance but not bound on the LHS, then reject+         -- that type variable as being out of scope.+         -- See Note [Renaming associated types]+       ; let lhs_bound_vars = extendNameSetList pat_fvs all_nms+             improperly_scoped cls_tkv =+                  cls_tkv `elemNameSet` rhs_fvs+                    -- Mentioned on the RHS...+               && not (cls_tkv `elemNameSet` lhs_bound_vars)+                    -- ...but not bound on the LHS.+             bad_tvs = filter improperly_scoped inst_head_tvs+       ; unless (null bad_tvs) (badAssocRhs bad_tvs)+        ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs              -- See Note [Type family equations and occurrences]              all_fvs = case atfi of@@ -770,14 +772,13 @@                            -> eqn_fvs                          _ -> eqn_fvs `addOneFV` unLoc tycon' -       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]-                      , hsib_body-                          = FamEqn { feqn_ext    = noExtField-                                   , feqn_tycon  = tycon'-                                   , feqn_bndrs  = bndrs' <$ mb_bndrs-                                   , feqn_pats   = pats'-                                   , feqn_fixity = fixity-                                   , feqn_rhs    = payload' } },+       ; return (FamEqn { feqn_ext    = noAnn+                        , feqn_tycon  = tycon'+                          -- Note [Wildcards in family instances]+                        , feqn_bndrs  = rn_outer_bndrs'+                        , feqn_pats   = pats'+                        , feqn_fixity = fixity+                        , feqn_rhs    = payload' },                  all_fvs) } }   where     -- The parent class, if we are dealing with an associated type family@@ -789,12 +790,12 @@      -- The type variables from the instance head, if we are dealing with an     -- associated type family instance.-    inst_tvs = case atfi of-      NonAssocTyFamEqn _        -> []-      AssocTyFamDeflt _         -> []-      AssocTyFamInst _ inst_tvs -> inst_tvs+    inst_head_tvs = case atfi of+      NonAssocTyFamEqn _             -> []+      AssocTyFamDeflt _              -> []+      AssocTyFamInst _ inst_head_tvs -> inst_head_tvs -    pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVars pats+    pat_kity_vars = extractHsTyArgRdrKiTyVars pats              -- It is crucial that extractHsTyArgRdrKiTyVars return              -- duplicate occurrences, since they're needed to help              -- determine unused binders on the LHS.@@ -804,17 +805,24 @@     --     --   type instance F a b c = Either a b     --                   ^^^^^-    lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLoc rhs_kvars of-      []         -> panic "rnFamInstEqn.lhs_loc"+    lhs_loc = case map lhsTypeArgSrcSpan pats ++ map getLocA extra_kvars of+      []         -> panic "rnFamEqn.lhs_loc"       [loc]      -> loc       (loc:locs) -> loc `combineSrcSpans` last locs +    badAssocRhs :: [Name] -> RnM ()+    badAssocRhs ns+      = addErr (hang (text "The RHS of an associated type declaration mentions"+                      <+> text "out-of-scope variable" <> plural ns+                      <+> pprWithCommas (quotes . ppr) ns)+                   2 (text "All such variables must be bound on the LHS"))+ rnTyFamInstDecl :: AssocTyFamInfo                 -> TyFamInstDecl GhcPs                 -> RnM (TyFamInstDecl GhcRn, FreeVars)-rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })+rnTyFamInstDecl atfi (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn })   = do { (eqn', fvs) <- rnTyFamInstEqn atfi eqn-       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }+       ; return (TyFamInstDecl { tfid_xtn = x, tfid_eqn = eqn' }, fvs) }  -- | Tracks whether we are renaming: --@@ -863,12 +871,10 @@ rnTyFamInstEqn :: AssocTyFamInfo                -> TyFamInstEqn GhcPs                -> RnM (TyFamInstEqn GhcRn, FreeVars)-rnTyFamInstEqn atfi-    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon-                                   , feqn_rhs   = rhs }})-  = rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn+rnTyFamInstEqn atfi eqn@(FamEqn { feqn_tycon = tycon, feqn_rhs = rhs })+  = rnFamEqn (TySynCtx tycon) atfi extra_kvs eqn rnTySyn   where-    rhs_kvs = extractHsTyRdrTyVarsKindVars rhs+    extra_kvs = extractHsTyRdrTyVarsKindVars rhs  rnTyFamDefltDecl :: Name                  -> TyFamDefltDecl GhcPs@@ -878,12 +884,12 @@ rnDataFamInstDecl :: AssocTyFamInfo                   -> DataFamInstDecl GhcPs                   -> RnM (DataFamInstDecl GhcRn, FreeVars)-rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =-                         FamEqn { feqn_tycon = tycon-                                , feqn_rhs   = rhs }})})-  = do { let rhs_kvs = extractDataDefnKindVars rhs+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn =+                    eqn@(FamEqn { feqn_tycon = tycon+                                , feqn_rhs   = rhs })})+  = do { let extra_kvs = extractDataDefnKindVars rhs        ; (eqn', fvs) <--           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn+           rnFamEqn (TyDataCtx tycon) atfi extra_kvs eqn rnDataDefn        ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }  -- Renaming of the associated types in instances.@@ -900,8 +906,8 @@                   RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl               -> Name      -- Class               -> [Name]-              -> [Located (decl GhcPs)]-              -> RnM ([Located (decl GhcRn)], FreeVars)+              -> [LocatedA (decl GhcPs)]+              -> RnM ([LocatedA (decl GhcRn)], FreeVars) -- Used for data and type family defaults in a class decl -- and the family instance declarations in an instance --@@ -964,59 +970,132 @@  Note [Renaming associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Check that the RHS of the decl mentions only type variables that are explicitly-bound on the LHS.  For example, this is not ok-   class C a b where-      type F a x :: *-   instance C (p,q) r where-      type F (p,q) x = (x, r)   -- BAD: mentions 'r'-c.f. #5515+When renaming a type/data family instance, be it top-level or associated with+a class, we must check that all of the type variables mentioned on the RHS are+properly scoped. Specifically, the rule is this: -Kind variables, on the other hand, are allowed to be implicitly or explicitly-bound. As examples, this (#9574) is acceptable:-   class Funct f where-      type Codomain f :: *-   instance Funct ('KProxy :: KProxy o) where-      -- o is implicitly bound by the kind signature-      -- of the LHS type pattern ('KProxy)-      type Codomain 'KProxy = NatTr (Proxy :: o -> *)-And this (#14131) is also acceptable:-    data family Nat :: k -> k -> *-    -- k is implicitly bound by an invisible kind pattern-    newtype instance Nat :: (k -> *) -> (k -> *) -> * where-      Nat :: (forall xx. f xx -> g xx) -> Nat f g-We could choose to disallow this, but then associated type families would not-be able to be as expressive as top-level type synonyms. For example, this type-synonym definition is allowed:-    type T = (Nothing :: Maybe a)-So for parity with type synonyms, we also allow:-    type family   T :: Maybe a-    type instance T = (Nothing :: Maybe a)+  Every variable mentioned on the RHS of a type instance declaration+  (whether associated or not) must be either+  * Mentioned on the LHS, or+  * Mentioned in an outermost kind signature on the RHS+    (see Note [Implicit quantification in type synonyms]) -All this applies only for *instance* declarations.  In *class*-declarations there is no RHS to worry about, and the class variables-can all be in scope (#5862):+Here is a simple example of something we should reject:++  class C a b where+    type F a x+  instance C Int Bool where+    type F Int x = z++Here, `z` is mentioned on the RHS of the associated instance without being+mentioned on the LHS, nor is `z` mentioned in an outermost kind signature. The+renamer will reject `z` as being out of scope without much fuss.++Things get slightly trickier when the instance header itself binds type+variables. Consider this example (adapted from #5515):++   instance C (p,q) z where+      type F (p,q) x = (x, z)++According to the rule above, this instance is improperly scoped. However, due+to the way GHC's renamer works, `z` is /technically/ in scope, as GHC will+always bring type variables from an instance header into scope over the+associated type family instances. As a result, the renamer won't simply reject+the `z` as being out of scope (like it would for the `type F Int x = z`+example) unless further action is taken. It is important to reject this sort of+thing in the renamer, because if it is allowed to make it through to the+typechecker, unexpected shenanigans can occur (see #18021 for examples).++To prevent these sorts of shenanigans, we reject programs like the one above+with an extra validity check in rnFamEqn. For each type variable bound in the+parent instance head, we check if it is mentioned on the RHS of the associated+family instance but not bound on the LHS. If any of the instance-head-bound+variables meet these criteria, we throw an error.+(See rnFamEqn.improperly_scoped for how this is implemented.)++Some additional wrinkles:++* This Note only applies to *instance* declarations.  In *class* declarations+  there is no RHS to worry about, and the class variables can all be in scope+  (#5862):+     class Category (x :: k -> k -> *) where       type Ob x :: k -> Constraint       id :: Ob x a => x a a       (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c-Here 'k' is in scope in the kind signature, just like 'x'. -Although type family equations can bind type variables with explicit foralls,-it need not be the case that all variables that appear on the RHS must be bound-by a forall. For instance, the following is acceptable:+  Here 'k' is in scope in the kind signature, just like 'x'. -   class C a where-     type T a b-   instance C (Maybe a) where-     type forall b. T (Maybe a) b = Either a b+* Although type family equations can bind type variables with explicit foralls,+  it need not be the case that all variables that appear on the RHS must be+  bound by a forall. For instance, the following is acceptable: -Even though `a` is not bound by the forall, this is still accepted because `a`-was previously bound by the `instance C (Maybe a)` part. (see #16116).+    class C4 a where+      type T4 a b+    instance C4 (Maybe a) where+      type forall b. T4 (Maybe a) b = Either a b -In each case, the function which detects improperly bound variables on the RHS-is GHC.Tc.Validity.checkValidFamPats.+  Even though `a` is not bound by the forall, this is still accepted because `a`+  was previously bound by the `instance C4 (Maybe a)` part. (see #16116). +* In addition to the validity check in rnFamEqn.improperly_scoped, there is an+  additional check in GHC.Tc.Validity.checkFamPatBinders that checks each family+  instance equation for type variables used on the RHS but not bound on the+  LHS. This is not made redundant by rmFamEqn.improperly_scoped, as there are+  programs that each check will reject that the other check will not catch:++  - checkValidFamPats is used on all forms of family instances, whereas+    rmFamEqn.improperly_scoped only checks associated family instances. Since+    checkFamPatBinders occurs after typechecking, it can catch programs that+    introduce dodgy scoping by way of type synonyms (see #7536), which is+    impractical to accomplish in the renamer.+  - rnFamEqn.improperly_scoped catches some programs that, if allowed to escape+    the renamer, would accidentally be accepted by the typechecker. Here is one+    such program (#18021):++      class C5 a where+        data family D a++      instance forall a. C5 Int where+        data instance D Int = MkD a++    If this is not rejected in the renamer, the typechecker would treat this+    program as though the `a` were existentially quantified, like so:++      data instance D Int = forall a. MkD a++    This is likely not what the user intended!++    Here is another such program (#9574):++      class Funct f where+        type Codomain f+      instance Funct ('KProxy :: KProxy o) where+        type Codomain 'KProxy = NatTr (Proxy :: o -> Type)++    Where:++      data Proxy (a :: k) = Proxy+      data KProxy (t :: Type) = KProxy+      data NatTr (c :: o -> Type)++    Note that the `o` in the `Codomain 'KProxy` instance should be considered+    improperly scoped. It does not meet the criteria for being explicitly+    quantified, as it is not mentioned by name on the LHS, nor does it meet the+    criteria for being implicitly quantified, as it is used in a RHS kind+    signature that is not outermost (see Note [Implicit quantification in type+    synonyms]). However, `o` /is/ bound by the instance header, so if this+    program is not rejected by the renamer, the typechecker would treat it as+    though you had written this:++      instance Funct ('KProxy :: KProxy o) where+        type Codomain ('KProxy @o) = NatTr (Proxy :: o -> Type)++    Although this is a valid program, it's probably a stretch too far to turn+    `type Codomain 'KProxy = ...` into `type Codomain ('KProxy @o) = ...` here.+    If the user really wants the latter, it is simple enough to communicate+    their intent by mentioning `o` on the LHS by name.+ Note [Type family equations and occurrences] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In most data/type family equations, the type family name used in the equation@@ -1086,11 +1165,11 @@            (text "Standalone-derived instance head")            (getLHsInstDeclHead $ dropWildCards ty')        ; warnNoDerivStrat mds' loc-       ; return (DerivDecl noExtField ty' mds' overlap, fvs) }+       ; return (DerivDecl noAnn ty' mds' overlap, fvs) }   where     ctxt    = DerivDeclCtx     inf_err = Just (text "Inferred type variables are not allowed")-    loc = getLoc $ hsib_body nowc_ty+    loc = getLocA nowc_ty     nowc_ty = dropWildCards ty  standaloneDerivErr :: SDoc@@ -1122,7 +1201,7 @@                      , rd_lhs  = lhs                      , rd_rhs  = rhs })   = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs-       ; checkDupRdrNames rdr_names_w_loc+       ; checkDupRdrNamesN rdr_names_w_loc        ; checkShadowedRdrNames rdr_names_w_loc        ; names <- newLocalBndrsRn rdr_names_w_loc        ; let doc = RuleCtx (snd $ unLoc rule_name)@@ -1139,7 +1218,7 @@                         , rd_lhs  = lhs'                         , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }   where-    get_var :: RuleBndr GhcPs -> Located RdrName+    get_var :: RuleBndr GhcPs -> LocatedN RdrName     get_var (RuleBndrSig _ v _) = v     get_var (RuleBndr _ v)      = v @@ -1153,13 +1232,13 @@   where     go ((L l (RuleBndr _ (L loc _))) : vars) (n : ns) thing_inside       = go vars ns $ \ vars' ->-        thing_inside (L l (RuleBndr noExtField (L loc n)) : vars')+        thing_inside (L l (RuleBndr noAnn (L loc n)) : vars')      go ((L l (RuleBndrSig _ (L loc _) bsig)) : vars)        (n : ns) thing_inside       = rnHsPatSigType bind_free_tvs doc bsig $ \ bsig' ->         go vars ns $ \ vars' ->-        thing_inside (L l (RuleBndrSig noExtField (L loc n) bsig') : vars')+        thing_inside (L l (RuleBndrSig noAnn (L loc n) bsig') : vars')      go [] [] thing_inside = thing_inside []     go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)@@ -1399,10 +1478,10 @@ -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds   = do { -- Rename the type/class, instance, and role declaraations-       ; tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl) (tyClGroupTyClDecls tycl_ds)+       ; tycls_w_fvs <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)        ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)        ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names (tyClGroupKindSigs tycl_ds)-       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)+       ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)        ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)         -- Do SCC analysis on the type/class decls@@ -1485,7 +1564,7 @@   = do { let (no_dups, dup_kisigs) = removeDups (compare `on` get_name) kisigs              get_name = standaloneKindSigName . unLoc        ; mapM_ dupKindSig_Err dup_kisigs-       ; mapM (wrapLocFstM (rnStandaloneKindSignature tc_names)) no_dups+       ; mapM (wrapLocFstMA (rnStandaloneKindSignature tc_names)) no_dups        }  rnStandaloneKindSignature@@ -1495,7 +1574,7 @@ rnStandaloneKindSignature tc_names (StandaloneKindSig _ v ki)   = do  { standalone_ki_sig_ok <- xoptM LangExt.StandaloneKindSignatures         ; unless standalone_ki_sig_ok $ addErr standaloneKiSigErr-        ; new_v <- lookupSigCtxtOccRn (TopSigCtxt tc_names) (text "standalone kind signature") v+        ; new_v <- lookupSigCtxtOccRnN (TopSigCtxt tc_names) (text "standalone kind signature") v         ; let doc = StandaloneKindSigCtx (ppr v)         ; (new_ki, fvs) <- rnHsSigType doc KindLevel ki         ; return (StandaloneKindSig noExtField new_v new_ki, fvs)@@ -1540,7 +1619,6 @@   = case lookupGRE_Name rdr_env n of       Just gre -> case gre_par gre of                     ParentIs  { par_is = p } -> p-                    FldParent { par_is = p } -> p                     _                        -> n       Nothing -> n @@ -1564,19 +1642,19 @@          let (no_dups, dup_annots) = removeDups (compare `on` get_name) role_annots              get_name = roleAnnotDeclName . unLoc        ; mapM_ dupRoleAnnotErr dup_annots-       ; mapM (wrapLocM rn_role_annot1) no_dups }+       ; mapM (wrapLocMA rn_role_annot1) no_dups }   where     rn_role_annot1 (RoleAnnotDecl _ tycon roles)       = do {  -- the name is an *occurrence*, but look it up only in the               -- decls defined in this group (see #10263)-             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)-                                          (text "role annotation")-                                          tycon+             tycon' <- lookupSigCtxtOccRnN (RoleAnnotCtxt tc_names)+                                           (text "role annotation")+                                           tycon            ; return $ RoleAnnotDecl noExtField tycon' roles }  dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM () dupRoleAnnotErr list-  = addErrAt loc $+  = addErrAt (locA loc) $     hang (text "Duplicate role annotations for" <+>           quotes (ppr $ roleAnnotDeclName first_decl) <> colon)        2 (vcat $ map pp_role_annot $ NE.toList sorted_list)@@ -1585,13 +1663,13 @@       ((L loc first_decl) :| _) = sorted_list        pp_role_annot (L loc decl) = hang (ppr decl)-                                      4 (text "-- written at" <+> ppr loc)+                                      4 (text "-- written at" <+> ppr (locA loc)) -      cmp_loc = SrcLoc.leftmost_smallest `on` getLoc+      cmp_loc = SrcLoc.leftmost_smallest `on` getLocA  dupKindSig_Err :: NonEmpty (LStandaloneKindSig GhcPs) -> RnM () dupKindSig_Err list-  = addErrAt loc $+  = addErrAt (locA loc) $     hang (text "Duplicate standalone kind signatures for" <+>           quotes (ppr $ standaloneKindSigName first_decl) <> colon)        2 (vcat $ map pp_kisig $ NE.toList sorted_list)@@ -1600,9 +1678,9 @@       ((L loc first_decl) :| _) = sorted_list        pp_kisig (L loc decl) =-        hang (ppr decl) 4 (text "-- written at" <+> ppr loc)+        hang (ppr decl) 4 (text "-- written at" <+> ppr (locA loc)) -      cmp_loc = SrcLoc.leftmost_smallest `on` getLoc+      cmp_loc = SrcLoc.leftmost_smallest `on` getLocA  {- Note [Role annotations in the renamer] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1685,7 +1763,7 @@  rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,                       tcdFixity = fixity, tcdRhs = rhs })-  = do { tycon' <- lookupLocatedTopBndrRn tycon+  = do { tycon' <- lookupLocatedTopBndrRnN tycon        ; let kvs = extractHsTyRdrTyVarsKindVars rhs              doc = TySynCtx tycon        ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)@@ -1701,7 +1779,7 @@       tcdFixity = fixity,       tcdDataDefn = defn@HsDataDefn{ dd_ND = new_or_data                                    , dd_kindSig = kind_sig} })-  = do { tycon' <- lookupLocatedTopBndrRn tycon+  = do { tycon' <- lookupLocatedTopBndrRnN tycon        ; let kvs = extractDataDefnKindVars defn              doc = TyDataCtx tycon        ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)@@ -1722,7 +1800,7 @@                         tcdFDs = fds, tcdSigs = sigs,                         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,                         tcdDocs = docs})-  = do  { lcls' <- lookupLocatedTopBndrRn lcls+  = do  { lcls' <- lookupLocatedTopBndrRnN lcls         ; let cls' = unLoc lcls'               kvs = []  -- No scoped kind vars except those in                         -- kind signatures on the tyvars@@ -1749,7 +1827,7 @@         ; let sig_rdr_names_w_locs =                 [op | L _ (ClassOpSig _ False ops _) <- sigs                     , op <- ops]-        ; checkDupRdrNames sig_rdr_names_w_locs+        ; checkDupRdrNamesN sig_rdr_names_w_locs                 -- Typechecker is responsible for checking that we only                 -- give default-method bindings for things in this class.                 -- The renamer *could* check this for class decls, but can't@@ -1769,21 +1847,18 @@                 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn                 -- and the methods are already in scope -  -- Haddock docs-        ; docs' <- mapM (wrapLocM rnDocDecl) docs-         ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',                               tcdTyVars = tyvars', tcdFixity = fixity,                               tcdFDs = fds', tcdSigs = sigs',                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',-                              tcdDocs = docs', tcdCExt = all_fvs },+                              tcdDocs = docs, tcdCExt = all_fvs },                   all_fvs ) }   where     cls_doc  = ClassDeclCtx lcls  -- Does the data type declaration include a CUSK?-data_decl_has_cusk :: LHsQTyVars pass -> NewOrData -> Bool -> Maybe (LHsKind pass') -> RnM Bool+data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do   { -- See Note [Unlifted Newtypes and CUSKs], and for a broader     -- picture, see Note [Implementation of UnliftedNewtypes].@@ -1825,7 +1900,7 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType                            , dd_ctxt = context, dd_cons = condecls                            , dd_kindSig = m_sig, dd_derivs = derivs })-  = do  { checkTc (h98_style || null (unLoc context))+  = do  { checkTc (h98_style || null (fromMaybeContext context))                   (badGadtStupidTheta doc)          ; (m_sig', sig_fvs) <- case m_sig of@@ -1858,12 +1933,12 @@                      (L _ (ConDeclGADT {}))                    : _ -> False                      _                                             -> True -    rn_derivs (L loc ds)+    rn_derivs ds       = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies            ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)                multipleDerivClausesErr            ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds-           ; return (L loc ds', fvs) }+           ; return (ds', fvs) }  warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)                  -> SrcSpan@@ -1894,15 +1969,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")@@ -1943,24 +2028,22 @@         failWith $ illegalDerivStrategyErr ds        case ds of-        StockStrategy    -> boring_case StockStrategy-        AnyclassStrategy -> boring_case AnyclassStrategy-        NewtypeStrategy  -> boring_case NewtypeStrategy-        ViaStrategy via_ty ->+        StockStrategy    _ -> boring_case (StockStrategy noExtField)+        AnyclassStrategy _ -> boring_case (AnyclassStrategy noExtField)+        NewtypeStrategy  _ -> boring_case (NewtypeStrategy noExtField)+        ViaStrategy (XViaStrategyPs _ via_ty) ->           do checkInferredVars doc inf_err via_ty              (via_ty', fvs1) <- rnHsSigType doc TypeLevel via_ty-             let HsIB { hsib_ext  = via_imp_tvs-                      , hsib_body = via_body } = via_ty'-                 (via_exp_tv_bndrs, via_rho) = splitLHsForAllTyInvis_KP via_body-                 via_exp_tvs = maybe [] hsLTyVarNames via_exp_tv_bndrs-                 via_tvs = via_imp_tvs ++ via_exp_tvs+             let HsSig { sig_bndrs = via_outer_bndrs+                       , sig_body  = via_body } = unLoc via_ty'+                 via_tvs = hsOuterTyVarNames via_outer_bndrs              -- Check if there are any nested `forall`s, which are illegal in a              -- `via` type.              -- See Note [No nested foralls or contexts in instance types]              -- (Wrinkle: Derived instances) in GHC.Hs.Type.              addNoNestedForallsContextsErr doc-               (quotes (text "via") <+> text "type") via_rho-             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs thing_inside+               (quotes (text "via") <+> text "type") via_body+             (thing, fvs2) <- bindLocalNamesFV via_tvs thing_inside              pure (ViaStrategy via_ty', thing, fvs1 `plusFV` fvs2)      inf_err = Just (text "Inferred type variables are not allowed")@@ -1999,10 +2082,11 @@           -> FamilyDecl GhcPs           -> RnM (FamilyDecl GhcRn, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars+                             , fdTopLevel = toplevel                              , fdFixity = fixity                              , fdInfo = info, fdResultSig = res_sig                              , fdInjectivityAnn = injectivity })-  = do { tycon' <- lookupLocatedTopBndrRn tycon+  = do { tycon' <- lookupLocatedTopBndrRnN tycon        ; ((tyvars', res_sig', injectivity'), fv1) <-             bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' _ ->             do { let rn_sig = rnFamResultSig doc@@ -2011,8 +2095,9 @@                                           injectivity                ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }        ; (info', fv2) <- rn_info info-       ; return (FamilyDecl { fdExt = noExtField+       ; return (FamilyDecl { fdExt = noAnn                             , fdLName = tycon', fdTyVars = tyvars'+                            , fdTopLevel = toplevel                             , fdFixity = fixity                             , fdInfo = info', fdResultSig = res_sig'                             , fdInjectivityAnn = injectivity' }@@ -2053,7 +2138,7 @@           rdr_env <- getLocalRdrEnv        ;  let resName = hsLTyVarName tvbndr        ;  when (resName `elemLocalRdrEnv` rdr_env) $-          addErrAt (getLoc tvbndr) $+          addErrAt (getLocA tvbndr) $                      (hsep [ text "Type variable", quotes (ppr resName) <> comma                            , text "naming a type family result,"                            ] $$@@ -2104,16 +2189,16 @@                  -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation                  -> RnM (LInjectivityAnn GhcRn) rnInjectivityAnn tvBndrs (L _ (TyVarSig _ resTv))-                 (L srcSpan (InjectivityAnn injFrom injTo))+                 (L srcSpan (InjectivityAnn x injFrom injTo))  = do-   { (injDecl'@(L _ (InjectivityAnn injFrom' injTo')), noRnErrors)+   { (injDecl'@(L _ (InjectivityAnn _ injFrom' injTo')), noRnErrors)           <- askNoErrs $              bindLocalNames [hsLTyVarName resTv] $              -- The return type variable scopes over the injectivity annotation              -- e.g.   type family F a = (r::*) | r -> a              do { injFrom' <- rnLTyVar injFrom                 ; injTo'   <- mapM rnLTyVar injTo-                ; return $ L srcSpan (InjectivityAnn injFrom' injTo') }+                ; return $ L srcSpan (InjectivityAnn x injFrom' injTo') }     ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs          resName  = hsLTyVarName resTv@@ -2125,7 +2210,7 @@    -- not-in-scope variables) don't check the validity of injectivity    -- annotation. This gives better error messages.    ; when (noRnErrors && not lhsValid) $-        addErrAt (getLoc injFrom)+        addErrAt (getLocA injFrom)               ( vcat [ text $ "Incorrect type variable on the LHS of "                            ++ "injectivity condition"               , nest 5@@ -2149,12 +2234,12 @@ -- -- So we rename injectivity annotation like we normally would except that -- this time we expect "result" to be reported not in scope by rnLTyVar.-rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =+rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn x injFrom injTo)) =    setSrcSpan srcSpan $ do    (injDecl', _) <- askNoErrs $ do      injFrom' <- rnLTyVar injFrom      injTo'   <- mapM rnLTyVar injTo-     return $ L srcSpan (InjectivityAnn injFrom' injTo')+     return $ L srcSpan (InjectivityAnn x injFrom' injTo')    return $ injDecl'  {-@@ -2177,15 +2262,14 @@  ----------------- rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)-rnConDecls = mapFvRn (wrapLocFstM rnConDecl)+rnConDecls = mapFvRn (wrapLocFstMA rnConDecl)  rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs                            , con_mb_cxt = mcxt, con_args = args-                           , con_doc = mb_doc })-  = do  { _        <- addLocM checkConName name-        ; new_name <- lookupLocatedTopBndrRn name-        ; mb_doc'  <- rnMbLHsDoc mb_doc+                           , con_doc = mb_doc, con_forall = forall })+  = do  { _        <- addLocMA checkConName name+        ; new_name <- lookupLocatedTopBndrRnN name          -- We bind no implicit binders here; this is just like         -- a nested HsForAllTy.  E.g. consider@@ -2200,50 +2284,44 @@         ; bindLHsTyVarBndrs ctxt WarnUnusedForalls                             Nothing ex_tvs $ \ new_ex_tvs ->     do  { (new_context, fvs1) <- rnMbContext ctxt mcxt-        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args+        ; (new_args,    fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args         ; let all_fvs  = fvs1 `plusFV` fvs2         ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat              [ text "ex_tvs:" <+> ppr ex_tvs              , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) -        ; return (decl { con_ext = noExtField+        ; return (decl { con_ext = noAnn                        , con_name = new_name, con_ex_tvs = new_ex_tvs                        , con_mb_cxt = new_context, con_args = new_args-                       , con_doc = mb_doc' },+                       , con_doc = mb_doc+                       , con_forall = forall }, -- Remove when #18311 is fixed                   all_fvs) }} -rnConDecl decl@(ConDeclGADT { con_names   = names-                            , con_forall  = L _ explicit_forall-                            , con_qvars   = explicit_tkvs-                            , con_mb_cxt  = mcxt-                            , con_args    = args-                            , con_res_ty  = res_ty-                            , con_doc = mb_doc })-  = do  { mapM_ (addLocM checkConName) names-        ; new_names <- mapM lookupLocatedTopBndrRn names-        ; mb_doc'   <- rnMbLHsDoc mb_doc--        ; let theta         = hsConDeclTheta mcxt-              arg_tys       = hsConDeclArgTys args+rnConDecl (ConDeclGADT { con_names   = names+                       , con_bndrs   = L l outer_bndrs+                       , con_mb_cxt  = mcxt+                       , con_g_args  = args+                       , con_res_ty  = res_ty+                       , con_doc     = mb_doc })+  = do  { mapM_ (addLocMA checkConName) names+        ; new_names <- mapM lookupLocatedTopBndrRnN names -          -- We must ensure that we extract the free tkvs in left-to-right-          -- order of their appearance in the constructor type.-          -- That order governs the order the implicitly-quantified type-          -- variable, and hence the order needed for visible type application-          -- See #14808.-        ; implicit_bndrs <- forAllOrNothing explicit_forall-            $ extractHsTvBndrs explicit_tkvs-            $ extractHsTysRdrTyVars theta-            $ extractHsScaledTysRdrTyVars arg_tys-            $ extractHsTysRdrTyVars [res_ty] []+        ; let -- We must ensure that we extract the free tkvs in left-to-right+              -- order of their appearance in the constructor type.+              -- That order governs the order the implicitly-quantified type+              -- variable, and hence the order needed for visible type application+              -- See #14808.+              implicit_bndrs =+                extractHsOuterTvBndrs outer_bndrs           $+                extractHsTysRdrTyVars (hsConDeclTheta mcxt) $+                extractConDeclGADTDetailsTyVars args        $+                extractHsTysRdrTyVars [res_ty] []          ; let ctxt = ConDeclCtx new_names -        ; rnImplicitBndrs Nothing implicit_bndrs $ \ implicit_tkvs ->-          bindLHsTyVarBndrs ctxt WarnUnusedForalls-                            Nothing explicit_tkvs $ \ explicit_tkvs ->+        ; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->     do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt-        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args+        ; (new_args, fvs2)   <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args         ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty           -- Ensure that there are no nested `forall`s or contexts, per@@ -2255,52 +2333,71 @@         ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3          ; traceRn "rnConDecl (ConDeclGADT)"-            (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)-        ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names-                       , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt-                       , con_args = new_args, con_res_ty = new_res_ty-                       , con_doc = mb_doc' },+            (ppr names $$ ppr outer_bndrs')+        ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names+                              , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt+                              , con_g_args = new_args, con_res_ty = new_res_ty+                              , con_doc = mb_doc },                   all_fvs) } }  rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)             -> RnM (Maybe (LHsContext GhcRn), FreeVars) rnMbContext _    Nothing    = return (Nothing, emptyFVs)-rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt-                                ; return (Just ctx',fvs) }+rnMbContext doc cxt = do { (ctx',fvs) <- rnContext doc cxt+                         ; return (ctx',fvs) } -rnConDeclDetails-   :: Name+rnConDeclH98Details ::+      Name    -> HsDocContext-   -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs])-   -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]),-           FreeVars)-rnConDeclDetails _ doc (PrefixCon tys)+   -> HsConDeclH98Details GhcPs+   -> RnM (HsConDeclH98Details GhcRn, FreeVars)+rnConDeclH98Details _ doc (PrefixCon _ tys)   = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys-       ; return (PrefixCon new_tys, fvs) }--rnConDeclDetails _ doc (InfixCon ty1 ty2)+       ; return (PrefixCon noTypeArgs new_tys, fvs) }+rnConDeclH98Details _ doc (InfixCon ty1 ty2)   = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1        ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2        ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }+rnConDeclH98Details con doc (RecCon flds)+  = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds+       ; return (RecCon new_flds, fvs) } -rnConDeclDetails con doc (RecCon (L l fields))+rnConDeclGADTDetails ::+      Name+   -> HsDocContext+   -> HsConDeclGADTDetails GhcPs+   -> RnM (HsConDeclGADTDetails GhcRn, FreeVars)+rnConDeclGADTDetails _ doc (PrefixConGADT tys)+  = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys+       ; return (PrefixConGADT new_tys, fvs) }+rnConDeclGADTDetails con doc (RecConGADT flds)+  = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds+       ; return (RecConGADT new_flds, fvs) }++rnRecConDeclFields ::+     Name+  -> HsDocContext+  -> LocatedL [LConDeclField GhcPs]+  -> RnM (LocatedL [LConDeclField GhcRn], FreeVars)+rnRecConDeclFields con doc (L l fields)   = do  { fls <- lookupConstructorFields con         ; (new_fields, fvs) <- rnConDeclFields doc fls fields                 -- No need to check for duplicate fields                 -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn-        ; return (RecCon (L l new_fields), fvs) }+        ; pure (L l new_fields, fvs) }  -------------------------------------------------  -- | Brings pattern synonym names and also pattern synonym selectors -- from record pattern synonyms into scope.-extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv+extendPatSynEnv :: DuplicateRecordFields -> FieldSelectors -> HsValBinds GhcPs -> MiniFixityEnv                 -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a-extendPatSynEnv val_decls local_fix_env thing = do {+extendPatSynEnv dup_fields_ok has_sel val_decls local_fix_env thing = do {      names_with_fls <- new_ps val_decls    ; let pat_syn_bndrs = concat [ name: map flSelector fields                                 | (name, fields) <- names_with_fls ]-   ; let avails = map avail pat_syn_bndrs+   ; let avails = map avail (map fst names_with_fls)+               ++ map availField (concatMap snd names_with_fls)    ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env     ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls@@ -2318,16 +2415,13 @@       | (L bind_loc (PatSynBind _ (PSB { psb_id = L _ n                                        , psb_args = RecCon as }))) <- bind       = do-          bnd_name <- newTopSrcBinder (L bind_loc n)-          let rnames = map recordPatSynSelectorId as-              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs-              mkFieldOcc (L l name) = L l (FieldOcc noExtField (L l name))-              field_occs =  map mkFieldOcc rnames-          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs+          bnd_name <- newTopSrcBinder (L (l2l bind_loc) n)+          let field_occs = map ((\ f -> L (getLocA (rdrNameFieldOcc f)) f) . recordPatSynField) as+          flds <- mapM (newRecordSelector dup_fields_ok has_sel [bnd_name]) field_occs           return ((bnd_name, flds): names)       | L bind_loc (PatSynBind _ (PSB { psb_id = L _ n})) <- bind       = do-        bnd_name <- newTopSrcBinder (L bind_loc n)+        bnd_name <- newTopSrcBinder (L (la2na bind_loc) n)         return ((bnd_name, []): names)       | otherwise       = return names@@ -2342,17 +2436,18 @@  rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn] rnFds fds-  = mapM (wrapLocM rn_fds) fds+  = mapM (wrapLocMA rn_fds) fds   where-    rn_fds (tys1, tys2)+    rn_fds :: FunDep GhcPs -> RnM (FunDep GhcRn)+    rn_fds (FunDep x tys1 tys2)       = do { tys1' <- rnHsTyVars tys1            ; tys2' <- rnHsTyVars tys2-           ; return (tys1', tys2') }+           ; return (FunDep x tys1' tys2') } -rnHsTyVars :: [Located RdrName] -> RnM [Located Name]+rnHsTyVars :: [LocatedN RdrName] -> RnM [LocatedN Name] rnHsTyVars tvs  = mapM rnHsTyVar tvs -rnHsTyVar :: Located RdrName -> RnM (Located Name)+rnHsTyVar :: LocatedN RdrName -> RnM (LocatedN Name) rnHsTyVar (L l tyvar) = do   tyvar' <- lookupOccRn tyvar   return (L l tyvar')@@ -2381,7 +2476,7 @@ addl gp (L l d : ds) = add gp l d ds  -add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]+add :: HsGroup GhcPs -> SrcSpanAnnA -> HsDecl GhcPs -> [LHsDecl GhcPs]     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))  -- #10047: Declaration QuasiQuoters are expanded immediately, without@@ -2397,7 +2492,7 @@          case flag of            ExplicitSplice -> return ()            ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell-                                ; unless th_on $ setSrcSpan loc $+                                ; unless th_on $ setSrcSpan (locA loc) $                                   failWith badImplicitSplice }         ; return (gp, Just (splice, ds)) }

GHC/Rename/Names.hs view

@@ -4,7 +4,7 @@ Extracting imported and top-level names in scope -} -{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}+{-# LANGUAGE CPP, NondecreasingIndentation #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -34,43 +34,62 @@  import GHC.Prelude +import GHC.Driver.Env import GHC.Driver.Session-import GHC.Core.TyCo.Ppr-import GHC.Hs-import GHC.Tc.Utils.Env+import GHC.Driver.Ppr+ import GHC.Rename.Env import GHC.Rename.Fixity import GHC.Rename.Utils ( warnUnusedTopBinds, mkFieldEnv )-import GHC.Iface.Load   ( loadSrcInterface )++import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad++import GHC.Hs+import GHC.Iface.Load   ( loadSrcInterface ) import GHC.Builtin.Names-import GHC.Unit.Module+import GHC.Parser.PostProcess ( setRdrNameSpace )+import GHC.Core.Type+import GHC.Core.PatSyn+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCon ( TyCon, tyConName, tyConKind )+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Misc as Utils+import GHC.Utils.Panic++import GHC.Types.Fixity.Env+import GHC.Types.SafeHaskell import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set+import GHC.Types.Name.Reader import GHC.Types.Avail import GHC.Types.FieldLabel-import GHC.Driver.Types-import GHC.Types.Name.Reader-import GHC.Parser.PostProcess ( setRdrNameSpace )-import GHC.Utils.Outputable as Outputable-import GHC.Data.Maybe+import GHC.Types.SourceFile import GHC.Types.SrcLoc as SrcLoc-import GHC.Types.Basic  ( TopLevelFlag(..), StringLiteral(..) )-import GHC.Utils.Misc as Utils+import GHC.Types.Basic  ( TopLevelFlag(..) )+import GHC.Types.SourceText+import GHC.Types.Id+import GHC.Types.HpcInfo++import GHC.Unit+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps++import GHC.Data.Maybe import GHC.Data.FastString import GHC.Data.FastString.Env-import GHC.Types.Id-import GHC.Core.Type-import GHC.Core.PatSyn-import qualified GHC.LanguageExtensions as LangExt  import Control.Monad-import Data.Either      ( partitionEithers, isRight, rights )+import Data.Either      ( partitionEithers ) import Data.Map         ( Map ) import qualified Data.Map as Map import Data.Ord         ( comparing )-import Data.List        ( partition, (\\), find, sortBy )+import Data.List        ( partition, (\\), find, sortBy, groupBy, sortOn ) import Data.Function    ( on ) import qualified Data.Set as S import System.FilePath  ((</>))@@ -268,13 +287,12 @@ rnImportDecl  :: Module -> LImportDecl GhcPs              -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod-             (L loc decl@(ImportDecl { ideclExt = noExtField-                                     , ideclName = loc_imp_mod_name+             (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name                                      , ideclPkgQual = mb_pkg                                      , ideclSource = want_boot, ideclSafe = mod_safe                                      , ideclQualified = qual_style, ideclImplicit = implicit                                      , ideclAs = as_mod, ideclHiding = imp_details }))-  = setSrcSpan loc $ do+  = setSrcSpanA loc $ do      when (isJust mb_pkg) $ do         pkg_imports <- xoptM LangExt.PackageImports@@ -305,7 +323,7 @@                            -- or the name of this_mod's package.  Yurgh!                            -- c.f. GHC.findModule, and #9997              Nothing         -> True-             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||+             Just (StringLiteral _ pkg_fs _) -> pkg_fs == fsLit "this" ||                             fsToUnit pkg_fs == moduleUnit this_mod))          (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name)) @@ -344,7 +362,7 @@     let         qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name         imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,-                                  is_dloc = loc, is_as = qual_mod_name }+                                  is_dloc = locA loc, is_as = qual_mod_name }      -- filter the imports according to the import declaration     (new_imp_details, gres) <- filterImports iface imp_spec imp_details@@ -363,15 +381,17 @@                     || (not implicit && safeDirectImpsReq dflags)                     || (implicit && safeImplicitImpsReq dflags) -    let imv = ImportedModsVal+    hsc_env <- getTopEnv+    let home_unit = hsc_home_unit hsc_env+        imv = ImportedModsVal             { imv_name        = qual_mod_name-            , imv_span        = loc+            , imv_span        = locA loc             , imv_is_safe     = mod_safe'             , imv_is_hiding   = is_hiding             , imv_all_exports = potential_gres             , imv_qualified   = qual_only             }-        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)+        imports = calculateAvails home_unit iface mod_safe' want_boot (ImportedByUser imv)      -- Complain if we import a deprecated module     whenWOptM Opt_WarnWarningsDeprecations (@@ -385,19 +405,21 @@     warnUnqualifiedImport decl iface      let new_imp_decl = L loc (decl { ideclExt = noExtField, ideclSafe = mod_safe'-                                   , ideclHiding = new_imp_details })+                                   , ideclHiding = new_imp_details+                                   , ideclName = ideclName decl+                                   , ideclAs = ideclAs decl })      return (new_imp_decl, gbl_env, imports, mi_hpc iface)  -- | Calculate the 'ImportAvails' induced by an import of a particular -- interface, but without 'imp_mods'.-calculateAvails :: DynFlags+calculateAvails :: HomeUnit                 -> ModIface                 -> IsSafeImport                 -> IsBootInterface                 -> ImportedBy                 -> ImportAvails-calculateAvails dflags iface mod_safe' want_boot imported_by =+calculateAvails home_unit iface mod_safe' want_boot imported_by =   let imp_mod    = mi_module iface       imp_sem_mod= mi_semantic_module iface       orph_iface = mi_orphan (mi_final_exts iface)@@ -448,7 +470,7 @@       ptrust = trust == Sf_Trustworthy || trust_pkg        (dependent_mods, dependent_pkgs, pkg_trust_req)-         | pkg == homeUnit dflags =+         | isHomeUnit home_unit pkg =             -- Imported module is from the home package             -- Take its dependent modules and add imp_mod itself             -- Take its dependent packages unchanged@@ -503,7 +525,7 @@     $ addWarnAt (Reason Opt_WarnCompatUnqualifiedImports) loc warning   where     mod = mi_module iface-    loc = getLoc $ ideclName decl+    loc = getLocA $ ideclName decl      is_qual = isImportDeclQualified (ideclQualified decl)     has_import_list =@@ -546,7 +568,7 @@  Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types+See also: Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env           Note [Looking up Exact RdrNames] in GHC.Rename.Env  Consider a Template Haskell declaration quotation like this:@@ -602,7 +624,8 @@                        | otherwise      = rdr_env                lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs-                                                       [ (n, (TopLevel, th_lvl))+                                                       [ ( greNameMangledName n+                                                         , (TopLevel, th_lvl) )                                                        | n <- new_names ] }          ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres@@ -613,8 +636,8 @@         ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)         ; return (gbl_env', lcl_env3) }   where-    new_names = concatMap availNames avails-    new_occs  = map nameOccName new_names+    new_names = concatMap availGreNames avails+    new_occs  = map occName new_names      -- If there is a fixity decl for the gre, add it to the fixity env     extend_fix_env fix_env gre@@ -623,7 +646,7 @@       | otherwise       = fix_env       where-        name = gre_name gre+        name = greMangledName gre         occ  = greOccName gre      new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails@@ -641,14 +664,108 @@       | otherwise       = return (extendGlobalRdrEnv env gre)       where-        occ  = greOccName gre-        dups = filter isDupGRE (lookupGlobalRdrEnv env occ)-        -- Duplicate GREs are those defined locally with the same OccName,-        -- except cases where *both* GREs are DuplicateRecordFields (#17965).-        isDupGRE gre' = isLocalGRE gre'-                && not (isOverloadedRecFldGRE gre && isOverloadedRecFldGRE gre')+        -- See Note [Reporting duplicate local declarations]+        dups = filter isDupGRE (lookupGlobalRdrEnv env (greOccName gre))+        isDupGRE gre' = isLocalGRE gre' && not (isAllowedDup gre')+        isAllowedDup gre' =+            case (isRecFldGRE gre, isRecFldGRE gre') of+              (True,  True)  -> gre_name gre /= gre_name gre'+                                  && isDuplicateRecFldGRE gre'+              (True,  False) -> isNoFieldSelectorGRE gre+              (False, True)  -> isNoFieldSelectorGRE gre'+              (False, False) -> False +{-+Note [Reporting duplicate local declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, a single module may not define the same OccName multiple times. This+is checked in extendGlobalRdrEnvRn: when adding a new locally-defined GRE to the+GlobalRdrEnv we report an error if there are already duplicates in the+environment.  This establishes INVARIANT 1 (see comments on GlobalRdrEnv in+GHC.Types.Name.Reader), which says that for a given OccName, all the+GlobalRdrElts to which it maps must have distinct 'gre_name's. +For example, the following will be rejected:++  f x = x+  g x = x+  f x = x  -- Duplicate!++Two GREs with the same OccName are OK iff:+-------------------------------------------------------------------+  Existing GRE     |          Newly-defined GRE+                   |  NormalGre            FieldGre+-------------------------------------------------------------------+  Imported         |  Always               Always+                   |+  Local NormalGre  |  Never                NoFieldSelectors+                   |+  Local FieldGre   |  NoFieldSelectors     DuplicateRecordFields+                   |                       and not in same record+-------------------------------------------------------------------            -+In this table "NoFieldSelectors" means "NoFieldSelectors was enabled at the+definition site of the fields; ditto "DuplicateRecordFields".  These facts are+recorded in the 'FieldLabel' (but where both GREs are local, both will+necessarily have the same extensions enabled).++More precisely:++* The programmer is allowed to make a new local definition that clashes with an+  imported one (although attempting to refer to either may lead to ambiguity+  errors at use sites).  For example, the following definition is allowed:++    import M (f)+    f x = x++  Thus isDupGRE reports errors only if the existing GRE is a LocalDef.++* When DuplicateRecordFields is enabled, the same field label may be defined in+  multiple records. For example, this is allowed:++    {-# LANGUAGE DuplicateRecordFields #-}+    data S1 = MkS1 { f :: Int }+    data S2 = MkS2 { f :: Int }++  Even though both fields have the same OccName, this does not violate INVARIANT+  1 of the GlobalRdrEnv, because the fields have distinct selector names, which+  form part of the gre_name (see Note [GreNames] in GHC.Types.Name.Reader).++* However, we must be careful to reject the following (#9156):++    {-# LANGUAGE DuplicateRecordFields #-}+    data T = MkT { f :: Int, f :: Int }  -- Duplicate!++  In this case, both 'gre_name's are the same (because the fields belong to the+  same type), and adding them both to the environment would be a violation of+  INVARIANT 1. Thus isAllowedDup checks both GREs have distinct 'gre_name's+  if they are both record fields.++* With DuplicateRecordFields, we reject attempts to define a field and a+  non-field with the same OccName (#17965):++    {-# LANGUAGE DuplicateRecordFields #-}+    f x = x+    data T = MkT { f :: Int}++  In principle this could be supported, but the current "specification" of+  DuplicateRecordFields does not allow it. Thus isAllowedDup checks for+  DuplicateRecordFields only if *both* GREs being compared are record fields.++* However, with NoFieldSelectors, it is possible by design to define a field and+  a non-field with the same OccName:++    {-# LANGUAGE NoFieldSelectors #-}+    f x = x+    data T = MkT { f :: Int}++  Thus isAllowedDup checks for NoFieldSelectors if either the existing or the+  new GRE are record fields.  See Note [NoFieldSelectors] in GHC.Rename.Env.++See also Note [Skipping ambiguity errors at use sites of local declarations] in+GHC.Rename.Utils.+-}++ {- ********************************************************************* *                                                                      *     getLocalDeclBindersd@ returns the names for an HsDecl@@ -675,9 +792,10 @@                 hs_fords  = foreign_decls })   = do  { -- Process all type/class decls *except* family instances         ; let inst_decls = tycl_decls >>= group_instds-        ; overload_ok <- xoptM LangExt.DuplicateRecordFields+        ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags+        ; has_sel <- xopt_FieldSelectors <$> getDynFlags         ; (tc_avails, tc_fldss)-            <- fmap unzip $ mapM (new_tc overload_ok)+            <- fmap unzip $ mapM (new_tc dup_fields_ok has_sel)                                  (tyClGroupTyClDecls tycl_decls)         ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)         ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env@@ -687,7 +805,7 @@            -- Process all family instances           -- to bring new data constructors into scope-        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc dup_fields_ok has_sel)                                                    inst_decls            -- Finish off with value binders:@@ -705,12 +823,9 @@         ; traceRn "getLocalNonValBinders 2" (ppr avails)         ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env -        -- Force the field access so that tcg_env is not retained. The-        -- selector thunk optimisation doesn't kick-in, see #20139-        ; let !old_field_env = tcg_field_env tcg_env         -- Extend tcg_field_env with new fields (this used to be the         -- work of extendRecordFieldEnv)-              field_env = extendNameEnvList old_field_env flds+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds               envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)          ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])@@ -718,30 +833,30 @@   where     ValBinds _ _val_binds val_sigs = binds -    for_hs_bndrs :: [Located RdrName]+    for_hs_bndrs :: [LocatedN RdrName]     for_hs_bndrs = hsForeignDeclsBinders foreign_decls      -- In a hs-boot file, the value binders come from the     --  *signatures*, and there should be no foreign binders-    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)+    hs_boot_sig_bndrs = [ L (l2l decl_loc) (unLoc n)                         | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]        -- the SrcSpan attached to the input should be the span of the       -- declaration, not just the name-    new_simple :: Located RdrName -> RnM AvailInfo+    new_simple :: LocatedN RdrName -> RnM AvailInfo     new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name                             ; return (avail nm) } -    new_tc :: Bool -> LTyClDecl GhcPs+    new_tc :: DuplicateRecordFields -> FieldSelectors -> LTyClDecl GhcPs            -> RnM (AvailInfo, [(Name, [FieldLabel])])-    new_tc overload_ok tc_decl -- NOT for type/data instances+    new_tc dup_fields_ok has_sel tc_decl -- NOT for type/data instances         = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl-             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs-             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; names@(main_name : sub_names) <- mapM (newTopSrcBinder . l2n) bndrs+             ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds              ; let fld_env = case unLoc tc_decl of                      DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'                      _                            -> []-             ; return (AvailTC main_name names flds', fld_env) }+             ; return (availTC main_name names flds', fld_env) }       -- Calculate the mapping from constructor names to fields, which@@ -756,7 +871,7 @@             = [( find_con_name rdr                , concatMap find_con_decl_flds (unLoc cdflds) )]         find_con_flds (L _ (ConDeclGADT { con_names = rdrs-                                        , con_args = RecCon flds }))+                                        , con_g_args = RecConGADT flds }))             = [ ( find_con_name rdr                  , concatMap find_con_decl_flds (unLoc flds))               | L _ rdr <- rdrs ]@@ -774,15 +889,15 @@               find (\ fl -> flLabel fl == lbl) flds           where lbl = occNameFS (rdrNameOcc rdr) -    new_assoc :: Bool -> LInstDecl GhcPs+    new_assoc :: DuplicateRecordFields -> FieldSelectors -> LInstDecl GhcPs               -> RnM ([AvailInfo], [(Name, [FieldLabel])])-    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])+    new_assoc _ _ (L _ (TyFamInstD {})) = return ([], [])       -- type instances don't bind new names -    new_assoc overload_ok (L _ (DataFamInstD _ d))-      = do { (avail, flds) <- new_di overload_ok Nothing d+    new_assoc dup_fields_ok has_sel (L _ (DataFamInstD _ d))+      = do { (avail, flds) <- new_di dup_fields_ok has_sel Nothing d            ; return ([avail], flds) }-    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty+    new_assoc dup_fields_ok has_sel (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty                                                       , cid_datafam_insts = adts })))       = do -- First, attempt to grab the name of the class from the instance.            -- This step could fail if the instance is not headed by a class,@@ -799,41 +914,43 @@              -- See (1) above              L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty              -- See (2) above-             MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr+             MaybeT $ setSrcSpan (locA loc) $ lookupGlobalOccRn_maybe cls_rdr            -- Assuming the previous step succeeded, process any associated data            -- family instances. If the previous step failed, bail out.            case mb_cls_nm of              Nothing -> pure ([], [])              Just cls_nm -> do                (avails, fldss)-                 <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts+                 <- mapAndUnzipM (new_loc_di dup_fields_ok has_sel (Just cls_nm)) adts                pure (avails, concat fldss) -    new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs+    new_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> DataFamInstDecl GhcPs                    -> RnM (AvailInfo, [(Name, [FieldLabel])])-    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =-                                     HsIB { hsib_body = ti_decl }})+    new_di dup_fields_ok has_sel mb_cls dfid@(DataFamInstDecl { dfid_eqn = ti_decl })         = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)              ; let (bndrs, flds) = hsDataFamInstBinders dfid-             ; sub_names <- mapM newTopSrcBinder bndrs-             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds-             ; let avail    = AvailTC (unLoc main_name) sub_names flds'+             ; sub_names <- mapM (newTopSrcBinder .l2n) bndrs+             ; flds' <- mapM (newRecordSelector dup_fields_ok has_sel sub_names) flds+             ; let avail    = availTC (unLoc main_name) sub_names flds'                                   -- main_name is not bound here!                    fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'              ; return (avail, fld_env) } -    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs+    new_loc_di :: DuplicateRecordFields -> FieldSelectors -> Maybe Name -> LDataFamInstDecl GhcPs                    -> RnM (AvailInfo, [(Name, [FieldLabel])])-    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d+    new_loc_di dup_fields_ok has_sel mb_cls (L _ d) = new_di dup_fields_ok has_sel mb_cls d -newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel-newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"-newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))-  = do { selName <- newTopSrcBinder $ L loc $ field-       ; return $ qualFieldLbl { flSelector = selName } }+newRecordSelector :: DuplicateRecordFields -> FieldSelectors -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel+newRecordSelector _ _ [] _ = error "newRecordSelector: datatype has no constructors!"+newRecordSelector dup_fields_ok has_sel (dc:_) (L loc (FieldOcc _ (L _ fld)))+  = do { selName <- newTopSrcBinder $ L (noAnnSrcSpan loc) $ field+       ; return $ FieldLabel { flLabel = fieldLabelString+                             , flHasDuplicateRecordFields = dup_fields_ok+                             , flHasFieldSelector = has_sel+                             , flSelector = selName } }   where-    fieldOccName = occNameFS $ rdrNameOcc fld-    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok+    fieldLabelString = occNameFS $ rdrNameOcc fld+    selOccName = fieldSelectorOccName fieldLabelString (nameOccName dc) dup_fields_ok has_sel     field | isExact fld = fld               -- use an Exact RdrName as is to preserve the bindings               -- of an already renamer-resolved field and its use@@ -841,7 +958,7 @@               -- selectors in Template Haskell. See Note [Binders in               -- Template Haskell] in "GHC.ThToHs" and Note [Looking up               -- Exact RdrNames] in "GHC.Rename.Env".-          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)+          | otherwise   = mkRdrUnqual selOccName  {- Note [Looking up family names in family instances]@@ -874,9 +991,12 @@ Note [Dealing with imports] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ For import M( ies ), we take the mi_exports of M, and make-   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)-One entry for each Name that M exports; the AvailInfo is the-AvailInfo exported from M that exports that Name.+   imp_occ_env :: OccEnv (NameEnv (GreName, AvailInfo, Maybe Name))+One entry for each OccName that M exports, mapping each corresponding Name to+its GreName, the AvailInfo exported from M that exports that Name, and+optionally a Name for an associated type's parent class. (Typically there will+be a single Name in the NameEnv, but see Note [Importing DuplicateRecordFields]+for why we may need more than one.)  The situation is made more complicated by associated types. E.g.    module M where@@ -888,7 +1008,7 @@ Notice that T appears *twice*, once as a child and once as a parent. From this list we construct a raw list including    T -> (T, T( T1, T2, T3 ), Nothing)-   T -> (C, C( C, T ),       Nothing)+   T -> (T, C( C, T ),       Nothing) and we combine these (in function 'combine' in 'imp_occ_env' in 'filterImports') to get    T  -> (T,  T(T,T1,T2,T3), Just C)@@ -904,13 +1024,64 @@  Note that the imp_occ_env will have entries for data constructors too, although we never look up data constructors.++Note [Importing PatternSynonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Dealing with imports], associated types can lead to the+same Name appearing twice, both as a child and once as a parent, when+constructing the imp_occ_env.  The same thing can happen with pattern synonyms+if they are exported bundled with a type.++A simplified example, based on #11959:++  {-# LANGUAGE PatternSynonyms #-}+  module M (T(P), pattern P) where  -- Duplicate export warning, but allowed+    data T = MkT+    pattern P = MkT++Here we have T(P) and P in export_avails, and construct both+  P -> (P, P, Nothing)+  P -> (P, T(P), Nothing)+which are 'combine'd to leave+  P -> (P, T(P), Nothing)+i.e. we simply discard the non-bundled Avail.++Note [Importing DuplicateRecordFields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In filterImports, another complicating factor is DuplicateRecordFields.+Suppose we have:++  {-# LANGUAGE DuplicateRecordFields #-}+  module M (S(foo), T(foo)) where+    data S = MkS { foo :: Int }+    data T = mkT { foo :: Int }++  module N where+    import M (foo)    -- this is an ambiguity error (A)+    import M (S(foo)) -- this is allowed (B)++Here M exports the OccName 'foo' twice, so we get an imp_occ_env where 'foo'+maps to a NameEnv containing an entry for each of the two mangled field selector+names (see Note [FieldLabel] in GHC.Types.FieldLabel).++  foo -> [ $sel:foo:MkS -> (foo, S(foo), Nothing)+         , $sel:foo:MKT -> (foo, T(foo), Nothing)+         ]++Then when we look up 'foo' in lookup_name for case (A) we get both entries and+hence report an ambiguity error.  Whereas in case (B) we reach the lookup_ie+case for IEThingWith, which looks up 'S' and then finds the unique 'foo' amongst+its children.++See T16745 for a test of this.+ -}  filterImports     :: ModIface     -> ImpDeclSpec                     -- The span for the entire import decl-    -> Maybe (Bool, Located [LIE GhcPs])    -- Import spec; True => hiding-    -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names+    -> Maybe (Bool, LocatedL [LIE GhcPs])    -- Import spec; True => hiding+    -> RnM (Maybe (Bool, LocatedL [LIE GhcRn]), -- Import spec w/ Names             [GlobalRdrElt])                   -- Same again, but in GRE form filterImports iface decl_spec Nothing   = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))@@ -940,37 +1111,53 @@     all_avails = mi_exports iface          -- See Note [Dealing with imports]-    imp_occ_env :: OccEnv (Name,    -- the name-                           AvailInfo,   -- the export item providing the name-                           Maybe Name)  -- the parent of associated types-    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))+    imp_occ_env :: OccEnv (NameEnv (GreName,    -- the name or field+                           AvailInfo,   -- the export item providing it+                           Maybe Name))   -- the parent of associated types+    imp_occ_env = mkOccEnv_C (plusNameEnv_C combine)+                             [ (occName c, mkNameEnv [(greNameMangledName c, (c, a, Nothing))])                                      | a <- all_avails-                                     , (n, occ) <- availNamesWithOccs a]-      where-        -- See Note [Dealing with imports]-        -- 'combine' is only called for associated data types which appear-        -- twice in the all_avails. In the example, we combine-        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)-        -- NB: the AvailTC can have fields as well as data constructors (#12127)-        combine (name1, a1@(AvailTC p1 _ _), mp1)-                (name2, a2@(AvailTC p2 _ _), mp2)-          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2-                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )-            if p1 == name1 then (name1, a1, Just p2)-                           else (name1, a2, Just p1)-        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)+                                     , c <- availGreNames a]+    -- See Note [Dealing with imports]+    -- 'combine' may be called for associated data types which appear+    -- twice in the all_avails. In the example, we combine+    --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)+    -- NB: the AvailTC can have fields as well as data constructors (#12127)+    combine :: (GreName, AvailInfo, Maybe Name)+            -> (GreName, AvailInfo, Maybe Name)+            -> (GreName, AvailInfo, Maybe Name)+    combine (NormalGreName name1, a1@(AvailTC p1 _), mb1)+            (NormalGreName name2, a2@(AvailTC p2 _), mb2)+      = ASSERT2( name1 == name2 && isNothing mb1 && isNothing mb2+               , ppr name1 <+> ppr name2 <+> ppr mb1 <+> ppr mb2 )+        if p1 == name1 then (NormalGreName name1, a1, Just p2)+                       else (NormalGreName name1, a2, Just p1)+    -- 'combine' may also be called for pattern synonyms which appear both+    -- unassociated and associated (see Note [Importing PatternSynonyms]).+    combine (c1, a1, mb1) (c2, a2, mb2)+      = ASSERT2( c1 == c2 && isNothing mb1 && isNothing mb2+                          && (isAvailTC a1 || isAvailTC a2)+               , ppr c1 <+> ppr c2 <+> ppr a1 <+> ppr a2 <+> ppr mb1 <+> ppr mb2 )+        if isAvailTC a1 then (c1, a1, Nothing)+                        else (c1, a2, Nothing) +    isAvailTC AvailTC{} = True+    isAvailTC _ = False+     lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)     lookup_name ie rdr        | isQual rdr              = failLookupWith (QualImportError rdr)-       | Just succ <- mb_success = return succ+       | Just succ <- mb_success = case nameEnvElts succ of+                                     -- See Note [Importing DuplicateRecordFields]+                                     [(c,a,x)] -> return (greNameMangledName c, a, x)+                                     xs -> failLookupWith (AmbiguousImport rdr (map sndOf3 xs))        | otherwise               = failLookupWith (BadImport ie)       where         mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)      lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]     lookup_lie (L loc ieRdr)-        = do (stuff, warns) <- setSrcSpan loc $+        = do (stuff, warns) <- setSrcSpanA loc $                                liftM (fromMaybe ([],[])) $                                run_lookup (lookup_ie ieRdr)              mapM_ emit_warning warns@@ -993,6 +1180,7 @@               BadImport ie  -> badImportItemErr iface decl_spec ie all_avails               IllegalImport -> illegalImportItemErr               QualImportError rdr -> qualImportItemErr rdr+              AmbiguousImport rdr xs -> ambiguousImportItemErr rdr xs          -- For each import item, we convert its RdrNames to Names,         -- and at the same time construct an AvailInfo corresponding@@ -1006,7 +1194,7 @@         -- different parents).  See Note [Dealing with imports]     lookup_ie :: IE GhcPs               -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])-    lookup_ie ie = handle_bad_import $ do+    lookup_ie ie = handle_bad_import $       case ie of         IEVar _ (L l n) -> do             (name, avail, _) <- lookup_name ie $ ieWrappedName n@@ -1019,8 +1207,8 @@                           Avail {}                     -- e.g. f(..)                             -> [DodgyImport $ ieWrappedName tc] -                          AvailTC _ subs fs-                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym+                          AvailTC _ subs+                            | null (drop 1 subs) -- e.g. T(..) where T is a synonym                             -> [DodgyImport $ ieWrappedName tc]                              | not (is_qual decl_spec)  -- e.g. import M( T(..) )@@ -1029,14 +1217,14 @@                             | otherwise                             -> [] -                renamed_ie = IEThingAll noExtField (L l (replaceWrappedName tc name))+                renamed_ie = IEThingAll noAnn (L l (replaceWrappedName tc name))                 sub_avails = case avail of-                               Avail {}              -> []-                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]+                               Avail {}           -> []+                               AvailTC name2 subs -> [(renamed_ie, AvailTC name2 (subs \\ [NormalGreName name]))]             case mb_parent of               Nothing     -> return ([(renamed_ie, avail)], warns)                              -- non-associated ty/cls-              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)+              Just parent -> return ((renamed_ie, AvailTC parent [NormalGreName name]) : sub_avails, warns)                              -- associated type          IEThingAbs _ (L l tc')@@ -1055,25 +1243,16 @@                   return ([mkIEThingAbs tc' l nameAvail]                          , []) -        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->-          ASSERT2(null rdr_fs, ppr rdr_fs) do+        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns -> do            (name, avail, mb_parent)-               <- lookup_name (IEThingAbs noExtField ltc) (ieWrappedName rdr_tc)--           let (ns,subflds) = case avail of-                                AvailTC _ ns' subflds' -> (ns',subflds')-                                Avail _                -> panic "filterImports"+               <- lookup_name (IEThingAbs noAnn ltc) (ieWrappedName rdr_tc)             -- Look up the children in the sub-names of the parent-           let subnames = case ns of   -- The tc is first in ns,-                            [] -> []   -- if it is there at all-                                       -- See the AvailTC Invariant in-                                       -- GHC.Types.Avail-                            (n1:ns1) | n1 == name -> ns1-                                     | otherwise  -> ns-           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of+           -- See Note [Importing DuplicateRecordFields]+           let subnames = availSubordinateGreNames avail+           case lookupChildren subnames rdr_ns of -             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))+             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs))                                 -- We are trying to import T( a,b,c,d ), and failed                                 -- to find 'b' and 'd'.  So we make up an import item                                 -- to report as failing, namely T( b, d ).@@ -1083,21 +1262,18 @@                case mb_parent of                  -- non-associated ty/cls                  Nothing-                   -> return ([(IEThingWith noExtField (L l name') wc childnames'-                                                                 childflds,-                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],+                   -> return ([(IEThingWith childflds (L l name') wc childnames',+                               availTC name (name:map unLoc childnames) (map unLoc childflds))],                               [])                    where name' = replaceWrappedName rdr_tc name                          childnames' = map to_ie_post_rn childnames                          -- childnames' = postrn_ies childnames                  -- associated ty                  Just parent-                   -> return ([(IEThingWith noExtField (L l name') wc childnames'-                                                           childflds,-                                AvailTC name (map unLoc childnames) (map unLoc childflds)),-                               (IEThingWith noExtField (L l name') wc childnames'-                                                           childflds,-                                AvailTC parent [name] [])],+                   -> return ([(IEThingWith childflds (L l name') wc childnames',+                                availTC name (map unLoc childnames) (map unLoc childflds)),+                               (IEThingWith childflds (L l name') wc childnames',+                                availTC parent [name] [])],                               [])                    where name' = replaceWrappedName rdr_tc name                          childnames' = map to_ie_post_rn childnames@@ -1108,10 +1284,10 @@        where         mkIEThingAbs tc l (n, av, Nothing    )-          = (IEThingAbs noExtField (L l (replaceWrappedName tc n)), trimAvail av n)+          = (IEThingAbs noAnn (L l (replaceWrappedName tc n)), trimAvail av n)         mkIEThingAbs tc l (n, _,  Just parent)-          = (IEThingAbs noExtField (L l (replaceWrappedName tc n))-             , AvailTC parent [n] [])+          = (IEThingAbs noAnn (L l (replaceWrappedName tc n))+             , availTC parent [n] [])          handle_bad_import m = catchIELookup m $ \err -> case err of           BadImport ie | want_hiding -> return ([], [BadImportW ie])@@ -1129,6 +1305,7 @@   = QualImportError RdrName   | BadImport (IE GhcPs)   | IllegalImport+  | AmbiguousImport RdrName [AvailInfo] -- e.g. a duplicated field name as a top-level import  failLookupWith :: IELookupError -> IELookupM a failLookupWith err = Failed err@@ -1160,7 +1337,8 @@     prov_fn name       = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })       where-        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }+        item_spec = ImpSome { is_explicit = is_explicit name+                            , is_iloc = locA loc }   {-@@ -1183,16 +1361,15 @@ mkChildEnv gres = foldr add emptyNameEnv gres   where     add gre env = case gre_par gre of-        FldParent p _  -> extendNameEnv_Acc (:) Utils.singleton env p gre-        ParentIs  p    -> extendNameEnv_Acc (:) Utils.singleton env p gre-        NoParent       -> env+        ParentIs  p -> extendNameEnv_Acc (:) Utils.singleton env p gre+        NoParent    -> env  findChildren :: NameEnv [a] -> Name -> [a] findChildren env n = lookupNameEnv env n `orElse` [] -lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]+lookupChildren :: [GreName] -> [LIEWrappedName RdrName]                -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed-                           ([Located Name], [Located FieldLabel])+                           ([LocatedA Name], [Located FieldLabel]) -- (lookupChildren all_kids rdr_items) maps each rdr_item to its -- corresponding Name all_kids, if the former exists -- The matching is done by FastString, not OccName, so that@@ -1204,24 +1381,24 @@   | null fails   = Succeeded (fmap concat (partitionEithers oks))        -- This 'fmap concat' trickily applies concat to the /second/ component-       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])+       -- of the pair, whose type is ([LocatedA Name], [[Located FieldLabel]])   | otherwise   = Failed fails   where     mb_xs = map doOne rdr_items     fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]     oks   = [ ok      | Succeeded ok   <- mb_xs ]-    oks :: [Either (Located Name) [Located FieldLabel]]+    oks :: [Either (LocatedA Name) [Located FieldLabel]]      doOne item@(L l r)        = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of-           Just [Left n]            -> Succeeded (Left (L l n))-           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))-           _                        -> Failed    item+           Just [NormalGreName n]                             -> Succeeded (Left (L l n))+           Just rs | Just fs <- traverse greNameFieldLabel rs -> Succeeded (Right (map (L (locA l)) fs))+           _                                                  -> Failed    item      -- See Note [Children for duplicate record fields]     kid_env = extendFsEnvList_C (++) emptyFsEnv-              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]+              [(occNameFS (occName x), [x]) | x <- all_kids]   @@ -1241,7 +1418,8 @@         ; traceRn "RUN" (ppr (tcg_dus gbl_env))         ; warnUnusedImportDecls gbl_env hsc_src         ; warnUnusedTopBinds $ unused_locals keep-        ; warnMissingSignatures gbl_env }+        ; warnMissingSignatures gbl_env+        ; warnMissingKindSignatures gbl_env }   where     used_names :: NameSet -> NameSet     used_names keep = findUses (tcg_dus gbl_env) emptyNameSet `unionNameSet` keep@@ -1256,11 +1434,13 @@     -- This is done in mkExports too; duplicated work      gre_is_used :: NameSet -> GlobalRdrElt -> Bool-    gre_is_used used_names (GRE {gre_name = name})+    gre_is_used used_names gre0         = name `elemNameSet` used_names-          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)+          || any (\ gre -> greMangledName gre `elemNameSet` used_names) (findChildren kids_env name)                 -- A use of C implies a use of T,                 -- if C was brought into scope by T(..) or T(C)+      where+        name = greMangledName gre0      -- Filter out the ones that are     --  (a) defined in this module, and@@ -1277,7 +1457,7 @@        in filter is_unused_local defined_but_not_used     is_unused_local :: GlobalRdrElt -> Bool-    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)+    is_unused_local gre = isLocalGRE gre && isExternalName (greMangledName gre)  {- ********************************************************************* *                                                                      *@@ -1293,7 +1473,7 @@   = do { let exports = availsToNameSet (tcg_exports gbl_env)              sig_ns  = tcg_sigs gbl_env                -- We use sig_ns to exclude top-level bindings that are generated by GHC-             binds    = collectHsBindsBinders $ tcg_binds gbl_env+             binds    = collectHsBindsBinders CollNoDictBinders $ tcg_binds gbl_env              pat_syns = tcg_patsyns gbl_env           -- Warn about missing signatures@@ -1303,16 +1483,16 @@        ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures         ; let add_sig_warns-               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures                | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures                | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures                | otherwise          = return ()               add_warns flag-                = when warn_pat_syns-                       (mapM_ add_pat_syn_warn pat_syns) >>-                  when (warn_missing_sigs || warn_only_exported)-                       (mapM_ add_bind_warn binds)+                = when (warn_missing_sigs || warn_only_exported)+                       (mapM_ add_bind_warn binds) >>+                  when (warn_missing_sigs || warn_pat_syns)+                       (mapM_ add_pat_syn_warn pat_syns)                 where                   add_pat_syn_warn p                     = add_warn name $@@ -1337,11 +1517,35 @@                            (addWarnAt (Reason flag) (getSrcSpan name) msg)                    export_check name-                    = not warn_only_exported || name `elemNameSet` exports+                    = warn_missing_sigs || not warn_only_exported || name `elemNameSet` exports         ; add_sig_warns } +-- | Warn the user about tycons that lack kind signatures.+-- Called /after/ type (and kind) inference, so that we can report the+-- inferred kinds.+warnMissingKindSignatures :: TcGblEnv -> RnM ()+warnMissingKindSignatures gbl_env+  = do { warn_missing_kind_sigs  <- woptM Opt_WarnMissingKindSignatures+       ; cusks_enabled <- xoptM LangExt.CUSKs+       ; when (warn_missing_kind_sigs) (mapM_ (add_ty_warn cusks_enabled) tcs)+       }+  where+    tcs = tcg_tcs gbl_env+    ksig_ns = tcg_ksigs gbl_env +    add_ty_warn :: Bool -> TyCon -> IOEnv (Env TcGblEnv TcLclEnv) ()+    add_ty_warn cusks_enabled tyCon = when (name `elemNameSet` ksig_ns) $+        addWarnAt (Reason Opt_WarnMissingKindSignatures) (getSrcSpan name) $+            hang msg 2 (text "type" <+> pprPrefixName name <+> dcolon <+> ki_msg)+      where+        msg | cusks_enabled = text "Top-level type constructor with no standalone kind signature or CUSK:"+            | otherwise     = text "Top-level type constructor with no standalone kind signature:"+        name = tyConName tyCon+        ki = tyConKind tyCon+        ki_msg :: SDoc+        ki_msg = pprKind ki+ {- ********************************************************* *                                                       *@@ -1396,14 +1600,15 @@     import_usage :: ImportMap     import_usage = mkImportMap used_gres +    unused_decl :: LImportDecl GhcRn -> (LImportDecl GhcRn, [GlobalRdrElt], [Name])     unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))       = (decl, used_gres, nameSetElemsStable unused_imps)       where-        used_gres = lookupSrcLoc (srcSpanEnd loc) import_usage+        used_gres = lookupSrcLoc (srcSpanEnd $ locA loc) import_usage                                -- srcSpanEnd: see Note [The ImportMap]                     `orElse` [] -        used_names   = mkNameSet (map      gre_name        used_gres)+        used_names   = mkNameSet (map      greMangledName        used_gres)         used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)          unused_imps   -- Not trivial; see eg #7454@@ -1416,7 +1621,7 @@         add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc         add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc         add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc-        add_unused (IEThingWith _ p wc ns fs) acc =+        add_unused (IEThingWith fs p wc ns) acc =           add_wc_all (add_unused_with pn xs acc)           where pn = lieWrappedName p                 xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs@@ -1482,7 +1687,7 @@           best_imp_spec = bestImport imp_specs           add _ gres = gre : gres -warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)+warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Parent)                  -> ImportDeclUsage -> RnM () warnUnusedImport flag fld_env (L loc decl, used, unused) @@ -1498,7 +1703,7 @@    -- Nothing used; drop entire declaration   | null used-  = addWarnAt (Reason flag) loc msg1+  = addWarnAt (Reason flag) (locA loc) msg1    -- Everything imported is used; nop   | null unused@@ -1509,11 +1714,11 @@   | Just (_, L _ imports) <- ideclHiding decl   , length unused == 1   , Just (L loc _) <- find (\(L _ ie) -> ((ieName ie) :: Name) `elem` unused) imports-  = addWarnAt (Reason flag) loc msg2+  = addWarnAt (Reason flag) (locA loc) msg2    -- Some imports are unused   | otherwise-  = addWarnAt (Reason flag) loc msg2+  = addWarnAt (Reason flag) (locA loc)  msg2    where     msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant@@ -1534,8 +1739,9 @@     -- to improve the consistent for ambiguous/unambiguous identifiers.     -- See trac#14881.     ppr_possible_field n = case lookupNameEnv fld_env n of-                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)-                               Nothing  -> pprNameUnqualified n+                               Just (fld, ParentIs p) -> pprNameUnqualified p <> parens (ppr fld)+                               Just (fld, NoParent)   -> ppr fld+                               Nothing                -> pprNameUnqualified n      -- Print unused names in a deterministic (lexicographic) order     sort_unused :: SDoc@@ -1566,7 +1772,7 @@ -}  getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]-getMinimalImports = mapM mk_minimal+getMinimalImports = fmap combine . mapM mk_minimal   where     mk_minimal (L l decl, used_gres, unused)       | null unused@@ -1579,7 +1785,7 @@            ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)            ; let used_avails = gresToAvailInfo used_gres                  lies = map (L l) (concatMap (to_ie iface) used_avails)-           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }+           ; return (L l (decl { ideclHiding = Just (False, L (l2l l) lies) })) }       where         doc = text "Compute minimal imports for" <+> ppr decl @@ -1587,38 +1793,53 @@     -- The main trick here is that if we're importing all the constructors     -- we want to say "T(..)", but if we're importing only a subset we want     -- to say "T(A,B,C)".  So we have to find out what the module exports.-    to_ie _ (Avail n)-       = [IEVar noExtField (to_ie_post_rn $ noLoc n)]-    to_ie _ (AvailTC n [m] [])-       | n==m = [IEThingAbs noExtField (to_ie_post_rn $ noLoc n)]-    to_ie iface (AvailTC n ns fs)-      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface+    to_ie _ (Avail c)  -- Note [Overloaded field import]+       = [IEVar noExtField (to_ie_post_rn $ noLocA (greNamePrintableName c))]+    to_ie _ avail@(AvailTC n [_])  -- Exporting the main decl and nothing else+       | availExportsDecl avail = [IEThingAbs noAnn (to_ie_post_rn $ noLocA n)]+    to_ie iface (AvailTC n cs)+      = case [xs | avail@(AvailTC x xs) <- mi_exports iface                  , x == n-                 , x `elem` xs    -- Note [Partial export]+                 , availExportsDecl avail  -- Note [Partial export]                  ] of-           [xs] | all_used xs -> [IEThingAll noExtField (to_ie_post_rn $ noLoc n)]+           [xs] | all_used xs ->+                   [IEThingAll noAnn (to_ie_post_rn $ noLocA n)]                 | otherwise   ->-                   [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard-                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))-                                (map noLoc fs)]+                   [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard+                                (map (to_ie_post_rn . noLocA) (filter (/= n) ns))]                                           -- Note [Overloaded field import]            _other | all_non_overloaded fs-                           -> map (IEVar noExtField . to_ie_post_rn_var . noLoc) $ ns+                           -> map (IEVar noExtField . to_ie_post_rn_var . noLocA) $ ns                                  ++ map flSelector fs                   | otherwise ->-                      [IEThingWith noExtField (to_ie_post_rn $ noLoc n) NoIEWildcard-                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))-                                (map noLoc fs)]+                      [IEThingWith (map noLoc fs) (to_ie_post_rn $ noLocA n) NoIEWildcard+                                (map (to_ie_post_rn . noLocA) (filter (/= n) ns))]         where--          fld_lbls = map flLabel fs+          (ns, fs) = partitionGreNames cs -          all_used (avail_occs, avail_flds)-              = all (`elem` ns) avail_occs-                    && all (`elem` fld_lbls) (map flLabel avail_flds)+          all_used avail_cs = all (`elem` cs) avail_cs            all_non_overloaded = all (not . flIsOverloaded) +    combine :: [LImportDecl GhcRn] -> [LImportDecl GhcRn]+    combine = map merge . groupBy ((==) `on` getKey) . sortOn getKey++    getKey :: LImportDecl GhcRn -> (Bool, Maybe ModuleName, ModuleName)+    getKey decl =+      ( isImportDeclQualified . ideclQualified $ idecl -- is this qualified? (important that this be first)+      , unLoc <$> ideclAs idecl -- what is the qualifier (inside Maybe monad)+      , unLoc . ideclName $ idecl -- Module Name+      )+      where+        idecl :: ImportDecl GhcRn+        idecl = unLoc decl++    merge :: [LImportDecl GhcRn] -> LImportDecl GhcRn+    merge []                     = error "getMinimalImports: unexpected empty list"+    merge decls@((L l decl) : _) = L l (decl { ideclHiding = Just (False, L (noAnnSrcSpan (locA l)) lies) })+      where lies = concatMap (unLoc . snd) $ mapMaybe (ideclHiding . unLoc) decls++ printMinimalImports :: HscSource -> [ImportDeclUsage] -> RnM () -- See Note [Printing minimal imports] printMinimalImports hsc_src imports_w_usage@@ -1645,16 +1866,16 @@         basefn = moduleNameString (moduleName this_mod) ++ suffix  -to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn_var :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn_var (L l n)-  | isDataOcc $ occName n = L l (IEPattern (L l n))-  | otherwise             = L l (IEName    (L l n))+  | isDataOcc $ occName n = L l (IEPattern (EpaSpan $ la2r l) (L (la2na l) n))+  | otherwise             = L l (IEName                       (L (la2na l) n))  -to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn :: (HasOccName name) => LocatedA name -> LIEWrappedName name to_ie_post_rn (L l n)-  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))-  | otherwise                   = L l (IEName (L l n))+  | isTcOcc occ && isSymOcc occ = L l (IEType (EpaSpan $ la2r l) (L (la2na l) n))+  | otherwise                   = L l (IEName                    (L (la2na l) n))   where occ = occName n  {-@@ -1675,7 +1896,7 @@ not    import A( C( op ) ) which we would usually generate if C was exported from B.  Hence-the (x `elem` xs) test when deciding what to generate.+the availExportsDecl test when deciding what to generate.   Note [Overloaded field import]@@ -1695,7 +1916,24 @@ because when DuplicateRecordFields is enabled, field selectors are not in scope without their enclosing datatype. +On the third hand, if we have +    {-# LANGUAGE DuplicateRecordFields #-}+    module A where+      pattern MkT { foo } = Just foo++    module B where+      import A+      f = ...foo...++then the minimal import for module B must be+    import A ( foo )+because foo doesn't have a parent.  This might actually be ambiguous if A+exports another field called foo, but there is no good answer to return and this+is a very obscure corner, so it seems to be the best we can do.  See+DRFPatSynExport for a test of this.++ ************************************************************************ *                                                                      * \subsection{Errors}@@ -1708,6 +1946,14 @@   = hang (text "Illegal qualified name in import item:")        2 (ppr rdr) +ambiguousImportItemErr :: RdrName -> [AvailInfo] -> SDoc+ambiguousImportItemErr rdr avails+  = hang (text "Ambiguous name" <+> quotes (ppr rdr) <+> text "in import item. It could refer to:")+       2 (vcat (map ppr_avail avails))+  where+    ppr_avail (AvailTC parent _) = ppr parent <> parens (ppr rdr)+    ppr_avail (Avail name)       = ppr name+ pprImpDeclSpec :: ModIface -> ImpDeclSpec -> SDoc pprImpDeclSpec iface decl_spec =   quotes (ppr (is_mod decl_spec)) <+> case mi_boot iface of@@ -1749,13 +1995,12 @@       Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie       Nothing  -> badImportItemErrStd iface decl_spec ie   where-    checkIfDataCon (AvailTC _ ns _) =-      case find (\n -> importedFS == nameOccNameFS n) ns of-        Just n  -> isDataConName n+    checkIfDataCon (AvailTC _ ns) =+      case find (\n -> importedFS == occNameFS (occName n)) ns of+        Just n  -> isDataConName (greNameMangledName n)         Nothing -> False     checkIfDataCon _ = False-    availOccName = nameOccName . availName-    nameOccNameFS = occNameFS . nameOccName+    availOccName = occName . availGreName     importedFS = occNameFS . rdrNameOcc $ ieName ie  illegalImportItemErr :: SDoc@@ -1775,10 +2020,10 @@           text "but it has none" ]  dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)-dodgyMsgInsert tc = IEThingAll noExtField ii+dodgyMsgInsert tc = IEThingAll noAnn ii   where     ii :: LIEWrappedName (IdP (GhcPass p))-    ii = noLoc (IEName $ noLoc tc)+    ii = noLocA (IEName $ noLocA tc)   addDupDeclErr :: [GlobalRdrElt] -> TcRn ()@@ -1796,7 +2041,7 @@   where     sorted_names =       sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)-             (map gre_name gres)+             (map greMangledName gres)

GHC/Rename/Pat.hs view

@@ -1,3 +1,15 @@+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ViewPatterns        #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -9,18 +21,6 @@ general, all of these functions return a renamed thing, and a set of free variables. -}--{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DeriveFunctor #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Rename.Pat (-- main entry points               rnPat, rnPats, rnBindPat, rnPatAndThen, @@ -33,13 +33,13 @@               rnHsRecUpdFields,                -- CpsRn monad-              CpsRn, liftCps,+              CpsRn, liftCps, liftCpsWithCont,                -- Literals               rnLit, rnOverLit, -             -- Pattern Error messages that are also used elsewhere-             checkTupSize, patSigErr+             -- Pattern Error message that is also used elsewhere+             patSigErr              ) where  -- ENH: thin imports to only what is necessary for patterns@@ -59,26 +59,31 @@ import GHC.Rename.Utils    ( HsDocContext(..), newLocalBndrRn, bindLocalNames                            , warnUnusedMatches, newLocalBndrRn                            , checkUnusedRecordWildcard-                           , checkDupNames, checkDupAndShadowedNames-                           , checkTupSize , unknownSubordinateErr )+                           , checkDupNames, checkDupAndShadowedNames ) import GHC.Rename.HsType import GHC.Builtin.Names+import GHC.Types.Avail ( greNameMangledName ) import GHC.Types.Name import GHC.Types.Name.Set import GHC.Types.Name.Reader import GHC.Types.Basic+import GHC.Types.SourceText import GHC.Utils.Misc import GHC.Data.List.SetOps( removeDups ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.Literal   ( inCharRange ) import GHC.Builtin.Types   ( nilDataCon ) import GHC.Core.DataCon+import GHC.Driver.Session ( getDynFlags, xopt_DuplicateRecordFields ) import qualified GHC.LanguageExtensions as LangExt -import Control.Monad       ( when, ap, guard )+import Control.Monad       ( when, ap, guard, forM, unless ) import qualified Data.List.NonEmpty as NE+import Data.Maybe import Data.Ratio+import GHC.Types.FieldLabel (DuplicateRecordFields(..))  {- *********************************************************@@ -132,14 +137,17 @@                                      ; (r,fvs2) <- k v                                      ; return (r, fvs1 `plusFV` fvs2) }) -wrapSrcSpanCps :: (a -> CpsRn b) -> Located a -> CpsRn (Located b)+liftCpsWithCont :: (forall r. (b -> RnM (r, FreeVars)) -> RnM (r, FreeVars)) -> CpsRn b+liftCpsWithCont = CpsRn++wrapSrcSpanCps :: (a -> CpsRn b) -> LocatedA a -> CpsRn (LocatedA b) -- Set the location, and also wrap it around the value returned wrapSrcSpanCps fn (L loc a)-  = CpsRn (\k -> setSrcSpan loc $+  = CpsRn (\k -> setSrcSpanA loc $                  unCpsRn (fn a) $ \v ->                  k (L loc v)) -lookupConCps :: Located RdrName -> CpsRn (Located Name)+lookupConCps :: LocatedN RdrName -> CpsRn (LocatedN Name) lookupConCps con_rdr   = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr                     ; (r, fvs) <- k con_name@@ -160,8 +168,8 @@   g _ = T1  Arguably we should report T2 as unused, even though it appears in a-pattern, because it never occurs in a constructed position.  See-#7336.+pattern, because it never occurs in a constructed position.+See #7336. However, implementing this in the face of pattern synonyms would be less straightforward, since given two pattern synonyms @@ -218,12 +226,12 @@                       ThPatQuote            -> False                       _                     -> True -newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)+newPatLName :: NameMaker -> LocatedN RdrName -> CpsRn (LocatedN Name) newPatLName name_maker rdr_name@(L loc _)   = do { name <- newPatName name_maker rdr_name        ; return (L loc name) } -newPatName :: NameMaker -> Located RdrName -> CpsRn Name+newPatName :: NameMaker -> LocatedN RdrName -> CpsRn Name newPatName (LamMk report_unused) rdr_name   = CpsRn (\ thing_inside ->         do { name <- newLocalBndrRn rdr_name@@ -236,19 +244,30 @@         do { name <- case is_top of                        NotTopLevel -> newLocalBndrRn rdr_name                        TopLevel    -> newTopSrcBinder rdr_name-           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here-                                        -- See Note [View pattern usage]+           ; bindLocalNames [name] $+                 -- Do *not* use bindLocalNameFV here;+                 --   see Note [View pattern usage]+                 -- For the TopLevel case+                 --   see Note [bindLocalNames for an External name]              addLocalFixities fix_env [name] $              thing_inside name }) -    -- Note: the bindLocalNames is somewhat suspicious-    --       because it binds a top-level name as a local name.-    --       however, this binding seems to work, and it only exists for-    --       the duration of the patterns and the continuation;-    --       then the top-level name is added to the global env-    --       before going on to the RHSes (see GHC.Rename.Module).+{- Note [bindLocalNames for an External name]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the TopLevel case, the use of bindLocalNames here is somewhat+suspicious because it binds a top-level External name in the+LocalRdrEnv.  c.f. Note [LocalRdrEnv] in GHC.Types.Name.Reader. -{-+However, this only happens when renaming the LHS (only) of a top-level+pattern binding.  Even though this only the LHS, we need to bring the+binder into scope in the pattern itself in case the binder is used in+subsequent view patterns.  A bit bizarre, something like+  (x, Just y <- f x) = e++Anyway, bindLocalNames does work, and the binding only exists for the+duration of the pattern; then the top-level name is added to the+global env before going on to the RHSes (see GHC.Rename.Module).+ Note [View pattern usage] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -325,7 +344,7 @@           --    complain *twice* about duplicates e.g. f (x,x) = ...           --           -- See note [Don't report shadowing for pattern synonyms]-        ; let bndrs = collectPatsBinders pats'+        ; let bndrs = collectPatsBinders CollNoDictBinders pats'         ; addErrCtxt doc_pat $           if isPatSynCtxt ctxt              then checkDupNames bndrs@@ -342,7 +361,7 @@ rnPat ctxt pat thing_inside   = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat') -applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)+applyNameMaker :: NameMaker -> LocatedN RdrName -> RnM (LocatedN Name) applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)                            ; return n } @@ -386,18 +405,18 @@ rnPatAndThen _  (WildPat _)   = return (WildPat noExtField) rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat                                      ; return (ParPat x pat') }-rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat-                                     ; return (LazyPat x pat') }-rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat-                                     ; return (BangPat x pat') }+rnPatAndThen mk (LazyPat _ pat) = do { pat' <- rnLPatAndThen mk pat+                                     ; return (LazyPat noExtField pat') }+rnPatAndThen mk (BangPat _ pat) = do { pat' <- rnLPatAndThen mk pat+                                     ; return (BangPat noExtField pat') } rnPatAndThen mk (VarPat x (L l rdr))     = do { loc <- liftCps getSrcSpanM-         ; name <- newPatName mk (L loc rdr)+         ; name <- newPatName mk (L (noAnnSrcSpan loc) rdr)          ; return (VarPat x (L l name)) }      -- we need to bind pattern variables for view pattern expressions      -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) -rnPatAndThen mk (SigPat x pat sig)+rnPatAndThen mk (SigPat _ pat sig)   -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is   -- important to rename its type signature _before_ renaming the rest of the   -- pattern, so that type variables are first bound by the _outermost_ pattern@@ -409,10 +428,10 @@   -- ~~~~~~~~~~~~~~~^                   the same `a' then used here   = do { sig' <- rnHsPatSigTypeAndThen sig        ; pat' <- rnLPatAndThen mk pat-       ; return (SigPat x pat' sig' ) }+       ; return (SigPat noExtField pat' sig' ) }   where     rnHsPatSigTypeAndThen :: HsPatSigType GhcPs -> CpsRn (HsPatSigType GhcRn)-    rnHsPatSigTypeAndThen sig = CpsRn (rnHsPatSigType AlwaysBind PatCtx sig)+    rnHsPatSigTypeAndThen sig = liftCpsWithCont (rnHsPatSigType AlwaysBind PatCtx sig)  rnPatAndThen mk (LitPat x lit)   | HsString src s <- lit@@ -420,7 +439,7 @@        ; if ovlStr          then rnPatAndThen mk                            (mkNPat (noLoc (mkHsIsString src s))-                                      Nothing)+                                      Nothing noAnn)          else normal_lit }   | otherwise = normal_lit   where@@ -440,24 +459,24 @@        ; eq' <- liftCpsFV $ lookupSyntax eqName        ; return (NPat x (L l lit') mb_neg' eq') } -rnPatAndThen mk (NPlusKPat x rdr (L l lit) _ _ _ )-  = do { new_name <- newPatName mk rdr+rnPatAndThen mk (NPlusKPat _ rdr (L l lit) _ _ _ )+  = do { new_name <- newPatName mk (l2n rdr)        ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]                                                 -- We skip negateName as                                                 -- negative zero doesn't make                                                 -- sense in n + k patterns        ; minus <- liftCpsFV $ lookupSyntax minusName        ; ge    <- liftCpsFV $ lookupSyntax geName-       ; return (NPlusKPat x (L (nameSrcSpan new_name) new_name)-                             (L l lit') lit' ge minus) }+       ; return (NPlusKPat noExtField (L (noAnnSrcSpan $ nameSrcSpan new_name) new_name)+                                      (L l lit') lit' ge minus) }                 -- The Report says that n+k patterns must be in Integral -rnPatAndThen mk (AsPat x rdr pat)+rnPatAndThen mk (AsPat _ rdr pat)   = do { new_name <- newPatLName mk rdr        ; pat' <- rnLPatAndThen mk pat-       ; return (AsPat x new_name pat') }+       ; return (AsPat noExtField new_name pat') } -rnPatAndThen mk p@(ViewPat x expr pat)+rnPatAndThen mk p@(ViewPat _ expr pat)   = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns                       ; checkErr vp_flag (badViewPat p) }          -- Because of the way we're arranging the recursive calls,@@ -466,14 +485,14 @@        ; pat' <- rnLPatAndThen mk pat        -- Note: at this point the PreTcType in ty can only be a placeHolder        -- ; return (ViewPat expr' pat' ty) }-       ; return (ViewPat x expr' pat') }+       ; return (ViewPat noExtField expr' pat') } -rnPatAndThen mk (ConPat NoExtField con args)+rnPatAndThen mk (ConPat _ con args)    -- rnConPatAndThen takes care of reconstructing the pattern    -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.   = case unLoc con == nameRdrName (dataConName nilDataCon) of       True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists-                    ; if ol_flag then rnPatAndThen mk (ListPat noExtField [])+                    ; if ol_flag then rnPatAndThen mk (ListPat noAnn [])                                  else rnConPatAndThen mk con args}       False   -> rnConPatAndThen mk con args @@ -485,14 +504,13 @@                      ; return (ListPat (Just to_list_name) pats')}           False -> return (ListPat Nothing pats') } -rnPatAndThen mk (TuplePat x pats boxed)-  = do { liftCps $ checkTupSize (length pats)-       ; pats' <- rnLPatsAndThen mk pats-       ; return (TuplePat x pats' boxed) }+rnPatAndThen mk (TuplePat _ pats boxed)+  = do { pats' <- rnLPatsAndThen mk pats+       ; return (TuplePat noExtField pats' boxed) } -rnPatAndThen mk (SumPat x pat alt arity)+rnPatAndThen mk (SumPat _ pat alt arity)   = do { pat <- rnLPatAndThen mk pat-       ; return (SumPat x pat alt arity)+       ; return (SumPat noExtField pat alt arity)        }  -- If a splice has been run already, just rename the result.@@ -507,19 +525,35 @@  -------------------- rnConPatAndThen :: NameMaker-                -> Located RdrName    -- the constructor+                -> LocatedN RdrName    -- the constructor                 -> HsConPatDetails GhcPs                 -> CpsRn (Pat GhcRn) -rnConPatAndThen mk con (PrefixCon pats)+rnConPatAndThen mk con (PrefixCon tyargs pats)   = do  { con' <- lookupConCps con+        ; liftCps check_lang_exts+        ; tyargs' <- forM tyargs $ \t ->+            liftCpsWithCont $ rnHsPatSigTypeBindingVars HsTypeCtx t         ; pats' <- rnLPatsAndThen mk pats         ; return $ ConPat             { pat_con_ext = noExtField             , pat_con = con'-            , pat_args = PrefixCon pats'+            , pat_args = PrefixCon tyargs' pats'             }         }+  where+    check_lang_exts :: RnM ()+    check_lang_exts = do+      scoped_tyvars <- xoptM LangExt.ScopedTypeVariables+      type_app      <- xoptM LangExt.TypeApplications+      unless (scoped_tyvars && type_app) $+        case listToMaybe tyargs of+          Nothing    -> pure ()+          Just tyarg -> addErr $+            hang (text "Illegal visible type application in a pattern:"+                    <+> quotes (char '@' <> ppr tyarg))+               2 (text "Both ScopedTypeVariables and TypeApplications are"+                    <+> text "required to use this feature")  rnConPatAndThen mk con (InfixCon pat1 pat2)   = do  { con' <- lookupConCps con@@ -546,7 +580,7 @@                     return (r, fvs) ) -------------------- rnHsRecPatsAndThen :: NameMaker-                   -> Located Name      -- Constructor+                   -> LocatedN Name      -- Constructor                    -> HsRecFields GhcPs (LPat GhcPs)                    -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) rnHsRecPatsAndThen mk (L _ con)@@ -557,7 +591,7 @@        ; check_unused_wildcard (implicit_binders flds' <$> dd)        ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }   where-    mkVarPat l n = VarPat noExtField (L l n)+    mkVarPat l n = VarPat noExtField (L (noAnnSrcSpan l) n)     rn_field (L l fld, n') =       do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)          ; return (L l (fld { hsRecFieldArg = arg' })) }@@ -565,7 +599,7 @@     loc = maybe noSrcSpan getLoc dd      -- Get the arguments of the implicit binders-    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats+    implicit_binders fs (unLoc -> n) = collectPatsBinders CollNoDictBinders implicit_pats       where         implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs) @@ -598,8 +632,8 @@        HsRecFieldContext     -> (SrcSpan -> RdrName -> arg)          -- When punning, use this to build a new field-    -> HsRecFields GhcPs (Located arg)-    -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars)+    -> HsRecFields GhcPs (LocatedA arg)+    -> RnM ([LHsRecField GhcRn (LocatedA arg)], FreeVars)  -- This surprisingly complicated pass --   a) looks up the field name (possibly using disambiguation)@@ -625,8 +659,8 @@                 HsRecFieldPat con  -> Just con                 _ {- update -}     -> Nothing -    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg)-           -> RnM (LHsRecField GhcRn (Located arg))+    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (LocatedA arg)+           -> RnM (LHsRecField GhcRn (LocatedA arg))     rn_fld pun_ok parent (L l                            (HsRecField                               { hsRecFieldLbl =@@ -638,11 +672,11 @@                      then do { checkErr pun_ok (badPun (L loc lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L loc (mk_arg loc arg_rdr)) }+                             ; return (L (noAnnSrcSpan loc) (mk_arg loc arg_rdr)) }                      else return arg            ; return (L l (HsRecField-                             { hsRecFieldLbl = (L loc (FieldOcc-                                                          sel (L ll lbl)))+                             { hsRecFieldAnn = noAnn+                             , hsRecFieldLbl = (L loc (FieldOcc sel (L ll lbl)))                              , hsRecFieldArg = arg'                              , hsRecPun      = pun })) } @@ -650,8 +684,8 @@     rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in GHC.Hs.Pat               -> Maybe Name -- The constructor (Nothing for an                                 --    out of scope constructor)-              -> [LHsRecField GhcRn (Located arg)] -- Explicit fields-              -> RnM ([LHsRecField GhcRn (Located arg)])   -- Field Labels we need to fill in+              -> [LHsRecField GhcRn (LocatedA arg)] -- Explicit fields+              -> RnM ([LHsRecField GhcRn (LocatedA arg)])   -- Field Labels we need to fill in     rn_dotdot (Just (L loc n)) (Just con) flds -- ".." on record construction / pat match       | not (isUnboundName con) -- This test is because if the constructor                                 -- isn't in scope the constructor lookup will add@@ -684,9 +718,12 @@                                     _other           -> True ]             ; addUsedGREs dot_dot_gres-           ; return [ L loc (HsRecField-                        { hsRecFieldLbl = L loc (FieldOcc sel (L loc arg_rdr))-                        , hsRecFieldArg = L loc (mk_arg loc arg_rdr)+           ; let locn = noAnnSrcSpan loc+           ; return [ L (noAnnSrcSpan loc) (HsRecField+                        { hsRecFieldAnn = noAnn+                        , hsRecFieldLbl+                           = L loc (FieldOcc sel (L (noAnnSrcSpan loc) arg_rdr))+                        , hsRecFieldArg = L locn (mk_arg loc arg_rdr)                         , hsRecPun      = False })                     | fl <- dot_dot_fields                     , let sel     = flSelector fl@@ -717,8 +754,8 @@     -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds   = do { pun_ok        <- xoptM LangExt.RecordPuns-       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields-       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds+       ; dup_fields_ok <- xopt_DuplicateRecordFields <$> getDynFlags+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok dup_fields_ok) flds        ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds         -- Check for an empty record update  e {}@@ -727,47 +764,32 @@         ; return (flds1, plusFVs fvss) }   where-    doc = text "constructor field name"--    rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs+    rn_fld :: Bool -> DuplicateRecordFields -> LHsRecUpdField GhcPs            -> RnM (LHsRecUpdField GhcRn, FreeVars)-    rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f+    rn_fld pun_ok dup_fields_ok (L l (HsRecField { hsRecFieldLbl = L loc f                                                , hsRecFieldArg = arg                                                , hsRecPun      = pun }))       = do { let lbl = rdrNameAmbiguousFieldOcc f-           ; sel <- setSrcSpan loc $+           ; mb_sel <- setSrcSpan loc $                       -- Defer renaming of overloaded fields to the typechecker-                      -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Expr-                      if overload_ok-                          then do { mb <- lookupGlobalOccRn_overloaded-                                            overload_ok lbl-                                  ; case mb of-                                      Nothing ->-                                        do { addErr-                                               (unknownSubordinateErr doc lbl)-                                           ; return (Right []) }-                                      Just r  -> return r }-                          else fmap Left $ lookupGlobalOccRn lbl+                      -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head+                      lookupRecFieldOcc_update dup_fields_ok lbl            ; arg' <- if pun                      then do { checkErr pun_ok (badPun (L loc lbl))                                -- Discard any module qualifier (#11662)                              ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)-                             ; return (L loc (HsVar noExtField (L loc arg_rdr))) }+                             ; return (L (noAnnSrcSpan loc) (HsVar noExtField+                                              (L (noAnnSrcSpan loc) arg_rdr))) }                      else return arg            ; (arg'', fvs) <- rnLExpr arg' -           ; let fvs' = case sel of-                          Left sel_name -> fvs `addOneFV` sel_name-                          Right [sel_name] -> fvs `addOneFV` sel_name-                          Right _       -> fvs-                 lbl' = case sel of-                          Left sel_name ->-                                     L loc (Unambiguous sel_name   (L loc lbl))-                          Right [sel_name] ->-                                     L loc (Unambiguous sel_name   (L loc lbl))-                          Right _ -> L loc (Ambiguous   noExtField (L loc lbl))+           ; let (lbl', fvs') = case mb_sel of+                   UnambiguousGre gname -> let sel_name = greNameMangledName gname+                                           in (Unambiguous sel_name (L (noAnnSrcSpan loc) lbl), fvs `addOneFV` sel_name)+                   AmbiguousFields       -> (Ambiguous   noExtField (L (noAnnSrcSpan loc) lbl), fvs) -           ; return (L l (HsRecField { hsRecFieldLbl = lbl'+           ; return (L l (HsRecField { hsRecFieldAnn = noAnn+                                     , hsRecFieldLbl = L loc lbl'                                      , hsRecFieldArg = arg''                                      , hsRecPun      = pun }), fvs') } @@ -782,9 +804,9 @@ getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds -getFieldLbls :: [LHsRecField id arg] -> [RdrName]+getFieldLbls :: forall p arg . UnXRec p => [LHsRecField p arg] -> [RdrName] getFieldLbls flds-  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds+  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unXRec @p) flds  getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName] getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds@@ -832,21 +854,26 @@ rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) rnLit _ = return () --- Turn a Fractional-looking literal which happens to be an integer into an+-- | Turn a Fractional-looking literal which happens to be an integer into an -- Integer-looking literal.+-- We only convert numbers where the exponent is between 0 and 100 to avoid+-- converting huge numbers and incurring long compilation times. See #15646. generalizeOverLitVal :: OverLitVal -> OverLitVal-generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))-    | denominator val == 1 = HsIntegral (IL { il_text=src-                                            , il_neg=neg-                                            , il_value=numerator val})+generalizeOverLitVal (HsFractional fl@(FL {fl_text=src,fl_neg=neg,fl_exp=e}))+    | e >= -100 && e <= 100+    , let val = rationalFromFractionalLit fl+    , denominator val == 1 = HsIntegral (IL {il_text=src,il_neg=neg,il_value=numerator val}) generalizeOverLitVal lit = lit  isNegativeZeroOverLit :: HsOverLit t -> Bool isNegativeZeroOverLit lit  = case ol_val lit of-        HsIntegral i   -> 0 == il_value i && il_neg i-        HsFractional f -> 0 == fl_value f && fl_neg f-        _              -> False+        HsIntegral i    -> 0 == il_value i && il_neg i+        -- For HsFractional, the value of fl is n * (b ^^ e) so it is sufficient+        -- to check if n = 0. b is equal to either 2 or 10. We don't call+        -- rationalFromFractionalLit here as it is expensive when e is big.+        HsFractional fl -> 0 == fl_signi fl && fl_neg fl+        _               -> False  {- Note [Negative zero]

GHC/Rename/Splice.hs view

@@ -1,6 +1,5 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP          #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -21,13 +20,15 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad+import GHC.Driver.Env.Types  import GHC.Rename.Env import GHC.Rename.Utils   ( HsDocContext(..), newLocalBndrRn ) import GHC.Rename.Unbound ( isUnboundName ) import GHC.Rename.Module  ( rnSrcDecls, findSplice ) import GHC.Rename.Pat     ( rnPat )-import GHC.Types.Basic    ( TopLevelFlag, isTopLevel, SourceText(..) )+import GHC.Types.Basic    ( TopLevelFlag, isTopLevel )+import GHC.Types.SourceText ( SourceText(..) ) import GHC.Utils.Outputable import GHC.Unit.Module import GHC.Types.SrcLoc@@ -37,16 +38,16 @@  import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr ) -import GHC.Tc.Utils.Env     ( checkWellStaged )-import GHC.Builtin.Names.TH ( liftName )+import GHC.Tc.Utils.Env     ( checkWellStaged, tcMetaTy )  import GHC.Driver.Session import GHC.Data.FastString-import GHC.Utils.Error  ( dumpIfSet_dyn_printer, DumpFormat (..) )-import GHC.Tc.Utils.Env ( tcMetaTy )+import GHC.Utils.Logger  ( dumpIfSet_dyn_printer, DumpFormat (..), getLogger )+import GHC.Utils.Panic import GHC.Driver.Hooks-import GHC.Builtin.Names.TH ( quoteExpName, quotePatName, quoteDecName, quoteTypeName-                            , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )+import GHC.Builtin.Names.TH ( decsQTyConName, expQTyConName, liftName+                            , patQTyConName, quoteDecName, quoteExpName+                            , quotePatName, quoteTypeName, typeQTyConName)  import {-# SOURCE #-} GHC.Tc.Gen.Expr   ( tcCheckPolyExpr ) import {-# SOURCE #-} GHC.Tc.Gen.Splice@@ -106,7 +107,7 @@                         ; (body', fvs_e) <-                           setStage (Brack cur_stage RnPendingTyped) $                                    rn_bracket cur_stage br_body-                        ; return (HsBracket noExtField body', fvs_e) }+                        ; return (HsBracket noAnn body', fvs_e) }              False -> do { traceRn "Renaming untyped TH bracket" empty                         ; ps_var <- newMutVar []@@ -121,7 +122,7 @@  rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) rn_bracket outer_stage br@(VarBr x flg rdr_name)-  = do { name <- lookupOccRn rdr_name+  = do { name <- lookupOccRn (unLoc rdr_name)        ; this_mod <- getModule         ; when (flg && nameIsLocalOrFrom this_mod name) $@@ -142,7 +143,7 @@                                              (quotedNameStageErr br) }                         }                     }-       ; return (VarBr x flg name, unitFV name) }+       ; return (VarBr x flg (noLocA name), unitFV name) }  rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e                             ; return (ExpBr x e', fvs) }@@ -175,7 +176,7 @@            ; Just (splice, rest) ->                do { group' <- groupDecls rest                   ; let group'' = appendGroups group group'-                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }+                  ; return group'' { hs_splcds = noLocA splice : hs_splcds group' }                   }            }} @@ -314,7 +315,10 @@             -> HsSplice GhcRn   -- Always untyped             -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice-  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)+  = do { hooks <- hsc_hooks <$> getTopEnv+       ; splice' <- case runRnSpliceHook hooks of+            Nothing -> return splice+            Just h  -> h splice         ; let the_expr = case splice' of                 HsUntypedSplice _ _ _ e   ->  e@@ -373,14 +377,16 @@                  -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote-mkQuasiQuoteExpr flavour quoter q_span quote-  = L q_span $ HsApp noExtField (L q_span-             $ HsApp noExtField (L q_span (HsVar noExtField (L q_span quote_selector)))+mkQuasiQuoteExpr flavour quoter q_span' quote+  = L q_span $ HsApp noComments (L q_span+             $ HsApp noComments (L q_span+                    (HsVar noExtField (L (la2na q_span) quote_selector)))                                 quoterExpr)                     quoteExpr   where-    quoterExpr = L q_span $! HsVar noExtField $! (L q_span quoter)-    quoteExpr  = L q_span $! HsLit noExtField $! HsString NoSourceText quote+    q_span = noAnnSrcSpan q_span'+    quoterExpr = L q_span $! HsVar noExtField $! (L (la2na q_span) quoter)+    quoteExpr  = L q_span $! HsLit noComments $! HsString NoSourceText quote     quote_selector = case flavour of                        UntypedExpSplice  -> quoteExpName                        UntypedPatSplice  -> quotePatName@@ -392,19 +398,19 @@ -- Not exported...used for all rnSplice (HsTypedSplice x hasParen splice_name expr)   = do  { loc  <- getSrcSpanM-        ; n' <- newLocalBndrRn (L loc splice_name)+        ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name)         ; (expr', fvs) <- rnLExpr expr         ; return (HsTypedSplice x hasParen n' expr', fvs) }  rnSplice (HsUntypedSplice x hasParen splice_name expr)   = do  { loc  <- getSrcSpanM-        ; n' <- newLocalBndrRn (L loc splice_name)+        ; n' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name)         ; (expr', fvs) <- rnLExpr expr         ; return (HsUntypedSplice x hasParen n' expr', fvs) }  rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)   = do  { loc  <- getSrcSpanM-        ; splice_name' <- newLocalBndrRn (L loc splice_name)+        ; splice_name' <- newLocalBndrRn (L (noAnnSrcSpan loc) splice_name)            -- Rename the quoter; akin to the HsVar case of rnExpr         ; quoter' <- lookupOccRn quoter@@ -424,7 +430,7 @@   where     pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)     pend_expr_splice rn_splice-        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExtField rn_splice)+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noAnn rn_splice)      run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)     run_expr_splice rn_splice@@ -433,11 +439,11 @@              traceRn "rnSpliceExpr: typed expression splice" empty            ; lcl_rdr <- getLocalRdrEnv            ; gbl_rdr <- getGlobalRdrEnv-           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr+           ; let gbl_names = mkNameSet [greMangledName gre | gre <- globalRdrEnvElts gbl_rdr                                                      , isLocalGRE gre]                  lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) -           ; return (HsSpliceE noExtField rn_splice, lcl_names `plusFV` gbl_names) }+           ; return (HsSpliceE noAnn rn_splice, lcl_names `plusFV` gbl_names) }        | otherwise  -- Run it here, see Note [Running splices in the Renamer]       = do { traceRn "rnSpliceExpr: untyped expression splice" empty@@ -445,7 +451,7 @@                 runRnSplice UntypedExpSplice runMetaE ppr rn_splice            ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsPar noExtField $ HsSpliceE noExtField+           ; return ( HsPar noAnn $ HsSpliceE noAnn                             . HsSpliced noExtField (ThModFinalizers mod_finalizers)                             . HsSplicedExpr <$>                             lexpr3@@ -496,7 +502,6 @@  {- Note [Rebindable syntax and Template Haskell] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- When processing Template Haskell quotes with Rebindable Syntax (RS) enabled, there are two possibilities: apply the RS rules to the quotes or don't. @@ -620,7 +625,7 @@                                  ; checkNoErrs $ rnLHsType doc hs_ty2 }                                     -- checkNoErrs: see Note [Renamer errors]              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( HsParTy noExtField+           ; return ( HsParTy noAnn                               $ HsSpliceTy noExtField                               . HsSpliced noExtField (ThModFinalizers mod_finalizers)                               . HsSplicedTy <$>@@ -690,7 +695,7 @@            ; (pat, mod_finalizers) <-                 runRnSplice UntypedPatSplice runMetaP ppr rn_splice              -- See Note [Delaying modFinalizers in untyped splices].-           ; return ( Left $ ParPat noExtField $ ((SplicePat noExtField)+           ; return ( Left $ ParPat noAnn $ ((SplicePat noExtField)                               . HsSpliced noExtField (ThModFinalizers mod_finalizers)                               . HsSplicedPat)  `mapLoc`                               pat@@ -808,15 +813,16 @@ traceSplice :: SpliceInfo -> TcM () traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src                         , spliceGenerated = gen, spliceIsDecl = is_decl })-  = do { loc <- case mb_src of-                   Nothing        -> getSrcSpanM-                   Just (L loc _) -> return loc-       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)+  = do loc <- case mb_src of+                 Nothing        -> getSrcSpanM+                 Just (L loc _) -> return (locA loc)+       traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc) -       ; when is_decl $  -- Raw material for -dth-dec-file-         do { dflags <- getDynFlags-            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file-                                             "" FormatHaskell (spliceCodeDoc loc) } }+       when is_decl $ do -- Raw material for -dth-dec-file+        dflags <- getDynFlags+        logger <- getLogger+        liftIO $ dumpIfSet_dyn_printer alwaysQualify logger dflags Opt_D_th_dec_file+                                       "" FormatHaskell (spliceCodeDoc loc)   where     -- `-ddump-splices`     spliceDebugDoc :: SrcSpan -> SDoc@@ -904,6 +910,12 @@           -- Construct the (lift x) expression         ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)               pend_splice = PendingRnSplice UntypedExpSplice name lift_expr++          -- Warning for implicit lift (#17804)+        ; whenWOptM Opt_WarnImplicitLift $+            addWarnTc (Reason Opt_WarnImplicitLift)+                       (text "The variable" <+> quotes (ppr name) <+>+                        text "is implicitly lifted in the TH quotation")            -- Update the pending splices         ; ps <- readMutVar ps_var

GHC/Rename/Unbound.hs view

@@ -20,22 +20,29 @@  import GHC.Prelude -import GHC.Types.Name.Reader-import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Tc.Utils.Monad-import GHC.Types.Name-import GHC.Unit.Module-import GHC.Types.SrcLoc as SrcLoc-import GHC.Utils.Outputable as Outputable import GHC.Builtin.Names ( mkUnboundName, isUnboundName, getUnique)+import GHC.Utils.Outputable as Outputable import GHC.Utils.Misc+ import GHC.Data.Maybe-import GHC.Driver.Session import GHC.Data.FastString-import Data.List-import Data.Function ( on )++import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Reader import GHC.Types.Unique.DFM (udfmToList) +import GHC.Unit.Module+import GHC.Unit.Module.Imported+import GHC.Unit.Home.ModInfo++import Data.List (sortBy, partition, nub)+import Data.Function ( on )+ {- ************************************************************************ *                                                                      *@@ -109,9 +116,28 @@     similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$     importSuggestions where_look global_env hpt                       curr_mod imports tried_rdr_name $$-    extensionSuggestions tried_rdr_name+    extensionSuggestions tried_rdr_name $$+    fieldSelectorSuggestions global_env tried_rdr_name +-- | When the name is in scope as field whose selector has been suppressed by+-- NoFieldSelectors, display a helpful message explaining this.+fieldSelectorSuggestions :: GlobalRdrEnv -> RdrName -> SDoc+fieldSelectorSuggestions global_env tried_rdr_name+  | null gres = Outputable.empty+  | otherwise = text "NB:"+      <+> quotes (ppr tried_rdr_name)+      <+> text "is a field selector" <+> whose+      $$ text "that has been suppressed by NoFieldSelectors"+  where+    gres = filter isNoFieldSelectorGRE $+               lookupGRE_RdrName' tried_rdr_name global_env+    parents = [ parent | ParentIs parent <- map gre_par gres ] +    -- parents may be empty if this is a pattern synonym field without a selector+    whose | null parents = empty+          | otherwise    = text "belonging to the type" <> plural parents+                             <+> pprQuotedList parents+ similarNameSuggestions :: WhereLooking -> DynFlags                         -> GlobalRdrEnv -> LocalRdrEnv                         -> RdrName -> SDoc@@ -173,8 +199,8 @@       | tried_is_qual = [ (rdr_qual, (rdr_qual, how))                         | gre <- globalRdrEnvElts global_env                         , isGreOk where_look gre-                        , let name = gre_name gre-                              occ  = nameOccName name+                        , not (isNoFieldSelectorGRE gre)+                        , let occ = greOccName gre                         , correct_name_space occ                         , (mod, how) <- qualsInScope gre                         , let rdr_qual = mkRdrQual mod occ ]@@ -182,8 +208,8 @@       | otherwise = [ (rdr_unqual, pair)                     | gre <- globalRdrEnvElts global_env                     , isGreOk where_look gre-                    , let name = gre_name gre-                          occ  = nameOccName name+                    , not (isNoFieldSelectorGRE gre)+                    , let occ = greOccName gre                           rdr_unqual = mkRdrUnqual occ                     , correct_name_space occ                     , pair <- case (unquals_in_scope gre, quals_only gre) of@@ -203,8 +229,8 @@      --------------------     unquals_in_scope :: GlobalRdrElt -> [HowInScope]-    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })-      | lcl       = [ Left (nameSrcSpan n) ]+    unquals_in_scope (gre@GRE { gre_lcl = lcl, gre_imp = is })+      | lcl       = [ Left (greDefinitionSrcSpan gre) ]       | otherwise = [ Right ispec                     | i <- is, let ispec = is_decl i                     , not (is_qual ispec) ]@@ -213,8 +239,8 @@     --------------------     quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]     -- Ones for which *only* the qualified version is in scope-    quals_only (GRE { gre_name = n, gre_imp = is })-      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)+    quals_only (gre@GRE { gre_imp = is })+      = [ (mkRdrQual (is_as ispec) (greOccName gre), Right ispec)         | i <- is, let ispec = is_decl i, is_qual ispec ]  -- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.@@ -359,10 +385,10 @@  qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)] -- Ones for which the qualified version is in scope-qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }-      | lcl = case nameModule_maybe n of+qualsInScope gre@GRE { gre_lcl = lcl, gre_imp = is }+      | lcl = case greDefinitionModule gre of                 Nothing -> []-                Just m  -> [(moduleName m, Left (nameSrcSpan n))]+                Just m  -> [(moduleName m, Left (greDefinitionSrcSpan gre))]       | otherwise = [ (is_as ispec, Right ispec)                     | i <- is, let ispec = is_decl i ]

GHC/Rename/Utils.hs view

@@ -1,18 +1,17 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} {-  This module contains miscellaneous functions related to renaming.  -}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Rename.Utils (-        checkDupRdrNames, checkShadowedRdrNames,+        checkDupRdrNames, checkDupRdrNamesN, checkShadowedRdrNames,         checkDupNames, checkDupAndShadowedNames, dupNamesErr,-        checkTupSize,+        checkTupSize, checkCTupSize,         addFvRn, mapFvRn, mapMaybeFvRn,         warnUnusedMatches, warnUnusedTypePatterns,         warnUnusedTopBinds, warnUnusedLocalBinds,@@ -26,7 +25,7 @@          bindLocalNames, bindLocalNamesFV, -        addNameClashErrRn, extendTyVarEnvFVRn,+        addNameClashErrRn,          checkInferredVars,         noNestedForallsContextsErr, addNoNestedForallsContextsErr@@ -40,7 +39,6 @@ import GHC.Core.Type import GHC.Hs import GHC.Types.Name.Reader-import GHC.Driver.Types import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Name@@ -48,7 +46,9 @@ import GHC.Types.Name.Env import GHC.Core.DataCon import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.SourceFile import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Types.Basic  ( TopLevelFlag(..) ) import GHC.Data.List.SetOps ( removeDups )@@ -56,8 +56,8 @@ import GHC.Driver.Session import GHC.Data.FastString import Control.Monad-import Data.List-import GHC.Settings.Constants ( mAX_TUPLE_SIZE )+import Data.List (find, sortBy)+import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE ) import qualified Data.List.NonEmpty as NE import qualified GHC.LanguageExtensions as LangExt @@ -69,7 +69,7 @@ ********************************************************* -} -newLocalBndrRn :: Located RdrName -> RnM Name+newLocalBndrRn :: LocatedN RdrName -> RnM Name -- Used for non-top-level binders.  These should -- never be qualified. newLocalBndrRn (L loc rdr_name)@@ -78,11 +78,11 @@                 -- See Note [Binders in Template Haskell] in "GHC.ThToHs"   | otherwise   = do { unless (isUnqual rdr_name)-                (addErrAt loc (badQualBndrErr rdr_name))+                (addErrAt (locA loc) (badQualBndrErr rdr_name))        ; uniq <- newUnique-       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) (locA loc)) } -newLocalBndrsRn :: [Located RdrName] -> RnM [Name]+newLocalBndrsRn :: [LocatedN RdrName] -> RnM [Name] newLocalBndrsRn = mapM newLocalBndrRn  bindLocalNames :: [Name] -> RnM a -> RnM a@@ -102,18 +102,20 @@         ; return (result, delFVs names fvs) }  ---------------------------------------extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)-extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside----------------------------------------checkDupRdrNames :: [Located RdrName] -> RnM ()+checkDupRdrNames :: [LocatedN RdrName] -> RnM () -- Check for duplicated names in a binding group checkDupRdrNames rdr_names_w_loc-  = mapM_ (dupNamesErr getLoc) dups+  = mapM_ (dupNamesErr getLocA) dups   where     (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc +checkDupRdrNamesN :: [LocatedN RdrName] -> RnM ()+-- Check for duplicated names in a binding group+checkDupRdrNamesN rdr_names_w_loc+  = mapM_ (dupNamesErr getLocA) dups+  where+    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc+ checkDupNames :: [Name] -> RnM () -- Check for duplicated names in a binding group checkDupNames names = check_dup_names (filterOut isSystemName names)@@ -126,14 +128,14 @@     (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names  ----------------------checkShadowedRdrNames :: [Located RdrName] -> RnM ()+checkShadowedRdrNames :: [LocatedN RdrName] -> RnM () checkShadowedRdrNames loc_rdr_names   = do { envs <- getRdrEnvs        ; checkShadowedOccs envs get_loc_occ filtered_rdrs }   where     filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names                 -- See Note [Binders in Template Haskell] in "GHC.ThToHs"-    get_loc_occ (L loc rdr) = (loc,rdrNameOcc rdr)+    get_loc_occ (L loc rdr) = (locA loc,rdrNameOcc rdr)  checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () checkDupAndShadowedNames envs names@@ -194,17 +196,14 @@                   -> RnM () checkInferredVars _    Nothing    _  = return () checkInferredVars ctxt (Just msg) ty =-  let bndrs = forallty_bndrs (hsSigType ty)+  let bndrs = sig_ty_bndrs ty   in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of     Nothing -> return ()     Just _  -> addErr $ withHsDocContext ctxt msg   where-    forallty_bndrs :: LHsType GhcPs -> [HsTyVarBndr Specificity GhcPs]-    forallty_bndrs (L _ ty) = case ty of-      HsParTy _ ty' -> forallty_bndrs ty'-      HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = tvs }}-                    -> map unLoc tvs-      _             -> []+    sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]+    sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))+      = map unLoc (hsOuterExplicitBndrs outer_bndrs)  {- Note [Unobservably inferred type variables]@@ -292,13 +291,13 @@          -- types of terms, so we give a slightly more descriptive error          -- message in the event that they contain visible dependent          -- quantification (currently only allowed in kinds).-      -> Just (l, vcat [ text "Illegal visible, dependent quantification" <+>-                         text "in the type of a term"-                       , text "(GHC does not yet support this)" ])+      -> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+>+                              text "in the type of a term"+                            , text "(GHC does not yet support this)" ])       |  HsForAllInvis{} <- tele-      -> Just (l, nested_foralls_contexts_err)+      -> Just (locA l, nested_foralls_contexts_err)     L l (HsQualTy {})-      -> Just (l, nested_foralls_contexts_err)+      -> Just (locA l, nested_foralls_contexts_err)     _ -> Nothing   where     nested_foralls_contexts_err =@@ -366,8 +365,8 @@                           -> FreeVars                           -> Maybe [Name]                           -> RnM ()-checkUnusedRecordWildcard _ _ Nothing    = return ()-checkUnusedRecordWildcard loc _ (Just [])  = do+checkUnusedRecordWildcard _ _ Nothing     = return ()+checkUnusedRecordWildcard loc _ (Just []) =   -- Add a new warning if the .. pattern binds no variables   setSrcSpan loc $ warnRedundantRecordWildcard checkUnusedRecordWildcard loc fvs (Just dotdot_names) =@@ -426,30 +425,26 @@ warnUnusedGREs :: [GlobalRdrElt] -> RnM () warnUnusedGREs gres = mapM_ warnUnusedGRE gres +-- NB the Names must not be the names of record fields! warnUnused :: WarningFlag -> [Name] -> RnM ()-warnUnused flag names = do-    fld_env <- mkFieldEnv <$> getGlobalRdrEnv-    mapM_ (warnUnused1 flag fld_env) names+warnUnused flag names =+    mapM_ (warnUnused1 flag . NormalGreName) names -warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()-warnUnused1 flag fld_env name-  = when (reportable name occ) $+warnUnused1 :: WarningFlag -> GreName -> RnM ()+warnUnused1 flag child+  = when (reportable child) $     addUnusedWarning flag-                     occ (nameSrcSpan name)+                     (occName child) (greNameSrcSpan child)                      (text $ "Defined but not used" ++ opt_str)   where-    occ = case lookupNameEnv fld_env name of-              Just (fl, _) -> mkVarOccFS fl-              Nothing      -> nameOccName name     opt_str = case flag of                 Opt_WarnUnusedTypePatterns -> " on the right hand side"                 _ -> ""  warnUnusedGRE :: GlobalRdrElt -> RnM ()-warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })-  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv-                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name-  | otherwise = when (reportable name occ) (mapM_ warn is)+warnUnusedGRE gre@(GRE { gre_lcl = lcl, gre_imp = is })+  | lcl       = warnUnused1 Opt_WarnUnusedTopBinds (gre_name gre)+  | otherwise = when (reportable (gre_name gre)) (mapM_ warn is)   where     occ = greOccName gre     warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg@@ -460,22 +455,23 @@  -- | Make a map from selector names to field labels and parent tycon -- names, to be used when reporting unused record fields.-mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)-mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Parent)+mkFieldEnv rdr_env = mkNameEnv [ (greMangledName gre, (flLabel fl, gre_par gre))                                | gres <- occEnvElts rdr_env                                , gre <- gres-                               , Just lbl <- [greLabel gre]+                               , Just fl <- [greFieldLabel gre]                                ]  -- | Should we report the fact that this 'Name' is unused? The -- 'OccName' may differ from 'nameOccName' due to -- DuplicateRecordFields.-reportable :: Name -> OccName -> Bool-reportable name occ-  | isWiredInName name = False    -- Don't report unused wired-in names+reportable :: GreName -> Bool+reportable child+  | NormalGreName name <- child+  , isWiredInName name = False    -- Don't report unused wired-in names                                   -- Otherwise we get a zillion warnings                                   -- from Data.Tuple-  | otherwise = not (startsWithUnderscore occ)+  | otherwise = not (startsWithUnderscore (occName child))  addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM () addUnusedWarning flag occ span msg@@ -498,20 +494,51 @@     $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"                                             <+> quotes (text "..")) -addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()+{-+Note [Skipping ambiguity errors at use sites of local declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we do not report ambiguous occurrences at use sites where all the+clashing names are defined locally, because the error will have been reported at+the definition site, and we want to avoid an error cascade.++However, when DuplicateRecordFields is enabled, it is possible to define the+same field name multiple times, so we *do* need to report an error at the use+site when there is ambiguity between multiple fields. Moreover, when+NoFieldSelectors is enabled, it is possible to define a field with the same name+as a non-field, so again we need to report ambiguity at the use site.++We can skip reporting an ambiguity error whenever defining the GREs must have+yielded a duplicate declarations error.  More precisely, we can skip if:++ * there are at least two non-fields amongst the GREs; or++ * there are at least two fields amongst the GREs, and DuplicateRecordFields is+   *disabled*; or++ * there is at least one non-field, at least one field, and NoFieldSelectors is+   *disabled*.++These conditions ensure that a duplicate local declaration will have been+reported.  See also Note [Reporting duplicate local declarations] in+GHC.Rename.Names).++-}++addNameClashErrRn :: RdrName -> NE.NonEmpty GlobalRdrElt -> RnM () addNameClashErrRn rdr_name gres-  | all isLocalGRE gres && not (all isRecFldGRE gres)-               -- If there are two or more *local* defns, we'll have reported-  = return ()  -- that already, and we don't want an error cascade+  | all isLocalGRE gres && can_skip+  -- If there are two or more *local* defns, we'll usually have reported that+  -- already, and we don't want an error cascade.+  = return ()   | otherwise   = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)                  , text "It could refer to"                  , nest 3 (vcat (msg1 : msgs)) ])   where-    (np1:nps) = gres+    np1 NE.:| nps = gres     msg1 =  text "either" <+> ppr_gre np1     msgs = [text "    or" <+> ppr_gre np | np <- nps]-    ppr_gre gre = sep [ pp_gre_name gre <> comma+    ppr_gre gre = sep [ pp_greMangledName gre <> comma                       , pprNameProvenance gre]      -- When printing the name, take care to qualify it in the same@@ -522,14 +549,14 @@     --                            imported from ‘Prelude’ at T15487.hs:1:8-13     --                     or ...     -- See #15487-    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent-                         , gre_lcl = lcl, gre_imp = iss })-      | FldParent { par_lbl = Just lbl } <- parent-      = text "the field" <+> quotes (ppr lbl)-      | otherwise-      = quotes (pp_qual <> dot <> ppr (nameOccName name))+    pp_greMangledName gre@(GRE { gre_name = child+                         , gre_lcl = lcl, gre_imp = iss }) =+      case child of+        FieldGreName fl  -> text "the field" <+> quotes (ppr fl)+        NormalGreName name -> quotes (pp_qual name <> dot <> ppr (nameOccName name))       where-        pp_qual | lcl+        pp_qual name+                | lcl                 = ppr (nameModule name)                 | imp : _ <- iss  -- This 'imp' is the one that                                   -- pprNameProvenance chooses@@ -539,6 +566,18 @@                 = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)                   -- Invariant: either 'lcl' is True or 'iss' is non-empty +    -- If all the GREs are defined locally, can we skip reporting an ambiguity+    -- error at use sites, because it will have been reported already? See+    -- Note [Skipping ambiguity errors at use sites of local declarations]+    can_skip = num_non_flds >= 2+            || (num_flds >= 2 && not (isDuplicateRecFldGRE (head flds)))+            || (num_non_flds >= 1 && num_flds >= 1+                                  && not (isNoFieldSelectorGRE (head flds)))+    (flds, non_flds) = NE.partition isRecFldGRE gres+    num_flds     = length flds+    num_non_flds = length non_flds++ shadowedNameWarn :: OccName -> [SDoc] -> SDoc shadowedNameWarn occ shadowed_locs   = sep [text "This binding for" <+> quotes (ppr occ)@@ -572,7 +611,9 @@             <+> quotes (char '@' <> ppr k))        2 (text "Perhaps you intended to use TypeApplications") -checkTupSize :: Int -> RnM ()+-- | Ensure that a boxed or unboxed tuple has arity no larger than+-- 'mAX_TUPLE_SIZE'.+checkTupSize :: Int -> TcM () checkTupSize tup_size   | tup_size <= mAX_TUPLE_SIZE   = return ()@@ -581,7 +622,17 @@                  nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),                  nest 2 (text "Workaround: use nested tuples or define a data type")]) +-- | Ensure that a constraint tuple has arity no larger than 'mAX_CTUPLE_SIZE'.+checkCTupSize :: Int -> TcM ()+checkCTupSize tup_size+  | tup_size <= mAX_CTUPLE_SIZE+  = return ()+  | otherwise+  = addErr (hang (text "Constraint tuple arity too large:" <+> int tup_size+                  <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+               2 (text "Instead, use a nested tuple")) + {- ************************************************************************ *                                                                      *@@ -598,18 +649,19 @@   | PatCtx   | SpecInstSigCtx   | DefaultDeclCtx-  | ForeignDeclCtx (Located RdrName)+  | ForeignDeclCtx (LocatedN RdrName)   | DerivDeclCtx   | RuleCtx FastString-  | TyDataCtx (Located RdrName)-  | TySynCtx (Located RdrName)-  | TyFamilyCtx (Located RdrName)-  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance-  | ConDeclCtx [Located Name]-  | ClassDeclCtx (Located RdrName)+  | TyDataCtx (LocatedN RdrName)+  | TySynCtx (LocatedN RdrName)+  | TyFamilyCtx (LocatedN RdrName)+  | FamPatCtx (LocatedN RdrName)    -- The patterns of a type/data family instance+  | ConDeclCtx [LocatedN Name]+  | ClassDeclCtx (LocatedN RdrName)   | ExprWithTySigCtx   | TypBrCtx   | HsTypeCtx+  | HsTypePatCtx   | GHCiCtx   | SpliceTypeCtx (LHsType GhcPs)   | ClassInstanceCtx@@ -638,6 +690,7 @@ pprHsDocContext ExprWithTySigCtx      = text "an expression type signature" pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type" pprHsDocContext HsTypeCtx             = text "a type argument"+pprHsDocContext HsTypePatCtx          = text "a type argument in a pattern" pprHsDocContext GHCiCtx               = text "GHCi input" pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty) pprHsDocContext ClassInstanceCtx      = text "GHC.Tc.Gen.Splice.reifyInstances"

+ GHC/Runtime/Context.hs view

@@ -0,0 +1,400 @@+module GHC.Runtime.Context+   ( InteractiveContext (..)+   , InteractiveImport (..)+   , emptyInteractiveContext+   , extendInteractiveContext+   , extendInteractiveContextWithIds+   , setInteractivePrintName+   , substInteractiveContext+   , icExtendGblRdrEnv+   , icInteractiveModule+   , icInScopeTTs+   , icPrintUnqual+   )+where++import GHC.Prelude++import GHC.Hs++import GHC.Driver.Session+import {-# SOURCE #-} GHC.Driver.Plugins++import GHC.Runtime.Eval.Types ( Resume )++import GHC.Unit+import GHC.Unit.Env++import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( ClsInst, identicalClsInstHead )+import GHC.Core.Type++import GHC.Types.Avail+import GHC.Types.Fixity.Env+import GHC.Types.Id ( isRecordSelector )+import GHC.Types.Id.Info ( IdDetails(..) )+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.Var++import GHC.Builtin.Names ( ioTyConName, printName, mkInteractiveModule )++import GHC.Utils.Outputable+import GHC.Utils.Misc++{-+Note [The interactive package]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type, class, and value declarations at the command prompt are treated+as if they were defined in modules+   interactive:Ghci1+   interactive:Ghci2+   ...etc...+with each bunch of declarations using a new module, all sharing a+common package 'interactive' (see Module.interactiveUnitId, and+GHC.Builtin.Names.mkInteractiveModule).++This scheme deals well with shadowing.  For example:++   ghci> data T = A+   ghci> data T = B+   ghci> :i A+   data Ghci1.T = A  -- Defined at <interactive>:2:10++Here we must display info about constructor A, but its type T has been+shadowed by the second declaration.  But it has a respectable+qualified name (Ghci1.T), and its source location says where it was+defined.++So the main invariant continues to hold, that in any session an+original name M.T only refers to one unique thing.  (In a previous+iteration both the T's above were called :Interactive.T, albeit with+different uniques, which gave rise to all sorts of trouble.)++The details are a bit tricky though:++ * The field ic_mod_index counts which Ghci module we've got up to.+   It is incremented when extending ic_tythings++ * ic_tythings contains only things from the 'interactive' package.++ * Module from the 'interactive' package (Ghci1, Ghci2 etc) never go+   in the Home Package Table (HPT).  When you say :load, that's when we+   extend the HPT.++ * The 'homeUnitId' field of DynFlags is *not* set to 'interactive'.+   It stays as 'main' (or whatever -this-unit-id says), and is the+   package to which :load'ed modules are added to.++ * So how do we arrange that declarations at the command prompt get to+   be in the 'interactive' package?  Simply by setting the tcg_mod+   field of the TcGblEnv to "interactive:Ghci1".  This is done by the+   call to initTc in initTcInteractive, which in turn get the module+   from it 'icInteractiveModule' field of the interactive context.++   The 'homeUnitId' field stays as 'main' (or whatever -this-unit-id says.++ * The main trickiness is that the type environment (tcg_type_env) and+   fixity envt (tcg_fix_env), now contain entities from all the+   interactive-package modules (Ghci1, Ghci2, ...) together, rather+   than just a single module as is usually the case.  So you can't use+   "nameIsLocalOrFrom" to decide whether to look in the TcGblEnv vs+   the HPT/PTE.  This is a change, but not a problem provided you+   know.++* However, the tcg_binds, tcg_sigs, tcg_insts, tcg_fam_insts, etc fields+  of the TcGblEnv, which collect "things defined in this module", all+  refer to stuff define in a single GHCi command, *not* all the commands+  so far.++  In contrast, tcg_inst_env, tcg_fam_inst_env, have instances from+  all GhciN modules, which makes sense -- they are all "home package"+  modules.+++Note [Interactively-bound Ids in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Ids bound by previous Stmts in GHCi are currently+        a) GlobalIds, with+        b) An External Name, like Ghci4.foo+           See Note [The interactive package] above+        c) A tidied type++ (a) They must be GlobalIds (not LocalIds) otherwise when we come to+     compile an expression using these ids later, the byte code+     generator will consider the occurrences to be free rather than+     global.++ (b) Having an External Name is important because of Note+     [GlobalRdrEnv shadowing] in GHC.Types.Names.RdrName++ (c) Their types are tidied. This is important, because :info may ask+     to look at them, and :info expects the things it looks up to have+     tidy types++Where do interactively-bound Ids come from?++  - GHCi REPL Stmts   e.g.+         ghci> let foo x = x+1+    These start with an Internal Name because a Stmt is a local+    construct, so the renamer naturally builds an Internal name for+    each of its binders.  Then in tcRnStmt they are externalised via+    GHC.Tc.Module.externaliseAndTidyId, so they get Names like Ghic4.foo.++  - Ids bound by the debugger etc have Names constructed by+    GHC.Iface.Env.newInteractiveBinder; at the call sites it is followed by+    mkVanillaGlobal or mkVanillaGlobalWithInfo.  So again, they are+    all Global, External.++  - TyCons, Classes, and Ids bound by other top-level declarations in+    GHCi (eg foreign import, record selectors) also get External+    Names, with Ghci9 (or 8, or 7, etc) as the module name.+++Note [ic_tythings]+~~~~~~~~~~~~~~~~~~+The ic_tythings field contains+  * The TyThings declared by the user at the command prompt+    (eg Ids, TyCons, Classes)++  * The user-visible Ids that arise from such things, which+    *don't* come from 'implicitTyThings', notably:+       - record selectors+       - class ops+    The implicitTyThings are readily obtained from the TyThings+    but record selectors etc are not++It does *not* contain+  * DFunIds (they can be gotten from ic_instances)+  * CoAxioms (ditto)++See also Note [Interactively-bound Ids in GHCi]++Note [Override identical instances in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you declare a new instance in GHCi that is identical to a previous one,+we simply override the previous one; we don't regard it as overlapping.+e.g.    Prelude> data T = A | B+        Prelude> instance Eq T where ...+        Prelude> instance Eq T where ...   -- This one overrides++It's exactly the same for type-family instances.  See #7102+-}++-- | Interactive context, recording information about the state of the+-- context in which statements are executed in a GHCi session.+data InteractiveContext+  = InteractiveContext {+         ic_dflags     :: DynFlags,+             -- ^ The 'DynFlags' used to evaluate interactive expressions+             -- and statements.++         ic_mod_index :: Int,+             -- ^ Each GHCi stmt or declaration brings some new things into+             -- scope. We give them names like interactive:Ghci9.T,+             -- where the ic_index is the '9'.  The ic_mod_index is+             -- incremented whenever we add something to ic_tythings+             -- See Note [The interactive package]++         ic_imports :: [InteractiveImport],+             -- ^ The GHCi top-level scope (ic_rn_gbl_env) is extended with+             -- these imports+             --+             -- This field is only stored here so that the client+             -- can retrieve it with GHC.getContext. GHC itself doesn't+             -- use it, but does reset it to empty sometimes (such+             -- as before a GHC.load). The context is set with GHC.setContext.++         ic_tythings   :: [TyThing],+             -- ^ TyThings defined by the user, in reverse order of+             -- definition (ie most recent at the front)+             -- See Note [ic_tythings]++         ic_rn_gbl_env :: GlobalRdrEnv,+             -- ^ The cached 'GlobalRdrEnv', built by+             -- 'GHC.Runtime.Eval.setContext' and updated regularly+             -- It contains everything in scope at the command line,+             -- including everything in ic_tythings++         ic_instances  :: ([ClsInst], [FamInst]),+             -- ^ All instances and family instances created during+             -- this session.  These are grabbed en masse after each+             -- update to be sure that proper overlapping is retained.+             -- That is, rather than re-check the overlapping each+             -- time we update the context, we just take the results+             -- from the instance code that already does that.++         ic_fix_env :: FixityEnv,+            -- ^ Fixities declared in let statements++         ic_default :: Maybe [Type],+             -- ^ The current default types, set by a 'default' declaration++          ic_resume :: [Resume],+             -- ^ The stack of breakpoint contexts++         ic_monad      :: Name,+             -- ^ The monad that GHCi is executing in++         ic_int_print  :: Name,+             -- ^ The function that is used for printing results+             -- of expressions in ghci and -e mode.++         ic_cwd :: Maybe FilePath,+             -- ^ virtual CWD of the program++         ic_plugins :: ![LoadedPlugin]+             -- ^ Cache of loaded plugins. We store them here to avoid having to+             -- load them everytime we switch to the interctive context.+    }++data InteractiveImport+  = IIDecl (ImportDecl GhcPs)+      -- ^ Bring the exports of a particular module+      -- (filtered by an import decl) into scope++  | IIModule ModuleName+      -- ^ Bring into scope the entire top-level envt of+      -- of this module, including the things imported+      -- into it.+++-- | Constructs an empty InteractiveContext.+emptyInteractiveContext :: DynFlags -> InteractiveContext+emptyInteractiveContext dflags+  = InteractiveContext {+       ic_dflags     = dflags,+       ic_imports    = [],+       ic_rn_gbl_env = emptyGlobalRdrEnv,+       ic_mod_index  = 1,+       ic_tythings   = [],+       ic_instances  = ([],[]),+       ic_fix_env    = emptyNameEnv,+       ic_monad      = ioTyConName,  -- IO monad by default+       ic_int_print  = printName,    -- System.IO.print by default+       ic_default    = Nothing,+       ic_resume     = [],+       ic_cwd        = Nothing,+       ic_plugins    = []+       }++icInteractiveModule :: InteractiveContext -> Module+icInteractiveModule (InteractiveContext { ic_mod_index = index })+  = mkInteractiveModule index++-- | This function returns the list of visible TyThings (useful for+-- e.g. showBindings)+icInScopeTTs :: InteractiveContext -> [TyThing]+icInScopeTTs = ic_tythings++-- | Get the PrintUnqualified function based on the flags and this InteractiveContext+icPrintUnqual :: UnitEnv -> InteractiveContext -> PrintUnqualified+icPrintUnqual unit_env InteractiveContext{ ic_rn_gbl_env = grenv } =+    mkPrintUnqualified unit_env grenv++-- | extendInteractiveContext is called with new TyThings recently defined to update the+-- InteractiveContext to include them.  Ids are easily removed when shadowed,+-- but Classes and TyCons are not.  Some work could be done to determine+-- whether they are entirely shadowed, but as you could still have references+-- to them (e.g. instances for classes or values of the type for TyCons), it's+-- not clear whether removing them is even the appropriate behavior.+extendInteractiveContext :: InteractiveContext+                         -> [TyThing]+                         -> [ClsInst] -> [FamInst]+                         -> Maybe [Type]+                         -> FixityEnv+                         -> InteractiveContext+extendInteractiveContext ictxt new_tythings new_cls_insts new_fam_insts defaults fix_env+  = ictxt { ic_mod_index  = ic_mod_index ictxt + 1+                            -- Always bump this; even instances should create+                            -- a new mod_index (#9426)+          , ic_tythings   = new_tythings ++ old_tythings+          , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings+          , ic_instances  = ( new_cls_insts ++ old_cls_insts+                            , new_fam_insts ++ fam_insts )+                            -- we don't shadow old family instances (#7102),+                            -- so don't need to remove them here+          , ic_default    = defaults+          , ic_fix_env    = fix_env  -- See Note [Fixity declarations in GHCi]+          }+  where+    new_ids = [id | AnId id <- new_tythings]+    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)++    -- Discard old instances that have been fully overridden+    -- See Note [Override identical instances in GHCi]+    (cls_insts, fam_insts) = ic_instances ictxt+    old_cls_insts = filterOut (\i -> any (identicalClsInstHead i) new_cls_insts) cls_insts++extendInteractiveContextWithIds :: InteractiveContext -> [Id] -> InteractiveContext+-- Just a specialised version+extendInteractiveContextWithIds ictxt new_ids+  | null new_ids = ictxt+  | otherwise    = ictxt { ic_mod_index  = ic_mod_index ictxt + 1+                         , ic_tythings   = new_tythings ++ old_tythings+                         , ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings }+  where+    new_tythings = map AnId new_ids+    old_tythings = filterOut (shadowed_by new_ids) (ic_tythings ictxt)++shadowed_by :: [Id] -> TyThing -> Bool+shadowed_by ids = shadowed+  where+    -- Keep record selectors because they might be needed by HasField (#19322)+    shadowed (AnId id) | isRecordSelector id = False+    shadowed tything = getOccName tything `elemOccSet` new_occs+    new_occs = mkOccSet (map getOccName ids)++setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext+setInteractivePrintName ic n = ic{ic_int_print = n}++    -- ToDo: should not add Ids to the gbl env here++-- | Add TyThings to the GlobalRdrEnv, earlier ones in the list shadowing+-- later ones, and shadowing existing entries in the GlobalRdrEnv.+icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv+icExtendGblRdrEnv env tythings+  = foldr add env tythings  -- Foldr makes things in the front of+                            -- the list shadow things at the back+  where+    -- One at a time, to ensure each shadows the previous ones+    add thing env+       | is_sub_bndr thing+       = env+       | otherwise+       = foldl' extendGlobalRdrEnv env1 (concatMap localGREsFromAvail avail)+       where+          env1  = shadowNames env (concatMap availGreNames avail)+          avail = tyThingAvailInfo thing++    -- Ugh! The new_tythings may include record selectors, since they+    -- are not implicit-ids, and must appear in the TypeEnv.  But they+    -- will also be brought into scope by the corresponding (ATyCon+    -- tc).  And we want the latter, because that has the correct+    -- parent (#10520)+    is_sub_bndr (AnId f) = case idDetails f of+                             RecSelId {}  -> True+                             ClassOpId {} -> True+                             _            -> False+    is_sub_bndr _ = False++substInteractiveContext :: InteractiveContext -> TCvSubst -> InteractiveContext+substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst+  | isEmptyTCvSubst subst = ictxt+  | otherwise             = ictxt { ic_tythings = map subst_ty tts }+  where+    subst_ty (AnId id)+      = AnId $ updateIdTypeAndMult (substTyAddInScope subst) id+      -- Variables in the interactive context *can* mention free type variables+      -- because of the runtime debugger. Otherwise you'd expect all+      -- variables bound in the interactive context to be closed.+    subst_ty tt+      = tt++instance Outputable InteractiveImport where+  ppr (IIModule m) = char '*' <> ppr m+  ppr (IIDecl d)   = ppr d+

GHC/Runtime/Debugger.hs view

@@ -1,5 +1,3 @@-{-# LANGUAGE MagicHash #-}- ----------------------------------------------------------------------------- -- -- GHCi Interactive debugging commands@@ -16,29 +14,37 @@  import GHC.Prelude -import GHC.Runtime.Linker-import GHC.Runtime.Heap.Inspect+import GHC -import GHC.Runtime.Interpreter-import GHCi.RemoteTypes+import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Driver.Monad-import GHC.Driver.Types-import GHC.Types.Id+import GHC.Driver.Env++import GHC.Linker.Loader++import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Interpreter+import GHC.Runtime.Context+ import GHC.Iface.Syntax ( showToHeader ) import GHC.Iface.Env    ( newInteractiveBinder )-import GHC.Types.Name-import GHC.Types.Var hiding ( varName )-import GHC.Types.Var.Set-import GHC.Types.Unique.Set import GHC.Core.Type-import GHC+ import GHC.Utils.Outputable-import GHC.Core.Ppr.TyThing import GHC.Utils.Error import GHC.Utils.Monad-import GHC.Driver.Session import GHC.Utils.Exception+import GHC.Utils.Logger +import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Var hiding ( varName )+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.TyThing.Ppr+import GHC.Types.TyThing+ import Control.Monad import Control.Monad.Catch as MC import Data.List ( (\\) )@@ -67,7 +73,8 @@   unqual  <- GHC.getPrintUnqual   docterms <- mapM showTerm terms   dflags <- getDynFlags-  liftIO $ (printOutputForUser dflags unqual . vcat)+  logger <- getLogger+  liftIO $ (printOutputForUser logger dflags unqual . vcat)            (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)                     ids                     docterms)@@ -90,8 +97,9 @@        case (improveRTTIType hsc_env id_ty' reconstructed_type) of          Nothing     -> return (subst, term')          Just subst' -> do { dflags <- GHC.getSessionDynFlags+                           ; logger <- getLogger                            ; liftIO $-                               dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"+                               dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI"                                  FormatText                                  (fsep $ [text "RTTI Improvement for", ppr id,                                   text "old substitution:" , ppr subst,@@ -127,8 +135,8 @@       let ids = [ mkVanillaGlobal name ty                 | (name,ty) <- zip names tys]           new_ic = extendInteractiveContextWithIds ictxt ids-          dl = hsc_dynLinker hsc_env-      liftIO $ extendLinkEnv dl (zip names fhvs)+          interp = hscInterp hsc_env+      liftIO $ extendLoadedEnv interp (zip names fhvs)       setSession hsc_env {hsc_IC = new_ic }       return t'      where@@ -170,32 +178,36 @@     if not (isFullyEvaluatedTerm t)      then return Nothing      else do-        hsc_env <- getSession-        dflags  <- GHC.getSessionDynFlags-        do-           (new_env, bname) <- bindToFreshName hsc_env ty "showme"-           setSession new_env-                      -- XXX: this tries to disable logging of errors-                      -- does this still do what it is intended to do-                      -- with the changed error handling and logging?-           let noop_log _ _ _ _ _ = return ()-               expr = "Prelude.return (Prelude.show " +++        let set_session = do+                hsc_env <- getSession+                (new_env, bname) <- bindToFreshName hsc_env ty "showme"+                setSession new_env++                -- this disables logging of errors+                let noop_log _ _ _ _ _ = return ()+                pushLogHookM (const noop_log)++                return (hsc_env, bname)++            reset_session (old_env,_) = setSession old_env++        MC.bracket set_session reset_session $ \(_,bname) -> do+           hsc_env <- getSession+           dflags  <- GHC.getSessionDynFlags+           let expr = "Prelude.return (Prelude.show " ++                          showPpr dflags bname ++                       ") :: Prelude.IO Prelude.String"-               dl   = hsc_dynLinker hsc_env-           GHC.setSessionDynFlags dflags{log_action=noop_log}-           txt_ <- withExtendedLinkEnv dl+               interp = hscInterp hsc_env+           txt_ <- withExtendedLoadedEnv interp                                        [(bname, fhv)]                                        (GHC.compileExprRemote expr)            let myprec = 10 -- application precedence. TODO Infix constructors-           txt <- liftIO $ evalString hsc_env txt_+           txt <- liftIO $ evalString interp txt_            if not (null txt) then              return $ Just $ cparen (prec >= myprec && needsParens txt)                                     (text txt)             else return Nothing-         `MC.finally` do-           setSession hsc_env-           GHC.setSessionDynFlags dflags+   cPprShowable prec NewtypeWrap{ty=new_ty,wrapped_term=t} =       cPprShowable prec t{ty=new_ty}   cPprShowable _ _ = return Nothing

GHC/Runtime/Eval.hs view

@@ -1,5 +1,7 @@-{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -15,16 +17,15 @@         Resume(..), History(..),         execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,         runDecls, runDeclsWithLocation, runParsedDecls,-        isStmt, hasImport, isImport, isDecl,         parseImportDecl, SingleStep(..),         abandon, abandonAll,         getResumeContext,         getHistorySpan,         getModBreaks,         getHistoryModule,+        setupBreakpoint,         back, forward,         setContext, getContext,-        availsToGlobalRdrEnv,         getNamesInScope,         getRdrNamesInScope,         moduleIsInterpreted,@@ -48,66 +49,78 @@  import GHC.Prelude -import GHC.Runtime.Eval.Types+import GHC.Driver.Monad+import GHC.Driver.Main+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Ppr +import GHC.Runtime.Eval.Types import GHC.Runtime.Interpreter as GHCi-import GHC.Runtime.Interpreter.Types+import GHC.Runtime.Heap.Inspect+import GHC.Runtime.Context import GHCi.Message import GHCi.RemoteTypes-import GHC.Driver.Monad-import GHC.Driver.Main+import GHC.ByteCode.Types++import GHC.Linker.Types+import GHC.Linker.Loader as Loader+ import GHC.Hs-import GHC.Driver.Types++import GHC.Core.Predicate import GHC.Core.InstEnv-import GHC.Iface.Env       ( newInteractiveBinder ) import GHC.Core.FamInstEnv ( FamInst ) import GHC.Core.FVs        ( orphNamesOfFamInst ) import GHC.Core.TyCon import GHC.Core.Type       hiding( typeKind ) import qualified GHC.Core.Type as Type-import GHC.Types.RepType++import GHC.Iface.Env       ( newInteractiveBinder ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import GHC.Core.Predicate++import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )+import GHC.Builtin.Types ( isCTupleTyConName )++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.Bag++import GHC.Utils.Monad+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Logger++import GHC.Types.RepType+import GHC.Types.Fixity.Env import GHC.Types.Var import GHC.Types.Id as Id import GHC.Types.Name      hiding ( varName ) import GHC.Types.Name.Set-import GHC.Types.Avail import GHC.Types.Name.Reader import GHC.Types.Var.Env-import GHC.ByteCode.Types-import GHC.Runtime.Linker as Linker-import GHC.Driver.Session-import GHC.LanguageExtensions+import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Types.Unique.Supply-import GHC.Utils.Monad-import GHC.Unit.Module-import GHC.Builtin.Names ( toDynName, pretendNameIsInScope )-import GHC.Builtin.Types ( isCTupleTyConName )-import GHC.Utils.Panic-import GHC.Data.Maybe-import GHC.Utils.Error-import GHC.Types.SrcLoc-import GHC.Runtime.Heap.Inspect-import GHC.Utils.Outputable-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       as Parser (parseStmt, parseModule, parseDeclaration, parseImport)+import GHC.Types.TyThing +import GHC.Unit+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Home.ModInfo+ import System.Directory import Data.Dynamic import Data.Either+import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate)-import Data.Map (Map) import qualified Data.Map as Map-import GHC.Data.StringBuffer (stringToStringBuffer) import Control.Monad import Control.Monad.Catch as MC import Data.Array@@ -196,14 +209,13 @@ execStmt' :: GhcMonad m => GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult execStmt' stmt stmt_text ExecOptions{..} = do     hsc_env <- getSession+    let interp = hscInterp hsc_env      -- Turn off -fwarn-unused-local-binds when running a statement, to hide     -- warnings about the implicit bindings we introduce.-    -- (This is basically `mkInteractiveHscEnv hsc_env`, except we unset-    -- -wwarn-unused-local-binds)     let ic       = hsc_IC hsc_env -- use the interactive dflags         idflags' = ic_dflags ic `wopt_unset` Opt_WarnUnusedLocalBinds-        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' } })+        hsc_env' = mkInteractiveHscEnv (hsc_env{ hsc_IC = ic{ ic_dflags = idflags' }})      r <- liftIO $ hscParsedStmt hsc_env' stmt @@ -217,7 +229,7 @@         status <-           withVirtualCWD $             liftIO $-              evalStmt hsc_env' (isStep execSingleStep) (execWrap hval)+              evalStmt interp idflags' (isStep execSingleStep) (execWrap hval)          let ic = hsc_IC hsc_env             bindings = (ic_tythings ic, ic_rn_gbl_env ic)@@ -270,7 +282,7 @@      -- a virtual CWD is only necessary when we're running interpreted code in     -- the same process as the compiler.-  case hsc_interp hsc_env of+  case interpInstance <$> hsc_interp hsc_env of     Just (ExternalInterp {}) -> m     _ -> do       let ic = hsc_IC hsc_env@@ -311,6 +323,8 @@     , not is_exception     = do        hsc_env <- getSession+       let interp = hscInterp hsc_env+       let dflags = hsc_dflags hsc_env        let hmi = expectJust "handleRunStatus" $                    lookupHptDirectly (hsc_HPT hsc_env)                                      (mkUniqueGrimily mod_uniq)@@ -318,18 +332,18 @@            breaks = getModBreaks hmi         b <- liftIO $-              breakpointStatus hsc_env (modBreaks_flags breaks) ix+              breakpointStatus interp (modBreaks_flags breaks) ix        if b          then not_tracing            -- This breakpoint is explicitly enabled; we want to stop            -- instead of just logging it.          else do-           apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref+           apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref            let bi = BreakInfo modl ix                !history' = mkHistory hsc_env apStack_fhv bi `consBL` history                  -- history is strict, otherwise our BoundedList is pointless.-           fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt-           status <- liftIO $ GHCi.resumeStmt hsc_env True fhv+           fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt+           status <- liftIO $ GHCi.resumeStmt interp dflags True fhv            handleRunStatus RunAndLogSteps expr bindings final_ids                            status history'     | otherwise@@ -340,8 +354,9 @@     | EvalBreak is_exception apStack_ref ix mod_uniq resume_ctxt ccs <- status     = do          hsc_env <- getSession-         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt-         apStack_fhv <- liftIO $ mkFinalizedHValue hsc_env apStack_ref+         let interp = hscInterp hsc_env+         resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt+         apStack_fhv <- liftIO $ mkFinalizedHValue interp apStack_ref          let hmi = expectJust "handleRunStatus" $                      lookupHptDirectly (hsc_HPT hsc_env)                                        (mkUniqueGrimily mod_uniq)@@ -370,8 +385,8 @@     = do hsc_env <- getSession          let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids              final_names = map getName final_ids-             dl = hsc_dynLinker hsc_env-         liftIO $ Linker.extendLinkEnv dl (zip final_names hvals)+             interp = hscInterp hsc_env+         liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)          hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}          setSession hsc_env'          return (ExecComplete (Right final_names) allocs)@@ -386,8 +401,9 @@ #endif  -resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult-resumeExec canLogSpan step+resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> Maybe Int+           -> m ExecResult+resumeExec canLogSpan step mbCnt  = do    hsc_env <- getSession    let ic = hsc_IC hsc_env@@ -412,26 +428,43 @@             new_names = [ n | thing <- ic_tythings ic                             , let n = getName thing                             , not (n `elem` old_names) ]-            dl        = hsc_dynLinker hsc_env-        liftIO $ Linker.deleteFromLinkEnv dl new_names+            interp    = hscInterp hsc_env+            dflags    = hsc_dflags hsc_env+        liftIO $ Loader.deleteFromLoadedEnv interp new_names          case r of           Resume { resumeStmt = expr, resumeContext = fhv                  , resumeBindings = bindings, resumeFinalIds = final_ids                  , resumeApStack = apStack, resumeBreakInfo = mb_brkpt                  , resumeSpan = span-                 , resumeHistory = hist } -> do+                 , resumeHistory = hist } ->                withVirtualCWD $ do-                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv+                when (isJust mb_brkpt && isJust mbCnt) $ do+                  setupBreakpoint hsc_env (fromJust mb_brkpt) (fromJust mbCnt)+                    -- When the user specified a break ignore count, set it+                    -- in the interpreter+                status <- liftIO $ GHCi.resumeStmt interp dflags (isStep step) fhv                 let prevHistoryLst = fromListBL 50 hist                     hist' = case mb_brkpt of                        Nothing -> prevHistoryLst                        Just bi-                         | not $canLogSpan span -> prevHistoryLst+                         | not $ canLogSpan span -> prevHistoryLst                          | otherwise -> mkHistory hsc_env apStack bi `consBL`                                                         fromListBL 50 hist                 handleRunStatus step expr bindings final_ids status hist' +setupBreakpoint :: GhcMonad m => HscEnv -> BreakInfo -> Int -> m ()   -- #19157+setupBreakpoint hsc_env brkInfo cnt = do+  let modl :: Module = breakInfo_module brkInfo+      breaks hsc_env modl = getModBreaks $ expectJust "setupBreakpoint" $+         lookupHpt (hsc_HPT hsc_env) (moduleName modl)+      ix = breakInfo_number brkInfo+      modBreaks  = breaks hsc_env modl+      breakarray = modBreaks_flags modBreaks+      interp = hscInterp hsc_env+  _ <- liftIO $ GHCi.storeBreakpoint interp breakarray ix cnt+  pure ()+ back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String) back n = moveHist (+n) @@ -507,9 +540,9 @@         ictxt0 = hsc_IC hsc_env        ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]-       dl     = hsc_dynLinker hsc_env+       interp = hscInterp hsc_env    ---   Linker.extendLinkEnv dl [(exn_name, apStack)]+   Loader.extendLoadedEnv interp [(exn_name, apStack)]    return (hsc_env{ hsc_IC = ictxt1 }, [exn_name], span, "<exception thrown>")  -- Just case: we stopped at a breakpoint, we have information about the location@@ -518,6 +551,7 @@    let        hmi       = expectJust "bindLocalsAtBreakpoint" $                      lookupHpt (hsc_HPT hsc_env) (moduleName breakInfo_module)+       interp    = hscInterp hsc_env        breaks    = getModBreaks hmi        info      = expectJust "bindLocalsAtBreakpoint2" $                      IntMap.lookup breakInfo_number (modBreaks_breakInfo breaks)@@ -540,9 +574,9 @@    -- So that we don't fall over in a heap when this happens, just don't    -- bind any free variables instead, and we emit a warning.    mb_hValues <--      mapM (getBreakpointVar hsc_env apStack_fhv . fromIntegral) offsets+      mapM (getBreakpointVar interp apStack_fhv . fromIntegral) offsets    when (any isNothing mb_hValues) $-      debugTraceMsg (hsc_dflags hsc_env) 1 $+      debugTraceMsg (hsc_logger hsc_env) (hsc_dflags hsc_env) 1 $           text "Warning: _result has been evaluated, some bindings have been lost"     us <- mkSplitUniqSupply 'I'   -- Dodgy; will give the same uniques every time@@ -564,11 +598,10 @@        ictxt0 = hsc_IC hsc_env        ictxt1 = extendInteractiveContextWithIds ictxt0 final_ids        names  = map idName new_ids-       dl     = hsc_dynLinker hsc_env     let fhvs = catMaybes mb_hValues-   Linker.extendLinkEnv dl (zip names fhvs)-   when result_ok $ Linker.extendLinkEnv dl [(result_name, apStack_fhv)]+   Loader.extendLoadedEnv interp (zip names fhvs)+   when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]    hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }    return (hsc_env1, if result_ok then result_name:names else names, span, decl)   where@@ -614,8 +647,7 @@            [id | id <- tmp_ids                , not $ noSkolems id                , (occNameFS.nameOccName.idName) id /= result_fs]-   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)-   return hsc_env'+   foldM improveTypes hsc_env (map idName incompletelyTypedIds)     where      noSkolems = noFreeVarsOfType . idType      improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do@@ -635,7 +667,8 @@                                            ++ "improvement for a type")) hsc_env                Just subst -> do                  let dflags = hsc_dflags hsc_env-                 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"+                 let logger = hsc_logger hsc_env+                 dumpIfSet_dyn logger dflags Opt_D_dump_rtti "RTTI"                    FormatText                    (fsep [text "RTTI Improvement for", ppr id, equals,                           ppr subst])@@ -664,7 +697,7 @@    There are 3 situations where items are removed from the Id list   (or replaced with `Nothing`):-  1.) If function `GHC.CoreToByteCode.schemeER_wrk` (which creates+  1.) If function `GHC.StgToByteCode.schemeER_wrk` (which creates       the Id list) doesn't find an Id in the ByteCode environement.   2.) If function `GHC.Runtime.Eval.bindLocalsAtBreakpoint`       filters out unboxed elements from the Id list, because GHCi cannot@@ -686,11 +719,12 @@    hsc_env <- getSession    let ic = hsc_IC hsc_env        resume = ic_resume ic+       interp = hscInterp hsc_env    case resume of       []    -> return False       r:rs  -> do          setSession hsc_env{ hsc_IC = ic { ic_resume = rs } }-         liftIO $ abandonStmt hsc_env (resumeContext r)+         liftIO $ abandonStmt interp (resumeContext r)          return True  abandonAll :: GhcMonad m => m Bool@@ -698,11 +732,12 @@    hsc_env <- getSession    let ic = hsc_IC hsc_env        resume = ic_resume ic+       interp = hscInterp hsc_env    case resume of       []  -> return False       rs  -> do          setSession hsc_env{ hsc_IC = ic { ic_resume = [] } }-         liftIO $ mapM_ (abandonStmt hsc_env. resumeContext) rs+         liftIO $ mapM_ (abandonStmt interp. resumeContext) rs          return True  -- -----------------------------------------------------------------------------@@ -771,7 +806,7 @@            (err : _, _)    -> Left err }   where     idecls :: [LImportDecl GhcPs]-    idecls = [noLoc d | IIDecl d <- imports]+    idecls = [noLocA d | IIDecl d <- imports]      imods :: [ModuleName]     imods = [m | IIModule m <- imports]@@ -780,17 +815,6 @@       Left err -> Left (mod, err)       Right env -> Right env -availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv-availsToGlobalRdrEnv mod_name avails-  = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) avails)-  where-      -- We're building a GlobalRdrEnv as if the user imported-      -- all the specified modules into the global interactive module-    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}-    decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name,-                         is_qual = False,-                         is_dloc = srcLocSpan interactiveSrcLoc }- mkTopLevEnv :: HomePackageTable -> ModuleName -> Either String GlobalRdrEnv mkTopLevEnv hpt modl   = case lookupHpt hpt modl of@@ -811,7 +835,7 @@ -- its full top-level scope available. moduleIsInterpreted :: GhcMonad m => Module -> m Bool moduleIsInterpreted modl = withSession $ \h ->- if not (isHomeModule (hsc_dflags h) modl)+ if notHomeModule (hsc_home_unit h) modl         then return False         else case lookupHpt (hsc_HPT h) (moduleName modl) of                 Just details       -> return (isJust (mi_globals (hm_iface details)))@@ -854,8 +878,8 @@  -- | Returns all names in scope in the current interactive context getNamesInScope :: GhcMonad m => m [Name]-getNamesInScope = withSession $ \hsc_env -> do-  return (map gre_name (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))+getNamesInScope = withSession $ \hsc_env ->+  return (map greMangledName (globalRdrEnvElts (ic_rn_gbl_env (hsc_IC hsc_env))))  -- | Returns all 'RdrName's in scope in the current interactive -- context, excluding any that are internally-generated.@@ -876,49 +900,10 @@    do { lrdr_name <- hscParseIdentifier hsc_env str       ; hscTcRnLookupRdrName hsc_env lrdr_name } --- | Returns @True@ if passed string is a statement.-isStmt :: ParserFlags -> 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 pflags stmt =-  case parseThing Parser.parseModule pflags stmt of-    Lexer.POk _ thing -> hasImports thing-    Lexer.PFailed _ -> False-  where-    hasImports = not . null . hsmodImports . unLoc---- | Returns @True@ if passed string is an import declaration.-isImport :: ParserFlags -> 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 pflags stmt = do-  case parseThing Parser.parseDeclaration pflags stmt of-    Lexer.POk _ thing ->-      case unLoc thing of-        SpliceD _ _ -> False-        _ -> True-    Lexer.PFailed _ -> False--parseThing :: Lexer.P thing -> ParserFlags -> String -> Lexer.ParseResult thing-parseThing parser pflags stmt = do-  let buf = stringToStringBuffer stmt-      loc = mkRealSrcLoc (fsLit "<interactive>") 1 1--  Lexer.unP parser (Lexer.mkPStatePure pflags buf loc)- getDocs :: GhcMonad m         => Name-        -> m (Either GetDocsFailure (Maybe HsDocString, Map Int HsDocString))+        -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))            -- TODO: What about docs for constructors etc.? getDocs name =   withSession $ \hsc_env -> do@@ -935,7 +920,7 @@              if isNothing mb_doc_hdr && Map.null dmap && Map.null amap                then pure (Left (NoDocsInIface mod compiled))                else pure (Right ( Map.lookup name dmap-                                , Map.findWithDefault Map.empty name amap))+                                , Map.findWithDefault mempty name amap))   where     compiled =       -- TODO: Find a more direct indicator.@@ -995,7 +980,7 @@  -- | Get the kind of a  type typeKind  :: GhcMonad m => Bool -> String -> m (Type, Kind)-typeKind normalise str = withSession $ \hsc_env -> do+typeKind normalise str = withSession $ \hsc_env ->    liftIO $ hscKcType hsc_env normalise str  -- ----------------------------------------------------------------------------@@ -1046,8 +1031,8 @@  -- Find all instances that match a provided type getInstancesForType :: GhcMonad m => Type -> m [ClsInst]-getInstancesForType ty = withSession $ \hsc_env -> do-  liftIO $ runInteractiveHsc hsc_env $ do+getInstancesForType ty = withSession $ \hsc_env ->+  liftIO $ runInteractiveHsc hsc_env $     ioMsgMaybe $ runTcInteractive hsc_env $ do       -- Bring class and instances from unqualified modules into scope, this fixes #16793.       loadUnqualIfaces hsc_env (hsc_IC hsc_env)@@ -1188,7 +1173,7 @@ -- | Parse an expression, the parsed expression can be further processed and -- passed to compileParsedExpr. parseExpr :: GhcMonad m => String -> m (LHsExpr GhcPs)-parseExpr expr = withSession $ \hsc_env -> do+parseExpr expr = withSession $ \hsc_env ->   liftIO $ runInteractiveHsc hsc_env $ hscParseExpr expr  -- | Compile an expression, run it, and deliver the resulting HValue.@@ -1207,15 +1192,19 @@ -- the resulting HValue. compileParsedExprRemote :: GhcMonad m => LHsExpr GhcPs -> m ForeignHValue compileParsedExprRemote expr@(L loc _) = withSession $ \hsc_env -> do+  let dflags = hsc_dflags hsc_env+  let interp = hscInterp hsc_env+   -- > let _compileParsedExpr = expr   -- Create let stmt from expr to make hscParsedStmt happy.   -- We will ignore the returned [Id], namely [expr_id], and not really   -- create a new binding.   let expr_fs = fsLit "_compileParsedExpr"-      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc-      let_stmt = L loc . LetStmt noExtField . L loc . (HsValBinds noExtField) $-        ValBinds noExtField-                     (unitBag $ mkHsVarBind loc (getRdrName expr_name) expr) []+      loc' = locA loc+      expr_name = mkInternalName (getUnique expr_fs) (mkTyVarOccFS expr_fs) loc'+      let_stmt = L loc . LetStmt noAnn . (HsValBinds noAnn) $+        ValBinds NoAnnSortKey+                     (unitBag $ mkHsVarBind loc' (getRdrName expr_name) expr) []    pstmt <- liftIO $ hscParsedStmt hsc_env let_stmt   let (hvals_io, fix_env) = case pstmt of@@ -1223,7 +1212,7 @@         _ -> panic "compileParsedExprRemote"    updateFixityEnv fix_env-  status <- liftIO $ evalStmt hsc_env False (EvalThis hvals_io)+  status <- liftIO $ evalStmt interp dflags False (EvalThis hvals_io)   case status of     EvalComplete _ (EvalSuccess [hval]) -> return hval     EvalComplete _ (EvalException e) ->@@ -1233,9 +1222,8 @@ compileParsedExpr :: GhcMonad m => LHsExpr GhcPs -> m HValue compileParsedExpr expr = do    fhv <- compileParsedExprRemote expr-   hsc_env <- getSession-   liftIO $ withInterp hsc_env $ \interp ->-      wormhole interp fhv+   interp <- hscInterp <$> getSession+   liftIO $ wormhole interp fhv  -- | Compile an expression, run it and return the result as a Dynamic. dynCompileExpr :: GhcMonad m => String -> m Dynamic@@ -1243,7 +1231,7 @@   parsed_expr <- parseExpr expr   -- > Data.Dynamic.toDyn expr   let loc = getLoc parsed_expr-      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L loc $ getRdrName toDynName)+      to_dyn_expr = mkHsApp (L loc . HsVar noExtField . L (la2na loc) $ getRdrName toDynName)                             parsed_expr   hval <- compileParsedExpr to_dyn_expr   return (unsafeCoerce hval :: Dynamic)@@ -1256,7 +1244,8 @@     withSession $ \hsc_env -> do         interpreted <- moduleIsBootOrNotObjectLinkable mod_summary         let dflags = hsc_dflags hsc_env-        return (showModMsg dflags (hscTarget dflags) interpreted mod_summary)+        -- extendModSummaryNoDeps because the message doesn't look at the deps+        return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode (extendModSummaryNoDeps mod_summary)))  moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->@@ -1271,63 +1260,26 @@  obtainTermFromVal :: HscEnv -> Int -> Bool -> Type -> a -> IO Term #if defined(HAVE_INTERNAL_INTERPRETER)-obtainTermFromVal hsc_env bound force ty x = withInterp hsc_env $ \case+obtainTermFromVal hsc_env bound force ty x = case interpInstance interp of   InternalInterp    -> cvObtainTerm hsc_env bound force ty (unsafeCoerce x) #else-obtainTermFromVal hsc_env _bound _force _ty _x = withInterp hsc_env $ \case+obtainTermFromVal hsc_env _bound _force _ty _x = case interpInstance interp of #endif   ExternalInterp {} -> throwIO (InstallationError                         "this operation requires -fno-external-interpreter")+  where+    interp = hscInterp hsc_env  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]+  hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)+  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) reconstructType hsc_env bound id = do-  hv <- Linker.getHValue hsc_env (varName id)+  hv <- Loader.loadName (hscInterp hsc_env) hsc_env (varName id)   cvReconstructType hsc_env bound (idType id) hv  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.--}

GHC/Runtime/Eval/Types.hs view

@@ -18,9 +18,9 @@ import GHCi.Message (EvalExpr, ResumeContext) import GHC.Types.Id import GHC.Types.Name+import GHC.Types.TyThing import GHC.Unit.Module import GHC.Types.Name.Reader-import GHC.Core.Type import GHC.Types.SrcLoc import GHC.Utils.Exception

GHC/Runtime/Heap/Inspect.hs view

@@ -30,7 +30,7 @@  import GHC.Runtime.Interpreter as GHCi import GHCi.RemoteTypes-import GHC.Driver.Types+import GHC.Driver.Env import GHCi.Message ( fromSerializableException )  import GHC.Core.DataCon@@ -57,7 +57,9 @@ import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Outputable as Ppr+import GHC.Utils.Panic import GHC.Char import GHC.Exts.Heap import GHC.Runtime.Heap.Layout ( roundUpTo )@@ -65,11 +67,11 @@  import Control.Monad import Data.Maybe-import Data.List+import Data.List ((\\)) import GHC.Exts import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..))-import Foreign+import Foreign hiding (shiftL, shiftR) import System.IO.Unsafe  ---------------------------------------------@@ -465,6 +467,10 @@     | t == wordPrimTyCon             = text $ show (build x :: Word)     | t == floatPrimTyCon            = text $ show (build x :: Float)     | t == doublePrimTyCon           = text $ show (build x :: Double)+    | t == int8PrimTyCon             = text $ show (build x :: Int8)+    | t == word8PrimTyCon            = text $ show (build x :: Word8)+    | t == int16PrimTyCon            = text $ show (build x :: Int16)+    | t == word16PrimTyCon           = text $ show (build x :: Word16)     | t == int32PrimTyCon            = text $ show (build x :: Int32)     | t == word32PrimTyCon           = text $ show (build x :: Word32)     | t == int64PrimTyCon            = text $ show (build x :: Int64)@@ -557,12 +563,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.checkTypeEq).+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@@ -576,6 +623,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@@ -583,6 +634,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 ()@@ -678,6 +730,8 @@             text "Type obtained: " <> ppr (termType term))    return term     where+  interp = hscInterp hsc_env+   go :: Int -> Type -> Type -> ForeignHValue -> TcM Term    -- I believe that my_ty should not have any enclosing    -- foralls, nor any free RuntimeUnk skolems;@@ -688,18 +742,18 @@   go 0 my_ty _old_ty a = do     traceTR (text "Gave up reconstructing a term after" <>                   int max_depth <> text " steps")-    clos <- trIO $ GHCi.getClosure hsc_env a+    clos <- trIO $ GHCi.getClosure interp a     return (Suspension (tipe (info clos)) my_ty a Nothing)   go !max_depth my_ty old_ty a = do     let monomorphic = not(isTyVarTy my_ty)     -- This ^^^ is a convention. The ancestor tests for     -- monomorphism and passes a type instead of a tv-    clos <- trIO $ GHCi.getClosure hsc_env a+    clos <- trIO $ GHCi.getClosure interp a     case clos of -- Thunks we may want to force       t | isThunk t && force -> do          traceTR (text "Forcing a " <> text (show (fmap (const ()) t)))-         evalRslt <- liftIO $ GHCi.seqHValue hsc_env a+         evalRslt <- liftIO $ GHCi.seqHValue interp hsc_env a          case evalRslt of                                            -- #2950            EvalSuccess _ -> go (pred max_depth) my_ty old_ty a            EvalException ex -> do@@ -712,7 +766,7 @@ -- of entering the TSO or BLOCKING_QUEUE (which leads to runtime panic).       BlackholeClosure{indirectee=ind} -> do          traceTR (text "Following a BLACKHOLE")-         ind_clos <- trIO (GHCi.getClosure hsc_env ind)+         ind_clos <- trIO (GHCi.getClosure interp ind)          let return_bh_value = return (Suspension BLACKHOLE my_ty a Nothing)          case ind_clos of            -- TSO and BLOCKING_QUEUE cases@@ -943,6 +997,8 @@    traceTR (text "RTTI completed. Type obtained:" <+> ppr new_ty)    return new_ty     where+  interp = hscInterp hsc_env+ --  search :: m Bool -> ([a] -> [a] -> [a]) -> [a] -> m ()   search _ _ _ 0 = traceTR (text "Failed to reconstruct a type after " <>                                 int max_depth <> text " steps")@@ -957,7 +1013,7 @@   go :: Type -> ForeignHValue -> TR [(Type, ForeignHValue)]   go my_ty a = do     traceTR (text "go" <+> ppr my_ty)-    clos <- trIO $ GHCi.getClosure hsc_env a+    clos <- trIO $ GHCi.getClosure interp a     case clos of       BlackholeClosure{indirectee=ind} -> go my_ty ind       IndClosure{indirectee=ind} -> go my_ty ind@@ -971,7 +1027,7 @@         traceTR (text "Constr1" <+> ppr dcname)         (mb_dc, _) <- tryTc (tcLookupDataCon dcname)         case mb_dc of-          Nothing-> do+          Nothing->             forM pArgs $ \x -> do               tv <- newVar liftedTypeKind               return (tv, x)@@ -1341,4 +1397,4 @@                     tyCoVarsOfTypeWellScoped rho                   , rho)   where-    (_tvs, rho) = tcSplitForAllTys ty+    (_tvs, rho) = tcSplitForAllInvisTyVars ty

GHC/Runtime/Heap/Layout.hs view

@@ -48,13 +48,15 @@  import GHC.Types.Basic( ConTagZ ) import GHC.Driver.Session-import GHC.Utils.Outputable import GHC.Platform+import GHC.Platform.Profile import GHC.Data.FastString import GHC.StgToCmm.Types +import GHC.Utils.Outputable+import GHC.Utils.Panic+ import Data.Word-import Data.Bits import Data.ByteString (ByteString)  {-@@ -197,9 +199,9 @@ ----------------------------------------------------------------------------- -- Construction -mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo+mkHeapRep :: Profile -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo           -> SMRep-mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info+mkHeapRep profile is_static ptr_wds nonptr_wds cl_type_info   = HeapRep is_static             ptr_wds             (nonptr_wds + slop_wds)@@ -207,9 +209,9 @@   where      slop_wds       | is_static = 0-      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))+      | otherwise = max 0 (minClosureSize profile - (hdr_size + payload_size)) -     hdr_size     = closureTypeHdrSize dflags cl_type_info+     hdr_size     = closureTypeHdrSize profile cl_type_info      payload_size = ptr_wds + nonptr_wds  mkRTSRep :: Int -> SMRep -> SMRep@@ -224,8 +226,8 @@ indStaticRep :: SMRep indStaticRep = HeapRep True 1 0 IndStatic -arrPtrsRep :: DynFlags -> WordOff -> SMRep-arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)+arrPtrsRep :: Platform -> WordOff -> SMRep+arrPtrsRep platform elems = ArrayPtrsRep elems (cardTableSizeW platform elems)  smallArrPtrsRep :: WordOff -> SMRep smallArrPtrsRep elems = SmallArrayPtrsRep elems@@ -271,71 +273,79 @@ ----------------------------------------------------------------------------- -- Size-related things -fixedHdrSize :: DynFlags -> ByteOff-fixedHdrSize dflags = wordsToBytes (targetPlatform dflags) (fixedHdrSizeW dflags)+fixedHdrSize :: Profile -> ByteOff+fixedHdrSize profile = wordsToBytes (profilePlatform profile) (fixedHdrSizeW profile)  -- | Size of a closure header (StgHeader in includes\/rts\/storage\/Closures.h)-fixedHdrSizeW :: DynFlags -> WordOff-fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags+fixedHdrSizeW :: Profile -> WordOff+fixedHdrSizeW profile = pc_STD_HDR_SIZE (profileConstants profile) + profHdrSize profile  -- | Size of the profiling part of a closure header -- (StgProfHeader in includes\/rts\/storage\/Closures.h)-profHdrSize  :: DynFlags -> WordOff-profHdrSize dflags- | sccProfilingEnabled dflags = pROF_HDR_SIZE dflags- | otherwise                  = 0+profHdrSize :: Profile -> WordOff+profHdrSize profile =+   if profileIsProfiling profile+      then pc_PROF_HDR_SIZE (profileConstants profile)+      else 0  -- | The garbage collector requires that every closure is at least as --   big as this.-minClosureSize :: DynFlags -> WordOff-minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags+minClosureSize :: Profile -> WordOff+minClosureSize profile+ = fixedHdrSizeW profile+   + pc_MIN_PAYLOAD_SIZE (profileConstants profile) -arrWordsHdrSize :: DynFlags -> ByteOff-arrWordsHdrSize dflags- = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags+arrWordsHdrSize :: Profile -> ByteOff+arrWordsHdrSize profile+ = fixedHdrSize profile+   + pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) -arrWordsHdrSizeW :: DynFlags -> WordOff-arrWordsHdrSizeW dflags =-    fixedHdrSizeW dflags +-    (sIZEOF_StgArrBytes_NoHdr dflags `quot`-      platformWordSizeInBytes (targetPlatform dflags))+arrWordsHdrSizeW :: Profile -> WordOff+arrWordsHdrSizeW profile+ = fixedHdrSizeW profile+   + (pc_SIZEOF_StgArrBytes_NoHdr (profileConstants profile) `quot`+      platformWordSizeInBytes (profilePlatform profile)) -arrPtrsHdrSize :: DynFlags -> ByteOff-arrPtrsHdrSize dflags- = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags+arrPtrsHdrSize :: Profile -> ByteOff+arrPtrsHdrSize profile+ = fixedHdrSize profile+   + pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) -arrPtrsHdrSizeW :: DynFlags -> WordOff-arrPtrsHdrSizeW dflags =-    fixedHdrSizeW dflags +-    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot`-      platformWordSizeInBytes (targetPlatform dflags))+arrPtrsHdrSizeW :: Profile -> WordOff+arrPtrsHdrSizeW profile+ = fixedHdrSizeW profile+   + (pc_SIZEOF_StgMutArrPtrs_NoHdr (profileConstants profile) `quot`+      platformWordSizeInBytes (profilePlatform profile)) -smallArrPtrsHdrSize :: DynFlags -> ByteOff-smallArrPtrsHdrSize dflags- = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags+smallArrPtrsHdrSize :: Profile -> ByteOff+smallArrPtrsHdrSize profile+ = fixedHdrSize profile+   + pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) -smallArrPtrsHdrSizeW :: DynFlags -> WordOff-smallArrPtrsHdrSizeW dflags =-    fixedHdrSizeW dflags +-    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot`-      platformWordSizeInBytes (targetPlatform dflags))+smallArrPtrsHdrSizeW :: Profile -> WordOff+smallArrPtrsHdrSizeW profile+ = fixedHdrSizeW profile+   + (pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (profileConstants profile) `quot`+      platformWordSizeInBytes (profilePlatform profile))  -- Thunks have an extra header word on SMP, so the update doesn't -- splat the payload.-thunkHdrSize :: DynFlags -> WordOff-thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr-        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot`-                         platformWordSizeInBytes (targetPlatform dflags)+thunkHdrSize :: Profile -> WordOff+thunkHdrSize profile = fixedHdrSizeW profile + smp_hdr+        where+         platform = profilePlatform profile+         smp_hdr  = pc_SIZEOF_StgSMPThunkHeader (platformConstants platform) `quot`+                         platformWordSizeInBytes platform -hdrSize :: DynFlags -> SMRep -> ByteOff-hdrSize dflags rep = wordsToBytes (targetPlatform dflags) (hdrSizeW dflags rep)+hdrSize :: Profile -> SMRep -> ByteOff+hdrSize profile rep = wordsToBytes (profilePlatform profile) (hdrSizeW profile rep) -hdrSizeW :: DynFlags -> SMRep -> WordOff-hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty-hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags-hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags-hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags-hdrSizeW _ _                          = panic "SMRep.hdrSizeW"+hdrSizeW :: Profile -> SMRep -> WordOff+hdrSizeW profile (HeapRep _ _ _ ty)    = closureTypeHdrSize profile ty+hdrSizeW profile (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW profile+hdrSizeW profile (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW profile+hdrSizeW profile (ArrayWordsRep _)     = arrWordsHdrSizeW profile+hdrSizeW _ _                           = panic "GHC.Runtime.Heap.Layout.hdrSizeW"  nonHdrSize :: Platform -> SMRep -> ByteOff nonHdrSize platform rep = wordsToBytes platform (nonHdrSizeW rep)@@ -349,24 +359,21 @@ nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep  -- | The total size of the closure, in words.-heapClosureSizeW :: DynFlags -> SMRep -> WordOff-heapClosureSizeW dflags (HeapRep _ p np ty)- = closureTypeHdrSize dflags ty + p + np-heapClosureSizeW dflags (ArrayPtrsRep elems ct)- = arrPtrsHdrSizeW dflags + elems + ct-heapClosureSizeW dflags (SmallArrayPtrsRep elems)- = smallArrPtrsHdrSizeW dflags + elems-heapClosureSizeW dflags (ArrayWordsRep words)- = arrWordsHdrSizeW dflags + words-heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"+heapClosureSizeW :: Profile -> SMRep -> WordOff+heapClosureSizeW profile rep = case rep of+   HeapRep _ p np ty       -> closureTypeHdrSize profile ty + p + np+   ArrayPtrsRep elems ct   -> arrPtrsHdrSizeW profile + elems + ct+   SmallArrayPtrsRep elems -> smallArrPtrsHdrSizeW profile + elems+   ArrayWordsRep words     -> arrWordsHdrSizeW profile + words+   _                       -> panic "GHC.Runtime.Heap.Layout.heapClosureSize" -closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff-closureTypeHdrSize dflags ty = case ty of-                  Thunk           -> thunkHdrSize dflags-                  ThunkSelector{} -> thunkHdrSize dflags-                  BlackHole       -> thunkHdrSize dflags-                  IndStatic       -> thunkHdrSize dflags-                  _               -> fixedHdrSizeW dflags+closureTypeHdrSize :: Profile -> ClosureTypeInfo -> WordOff+closureTypeHdrSize profile ty = case ty of+                  Thunk           -> thunkHdrSize profile+                  ThunkSelector{} -> thunkHdrSize profile+                  BlackHole       -> thunkHdrSize profile+                  IndStatic       -> thunkHdrSize profile+                  _               -> fixedHdrSizeW profile         -- All thunks use thunkHdrSize, even if they are non-updatable.         -- this is because we don't have separate closure types for         -- updatable vs. non-updatable thunks, so the GC can't tell the@@ -377,23 +384,22 @@ -- Arrays  -- | The byte offset into the card table of the card for a given element-card :: DynFlags -> Int -> Int-card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags+card :: Platform -> Int -> Int+card platform i = i `shiftR` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)  -- | Convert a number of elements to a number of cards, rounding up-cardRoundUp :: DynFlags -> Int -> Int-cardRoundUp dflags i =-  card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))+cardRoundUp :: Platform -> Int -> Int+cardRoundUp platform i =+  card platform (i + ((1 `shiftL` pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)) - 1))  -- | The size of a card table, in bytes-cardTableSizeB :: DynFlags -> Int -> ByteOff-cardTableSizeB dflags elems = cardRoundUp dflags elems+cardTableSizeB :: Platform -> Int -> ByteOff+cardTableSizeB platform elems = cardRoundUp platform elems  -- | The size of a card table, in words-cardTableSizeW :: DynFlags -> Int -> WordOff-cardTableSizeW dflags elems =-  bytesToWordsRoundUp (targetPlatform dflags)-                      (cardTableSizeB dflags elems)+cardTableSizeW :: Platform -> Int -> WordOff+cardTableSizeW platform elems =+  bytesToWordsRoundUp platform (cardTableSizeB platform elems)  ----------------------------------------------------------------------------- -- deriving the RTS closure type from an SMRep

GHC/Runtime/Interpreter.hs view

@@ -6,8 +6,10 @@ -- external process or in the current process. -- module GHC.Runtime.Interpreter-  ( -- * High-level interface to the interpreter-    evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)+  ( module GHC.Runtime.Interpreter.Types++  -- * High-level interface to the interpreter+  , evalStmt, EvalStatus_(..), EvalStatus, EvalResult(..), EvalExpr(..)   , resumeStmt   , abandonStmt   , evalIO@@ -19,7 +21,7 @@   , mkCostCentres   , costCentreStackInfo   , newBreakArray-  , enableBreakpoint+  , storeBreakpoint   , breakpointStatus   , getBreakpointVar   , getClosure@@ -42,8 +44,8 @@   , findSystemLibrary    -- * Lower-level API using messages-  , iservCmd, Message(..), withIServ, withIServ_-  , withInterp, hscInterp, stopInterp+  , interpCmd, Message(..), withIServ, withIServ_+  , hscInterp, stopInterp   , iservCall, readIServ, writeIServ   , purgeLookupSymbolCache   , freeHValueRefs@@ -55,31 +57,41 @@  import GHC.Prelude +import GHC.Driver.Ppr (showSDoc)+import GHC.Driver.Env+import GHC.Driver.Session+ import GHC.Runtime.Interpreter.Types import GHCi.Message import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray)-import GHC.Utils.Fingerprint-import GHC.Driver.Types+import GHC.Runtime.Eval.Types(BreakInfo(..))+import GHC.ByteCode.Types++import GHC.Linker.Types++import GHC.Data.Maybe+import GHC.Data.FastString++import GHC.Types.Unique+import GHC.Types.SrcLoc import GHC.Types.Unique.FM+import GHC.Types.Basic+ import GHC.Utils.Panic-import GHC.Driver.Session import GHC.Utils.Exception as Ex-import GHC.Types.Basic-import GHC.Data.FastString+import GHC.Utils.Outputable(brackets, ppr)+import GHC.Utils.Fingerprint import GHC.Utils.Misc-import GHC.Runtime.Eval.Types(BreakInfo(..))-import GHC.Utils.Outputable(brackets, ppr, showSDocUnqual)-import GHC.Types.SrcLoc-import GHC.Data.Maybe+ import GHC.Unit.Module-import GHC.ByteCode.Types-import GHC.Types.Unique+import GHC.Unit.Module.ModIface+import GHC.Unit.Home.ModInfo  #if defined(HAVE_INTERNAL_INTERPRETER) import GHCi.Run-import GHC.Driver.Ways+import GHC.Platform.Ways #endif  import Control.Concurrent@@ -93,7 +105,7 @@ import Data.Array ((!)) import Data.IORef import Foreign hiding (void)-import GHC.Exts.Heap+import qualified GHC.Exts.Heap as Heap import GHC.Stack.CCS (CostCentre,CostCentreStack) import System.Exit import GHC.IO.Handle.Types (Handle)@@ -176,23 +188,17 @@ -- external iserv process, and the response is deserialized (hence the -- @Binary@ constraint).  With @-fno-external-interpreter@ we execute -- the command directly here.-iservCmd :: Binary a => HscEnv -> Message a -> IO a-iservCmd hsc_env msg = withInterp hsc_env $ \case+interpCmd :: Binary a => Interp -> Message a -> IO a+interpCmd interp msg = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)   InternalInterp     -> run msg -- Just run it directly #endif-  (ExternalInterp c i) -> withIServ_ c i $ \iserv ->-    uninterruptibleMask_ $ do -- Note [uninterruptibleMask_]+  ExternalInterp c i -> withIServ_ c i $ \iserv ->+    uninterruptibleMask_ $ -- Note [uninterruptibleMask_]       iservCall iserv msg  --- | Execute an action with the interpreter------ Fails if no target code interpreter is available-withInterp :: HscEnv -> (Interp -> IO a) -> IO a-withInterp hsc_env action = action (hscInterp hsc_env)---- | Retreive the targe code interpreter+-- | Retrieve the target code interpreter -- -- Fails if no target code interpreter is available hscInterp :: HscEnv -> Interp@@ -200,7 +206,7 @@    Nothing -> throw (InstallationError "Couldn't find a target code interpreter. Try with -fexternal-interpreter")    Just i  -> i --- Note [uninterruptibleMask_ and iservCmd]+-- Note [uninterruptibleMask_ and interpCmd] -- -- If we receive an async exception, such as ^C, while communicating -- with the iserv process then we will be out-of-sync and not be able@@ -214,7 +220,7 @@ withIServ   :: (ExceptionMonad m)   => IServConfig -> IServ -> (IServInstance -> m (IServInstance, a)) -> m a-withIServ conf (IServ mIServState) action = do+withIServ conf (IServ mIServState) action =   MC.mask $ \restore -> do     state <- liftIO $ takeMVar mIServState @@ -251,13 +257,15 @@ -- | Execute an action of type @IO [a]@, returning 'ForeignHValue's for -- each of the results. evalStmt-  :: HscEnv -> Bool -> EvalExpr ForeignHValue+  :: Interp+  -> DynFlags -- used by mkEvalOpts+  -> Bool     -- "step" for mkEvalOpts+  -> EvalExpr ForeignHValue   -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-evalStmt hsc_env step foreign_expr = do-  let dflags = hsc_dflags hsc_env+evalStmt interp dflags step foreign_expr = do   status <- withExpr foreign_expr $ \expr ->-    iservCmd hsc_env (EvalStmt (mkEvalOpts dflags step) expr)-  handleEvalStatus hsc_env status+    interpCmd interp (EvalStmt (mkEvalOpts dflags step) expr)+  handleEvalStatus interp status  where   withExpr :: EvalExpr ForeignHValue -> (EvalExpr HValueRef -> IO a) -> IO a   withExpr (EvalThis fhv) cont =@@ -268,72 +276,74 @@     cont (EvalApp fl' fr')  resumeStmt-  :: HscEnv -> Bool -> ForeignRef (ResumeContext [HValueRef])+  :: Interp+  -> DynFlags -- used by mkEvalOpts+  -> Bool     -- "step" for mkEvalOpts+  -> ForeignRef (ResumeContext [HValueRef])   -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-resumeStmt hsc_env step resume_ctxt = do-  let dflags = hsc_dflags hsc_env+resumeStmt interp dflags step resume_ctxt = do   status <- withForeignRef resume_ctxt $ \rhv ->-    iservCmd hsc_env (ResumeStmt (mkEvalOpts dflags step) rhv)-  handleEvalStatus hsc_env status+    interpCmd interp (ResumeStmt (mkEvalOpts dflags step) rhv)+  handleEvalStatus interp status -abandonStmt :: HscEnv -> ForeignRef (ResumeContext [HValueRef]) -> IO ()-abandonStmt hsc_env resume_ctxt = do+abandonStmt :: Interp -> ForeignRef (ResumeContext [HValueRef]) -> IO ()+abandonStmt interp resume_ctxt =   withForeignRef resume_ctxt $ \rhv ->-    iservCmd hsc_env (AbandonStmt rhv)+    interpCmd interp (AbandonStmt rhv)  handleEvalStatus-  :: HscEnv -> EvalStatus [HValueRef]+  :: Interp+  -> EvalStatus [HValueRef]   -> IO (EvalStatus_ [ForeignHValue] [HValueRef])-handleEvalStatus hsc_env status =+handleEvalStatus interp status =   case status of     EvalBreak a b c d e f -> return (EvalBreak a b c d e f)     EvalComplete alloc res ->       EvalComplete alloc <$> addFinalizer res  where   addFinalizer (EvalException e) = return (EvalException e)-  addFinalizer (EvalSuccess rs) = do-    EvalSuccess <$> mapM (mkFinalizedHValue hsc_env) rs+  addFinalizer (EvalSuccess rs)  =+    EvalSuccess <$> mapM (mkFinalizedHValue interp) rs  -- | Execute an action of type @IO ()@-evalIO :: HscEnv -> ForeignHValue -> IO ()-evalIO hsc_env fhv = do+evalIO :: Interp -> ForeignHValue -> IO ()+evalIO interp fhv =   liftIO $ withForeignRef fhv $ \fhv ->-    iservCmd hsc_env (EvalIO fhv) >>= fromEvalResult+    interpCmd interp (EvalIO fhv) >>= fromEvalResult  -- | Execute an action of type @IO String@-evalString :: HscEnv -> ForeignHValue -> IO String-evalString hsc_env fhv = do+evalString :: Interp -> ForeignHValue -> IO String+evalString interp fhv =   liftIO $ withForeignRef fhv $ \fhv ->-    iservCmd hsc_env (EvalString fhv) >>= fromEvalResult+    interpCmd interp (EvalString fhv) >>= fromEvalResult  -- | Execute an action of type @String -> IO String@-evalStringToIOString :: HscEnv -> ForeignHValue -> String -> IO String-evalStringToIOString hsc_env fhv str = do+evalStringToIOString :: Interp -> ForeignHValue -> String -> IO String+evalStringToIOString interp fhv str =   liftIO $ withForeignRef fhv $ \fhv ->-    iservCmd hsc_env (EvalStringToString fhv str) >>= fromEvalResult+    interpCmd interp (EvalStringToString fhv str) >>= fromEvalResult   -- | Allocate and store the given bytes in memory, returning a pointer -- to the memory in the remote process.-mallocData :: HscEnv -> ByteString -> IO (RemotePtr ())-mallocData hsc_env bs = iservCmd hsc_env (MallocData bs)+mallocData :: Interp -> ByteString -> IO (RemotePtr ())+mallocData interp bs = interpCmd interp (MallocData bs) -mkCostCentres-  :: HscEnv -> String -> [(String,String)] -> IO [RemotePtr CostCentre]-mkCostCentres hsc_env mod ccs =-  iservCmd hsc_env (MkCostCentres mod ccs)+mkCostCentres :: Interp -> String -> [(String,String)] -> IO [RemotePtr CostCentre]+mkCostCentres interp mod ccs =+  interpCmd interp (MkCostCentres mod ccs)  -- | Create a set of BCOs that may be mutually recursive.-createBCOs :: HscEnv -> [ResolvedBCO] -> IO [HValueRef]-createBCOs hsc_env rbcos = do-  n_jobs <- case parMakeCount (hsc_dflags hsc_env) of+createBCOs :: Interp -> DynFlags -> [ResolvedBCO] -> IO [HValueRef]+createBCOs interp dflags rbcos = do+  n_jobs <- case parMakeCount dflags of               Nothing -> liftIO getNumProcessors               Just n  -> return n   -- Serializing ResolvedBCO is expensive, so if we're in parallel mode   -- (-j<n>) parallelise the serialization.   if (n_jobs == 1)     then-      iservCmd hsc_env (CreateBCOs [runPut (put rbcos)])+      interpCmd interp (CreateBCOs [runPut (put rbcos)])      else do       old_caps <- getNumCapabilities@@ -342,7 +352,7 @@          else bracket_ (setNumCapabilities n_jobs)                        (setNumCapabilities old_caps)                        (void $ evaluate puts)-      iservCmd hsc_env (CreateBCOs puts)+      interpCmd interp (CreateBCOs puts)  where   puts = parMap doChunk (chunkList 100 rbcos) @@ -355,56 +365,57 @@   parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))     where fx = f x; fxs = parMap f xs -addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO ()-addSptEntry hsc_env fpr ref =+addSptEntry :: Interp -> Fingerprint -> ForeignHValue -> IO ()+addSptEntry interp fpr ref =   withForeignRef ref $ \val ->-    iservCmd hsc_env (AddSptEntry fpr val)+    interpCmd interp (AddSptEntry fpr val) -costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String]-costCentreStackInfo hsc_env ccs =-  iservCmd hsc_env (CostCentreStackInfo ccs)+costCentreStackInfo :: Interp -> RemotePtr CostCentreStack -> IO [String]+costCentreStackInfo interp ccs =+  interpCmd interp (CostCentreStackInfo ccs) -newBreakArray :: HscEnv -> Int -> IO (ForeignRef BreakArray)-newBreakArray hsc_env size = do-  breakArray <- iservCmd hsc_env (NewBreakArray size)-  mkFinalizedHValue hsc_env breakArray+newBreakArray :: Interp -> Int -> IO (ForeignRef BreakArray)+newBreakArray interp size = do+  breakArray <- interpCmd interp (NewBreakArray size)+  mkFinalizedHValue interp breakArray -enableBreakpoint :: HscEnv -> ForeignRef BreakArray -> Int -> Bool -> IO ()-enableBreakpoint hsc_env ref ix b = do+storeBreakpoint :: Interp -> ForeignRef BreakArray -> Int -> Int -> IO ()+storeBreakpoint interp ref ix cnt = do                               -- #19157   withForeignRef ref $ \breakarray ->-    iservCmd hsc_env (EnableBreakpoint breakarray ix b)+    interpCmd interp (SetupBreakpoint breakarray ix cnt) -breakpointStatus :: HscEnv -> ForeignRef BreakArray -> Int -> IO Bool-breakpointStatus hsc_env ref ix = do+breakpointStatus :: Interp -> ForeignRef BreakArray -> Int -> IO Bool+breakpointStatus interp ref ix =   withForeignRef ref $ \breakarray ->-    iservCmd hsc_env (BreakpointStatus breakarray ix)+    interpCmd interp (BreakpointStatus breakarray ix) -getBreakpointVar :: HscEnv -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)-getBreakpointVar hsc_env ref ix =+getBreakpointVar :: Interp -> ForeignHValue -> Int -> IO (Maybe ForeignHValue)+getBreakpointVar interp ref ix =   withForeignRef ref $ \apStack -> do-    mb <- iservCmd hsc_env (GetBreakpointVar apStack ix)-    mapM (mkFinalizedHValue hsc_env) mb+    mb <- interpCmd interp (GetBreakpointVar apStack ix)+    mapM (mkFinalizedHValue interp) mb -getClosure :: HscEnv -> ForeignHValue -> IO (GenClosure ForeignHValue)-getClosure hsc_env ref =+getClosure :: Interp -> ForeignHValue -> IO (Heap.GenClosure ForeignHValue)+getClosure interp ref =   withForeignRef ref $ \hval -> do-    mb <- iservCmd hsc_env (GetClosure hval)-    mapM (mkFinalizedHValue hsc_env) mb+    mb <- interpCmd interp (GetClosure hval)+    mapM (mkFinalizedHValue interp) mb  -- | Send a Seq message to the iserv process to force a value      #2950-seqHValue :: HscEnv -> ForeignHValue -> IO (EvalResult ())-seqHValue hsc_env ref =-  withForeignRef ref $ \hval ->-    iservCmd hsc_env (Seq hval) >>= handleSeqHValueStatus hsc_env+seqHValue :: Interp -> HscEnv -> ForeignHValue -> IO (EvalResult ())+seqHValue interp hsc_env ref =+  withForeignRef ref $ \hval -> do+    status <- interpCmd interp (Seq hval)+    handleSeqHValueStatus interp hsc_env status  -- | Process the result of a Seq or ResumeSeq message.             #2950-handleSeqHValueStatus :: HscEnv -> EvalStatus () -> IO (EvalResult ())-handleSeqHValueStatus hsc_env eval_status = do+handleSeqHValueStatus :: Interp -> HscEnv -> EvalStatus () -> IO (EvalResult ())+handleSeqHValueStatus interp hsc_env eval_status =   case eval_status of     (EvalBreak is_exception _ ix mod_uniq resume_ctxt _) -> do-      -- A breakpoint was hit, inform the user and tell him+      -- A breakpoint was hit; inform the user and tell them       -- which breakpoint was hit.-      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue hsc_env resume_ctxt+      resume_ctxt_fhv <- liftIO $ mkFinalizedHValue interp resume_ctxt       let hmi = expectJust "handleRunStatus" $                   lookupHptDirectly (hsc_HPT hsc_env)                     (mkUniqueGrimily mod_uniq)@@ -413,10 +424,11 @@              | otherwise = Just (BreakInfo modl ix)           sdocBpLoc = brackets . ppr . getSeqBpSpan       putStrLn ("*** Ignoring breakpoint " ++-            (showSDocUnqual (hsc_dflags hsc_env) $ sdocBpLoc bp))+            (showSDoc (hsc_dflags hsc_env) $ sdocBpLoc bp))       -- resume the seq (:force) processing in the iserv process-      withForeignRef resume_ctxt_fhv $ \hval ->-        iservCmd hsc_env (ResumeSeq hval) >>= handleSeqHValueStatus hsc_env+      withForeignRef resume_ctxt_fhv $ \hval -> do+        status <- interpCmd interp (ResumeSeq hval)+        handleSeqHValueStatus interp hsc_env status     (EvalComplete _ r) -> return r   where     getSeqBpSpan :: Maybe BreakInfo -> SrcSpan@@ -434,11 +446,11 @@ -- ----------------------------------------------------------------------------- -- Interface to the object-code linker -initObjLinker :: HscEnv -> IO ()-initObjLinker hsc_env = iservCmd hsc_env InitLinker+initObjLinker :: Interp -> IO ()+initObjLinker interp = interpCmd interp InitLinker -lookupSymbol :: HscEnv -> FastString -> IO (Maybe (Ptr ()))-lookupSymbol hsc_env str = withInterp hsc_env $ \case+lookupSymbol :: Interp -> FastString -> IO (Maybe (Ptr ()))+lookupSymbol interp str = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)   InternalInterp -> fmap fromRemotePtr <$> run (LookupSymbol (unpackFS str)) #endif@@ -462,17 +474,16 @@                 iserv' = iserv {iservLookupSymbolCache = cache'}             return (iserv', Just p) -lookupClosure :: HscEnv -> String -> IO (Maybe HValueRef)-lookupClosure hsc_env str =-  iservCmd hsc_env (LookupClosure str)+lookupClosure :: Interp -> String -> IO (Maybe HValueRef)+lookupClosure interp str =+  interpCmd interp (LookupClosure str) -purgeLookupSymbolCache :: HscEnv -> IO ()-purgeLookupSymbolCache hsc_env = case hsc_interp hsc_env of-  Nothing             -> pure ()+purgeLookupSymbolCache :: Interp -> IO ()+purgeLookupSymbolCache interp = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-  Just InternalInterp -> pure ()+  InternalInterp -> pure () #endif-  Just (ExternalInterp _ (IServ mstate)) ->+  ExternalInterp _ (IServ mstate) ->     modifyMVar_ mstate $ \state -> pure $ case state of       IServPending       -> state       IServRunning iserv -> IServRunning@@ -489,42 +500,42 @@ -- -- Nothing      => success -- Just err_msg => failure-loadDLL :: HscEnv -> String -> IO (Maybe String)-loadDLL hsc_env str = iservCmd hsc_env (LoadDLL str)+loadDLL :: Interp -> String -> IO (Maybe String)+loadDLL interp str = interpCmd interp (LoadDLL str) -loadArchive :: HscEnv -> String -> IO ()-loadArchive hsc_env path = do+loadArchive :: Interp -> String -> IO ()+loadArchive interp path = do   path' <- canonicalizePath path -- Note [loadObj and relative paths]-  iservCmd hsc_env (LoadArchive path')+  interpCmd interp (LoadArchive path') -loadObj :: HscEnv -> String -> IO ()-loadObj hsc_env path = do+loadObj :: Interp -> String -> IO ()+loadObj interp path = do   path' <- canonicalizePath path -- Note [loadObj and relative paths]-  iservCmd hsc_env (LoadObj path')+  interpCmd interp (LoadObj path') -unloadObj :: HscEnv -> String -> IO ()-unloadObj hsc_env path = do+unloadObj :: Interp -> String -> IO ()+unloadObj interp path = do   path' <- canonicalizePath path -- Note [loadObj and relative paths]-  iservCmd hsc_env (UnloadObj path')+  interpCmd interp (UnloadObj path')  -- Note [loadObj and relative paths] -- the iserv process might have a different current directory from the -- GHC process, so we must make paths absolute before sending them -- over. -addLibrarySearchPath :: HscEnv -> String -> IO (Ptr ())-addLibrarySearchPath hsc_env str =-  fromRemotePtr <$> iservCmd hsc_env (AddLibrarySearchPath str)+addLibrarySearchPath :: Interp -> String -> IO (Ptr ())+addLibrarySearchPath interp str =+  fromRemotePtr <$> interpCmd interp (AddLibrarySearchPath str) -removeLibrarySearchPath :: HscEnv -> Ptr () -> IO Bool-removeLibrarySearchPath hsc_env p =-  iservCmd hsc_env (RemoveLibrarySearchPath (toRemotePtr p))+removeLibrarySearchPath :: Interp -> Ptr () -> IO Bool+removeLibrarySearchPath interp p =+  interpCmd interp (RemoveLibrarySearchPath (toRemotePtr p)) -resolveObjs :: HscEnv -> IO SuccessFlag-resolveObjs hsc_env = successIf <$> iservCmd hsc_env ResolveObjs+resolveObjs :: Interp -> IO SuccessFlag+resolveObjs interp = successIf <$> interpCmd interp ResolveObjs -findSystemLibrary :: HscEnv -> String -> IO (Maybe String)-findSystemLibrary hsc_env str = iservCmd hsc_env (FindSystemLibrary str)+findSystemLibrary :: Interp -> String -> IO (Maybe String)+findSystemLibrary interp str = interpCmd interp (FindSystemLibrary str)   -- -----------------------------------------------------------------------------@@ -578,22 +589,21 @@     }  -- | Stop the interpreter-stopInterp :: HscEnv -> IO ()-stopInterp hsc_env = case hsc_interp hsc_env of-  Nothing             -> pure ()+stopInterp :: Interp -> IO ()+stopInterp interp = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-  Just InternalInterp -> pure ()+    InternalInterp -> pure () #endif-  Just (ExternalInterp _ (IServ mstate)) ->-    MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do-      case state of-        IServPending    -> pure state -- already stopped-        IServRunning i  -> do-          ex <- getProcessExitCode (iservProcess i)-          if isJust ex-             then pure ()-             else iservCall i Shutdown-          pure IServPending+    ExternalInterp _ (IServ mstate) ->+      MC.mask $ \_restore -> modifyMVar_ mstate $ \state -> do+        case state of+          IServPending    -> pure state -- already stopped+          IServRunning i  -> do+            ex <- getProcessExitCode (iservProcess i)+            if isJust ex+               then pure ()+               else iservCall i Shutdown+            pure IServPending  runWithPipes :: (CreateProcess -> IO ProcessHandle)              -> FilePath -> [String] -> IO (ProcessHandle, Handle, Handle)@@ -666,24 +676,23 @@ on the GHC side.  The finalizer adds the RemoteRef to the iservPendingFrees list in the-IServ record.  The next call to iservCmd will free any RemoteRefs in-the list.  It was done this way rather than calling iservCmd directly,-because I didn't want to have arbitrary threads calling iservCmd.  In+IServ record.  The next call to interpCmd will free any RemoteRefs in+the list.  It was done this way rather than calling interpCmd directly,+because I didn't want to have arbitrary threads calling interpCmd.  In principle it would probably be ok, but it seems less hairy this way. -}  -- | Creates a 'ForeignRef' that will automatically release the -- 'RemoteRef' when it is no longer referenced.-mkFinalizedHValue :: HscEnv -> RemoteRef a -> IO (ForeignRef a)-mkFinalizedHValue hsc_env rref = do+mkFinalizedHValue :: Interp -> RemoteRef a -> IO (ForeignRef a)+mkFinalizedHValue interp rref = do    let hvref = toHValueRef rref -   free <- case hsc_interp hsc_env of-     Nothing                           -> return (pure ())+   free <- case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-     Just InternalInterp               -> return (freeRemoteRef hvref)+      InternalInterp             -> return (freeRemoteRef hvref) #endif-     Just (ExternalInterp _ (IServ i)) -> return $ modifyMVar_ i $ \state ->+      ExternalInterp _ (IServ i) -> return $ modifyMVar_ i $ \state ->        case state of          IServPending {}   -> pure state -- already shut down          IServRunning inst -> do@@ -693,9 +702,9 @@    mkForeignRef rref free  -freeHValueRefs :: HscEnv -> [HValueRef] -> IO ()+freeHValueRefs :: Interp -> [HValueRef] -> IO () freeHValueRefs _ [] = return ()-freeHValueRefs hsc_env refs = iservCmd hsc_env (FreeHValueRefs refs)+freeHValueRefs interp refs = interpCmd interp (FreeHValueRefs refs)  -- | Convert a 'ForeignRef' to the value it references directly.  This -- only works when the interpreter is running in the same process as@@ -707,12 +716,12 @@ -- only works when the interpreter is running in the same process as -- the compiler, so it fails when @-fexternal-interpreter@ is on. wormholeRef :: Interp -> RemoteRef a -> IO a+wormholeRef interp _r = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-wormholeRef InternalInterp      _r = localRef _r+  InternalInterp -> localRef _r #endif-wormholeRef (ExternalInterp {}) _r-  = throwIO (InstallationError-      "this operation requires -fno-external-interpreter")+  ExternalInterp {}+    -> throwIO (InstallationError "this operation requires -fno-external-interpreter")  -- ----------------------------------------------------------------------------- -- Misc utils@@ -732,21 +741,28 @@ getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi   | Just linkable <- hm_linkable hmi,-    [BCOs cbc _] <- linkableUnlinked linkable+    [cbc] <- mapMaybe onlyBCOs $ linkableUnlinked linkable   = fromMaybe emptyModBreaks (bc_breaks cbc)   | otherwise   = emptyModBreaks -- probably object code+  where+    -- The linkable may have 'DotO's as well; only consider BCOs. See #20570.+    onlyBCOs :: Unlinked -> Maybe CompiledByteCode+    onlyBCOs (BCOs cbc _) = Just cbc+    onlyBCOs _            = Nothing  -- | Interpreter uses Profiling way interpreterProfiled :: Interp -> Bool+interpreterProfiled interp = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-interpreterProfiled InternalInterp       = hostIsProfiled+  InternalInterp     -> hostIsProfiled #endif-interpreterProfiled (ExternalInterp c _) = iservConfProfiled c+  ExternalInterp c _ -> iservConfProfiled c  -- | Interpreter uses Dynamic way interpreterDynamic :: Interp -> Bool+interpreterDynamic interp = case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)-interpreterDynamic InternalInterp       = hostIsDynamic+  InternalInterp     -> hostIsDynamic #endif-interpreterDynamic (ExternalInterp c _) = iservConfDynamic c+  ExternalInterp c _ -> iservConfDynamic c

GHC/Runtime/Interpreter/Types.hs view

@@ -3,6 +3,7 @@ -- | Types used by the runtime interpreter module GHC.Runtime.Interpreter.Types    ( Interp(..)+   , InterpInstance(..)    , IServ(..)    , IServInstance(..)    , IServConfig(..)@@ -11,6 +12,7 @@ where  import GHC.Prelude+import GHC.Linker.Types  import GHCi.RemoteTypes import GHCi.Message         ( Pipe )@@ -21,8 +23,17 @@ import Control.Concurrent import System.Process   ( ProcessHandle, CreateProcess ) --- | Runtime interpreter-data Interp+-- | Interpreter+data Interp = Interp+  { interpInstance :: !InterpInstance+      -- ^ Interpreter instance (internal, external)++  , interpLoader   :: !Loader+      -- ^ Interpreter loader+  }+++data InterpInstance    = ExternalInterp !IServConfig !IServ -- ^ External interpreter #if defined(HAVE_INTERNAL_INTERPRETER)    | InternalInterp                     -- ^ Internal interpreter

− GHC/Runtime/Linker.hs

@@ -1,1780 +0,0 @@-{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}-{-# LANGUAGE BangPatterns #-}-------  (c) The University of Glasgow 2002-2006------ | The dynamic linker for GHCi.------ This module deals with the top-level issues of dynamic linking,--- calling the object-code linker and the byte-code linker where--- necessary.-module GHC.Runtime.Linker-   ( getHValue-   , showLinkerState-   , linkExpr-   , linkDecls-   , unload-   , withExtendedLinkEnv-   , extendLinkEnv-   , deleteFromLinkEnv-   , extendLoadedPkgs-   , linkPackages-   , initDynLinker-   , linkModule-   , linkCmdLineLibs-   , uninitializedLinker-   )-where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Runtime.Interpreter-import GHC.Runtime.Interpreter.Types-import GHCi.RemoteTypes-import GHC.Iface.Load-import GHC.ByteCode.Linker-import GHC.ByteCode.Asm-import GHC.ByteCode.Types-import GHC.Tc.Utils.Monad-import GHC.Unit.State as Packages-import GHC.Driver.Phases-import GHC.Driver.Finder-import GHC.Driver.Types-import GHC.Driver.Ways-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Unit.Module-import GHC.Data.List.SetOps-import GHC.Runtime.Linker.Types (DynLinker(..), PersistentLinkerState(..))-import GHC.Driver.Session-import GHC.Types.Basic-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Misc-import GHC.Utils.Error-import GHC.Types.SrcLoc-import qualified GHC.Data.Maybe as Maybes-import GHC.Types.Unique.DSet-import GHC.Data.FastString-import GHC.Platform-import GHC.SysTools-import GHC.SysTools.FileCleanup---- Standard libraries-import Control.Monad--import qualified Data.Set as Set-import Data.Char (isSpace)-import Data.Function ((&))-import Data.IORef-import Data.List (intercalate, isPrefixOf, isSuffixOf, nub, partition)-import Data.Maybe-import Control.Concurrent.MVar-import qualified Control.Monad.Catch as MC--import System.FilePath-import System.Directory-import System.IO.Unsafe-import System.Environment (lookupEnv)--#if defined(mingw32_HOST_OS)-import System.Win32.Info (getSystemDirectory)-#endif--import GHC.Utils.Exception--{- **********************************************************************--                        The Linker's state--  ********************************************************************* -}--{--The persistent linker state *must* match the actual state of the-C dynamic linker at all times.--The MVar used to hold the PersistentLinkerState contains a Maybe-PersistentLinkerState. The MVar serves to ensure mutual exclusion between-multiple loaded copies of the GHC library. The Maybe may be Nothing to-indicate that the linker has not yet been initialised.--The PersistentLinkerState maps Names to actual closures (for-interpreted code only), for use during linking.--}--uninitializedLinker :: IO DynLinker-uninitializedLinker =-  newMVar Nothing >>= (pure . DynLinker)--uninitialised :: a-uninitialised = panic "Dynamic linker not initialised"--modifyPLS_ :: DynLinker -> (PersistentLinkerState -> IO PersistentLinkerState) -> IO ()-modifyPLS_ dl f =-  modifyMVar_ (dl_mpls dl) (fmap pure . f . fromMaybe uninitialised)--modifyPLS :: DynLinker -> (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a-modifyPLS dl f =-  modifyMVar (dl_mpls dl) (fmapFst pure . f . fromMaybe uninitialised)-  where fmapFst f = fmap (\(x, y) -> (f x, y))--readPLS :: DynLinker -> IO PersistentLinkerState-readPLS dl =-  (fmap (fromMaybe uninitialised) . readMVar) (dl_mpls dl)--modifyMbPLS_-  :: DynLinker -> (Maybe PersistentLinkerState -> IO (Maybe PersistentLinkerState)) -> IO ()-modifyMbPLS_ dl f = modifyMVar_ (dl_mpls dl) f--emptyPLS :: PersistentLinkerState-emptyPLS = PersistentLinkerState-   { closure_env = emptyNameEnv-   , itbl_env    = emptyNameEnv-   , pkgs_loaded = init_pkgs-   , bcos_loaded = []-   , objs_loaded = []-   , temp_sos = []-   }-  -- Packages that don't need loading, because the compiler-  -- shares them with the interpreted program.-  ---  -- The linker's symbol table is populated with RTS symbols using an-  -- explicit list.  See rts/Linker.c for details.-  where init_pkgs = [rtsUnitId]--extendLoadedPkgs :: DynLinker -> [UnitId] -> IO ()-extendLoadedPkgs dl pkgs =-  modifyPLS_ dl $ \s ->-      return s{ pkgs_loaded = pkgs ++ pkgs_loaded s }--extendLinkEnv :: DynLinker -> [(Name,ForeignHValue)] -> IO ()-extendLinkEnv dl new_bindings =-  modifyPLS_ dl $ \pls@PersistentLinkerState{..} -> do-    let new_ce = extendClosureEnv closure_env new_bindings-    return $! pls{ closure_env = new_ce }-    -- strictness is important for not retaining old copies of the pls--deleteFromLinkEnv :: DynLinker -> [Name] -> IO ()-deleteFromLinkEnv dl to_remove =-  modifyPLS_ dl $ \pls -> do-    let ce = closure_env pls-    let new_ce = delListFromNameEnv ce to_remove-    return pls{ closure_env = new_ce }---- | Get the 'HValue' associated with the given name.------ May cause loading the module that contains the name.------ Throws a 'ProgramError' if loading fails or the name cannot be found.-getHValue :: HscEnv -> Name -> IO ForeignHValue-getHValue hsc_env name = do-  let dl = hsc_dynLinker hsc_env-  initDynLinker hsc_env-  pls <- modifyPLS dl $ \pls -> do-           if (isExternalName name) then do-             (pls', ok) <- linkDependencies hsc_env pls noSrcSpan-                              [nameModule name]-             if (failed ok) then throwGhcExceptionIO (ProgramError "")-                            else return (pls', pls')-            else-             return (pls, pls)-  case lookupNameEnv (closure_env pls) name of-    Just (_,aa) -> return aa-    Nothing-        -> ASSERT2(isExternalName name, ppr name)-           do let sym_to_find = nameToCLabel name "closure"-              m <- lookupClosure hsc_env (unpackFS sym_to_find)-              case m of-                Just hvref -> mkFinalizedHValue hsc_env hvref-                Nothing -> linkFail "GHC.Runtime.Linker.getHValue"-                             (unpackFS sym_to_find)--linkDependencies :: HscEnv -> PersistentLinkerState-                 -> SrcSpan -> [Module]-                 -> IO (PersistentLinkerState, SuccessFlag)-linkDependencies hsc_env pls span needed_mods = do---   initDynLinker (hsc_dflags hsc_env) dl-   let hpt = hsc_HPT hsc_env-   -- The interpreter and dynamic linker can only handle object code built-   -- the "normal" way, i.e. no non-std ways like profiling or ticky-ticky.-   -- So here we check the build tag: if we're building a non-standard way-   -- then we need to find & link object files built the "normal" way.-   maybe_normal_osuf <- checkNonStdWay hsc_env span--   -- Find what packages and linkables are required-   (lnks, pkgs) <- getLinkDeps hsc_env hpt pls-                               maybe_normal_osuf span needed_mods--   -- Link the packages and modules required-   pls1 <- linkPackages' hsc_env pkgs pls-   linkModules hsc_env pls1 lnks----- | Temporarily extend the linker state.--withExtendedLinkEnv :: (ExceptionMonad m) =>-                       DynLinker -> [(Name,ForeignHValue)] -> m a -> m a-withExtendedLinkEnv dl new_env action-    = MC.bracket (liftIO $ extendLinkEnv dl new_env)-               (\_ -> reset_old_env)-               (\_ -> action)-    where-        -- Remember that the linker state might be side-effected-        -- during the execution of the IO action, and we don't want to-        -- lose those changes (we might have linked a new module or-        -- package), so the reset action only removes the names we-        -- added earlier.-          reset_old_env = liftIO $ do-            modifyPLS_ dl $ \pls ->-                let cur = closure_env pls-                    new = delListFromNameEnv cur (map fst new_env)-                in return pls{ closure_env = new }----- | Display the persistent linker state.-showLinkerState :: DynLinker -> IO SDoc-showLinkerState dl-  = do pls <- readPLS dl-       return $ withPprStyle defaultDumpStyle-                 (vcat [text "----- Linker state -----",-                        text "Pkgs:" <+> ppr (pkgs_loaded pls),-                        text "Objs:" <+> ppr (objs_loaded pls),-                        text "BCOs:" <+> ppr (bcos_loaded pls)])---{- **********************************************************************--                        Initialisation--  ********************************************************************* -}---- | Initialise the dynamic linker.  This entails------  a) Calling the C initialisation procedure,------  b) Loading any packages specified on the command line,------  c) Loading any packages specified on the command line, now held in the---     @-l@ options in @v_Opt_l@,------  d) Loading any @.o\/.dll@ files specified on the command line, now held---     in @ldInputs@,------  e) Loading any MacOS frameworks.------ NOTE: This function is idempotent; if called more than once, it does--- nothing.  This is useful in Template Haskell, where we call it before--- trying to link.----initDynLinker :: HscEnv -> IO ()-initDynLinker hsc_env = do-  let dl = hsc_dynLinker hsc_env-  modifyMbPLS_ dl $ \pls -> do-    case pls of-      Just  _ -> return pls-      Nothing -> Just <$> reallyInitDynLinker hsc_env--reallyInitDynLinker :: HscEnv -> IO PersistentLinkerState-reallyInitDynLinker hsc_env = do-  -- Initialise the linker state-  let dflags = hsc_dflags hsc_env-      pls0 = emptyPLS--  -- (a) initialise the C dynamic linker-  initObjLinker hsc_env--  -- (b) Load packages from the command-line (Note [preload packages])-  pls <- linkPackages' hsc_env (preloadUnits (unitState dflags)) pls0--  -- steps (c), (d) and (e)-  linkCmdLineLibs' hsc_env pls---linkCmdLineLibs :: HscEnv -> IO ()-linkCmdLineLibs hsc_env = do-  let dl = hsc_dynLinker hsc_env-  initDynLinker hsc_env-  modifyPLS_ dl $ \pls -> do-    linkCmdLineLibs' hsc_env pls--linkCmdLineLibs' :: HscEnv -> PersistentLinkerState -> IO PersistentLinkerState-linkCmdLineLibs' hsc_env pls =-  do-      let dflags@(DynFlags { ldInputs = cmdline_ld_inputs-                           , libraryPaths = lib_paths_base})-            = hsc_dflags hsc_env--      -- (c) Link libraries from the command-line-      let minus_ls_1 = [ lib | Option ('-':'l':lib) <- cmdline_ld_inputs ]--      -- On Windows we want to add libpthread by default just as GCC would.-      -- However because we don't know the actual name of pthread's dll we-      -- need to defer this to the locateLib call so we can't initialize it-      -- inside of the rts. Instead we do it here to be able to find the-      -- import library for pthreads. See #13210.-      let platform = targetPlatform dflags-          os       = platformOS platform-          minus_ls = case os of-                       OSMinGW32 -> "pthread" : minus_ls_1-                       _         -> minus_ls_1-      -- See Note [Fork/Exec Windows]-      gcc_paths <- getGCCPaths dflags os--      lib_paths_env <- addEnvPaths "LIBRARY_PATH" lib_paths_base--      maybePutStrLn dflags "Search directories (user):"-      maybePutStr dflags (unlines $ map ("  "++) lib_paths_env)-      maybePutStrLn dflags "Search directories (gcc):"-      maybePutStr dflags (unlines $ map ("  "++) gcc_paths)--      libspecs-        <- mapM (locateLib hsc_env False lib_paths_env gcc_paths) minus_ls--      -- (d) Link .o files from the command-line-      classified_ld_inputs <- mapM (classifyLdInput dflags)-                                [ f | FileOption _ f <- cmdline_ld_inputs ]--      -- (e) Link any MacOS frameworks-      let platform = targetPlatform dflags-      let (framework_paths, frameworks) =-            if platformUsesFrameworks platform-             then (frameworkPaths dflags, cmdlineFrameworks dflags)-              else ([],[])--      -- Finally do (c),(d),(e)-      let cmdline_lib_specs = catMaybes classified_ld_inputs-                           ++ libspecs-                           ++ map Framework frameworks-      if null cmdline_lib_specs then return pls-                                else do--      -- Add directories to library search paths, this only has an effect-      -- on Windows. On Unix OSes this function is a NOP.-      let all_paths = let paths = takeDirectory (pgm_c dflags)-                                : framework_paths-                               ++ lib_paths_base-                               ++ [ takeDirectory dll | DLLPath dll <- libspecs ]-                      in nub $ map normalise paths-      let lib_paths = nub $ lib_paths_base ++ gcc_paths-      all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths-      pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env--      let merged_specs = mergeStaticObjects cmdline_lib_specs-      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls-                    merged_specs--      maybePutStr dflags "final link ... "-      ok <- resolveObjs hsc_env--      -- DLLs are loaded, reset the search paths-      mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache--      if succeeded ok then maybePutStrLn dflags "done"-      else throwGhcExceptionIO (ProgramError "linking extra libraries/objects failed")--      return pls1---- | Merge runs of consecutive of 'Objects'. This allows for resolution of--- cyclic symbol references when dynamically linking. Specifically, we link--- together all of the static objects into a single shared object, avoiding--- the issue we saw in #13786.-mergeStaticObjects :: [LibrarySpec] -> [LibrarySpec]-mergeStaticObjects specs = go [] specs-  where-    go :: [FilePath] -> [LibrarySpec] -> [LibrarySpec]-    go accum (Objects objs : rest) = go (objs ++ accum) rest-    go accum@(_:_) rest = Objects (reverse accum) : go [] rest-    go [] (spec:rest) = spec : go [] rest-    go [] [] = []--{- Note [preload packages]--Why do we need to preload packages from the command line?  This is an-explanation copied from #2437:--I tried to implement the suggestion from #3560, thinking it would be-easy, but there are two reasons we link in packages eagerly when they-are mentioned on the command line:--  * So that you can link in extra object files or libraries that-    depend on the packages. e.g. ghc -package foo -lbar where bar is a-    C library that depends on something in foo. So we could link in-    foo eagerly if and only if there are extra C libs or objects to-    link in, but....--  * Haskell code can depend on a C function exported by a package, and-    the normal dependency tracking that TH uses can't know about these-    dependencies. The test ghcilink004 relies on this, for example.--I conclude that we need two -package flags: one that says "this is a-package I want to make available", and one that says "this is a-package I want to link in eagerly". Would that be too complicated for-users?--}--classifyLdInput :: DynFlags -> FilePath -> IO (Maybe LibrarySpec)-classifyLdInput dflags f-  | isObjectFilename platform f = return (Just (Objects [f]))-  | isDynLibFilename platform f = return (Just (DLLPath f))-  | otherwise          = do-        putLogMsg dflags NoReason SevInfo noSrcSpan-            $ withPprStyle defaultUserStyle-            (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))-        return Nothing-    where platform = targetPlatform dflags--preloadLib-  :: HscEnv -> [String] -> [String] -> PersistentLinkerState-  -> LibrarySpec -> IO PersistentLinkerState-preloadLib hsc_env lib_paths framework_paths pls lib_spec = do-  maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ")-  case lib_spec of-    Objects static_ishs -> do-      (b, pls1) <- preload_statics lib_paths static_ishs-      maybePutStrLn dflags (if b  then "done" else "not found")-      return pls1--    Archive static_ish -> do-      b <- preload_static_archive lib_paths static_ish-      maybePutStrLn dflags (if b  then "done" else "not found")-      return pls--    DLL dll_unadorned -> do-      maybe_errstr <- loadDLL hsc_env (mkSOName platform dll_unadorned)-      case maybe_errstr of-         Nothing -> maybePutStrLn dflags "done"-         Just mm | platformOS platform /= OSDarwin ->-           preloadFailed mm lib_paths lib_spec-         Just mm | otherwise -> do-           -- As a backup, on Darwin, try to also load a .so file-           -- since (apparently) some things install that way - see-           -- ticket #8770.-           let libfile = ("lib" ++ dll_unadorned) <.> "so"-           err2 <- loadDLL hsc_env libfile-           case err2 of-             Nothing -> maybePutStrLn dflags "done"-             Just _  -> preloadFailed mm lib_paths lib_spec-      return pls--    DLLPath dll_path -> do-      do maybe_errstr <- loadDLL hsc_env dll_path-         case maybe_errstr of-            Nothing -> maybePutStrLn dflags "done"-            Just mm -> preloadFailed mm lib_paths lib_spec-         return pls--    Framework framework ->-      if platformUsesFrameworks (targetPlatform dflags)-      then do maybe_errstr <- loadFramework hsc_env framework_paths framework-              case maybe_errstr of-                 Nothing -> maybePutStrLn dflags "done"-                 Just mm -> preloadFailed mm framework_paths lib_spec-              return pls-      else throwGhcExceptionIO (ProgramError "preloadLib Framework")--  where-    dflags = hsc_dflags hsc_env--    platform = targetPlatform dflags--    preloadFailed :: String -> [String] -> LibrarySpec -> IO ()-    preloadFailed sys_errmsg paths spec-       = do maybePutStr dflags "failed.\n"-            throwGhcExceptionIO $-              CmdLineError (-                    "user specified .o/.so/.DLL could not be loaded ("-                    ++ sys_errmsg ++ ")\nWhilst trying to load:  "-                    ++ showLS spec ++ "\nAdditional directories searched:"-                    ++ (if null paths then " (none)" else-                        intercalate "\n" (map ("   "++) paths)))--    -- Not interested in the paths in the static case.-    preload_statics _paths names-       = do b <- or <$> mapM doesFileExist names-            if not b then return (False, pls)-                     else if hostIsDynamic-                             then  do pls1 <- dynLoadObjs hsc_env pls names-                                      return (True, pls1)-                             else  do mapM_ (loadObj hsc_env) names-                                      return (True, pls)--    preload_static_archive _paths name-       = do b <- doesFileExist name-            if not b then return False-                     else do if hostIsDynamic-                                 then throwGhcExceptionIO $-                                      CmdLineError dynamic_msg-                                 else loadArchive hsc_env name-                             return True-      where-        dynamic_msg = unlines-          [ "User-specified static library could not be loaded ("-            ++ name ++ ")"-          , "Loading static libraries is not supported in this configuration."-          , "Try using a dynamic library instead."-          ]---{- **********************************************************************--                        Link a byte-code expression--  ********************************************************************* -}---- | Link a single expression, /including/ first linking packages and--- modules that this expression depends on.------ Raises an IO exception ('ProgramError') if it can't find a compiled--- version of the dependents to link.----linkExpr :: HscEnv -> SrcSpan -> UnlinkedBCO -> IO ForeignHValue-linkExpr hsc_env span root_ul_bco-  = do {-     -- Initialise the linker (if it's not been done already)-   ; initDynLinker hsc_env--     -- Extract the DynLinker value for passing into required places-   ; let dl = hsc_dynLinker hsc_env--     -- Take lock for the actual work.-   ; modifyPLS dl $ \pls0 -> do {--     -- Link the packages and modules required-   ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods-   ; if failed ok then-        throwGhcExceptionIO (ProgramError "")-     else do {--     -- Link the expression itself-     let ie = itbl_env pls-         ce = closure_env pls--     -- Link the necessary packages and linkables--   ; let nobreakarray = error "no break array"-         bco_ix = mkNameEnv [(unlinkedBCOName root_ul_bco, 0)]-   ; resolved <- linkBCO hsc_env ie ce bco_ix nobreakarray root_ul_bco-   ; [root_hvref] <- createBCOs hsc_env [resolved]-   ; fhv <- mkFinalizedHValue hsc_env root_hvref-   ; return (pls, fhv)-   }}}-   where-     free_names = uniqDSetToList (bcoFreeNames root_ul_bco)--     needed_mods :: [Module]-     needed_mods = [ nameModule n | n <- free_names,-                     isExternalName n,      -- Names from other modules-                     not (isWiredInName n)  -- Exclude wired-in names-                   ]                        -- (see note below)-        -- Exclude wired-in names because we may not have read-        -- their interface files, so getLinkDeps will fail-        -- All wired-in names are in the base package, which we link-        -- by default, so we can safely ignore them here.--dieWith :: DynFlags -> SrcSpan -> MsgDoc -> IO a-dieWith dflags span msg = throwGhcExceptionIO (ProgramError (showSDoc dflags (mkLocMessage SevFatal span msg)))---checkNonStdWay :: HscEnv -> SrcSpan -> IO (Maybe FilePath)-checkNonStdWay hsc_env srcspan-  | Just (ExternalInterp {}) <- hsc_interp hsc_env = return Nothing-    -- with -fexternal-interpreter we load the .o files, whatever way-    -- they were built.  If they were built for a non-std way, then-    -- we will use the appropriate variant of the iserv binary to load them.--  | hostFullWays == targetFullWays = return Nothing-    -- Only if we are compiling with the same ways as GHC is built-    -- with, can we dynamically load those object files. (see #3604)--  | objectSuf (hsc_dflags hsc_env) == normalObjectSuffix && not (null targetFullWays)-  = failNonStd (hsc_dflags hsc_env) srcspan--  | otherwise = return (Just (hostWayTag ++ "o"))-  where-    targetFullWays = Set.filter (not . wayRTSOnly) (ways (hsc_dflags hsc_env))-    hostWayTag = case waysTag hostFullWays of-                  "" -> ""-                  tag -> tag ++ "_"--normalObjectSuffix :: String-normalObjectSuffix = phaseInputExt StopLn--failNonStd :: DynFlags -> SrcSpan -> IO (Maybe FilePath)-failNonStd dflags srcspan = dieWith dflags srcspan $-  text "Cannot load" <+> compWay <+>-     text "objects when GHC is built" <+> ghciWay $$-  text "To fix this, either:" $$-  text "  (1) Use -fexternal-interpreter, or" $$-  text "  (2) Build the program twice: once" <+>-                       ghciWay <> text ", and then" $$-  text "      with" <+> compWay <+>-     text "using -osuf to set a different object file suffix."-    where compWay-            | WayDyn `elem` ways dflags = text "-dynamic"-            | WayProf `elem` ways dflags = text "-prof"-            | otherwise = text "normal"-          ghciWay-            | hostIsDynamic = text "with -dynamic"-            | hostIsProfiled = text "with -prof"-            | otherwise = text "the normal way"--getLinkDeps :: HscEnv -> HomePackageTable-            -> PersistentLinkerState-            -> Maybe FilePath                   -- replace object suffices?-            -> SrcSpan                          -- for error messages-            -> [Module]                         -- If you need these-            -> IO ([Linkable], [UnitId])     -- ... then link these first--- Fails with an IO exception if it can't find enough files--getLinkDeps hsc_env hpt pls replace_osuf span mods--- Find all the packages and linkables that a set of modules depends on- = do {-        -- 1.  Find the dependent home-pkg-modules/packages from each iface-        -- (omitting modules from the interactive package, which is already linked)-      ; (mods_s, pkgs_s) <- follow_deps (filterOut isInteractiveModule mods)-                                        emptyUniqDSet emptyUniqDSet;--      ; let {-        -- 2.  Exclude ones already linked-        --      Main reason: avoid findModule calls in get_linkable-            mods_needed = mods_s `minusList` linked_mods     ;-            pkgs_needed = pkgs_s `minusList` pkgs_loaded pls ;--            linked_mods = map (moduleName.linkableModule)-                                (objs_loaded pls ++ bcos_loaded pls)  }--        -- 3.  For each dependent module, find its linkable-        --     This will either be in the HPT or (in the case of one-shot-        --     compilation) we may need to use maybe_getFileLinkable-      ; let { osuf = objectSuf dflags }-      ; lnks_needed <- mapM (get_linkable osuf) mods_needed--      ; return (lnks_needed, pkgs_needed) }-  where-    dflags = hsc_dflags hsc_env-    this_pkg = homeUnit dflags--        -- The ModIface contains the transitive closure of the module dependencies-        -- within the current package, *except* for boot modules: if we encounter-        -- a boot module, we have to find its real interface and discover the-        -- dependencies of that.  Hence we need to traverse the dependency-        -- tree recursively.  See bug #936, testcase ghci/prog007.-    follow_deps :: [Module]             -- modules to follow-                -> UniqDSet ModuleName         -- accum. module dependencies-                -> UniqDSet UnitId          -- accum. package dependencies-                -> IO ([ModuleName], [UnitId]) -- result-    follow_deps []     acc_mods acc_pkgs-        = return (uniqDSetToList acc_mods, uniqDSetToList acc_pkgs)-    follow_deps (mod:mods) acc_mods acc_pkgs-        = do-          mb_iface <- initIfaceCheck (text "getLinkDeps") hsc_env $-                        loadInterface msg mod (ImportByUser NotBoot)-          iface <- case mb_iface of-                    Maybes.Failed err      -> throwGhcExceptionIO (ProgramError (showSDoc dflags err))-                    Maybes.Succeeded iface -> return iface--          when (mi_boot iface == IsBoot) $ link_boot_mod_error mod--          let-            pkg = moduleUnit mod-            deps  = mi_deps iface--            pkg_deps = dep_pkgs deps-            (boot_deps, mod_deps) = flip partitionWith (dep_mods deps) $-              \ (GWIB { gwib_mod = m, gwib_isBoot = is_boot }) ->-                m & case is_boot of-                  IsBoot -> Left-                  NotBoot -> Right--            boot_deps' = filter (not . (`elementOfUniqDSet` acc_mods)) boot_deps-            acc_mods'  = addListToUniqDSet acc_mods (moduleName mod : mod_deps)-            acc_pkgs'  = addListToUniqDSet acc_pkgs $ map fst pkg_deps-          ---          if pkg /= this_pkg-             then follow_deps mods acc_mods (addOneToUniqDSet acc_pkgs' (toUnitId pkg))-             else follow_deps (map (mkModule this_pkg) boot_deps' ++ mods)-                              acc_mods' acc_pkgs'-        where-            msg = text "need to link module" <+> ppr mod <+>-                  text "due to use of Template Haskell"---    link_boot_mod_error mod =-        throwGhcExceptionIO (ProgramError (showSDoc dflags (-            text "module" <+> ppr mod <+>-            text "cannot be linked; it is only available as a boot module")))--    no_obj :: Outputable a => a -> IO b-    no_obj mod = dieWith dflags span $-                     text "cannot find object file for module " <>-                        quotes (ppr mod) $$-                     while_linking_expr--    while_linking_expr = text "while linking an interpreted expression"--        -- This one is a build-system bug--    get_linkable osuf mod_name      -- A home-package module-        | Just mod_info <- lookupHpt hpt mod_name-        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))-        | otherwise-        = do    -- It's not in the HPT because we are in one shot mode,-                -- so use the Finder to get a ModLocation...-             mb_stuff <- findHomeModule hsc_env mod_name-             case mb_stuff of-                  Found loc mod -> found loc mod-                  _ -> no_obj mod_name-        where-            found loc mod = do {-                -- ...and then find the linkable for it-               mb_lnk <- findObjectLinkableMaybe mod loc ;-               case mb_lnk of {-                  Nothing  -> no_obj mod ;-                  Just lnk -> adjust_linkable lnk-              }}--            adjust_linkable lnk-                | Just new_osuf <- replace_osuf = do-                        new_uls <- mapM (adjust_ul new_osuf)-                                        (linkableUnlinked lnk)-                        return lnk{ linkableUnlinked=new_uls }-                | otherwise =-                        return lnk--            adjust_ul new_osuf (DotO file) = do-                MASSERT(osuf `isSuffixOf` file)-                let file_base = fromJust (stripExtension osuf file)-                    new_file = file_base <.> new_osuf-                ok <- doesFileExist new_file-                if (not ok)-                   then dieWith dflags span $-                          text "cannot find object file "-                                <> quotes (text new_file) $$ while_linking_expr-                   else return (DotO new_file)-            adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)-            adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)-            adjust_ul _ l@(BCOs {}) = return l----{- **********************************************************************--              Loading a Decls statement--  ********************************************************************* -}--linkDecls :: HscEnv -> SrcSpan -> CompiledByteCode -> IO ()-linkDecls hsc_env span cbc@CompiledByteCode{..} = do-    -- Initialise the linker (if it's not been done already)-    initDynLinker hsc_env--    -- Extract the DynLinker for passing into required places-    let dl = hsc_dynLinker hsc_env--    -- Take lock for the actual work.-    modifyPLS dl $ \pls0 -> do--    -- Link the packages and modules required-    (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods-    if failed ok-      then throwGhcExceptionIO (ProgramError "")-      else do--    -- Link the expression itself-    let ie = plusNameEnv (itbl_env pls) bc_itbls-        ce = closure_env pls--    -- Link the necessary packages and linkables-    new_bindings <- linkSomeBCOs hsc_env ie ce [cbc]-    nms_fhvs <- makeForeignNamedHValueRefs hsc_env new_bindings-    let pls2 = pls { closure_env = extendClosureEnv ce nms_fhvs-                   , itbl_env    = ie }-    return (pls2, ())-  where-    free_names = uniqDSetToList $-      foldr (unionUniqDSets . bcoFreeNames) emptyUniqDSet bc_bcos--    needed_mods :: [Module]-    needed_mods = [ nameModule n | n <- free_names,-                    isExternalName n,       -- Names from other modules-                    not (isWiredInName n)   -- Exclude wired-in names-                  ]                         -- (see note below)-    -- Exclude wired-in names because we may not have read-    -- their interface files, so getLinkDeps will fail-    -- All wired-in names are in the base package, which we link-    -- by default, so we can safely ignore them here.--{- **********************************************************************--              Loading a single module--  ********************************************************************* -}--linkModule :: HscEnv -> Module -> IO ()-linkModule hsc_env mod = do-  initDynLinker hsc_env-  let dl = hsc_dynLinker hsc_env-  modifyPLS_ dl $ \pls -> do-    (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod]-    if (failed ok) then throwGhcExceptionIO (ProgramError "could not link module")-      else return pls'--{- **********************************************************************--                Link some linkables-        The linkables may consist of a mixture of-        byte-code modules and object modules--  ********************************************************************* -}--linkModules :: HscEnv -> PersistentLinkerState -> [Linkable]-            -> IO (PersistentLinkerState, SuccessFlag)-linkModules hsc_env pls linkables-  = mask_ $ do  -- don't want to be interrupted by ^C in here--        let (objs, bcos) = partition isObjectLinkable-                              (concatMap partitionLinkable linkables)--                -- Load objects first; they can't depend on BCOs-        (pls1, ok_flag) <- dynLinkObjs hsc_env pls objs--        if failed ok_flag then-                return (pls1, Failed)-          else do-                pls2 <- dynLinkBCOs hsc_env pls1 bcos-                return (pls2, Succeeded)----- HACK to support f-x-dynamic in the interpreter; no other purpose-partitionLinkable :: Linkable -> [Linkable]-partitionLinkable li-   = let li_uls = linkableUnlinked li-         li_uls_obj = filter isObject li_uls-         li_uls_bco = filter isInterpretable li_uls-     in-         case (li_uls_obj, li_uls_bco) of-            (_:_, _:_) -> [li {linkableUnlinked=li_uls_obj},-                           li {linkableUnlinked=li_uls_bco}]-            _ -> [li]--findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable-findModuleLinkable_maybe lis mod-   = case [LM time nm us | LM time nm us <- lis, nm == mod] of-        []   -> Nothing-        [li] -> Just li-        _    -> pprPanic "findModuleLinkable" (ppr mod)--linkableInSet :: Linkable -> [Linkable] -> Bool-linkableInSet l objs_loaded =-  case findModuleLinkable_maybe objs_loaded (linkableModule l) of-        Nothing -> False-        Just m  -> linkableTime l == linkableTime m---{- **********************************************************************--                The object-code linker--  ********************************************************************* -}--dynLinkObjs :: HscEnv -> PersistentLinkerState -> [Linkable]-            -> IO (PersistentLinkerState, SuccessFlag)-dynLinkObjs hsc_env pls objs = do-        -- Load the object files and link them-        let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs-            pls1                     = pls { objs_loaded = objs_loaded' }-            unlinkeds                = concatMap linkableUnlinked new_objs-            wanted_objs              = map nameOfObject unlinkeds--        if interpreterDynamic (hscInterp hsc_env)-            then do pls2 <- dynLoadObjs hsc_env pls1 wanted_objs-                    return (pls2, Succeeded)-            else do mapM_ (loadObj hsc_env) wanted_objs--                    -- Link them all together-                    ok <- resolveObjs hsc_env--                    -- If resolving failed, unload all our-                    -- object modules and carry on-                    if succeeded ok then do-                            return (pls1, Succeeded)-                      else do-                            pls2 <- unload_wkr hsc_env [] pls1-                            return (pls2, Failed)---dynLoadObjs :: HscEnv -> PersistentLinkerState -> [FilePath]-            -> IO PersistentLinkerState-dynLoadObjs _       pls                           []   = return pls-dynLoadObjs hsc_env pls@PersistentLinkerState{..} objs = do-    let dflags = hsc_dflags hsc_env-    let platform = targetPlatform dflags-    let minus_ls = [ lib | Option ('-':'l':lib) <- ldInputs dflags ]-    let minus_big_ls = [ lib | Option ('-':'L':lib) <- ldInputs dflags ]-    (soFile, libPath , libName) <--      newTempLibName dflags TFL_CurrentModule (soExt platform)-    let-        dflags2 = dflags {-                      -- We don't want the original ldInputs in-                      -- (they're already linked in), but we do want-                      -- to link against previous dynLoadObjs-                      -- libraries if there were any, so that the linker-                      -- can resolve dependencies when it loads this-                      -- library.-                      ldInputs =-                           concatMap (\l -> [ Option ("-l" ++ l) ])-                                     (nub $ snd <$> temp_sos)-                        ++ concatMap (\lp -> Option ("-L" ++ lp)-                                          : if useXLinkerRPath dflags (platformOS platform)-                                            then [ Option "-Xlinker"-                                                 , Option "-rpath"-                                                 , Option "-Xlinker"-                                                 , Option lp ]-                                            else [])-                                     (nub $ fst <$> temp_sos)-                        ++ concatMap-                             (\lp -> Option ("-L" ++ lp)-                                  : if useXLinkerRPath dflags (platformOS platform)-                                    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,-                      -- Add -l options and -L options from dflags.-                      ---                      -- When running TH for a non-dynamic way, we still-                      -- need to make -l flags to link against the dynamic-                      -- libraries, so we need to add WayDyn to ways.-                      ---                      -- Even if we're e.g. profiling, we still want-                      -- the vanilla dynamic libraries, so we set the-                      -- ways / build tag to be just WayDyn.-                      ways = Set.singleton WayDyn,-                      outputFile = Just soFile-                  }-    -- link all "loaded packages" so symbols in those can be resolved-    -- Note: We are loading packages with local scope, so to see the-    -- symbols in this link we must link all loaded packages again.-    linkDynLib dflags2 objs pkgs_loaded--    -- if we got this far, extend the lifetime of the library file-    changeTempFilesLifetime dflags TFL_GhcSession [soFile]-    m <- loadDLL hsc_env soFile-    case m of-        Nothing -> return $! pls { temp_sos = (libPath, libName) : temp_sos }-        Just err -> linkFail msg err-  where-    msg = "GHC.Runtime.Linker.dynLoadObjs: Loading temp shared object failed"--rmDupLinkables :: [Linkable]    -- Already loaded-               -> [Linkable]    -- New linkables-               -> ([Linkable],  -- New loaded set (including new ones)-                   [Linkable])  -- New linkables (excluding dups)-rmDupLinkables already ls-  = go already [] ls-  where-    go already extras [] = (already, extras)-    go already extras (l:ls)-        | linkableInSet l already = go already     extras     ls-        | otherwise               = go (l:already) (l:extras) ls--{- **********************************************************************--                The byte-code linker--  ********************************************************************* -}---dynLinkBCOs :: HscEnv -> PersistentLinkerState -> [Linkable]-            -> IO PersistentLinkerState-dynLinkBCOs hsc_env pls bcos = do--        let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos-            pls1                     = pls { bcos_loaded = bcos_loaded' }-            unlinkeds :: [Unlinked]-            unlinkeds                = concatMap linkableUnlinked new_bcos--            cbcs :: [CompiledByteCode]-            cbcs      = map byteCodeOfObject unlinkeds---            ies        = map bc_itbls cbcs-            gce       = closure_env pls-            final_ie  = foldr plusNameEnv (itbl_env pls) ies--        names_and_refs <- linkSomeBCOs hsc_env final_ie gce cbcs--        -- We only want to add the external ones to the ClosureEnv-        let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs--        -- Immediately release any HValueRefs we're not going to add-        freeHValueRefs hsc_env (map snd to_drop)-        -- Wrap finalizers on the ones we want to keep-        new_binds <- makeForeignNamedHValueRefs hsc_env to_add--        return pls1 { closure_env = extendClosureEnv gce new_binds,-                      itbl_env    = final_ie }---- Link a bunch of BCOs and return references to their values-linkSomeBCOs :: HscEnv-             -> ItblEnv-             -> ClosureEnv-             -> [CompiledByteCode]-             -> IO [(Name,HValueRef)]-                        -- The returned HValueRefs are associated 1-1 with-                        -- the incoming unlinked BCOs.  Each gives the-                        -- value of the corresponding unlinked BCO--linkSomeBCOs hsc_env ie ce mods = foldr fun do_link mods []- where-  fun CompiledByteCode{..} inner accum =-    case bc_breaks of-      Nothing -> inner ((panic "linkSomeBCOs: no break array", bc_bcos) : accum)-      Just mb -> withForeignRef (modBreaks_flags mb) $ \breakarray ->-                   inner ((breakarray, bc_bcos) : accum)--  do_link [] = return []-  do_link mods = do-    let flat = [ (breakarray, bco) | (breakarray, bcos) <- mods, bco <- bcos ]-        names = map (unlinkedBCOName . snd) flat-        bco_ix = mkNameEnv (zip names [0..])-    resolved <- sequence [ linkBCO hsc_env ie ce bco_ix breakarray bco-                         | (breakarray, bco) <- flat ]-    hvrefs <- createBCOs hsc_env resolved-    return (zip names hvrefs)---- | Useful to apply to the result of 'linkSomeBCOs'-makeForeignNamedHValueRefs-  :: HscEnv -> [(Name,HValueRef)] -> IO [(Name,ForeignHValue)]-makeForeignNamedHValueRefs hsc_env bindings =-  mapM (\(n, hvref) -> (n,) <$> mkFinalizedHValue hsc_env hvref) bindings--{- **********************************************************************--                Unload some object modules--  ********************************************************************* -}---- ------------------------------------------------------------------------------ | Unloading old objects ready for a new compilation sweep.------ The compilation manager provides us with a list of linkables that it--- considers \"stable\", i.e. won't be recompiled this time around.  For--- each of the modules current linked in memory,------   * if the linkable is stable (and it's the same one -- the user may have---     recompiled the module on the side), we keep it,------   * otherwise, we unload it.------   * we also implicitly unload all temporary bindings at this point.----unload :: HscEnv-       -> [Linkable] -- ^ The linkables to *keep*.-       -> IO ()-unload hsc_env linkables-  = mask_ $ do -- mask, so we're safe from Ctrl-C in here--        -- Initialise the linker (if it's not been done already)-        initDynLinker hsc_env--        -- Extract DynLinker for passing into required places-        let dl = hsc_dynLinker hsc_env--        new_pls-            <- modifyPLS dl $ \pls -> do-                 pls1 <- unload_wkr hsc_env linkables pls-                 return (pls1, pls1)--        let dflags = hsc_dflags hsc_env-        debugTraceMsg dflags 3 $-          text "unload: retaining objs" <+> ppr (objs_loaded new_pls)-        debugTraceMsg dflags 3 $-          text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)-        return ()--unload_wkr :: HscEnv-           -> [Linkable]                -- stable linkables-           -> PersistentLinkerState-           -> IO PersistentLinkerState--- Does the core unload business--- (the wrapper blocks exceptions and deals with the PLS get and put)--unload_wkr hsc_env keep_linkables pls@PersistentLinkerState{..}  = do-  -- NB. careful strictness here to avoid keeping the old PLS when-  -- we're unloading some code.  -fghci-leak-check with the tests in-  -- testsuite/ghci can detect space leaks here.--  let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable keep_linkables--      discard keep l = not (linkableInSet l keep)--      (objs_to_unload, remaining_objs_loaded) =-         partition (discard objs_to_keep) objs_loaded-      (bcos_to_unload, remaining_bcos_loaded) =-         partition (discard bcos_to_keep) bcos_loaded--  mapM_ unloadObjs objs_to_unload-  mapM_ unloadObjs bcos_to_unload--  -- If we unloaded any object files at all, we need to purge the cache-  -- of lookupSymbol results.-  when (not (null (objs_to_unload ++-                   filter (not . null . linkableObjs) bcos_to_unload))) $-    purgeLookupSymbolCache hsc_env--  let !bcos_retained = mkModuleSet $ map linkableModule remaining_bcos_loaded--      -- 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 (n,_) = isExternalName n &&-                        nameModule n `elemModuleSet` bcos_retained--      itbl_env'     = filterNameEnv keep_name itbl_env-      closure_env'  = filterNameEnv keep_name closure_env--      !new_pls = pls { itbl_env = itbl_env',-                       closure_env = closure_env',-                       bcos_loaded = remaining_bcos_loaded,-                       objs_loaded = remaining_objs_loaded }--  return new_pls-  where-    unloadObjs :: Linkable -> IO ()-    unloadObjs lnk-        -- The RTS's PEi386 linker currently doesn't support unloading.-      | isWindowsHost = return ()--      | hostIsDynamic = return ()-        -- We don't do any cleanup when linking objects with the-        -- dynamic linker.  Doing so introduces extra complexity for-        -- not much benefit.--      | otherwise-      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]-                -- The components of a BCO linkable may contain-                -- dot-o files.  Which is very confusing.-                ---                -- But the BCO parts can be unlinked just by-                -- letting go of them (plus of course depopulating-                -- the symbol table which is done in the main body)--{- **********************************************************************--                Loading packages--  ********************************************************************* -}--data LibrarySpec-   = Objects [FilePath] -- Full path names of set of .o files, including trailing .o-                        -- We allow batched loading to ensure that cyclic symbol-                        -- references can be resolved (see #13786).-                        -- For dynamic objects only, try to find the object-                        -- file in all the directories specified in-                        -- v_Library_paths before giving up.--   | Archive FilePath   -- Full path name of a .a file, including trailing .a--   | DLL String         -- "Unadorned" name of a .DLL/.so-                        --  e.g.    On unix     "qt"  denotes "libqt.so"-                        --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"-                        --  loadDLL is platform-specific and adds the lib/.so/.DLL-                        --  suffixes platform-dependently--   | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library-                        -- (ends with .dll or .so).--   | Framework String   -- Only used for darwin, but does no harm--instance Outputable LibrarySpec where-  ppr (Objects objs) = text "Objects" <+> ppr objs-  ppr (Archive a) = text "Archive" <+> text a-  ppr (DLL s) = text "DLL" <+> text s-  ppr (DLLPath f) = text "DLLPath" <+> text f-  ppr (Framework s) = text "Framework" <+> text s---- If this package is already part of the GHCi binary, we'll already--- have the right DLLs for this package loaded, so don't try to--- load them again.------ But on Win32 we must load them 'again'; doing so is a harmless no-op--- as far as the loader is concerned, but it does initialise the list--- of DLL handles that rts/Linker.c maintains, and that in turn is--- used by lookupSymbol.  So we must call addDLL for each library--- just to get the DLL handle into the list.-partOfGHCi :: [PackageName]-partOfGHCi- | isWindowsHost || isDarwinHost = []- | otherwise = map (PackageName . mkFastString)-                   ["base", "template-haskell", "editline"]--showLS :: LibrarySpec -> String-showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]"-showLS (Archive nm)   = "(static archive) " ++ nm-showLS (DLL nm)       = "(dynamic) " ++ nm-showLS (DLLPath nm)   = "(dynamic) " ++ nm-showLS (Framework nm) = "(framework) " ++ nm---- | Link exactly the specified packages, and their dependents (unless of--- course they are already linked).  The dependents are linked--- automatically, and it doesn't matter what order you specify the input--- packages.----linkPackages :: HscEnv -> [UnitId] -> IO ()--- NOTE: in fact, since each module tracks all the packages it depends on,---       we don't really need to use the package-config dependencies.------ However we do need the package-config stuff (to find aux libs etc),--- and following them lets us load libraries in the right order, which--- perhaps makes the error message a bit more localised if we get a link--- failure.  So the dependency walking code is still here.--linkPackages hsc_env new_pkgs = do-  -- It's probably not safe to try to load packages concurrently, so we take-  -- a lock.-  initDynLinker hsc_env-  let dl = hsc_dynLinker hsc_env-  modifyPLS_ dl $ \pls -> do-    linkPackages' hsc_env new_pkgs pls--linkPackages' :: HscEnv -> [UnitId] -> PersistentLinkerState-             -> IO PersistentLinkerState-linkPackages' hsc_env new_pks pls = do-    pkgs' <- link (pkgs_loaded pls) new_pks-    return $! pls { pkgs_loaded = pkgs' }-  where-     dflags = hsc_dflags hsc_env-     pkgstate = unitState dflags--     link :: [UnitId] -> [UnitId] -> IO [UnitId]-     link pkgs new_pkgs =-         foldM link_one pkgs new_pkgs--     link_one pkgs new_pkg-        | new_pkg `elem` pkgs   -- Already linked-        = return pkgs--        | Just pkg_cfg <- lookupUnitId pkgstate new_pkg-        = do {  -- Link dependents first-               pkgs' <- link pkgs (unitDepends pkg_cfg)-                -- Now link the package itself-             ; linkPackage hsc_env pkg_cfg-             ; return (new_pkg : pkgs') }--        | otherwise-        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))---linkPackage :: HscEnv -> UnitInfo -> IO ()-linkPackage hsc_env pkg-   = do-        let dflags    = hsc_dflags hsc_env-            platform  = targetPlatform dflags-            is_dyn    = interpreterDynamic (hscInterp hsc_env)-            dirs | is_dyn    = Packages.unitLibraryDynDirs pkg-                 | otherwise = Packages.unitLibraryDirs pkg--        let hs_libs   =  Packages.unitLibraries pkg-            -- The FFI GHCi import lib isn't needed as-            -- GHC.Runtime.Linker + rts/Linker.c link the-            -- interpreted references to FFI to the compiled FFI.-            -- We therefore filter it out so that we don't get-            -- duplicate symbol errors.-            hs_libs'  =  filter ("HSffi" /=) hs_libs--        -- Because of slight differences between the GHC dynamic linker and-        -- the native system linker some packages have to link with a-        -- different list of libraries when using GHCi. Examples include: libs-        -- that are actually gnu ld scripts, and the possibility that the .a-        -- libs do not exactly match the .so/.dll equivalents. So if the-        -- package file provides an "extra-ghci-libraries" field then we use-        -- that instead of the "extra-libraries" field.-            extra_libs =-                      (if null (Packages.unitExtDepLibsGhc pkg)-                            then Packages.unitExtDepLibsSys pkg-                            else Packages.unitExtDepLibsGhc pkg)-                      ++ [ lib | '-':'l':lib <- Packages.unitLinkerOptions pkg ]-        -- See Note [Fork/Exec Windows]-        gcc_paths <- getGCCPaths dflags (platformOS platform)-        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs--        hs_classifieds-           <- mapM (locateLib hsc_env True  dirs_env gcc_paths) hs_libs'-        extra_classifieds-           <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs-        let classifieds = hs_classifieds ++ extra_classifieds--        -- Complication: all the .so's must be loaded before any of the .o's.-        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]-            dlls       = [ dll  | DLL dll        <- classifieds ]-            objs       = [ obj  | Objects objs    <- classifieds-                                , obj <- objs ]-            archs      = [ arch | Archive arch   <- classifieds ]--        -- Add directories to library search paths-        let dll_paths  = map takeDirectory known_dlls-            all_paths  = nub $ map normalise $ dll_paths ++ dirs-        all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths-        pathCache <- mapM (addLibrarySearchPath hsc_env) all_paths_env--        maybePutStr dflags-            ("Loading package " ++ unitPackageIdString pkg ++ " ... ")--        -- See comments with partOfGHCi-#if defined(CAN_LOAD_DLL)-        when (unitPackageName pkg `notElem` partOfGHCi) $ do-            loadFrameworks hsc_env platform pkg-            -- See Note [Crash early load_dyn and locateLib]-            -- Crash early if can't load any of `known_dlls`-            mapM_ (load_dyn hsc_env True) known_dlls-            -- For remaining `dlls` crash early only when there is surely-            -- no package's DLL around ... (not is_dyn)-            mapM_ (load_dyn hsc_env (not is_dyn) . mkSOName platform) dlls-#endif-        -- After loading all the DLLs, we can load the static objects.-        -- Ordering isn't important here, because we do one final link-        -- step to resolve everything.-        mapM_ (loadObj hsc_env) objs-        mapM_ (loadArchive hsc_env) archs--        maybePutStr dflags "linking ... "-        ok <- resolveObjs hsc_env--        -- DLLs are loaded, reset the search paths-        -- Import libraries will be loaded via loadArchive so only-        -- reset the DLL search path after all archives are loaded-        -- as well.-        mapM_ (removeLibrarySearchPath hsc_env) $ reverse pathCache--        if succeeded ok-           then maybePutStrLn dflags "done."-           else let errmsg = "unable to load package `"-                             ++ unitPackageIdString pkg ++ "'"-                 in throwGhcExceptionIO (InstallationError errmsg)--{--Note [Crash early load_dyn and locateLib]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a package is "normal" (exposes it's code from more than zero Haskell-modules, unlike e.g. that in ghcilink004) and is built "dyn" way, then-it has it's code compiled and linked into the DLL, which GHCi linker picks-when loading the package's code (see the big comment in the beginning of-`locateLib`).--When loading DLLs, GHCi linker simply calls the system's `dlopen` or-`LoadLibrary` APIs. This is quite different from the case when GHCi linker-loads an object file or static library. When loading an object file or static-library GHCi linker parses them and resolves all symbols "manually".-These object file or static library may reference some external symbols-defined in some external DLLs. And GHCi should know which these-external DLLs are.--But when GHCi loads a DLL, it's the *system* linker who manages all-the necessary dependencies, and it is able to load this DLL not having-any extra info. Thus we don't *have to* crash in this case even if we-are unable to load any supposed dependencies explicitly.--Suppose during GHCi session a client of the package wants to-`foreign import` a symbol which isn't exposed by the package DLL, but-is exposed by such an external (dependency) DLL.-If the DLL isn't *explicitly* loaded because `load_dyn` failed to do-this, then the client code eventually crashes because the GHCi linker-isn't able to locate this symbol (GHCi linker maintains a list of-explicitly loaded DLLs it looks into when trying to find a symbol).--This is why we still should try to load all the dependency DLLs-even though we know that the system linker loads them implicitly when-loading the package DLL.--Why we still keep the `crash_early` opportunity then not allowing such-a permissive behaviour for any DLLs? Well, we, perhaps, improve a user-experience in some cases slightly.--But if it happens there exist other corner cases where our current-usage of `crash_early` flag is overly restrictive, we may lift the-restriction very easily.--}---- we have already searched the filesystem; the strings passed to load_dyn--- can be passed directly to loadDLL.  They are either fully-qualified--- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,--- loadDLL is going to search the system paths to find the library.-load_dyn :: HscEnv -> Bool -> FilePath -> IO ()-load_dyn hsc_env crash_early dll = do-  r <- loadDLL hsc_env dll-  case r of-    Nothing  -> return ()-    Just err ->-      if crash_early-        then cmdLineErrorIO err-        else let dflags = hsc_dflags hsc_env in-          when (wopt Opt_WarnMissedExtraSharedLib dflags)-            $ putLogMsg dflags-                (Reason Opt_WarnMissedExtraSharedLib) SevWarning-                  noSrcSpan $ withPprStyle defaultUserStyle (note err)-  where-    note err = vcat $ map text-      [ err-      , "It's OK if you don't want to use symbols from it directly."-      , "(the package DLL is loaded by the system linker"-      , " which manages dependencies by itself)." ]--loadFrameworks :: HscEnv -> Platform -> UnitInfo -> IO ()-loadFrameworks hsc_env platform pkg-    = when (platformUsesFrameworks platform) $ mapM_ load frameworks-  where-    fw_dirs    = Packages.unitExtDepFrameworkDirs pkg-    frameworks = Packages.unitExtDepFrameworks pkg--    load fw = do  r <- loadFramework hsc_env fw_dirs fw-                  case r of-                    Nothing  -> return ()-                    Just err -> cmdLineErrorIO ("can't load framework: "-                                                ++ fw ++ " (" ++ err ++ ")" )---- Try to find an object file for a given library in the given paths.--- If it isn't present, we assume that addDLL in the RTS can find it,--- which generally means that it should be a dynamic library in the--- standard system search path.--- For GHCi we tend to prefer dynamic libraries over static ones as--- they are easier to load and manage, have less overhead.-locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String-          -> IO LibrarySpec-locateLib hsc_env is_hs lib_dirs gcc_dirs lib-  | not is_hs-    -- For non-Haskell libraries (e.g. gmp, iconv):-    --   first look in library-dirs for a dynamic library (on User paths only)-    --   (libfoo.so)-    --   then  try looking for import libraries on Windows (on User paths only)-    --   (.dll.a, .lib)-    --   first look in library-dirs for a dynamic library (on GCC paths only)-    --   (libfoo.so)-    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)-    --   then  try looking for import libraries on Windows (on GCC paths only)-    --   (.dll.a, .lib)-    --   then  look in library-dirs for a static library (libfoo.a)-    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)-    --   then  try looking for import libraries on Windows (.dll.a, .lib)-    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)-    --   then  try "gcc --print-file-name" to search gcc's search path-    --       for a dynamic library (#5289)-    --   otherwise, assume loadDLL can find it-    ---    --   The logic is a bit complicated, but the rationale behind it is that-    --   loading a shared library for us is O(1) while loading an archive is-    --   O(n). Loading an import library is also O(n) so in general we prefer-    --   shared libraries because they are simpler and faster.-    ---  =-#if defined(CAN_LOAD_DLL)-    findDll   user `orElse`-#endif-    tryImpLib user `orElse`-#if defined(CAN_LOAD_DLL)-    findDll   gcc  `orElse`-    findSysDll     `orElse`-#endif-    tryImpLib gcc  `orElse`-    findArchive    `orElse`-    tryGcc         `orElse`-    assumeDll--  | loading_dynamic_hs_libs -- search for .so libraries first.-  = findHSDll     `orElse`-    findDynObject `orElse`-    assumeDll--  | otherwise-    -- use HSfoo.{o,p_o} if it exists, otherwise fallback to libHSfoo{,_p}.a-  = findObject  `orElse`-    findArchive `orElse`-    assumeDll--   where-     dflags = hsc_dflags hsc_env-     interp = hscInterp hsc_env-     dirs   = lib_dirs ++ gcc_dirs-     gcc    = False-     user   = True--     obj_file-       | is_hs && loading_profiled_hs_libs = lib <.> "p_o"-       | otherwise = lib <.> "o"-     dyn_obj_file = lib <.> "dyn_o"-     arch_files = [ "lib" ++ lib ++ lib_tag <.> "a"-                  , lib <.> "a" -- native code has no lib_tag-                  , "lib" ++ lib, lib-                  ]-     lib_tag = if is_hs && loading_profiled_hs_libs then "_p" else ""--     loading_profiled_hs_libs = interpreterProfiled interp-     loading_dynamic_hs_libs  = interpreterDynamic  interp--     import_libs  = [ lib <.> "lib"           , "lib" ++ lib <.> "lib"-                    , "lib" ++ lib <.> "dll.a", lib <.> "dll.a"-                    ]--     hs_dyn_lib_name = lib ++ '-':programName dflags ++ projectVersion dflags-     hs_dyn_lib_file = mkHsSOName platform hs_dyn_lib_name--     so_name     = mkSOName platform lib-     lib_so_name = "lib" ++ so_name-     dyn_lib_file = case (arch, os) of-                             (ArchX86_64, OSSolaris2) -> "64" </> so_name-                             _ -> so_name--     findObject    = liftM (fmap $ Objects . (:[]))  $ findFile dirs obj_file-     findDynObject = liftM (fmap $ Objects . (:[]))  $ findFile dirs dyn_obj_file-     findArchive   = let local name = liftM (fmap Archive) $ findFile dirs name-                     in  apply (map local arch_files)-     findHSDll     = liftM (fmap DLLPath) $ findFile dirs hs_dyn_lib_file-     findDll    re = let dirs' = if re == user then lib_dirs else gcc_dirs-                     in liftM (fmap DLLPath) $ findFile dirs' dyn_lib_file-     findSysDll    = fmap (fmap $ DLL . dropExtension . takeFileName) $-                        findSystemLibrary hsc_env so_name-     tryGcc        = let search   = searchForLibUsingGcc dflags-                         dllpath  = liftM (fmap DLLPath)-                         short    = dllpath $ search so_name lib_dirs-                         full     = dllpath $ search lib_so_name lib_dirs-                         gcc name = liftM (fmap Archive) $ search name lib_dirs-                         files    = import_libs ++ arch_files-                         dlls     = [short, full]-                         archives = map gcc files-                     in apply $-#if defined(CAN_LOAD_DLL)-                          dlls ++-#endif-                          archives-     tryImpLib re = case os of-                       OSMinGW32 ->-                        let dirs' = if re == user then lib_dirs else gcc_dirs-                            implib name = liftM (fmap Archive) $-                                            findFile dirs' name-                        in apply (map implib import_libs)-                       _         -> return Nothing--     -- TH Makes use of the interpreter so this failure is not obvious.-     -- So we are nice and warn/inform users why we fail before we do.-     -- But only for haskell libraries, as C libraries don't have a-     -- profiling/non-profiling distinction to begin with.-     assumeDll-      | is_hs-      , not loading_dynamic_hs_libs-      , interpreterProfiled interp-      = do-          warningMsg dflags-            (text "Interpreter failed to load profiled static library" <+> text lib <> char '.' $$-              text " \tTrying dynamic library instead. If this fails try to rebuild" <+>-              text "libraries with profiling support.")-          return (DLL lib)-      | otherwise = return (DLL lib)-     infixr `orElse`-     f `orElse` g = f >>= maybe g return--     apply :: [IO (Maybe a)] -> IO (Maybe a)-     apply []     = return Nothing-     apply (x:xs) = do x' <- x-                       if isJust x'-                          then return x'-                          else apply xs--     platform = targetPlatform dflags-     arch = platformArch platform-     os = platformOS platform--searchForLibUsingGcc :: DynFlags -> String -> [FilePath] -> IO (Maybe FilePath)-searchForLibUsingGcc dflags so dirs = do-   -- GCC does not seem to extend the library search path (using -L) when using-   -- --print-file-name. So instead pass it a new base location.-   str <- askLd dflags (map (FileOption "-B") dirs-                          ++ [Option "--print-file-name", Option so])-   let file = case lines str of-                []  -> ""-                l:_ -> l-   if (file == so)-      then return Nothing-      else do b <- doesFileExist file -- file could be a folder (see #16063)-              return (if b then Just file else Nothing)---- | Retrieve the list of search directory GCC and the System use to find---   libraries and components. See Note [Fork/Exec Windows].-getGCCPaths :: DynFlags -> OS -> IO [FilePath]-getGCCPaths dflags os-  = case os of-      OSMinGW32 ->-        do gcc_dirs <- getGccSearchDirectory dflags "libraries"-           sys_dirs <- getSystemDirectories-           return $ nub $ gcc_dirs ++ sys_dirs-      _         -> return []---- | Cache for the GCC search directories as this can't easily change---   during an invocation of GHC. (Maybe with some env. variable but we'll)---   deal with that highly unlikely scenario then.-{-# NOINLINE gccSearchDirCache #-}-gccSearchDirCache :: IORef [(String, [String])]-gccSearchDirCache = unsafePerformIO $ newIORef []---- Note [Fork/Exec Windows]--- ~~~~~~~~~~~~~~~~~~~~~~~~--- fork/exec is expensive on Windows, for each time we ask GCC for a library we--- have to eat the cost of af least 3 of these: gcc -> real_gcc -> cc1.--- So instead get a list of location that GCC would search and use findDirs--- which hopefully is written in an optimized mannor to take advantage of--- caching. At the very least we remove the overhead of the fork/exec and waits--- which dominate a large percentage of startup time on Windows.-getGccSearchDirectory :: DynFlags -> String -> IO [FilePath]-getGccSearchDirectory dflags key = do-    cache <- readIORef gccSearchDirCache-    case lookup key cache of-      Just x  -> return x-      Nothing -> do-        str <- askLd dflags [Option "--print-search-dirs"]-        let line = dropWhile isSpace str-            name = key ++ ": ="-        if null line-          then return []-          else do let val = split $ find name line-                  dirs <- filterM doesDirectoryExist val-                  modifyIORef' gccSearchDirCache ((key, dirs):)-                  return val-      where split :: FilePath -> [FilePath]-            split r = case break (==';') r of-                        (s, []    ) -> [s]-                        (s, (_:xs)) -> s : split xs--            find :: String -> String -> String-            find r x = let lst = lines x-                           val = filter (r `isPrefixOf`) lst-                       in if null val-                             then []-                             else case break (=='=') (head val) of-                                     (_ , [])    -> []-                                     (_, (_:xs)) -> xs---- | Get a list of system search directories, this to alleviate pressure on--- the findSysDll function.-getSystemDirectories :: IO [FilePath]-#if defined(mingw32_HOST_OS)-getSystemDirectories = fmap (:[]) getSystemDirectory-#else-getSystemDirectories = return []-#endif---- | Merge the given list of paths with those in the environment variable---   given. If the variable does not exist then just return the identity.-addEnvPaths :: String -> [String] -> IO [String]-addEnvPaths name list-  = do -- According to POSIX (chapter 8.3) a zero-length prefix means current-       -- working directory. Replace empty strings in the env variable with-       -- `working_dir` (see also #14695).-       working_dir <- getCurrentDirectory-       values <- lookupEnv name-       case values of-         Nothing  -> return list-         Just arr -> return $ list ++ splitEnv working_dir arr-    where-      splitEnv :: FilePath -> String -> [String]-      splitEnv working_dir value =-        case break (== envListSep) value of-          (x, []    ) ->-            [if null x then working_dir else x]-          (x, (_:xs)) ->-            (if null x then working_dir else x) : splitEnv working_dir xs-#if defined(mingw32_HOST_OS)-      envListSep = ';'-#else-      envListSep = ':'-#endif---- ------------------------------------------------------------------------------- Loading a dynamic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32)--{--Note [macOS Big Sur dynamic libraries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--macOS Big Sur makes the following change to how frameworks are shipped-with the OS:--> New in macOS Big Sur 11 beta, the system ships with a built-in-> dynamic linker cache of all system-provided libraries.  As part of-> this change, copies of dynamic libraries are no longer present on-> the filesystem.  Code that attempts to check for dynamic library-> presence by looking for a file at a path or enumerating a directory-> will fail.  Instead, check for library presence by attempting to-> dlopen() the path, which will correctly check for the library in the-> cache. (62986286)--(https://developer.apple.com/documentation/macos-release-notes/macos-big-sur-11-beta-release-notes/)--Therefore, the previous method of checking whether a library exists-before attempting to load it makes GHC.Runtime.Linker.loadFramework-fail to find frameworks installed at /System/Library/Frameworks.-Instead, any attempt to load a framework at runtime, such as by-passing -framework OpenGL to runghc or running code loading such a-framework with GHCi, fails with a 'not found' message.--GHC.Runtime.Linker.loadFramework now opportunistically loads the-framework libraries without checking for their existence first,-failing only if all attempts to load a given framework from any of the-various possible locations fail.  See also #18446, which this change-addresses.--}---- Darwin / MacOS X only: load a framework--- a framework is a dynamic library packaged inside a directory of the same--- name. They are searched for in different paths than normal libraries.-loadFramework :: HscEnv -> [FilePath] -> FilePath -> IO (Maybe String)-loadFramework hsc_env extraPaths rootname-   = do { either_dir <- tryIO getHomeDirectory-        ; let homeFrameworkPath = case either_dir of-                                  Left _ -> []-                                  Right dir -> [dir </> "Library/Frameworks"]-              ps = extraPaths ++ homeFrameworkPath ++ defaultFrameworkPaths-        ; errs <- findLoadDLL ps []-        ; return $ fmap (intercalate ", ") errs-        }-   where-     fwk_file = rootname <.> "framework" </> rootname--     -- sorry for the hardcoded paths, I hope they won't change anytime soon:-     defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]--     -- Try to call loadDLL for each candidate path.-     ---     -- See Note [macOS Big Sur dynamic libraries]-     findLoadDLL [] errs =-       -- Tried all our known library paths, but dlopen()-       -- has no built-in paths for frameworks: give up-       return $ Just errs-     findLoadDLL (p:ps) errs =-       do { dll <- loadDLL hsc_env (p </> fwk_file)-          ; case dll of-              Nothing  -> return Nothing-              Just err -> findLoadDLL ps ((p ++ ": " ++ err):errs)-          }--{- **********************************************************************--                Helper functions--  ********************************************************************* -}--maybePutStr :: DynFlags -> String -> IO ()-maybePutStr dflags s-    = when (verbosity dflags > 1) $-          putLogMsg dflags-              NoReason-              SevInteractive-              noSrcSpan-              $ withPprStyle defaultUserStyle (text s)--maybePutStrLn :: DynFlags -> String -> IO ()-maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")

− GHC/Runtime/Linker/Types.hs

@@ -1,108 +0,0 @@------------------------------------------------------------------------------------ Types for the Dynamic Linker------ (c) The University of Glasgow 2019-----------------------------------------------------------------------------------module GHC.Runtime.Linker.Types (-      DynLinker(..),-      PersistentLinkerState(..),-      Linkable(..),-      Unlinked(..),-      SptEntry(..)-    ) where--import GHC.Prelude             ( FilePath, String, show )-import Data.Time               ( UTCTime )-import Data.Maybe              ( Maybe )-import Control.Concurrent.MVar ( MVar )-import GHC.Unit                ( UnitId, Module )-import GHC.ByteCode.Types      ( ItblEnv, CompiledByteCode )-import GHC.Utils.Outputable-import GHC.Types.Var           ( Id )-import GHC.Fingerprint.Type    ( Fingerprint )-import GHC.Types.Name.Env      ( NameEnv )-import GHC.Types.Name          ( Name )-import GHCi.RemoteTypes        ( ForeignHValue )--type ClosureEnv = NameEnv (Name, ForeignHValue)--newtype DynLinker =-  DynLinker { dl_mpls :: MVar (Maybe PersistentLinkerState) }--data PersistentLinkerState-  = PersistentLinkerState {--       -- Current global mapping from Names to their true values-       closure_env :: ClosureEnv,--       -- The current global mapping from RdrNames of DataCons to-       -- info table addresses.-       -- When a new Unlinked is linked into the running image, or an existing-       -- module in the image is replaced, the itbl_env must be updated-       -- appropriately.-       itbl_env    :: !ItblEnv,--       -- The currently loaded interpreted modules (home package)-       bcos_loaded :: ![Linkable],--       -- And the currently-loaded compiled modules (home package)-       objs_loaded :: ![Linkable],--       -- The currently-loaded packages; always object code-       -- Held, as usual, in dependency order; though I am not sure if-       -- that is really important-       pkgs_loaded :: ![UnitId],--       -- we need to remember the name of previous temporary DLL/.so-       -- libraries so we can link them (see #10322)-       temp_sos :: ![(FilePath, String)] }---- | Information we can use to dynamically link modules into the compiler-data Linkable = LM {-  linkableTime     :: UTCTime,          -- ^ Time at which this linkable was built-                                        -- (i.e. when the bytecodes were produced,-                                        --       or the mod date on the files)-  linkableModule   :: Module,           -- ^ The linkable module itself-  linkableUnlinked :: [Unlinked]-    -- ^ Those files and chunks of code we have yet to link.-    ---    -- INVARIANT: A valid linkable always has at least one 'Unlinked' item.-    -- If this list is empty, the Linkable represents a fake linkable, which-    -- is generated in HscNothing mode to avoid recompiling modules.-    ---    -- ToDo: Do items get removed from this list when they get linked?- }--instance Outputable Linkable where-  ppr (LM when_made mod unlinkeds)-     = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)-       $$ nest 3 (ppr unlinkeds)---- | Objects which have yet to be linked by the compiler-data Unlinked-  = DotO FilePath      -- ^ An object file (.o)-  | DotA FilePath      -- ^ Static archive file (.a)-  | DotDLL FilePath    -- ^ Dynamically linked library file (.so, .dll, .dylib)-  | BCOs CompiledByteCode-         [SptEntry]    -- ^ A byte-code object, lives only in memory. Also-                       -- carries some static pointer table entries which-                       -- should be loaded along with the BCOs.-                       -- See Note [Grant plan for static forms] in-                       -- "GHC.Iface.Tidy.StaticPtrTable".--instance Outputable Unlinked where-  ppr (DotO path)   = text "DotO" <+> text path-  ppr (DotA path)   = text "DotA" <+> text path-  ppr (DotDLL path) = text "DotDLL" <+> text path-  ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt---- | An entry to be inserted into a module's static pointer table.--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-data SptEntry = SptEntry Id Fingerprint--instance Outputable SptEntry where-  ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr-

GHC/Runtime/Loader.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, MagicHash #-}+{-# LANGUAGE CPP #-}  -- | Dynamically lookup up values from modules and loading them. module GHC.Runtime.Loader (@@ -21,38 +21,47 @@     ) where  import GHC.Prelude+ import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Hooks+import GHC.Driver.Plugins -import GHC.Runtime.Linker      ( linkModule, getHValue )-import GHC.Runtime.Interpreter ( wormhole, withInterp )+import GHC.Linker.Loader       ( loadModule, loadName )+import GHC.Runtime.Interpreter ( wormhole, hscInterp ) import GHC.Runtime.Interpreter.Types-import GHC.Types.SrcLoc        ( noSrcSpan )-import GHC.Driver.Finder       ( findPluginModule, cannotFindModule )+ import GHC.Tc.Utils.Monad      ( initTcInteractive, initIfaceTcRn )-import GHC.Iface.Load          ( loadPluginInterface )-import GHC.Types.Name.Reader   ( RdrName, ImportSpec(..), ImpDeclSpec(..)-                               , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName-                               , gre_name, mkRdrQual )-import GHC.Types.Name.Occurrence ( OccName, mkVarOcc )+import GHC.Iface.Load          ( loadPluginInterface, cannotFindModule ) import GHC.Rename.Names ( gresFromAvails )-import GHC.Driver.Plugins import GHC.Builtin.Names ( pluginTyConName, frontendPluginTyConName ) -import GHC.Driver.Types+import GHC.Driver.Env import GHCi.RemoteTypes  ( HValue ) import GHC.Core.Type     ( Type, eqType, mkTyConTy )-import GHC.Core.TyCo.Ppr ( pprTyThingCategory ) import GHC.Core.TyCon    ( TyCon )++import GHC.Types.SrcLoc        ( noSrcSpan ) import GHC.Types.Name    ( Name, nameModule_maybe ) import GHC.Types.Id      ( idType )+import GHC.Types.TyThing+import GHC.Types.Name.Occurrence ( OccName, mkVarOcc )+import GHC.Types.Name.Reader   ( RdrName, ImportSpec(..), ImpDeclSpec(..)+                               , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName+                               , greMangledName, mkRdrQual )++import GHC.Unit.Finder         ( findPluginModule, FindResult(..) ) import GHC.Unit.Module   ( Module, ModuleName )+import GHC.Unit.Module.ModIface+ import GHC.Utils.Panic-import GHC.Data.FastString+import GHC.Utils.Logger import GHC.Utils.Error import GHC.Utils.Outputable import GHC.Utils.Exception-import GHC.Driver.Hooks +import GHC.Data.FastString+ import Control.Monad     ( unless ) import Data.Maybe        ( mapMaybe ) import Unsafe.Coerce     ( unsafeCoerce )@@ -61,22 +70,22 @@ -- flags. Should be called after command line arguments are parsed, but before -- actual compilation starts. Idempotent operation. Should be re-called if -- pluginModNames or pluginModNameOpts changes.-initializePlugins :: HscEnv -> DynFlags -> IO DynFlags-initializePlugins hsc_env df-  | map lpModuleName (cachedPlugins df)-         == pluginModNames df -- plugins not changed-     && all (\p -> paArguments (lpPlugin p)-                       == argumentsForPlugin p (pluginModNameOpts df))-            (cachedPlugins df) -- arguments not changed-  = return df -- no need to reload plugins+initializePlugins :: HscEnv -> IO HscEnv+initializePlugins hsc_env+    -- plugins not changed+  | map lpModuleName (hsc_plugins hsc_env) == pluginModNames dflags+   -- arguments not changed+  , all same_args (hsc_plugins hsc_env)+  = return hsc_env -- no need to reload plugins   | otherwise-  = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })-       let df' = df { cachedPlugins = loadedPlugins }-       df'' <- withPlugins df' runDflagsPlugin df'-       return df''--  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)-        runDflagsPlugin p opts dynflags = dynflagsPlugin p opts dynflags+  = do loaded_plugins <- loadPlugins hsc_env+       let hsc_env' = hsc_env { hsc_plugins = loaded_plugins }+       withPlugins hsc_env' driverPlugin hsc_env'+  where+    plugin_args = pluginModNameOpts dflags+    same_args p = paArguments (lpPlugin p) == argumentsForPlugin p plugin_args+    argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)+    dflags = hsc_dflags hsc_env  loadPlugins :: HscEnv -> IO [LoadedPlugin] loadPlugins hsc_env@@ -104,11 +113,10 @@  -- #14335 checkExternalInterpreter :: HscEnv -> IO ()-checkExternalInterpreter hsc_env-  | Just (ExternalInterp {}) <- hsc_interp hsc_env-  = throwIO (InstallationError "Plugins require -fno-external-interpreter")-  | otherwise-  = pure ()+checkExternalInterpreter hsc_env = case interpInstance <$> hsc_interp hsc_env of+  Just (ExternalInterp {})+    -> throwIO (InstallationError "Plugins require -fno-external-interpreter")+  _ -> pure ()  loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO (a, ModIface) loadPlugin' occ_name plugin_name hsc_env mod_name@@ -160,7 +168,7 @@ forceLoadTyCon hsc_env con_name = do     forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of loadTyConTy") con_name -    mb_con_thing <- lookupTypeHscEnv hsc_env con_name+    mb_con_thing <- lookupType hsc_env con_name     case mb_con_thing of         Nothing -> throwCmdLineErrorS dflags $ missingTyThingError con_name         Just (ATyCon tycon) -> return tycon@@ -179,20 +187,25 @@  getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) getValueSafely hsc_env val_name expected_type = do-  mb_hval <- lookupHook getValueSafelyHook getHValueSafely dflags hsc_env val_name expected_type+  mb_hval <- case getValueSafelyHook hooks of+    Nothing -> getHValueSafely interp hsc_env val_name expected_type+    Just h  -> h                      hsc_env val_name expected_type   case mb_hval of     Nothing   -> return Nothing     Just hval -> do-      value <- lessUnsafeCoerce dflags "getValueSafely" hval+      value <- lessUnsafeCoerce logger dflags "getValueSafely" hval       return (Just value)   where+    interp = hscInterp hsc_env     dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env+    hooks  = hsc_hooks hsc_env -getHValueSafely :: HscEnv -> Name -> Type -> IO (Maybe HValue)-getHValueSafely hsc_env val_name expected_type = do+getHValueSafely :: Interp -> HscEnv -> Name -> Type -> IO (Maybe HValue)+getHValueSafely interp hsc_env val_name expected_type = do     forceLoadNameModuleInterface hsc_env (text "contains a name used in an invocation of getHValueSafely") val_name     -- Now look up the names for the value and type constructor in the type environment-    mb_val_thing <- lookupTypeHscEnv hsc_env val_name+    mb_val_thing <- lookupType hsc_env val_name     case mb_val_thing of         Nothing -> throwCmdLineErrorS dflags $ missingTyThingError val_name         Just (AnId id) -> do@@ -202,11 +215,13 @@              then do                 -- Link in the module that contains the value, if it has such a module                 case nameModule_maybe val_name of-                    Just mod -> do linkModule hsc_env mod+                    Just mod -> do loadModule interp hsc_env mod                                    return ()                     Nothing ->  return ()                 -- Find the value that we just linked in and cast it given that we have proved it's type-                hval <- withInterp hsc_env $ \interp -> getHValue hsc_env val_name >>= wormhole interp+                hval <- do+                  v <- loadName interp hsc_env val_name+                  wormhole interp v                 return (Just hval)              else return Nothing         Just val_thing -> throwCmdLineErrorS dflags $ wrongTyThingError val_name val_thing@@ -218,12 +233,12 @@ -- -- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened --    if it /does/ segfault-lessUnsafeCoerce :: DynFlags -> String -> a -> IO b-lessUnsafeCoerce dflags context what = do-    debugTraceMsg dflags 3 $ (text "Coercing a value in") <+> (text context) <>-                             (text "...")+lessUnsafeCoerce :: Logger -> DynFlags -> String -> a -> IO b+lessUnsafeCoerce logger dflags context what = do+    debugTraceMsg logger dflags 3 $+        (text "Coercing a value in") <+> (text context) <> (text "...")     output <- evaluate (unsafeCoerce what)-    debugTraceMsg dflags 3 (text "Successfully evaluated coercion")+    debugTraceMsg logger dflags 3 (text "Successfully evaluated coercion")     return output  @@ -260,12 +275,12 @@                         imp_spec = ImpSpec decl_spec ImpAll                         env = mkGlobalRdrEnv (gresFromAvails (Just imp_spec) (mi_exports iface))                     case lookupGRE_RdrName rdr_name env of-                        [gre] -> return (Just (gre_name gre, iface))+                        [gre] -> return (Just (greMangledName gre, iface))                         []    -> return Nothing                         _     -> panic "lookupRdrNameInModule"                  Nothing -> throwCmdLineErrorS dflags $ hsep [text "Could not determine the exports of the module", ppr mod_name]-        err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err+        err -> throwCmdLineErrorS dflags $ cannotFindModule hsc_env mod_name err   where     dflags = hsc_dflags hsc_env     doc = text "contains a name used in an invocation of lookupRdrNameInModule"

GHC/Settings.hs view

@@ -6,11 +6,10 @@   , ToolSettings (..)   , FileSettings (..)   , GhcNameVersion (..)-  , PlatformConstants (..)   , Platform (..)   , PlatformMisc (..)-  , PlatformMini (..)   -- * Accessors+  , dynLibSuffix   , sProgramName   , sProjectVersion   , sGhcUsagePath@@ -63,8 +62,6 @@   , sGhcWithSMP   , sGhcRTSWays   , sLibFFI-  , sGhcThreaded-  , sGhcDebugged   , sGhcRtsWithLibdw   ) where @@ -80,7 +77,6 @@   , sTargetPlatform    :: Platform       -- Filled in by SysTools   , sToolSettings      :: {-# UNPACK #-} !ToolSettings   , sPlatformMisc      :: {-# UNPACK #-} !PlatformMisc-  , sPlatformConstants :: PlatformConstants    -- You shouldn't need to look things up in rawSettings directly.   -- They should have their own fields instead.@@ -166,9 +162,9 @@   , ghcNameVersion_projectVersion :: String   } --- Produced by deriveConstants--- Provides PlatformConstants datatype-#include "GHCConstantsHaskellType.hs"+-- | Dynamic library suffix+dynLibSuffix :: GhcNameVersion -> String+dynLibSuffix (GhcNameVersion name ver) = '-':name ++ ver  ----------------------------------------------------------------------------- -- Accessessors from 'Settings'@@ -282,9 +278,5 @@ sGhcRTSWays = platformMisc_ghcRTSWays . sPlatformMisc sLibFFI :: Settings -> Bool sLibFFI = platformMisc_libFFI . sPlatformMisc-sGhcThreaded :: Settings -> Bool-sGhcThreaded = platformMisc_ghcThreaded . sPlatformMisc-sGhcDebugged :: Settings -> Bool-sGhcDebugged = platformMisc_ghcDebugged . sPlatformMisc sGhcRtsWithLibdw :: Settings -> Bool sGhcRtsWithLibdw = platformMisc_ghcRtsWithLibdw . sPlatformMisc

+ GHC/Settings/Config.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE CPP #-}+module GHC.Settings.Config+  ( module GHC.Version+  , cBuildPlatformString+  , cHostPlatformString+  , cProjectName+  , cBooterVersion+  , cStage+  ) where++import GHC.Prelude++import GHC.Version++cBuildPlatformString :: String+cBuildPlatformString = "x86_64-unknown-linux"++cHostPlatformString :: String+cHostPlatformString = "x86_64-unknown-linux"++cProjectName          :: String+cProjectName          = "The Glorious Glasgow Haskell Compilation System"++cBooterVersion        :: String+cBooterVersion        = "8.10.4"++cStage                :: String+cStage                = show (2 :: Int)

GHC/Settings/Constants.hs view

@@ -11,14 +11,14 @@ -- All pretty arbitrary:  mAX_TUPLE_SIZE :: Int-mAX_TUPLE_SIZE = 62 -- Should really match the number-                    -- of decls in Data.Tuple+mAX_TUPLE_SIZE = 64 -- Should really match the number+                    -- of decls in GHC.Tuple  mAX_CTUPLE_SIZE :: Int   -- Constraint tuples-mAX_CTUPLE_SIZE = 62     -- Should match the number of decls in GHC.Classes+mAX_CTUPLE_SIZE = 64     -- Should match the number of decls in GHC.Classes  mAX_SUM_SIZE :: Int-mAX_SUM_SIZE = 62+mAX_SUM_SIZE = 64  -- | Default maximum depth for both class instance search and type family -- reduction. See also #5395.

GHC/Settings/IO.hs view

@@ -11,14 +11,13 @@  import GHC.Prelude -import GHC.Settings.Platform import GHC.Settings.Utils  import GHC.Settings.Config import GHC.Utils.CliOption import GHC.Utils.Fingerprint import GHC.Platform-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Settings import GHC.SysTools.BaseDir @@ -49,7 +48,6 @@       libexec :: FilePath -> FilePath       libexec file = top_dir </> "bin" </> file       settingsFile = installed "settings"-      platformConstantsFile = installed "platformConstants"        readFileSafe :: FilePath -> ExceptT SettingsError m String       readFileSafe path = liftIO (doesFileExist path) >>= \case@@ -57,26 +55,21 @@         False -> throwE $ SettingsError_MissingData $ "Missing file: " ++ path    settingsStr <- readFileSafe settingsFile-  platformConstantsStr <- readFileSafe platformConstantsFile   settingsList <- case maybeReadFuzzy settingsStr of     Just s -> pure s     Nothing -> throwE $ SettingsError_BadData $       "Can't parse " ++ show settingsFile   let mySettings = Map.fromList settingsList-  platformConstants <- case maybeReadFuzzy platformConstantsStr of-    Just s -> pure s-    Nothing -> throwE $ SettingsError_BadData $-      "Can't parse " ++ show platformConstantsFile   -- See Note [Settings file] for a little more about this file. We're   -- just partially applying those functions and throwing 'Left's; they're   -- written in a very portable style to keep ghc-boot light.   let getSetting key = either pgmError pure $-        getFilePathSetting0 top_dir settingsFile mySettings key+        getRawFilePathSetting top_dir settingsFile mySettings key       getToolSetting :: String -> ExceptT SettingsError m String       getToolSetting key = expandToolDir mtool_dir <$> getSetting key       getBooleanSetting :: String -> ExceptT SettingsError m Bool       getBooleanSetting key = either pgmError pure $-        getBooleanSetting0 settingsFile mySettings key+        getRawBooleanSetting settingsFile mySettings key   targetPlatformString <- getSetting "target platform string"   myExtraGccViaCFlags <- getSetting "GCC extra via C opts"   -- On Windows, mingw is distributed with GHC,@@ -156,8 +149,6 @@   ghcWithSMP <- getBooleanSetting "Support SMP"   ghcRTSWays <- getSetting "RTS ways"   useLibFFI <- getBooleanSetting "Use LibFFI"-  ghcThreaded <- getBooleanSetting "Use Threads"-  ghcDebugged <- getBooleanSetting "Use Debugging"   ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"    return $ Settings@@ -226,13 +217,44 @@       , platformMisc_ghcWithSMP = ghcWithSMP       , platformMisc_ghcRTSWays = ghcRTSWays       , platformMisc_libFFI = useLibFFI-      , platformMisc_ghcThreaded = ghcThreaded-      , platformMisc_ghcDebugged = ghcDebugged       , platformMisc_ghcRtsWithLibdw = ghcRtsWithLibdw       , platformMisc_llvmTarget = llvmTarget       } -    , sPlatformConstants = platformConstants-     , sRawSettings    = settingsList+    }++getTargetPlatform+  :: FilePath     -- ^ Settings filepath (for error messages)+  -> RawSettings  -- ^ Raw settings file contents+  -> Either String Platform+getTargetPlatform settingsFile settings = do+  let+    getBooleanSetting = getRawBooleanSetting settingsFile settings+    readSetting :: (Show a, Read a) => String -> Either String a+    readSetting = readRawSetting settingsFile settings++  targetArchOS <- getTargetArchOS settingsFile settings+  targetWordSize <- readSetting "target word size"+  targetWordBigEndian <- getBooleanSetting "target word big endian"+  targetLeadingUnderscore <- getBooleanSetting "Leading underscore"+  targetUnregisterised <- getBooleanSetting "Unregisterised"+  targetHasGnuNonexecStack <- getBooleanSetting "target has GNU nonexec stack"+  targetHasIdentDirective <- getBooleanSetting "target has .ident directive"+  targetHasSubsectionsViaSymbols <- getBooleanSetting "target has subsections via symbols"+  crossCompiling <- getBooleanSetting "cross compiling"+  tablesNextToCode <- getBooleanSetting "Tables next to code"++  pure $ Platform+    { platformArchOS    = targetArchOS+    , platformWordSize  = targetWordSize+    , platformByteOrder = if targetWordBigEndian then BigEndian else LittleEndian+    , platformUnregisterised = targetUnregisterised+    , platformHasGnuNonexecStack = targetHasGnuNonexecStack+    , platformHasIdentDirective = targetHasIdentDirective+    , platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols+    , platformIsCrossCompiling = crossCompiling+    , platformLeadingUnderscore = targetLeadingUnderscore+    , platformTablesNextToCode  = tablesNextToCode+    , platform_constants = Nothing -- will be filled later when loading (or building) the RTS unit     }

GHC/Stg/CSE.hs view

@@ -95,13 +95,13 @@ import GHC.Core.DataCon import GHC.Types.Id import GHC.Stg.Syntax-import GHC.Utils.Outputable import GHC.Types.Basic (isWeakLoopBreaker) import GHC.Types.Var.Env import GHC.Core (AltCon(..)) import Data.List (mapAccumL) import Data.Maybe (fromMaybe)-import GHC.Core.Map+import GHC.Core.Map.Expr+import GHC.Data.TrieMap import GHC.Types.Name.Env import Control.Monad( (>=>) ) @@ -128,6 +128,8 @@     foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)     mapTM f (SAM {sam_var = varm, sam_lit = litm}) =         SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }+    filterTM f (SAM {sam_var = varm, sam_lit = litm}) =+        SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }  newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } @@ -139,6 +141,7 @@         m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }     foldTM k = un_cam >.> foldTM (foldTM k)     mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM+    filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM  ----------------- -- The CSE Env --@@ -289,8 +292,8 @@ stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)     = let body' = stgCseExpr (initEnv in_scope) body       in  StgRhsClosure ext ccs upd args body'-stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)-    = StgRhsCon ccs dataCon args+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon mu ticks args)+    = StgRhsCon ccs dataCon mu ticks args  ------------------------------ -- The actual AST traversal --@@ -307,8 +310,6 @@ stgCseExpr env (StgOpApp op args tys)     = StgOpApp op args' tys   where args' = substArgs env args-stgCseExpr _ (StgLam _ _)-    = pprPanic "stgCseExp" (text "StgLam") stgCseExpr env (StgTick tick body)     = let body' = stgCseExpr env body       in StgTick tick body'@@ -325,11 +326,11 @@  -- A constructor application. -- To be removed by a variable use when found in the CSE environment-stgCseExpr env (StgConApp dataCon args tys)+stgCseExpr env (StgConApp dataCon n args tys)     | Just bndr' <- envLookup dataCon args' env     = StgApp bndr' []     | otherwise-    = StgConApp dataCon args' tys+    = StgConApp dataCon n args' tys   where args' = substArgs env args  -- Let bindings@@ -394,7 +395,7 @@ -- The RHS of a binding. -- If it is a constructor application, either short-cut it or extend the environment stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)-stgCseRhs env bndr (StgRhsCon ccs dataCon args)+stgCseRhs env bndr (StgRhsCon ccs dataCon mu ticks args)     | Just other_bndr <- envLookup dataCon args' env     , not (isWeakLoopBreaker (idOccInfo bndr)) -- See Note [Care with loop breakers]     = let env' = addSubst bndr other_bndr env@@ -402,7 +403,7 @@     | otherwise     = let env' = addDataCon bndr dataCon args' env             -- see note [Case 1: CSEing allocated closures]-          pair = (bndr, StgRhsCon ccs dataCon args')+          pair = (bndr, StgRhsCon ccs dataCon mu ticks args')       in (Just pair, env')   where args' = substArgs env args

+ GHC/Stg/Debug.hs view

@@ -0,0 +1,240 @@+{-# LANGUAGE TupleSections #-}+-- This module contains functions which implement+-- the -finfo-table-map and -fdistinct-constructor-tables flags+module GHC.Stg.Debug(collectDebugInformation) where+++import GHC.Prelude++import GHC.Stg.Syntax++import GHC.Types.Id+import GHC.Types.Tickish+import GHC.Core.DataCon+import GHC.Types.IPE+import GHC.Unit.Module+import GHC.Types.Name   ( getName, getOccName, occNameString, nameSrcSpan)+import GHC.Data.FastString+import GHC.Driver.Session++import Control.Monad (when)+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State+import Control.Monad.Trans.Class+import GHC.Types.Unique.Map+import GHC.Types.SrcLoc+import Control.Applicative+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty (NonEmpty(..))++data SpanWithLabel = SpanWithLabel RealSrcSpan String++data R = R { rDynFlags :: DynFlags, rModLocation :: ModLocation, rSpan :: Maybe SpanWithLabel }++type M a = ReaderT R (State InfoTableProvMap) a++withSpan :: (RealSrcSpan, String) -> M a -> M a+withSpan (new_s, new_l) act = local maybe_replace act+  where+    maybe_replace r@R{ rModLocation = cur_mod, rSpan = Just (SpanWithLabel old_s _old_l) }+      -- prefer spans from the current module+      | Just (unpackFS $ srcSpanFile old_s) == ml_hs_file cur_mod+      , Just (unpackFS $ srcSpanFile new_s) /= ml_hs_file cur_mod+      = r+    maybe_replace r+      = r { rSpan = Just (SpanWithLabel new_s new_l) }++collectDebugInformation :: DynFlags -> ModLocation -> [StgTopBinding] -> ([StgTopBinding], InfoTableProvMap)+collectDebugInformation dflags ml bs =+    runState (runReaderT (mapM collectTop bs) (R dflags ml Nothing)) emptyInfoTableProvMap++collectTop :: StgTopBinding -> M StgTopBinding+collectTop (StgTopLifted t) = StgTopLifted <$> collectStgBind t+collectTop tb = return tb++collectStgBind :: StgBinding -> M StgBinding+collectStgBind  (StgNonRec bndr rhs) = do+    rhs' <- collectStgRhs bndr rhs+    return (StgNonRec bndr rhs')+collectStgBind (StgRec pairs) = do+    es <- mapM (\(b, e) -> (b,) <$> collectStgRhs b e) pairs+    return (StgRec es)++collectStgRhs :: Id -> StgRhs -> M StgRhs+collectStgRhs bndr (StgRhsClosure ext cc us bs e)= do+  e' <- collectExpr e+  recordInfo bndr e'+  return $ StgRhsClosure ext cc us bs e'+collectStgRhs _bndr (StgRhsCon cc dc _mn ticks args) = do+  n' <- numberDataCon dc ticks+  return (StgRhsCon cc dc n' ticks args)+++recordInfo :: Id -> StgExpr -> M ()+recordInfo bndr new_rhs = do+  modLoc <- asks rModLocation+  let+    thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc+    -- A span from the ticks surrounding the new_rhs+    best_span = quickSourcePos thisFile new_rhs+    -- A back-up span if the bndr had a source position, many do not (think internally generated ids)+    bndr_span = (\s -> SpanWithLabel s (occNameString (getOccName bndr)))+                  <$> srcSpanToRealSrcSpan (nameSrcSpan (getName bndr))+  recordStgIdPosition bndr best_span bndr_span++collectExpr :: StgExpr -> M StgExpr+collectExpr = go+  where+    go (StgApp occ as) = return $ StgApp occ as+    go (StgLit lit) = return $ StgLit lit+    go (StgConApp dc _mn as tys) = do+      n' <- numberDataCon dc []+      return (StgConApp dc n' as tys)+    go (StgOpApp op as ty) = return (StgOpApp op as ty)+    go (StgCase scrut bndr ty alts) =+      StgCase <$> collectExpr scrut <*> pure bndr <*> pure ty <*> mapM collectAlt alts+    go (StgLet ext bind body) = do+        bind' <- collectStgBind bind+        body' <- go body+        return (StgLet ext bind' body')+    go (StgLetNoEscape ext bind body) = do+        bind' <- collectStgBind bind+        body' <- go body+        return (StgLetNoEscape ext bind' body')++    go (StgTick tick e) = do+       let k = case tick of+                SourceNote ss fp -> withSpan (ss, fp)+                _ -> id+       e' <- k (go e)+       return (StgTick tick e')++collectAlt :: StgAlt -> M StgAlt+collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e++-- | Try to find the best source position surrounding a 'StgExpr'. The+-- heuristic strips ticks from the current expression until it finds one which+-- is from the module currently being compiled. This is the same method that+-- the DWARF information uses to give locations to info tables.+--+-- It is usually a better alternative than using the 'RealSrcSpan' which is carefully+-- propagated downwards by 'withSpan'. It's "quick" because it works only using immediate context rather+-- than looking at the parent context like 'withSpan'+quickSourcePos :: FastString -> StgExpr -> Maybe SpanWithLabel+quickSourcePos cur_mod (StgTick (SourceNote ss m) e)+  | srcSpanFile ss == cur_mod = Just (SpanWithLabel ss m)+  | otherwise = quickSourcePos cur_mod e+quickSourcePos _ _ = Nothing++recordStgIdPosition :: Id -> Maybe SpanWithLabel -> Maybe SpanWithLabel -> M ()+recordStgIdPosition id best_span ss = do+  dflags <- asks rDynFlags+  when (gopt Opt_InfoTableMap dflags) $ do+    cc <- asks rSpan+    --Useful for debugging why a certain Id gets given a certain span+    --pprTraceM "recordStgIdPosition" (ppr id $$ ppr cc $$ ppr best_span $$ ppr ss)+    let mbspan = (\(SpanWithLabel rss d) -> (rss, d)) <$> (best_span <|> cc <|> ss)+    lift $ modify (\env -> env { provClosure = addToUniqMap (provClosure env) (idName id) (idType id, mbspan) })++numberDataCon :: DataCon -> [StgTickish] -> M ConstructorNumber+-- Unboxed tuples and sums do not allocate so they+-- have no info tables.+numberDataCon dc _ | isUnboxedTupleDataCon dc = return NoNumber+numberDataCon dc _ | isUnboxedSumDataCon dc = return NoNumber+numberDataCon dc ts = do+  dflags <- asks rDynFlags+  if not (gopt Opt_DistinctConstructorTables dflags) then return NoNumber else do+    env <- lift get+    mcc <- asks rSpan+    let mbest_span = (\(SpanWithLabel rss l) -> (rss, l)) <$> (selectTick ts <|> mcc)+    let dcMap' = alterUniqMap (maybe (Just ((0, mbest_span) :| [] ))+                        (\xs@((k, _):|_) -> Just ((k + 1, mbest_span) `NE.cons` xs))) (provDC env) dc+    lift $ put (env { provDC = dcMap' })+    let r = lookupUniqMap dcMap' dc+    return $ case r of+      Nothing -> NoNumber+      Just res -> Numbered (fst (NE.head res))++selectTick :: [StgTickish] -> Maybe SpanWithLabel+selectTick [] = Nothing+selectTick (SourceNote rss d : ts ) = selectTick ts <|> Just (SpanWithLabel rss d)+selectTick (_:ts) = selectTick ts++{-+Note [Mapping Info Tables to Source Positions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This note describes what the `-finfo-table-map` flag achieves.++When debugging memory issues it is very useful to be able to map a specific closure+to a position in the source. The prime example is being able to map a THUNK to+a specific place in the source program, the mapping is usually quite precise because+a fresh info table is created for each distinct THUNK.++There are three parts to the implementation++1. In GHC.Stg.Debug, the SourceNote information is used in order to give a source location to+some specific closures.+2. In StgToCmm, the actually used info tables are recorded in an IORef, this+is important as it's hard to predict beforehand what code generation will do+and which ids will end up in the generated program.+3. During code generation, a mapping from the info table to the statically+determined location is emitted which can then be queried at runtime by+various tools.++-- Giving Source Locations to Closures++At the moment thunk and constructor closures are added to the map. This information+is collected in the `InfoTableProvMap` which provides a mapping from:++1. Data constructors to a list of where they are used.+2. `Name`s and where they originate from.++During the CoreToStg phase, this map is populated whenever something is turned into+a StgRhsClosure or an StgConApp. The current source position is recorded+depending on the location indicated by the surrounding SourceNote.++The functions which add information to the map are `recordStgIdPosition` and+`numberDataCon`.++When the -fdistinct-constructor-tables` flag is turned on then every+usage of a data constructor gets its own distinct info table. This is orchestrated+in `collectExpr` where an incrementing number is used to distinguish each+occurrence of a data constructor.++-- StgToCmm++The info tables which are actually used in the generated program are recorded during the+conversion from STG to Cmm. The used info tables are recorded in the `emitProc` function.+All the used info tables are recorded in the `cgs_used_info` field. This step+is necessary because when the information about names is collected in the previous+phase it's unpredictable about which names will end up needing info tables. If+you don't record which ones are actually used then you end up generating code+which references info tables which don't exist.++-- Code Generation++The output of these two phases is combined together during code generation.+A C stub is generated which+creates the static map from info table pointer to the information about where that+info table was created from. This is created by `ipInitCode` in the same manner as a+C stub is generated for cost centres.++This information can be consumed in two ways.++1. The complete mapping is emitted into the eventlog so that external tools such+as eventlog2html can use the information with the heap profile by info table mode.+2. The `lookupIPE` function can be used via the `whereFrom#` primop to introspect+information about a closure in a running Haskell program.++Note [Distinct Info Tables for Constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In the old times, each usage of a data constructor used the same info table.+This made it impossible to distinguish which actual usuage of a data constructor was+contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you+can cause code generation to generate a distinct info table for each usage of+a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor+was responsible for each allocation.++-}

GHC/Stg/DepAnal.hs view

@@ -9,6 +9,7 @@ import GHC.Types.Name (Name, nameIsLocalOrFrom) import GHC.Types.Name.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique.Set (nonDetEltsUniqSet) import GHC.Types.Var.Set import GHC.Unit.Module (Module)@@ -61,7 +62,7 @@     rhs bounds (StgRhsClosure _ _ _ as e) =       expr (extendVarSetList bounds as) e -    rhs bounds (StgRhsCon _ _ as) =+    rhs bounds (StgRhsCon _ _ _ _ as) =       args bounds as      var :: BVs -> Var -> FVs@@ -86,12 +87,10 @@     expr _ StgLit{} =       emptyVarSet -    expr bounds (StgConApp _ as _) =+    expr bounds (StgConApp _ _ as _) =       args bounds as     expr bounds (StgOpApp _ as _) =       args bounds as-    expr _ lam@StgLam{} =-      pprPanic "annTopBindingsDeps" (text "Found lambda:" $$ pprStgExpr panicStgPprOpts lam)     expr bounds (StgCase scrut scrut_bndr _ as) =       expr bounds scrut `unionVarSet`         alts (extendVarSet bounds scrut_bndr) as

GHC/Stg/FVs.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+ {- | Non-global free variable analysis on STG terms. This pass annotates non-top-level closure bindings with captured variables. Global variables are not@@ -47,8 +49,7 @@ import GHC.Stg.Syntax import GHC.Types.Id import GHC.Types.Var.Set-import GHC.Core    ( Tickish(Breakpoint) )-import GHC.Utils.Outputable+import GHC.Types.Tickish ( GenTickish(Breakpoint) ) import GHC.Utils.Misc  import Data.Maybe ( mapMaybe )@@ -125,9 +126,8 @@     go (StgApp occ as)       = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))     go (StgLit lit) = (StgLit lit, emptyDVarSet)-    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)+    go (StgConApp dc n as tys) = (StgConApp dc n as tys, args env as)     go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)-    go StgLam{} = pprPanic "StgFVs: StgLam" empty     go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)       where         (scrut', scrut_fvs) = go scrut@@ -141,8 +141,8 @@       where         (e', fvs) = go e         fvs' = unionDVarSet (tickish tick) fvs-        tickish (Breakpoint _ ids) = mkDVarSet ids-        tickish _                  = emptyDVarSet+        tickish (Breakpoint _ _ ids) = mkDVarSet ids+        tickish _                    = emptyDVarSet      go_bind dc bind body = (dc bind' body', fvs)       where@@ -158,7 +158,7 @@     -- See Note [Tracking local binders]     (body', body_fvs) = expr (addLocals bndrs env) body     fvs = delDVarSetList body_fvs bndrs-rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)+rhs env (StgRhsCon ccs dc mu ts as) = (StgRhsCon ccs dc mu ts as, args env as)  alt :: Env -> StgAlt -> (CgStgAlt, DIdSet) alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)

GHC/Stg/Lift.hs view

@@ -29,6 +29,7 @@ import GHC.Utils.Outputable import GHC.Types.Unique.Supply import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.Var.Set import Control.Monad ( when ) import Data.Maybe ( isNothing )@@ -198,14 +199,14 @@   -- as lambda binders, discarding all free vars.   -> LlStgRhs   -> LiftM OutStgRhs-liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con mn ts args)   = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ pprStgRhs panicStgPprOpts rhs)-    StgRhsCon ccs con <$> traverse liftArgs args-liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do+    StgRhsCon ccs con mn ts <$> traverse liftArgs args+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) =   -- This RHS wasn't lifted.   withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->     StgRhsClosure noExtFieldSilent ccs upd bndrs' <$> liftExpr body-liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) =   -- This RHS was lifted. Insert extra binders for @former_fvs@.   withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do     let bndrs'' = dVarSetElems former_fvs ++ bndrs'@@ -226,9 +227,8 @@   fvs' <- formerFreeVars f   let top_lvl_args = map StgVarArg fvs' ++ args'   pure (StgApp f' top_lvl_args)-liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys+liftExpr (StgConApp con mn args tys) = StgConApp con mn <$> traverse liftArgs args <*> pure tys liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty-liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") liftExpr (StgCase scrut info ty alts) = do   scrut' <- liftExpr scrut   withSubstBndr (binderInfoBndr info) $ \bndr' -> do

GHC/Stg/Lift/Analysis.hs view

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DataKinds #-} @@ -21,7 +20,9 @@   ) where  import GHC.Prelude+ import GHC.Platform+import GHC.Platform.Profile  import GHC.Types.Basic import GHC.Types.Demand@@ -93,7 +94,7 @@ -- --   * 'ClosureSk', representing closure allocation. --   * 'RhsSk', representing a RHS of a binding and how many times it's called---     by an appropriate 'DmdShell'.+--     by an appropriate 'Card'. --   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element. -- -- This abstraction is mostly so that the main analysis function 'closureGrowth'@@ -113,16 +114,14 @@ type instance XRhsClosure  'LiftLams = DIdSet type instance XLet         'LiftLams = Skeleton type instance XLetNoEscape 'LiftLams = Skeleton+type instance XConApp      'LiftLams = ConstructorNumber -freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet-freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]-freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs  -- | Captures details of the syntax tree relevant to the cost model, such as -- closures, multi-shot lambdas and case expressions. data Skeleton   = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton-  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton+  | RhsSk !Card {- ^ how often the RHS was entered -} !Skeleton   | AltSk !Skeleton !Skeleton   | BothSk !Skeleton !Skeleton   | NilSk@@ -137,7 +136,7 @@ altSk a NilSk = a altSk a b     = AltSk a b -rhsSk :: DmdShell -> Skeleton -> Skeleton+rhsSk :: Card -> Skeleton -> Skeleton rhsSk _        NilSk = NilSk rhsSk body_dmd skel  = RhsSk body_dmd skel @@ -170,22 +169,12 @@     ]   ppr (BothSk l r) = ppr l $$ ppr r   ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)-  ppr (RhsSk body_dmd body) = hcat-    [ text "λ["-    , ppr str-    , text ", "-    , ppr use-    , text "]. "+  ppr (RhsSk card body) = hcat+    [ lambda+    , ppr card+    , dot     , ppr body     ]-    where-      str-        | isStrictDmd body_dmd = '1'-        | otherwise = '0'-      use-        | isAbsDmd body_dmd = '0'-        | isUsedOnce body_dmd = '1'-        | otherwise = 'ω'  instance Outputable BinderInfo where   ppr = ppr . binderInfoBndr@@ -219,8 +208,8 @@ tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr) tagSkeletonExpr (StgLit lit)   = (NilSk, emptyVarSet, StgLit lit)-tagSkeletonExpr (StgConApp con args tys)-  = (NilSk, mkArgOccs args, StgConApp con args tys)+tagSkeletonExpr (StgConApp con mn args tys)+  = (NilSk, mkArgOccs args, StgConApp con mn args tys) tagSkeletonExpr (StgOpApp op args ty)   = (NilSk, mkArgOccs args, StgOpApp op args ty) tagSkeletonExpr (StgApp f args)@@ -231,7 +220,6 @@       -- argument occurrences, see "GHC.Stg.Lift.Analysis#arg_occs".       | null args = unitVarSet f       | otherwise = mkArgOccs args-tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam") tagSkeletonExpr (StgCase scrut bndr ty alts)   = (skel, arg_occs, StgCase scrut' bndr' ty alts')   where@@ -324,26 +312,26 @@         bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)  tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)-tagSkeletonRhs _ (StgRhsCon ccs dc args)-  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)+tagSkeletonRhs _ (StgRhsCon ccs dc mn ts args)+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc mn ts args) tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)   = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')   where     bndrs' = map BoringBinder bndrs     (body_skel, body_arg_occs, body') = tagSkeletonExpr body-    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel+    rhs_skel = rhsSk (rhsCard bndr) body_skel  -- | How many times will the lambda body of the RHS bound to the given -- identifier be evaluated, relative to its defining context? This function--- computes the answer in form of a 'DmdShell'.-rhsDmdShell :: Id -> DmdShell-rhsDmdShell bndr-  | is_thunk = oneifyDmd ds+-- computes the answer in form of a 'Card'.+rhsCard :: Id -> Card+rhsCard bndr+  | is_thunk  = oneifyCard n   | otherwise = peelManyCalls (idArity bndr) cd   where     is_thunk = idArity bndr == 0     -- Let's pray idDemandInfo is still OK after unarise...-    (ds, cd) = toCleanDmd (idDemandInfo bndr)+    n :* cd = idDemandInfo bndr  tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt) tagSkeletonAlt (con, bndrs, rhs)@@ -375,7 +363,8 @@   , ("args spill on stack", args_spill_on_stack)   , ("increases allocation", inc_allocs)   ] where-      platform = targetPlatform dflags+      profile  = targetProfile dflags+      platform = profilePlatform profile       decide deciders         | not (fancy_or deciders)         = llTrace "stgLiftLams:lifting"@@ -472,7 +461,7 @@       -- GHC does not currently share closure environments, and we either lift       -- the entire recursive binding group or none of it.       closuresSize = sum $ flip map rhss $ \rhs ->-        closureSize dflags+        closureSize profile         . dVarSetElems         . expander         . flip dVarSetMinusVarSet bndrs_set@@ -485,14 +474,14 @@  -- | The size in words of a function closure closing over the given 'Id's, -- including the header.-closureSize :: DynFlags -> [Id] -> WordOff-closureSize dflags ids = words + sTD_HDR_SIZE dflags+closureSize :: Profile -> [Id] -> WordOff+closureSize profile ids = words + pc_STD_HDR_SIZE (platformConstants (profilePlatform profile))   -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't   -- optimise differently when profiling is enabled.   where     (words, _, _)       -- Functions have a StdHeader (as opposed to ThunkHeader).-      = StgToCmm.Layout.mkVirtHeapOffsets dflags StgToCmm.Layout.StdHeader+      = StgToCmm.Layout.mkVirtHeapOffsets profile StgToCmm.Layout.StdHeader       . StgToCmm.Closure.addIdReps       . StgToCmm.Closure.nonVoidIds       $ ids@@ -504,7 +493,7 @@ idClosureFootprint:: Platform -> Id -> WordOff idClosureFootprint platform   = StgToCmm.ArgRep.argRepSizeW platform-  . StgToCmm.ArgRep.idArgRep+  . StgToCmm.ArgRep.idArgRep platform  -- | @closureGrowth expander sizer f fvs@ computes the closure growth in words -- as a result of lifting @f@ to top-level. If there was any growing closure@@ -547,7 +536,7 @@         -- Lifting @f@ removes @f@ from the closure but adds all @newbies@         cost = nonDetStrictFoldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs         -- Using a non-deterministic fold is OK here because addition is commutative.-    go (RhsSk body_dmd body)+    go (RhsSk n body)       -- The conservative assumption would be that       --   1. Every RHS with positive growth would be called multiple times,       --      modulo thunks.@@ -558,11 +547,11 @@       -- considering information from the demand analyser, which provides us       -- with conservative estimates on minimum and maximum evaluation       -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of-      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body+      -- 'rhsCard' and accurately captures the cardinality of the RHSs body       -- relative to its defining context.-      | isAbsDmd body_dmd   = 0-      | cg <= 0             = if isStrictDmd body_dmd then cg else 0-      | isUsedOnce body_dmd = cg-      | otherwise           = infinity+      | isAbs n      = 0+      | cg <= 0      = if isStrict n then cg else 0+      | isUsedOnce n = cg+      | otherwise    = infinity       where         cg = go body

GHC/Stg/Lift/Monad.hs view

@@ -37,6 +37,7 @@ import GHC.Core.Utils import GHC.Types.Unique.Supply import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Multiplicity@@ -193,9 +194,9 @@ removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)   | isCurrentCCS ccs   = StgRhsClosure ext dontCareCCS upd bndrs body-removeRhsCCCS (StgRhsCon ccs con args)+removeRhsCCCS (StgRhsCon ccs con mu ts args)   | isCurrentCCS ccs-  = StgRhsCon dontCareCCS con args+  = StgRhsCon dontCareCCS con mu ts args removeRhsCCCS rhs = rhs  -- | The analysis monad consists of the following 'RWST' components:

GHC/Stg/Lint.hs view

@@ -27,8 +27,8 @@     for Stg code that is currently perfectly acceptable for code     generation.  Solution: don't use it!  (KSW 2000-05). -Since then there were some attempts at enabling it again, as summarised in-#14787. It's finally decided that we remove all type checking and only look for+Since then there were some attempts at enabling it again, as summarised in #14787.+It's finally decided that we remove all type checking and only look for basic properties listed above. -} @@ -42,39 +42,44 @@ import GHC.Stg.Syntax  import GHC.Driver.Session+import GHC.Core.Lint        ( interactiveInScope ) import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList ) import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel ) import GHC.Types.CostCentre ( isCurrentCCS )-import GHC.Types.Id         ( Id, idType, isJoinId, idName )+import GHC.Types.Id import GHC.Types.Var.Set import GHC.Core.DataCon import GHC.Core             ( AltCon(..) ) import GHC.Types.Name       ( getSrcLoc, nameIsLocalOrFrom )-import GHC.Utils.Error      ( MsgDoc, Severity(..), mkLocMessage )+import GHC.Utils.Error      ( Severity(..), mkLocMessage ) import GHC.Core.Type import GHC.Types.RepType import GHC.Types.SrcLoc+import GHC.Utils.Logger import GHC.Utils.Outputable import GHC.Unit.Module            ( Module )+import GHC.Runtime.Context        ( InteractiveContext ) import qualified GHC.Utils.Error as Err import Control.Applicative ((<|>)) import Control.Monad  lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)-                   => DynFlags+                   => Logger+                   -> DynFlags+                   -> InteractiveContext                    -> Module -- ^ module being compiled                    -> Bool   -- ^ have we run Unarise yet?                    -> String -- ^ who produced the STG?                    -> [GenStgTopBinding a]                    -> IO () -lintStgTopBindings dflags this_mod unarised whodunnit binds+lintStgTopBindings logger dflags ictxt this_mod unarised whodunnit binds   = {-# SCC "StgLint" #-}     case initL this_mod unarised opts top_level_binds (lint_binds binds) of       Nothing  ->         return ()       Just msg -> do-        putLogMsg dflags NoReason Err.SevDump noSrcSpan+        putLogMsg logger dflags NoReason Err.SevDump noSrcSpan           $ withPprStyle defaultDumpStyle           (vcat [ text "*** Stg Lint ErrMsgs: in" <+>                         text whodunnit <+> text "***",@@ -82,12 +87,13 @@                   text "*** Offending Program ***",                   pprGenStgTopBindings opts binds,                   text "*** End of Offense ***"])-        Err.ghcExit dflags 1+        Err.ghcExit logger dflags 1   where     opts = initStgPprOpts dflags     -- Bring all top-level binds into scope because CoreToStg does not generate     -- bindings in dependency order (so we may see a use before its definition).-    top_level_binds = mkVarSet (bindersOfTopBinds binds)+    top_level_binds = extendVarSetList (mkVarSet (bindersOfTopBinds binds))+                                       (interactiveInScope ictxt)      lint_binds :: [GenStgTopBinding a] -> LintM () @@ -132,8 +138,10 @@         lintStgRhs rhs         opts <- getStgPprOpts         -- Check binder doesn't have unlifted type or it's a join point-        checkL (isJoinId binder || not (isUnliftedType (idType binder)))-               (mkUnliftedTyMsg opts binder rhs)+        checkL ( isJoinId binder+              || not (isUnliftedType (idType binder))+              || isDataConWorkId binder || isDataConWrapId binder) -- until #17521 is fixed+          (mkUnliftedTyMsg opts binder rhs)  -- | Top-level bindings can't inherit the cost centre stack from their -- (static) allocation site.@@ -148,7 +156,7 @@       StgRhsClosure _ ccs _ _ _          | isCurrentCCS ccs          -> addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ rhs')-      StgRhsCon ccs _ _+      StgRhsCon ccs _ _ _ _          | isCurrentCCS ccs          -> addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ rhs')       _ -> return ()@@ -163,8 +171,8 @@       addInScopeVars binders $         lintStgExpr expr -lintStgRhs rhs@(StgRhsCon _ con args) = do-    when (isUnboxedTupleCon con || isUnboxedSumCon con) $ do+lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do+    when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do       opts <- getStgPprOpts       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$                pprStgRhs opts rhs)@@ -179,10 +187,10 @@     lintStgVar fun     mapM_ lintStgArg args -lintStgExpr app@(StgConApp con args _arg_tys) = do+lintStgExpr app@(StgConApp con _n 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)@@ -192,10 +200,6 @@ lintStgExpr (StgOpApp _ args _) =     mapM_ lintStgArg args -lintStgExpr lam@(StgLam _ _) = do-    opts <- getStgPprOpts-    addErrL (text "Unexpected StgLam" <+> pprStgExpr opts lam)- lintStgExpr (StgLet _ binds body) = do     binders <- lintStgBinds NotTopLevel binds     addLoc (BodyOfLetRec binders) $@@ -246,8 +250,8 @@               -> StgPprOpts        -- Pretty-printing options               -> [LintLocInfo]     -- Locations               -> IdSet             -- Local vars in scope-              -> Bag MsgDoc        -- Error messages so far-              -> (a, Bag MsgDoc)   -- Result and error messages (if any)+              -> Bag SDoc        -- Error messages so far+              -> (a, Bag SDoc)   -- Result and error messages (if any)     }     deriving (Functor) @@ -277,7 +281,7 @@     pp_binder b       = hsep [ppr b, dcolon, ppr (idType b)] -initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe MsgDoc+initL :: Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc initL this_mod unarised opts locals (LintM m) = do   let (_, errs) = m this_mod (LintFlags unarised) opts [] locals emptyBag   if isEmptyBag errs then@@ -304,7 +308,7 @@   -> case unLintM m mod lf opts loc scope errs of       (_, errs') -> unLintM k mod lf opts loc scope errs' -checkL :: Bool -> MsgDoc -> LintM ()+checkL :: Bool -> SDoc -> LintM () checkL True  _   = return () checkL False msg = addErrL msg @@ -346,10 +350,10 @@     in       is_sum <|> is_tuple <|> is_void -addErrL :: MsgDoc -> LintM ()+addErrL :: SDoc -> LintM () addErrL msg = LintM $ \_mod _lf _opts loc _scope errs -> ((), addErr errs msg loc) -addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc+addErr :: Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc addErr errs_so_far msg locs   = errs_so_far `snocBag` mk_msg locs   where

GHC/Stg/Pipeline.hs view

@@ -24,11 +24,14 @@ import GHC.Stg.CSE      ( stgCse ) import GHC.Stg.Lift     ( stgLiftLams ) import GHC.Unit.Module ( Module )+import GHC.Runtime.Context ( InteractiveContext )  import GHC.Driver.Session import GHC.Utils.Error import GHC.Types.Unique.Supply import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.State.Strict@@ -45,14 +48,15 @@ runStgM :: Char -> StgM a -> IO a runStgM mask (StgM m) = evalStateT m mask -stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do+stg2stg :: Logger+        -> DynFlags                  -- includes spec of what stg-to-stg passes to do+        -> InteractiveContext         -> Module                    -- module being compiled         -> [StgTopBinding]           -- input program         -> IO [StgTopBinding]        -- output program--stg2stg dflags this_mod binds-  = do  { dump_when Opt_D_dump_stg "STG:" binds-        ; showPass dflags "Stg2Stg"+stg2stg logger dflags ictxt this_mod binds+  = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds+        ; showPass logger dflags "Stg2Stg"         -- Do the main business!         ; binds' <- runStgM 'g' $             foldM do_stg_pass binds (getStgToDo dflags)@@ -72,7 +76,7 @@   where     stg_linter unarised       | gopt Opt_DoStgLinting dflags-      = lintStgTopBindings dflags this_mod unarised+      = lintStgTopBindings logger dflags ictxt this_mod unarised       | otherwise       = \ _whodunnit _binds -> return () @@ -105,11 +109,11 @@      opts = initStgPprOpts dflags     dump_when flag header binds-      = dumpIfSet_dyn dflags flag header FormatSTG (pprStgTopBindings opts binds)+      = dumpIfSet_dyn logger dflags flag header FormatSTG (pprStgTopBindings opts binds)      end_pass what binds2       = liftIO $ do -- report verbosely, if required-          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what+          dumpIfSet_dyn logger dflags Opt_D_verbose_stg2stg what             FormatSTG (vcat (map (pprStgTopBinding opts) binds2))           stg_linter False what binds2           return binds2

GHC/Stg/Stats.hs view

@@ -32,7 +32,6 @@ import GHC.Stg.Syntax  import GHC.Types.Id (Id)-import GHC.Utils.Panic  import Data.Map (Map) import qualified Data.Map as Map@@ -125,7 +124,7 @@  statRhs :: Bool -> (Id, StgRhs) -> StatEnv -statRhs top (_, StgRhsCon _ _ _)+statRhs top (_, StgRhsCon _ _ _ _ _)   = countOne (ConstructorBinds top)  statRhs top (_, StgRhsClosure _ _ u _ body)@@ -149,7 +148,7 @@  statExpr (StgApp _ _)     = countOne Applications statExpr (StgLit _)       = countOne Literals-statExpr (StgConApp _ _ _)= countOne ConstructorApps+statExpr (StgConApp _ _ _ _)= countOne ConstructorApps statExpr (StgOpApp _ _ _) = countOne PrimitiveApps statExpr (StgTick _ e)    = statExpr e @@ -169,5 +168,3 @@   where     stat_alts alts         = combineSEs (map statExpr [ e | (_,_,e) <- alts ])--statExpr (StgLam {}) = panic "statExpr StgLam"

GHC/Stg/Subst.hs view

@@ -9,8 +9,12 @@ import GHC.Types.Id import GHC.Types.Var.Env import Control.Monad.Trans.State.Strict+ import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Driver.Ppr  -- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not -- maintaining pairs of substitutions. Like 'GHC.Core.Subst.Subst', but

GHC/Stg/Syntax.hs view

@@ -1,3 +1,12 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -10,28 +19,20 @@ generation. -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Stg.Syntax (         StgArg(..),          GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),         GenStgAlt, AltType(..), -        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,+        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape, XConApp,         NoExtFieldSilent, noExtFieldSilent,         OutputablePass,          UpdateFlag(..), isUpdatable, +        ConstructorNumber(..),+         -- a set of synonyms for the vanilla parameterisation         StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt, @@ -49,7 +50,7 @@         StgOp(..),          -- utils-        stgRhsArity,+        stgRhsArity, freeVarsOfRhs,         isDllConApp,         stgArgType,         stripStgTicksTop, stripStgTicksTopE,@@ -57,7 +58,8 @@         bindersOf, bindersOfTop, bindersOfTopBinds,          -- ppr-        StgPprOpts(..), initStgPprOpts, panicStgPprOpts,+        StgPprOpts(..), initStgPprOpts,+        panicStgPprOpts, shortStgPprOpts,         pprStgArg, pprStgExpr, pprStgRhs, pprStgBinding,         pprGenStgTopBinding, pprStgTopBinding,         pprGenStgTopBindings, pprStgTopBindings@@ -67,7 +69,7 @@  import GHC.Prelude -import GHC.Core     ( AltCon, Tickish )+import GHC.Core     ( AltCon ) import GHC.Types.CostCentre ( CostCentreStack ) import Data.ByteString ( ByteString ) import Data.Data   ( Data )@@ -77,6 +79,7 @@ import GHC.Types.ForeignCall ( ForeignCall ) import GHC.Types.Id import GHC.Types.Name        ( isDynLinkName )+import GHC.Types.Tickish     ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal     ( Literal, literalType ) import GHC.Unit.Module       ( Module )@@ -88,8 +91,7 @@ import GHC.Core.Type     ( Type ) import GHC.Types.RepType ( typePrimRep1 ) import GHC.Utils.Misc--import Data.List.NonEmpty ( NonEmpty, toList )+import GHC.Utils.Panic  {- ************************************************************************@@ -175,13 +177,13 @@   -- | Strip ticks of a given type from an STG expression.-stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)+stripStgTicksTop :: (StgTickish -> Bool) -> GenStgExpr p -> ([StgTickish], GenStgExpr p) stripStgTicksTop p = go []    where go ts (StgTick t e) | p t = go (t:ts) e          go ts other               = (reverse ts, other)  -- | Strip ticks of a given type from an STG expression returning only the expression.-stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p+stripStgTicksTopE :: (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p stripStgTicksTopE p = go    where go (StgTick t e) | p t = go e          go other               = other@@ -244,6 +246,7 @@         -- StgConApp is vital for returning unboxed tuples or sums         -- which can't be let-bound   | StgConApp   DataCon+                (XConApp pass)                 [StgArg] -- Saturated                 [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise @@ -256,22 +259,6 @@ {- ************************************************************************ *                                                                      *-StgLam-*                                                                      *-************************************************************************--StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished it-encodes (\x -> e) as (let f = \x -> e in f) TODO: Encode this via an extension-to GenStgExpr à la TTG.--}--  | StgLam-        (NonEmpty (BinderP pass))-        StgExpr    -- Body of lambda--{--************************************************************************-*                                                                      * GenStgExpr: case-expressions *                                                                      * ************************************************************************@@ -383,7 +370,7 @@ -}    | StgTick-    (Tickish Id)+    StgTickish     (GenStgExpr pass)       -- sub expression  -- END of GenStgExpr@@ -434,8 +421,34 @@                         -- from static closure.         DataCon         -- Constructor. Never an unboxed tuple or sum, as those                         -- are not allocated.+        ConstructorNumber+        [StgTickish]         [StgArg]        -- Args +{-+Note Stg Passes+~~~~~~~~~~~~~~~+Here is a short summary of the STG pipeline and where we use the different+StgPass data type indexes:++  1. CoreToStg.Prep performs several transformations that prepare the desugared+     and simplified core to be converted to STG. One of these transformations is+     making it so that value lambdas only exist as the RHS of a binding.++  2. CoreToStg converts the prepared core to STG, specifically GenStg*+     parameterised by 'Vanilla.++  3. Stg.Pipeline does a number of passes on the generated STG. One of these is+     the lambda-lifting pass, which internally uses the 'LiftLams+     parameterisation to store information for deciding whether or not to lift+     each binding.++  4. Stg.FVs annotates closures with their free variables. To store these+     annotations we use the 'CodeGen parameterisation.++  5. Stg.StgToCmm generates Cmm from the annotated STG.+-}+ -- | Used as a data type index for the stgSyn AST data StgPass   = Vanilla@@ -472,6 +485,20 @@ type instance XLet 'Vanilla = NoExtFieldSilent type instance XLet 'CodeGen = NoExtFieldSilent +type family XConApp (pass :: StgPass)+type instance XConApp 'Vanilla =  ConstructorNumber+type instance XConApp 'CodeGen = ConstructorNumber++-- | When `-fdistinct-constructor-tables` is turned on then+-- each usage of a constructor is given an unique number and+-- an info table is generated for each different constructor.+data ConstructorNumber =+      NoNumber | Numbered Int++instance Outputable ConstructorNumber where+  ppr NoNumber = empty+  ppr (Numbered n) = text "#" <> ppr n+ type family XLetNoEscape (pass :: StgPass) type instance XLetNoEscape 'Vanilla = NoExtFieldSilent type instance XLetNoEscape 'CodeGen = NoExtFieldSilent@@ -480,8 +507,12 @@ stgRhsArity (StgRhsClosure _ _ _ bndrs _)   = ASSERT( all isId bndrs ) length bndrs   -- The arity never includes type parameters, but they should have gone by now-stgRhsArity (StgRhsCon _ _ _) = 0+stgRhsArity (StgRhsCon _ _ _ _ _) = 0 +freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet+freeVarsOfRhs (StgRhsCon _ _ _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs+ {- ************************************************************************ *                                                                      *@@ -506,7 +537,7 @@      GenStgExpr pass) -- ...right-hand side.  data AltType-  = PolyAlt             -- Polymorphic (a lifted type variable)+  = PolyAlt             -- Polymorphic (a boxed type variable, lifted or unlifted)   | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)                         -- the arity could indeed be 1 for unary unboxed tuple                         -- or enum-like unboxed sums@@ -642,6 +673,7 @@  type OutputablePass pass =   ( Outputable (XLet pass)+  , Outputable (XConApp pass)   , Outputable (XLetNoEscape pass)   , Outputable (XRhsClosure pass)   , OutputableBndr (BinderP pass)@@ -664,6 +696,13 @@    { stgSccEnabled = True    } +-- | STG pretty-printing options used for short messages+shortStgPprOpts :: StgPprOpts+shortStgPprOpts = StgPprOpts+   { stgSccEnabled = False+   }++ pprGenStgTopBinding   :: OutputablePass pass => StgPprOpts -> GenStgTopBinding pass -> SDoc pprGenStgTopBinding opts b = case b of@@ -707,13 +746,8 @@    StgLit lit           -> ppr lit                            -- general case    StgApp func args     -> hang (ppr func) 4 (interppSP args)-   StgConApp con args _ -> hsep [ ppr con, brackets (interppSP args) ]+   StgConApp con n args _ -> hsep [ ppr con, ppr n, brackets (interppSP args) ]    StgOpApp op args _   -> hsep [ pprStgOp op, brackets (interppSP args)]-   StgLam bndrs body    -> let ppr_list = brackets . fsep . punctuate comma-                           in sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))-                                      <+> text "->"-                                  , pprStgExpr opts body-                                  ]  -- special case: let v = <very specific thing> --               in@@ -756,9 +790,10 @@              , hang (text "} in ") 2 (pprStgExpr opts expr)              ] -   StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case+   StgTick _tickish expr -> sdocOption sdocSuppressTicks $ \case       True  -> pprStgExpr opts expr-      False -> sep [ ppr tickish, pprStgExpr opts expr ]+      False -> pprStgExpr opts expr+        -- XXX sep [ ppr tickish, pprStgExpr opts expr ]     -- Don't indent for a single case alternative.    StgCase expr bndr alt_type [alt]@@ -815,5 +850,9 @@                     ])               4 (pprStgExpr opts body) -   StgRhsCon cc con args-      -> hcat [ ppr cc, space, ppr con, text "! ", brackets (sep (map pprStgArg args))]+   StgRhsCon cc con mid _ticks args+      -> hcat [ ppr cc, space+              , case mid of+                  NoNumber -> empty+                  Numbered n -> hcat [ppr n, space]+              , ppr con, text "! ", brackets (sep (map pprStgArg args))]

GHC/Stg/Unarise.hs view

@@ -1,5 +1,9 @@+{-# LANGUAGE CPP              #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections    #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The GRASP/AQUA Project, Glasgow University, 1992-2012 @@ -126,43 +130,19 @@    (# 2#, rubbish, 2#, 3# #). --Note [Don't merge lifted and unlifted slots]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When merging slots, one might be tempted to collapse lifted and unlifted-pointers. However, as seen in #19645, this is wrong. Imagine that you have+points. However, as seen in #19645, this is wrong. Imagine that you have the program: -  test :: (# Char | ByteArray# #) -> ByteArray#-  test (# c | #) = doSomething c-  test (# | ba #) = ba--Collapsing the Char and ByteArray# slots would produce STG like:--  test :: forall {t}. (# t | GHC.Prim.ByteArray# #) -> GHC.Prim.ByteArray#-    = {} \r [ (tag :: Int#) (slot0 :: (Any :: Type)) ]-          case tag of tag'-            1# -> doSomething slot0-            2# -> slot0;--Note how `slot0` has a lifted type, despite being bound to an unlifted-ByteArray# in the 2# alternative. This liftedness would cause the code generator to-attempt to enter it upon returning. As unlifted objects do not have entry code,-this causes a runtime crash.--For this reason, Unarise treats unlifted and lifted things as distinct slot-types, despite both being GC pointers. This approach is a slight pessimisation-(since we need to pass more arguments) but appears to be the simplest way to-avoid #19645. Other alternatives considered include:-- a. Giving unlifted objects "trivial" entry code. However, we ultimately-    concluded that the value of the "unlifted things are never entered" invariant-    outweighed the simplicity of this approach.-- b. Annotating occurrences with calling convention information instead of-    relying on the binder's type. This seemed like a very complicated-    way to fix what is ultimately a corner-case.+    test :: (# Char | ByteArray# #) -> ByteArray#+    test (# | ba #) = ba+    test (# c | #) = ... +If we were to collapse the sum argument to (# Tag#, Any #) we would end up treating+the ByteArray# as a lifted object. This would cause the code generator to+attempt to enter it upon returning, causing a runtime crash. For this reason we+treat unlifted and lifted things as distinct slot types, despite both being GC+pointers.  Note [Types in StgConApp] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -232,10 +212,6 @@   * Binders always have zero (for void arguments) or one PrimRep. -} -{-# LANGUAGE CPP, TupleSections, PatternSynonyms #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- module GHC.Stg.Unarise (unarise) where  #include "HsVersions.h"@@ -252,6 +228,7 @@ import GHC.Types.Id.Make (voidPrimId, voidArgId) import GHC.Utils.Monad (mapAccumLM) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.RepType import GHC.Stg.Syntax import GHC.Core.Type@@ -330,9 +307,9 @@        expr' <- unariseExpr rho' expr        return (StgRhsClosure ext ccs update_flag args1 expr') -unariseRhs rho (StgRhsCon ccs con args)-  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))-    return (StgRhsCon ccs con (unariseConArgs rho args))+unariseRhs rho (StgRhsCon ccs con mu ts args)+  = ASSERT(not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))+    return (StgRhsCon ccs con mu ts (unariseConArgs rho args))  -------------------------------------------------------------------------------- @@ -362,20 +339,17 @@ unariseExpr _ (StgLit l)   = return (StgLit l) -unariseExpr rho (StgConApp dc args ty_args)+unariseExpr rho (StgConApp dc n args ty_args)   | Just args' <- unariseMulti_maybe rho dc args ty_args   = return (mkTuple args')    | otherwise   , let args' = unariseConArgs rho args-  = return (StgConApp dc args' (map stgArgType args'))+  = return (StgConApp dc n args' (map stgArgType args'))  unariseExpr rho (StgOpApp op args ty)   = return (StgOpApp op (unariseFunArgs rho args) ty) -unariseExpr _ e@StgLam{}-  = pprPanic "unariseExpr: found lambda" (pprStgExpr panicStgPprOpts e)- unariseExpr rho (StgCase scrut bndr alt_ty alts)   -- tuple/sum binders in the scrutinee can always be eliminated   | StgApp v [] <- scrut@@ -385,7 +359,7 @@   -- Handle strict lets for tuples and sums:   --   case (# a,b #) of r -> rhs   -- and analogously for sums-  | StgConApp dc args ty_args <- scrut+  | StgConApp dc _n args ty_args <- scrut   , Just args' <- unariseMulti_maybe rho dc args ty_args   = elimCase rho args' bndr alt_ty alts @@ -409,10 +383,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) @@ -797,7 +771,7 @@ isUnboxedTupleBndr = isUnboxedTupleType . idType  mkTuple :: [StgArg] -> StgExpr-mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) NoNumber args (map stgArgType args)  tagAltTy :: AltType tagAltTy = PrimAlt IntRep

+ GHC/StgToByteCode.hs view

@@ -0,0 +1,2268 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards            #-}++{-# OPTIONS_GHC -fprof-auto-top #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++--+--  (c) The University of Glasgow 2002-2006+--++-- | GHC.StgToByteCode: Generate bytecode from STG+module GHC.StgToByteCode ( UnlinkedBCO, byteCodeGen) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Session+import GHC.Driver.Env++import GHC.ByteCode.Instr+import GHC.ByteCode.Asm+import GHC.ByteCode.Types++import GHC.Cmm.CallConv+import GHC.Cmm.Expr+import GHC.Cmm.Node+import GHC.Cmm.Utils++import GHC.Platform+import GHC.Platform.Profile++import GHC.Runtime.Interpreter+import GHCi.FFI+import GHCi.RemoteTypes+import GHC.Types.Basic+import GHC.Utils.Outputable+import GHC.Types.Name+import GHC.Types.Id.Make+import GHC.Types.Id+import GHC.Types.ForeignCall+import GHC.Core+import GHC.Types.Literal+import GHC.Builtin.PrimOps+import GHC.Core.Type+import GHC.Types.RepType+import GHC.Core.DataCon+import GHC.Core.TyCon+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Types.Var.Set+import GHC.Builtin.Types ( unboxedUnitTy )+import GHC.Builtin.Types.Prim+import GHC.Core.TyCo.Ppr ( pprType )+import GHC.Utils.Error+import GHC.Types.Unique+import GHC.Builtin.Uniques+import GHC.Builtin.Utils ( primOpId )+import GHC.Data.FastString+import GHC.Utils.Panic+import GHC.StgToCmm.Closure ( NonVoid(..), fromNonVoid, nonVoidIds )+import GHC.StgToCmm.Layout+import GHC.Runtime.Heap.Layout hiding (WordOff, ByteOff, wordsToBytes)+import GHC.Data.Bitmap+import GHC.Data.OrdList+import GHC.Data.Maybe+import GHC.Types.Var.Env+import GHC.Types.Tickish++import Data.List ( genericReplicate, genericLength, intersperse+                 , partition, scanl', sort, sortBy, zip4, zip6, nub )+import Foreign hiding (shiftL, shiftR)+import Control.Monad+import Data.Char++import GHC.Types.Unique.Supply+import GHC.Unit.Module++import Control.Exception+import Data.Array+import Data.Coerce (coerce)+import Data.ByteString (ByteString)+import Data.Map (Map)+import Data.IntMap (IntMap)+import qualified Data.Map as Map+import qualified Data.IntMap as IntMap+import qualified GHC.Data.FiniteMap as Map+import Data.Ord+import GHC.Stack.CCS+import Data.Either ( partitionEithers )++import qualified GHC.Types.CostCentre as CC+import GHC.Stg.Syntax+import GHC.Stg.FVs++-- -----------------------------------------------------------------------------+-- Generating byte code for a complete module++byteCodeGen :: HscEnv+            -> Module+            -> [StgTopBinding]+            -> [TyCon]+            -> Maybe ModBreaks+            -> IO CompiledByteCode+byteCodeGen hsc_env this_mod binds tycs mb_modBreaks+   = withTiming logger dflags+                (text "GHC.StgToByteCode"<+>brackets (ppr this_mod))+                (const ()) $ do+        -- Split top-level binds into strings and others.+        -- See Note [generating code for top-level string literal bindings].+        let (strings, lifted_binds) = partitionEithers $ do  -- list monad+                bnd <- binds+                case bnd of+                  StgTopLifted bnd      -> [Right bnd]+                  StgTopStringLit b str -> [Left (b, str)]+            flattenBind (StgNonRec b e) = [(b,e)]+            flattenBind (StgRec bs)     = bs+        stringPtrs <- allocateTopStrings interp strings++        us <- mkSplitUniqSupply 'y'+        (BcM_State{..}, proto_bcos) <-+           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $ do+             prepd_binds <- mapM bcPrepBind lifted_binds+             let flattened_binds =+                   concatMap (flattenBind . annBindingFreeVars) (reverse prepd_binds)+             mapM schemeTopBind flattened_binds++        when (notNull ffis)+             (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")++        dumpIfSet_dyn logger dflags Opt_D_dump_BCOs+           "Proto-BCOs" FormatByteCode+           (vcat (intersperse (char ' ') (map ppr proto_bcos)))++        cbc <- assembleBCOs interp profile proto_bcos tycs (map snd stringPtrs)+          (case modBreaks of+             Nothing -> Nothing+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })++        -- Squash space leaks in the CompiledByteCode.  This is really+        -- important, because when loading a set of modules into GHCi+        -- we don't touch the CompiledByteCode until the end when we+        -- do linking.  Forcing out the thunks here reduces space+        -- usage by more than 50% when loading a large number of+        -- modules.+        evaluate (seqCompiledByteCode cbc)++        return cbc++  where dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        interp  = hscInterp hsc_env+        profile = targetProfile dflags++allocateTopStrings+  :: Interp+  -> [(Id, ByteString)]+  -> IO [(Var, RemotePtr ())]+allocateTopStrings interp topStrings = do+  let !(bndrs, strings) = unzip topStrings+  ptrs <- interpCmd interp $ MallocStrings strings+  return $ zip bndrs ptrs++{-+Note [generating code for top-level string literal bindings]++Here is a summary on how the byte code generator deals with top-level string+literals:++1. Top-level string literal bindings are separated from the rest of the module.++2. The strings are allocated via interpCmd, in allocateTopStrings++3. The mapping from binders to allocated strings (topStrings) are maintained in+   BcM and used when generating code for variable references.+-}++{-+  Prepare the STG for bytecode generation:++   - Ensure that all breakpoints are directly under+        a let-binding, introducing a new binding for+        those that aren't already.++   - Protect Not-necessarily lifted join points, see+        Note [Not-necessarily-lifted join points]++ -}++bcPrepRHS :: StgRhs -> BcM StgRhs+-- explicitly match all constructors so we get a warning if we miss any+bcPrepRHS (StgRhsClosure fvs cc upd args (StgTick bp@Breakpoint{} expr)) = do+  {- If we have a breakpoint directly under an StgRhsClosure we don't+     need to introduce a new binding for it.+   -}+  expr' <- bcPrepExpr expr+  pure (StgRhsClosure fvs cc upd args (StgTick bp expr'))+bcPrepRHS (StgRhsClosure fvs cc upd args expr) =+  StgRhsClosure fvs cc upd args <$> bcPrepExpr expr+bcPrepRHS con@StgRhsCon{} = pure con++bcPrepExpr :: StgExpr -> BcM StgExpr+-- explicitly match all constructors so we get a warning if we miss any+bcPrepExpr (StgTick bp@(Breakpoint tick_ty _ _) rhs)+  | isLiftedTypeKind (typeKind tick_ty) = do+      id <- newId tick_ty+      rhs' <- bcPrepExpr rhs+      let expr' = StgTick bp rhs'+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent+                                            CC.dontCareCCS+                                            ReEntrant+                                            []+                                            expr'+                             )+          letExp = StgLet noExtFieldSilent bnd (StgApp id [])+      pure letExp+  | otherwise = do+      id <- newId (mkVisFunTyMany realWorldStatePrimTy tick_ty)+      st <- newId realWorldStatePrimTy+      rhs' <- bcPrepExpr rhs+      let expr' = StgTick bp rhs'+          bnd = StgNonRec id (StgRhsClosure noExtFieldSilent+                                            CC.dontCareCCS+                                            ReEntrant+                                            [voidArgId]+                                            expr'+                             )+      pure $ StgLet noExtFieldSilent bnd (StgApp id [StgVarArg st])+bcPrepExpr (StgTick tick rhs) =+  StgTick tick <$> bcPrepExpr rhs+bcPrepExpr (StgLet xlet bnds expr) =+  StgLet xlet <$> bcPrepBind bnds+              <*> bcPrepExpr expr+bcPrepExpr (StgLetNoEscape xlne bnds expr) =+  StgLet xlne <$> bcPrepBind bnds+              <*> bcPrepExpr expr+bcPrepExpr (StgCase expr bndr alt_type alts) =+  StgCase <$> bcPrepExpr expr+          <*> pure bndr+          <*> pure alt_type+          <*> mapM bcPrepAlt alts+bcPrepExpr lit@StgLit{} = pure lit+-- See Note [Not-necessarily-lifted join points], step 3.+bcPrepExpr (StgApp x [])+  | isNNLJoinPoint x = pure $+      StgApp (protectNNLJoinPointId x) [StgVarArg voidPrimId]+bcPrepExpr app@StgApp{} = pure app+bcPrepExpr app@StgConApp{} = pure app+bcPrepExpr app@StgOpApp{} = pure app++bcPrepAlt :: StgAlt -> BcM StgAlt+bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr++bcPrepBind :: StgBinding -> BcM StgBinding+-- explicitly match all constructors so we get a warning if we miss any+bcPrepBind (StgNonRec bndr rhs) =+  let (bndr', rhs') = bcPrepSingleBind (bndr, rhs)+  in  StgNonRec bndr' <$> bcPrepRHS rhs'+bcPrepBind (StgRec bnds) =+  StgRec <$> mapM ((\(b,r) -> (,) b <$> bcPrepRHS r) . bcPrepSingleBind)+                  bnds++bcPrepSingleBind :: (Id, StgRhs) -> (Id, StgRhs)+-- If necessary, modify this Id and body to protect not-necessarily-lifted join points.+-- See Note [Not-necessarily-lifted join points], step 2.+bcPrepSingleBind (x, StgRhsClosure ext cc upd_flag args body)+  | isNNLJoinPoint x+  = ( protectNNLJoinPointId x+    , StgRhsClosure ext cc upd_flag (args ++ [voidArgId]) body)+bcPrepSingleBind bnd = bnd++-- -----------------------------------------------------------------------------+-- Compilation schema for the bytecode generator++type BCInstrList = OrdList BCInstr++wordsToBytes :: Platform -> WordOff -> ByteOff+wordsToBytes platform = fromIntegral . (* platformWordSizeInBytes platform) . fromIntegral++-- Used when we know we have a whole number of words+bytesToWords :: Platform -> ByteOff -> WordOff+bytesToWords platform (ByteOff bytes) =+    let (q, r) = bytes `quotRem` (platformWordSizeInBytes platform)+    in if r == 0+           then fromIntegral q+           else pprPanic "GHC.StgToByteCode.bytesToWords"+                         (text "bytes=" <> ppr bytes)++wordSize :: Platform -> ByteOff+wordSize platform = ByteOff (platformWordSizeInBytes platform)++type Sequel = ByteOff -- back off to this depth before ENTER++type StackDepth = ByteOff++-- | Maps Ids to their stack depth. This allows us to avoid having to mess with+-- it after each push/pop.+type BCEnv = Map Id StackDepth -- To find vars on the stack++{-+ppBCEnv :: BCEnv -> SDoc+ppBCEnv p+   = text "begin-env"+     $$ nest 4 (vcat (map pp_one (sortBy cmp_snd (Map.toList p))))+     $$ text "end-env"+     where+        pp_one (var, ByteOff offset) = int offset <> colon <+> ppr var <+> ppr (bcIdArgReps var)+        cmp_snd x y = compare (snd x) (snd y)+-}++-- Create a BCO and do a spot of peephole optimisation on the insns+-- at the same time.+mkProtoBCO+   :: Platform+   -> name+   -> BCInstrList+   -> Either  [CgStgAlt] (CgStgRhs)+        -- ^ original expression; for debugging only+   -> Int+   -> Word16+   -> [StgWord]+   -> Bool      -- True <=> is a return point, rather than a function+   -> [FFIInfo]+   -> ProtoBCO name+mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis+   = ProtoBCO {+        protoBCOName = nm,+        protoBCOInstrs = maybe_with_stack_check,+        protoBCOBitmap = bitmap,+        protoBCOBitmapSize = bitmap_size,+        protoBCOArity = arity,+        protoBCOExpr = origin,+        protoBCOFFIs = ffis+      }+     where+        -- Overestimate the stack usage (in words) of this BCO,+        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit+        -- stack check.  (The interpreter always does a stack check+        -- for iNTERP_STACK_CHECK_THRESH words at the start of each+        -- BCO anyway, so we only need to add an explicit one in the+        -- (hopefully rare) cases when the (overestimated) stack use+        -- exceeds iNTERP_STACK_CHECK_THRESH.+        maybe_with_stack_check+           | is_ret && stack_usage < fromIntegral (pc_AP_STACK_SPLIM (platformConstants platform)) = peep_d+                -- don't do stack checks at return points,+                -- everything is aggregated up to the top BCO+                -- (which must be a function).+                -- That is, unless the stack usage is >= AP_STACK_SPLIM,+                -- see bug #1466.+           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH+           = STKCHECK stack_usage : peep_d+           | otherwise+           = peep_d     -- the supposedly common case++        -- We assume that this sum doesn't wrap+        stack_usage = sum (map bciStackUse peep_d)++        -- Merge local pushes+        peep_d = peep (fromOL instrs_ordlist)++        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)+           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest+        peep (PUSH_L off1 : PUSH_L off2 : rest)+           = PUSH_LL off1 (off2-1) : peep rest+        peep (i:rest)+           = i : peep rest+        peep []+           = []++argBits :: Platform -> [ArgRep] -> [Bool]+argBits _        [] = []+argBits platform (rep : args)+  | isFollowableArg rep  = False : argBits platform args+  | otherwise = take (argRepSizeW platform rep) (repeat True) ++ argBits platform args++non_void :: [ArgRep] -> [ArgRep]+non_void = filter nv+  where nv V = False+        nv _ = True++-- -----------------------------------------------------------------------------+-- schemeTopBind++-- Compile code for the right-hand side of a top-level binding++schemeTopBind :: (Id, CgStgRhs) -> BcM (ProtoBCO Name)+schemeTopBind (id, rhs)+  | Just data_con <- isDataConWorkId_maybe id,+    isNullaryRepDataCon data_con = do+    platform <- profilePlatform <$> getProfile+        -- Special case for the worker of a nullary data con.+        -- It'll look like this:        Nil = /\a -> Nil a+        -- If we feed it into schemeR, we'll get+        --      Nil = Nil+        -- because mkConAppCode treats nullary constructor applications+        -- by just re-using the single top-level definition.  So+        -- for the worker itself, we must allocate it directly.+    -- ioToBc (putStrLn $ "top level BCO")+    let enter = if isUnliftedTypeKind (tyConResKind (dataConTyCon data_con))+                then RETURN_UNLIFTED P+                else ENTER+    emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, enter])+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})++  | otherwise+  = schemeR [{- No free variables -}] (getName id, rhs)+++-- -----------------------------------------------------------------------------+-- schemeR++-- Compile code for a right-hand side, to give a BCO that,+-- when executed with the free variables and arguments on top of the stack,+-- will return with a pointer to the result on top of the stack, after+-- removing the free variables and arguments.+--+-- Park the resulting BCO in the monad.  Also requires the+-- name of the variable to which this value was bound,+-- so as to give the resulting BCO a name.+schemeR :: [Id]                 -- Free vars of the RHS, ordered as they+                                -- will appear in the thunk.  Empty for+                                -- top-level things, which have no free vars.+        -> (Name, CgStgRhs)+        -> BcM (ProtoBCO Name)+schemeR fvs (nm, rhs)+   = schemeR_wrk fvs nm rhs (collect rhs)++-- If an expression is a lambda, return the+-- list of arguments to the lambda (in R-to-L order) and the+-- underlying expression++collect :: CgStgRhs -> ([Var], CgStgExpr)+collect (StgRhsClosure _ _ _ args body) = (args, body)+collect (StgRhsCon _cc dc cnum _ticks args) = ([], StgConApp dc cnum args [])++schemeR_wrk+    :: [Id]+    -> Name+    -> CgStgRhs            -- expression e, for debugging only+    -> ([Var], CgStgExpr)  -- result of collect on e+    -> BcM (ProtoBCO Name)+schemeR_wrk fvs nm original_body (args, body)+   = do+     profile <- getProfile+     let+         platform  = profilePlatform profile+         all_args  = reverse args ++ fvs+         arity     = length all_args+         -- all_args are the args in reverse order.  We're compiling a function+         -- \fv1..fvn x1..xn -> e+         -- i.e. the fvs come first++         -- Stack arguments always take a whole number of words, we never pack+         -- them unlike constructor fields.+         szsb_args = map (wordsToBytes platform . idSizeW platform) all_args+         sum_szsb_args  = sum szsb_args+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))++         -- make the arg bitmap+         bits = argBits platform (reverse (map (bcIdArgRep platform) all_args))+         bitmap_size = genericLength bits+         bitmap = mkBitmap platform bits+     body_code <- schemeER_wrk sum_szsb_args p_init body++     emitBc (mkProtoBCO platform nm body_code (Right original_body)+                 arity bitmap_size bitmap False{-not alts-})++-- introduce break instructions for ticked expressions+schemeER_wrk :: StackDepth -> BCEnv -> CgStgExpr -> BcM BCInstrList+schemeER_wrk d p (StgTick (Breakpoint tick_ty tick_no fvs) rhs)+  = do  code <- schemeE d 0 p rhs+        cc_arr <- getCCArray+        this_mod <- moduleName <$> getCurrentModule+        platform <- profilePlatform <$> getProfile+        let idOffSets = getVarOffSets platform d p fvs+        let breakInfo = CgBreakInfo+                        { cgb_vars = idOffSets+                        , cgb_resty = tick_ty+                        }+        newBreakInfo tick_no breakInfo+        hsc_env <- getHscEnv+        let cc | Just interp <- hsc_interp hsc_env+               , interpreterProfiled interp+               = cc_arr ! tick_no+               | otherwise = toRemotePtr nullPtr+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc+        return $ breakInstr `consOL` code+schemeER_wrk d p rhs = schemeE d 0 p rhs++getVarOffSets :: Platform -> StackDepth -> BCEnv -> [Id] -> [Maybe (Id, Word16)]+getVarOffSets platform depth env = map getOffSet+  where+    getOffSet id = case lookupBCEnv_maybe id env of+        Nothing     -> Nothing+        Just offset ->+            -- michalt: I'm not entirely sure why we need the stack+            -- adjustment by 2 here. I initially thought that there's+            -- something off with getIdValFromApStack (the only user of this+            -- value), but it looks ok to me. My current hypothesis is that+            -- this "adjustment" is needed due to stack manipulation for+            -- BRK_FUN in Interpreter.c In any case, this is used only when+            -- we trigger a breakpoint.+            let !var_depth_ws =+                    trunc16W $ bytesToWords platform (depth - offset) + 2+            in Just (id, var_depth_ws)++truncIntegral16 :: Integral a => a -> Word16+truncIntegral16 w+    | w > fromIntegral (maxBound :: Word16)+    = panic "stack depth overflow"+    | otherwise+    = fromIntegral w++trunc16B :: ByteOff -> Word16+trunc16B = truncIntegral16++trunc16W :: WordOff -> Word16+trunc16W = truncIntegral16++fvsToEnv :: BCEnv -> CgStgRhs -> [Id]+-- Takes the free variables of a right-hand side, and+-- delivers an ordered list of the local variables that will+-- be captured in the thunk for the RHS+-- The BCEnv argument tells which variables are in the local+-- environment: these are the ones that should be captured+--+-- The code that constructs the thunk, and the code that executes+-- it, have to agree about this layout++fvsToEnv p rhs =  [v | v <- dVarSetElems $ freeVarsOfRhs rhs,+                       v `Map.member` p]++-- -----------------------------------------------------------------------------+-- schemeE++-- Returning an unlifted value.+-- Heave it on the stack, SLIDE, and RETURN.+returnUnliftedAtom+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> StgArg+    -> BcM BCInstrList+returnUnliftedAtom d s p e = do+    let reps = case e of+                 StgLitArg lit -> typePrimRepArgs (literalType lit)+                 StgVarArg i   -> bcIdPrimReps i+    (push, szb) <- pushAtom d p e+    ret <- returnUnliftedReps d s szb reps+    return (push `appOL` ret)++-- return an unlifted value from the top of the stack+returnUnliftedReps+    :: StackDepth+    -> Sequel+    -> ByteOff    -- size of the thing we're returning+    -> [PrimRep]  -- representations+    -> BcM BCInstrList+returnUnliftedReps d s szb reps = do+    profile <- getProfile+    let platform = profilePlatform profile+        non_void VoidRep = False+        non_void _ = True+    ret <- case filter non_void reps of+             -- use RETURN_UBX for unary representations+             []    -> return (unitOL $ RETURN_UNLIFTED V)+             [rep] -> return (unitOL $ RETURN_UNLIFTED (toArgRep platform rep))+             -- otherwise use RETURN_TUPLE with a tuple descriptor+             nv_reps -> do+               let (tuple_info, args_offsets) = layoutTuple profile 0 (primRepCmmType platform) nv_reps+                   args_ptrs = map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off)) args_offsets+               tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)+               return $ PUSH_UBX (mkTupleInfoLit platform tuple_info) 1 `consOL`+                        PUSH_BCO tuple_bco `consOL`+                        unitOL RETURN_TUPLE+    return ( mkSlideB platform szb (d - s) -- clear to sequel+             `appOL`  ret)                 -- go++-- construct and return an unboxed tuple+returnUnboxedTuple+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> [StgArg]+    -> BcM BCInstrList+returnUnboxedTuple d s p es = do+    profile <- getProfile+    let platform = profilePlatform profile+        arg_ty e = primRepCmmType platform (atomPrimRep e)+        (tuple_info, tuple_components) = layoutTuple profile d arg_ty es+        go _   pushes [] = return (reverse pushes)+        go !dd pushes ((a, off):cs) = do (push, szb) <- pushAtom dd p a+                                         MASSERT(off == dd + szb)+                                         go (dd + szb) (push:pushes) cs+    pushes <- go d [] tuple_components+    ret <- returnUnliftedReps d+                              s+                              (wordsToBytes platform $ tupleSize tuple_info)+                              (map atomPrimRep es)+    return (mconcat pushes `appOL` ret)++-- Compile code to apply the given expression to the remaining args+-- on the stack, returning a HNF.+schemeE+    :: StackDepth -> Sequel -> BCEnv -> CgStgExpr -> BcM BCInstrList+schemeE d s p (StgLit lit) = returnUnliftedAtom d s p (StgLitArg lit)+schemeE d s p (StgApp x [])+   | isUnliftedType (idType x) = returnUnliftedAtom d s p (StgVarArg x)+-- Delegate tail-calls to schemeT.+schemeE d s p e@(StgApp {}) = schemeT d s p e+schemeE d s p e@(StgConApp {}) = schemeT d s p e+schemeE d s p e@(StgOpApp {}) = schemeT d s p e+schemeE d s p (StgLetNoEscape xlet bnd body)+   = schemeE d s p (StgLet xlet bnd body)+schemeE d s p (StgLet _xlet+                      (StgNonRec x (StgRhsCon _cc data_con _cnum _ticks args))+                      body)+   = do -- Special case for a non-recursive let whose RHS is a+        -- saturated constructor application.+        -- Just allocate the constructor and carry on+        alloc_code <- mkConAppCode d s p data_con args+        platform <- targetPlatform <$> getDynFlags+        let !d2 = d + wordSize platform+        body_code <- schemeE d2 s (Map.insert x d2 p) body+        return (alloc_code `appOL` body_code)+-- General case for let.  Generates correct, if inefficient, code in+-- all situations.+schemeE d s p (StgLet _ext binds body) = do+     platform <- targetPlatform <$> getDynFlags+     let (xs,rhss) = case binds of StgNonRec x rhs  -> ([x],[rhs])+                                   StgRec xs_n_rhss -> unzip xs_n_rhss+         n_binds = genericLength xs++         fvss  = map (fvsToEnv p') rhss++         -- Sizes of free vars+         size_w = trunc16W . idSizeW platform+         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss++         -- the arity of each rhs+         arities = map (genericLength . fst . collect) rhss++         -- This p', d' defn is safe because all the items being pushed+         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack+         -- after the closures have been allocated in the heap (but not+         -- filled in), and pointers to them parked on the stack.+         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize platform))+         p' = Map.insertList (zipE xs offsets) p+         d' = d + wordsToBytes platform n_binds+         zipE = zipEqual "schemeE"++         -- ToDo: don't build thunks for things with no free variables+         build_thunk+             :: StackDepth+             -> [Id]+             -> Word16+             -> ProtoBCO Name+             -> Word16+             -> Word16+             -> BcM BCInstrList+         build_thunk _ [] size bco off arity+            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))+           where+                mkap | arity == 0 = MKAP+                     | otherwise  = MKPAP+         build_thunk dd (fv:fvs) size bco off arity = do+              (push_code, pushed_szb) <- pushAtom dd p' (StgVarArg fv)+              more_push_code <-+                  build_thunk (dd + pushed_szb) fvs size bco off arity+              return (push_code `appOL` more_push_code)++         alloc_code = toOL (zipWith mkAlloc sizes arities)+           where mkAlloc sz 0+                    | is_tick     = ALLOC_AP_NOUPD sz+                    | otherwise   = ALLOC_AP sz+                 mkAlloc sz arity = ALLOC_PAP arity sz++         is_tick = case binds of+                     StgNonRec id _ -> occNameFS (getOccName id) == tickFS+                     _other -> False++         compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do+                bco <- schemeR fvs (getName x,rhs)+                build_thunk d' fvs size bco off arity++         compile_binds =+            [ compile_bind d' fvs x rhs size arity (trunc16W n)+            | (fvs, x, rhs, size, arity, n) <-+                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]+            ]+     body_code <- schemeE d' s p' body+     thunk_codes <- sequence compile_binds+     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)++schemeE _d _s _p (StgTick (Breakpoint _ bp_id _) _rhs)+   = panic ("schemeE: Breakpoint without let binding: " +++            show bp_id +++            " forgot to run bcPrep?")++-- ignore other kinds of tick+schemeE d s p (StgTick _ rhs) = schemeE d s p rhs++-- no alts: scrut is guaranteed to diverge+schemeE d s p (StgCase scrut _ _ []) = schemeE d s p scrut++schemeE d s p (StgCase scrut bndr _ alts)+   = doCase d s p scrut bndr alts++-- Is this Id a not-necessarily-lifted join point?+-- See Note [Not-necessarily-lifted join points], step 1+isNNLJoinPoint :: Id -> Bool+isNNLJoinPoint x = isJoinId x &&+                   Just True /= isLiftedType_maybe (idType x)++-- Update an Id's type to take a Void# argument.+-- Precondition: the Id is a not-necessarily-lifted join point.+-- See Note [Not-necessarily-lifted join points]+protectNNLJoinPointId :: Id -> Id+protectNNLJoinPointId x+  = ASSERT( isNNLJoinPoint x )+    updateIdTypeButNotMult (unboxedUnitTy `mkVisFunTyMany`) x++{-+   Ticked Expressions+   ------------------++  The idea is that the "breakpoint<n,fvs> E" is really just an annotation on+  the code. When we find such a thing, we pull out the useful information,+  and then compile the code as if it was just the expression E.++Note [Not-necessarily-lifted join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point variable is essentially a goto-label: it is, for example,+never used as an argument to another function, and it is called only+in tail position. See Note [Join points] and Note [Invariants on join points],+both in GHC.Core. Because join points do not compile to true, red-blooded+variables (with, e.g., registers allocated to them), they are allowed+to be levity-polymorphic. (See invariant #6 in Note [Invariants on join points]+in GHC.Core.)++However, in this byte-code generator, join points *are* treated just as+ordinary variables. There is no check whether a binding is for a join point+or not; they are all treated uniformly. (Perhaps there is a missed optimization+opportunity here, but that is beyond the scope of my (Richard E's) Thursday.)++We thus must have *some* strategy for dealing with levity-polymorphic and+unlifted join points. Levity-polymorphic variables are generally not allowed+(though levity-polymorphic join points *are*; see Note [Invariants on join points]+in GHC.Core, point 6), and we don't wish to evaluate unlifted join points eagerly.+The questionable join points are *not-necessarily-lifted join points*+(NNLJPs). (Not having such a strategy led to #16509, which panicked in the+isUnliftedType check in the AnnVar case of schemeE.) Here is the strategy:++1. Detect NNLJPs. This is done in isNNLJoinPoint.++2. When binding an NNLJP, add a `\ (_ :: (# #)) ->` to its RHS, and modify the+   type to tack on a `(# #) ->`.+   Note that functions are never levity-polymorphic, so this transformation+   changes an NNLJP to a non-levity-polymorphic join point. This is done+   in bcPrepSingleBind.++3. At an occurrence of an NNLJP, add an application to void# (called voidPrimId),+   being careful to note the new type of the NNLJP. This is done in the AnnVar+   case of schemeE, with help from protectNNLJoinPointId.++Here is an example. Suppose we have++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      join j :: a+           j = error @r @a "bloop"+      in case x of+           A -> j+           B -> j+           C -> error @r @a "blurp"++Our plan is to behave is if the code was++  f = \(r :: RuntimeRep) (a :: TYPE r) (x :: T).+      let j :: (Void# -> a)+          j = \ _ -> error @r @a "bloop"+      in case x of+           A -> j void#+           B -> j void#+           C -> error @r @a "blurp"++It's a bit hacky, but it works well in practice and is local. I suspect the+Right Fix is to take advantage of join points as goto-labels.++-}++-- Compile code to do a tail call.  Specifically, push the fn,+-- slide the on-stack app back down to the sequel depth,+-- and enter.  Four cases:+--+-- 0.  (Nasty hack).+--     An application "GHC.Prim.tagToEnum# <type> unboxed-int".+--     The int will be on the stack.  Generate a code sequence+--     to convert it to the relevant constructor, SLIDE and ENTER.+--+-- 1.  The fn denotes a ccall.  Defer to generateCCall.+--+-- 2.  An unboxed tuple: push the components on the top of+--     the stack and return.+--+-- 3.  Application of a constructor, by defn saturated.+--     Split the args into ptrs and non-ptrs, and push the nonptrs,+--     then the ptrs, and then do PACK and RETURN.+--+-- 4.  Otherwise, it must be a function call.  Push the args+--     right to left, SLIDE and ENTER.++schemeT :: StackDepth   -- Stack depth+        -> Sequel       -- Sequel depth+        -> BCEnv        -- stack env+        -> CgStgExpr+        -> BcM BCInstrList++   -- Case 0+schemeT d s p app+   | Just (arg, constr_names) <- maybe_is_tagToEnum_call app+   = implement_tagToId d s p arg constr_names++   -- Case 1+schemeT d s p (StgOpApp (StgFCallOp (CCall ccall_spec) _ty) args result_ty)+   = if isSupportedCConv ccall_spec+      then generateCCall d s p ccall_spec result_ty (reverse args)+      else unsupportedCConvException++schemeT d s p (StgOpApp (StgPrimOp op) args _ty)+   = doTailCall d s p (primOpId op) (reverse args)++schemeT _d _s _p (StgOpApp StgPrimCallOp{} _args _ty)+   = unsupportedCConvException++   -- Case 2: Unboxed tuple+schemeT d s p (StgConApp con _ext args _tys)+   | isUnboxedTupleDataCon con || isUnboxedSumDataCon con+   = returnUnboxedTuple d s p args++   -- Case 3: Ordinary data constructor+   | otherwise+   = do alloc_con <- mkConAppCode d s p con args+        platform <- profilePlatform <$> getProfile+        return (alloc_con         `appOL`+                mkSlideW 1 (bytesToWords platform $ d - s) `snocOL`+                if isUnliftedTypeKind (tyConResKind (dataConTyCon con))+                then RETURN_UNLIFTED P+                else ENTER)++   -- Case 4: Tail call of function+schemeT d s p (StgApp fn args)+   = doTailCall d s p fn (reverse args)++schemeT _ _ _ e = pprPanic "GHC.StgToByteCode.schemeT"+                           (pprStgExpr shortStgPprOpts e)++-- -----------------------------------------------------------------------------+-- Generate code to build a constructor application,+-- leaving it on top of the stack++mkConAppCode+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> DataCon                  -- The data constructor+    -> [StgArg]                 -- Args, in *reverse* order+    -> BcM BCInstrList+mkConAppCode orig_d _ p con args = app_code+  where+    app_code = do+        profile <- getProfile+        let platform = profilePlatform profile++            non_voids =+                [ NonVoid (prim_rep, arg)+                | arg <- args+                , let prim_rep = atomPrimRep arg+                , not (isVoidRep prim_rep)+                ]+            (_, _, args_offsets) =+                mkVirtHeapOffsetsWithPadding profile StdHeader non_voids++            do_pushery !d (arg : args) = do+                (push, arg_bytes) <- case arg of+                    (Padding l _) -> return $! pushPadding (ByteOff l)+                    (FieldOff a _) -> pushConstrAtom d p (fromNonVoid a)+                more_push_code <- do_pushery (d + arg_bytes) args+                return (push `appOL` more_push_code)+            do_pushery !d [] = do+                let !n_arg_words = trunc16W $ bytesToWords platform (d - orig_d)+                return (unitOL (PACK con n_arg_words))++        -- Push on the stack in the reverse order.+        do_pushery orig_d (reverse args_offsets)++-- -----------------------------------------------------------------------------+-- Generate code for a tail-call++doTailCall+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> Id+    -> [StgArg]+    -> BcM BCInstrList+doTailCall init_d s p fn args = do+   platform <- profilePlatform <$> getProfile+   do_pushes init_d args (map (atomRep platform) args)+  where+  do_pushes !d [] reps = do+        ASSERT( null reps ) return ()+        (push_fn, sz) <- pushAtom d p (StgVarArg fn)+        platform <- profilePlatform <$> getProfile+        ASSERT( sz == wordSize platform ) return ()+        let slide = mkSlideB platform (d - init_d + wordSize platform) (init_d - s)+            enter = if isUnliftedType (idType fn)+                    then RETURN_UNLIFTED P+                    else ENTER+        return (push_fn `appOL` (slide `appOL` unitOL enter))+  do_pushes !d args reps = do+      let (push_apply, n, rest_of_reps) = findPushSeq reps+          (these_args, rest_of_args) = splitAt n args+      (next_d, push_code) <- push_seq d these_args+      platform <- profilePlatform <$> getProfile+      instrs <- do_pushes (next_d + wordSize platform) rest_of_args rest_of_reps+      --                          ^^^ for the PUSH_APPLY_ instruction+      return (push_code `appOL` (push_apply `consOL` instrs))++  push_seq d [] = return (d, nilOL)+  push_seq d (arg:args) = do+    (push_code, sz) <- pushAtom d p arg+    (final_d, more_push_code) <- push_seq (d + sz) args+    return (final_d, push_code `appOL` more_push_code)++-- v. similar to CgStackery.findMatch, ToDo: merge+findPushSeq :: [ArgRep] -> (BCInstr, Int, [ArgRep])+findPushSeq (P: P: P: P: P: P: rest)+  = (PUSH_APPLY_PPPPPP, 6, rest)+findPushSeq (P: P: P: P: P: rest)+  = (PUSH_APPLY_PPPPP, 5, rest)+findPushSeq (P: P: P: P: rest)+  = (PUSH_APPLY_PPPP, 4, rest)+findPushSeq (P: P: P: rest)+  = (PUSH_APPLY_PPP, 3, rest)+findPushSeq (P: P: rest)+  = (PUSH_APPLY_PP, 2, rest)+findPushSeq (P: rest)+  = (PUSH_APPLY_P, 1, rest)+findPushSeq (V: rest)+  = (PUSH_APPLY_V, 1, rest)+findPushSeq (N: rest)+  = (PUSH_APPLY_N, 1, rest)+findPushSeq (F: rest)+  = (PUSH_APPLY_F, 1, rest)+findPushSeq (D: rest)+  = (PUSH_APPLY_D, 1, rest)+findPushSeq (L: rest)+  = (PUSH_APPLY_L, 1, rest)+findPushSeq _+  = panic "GHC.StgToByteCode.findPushSeq"++-- -----------------------------------------------------------------------------+-- Case expressions++doCase+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> CgStgExpr+    -> Id+    -> [CgStgAlt]+    -> BcM BCInstrList+doCase d s p scrut bndr alts+  = do+     profile <- getProfile+     hsc_env <- getHscEnv+     let+        platform = profilePlatform profile++        -- Are we dealing with an unboxed tuple with a tuple return frame?+        --+        -- 'Simple' tuples with at most one non-void component,+        -- like (# Word# #) or (# Int#, State# RealWorld# #) do not have a+        -- tuple return frame. This is because (# foo #) and (# foo, Void# #)+        -- have the same runtime rep. We have more efficient specialized+        -- return frames for the situations with one non-void element.++        ubx_tuple_frame =+          (isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty) &&+          length non_void_arg_reps > 1++        non_void_arg_reps = non_void (typeArgReps platform bndr_ty)++        profiling+          | Just interp <- hsc_interp hsc_env+          = interpreterProfiled interp+          | otherwise = False++        -- Top of stack is the return itbl, as usual.+        -- underneath it is the pointer to the alt_code BCO.+        -- When an alt is entered, it assumes the returned value is+        -- on top of the itbl.+        ret_frame_size_b :: StackDepth+        ret_frame_size_b | ubx_tuple_frame =+                             (if profiling then 5 else 4) * wordSize platform+                         | otherwise = 2 * wordSize platform++        -- The stack space used to save/restore the CCCS when profiling+        save_ccs_size_b | profiling &&+                          not ubx_tuple_frame = 2 * wordSize platform+                        | otherwise = 0++        -- An unlifted value gets an extra info table pushed on top+        -- when it is returned.+        unlifted_itbl_size_b :: StackDepth+        unlifted_itbl_size_b | ubx_tuple_frame              = 3 * wordSize platform+                             | not (isUnliftedType bndr_ty) = 0+                             | otherwise                    = wordSize platform++        (bndr_size, tuple_info, args_offsets)+           | ubx_tuple_frame =+               let bndr_ty = primRepCmmType platform+                   bndr_reps = filter (not.isVoidRep) (bcIdPrimReps bndr)+                   (tuple_info, args_offsets) =+                       layoutTuple profile 0 bndr_ty bndr_reps+               in ( wordsToBytes platform (tupleSize tuple_info)+                  , tuple_info+                  , args_offsets+                  )+           | otherwise = ( wordsToBytes platform (idSizeW platform bndr)+                         , voidTupleInfo+                         , []+                         )++        -- depth of stack after the return value has been pushed+        d_bndr =+            d + ret_frame_size_b + bndr_size++        -- depth of stack after the extra info table for an unlifted return+        -- has been pushed, if any.  This is the stack depth at the+        -- continuation.+        d_alts = d + ret_frame_size_b + bndr_size + unlifted_itbl_size_b++        -- Env in which to compile the alts, not including+        -- any vars bound by the alts themselves+        p_alts = Map.insert bndr d_bndr p++        bndr_ty = idType bndr+        isAlgCase = isAlgType bndr_ty++        -- given an alt, return a discr and code for it.+        codeAlt (DEFAULT, _, rhs)+           = do rhs_code <- schemeE d_alts s p_alts rhs+                return (NoDiscr, rhs_code)++        codeAlt alt@(_, bndrs, rhs)+           -- primitive or nullary constructor alt: no need to UNPACK+           | null real_bndrs = do+                rhs_code <- schemeE d_alts s p_alts rhs+                return (my_discr alt, rhs_code)+           | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty =+             let bndr_ty = primRepCmmType platform . bcIdPrimRep+                 tuple_start = d_bndr+                 (tuple_info, args_offsets) =+                   layoutTuple profile+                               0+                               bndr_ty+                               bndrs++                 stack_bot = d_alts++                 p' = Map.insertList+                        [ (arg, tuple_start -+                                wordsToBytes platform (tupleSize tuple_info) ++                                offset)+                        | (arg, offset) <- args_offsets+                        , not (isVoidRep $ bcIdPrimRep arg)]+                        p_alts+             in do+               rhs_code <- schemeE stack_bot s p' rhs+               return (NoDiscr, rhs_code)+           -- algebraic alt with some binders+           | otherwise =+             let (tot_wds, _ptrs_wds, args_offsets) =+                     mkVirtHeapOffsets profile NoHeader+                         [ NonVoid (bcIdPrimRep id, id)+                         | NonVoid id <- nonVoidIds real_bndrs+                         ]+                 size = WordOff tot_wds++                 stack_bot = d_alts + wordsToBytes platform size++                 -- convert offsets from Sp into offsets into the virtual stack+                 p' = Map.insertList+                        [ (arg, stack_bot - ByteOff offset)+                        | (NonVoid arg, offset) <- args_offsets ]+                        p_alts++                 -- unlifted datatypes have an infotable word on top+                 unpack = if isUnliftedType bndr_ty+                          then PUSH_L 1 `consOL`+                               UNPACK (trunc16W size) `consOL`+                               unitOL (SLIDE (trunc16W size) 1)+                          else unitOL (UNPACK (trunc16W size))+             in do+             MASSERT(isAlgCase)+             rhs_code <- schemeE stack_bot s p' rhs+             return (my_discr alt, unpack `appOL` rhs_code)+           where+             real_bndrs = filterOut isTyVar bndrs++        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}+        my_discr (DataAlt dc, _, _)+           | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc+           = NoDiscr+           | otherwise+           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))+        my_discr (LitAlt l, _, _)+           = case l of LitNumber LitNumInt i  -> DiscrI (fromInteger i)+                       LitNumber LitNumWord w -> DiscrW (fromInteger w)+                       LitFloat r   -> DiscrF (fromRational r)+                       LitDouble r  -> DiscrD (fromRational r)+                       LitChar i    -> DiscrI (ord i)+                       _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)++        maybe_ncons+           | not isAlgCase = Nothing+           | otherwise+           = case [dc | (DataAlt dc, _, _) <- alts] of+                []     -> Nothing+                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))++        -- the bitmap is relative to stack depth d, i.e. before the+        -- BCO, info table and return value are pushed on.+        -- This bit of code is v. similar to buildLivenessMask in CgBindery,+        -- except that here we build the bitmap from the known bindings of+        -- things that are pointers, whereas in CgBindery the code builds the+        -- bitmap from the free slots and unboxed bindings.+        -- (ToDo: merge?)+        --+        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.+        -- The bitmap must cover the portion of the stack up to the sequel only.+        -- Previously we were building a bitmap for the whole depth (d), but we+        -- really want a bitmap up to depth (d-s).  This affects compilation of+        -- case-of-case expressions, which is the only time we can be compiling a+        -- case expression with s /= 0.++        -- unboxed tuples get two more words, the second is a pointer (tuple_bco)+        (extra_pointers, extra_slots)+           | ubx_tuple_frame && profiling = ([1], 3) -- tuple_info, tuple_BCO, CCCS+           | ubx_tuple_frame              = ([1], 2) -- tuple_info, tuple_BCO+           | otherwise                    = ([], 0)++        bitmap_size = trunc16W $ fromIntegral extra_slots ++                                 bytesToWords platform (d - s)++        bitmap_size' :: Int+        bitmap_size' = fromIntegral bitmap_size+++        pointers =+          extra_pointers +++          sort (filter (< bitmap_size') (map (+extra_slots) rel_slots))+          where+          binds = Map.toList p+          -- NB: unboxed tuple cases bind the scrut binder to the same offset+          -- as one of the alt binders, so we have to remove any duplicates here:+          rel_slots = nub $ map fromIntegral $ concatMap spread binds+          spread (id, offset) | isUnboxedTupleType (idType id) ||+                                isUnboxedSumType (idType id) = []+                              | isFollowableArg (bcIdArgRep platform id) = [ rel_offset ]+                              | otherwise                      = []+                where rel_offset = trunc16W $ bytesToWords platform (d - offset)++        bitmap = intsToReverseBitmap platform bitmap_size'{-size-} pointers++     alt_stuff <- mapM codeAlt alts+     alt_final <- mkMultiBranch maybe_ncons alt_stuff++     let+         alt_bco_name = getName bndr+         alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)+                       0{-no arity-} bitmap_size bitmap True{-is alts-}+     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)+                           (d + ret_frame_size_b + save_ccs_size_b)+                           p scrut+     alt_bco' <- emitBc alt_bco+     if ubx_tuple_frame+       then do+              let args_ptrs =+                    map (\(rep, off) -> (isFollowableArg (toArgRep platform rep), off))+                        args_offsets+              tuple_bco <- emitBc (tupleBCO platform tuple_info args_ptrs)+              return (PUSH_ALTS_TUPLE alt_bco' tuple_info tuple_bco+                      `consOL` scrut_code)+       else let push_alts+                  | not (isUnliftedType bndr_ty)+                  = PUSH_ALTS alt_bco'+                  | otherwise+                  = let unlifted_rep =+                          case non_void_arg_reps of+                            []    -> V+                            [rep] -> rep+                            _     -> panic "schemeE(StgCase).push_alts"+                    in PUSH_ALTS_UNLIFTED alt_bco' unlifted_rep+            in return (push_alts `consOL` scrut_code)+++-- -----------------------------------------------------------------------------+-- Deal with tuples++-- The native calling convention uses registers for tuples, but in the+-- bytecode interpreter, all values live on the stack.++layoutTuple :: Profile+            -> ByteOff+            -> (a -> CmmType)+            -> [a]+            -> ( TupleInfo      -- See Note [GHCi TupleInfo]+               , [(a, ByteOff)] -- argument, offset on stack+               )+layoutTuple profile start_off arg_ty reps =+  let platform = profilePlatform profile+      (orig_stk_bytes, pos) = assignArgumentsPos profile+                                                 0+                                                 NativeReturn+                                                 arg_ty+                                                 reps++      -- keep the stack parameters in the same place+      orig_stk_params = [(x, fromIntegral off) | (x, StackParam off) <- pos]++      -- sort the register parameters by register and add them to the stack+      regs_order :: Map.Map GlobalReg Int+      regs_order = Map.fromList $ zip (tupleRegsCover platform) [0..]++      reg_order :: GlobalReg -> (Int, GlobalReg)+      reg_order reg | Just n <- Map.lookup reg regs_order = (n, reg)+      -- a VanillaReg goes to the same place regardless of whether it+      -- contains a pointer+      reg_order (VanillaReg n VNonGcPtr) = reg_order (VanillaReg n VGcPtr)+      -- if we don't have a position for a FloatReg then they must be passed+      -- in the equivalent DoubleReg+      reg_order (FloatReg n) = reg_order (DoubleReg n)+      -- one-tuples can be passed in other registers, but then we don't need+      -- to care about the order+      reg_order reg          = (0, reg)++      (regs, reg_params)+          = unzip $ sortBy (comparing fst)+                           [(reg_order reg, x) | (x, RegisterParam reg) <- pos]++      (new_stk_bytes, new_stk_params) = assignStack platform+                                                    orig_stk_bytes+                                                    arg_ty+                                                    reg_params++      regs_set = mkRegSet (map snd regs)++      get_byte_off (x, StackParam y) = (x, fromIntegral y)+      get_byte_off _                 =+          panic "GHC.StgToByteCode.layoutTuple get_byte_off"++  in ( TupleInfo+         { tupleSize        = bytesToWords platform (ByteOff new_stk_bytes)+         , tupleRegs        = regs_set+         , tupleNativeStackSize = bytesToWords platform+                                               (ByteOff orig_stk_bytes)+         }+     , sortBy (comparing snd) $+              map (\(x, o) -> (x, o + start_off))+                  (orig_stk_params ++ map get_byte_off new_stk_params)+     )++{- Note [unboxed tuple bytecodes and tuple_BCO]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  We have the bytecode instructions RETURN_TUPLE and PUSH_ALTS_TUPLE to+  return and receive arbitrary unboxed tuples, respectively. These+  instructions use the helper data tuple_BCO and tuple_info.++  The helper data is used to convert tuples between GHCs native calling+  convention (object code), which uses stack and registers, and the bytecode+  calling convention, which only uses the stack. See Note [GHCi TupleInfo]+  for more details.+++  Returning a tuple+  =================++  Bytecode that returns a tuple first pushes all the tuple fields followed+  by the appropriate tuple_info and tuple_BCO onto the stack. It then+  executes the RETURN_TUPLE instruction, which causes the interpreter+  to push stg_ret_t_info to the top of the stack. The stack (growing down)+  then looks as follows:++      ...+      next_frame+      tuple_field_1+      tuple_field_2+      ...+      tuple_field_n+      tuple_info+      tuple_BCO+      stg_ret_t_info <- Sp++  If next_frame is bytecode, the interpreter will start executing it. If+  it's object code, the interpreter jumps back to the scheduler, which in+  turn jumps to stg_ret_t. stg_ret_t converts the tuple to the native+  calling convention using the description in tuple_info, and then jumps+  to next_frame.+++  Receiving a tuple+  =================++  Bytecode that receives a tuple uses the PUSH_ALTS_TUPLE instruction to+  push a continuation, followed by jumping to the code that produces the+  tuple. The PUSH_ALTS_TUPLE instuction contains three pieces of data:++     * cont_BCO: the continuation that receives the tuple+     * tuple_info: see below+     * tuple_BCO: see below++  The interpreter pushes these onto the stack when the PUSH_ALTS_TUPLE+  instruction is executed, followed by stg_ctoi_tN_info, with N depending+  on the number of stack words used by the tuple in the GHC native calling+  convention. N is derived from tuple_info.++  For example if we expect a tuple with three words on the stack, the stack+  looks as follows after PUSH_ALTS_TUPLE:++      ...+      next_frame+      cont_free_var_1+      cont_free_var_2+      ...+      cont_free_var_n+      tuple_info+      tuple_BCO+      cont_BCO+      stg_ctoi_t3_info <- Sp++  If the tuple is returned by object code, stg_ctoi_t3 will deal with+  adjusting the stack pointer and converting the tuple to the bytecode+  calling convention. See Note [GHCi unboxed tuples stack spills] for more+  details.+++  The tuple_BCO+  =============++  The tuple_BCO is a helper bytecode object. Its main purpose is describing+  the contents of the stack frame containing the tuple for the storage+  manager. It contains only instructions to immediately return the tuple+  that is already on the stack.+++  The tuple_info word+  ===================++  The tuple_info word describes the stack and STG register (e.g. R1..R6,+  D1..D6) usage for the tuple. tuple_info contains enough information to+  convert the tuple between the stack-only bytecode and stack+registers+  GHC native calling conventions.++  See Note [GHCi tuple layout] for more details of how the data is packed+  in a single word.++ -}++tupleBCO :: Platform -> TupleInfo -> [(Bool, ByteOff)] -> [FFIInfo] -> ProtoBCO Name+tupleBCO platform info pointers =+  mkProtoBCO platform invented_name body_code (Left [])+             0{-no arity-} bitmap_size bitmap False{-is alts-}++  where+    {-+      The tuple BCO is never referred to by name, so we can get away+      with using a fake name here. We will need to change this if we want+      to save some memory by sharing the BCO between places that have+      the same tuple shape+    -}+    invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "tuple")++    -- the first word in the frame is the tuple_info word,+    -- which is not a pointer+    bitmap_size = trunc16W $ 1 + tupleSize info+    bitmap      = intsToReverseBitmap platform (fromIntegral bitmap_size) $+                  map ((+1) . fromIntegral . bytesToWords platform . snd)+                      (filter fst pointers)+    body_code = mkSlideW 0 1          -- pop frame header+                `snocOL` RETURN_TUPLE -- and add it again++-- -----------------------------------------------------------------------------+-- Deal with a CCall.++-- Taggedly push the args onto the stack R->L,+-- deferencing ForeignObj#s and adjusting addrs to point to+-- payloads in Ptr/Byte arrays.  Then, generate the marshalling+-- (machine) code for the ccall, and create bytecodes to call that and+-- then return in the right way.++generateCCall+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> CCallSpec               -- where to call+    -> Type+    -> [StgArg]              -- args (atoms)+    -> BcM BCInstrList+generateCCall d0 s p (CCallSpec target cconv safety) result_ty args_r_to_l+ = do+     profile <- getProfile++     let+         platform = profilePlatform profile+         -- useful constants+         addr_size_b :: ByteOff+         addr_size_b = wordSize platform++         arrayish_rep_hdr_size :: TyCon -> Maybe Int+         arrayish_rep_hdr_size t+           | t == arrayPrimTyCon || t == mutableArrayPrimTyCon+              = Just (arrPtrsHdrSize profile)+           | t == smallArrayPrimTyCon || t == smallMutableArrayPrimTyCon+              = Just (smallArrPtrsHdrSize profile)+           | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon+              = Just (arrWordsHdrSize profile)+           | otherwise+              = Nothing++         -- Get the args on the stack, with tags and suitably+         -- dereferenced for the CCall.  For each arg, return the+         -- depth to the first word of the bits for that arg, and the+         -- ArgRep of what was actually pushed.++         pargs+             :: ByteOff -> [StgArg] -> BcM [(BCInstrList, PrimRep)]+         pargs _ [] = return []+         pargs d (aa@(StgVarArg a):az)+            | Just t      <- tyConAppTyCon_maybe (idType a)+            , Just hdr_sz <- arrayish_rep_hdr_size t+            -- Do magic for Ptr/Byte arrays.  Push a ptr to the array on+            -- the stack but then advance it over the headers, so as to+            -- point to the payload.+            = do rest <- pargs (d + addr_size_b) az+                 (push_fo, _) <- pushAtom d p aa+                 -- The ptr points at the header.  Advance it over the+                 -- header and then pretend this is an Addr#.+                 let code = push_fo `snocOL` SWIZZLE 0 (fromIntegral hdr_sz)+                 return ((code, AddrRep) : rest)+         pargs d (aa:az) =  do (code_a, sz_a) <- pushAtom d p aa+                               rest <- pargs (d + sz_a) az+                               return ((code_a, atomPrimRep aa) : rest)++     code_n_reps <- pargs d0 args_r_to_l+     let+         (pushs_arg, a_reps_pushed_r_to_l) = unzip code_n_reps+         a_reps_sizeW = sum (map (repSizeWords platform) a_reps_pushed_r_to_l)++         push_args    = concatOL pushs_arg+         !d_after_args = d0 + wordsToBytes platform a_reps_sizeW+         a_reps_pushed_RAW+            | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))+            = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"+            | otherwise+            = reverse (tail a_reps_pushed_r_to_l)++         -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.+         -- push_args is the code to do that.+         -- d_after_args is the stack depth once the args are on.++         -- Get the result rep.+         (returns_void, r_rep)+            = case maybe_getCCallReturnRep result_ty of+                 Nothing -> (True,  VoidRep)+                 Just rr -> (False, rr)+         {-+         Because the Haskell stack grows down, the a_reps refer to+         lowest to highest addresses in that order.  The args for the call+         are on the stack.  Now push an unboxed Addr# indicating+         the C function to call.  Then push a dummy placeholder for the+         result.  Finally, emit a CCALL insn with an offset pointing to the+         Addr# just pushed, and a literal field holding the mallocville+         address of the piece of marshalling code we generate.+         So, just prior to the CCALL insn, the stack looks like this+         (growing down, as usual):++            <arg_n>+            ...+            <arg_1>+            Addr# address_of_C_fn+            <placeholder-for-result#> (must be an unboxed type)++         The interpreter then calls the marshall code mentioned+         in the CCALL insn, passing it (& <placeholder-for-result#>),+         that is, the addr of the topmost word in the stack.+         When this returns, the placeholder will have been+         filled in.  The placeholder is slid down to the sequel+         depth, and we RETURN.++         This arrangement makes it simple to do f-i-dynamic since the Addr#+         value is the first arg anyway.++         The marshalling code is generated specifically for this+         call site, and so knows exactly the (Haskell) stack+         offsets of the args, fn address and placeholder.  It+         copies the args to the C stack, calls the stacked addr,+         and parks the result back in the placeholder.  The interpreter+         calls it as a normal C call, assuming it has a signature+            void marshall_code ( StgWord* ptr_to_top_of_stack )+         -}+         -- resolve static address+         maybe_static_target :: Maybe Literal+         maybe_static_target =+             case target of+                 DynamicTarget -> Nothing+                 StaticTarget _ _ _ False ->+                   panic "generateCCall: unexpected FFI value import"+                 StaticTarget _ target _ True ->+                   Just (LitLabel target mb_size IsFunction)+                   where+                      mb_size+                          | OSMinGW32 <- platformOS platform+                          , StdCallConv <- cconv+                          = Just (fromIntegral a_reps_sizeW * platformWordSizeInBytes platform)+                          | otherwise+                          = Nothing++     let+         is_static = isJust maybe_static_target++         -- Get the arg reps, zapping the leading Addr# in the dynamic case+         a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"+                | is_static = a_reps_pushed_RAW+                | otherwise = if null a_reps_pushed_RAW+                              then panic "GHC.StgToByteCode.generateCCall: dyn with no args"+                              else tail a_reps_pushed_RAW++         -- push the Addr#+         (push_Addr, d_after_Addr)+            | Just machlabel <- maybe_static_target+            = (toOL [PUSH_UBX machlabel 1], d_after_args + addr_size_b)+            | otherwise -- is already on the stack+            = (nilOL, d_after_args)++         -- Push the return placeholder.  For a call returning nothing,+         -- this is a V (tag).+         r_sizeW   = repSizeWords platform r_rep+         d_after_r = d_after_Addr + wordsToBytes platform r_sizeW+         push_r =+             if returns_void+                then nilOL+                else unitOL (PUSH_UBX (mkDummyLiteral platform r_rep) (trunc16W r_sizeW))++         -- generate the marshalling code we're going to call++         -- Offset of the next stack frame down the stack.  The CCALL+         -- instruction needs to describe the chunk of stack containing+         -- the ccall args to the GC, so it needs to know how large it+         -- is.  See comment in Interpreter.c with the CCALL instruction.+         stk_offset   = trunc16W $ bytesToWords platform (d_after_r - s)++         conv = case cconv of+           CCallConv -> FFICCall+           StdCallConv -> FFIStdCall+           _ -> panic "GHC.StgToByteCode: unexpected calling convention"++     -- the only difference in libffi mode is that we prepare a cif+     -- describing the call type by calling libffi, and we attach the+     -- address of this to the CCALL instruction.+++     let ffires = primRepToFFIType platform r_rep+         ffiargs = map (primRepToFFIType platform) a_reps+     interp <- hscInterp <$> getHscEnv+     token <- ioToBc $ interpCmd interp (PrepFFI conv ffiargs ffires)+     recordFFIBc token++     let+         -- do the call+         do_call      = unitOL (CCALL stk_offset token flags)+           where flags = case safety of+                           PlaySafe          -> 0x0+                           PlayInterruptible -> 0x1+                           PlayRisky         -> 0x2++         -- slide and return+         d_after_r_min_s = bytesToWords platform (d_after_r - s)+         wrapup       = mkSlideW (trunc16W r_sizeW) (d_after_r_min_s - r_sizeW)+                        `snocOL` RETURN_UNLIFTED (toArgRep platform r_rep)+         --trace (show (arg1_offW, args_offW  ,  (map argRepSizeW a_reps) )) $+     return (+         push_args `appOL`+         push_Addr `appOL` push_r `appOL` do_call `appOL` wrapup+         )++primRepToFFIType :: Platform -> PrimRep -> FFIType+primRepToFFIType platform r+  = case r of+     VoidRep     -> FFIVoid+     IntRep      -> signed_word+     WordRep     -> unsigned_word+     Int8Rep     -> FFISInt8+     Word8Rep    -> FFIUInt8+     Int16Rep    -> FFISInt16+     Word16Rep   -> FFIUInt16+     Int32Rep    -> FFISInt32+     Word32Rep   -> FFIUInt32+     Int64Rep    -> FFISInt64+     Word64Rep   -> FFIUInt64+     AddrRep     -> FFIPointer+     FloatRep    -> FFIFloat+     DoubleRep   -> FFIDouble+     _           -> panic "primRepToFFIType"+  where+    (signed_word, unsigned_word) = case platformWordSize platform of+       PW4 -> (FFISInt32, FFIUInt32)+       PW8 -> (FFISInt64, FFIUInt64)++-- Make a dummy literal, to be used as a placeholder for FFI return+-- values on the stack.+mkDummyLiteral :: Platform -> PrimRep -> Literal+mkDummyLiteral platform pr+   = case pr of+        IntRep    -> mkLitInt  platform 0+        WordRep   -> mkLitWord platform 0+        Int8Rep   -> mkLitInt8 0+        Word8Rep  -> mkLitWord8 0+        Int16Rep  -> mkLitInt16 0+        Word16Rep -> mkLitWord16 0+        Int32Rep  -> mkLitInt32 0+        Word32Rep -> mkLitWord32 0+        Int64Rep  -> mkLitInt64 0+        Word64Rep -> mkLitWord64 0+        AddrRep   -> LitNullAddr+        DoubleRep -> LitDouble 0+        FloatRep  -> LitFloat 0+        _         -> pprPanic "mkDummyLiteral" (ppr pr)+++-- Convert (eg)+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #)+--+-- to  Just IntRep+-- and check that an unboxed pair is returned wherein the first arg is V'd.+--+-- Alternatively, for call-targets returning nothing, convert+--+--     GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld+--                   -> (# GHC.Prim.State# GHC.Prim.RealWorld #)+--+-- to  Nothing++maybe_getCCallReturnRep :: Type -> Maybe PrimRep+maybe_getCCallReturnRep fn_ty+   = let+       (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty)+       r_reps = typePrimRepArgs r_ty++       blargh :: a -- Used at more than one type+       blargh = pprPanic "maybe_getCCallReturn: can't handle:"+                         (pprType fn_ty)+     in+       case r_reps of+         []            -> panic "empty typePrimRepArgs"+         [VoidRep]     -> Nothing+         [rep]+           | isGcPtrRep rep -> blargh+           | otherwise      -> Just rep++                 -- if it was, it would be impossible to create a+                 -- valid return value placeholder on the stack+         _             -> blargh++maybe_is_tagToEnum_call :: CgStgExpr -> Maybe (Id, [Name])+-- Detect and extract relevant info for the tagToEnum kludge.+maybe_is_tagToEnum_call (StgOpApp (StgPrimOp TagToEnumOp) [StgVarArg v] t)+  = Just (v, extract_constr_Names t)+  where+    extract_constr_Names ty+           | rep_ty <- unwrapType ty+           , Just tyc <- tyConAppTyCon_maybe rep_ty+           , isDataTyCon tyc+           = map (getName . dataConWorkId) (tyConDataCons tyc)+           -- NOTE: use the worker name, not the source name of+           -- the DataCon.  See "GHC.Core.DataCon" for details.+           | otherwise+           = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty)+maybe_is_tagToEnum_call _ = Nothing++{- -----------------------------------------------------------------------------+Note [Implementing tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(implement_tagToId arg names) compiles code which takes an argument+'arg', (call it i), and enters the i'th closure in the supplied list+as a consequence.  The [Name] is a list of the constructors of this+(enumeration) type.++The code we generate is this:+                push arg+                push bogus-word++                TESTEQ_I 0 L1+                  PUSH_G <lbl for first data con>+                  JMP L_Exit++        L1:     TESTEQ_I 1 L2+                  PUSH_G <lbl for second data con>+                  JMP L_Exit+        ...etc...+        Ln:     TESTEQ_I n L_fail+                  PUSH_G <lbl for last data con>+                  JMP L_Exit++        L_fail: CASEFAIL++        L_exit: SLIDE 1 n+                ENTER++The 'bogus-word' push is because TESTEQ_I expects the top of the stack+to have an info-table, and the next word to have the value to be+tested.  This is very weird, but it's the way it is right now.  See+Interpreter.c.  We don't actually need an info-table here; we just+need to have the argument to be one-from-top on the stack, hence pushing+a 1-word null. See #8383.+-}+++implement_tagToId+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> Id+    -> [Name]+    -> BcM BCInstrList+-- See Note [Implementing tagToEnum#]+implement_tagToId d s p arg names+  = ASSERT( notNull names )+    do (push_arg, arg_bytes) <- pushAtom d p (StgVarArg arg)+       labels <- getLabelsBc (genericLength names)+       label_fail <- getLabelBc+       label_exit <- getLabelBc+       dflags <- getDynFlags+       let infos = zip4 labels (tail labels ++ [label_fail])+                               [0 ..] names+           platform = targetPlatform dflags+           steps = map (mkStep label_exit) infos+           slide_ws = bytesToWords platform (d - s + arg_bytes)++       return (push_arg+               `appOL` unitOL (PUSH_UBX LitNullAddr 1)+                   -- Push bogus word (see Note [Implementing tagToEnum#])+               `appOL` concatOL steps+               `appOL` toOL [ LABEL label_fail, CASEFAIL,+                              LABEL label_exit ]+               `appOL` mkSlideW 1 (slide_ws + 1)+                   -- "+1" to account for bogus word+                   --      (see Note [Implementing tagToEnum#])+               `appOL` unitOL ENTER)+  where+        mkStep l_exit (my_label, next_label, n, name_for_n)+           = toOL [LABEL my_label,+                   TESTEQ_I n next_label,+                   PUSH_G name_for_n,+                   JMP l_exit]+++-- -----------------------------------------------------------------------------+-- pushAtom++-- Push an atom onto the stack, returning suitable code & number of+-- stack words used.+--+-- The env p must map each variable to the highest- numbered stack+-- slot for it.  For example, if the stack has depth 4 and we+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],+-- the tag in stack[5], the stack will have depth 6, and p must map v+-- to 5 and not to 4.  Stack locations are numbered from zero, so a+-- depth 6 stack has valid words 0 .. 5.++pushAtom+    :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)++-- See Note [Empty case alternatives] in GHC.Core+-- and Note [Bottoming expressions] in GHC.Core.Utils:+-- The scrutinee of an empty case evaluates to bottom+pushAtom d p (StgVarArg var)+   | [] <- typePrimRep (idType var)+   = return (nilOL, 0)++   | isFCallId var+   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)++   | Just primop <- isPrimOpId_maybe var+   = do+       platform <- targetPlatform <$> getDynFlags+       return (unitOL (PUSH_PRIMOP primop), wordSize platform)++   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable+   = do platform <- targetPlatform <$> getDynFlags++        let !szb = idSizeCon platform var+            with_instr instr = do+                let !off_b = trunc16B $ d - d_v+                return (unitOL (instr off_b), wordSize platform)++        case szb of+            1 -> with_instr PUSH8_W+            2 -> with_instr PUSH16_W+            4 -> with_instr PUSH32_W+            _ -> do+                let !szw = bytesToWords platform szb+                    !off_w = trunc16W $ bytesToWords platform (d - d_v) + szw - 1+                return (toOL (genericReplicate szw (PUSH_L off_w)),+                              wordsToBytes platform szw)+        -- d - d_v           offset from TOS to the first slot of the object+        --+        -- d - d_v + sz - 1  offset from the TOS of the last slot of the object+        --+        -- Having found the last slot, we proceed to copy the right number of+        -- slots on to the top of the stack.++   | otherwise  -- var must be a global variable+   = do topStrings <- getTopStrings+        platform <- targetPlatform <$> getDynFlags+        case lookupVarEnv topStrings var of+            Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $+              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr+            Nothing -> do+                let sz = idSizeCon platform var+                MASSERT( sz == wordSize platform )+                return (unitOL (PUSH_G (getName var)), sz)+++pushAtom _ _ (StgLitArg lit) = pushLiteral True lit++pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)+pushLiteral padded lit =+  do+     platform <- targetPlatform <$> getDynFlags+     let code :: PrimRep -> BcM (BCInstrList, ByteOff)+         code rep =+            return (padding_instr `snocOL` instr, size_bytes + padding_bytes)+          where+            size_bytes = ByteOff $ primRepSizeB platform rep++            -- Here we handle the non-word-width cases specifically since we+            -- must emit different bytecode for them.++            round_to_words (ByteOff bytes) =+              ByteOff (roundUpToWords platform bytes)++            padding_bytes+                | padded    = round_to_words size_bytes - size_bytes+                | otherwise = 0++            (padding_instr, _) = pushPadding padding_bytes++            instr =+              case size_bytes of+                1  -> PUSH_UBX8 lit+                2  -> PUSH_UBX16 lit+                4  -> PUSH_UBX32 lit+                _  -> PUSH_UBX lit (trunc16W $ bytesToWords platform size_bytes)++     case lit of+        LitLabel {}     -> code AddrRep+        LitFloat {}     -> code FloatRep+        LitDouble {}    -> code DoubleRep+        LitChar {}      -> code WordRep+        LitNullAddr     -> code AddrRep+        LitString {}    -> code AddrRep+        LitRubbish {}   -> code WordRep+        LitNumber nt _  -> case nt of+          LitNumInt     -> code IntRep+          LitNumWord    -> code WordRep+          LitNumInt8    -> code Int8Rep+          LitNumWord8   -> code Word8Rep+          LitNumInt16   -> code Int16Rep+          LitNumWord16  -> code Word16Rep+          LitNumInt32   -> code Int32Rep+          LitNumWord32  -> code Word32Rep+          LitNumInt64   -> code Int64Rep+          LitNumWord64  -> code Word64Rep+          -- No LitInteger's or LitNatural's should be left by the time this is+          -- called. CorePrep should have converted them all to a real core+          -- representation.+          LitNumInteger -> panic "pushAtom: LitInteger"+          LitNumNatural -> panic "pushAtom: LitNatural"++-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.+-- This is slightly different to @pushAtom@ due to the fact that we allow+-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.+pushConstrAtom+    :: StackDepth -> BCEnv -> StgArg -> BcM (BCInstrList, ByteOff)+pushConstrAtom _ _ (StgLitArg lit) = pushLiteral False lit++pushConstrAtom d p va@(StgVarArg v)+    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable+        platform <- targetPlatform <$> getDynFlags+        let !szb = idSizeCon platform v+            done instr = do+                let !off = trunc16B $ d - d_v+                return (unitOL (instr off), szb)+        case szb of+            1 -> done PUSH8+            2 -> done PUSH16+            4 -> done PUSH32+            _ -> pushAtom d p va++pushConstrAtom d p expr = pushAtom d p expr++pushPadding :: ByteOff -> (BCInstrList, ByteOff)+pushPadding (ByteOff n) = go n (nilOL, 0)+  where+    go n acc@(!instrs, !off) = case n of+        0 -> acc+        1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)+        2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)+        3 -> go 1 (go 2 acc)+        4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)+        _ -> go (n - 4) (go 4 acc)++-- -----------------------------------------------------------------------------+-- Given a bunch of alts code and their discrs, do the donkey work+-- of making a multiway branch using a switch tree.+-- What a load of hassle!++mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt+                                -- a hint; generates better code+                                -- Nothing is always safe+              -> [(Discr, BCInstrList)]+              -> BcM BCInstrList+mkMultiBranch maybe_ncons raw_ways = do+     lbl_default <- getLabelBc++     let+         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList+         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))+             -- shouldn't happen?++         mkTree [val] range_lo range_hi+            | range_lo == range_hi+            = return (snd val)+            | null defaults -- Note [CASEFAIL]+            = do lbl <- getLabelBc+                 return (testEQ (fst val) lbl+                            `consOL` (snd val+                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))+            | otherwise+            = return (testEQ (fst val) lbl_default `consOL` snd val)++            -- Note [CASEFAIL] It may be that this case has no default+            -- branch, but the alternatives are not exhaustive - this+            -- happens for GADT cases for example, where the types+            -- prove that certain branches are impossible.  We could+            -- just assume that the other cases won't occur, but if+            -- this assumption was wrong (because of a bug in GHC)+            -- then the result would be a segfault.  So instead we+            -- emit an explicit test and a CASEFAIL instruction that+            -- causes the interpreter to barf() if it is ever+            -- executed.++         mkTree vals range_lo range_hi+            = let n = length vals `div` 2+                  vals_lo = take n vals+                  vals_hi = drop n vals+                  v_mid = fst (head vals_hi)+              in do+              label_geq <- getLabelBc+              code_lo <- mkTree vals_lo range_lo (dec v_mid)+              code_hi <- mkTree vals_hi v_mid range_hi+              return (testLT v_mid label_geq+                      `consOL` (code_lo+                      `appOL`   unitOL (LABEL label_geq)+                      `appOL`   code_hi))++         the_default+            = case defaults of+                []         -> nilOL+                [(_, def)] -> LABEL lbl_default `consOL` def+                _          -> panic "mkMultiBranch/the_default"+     instrs <- mkTree notd_ways init_lo init_hi+     return (instrs `appOL` the_default)+  where+         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways+         notd_ways = sortBy (comparing fst) not_defaults++         testLT (DiscrI i) fail_label = TESTLT_I i fail_label+         testLT (DiscrW i) fail_label = TESTLT_W i fail_label+         testLT (DiscrF i) fail_label = TESTLT_F i fail_label+         testLT (DiscrD i) fail_label = TESTLT_D i fail_label+         testLT (DiscrP i) fail_label = TESTLT_P i fail_label+         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"++         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label+         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label+         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label+         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label+         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label+         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"++         -- None of these will be needed if there are no non-default alts+         (init_lo, init_hi)+            | null notd_ways+            = panic "mkMultiBranch: awesome foursome"+            | otherwise+            = case fst (head notd_ways) of+                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )+                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )+                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )+                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )+                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )+                NoDiscr -> panic "mkMultiBranch NoDiscr"++         (algMinBound, algMaxBound)+            = case maybe_ncons of+                 -- XXX What happens when n == 0?+                 Just n  -> (0, fromIntegral n - 1)+                 Nothing -> (minBound, maxBound)++         isNoDiscr NoDiscr = True+         isNoDiscr _       = False++         dec (DiscrI i) = DiscrI (i-1)+         dec (DiscrW w) = DiscrW (w-1)+         dec (DiscrP i) = DiscrP (i-1)+         dec other      = other         -- not really right, but if you+                -- do cases on floating values, you'll get what you deserve++         -- same snotty comment applies to the following+         minF, maxF :: Float+         minD, maxD :: Double+         minF = -1.0e37+         maxF =  1.0e37+         minD = -1.0e308+         maxD =  1.0e308+++-- -----------------------------------------------------------------------------+-- Supporting junk for the compilation schemes++-- Describes case alts+data Discr+   = DiscrI Int+   | DiscrW Word+   | DiscrF Float+   | DiscrD Double+   | DiscrP Word16+   | NoDiscr+    deriving (Eq, Ord)++instance Outputable Discr where+   ppr (DiscrI i) = int i+   ppr (DiscrW w) = text (show w)+   ppr (DiscrF f) = text (show f)+   ppr (DiscrD d) = text (show d)+   ppr (DiscrP i) = ppr i+   ppr NoDiscr    = text "DEF"+++lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff+lookupBCEnv_maybe = Map.lookup++idSizeW :: Platform -> Id -> WordOff+idSizeW platform = WordOff . argRepSizeW platform . bcIdArgRep platform++idSizeCon :: Platform -> Id -> ByteOff+idSizeCon platform var+  -- unboxed tuple components are padded to word size+  | isUnboxedTupleType (idType var) ||+    isUnboxedSumType (idType var) =+    wordsToBytes platform .+    WordOff . sum . map (argRepSizeW platform . toArgRep platform) .+    bcIdPrimReps $ var+  | otherwise = ByteOff (primRepSizeB platform (bcIdPrimRep var))++bcIdArgRep :: Platform -> Id -> ArgRep+bcIdArgRep platform = toArgRep platform . bcIdPrimRep++bcIdPrimRep :: Id -> PrimRep+bcIdPrimRep id+  | [rep] <- typePrimRepArgs (idType id)+  = rep+  | otherwise+  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))+++bcIdPrimReps :: Id -> [PrimRep]+bcIdPrimReps id = typePrimRepArgs (idType id)++repSizeWords :: Platform -> PrimRep -> WordOff+repSizeWords platform rep = WordOff $ argRepSizeW platform (toArgRep platform rep)++isFollowableArg :: ArgRep -> Bool+isFollowableArg P = True+isFollowableArg _ = False++-- | Indicate if the calling convention is supported+isSupportedCConv :: CCallSpec -> Bool+isSupportedCConv (CCallSpec _ cconv _) = case cconv of+   CCallConv            -> True     -- we explicitly pattern match on every+   StdCallConv          -> True     -- convention to ensure that a warning+   PrimCallConv         -> False    -- is triggered when a new one is added+   JavaScriptCallConv   -> False+   CApiConv             -> False++-- See bug #10462+unsupportedCConvException :: a+unsupportedCConvException = throwGhcException (ProgramError+  ("Error: bytecode compiler can't handle some foreign calling conventions\n"+++   "  Workaround: use -fobject-code, or compile this module to .o separately."))++mkSlideB :: Platform -> ByteOff -> ByteOff -> OrdList BCInstr+mkSlideB platform !nb !db = mkSlideW n d+  where+    !n = trunc16W $ bytesToWords platform nb+    !d = bytesToWords platform db++mkSlideW :: Word16 -> WordOff -> OrdList BCInstr+mkSlideW !n !ws+    | ws > fromIntegral limit+    -- If the amount to slide doesn't fit in a Word16, generate multiple slide+    -- instructions+    = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)+    | ws == 0+    = nilOL+    | otherwise+    = unitOL (SLIDE n $ fromIntegral ws)+  where+    limit :: Word16+    limit = maxBound++atomPrimRep :: StgArg -> PrimRep+atomPrimRep (StgVarArg v) = bcIdPrimRep v+atomPrimRep (StgLitArg l) = typePrimRep1 (literalType l)++atomRep :: Platform -> StgArg -> ArgRep+atomRep platform e = toArgRep platform (atomPrimRep e)++-- | Let szsw be the sizes in bytes of some items pushed onto the stack, which+-- has initial depth @original_depth@.  Return the values which the stack+-- environment should map these items to.+mkStackOffsets :: ByteOff -> [ByteOff] -> [ByteOff]+mkStackOffsets original_depth szsb = tail (scanl' (+) original_depth szsb)++typeArgReps :: Platform -> Type -> [ArgRep]+typeArgReps platform = map (toArgRep platform) . typePrimRepArgs++-- -----------------------------------------------------------------------------+-- The bytecode generator's monad++data BcM_State+   = BcM_State+        { bcm_hsc_env :: HscEnv+        , uniqSupply  :: UniqSupply      -- for generating fresh variable names+        , thisModule  :: Module          -- current module (for breakpoints)+        , nextlabel   :: Word32          -- for generating local labels+        , ffis        :: [FFIInfo]       -- ffi info blocks, to free later+                                         -- Should be free()d when it is GCd+        , modBreaks   :: Maybe ModBreaks -- info about breakpoints+        , breakInfo   :: IntMap CgBreakInfo+        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals+          -- See Note [generating code for top-level string literal bindings].+        }++newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) deriving (Functor)++ioToBc :: IO a -> BcM a+ioToBc io = BcM $ \st -> do+  x <- io+  return (st, x)++runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks+      -> IdEnv (RemotePtr ())+      -> BcM r+      -> IO (BcM_State, r)+runBc hsc_env us this_mod modBreaks topStrings (BcM m)+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)++thenBc :: BcM a -> (a -> BcM b) -> BcM b+thenBc (BcM expr) cont = BcM $ \st0 -> do+  (st1, q) <- expr st0+  let BcM k = cont q+  (st2, r) <- k st1+  return (st2, r)++thenBc_ :: BcM a -> BcM b -> BcM b+thenBc_ (BcM expr) (BcM cont) = BcM $ \st0 -> do+  (st1, _) <- expr st0+  (st2, r) <- cont st1+  return (st2, r)++returnBc :: a -> BcM a+returnBc result = BcM $ \st -> (return (st, result))++instance Applicative BcM where+    pure = returnBc+    (<*>) = ap+    (*>) = thenBc_++instance Monad BcM where+  (>>=) = thenBc+  (>>)  = (*>)++instance HasDynFlags BcM where+    getDynFlags = BcM $ \st -> return (st, hsc_dflags (bcm_hsc_env st))++getHscEnv :: BcM HscEnv+getHscEnv = BcM $ \st -> return (st, bcm_hsc_env st)++getProfile :: BcM Profile+getProfile = targetProfile <$> getDynFlags++emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)+emitBc bco+  = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))++recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()+recordFFIBc a+  = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())++getLabelBc :: BcM LocalLabel+getLabelBc+  = BcM $ \st -> do let nl = nextlabel st+                    when (nl == maxBound) $+                        panic "getLabelBc: Ran out of labels"+                    return (st{nextlabel = nl + 1}, LocalLabel nl)++getLabelsBc :: Word32 -> BcM [LocalLabel]+getLabelsBc n+  = BcM $ \st -> let ctr = nextlabel st+                 in return (st{nextlabel = ctr+n}, coerce [ctr .. ctr+n-1])++getCCArray :: BcM (Array BreakIndex (RemotePtr CostCentre))+getCCArray = BcM $ \st ->+  let breaks = expectJust "GHC.StgToByteCode.getCCArray" $ modBreaks st in+  return (st, modBreaks_ccs breaks)+++newBreakInfo :: BreakIndex -> CgBreakInfo -> BcM ()+newBreakInfo ix info = BcM $ \st ->+  return (st{breakInfo = IntMap.insert ix info (breakInfo st)}, ())++newUnique :: BcM Unique+newUnique = BcM $+   \st -> case takeUniqFromSupply (uniqSupply st) of+             (uniq, us) -> let newState = st { uniqSupply = us }+                           in  return (newState, uniq)++getCurrentModule :: BcM Module+getCurrentModule = BcM $ \st -> return (st, thisModule st)++getTopStrings :: BcM (IdEnv (RemotePtr ()))+getTopStrings = BcM $ \st -> return (st, topStrings st)++newId :: Type -> BcM Id+newId ty = do+    uniq <- newUnique+    return $ mkSysLocal tickFS uniq Many ty++tickFS :: FastString+tickFS = fsLit "ticked"

GHC/StgToCmm.hs view

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}  ----------------------------------------------------------------------------- --@@ -16,7 +17,10 @@  import GHC.Prelude as Prelude -import GHC.StgToCmm.Prof (initCostCentres, ldvEnter)+import GHC.Driver.Backend+import GHC.Driver.Session++import GHC.StgToCmm.Prof (initInfoTableProv, initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env import GHC.StgToCmm.Bind@@ -31,65 +35,90 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.CLabel+import GHC.Cmm.Graph  import GHC.Stg.Syntax-import GHC.Driver.Session-import GHC.Utils.Error -import GHC.Driver.Types import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.HpcInfo import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.RepType+import GHC.Types.Basic+import GHC.Types.Var.Set ( isEmptyDVarSet )+import GHC.Types.Unique.FM+import GHC.Types.Name.Env+import GHC.Types.ForeignStubs+ import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Multiplicity+ import GHC.Unit.Module++import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Data.Stream-import GHC.Types.Basic-import GHC.Types.Var.Set ( isEmptyDVarSet )-import GHC.SysTools.FileCleanup-import GHC.Types.Unique.FM-import GHC.Types.Name.Env+import GHC.Utils.Panic+import GHC.Utils.Logger +import GHC.Utils.TmpFs++import GHC.Data.Stream import GHC.Data.OrdList-import GHC.Cmm.Graph+import GHC.Types.Unique.Map -import Data.IORef-import Control.Monad (when,void)+import Control.Monad (when,void, forM_) import GHC.Utils.Misc import System.IO.Unsafe import qualified Data.ByteString as BS+import Data.Maybe+import Data.IORef -codeGen :: DynFlags+data CodeGenState = CodeGenState { codegen_used_info :: !(OrdList CmmInfoTable)+                                 , codegen_state :: !CgState }+++codeGen :: Logger+        -> TmpFs+        -> DynFlags         -> Module+        -> InfoTableProvMap         -> [TyCon]         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.         -> [CgStgTopBinding]           -- Bindings to convert         -> HpcInfo-        -> Stream IO CmmGroup ModuleLFInfos-                                       -- Output as a stream, so codegen can+        -> Stream IO CmmGroup (CStub, ModuleLFInfos)       -- Output as a stream, so codegen can                                        -- be interleaved with output -codeGen dflags this_mod data_tycons+codeGen logger tmpfs dflags this_mod ip_map@(InfoTableProvMap (UniqMap denv) _) data_tycons         cost_centre_info stg_binds hpc_info   = do  {     -- cg: run the code generator, and yield the resulting CmmGroup               -- Using an IORef to store the state is a bit crude, but otherwise-              -- we would need to add a state monad layer.-        ; cgref <- liftIO $ newIORef =<< initC-        ; let cg :: FCode () -> Stream IO CmmGroup ()+              -- we would need to add a state monad layer which regresses+              -- allocations by 0.5-2%.+        ; cgref <- liftIO $ initC >>= \s -> newIORef (CodeGenState mempty s)+        ; let cg :: FCode a -> Stream IO CmmGroup a               cg fcode = do-                cmm <- liftIO . withTimingSilent dflags (text "STG -> Cmm") (`seq` ()) $ do-                         st <- readIORef cgref+                (a, cmm) <- liftIO . withTimingSilent logger dflags (text "STG -> Cmm") (`seq` ()) $ do+                         CodeGenState ts st <- readIORef cgref                          let (a,st') = runC dflags this_mod st (getCmm fcode)                           -- NB. stub-out cgs_tops and cgs_stmts.  This fixes                          -- a big space leak.  DO NOT REMOVE!-                         writeIORef cgref $! st'{ cgs_tops = nilOL,-                                                  cgs_stmts = mkNop }+                         -- This is observed by the #3294 test+                         let !used_info+                                | gopt Opt_InfoTableMap dflags = toOL (mapMaybe topInfoTable (snd a)) `mappend` ts+                                | otherwise = mempty+                         writeIORef cgref $!+                                    CodeGenState used_info+                                      (st'{ cgs_tops = nilOL,+                                            cgs_stmts = mkNop+                                          })+                          return a                 yield cmm+                return a                 -- Note [codegen-split-init] the cmm_init block must come                -- FIRST.  This is because when -split-objs is on we need to@@ -97,8 +126,7 @@                -- Note [pipeline-split-init].         ; cg (mkModuleInit cost_centre_info this_mod hpc_info) -        ; mapM_ (cg . cgTopBinding dflags) stg_binds-+        ; mapM_ (cg . cgTopBinding logger tmpfs dflags) stg_binds                 -- Put datatype_stuff after code_stuff, because the                 -- datatype closure table (for enumeration types) to                 -- (say) PrelBase_True_closure, which is defined in@@ -108,12 +136,21 @@                 -- enumeration type Note that the closure pointers are                 -- tagged.                  when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)-                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)+                 -- Emit normal info_tables, for data constructors defined in this module.+                 mapM_ (cg . cgDataCon DefinitionSite) (tyConDataCons tycon)          ; mapM_ do_tycon data_tycons -        ; cg_id_infos <- cgs_binds <$> liftIO (readIORef cgref)+        -- Emit special info tables for everything used in this module+        -- This will only do something if  `-fdistinct-info-tables` is turned on.+        ; mapM_ (\(dc, ns) -> forM_ ns $ \(k, _ss) -> cg (cgDataCon (UsageSite this_mod k) dc)) (nonDetEltsUFM denv) +        ; final_state <- liftIO (readIORef cgref)+        ; let cg_id_infos = cgs_binds . codegen_state $ final_state+              used_info = fromOL . codegen_used_info $ final_state++        ; !foreign_stub <- cg (initInfoTableProv used_info ip_map this_mod)+           -- See Note [Conveying CAF-info and LFInfo between modules] in           -- GHC.StgToCmm.Types         ; let extractInfo info = (name, lf)@@ -127,7 +164,7 @@                 | otherwise                 = mkNameEnv (Prelude.map extractInfo (eltsUFM cg_id_infos)) -        ; return generatedInfo+        ; return (foreign_stub, generatedInfo)         }  ---------------------------------------------------------------@@ -144,52 +181,51 @@ style, with the increasing static environment being plumbed as a state variable. -} -cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()-cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))-  = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs-        ; fcode-        ; addBindC info-        }+cgTopBinding :: Logger -> TmpFs -> DynFlags -> CgStgTopBinding -> FCode ()+cgTopBinding logger tmpfs dflags = \case+    StgTopLifted (StgNonRec id rhs) -> do+        let (info, fcode) = cgTopRhs dflags NonRecursive id rhs+        fcode+        addBindC info -cgTopBinding dflags (StgTopLifted (StgRec pairs))-  = do  { let (bndrs, rhss) = unzip pairs-        ; let pairs' = zip bndrs rhss-              r = unzipWith (cgTopRhs dflags Recursive) pairs'-              (infos, fcodes) = unzip r-        ; addBindsC infos-        ; sequence_ fcodes-        }+    StgTopLifted (StgRec pairs) -> do+        let (bndrs, rhss) = unzip pairs+        let pairs' = zip bndrs rhss+            r = unzipWith (cgTopRhs dflags Recursive) pairs'+            (infos, fcodes) = unzip r+        addBindsC infos+        sequence_ fcodes -cgTopBinding dflags (StgTopStringLit id str) = do-  let label = mkBytesLabel (idName id)-  -- emit either a CmmString literal or dump the string in a file and emit a-  -- CmmFileEmbed literal.-  -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr-  let isNCG    = hscTarget dflags == HscAsm-      isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags-      asString = binBlobThreshold dflags == 0 || isSmall+    StgTopStringLit id str -> do+        let label = mkBytesLabel (idName id)+        -- emit either a CmmString literal or dump the string in a file and emit a+        -- CmmFileEmbed literal.+        -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr+        let isNCG    = backend dflags == NCG+            isSmall  = fromIntegral (BS.length str) <= binBlobThreshold dflags+            asString = binBlobThreshold dflags == 0 || isSmall -      (lit,decl) = if not isNCG || asString-        then mkByteStringCLit label str-        else mkFileEmbedLit label $ unsafePerformIO $ do-               bFile <- newTempName dflags TFL_CurrentModule ".dat"-               BS.writeFile bFile str-               return bFile-  emitDecl decl-  addBindC (litIdInfo dflags id mkLFStringLit lit)+            (lit,decl) = if not isNCG || asString+              then mkByteStringCLit label str+              else mkFileEmbedLit label $ unsafePerformIO $ do+                     bFile <- newTempName logger tmpfs dflags TFL_CurrentModule ".dat"+                     BS.writeFile bFile str+                     return bFile+        emitDecl decl+        addBindC (litIdInfo (targetPlatform dflags) id mkLFStringLit lit)   cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())         -- The Id is passed along for setting up a binding... -cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)-  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)+cgTopRhs dflags _rec bndr (StgRhsCon _cc con mn _ts args)+  = cgTopRhsCon dflags bndr con mn (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)   = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables-    cgTopRhsClosure dflags rec bndr cc upd_flag args body+    cgTopRhsClosure (targetPlatform dflags) rec bndr cc upd_flag args body   ---------------------------------------------------------------@@ -215,28 +251,29 @@  cgEnumerationTyCon :: TyCon -> FCode () cgEnumerationTyCon tycon-  = do dflags <- getDynFlags+  = do platform <- getPlatform        emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)              [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)-                           (tagForCon dflags con)+                           (tagForCon platform con)              | con <- tyConDataCons tycon]  -cgDataCon :: DataCon -> FCode ()+cgDataCon :: ConInfoTableLocation -> DataCon -> FCode () -- Generate the entry code, info tables, and (for niladic constructor) -- the static closure, for a constructor.-cgDataCon data_con-  = do  { dflags <- getDynFlags+cgDataCon mn data_con+  = do  { MASSERT( not (isUnboxedTupleDataCon data_con || isUnboxedSumDataCon data_con) )+        ; profile <- getProfile         ; platform <- getPlatform         ; let             (tot_wds, --  #ptr_wds + #nonptr_wds              ptr_wds) --  #ptr_wds-              = mkVirtConstrSizes dflags arg_reps+              = mkVirtConstrSizes profile arg_reps              nonptr_wds   = tot_wds - ptr_wds              dyn_info_tbl =-              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds+              mkDataConInfoTable profile data_con mn False ptr_wds nonptr_wds              -- We're generating info tables, so we don't know and care about             -- what the actual arguments are. Using () here as the place holder.@@ -246,7 +283,7 @@                        , rep_ty <- typePrimRep (scaledThing ty)                        , not (isVoidRep rep_ty) ] -        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $+        ; emitClosureAndInfoTable platform dyn_info_tbl NativeDirectCall [] $             -- NB: the closure pointer is assumed *untagged* on             -- entry to a constructor.  If the pointer is tagged,             -- then we should not be entering it.  This assumption@@ -256,7 +293,7 @@             do { tickyEnterDynCon                ; ldvEnter (CmmReg nodeReg)                ; tickyReturnOldCon (length arg_reps)-               ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon dflags data_con)]+               ; void $ emitReturn [cmmOffsetB platform (CmmReg nodeReg) (tagForCon platform data_con)]                }                     -- The case continuation code expects a tagged pointer         }

GHC/StgToCmm/ArgRep.hs view

@@ -65,28 +65,33 @@ argRepString V32 = "V32" argRepString V64 = "V64" -toArgRep :: PrimRep -> ArgRep-toArgRep VoidRep           = V-toArgRep LiftedRep         = P-toArgRep UnliftedRep       = P-toArgRep IntRep            = N-toArgRep WordRep           = N-toArgRep Int8Rep           = N  -- Gets widened to native word width for calls-toArgRep Word8Rep          = N  -- Gets widened to native word width for calls-toArgRep Int16Rep          = N  -- Gets widened to native word width for calls-toArgRep Word16Rep         = N  -- Gets widened to native word width for calls-toArgRep Int32Rep          = N  -- Gets widened to native word width for calls-toArgRep Word32Rep         = N  -- Gets widened to native word width for calls-toArgRep AddrRep           = N-toArgRep Int64Rep          = L-toArgRep Word64Rep         = L-toArgRep FloatRep          = F-toArgRep DoubleRep         = D-toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of-                               16 -> V16-                               32 -> V32-                               64 -> V64-                               _  -> error "toArgRep: bad vector primrep"+toArgRep :: Platform -> PrimRep -> ArgRep+toArgRep platform rep = case rep of+   VoidRep           -> V+   LiftedRep         -> P+   UnliftedRep       -> P+   IntRep            -> N+   WordRep           -> N+   Int8Rep           -> N  -- Gets widened to native word width for calls+   Word8Rep          -> N  -- Gets widened to native word width for calls+   Int16Rep          -> N  -- Gets widened to native word width for calls+   Word16Rep         -> N  -- Gets widened to native word width for calls+   Int32Rep          -> N  -- Gets widened to native word width for calls+   Word32Rep         -> N  -- Gets widened to native word width for calls+   AddrRep           -> N+   Int64Rep          -> case platformWordSize platform of+                           PW4 -> L+                           PW8 -> N+   Word64Rep         -> case platformWordSize platform of+                           PW4 -> L+                           PW8 -> N+   FloatRep          -> F+   DoubleRep         -> D+   (VecRep len elem) -> case len*primElemRepSizeB elem of+                           16 -> V16+                           32 -> V32+                           64 -> V64+                           _  -> error "toArgRep: bad vector primrep"  isNonV :: ArgRep -> Bool isNonV V = False@@ -106,8 +111,8 @@   where    ws       = platformWordSizeInBytes platform -idArgRep :: Id -> ArgRep-idArgRep = toArgRep . idPrimRep+idArgRep :: Platform -> Id -> ArgRep+idArgRep platform = toArgRep platform . idPrimRep  -- This list of argument patterns should be kept in sync with at least -- the following:

GHC/StgToCmm/Bind.hs view

@@ -14,7 +14,9 @@   ) where  import GHC.Prelude hiding ((<*>))+ import GHC.Platform+import GHC.Platform.Profile  import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad@@ -30,7 +32,7 @@ import GHC.StgToCmm.Foreign    (emitPrimCall)  import GHC.Cmm.Graph-import GHC.Core          ( AltCon(..), tickishIsCode )+import GHC.Core          ( AltCon(..) ) import GHC.Cmm.BlockId import GHC.Runtime.Heap.Layout import GHC.Cmm@@ -47,9 +49,12 @@ import GHC.Utils.Misc import GHC.Types.Var.Set import GHC.Types.Basic+import GHC.Types.Tickish ( tickishIsCode ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Driver.Session+import GHC.Driver.Ppr  import Control.Monad @@ -60,7 +65,7 @@ -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: DynFlags+cgTopRhsClosure :: Platform                 -> RecFlag              -- member of a recursive group?                 -> Id                 -> CostCentreStack      -- Optional cost centre annotation@@ -69,12 +74,11 @@                 -> CgStgExpr                 -> (CgIdInfo, FCode ()) -cgTopRhsClosure dflags rec id ccs upd_flag args body =-  let platform      = targetPlatform dflags-      closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)-      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)+cgTopRhsClosure platform rec id ccs upd_flag args body =+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+      cg_id_info    = litIdInfo platform id lf_info (CmmLabel closure_label)       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args-  in (cg_id_info, gen_code dflags lf_info closure_label)+  in (cg_id_info, gen_code lf_info closure_label)   where   -- special case for a indirection (f = g).  We create an IND_STATIC   -- closure pointing directly to the indirectee.  This is exactly@@ -89,17 +93,19 @@   -- hole detection from working in that case.  Test   -- concurrent/should_run/4030 fails, for instance.   ---  gen_code _ _ closure_label+  gen_code _ closure_label     | StgApp f [] <- body, null args, isNonRec rec     = do          cg_info <- getCgIdInfo f          emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)] -  gen_code dflags lf_info _closure_label-   = do { let name = idName id+  gen_code lf_info _closure_label+   = do { profile <- getProfile+        ; dflags <- getDynFlags+        ; let name = idName id         ; mod_name <- getModuleName         ; let descr         = closureDescription dflags mod_name name-              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr+              closure_info  = mkClosureInfo profile True id lf_info 0 0 descr          -- We don't generate the static closure here, because we might         -- want to add references to static closures to it later.  The@@ -108,7 +114,7 @@          ; let fv_details :: [(NonVoid Id, ByteOff)]               header = if isLFThunk lf_info then ThunkHeader else StdHeader-              (_, _, fv_details) = mkVirtHeapOffsets dflags header []+              (_, _, fv_details) = mkVirtHeapOffsets profile header []         -- Don't drop the non-void args until the closure info has been made         ; forkClosureBody (closureCodeBody True id closure_info ccs                                 args body fv_details)@@ -200,22 +206,22 @@                                   -- (see above)                ) -cgRhs id (StgRhsCon cc con args)+cgRhs id (StgRhsCon cc con mn _ts args)   = withNewTickyCounterCon (idName id) con $-    buildDynCon id True cc con (assertNonVoidStgArgs args)+    buildDynCon id mn True cc con (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise  {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -} cgRhs id (StgRhsClosure fvs cc upd_flag args body)-  = do dflags <- getDynFlags-       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body+  = do profile <- getProfile+       mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body  ------------------------------------------------------------------------ --              Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: DynFlags -> Id -> CostCentreStack+mkRhsClosure :: Profile -> Id -> CostCentreStack              -> [NonVoid Id]                    -- Free vars              -> UpdateFlag              -> [Id]                            -- Args@@ -258,7 +264,7 @@ -}  ---------- Note [Selectors] -------------------mkRhsClosure    dflags bndr _cc+mkRhsClosure    profile bndr _cc                 [NonVoid the_fv]                -- Just one free var                 upd_flag                -- Updatable thunk                 []                      -- A thunk@@ -271,14 +277,14 @@   , StgApp selectee [{-no args-}] <- strip sel_expr   , the_fv == scrutinee                -- Scrutinee is the only free variable -  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))+  , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))                                    -- pattern binders are always non-void,                                    -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise   , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee) -  , let offset_into_int = bytesToWordsRoundUp (targetPlatform dflags) the_offset-                          - fixedHdrSizeW dflags-  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough+  , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset+                          - fixedHdrSizeW profile+  , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough   = -- NOT TRUE: ASSERT(is_single_constructor)     -- The simplifier may have statically determined that the single alternative     -- is the only possible case and eliminated the others, even if there are@@ -291,7 +297,7 @@     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]  ---------- Note [Ap thunks] -------------------mkRhsClosure    dflags bndr _cc+mkRhsClosure    profile bndr _cc                 fvs                 upd_flag                 []                      -- No args; a thunk@@ -306,8 +312,8 @@     -- Missed opportunity:   (f x x) is not detected   , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs   , isUpdatable upd_flag-  , n_fvs <= mAX_SPEC_AP_SIZE dflags-  , not (sccProfilingEnabled dflags)+  , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile)+  , not (profileIsProfiling profile)                          -- not when profiling: we don't want to                          -- lose information about this particular                          -- thunk (e.g. its type) (#949)@@ -324,12 +330,11 @@     payload = StgVarArg fun_id : args  ---------- Default case -------------------mkRhsClosure dflags bndr cc fvs upd_flag args body-  = do  { let lf_info = mkClosureLFInfo platform bndr NotTopLevel fvs upd_flag args+mkRhsClosure profile bndr cc fvs upd_flag args body+  = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args         ; (id_info, reg) <- rhsIdInfo bndr lf_info         ; return (id_info, gen_code lf_info reg) }  where- platform = targetPlatform dflags  gen_code lf_info reg   = do  {       -- LAY OUT THE OBJECT         -- If the binder is itself a free variable, then don't store@@ -341,15 +346,19 @@         -- Node points to it...         ; let   reduced_fvs = filter (NonVoid bndr /=) fvs +        ; profile <- getProfile+        ; let platform = profilePlatform profile+         -- MAKE CLOSURE INFO FOR THIS CLOSURE         ; mod_name <- getModuleName+        ; dflags <- getDynFlags         ; let   name  = idName bndr                 descr = closureDescription dflags mod_name name                 fv_details :: [(NonVoid Id, ByteOff)]                 header = if isLFThunk lf_info then ThunkHeader else StdHeader                 (tot_wds, ptr_wds, fv_details)-                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)-                closure_info = mkClosureInfo dflags False       -- Not static+                   = mkVirtHeapOffsets profile header (addIdReps reduced_fvs)+                closure_info = mkClosureInfo profile False       -- Not static                                              bndr lf_info tot_wds ptr_wds                                              descr @@ -371,7 +380,7 @@                                          (map toVarArg fv_details)          -- RETURN-        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+        ; return (mkRhsInit platform reg lf_info hp_plus_n) }  ------------------------- cgRhsStdThunk@@ -391,13 +400,15 @@   {     -- LAY OUT THE OBJECT     mod_name <- getModuleName   ; dflags <- getDynFlags-  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader+  ; profile <- getProfile+  ; let platform = profilePlatform profile+        header = if isLFThunk lf_info then ThunkHeader else StdHeader         (tot_wds, ptr_wds, payload_w_offsets)-            = mkVirtHeapOffsets dflags header+            = mkVirtHeapOffsets profile header                 (addArgReps (nonVoidStgArgs payload))          descr = closureDescription dflags mod_name (idName bndr)-        closure_info = mkClosureInfo dflags False       -- Not static+        closure_info = mkClosureInfo profile False       -- Not static                                      bndr lf_info tot_wds ptr_wds                                      descr @@ -411,7 +422,7 @@                                    use_cc blame_cc payload_w_offsets          -- RETURN-  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+  ; return (mkRhsInit platform reg lf_info hp_plus_n) }   mkClosureLFInfo :: Platform@@ -480,9 +491,9 @@             \(_offset, node, arg_regs) -> do                 -- Emit slow-entry code (for entering a closure through a PAP)                 { mkSlowEntryCode bndr cl_info arg_regs-                ; dflags <- getDynFlags+                ; profile <- getProfile                 ; platform <- getPlatform-                ; let node_points = nodeMustPointToIt dflags lf_info+                ; let node_points = nodeMustPointToIt profile lf_info                       node' = if node_points then Just node else Nothing                 ; loop_header_id <- newBlockId                 -- Extend reader monad with information that@@ -499,7 +510,7 @@                 ; enterCostCentreFun cc                     (CmmMachOp (mo_wordSub platform)                          [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]-                         , mkIntExpr platform (funTag dflags cl_info) ])+                         , mkIntExpr platform (funTag platform cl_info) ])                 ; fv_bindings <- mapM bind_fv fv_details                 -- Load free vars out of closure *after*                 -- heap check, to reduce live vars over check@@ -528,9 +539,8 @@  load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode () load_fvs node lf_info = mapM_ (\ (reg, off) ->-   do dflags <- getDynFlags-      platform <- getPlatform-      let tag = lfDynTag dflags lf_info+   do platform <- getPlatform+      let tag = lfDynTag platform lf_info       emit $ mkTaggedObjectLoad platform reg node off tag)  -----------------------------------------@@ -548,13 +558,13 @@ -- Here, we emit the slow-entry code. mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'   | Just (_, ArgGen _) <- closureFunInfo cl_info-  = do dflags <- getDynFlags+  = do profile <- getProfile        platform <- getPlatform        let node = idToReg platform (NonVoid bndr)-           slow_lbl = closureSlowEntryLabel  cl_info+           slow_lbl = closureSlowEntryLabel  platform cl_info            fast_lbl = closureLocalEntryLabel platform cl_info            -- mkDirectJump does not clobber `Node' containing function closure-           jump = mkJump dflags NativeNodeCall+           jump = mkJump profile NativeNodeCall                                 (mkLblExpr fast_lbl)                                 (map (CmmReg . CmmLocal) (node : arg_regs))                                 (initUpdFrameOff platform)@@ -567,8 +577,8 @@ thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack           -> LocalReg -> CgStgExpr -> FCode () thunkCode cl_info fv_details _cc node body-  = do { dflags <- getDynFlags-       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)+  = do { profile <- getProfile+       ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info)              node'       = if node_points then Just node else Nothing         ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling @@ -606,7 +616,8 @@ emitBlackHoleCode :: CmmExpr -> FCode () emitBlackHoleCode node = do   dflags <- getDynFlags-  let platform = targetPlatform dflags+  profile <- getProfile+  let platform = profilePlatform profile    -- Eager blackholing is normally disabled, but can be turned on with   -- -feager-blackholing.  When it is on, we replace the info pointer@@ -626,7 +637,7 @@   -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,   -- because emitBlackHoleCode is called from GHC.Cmm.Parser. -  let  eager_blackholing =  not (sccProfilingEnabled dflags)+  let  eager_blackholing =  not (profileIsProfiling profile)                          && gopt Opt_EagerBlackHoling dflags              -- Profiling needs slop filling (to support LDV              -- profiling), so currently eager blackholing doesn't@@ -634,7 +645,7 @@    when eager_blackholing $ do     whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node-    emitStore (cmmOffsetW platform node (fixedHdrSizeW dflags)) currentTSOExpr+    emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr     -- See Note [Heap memory barriers] in SMP.h.     emitPrimCall [] MO_WriteBarrier []     emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))@@ -684,20 +695,21 @@ pushUpdateFrame lbl updatee body   = do        updfr  <- getUpdFrameOff-       dflags <- getDynFlags+       profile <- getProfile        let-           hdr         = fixedHdrSize dflags-           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags+           hdr         = fixedHdrSize profile+           frame       = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)        ---       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee+       emitUpdateFrame (CmmStackSlot Old frame) lbl updatee        withUpdFrameOff frame body -emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()-emitUpdateFrame dflags frame lbl updatee = do+emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()+emitUpdateFrame frame lbl updatee = do+  profile <- getProfile   let-           hdr         = fixedHdrSize dflags-           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags-           platform    = targetPlatform dflags+           hdr         = fixedHdrSize profile+           off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform)+           platform    = profilePlatform profile   --   emitStore frame (mkLblExpr lbl)   emitStore (cmmOffset platform frame off_updatee) updatee@@ -713,12 +725,12 @@ -- This function returns the address of the black hole, so it can be -- updated with the new value when available. link_caf node = do-  { dflags <- getDynFlags+  { profile <- getProfile         -- Call the RTS function newCAF, returning the newly-allocated         -- blackhole indirection closure   ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing                                     ForeignLabelInExternalPackage IsFunction-  ; let platform = targetPlatform dflags+  ; let platform = profilePlatform profile   ; bh <- newTemp (bWord platform)   ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl       [ (baseExpr,  AddrHint),@@ -727,11 +739,12 @@    -- see Note [atomic CAF entry] in rts/sm/Storage.c   ; updfr  <- getUpdFrameOff-  ; let target = entryCode platform (closureInfoPtr dflags (CmmReg (CmmLocal node)))+  ; ptr_opts <- getPtrOpts+  ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node)))   ; emit =<< mkCmmIfThen       (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))         -- re-enter the CAF-       (mkJump dflags NativeNodeCall target [] updfr)+       (mkJump profile NativeNodeCall target [] updfr)    ; return (CmmReg (CmmLocal bh)) } @@ -743,14 +756,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) <>

GHC/StgToCmm/CgUtils.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}  ----------------------------------------------------------------------------- --@@ -19,82 +20,84 @@ import GHC.Prelude  import GHC.Platform.Regs+import GHC.Platform import GHC.Cmm import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Driver.Session-import GHC.Utils.Outputable+import GHC.Utils.Panic  -- ----------------------------------------------------------------------------- -- Information about global registers -baseRegOffset :: DynFlags -> GlobalReg -> Int--baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags-baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags-baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags-baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags-baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags-baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags-baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags-baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags-baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags-baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags-baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")-baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags-baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags-baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags-baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags-baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags-baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags-baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")-baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags-baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags-baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags-baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags-baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags-baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags-baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")-baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags-baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags-baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags-baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags-baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags-baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags-baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")-baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags-baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags-baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags-baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags-baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags-baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags-baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")-baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags-baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags-baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags-baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags-baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags-baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags-baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")-baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags-baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags-baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags-baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")-baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags-baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags-baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags-baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags-baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags-baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags-baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags-baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags-baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags-baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"-baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"-baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"-baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"+baseRegOffset :: Platform -> GlobalReg -> Int+baseRegOffset platform reg = case reg of+   VanillaReg 1 _       -> pc_OFFSET_StgRegTable_rR1  constants+   VanillaReg 2 _       -> pc_OFFSET_StgRegTable_rR2  constants+   VanillaReg 3 _       -> pc_OFFSET_StgRegTable_rR3  constants+   VanillaReg 4 _       -> pc_OFFSET_StgRegTable_rR4  constants+   VanillaReg 5 _       -> pc_OFFSET_StgRegTable_rR5  constants+   VanillaReg 6 _       -> pc_OFFSET_StgRegTable_rR6  constants+   VanillaReg 7 _       -> pc_OFFSET_StgRegTable_rR7  constants+   VanillaReg 8 _       -> pc_OFFSET_StgRegTable_rR8  constants+   VanillaReg 9 _       -> pc_OFFSET_StgRegTable_rR9  constants+   VanillaReg 10 _      -> pc_OFFSET_StgRegTable_rR10 constants+   VanillaReg n _       -> panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+   FloatReg  1          -> pc_OFFSET_StgRegTable_rF1 constants+   FloatReg  2          -> pc_OFFSET_StgRegTable_rF2 constants+   FloatReg  3          -> pc_OFFSET_StgRegTable_rF3 constants+   FloatReg  4          -> pc_OFFSET_StgRegTable_rF4 constants+   FloatReg  5          -> pc_OFFSET_StgRegTable_rF5 constants+   FloatReg  6          -> pc_OFFSET_StgRegTable_rF6 constants+   FloatReg  n          -> panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+   DoubleReg 1          -> pc_OFFSET_StgRegTable_rD1 constants+   DoubleReg 2          -> pc_OFFSET_StgRegTable_rD2 constants+   DoubleReg 3          -> pc_OFFSET_StgRegTable_rD3 constants+   DoubleReg 4          -> pc_OFFSET_StgRegTable_rD4 constants+   DoubleReg 5          -> pc_OFFSET_StgRegTable_rD5 constants+   DoubleReg 6          -> pc_OFFSET_StgRegTable_rD6 constants+   DoubleReg n          -> panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+   XmmReg 1             -> pc_OFFSET_StgRegTable_rXMM1 constants+   XmmReg 2             -> pc_OFFSET_StgRegTable_rXMM2 constants+   XmmReg 3             -> pc_OFFSET_StgRegTable_rXMM3 constants+   XmmReg 4             -> pc_OFFSET_StgRegTable_rXMM4 constants+   XmmReg 5             -> pc_OFFSET_StgRegTable_rXMM5 constants+   XmmReg 6             -> pc_OFFSET_StgRegTable_rXMM6 constants+   XmmReg n             -> panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+   YmmReg 1             -> pc_OFFSET_StgRegTable_rYMM1 constants+   YmmReg 2             -> pc_OFFSET_StgRegTable_rYMM2 constants+   YmmReg 3             -> pc_OFFSET_StgRegTable_rYMM3 constants+   YmmReg 4             -> pc_OFFSET_StgRegTable_rYMM4 constants+   YmmReg 5             -> pc_OFFSET_StgRegTable_rYMM5 constants+   YmmReg 6             -> pc_OFFSET_StgRegTable_rYMM6 constants+   YmmReg n             -> panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+   ZmmReg 1             -> pc_OFFSET_StgRegTable_rZMM1 constants+   ZmmReg 2             -> pc_OFFSET_StgRegTable_rZMM2 constants+   ZmmReg 3             -> pc_OFFSET_StgRegTable_rZMM3 constants+   ZmmReg 4             -> pc_OFFSET_StgRegTable_rZMM4 constants+   ZmmReg 5             -> pc_OFFSET_StgRegTable_rZMM5 constants+   ZmmReg 6             -> pc_OFFSET_StgRegTable_rZMM6 constants+   ZmmReg n             -> panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+   Sp                   -> pc_OFFSET_StgRegTable_rSp    constants+   SpLim                -> pc_OFFSET_StgRegTable_rSpLim constants+   LongReg 1            -> pc_OFFSET_StgRegTable_rL1    constants+   LongReg n            -> panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+   Hp                   -> pc_OFFSET_StgRegTable_rHp             constants+   HpLim                -> pc_OFFSET_StgRegTable_rHpLim          constants+   CCCS                 -> pc_OFFSET_StgRegTable_rCCCS           constants+   CurrentTSO           -> pc_OFFSET_StgRegTable_rCurrentTSO     constants+   CurrentNursery       -> pc_OFFSET_StgRegTable_rCurrentNursery constants+   HpAlloc              -> pc_OFFSET_StgRegTable_rHpAlloc        constants+   EagerBlackholeInfo   -> pc_OFFSET_stgEagerBlackholeInfo       constants+   GCEnter1             -> pc_OFFSET_stgGCEnter1                 constants+   GCFun                -> pc_OFFSET_stgGCFun                    constants+   BaseReg              -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:BaseReg"+   PicBaseReg           -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:PicBaseReg"+   MachSp               -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:MachSp"+   UnwindReturnReg      -> panic "GHC.StgToCmm.CgUtils.baseRegOffset:UnwindReturnReg"+ where+   !constants = platformConstants platform   -- -----------------------------------------------------------------------------@@ -107,40 +110,38 @@ -- to real machine registers or stored as offsets from BaseReg.  Given -- a GlobalReg, get_GlobalReg_addr always produces the -- register table address for it.-get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr-get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0-get_GlobalReg_addr dflags mid-    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)+get_GlobalReg_addr :: Platform -> GlobalReg -> CmmExpr+get_GlobalReg_addr platform BaseReg = regTableOffset platform 0+get_GlobalReg_addr platform mid+    = get_Regtable_addr_from_offset platform (baseRegOffset platform mid)  -- Calculate a literal representing an offset into the register table. -- Used when we don't have an actual BaseReg to offset from.-regTableOffset :: DynFlags -> Int -> CmmExpr-regTableOffset dflags n =-  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))+regTableOffset :: Platform -> Int -> CmmExpr+regTableOffset platform n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (pc_OFFSET_Capability_r (platformConstants platform) + n)) -get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr-get_Regtable_addr_from_offset dflags offset =-    if haveRegBase (targetPlatform dflags)+get_Regtable_addr_from_offset :: Platform -> Int -> CmmExpr+get_Regtable_addr_from_offset platform offset =+    if haveRegBase platform     then cmmRegOff baseReg offset-    else regTableOffset dflags offset+    else regTableOffset platform offset  -- | Fixup global registers so that they assign to locations within the -- RegTable if they aren't pinned for the current target.-fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl+fixStgRegisters :: Platform -> RawCmmDecl -> RawCmmDecl fixStgRegisters _ top@(CmmData _ _) = top -fixStgRegisters dflags (CmmProc info lbl live graph) =-  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph+fixStgRegisters platform (CmmProc info lbl live graph) =+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock platform)) graph   in CmmProc info lbl live graph' -fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x-fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block+fixStgRegBlock :: Platform -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock platform block = mapBlock (fixStgRegStmt platform) block -fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x-fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt+fixStgRegStmt :: Platform -> CmmNode e x -> CmmNode e x+fixStgRegStmt platform stmt = fixAssign $ mapExpDeep fixExpr stmt   where-    platform = targetPlatform dflags-     fixAssign stmt =       case stmt of         CmmAssign (CmmGlobal reg) src@@ -148,7 +149,7 @@           -- information           | reg == MachSp -> stmt           | otherwise ->-            let baseAddr = get_GlobalReg_addr dflags reg+            let baseAddr = get_GlobalReg_addr platform reg             in case reg `elem` activeStgRegs platform of                 True  -> CmmAssign (CmmGlobal reg) src                 False -> CmmStore baseAddr src@@ -167,7 +168,7 @@             case reg `elem` activeStgRegs platform of                 True  -> expr                 False ->-                    let baseAddr = get_GlobalReg_addr dflags reg+                    let baseAddr = get_GlobalReg_addr platform reg                     in case reg of                         BaseReg -> baseAddr                         _other  -> CmmLoad baseAddr (globalRegType platform reg)

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:@@ -31,7 +36,8 @@          -- * Used by other modules         CgLoc(..), SelfLoopInfo, CallMethod(..),-        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,+        nodeMustPointToIt, isKnownFun, funTag, tagForArity,+        CallOpts(..), getCallMethod,          -- * ClosureInfo         ClosureInfo,@@ -66,10 +72,12 @@  import GHC.Prelude import GHC.Platform+import GHC.Platform.Profile  import GHC.Stg.Syntax import GHC.Runtime.Heap.Layout import GHC.Cmm+import GHC.Cmm.Utils import GHC.Cmm.Ppr.Expr() -- For Outputable instances import GHC.StgToCmm.Types @@ -87,7 +95,7 @@ import GHC.Types.RepType import GHC.Types.Basic import GHC.Utils.Outputable-import GHC.Driver.Session+import GHC.Utils.Panic import GHC.Utils.Misc  import Data.Coerce (coerce)@@ -111,10 +119,14 @@         -- 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])  -- used by ticky profiling@@ -307,25 +319,30 @@ -- x86-32 and 3 bits on x86-64. -- -- Also see Note [Tagging big families] in GHC.StgToCmm.Expr+--+-- The interpreter also needs to be updated if we change the+-- tagging strategy. See Note [Data constructor dynamic tags] in+-- rts/Interpreter.c -isSmallFamily :: DynFlags -> Int -> Bool-isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags+isSmallFamily :: Platform -> Int -> Bool+isSmallFamily platform fam_size = fam_size <= mAX_PTR_TAG platform -tagForCon :: DynFlags -> DataCon -> DynTag-tagForCon dflags con = min (dataConTag con) (mAX_PTR_TAG dflags)+tagForCon :: Platform -> DataCon -> DynTag+tagForCon platform con = min (dataConTag con) (mAX_PTR_TAG platform) -- NB: 1-indexed -tagForArity :: DynFlags -> RepArity -> DynTag-tagForArity dflags arity- | isSmallFamily dflags arity = arity- | otherwise                  = 0+tagForArity :: Platform -> RepArity -> DynTag+tagForArity platform arity+ | isSmallFamily platform arity = arity+ | otherwise                    = 0 -lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag--- Return the tag in the low order bits of a variable bound+-- | Return the tag in the low order bits of a variable bound -- to this LambdaForm-lfDynTag dflags (LFCon con)               = tagForCon dflags con-lfDynTag dflags (LFReEntrant _ arity _ _) = tagForArity dflags arity-lfDynTag _      _other                    = 0+lfDynTag :: Platform -> LambdaFormInfo -> DynTag+lfDynTag platform lf = case lf of+   LFCon con               -> tagForCon   platform con+   LFReEntrant _ arity _ _ -> tagForArity platform arity+   _other                  -> 0   -----------------------------------------------------------------------------@@ -365,7 +382,7 @@ --                nodeMustPointToIt ----------------------------------------------------------------------------- -nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool+nodeMustPointToIt :: Profile -> LambdaFormInfo -> Bool -- If nodeMustPointToIt is true, then the entry convention for -- this closure has R1 (the "Node" register) pointing to the -- closure itself --- the "self" argument@@ -377,11 +394,11 @@         -- non-inherited (i.e. non-top-level) function.         -- The isNotTopLevel test above ensures this is ok. -nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)+nodeMustPointToIt profile (LFThunk top no_fvs updatable NonStandardThunk _)   =  not no_fvs            -- Self parameter   || isNotTopLevel top     -- Note [GC recovery]   || updatable             -- Need to push update frame-  || sccProfilingEnabled dflags+  || profileIsProfiling profile           -- For the non-updatable (single-entry case):           --           -- True if has fvs (in which case we need access to them, and we@@ -476,7 +493,13 @@         CLabel          --   The code label         RepArity        --   Its arity -getCallMethod :: DynFlags+data CallOpts = CallOpts+   { co_profile       :: !Profile   -- ^ Platform profile+   , co_loopification :: !Bool      -- ^ Loopification enabled (cf @-floopification@)+   , co_ticky         :: !Bool      -- ^ Ticky profiling enabled (cf @-ticky@)+   }++getCallMethod :: CallOpts               -> Name           -- Function being applied               -> Id             -- Function Id used to chech if it can refer to                                 -- CAF's and whether the function is tail-calling@@ -492,9 +515,9 @@               -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?               -> CallMethod -getCallMethod dflags _ id _ n_args v_args _cg_loc+getCallMethod opts _ id _ n_args v_args _cg_loc               (Just (self_loop_id, block_id, args))-  | gopt Opt_Loopification dflags+  | co_loopification opts   , id == self_loop_id   , args `lengthIs` (n_args - v_args)   -- If these patterns match then we know that:@@ -505,14 +528,14 @@   -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details   = JumpToIt block_id args -getCallMethod dflags name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc+getCallMethod opts name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc               _self_loop_info   | n_args == 0 -- No args at all-  && not (sccProfilingEnabled dflags)+  && not (profileIsProfiling (co_profile opts))      -- See Note [Evaluating functions with profiling] in rts/Apply.cmm   = ASSERT( arity /= 0 ) ReturnIt   | n_args < arity = SlowCall        -- Not enough args-  | otherwise      = DirectEntry (enterIdLabel (targetPlatform dflags) name (idCafInfo id)) arity+  | otherwise      = DirectEntry (enterIdLabel (profilePlatform (co_profile opts)) name (idCafInfo id)) arity  getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info   = ASSERT( n_args == 0 ) ReturnIt@@ -522,14 +545,14 @@     -- n_args=0 because it'd be ill-typed to apply a saturated     --          constructor application to anything -getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)+getCallMethod opts name id (LFThunk _ _ updatable std_form_info is_fun)               n_args _v_args _cg_loc _self_loop_info   | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)   = SlowCall    -- We cannot just enter it [in eval/apply, the entry code                 -- is the fast-entry code]    -- Since is_fun is False, we are *definitely* looking at a data value-  | updatable || gopt Opt_Ticky dflags -- to catch double entry+  | updatable || co_ticky opts -- to catch double entry       {- OLD: || opt_SMP          I decided to remove this, because in SMP mode it doesn't matter          if we enter the same thunk multiple times, so the optimisation@@ -551,7 +574,7 @@    | otherwise        -- Jump direct to code for single-entry thunks   = ASSERT( n_args == 0 )-    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info+    DirectEntry (thunkEntryLabel (profilePlatform (co_profile opts)) name (idCafInfo id) std_form_info                 updatable) 0  getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info@@ -619,14 +642,14 @@ --        Building ClosureInfos -------------------------------------- -mkClosureInfo :: DynFlags+mkClosureInfo :: Profile               -> Bool                -- Is static               -> Id               -> LambdaFormInfo               -> Int -> Int        -- Total and pointer words               -> String         -- String descriptor               -> ClosureInfo-mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr+mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr   = ClosureInfo { closureName      = name                 , closureLFInfo    = lf_info                 , closureInfoLabel = info_lbl   -- These three fields are@@ -634,11 +657,11 @@                 , closureProf      = prof }     -- (we don't have an SRT yet)   where     name       = idName id-    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)-    prof       = mkProfilingInfo dflags id val_descr+    sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)+    prof       = mkProfilingInfo profile id val_descr     nonptr_wds = tot_wds - ptr_wds -    info_lbl = mkClosureInfoTableLabel dflags id lf_info+    info_lbl = mkClosureInfoTableLabel (profilePlatform profile) id lf_info  -------------------------------------- --   Other functions over ClosureInfo@@ -761,9 +784,9 @@ lfFunInfo (LFReEntrant _ arity _ arg_desc)  = Just (arity, arg_desc) lfFunInfo _                                 = Nothing -funTag :: DynFlags -> ClosureInfo -> DynTag-funTag dflags (ClosureInfo { closureLFInfo = lf_info })-    = lfDynTag dflags lf_info+funTag :: Platform -> ClosureInfo -> DynTag+funTag platform (ClosureInfo { closureLFInfo = lf_info })+    = lfDynTag platform lf_info  isToplevClosure :: ClosureInfo -> Bool isToplevClosure (ClosureInfo { closureLFInfo = lf_info })@@ -776,25 +799,25 @@ --   Label generation -------------------------------------- -staticClosureLabel :: ClosureInfo -> CLabel-staticClosureLabel = toClosureLbl .  closureInfoLabel+staticClosureLabel :: Platform -> ClosureInfo -> CLabel+staticClosureLabel platform = toClosureLbl platform .  closureInfoLabel -closureSlowEntryLabel :: ClosureInfo -> CLabel-closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel+closureSlowEntryLabel :: Platform -> ClosureInfo -> CLabel+closureSlowEntryLabel platform = toSlowEntryLbl platform . closureInfoLabel  closureLocalEntryLabel :: Platform -> ClosureInfo -> CLabel closureLocalEntryLabel platform-  | platformTablesNextToCode platform = toInfoLbl  . closureInfoLabel-  | otherwise                         = toEntryLbl . closureInfoLabel+  | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel+  | otherwise                         = toEntryLbl platform . closureInfoLabel -mkClosureInfoTableLabel :: DynFlags -> Id -> LambdaFormInfo -> CLabel-mkClosureInfoTableLabel dflags id lf_info+mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel platform id lf_info   = case lf_info of         LFThunk _ _ upd_flag (SelectorThunk offset) _-                      -> mkSelectorInfoLabel dflags upd_flag offset+                      -> mkSelectorInfoLabel platform upd_flag offset          LFThunk _ _ upd_flag (ApThunk arity) _-                      -> mkApInfoTableLabel dflags upd_flag arity+                      -> mkApInfoTableLabel platform upd_flag arity          LFThunk{}     -> std_mk_lbl name cafs         LFReEntrant{} -> std_mk_lbl name cafs@@ -814,29 +837,23 @@        -- invariants in "GHC.CoreToStg.Prep" anything else gets eta expanded.  -thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel--- thunkEntryLabel is a local help function, not exported.  It's used from+-- | thunkEntryLabel is a local help function, not exported.  It's used from -- getCallMethod.-thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag-  = enterApLabel dflags upd_flag arity-thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag-  = enterSelectorLabel dflags upd_flag offset-thunkEntryLabel dflags thunk_id c _ _-  = enterIdLabel (targetPlatform dflags) thunk_id c+thunkEntryLabel :: Platform -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel+thunkEntryLabel platform thunk_id caf_info sfi upd_flag = case sfi of+   ApThunk arity        -> enterApLabel       platform upd_flag arity+   SelectorThunk offset -> enterSelectorLabel platform upd_flag offset+   _                    -> enterIdLabel       platform thunk_id caf_info -enterApLabel :: DynFlags -> Bool -> Arity -> CLabel-enterApLabel dflags is_updatable arity-  | platformTablesNextToCode platform = mkApInfoTableLabel dflags is_updatable arity-  | otherwise                         = mkApEntryLabel     dflags is_updatable arity-  where-   platform = targetPlatform dflags+enterApLabel :: Platform -> Bool -> Arity -> CLabel+enterApLabel platform is_updatable arity+  | platformTablesNextToCode platform = mkApInfoTableLabel platform is_updatable arity+  | otherwise                         = mkApEntryLabel     platform is_updatable arity -enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel-enterSelectorLabel dflags upd_flag offset-  | platformTablesNextToCode platform = mkSelectorInfoLabel  dflags upd_flag offset-  | otherwise                         = mkSelectorEntryLabel dflags upd_flag offset-  where-   platform = targetPlatform dflags+enterSelectorLabel :: Platform -> Bool -> WordOff -> CLabel+enterSelectorLabel platform upd_flag offset+  | platformTablesNextToCode platform = mkSelectorInfoLabel  platform upd_flag offset+  | otherwise                         = mkSelectorEntryLabel platform upd_flag offset  enterIdLabel :: Platform -> Name -> CafInfo -> CLabel enterIdLabel platform id c@@ -857,10 +874,10 @@ -- The type is determined from the type information stored with the @Id@ -- in the closure info using @closureTypeDescr@. -mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo-mkProfilingInfo dflags id val_descr-  | not (sccProfilingEnabled dflags) = NoProfilingInfo-  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)+mkProfilingInfo :: Profile -> Id -> String -> ProfilingInfo+mkProfilingInfo profile id val_descr+  | not (profileIsProfiling profile) = NoProfilingInfo+  | otherwise                        = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)   where     ty_descr_w8  = BS8.pack (getTyDescription (idType id)) @@ -886,13 +903,14 @@   case l of     NumTyLit n -> show n     StrTyLit n -> show n+    CharTyLit n -> show n  -------------------------------------- --   CmmInfoTable-related things -------------------------------------- -mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable-mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds+mkDataConInfoTable :: Profile -> DataCon -> ConInfoTableLocation -> Bool -> Int -> Int -> CmmInfoTable+mkDataConInfoTable profile data_con mn is_static ptr_wds nonptr_wds  = CmmInfoTable { cit_lbl  = info_lbl                 , cit_rep  = sm_rep                 , cit_prof = prof@@ -900,13 +918,13 @@                 , cit_clo  = Nothing }  where    name = dataConName data_con-   info_lbl = mkConInfoTableLabel name NoCafRefs-   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type+   info_lbl = mkConInfoTableLabel name mn -- NoCAFRefs+   sm_rep = mkHeapRep profile is_static ptr_wds nonptr_wds cl_type    cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)                   -- We keep the *zero-indexed* tag in the srt_len field                   -- of the info table of a data constructor. -   prof | not (sccProfilingEnabled dflags) = NoProfilingInfo+   prof | not (profileIsProfiling profile) = NoProfilingInfo         | otherwise                        = ProfilingInfo ty_descr val_descr     ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con

GHC/StgToCmm/DataCon.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-}  -----------------------------------------------------------------------------@@ -19,6 +20,9 @@  import GHC.Prelude +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Stg.Syntax import GHC.Core  ( AltCon(..) ) @@ -45,8 +49,7 @@ import GHC.Types.RepType (countConRepArgs) import GHC.Types.Literal import GHC.Builtin.Utils-import GHC.Utils.Outputable-import GHC.Platform+import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Monad (mapMaybeM) @@ -60,9 +63,10 @@ cgTopRhsCon :: DynFlags             -> Id               -- Name of thing bound to this RHS             -> DataCon          -- Id+            -> ConstructorNumber             -> [NonVoid StgArg] -- Args             -> (CgIdInfo, FCode ())-cgTopRhsCon dflags id con args+cgTopRhsCon dflags id con mn args   | Just static_info <- precomputedStaticConInfo_maybe dflags id con args   , let static_code | isInternalName name = pure ()                     | otherwise           = gen_code@@ -79,14 +83,16 @@   = (id_Info, gen_code)    where-   id_Info       = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)+   platform      = targetPlatform dflags+   id_Info       = litIdInfo platform id (mkConLFInfo con) (CmmLabel closure_label)    name          = idName id    caffy         = idCafInfo id -- any stgArgHasCafRefs args    closure_label = mkClosureLabel name caffy     gen_code =-     do { this_mod <- getModuleName-        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $+     do { profile <- getProfile+        ; this_mod <- getModuleName+        ; when (platformOS platform == OSMinGW32) $               -- Windows DLLs have a problem with static cross-DLL refs.               MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )         ; ASSERT( args `lengthIs` countConRepArgs con ) return ()@@ -96,8 +102,23 @@             (tot_wds, --  #ptr_wds + #nonptr_wds              ptr_wds, --  #ptr_wds              nv_args_w_offsets) =-                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)+                 mkVirtHeapOffsetsWithPadding profile StdHeader (addArgReps args) +        ; let+            -- Decompose padding into units of length 8, 4, 2, or 1 bytes to+            -- allow the implementation of mk_payload to use widthFromBytes,+            -- which only handles these cases.+            fix_padding (x@(Padding n off) : rest)+              | n == 0                 = fix_padding rest+              | n `elem` [1,2,4,8]     = x : fix_padding rest+              | n > 8                  = add_pad 8+              | n > 4                  = add_pad 4+              | n > 2                  = add_pad 2+              | otherwise              = add_pad 1+              where add_pad m = Padding m off : fix_padding (Padding (n-m) (off+m) : rest)+            fix_padding (x : rest)     = x : fix_padding rest+            fix_padding []             = []+             mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))             mk_payload (FieldOff arg _) = do                 amode <- getArgAmode arg@@ -110,17 +131,26 @@              -- we're not really going to emit an info table, so having              -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields              -- needs to poke around inside it.-            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds+            info_tbl = mkDataConInfoTable profile con (addModuleLoc this_mod mn) True ptr_wds nonptr_wds  -        ; payload <- mapM mk_payload nv_args_w_offsets+        ; payload <- mapM mk_payload (fix_padding nv_args_w_offsets)                 -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs                 -- NB2: all the amodes should be Lits!                 --      TODO (osa): Why?                  -- BUILD THE OBJECT+                --+            -- We're generating info tables, so we don't know and care about+            -- what the actual arguments are. Using () here as the place holder.+         ; emitDataCon closure_label info_tbl dontCareCCS payload } +addModuleLoc :: Module -> ConstructorNumber -> ConInfoTableLocation+addModuleLoc this_mod mn = do+  case mn of+    NoNumber -> DefinitionSite+    Numbered n -> UsageSite this_mod n  --------------------------------------------------------------- --      Lay out and allocate non-top-level constructors@@ -128,6 +158,7 @@  buildDynCon :: Id                 -- Name of the thing to which this constr will                                   -- be bound+            -> ConstructorNumber             -> Bool               -- is it genuinely bound to that name, or just                                   -- for profiling?             -> CostCentreStack    -- Where to grab cost centre from;@@ -136,13 +167,14 @@             -> [NonVoid StgArg]   -- Its args             -> FCode (CgIdInfo, FCode CmmAGraph)                -- Return details about how to find it and initialization code-buildDynCon binder actually_bound cc con args+buildDynCon binder mn actually_bound cc con args     = do dflags <- getDynFlags-         buildDynCon' dflags binder actually_bound cc con args+         buildDynCon' dflags binder mn actually_bound cc con args   buildDynCon' :: DynFlags-             -> Id -> Bool+             -> Id -> ConstructorNumber+             -> Bool              -> CostCentreStack              -> DataCon              -> [NonVoid StgArg]@@ -159,13 +191,13 @@ premature looking at the args will cause the compiler to black-hole! -} -buildDynCon' dflags binder _ _cc con args+buildDynCon' dflags binder _ _ _cc con args   | Just cgInfo <- precomputedStaticConInfo_maybe dflags binder con args   -- , pprTrace "noCodeLocal:" (ppr (binder,con,args,cgInfo)) True   = return (cgInfo, return mkNop)  -------- buildDynCon': the general case ------------buildDynCon' dflags binder actually_bound ccs con args+buildDynCon' _ binder mn actually_bound ccs con args   = do  { (id_info, reg) <- rhsIdInfo binder lf_info         ; return (id_info, gen_code reg)         }@@ -173,17 +205,20 @@   lf_info = mkConLFInfo con    gen_code reg-    = do  { let (tot_wds, ptr_wds, args_w_offsets)-                  = mkVirtConstrOffsets dflags (addArgReps args)+    = do  { modu <- getModuleName+          ; profile <- getProfile+          ; let platform = profilePlatform profile+                (tot_wds, ptr_wds, args_w_offsets)+                   = mkVirtConstrOffsets profile (addArgReps args)                 nonptr_wds = tot_wds - ptr_wds-                info_tbl = mkDataConInfoTable dflags con False+                info_tbl = mkDataConInfoTable profile con (addModuleLoc modu mn) False                                 ptr_wds nonptr_wds           ; let ticky_name | actually_bound = Just binder                            | otherwise = Nothing            ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info                                           use_cc blame_cc args_w_offsets-          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+          ; return (mkRhsInit platform reg lf_info hp_plus_n) }     where       use_cc      -- cost-centre to stick in the object         | isCurrentCCS ccs = cccsExpr@@ -293,7 +328,7 @@ precomputedStaticConInfo_maybe dflags binder con [] -- Nullary constructors   | isNullaryRepDataCon con-  = Just $ litIdInfo dflags binder (mkConLFInfo con)+  = Just $ litIdInfo (targetPlatform dflags) binder (mkConLFInfo con)                 (CmmLabel (mkClosureLabel (dataConName con) NoCafRefs)) precomputedStaticConInfo_maybe dflags binder con [arg]   -- Int/Char values with existing closures in the RTS@@ -303,12 +338,13 @@   , inRange val   = let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit label)         val_int = fromIntegral val :: Int-        offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW dflags + 1)+        offsetW = (val_int - (fromIntegral min_static_range)) * (fixedHdrSizeW profile + 1)                 -- INTLIKE/CHARLIKE closures consist of a header and one word payload         static_amode = cmmLabelOffW platform intlike_lbl offsetW-    in Just $ litIdInfo dflags binder (mkConLFInfo con) static_amode+    in Just $ litIdInfo platform binder (mkConLFInfo con) static_amode   where-    platform = targetPlatform dflags+    profile = targetProfile dflags+    platform = profilePlatform profile     intClosure = maybeIntLikeCon con     charClosure = maybeCharLikeCon con     getClosurePayload (NonVoid (StgLitArg (LitNumber LitNumInt val))) = Just val@@ -319,14 +355,16 @@     inRange val       = val >= min_static_range && val <= max_static_range +    constants = platformConstants platform+     min_static_range :: Integer     min_static_range-      | intClosure = fromIntegral (mIN_INTLIKE dflags)-      | charClosure = fromIntegral (mIN_CHARLIKE dflags)+      | intClosure = fromIntegral (pc_MIN_INTLIKE constants)+      | charClosure = fromIntegral (pc_MIN_CHARLIKE constants)       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"     max_static_range-      | intClosure = fromIntegral (mAX_INTLIKE dflags)-      | charClosure = fromIntegral (mAX_CHARLIKE dflags)+      | intClosure = fromIntegral (pc_MAX_INTLIKE constants)+      | charClosure = fromIntegral (pc_MAX_CHARLIKE constants)       | otherwise = panic "precomputedStaticConInfo_maybe: Unknown closure type"     label       | intClosure = "stg_INTLIKE"@@ -345,11 +383,11 @@ -- binders args, assuming that we have just returned from a 'case' which -- found a con bindConArgs (DataAlt con) base args-  = ASSERT(not (isUnboxedTupleCon con))-    do dflags <- getDynFlags+  = ASSERT(not (isUnboxedTupleDataCon con))+    do profile <- getProfile        platform <- getPlatform-       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)-           tag = tagForCon dflags con+       let (_, _, args_w_offsets) = mkVirtConstrOffsets profile (addIdReps args)+           tag = tagForCon platform con             -- The binding below forces the masking out of the tag bits            -- when accessing the constructor field.

GHC/StgToCmm/Env.hs view

@@ -37,18 +37,22 @@ import GHC.Cmm.BlockId import GHC.Cmm.Expr import GHC.Cmm.Utils-import GHC.Driver.Session import GHC.Types.Id import GHC.Cmm.Graph import GHC.Types.Name-import GHC.Utils.Outputable import GHC.Stg.Syntax import GHC.Core.Type import GHC.Builtin.Types.Prim import GHC.Types.Unique.FM-import GHC.Utils.Misc import GHC.Types.Var.Env +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Driver.Session++ ------------------------------------- --        Manipulating CgIdInfo -------------------------------------@@ -58,13 +62,12 @@   = CgIdInfo { cg_id = id, cg_lf = lf              , cg_loc = CmmLoc expr } -litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo-litIdInfo dflags id lf lit+litIdInfo :: Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo+litIdInfo platform id lf lit   = CgIdInfo { cg_id = id, cg_lf = lf              , cg_loc = CmmLoc (addDynTag platform (CmmLit lit) tag) }   where-    tag = lfDynTag dflags lf-    platform = targetPlatform dflags+    tag = lfDynTag platform lf  lneIdInfo :: Platform -> Id -> [NonVoid Id] -> CgIdInfo lneIdInfo platform id regs@@ -81,10 +84,9 @@        reg <- newTemp (gcWord platform)        return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg) -mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph-mkRhsInit dflags reg lf_info expr-  = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag dflags lf_info))-  where platform = targetPlatform dflags+mkRhsInit :: Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph+mkRhsInit platform reg lf_info expr+  = mkAssign (CmmLocal reg) (addDynTag platform expr (lfDynTag platform lf_info))  idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer@@ -124,7 +126,7 @@  getCgIdInfo :: Id -> FCode CgIdInfo getCgIdInfo id-  = do  { dflags <- getDynFlags+  = do  { platform <- targetPlatform <$> getDynFlags         ; local_binds <- getBinds -- Try local bindings first         ; case lookupVarEnv local_binds id of {             Just info -> return info ;@@ -134,14 +136,17 @@           let name = idName id         ; if isExternalName name then               let ext_lbl-                      | isUnliftedType (idType id) =+                      | isBoxedType (idType id)+                      = mkClosureLabel name $ idCafInfo id+                      | isUnliftedType (idType id)                           -- An unlifted external Id must refer to a top-level                           -- string literal. See Note [Bytes label] in "GHC.Cmm.CLabel".-                          ASSERT( idType id `eqType` addrPrimTy )-                          mkBytesLabel name-                      | otherwise = mkClosureLabel name $ idCafInfo id+                      = ASSERT( idType id `eqType` addrPrimTy )+                        mkBytesLabel name+                      | otherwise+                      = pprPanic "GHC.StgToCmm.Env: label not found" (ppr id <+> dcolon <+> ppr (idType id))               in return $-                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)+                  litIdInfo platform id (mkLFImported id) (CmmLabel ext_lbl)           else               cgLookupPanic id -- Bug         }}}

GHC/StgToCmm/Expr.hs view

@@ -36,9 +36,9 @@ import GHC.Cmm.BlockId import GHC.Cmm hiding ( succ ) import GHC.Cmm.Info+import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG ) import GHC.Core import GHC.Core.DataCon-import GHC.Driver.Session ( mAX_PTR_TAG ) import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Builtin.PrimOps@@ -46,10 +46,12 @@ import GHC.Core.Type        ( isUnliftedType ) import GHC.Types.RepType    ( isVoidTy, countConRepArgs ) import GHC.Types.CostCentre ( CostCentreStack, currentCCS )+import GHC.Types.Tickish import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic  import Control.Monad ( unless, void ) import Control.Arrow ( first )@@ -69,18 +71,49 @@   cgIdApp a []  -- dataToTag# :: a -> Int#--- See Note [dataToTag#] in primops.txt.pp+-- See Note [dataToTag# magic] in primops.txt.pp cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do-  dflags <- getDynFlags   platform <- getPlatform   emitComment (mkFastString "dataToTag#")-  tmp <- newTemp (bWord platform)-  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])-  -- TODO: For small types look at the tag bits instead of reading info table-  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]+  info <- getCgIdInfo a+  let amode = idInfoToAmode info+  tag_reg <- assignTemp $ cmmConstrTag1 platform amode+  result_reg <- newTemp (bWord platform)+  let tag = CmmReg $ CmmLocal tag_reg+      is_tagged = cmmNeWord platform tag (zeroExpr platform)+      is_too_big_tag = cmmEqWord platform tag (cmmTagMask platform)+  -- Here we will first check the tag bits of the pointer we were given;+  -- if this doesn't work then enter the closure and use the info table+  -- to determine the constructor. Note that all tag bits set means that+  -- the constructor index is too large to fit in the pointer and therefore+  -- we must look in the info table. See Note [Tagging big families]. +  slow_path <- getCode $ do+      tmp <- newTemp (bWord platform)+      _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])+      ptr_opts <- getPtrOpts+      emitAssign (CmmLocal result_reg)+        $ getConstrTag ptr_opts (cmmUntag platform (CmmReg (CmmLocal tmp)))++  fast_path <- getCode $ do+      -- Return the constructor index from the pointer tag+      return_ptr_tag <- getCode $ do+          emitAssign (CmmLocal result_reg)+            $ cmmSubWord platform tag (CmmLit $ mkWordCLit platform 1)+      -- Return the constructor index recorded in the info table+      return_info_tag <- getCode $ do+          ptr_opts <- getPtrOpts+          emitAssign (CmmLocal result_reg)+            $ getConstrTag ptr_opts (cmmUntag platform amode)++      emit =<< mkCmmIfThenElse' is_too_big_tag return_info_tag return_ptr_tag (Just False)++  emit =<< mkCmmIfThenElse' is_tagged fast_path slow_path (Just True)+  emitReturn [CmmReg $ CmmLocal result_reg]++ cgExpr (StgOpApp op args ty) = cgOpApp op args ty-cgExpr (StgConApp con args _)= cgConApp con args+cgExpr (StgConApp con mn args _) = cgConApp con mn args cgExpr (StgTick t e)         = cgTick t >> cgExpr e cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit                                emitReturn [CmmLit cmm_lit]@@ -97,8 +130,6 @@ cgExpr (StgCase expr bndr alt_type alts) =   cgCase expr bndr alt_type alts -cgExpr (StgLam {}) = panic "cgExpr: StgLam"- ------------------------------------------------------------------------ --              Let no escape ------------------------------------------------------------------------@@ -157,9 +188,9 @@     -> FCode (CgIdInfo, FCode ()) cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)   = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body-cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con mn _ts args)   = cgLetNoEscapeClosure bndr local_cc cc []-      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $+      (StgConApp con mn args (pprPanic "cgLetNoEscapeRhsBody" $                            text "StgRhsCon doesn't have type args"))         -- For a constructor RHS we want to generate a single chunk of         -- code which can be jumped to from many places, which will@@ -177,12 +208,10 @@  cgLetNoEscapeClosure bndr cc_slot _unused_cc args body   = do platform <- getPlatform-       return ( lneIdInfo platform bndr args-              , code )+       return ( lneIdInfo platform bndr args, code )   where-   code = forkLneBody $ do {-            ; withNewTickyCounterLNE (idName bndr) args $ do-            ; restoreCurrentCostCentre cc_slot+   code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do+            { restoreCurrentCostCentre cc_slot             ; arg_regs <- bindArgsToRegs args             ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) } @@ -564,18 +593,17 @@         ; return AssignedDirectly }  cgAlts gc_plan bndr (AlgAlt tycon) alts-  = do  { dflags <- getDynFlags-        ; platform <- getPlatform+  = do  { platform <- getPlatform          ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts          ; let !fam_sz   = tyConFamilySize tycon               !bndr_reg = CmmLocal (idToReg platform bndr)-              !ptag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+              !ptag_expr = cmmConstrTag1 platform (CmmReg bndr_reg)               !branches' = first succ <$> branches-              !maxpt = mAX_PTR_TAG dflags+              !maxpt = mAX_PTR_TAG platform               (!via_ptr, !via_info) = partition ((< maxpt) . fst) branches'-              !small = isSmallFamily dflags fam_sz+              !small = isSmallFamily platform fam_sz                  -- Is the constructor tag in the node reg?                 -- See Note [Tagging big families]@@ -587,8 +615,9 @@            else -- No, the get exact tag from info table when mAX_PTR_TAG                 -- See Note [Double switching for big families]               do-                let !untagged_ptr = cmmUntag dflags (CmmReg bndr_reg)-                    !itag_expr = getConstrTag dflags untagged_ptr+                ptr_opts <- getPtrOpts+                let !untagged_ptr = cmmUntag platform (CmmReg bndr_reg)+                    !itag_expr = getConstrTag ptr_opts untagged_ptr                     !info0 = first pred <$> via_info                 if null via_ptr then                   emitSwitch itag_expr info0 mb_deflt 0 (fam_sz - 1)@@ -834,16 +863,16 @@ --      Tail calls ----------------------------------------------------------------------------- -cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind-cgConApp con stg_args-  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return+cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind+cgConApp con mn stg_args+  | isUnboxedTupleDataCon con       -- Unboxed tuple: assign and return   = do { arg_exprs <- getNonVoidArgAmodes stg_args        ; tickyUnboxedTupleReturn (length arg_exprs)        ; emitReturn arg_exprs }    | otherwise   --  Boxed constructors; allocate and return   = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) mn False                                      currentCCS con (assertNonVoidStgArgs stg_args)                                      -- con args are always non-void,                                      -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise@@ -857,17 +886,17 @@  cgIdApp :: Id -> [StgArg] -> FCode ReturnKind cgIdApp fun_id args = do-    dflags         <- getDynFlags     fun_info       <- getCgIdInfo fun_id     self_loop_info <- getSelfLoop+    call_opts      <- getCallOpts+    profile        <- getProfile     let fun_arg     = StgVarArg fun_id         fun_name    = idName    fun_id         fun         = idInfoToAmode fun_info         lf_info     = cg_lf         fun_info         n_args      = length args         v_args      = length $ filter (isVoidTy . stgArgType) args-        node_points dflags = nodeMustPointToIt dflags lf_info-    case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+    case getCallMethod call_opts fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of             -- A value in WHNF, so we can just return it.         ReturnIt           | isVoidTy (idType fun_id) -> emitReturn []@@ -885,7 +914,7 @@         -- A direct function call (possibly with some left-over arguments)         DirectEntry lbl arity -> do                 { tickyDirectCall arity args-                ; if node_points dflags+                ; if nodeMustPointToIt profile lf_info                      then directCall NativeNodeCall   lbl arity (fun_arg:args)                      else directCall NativeDirectCall lbl arity args } @@ -1006,8 +1035,9 @@  emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do-  { dflags <- getDynFlags+  { ptr_opts <- getPtrOpts   ; platform <- getPlatform+  ; profile <- getProfile   ; adjustHpBackwards   ; sequel <- getSequel   ; updfr_off <- getUpdFrameOff@@ -1021,9 +1051,9 @@       -- Right now, we do what the old codegen did, and omit the tag       -- test, just generating an enter.       Return -> do-        { let entry = entryCode platform $ closureInfoPtr dflags $ CmmReg nodeReg-        ; emit $ mkJump dflags NativeNodeCall entry-                        [cmmUntag dflags fun] updfr_off+        { let entry = entryCode platform $ closureInfoPtr ptr_opts $ CmmReg nodeReg+        ; emit $ mkJump profile NativeNodeCall entry+                        [cmmUntag platform fun] updfr_off         ; return AssignedDirectly         } @@ -1054,21 +1084,21 @@       --       AssignTo res_regs _ -> do        { lret <- newBlockId-       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []+       ; let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) res_regs []        ; lcall <- newBlockId        ; updfr_off <- getUpdFrameOff        ; let area = Young lret-       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area+       ; let (outArgs, regs, copyout) = copyOutOflow profile NativeNodeCall Call area                                           [fun] updfr_off []          -- refer to fun via nodeReg after the copyout, to avoid having          -- both live simultaneously; this sometimes enables fun to be          -- inlined in the RHS of the R1 assignment.-       ; let entry = entryCode platform (closureInfoPtr dflags (CmmReg nodeReg))+       ; let entry = entryCode platform (closureInfoPtr ptr_opts (CmmReg nodeReg))              the_call = toCall entry (Just lret) updfr_off off outArgs regs        ; tscope <- getTickScope        ; emit $            copyout <*>-           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))+           mkCbranch (cmmIsTagged platform (CmmReg nodeReg))                      lret lcall Nothing <*>            outOfLine lcall (the_call,tscope) <*>            mkLabel lret tscope <*>@@ -1084,7 +1114,7 @@ -- | Generate Cmm code for a tick. Depending on the type of Tickish, -- this will either generate actual Cmm instrumentation code, or -- simply pass on the annotation as a @CmmTickish@.-cgTick :: Tickish Id -> FCode ()+cgTick :: StgTickish -> FCode () cgTick tick   = do { platform <- getPlatform        ; case tick of

GHC/StgToCmm/ExtCode.hs view

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE TupleSections #-} -- | Our extended FCode monad.  -- We add a mapping from names to CmmExpr, to support local variable names in@@ -32,19 +33,24 @@         emit, emitLabel, emitAssign, emitStore,         getCode, getCodeR, getCodeScoped,         emitOutOfLine,-        withUpdFrameOff, getUpdFrameOff+        withUpdFrameOff, getUpdFrameOff,+        getProfile, getPlatform, getPtrOpts )  where  import GHC.Prelude +import GHC.Platform+import GHC.Platform.Profile+ import qualified GHC.StgToCmm.Monad as F import GHC.StgToCmm.Monad (FCode, newUnique)  import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Graph+import GHC.Cmm.Info  import GHC.Cmm.BlockId import GHC.Driver.Session@@ -98,9 +104,16 @@     return (decls, u)  instance HasDynFlags CmmParse where-    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags-                                   return (d, dflags))+    getDynFlags = EC (\_ _ d -> (d,) <$> getDynFlags) +getProfile :: CmmParse Profile+getProfile = EC (\_ _ d -> (d,) <$> F.getProfile)++getPlatform :: CmmParse Platform+getPlatform = EC (\_ _ d -> (d,) <$> F.getPlatform)++getPtrOpts :: CmmParse PtrOpts+getPtrOpts = EC (\_ _ d -> (d,) <$> F.getPtrOpts)  -- | Takes the variable declarations and imports from the monad --      and makes an environment, which is looped back into the computation.

GHC/StgToCmm/Foreign.hs view

@@ -15,6 +15,8 @@   emitLoadThreadState,   emitSaveRegs,   emitRestoreRegs,+  emitPushTupleRegs,+  emitPopTupleRegs,   loadThreadState,   emitOpenNursery,   emitCloseNursery,@@ -22,6 +24,9 @@  import GHC.Prelude hiding( succ, (<*>) ) +import GHC.Platform+import GHC.Platform.Profile+ import GHC.Stg.Syntax import GHC.StgToCmm.Prof (storeCurCCS, ccsType) import GHC.StgToCmm.Env@@ -40,12 +45,11 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout import GHC.Types.ForeignCall-import GHC.Driver.Session-import GHC.Platform import GHC.Data.Maybe-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.Unique.Supply import GHC.Types.Basic+import GHC.Unit.Types  import GHC.Core.TyCo.Rep import GHC.Builtin.Types.Prim@@ -81,6 +85,7 @@             arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)                                      (platformWordSizeInBytes platform)         ; cmm_args <- getFCallArgs stg_args typ+        -- ; traceM $ show cmm_args         ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty         ; let ((call_args, arg_hints), cmm_target)                 = case target of@@ -90,7 +95,7 @@                      -> let labelSource                                 = case mPkgId of                                         Nothing         -> ForeignLabelInThisPackage-                                        Just pkgId      -> ForeignLabelInPackage pkgId+                                        Just pkgId      -> ForeignLabelInPackage (toUnitId pkgId)                             size = call_size cmm_args                         in  ( unzip cmm_args                             , CmmLit (CmmLabel@@ -216,8 +221,8 @@         -> FCode ReturnKind emitForeignCall safety results target args   | not (playSafe safety) = do-    dflags <- getDynFlags-    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    platform <- getPlatform+    let (caller_save, caller_load) = callerSaveVolatileRegs platform     emit caller_save     target' <- load_target_into_temp target     args' <- mapM maybe_assign_temp args@@ -226,13 +231,13 @@     return AssignedDirectly    | otherwise = do-    dflags <- getDynFlags+    profile <- getProfile     platform <- getPlatform     updfr_off <- getUpdFrameOff     target' <- load_target_into_temp target     args' <- mapM maybe_assign_temp args     k <- newBlockId-    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []+    let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results []        -- see Note [safe foreign call convention]     tscope <- getTickScope     emit $@@ -283,32 +288,35 @@  emitSaveThreadState :: FCode () emitSaveThreadState = do-  dflags <- getDynFlags-  code <- saveThreadState dflags+  profile <- getProfile+  code <- saveThreadState profile   emit code  -- | Produce code to save the current thread state to @CurrentTSO@-saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-saveThreadState dflags = do-  let platform = targetPlatform dflags+saveThreadState :: MonadUnique m => Profile -> m CmmAGraph+saveThreadState profile = do+  let platform = profilePlatform profile   tso <- newTemp (gcWord platform)-  close_nursery <- closeNursery dflags tso-  pure $ catAGraphs [-    -- tso = CurrentTSO;-    mkAssign (CmmLocal tso) currentTSOExpr,-    -- tso->stackobj->sp = Sp;-    mkStore (cmmOffset platform-                       (CmmLoad (cmmOffset platform-                                           (CmmReg (CmmLocal tso))-                                           (tso_stackobj dflags))-                                (bWord platform))-                       (stack_SP dflags))-            spExpr,-    close_nursery,-    -- and save the current cost centre stack in the TSO when profiling:-    if sccProfilingEnabled dflags then-        mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr-      else mkNop+  close_nursery <- closeNursery profile tso+  pure $ catAGraphs+   [ -- tso = CurrentTSO;+     mkAssign (CmmLocal tso) currentTSOExpr++   , -- tso->stackobj->sp = Sp;+     mkStore (cmmOffset platform+                        (CmmLoad (cmmOffset platform+                                            (CmmReg (CmmLocal tso))+                                            (tso_stackobj profile))+                                 (bWord platform))+                        (stack_SP profile))+             spExpr++    , close_nursery++    , -- and save the current cost centre stack in the TSO when profiling:+      if profileIsProfiling profile+         then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile)) cccsExpr+         else mkNop     ]  @@ -323,26 +331,83 @@ -- are live, we might have to save them all. emitSaveRegs :: FCode () emitSaveRegs = do-   dflags <- getDynFlags-   let regs = realArgRegsCover dflags-       save = catAGraphs (map (callerSaveGlobalReg dflags) regs)+   platform <- getPlatform+   let regs = realArgRegsCover platform+       save = catAGraphs (map (callerSaveGlobalReg platform) regs)    emit save  -- | Restore STG registers (see 'emitSaveRegs') emitRestoreRegs :: FCode () emitRestoreRegs = do-   dflags <- getDynFlags-   let regs = realArgRegsCover dflags-       save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)-   emit save+   platform <- getPlatform+   let regs    = realArgRegsCover platform+       restore = catAGraphs (map (callerRestoreGlobalReg platform) regs)+   emit restore +-- | Push a subset of STG registers onto the stack, specified by the bitmap+--+-- Sometimes, a "live" subset of the STG registers needs to be saved on the+-- stack, for example when storing an unboxed tuple to be used in the GHCi+-- bytecode interpreter.+--+-- The "live registers" bitmap corresponds to the list of registers given by+-- 'tupleRegsCover', with the least significant bit indicating liveness of+-- the first register in the list.+--+-- Each register is saved to a stack slot of one or more machine words, even+-- if the register size itself is smaller.+--+-- The resulting Cmm code looks like this, with a line for each real or+-- virtual register used for returning tuples:+--+--    ...+--    if((mask & 2) != 0) { Sp_adj(-1); Sp(0) = R2; }+--    if((mask & 1) != 0) { Sp_adj(-1); Sp(0) = R1; }+--+-- See Note [GHCi tuple layout] +emitPushTupleRegs :: CmmExpr -> FCode ()+emitPushTupleRegs regs_live = do+  platform <- getPlatform+  let regs = zip (tupleRegsCover platform) [0..]+      save_arg (reg, n) =+        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))+            live     = cmmAndWord platform regs_live mask+            cond     = cmmNeWord platform live (zeroExpr platform)+            reg_ty   = cmmRegType platform (CmmGlobal reg)+            width    = roundUpToWords platform+                                      (widthInBytes $ typeWidth reg_ty)+            adj_sp   = mkAssign spReg+                                (cmmOffset platform spExpr (negate width))+            save_reg = mkStore spExpr (CmmReg $ CmmGlobal reg)+        in mkCmmIfThen cond $ catAGraphs [adj_sp, save_reg]+  emit . catAGraphs =<< mapM save_arg (reverse regs)++-- | Pop a subset of STG registers from the stack (see 'emitPushTupleRegs')+emitPopTupleRegs :: CmmExpr -> FCode ()+emitPopTupleRegs regs_live = do+  platform <- getPlatform+  let regs = zip (tupleRegsCover platform) [0..]+      save_arg (reg, n) =+        let mask     = CmmLit (CmmInt (1 `shiftL` n) (wordWidth platform))+            live     = cmmAndWord platform regs_live mask+            cond     = cmmNeWord platform live (zeroExpr platform)+            reg_ty   = cmmRegType platform (CmmGlobal reg)+            width    = roundUpToWords platform+                                      (widthInBytes $ typeWidth reg_ty)+            adj_sp   = mkAssign spReg+                                (cmmOffset platform spExpr width)+            restore_reg = mkAssign (CmmGlobal reg) (CmmLoad spExpr reg_ty)+        in mkCmmIfThen cond $ catAGraphs [restore_reg, adj_sp]+  emit . catAGraphs =<< mapM save_arg regs++ emitCloseNursery :: FCode () emitCloseNursery = do-  dflags <- getDynFlags-  platform <- getPlatform+  profile <- getProfile+  let platform = profilePlatform profile   tso <- newTemp (bWord platform)-  code <- closeNursery dflags tso+  code <- closeNursery profile tso   emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code  {- |@@ -366,24 +431,24 @@   cn->free = Hp + WDS(1); @ -}-closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-closeNursery df tso = do-  let tsoreg  = CmmLocal tso-      platform = targetPlatform df+closeNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph+closeNursery profile tso = do+  let tsoreg   = CmmLocal tso+      platform = profilePlatform profile   cnreg      <- CmmLocal <$> newTemp (bWord platform)   pure $ catAGraphs [     mkAssign cnreg currentNurseryExpr,      -- CurrentNursery->free = Hp+1;-    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1),+    mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform hpExpr 1),      let alloc =            CmmMachOp (mo_wordSub platform)               [ cmmOffsetW platform hpExpr 1-              , CmmLoad (nursery_bdescr_start df cnreg) (bWord platform)+              , CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)               ] -        alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df)+        alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile)     in      -- tso->alloc_limit += alloc@@ -394,51 +459,51 @@  emitLoadThreadState :: FCode () emitLoadThreadState = do-  dflags <- getDynFlags-  code <- loadThreadState dflags+  profile <- getProfile+  code <- loadThreadState profile   emit code  -- | Produce code to load the current thread state from @CurrentTSO@-loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph-loadThreadState dflags = do-  let platform = targetPlatform dflags+loadThreadState :: MonadUnique m => Profile -> m CmmAGraph+loadThreadState profile = do+  let platform = profilePlatform profile   tso <- newTemp (gcWord platform)   stack <- newTemp (gcWord platform)-  open_nursery <- openNursery dflags tso+  open_nursery <- openNursery profile tso   pure $ catAGraphs [     -- tso = CurrentTSO;     mkAssign (CmmLocal tso) currentTSOExpr,     -- stack = tso->stackobj;-    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)),+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile)) (bWord platform)),     -- Sp = stack->sp;-    mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)),+    mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile)) (bWord platform)),     -- SpLim = stack->stack + RESERVED_STACK_WORDS;-    mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags))-                                (rESERVED_STACK_WORDS dflags)),+    mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile))+                                (pc_RESERVED_STACK_WORDS (platformConstants platform))),     -- HpAlloc = 0;     --   HpAlloc is assumed to be set to non-zero only by a failed     --   a heap check, see HeapStackCheck.cmm:GC_GENERIC     mkAssign hpAllocReg (zeroExpr platform),     open_nursery,     -- and load the current cost centre stack from the TSO when profiling:-    if sccProfilingEnabled dflags+    if profileIsProfiling profile        then storeCurCCS               (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))-                 (tso_CCCS dflags)) (ccsType platform))+                 (tso_CCCS profile)) (ccsType platform))        else mkNop    ]   emitOpenNursery :: FCode () emitOpenNursery = do-  dflags <- getDynFlags-  platform <- getPlatform+  profile <- getProfile+  let platform = profilePlatform profile   tso <- newTemp (bWord platform)-  code <- openNursery dflags tso+  code <- openNursery profile tso   emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code  {- |-@openNursery dflags tso@ produces code to open the nursery. A local register+@openNursery profile tso@ produces code to open the nursery. A local register holding the value of @CurrentTSO@ is expected for efficiency.  Opening the nursery corresponds to the following code:@@ -455,7 +520,7 @@    tso->alloc_limit += bdfree - bdstart;     // Set Hp to the last occupied word of the heap block.  Why not the-   // next unocupied word?  Doing it this way means that we get to use+   // next unoccupied word?  Doing it this way means that we get to use    // an offset of zero more often, which might lead to slightly smaller    // code on some architectures.    Hp = bdfree - WDS(1);@@ -465,10 +530,10 @@    HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1; @ -}-openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph-openNursery dflags tso = do-  let tsoreg =  CmmLocal tso-      platform = targetPlatform dflags+openNursery :: MonadUnique m => Profile -> LocalReg -> m CmmAGraph+openNursery profile tso = do+  let tsoreg   = CmmLocal tso+      platform = profilePlatform profile   cnreg      <- CmmLocal <$> newTemp (bWord platform)   bdfreereg  <- CmmLocal <$> newTemp (bWord platform)   bdstartreg <- CmmLocal <$> newTemp (bWord platform)@@ -479,12 +544,12 @@   -- stg_returnToStackTop in rts/StgStartup.cmm.   pure $ catAGraphs [      mkAssign cnreg currentNurseryExpr,-     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free dflags cnreg)  (bWord platform)),+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free platform cnreg)  (bWord platform)),       -- Hp = CurrentNursery->free - 1;      mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (-1)), -     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)),+     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start platform cnreg) (bWord platform)),       -- HpLim = CurrentNursery->start +      --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;@@ -494,8 +559,8 @@              (cmmOffset platform                (CmmMachOp (mo_wordMul platform) [                  CmmMachOp (MO_SS_Conv W32 (wordWidth platform))-                   [CmmLoad (nursery_bdescr_blocks dflags cnreg) b32],-                 mkIntExpr platform (bLOCK_SIZE dflags)+                   [CmmLoad (nursery_bdescr_blocks platform cnreg) b32],+                 mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))                 ])                (-1)              )@@ -505,7 +570,7 @@      let alloc =            CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg] -         alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags)+         alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit profile)      in       -- tso->alloc_limit += alloc@@ -516,24 +581,24 @@    ]  nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks-  :: DynFlags -> CmmReg -> CmmExpr-nursery_bdescr_free   dflags cn =-  cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags)-nursery_bdescr_start  dflags cn =-  cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags)-nursery_bdescr_blocks dflags cn =-  cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags)+  :: Platform -> CmmReg -> CmmExpr+nursery_bdescr_free   platform cn =+  cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_free (platformConstants platform))+nursery_bdescr_start  platform cn =+  cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_start (platformConstants platform))+nursery_bdescr_blocks platform cn =+  cmmOffset platform (CmmReg cn) (pc_OFFSET_bdescr_blocks (platformConstants platform)) -tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff-tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)-tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)-tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)-stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)-stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)+tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff+tso_stackobj    profile = closureField profile (pc_OFFSET_StgTSO_stackobj    (profileConstants profile))+tso_alloc_limit profile = closureField profile (pc_OFFSET_StgTSO_alloc_limit (profileConstants profile))+tso_CCCS        profile = closureField profile (pc_OFFSET_StgTSO_cccs        (profileConstants profile))+stack_STACK     profile = closureField profile (pc_OFFSET_StgStack_stack     (profileConstants profile))+stack_SP        profile = closureField profile (pc_OFFSET_StgStack_sp        (profileConstants profile))  -closureField :: DynFlags -> ByteOff -> ByteOff-closureField dflags off = off + fixedHdrSize dflags+closureField :: Profile -> ByteOff -> ByteOff+closureField profile off = off + fixedHdrSize profile  -- Note [Unlifted boxed arguments to foreign calls] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -601,8 +666,8 @@       = return Nothing       | otherwise       = do { cmm <- getArgAmode (NonVoid arg)-           ; dflags <- getDynFlags-           ; return (Just (add_shim dflags typ cmm, hint)) }+           ; profile <- getProfile+           ; return (Just (add_shim profile typ cmm, hint)) }       where         arg_ty   = stgArgType arg         arg_reps = typePrimRep arg_ty@@ -618,14 +683,14 @@   | StgByteArrayType  -- See Note [Unlifted boxed arguments to foreign calls]-add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr-add_shim dflags ty expr = case ty of-  StgPlainType -> expr-  StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags)-  StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags)-  StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags)+add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr+add_shim profile ty expr = case ty of+  StgPlainType      -> expr+  StgArrayType      -> cmmOffsetB platform expr (arrPtrsHdrSize profile)+  StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize profile)+  StgByteArrayType  -> cmmOffsetB platform expr (arrWordsHdrSize profile)   where-    platform = targetPlatform dflags+    platform = profilePlatform profile  -- From a function, extract information needed to determine -- the offset of each argument when used as a C FFI argument.

GHC/StgToCmm/Heap.hs view

@@ -47,6 +47,7 @@ import GHC.Unit import GHC.Driver.Session import GHC.Platform+import GHC.Platform.Profile import GHC.Data.FastString( mkFastString, fsLit ) import GHC.Utils.Panic( sorry ) @@ -135,20 +136,19 @@   hpStore base payload    -- Bump the virtual heap pointer-  dflags <- getDynFlags-  setVirtHp (virt_hp + heapClosureSizeW dflags rep)+  profile <- getProfile+  setVirtHp (virt_hp + heapClosureSizeW profile rep)    return base   emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs-  = do dflags <- getDynFlags-       let platform = targetPlatform dflags-       hpStore base (zip (header dflags) [0, platformWordSizeInBytes platform ..])+  = do profile <- getProfile+       hpStore base (zip (header profile) [0, profileWordSizeInBytes profile ..])   where-    header :: DynFlags -> [CmmExpr]-    header dflags = [info_ptr] ++ dynProfHdr dflags ccs+    header :: Profile -> [CmmExpr]+    header profile = [info_ptr] ++ dynProfHdr profile ccs         -- ToDo: Parallel stuff         -- No ticky header @@ -167,17 +167,17 @@ -- and adding a static link field if necessary.  mkStaticClosureFields-        :: DynFlags+        :: Profile         -> CmmInfoTable         -> CostCentreStack         -> CafInfo         -> [CmmLit]             -- Payload         -> [CmmLit]             -- The full closure-mkStaticClosureFields dflags info_tbl ccs caf_refs payload-  = mkStaticClosure dflags info_lbl ccs payload padding+mkStaticClosureFields profile info_tbl ccs caf_refs payload+  = mkStaticClosure profile info_lbl ccs payload padding         static_link_field saved_info_field   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     info_lbl = cit_lbl info_tbl      -- CAFs must have consistent layout, regardless of whether they@@ -219,11 +219,11 @@                                       -- See Note [STATIC_LINK fields]                                       -- in rts/sm/Storage.h -mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]+mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit]   -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]-mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field+mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field   =  [CmmLabel info_lbl]-  ++ staticProfHdr dflags ccs+  ++ staticProfHdr profile ccs   ++ payload   ++ padding   ++ static_link_field@@ -333,17 +333,19 @@                -> FCode ()                -> FCode () -entryHeapCheck cl_info nodeSet arity args code-  = entryHeapCheck' is_fastf node arity args code-  where+entryHeapCheck cl_info nodeSet arity args code = do+  platform <- getPlatform+  let     node = case nodeSet of               Just r  -> CmmReg (CmmLocal r)-              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel platform cl_info)      is_fastf = case closureFunInfo cl_info of                  Just (_, ArgGen _) -> False                  _otherwise         -> True +  entryHeapCheck' is_fastf node arity args code+ -- | lower-level version for "GHC.Cmm.Parser" entryHeapCheck' :: Bool           -- is a known function pattern                 -> CmmExpr        -- expression for the closure pointer@@ -352,7 +354,7 @@                 -> FCode ()                 -> FCode () entryHeapCheck' is_fastf node arity args code-  = do dflags <- getDynFlags+  = do profile <- getProfile        let is_thunk = arity == 0             args' = map (CmmReg . CmmLocal) args@@ -367,13 +369,13 @@            -}            gc_call upd                | is_thunk-                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd+                 = mkJump profile NativeNodeCall stg_gc_enter1 [node] upd                 | is_fastf-                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd+                 = mkJump profile NativeNodeCall stg_gc_fun (node : args') upd                 | otherwise-                 = mkJump dflags Slow stg_gc_fun (node : args') upd+                 = mkJump profile Slow stg_gc_fun (node : args') upd         updfr_sz <- getUpdFrameOff @@ -404,13 +406,13 @@  altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a altOrNoEscapeHeapCheck checkYield regs code = do-    dflags <- getDynFlags+    profile <- getProfile     platform <- getPlatform     case cannedGCEntryPoint platform regs of       Nothing -> genericGC checkYield code       Just gc -> do         lret <- newBlockId-        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []+        let (off, _, copyin) = copyInOflow profile NativeReturn (Young lret) regs []         lcont <- newBlockId         tscope <- getTickScope         emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)@@ -434,9 +436,9 @@                   -> FCode a                   -> FCode a cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code-  = do dflags <- getDynFlags+  = do profile <- getProfile        updfr_sz <- getUpdFrameOff-       heapCheck False checkYield (gc_call dflags gc updfr_sz) code+       heapCheck False checkYield (gc_call profile gc updfr_sz) code   where     reg_exprs = map (CmmReg . CmmLocal) regs       -- Note [stg_gc arguments]@@ -445,11 +447,11 @@       -- to the canned heap-check routines, because we are in a case       -- alternative and hence the [LocalReg] was passed to us in the       -- NativeReturn convention.-    gc_call dflags label sp+    gc_call profile label sp       | cont_on_stack-      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp+      = mkJumpReturnsTo profile label NativeReturn reg_exprs lret off sp       | otherwise-      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []+      = mkCallReturnsTo profile label NativeReturn reg_exprs lret off sp []  genericGC :: Bool -> FCode a -> FCode a genericGC checkYield code@@ -521,8 +523,7 @@   = getHeapUsage $ \ hpHw ->     -- Emit heap checks, but be sure to do it lazily so     -- that the conditionals on hpHw don't cause a black hole-    do  { dflags <- getDynFlags-        ; platform <- getPlatform+    do  { platform <- getPlatform         ; let mb_alloc_bytes                  | hpHw > mBLOCK_SIZE = sorry $ unlines                     [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",@@ -533,7 +534,10 @@                      "structures in code."]                  | hpHw > 0  = Just (mkIntExpr platform (hpHw * (platformWordSizeInBytes platform)))                  | otherwise = Nothing-                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags+                 where+                  constants = platformConstants platform+                  bLOCK_SIZE_W = pc_BLOCK_SIZE (platformConstants platform) `quot` platformWordSizeInBytes platform+                  mBLOCK_SIZE = pc_BLOCKS_PER_MBLOCK constants * bLOCK_SIZE_W               stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)                       | otherwise  = Nothing         ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc@@ -646,7 +650,7 @@      tickyHeapCheck      emitAssign hpReg bump_hp      emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)-    else do+    else       when (checkYield && not (gopt Opt_OmitYields dflags)) $ do          -- Yielding if HpLim == 0          let yielding = CmmMachOp (mo_wordEq platform)

GHC/StgToCmm/Hpc.hs view

@@ -9,18 +9,20 @@ module GHC.StgToCmm.Hpc ( initHpc, mkTickBox ) where  import GHC.Prelude+import GHC.Platform +import GHC.Driver.Session+ import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils -import GHC.Platform import GHC.Cmm.Graph import GHC.Cmm.Expr import GHC.Cmm.CLabel-import GHC.Unit.Module import GHC.Cmm.Utils-import GHC.StgToCmm.Utils-import GHC.Driver.Types-import GHC.Driver.Session++import GHC.Unit.Module+import GHC.Types.HpcInfo  import Control.Monad

GHC/StgToCmm/Layout.hs view

@@ -34,6 +34,9 @@  import GHC.Prelude hiding ((<*>)) +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.StgToCmm.Closure import GHC.StgToCmm.Env import GHC.StgToCmm.ArgRep -- notably: ( slowCallPattern )@@ -52,13 +55,14 @@ import GHC.Types.Id import GHC.Core.TyCon    ( PrimRep(..), primRepSizeB ) import GHC.Types.Basic   ( RepArity )-import GHC.Driver.Session import GHC.Platform+import GHC.Platform.Profile import GHC.Unit  import GHC.Utils.Misc-import Data.List+import Data.List (mapAccumL, partition) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import Control.Monad @@ -78,7 +82,7 @@ -- emitReturn :: [CmmExpr] -> FCode ReturnKind emitReturn results-  = do { dflags    <- getDynFlags+  = do { profile   <- getProfile        ; platform  <- getPlatform        ; sequel    <- getSequel        ; updfr_off <- getUpdFrameOff@@ -86,7 +90,7 @@            Return ->              do { adjustHpBackwards                 ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord platform)-                ; emit (mkReturn dflags (entryCode platform e) results updfr_off)+                ; emit (mkReturn profile (entryCode platform e) results updfr_off)                 }            AssignTo regs adjust ->              do { when adjust adjustHpBackwards@@ -113,19 +117,19 @@    :: (Convention, Convention) -> CmmExpr -> [CmmExpr]    -> [CmmExpr] -> FCode ReturnKind emitCallWithExtraStack (callConv, retConv) fun args extra_stack-  = do  { dflags <- getDynFlags+  = do  { profile <- getProfile         ; adjustHpBackwards         ; sequel <- getSequel         ; updfr_off <- getUpdFrameOff         ; case sequel of             Return -> do-              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack+              emit $ mkJumpExtra profile callConv fun args updfr_off extra_stack               return AssignedDirectly             AssignTo res_regs _ -> do               k <- newBlockId               let area = Young k-                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []-                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off+                  (off, _, copyin) = copyInOflow profile retConv area res_regs []+                  copyout = mkCallReturnsTo profile fun callConv args k off updfr_off                                    extra_stack               tscope <- getTickScope               emit (copyout <*> mkLabel k tscope <*> copyin)@@ -191,7 +195,8 @@ -- (slowCall fun args) applies fun to args, returning the results to Sequel slowCall fun stg_args   = do  dflags <- getDynFlags-        platform <- getPlatform+        profile <- getProfile+        let platform = profilePlatform profile         argsreps <- getArgRepsAmodes stg_args         let (rts_fun, arity) = slowCallPattern (map fst argsreps) @@ -199,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 @@ -207,9 +212,10 @@         let n_args = length stg_args         if n_args > arity && optLevel dflags >= 2            then do+             ptr_opts <- getPtrOpts              funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun              fun_iptr <- (CmmReg . CmmLocal) `fmap`-                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))+                    assignTemp (closureInfoPtr ptr_opts (cmmUntag platform funv))               -- ToDo: we could do slightly better here by reusing the              -- continuation from the slow call, which we have in r.@@ -230,11 +236,11 @@              is_tagged_lbl <- newBlockId              end_lbl <- newBlockId -             let correct_arity = cmmEqWord platform (funInfoArity dflags fun_iptr)+             let correct_arity = cmmEqWord platform (funInfoArity profile fun_iptr)                                                     (mkIntExpr platform n_args)               tscope <- getTickScope-             emit (mkCbranch (cmmIsTagged dflags funv)+             emit (mkCbranch (cmmIsTagged platform funv)                              is_tagged_lbl slow_lbl (Just True)                    <*> mkLabel is_tagged_lbl tscope                    <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)@@ -285,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)@@ -314,12 +321,14 @@ -- using zeroCLit or even undefined would work, but would be ugly). -- getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]-getArgRepsAmodes = mapM getArgRepAmode-  where getArgRepAmode arg+getArgRepsAmodes args = do+   platform <- profilePlatform <$> getProfile+   mapM (getArgRepAmode platform) args+  where getArgRepAmode platform arg            | V <- rep  = return (V, Nothing)            | otherwise = do expr <- getArgAmode (NonVoid arg)                             return (rep, Just expr)-           where rep = toArgRep (argPrimRep arg)+           where rep = toArgRep platform (argPrimRep arg)  nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr] nonVArgs [] = []@@ -411,7 +420,7 @@   | ThunkHeader  mkVirtHeapOffsetsWithPadding-  :: DynFlags+  :: Profile   -> ClosureHeader            -- What kind of header to account for   -> [NonVoid (PrimRep, a)]   -- Things to make offsets for   -> ( WordOff                -- Total number of words allocated@@ -426,18 +435,18 @@ -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets -- than the unboxed things -mkVirtHeapOffsetsWithPadding dflags header things =+mkVirtHeapOffsetsWithPadding profile header things =     ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))     ( tot_wds     , bytesToWordsRoundUp platform bytes_of_ptrs     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad     )   where-    platform = targetPlatform dflags+    platform = profilePlatform profile     hdr_words = case header of       NoHeader -> 0-      StdHeader -> fixedHdrSizeW dflags-      ThunkHeader -> thunkHdrSize dflags+      StdHeader -> fixedHdrSizeW profile+      ThunkHeader -> thunkHdrSize profile     hdr_bytes = wordsToBytes platform hdr_words      (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things@@ -485,36 +494,36 @@   mkVirtHeapOffsets-  :: DynFlags+  :: Profile   -> ClosureHeader            -- What kind of header to account for   -> [NonVoid (PrimRep,a)]    -- Things to make offsets for   -> (WordOff,                -- _Total_ number of words allocated       WordOff,                -- Number of words allocated for *pointers*       [(NonVoid a, ByteOff)])-mkVirtHeapOffsets dflags header things =+mkVirtHeapOffsets profile header things =     ( tot_wds     , ptr_wds     , [ (field, offset) | (FieldOff field offset) <- things_offsets ]     )   where    (tot_wds, ptr_wds, things_offsets) =-       mkVirtHeapOffsetsWithPadding dflags header things+       mkVirtHeapOffsetsWithPadding profile header things  -- | Just like mkVirtHeapOffsets, but for constructors mkVirtConstrOffsets-  :: DynFlags -> [NonVoid (PrimRep, a)]+  :: Profile -> [NonVoid (PrimRep, a)]   -> (WordOff, WordOff, [(NonVoid a, ByteOff)])-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader+mkVirtConstrOffsets profile = mkVirtHeapOffsets profile StdHeader  -- | Just like mkVirtConstrOffsets, but used when we don't have the actual -- arguments. Useful when e.g. generating info tables; we just need to know -- sizes of pointer and non-pointer fields.-mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)-mkVirtConstrSizes dflags field_reps+mkVirtConstrSizes :: Profile -> [NonVoid PrimRep] -> (WordOff, WordOff)+mkVirtConstrSizes profile field_reps   = (tot_wds, ptr_wds)   where     (tot_wds, ptr_wds, _) =-       mkVirtConstrOffsets dflags+       mkVirtConstrOffsets profile          (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)  -------------------------------------------------------------------------@@ -535,7 +544,7 @@ mkArgDescr :: Platform -> [Id] -> ArgDescr mkArgDescr platform args   = let arg_bits = argBits platform arg_reps-        arg_reps = filter isNonV (map idArgRep args)+        arg_reps = filter isNonV (map (idArgRep platform) args)            -- Getting rid of voids eases matching of standard patterns     in case stdPattern arg_reps of          Just spec_id -> ArgSpec spec_id@@ -601,28 +610,28 @@                             -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body                             -> FCode () emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body- = do   { dflags <- getDynFlags+ = do   { profile <- getProfile         ; platform <- getPlatform         -- Bind the binder itself, but only if it's not a top-level         -- binding. We need non-top let-bindings to refer to the         -- top-level binding, which this binding would incorrectly shadow.         ; node <- if top_lvl then return $ idToReg platform (NonVoid bndr)                   else bindToReg (NonVoid bndr) lf_info-        ; let node_points = nodeMustPointToIt dflags lf_info+        ; let node_points = nodeMustPointToIt profile lf_info         ; arg_regs <- bindArgsToRegs args         ; let args' = if node_points then (node : arg_regs) else arg_regs-              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall+              conv  = if nodeMustPointToIt profile lf_info then NativeNodeCall                                                           else NativeDirectCall-              (offset, _, _) = mkCallEntry dflags conv args' []-        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)+              (offset, _, _) = mkCallEntry profile conv args' []+        ; emitClosureAndInfoTable (profilePlatform profile) info_tbl conv args' $ body (offset, node, arg_regs)         }  -- Data constructors need closures, but not with all the argument handling -- needed for functions. The shared part goes here.-emitClosureAndInfoTable ::-  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()-emitClosureAndInfoTable info_tbl conv args body+emitClosureAndInfoTable+   :: Platform -> CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()+emitClosureAndInfoTable platform info_tbl conv args body   = do { (_, blks) <- getCodeScoped body-       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)+       ; let entry_lbl = toEntryLbl platform (cit_lbl info_tbl)        ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks        }

GHC/StgToCmm/Monad.hs view

@@ -1,6 +1,10 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE PatternSynonyms #-} + ----------------------------------------------------------------------------- -- -- Monad for Stg to C-- code generation@@ -22,8 +26,9 @@         emitOutOfLine, emitAssign, emitStore,         emitComment, emitTick, emitUnwind, -        getCmm, aGraphToGraph, getPlatform,+        getCmm, aGraphToGraph, getPlatform, getProfile,         getCodeR, getCode, getCodeScoped, getHeapUsage,+        getCallOpts, getPtrOpts,          mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,         mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',@@ -54,14 +59,14 @@         -- more localised access to monad state         CgIdInfo(..),         getBinds, setBinds,-         -- out of general friendliness, we also export ...-        CgInfoDownwards(..), CgState(..)        -- non-abstract+        CgInfoDownwards(..), CgState(..) -- non-abstract     ) where  import GHC.Prelude hiding( sequence, succ )  import GHC.Platform+import GHC.Platform.Profile import GHC.Cmm import GHC.StgToCmm.Closure import GHC.Driver.Session@@ -69,6 +74,7 @@ import GHC.Cmm.Graph as CmmGraph import GHC.Cmm.BlockId import GHC.Cmm.CLabel+import GHC.Cmm.Info import GHC.Runtime.Heap.Layout import GHC.Unit import GHC.Types.Id@@ -79,11 +85,12 @@ import GHC.Types.Unique.Supply import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Exts (oneShot)  import Control.Monad-import Data.List-+import Data.List (mapAccumL)   --------------------------------------------------------@@ -112,9 +119,27 @@  -------------------------------------------------------- -newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }-    deriving (Functor)+newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) } +-- Not derived because of #18202.+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+instance Functor FCode where+  fmap f (FCode m) =+    FCode $ \info_down state ->+      case m info_down state of+        (x, state') -> (f x, state')++-- This pattern synonym makes the simplifier monad eta-expand,+-- which as a very beneficial effect on compiler performance+-- See #18202.+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+{-# COMPLETE FCode #-}+pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState))+              -> FCode a+pattern FCode m <- FCode' m+  where+    FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state))+ instance Applicative FCode where     pure val = FCode (\_info_down state -> (val, state))     {-# INLINE pure #-}@@ -178,9 +203,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@@ -308,6 +333,9 @@      cgs_hp_usg  :: HeapUsage,       cgs_uniqs :: UniqSupply }+-- If you are wondering why you have to be careful forcing CgState then+-- the reason is the knot-tying in 'getHeapUsage'. This problem is tracked+-- in #19245  data HeapUsage   -- See Note [Virtual and real heap pointers]   = HeapUsage {@@ -373,7 +401,6 @@   = s1 { cgs_stmts = cgs_stmts s1 CmmGraph.<*> cgs_stmts s2,          cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 } - -- The heap high water mark is the larger of virtHp and hwHp.  The latter is -- only records the high water marks of forked-off branches, so to find the -- heap high water mark you have to take the max of virtHp and hwHp.  Remember,@@ -471,9 +498,32 @@ instance HasDynFlags FCode where     getDynFlags = liftM cgd_dflags getInfoDown +getProfile :: FCode Profile+getProfile = targetProfile <$> getDynFlags+ getPlatform :: FCode Platform-getPlatform = targetPlatform <$> getDynFlags+getPlatform = profilePlatform <$> getProfile +getCallOpts :: FCode CallOpts+getCallOpts = do+   dflags <- getDynFlags+   profile <- getProfile+   pure $ CallOpts+    { co_profile       = profile+    , co_loopification = gopt Opt_Loopification dflags+    , co_ticky         = gopt Opt_Ticky dflags+    }++getPtrOpts :: FCode PtrOpts+getPtrOpts = do+   dflags <- getDynFlags+   profile <- getProfile+   pure $ PtrOpts+      { po_profile     = profile+      , po_align_check = gopt Opt_AlignmentSanitisation dflags+      }++ withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -704,7 +754,7 @@ emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode () emitUnwind regs = do   dflags <- getDynFlags-  when (debugLevel dflags > 0) $ do+  when (debugLevel dflags > 0) $      emitCgStmt $ CgStmt $ CmmUnwind regs  emitAssign :: CmmReg  -> CmmExpr -> FCode ()@@ -742,8 +792,8 @@         } emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True         -- do layout-  = do  { dflags <- getDynFlags-        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args+  = do  { profile <- getProfile+        ; let (offset, live, entry) = mkCallEntry profile conv args stk_args               graph' = entry CmmGraph.<*> graph         ; emitProc mb_info lbl live (graph', tscope) offset True         }@@ -778,15 +828,15 @@         ; state <- getState         ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -getCmm :: FCode () -> FCode CmmGroup+getCmm :: FCode a -> FCode (a, CmmGroup) -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) getCmm code   = do  { state1 <- getState-        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; (a, state2) <- withState code (state1 { cgs_tops  = nilOL })         ; setState $ state2 { cgs_tops = cgs_tops state1 }-        ; return (fromOL (cgs_tops state2)) }+        ; return (a, fromOL (cgs_tops state2)) }   mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph@@ -837,12 +887,12 @@ mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]        -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do-  dflags <- getDynFlags-  k      <- newBlockId-  tscp   <- getTickScope+  profile <- getProfile+  k       <- newBlockId+  tscp    <- getTickScope   let area = Young k-      (off, _, copyin) = copyInOflow dflags retConv area results []-      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack+      (off, _, copyin) = copyInOflow profile retConv area results []+      copyout = mkCallReturnsTo profile f callConv actuals k off updfr_off extra_stack   return $ catAGraphs [copyout, mkLabel k tscp, copyin]  mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset

GHC/StgToCmm/Prim.hs view

@@ -1,3036 +1,3226 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}--#if __GLASGOW_HASKELL__ <= 808--- GHC 8.10 deprecates this flag, but GHC 8.8 needs it--- emitPrimOp is quite large-{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}-#endif--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------ Stg to C--: primitive operations------ (c) The University of Glasgow 2004-2006-----------------------------------------------------------------------------------module GHC.StgToCmm.Prim (-   cgOpApp,-   shouldInlinePrimOp- ) where--#include "HsVersions.h"--import GHC.Prelude hiding ((<*>))--import GHC.StgToCmm.Layout-import GHC.StgToCmm.Foreign-import GHC.StgToCmm.Env-import GHC.StgToCmm.Monad-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Ticky-import GHC.StgToCmm.Heap-import GHC.StgToCmm.Prof ( costCentreFrom )--import GHC.Driver.Session-import GHC.Platform-import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Cmm.Graph-import GHC.Stg.Syntax-import GHC.Cmm-import GHC.Unit         ( rtsUnit )-import GHC.Core.Type    ( Type, tyConAppTyCon )-import GHC.Core.TyCon-import GHC.Cmm.CLabel-import GHC.Cmm.Utils-import GHC.Builtin.PrimOps-import GHC.Runtime.Heap.Layout-import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Utils.Misc-import Data.Maybe--import Data.Bits ((.&.), bit)-import Control.Monad (liftM, when, unless)-----------------------------------------------------------------------------      Primitive operations and foreign calls---------------------------------------------------------------------------{- Note [Foreign call results]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~-A foreign call always returns an unboxed tuple of results, one-of which is the state token.  This seems to happen even for pure-calls.--Even if we returned a single result for pure calls, it'd still be-right to wrap it in a singleton unboxed tuple, because the result-might be a Haskell closure pointer, we don't want to evaluate it. -}-------------------------------------cgOpApp :: StgOp        -- The op-        -> [StgArg]     -- Arguments-        -> Type         -- Result type (always an unboxed tuple)-        -> FCode ReturnKind---- Foreign calls-cgOpApp (StgFCallOp fcall ty) stg_args res_ty-  = cgForeignCall fcall ty stg_args res_ty-      -- Note [Foreign call results]--cgOpApp (StgPrimOp primop) args res_ty = do-    dflags <- getDynFlags-    cmm_args <- getNonVoidArgAmodes args-    cmmPrimOpApp dflags primop cmm_args (Just res_ty)--cgOpApp (StgPrimCallOp primcall) args _res_ty-  = do  { cmm_args <- getNonVoidArgAmodes args-        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))-        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }--cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind-cmmPrimOpApp dflags primop cmm_args mres_ty =-  case emitPrimOp dflags primop cmm_args of-    PrimopCmmEmit_Internal f ->-      let-         -- if the result type isn't explicitly given, we directly use the-         -- result type of the primop.-         res_ty = fromMaybe (primOpResultType primop) mres_ty-      in emitReturn =<< f res_ty-    PrimopCmmEmit_External -> do-      let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))-      emitCall (NativeNodeCall, NativeReturn) fun cmm_args----- | Interpret the argument as an unsigned value, assuming the value--- is given in two-complement form in the given width.------ Example: @asUnsigned W64 (-1)@ is 18446744073709551615.------ This function is used to work around the fact that many array--- primops take Int# arguments, but we interpret them as unsigned--- quantities in the code gen. This means that we have to be careful--- every time we work on e.g. a CmmInt literal that corresponds to the--- array size, as it might contain a negative Integer value if the--- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#--- literal.-asUnsigned :: Width -> Integer -> Integer-asUnsigned w n = n .&. (bit (widthInBits w) - 1)-----------------------------------------------------------------------------      Emitting code for a primop---------------------------------------------------------------------------shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool-shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of-  PrimopCmmEmit_External -> False-  PrimopCmmEmit_Internal _ -> True---- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use--- ByteOff (or some other fixed width signed type) to represent--- array sizes or indices. This means that these will overflow for--- large enough sizes.---- TODO: Several primops, such as 'copyArray#', only have an inline--- implementation (below) but could possibly have both an inline--- implementation and an out-of-line implementation, just like--- 'newArray#'. This would lower the amount of code generated,--- hopefully without a performance impact (needs to be measured).---- | The big function handling all the primops.------ In the simple case, there is just one implementation, and we emit that.------ In more complex cases, there is a foreign call (out of line) fallback. This--- might happen e.g. if there's enough static information, such as statically--- know arguments.-emitPrimOp-  :: DynFlags-  -> PrimOp            -- ^ The primop-  -> [CmmExpr]         -- ^ The primop arguments-  -> PrimopCmmEmit-emitPrimOp dflags primop = case primop of-  NewByteArrayOp_Char -> \case-    [(CmmLit (CmmInt n w))]-      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)-    _ -> PrimopCmmEmit_External--  NewArrayOp -> \case-    [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel-        [ (mkIntExpr platform (fromInteger n),-           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)-        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),-           fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)-        ]-        (fromInteger n) init-    _ -> PrimopCmmEmit_External--  CopyArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopyMutableArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopyArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopyMutableArrayArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneMutableArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  FreezeArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  ThawArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  NewSmallArrayOp -> \case-    [(CmmLit (CmmInt n w)), init]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] ->-        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel-        [ (mkIntExpr platform (fromInteger n),-           fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-        ]-        (fromInteger n) init-    _ -> PrimopCmmEmit_External--  CopySmallArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CopySmallMutableArrayOp -> \case-    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->-      opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  CloneSmallMutableArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  FreezeSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External--  ThawSmallArrayOp -> \case-    [src, src_off, (CmmLit (CmmInt n w))]-      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)-      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)-    _ -> PrimopCmmEmit_External---- First we handle various awkward cases specially.--  ParOp -> \[arg] -> opIntoRegs $ \[res] -> do-    -- for now, just implement this in a C function-    -- later, we might want to inline it.-    emitCCall-        [(res,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr, AddrHint), (arg,AddrHint)]--  SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do-    -- returns the value of arg in res.  We're going to therefore-    -- refer to arg twice (once to pass to newSpark(), and once to-    -- assign to res), so put it in a temporary.-    tmp <- assignTemp arg-    tmp2 <- newTemp (bWord platform)-    emitCCall-        [(tmp2,NoHint)]-        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))-        [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]-    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))--  GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do-    let-      val-       | sccProfilingEnabled dflags = costCentreFrom dflags (cmmUntag dflags arg)-       | otherwise                  = CmmLit (zeroCLit platform)-    emitAssign (CmmLocal res) val--  GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) cccsExpr--  MyThreadIdOp -> \[] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) currentTSOExpr--  ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))--  WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do-    old_val <- CmmLocal <$> newTemp (cmmExprType platform var)-    emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW dflags) (gcWord platform))--    -- Without this write barrier, other CPUs may see this pointer before-    -- the writes for the closure it points to have occurred.-    -- Note that this also must come after we read the old value to ensure-    -- that the read of old_val comes before another core's write to the-    -- MutVar's value.-    emitPrimCall res MO_WriteBarrier []-    emitStore (cmmOffsetW platform mutv (fixedHdrSizeW dflags)) var-    emitCCall-            [{-no results-}]-            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))-            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]----  #define sizzeofByteArrayzh(r,a) \---     r = ((StgArrBytes *)(a))->bytes-  SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))----  #define sizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp----  #define getSizzeofMutableByteArrayzh(r,a) \---      r = ((StgArrBytes *)(a))->bytes-  GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))-----  #define touchzh(o)                  /* nothing */-  TouchOp -> \args@[_] -> opIntoRegs $ \res@[] -> do-    emitPrimCall res MO_Touch args----  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)-  ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize dflags))----  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)-  StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW dflags) (bWord platform))--  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])----  #define addrToHValuezh(r,a) r=(P_)a-  AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) arg----  #define hvalueToAddrzh(r, a) r=(W_)a-  AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) arg--{- Freezing arrays-of-ptrs requires changing an info table, for the-   benefit of the generational collector.  It needs to scavenge mutable-   objects, even if they are in old space.  When they become immutable,-   they can be removed from this scavenge list.  -}----  #define unsafeFreezzeArrayzh(r,a)---      {---        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);---        r = a;---      }-  UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]-  UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]-  UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emit $ catAGraphs-      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),-        mkAssign (CmmLocal res) arg ]----  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)-  UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emitAssign (CmmLocal res) arg---- Reading/writing pointer arrays--  ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] -> do-    doWritePtrArrayOp obj ix v--  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadPtrArrayOp res obj ix-  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do-    doWritePtrArrayOp obj ix v-  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] -> do-    doWritePtrArrayOp obj ix v--  ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadSmallPtrArrayOp res obj ix-  IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] -> do-    doReadSmallPtrArrayOp res obj ix-  WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] -> do-    doWriteSmallPtrArrayOp obj ix v---- Getting the size of pointer arrays--  SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg-      (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgMutArrPtrs_ptrs dflags))-        (bWord platform))-  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp-  SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] -> do-    emit $ mkAssign (CmmLocal res)-     (cmmLoadIndexW platform arg-     (fixedHdrSizeW dflags + bytesToWordsRoundUp platform (oFFSET_StgSmallMutArrPtrs_ptrs dflags))-        (bWord platform))--  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp-  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp---- IndexXXXoffAddr--  IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args-  IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args-  IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing f32 res args-  IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing f64 res args-  IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_8ToWord platform)) b8  res args-  IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_16ToWord platform)) b16 res args-  IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_32ToWord platform)) b32 res args-  IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args-  IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8  res args-  IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_16ToWord platform)) b16 res args-  IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args-  IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args---- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.--  ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args-  ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args-  ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing f32 res args-  ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing f64 res args-  ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing (bWord platform) res args-  ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_8ToWord platform)) b8  res args-  ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_16ToWord platform)) b16 res args-  ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_s_32ToWord platform)) b32 res args-  ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args-  ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8  res args-  ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_16ToWord platform)) b16 res args-  ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args-  ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do-    doIndexOffAddrOp   Nothing b64 res args---- IndexXXXArray--  IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args-  IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args-  IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing f32 res args-  IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing f64 res args-  IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_8ToWord platform)) b8  res args-  IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_16ToWord platform)) b16  res args-  IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_32ToWord platform)) b32  res args-  IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args-  IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8  res args-  IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_16ToWord platform)) b16  res args-  IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32  res args-  IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args---- ReadXXXArray, identical to IndexXXXArray.--  ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args-  ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args-  ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing f32 res args-  ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing f64 res args-  ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing (bWord platform) res args-  ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_8ToWord platform)) b8  res args-  ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_16ToWord platform)) b16  res args-  ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_s_32ToWord platform)) b32  res args-  ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args-  ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8  res args-  ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_16ToWord platform)) b16  res args-  ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32  res args-  ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOp   Nothing b64  res args---- IndexWord8ArrayAsXXX--  IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args-  IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing f32 b8 res args-  IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing f64 b8 res args-  IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_16ToWord platform)) b16 b8 res args-  IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_32ToWord platform)) b32 b8 res args-  IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args-  IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_16ToWord platform)) b16 b8 res args-  IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args---- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX--  ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args-  ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing f32 b8 res args-  ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing f64 b8 res args-  ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args-  ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_16ToWord platform)) b16 b8 res args-  ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_s_32ToWord platform)) b32 b8 res args-  ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args-  ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_16ToWord platform)) b16 b8 res args-  ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args-  ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do-    doIndexByteArrayOpAs   Nothing b64 b8 res args---- WriteXXXoffAddr--  WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args-  WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args-  WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing f32 res args-  WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing f64 res args-  WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing (bWord platform) res args-  WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args-  WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args-  WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args-  WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing b64 res args-  WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args-  WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo16 platform)) b16 res args-  WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args-  WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res -> do-    doWriteOffAddrOp Nothing b64 res args---- WriteXXXArray--  WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args-  WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args-  WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing f32 res args-  WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing f64 res args-  WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing (bWord platform) res args-  WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args-  WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args-  WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args-  WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b64 res args-  WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8  res args-  WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b16 res args-  WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args-  WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b64 res args---- WriteInt8ArrayAsXXX--  WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args-  WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args-  WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args-  WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args-  WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args-  WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo16 platform)) b8 res args-  WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args-  WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res -> do-    doWriteByteArrayOp Nothing b8 res args---- Copying and setting byte arrays-  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do-    doCopyByteArrayOp src src_off dst dst_off n-  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] -> do-    doCopyMutableByteArrayOp src src_off dst dst_off n-  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do-    doCopyByteArrayToAddrOp src src_off dst n-  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] -> do-    doCopyMutableByteArrayToAddrOp src src_off dst n-  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] -> do-    doCopyAddrToByteArrayOp src dst dst_off n-  SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] -> do-    doSetByteArrayOp ba off len c---- Comparing byte arrays-  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] -> do-    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n--  BSwap16Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBSwapCall res w W16-  BSwap32Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBSwapCall res w W32-  BSwap64Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBSwapCall res w W64-  BSwapOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitBSwapCall res w (wordWidth platform)--  BRev8Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBRevCall res w W8-  BRev16Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBRevCall res w W16-  BRev32Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBRevCall res w W32-  BRev64Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitBRevCall res w W64-  BRevOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitBRevCall res w (wordWidth platform)---- Population count-  PopCnt8Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitPopCntCall res w W8-  PopCnt16Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitPopCntCall res w W16-  PopCnt32Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitPopCntCall res w W32-  PopCnt64Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitPopCntCall res w W64-  PopCntOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitPopCntCall res w (wordWidth platform)---- Parallel bit deposit-  Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPdepCall res src mask W8-  Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPdepCall res src mask W16-  Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPdepCall res src mask W32-  Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPdepCall res src mask W64-  PdepOp -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPdepCall res src mask (wordWidth platform)---- Parallel bit extract-  Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPextCall res src mask W8-  Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPextCall res src mask W16-  Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPextCall res src mask W32-  Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPextCall res src mask W64-  PextOp -> \[src, mask] -> opIntoRegs $ \[res] -> do-    emitPextCall res src mask (wordWidth platform)---- count leading zeros-  Clz8Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitClzCall res w W8-  Clz16Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitClzCall res w W16-  Clz32Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitClzCall res w W32-  Clz64Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitClzCall res w W64-  ClzOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitClzCall res w (wordWidth platform)---- count trailing zeros-  Ctz8Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitCtzCall res w W8-  Ctz16Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitCtzCall res w W16-  Ctz32Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitCtzCall res w W32-  Ctz64Op -> \[w] -> opIntoRegs $ \[res] -> do-    emitCtzCall res w W64-  CtzOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitCtzCall res w (wordWidth platform)---- Unsigned int to floating point conversions-  Word2FloatOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitPrimCall [res] (MO_UF_Conv W32) [w]-  Word2DoubleOp -> \[w] -> opIntoRegs $ \[res] -> do-    emitPrimCall [res] (MO_UF_Conv W64) [w]---- Atomic operations-  InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]-  InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]--  CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]-  CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->-    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]---- SIMD primops-  (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w-    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res-   where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w-    when (es `lengthIsNot` n) $-        panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res-   where-    zeros :: CmmExpr-    zeros = CmmLit $ CmmVec (replicate n zero)--    zero :: CmmLit-    zero = case vcat of-             IntVec   -> CmmInt 0 w-             WordVec  -> CmmInt 0 w-             FloatVec -> CmmFloat 0 w--    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do-    checkVecCompatibility dflags vcat n w-    when (res `lengthIsNot` n) $-        panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do-    checkVecCompatibility dflags vcat n w-    doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecVmmType vcat n w--  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexByteArrayOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteByteArrayOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doIndexOffAddrOpAs Nothing vecty ty res0 args-   where-    vecty :: CmmType-    vecty = vecVmmType vcat n w--    ty :: CmmType-    ty = vecCmmCat vcat w--  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do-    checkVecCompatibility dflags vcat n w-    doWriteOffAddrOp Nothing ty res0 args-   where-    ty :: CmmType-    ty = vecCmmCat vcat w---- Prefetch-  PrefetchByteArrayOp3         -> \args -> opIntoRegs $ \[] -> do-    doPrefetchByteArrayOp 3  args-  PrefetchMutableByteArrayOp3  -> \args -> opIntoRegs $ \[] -> do-    doPrefetchMutableByteArrayOp 3  args-  PrefetchAddrOp3              -> \args -> opIntoRegs $ \[] -> do-    doPrefetchAddrOp  3  args-  PrefetchValueOp3             -> \args -> opIntoRegs $ \[] -> do-    doPrefetchValueOp 3 args--  PrefetchByteArrayOp2         -> \args -> opIntoRegs $ \[] -> do-    doPrefetchByteArrayOp 2  args-  PrefetchMutableByteArrayOp2  -> \args -> opIntoRegs $ \[] -> do-    doPrefetchMutableByteArrayOp 2  args-  PrefetchAddrOp2              -> \args -> opIntoRegs $ \[] -> do-    doPrefetchAddrOp 2  args-  PrefetchValueOp2             -> \args -> opIntoRegs $ \[] -> do-    doPrefetchValueOp 2 args-  PrefetchByteArrayOp1         -> \args -> opIntoRegs $ \[] -> do-    doPrefetchByteArrayOp 1  args-  PrefetchMutableByteArrayOp1  -> \args -> opIntoRegs $ \[] -> do-    doPrefetchMutableByteArrayOp 1  args-  PrefetchAddrOp1              -> \args -> opIntoRegs $ \[] -> do-    doPrefetchAddrOp 1  args-  PrefetchValueOp1             -> \args -> opIntoRegs $ \[] -> do-    doPrefetchValueOp 1 args--  PrefetchByteArrayOp0         -> \args -> opIntoRegs $ \[] -> do-    doPrefetchByteArrayOp 0  args-  PrefetchMutableByteArrayOp0  -> \args -> opIntoRegs $ \[] -> do-    doPrefetchMutableByteArrayOp 0  args-  PrefetchAddrOp0              -> \args -> opIntoRegs $ \[] -> do-    doPrefetchAddrOp 0  args-  PrefetchValueOp0             -> \args -> opIntoRegs $ \[] -> do-    doPrefetchValueOp 0 args---- Atomic read-modify-write-  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do-    doAtomicRMW res AMO_Add mba ix (bWord platform) n-  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do-    doAtomicRMW res AMO_Sub mba ix (bWord platform) n-  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do-    doAtomicRMW res AMO_And mba ix (bWord platform) n-  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do-    doAtomicRMW res AMO_Nand mba ix (bWord platform) n-  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do-    doAtomicRMW res AMO_Or mba ix (bWord platform) n-  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] -> do-    doAtomicRMW res AMO_Xor mba ix (bWord platform) n-  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] -> do-    doAtomicReadByteArray res mba ix (bWord platform)-  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] -> do-    doAtomicWriteByteArray mba ix (bWord platform) val-  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] -> do-    doCasByteArray res mba ix (bWord platform) old new---- The rest just translate straightforwardly--  Int2WordOp      -> \args -> opNop args-  Word2IntOp      -> \args -> opNop args-  Int2AddrOp      -> \args -> opNop args-  Addr2IntOp      -> \args -> opNop args-  ChrOp           -> \args -> opNop args  -- Int# and Char# are rep'd the same-  OrdOp           -> \args -> opNop args--  Narrow8IntOp   -> \args -> opNarrow args (MO_SS_Conv, W8)-  Narrow16IntOp  -> \args -> opNarrow args (MO_SS_Conv, W16)-  Narrow32IntOp  -> \args -> opNarrow args (MO_SS_Conv, W32)-  Narrow8WordOp  -> \args -> opNarrow args (MO_UU_Conv, W8)-  Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16)-  Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32)--  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr-  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin-  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos-  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan-  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh-  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh-  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh-  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin-  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos-  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan-  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh-  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh-  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh-  DoubleLogOp    -> \args -> opCallish args MO_F64_Log-  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P-  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp-  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1-  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt--  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr-  FloatSinOp     -> \args -> opCallish args MO_F32_Sin-  FloatCosOp     -> \args -> opCallish args MO_F32_Cos-  FloatTanOp     -> \args -> opCallish args MO_F32_Tan-  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh-  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh-  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh-  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin-  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos-  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan-  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh-  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh-  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh-  FloatLogOp     -> \args -> opCallish args MO_F32_Log-  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P-  FloatExpOp     -> \args -> opCallish args MO_F32_Exp-  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1-  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt---- Native word signless ops--  IntAddOp       -> \args -> opTranslate args (mo_wordAdd platform)-  IntSubOp       -> \args -> opTranslate args (mo_wordSub platform)-  WordAddOp      -> \args -> opTranslate args (mo_wordAdd platform)-  WordSubOp      -> \args -> opTranslate args (mo_wordSub platform)-  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd platform)-  AddrSubOp      -> \args -> opTranslate args (mo_wordSub platform)--  IntEqOp        -> \args -> opTranslate args (mo_wordEq platform)-  IntNeOp        -> \args -> opTranslate args (mo_wordNe platform)-  WordEqOp       -> \args -> opTranslate args (mo_wordEq platform)-  WordNeOp       -> \args -> opTranslate args (mo_wordNe platform)-  AddrEqOp       -> \args -> opTranslate args (mo_wordEq platform)-  AddrNeOp       -> \args -> opTranslate args (mo_wordNe platform)--  AndOp          -> \args -> opTranslate args (mo_wordAnd platform)-  OrOp           -> \args -> opTranslate args (mo_wordOr platform)-  XorOp          -> \args -> opTranslate args (mo_wordXor platform)-  NotOp          -> \args -> opTranslate args (mo_wordNot platform)-  SllOp          -> \args -> opTranslate args (mo_wordShl platform)-  SrlOp          -> \args -> opTranslate args (mo_wordUShr platform)--  AddrRemOp      -> \args -> opTranslate args (mo_wordURem platform)---- Native word signed ops--  IntMulOp        -> \args -> opTranslate args (mo_wordMul platform)-  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform))-  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot platform)-  IntRemOp        -> \args -> opTranslate args (mo_wordSRem platform)-  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg platform)--  IntGeOp        -> \args -> opTranslate args (mo_wordSGe platform)-  IntLeOp        -> \args -> opTranslate args (mo_wordSLe platform)-  IntGtOp        -> \args -> opTranslate args (mo_wordSGt platform)-  IntLtOp        -> \args -> opTranslate args (mo_wordSLt platform)--  AndIOp         -> \args -> opTranslate args (mo_wordAnd platform)-  OrIOp          -> \args -> opTranslate args (mo_wordOr platform)-  XorIOp         -> \args -> opTranslate args (mo_wordXor platform)-  NotIOp         -> \args -> opTranslate args (mo_wordNot platform)-  ISllOp         -> \args -> opTranslate args (mo_wordShl platform)-  ISraOp         -> \args -> opTranslate args (mo_wordSShr platform)-  ISrlOp         -> \args -> opTranslate args (mo_wordUShr platform)---- Native word unsigned ops--  WordGeOp       -> \args -> opTranslate args (mo_wordUGe platform)-  WordLeOp       -> \args -> opTranslate args (mo_wordULe platform)-  WordGtOp       -> \args -> opTranslate args (mo_wordUGt platform)-  WordLtOp       -> \args -> opTranslate args (mo_wordULt platform)--  WordMulOp      -> \args -> opTranslate args (mo_wordMul platform)-  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot platform)-  WordRemOp      -> \args -> opTranslate args (mo_wordURem platform)--  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe platform)-  AddrLeOp       -> \args -> opTranslate args (mo_wordULe platform)-  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt platform)-  AddrLtOp       -> \args -> opTranslate args (mo_wordULt platform)---- Int8# signed ops--  Int8Extend     -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))-  Int8Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)-  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)-  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)-  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)-  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)-  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)-  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)--  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)-  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)-  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)-  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)-  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)-  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)---- Word8# unsigned ops--  Word8Extend     -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))-  Word8Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)-  Word8NotOp      -> \args -> opTranslate args (MO_Not W8)-  Word8AddOp      -> \args -> opTranslate args (MO_Add W8)-  Word8SubOp      -> \args -> opTranslate args (MO_Sub W8)-  Word8MulOp      -> \args -> opTranslate args (MO_Mul W8)-  Word8QuotOp     -> \args -> opTranslate args (MO_U_Quot W8)-  Word8RemOp      -> \args -> opTranslate args (MO_U_Rem W8)--  Word8EqOp       -> \args -> opTranslate args (MO_Eq W8)-  Word8GeOp       -> \args -> opTranslate args (MO_U_Ge W8)-  Word8GtOp       -> \args -> opTranslate args (MO_U_Gt W8)-  Word8LeOp       -> \args -> opTranslate args (MO_U_Le W8)-  Word8LtOp       -> \args -> opTranslate args (MO_U_Lt W8)-  Word8NeOp       -> \args -> opTranslate args (MO_Ne W8)---- Int16# signed ops--  Int16Extend     -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))-  Int16Narrow     -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)-  Int16NegOp      -> \args -> opTranslate args (MO_S_Neg W16)-  Int16AddOp      -> \args -> opTranslate args (MO_Add W16)-  Int16SubOp      -> \args -> opTranslate args (MO_Sub W16)-  Int16MulOp      -> \args -> opTranslate args (MO_Mul W16)-  Int16QuotOp     -> \args -> opTranslate args (MO_S_Quot W16)-  Int16RemOp      -> \args -> opTranslate args (MO_S_Rem W16)--  Int16EqOp       -> \args -> opTranslate args (MO_Eq W16)-  Int16GeOp       -> \args -> opTranslate args (MO_S_Ge W16)-  Int16GtOp       -> \args -> opTranslate args (MO_S_Gt W16)-  Int16LeOp       -> \args -> opTranslate args (MO_S_Le W16)-  Int16LtOp       -> \args -> opTranslate args (MO_S_Lt W16)-  Int16NeOp       -> \args -> opTranslate args (MO_Ne W16)---- Word16# unsigned ops--  Word16Extend     -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))-  Word16Narrow     -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)-  Word16NotOp      -> \args -> opTranslate args (MO_Not W16)-  Word16AddOp      -> \args -> opTranslate args (MO_Add W16)-  Word16SubOp      -> \args -> opTranslate args (MO_Sub W16)-  Word16MulOp      -> \args -> opTranslate args (MO_Mul W16)-  Word16QuotOp     -> \args -> opTranslate args (MO_U_Quot W16)-  Word16RemOp      -> \args -> opTranslate args (MO_U_Rem W16)--  Word16EqOp       -> \args -> opTranslate args (MO_Eq W16)-  Word16GeOp       -> \args -> opTranslate args (MO_U_Ge W16)-  Word16GtOp       -> \args -> opTranslate args (MO_U_Gt W16)-  Word16LeOp       -> \args -> opTranslate args (MO_U_Le W16)-  Word16LtOp       -> \args -> opTranslate args (MO_U_Lt W16)-  Word16NeOp       -> \args -> opTranslate args (MO_Ne W16)---- Char# ops--  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth platform))-  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth platform))-  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth platform))-  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth platform))-  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth platform))-  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth platform))---- Double ops--  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)-  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)-  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)-  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)-  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)-  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)--  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)-  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)-  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)-  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)-  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)---- Float ops--  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)-  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)-  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)-  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)-  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)-  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)--  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)-  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)-  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)-  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)-  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)---- Vector ops--  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)-  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)-  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)-  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)-  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"-  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"-  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)--  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)-  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)-  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)-  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)-  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)-  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)--  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)-  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)-  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)-  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"-  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)-  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)-  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"---- Conversions--  Int2DoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)-  Double2IntOp   -> \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))--  Float2DoubleOp -> \args -> opTranslate args (MO_FF_Conv W32 W64)-  Double2FloatOp -> \args -> opTranslate args (MO_FF_Conv W64 W32)---- Word comparisons masquerading as more exotic things.--  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)-  SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)-  SameIOPortOp            -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)-  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)-  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)-  SameTVarOp              -> \args -> opTranslate args (mo_wordEq platform)-  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq platform)--- See Note [Comparing stable names]-  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq platform)--  IntQuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem  (wordWidth platform))-    else Right (genericIntQuotRemOp (wordWidth platform))--  Int8QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W8)-    else Right (genericIntQuotRemOp W8)--  Int16QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_S_QuotRem W16)-    else Right (genericIntQuotRemOp W16)--  WordQuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem  (wordWidth platform))-    else Right (genericWordQuotRemOp (wordWidth platform))--  WordQuotRem2Op -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_U_QuotRem2 (wordWidth platform))-    else Right (genericWordQuotRem2Op platform)--  Word8QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W8)-    else Right (genericWordQuotRemOp W8)--  Word16QuotRemOp -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)-    then Left (MO_U_QuotRem W16)-    else Right (genericWordQuotRemOp W16)--  WordAdd2Op -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_Add2       (wordWidth platform))-    else Right genericWordAdd2Op--  WordAddCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_AddWordC   (wordWidth platform))-    else Right genericWordAddCOp--  WordSubCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_SubWordC   (wordWidth platform))-    else Right genericWordSubCOp--  IntAddCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_AddIntC    (wordWidth platform))-    else Right genericIntAddCOp--  IntSubCOp -> \args -> opCallishHandledLater args $-    if (ncg && (x86ish || ppc)) || llvm-    then Left (MO_SubIntC    (wordWidth platform))-    else Right genericIntSubCOp--  WordMul2Op -> \args -> opCallishHandledLater args $-    if ncg && (x86ish || ppc) || llvm-    then Left (MO_U_Mul2     (wordWidth platform))-    else Right genericWordMul2Op--  IntMul2Op  -> \args -> opCallishHandledLater args $-    if ncg && x86ish || llvm-    then Left (MO_S_Mul2     (wordWidth platform))-    else Right genericIntMul2Op--  FloatFabsOp -> \args -> opCallishHandledLater args $-    if (ncg && x86ish || ppc) || llvm-    then Left MO_F32_Fabs-    else Right $ genericFabsOp W32--  DoubleFabsOp -> \args -> opCallishHandledLater args $-    if (ncg && x86ish || ppc) || llvm-    then Left MO_F64_Fabs-    else Right $ genericFabsOp W64--  -- tagToEnum# is special: we need to pull the constructor-  -- out of the table, and perform an appropriate return.-  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do-    -- If you're reading this code in the attempt to figure-    -- out why the compiler panic'ed here, it is probably because-    -- you used tagToEnum# in a non-monomorphic setting, e.g.,-    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#-    -- That won't work.-    let tycon = tyConAppTyCon res_ty-    MASSERT(isEnumerationTyCon tycon)-    platform <- getPlatform-    pure [tagToClosure platform tycon amode]---- Out of line primops.--- TODO compiler need not know about these--  UnsafeThawArrayOp -> alwaysExternal-  CasArrayOp -> alwaysExternal-  UnsafeThawSmallArrayOp -> alwaysExternal-  CasSmallArrayOp -> alwaysExternal-  NewPinnedByteArrayOp_Char -> alwaysExternal-  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal-  MutableByteArrayIsPinnedOp -> alwaysExternal-  DoubleDecode_2IntOp -> alwaysExternal-  DoubleDecode_Int64Op -> alwaysExternal-  FloatDecode_IntOp -> alwaysExternal-  ByteArrayIsPinnedOp -> alwaysExternal-  ShrinkMutableByteArrayOp_Char -> alwaysExternal-  ResizeMutableByteArrayOp_Char -> alwaysExternal-  ShrinkSmallMutableArrayOp_Char -> alwaysExternal-  NewArrayArrayOp -> alwaysExternal-  NewMutVarOp -> alwaysExternal-  AtomicModifyMutVar2Op -> alwaysExternal-  AtomicModifyMutVar_Op -> alwaysExternal-  CasMutVarOp -> alwaysExternal-  CatchOp -> alwaysExternal-  RaiseOp -> alwaysExternal-  RaiseIOOp -> alwaysExternal-  MaskAsyncExceptionsOp -> alwaysExternal-  MaskUninterruptibleOp -> alwaysExternal-  UnmaskAsyncExceptionsOp -> alwaysExternal-  MaskStatus -> alwaysExternal-  AtomicallyOp -> alwaysExternal-  RetryOp -> alwaysExternal-  CatchRetryOp -> alwaysExternal-  CatchSTMOp -> alwaysExternal-  NewTVarOp -> alwaysExternal-  ReadTVarOp -> alwaysExternal-  ReadTVarIOOp -> alwaysExternal-  WriteTVarOp -> alwaysExternal-  NewMVarOp -> alwaysExternal-  TakeMVarOp -> alwaysExternal-  TryTakeMVarOp -> alwaysExternal-  PutMVarOp -> alwaysExternal-  TryPutMVarOp -> alwaysExternal-  ReadMVarOp -> alwaysExternal-  TryReadMVarOp -> alwaysExternal-  IsEmptyMVarOp -> alwaysExternal-  NewIOPortrOp -> alwaysExternal-  ReadIOPortOp -> alwaysExternal-  WriteIOPortOp -> alwaysExternal-  DelayOp -> alwaysExternal-  WaitReadOp -> alwaysExternal-  WaitWriteOp -> alwaysExternal-  ForkOp -> alwaysExternal-  ForkOnOp -> alwaysExternal-  KillThreadOp -> alwaysExternal-  YieldOp -> alwaysExternal-  LabelThreadOp -> alwaysExternal-  IsCurrentThreadBoundOp -> alwaysExternal-  NoDuplicateOp -> alwaysExternal-  ThreadStatusOp -> alwaysExternal-  MkWeakOp -> alwaysExternal-  MkWeakNoFinalizerOp -> alwaysExternal-  AddCFinalizerToWeakOp -> alwaysExternal-  DeRefWeakOp -> alwaysExternal-  FinalizeWeakOp -> alwaysExternal-  MakeStablePtrOp -> alwaysExternal-  DeRefStablePtrOp -> alwaysExternal-  MakeStableNameOp -> alwaysExternal-  CompactNewOp -> alwaysExternal-  CompactResizeOp -> alwaysExternal-  CompactContainsOp -> alwaysExternal-  CompactContainsAnyOp -> alwaysExternal-  CompactGetFirstBlockOp -> alwaysExternal-  CompactGetNextBlockOp -> alwaysExternal-  CompactAllocateBlockOp -> alwaysExternal-  CompactFixupPointersOp -> alwaysExternal-  CompactAdd -> alwaysExternal-  CompactAddWithSharing -> alwaysExternal-  CompactSize -> alwaysExternal-  SeqOp -> alwaysExternal-  GetSparkOp -> alwaysExternal-  NumSparks -> alwaysExternal-  DataToTagOp -> alwaysExternal-  MkApUpd0_Op -> alwaysExternal-  NewBCOOp -> alwaysExternal-  UnpackClosureOp -> alwaysExternal-  ClosureSizeOp -> alwaysExternal-  GetApStackValOp -> alwaysExternal-  ClearCCSOp -> alwaysExternal-  TraceEventOp -> alwaysExternal-  TraceEventBinaryOp -> alwaysExternal-  TraceMarkerOp -> alwaysExternal-  SetThreadAllocationCounter -> alwaysExternal--  -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.-  KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"-- where-  platform = targetPlatform dflags-  result_info = getPrimOpResultInfo primop--  opNop :: [CmmExpr] -> PrimopCmmEmit-  opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg-    where [arg] = args--  opNarrow-    :: [CmmExpr]-    -> (Width -> Width -> MachOp, Width)-    -> PrimopCmmEmit-  opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $-    CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]-    where [arg] = args--  -- | These primops are implemented by CallishMachOps, because they sometimes-  -- turn into foreign calls depending on the backend.-  opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit-  opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args--  opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit-  opTranslate args mop = opIntoRegs $ \[res] -> do-    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)-    emit stmt--  -- | Basically a "manual" case, rather than one of the common repetitive forms-  -- above. The results are a parameter to the returned function so we know the-  -- choice of variant never depends on them.-  opCallishHandledLater-    :: [CmmExpr]-    -> Either CallishMachOp GenericOp-    -> PrimopCmmEmit-  opCallishHandledLater args callOrNot = opIntoRegs $ \res0 -> case callOrNot of-    Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args-    Right gen -> gen res0 args--  opIntoRegs-    :: ([LocalReg] -- where to put the results-        -> FCode ())-    -> PrimopCmmEmit-  opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do-    regs <- if-      | ReturnsPrim VoidRep <- result_info-      -> pure []--      | ReturnsPrim rep <- result_info-      -> do reg <- newTemp (primRepCmmType platform rep)-            pure [reg]--      | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon-      -> do (regs, _hints) <- newUnboxedTupleRegs res_ty-            pure regs--      | otherwise -> panic "cgOpApp"-    f regs-    pure $ map (CmmReg . CmmLocal) regs--  alwaysExternal = \_ -> PrimopCmmEmit_External-  -- Note [QuotRem optimization]-  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~-  ---  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops-  -- (shift, .&.).-  ---  -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the-  -- constant is a power of 2. #9041 tracks the implementation of the general-  -- optimization.-  ---  -- `quotRem` can be optimized in the same way. However as it returns two values,-  -- it is implemented as a "callish" primop which is harder to match and-  -- to transform later on. For simplicity, the current implementation detects cases-  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem-  -- primop into two CMM quot and rem primops.-  quotRemCanBeOptimized = \case-    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)-    _                         -> False--  ncg = case hscTarget dflags of-           HscAsm -> True-           _      -> False-  llvm = case hscTarget dflags of-           HscLlvm -> True-           _       -> False-  x86ish = case platformArch platform of-             ArchX86    -> True-             ArchX86_64 -> True-             _          -> False-  ppc = case platformArch platform of-          ArchPPC      -> True-          ArchPPC_64 _ -> True-          _            -> False--data PrimopCmmEmit-  -- | Out of line fake primop that's actually just a foreign call to other-  -- (presumably) C--.-  = PrimopCmmEmit_External-  -- | Real primop turned into inline C--.-  | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it-                            -> FCode [CmmExpr]) -- just for TagToEnum for now--type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()--genericIntQuotRemOp :: Width -> GenericOp-genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]-   = emit $ mkAssign (CmmLocal res_q)-              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>-            mkAssign (CmmLocal res_r)-              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])-genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"--genericWordQuotRemOp :: Width -> GenericOp-genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]-    = emit $ mkAssign (CmmLocal res_q)-               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>-             mkAssign (CmmLocal res_r)-               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])-genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"--genericWordQuotRem2Op :: Platform -> GenericOp-genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]-    = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low-    where    ty = cmmExprType platform arg_x_high-             shl   x i = CmmMachOp (MO_Shl   (wordWidth platform)) [x, i]-             shr   x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]-             or    x y = CmmMachOp (MO_Or    (wordWidth platform)) [x, y]-             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth platform)) [x, y]-             ne    x y = CmmMachOp (MO_Ne    (wordWidth platform)) [x, y]-             minus x y = CmmMachOp (MO_Sub   (wordWidth platform)) [x, y]-             times x y = CmmMachOp (MO_Mul   (wordWidth platform)) [x, y]-             zero   = lit 0-             one    = lit 1-             negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)-             lit i = CmmLit (CmmInt i (wordWidth platform))--             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph-             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>-                                      mkAssign (CmmLocal res_r) high)-             f i acc high low =-                 do roverflowedBit <- newTemp ty-                    rhigh'         <- newTemp ty-                    rhigh''        <- newTemp ty-                    rlow'          <- newTemp ty-                    risge          <- newTemp ty-                    racc'          <- newTemp ty-                    let high'         = CmmReg (CmmLocal rhigh')-                        isge          = CmmReg (CmmLocal risge)-                        overflowedBit = CmmReg (CmmLocal roverflowedBit)-                    let this = catAGraphs-                               [mkAssign (CmmLocal roverflowedBit)-                                          (shr high negone),-                                mkAssign (CmmLocal rhigh')-                                          (or (shl high one) (shr low negone)),-                                mkAssign (CmmLocal rlow')-                                          (shl low one),-                                mkAssign (CmmLocal risge)-                                          (or (overflowedBit `ne` zero)-                                              (high' `ge` arg_y)),-                                mkAssign (CmmLocal rhigh'')-                                          (high' `minus` (arg_y `times` isge)),-                                mkAssign (CmmLocal racc')-                                          (or (shl acc one) isge)]-                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))-                                      (CmmReg (CmmLocal rhigh''))-                                      (CmmReg (CmmLocal rlow'))-                    return (this <*> rest)-genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"--genericWordAdd2Op :: GenericOp-genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]-  = do platform <- getPlatform-       r1 <- newTemp (cmmExprType platform arg_x)-       r2 <- newTemp (cmmExprType platform arg_x)-       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]-           toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]-           bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]-           add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]-           or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]-           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))-                                (wordWidth platform))-           hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))-       emit $ catAGraphs-          [mkAssign (CmmLocal r1)-               (add (bottomHalf arg_x) (bottomHalf arg_y)),-           mkAssign (CmmLocal r2)-               (add (topHalf (CmmReg (CmmLocal r1)))-                    (add (topHalf arg_x) (topHalf arg_y))),-           mkAssign (CmmLocal res_h)-               (topHalf (CmmReg (CmmLocal r2))),-           mkAssign (CmmLocal res_l)-               (or (toTopHalf (CmmReg (CmmLocal r2)))-                   (bottomHalf (CmmReg (CmmLocal r1))))]-genericWordAdd2Op _ _ = panic "genericWordAdd2Op"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:------ @---    c = a&b | (a|b)&~r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordAddCOp :: GenericOp-genericWordAddCOp [res_r, res_c] [aa, bb]- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-            CmmMachOp (mo_wordOr platform) [-              CmmMachOp (mo_wordAnd platform) [aa,bb],-              CmmMachOp (mo_wordAnd platform) [-                CmmMachOp (mo_wordOr platform) [aa,bb],-                CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]-              ]-            ],-            mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericWordAddCOp _ _ = panic "genericWordAddCOp"---- | Implements branchless recovery of the carry flag @c@ by checking the--- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:------ @---    c = ~a&b | (~a|b)&r--- @------ https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/-genericWordSubCOp :: GenericOp-genericWordSubCOp [res_r, res_c] [aa, bb]- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-            CmmMachOp (mo_wordOr platform) [-              CmmMachOp (mo_wordAnd platform) [-                CmmMachOp (mo_wordNot platform) [aa],-                bb-              ],-              CmmMachOp (mo_wordAnd platform) [-                CmmMachOp (mo_wordOr platform) [-                  CmmMachOp (mo_wordNot platform) [aa],-                  bb-                ],-                CmmReg (CmmLocal res_r)-              ]-            ],-            mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericWordSubCOp _ _ = panic "genericWordSubCOp"--genericIntAddCOp :: GenericOp-genericIntAddCOp [res_r, res_c] [aa, bb]-{--   With some bit-twiddling, we can define int{Add,Sub}Czh portably in-   C, and without needing any comparisons.  This may not be the-   fastest way to do it - if you have better code, please send it! --SDM--   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.--   We currently don't make use of the r value if c is != 0 (i.e.-   overflow), we just convert to big integers and try again.  This-   could be improved by making r and c the correct values for-   plugging into a new J#.--   { r = ((I_)(a)) + ((I_)(b));                                 \-     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \-         >> (BITS_IN (I_) - 1);                                 \-   }-   Wading through the mass of bracketry, it seems to reduce to:-   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)---}- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-                CmmMachOp (mo_wordAnd platform) [-                    CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],-                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericIntAddCOp _ _ = panic "genericIntAddCOp"--genericIntSubCOp :: GenericOp-genericIntSubCOp [res_r, res_c] [aa, bb]-{- Similarly:-   #define subIntCzh(r,c,a,b)                                   \-   { r = ((I_)(a)) - ((I_)(b));                                 \-     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \-         >> (BITS_IN (I_) - 1);                                 \-   }--   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)--}- = do platform <- getPlatform-      emit $ catAGraphs [-        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),-        mkAssign (CmmLocal res_c) $-          CmmMachOp (mo_wordUShr platform) [-                CmmMachOp (mo_wordAnd platform) [-                    CmmMachOp (mo_wordXor platform) [aa,bb],-                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]-                ],-                mkIntExpr platform (platformWordSizeInBits platform - 1)-          ]-        ]-genericIntSubCOp _ _ = panic "genericIntSubCOp"--genericWordMul2Op :: GenericOp-genericWordMul2Op [res_h, res_l] [arg_x, arg_y]- = do platform <- getPlatform-      let t = cmmExprType platform arg_x-      xlyl <- liftM CmmLocal $ newTemp t-      xlyh <- liftM CmmLocal $ newTemp t-      xhyl <- liftM CmmLocal $ newTemp t-      r    <- liftM CmmLocal $ newTemp t-      -- This generic implementation is very simple and slow. We might-      -- well be able to do better, but for now this at least works.-      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]-          toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]-          bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]-          add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]-          sum = foldl1 add-          mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]-          or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]-          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))-                               (wordWidth platform))-          hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))-      emit $ catAGraphs-             [mkAssign xlyl-                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),-              mkAssign xlyh-                  (mul (bottomHalf arg_x) (topHalf arg_y)),-              mkAssign xhyl-                  (mul (topHalf arg_x) (bottomHalf arg_y)),-              mkAssign r-                  (sum [topHalf    (CmmReg xlyl),-                        bottomHalf (CmmReg xhyl),-                        bottomHalf (CmmReg xlyh)]),-              mkAssign (CmmLocal res_l)-                  (or (bottomHalf (CmmReg xlyl))-                      (toTopHalf (CmmReg r))),-              mkAssign (CmmLocal res_h)-                  (sum [mul (topHalf arg_x) (topHalf arg_y),-                        topHalf (CmmReg xhyl),-                        topHalf (CmmReg xlyh),-                        topHalf (CmmReg r)])]-genericWordMul2Op _ _ = panic "genericWordMul2Op"--genericIntMul2Op :: GenericOp-genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]- = do dflags <- getDynFlags-      platform <- getPlatform-      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174-      let t = cmmExprType platform arg_x-      p   <- newTemp t-      -- 1) compute the multiplication as if numbers were unsigned-      _ <- withSequel (AssignTo [p, res_l] False) $-             cmmPrimOpApp dflags WordMul2Op both_args Nothing-      -- 2) correct the high bits of the unsigned result-      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]-          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]-          and x y     = CmmMachOp (MO_And   ww) [x, y]-          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]-          f   x y     = (carryFill x) `and` y-          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)-          rl x        = CmmReg (CmmLocal x)-          ww          = wordWidth platform-      emit $ catAGraphs-             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)-             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))-             ]-genericIntMul2Op _ _ = panic "genericIntMul2Op"---- This replicates what we had in libraries/base/GHC/Float.hs:------    abs x    | x == 0    = 0 -- handles (-0.0)---             | x >  0    = x---             | otherwise = negateFloat x-genericFabsOp :: Width -> GenericOp-genericFabsOp w [res_r] [aa]- = do platform <- getPlatform-      let zero   = CmmLit (CmmFloat 0 w)--          eq x y = CmmMachOp (MO_F_Eq w) [x, y]-          gt x y = CmmMachOp (MO_F_Gt w) [x, y]--          neg x  = CmmMachOp (MO_F_Neg w) [x]--          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]-          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]--      res_t <- CmmLocal <$> newTemp (cmmExprType platform aa)-      let g3 = catAGraphs [mkAssign res_t aa,-                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]--      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3--      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4--genericFabsOp _ _ _ = panic "genericFabsOp"---- Note [Comparing stable names]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ A StableName# is actually a pointer to a stable name object (SNO)--- containing an index into the stable name table (SNT). We--- used to compare StableName#s by following the pointers to the--- SNOs and checking whether they held the same SNT indices. However,--- this is not necessary: there is a one-to-one correspondence--- between SNOs and entries in the SNT, so simple pointer equality--- does the trick.----------------------------------------------------------------------------------- Helpers for translating various minor variants of array indexing.--doIndexOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx-doIndexOffAddrOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"--doIndexOffAddrOpAs :: Maybe MachOp-                   -> CmmType-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx-doIndexOffAddrOpAs _ _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"--doIndexByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx-doIndexByteArrayOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"--doIndexByteArrayOpAs :: Maybe MachOp-                    -> CmmType-                    -> CmmType-                    -> [LocalReg]-                    -> [CmmExpr]-                    -> FCode ()-doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]-   = do dflags <- getDynFlags-        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx-doIndexByteArrayOpAs _ _ _ _ _-   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"--doReadPtrArrayOp :: LocalReg-                 -> CmmExpr-                 -> CmmExpr-                 -> FCode ()-doReadPtrArrayOp res addr idx-   = do dflags <- getDynFlags-        platform <- getPlatform-        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord platform) res addr (gcWord platform) idx--doWriteOffAddrOp :: Maybe MachOp-                 -> CmmType-                 -> [LocalReg]-                 -> [CmmExpr]-                 -> FCode ()-doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val-doWriteOffAddrOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"--doWriteByteArrayOp :: Maybe MachOp-                   -> CmmType-                   -> [LocalReg]-                   -> [CmmExpr]-                   -> FCode ()-doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]-   = do dflags <- getDynFlags-        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val-doWriteByteArrayOp _ _ _ _-   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"--doWritePtrArrayOp :: CmmExpr-                  -> CmmExpr-                  -> CmmExpr-                  -> FCode ()-doWritePtrArrayOp addr idx val-  = do dflags <- getDynFlags-       platform <- getPlatform-       let ty = cmmExprType platform val-           hdr_size = arrPtrsHdrSize dflags-       -- Update remembered set for non-moving collector-       whenUpdRemSetEnabled-           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)-       -- This write barrier is to ensure that the heap writes to the object-       -- referred to by val have happened before we write val into the array.-       -- See #12469 for details.-       emitPrimCall [] MO_WriteBarrier []-       mkBasicIndexedWrite hdr_size Nothing addr ty idx val-       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))-       -- the write barrier.  We must write a byte into the mark table:-       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]-       emit $ mkStore (-         cmmOffsetExpr platform-          (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)-                         (loadArrPtrsSize dflags addr))-          (CmmMachOp (mo_wordUShr platform) [idx,-                                           mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags)])-         ) (CmmLit (CmmInt 1 W8))--loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr-loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)- where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags-       platform = targetPlatform dflags--mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes-                   -> Maybe MachOp -- Optional result cast-                   -> CmmType      -- Type of element we are accessing-                   -> LocalReg     -- Destination-                   -> CmmExpr      -- Base address-                   -> CmmType      -- Type of element by which we are indexing-                   -> CmmExpr      -- Index-                   -> FCode ()-mkBasicIndexedRead off Nothing ty res base idx_ty idx-   = do platform <- getPlatform-        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx)-mkBasicIndexedRead off (Just cast) ty res base idx_ty idx-   = do platform <- getPlatform-        emitAssign (CmmLocal res) (CmmMachOp cast [-                                   cmmLoadIndexOffExpr platform off ty base idx_ty idx])--mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes-                    -> Maybe MachOp -- Optional value cast-                    -> CmmExpr      -- Base address-                    -> CmmType      -- Type of element by which we are indexing-                    -> CmmExpr      -- Index-                    -> CmmExpr      -- Value to write-                    -> FCode ()-mkBasicIndexedWrite off Nothing base idx_ty idx val-   = do platform <- getPlatform-        emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val-mkBasicIndexedWrite off (Just cast) base idx_ty idx val-   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])---- ------------------------------------------------------------------------------- Misc utils--cmmIndexOffExpr :: Platform-                -> ByteOff  -- Initial offset in bytes-                -> Width    -- Width of element by which we are indexing-                -> CmmExpr  -- Base address-                -> CmmExpr  -- Index-                -> CmmExpr-cmmIndexOffExpr platform off width base idx-   = cmmIndexExpr platform width (cmmOffsetB platform base off) idx--cmmLoadIndexOffExpr :: Platform-                    -> ByteOff  -- Initial offset in bytes-                    -> CmmType  -- Type of element we are accessing-                    -> CmmExpr  -- Base address-                    -> CmmType  -- Type of element by which we are indexing-                    -> CmmExpr  -- Index-                    -> CmmExpr-cmmLoadIndexOffExpr platform off ty base idx_ty idx-   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty--setInfo :: CmmExpr -> CmmExpr -> CmmAGraph-setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr----------------------------------------------------------------------------------- Helpers for translating vector primops.--vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType-vecVmmType pocat n w = vec n (vecCmmCat pocat w)--vecCmmCat :: PrimOpVecCat -> Width -> CmmType-vecCmmCat IntVec   = cmmBits-vecCmmCat WordVec  = cmmBits-vecCmmCat FloatVec = cmmFloat--vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemInjectCast _        FloatVec _   =  Nothing-vecElemInjectCast platform   IntVec   W8  =  Just (mo_WordTo8  platform)-vecElemInjectCast platform   IntVec   W16 =  Just (mo_WordTo16 platform)-vecElemInjectCast platform   IntVec   W32 =  Just (mo_WordTo32 platform)-vecElemInjectCast _        IntVec   W64 =  Nothing-vecElemInjectCast platform   WordVec  W8  =  Just (mo_WordTo8  platform)-vecElemInjectCast platform   WordVec  W16 =  Just (mo_WordTo16 platform)-vecElemInjectCast platform   WordVec  W32 =  Just (mo_WordTo32 platform)-vecElemInjectCast _        WordVec  W64 =  Nothing-vecElemInjectCast _        _        _   =  Nothing--vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemProjectCast _        FloatVec _   =  Nothing-vecElemProjectCast platform   IntVec   W8  =  Just (mo_s_8ToWord  platform)-vecElemProjectCast platform   IntVec   W16 =  Just (mo_s_16ToWord platform)-vecElemProjectCast platform   IntVec   W32 =  Just (mo_s_32ToWord platform)-vecElemProjectCast _        IntVec   W64 =  Nothing-vecElemProjectCast platform   WordVec  W8  =  Just (mo_u_8ToWord  platform)-vecElemProjectCast platform   WordVec  W16 =  Just (mo_u_16ToWord platform)-vecElemProjectCast platform   WordVec  W32 =  Just (mo_u_32ToWord platform)-vecElemProjectCast _        WordVec  W64 =  Nothing-vecElemProjectCast _        _        _   =  Nothing----- NOTE [SIMD Design for the future]--- Check to make sure that we can generate code for the specified vector type--- given the current set of dynamic flags.--- Currently these checks are specific to x86 and x86_64 architecture.--- This should be fixed!--- In particular,--- 1) Add better support for other architectures! (this may require a redesign)--- 2) Decouple design choices from LLVM's pseudo SIMD model!---   The high level LLVM naive rep makes per CPU family SIMD generation is own---   optimization problem, and hides important differences in eg ARM vs x86_64 simd--- 3) Depending on the architecture, the SIMD registers may also support general---    computations on Float/Double/Word/Int scalars, but currently on---    for example x86_64, we always put Word/Int (or sized) in GPR---    (general purpose) registers. Would relaxing that allow for---    useful optimization opportunities?---      Phrased differently, it is worth experimenting with supporting---    different register mapping strategies than we currently have, especially if---    someday we want SIMD to be a first class denizen in GHC along with scalar---    values!---      The current design with respect to register mapping of scalars could---    very well be the best,but exploring the  design space and doing careful---    measurements is the only way to validate that.---      In some next generation CPU ISAs, notably RISC V, the SIMD extension---    includes  support for a sort of run time CPU dependent vectorization parameter,---    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...---    element chunk! Time will tell if that direction sees wide adoption,---    but it is from that context that unifying our handling of simd and scalars---    may benefit. It is not likely to benefit current architectures, though---    it may very well be a design perspective that helps guide improving the NCG.---checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()-checkVecCompatibility dflags vcat l w = do-    when (hscTarget dflags /= HscLlvm) $ do-        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."-                         ,"Please use -fllvm."]-    check vecWidth vcat l w-  where-    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()-    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =-        sorry $ "128-bit wide single-precision floating point " ++-                "SIMD vector instructions require at least -msse."-    check W128 _ _ _ | not (isSse2Enabled dflags) =-        sorry $ "128-bit wide integer and double precision " ++-                "SIMD vector instructions require at least -msse2."-    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =-        sorry $ "256-bit wide floating point " ++-                "SIMD vector instructions require at least -mavx."-    check W256 _ _ _ | not (isAvx2Enabled dflags) =-        sorry $ "256-bit wide integer " ++-                "SIMD vector instructions require at least -mavx2."-    check W512 _ _ _ | not (isAvx512fEnabled dflags) =-        sorry $ "512-bit wide " ++-                "SIMD vector instructions require -mavx512f."-    check _ _ _ _ = return ()--    vecWidth = typeWidth (vecVmmType vcat l w)----------------------------------------------------------------------------------- Helpers for translating vector packing and unpacking.--doVecPackOp :: Maybe MachOp  -- Cast from element to vector component-            -> CmmType       -- Type of vector-            -> CmmExpr       -- Initial vector-            -> [CmmExpr]     -- Elements-            -> CmmFormal     -- Destination for result-            -> FCode ()-doVecPackOp maybe_pre_write_cast ty z es res = do-    dst <- newTemp ty-    emitAssign (CmmLocal dst) z-    vecPack dst es 0-  where-    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()-    vecPack src [] _ =-        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))--    vecPack src (e : es) i = do-        dst <- newTemp ty-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])-          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])-        vecPack dst es (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result-              -> CmmType       -- Type of vector-              -> CmmExpr       -- Vector-              -> [CmmFormal]   -- Element results-              -> FCode ()-doVecUnpackOp maybe_post_read_cast ty e res =-    vecUnpack res 0-  where-    vecUnpack :: [CmmFormal] -> Int -> FCode ()-    vecUnpack [] _ =-        return ()--    vecUnpack (r : rs) i = do-        if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)-                                             [e, iLit]))-          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)-                                             [e, iLit]))-        vecUnpack rs (i + 1)-      where-        -- vector indices are always 32-bits-        iLit = CmmLit (CmmInt (toInteger i) W32)--    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_post_read_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)--doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component-              -> CmmType       -- Vector type-              -> CmmExpr       -- Source vector-              -> CmmExpr       -- Element-              -> CmmExpr       -- Index at which to insert element-              -> CmmFormal     -- Destination for result-              -> FCode ()-doVecInsertOp maybe_pre_write_cast ty src e idx res = do-    platform <- getPlatform-    -- vector indices are always 32-bits-    let idx' :: CmmExpr-        idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]-    if isFloatType (vecElemType ty)-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])-  where-    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]--    len :: Length-    len = vecLength ty--    wid :: Width-    wid = typeWidth (vecElemType ty)----------------------------------------------------------------------------------- Helpers for translating prefetching.----- | Translate byte array prefetch operations into proper primcalls.-doPrefetchByteArrayOp :: Int-                      -> [CmmExpr]-                      -> FCode ()-doPrefetchByteArrayOp locality  [addr,idx]-   = do dflags <- getDynFlags-        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx-doPrefetchByteArrayOp _ _-   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"---- | Translate mutable byte array prefetch operations into proper primcalls.-doPrefetchMutableByteArrayOp :: Int-                      -> [CmmExpr]-                      -> FCode ()-doPrefetchMutableByteArrayOp locality  [addr,idx]-   = do dflags <- getDynFlags-        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx-doPrefetchMutableByteArrayOp _ _-   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"---- | Translate address prefetch operations into proper primcalls.-doPrefetchAddrOp ::Int-                 -> [CmmExpr]-                 -> FCode ()-doPrefetchAddrOp locality   [addr,idx]-   = mkBasicPrefetch locality 0  addr idx-doPrefetchAddrOp _ _-   = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp"---- | Translate value prefetch operations into proper primcalls.-doPrefetchValueOp :: Int-                 -> [CmmExpr]-                 -> FCode ()-doPrefetchValueOp  locality   [addr]-  =  do platform <- getPlatform-        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth platform)))-doPrefetchValueOp _ _-  = panic "GHC.StgToCmm.Prim: doPrefetchValueOp"---- | helper to generate prefetch primcalls-mkBasicPrefetch :: Int          -- Locality level 0-3-                -> ByteOff      -- Initial offset in bytes-                -> CmmExpr      -- Base address-                -> CmmExpr      -- Index-                -> FCode ()-mkBasicPrefetch locality off base idx-   = do platform <- getPlatform-        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx]-        return ()---- ------------------------------------------------------------------------------- Allocating byte arrays---- | Takes a register to return the newly allocated array in and the--- size of the new array in bytes. Allocates a new--- 'MutableByteArray#'.-doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()-doNewByteArrayOp res_r n = do-    dflags <- getDynFlags-    platform <- getPlatform--    let info_ptr = mkLblExpr mkArrWords_infoLabel-        rep = arrWordsRep platform n--    tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize dflags))-        (mkIntExpr platform (nonHdrSize platform rep))-        (zeroExpr platform)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr platform n,-                        hdr_size + oFFSET_StgArrBytes_bytes dflags)-                     ]--    emit $ mkAssign (CmmLocal res_r) base---- ------------------------------------------------------------------------------- Comparing byte arrays--doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                     -> FCode ()-doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do-    dflags <- getDynFlags-    platform <- getPlatform-    ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize dflags)) ba1_off-    ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize dflags)) ba2_off--    -- short-cut in case of equal pointers avoiding a costly-    -- subroutine call to the memcmp(3) routine; the Cmm logic below-    -- results in assembly code being generated for-    ---    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#-    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#-    ---    -- that looks like-    ---    --          leaq 16(%r14),%rax-    --          leaq 16(%rsi),%rbx-    --          xorl %ecx,%ecx-    --          cmpq %rbx,%rax-    --          je l_ptr_eq-    ---    --          ; NB: the common case (unequal pointers) falls-through-    --          ; the conditional jump, and therefore matches the-    --          ; usual static branch prediction convention of modern cpus-    ---    --          subq $8,%rsp-    --          movq %rbx,%rsi-    --          movq %rax,%rdi-    --          movl $10,%edx-    --          xorl %eax,%eax-    --          call memcmp-    --          addq $8,%rsp-    --          movslq %eax,%rax-    --          movq %rax,%rcx-    --  l_ptr_eq:-    --          movq %rcx,%rbx-    --          jmp *(%rbp)--    l_ptr_eq <- newBlockId-    l_ptr_ne <- newBlockId--    emit (mkAssign (CmmLocal res) (zeroExpr platform))-    emit (mkCbranch (cmmEqWord platform ba1_p ba2_p)-                    l_ptr_eq l_ptr_ne (Just False))--    emitLabel l_ptr_ne-    emitMemcmpCall res ba1_p ba2_p n 1--    emitLabel l_ptr_eq---- ------------------------------------------------------------------------------- Copying byte arrays---- | Takes a source 'ByteArray#', an offset in the source array, a--- destination 'MutableByteArray#', an offset into the destination--- array, and the number of bytes to copy.  Copies the given number of--- bytes from the source array to the destination array.-doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                  -> FCode ()-doCopyByteArrayOp = emitCopyByteArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes align =-        emitMemcpyCall dst_p src_p bytes align---- | Takes a source 'MutableByteArray#', an offset in the source--- array, a destination 'MutableByteArray#', an offset into the--- destination array, and the number of bytes to copy.  Copies the--- given number of bytes from the source array to the destination--- array.-doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                         -> FCode ()-doCopyMutableByteArrayOp = emitCopyByteArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes align = do-        platform <- getPlatform-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p bytes align)-            (getCode $ emitMemcpyCall  dst_p src_p bytes align)-        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall--emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                      -> Alignment -> FCode ())-                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                  -> FCode ()-emitCopyByteArray copy src src_off dst dst_off n = do-    dflags <- getDynFlags-    platform <- getPlatform-    let byteArrayAlignment = wordAlignment platform-        srcOffAlignment = cmmExprAlignment src_off-        dstOffAlignment = cmmExprAlignment dst_off-        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]-    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off-    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off-    copy src dst dst_p src_p n align---- | Takes a source 'ByteArray#', an offset in the source array, a--- destination 'Addr#', and the number of bytes to copy.  Copies the given--- number of bytes from the source array to the destination memory region.-doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-doCopyByteArrayToAddrOp src src_off dst_p bytes = do-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)-    dflags <- getDynFlags-    platform <- getPlatform-    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize dflags)) src_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)---- | Takes a source 'MutableByteArray#', an offset in the source array, a--- destination 'Addr#', and the number of bytes to copy.  Copies the given--- number of bytes from the source array to the destination memory region.-doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                               -> FCode ()-doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp---- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into--- the destination array, and the number of bytes to copy.  Copies the given--- number of bytes from the source memory region to the destination array.-doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()-doCopyAddrToByteArrayOp src_p dst dst_off bytes = do-    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)-    dflags <- getDynFlags-    platform <- getPlatform-    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize dflags)) dst_off-    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)----- ------------------------------------------------------------------------------- Setting byte arrays---- | Takes a 'MutableByteArray#', an offset into the array, a length,--- and a byte, and sets each of the selected bytes in the array to the--- character.-doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr-                 -> FCode ()-doSetByteArrayOp ba off len c = do-    dflags <- getDynFlags-    platform <- getPlatform--    let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap-        offsetAlignment = cmmExprAlignment off-        align = min byteArrayAlignment offsetAlignment--    p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize dflags)) off-    emitMemsetCall p c len align---- ------------------------------------------------------------------------------- Allocating arrays---- | Allocate a new array.-doNewArrayOp :: CmmFormal             -- ^ return register-             -> SMRep                 -- ^ representation of the array-             -> CLabel                -- ^ info pointer-             -> [(CmmExpr, ByteOff)]  -- ^ header payload-             -> WordOff               -- ^ array size-             -> CmmExpr               -- ^ initial element-             -> FCode ()-doNewArrayOp res_r rep info payload n init = do-    dflags <- getDynFlags-    platform <- getPlatform--    let info_ptr = mkLblExpr info--    tickyAllocPrim (mkIntExpr platform (hdrSize dflags rep))-        (mkIntExpr platform (nonHdrSize platform rep))-        (zeroExpr platform)--    base <- allocHeapClosure rep info_ptr cccsExpr payload--    arr <- CmmLocal `fmap` newTemp (bWord platform)-    emit $ mkAssign arr base--    -- Initialise all elements of the array-    let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW dflags rep + off)-        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]-    emit (catAGraphs initialization)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- ------------------------------------------------------------------------------- Copying pointer arrays---- EZY: This code has an unusually high amount of assignTemp calls, seen--- nowhere else in the code generator.  This is mostly because these--- "primitive" ops result in a surprisingly large amount of code.  It--- will likely be worthwhile to optimize what is emitted here, so that--- our optimization passes don't waste time repeatedly optimizing the--- same bits of code.---- More closely imitates 'assignTemp' from the old code generator, which--- returns a CmmExpr rather than a LocalReg.-assignTempE :: CmmExpr -> FCode CmmExpr-assignTempE e = do-    t <- assignTemp e-    return (CmmReg (CmmLocal t))---- | Takes a source 'Array#', an offset in the source array, a--- destination 'MutableArray#', an offset into the destination array,--- and the number of elements to copy.  Copies the given number of--- elements from the source array to the destination array.-doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-              -> FCode ()-doCopyArrayOp = emitCopyArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        do platform <- getPlatform-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)-               (wordAlignment platform)----- | Takes a source 'MutableArray#', an offset in the source array, a--- destination 'MutableArray#', an offset into the destination array,--- and the number of elements to copy.  Copies the given number of--- elements from the source array to the destination array.-doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                     -> FCode ()-doCopyMutableArrayOp = emitCopyArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        platform <- getPlatform-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)-             (wordAlignment platform))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)-             (wordAlignment platform))-        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall--emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff-                  -> FCode ())  -- ^ copy function-              -> CmmExpr        -- ^ source array-              -> CmmExpr        -- ^ offset in source array-              -> CmmExpr        -- ^ destination array-              -> CmmExpr        -- ^ offset in destination array-              -> WordOff        -- ^ number of elements to copy-              -> FCode ()-emitCopyArray copy src0 src_off dst0 dst_off0 n =-    when (n /= 0) $ do-        dflags <- getDynFlags-        platform <- getPlatform--        -- Passed as arguments (be careful)-        src     <- assignTempE src0-        dst     <- assignTempE dst0-        dst_off <- assignTempE dst_off0--        -- Nonmoving collector write barrier-        emitCopyUpdRemSetPush platform (arrPtrsHdrSize dflags) dst dst_off n--        -- Set the dirty bit in the header.-        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))--        dst_elems_p <- assignTempE $ cmmOffsetB platform dst-                       (arrPtrsHdrSize dflags)-        dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off-        src_p <- assignTempE $ cmmOffsetExprW platform-                 (cmmOffsetB platform src (arrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes platform n--        copy src dst dst_p src_p bytes--        -- The base address of the destination card table-        dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p-                       (loadArrPtrsSize dflags dst)--        emitSetCards dst_off dst_cards_p n--doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                   -> FCode ()-doCopySmallArrayOp = emitCopySmallArray copy-  where-    -- Copy data (we assume the arrays aren't overlapping since-    -- they're of different types)-    copy _src _dst dst_p src_p bytes =-        do platform <- getPlatform-           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)-               (wordAlignment platform)---doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff-                          -> FCode ()-doCopySmallMutableArrayOp = emitCopySmallArray copy-  where-    -- The only time the memory might overlap is when the two arrays-    -- we were provided are the same array!-    -- TODO: Optimize branch for common case of no aliasing.-    copy src dst dst_p src_p bytes = do-        platform <- getPlatform-        (moveCall, cpyCall) <- forkAltPair-            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)-             (wordAlignment platform))-            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)-             (wordAlignment platform))-        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall--emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff-                       -> FCode ())  -- ^ copy function-                   -> CmmExpr        -- ^ source array-                   -> CmmExpr        -- ^ offset in source array-                   -> CmmExpr        -- ^ destination array-                   -> CmmExpr        -- ^ offset in destination array-                   -> WordOff        -- ^ number of elements to copy-                   -> FCode ()-emitCopySmallArray copy src0 src_off dst0 dst_off n =-    when (n /= 0) $ do-        dflags <- getDynFlags-        platform <- getPlatform--        -- Passed as arguments (be careful)-        src     <- assignTempE src0-        dst     <- assignTempE dst0--        -- Nonmoving collector write barrier-        emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize dflags) dst dst_off n--        -- Set the dirty bit in the header.-        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))--        dst_p <- assignTempE $ cmmOffsetExprW platform-                 (cmmOffsetB platform dst (smallArrPtrsHdrSize dflags)) dst_off-        src_p <- assignTempE $ cmmOffsetExprW platform-                 (cmmOffsetB platform src (smallArrPtrsHdrSize dflags)) src_off-        let bytes = wordsToBytes platform n--        copy src dst dst_p src_p bytes---- | Takes an info table label, a register to return the newly--- allocated array in, a source array, an offset in the source array,--- and the number of elements to copy. Allocates a new array and--- initializes it from the source array.-emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff-               -> FCode ()-emitCloneArray info_p res_r src src_off n = do-    dflags <- getDynFlags-    platform <- getPlatform--    let info_ptr = mkLblExpr info_p-        rep = arrPtrsRep dflags n--    tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize dflags))-        (mkIntExpr platform (nonHdrSize platform rep))-        (zeroExpr platform)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr platform n,-                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)-                     , (mkIntExpr platform (nonHdrSizeW rep),-                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)-                     ]--    arr <- CmmLocal `fmap` newTemp (bWord platform)-    emit $ mkAssign arr base--    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)-             (arrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW platform src-             (cmmAddWord platform-              (mkIntExpr platform (arrPtrsHdrSizeW dflags)) src_off)--    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))-        (wordAlignment platform)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- | Takes an info table label, a register to return the newly--- allocated array in, a source array, an offset in the source array,--- and the number of elements to copy. Allocates a new array and--- initializes it from the source array.-emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff-                    -> FCode ()-emitCloneSmallArray info_p res_r src src_off n = do-    dflags <- getDynFlags-    platform <- getPlatform--    let info_ptr = mkLblExpr info_p-        rep = smallArrPtrsRep n--    tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize dflags))-        (mkIntExpr platform (nonHdrSize platform rep))-        (zeroExpr platform)--    let hdr_size = fixedHdrSize dflags--    base <- allocHeapClosure rep info_ptr cccsExpr-                     [ (mkIntExpr platform n,-                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)-                     ]--    arr <- CmmLocal `fmap` newTemp (bWord platform)-    emit $ mkAssign arr base--    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)-             (smallArrPtrsHdrSize dflags)-    src_p <- assignTempE $ cmmOffsetExprW platform src-             (cmmAddWord platform-              (mkIntExpr platform (smallArrPtrsHdrSizeW dflags)) src_off)--    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))-        (wordAlignment platform)--    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)---- | Takes and offset in the destination array, the base address of--- the card table, and the number of elements affected (*not* the--- number of cards). The number of elements may not be zero.--- Marks the relevant cards as dirty.-emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()-emitSetCards dst_start dst_cards_start n = do-    dflags <- getDynFlags-    platform <- getPlatform-    start_card <- assignTempE $ cardCmm dflags dst_start-    let end_card = cardCmm dflags-                   (cmmSubWord platform-                    (cmmAddWord platform dst_start (mkIntExpr platform n))-                    (mkIntExpr platform 1))-    emitMemsetCall (cmmAddWord platform dst_cards_start start_card)-        (mkIntExpr platform 1)-        (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1))-        (mkAlignment 1) -- no alignment (1 byte)---- Convert an element index to a card index-cardCmm :: DynFlags -> CmmExpr -> CmmExpr-cardCmm dflags i =-    cmmUShrWord platform i (mkIntExpr platform (mUT_ARR_PTRS_CARD_BITS dflags))-    where platform = targetPlatform dflags----------------------------------------------------------------------------------- SmallArray PrimOp implementations--doReadSmallPtrArrayOp :: LocalReg-                      -> CmmExpr-                      -> CmmExpr-                      -> FCode ()-doReadSmallPtrArrayOp res addr idx = do-    dflags <- getDynFlags-    platform <- getPlatform-    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord platform) res addr-        (gcWord platform) idx--doWriteSmallPtrArrayOp :: CmmExpr-                       -> CmmExpr-                       -> CmmExpr-                       -> FCode ()-doWriteSmallPtrArrayOp addr idx val = do-    dflags <- getDynFlags-    platform <- getPlatform-    let ty = cmmExprType platform val--    -- Update remembered set for non-moving collector-    tmp <- newTemp ty-    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing ty tmp addr ty idx-    whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))--    emitPrimCall [] MO_WriteBarrier [] -- #12469-    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val-    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))----------------------------------------------------------------------------------- Atomic read-modify-write---- | Emit an atomic modification to a byte array element. The result--- reg contains that previous value of the element. Implies a full--- memory barrier.-doAtomicRMW :: LocalReg      -- ^ Result reg-            -> AtomicMachOp  -- ^ Atomic op (e.g. add)-            -> CmmExpr       -- ^ MutableByteArray#-            -> CmmExpr       -- ^ Index-            -> CmmType       -- ^ Type of element by which we are indexing-            -> CmmExpr       -- ^ Op argument (e.g. amount to add)-            -> FCode ()-doAtomicRMW res amop mba idx idx_ty n = do-    dflags <- getDynFlags-    platform <- getPlatform-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr platform (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ res ]-        (MO_AtomicRMW width amop)-        [ addr, n ]---- | Emit an atomic read to a byte array that acts as a memory barrier.-doAtomicReadByteArray-    :: LocalReg  -- ^ Result reg-    -> CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> FCode ()-doAtomicReadByteArray res mba idx idx_ty = do-    dflags <- getDynFlags-    platform <- getPlatform-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr platform (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ res ]-        (MO_AtomicRead width)-        [ addr ]---- | Emit an atomic write to a byte array that acts as a memory barrier.-doAtomicWriteByteArray-    :: CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> CmmExpr   -- ^ Value to write-    -> FCode ()-doAtomicWriteByteArray mba idx idx_ty val = do-    dflags <- getDynFlags-    platform <- getPlatform-    let width = typeWidth idx_ty-        addr  = cmmIndexOffExpr platform (arrWordsHdrSize dflags)-                width mba idx-    emitPrimCall-        [ {- no results -} ]-        (MO_AtomicWrite width)-        [ addr, val ]--doCasByteArray-    :: LocalReg  -- ^ Result reg-    -> CmmExpr   -- ^ MutableByteArray#-    -> CmmExpr   -- ^ Index-    -> CmmType   -- ^ Type of element by which we are indexing-    -> CmmExpr   -- ^ Old value-    -> CmmExpr   -- ^ New value-    -> FCode ()-doCasByteArray res mba idx idx_ty old new = do-    dflags <- getDynFlags-    platform <- getPlatform-    let width = (typeWidth idx_ty)-        addr = cmmIndexOffExpr platform (arrWordsHdrSize dflags)-               width mba idx-    emitPrimCall-        [ res ]-        (MO_Cmpxchg width)-        [ addr, old, new ]----------------------------------------------------------------------------------- Helpers for emitting function calls---- | Emit a call to @memcpy@.-emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemcpyCall dst src n align = do-    emitPrimCall-        [ {-no results-} ]-        (MO_Memcpy (alignmentBytes align))-        [ dst, src, n ]---- | Emit a call to @memmove@.-emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemmoveCall dst src n align = do-    emitPrimCall-        [ {- no results -} ]-        (MO_Memmove (alignmentBytes align))-        [ dst, src, n ]---- | Emit a call to @memset@.  The second argument must fit inside an--- unsigned char.-emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()-emitMemsetCall dst c n align = do-    emitPrimCall-        [ {- no results -} ]-        (MO_Memset (alignmentBytes align))-        [ dst, c, n ]--emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()-emitMemcmpCall res ptr1 ptr2 n align = do-    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all-    -- code-gens currently call out to the @memcmp(3)@ C function.-    -- This was easier than moving the sign-extensions into-    -- all the code-gens.-    platform <- getPlatform-    let is32Bit = typeWidth (localRegType res) == W32--    cres <- if is32Bit-              then return res-              else newTemp b32--    emitPrimCall-        [ cres ]-        (MO_Memcmp align)-        [ ptr1, ptr2, n ]--    unless is32Bit $ do-      emit $ mkAssign (CmmLocal res)-                      (CmmMachOp-                         (mo_s_32ToWord platform)-                         [(CmmReg (CmmLocal cres))])--emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBSwapCall res x width = do-    emitPrimCall-        [ res ]-        (MO_BSwap width)-        [ x ]--emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitBRevCall res x width = do-    emitPrimCall-        [ res ]-        (MO_BRev width)-        [ x ]--emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitPopCntCall res x width = do-    emitPrimCall-        [ res ]-        (MO_PopCnt width)-        [ x ]--emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPdepCall res x y width = do-    emitPrimCall-        [ res ]-        (MO_Pdep width)-        [ x, y ]--emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()-emitPextCall res x y width = do-    emitPrimCall-        [ res ]-        (MO_Pext width)-        [ x, y ]--emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitClzCall res x width = do-    emitPrimCall-        [ res ]-        (MO_Clz width)-        [ x ]--emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()-emitCtzCall res x width = do++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module GHC.StgToCmm.Prim (+   cgOpApp,+   shouldInlinePrimOp+ ) where++#include "HsVersions.h"+#include "MachDeps.h"++import GHC.Prelude hiding ((<*>))++import GHC.Platform+import GHC.Platform.Profile++import GHC.StgToCmm.Layout+import GHC.StgToCmm.Foreign+import GHC.StgToCmm.Env+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils+import GHC.StgToCmm.Ticky+import GHC.StgToCmm.Heap+import GHC.StgToCmm.Prof ( costCentreFrom )++import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Cmm.Graph+import GHC.Stg.Syntax+import GHC.Cmm+import GHC.Unit         ( rtsUnit )+import GHC.Core.Type    ( Type, tyConAppTyCon )+import GHC.Core.TyCon+import GHC.Cmm.CLabel+import GHC.Cmm.Utils+import GHC.Builtin.PrimOps+import GHC.Runtime.Heap.Layout+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Utils.Panic+import Data.Maybe++import Control.Monad (liftM, when, unless)++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall ty) stg_args res_ty+  = cgForeignCall fcall ty stg_args res_ty+      -- Note [Foreign call results]++cgOpApp (StgPrimOp primop) args res_ty = do+    dflags <- getDynFlags+    cmm_args <- getNonVoidArgAmodes args+    cmmPrimOpApp dflags primop cmm_args (Just res_ty)++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++cmmPrimOpApp :: DynFlags -> PrimOp -> [CmmExpr] -> Maybe Type -> FCode ReturnKind+cmmPrimOpApp dflags primop cmm_args mres_ty =+  case emitPrimOp dflags primop cmm_args of+    PrimopCmmEmit_Internal f ->+      let+         -- if the result type isn't explicitly given, we directly use the+         -- result type of the primop.+         res_ty = fromMaybe (primOpResultType primop) mres_ty+      in emitReturn =<< f res_ty+    PrimopCmmEmit_External -> do+      let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+      emitCall (NativeNodeCall, NativeReturn) fun cmm_args+++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++shouldInlinePrimOp :: DynFlags -> PrimOp -> [CmmExpr] -> Bool+shouldInlinePrimOp dflags op args = case emitPrimOp dflags op args of+  PrimopCmmEmit_External -> False+  PrimopCmmEmit_Internal _ -> True++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+-- ByteOff (or some other fixed width signed type) to represent+-- array sizes or indices. This means that these will overflow for+-- large enough sizes.++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++-- | The big function handling all the primops.+--+-- In the simple case, there is just one implementation, and we emit that.+--+-- In more complex cases, there is a foreign call (out of line) fallback. This+-- might happen e.g. if there's enough static information, such as statically+-- know arguments.+emitPrimOp+  :: DynFlags+  -> PrimOp            -- ^ The primop+  -> [CmmExpr]         -- ^ The primop arguments+  -> PrimopCmmEmit+emitPrimOp dflags primop = case primop of+  NewByteArrayOp_Char -> \case+    [(CmmLit (CmmInt n w))]+      | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs  $ \ [res] -> doNewByteArrayOp res (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \[res] -> doNewArrayOp res (arrPtrsRep platform (fromInteger n)) mkMAP_DIRTY_infoLabel+        [ (mkIntExpr platform (fromInteger n),+           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform))+        , (mkIntExpr platform (nonHdrSizeW (arrPtrsRep platform (fromInteger n))),+           fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_size (platformConstants platform))+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopyArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopyMutableArrayArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  NewSmallArrayOp -> \case+    [(CmmLit (CmmInt n w)), init]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] ->+        doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+        [ (mkIntExpr platform (fromInteger n),+           fixedHdrSize profile + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))+        ]+        (fromInteger n) init+    _ -> PrimopCmmEmit_External++  CopySmallArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CopySmallMutableArrayOp -> \case+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] ->+      opIntoRegs $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  CloneSmallMutableArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  FreezeSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++  ThawSmallArrayOp -> \case+    [src, src_off, (CmmLit (CmmInt n w))]+      | wordsToBytes platform (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags)+      -> opIntoRegs $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)+    _ -> PrimopCmmEmit_External++-- First we handle various awkward cases specially.++  ParOp -> \[arg] -> opIntoRegs $ \[res] ->+    -- for now, just implement this in a C function+    -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), (arg,AddrHint)]++  SparkOp -> \[arg] -> opIntoRegs $ \[res] -> do+    -- returns the value of arg in res.  We're going to therefore+    -- refer to arg twice (once to pass to newSpark(), and once to+    -- assign to res), so put it in a temporary.+    tmp <- assignTemp arg+    tmp2 <- newTemp (bWord platform)+    emitCCall+        [(tmp2,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+    emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++  GetCCSOfOp -> \[arg] -> opIntoRegs $ \[res] -> do+    let+      val+       | profileIsProfiling profile = costCentreFrom platform (cmmUntag platform arg)+       | otherwise                  = CmmLit (zeroCLit platform)+    emitAssign (CmmLocal res) val++  GetCurrentCCSOp -> \[_] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) cccsExpr++  MyThreadIdOp -> \[] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) currentTSOExpr++  ReadMutVarOp -> \[mutv] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform))++  WriteMutVarOp -> \[mutv, var] -> opIntoRegs $ \res@[] -> do+    old_val <- CmmLocal <$> newTemp (cmmExprType platform var)+    emitAssign old_val (cmmLoadIndexW platform mutv (fixedHdrSizeW profile) (gcWord platform))++    -- Without this write barrier, other CPUs may see this pointer before+    -- the writes for the closure it points to have occurred.+    -- Note that this also must come after we read the old value to ensure+    -- that the read of old_val comes before another core's write to the+    -- MutVar's value.+    emitPrimCall res MO_WriteBarrier []+    emitStore (cmmOffsetW platform mutv (fixedHdrSizeW profile)) var+    emitCCall+            [{-no results-}]+            (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+            [(baseExpr, AddrHint), (mutv, AddrHint), (CmmReg old_val, AddrHint)]++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+  SizeofByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  SizeofMutableByteArrayOp -> emitPrimOp dflags SizeofByteArrayOp++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+  GetSizeofMutableByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))+++--  #define touchzh(o)                  /* nothing */+  TouchOp -> \args@[_] -> opIntoRegs $ \res@[] ->+    emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  ByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))++--  #define mutableByteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+  MutableByteArrayContents_Char -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmOffsetB platform arg (arrWordsHdrSize profile))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+  StableNameToIntOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (cmmLoadIndexW platform arg (fixedHdrSizeW profile) (bWord platform))++  ReallyUnsafePtrEqualityOp -> \[arg1, arg2] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq platform) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+  AddrToAnyOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+  AnyToAddrOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);+--        r = a;+--      }+  UnsafeFreezeArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeArrayArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]+  UnsafeFreezeSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ catAGraphs+      [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+        mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+  UnsafeFreezeByteArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++  ReadArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  IndexArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  WriteArrayOp -> \[obj, ix, v] -> opIntoRegs $ \[] ->+    doWritePtrArrayOp obj ix v++  IndexArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  IndexArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableByteArray -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_ArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  ReadArrayArrayOp_MutableArrayArray -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadPtrArrayOp res obj ix+  WriteArrayArrayOp_ByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableByteArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_ArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->+    doWritePtrArrayOp obj ix v+  WriteArrayArrayOp_MutableArrayArray -> \[obj,ix,v] -> opIntoRegs $ \[] ->+    doWritePtrArrayOp obj ix v++  ReadSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadSmallPtrArrayOp res obj ix+  IndexSmallArrayOp -> \[obj, ix] -> opIntoRegs $ \[res] ->+    doReadSmallPtrArrayOp res obj ix+  WriteSmallArrayOp -> \[obj,ix,v] -> opIntoRegs $ \[] ->+    doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++  SizeofArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ mkAssign (CmmLocal res) (cmmLoadIndexW platform arg+      (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgMutArrPtrs_ptrs (platformConstants platform)))+        (bWord platform))+  SizeofMutableArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofMutableArrayArrayOp -> emitPrimOp dflags SizeofArrayOp+  SizeofSmallArrayOp -> \[arg] -> opIntoRegs $ \[res] ->+    emit $ mkAssign (CmmLocal res)+     (cmmLoadIndexW platform arg+     (fixedHdrSizeW profile + bytesToWordsRoundUp platform (pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform)))+        (bWord platform))++  SizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp+  GetSizeofSmallMutableArrayOp -> emitPrimOp dflags SizeofSmallArrayOp++-- IndexXXXoffAddr++  IndexOffAddrOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args+  IndexOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args+  IndexOffAddrOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f32 res args+  IndexOffAddrOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f64 res args+  IndexOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  IndexOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  IndexOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  IndexOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  IndexOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args+  IndexOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  IndexOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  IndexOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  IndexOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++  ReadOffAddrOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_8ToWord platform)) b8 res args+  ReadOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   (Just (mo_u_32ToWord platform)) b32 res args+  ReadOffAddrOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f32 res args+  ReadOffAddrOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing f64 res args+  ReadOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing (bWord platform) res args+  ReadOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  ReadOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  ReadOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  ReadOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args+  ReadOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b8  res args+  ReadOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b16 res args+  ReadOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b32 res args+  ReadOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++  IndexByteArrayOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args+  IndexByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args+  IndexByteArrayOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f32 res args+  IndexByteArrayOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f64 res args+  IndexByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  IndexByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  IndexByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  IndexByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  IndexByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args+  IndexByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  IndexByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  IndexByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  IndexByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++  ReadByteArrayOp_Char -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_8ToWord platform)) b8 res args+  ReadByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   (Just (mo_u_32ToWord platform)) b32 res args+  ReadByteArrayOp_Int -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Word -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Float -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f32 res args+  ReadByteArrayOp_Double -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing f64 res args+  ReadByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing (bWord platform) res args+  ReadByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  ReadByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  ReadByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  ReadByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args+  ReadByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b8  res args+  ReadByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b16  res args+  ReadByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b32  res args+  ReadByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++  IndexByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args+  IndexByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args+  IndexByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  IndexByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  IndexByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  IndexByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  IndexByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  IndexByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  IndexByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  IndexByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  IndexByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++  ReadByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_8ToWord platform)) b8 b8 res args+  ReadByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   (Just (mo_u_32ToWord platform)) b32 b8 res args+  ReadByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f32 b8 res args+  ReadByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing f64 b8 res args+  ReadByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing (bWord platform) b8 res args+  ReadByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  ReadByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  ReadByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args+  ReadByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b16 b8 res args+  ReadByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b32 b8 res args+  ReadByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++  WriteOffAddrOp_Char -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp (Just (mo_WordTo8 platform))  b8 res args+  WriteOffAddrOp_WideChar -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp (Just (mo_WordTo32 platform)) b32 res args+  WriteOffAddrOp_Int -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Word -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Addr -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Float -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing f32 res args+  WriteOffAddrOp_Double -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing f64 res args+  WriteOffAddrOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing (bWord platform) res args+  WriteOffAddrOp_Int8 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Int16 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b16 res args+  WriteOffAddrOp_Int32 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b32 res args+  WriteOffAddrOp_Int64 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b64 res args+  WriteOffAddrOp_Word8 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b8 res args+  WriteOffAddrOp_Word16 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b16 res args+  WriteOffAddrOp_Word32 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b32 res args+  WriteOffAddrOp_Word64 -> \args -> opIntoRegs $ \res ->+    doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++  WriteByteArrayOp_Char -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args+  WriteByteArrayOp_WideChar -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b32 res args+  WriteByteArrayOp_Int -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Word -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Addr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Float -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing f32 res args+  WriteByteArrayOp_Double -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing f64 res args+  WriteByteArrayOp_StablePtr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing (bWord platform) res args+  WriteByteArrayOp_Int8 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Int16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b16 res args+  WriteByteArrayOp_Int32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b32 res args+  WriteByteArrayOp_Int64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b64 res args+  WriteByteArrayOp_Word8 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8  res args+  WriteByteArrayOp_Word16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b16 res args+  WriteByteArrayOp_Word32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b32 res args+  WriteByteArrayOp_Word64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++  WriteByteArrayOp_Word8AsChar -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo8 platform))  b8 res args+  WriteByteArrayOp_Word8AsWideChar -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp (Just (mo_WordTo32 platform)) b8 res args+  WriteByteArrayOp_Word8AsInt -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsAddr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsFloat -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsDouble -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsStablePtr -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsInt64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord16 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord32 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args+  WriteByteArrayOp_Word8AsWord64 -> \args -> opIntoRegs $ \res ->+    doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+  CopyByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyByteArrayOp src src_off dst dst_off n+  CopyMutableByteArrayOp -> \[src,src_off,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyMutableByteArrayOp src src_off dst dst_off n+  CopyByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->+    doCopyByteArrayToAddrOp src src_off dst n+  CopyMutableByteArrayToAddrOp -> \[src,src_off,dst,n] -> opIntoRegs $ \[] ->+    doCopyMutableByteArrayToAddrOp src src_off dst n+  CopyAddrToByteArrayOp -> \[src,dst,dst_off,n] -> opIntoRegs $ \[] ->+    doCopyAddrToByteArrayOp src dst dst_off n+  SetByteArrayOp -> \[ba,off,len,c] -> opIntoRegs $ \[] ->+    doSetByteArrayOp ba off len c++-- Comparing byte arrays+  CompareByteArraysOp -> \[ba1,ba1_off,ba2,ba2_off,n] -> opIntoRegs $ \[res] ->+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++  BSwap16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w W16+  BSwap32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w W32+  BSwap64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w W64+  BSwapOp -> \[w] -> opIntoRegs $ \[res] ->+    emitBSwapCall res w (wordWidth platform)++  BRev8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W8+  BRev16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W16+  BRev32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W32+  BRev64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w W64+  BRevOp -> \[w] -> opIntoRegs $ \[res] ->+    emitBRevCall res w (wordWidth platform)++-- Population count+  PopCnt8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W8+  PopCnt16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W16+  PopCnt32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W32+  PopCnt64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w W64+  PopCntOp -> \[w] -> opIntoRegs $ \[res] ->+    emitPopCntCall res w (wordWidth platform)++-- Parallel bit deposit+  Pdep8Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W8+  Pdep16Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W16+  Pdep32Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W32+  Pdep64Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask W64+  PdepOp -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPdepCall res src mask (wordWidth platform)++-- Parallel bit extract+  Pext8Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W8+  Pext16Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W16+  Pext32Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W32+  Pext64Op -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask W64+  PextOp -> \[src, mask] -> opIntoRegs $ \[res] ->+    emitPextCall res src mask (wordWidth platform)++-- count leading zeros+  Clz8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W8+  Clz16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W16+  Clz32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W32+  Clz64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w W64+  ClzOp -> \[w] -> opIntoRegs $ \[res] ->+    emitClzCall res w (wordWidth platform)++-- count trailing zeros+  Ctz8Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W8+  Ctz16Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W16+  Ctz32Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W32+  Ctz64Op -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w W64+  CtzOp -> \[w] -> opIntoRegs $ \[res] ->+    emitCtzCall res w (wordWidth platform)++-- Unsigned int to floating point conversions+  WordToFloatOp -> \[w] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_UF_Conv W32) [w]+  WordToDoubleOp -> \[w] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_UF_Conv W64) [w]++-- Atomic operations+  InterlockedExchange_Addr -> \[src, value] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]+  InterlockedExchange_Word -> \[src, value] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Xchg (wordWidth platform)) [src, value]++  FetchAddAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Add addr (bWord platform) n+  FetchSubAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Sub addr (bWord platform) n+  FetchAndAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_And addr (bWord platform) n+  FetchNandAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Nand addr (bWord platform) n+  FetchOrAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Or addr (bWord platform) n+  FetchXorAddrOp_Word -> \[addr, n] -> opIntoRegs $ \[res] ->+    doAtomicAddrRMW res AMO_Xor addr (bWord platform) n++  AtomicReadAddrOp_Word -> \[addr] -> opIntoRegs $ \[res] ->+    doAtomicReadAddr res addr (bWord platform)+  AtomicWriteAddrOp_Word -> \[addr, val] -> opIntoRegs $ \[] ->+    doAtomicWriteAddr addr (bWord platform) val++  CasAddrOp_Addr -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]+  CasAddrOp_Word -> \[dst, expected, new] -> opIntoRegs $ \[res] ->+    emitPrimCall [res] (MO_Cmpxchg (wordWidth platform)) [dst, expected, new]++-- SIMD primops+  (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res+   where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecPackOp vcat n w) -> \es -> opIntoRegs $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    when (es `lengthIsNot` n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res+   where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecUnpackOp vcat n w) -> \[arg] -> opIntoRegs $ \res -> do+    checkVecCompatibility dflags vcat n w+    when (res `lengthIsNot` n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do+    checkVecCompatibility dflags vcat n w+    doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecReadByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecWriteByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecReadOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecWriteOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecVmmType vcat n w++  (VecIndexScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarByteArrayOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecIndexScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecReadScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res0 args+   where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++  (VecWriteScalarOffAddrOp vcat n w) -> \args -> opIntoRegs $ \res0 -> do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res0 args+   where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+  PrefetchByteArrayOp3         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 3  args+  PrefetchMutableByteArrayOp3  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 3  args+  PrefetchAddrOp3              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp  3  args+  PrefetchValueOp3             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 3 args++  PrefetchByteArrayOp2         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 2  args+  PrefetchMutableByteArrayOp2  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 2  args+  PrefetchAddrOp2              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp 2  args+  PrefetchValueOp2             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 2 args+  PrefetchByteArrayOp1         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 1  args+  PrefetchMutableByteArrayOp1  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 1  args+  PrefetchAddrOp1              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp 1  args+  PrefetchValueOp1             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 1 args++  PrefetchByteArrayOp0         -> \args -> opIntoRegs $ \[] ->+    doPrefetchByteArrayOp 0  args+  PrefetchMutableByteArrayOp0  -> \args -> opIntoRegs $ \[] ->+    doPrefetchMutableByteArrayOp 0  args+  PrefetchAddrOp0              -> \args -> opIntoRegs $ \[] ->+    doPrefetchAddrOp 0  args+  PrefetchValueOp0             -> \args -> opIntoRegs $ \[] ->+    doPrefetchValueOp 0 args++-- Atomic read-modify-write+  FetchAddByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Add mba ix (bWord platform) n+  FetchSubByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Sub mba ix (bWord platform) n+  FetchAndByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_And mba ix (bWord platform) n+  FetchNandByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Nand mba ix (bWord platform) n+  FetchOrByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Or mba ix (bWord platform) n+  FetchXorByteArrayOp_Int -> \[mba, ix, n] -> opIntoRegs $ \[res] ->+    doAtomicByteArrayRMW res AMO_Xor mba ix (bWord platform) n+  AtomicReadByteArrayOp_Int -> \[mba, ix] -> opIntoRegs $ \[res] ->+    doAtomicReadByteArray res mba ix (bWord platform)+  AtomicWriteByteArrayOp_Int -> \[mba, ix, val] -> opIntoRegs $ \[] ->+    doAtomicWriteByteArray mba ix (bWord platform) val+  CasByteArrayOp_Int -> \[mba, ix, old, new] -> opIntoRegs $ \[res] ->+    doCasByteArray res mba ix (bWord platform) old new++-- The rest just translate straightforwardly++  Int8ToWord8Op   -> \args -> opNop args+  Word8ToInt8Op   -> \args -> opNop args+  Int16ToWord16Op -> \args -> opNop args+  Word16ToInt16Op -> \args -> opNop args+  Int32ToWord32Op -> \args -> opNop args+  Word32ToInt32Op -> \args -> opNop args+#if WORD_SIZE_IN_BITS < 64+  Int64ToWord64Op -> \args -> opNop args+  Word64ToInt64Op -> \args -> opNop args+#endif+  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++  Narrow8IntOp   -> \args -> opNarrow args (MO_SS_Conv, W8)+  Narrow16IntOp  -> \args -> opNarrow args (MO_SS_Conv, W16)+  Narrow32IntOp  -> \args -> opNarrow args (MO_SS_Conv, W32)+  Narrow8WordOp  -> \args -> opNarrow args (MO_UU_Conv, W8)+  Narrow16WordOp -> \args -> opNarrow args (MO_UU_Conv, W16)+  Narrow32WordOp -> \args -> opNarrow args (MO_UU_Conv, W32)++  DoublePowerOp  -> \args -> opCallish args MO_F64_Pwr+  DoubleSinOp    -> \args -> opCallish args MO_F64_Sin+  DoubleCosOp    -> \args -> opCallish args MO_F64_Cos+  DoubleTanOp    -> \args -> opCallish args MO_F64_Tan+  DoubleSinhOp   -> \args -> opCallish args MO_F64_Sinh+  DoubleCoshOp   -> \args -> opCallish args MO_F64_Cosh+  DoubleTanhOp   -> \args -> opCallish args MO_F64_Tanh+  DoubleAsinOp   -> \args -> opCallish args MO_F64_Asin+  DoubleAcosOp   -> \args -> opCallish args MO_F64_Acos+  DoubleAtanOp   -> \args -> opCallish args MO_F64_Atan+  DoubleAsinhOp  -> \args -> opCallish args MO_F64_Asinh+  DoubleAcoshOp  -> \args -> opCallish args MO_F64_Acosh+  DoubleAtanhOp  -> \args -> opCallish args MO_F64_Atanh+  DoubleLogOp    -> \args -> opCallish args MO_F64_Log+  DoubleLog1POp  -> \args -> opCallish args MO_F64_Log1P+  DoubleExpOp    -> \args -> opCallish args MO_F64_Exp+  DoubleExpM1Op  -> \args -> opCallish args MO_F64_ExpM1+  DoubleSqrtOp   -> \args -> opCallish args MO_F64_Sqrt++  FloatPowerOp   -> \args -> opCallish args MO_F32_Pwr+  FloatSinOp     -> \args -> opCallish args MO_F32_Sin+  FloatCosOp     -> \args -> opCallish args MO_F32_Cos+  FloatTanOp     -> \args -> opCallish args MO_F32_Tan+  FloatSinhOp    -> \args -> opCallish args MO_F32_Sinh+  FloatCoshOp    -> \args -> opCallish args MO_F32_Cosh+  FloatTanhOp    -> \args -> opCallish args MO_F32_Tanh+  FloatAsinOp    -> \args -> opCallish args MO_F32_Asin+  FloatAcosOp    -> \args -> opCallish args MO_F32_Acos+  FloatAtanOp    -> \args -> opCallish args MO_F32_Atan+  FloatAsinhOp   -> \args -> opCallish args MO_F32_Asinh+  FloatAcoshOp   -> \args -> opCallish args MO_F32_Acosh+  FloatAtanhOp   -> \args -> opCallish args MO_F32_Atanh+  FloatLogOp     -> \args -> opCallish args MO_F32_Log+  FloatLog1POp   -> \args -> opCallish args MO_F32_Log1P+  FloatExpOp     -> \args -> opCallish args MO_F32_Exp+  FloatExpM1Op   -> \args -> opCallish args MO_F32_ExpM1+  FloatSqrtOp    -> \args -> opCallish args MO_F32_Sqrt++-- Native word signless ops++  IntAddOp       -> \args -> opTranslate args (mo_wordAdd platform)+  IntSubOp       -> \args -> opTranslate args (mo_wordSub platform)+  WordAddOp      -> \args -> opTranslate args (mo_wordAdd platform)+  WordSubOp      -> \args -> opTranslate args (mo_wordSub platform)+  AddrAddOp      -> \args -> opTranslate args (mo_wordAdd platform)+  AddrSubOp      -> \args -> opTranslate args (mo_wordSub platform)++  IntEqOp        -> \args -> opTranslate args (mo_wordEq platform)+  IntNeOp        -> \args -> opTranslate args (mo_wordNe platform)+  WordEqOp       -> \args -> opTranslate args (mo_wordEq platform)+  WordNeOp       -> \args -> opTranslate args (mo_wordNe platform)+  AddrEqOp       -> \args -> opTranslate args (mo_wordEq platform)+  AddrNeOp       -> \args -> opTranslate args (mo_wordNe platform)++  WordAndOp      -> \args -> opTranslate args (mo_wordAnd platform)+  WordOrOp       -> \args -> opTranslate args (mo_wordOr platform)+  WordXorOp      -> \args -> opTranslate args (mo_wordXor platform)+  WordNotOp      -> \args -> opTranslate args (mo_wordNot platform)+  WordSllOp      -> \args -> opTranslate args (mo_wordShl platform)+  WordSrlOp      -> \args -> opTranslate args (mo_wordUShr platform)++  AddrRemOp      -> \args -> opTranslate args (mo_wordURem platform)++-- Native word signed ops++  IntMulOp        -> \args -> opTranslate args (mo_wordMul platform)+  IntMulMayOfloOp -> \args -> opTranslate args (MO_S_MulMayOflo (wordWidth platform))+  IntQuotOp       -> \args -> opTranslate args (mo_wordSQuot platform)+  IntRemOp        -> \args -> opTranslate args (mo_wordSRem platform)+  IntNegOp        -> \args -> opTranslate args (mo_wordSNeg platform)++  IntGeOp        -> \args -> opTranslate args (mo_wordSGe platform)+  IntLeOp        -> \args -> opTranslate args (mo_wordSLe platform)+  IntGtOp        -> \args -> opTranslate args (mo_wordSGt platform)+  IntLtOp        -> \args -> opTranslate args (mo_wordSLt platform)++  IntAndOp       -> \args -> opTranslate args (mo_wordAnd platform)+  IntOrOp        -> \args -> opTranslate args (mo_wordOr platform)+  IntXorOp       -> \args -> opTranslate args (mo_wordXor platform)+  IntNotOp       -> \args -> opTranslate args (mo_wordNot platform)+  IntSllOp       -> \args -> opTranslate args (mo_wordShl platform)+  IntSraOp       -> \args -> opTranslate args (mo_wordSShr platform)+  IntSrlOp       -> \args -> opTranslate args (mo_wordUShr platform)++-- Native word unsigned ops++  WordGeOp       -> \args -> opTranslate args (mo_wordUGe platform)+  WordLeOp       -> \args -> opTranslate args (mo_wordULe platform)+  WordGtOp       -> \args -> opTranslate args (mo_wordUGt platform)+  WordLtOp       -> \args -> opTranslate args (mo_wordULt platform)++  WordMulOp      -> \args -> opTranslate args (mo_wordMul platform)+  WordQuotOp     -> \args -> opTranslate args (mo_wordUQuot platform)+  WordRemOp      -> \args -> opTranslate args (mo_wordURem platform)++  AddrGeOp       -> \args -> opTranslate args (mo_wordUGe platform)+  AddrLeOp       -> \args -> opTranslate args (mo_wordULe platform)+  AddrGtOp       -> \args -> opTranslate args (mo_wordUGt platform)+  AddrLtOp       -> \args -> opTranslate args (mo_wordULt platform)++-- Int8# signed ops++  Int8ToIntOp    -> \args -> opTranslate args (MO_SS_Conv W8 (wordWidth platform))+  IntToInt8Op    -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W8)+  Int8NegOp      -> \args -> opTranslate args (MO_S_Neg W8)+  Int8AddOp      -> \args -> opTranslate args (MO_Add W8)+  Int8SubOp      -> \args -> opTranslate args (MO_Sub W8)+  Int8MulOp      -> \args -> opTranslate args (MO_Mul W8)+  Int8QuotOp     -> \args -> opTranslate args (MO_S_Quot W8)+  Int8RemOp      -> \args -> opTranslate args (MO_S_Rem W8)++  Int8SllOp     -> \args -> opTranslate args (MO_Shl W8)+  Int8SraOp     -> \args -> opTranslate args (MO_S_Shr W8)+  Int8SrlOp     -> \args -> opTranslate args (MO_U_Shr W8)++  Int8EqOp       -> \args -> opTranslate args (MO_Eq W8)+  Int8GeOp       -> \args -> opTranslate args (MO_S_Ge W8)+  Int8GtOp       -> \args -> opTranslate args (MO_S_Gt W8)+  Int8LeOp       -> \args -> opTranslate args (MO_S_Le W8)+  Int8LtOp       -> \args -> opTranslate args (MO_S_Lt W8)+  Int8NeOp       -> \args -> opTranslate args (MO_Ne W8)++-- Word8# unsigned ops++  Word8ToWordOp  -> \args -> opTranslate args (MO_UU_Conv W8 (wordWidth platform))+  WordToWord8Op  -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W8)+  Word8AddOp     -> \args -> opTranslate args (MO_Add W8)+  Word8SubOp     -> \args -> opTranslate args (MO_Sub W8)+  Word8MulOp     -> \args -> opTranslate args (MO_Mul W8)+  Word8QuotOp    -> \args -> opTranslate args (MO_U_Quot W8)+  Word8RemOp     -> \args -> opTranslate args (MO_U_Rem W8)++  Word8AndOp    -> \args -> opTranslate args (MO_And W8)+  Word8OrOp     -> \args -> opTranslate args (MO_Or W8)+  Word8XorOp    -> \args -> opTranslate args (MO_Xor W8)+  Word8NotOp    -> \args -> opTranslate args (MO_Not W8)+  Word8SllOp    -> \args -> opTranslate args (MO_Shl W8)+  Word8SrlOp    -> \args -> opTranslate args (MO_U_Shr W8)++  Word8EqOp      -> \args -> opTranslate args (MO_Eq W8)+  Word8GeOp      -> \args -> opTranslate args (MO_U_Ge W8)+  Word8GtOp      -> \args -> opTranslate args (MO_U_Gt W8)+  Word8LeOp      -> \args -> opTranslate args (MO_U_Le W8)+  Word8LtOp      -> \args -> opTranslate args (MO_U_Lt W8)+  Word8NeOp      -> \args -> opTranslate args (MO_Ne W8)++-- Int16# signed ops++  Int16ToIntOp   -> \args -> opTranslate args (MO_SS_Conv W16 (wordWidth platform))+  IntToInt16Op   -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W16)+  Int16NegOp     -> \args -> opTranslate args (MO_S_Neg W16)+  Int16AddOp     -> \args -> opTranslate args (MO_Add W16)+  Int16SubOp     -> \args -> opTranslate args (MO_Sub W16)+  Int16MulOp     -> \args -> opTranslate args (MO_Mul W16)+  Int16QuotOp    -> \args -> opTranslate args (MO_S_Quot W16)+  Int16RemOp     -> \args -> opTranslate args (MO_S_Rem W16)++  Int16SllOp     -> \args -> opTranslate args (MO_Shl W16)+  Int16SraOp     -> \args -> opTranslate args (MO_S_Shr W16)+  Int16SrlOp     -> \args -> opTranslate args (MO_U_Shr W16)++  Int16EqOp      -> \args -> opTranslate args (MO_Eq W16)+  Int16GeOp      -> \args -> opTranslate args (MO_S_Ge W16)+  Int16GtOp      -> \args -> opTranslate args (MO_S_Gt W16)+  Int16LeOp      -> \args -> opTranslate args (MO_S_Le W16)+  Int16LtOp      -> \args -> opTranslate args (MO_S_Lt W16)+  Int16NeOp      -> \args -> opTranslate args (MO_Ne W16)++-- Word16# unsigned ops++  Word16ToWordOp -> \args -> opTranslate args (MO_UU_Conv W16 (wordWidth platform))+  WordToWord16Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W16)+  Word16AddOp    -> \args -> opTranslate args (MO_Add W16)+  Word16SubOp    -> \args -> opTranslate args (MO_Sub W16)+  Word16MulOp    -> \args -> opTranslate args (MO_Mul W16)+  Word16QuotOp   -> \args -> opTranslate args (MO_U_Quot W16)+  Word16RemOp    -> \args -> opTranslate args (MO_U_Rem W16)++  Word16AndOp    -> \args -> opTranslate args (MO_And W16)+  Word16OrOp     -> \args -> opTranslate args (MO_Or W16)+  Word16XorOp    -> \args -> opTranslate args (MO_Xor W16)+  Word16NotOp    -> \args -> opTranslate args (MO_Not W16)+  Word16SllOp    -> \args -> opTranslate args (MO_Shl W16)+  Word16SrlOp    -> \args -> opTranslate args (MO_U_Shr W16)++  Word16EqOp     -> \args -> opTranslate args (MO_Eq W16)+  Word16GeOp     -> \args -> opTranslate args (MO_U_Ge W16)+  Word16GtOp     -> \args -> opTranslate args (MO_U_Gt W16)+  Word16LeOp     -> \args -> opTranslate args (MO_U_Le W16)+  Word16LtOp     -> \args -> opTranslate args (MO_U_Lt W16)+  Word16NeOp     -> \args -> opTranslate args (MO_Ne W16)++-- Int32# signed ops++  Int32ToIntOp   -> \args -> opTranslate args (MO_SS_Conv W32 (wordWidth platform))+  IntToInt32Op   -> \args -> opTranslate args (MO_SS_Conv (wordWidth platform) W32)+  Int32NegOp     -> \args -> opTranslate args (MO_S_Neg W32)+  Int32AddOp     -> \args -> opTranslate args (MO_Add W32)+  Int32SubOp     -> \args -> opTranslate args (MO_Sub W32)+  Int32MulOp     -> \args -> opTranslate args (MO_Mul W32)+  Int32QuotOp    -> \args -> opTranslate args (MO_S_Quot W32)+  Int32RemOp     -> \args -> opTranslate args (MO_S_Rem W32)++  Int32SllOp     -> \args -> opTranslate args (MO_Shl W32)+  Int32SraOp     -> \args -> opTranslate args (MO_S_Shr W32)+  Int32SrlOp     -> \args -> opTranslate args (MO_U_Shr W32)++  Int32EqOp      -> \args -> opTranslate args (MO_Eq W32)+  Int32GeOp      -> \args -> opTranslate args (MO_S_Ge W32)+  Int32GtOp      -> \args -> opTranslate args (MO_S_Gt W32)+  Int32LeOp      -> \args -> opTranslate args (MO_S_Le W32)+  Int32LtOp      -> \args -> opTranslate args (MO_S_Lt W32)+  Int32NeOp      -> \args -> opTranslate args (MO_Ne W32)++-- Word32# unsigned ops++  Word32ToWordOp -> \args -> opTranslate args (MO_UU_Conv W32 (wordWidth platform))+  WordToWord32Op -> \args -> opTranslate args (MO_UU_Conv (wordWidth platform) W32)+  Word32AddOp    -> \args -> opTranslate args (MO_Add W32)+  Word32SubOp    -> \args -> opTranslate args (MO_Sub W32)+  Word32MulOp    -> \args -> opTranslate args (MO_Mul W32)+  Word32QuotOp   -> \args -> opTranslate args (MO_U_Quot W32)+  Word32RemOp    -> \args -> opTranslate args (MO_U_Rem W32)++  Word32AndOp    -> \args -> opTranslate args (MO_And W32)+  Word32OrOp     -> \args -> opTranslate args (MO_Or W32)+  Word32XorOp    -> \args -> opTranslate args (MO_Xor W32)+  Word32NotOp    -> \args -> opTranslate args (MO_Not W32)+  Word32SllOp    -> \args -> opTranslate args (MO_Shl W32)+  Word32SrlOp    -> \args -> opTranslate args (MO_U_Shr W32)++  Word32EqOp     -> \args -> opTranslate args (MO_Eq W32)+  Word32GeOp     -> \args -> opTranslate args (MO_U_Ge W32)+  Word32GtOp     -> \args -> opTranslate args (MO_U_Gt W32)+  Word32LeOp     -> \args -> opTranslate args (MO_U_Le W32)+  Word32LtOp     -> \args -> opTranslate args (MO_U_Lt W32)+  Word32NeOp     -> \args -> opTranslate args (MO_Ne W32)++#if WORD_SIZE_IN_BITS < 64+-- Int64# signed ops++  Int64ToIntOp   -> \args -> opTranslate64 args (\w -> MO_SS_Conv w (wordWidth platform)) MO_I64_ToI+  IntToInt64Op   -> \args -> opTranslate64 args (\w -> MO_SS_Conv (wordWidth platform) w) MO_I64_FromI+  Int64NegOp     -> \args -> opTranslate64 args MO_S_Neg  MO_x64_Neg+  Int64AddOp     -> \args -> opTranslate64 args MO_Add    MO_x64_Add+  Int64SubOp     -> \args -> opTranslate64 args MO_Sub    MO_x64_Sub+  Int64MulOp     -> \args -> opTranslate64 args MO_Mul    MO_x64_Mul+  Int64QuotOp    -> \args -> opTranslate64 args MO_S_Quot MO_I64_Quot+  Int64RemOp     -> \args -> opTranslate64 args MO_S_Rem  MO_I64_Rem++  Int64SllOp     -> \args -> opTranslate64 args MO_Shl    MO_x64_Shl+  Int64SraOp     -> \args -> opTranslate64 args MO_S_Shr  MO_I64_Shr+  Int64SrlOp     -> \args -> opTranslate64 args MO_U_Shr  MO_W64_Shr++  Int64EqOp      -> \args -> opTranslate64 args MO_Eq     MO_x64_Eq+  Int64GeOp      -> \args -> opTranslate64 args MO_S_Ge   MO_I64_Ge+  Int64GtOp      -> \args -> opTranslate64 args MO_S_Gt   MO_I64_Gt+  Int64LeOp      -> \args -> opTranslate64 args MO_S_Le   MO_I64_Le+  Int64LtOp      -> \args -> opTranslate64 args MO_S_Lt   MO_I64_Lt+  Int64NeOp      -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne++-- Word64# unsigned ops++  Word64ToWordOp -> \args -> opTranslate64 args (\w -> MO_UU_Conv w (wordWidth platform)) MO_W64_ToW+  WordToWord64Op -> \args -> opTranslate64 args (\w -> MO_UU_Conv (wordWidth platform) w) MO_W64_FromW+  Word64AddOp    -> \args -> opTranslate64 args MO_Add    MO_x64_Add+  Word64SubOp    -> \args -> opTranslate64 args MO_Sub    MO_x64_Sub+  Word64MulOp    -> \args -> opTranslate64 args MO_Mul    MO_x64_Mul+  Word64QuotOp   -> \args -> opTranslate64 args MO_U_Quot MO_W64_Quot+  Word64RemOp    -> \args -> opTranslate64 args MO_U_Rem  MO_W64_Rem++  Word64AndOp    -> \args -> opTranslate64 args MO_And    MO_x64_And+  Word64OrOp     -> \args -> opTranslate64 args MO_Or     MO_x64_Or+  Word64XorOp    -> \args -> opTranslate64 args MO_Xor    MO_x64_Xor+  Word64NotOp    -> \args -> opTranslate64 args MO_Not    MO_x64_Not+  Word64SllOp    -> \args -> opTranslate64 args MO_Shl    MO_x64_Shl+  Word64SrlOp    -> \args -> opTranslate64 args MO_U_Shr  MO_W64_Shr++  Word64EqOp     -> \args -> opTranslate64 args MO_Eq     MO_x64_Eq+  Word64GeOp     -> \args -> opTranslate64 args MO_U_Ge   MO_W64_Ge+  Word64GtOp     -> \args -> opTranslate64 args MO_U_Gt   MO_W64_Gt+  Word64LeOp     -> \args -> opTranslate64 args MO_U_Le   MO_W64_Le+  Word64LtOp     -> \args -> opTranslate64 args MO_U_Lt   MO_W64_Lt+  Word64NeOp     -> \args -> opTranslate64 args MO_Ne     MO_x64_Ne+#endif++-- Char# ops++  CharEqOp       -> \args -> opTranslate args (MO_Eq (wordWidth platform))+  CharNeOp       -> \args -> opTranslate args (MO_Ne (wordWidth platform))+  CharGeOp       -> \args -> opTranslate args (MO_U_Ge (wordWidth platform))+  CharLeOp       -> \args -> opTranslate args (MO_U_Le (wordWidth platform))+  CharGtOp       -> \args -> opTranslate args (MO_U_Gt (wordWidth platform))+  CharLtOp       -> \args -> opTranslate args (MO_U_Lt (wordWidth platform))++-- Double ops++  DoubleEqOp     -> \args -> opTranslate args (MO_F_Eq W64)+  DoubleNeOp     -> \args -> opTranslate args (MO_F_Ne W64)+  DoubleGeOp     -> \args -> opTranslate args (MO_F_Ge W64)+  DoubleLeOp     -> \args -> opTranslate args (MO_F_Le W64)+  DoubleGtOp     -> \args -> opTranslate args (MO_F_Gt W64)+  DoubleLtOp     -> \args -> opTranslate args (MO_F_Lt W64)++  DoubleAddOp    -> \args -> opTranslate args (MO_F_Add W64)+  DoubleSubOp    -> \args -> opTranslate args (MO_F_Sub W64)+  DoubleMulOp    -> \args -> opTranslate args (MO_F_Mul W64)+  DoubleDivOp    -> \args -> opTranslate args (MO_F_Quot W64)+  DoubleNegOp    -> \args -> opTranslate args (MO_F_Neg W64)++-- Float ops++  FloatEqOp     -> \args -> opTranslate args (MO_F_Eq W32)+  FloatNeOp     -> \args -> opTranslate args (MO_F_Ne W32)+  FloatGeOp     -> \args -> opTranslate args (MO_F_Ge W32)+  FloatLeOp     -> \args -> opTranslate args (MO_F_Le W32)+  FloatGtOp     -> \args -> opTranslate args (MO_F_Gt W32)+  FloatLtOp     -> \args -> opTranslate args (MO_F_Lt W32)++  FloatAddOp    -> \args -> opTranslate args (MO_F_Add  W32)+  FloatSubOp    -> \args -> opTranslate args (MO_F_Sub  W32)+  FloatMulOp    -> \args -> opTranslate args (MO_F_Mul  W32)+  FloatDivOp    -> \args -> opTranslate args (MO_F_Quot W32)+  FloatNegOp    -> \args -> opTranslate args (MO_F_Neg  W32)++-- Vector ops++  (VecAddOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Add  n w)+  (VecSubOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Sub  n w)+  (VecMulOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Mul  n w)+  (VecDivOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Quot n w)+  (VecQuotOp FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecRemOp  FloatVec _ _) -> \_ -> panic "unsupported primop"+  (VecNegOp  FloatVec n w) -> \args -> opTranslate args (MO_VF_Neg  n w)++  (VecAddOp  IntVec n w) -> \args -> opTranslate args (MO_V_Add   n w)+  (VecSubOp  IntVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)+  (VecMulOp  IntVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)+  (VecDivOp  IntVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp IntVec n w) -> \args -> opTranslate args (MO_VS_Quot n w)+  (VecRemOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Rem  n w)+  (VecNegOp  IntVec n w) -> \args -> opTranslate args (MO_VS_Neg  n w)++  (VecAddOp  WordVec n w) -> \args -> opTranslate args (MO_V_Add   n w)+  (VecSubOp  WordVec n w) -> \args -> opTranslate args (MO_V_Sub   n w)+  (VecMulOp  WordVec n w) -> \args -> opTranslate args (MO_V_Mul   n w)+  (VecDivOp  WordVec _ _) -> \_ -> panic "unsupported primop"+  (VecQuotOp WordVec n w) -> \args -> opTranslate args (MO_VU_Quot n w)+  (VecRemOp  WordVec n w) -> \args -> opTranslate args (MO_VU_Rem  n w)+  (VecNegOp  WordVec _ _) -> \_ -> panic "unsupported primop"++-- Conversions++  IntToDoubleOp   -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W64)+  DoubleToIntOp   -> \args -> opTranslate args (MO_FS_Conv W64 (wordWidth platform))++  IntToFloatOp    -> \args -> opTranslate args (MO_SF_Conv (wordWidth platform) W32)+  FloatToIntOp    -> \args -> opTranslate args (MO_FS_Conv W32 (wordWidth platform))++  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.++  SameMutVarOp            -> \args -> opTranslate args (mo_wordEq platform)+  SameMVarOp              -> \args -> opTranslate args (mo_wordEq platform)+  SameIOPortOp            -> \args -> opTranslate args (mo_wordEq platform)+  SameMutableArrayOp      -> \args -> opTranslate args (mo_wordEq platform)+  SameMutableByteArrayOp  -> \args -> opTranslate args (mo_wordEq platform)+  SameMutableArrayArrayOp -> \args -> opTranslate args (mo_wordEq platform)+  SameSmallMutableArrayOp -> \args -> opTranslate args (mo_wordEq platform)+  SameTVarOp              -> \args -> opTranslate args (mo_wordEq platform)+  EqStablePtrOp           -> \args -> opTranslate args (mo_wordEq platform)+-- See Note [Comparing stable names]+  EqStableNameOp          -> \args -> opTranslate args (mo_wordEq platform)++  IntQuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem  (wordWidth platform))+    else Right (genericIntQuotRemOp (wordWidth platform))++  Int8QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W8)+    else Right (genericIntQuotRemOp W8)++  Int16QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W16)+    else Right (genericIntQuotRemOp W16)++  Int32QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_S_QuotRem W32)+    else Right (genericIntQuotRemOp W32)++  WordQuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem  (wordWidth platform))+    else Right (genericWordQuotRemOp (wordWidth platform))++  WordQuotRem2Op -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_U_QuotRem2 (wordWidth platform))+    else Right (genericWordQuotRem2Op platform)++  Word8QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W8)+    else Right (genericWordQuotRemOp W8)++  Word16QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W16)+    else Right (genericWordQuotRemOp W16)++  Word32QuotRemOp -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) && not (quotRemCanBeOptimized args)+    then Left (MO_U_QuotRem W32)+    else Right (genericWordQuotRemOp W32)++  WordAdd2Op -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_Add2       (wordWidth platform))+    else Right genericWordAdd2Op++  WordAddCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddWordC   (wordWidth platform))+    else Right genericWordAddCOp++  WordSubCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubWordC   (wordWidth platform))+    else Right genericWordSubCOp++  IntAddCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_AddIntC    (wordWidth platform))+    else Right genericIntAddCOp++  IntSubCOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc)) || llvm+    then Left (MO_SubIntC    (wordWidth platform))+    else Right genericIntSubCOp++  WordMul2Op -> \args -> opCallishHandledLater args $+    if ncg && (x86ish || ppc) || llvm+    then Left (MO_U_Mul2     (wordWidth platform))+    else Right genericWordMul2Op++  IntMul2Op  -> \args -> opCallishHandledLater args $+    if ncg && x86ish || llvm+    then Left (MO_S_Mul2     (wordWidth platform))+    else Right genericIntMul2Op++  FloatFabsOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc || aarch64)) || llvm+    then Left MO_F32_Fabs+    else Right $ genericFabsOp W32++  DoubleFabsOp -> \args -> opCallishHandledLater args $+    if (ncg && (x86ish || ppc || aarch64)) || llvm+    then Left MO_F64_Fabs+    else Right $ genericFabsOp W64++  -- tagToEnum# is special: we need to pull the constructor+  -- out of the table, and perform an appropriate return.+  TagToEnumOp -> \[amode] -> PrimopCmmEmit_Internal $ \res_ty -> do+    -- If you're reading this code in the attempt to figure+    -- out why the compiler panic'ed here, it is probably because+    -- you used tagToEnum# in a non-monomorphic setting, e.g.,+    --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+    -- That won't work.+    let tycon = tyConAppTyCon res_ty+    MASSERT(isEnumerationTyCon tycon)+    platform <- getPlatform+    pure [tagToClosure platform tycon amode]++-- Out of line primops.+-- TODO compiler need not know about these++  UnsafeThawArrayOp -> alwaysExternal+  CasArrayOp -> alwaysExternal+  UnsafeThawSmallArrayOp -> alwaysExternal+  CasSmallArrayOp -> alwaysExternal+  NewPinnedByteArrayOp_Char -> alwaysExternal+  NewAlignedPinnedByteArrayOp_Char -> alwaysExternal+  MutableByteArrayIsPinnedOp -> alwaysExternal+  DoubleDecode_2IntOp -> alwaysExternal+  DoubleDecode_Int64Op -> alwaysExternal+  FloatDecode_IntOp -> alwaysExternal+  ByteArrayIsPinnedOp -> alwaysExternal+  ShrinkMutableByteArrayOp_Char -> alwaysExternal+  ResizeMutableByteArrayOp_Char -> alwaysExternal+  ShrinkSmallMutableArrayOp_Char -> alwaysExternal+  NewArrayArrayOp -> alwaysExternal+  NewMutVarOp -> alwaysExternal+  AtomicModifyMutVar2Op -> alwaysExternal+  AtomicModifyMutVar_Op -> alwaysExternal+  CasMutVarOp -> alwaysExternal+  CatchOp -> alwaysExternal+  RaiseOp -> alwaysExternal+  RaiseIOOp -> alwaysExternal+  MaskAsyncExceptionsOp -> alwaysExternal+  MaskUninterruptibleOp -> alwaysExternal+  UnmaskAsyncExceptionsOp -> alwaysExternal+  MaskStatus -> alwaysExternal+  AtomicallyOp -> alwaysExternal+  RetryOp -> alwaysExternal+  CatchRetryOp -> alwaysExternal+  CatchSTMOp -> alwaysExternal+  NewTVarOp -> alwaysExternal+  ReadTVarOp -> alwaysExternal+  ReadTVarIOOp -> alwaysExternal+  WriteTVarOp -> alwaysExternal+  NewMVarOp -> alwaysExternal+  TakeMVarOp -> alwaysExternal+  TryTakeMVarOp -> alwaysExternal+  PutMVarOp -> alwaysExternal+  TryPutMVarOp -> alwaysExternal+  ReadMVarOp -> alwaysExternal+  TryReadMVarOp -> alwaysExternal+  IsEmptyMVarOp -> alwaysExternal+  NewIOPortrOp -> alwaysExternal+  ReadIOPortOp -> alwaysExternal+  WriteIOPortOp -> alwaysExternal+  DelayOp -> alwaysExternal+  WaitReadOp -> alwaysExternal+  WaitWriteOp -> alwaysExternal+  ForkOp -> alwaysExternal+  ForkOnOp -> alwaysExternal+  KillThreadOp -> alwaysExternal+  YieldOp -> alwaysExternal+  LabelThreadOp -> alwaysExternal+  IsCurrentThreadBoundOp -> alwaysExternal+  NoDuplicateOp -> alwaysExternal+  ThreadStatusOp -> alwaysExternal+  MkWeakOp -> alwaysExternal+  MkWeakNoFinalizerOp -> alwaysExternal+  AddCFinalizerToWeakOp -> alwaysExternal+  DeRefWeakOp -> alwaysExternal+  FinalizeWeakOp -> alwaysExternal+  MakeStablePtrOp -> alwaysExternal+  DeRefStablePtrOp -> alwaysExternal+  MakeStableNameOp -> alwaysExternal+  CompactNewOp -> alwaysExternal+  CompactResizeOp -> alwaysExternal+  CompactContainsOp -> alwaysExternal+  CompactContainsAnyOp -> alwaysExternal+  CompactGetFirstBlockOp -> alwaysExternal+  CompactGetNextBlockOp -> alwaysExternal+  CompactAllocateBlockOp -> alwaysExternal+  CompactFixupPointersOp -> alwaysExternal+  CompactAdd -> alwaysExternal+  CompactAddWithSharing -> alwaysExternal+  CompactSize -> alwaysExternal+  SeqOp -> alwaysExternal+  GetSparkOp -> alwaysExternal+  NumSparks -> alwaysExternal+  DataToTagOp -> alwaysExternal+  MkApUpd0_Op -> alwaysExternal+  NewBCOOp -> alwaysExternal+  UnpackClosureOp -> alwaysExternal+  ClosureSizeOp -> alwaysExternal+  WhereFromOp   -> alwaysExternal+  GetApStackValOp -> alwaysExternal+  ClearCCSOp -> alwaysExternal+  TraceEventOp -> alwaysExternal+  TraceEventBinaryOp -> alwaysExternal+  TraceMarkerOp -> alwaysExternal+  SetThreadAllocationCounter -> alwaysExternal++  -- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.+  KeepAliveOp -> panic "keepAlive# should have been eliminated in CorePrep"++ where+  profile = targetProfile dflags+  platform = profilePlatform profile+  result_info = getPrimOpResultInfo primop++  opNop :: [CmmExpr] -> PrimopCmmEmit+  opNop args = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) arg+    where [arg] = args++  opNarrow+    :: [CmmExpr]+    -> (Width -> Width -> MachOp, Width)+    -> PrimopCmmEmit+  opNarrow args (mop, rep) = opIntoRegs $ \[res] -> emitAssign (CmmLocal res) $+    CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]+    where [arg] = args++  -- | These primops are implemented by CallishMachOps, because they sometimes+  -- turn into foreign calls depending on the backend.+  opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit+  opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args++  opTranslate :: [CmmExpr] -> MachOp -> PrimopCmmEmit+  opTranslate args mop = opIntoRegs $ \[res] -> do+    let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args)+    emit stmt++#if WORD_SIZE_IN_BITS < 64+  opTranslate64+    :: [CmmExpr]+    -> (Width -> MachOp)+    -> CallishMachOp+    -> PrimopCmmEmit+  opTranslate64 args mkMop callish =+    case platformWordSize platform of+      PW4 -> opCallish args callish+      PW8 -> opTranslate args $ mkMop W64+#endif++  -- | Basically a "manual" case, rather than one of the common repetitive forms+  -- above. The results are a parameter to the returned function so we know the+  -- choice of variant never depends on them.+  opCallishHandledLater+    :: [CmmExpr]+    -> Either CallishMachOp GenericOp+    -> PrimopCmmEmit+  opCallishHandledLater args callOrNot = opIntoRegs $ \res0 -> case callOrNot of+    Left op   -> emit $ mkUnsafeCall (PrimTarget op) res0 args+    Right gen -> gen res0 args++  opIntoRegs+    :: ([LocalReg] -- where to put the results+        -> FCode ())+    -> PrimopCmmEmit+  opIntoRegs f = PrimopCmmEmit_Internal $ \res_ty -> do+    regs <- case result_info of+      ReturnsPrim VoidRep -> pure []+      ReturnsPrim rep+        -> do reg <- newTemp (primRepCmmType platform rep)+              pure [reg]++      ReturnsAlg tycon | isUnboxedTupleTyCon tycon+        -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+              pure regs++      _ -> panic "cgOpApp"+    f regs+    pure $ map (CmmReg . CmmLocal) regs++  alwaysExternal = \_ -> PrimopCmmEmit_External+  -- Note [QuotRem optimization]+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+  --+  -- `quot` and `rem` with constant divisor can be implemented with fast bit-ops+  -- (shift, .&.).+  --+  -- Currently we only support optimization (performed in GHC.Cmm.Opt) when the+  -- constant is a power of 2. #9041 tracks the implementation of the general+  -- optimization.+  --+  -- `quotRem` can be optimized in the same way. However as it returns two values,+  -- it is implemented as a "callish" primop which is harder to match and+  -- to transform later on. For simplicity, the current implementation detects cases+  -- that can be optimized (see `quotRemCanBeOptimized`) and converts STG quotRem+  -- primop into two CMM quot and rem primops.+  quotRemCanBeOptimized = \case+    [_, CmmLit (CmmInt n _) ] -> isJust (exactLog2 n)+    _                         -> False++  ncg  = backend dflags == NCG+  llvm = backend dflags == LLVM+  x86ish = case platformArch platform of+             ArchX86    -> True+             ArchX86_64 -> True+             _          -> False+  ppc = case platformArch platform of+          ArchPPC      -> True+          ArchPPC_64 _ -> True+          _            -> False+  aarch64 = platformArch platform == ArchAArch64++data PrimopCmmEmit+  -- | Out of line fake primop that's actually just a foreign call to other+  -- (presumably) C--.+  = PrimopCmmEmit_External+  -- | Real primop turned into inline C--.+  | PrimopCmmEmit_Internal (Type -- the return type, some primops are specialized to it+                            -> FCode [CmmExpr]) -- just for TagToEnum for now++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++genericIntQuotRemOp :: Width -> GenericOp+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: Width -> GenericOp+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++genericWordQuotRem2Op :: Platform -> GenericOp+genericWordQuotRem2Op platform [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth platform)) zero arg_x_high arg_x_low+    where    ty = cmmExprType platform arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth platform)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth platform)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth platform)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth platform)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth platform)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth platform)) [x, y]+             zero   = lit 0+             one    = lit 1+             negone = lit (fromIntegral (platformWordSizeInBits platform) - 1)+             lit i = CmmLit (CmmInt i (wordWidth platform))++             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>+                                      mkAssign (CmmLocal res_r) high)+             f i acc high low =+                 do roverflowedBit <- newTemp ty+                    rhigh'         <- newTemp ty+                    rhigh''        <- newTemp ty+                    rlow'          <- newTemp ty+                    risge          <- newTemp ty+                    racc'          <- newTemp ty+                    let high'         = CmmReg (CmmLocal rhigh')+                        isge          = CmmReg (CmmLocal risge)+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)+                    let this = catAGraphs+                               [mkAssign (CmmLocal roverflowedBit)+                                          (shr high negone),+                                mkAssign (CmmLocal rhigh')+                                          (or (shl high one) (shr low negone)),+                                mkAssign (CmmLocal rlow')+                                          (shl low one),+                                mkAssign (CmmLocal risge)+                                          (or (overflowedBit `ne` zero)+                                              (high' `ge` arg_y)),+                                mkAssign (CmmLocal rhigh'')+                                          (high' `minus` (arg_y `times` isge)),+                                mkAssign (CmmLocal racc')+                                          (or (shl acc one) isge)]+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))+                                      (CmmReg (CmmLocal rhigh''))+                                      (CmmReg (CmmLocal rlow'))+                    return (this <*> rest)+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do platform <- getPlatform+       r1 <- newTemp (cmmExprType platform arg_x)+       r2 <- newTemp (cmmExprType platform arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))+                                (wordWidth platform))+           hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:+--+-- @+--    c = a&b | (a|b)&~r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordAddCOp :: GenericOp+genericWordAddCOp [res_r, res_c] [aa, bb]+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+            CmmMachOp (mo_wordOr platform) [+              CmmMachOp (mo_wordAnd platform) [aa,bb],+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordOr platform) [aa,bb],+                CmmMachOp (mo_wordNot platform) [CmmReg (CmmLocal res_r)]+              ]+            ],+            mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericWordAddCOp _ _ = panic "genericWordAddCOp"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:+--+-- @+--    c = ~a&b | (~a|b)&r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb]+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+            CmmMachOp (mo_wordOr platform) [+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordNot platform) [aa],+                bb+              ],+              CmmMachOp (mo_wordAnd platform) [+                CmmMachOp (mo_wordOr platform) [+                  CmmMachOp (mo_wordNot platform) [aa],+                  bb+                ],+                CmmReg (CmmLocal res_r)+              ]+            ],+            mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+                CmmMachOp (mo_wordAnd platform) [+                    CmmMachOp (mo_wordNot platform) [CmmMachOp (mo_wordXor platform) [aa,bb]],+                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do platform <- getPlatform+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub platform) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr platform) [+                CmmMachOp (mo_wordAnd platform) [+                    CmmMachOp (mo_wordXor platform) [aa,bb],+                    CmmMachOp (mo_wordXor platform) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr platform (platformWordSizeInBits platform - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do platform <- getPlatform+      let t = cmmExprType platform arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth platform)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth platform)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth platform)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth platform)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth platform)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth platform)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth platform)))+                               (wordWidth platform))+          hwm = CmmLit (CmmInt (halfWordMask platform) (wordWidth platform))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (sum [topHalf    (CmmReg xlyl),+                        bottomHalf (CmmReg xhyl),+                        bottomHalf (CmmReg xlyh)]),+              mkAssign (CmmLocal res_l)+                  (or (bottomHalf (CmmReg xlyl))+                      (toTopHalf (CmmReg r))),+              mkAssign (CmmLocal res_h)+                  (sum [mul (topHalf arg_x) (topHalf arg_y),+                        topHalf (CmmReg xhyl),+                        topHalf (CmmReg xlyh),+                        topHalf (CmmReg r)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++genericIntMul2Op :: GenericOp+genericIntMul2Op [res_c, res_h, res_l] both_args@[arg_x, arg_y]+ = do dflags <- getDynFlags+      platform <- getPlatform+      -- Implement algorithm from Hacker's Delight, 2nd edition, p.174+      let t = cmmExprType platform arg_x+      p   <- newTemp t+      -- 1) compute the multiplication as if numbers were unsigned+      _ <- withSequel (AssignTo [p, res_l] False) $+             cmmPrimOpApp dflags WordMul2Op both_args Nothing+      -- 2) correct the high bits of the unsigned result+      let carryFill x = CmmMachOp (MO_S_Shr ww) [x, wwm1]+          sub x y     = CmmMachOp (MO_Sub   ww) [x, y]+          and x y     = CmmMachOp (MO_And   ww) [x, y]+          neq x y     = CmmMachOp (MO_Ne    ww) [x, y]+          f   x y     = (carryFill x) `and` y+          wwm1        = CmmLit (CmmInt (fromIntegral (widthInBits ww - 1)) ww)+          rl x        = CmmReg (CmmLocal x)+          ww          = wordWidth platform+      emit $ catAGraphs+             [ mkAssign (CmmLocal res_h) (rl p `sub` f arg_x arg_y `sub` f arg_y arg_x)+             , mkAssign (CmmLocal res_c) (rl res_h `neq` carryFill (rl res_l))+             ]+genericIntMul2Op _ _ = panic "genericIntMul2Op"++-- This replicates what we had in libraries/base/GHC/Float.hs:+--+--    abs x    | x == 0    = 0 -- handles (-0.0)+--             | x >  0    = x+--             | otherwise = negateFloat x+genericFabsOp :: Width -> GenericOp+genericFabsOp w [res_r] [aa]+ = do platform <- getPlatform+      let zero   = CmmLit (CmmFloat 0 w)++          eq x y = CmmMachOp (MO_F_Eq w) [x, y]+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]++          neg x  = CmmMachOp (MO_F_Neg w) [x]++          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]++      res_t <- CmmLocal <$> newTemp (cmmExprType platform aa)+      let g3 = catAGraphs [mkAssign res_t aa,+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]++      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3++      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4++genericFabsOp _ _ _ = panic "genericFabsOp"++-- Note [Comparing stable names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- A StableName# is actually a pointer to a stable name object (SNO)+-- containing an index into the stable name table (SNT). We+-- used to compare StableName#s by following the pointers to the+-- SNOs and checking whether they held the same SNT indices. However,+-- this is not necessary: there is a one-to-one correspondence+-- between SNOs and entries in the SNT, so simple pointer equality+-- does the trick.++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do profile <- getProfile+        mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do profile <- getProfile+        mkBasicIndexedRead (arrWordsHdrSize profile) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "GHC.StgToCmm.Prim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do profile <- getProfile+        platform <- getPlatform+        mkBasicIndexedRead (arrPtrsHdrSize profile) Nothing (gcWord platform) res addr (gcWord platform) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = do profile <- getProfile+        mkBasicIndexedWrite (arrWordsHdrSize profile) maybe_pre_write_cast addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "GHC.StgToCmm.Prim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do profile  <- getProfile+       platform <- getPlatform+       let ty = cmmExprType platform val+           hdr_size = arrPtrsHdrSize profile+       -- Update remembered set for non-moving collector+       whenUpdRemSetEnabled+           $ emitUpdRemSetPush (cmmLoadIndexOffExpr platform hdr_size ty addr ty idx)+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       emitPrimCall [] MO_WriteBarrier []+       mkBasicIndexedWrite hdr_size Nothing addr ty idx val+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+       -- the write barrier.  We must write a byte into the mark table:+       -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr platform+          (cmmOffsetExprW platform (cmmOffsetB platform addr hdr_size)+                         (loadArrPtrsSize profile addr))+          (CmmMachOp (mo_wordUShr platform) [idx,+                                           mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform))])+         ) (CmmLit (CmmInt 1 W8))++loadArrPtrsSize :: Profile -> CmmExpr -> CmmExpr+loadArrPtrsSize profile addr = CmmLoad (cmmOffsetB platform addr off) (bWord platform)+ where off = fixedHdrSize profile + pc_OFFSET_StgMutArrPtrs_ptrs (profileConstants profile)+       platform = profilePlatform profile++mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead off Nothing ty res base idx_ty idx+   = do platform <- getPlatform+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr platform off ty base idx_ty idx)+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+   = do platform <- getPlatform+        emitAssign (CmmLocal res) (CmmMachOp cast [+                                   cmmLoadIndexOffExpr platform off ty base idx_ty idx])++mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes+                    -> Maybe MachOp -- Optional value cast+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite off Nothing base idx_ty idx val+   = do platform <- getPlatform+        emitStore (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) val+mkBasicIndexedWrite off (Just cast) base idx_ty idx val+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: Platform+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr platform off width base idx+   = cmmIndexExpr platform width (cmmOffsetB platform base off) idx++cmmLoadIndexOffExpr :: Platform+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr platform off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr platform off (typeWidth idx_ty) base idx) ty++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecVmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _        FloatVec _   =  Nothing+vecElemInjectCast platform   IntVec   W8  =  Just (mo_WordTo8  platform)+vecElemInjectCast platform   IntVec   W16 =  Just (mo_WordTo16 platform)+vecElemInjectCast platform   IntVec   W32 =  Just (mo_WordTo32 platform)+vecElemInjectCast _        IntVec   W64 =  Nothing+vecElemInjectCast platform   WordVec  W8  =  Just (mo_WordTo8  platform)+vecElemInjectCast platform   WordVec  W16 =  Just (mo_WordTo16 platform)+vecElemInjectCast platform   WordVec  W32 =  Just (mo_WordTo32 platform)+vecElemInjectCast _        WordVec  W64 =  Nothing+vecElemInjectCast _        _        _   =  Nothing++vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _        FloatVec _   =  Nothing+vecElemProjectCast platform   IntVec   W8  =  Just (mo_s_8ToWord  platform)+vecElemProjectCast platform   IntVec   W16 =  Just (mo_s_16ToWord platform)+vecElemProjectCast platform   IntVec   W32 =  Just (mo_s_32ToWord platform)+vecElemProjectCast _        IntVec   W64 =  Nothing+vecElemProjectCast platform   WordVec  W8  =  Just (mo_u_8ToWord  platform)+vecElemProjectCast platform   WordVec  W16 =  Just (mo_u_16ToWord platform)+vecElemProjectCast platform   WordVec  W32 =  Just (mo_u_32ToWord platform)+vecElemProjectCast _        WordVec  W64 =  Nothing+vecElemProjectCast _        _        _   =  Nothing+++-- NOTE [SIMD Design for the future]+-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+-- Currently these checks are specific to x86 and x86_64 architecture.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurements is the only way to validate that.+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension+--    includes  support for a sort of run time CPU dependent vectorization parameter,+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...+--    element chunk! Time will tell if that direction sees wide adoption,+--    but it is from that context that unifying our handling of simd and scalars+--    may benefit. It is not likely to benefit current architectures, though+--    it may very well be a design perspective that helps guide improving the NCG.+++checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility dflags vcat l w = do+    when (backend dflags /= LLVM) $+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."+                         ,"Please use -fllvm."]+    check vecWidth vcat l w+  where+    platform = targetPlatform dflags+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    check W128 FloatVec 4 W32 | not (isSseEnabled platform) =+        sorry $ "128-bit wide single-precision floating point " +++                "SIMD vector instructions require at least -msse."+    check W128 _ _ _ | not (isSse2Enabled platform) =+        sorry $ "128-bit wide integer and double precision " +++                "SIMD vector instructions require at least -msse2."+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+        sorry $ "256-bit wide floating point " +++                "SIMD vector instructions require at least -mavx."+    check W256 _ _ _ | not (isAvx2Enabled dflags) =+        sorry $ "256-bit wide integer " +++                "SIMD vector instructions require at least -mavx2."+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+        sorry $ "512-bit wide " +++                "SIMD vector instructions require -mavx512f."+    check _ _ _ _ = return ()++    vecWidth = typeWidth (vecVmmType vcat l w)++------------------------------------------------------------------------------+-- Helpers for translating vector packing and unpacking.++doVecPackOp :: Maybe MachOp  -- Cast from element to vector component+            -> CmmType       -- Type of vector+            -> CmmExpr       -- Initial vector+            -> [CmmExpr]     -- Elements+            -> CmmFormal     -- Destination for result+            -> FCode ()+doVecPackOp maybe_pre_write_cast ty z es res = do+    dst <- newTemp ty+    emitAssign (CmmLocal dst) z+    vecPack dst es 0+  where+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()+    vecPack src [] _ =+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))++    vecPack src (e : es) i = do+        dst <- newTemp ty+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+        vecPack dst es (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result+              -> CmmType       -- Type of vector+              -> CmmExpr       -- Vector+              -> [CmmFormal]   -- Element results+              -> FCode ()+doVecUnpackOp maybe_post_read_cast ty e res =+    vecUnpack res 0+  where+    vecUnpack :: [CmmFormal] -> Int -> FCode ()+    vecUnpack [] _ =+        return ()++    vecUnpack (r : rs) i = do+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)+                                             [e, iLit]))+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)+                                             [e, iLit]))+        vecUnpack rs (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_post_read_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component+              -> CmmType       -- Vector type+              -> CmmExpr       -- Source vector+              -> CmmExpr       -- Element+              -> CmmExpr       -- Index at which to insert element+              -> CmmFormal     -- Destination for result+              -> FCode ()+doVecInsertOp maybe_pre_write_cast ty src e idx res = do+    platform <- getPlatform+    -- vector indices are always 32-bits+    let idx' :: CmmExpr+        idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]+    if isFloatType (vecElemType ty)+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])+  where+    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++------------------------------------------------------------------------------+-- Helpers for translating prefetching.+++-- | Translate byte array prefetch operations into proper primcalls.+doPrefetchByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchByteArrayOp locality  [addr,idx]+   = do profile <- getProfile+        mkBasicPrefetch locality (arrWordsHdrSize profile)  addr idx+doPrefetchByteArrayOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"++-- | Translate mutable byte array prefetch operations into proper primcalls.+doPrefetchMutableByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchMutableByteArrayOp locality  [addr,idx]+   = do profile <- getProfile+        mkBasicPrefetch locality (arrWordsHdrSize profile)  addr idx+doPrefetchMutableByteArrayOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchByteArrayOp"++-- | Translate address prefetch operations into proper primcalls.+doPrefetchAddrOp ::Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchAddrOp locality   [addr,idx]+   = mkBasicPrefetch locality 0  addr idx+doPrefetchAddrOp _ _+   = panic "GHC.StgToCmm.Prim: doPrefetchAddrOp"++-- | Translate value prefetch operations into proper primcalls.+doPrefetchValueOp :: Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchValueOp  locality   [addr]+  =  do platform <- getPlatform+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth platform)))+doPrefetchValueOp _ _+  = panic "GHC.StgToCmm.Prim: doPrefetchValueOp"++-- | helper to generate prefetch primcalls+mkBasicPrefetch :: Int          -- Locality level 0-3+                -> ByteOff      -- Initial offset in bytes+                -> CmmExpr      -- Base address+                -> CmmExpr      -- Index+                -> FCode ()+mkBasicPrefetch locality off base idx+   = do platform <- getPlatform+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr platform W8 (cmmOffsetB platform base off) idx]+        return ()++-- ----------------------------------------------------------------------------+-- Allocating byte arrays++-- | Takes a register to return the newly allocated array in and the+-- size of the new array in bytes. Allocates a new+-- 'MutableByteArray#'.+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()+doNewByteArrayOp res_r n = do+    profile <- getProfile+    platform <- getPlatform++    let info_ptr = mkLblExpr mkArrWords_infoLabel+        rep = arrWordsRep platform n++    tickyAllocPrim (mkIntExpr platform (arrWordsHdrSize profile))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)++    let hdr_size = fixedHdrSize profile++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr platform n,+                        hdr_size + pc_OFFSET_StgArrBytes_bytes (platformConstants platform))+                     ]++    emit $ mkAssign (CmmLocal res_r) base++-- ----------------------------------------------------------------------------+-- Comparing byte arrays++doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                     -> FCode ()+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do+    profile <- getProfile+    platform <- getPlatform+    ba1_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba1 (arrWordsHdrSize profile)) ba1_off+    ba2_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba2 (arrWordsHdrSize profile)) ba2_off++    -- short-cut in case of equal pointers avoiding a costly+    -- subroutine call to the memcmp(3) routine; the Cmm logic below+    -- results in assembly code being generated for+    --+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#+    --+    -- that looks like+    --+    --          leaq 16(%r14),%rax+    --          leaq 16(%rsi),%rbx+    --          xorl %ecx,%ecx+    --          cmpq %rbx,%rax+    --          je l_ptr_eq+    --+    --          ; NB: the common case (unequal pointers) falls-through+    --          ; the conditional jump, and therefore matches the+    --          ; usual static branch prediction convention of modern cpus+    --+    --          subq $8,%rsp+    --          movq %rbx,%rsi+    --          movq %rax,%rdi+    --          movl $10,%edx+    --          xorl %eax,%eax+    --          call memcmp+    --          addq $8,%rsp+    --          movslq %eax,%rax+    --          movq %rax,%rcx+    --  l_ptr_eq:+    --          movq %rcx,%rbx+    --          jmp *(%rbp)++    l_ptr_eq <- newBlockId+    l_ptr_ne <- newBlockId++    emit (mkAssign (CmmLocal res) (zeroExpr platform))+    emit (mkCbranch (cmmEqWord platform ba1_p ba2_p)+                    l_ptr_eq l_ptr_ne (Just False))++    emitLabel l_ptr_ne+    emitMemcmpCall res ba1_p ba2_p n 1++    emitLabel l_ptr_eq++-- ----------------------------------------------------------------------------+-- Copying byte arrays++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'MutableByteArray#', an offset into the destination+-- array, and the number of bytes to copy.  Copies the given number of+-- bytes from the source array to the destination array.+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+doCopyByteArrayOp = emitCopyByteArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes align =+        emitMemcpyCall dst_p src_p bytes align++-- | Takes a source 'MutableByteArray#', an offset in the source+-- array, a destination 'MutableByteArray#', an offset into the+-- destination array, and the number of bytes to copy.  Copies the+-- given number of bytes from the source array to the destination+-- array.+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                         -> FCode ()+doCopyMutableByteArrayOp = emitCopyByteArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes align = do+        platform <- getPlatform+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p bytes align)+            (getCode $ emitMemcpyCall  dst_p src_p bytes align)+        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall++emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                      -> Alignment -> FCode ())+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+emitCopyByteArray copy src src_off dst dst_off n = do+    profile <- getProfile+    platform <- getPlatform+    let byteArrayAlignment = wordAlignment platform+        srcOffAlignment = cmmExprAlignment src_off+        dstOffAlignment = cmmExprAlignment dst_off+        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]+    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off+    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off+    copy src dst dst_p src_p n align++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyByteArrayToAddrOp src src_off dst_p bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    profile <- getProfile+    platform <- getPlatform+    src_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform src (arrWordsHdrSize profile)) src_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)++-- | Takes a source 'MutableByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                               -> FCode ()+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp++-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into+-- the destination array, and the number of bytes to copy.  Copies the given+-- number of bytes from the source memory region to the destination array.+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    profile <- getProfile+    platform <- getPlatform+    dst_p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform dst (arrWordsHdrSize profile)) dst_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+++-- ----------------------------------------------------------------------------+-- Setting byte arrays++-- | Takes a 'MutableByteArray#', an offset into the array, a length,+-- and a byte, and sets each of the selected bytes in the array to the+-- character.+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                 -> FCode ()+doSetByteArrayOp ba off len c = do+    profile <- getProfile+    platform <- getPlatform++    let byteArrayAlignment = wordAlignment platform -- known since BA is allocated on heap+        offsetAlignment = cmmExprAlignment off+        align = min byteArrayAlignment offsetAlignment++    p <- assignTempE $ cmmOffsetExpr platform (cmmOffsetB platform ba (arrWordsHdrSize profile)) off+    emitMemsetCall p c len align++-- ----------------------------------------------------------------------------+-- Allocating arrays++-- | Allocate a new array.+doNewArrayOp :: CmmFormal             -- ^ return register+             -> SMRep                 -- ^ representation of the array+             -> CLabel                -- ^ info pointer+             -> [(CmmExpr, ByteOff)]  -- ^ header payload+             -> WordOff               -- ^ array size+             -> CmmExpr               -- ^ initial element+             -> FCode ()+doNewArrayOp res_r rep info payload n init = do+    profile <- getProfile+    platform <- getPlatform++    let info_ptr = mkLblExpr info++    tickyAllocPrim (mkIntExpr platform (hdrSize profile rep))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)++    base <- allocHeapClosure rep info_ptr cccsExpr payload++    arr <- CmmLocal `fmap` newTemp (bWord platform)+    emit $ mkAssign arr base++    -- Initialise all elements of the array+    let mkOff off = cmmOffsetW platform (CmmReg arr) (hdrSizeW profile rep + off)+        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]+    emit (catAGraphs initialization)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- ----------------------------------------------------------------------------+-- Copying pointer arrays++-- EZY: This code has an unusually high amount of assignTemp calls, seen+-- nowhere else in the code generator.  This is mostly because these+-- "primitive" ops result in a surprisingly large amount of code.  It+-- will likely be worthwhile to optimize what is emitted here, so that+-- our optimization passes don't waste time repeatedly optimizing the+-- same bits of code.++-- More closely imitates 'assignTemp' from the old code generator, which+-- returns a CmmExpr rather than a LocalReg.+assignTempE :: CmmExpr -> FCode CmmExpr+assignTempE e = do+    t <- assignTemp e+    return (CmmReg (CmmLocal t))++-- | Takes a source 'Array#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+              -> FCode ()+doCopyArrayOp = emitCopyArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do platform <- getPlatform+           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+               (wordAlignment platform)+++-- | Takes a source 'MutableArray#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                     -> FCode ()+doCopyMutableArrayOp = emitCopyArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        platform <- getPlatform+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall++emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                  -> FCode ())  -- ^ copy function+              -> CmmExpr        -- ^ source array+              -> CmmExpr        -- ^ offset in source array+              -> CmmExpr        -- ^ destination array+              -> CmmExpr        -- ^ offset in destination array+              -> WordOff        -- ^ number of elements to copy+              -> FCode ()+emitCopyArray copy src0 src_off dst0 dst_off0 n =+    when (n /= 0) $ do+        profile <- getProfile+        platform <- getPlatform++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0+        dst_off <- assignTempE dst_off0++        -- Nonmoving collector write barrier+        emitCopyUpdRemSetPush platform (arrPtrsHdrSize profile) dst dst_off n++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))++        dst_elems_p <- assignTempE $ cmmOffsetB platform dst+                       (arrPtrsHdrSize profile)+        dst_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p dst_off+        src_p <- assignTempE $ cmmOffsetExprW platform+                 (cmmOffsetB platform src (arrPtrsHdrSize profile)) src_off+        let bytes = wordsToBytes platform n++        copy src dst dst_p src_p bytes++        -- The base address of the destination card table+        dst_cards_p <- assignTempE $ cmmOffsetExprW platform dst_elems_p+                       (loadArrPtrsSize profile dst)++        emitSetCards dst_off dst_cards_p n++doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                   -> FCode ()+doCopySmallArrayOp = emitCopySmallArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do platform <- getPlatform+           emitMemcpyCall dst_p src_p (mkIntExpr platform bytes)+               (wordAlignment platform)+++doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                          -> FCode ()+doCopySmallMutableArrayOp = emitCopySmallArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        platform <- getPlatform+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr platform bytes)+             (wordAlignment platform))+        emit =<< mkCmmIfThenElse (cmmEqWord platform src dst) moveCall cpyCall++emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                       -> FCode ())  -- ^ copy function+                   -> CmmExpr        -- ^ source array+                   -> CmmExpr        -- ^ offset in source array+                   -> CmmExpr        -- ^ destination array+                   -> CmmExpr        -- ^ offset in destination array+                   -> WordOff        -- ^ number of elements to copy+                   -> FCode ()+emitCopySmallArray copy src0 src_off dst0 dst_off n =+    when (n /= 0) $ do+        profile <- getProfile+        platform <- getPlatform++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0++        -- Nonmoving collector write barrier+        emitCopyUpdRemSetPush platform (smallArrPtrsHdrSize profile) dst dst_off n++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++        dst_p <- assignTempE $ cmmOffsetExprW platform+                 (cmmOffsetB platform dst (smallArrPtrsHdrSize profile)) dst_off+        src_p <- assignTempE $ cmmOffsetExprW platform+                 (cmmOffsetB platform src (smallArrPtrsHdrSize profile)) src_off+        let bytes = wordsToBytes platform n++        copy src dst dst_p src_p bytes++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+               -> FCode ()+emitCloneArray info_p res_r src src_off n = do+    profile <- getProfile+    platform <- getPlatform++    let info_ptr = mkLblExpr info_p+        rep = arrPtrsRep platform n++    tickyAllocPrim (mkIntExpr platform (arrPtrsHdrSize profile))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)++    let hdr_size = fixedHdrSize profile+        constants = platformConstants platform++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr platform n,+                        hdr_size + pc_OFFSET_StgMutArrPtrs_ptrs constants)+                     , (mkIntExpr platform (nonHdrSizeW rep),+                        hdr_size + pc_OFFSET_StgMutArrPtrs_size constants)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord platform)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)+             (arrPtrsHdrSize profile)+    src_p <- assignTempE $ cmmOffsetExprW platform src+             (cmmAddWord platform+              (mkIntExpr platform (arrPtrsHdrSizeW profile)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))+        (wordAlignment platform)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+                    -> FCode ()+emitCloneSmallArray info_p res_r src src_off n = do+    profile  <- getProfile+    platform <- getPlatform++    let info_ptr = mkLblExpr info_p+        rep = smallArrPtrsRep n++    tickyAllocPrim (mkIntExpr platform (smallArrPtrsHdrSize profile))+        (mkIntExpr platform (nonHdrSize platform rep))+        (zeroExpr platform)++    let hdr_size = fixedHdrSize profile++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr platform n,+                        hdr_size + pc_OFFSET_StgSmallMutArrPtrs_ptrs (platformConstants platform))+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord platform)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB platform (CmmReg arr)+             (smallArrPtrsHdrSize profile)+    src_p <- assignTempE $ cmmOffsetExprW platform src+             (cmmAddWord platform+              (mkIntExpr platform (smallArrPtrsHdrSizeW profile)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr platform (wordsToBytes platform n))+        (wordAlignment platform)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes and offset in the destination array, the base address of+-- the card table, and the number of elements affected (*not* the+-- number of cards). The number of elements may not be zero.+-- Marks the relevant cards as dirty.+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()+emitSetCards dst_start dst_cards_start n = do+    platform <- getPlatform+    start_card <- assignTempE $ cardCmm platform dst_start+    let end_card = cardCmm platform+                   (cmmSubWord platform+                    (cmmAddWord platform dst_start (mkIntExpr platform n))+                    (mkIntExpr platform 1))+    emitMemsetCall (cmmAddWord platform dst_cards_start start_card)+        (mkIntExpr platform 1)+        (cmmAddWord platform (cmmSubWord platform end_card start_card) (mkIntExpr platform 1))+        (mkAlignment 1) -- no alignment (1 byte)++-- Convert an element index to a card index+cardCmm :: Platform -> CmmExpr -> CmmExpr+cardCmm platform i =+    cmmUShrWord platform i (mkIntExpr platform (pc_MUT_ARR_PTRS_CARD_BITS (platformConstants platform)))++------------------------------------------------------------------------------+-- SmallArray PrimOp implementations++doReadSmallPtrArrayOp :: LocalReg+                      -> CmmExpr+                      -> CmmExpr+                      -> FCode ()+doReadSmallPtrArrayOp res addr idx = do+    profile <- getProfile+    platform <- getPlatform+    mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing (gcWord platform) res addr+        (gcWord platform) idx++doWriteSmallPtrArrayOp :: CmmExpr+                       -> CmmExpr+                       -> CmmExpr+                       -> FCode ()+doWriteSmallPtrArrayOp addr idx val = do+    profile <- getProfile+    platform <- getPlatform+    let ty = cmmExprType platform val++    -- Update remembered set for non-moving collector+    tmp <- newTemp ty+    mkBasicIndexedRead (smallArrPtrsHdrSize profile) Nothing ty tmp addr ty idx+    whenUpdRemSetEnabled $ emitUpdRemSetPush (CmmReg (CmmLocal tmp))++    emitPrimCall [] MO_WriteBarrier [] -- #12469+    mkBasicIndexedWrite (smallArrPtrsHdrSize profile) Nothing addr ty idx val+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++------------------------------------------------------------------------------+-- Atomic read-modify-write++-- | Emit an atomic modification to a byte array element. The result+-- reg contains that previous value of the element. Implies a full+-- memory barrier.+doAtomicByteArrayRMW+            :: LocalReg      -- ^ Result reg+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)+            -> CmmExpr       -- ^ MutableByteArray#+            -> CmmExpr       -- ^ Index+            -> CmmType       -- ^ Type of element by which we are indexing+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)+            -> FCode ()+doAtomicByteArrayRMW res amop mba idx idx_ty n = do+    profile <- getProfile+    platform <- getPlatform+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)+                width mba idx+    doAtomicAddrRMW res amop addr idx_ty n++doAtomicAddrRMW+            :: LocalReg      -- ^ Result reg+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)+            -> CmmExpr       -- ^ Addr#+            -> CmmType       -- ^ Pointed value type+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)+            -> FCode ()+doAtomicAddrRMW res amop addr ty n =+    emitPrimCall+        [ res ]+        (MO_AtomicRMW (typeWidth ty) amop)+        [ addr, n ]++-- | Emit an atomic read to a byte array that acts as a memory barrier.+doAtomicReadByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> FCode ()+doAtomicReadByteArray res mba idx idx_ty = do+    profile <- getProfile+    platform <- getPlatform+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)+                width mba idx+    doAtomicReadAddr res addr idx_ty++-- | Emit an atomic read to an address that acts as a memory barrier.+doAtomicReadAddr+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ Addr#+    -> CmmType   -- ^ Type of element by which we are indexing+    -> FCode ()+doAtomicReadAddr res addr ty =+    emitPrimCall+        [ res ]+        (MO_AtomicRead (typeWidth ty))+        [ addr ]++-- | Emit an atomic write to a byte array that acts as a memory barrier.+doAtomicWriteByteArray+    :: CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Value to write+    -> FCode ()+doAtomicWriteByteArray mba idx idx_ty val = do+    profile <- getProfile+    platform <- getPlatform+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr platform (arrWordsHdrSize profile)+                width mba idx+    doAtomicWriteAddr addr idx_ty val++-- | Emit an atomic write to an address that acts as a memory barrier.+doAtomicWriteAddr+    :: CmmExpr   -- ^ Addr#+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Value to write+    -> FCode ()+doAtomicWriteAddr addr ty val =+    emitPrimCall+        [ {- no results -} ]+        (MO_AtomicWrite (typeWidth ty))+        [ addr, val ]++doCasByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Old value+    -> CmmExpr   -- ^ New value+    -> FCode ()+doCasByteArray res mba idx idx_ty old new = do+    profile <- getProfile+    platform <- getPlatform+    let width = (typeWidth idx_ty)+        addr = cmmIndexOffExpr platform (arrWordsHdrSize profile)+               width mba idx+    emitPrimCall+        [ res ]+        (MO_Cmpxchg width)+        [ addr, old, new ]++------------------------------------------------------------------------------+-- Helpers for emitting function calls++-- | Emit a call to @memcpy@.+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemcpyCall dst src n align =+    emitPrimCall+        [ {-no results-} ]+        (MO_Memcpy (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memmove@.+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemmoveCall dst src n align =+    emitPrimCall+        [ {- no results -} ]+        (MO_Memmove (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memset@.  The second argument must fit inside an+-- unsigned char.+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemsetCall dst c n align =+    emitPrimCall+        [ {- no results -} ]+        (MO_Memset (alignmentBytes align))+        [ dst, c, n ]++emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemcmpCall res ptr1 ptr2 n align = do+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all+    -- code-gens currently call out to the @memcmp(3)@ C function.+    -- This was easier than moving the sign-extensions into+    -- all the code-gens.+    platform <- getPlatform+    let is32Bit = typeWidth (localRegType res) == W32++    cres <- if is32Bit+              then return res+              else newTemp b32++    emitPrimCall+        [ cres ]+        (MO_Memcmp align)+        [ ptr1, ptr2, n ]++    unless is32Bit $+      emit $ mkAssign (CmmLocal res)+                      (CmmMachOp+                         (mo_s_32ToWord platform)+                         [(CmmReg (CmmLocal cres))])++emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBSwapCall res x width =+    emitPrimCall+        [ res ]+        (MO_BSwap width)+        [ x ]++emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBRevCall res x width =+    emitPrimCall+        [ res ]+        (MO_BRev width)+        [ x ]++emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitPopCntCall res x width =+    emitPrimCall+        [ res ]+        (MO_PopCnt width)+        [ x ]++emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPdepCall res x y width =+    emitPrimCall+        [ res ]+        (MO_Pdep width)+        [ x, y ]++emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPextCall res x y width =+    emitPrimCall+        [ res ]+        (MO_Pext width)+        [ x, y ]++emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitClzCall res x width =+    emitPrimCall+        [ res ]+        (MO_Clz width)+        [ x ]++emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitCtzCall res x width =     emitPrimCall         [ res ]         (MO_Ctz width)

GHC/StgToCmm/Prof.hs view

@@ -10,6 +10,9 @@         initCostCentres, ccType, ccsType,         mkCCostCentre, mkCCostCentreStack, +        -- infoTablePRov+        initInfoTableProv, emitInfoTableProv,+         -- Cost-centre Profiling         dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,         enterCostCentreThunk, enterCostCentreFun,@@ -25,7 +28,11 @@  import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Platform+import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad@@ -37,11 +44,16 @@ import GHC.Cmm.CLabel  import GHC.Types.CostCentre-import GHC.Driver.Session+import GHC.Types.IPE+import GHC.Types.ForeignStubs import GHC.Data.FastString import GHC.Unit.Module as Module import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Driver.CodeOutput ( ipInitCode ) +import GHC.Utils.Encoding+ import Control.Monad import Data.Char (ord) @@ -67,32 +79,30 @@ mkCCostCentreStack :: CostCentreStack -> CmmLit mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs) -costCentreFrom :: DynFlags-               -> CmmExpr         -- A closure pointer+costCentreFrom :: Platform+               -> CmmExpr        -- A closure pointer                -> CmmExpr        -- The cost centre from that closure-costCentreFrom dflags cl = CmmLoad (cmmOffsetB platform cl (oFFSET_StgHeader_ccs dflags)) (ccsType platform)-  where platform = targetPlatform dflags+costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform)  -- | The profiling header words in a static closure-staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]-staticProfHdr dflags ccs-  | sccProfilingEnabled dflags = [mkCCostCentreStack ccs, staticLdvInit platform]+staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]+staticProfHdr profile ccs+  | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform]   | otherwise                  = []-  where platform = targetPlatform dflags+  where platform = profilePlatform profile  -- | Profiling header words in a dynamic closure-dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]-dynProfHdr dflags ccs-  | sccProfilingEnabled dflags = [ccs, dynLdvInit dflags]+dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]+dynProfHdr profile ccs+  | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)]   | otherwise                  = []  -- | Initialise the profiling field of an update frame initUpdFrameProf :: CmmExpr -> FCode () initUpdFrameProf frame   = ifProfiling $        -- frame->header.prof.ccs = CCCS-    do dflags <- getDynFlags-       platform <- getPlatform-       emitStore (cmmOffset platform frame (oFFSET_StgHeader_ccs dflags)) cccsExpr+    do platform <- getPlatform+       emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr         -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)         -- is unnecessary because it is not used anyhow. @@ -152,9 +162,9 @@ profDynAlloc :: SMRep -> CmmExpr -> FCode () profDynAlloc rep ccs   = ifProfiling $-    do dflags <- getDynFlags-       platform <- getPlatform-       profAlloc (mkIntExpr platform (heapClosureSizeW dflags rep)) ccs+    do profile <- targetProfile <$> getDynFlags+       let platform = profilePlatform profile+       profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs  -- | Record the allocation of a closure (size is given by a CmmExpr) -- The size must be in words, because the allocation counter in a CCS counts@@ -162,16 +172,16 @@ profAlloc :: CmmExpr -> CmmExpr -> FCode () profAlloc words ccs   = ifProfiling $-        do dflags <- getDynFlags-           platform <- getPlatform-           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags-           emit (addToMemE alloc_rep-                       (cmmOffsetB platform ccs (oFFSET_CostCentreStack_mem_alloc dflags))+        do profile <- targetProfile <$> getDynFlags+           let platform = profilePlatform profile+           let alloc_rep = rEP_CostCentreStack_mem_alloc platform+           emit $ addToMemE alloc_rep+                       (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform)))                        (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $-                         [CmmMachOp (mo_wordSub platform) [words,-                                                           mkIntExpr platform (profHdrSize dflags)]]))-                       -- subtract the "profiling overhead", which is the-                       -- profiling header in a closure.+                           -- subtract the "profiling overhead", which is the+                           -- profiling header in a closure.+                           [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]+                       )  -- ----------------------------------------------------------------------- -- Setting the current cost centre on entry to a closure@@ -179,23 +189,23 @@ enterCostCentreThunk :: CmmExpr -> FCode () enterCostCentreThunk closure =   ifProfiling $ do-      dflags <- getDynFlags-      emit $ storeCurCCS (costCentreFrom dflags closure)+      platform <- getPlatform+      emit $ storeCurCCS (costCentreFrom platform closure)  enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode () enterCostCentreFun ccs closure =-  ifProfiling $ do+  ifProfiling $     if isCurrentCCS ccs-       then do dflags <- getDynFlags+       then do platform <- getPlatform                emitRtsCall rtsUnitId (fsLit "enterFunCCS")                    [(baseExpr, AddrHint),-                    (costCentreFrom dflags closure, AddrHint)] False+                    (costCentreFrom platform closure, AddrHint)] False        else return () -- top-level function, nothing to do  ifProfiling :: FCode () -> FCode () ifProfiling code-  = do dflags <- getDynFlags-       if sccProfilingEnabled dflags+  = do profile <- targetProfile <$> getDynFlags+       if profileIsProfiling profile            then code            else return () @@ -206,10 +216,9 @@ initCostCentres :: CollectedCCs -> FCode () -- Emit the declarations initCostCentres (local_CCs, singleton_CCSs)-  = do dflags <- getDynFlags-       when (sccProfilingEnabled dflags) $-           do mapM_ emitCostCentreDecl local_CCs-              mapM_ emitCostCentreStackDecl singleton_CCSs+  = ifProfiling $ do+      mapM_ emitCostCentreDecl local_CCs+      mapM_ emitCostCentreStackDecl singleton_CCSs   emitCostCentreDecl :: CostCentre -> FCode ()@@ -223,9 +232,8 @@   ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS                                         $ moduleName                                         $ cc_mod cc)-  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $+  ; loc <- newByteStringCLit $ utf8EncodeString $                    showPpr dflags (costCentreSrcSpan cc)-           -- XXX going via FastString to get UTF-8 encoding is silly   ; let      lits = [ zero platform,  -- StgInt ccID,               label,          -- char *label,@@ -243,11 +251,10 @@ emitCostCentreStackDecl ccs   = case maybeSingletonCCS ccs of     Just cc ->-        do dflags <- getDynFlags-           platform <- getPlatform+        do platform <- getPlatform            let mk_lits cc = zero platform :                             mkCCostCentre cc :-                            replicate (sizeof_ccs_words dflags - 2) (zero platform)+                            replicate (sizeof_ccs_words platform - 2) (zero platform)                 -- Note: to avoid making any assumptions about how the                 -- C compiler (that compiles the RTS, in particular) does                 -- layouts of structs containing long-longs, simply@@ -261,27 +268,70 @@ zero64 :: CmmLit zero64 = CmmInt 0 W64 -sizeof_ccs_words :: DynFlags -> Int-sizeof_ccs_words dflags+sizeof_ccs_words :: Platform -> Int+sizeof_ccs_words platform     -- round up to the next word.   | ms == 0   = ws   | otherwise = ws + 1   where-   platform = targetPlatform dflags-   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` platformWordSizeInBytes platform+   (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform ++initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub+-- Emit the declarations+initInfoTableProv infos itmap this_mod+  = do+       dflags <- getDynFlags+       let ents = convertInfoProvMap dflags infos this_mod itmap+       --pprTraceM "UsedInfo" (ppr (length infos))+       --pprTraceM "initInfoTable" (ppr (length ents))+       -- Output the actual IPE data+       mapM_ emitInfoTableProv ents+       -- Create the C stub which initialises the IPE_LIST+       return (ipInitCode dflags this_mod ents)++--- Info Table Prov stuff+emitInfoTableProv :: InfoProvEnt  -> FCode ()+emitInfoTableProv ip = do+  { dflags <- getDynFlags+  ; let mod = infoProvModule ip+  ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (infoTableProv ip)+  ; platform <- getPlatform+  ; let mk_string = newByteStringCLit . utf8EncodeString+  ; label <- mk_string label+  ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS+                                        $ moduleName+                                        $ mod)++  ; ty_string  <- mk_string (infoTableType ip)+  ; loc <- mk_string src+  ; table_name <- mk_string (showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip)))+  ; closure_type <- mk_string+                      (showPpr dflags (text $ show $ infoProvEntClosureType ip))+  ; let+     lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer+              table_name,     -- char *table_name+              closure_type,   -- char *closure_desc -- Filled in from the InfoTable+              ty_string,      -- char *ty_string+              label,          -- char *label,+              modl,           -- char *module,+              loc,            -- char *srcloc,+              zero platform   -- struct _InfoProvEnt *link+            ]+  ; emitDataLits (mkIPELabel ip) lits+  } -- --------------------------------------------------------------------------- -- Set the current cost centre stack  emitSetCCC :: CostCentre -> Bool -> Bool -> FCode () emitSetCCC cc tick push- = do dflags <- getDynFlags-      platform <- getPlatform-      if not (sccProfilingEnabled dflags)+ = do profile <- targetProfile <$> getDynFlags+      let platform = profilePlatform profile+      if not (profileIsProfiling profile)           then return ()           else do tmp <- newTemp (ccsType platform)                   pushCostCentre tmp cccsExpr cc-                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))+                  when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))                   when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))  pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()@@ -292,11 +342,10 @@                                 (CmmLit (mkCCostCentre cc), AddrHint)]         False -bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph-bumpSccCount dflags ccs-  = addToMem (rEP_CostCentreStack_scc_count dflags)-         (cmmOffsetB platform ccs (oFFSET_CostCentreStack_scc_count dflags)) 1-  where platform = targetPlatform dflags+bumpSccCount :: Platform -> CmmExpr -> CmmAGraph+bumpSccCount platform ccs+  = addToMem (rEP_CostCentreStack_scc_count platform)+         (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1  ----------------------------------------------------------------------------- --@@ -313,22 +362,20 @@ -- -- Initial value of the LDV field in a dynamic closure ---dynLdvInit :: DynFlags -> CmmExpr-dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE+dynLdvInit :: Platform -> CmmExpr+dynLdvInit platform =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE   CmmMachOp (mo_wordOr platform) [-      CmmMachOp (mo_wordShl platform) [loadEra dflags, mkIntExpr platform (lDV_SHIFT dflags)],-      CmmLit (mkWordCLit platform (iLDV_STATE_CREATE dflags))+      CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))],+      CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform)))   ]-  where-   platform = targetPlatform dflags  -- -- Initialise the LDV word of a new closure -- ldvRecordCreate :: CmmExpr -> FCode () ldvRecordCreate closure = do-  dflags <- getDynFlags-  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)+  platform <- getPlatform+  emit $ mkStore (ldvWord platform closure) (dynLdvInit platform)  -- -- | Called when a closure is entered, marks the closure as having@@ -337,40 +384,37 @@ -- ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode () ldvEnterClosure closure_info node_reg = do-    dflags <- getDynFlags     platform <- getPlatform-    let tag = funTag dflags closure_info+    let tag = funTag platform closure_info     -- don't forget to subtract node's tag     ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag))  ldvEnter :: CmmExpr -> FCode () -- Argument is a closure pointer ldvEnter cl_ptr = do-    dflags <- getDynFlags     platform <- getPlatform-    let -- don't forget to subtract node's tag-        ldv_wd = ldvWord dflags cl_ptr+    let constants = platformConstants platform+        -- don't forget to subtract node's tag+        ldv_wd = ldvWord platform cl_ptr         new_ldv_wd = cmmOrWord platform                         (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))-                                             (CmmLit (mkWordCLit platform (iLDV_CREATE_MASK dflags))))-                        (cmmOrWord platform (loadEra dflags) (CmmLit (mkWordCLit platform (iLDV_STATE_USE dflags))))+                                             (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants))))+                        (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants))))     ifProfiling $          -- if (era > 0) {          --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |          --                era | LDV_STATE_USE }-        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra dflags, CmmLit (zeroCLit platform)])+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)])                      (mkStore ldv_wd new_ldv_wd)                      mkNop -loadEra :: DynFlags -> CmmExpr-loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth platform))+loadEra :: Platform -> CmmExpr+loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform))     [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))-             (cInt dflags)]-    where platform = targetPlatform dflags+             (cInt platform)] -ldvWord :: DynFlags -> CmmExpr -> CmmExpr--- Takes the address of a closure, and returns+-- | Takes the address of a closure, and returns -- the address of the LDV word in the closure-ldvWord dflags closure_ptr-    = cmmOffsetB platform closure_ptr (oFFSET_StgHeader_ldvw dflags)-    where platform = targetPlatform dflags+ldvWord :: Platform -> CmmExpr -> CmmExpr+ldvWord platform closure_ptr+    = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform))

GHC/StgToCmm/Ticky.hs view

@@ -103,6 +103,8 @@ import GHC.Prelude  import GHC.Platform+import GHC.Platform.Profile+ import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString ) import GHC.StgToCmm.Closure import GHC.StgToCmm.Utils@@ -120,9 +122,11 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc  import GHC.Driver.Session+import GHC.Driver.Ppr  -- Turgid imports for showTypeCategory import GHC.Builtin.Names@@ -340,20 +344,20 @@ --          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */ --          f_ct.registeredp = 1 } registerTickyCtr ctr_lbl = do-  dflags <- getDynFlags   platform <- getPlatform   let+    constants = platformConstants platform     -- krc: code generator doesn't handle Not, so we test for Eq 0 instead     test = CmmMachOp (MO_Eq (wordWidth platform))               [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord platform),+                                (pc_OFFSET_StgEntCounter_registeredp constants))) (bWord platform),                zeroExpr platform]     register_stmts-      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants)))                    (CmmLoad ticky_entry_ctrs (bWord platform))         , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)         , mkStore (CmmLit (cmmLabelOffB ctr_lbl-                                (oFFSET_StgEntCounter_registeredp dflags)))+                                (pc_OFFSET_StgEntCounter_registeredp constants)))                    (mkIntExpr platform 1) ]     ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))   emit =<< mkCmmIfThen test (catAGraphs register_stmts)@@ -405,10 +409,11 @@  tickySlowCallPat (map argPrimRep args)  tickySlowCallPat :: [PrimRep] -> FCode ()-tickySlowCallPat args = ifTicky $-  let argReps = map toArgRep args+tickySlowCallPat args = ifTicky $ do+  platform <- profilePlatform <$> getProfile+  let argReps = map (toArgRep platform) args       (_, n_matched) = slowCallPattern argReps-  in if n_matched > 0 && args `lengthIs` n_matched+  if n_matched > 0 && args `lengthIs` n_matched      then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps      else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr" @@ -440,9 +445,9 @@ -- -- TODO what else to count while we're here? tickyDynAlloc mb_id rep lf = ifTicky $ do-  dflags <- getDynFlags-  let platform = targetPlatform dflags-      bytes = platformWordSizeInBytes platform * heapClosureSizeW dflags rep+  profile <- getProfile+  let platform = profilePlatform profile+      bytes = platformWordSizeInBytes platform * heapClosureSizeW profile rep        countGlobal tot ctr = do         bumpTickyCounterBy tot bytes@@ -482,8 +487,7 @@ -- Must be lazy in the amount of allocation! tickyAllocHeap genuine hp   = ifTicky $-    do  { dflags <- getDynFlags-        ; platform <- getPlatform+    do  { platform <- getPlatform         ; ticky_ctr <- getTickyCtrLabel         ; emit $ catAGraphs $             -- only test hp from within the emit so that the monadic@@ -492,8 +496,8 @@           if hp == 0 then []           else let !bytes = platformWordSizeInBytes platform * hp in [             -- Bump the allocation total in the closure's StgEntCounter-            addToMem (rEP_StgEntCounter_allocs dflags)-                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))+            addToMem (rEP_StgEntCounter_allocs platform)+                     (CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform))))                      bytes,             -- Bump the global allocation total ALLOC_HEAP_tot             addToMemLbl (bWord platform)@@ -576,13 +580,13 @@  bumpTickyEntryCount :: CLabel -> FCode () bumpTickyEntryCount lbl = do-  dflags <- getDynFlags-  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))+  platform <- getPlatform+  bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform)))  bumpTickyAllocd :: CLabel -> Int -> FCode () bumpTickyAllocd lbl bytes = do-  dflags <- getDynFlags-  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes+  platform <- getPlatform+  bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_allocd (platformConstants platform))) bytes  bumpTickyLbl :: CLabel -> FCode () bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1@@ -608,9 +612,8 @@  bumpHistogram :: FastString -> Int -> FCode () bumpHistogram lbl n = do-    dflags <- getDynFlags     platform <- getPlatform-    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)+    let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) - 1)     emit (addToMem (bWord platform)            (cmmIndexExpr platform                 (wordWidth platform)

GHC/StgToCmm/Types.hs view

@@ -15,11 +15,13 @@ import GHC.Prelude  import GHC.Types.Basic+import GHC.Types.ForeignStubs import GHC.Core.DataCon import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Utils.Outputable + {- Note [Conveying CAF-info and LFInfo between modules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -86,6 +88,8 @@       -- either not exported of CAFFY.   , cgLFInfos :: !ModuleLFInfos       -- ^ LambdaFormInfos of exported closures in the current module.+  , cgIPEStub :: !CStub+      -- ^ The C stub which is used for IPE information   }  --------------------------------------------------------------------------------

GHC/StgToCmm/Utils.hs view

@@ -44,6 +44,8 @@         whenUpdRemSetEnabled,         emitUpdRemSetPush,         emitUpdRemSetPushThunk,++        convertInfoProvMap, cmmInfoTableToInfoProvEnt   ) where  #include "HsVersions.h"@@ -76,16 +78,25 @@ import GHC.Driver.Session import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.RepType import GHC.Types.CostCentre+import GHC.Types.IPE  import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import qualified Data.Map as M import Data.Char-import Data.List+import Data.List (sortBy) import Data.Ord-+import GHC.Types.Unique.Map+import Data.Maybe+import GHC.Driver.Ppr+import qualified Data.List.NonEmpty as NE+import GHC.Core.DataCon+import GHC.Types.Unique.FM+import GHC.Data.Maybe+import Control.Monad  ------------------------------------------------------------------------- --@@ -105,8 +116,14 @@                                           (wordWidth platform)    LitNullAddr                  -> zeroCLit platform    (LitNumber LitNumInt i)      -> CmmInt i (wordWidth platform)+   (LitNumber LitNumInt8 i)     -> CmmInt i W8+   (LitNumber LitNumInt16 i)    -> CmmInt i W16+   (LitNumber LitNumInt32 i)    -> CmmInt i W32    (LitNumber LitNumInt64 i)    -> CmmInt i W64    (LitNumber LitNumWord i)     -> CmmInt i (wordWidth platform)+   (LitNumber LitNumWord8 i)    -> CmmInt i W8+   (LitNumber LitNumWord16 i)   -> CmmInt i W16+   (LitNumber LitNumWord32 i)   -> CmmInt i W32    (LitNumber LitNumWord64 i)   -> CmmInt i W64    (LitFloat r)                 -> CmmFloat r W32    (LitDouble r)                -> CmmFloat r W64@@ -197,9 +214,9 @@    -> Bool -- True <=> CmmSafe call    -> FCode () emitRtsCallGen res lbl args safe-  = do { dflags <- getDynFlags+  = do { platform <- targetPlatform <$> getDynFlags        ; updfr_off <- getUpdFrameOff-       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags+       ; let (caller_save, caller_load) = callerSaveVolatileRegs platform        ; emit caller_save        ; call updfr_off        ; emit caller_load }@@ -245,13 +262,11 @@ -- "GHC.Cmm.Node".  Right now the workaround is to avoid inlining across -- unsafe foreign calls in GHC.Cmm.Sink, but this is strictly -- temporary.-callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)-callerSaveVolatileRegs dflags = (caller_save, caller_load)+callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)+callerSaveVolatileRegs platform = (caller_save, caller_load)   where-    platform = targetPlatform dflags--    caller_save = catAGraphs (map (callerSaveGlobalReg    dflags) regs_to_save)-    caller_load = catAGraphs (map (callerRestoreGlobalReg dflags) regs_to_save)+    caller_save = catAGraphs (map (callerSaveGlobalReg    platform) regs_to_save)+    caller_load = catAGraphs (map (callerRestoreGlobalReg platform) regs_to_save)      system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery                     {- ,SparkHd,SparkTl,SparkBase,SparkLim -}@@ -259,14 +274,14 @@      regs_to_save = filter (callerSaves platform) system_regs -callerSaveGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph-callerSaveGlobalReg dflags reg-    = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))+callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph+callerSaveGlobalReg platform reg+    = mkStore (get_GlobalReg_addr platform reg) (CmmReg (CmmGlobal reg)) -callerRestoreGlobalReg :: DynFlags -> GlobalReg -> CmmAGraph-callerRestoreGlobalReg dflags reg+callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph+callerRestoreGlobalReg platform reg     = mkAssign (CmmGlobal reg)-               (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType (targetPlatform dflags) reg))+               (CmmLoad (get_GlobalReg_addr platform reg) (globalRegType platform reg))   -------------------------------------------------------------------------@@ -284,7 +299,8 @@ emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)  emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()-emitDataCon lbl itbl ccs payload = emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))+emitDataCon lbl itbl ccs payload =+  emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))  newStringCLit :: String -> FCode CmmLit -- Make a global definition for the string,@@ -365,7 +381,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 ()@@ -609,7 +625,7 @@ -- remembered set. emitUpdRemSetPush :: CmmExpr   -- ^ value of pointer which was overwritten                   -> FCode ()-emitUpdRemSetPush ptr = do+emitUpdRemSetPush ptr =     emitRtsCall       rtsUnitId       (fsLit "updateRemembSetPushClosure_")@@ -619,10 +635,46 @@  emitUpdRemSetPushThunk :: CmmExpr -- ^ the thunk                        -> FCode ()-emitUpdRemSetPushThunk ptr = do+emitUpdRemSetPushThunk ptr =     emitRtsCall       rtsUnitId       (fsLit "updateRemembSetPushThunk_")       [(CmmReg (CmmGlobal BaseReg), AddrHint),        (ptr, AddrHint)]       False++-- | A bare bones InfoProvEnt for things which don't have a good source location+cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt+cmmInfoTableToInfoProvEnt this_mod cmit =+    let cl = cit_lbl cmit+        cn  = rtsClosureType (cit_rep cmit)+    in InfoProvEnt cl cn "" this_mod Nothing++-- | Convert source information collected about identifiers in 'GHC.STG.Debug'+-- to entries suitable for placing into the info table provenenance table.+convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]+convertInfoProvMap dflags defns this_mod (InfoTableProvMap (UniqMap dcenv) denv) =+  map (\cmit ->+    let cl = cit_lbl cmit+        cn  = rtsClosureType (cit_rep cmit)++        tyString :: Outputable a => a -> String+        tyString t = showPpr dflags t++        lookupClosureMap :: Maybe InfoProvEnt+        lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of+                                Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan)+                                Nothing -> Nothing++        lookupDataConMap = do+            UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation+            -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do+            (dc, ns) <- (hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique)+            -- Lookup is linear but lists will be small (< 100)+            return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))++        -- This catches things like prim closure types and anything else which doesn't have a+        -- source location+        simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit++    in fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns

GHC/SysTools.hs view

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+ {- ----------------------------------------------------------------------------- --@@ -8,8 +11,6 @@ ----------------------------------------------------------------------------- -} -{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}- module GHC.SysTools (         -- * Initialisation         initSysTools,@@ -19,21 +20,12 @@         module GHC.SysTools.Tasks,         module GHC.SysTools.Info, -        linkDynLib,-         copy,         copyWithHeader,          -- * General utilities         Option(..),         expandTopDir,--        -- * Platform-specifics-        libmLinkOpts,--        -- * Mac OS X frameworks-        getUnitFrameworkOpts,-        getFrameworkOpts  ) where  #include "HsVersions.h"@@ -42,23 +34,20 @@  import GHC.Settings.Utils -import GHC.Unit-import GHC.Utils.Outputable import GHC.Utils.Error-import GHC.Platform+import GHC.Utils.Panic+import GHC.Utils.Logger import GHC.Driver.Session-import GHC.Driver.Ways  import Control.Monad.Trans.Except (runExceptT) import System.FilePath import System.IO import System.IO.Unsafe (unsafeInterleaveIO)-import GHC.SysTools.ExtraObj+import GHC.Linker.ExtraObj import GHC.SysTools.Info import GHC.SysTools.Tasks import GHC.SysTools.BaseDir import GHC.Settings.IO-import qualified Data.Set as Set  {- Note [How GHC finds toolchain utilities]@@ -137,15 +126,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@@ -195,13 +186,13 @@  -} -copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()-copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to+copy :: Logger -> DynFlags -> String -> FilePath -> FilePath -> IO ()+copy logger dflags purpose from to = copyWithHeader logger dflags purpose Nothing from to -copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath+copyWithHeader :: Logger -> DynFlags -> String -> Maybe String -> FilePath -> FilePath                -> IO ()-copyWithHeader dflags purpose maybe_header from to = do-  showPass dflags purpose+copyWithHeader logger dflags purpose maybe_header from to = do+  showPass logger dflags purpose    hout <- openBinaryFile to   WriteMode   hin  <- openBinaryFile from ReadMode@@ -218,268 +209,3 @@    hSetEncoding h utf8    hPutStr h str    hSetBinaryMode h True--{--************************************************************************-*                                                                      *-\subsection{Support code}-*                                                                      *-************************************************************************--}--linkDynLib :: DynFlags -> [String] -> [UnitId] -> IO ()-linkDynLib dflags0 o_files dep_packages- = do-    let -- This is a rather ugly hack to fix dynamically linked-        -- GHC on Windows. If GHC is linked with -threaded, then-        -- it links against libHSrts_thr. But if base is linked-        -- against libHSrts, then both end up getting loaded,-        -- and things go wrong. We therefore link the libraries-        -- with the same RTS flags that we link GHC with.-        dflags1 = if platformMisc_ghcThreaded $ platformMisc dflags0-          then addWay' WayThreaded dflags0-          else                     dflags0-        dflags = if platformMisc_ghcDebugged $ platformMisc dflags1-          then addWay' WayDebug dflags1-          else                  dflags1--        verbFlags = getVerbFlags dflags-        o_file = outputFile dflags--    pkgs <- getPreloadUnitsAnd dflags dep_packages--    let platform = targetPlatform dflags-        os = platformOS platform-    let pkg_lib_paths = collectLibraryPaths dflags pkgs-    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths-        get_pkg_lib_path_opts l-         | ( osElfTarget (platformOS (targetPlatform dflags)) ||-             osMachOTarget (platformOS (targetPlatform dflags)) ) &&-           dynLibLoader dflags == SystemDependent &&-           -- Only if we want dynamic libraries-           WayDyn `Set.member` ways dflags &&-           -- Only use RPath if we explicitly asked for it-           useXLinkerRPath dflags os-            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]-              -- See Note [-Xlinker -rpath vs -Wl,-rpath]-         | otherwise = ["-L" ++ l]--    let lib_paths = libraryPaths dflags-    let lib_path_opts = map ("-L"++) lib_paths--    -- We don't want to link our dynamic libs against the RTS package,-    -- because the RTS lib comes in several flavours and we want to be-    -- able to pick the flavour when a binary is linked.-    -- On Windows we need to link the RTS import lib as Windows does-    -- not allow undefined symbols.-    -- The RTS library path is still added to the library search path-    -- above in case the RTS is being explicitly linked in (see #3807).-    let pkgs_no_rts = case os of-                      OSMinGW32 ->-                          pkgs-                      _ | gopt Opt_LinkRts dflags ->-                          pkgs-                        | otherwise ->-                          filter ((/= rtsUnitId) . unitId) pkgs-    let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts-                        in  package_hs_libs ++ extra_libs ++ other_flags--        -- probably _stub.o files-        -- and last temporary shared object file-    let extra_ld_inputs = ldInputs dflags--    -- frameworks-    pkg_framework_opts <- getUnitFrameworkOpts dflags platform-                                              (map unitId pkgs)-    let framework_opts = getFrameworkOpts dflags platform--    case os of-        OSMinGW32 -> do-            --------------------------------------------------------------            -- Making a DLL-            --------------------------------------------------------------            let output_fn = case o_file of-                            Just s -> s-                            Nothing -> "HSdll.dll"--            runLink dflags (-                    map Option verbFlags-                 ++ [ Option "-o"-                    , FileOption "" output_fn-                    , Option "-shared"-                    ] ++-                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")-                    | gopt Opt_SharedImplib dflags-                    ]-                 ++ map (FileOption "") o_files--                 -- Permit the linker to auto link _symbol to _imp_symbol-                 -- This lets us link against DLLs without needing an "import library"-                 ++ [Option "-Wl,--enable-auto-import"]--                 ++ extra_ld_inputs-                 ++ map Option (-                    lib_path_opts-                 ++ pkg_lib_path_opts-                 ++ pkg_link_opts-                ))-        _ | os == OSDarwin -> do-            --------------------------------------------------------------------            -- Making a darwin dylib-            --------------------------------------------------------------------            -- About the options used for Darwin:-            -- -dynamiclib-            --   Apple's way of saying -shared-            -- -undefined dynamic_lookup:-            --   Without these options, we'd have to specify the correct-            --   dependencies for each of the dylibs. Note that we could-            --   (and should) do without this for all libraries except-            --   the RTS; all we need to do is to pass the correct-            --   HSfoo_dyn.dylib files to the link command.-            --   This feature requires Mac OS X 10.3 or later; there is-            --   a similar feature, -flat_namespace -undefined suppress,-            --   which works on earlier versions, but it has other-            --   disadvantages.-            -- -single_module-            --   Build the dynamic library as a single "module", i.e. no-            --   dynamic binding nonsense when referring to symbols from-            --   within the library. The NCG assumes that this option is-            --   specified (on i386, at least).-            -- -install_name-            --   Mac OS/X stores the path where a dynamic library is (to-            --   be) installed in the library itself.  It's called the-            --   "install name" of the library. Then any library or-            --   executable that links against it before it's installed-            --   will search for it in its ultimate install location.-            --   By default we set the install name to the absolute path-            --   at build time, but it can be overridden by the-            --   -dylib-install-name option passed to ghc. Cabal does-            --   this.-            ---------------------------------------------------------------------            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }--            instName <- case dylibInstallName dflags of-                Just n -> return n-                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)-            runLink dflags (-                    map Option verbFlags-                 ++ [ Option "-dynamiclib"-                    , Option "-o"-                    , FileOption "" output_fn-                    ]-                 ++ map Option o_files-                 ++ [ Option "-undefined",-                      Option "dynamic_lookup",-                      Option "-single_module" ]-                 ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ]-                     then [ ]-                     else [ Option "-Wl,-read_only_relocs,suppress" ])-                 ++ [ Option "-install_name", Option instName ]-                 ++ map Option lib_path_opts-                 ++ extra_ld_inputs-                 ++ map Option framework_opts-                 ++ map Option pkg_lib_path_opts-                 ++ map Option pkg_link_opts-                 ++ map Option pkg_framework_opts-                 -- 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-            ---------------------------------------------------------------------            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }-                unregisterised = platformUnregisterised (targetPlatform dflags)-            let bsymbolicFlag = -- we need symbolic linking to resolve-                                -- non-PIC intra-package-relocations for-                                -- performance (where symbolic linking works)-                                -- See Note [-Bsymbolic assumptions by GHC]-                                ["-Wl,-Bsymbolic" | not unregisterised]--            runLink dflags (-                    map Option verbFlags-                 ++ libmLinkOpts-                 ++ [ Option "-o"-                    , FileOption "" output_fn-                    ]-                 ++ map Option o_files-                 ++ [ Option "-shared" ]-                 ++ map Option bsymbolicFlag-                    -- Set the library soname. We use -h rather than -soname as-                    -- Solaris 10 doesn't support the latter:-                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]-                 ++ extra_ld_inputs-                 ++ map Option lib_path_opts-                 ++ map Option pkg_lib_path_opts-                 ++ map Option pkg_link_opts-              )---- | Some platforms require that we explicitly link against @libm@ if any--- math-y things are used (which we assume to include all programs). See #14022.-libmLinkOpts :: [Option]-libmLinkOpts =-#if defined(HAVE_LIBM)-  [Option "-lm"]-#else-  []-#endif--getUnitFrameworkOpts :: DynFlags -> Platform -> [UnitId] -> IO [String]-getUnitFrameworkOpts dflags platform dep_packages-  | platformUsesFrameworks platform = do-    pkg_framework_path_opts <- do-        pkg_framework_paths <- getUnitFrameworkPath dflags dep_packages-        return $ map ("-F" ++) pkg_framework_paths--    pkg_framework_opts <- do-        pkg_frameworks <- getUnitFrameworks dflags dep_packages-        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]--    return (pkg_framework_path_opts ++ pkg_framework_opts)--  | otherwise = return []--getFrameworkOpts :: DynFlags -> Platform -> [String]-getFrameworkOpts dflags platform-  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts-  | otherwise = []-  where-    framework_paths     = frameworkPaths dflags-    framework_path_opts = map ("-F" ++) framework_paths--    frameworks     = cmdlineFrameworks dflags-    -- reverse because they're added in reverse order from the cmd line:-    framework_opts = concat [ ["-framework", fw]-                            | fw <- reverse frameworks ]--{--Note [-Bsymbolic assumptions by GHC]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--GHC has a few assumptions about interaction of relocations in NCG and linker:--1. -Bsymbolic resolves internal references when the shared library is linked,-   which is important for performance.-2. When there is a reference to data in a shared library from the main program,-   the runtime linker relocates the data object into the main program using an-   R_*_COPY relocation.-3. If we used -Bsymbolic, then this results in multiple copies of the data-   object, because some references have already been resolved to point to the-   original instance. This is bad!--We work around [3.] for native compiled code by avoiding the generation of-R_*_COPY relocations.--Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable--Bsymbolic linking there.--See related tickets: #4210, #15338--}

GHC/SysTools/BaseDir.hs view

@@ -185,17 +185,19 @@   :: FilePath -- ^ topdir   -> IO (Maybe FilePath) #if defined(mingw32_HOST_OS) && !defined(USE_INPLACE_MINGW_TOOLCHAIN)-findToolDir top_dir = go 0 (top_dir </> "..")+findToolDir top_dir = go 0 (top_dir </> "..") []   where maxDepth = 3-        go :: Int -> FilePath -> IO (Maybe FilePath)-        go k path+        go :: Int -> FilePath -> [FilePath] -> IO (Maybe FilePath)+        go k path tried           | k == maxDepth = throwGhcExceptionIO $-              InstallationError "could not detect mingw toolchain"+              InstallationError $ "could not detect mingw toolchain in the following paths: " ++ show tried           | otherwise = do-              oneLevel <- doesDirectoryExist (path </> "mingw")+              let try = path </> "mingw"+              let tried = tried ++ [try]+              oneLevel <- doesDirectoryExist try               if oneLevel                 then return (Just path)-                else go (k+1) (path </> "..")+                else go (k+1) (path </> "..") tried #else findToolDir _ = return Nothing #endif

GHC/SysTools/Elf.hs view

@@ -23,7 +23,8 @@ import GHC.Utils.Error import GHC.Data.Maybe       (MaybeT(..),runMaybeT) import GHC.Utils.Misc       (charToC)-import GHC.Utils.Outputable (text,hcat,SDoc)+import GHC.Utils.Outputable (text,hcat)+import GHC.Utils.Logger  import Control.Monad (when) import Data.Binary.Get@@ -141,9 +142,9 @@   -- | Read the ELF header-readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader)-readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do-    debugTraceMsg dflags 3 $+readElfHeader :: Logger -> DynFlags -> ByteString -> IO (Maybe ElfHeader)+readElfHeader logger dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do+    debugTraceMsg logger dflags 3 $       text ("Unable to read ELF header")     return Nothing   where@@ -194,13 +195,14 @@   }  -- | Read the ELF section table-readElfSectionTable :: DynFlags+readElfSectionTable :: Logger+                    -> DynFlags                     -> ElfHeader                     -> ByteString                     -> IO (Maybe SectionTable) -readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do-    debugTraceMsg dflags 3 $+readElfSectionTable logger dflags hdr bs = action `catchIO` \_ -> do+    debugTraceMsg logger dflags 3 $       text ("Unable to read ELF section table")     return Nothing   where@@ -245,15 +247,16 @@   }  -- | Read a ELF section-readElfSectionByIndex :: DynFlags+readElfSectionByIndex :: Logger+                      -> DynFlags                       -> ElfHeader                       -> SectionTable                       -> Word64                       -> ByteString                       -> IO (Maybe Section) -readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do-    debugTraceMsg dflags 3 $+readElfSectionByIndex logger dflags hdr secTable i bs = action `catchIO` \_ -> do+    debugTraceMsg logger dflags 3 $       text ("Unable to read ELF section")     return Nothing   where@@ -289,13 +292,14 @@ -- | Find a section from its name. Return the section contents. -- -- We do not perform any check on the section type.-findSectionFromName :: DynFlags+findSectionFromName :: Logger+                    -> DynFlags                     -> ElfHeader                     -> SectionTable                     -> String                     -> ByteString                     -> IO (Maybe ByteString)-findSectionFromName dflags hdr secTable name bs =+findSectionFromName logger dflags hdr secTable name bs =     rec [0..sectionEntryCount secTable - 1]   where     -- convert the required section name into a ByteString to perform@@ -306,7 +310,7 @@     -- the matching one, if any     rec []     = return Nothing     rec (x:xs) = do-      me <- readElfSectionByIndex dflags hdr secTable x bs+      me <- readElfSectionByIndex logger dflags hdr secTable x bs       case me of         Just e | entryName e == name' -> return (Just (entryBS e))         _                             -> rec xs@@ -316,20 +320,21 @@ -- -- If the section isn't found or if there is any parsing error, we return -- Nothing-readElfSectionByName :: DynFlags+readElfSectionByName :: Logger+                     -> DynFlags                      -> ByteString                      -> String                      -> IO (Maybe LBS.ByteString) -readElfSectionByName dflags bs name = action `catchIO` \_ -> do-    debugTraceMsg dflags 3 $+readElfSectionByName logger dflags bs name = action `catchIO` \_ -> do+    debugTraceMsg logger dflags 3 $       text ("Unable to read ELF section \"" ++ name ++ "\"")     return Nothing   where     action = runMaybeT $ do-      hdr      <- MaybeT $ readElfHeader dflags bs-      secTable <- MaybeT $ readElfSectionTable dflags hdr bs-      MaybeT $ findSectionFromName dflags hdr secTable name bs+      hdr      <- MaybeT $ readElfHeader logger dflags bs+      secTable <- MaybeT $ readElfSectionTable logger dflags hdr bs+      MaybeT $ findSectionFromName logger dflags hdr secTable name bs  ------------------ -- NOTE SECTIONS@@ -339,14 +344,15 @@ -- -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned-readElfNoteBS :: DynFlags+readElfNoteBS :: Logger+              -> DynFlags               -> ByteString               -> String               -> String               -> IO (Maybe LBS.ByteString) -readElfNoteBS dflags bs sectionName noteId = action `catchIO`  \_ -> do-    debugTraceMsg dflags 3 $+readElfNoteBS logger dflags bs sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg logger dflags 3 $          text ("Unable to read ELF note \"" ++ noteId ++                "\" in section \"" ++ sectionName ++ "\"")     return Nothing@@ -380,29 +386,30 @@       action = runMaybeT $ do-      hdr  <- MaybeT $ readElfHeader dflags bs-      sec  <- MaybeT $ readElfSectionByName dflags bs sectionName+      hdr  <- MaybeT $ readElfHeader logger dflags bs+      sec  <- MaybeT $ readElfSectionByName logger dflags bs sectionName       MaybeT $ runGetOrThrow (findNote hdr) sec  -- | read a Note as a String -- -- If you try to read a note from a section which does not support the Note -- format, the parsing is likely to fail and Nothing will be returned-readElfNoteAsString :: DynFlags+readElfNoteAsString :: Logger+                    -> DynFlags                     -> FilePath                     -> String                     -> String                     -> IO (Maybe String) -readElfNoteAsString dflags path sectionName noteId = action `catchIO`  \_ -> do-    debugTraceMsg dflags 3 $+readElfNoteAsString logger dflags path sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg logger dflags 3 $          text ("Unable to read ELF note \"" ++ noteId ++                "\" in section \"" ++ sectionName ++ "\"")     return Nothing   where     action = do       bs   <- LBS.readFile path-      note <- readElfNoteBS dflags bs sectionName noteId+      note <- readElfNoteBS logger dflags bs sectionName noteId       return (fmap B8.unpack note)

− GHC/SysTools/ExtraObj.hs

@@ -1,246 +0,0 @@------------------------------------------------------------------------------------ GHC Extra object linking code------ (c) The GHC Team 2017-----------------------------------------------------------------------------------module GHC.SysTools.ExtraObj (-  mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,-  checkLinkInfo, getLinkInfo, getCompilerInfo,-  ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts,-  haveRtsOptsFlags-) where--import GHC.Utils.Asm-import GHC.Utils.Error-import GHC.Driver.Session-import GHC.Unit.State-import GHC.Platform-import GHC.Utils.Outputable as Outputable-import GHC.Types.SrcLoc ( noSrcSpan )-import GHC.Unit-import GHC.SysTools.Elf-import GHC.Utils.Misc-import GHC.Prelude--import Control.Monad-import Data.Maybe--import Control.Monad.IO.Class--import GHC.SysTools.FileCleanup-import GHC.SysTools.Tasks-import GHC.SysTools.Info--mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath-mkExtraObj dflags extn xs- = do cFile <- newTempName dflags TFL_CurrentModule extn-      oFile <- newTempName dflags TFL_GhcSession "o"-      writeFile cFile xs-      ccInfo <- liftIO $ getCompilerInfo dflags-      runCc Nothing dflags-            ([Option        "-c",-              FileOption "" cFile,-              Option        "-o",-              FileOption "" oFile]-              ++ if extn /= "s"-                    then cOpts-                    else asmOpts ccInfo)-      return oFile-    where-      pkgs = unitState dflags--      -- Pass a different set of options to the C compiler depending one whether-      -- we're compiling C or assembler. When compiling C, we pass the usual-      -- set of include directories and PIC flags.-      cOpts = map Option (picCCOpts dflags)-                    ++ map (FileOption "-I")-                            (unitIncludeDirs $ unsafeLookupUnit pkgs rtsUnit)--      -- When compiling assembler code, we drop the usual C options, and if the-      -- compiler is Clang, we add an extra argument to tell Clang to ignore-      -- unused command line options. See trac #11684.-      asmOpts ccInfo =-            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]-                then [Option "-Qunused-arguments"]-                else []---- When linking a binary, we need to create a C main() function that--- starts everything off.  This used to be compiled statically as part--- of the RTS, but that made it hard to change the -rtsopts setting,--- so now we generate and compile a main() stub as part of every--- binary and pass the -rtsopts setting directly to the RTS (#5373)------ On Windows, when making a shared library we also may need a DllMain.----mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath-mkExtraObjToLinkIntoBinary dflags = do-  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do-     putLogMsg dflags NoReason SevInfo noSrcSpan-         $ withPprStyle defaultUserStyle-         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$-          text "    Call hs_init_ghc() from your main() function to set these options.")--  mkExtraObj dflags "c" (showSDoc dflags main)-  where-    main-      | gopt Opt_NoHsMain dflags = Outputable.empty-      | otherwise-          = case ghcLink dflags of-                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32-                                    then dllMain-                                    else Outputable.empty-                  _                      -> exeMain--    exeMain = vcat [-        text "#include <Rts.h>",-        text "extern StgClosure ZCMain_main_closure;",-        text "int main(int argc, char *argv[])",-        char '{',-        text " RtsConfig __conf = defaultRtsConfig;",-        text " __conf.rts_opts_enabled = "-            <> text (show (rtsOptsEnabled dflags)) <> semi,-        text " __conf.rts_opts_suggestions = "-            <> text (if rtsOptsSuggestions dflags-                        then "true"-                        else "false") <> semi,-        text "__conf.keep_cafs = "-            <> text (if gopt Opt_KeepCAFs dflags-                       then "true"-                       else "false") <> semi,-        case rtsOpts dflags of-            Nothing   -> Outputable.empty-            Just opts -> text "    __conf.rts_opts= " <>-                          text (show opts) <> semi,-        text " __conf.rts_hs_main = true;",-        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",-        char '}',-        char '\n' -- final newline, to keep gcc happy-        ]--    dllMain = vcat [-        text "#include <Rts.h>",-        text "#include <windows.h>",-        text "#include <stdbool.h>",-        char '\n',-        text "bool",-        text "WINAPI",-        text "DllMain ( HINSTANCE hInstance STG_UNUSED",-        text "        , DWORD reason STG_UNUSED",-        text "        , LPVOID reserved STG_UNUSED",-        text "        )",-        text "{",-        text "  return true;",-        text "}",-        char '\n' -- final newline, to keep gcc happy-        ]---- Write out the link info section into a new assembly file. Previously--- this was included as inline assembly in the main.c file but this--- is pretty fragile. gas gets upset trying to calculate relative offsets--- that span the .note section (notably .text) when debug info is present-mkNoteObjsToLinkIntoBinary :: DynFlags -> [UnitId] -> IO [FilePath]-mkNoteObjsToLinkIntoBinary dflags dep_packages = do-   link_info <- getLinkInfo dflags dep_packages--   if (platformSupportsSavingLinkOpts (platformOS platform ))-     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))-     else return []--  where-    platform = targetPlatform dflags-    link_opts info = hcat [-      -- "link info" section (see Note [LinkInfo section])-      makeElfNote platform ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,--      -- ALL generated assembly must have this section to disable-      -- executable stacks.  See also-      -- "GHC.CmmToAsm" for another instance-      -- where we need to do this.-      if platformHasGnuNonexecStack platform-        then text ".section .note.GNU-stack,\"\","-             <> sectionType platform "progbits" <> char '\n'-        else Outputable.empty-      ]---- | Return the "link info" string------ See Note [LinkInfo section]-getLinkInfo :: DynFlags -> [UnitId] -> IO String-getLinkInfo dflags dep_packages = do-   package_link_opts <- getUnitLinkOpts dflags dep_packages-   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)-                     then getUnitFrameworks dflags dep_packages-                     else return []-   let extra_ld_inputs = ldInputs dflags-   let-      link_info = (package_link_opts,-                   pkg_frameworks,-                   rtsOpts dflags,-                   rtsOptsEnabled dflags,-                   gopt Opt_NoHsMain dflags,-                   map showOpt extra_ld_inputs,-                   getOpts dflags opt_l)-   ---   return (show link_info)--platformSupportsSavingLinkOpts :: OS -> Bool-platformSupportsSavingLinkOpts os- | os == OSSolaris2 = False -- see #5382- | otherwise        = osElfTarget os---- See Note [LinkInfo section]-ghcLinkInfoSectionName :: String-ghcLinkInfoSectionName = ".debug-ghc-link-info"-  -- if we use the ".debug" prefix, then strip will strip it by default---- Identifier for the note (see Note [LinkInfo section])-ghcLinkInfoNoteName :: String-ghcLinkInfoNoteName = "GHC link info"---- Returns 'False' if it was, and we can avoid linking, because the--- previous binary was linked with "the same options".-checkLinkInfo :: DynFlags -> [UnitId] -> FilePath -> IO Bool-checkLinkInfo dflags pkg_deps exe_file- | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))- -- ToDo: Windows and OS X do not use the ELF binary format, so- -- readelf does not work there.  We need to find another way to do- -- this.- = return False -- conservatively we should return True, but not-                -- linking in this case was the behaviour for a long-                -- time so we leave it as-is.- | otherwise- = do-   link_info <- getLinkInfo dflags pkg_deps-   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)-   m_exe_link_info <- readElfNoteAsString dflags exe_file-                          ghcLinkInfoSectionName ghcLinkInfoNoteName-   let sameLinkInfo = (Just link_info == m_exe_link_info)-   debugTraceMsg dflags 3 $ case m_exe_link_info of-     Nothing -> text "Exe link info: Not found"-     Just s-       | sameLinkInfo -> text ("Exe link info is the same")-       | otherwise    -> text ("Exe link info is different: " ++ s)-   return (not sameLinkInfo)--{- Note [LinkInfo section]-   ~~~~~~~~~~~~~~~~~~~~~~~--The "link info" is a string representing the parameters of the link. We save-this information in the binary, and the next time we link, if nothing else has-changed, we use the link info stored in the existing binary to decide whether-to re-link or not.--The "link info" string is stored in a ELF section called ".debug-ghc-link-info"-(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to-not follow the specified record-based format (see #11022).---}--haveRtsOptsFlags :: DynFlags -> Bool-haveRtsOptsFlags dflags =-        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of-                                       RtsOptsSafeOnly -> False-                                       _ -> True

− GHC/SysTools/FileCleanup.hs

@@ -1,314 +0,0 @@-{-# LANGUAGE CPP #-}-module GHC.SysTools.FileCleanup-  ( TempFileLifetime(..)-  , cleanTempDirs, cleanTempFiles, cleanCurrentModuleTempFiles-  , addFilesToClean, changeTempFilesLifetime-  , newTempName, newTempLibName, newTempDir-  , withSystemTempDirectory, withTempDirectory-  ) where--import GHC.Prelude--import GHC.Driver.Session-import GHC.Utils.Error-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Exception as Exception-import GHC.Driver.Phases--import Control.Monad-import Data.List-import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.IORef-import System.Directory-import System.FilePath-import System.IO.Error--#if !defined(mingw32_HOST_OS)-import qualified System.Posix.Internals-#endif---- | Used when a temp file is created. This determines which component Set of--- FilesToClean will get the temp file-data TempFileLifetime-  = TFL_CurrentModule-  -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the-  -- end of upweep_mod-  | TFL_GhcSession-  -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of-  -- runGhc(T)-  deriving (Show)--cleanTempDirs :: DynFlags -> IO ()-cleanTempDirs dflags-   = unless (gopt Opt_KeepTmpFiles dflags)-   $ mask_-   $ do let ref = dirsToClean dflags-        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)-        removeTmpDirs dflags (Map.elems ds)---- | Delete all files in @filesToClean dflags@.-cleanTempFiles :: DynFlags -> IO ()-cleanTempFiles dflags-   = unless (gopt Opt_KeepTmpFiles dflags)-   $ mask_-   $ do let ref = filesToClean dflags-        to_delete <- atomicModifyIORef' ref $-            \FilesToClean-                { ftcCurrentModule = cm_files-                , ftcGhcSession = gs_files-                } -> ( emptyFilesToClean-                     , Set.toList cm_files ++ Set.toList gs_files)-        removeTmpFiles dflags to_delete---- | Delete all files in @filesToClean dflags@. That have lifetime--- TFL_CurrentModule.--- If a file must be cleaned eventually, but must survive a--- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.-cleanCurrentModuleTempFiles :: DynFlags -> IO ()-cleanCurrentModuleTempFiles dflags-   = unless (gopt Opt_KeepTmpFiles dflags)-   $ mask_-   $ do let ref = filesToClean dflags-        to_delete <- atomicModifyIORef' ref $-            \ftc@FilesToClean{ftcCurrentModule = cm_files} ->-                (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)-        removeTmpFiles dflags to_delete---- | Ensure that new_files are cleaned on the next call of--- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.--- If any of new_files are already tracked, they will have their lifetime--- updated.-addFilesToClean :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()-addFilesToClean dflags lifetime new_files = modifyIORef' (filesToClean dflags) $-  \FilesToClean-    { ftcCurrentModule = cm_files-    , ftcGhcSession = gs_files-    } -> case lifetime of-      TFL_CurrentModule -> FilesToClean-        { ftcCurrentModule = cm_files `Set.union` new_files_set-        , ftcGhcSession = gs_files `Set.difference` new_files_set-        }-      TFL_GhcSession -> FilesToClean-        { ftcCurrentModule = cm_files `Set.difference` new_files_set-        , ftcGhcSession = gs_files `Set.union` new_files_set-        }-  where-    new_files_set = Set.fromList new_files---- | Update the lifetime of files already being tracked. If any files are--- not being tracked they will be discarded.-changeTempFilesLifetime :: DynFlags -> TempFileLifetime -> [FilePath] -> IO ()-changeTempFilesLifetime dflags lifetime files = do-  FilesToClean-    { ftcCurrentModule = cm_files-    , ftcGhcSession = gs_files-    } <- readIORef (filesToClean dflags)-  let old_set = case lifetime of-        TFL_CurrentModule -> gs_files-        TFL_GhcSession -> cm_files-      existing_files = [f | f <- files, f `Set.member` old_set]-  addFilesToClean dflags lifetime existing_files---- Return a unique numeric temp file suffix-newTempSuffix :: DynFlags -> IO Int-newTempSuffix dflags =-  atomicModifyIORef' (nextTempSuffix dflags) $ \n -> (n+1,n)---- Find a temporary name that doesn't already exist.-newTempName :: DynFlags -> TempFileLifetime -> Suffix -> IO FilePath-newTempName dflags lifetime extn-  = do d <- getTempDir dflags-       findTempName (d </> "ghc_") -- See Note [Deterministic base name]-  where-    findTempName :: FilePath -> IO FilePath-    findTempName prefix-      = do n <- newTempSuffix dflags-           let filename = prefix ++ show n <.> extn-           b <- doesFileExist filename-           if b then findTempName prefix-                else do -- clean it up later-                        addFilesToClean dflags lifetime [filename]-                        return filename--newTempDir :: DynFlags -> IO FilePath-newTempDir dflags-  = do d <- getTempDir dflags-       findTempDir (d </> "ghc_")-  where-    findTempDir :: FilePath -> IO FilePath-    findTempDir prefix-      = do n <- newTempSuffix dflags-           let filename = prefix ++ show n-           b <- doesDirectoryExist filename-           if b then findTempDir prefix-                else do createDirectory filename-                        -- see mkTempDir below; this is wrong: -> consIORef (dirsToClean dflags) filename-                        return filename--newTempLibName :: DynFlags -> TempFileLifetime -> Suffix-  -> IO (FilePath, FilePath, String)-newTempLibName dflags lifetime extn-  = do d <- getTempDir dflags-       findTempName d ("ghc_")-  where-    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)-    findTempName dir prefix-      = do n <- newTempSuffix dflags -- See Note [Deterministic base name]-           let libname = prefix ++ show n-               filename = dir </> "lib" ++ libname <.> extn-           b <- doesFileExist filename-           if b then findTempName dir prefix-                else do -- clean it up later-                        addFilesToClean dflags lifetime [filename]-                        return (filename, dir, libname)----- Return our temporary directory within tmp_dir, creating one if we--- don't have one yet.-getTempDir :: DynFlags -> IO FilePath-getTempDir dflags = do-    mapping <- readIORef dir_ref-    case Map.lookup tmp_dir mapping of-        Nothing -> do-            pid <- getProcessID-            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"-            mask_ $ mkTempDir prefix-        Just dir -> return dir-  where-    tmp_dir = tmpDir dflags-    dir_ref = dirsToClean dflags--    mkTempDir :: FilePath -> IO FilePath-    mkTempDir prefix = do-        n <- newTempSuffix dflags-        let our_dir = prefix ++ show n--        -- 1. Speculatively create our new directory.-        createDirectory our_dir--        -- 2. Update the dirsToClean mapping unless an entry already exists-        -- (i.e. unless another thread beat us to it).-        their_dir <- atomicModifyIORef' dir_ref $ \mapping ->-            case Map.lookup tmp_dir mapping of-                Just dir -> (mapping, Just dir)-                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)--        -- 3. If there was an existing entry, return it and delete the-        -- directory we created.  Otherwise return the directory we created.-        case their_dir of-            Nothing  -> do-                debugTraceMsg dflags 2 $-                    text "Created temporary directory:" <+> text our_dir-                return our_dir-            Just dir -> do-                removeDirectory our_dir-                return dir-      `catchIO` \e -> if isAlreadyExistsError e-                      then mkTempDir prefix else ioError e--{- Note [Deterministic base name]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The filename of temporary files, especially the basename of C files, can end-up in the output in some form, e.g. as part of linker debug information. In the-interest of bit-wise exactly reproducible compilation (#4012), the basename of-the temporary file no longer contains random information (it used to contain-the process id).--This is ok, as the temporary directory used contains the pid (see getTempDir).--}-removeTmpDirs :: DynFlags -> [FilePath] -> IO ()-removeTmpDirs dflags ds-  = traceCmd dflags "Deleting temp dirs"-             ("Deleting: " ++ unwords ds)-             (mapM_ (removeWith dflags removeDirectory) ds)--removeTmpFiles :: DynFlags -> [FilePath] -> IO ()-removeTmpFiles dflags fs-  = warnNon $-    traceCmd dflags "Deleting temp files"-             ("Deleting: " ++ unwords deletees)-             (mapM_ (removeWith dflags removeFile) deletees)-  where-     -- Flat out refuse to delete files that are likely to be source input-     -- files (is there a worse bug than having a compiler delete your source-     -- files?)-     ---     -- Deleting source files is a sign of a bug elsewhere, so prominently flag-     -- the condition.-    warnNon act-     | null non_deletees = act-     | otherwise         = do-        putMsg dflags (text "WARNING - NOT deleting source files:"-                       <+> hsep (map text non_deletees))-        act--    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs--removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()-removeWith dflags remover f = remover f `catchIO`-  (\e ->-   let msg = if isDoesNotExistError e-             then text "Warning: deleting non-existent" <+> text f-             else text "Warning: exception raised when deleting"-                                            <+> text f <> colon-               $$ text (show e)-   in debugTraceMsg dflags 2 msg-  )--#if defined(mingw32_HOST_OS)--- relies on Int == Int32 on Windows-foreign import ccall unsafe "_getpid" getProcessID :: IO Int-#else-getProcessID :: IO Int-getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral-#endif---- The following three functions are from the `temporary` package.---- | Create and use a temporary directory in the system standard temporary--- directory.------ Behaves exactly the same as 'withTempDirectory', except that the parent--- temporary directory will be that returned by 'getTemporaryDirectory'.-withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.-                        -> (FilePath -> IO a) -- ^ Callback that can use the directory-                        -> IO a-withSystemTempDirectory template action =-  getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action----- | Create and use a temporary directory.------ Creates a new temporary directory inside the given directory, making use--- of the template. The temp directory is deleted after use. For example:------ > withTempDirectory "src" "sdist." $ \tmpDir -> do ...------ The @tmpDir@ will be a new subdirectory of the given directory, e.g.--- @src/sdist.342@.-withTempDirectory :: FilePath -- ^ Temp directory to create the directory in-                  -> String   -- ^ Directory name template. See 'openTempFile'.-                  -> (FilePath -> IO a) -- ^ Callback that can use the directory-                  -> IO a-withTempDirectory targetDir template =-  Exception.bracket-    (createTempDirectory targetDir template)-    (ignoringIOErrors . removeDirectoryRecursive)--ignoringIOErrors :: IO () -> IO ()-ignoringIOErrors ioe = ioe `catchIO` const (return ())---createTempDirectory :: FilePath -> String -> IO FilePath-createTempDirectory dir template = do-  pid <- getProcessID-  findTempName pid-  where findTempName x = do-            let path = dir </> template ++ show x-            createDirectory path-            return path-          `catchIO` \e -> if isAlreadyExistsError e-                          then findTempName (x+1) else ioError e

GHC/SysTools/Info.hs view

@@ -13,8 +13,9 @@ import GHC.Driver.Session import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Logger -import Data.List+import Data.List ( isInfixOf, isPrefixOf ) import Data.IORef  import System.IO@@ -103,25 +104,25 @@ neededLinkArgs UnknownLD     = []  -- Grab linker info and cache it in DynFlags.-getLinkerInfo :: DynFlags -> IO LinkerInfo-getLinkerInfo dflags = do+getLinkerInfo :: Logger -> DynFlags -> IO LinkerInfo+getLinkerInfo logger dflags = do   info <- readIORef (rtldInfo dflags)   case info of     Just v  -> return v     Nothing -> do-      v <- getLinkerInfo' dflags+      v <- getLinkerInfo' logger dflags       writeIORef (rtldInfo dflags) (Just v)       return v  -- See Note [Run-time linker info].-getLinkerInfo' :: DynFlags -> IO LinkerInfo-getLinkerInfo' dflags = do+getLinkerInfo' :: Logger -> DynFlags -> IO LinkerInfo+getLinkerInfo' logger dflags = do   let platform = targetPlatform dflags       os = platformOS platform       (pgm,args0) = pgm_l dflags-      args1     = map Option (getOpts dflags opt_l)-      args2     = args0 ++ args1-      args3     = filter notNull (map showOpt args2)+      args1       = map Option (getOpts dflags opt_l)+      args2       = args0 ++ args1+      args3       = filter notNull (map showOpt args2)        -- Try to grab the info from the process output.       parseLinkerInfo stdo _stde _exitc@@ -142,83 +143,82 @@           return (GnuGold [Option "-Wl,--no-as-needed"])          | any ("LLD" `isPrefixOf`) stdo =-          return (LlvmLLD $ map Option [-                                      -- see Note [ELF needed shared libs]-                                      "-Wl,--no-as-needed"])+          return (LlvmLLD $ map Option [ --see Note [ELF needed shared libs]+                                        "-Wl,--no-as-needed"])           -- Unknown linker.         | otherwise = fail "invalid --version output, or linker is unsupported"    -- Process the executable call-  info <- catchIO (do-             case os of-               OSSolaris2 ->-                 -- Solaris uses its own Solaris linker. Even all-                 -- GNU C are recommended to configure with Solaris-                 -- linker instead of using GNU binutils linker. Also-                 -- all GCC distributed with Solaris follows this rule-                 -- precisely so we assume here, the Solaris linker is-                 -- used.-                 return $ SolarisLD []-               OSAIX ->-                 -- IBM AIX uses its own non-binutils linker as well-                 return $ AixLD []-               OSDarwin ->-                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker-                 -- that doesn't support --version. We can just assume that's-                 -- what we're using.-                 return $ DarwinLD []-               OSMinGW32 ->-                 -- GHC doesn't support anything but GNU ld on Windows anyway.-                 -- Process creation is also fairly expensive on win32, so-                 -- we short-circuit here.-                 return $ GnuLD $ map Option-                   [ -- Reduce ld memory usage-                     "-Wl,--hash-size=31"-                   , "-Wl,--reduce-memory-overheads"-                     -- Emit gcc stack checks-                     -- Note [Windows stack usage]-                   , "-fstack-check"-                     -- Force static linking of libGCC-                     -- Note [Windows static libGCC]-                   , "-static-libgcc" ]-               _ -> do-                 -- In practice, we use the compiler as the linker here. Pass-                 -- -Wl,--version to get linker version info.-                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm-                                        (["-Wl,--version"] ++ args3)-                                        c_locale_env-                 -- Split the output by lines to make certain kinds-                 -- of processing easier. In particular, 'clang' and 'gcc'-                 -- have slightly different outputs for '-Wl,--version', but-                 -- it's still easy to figure out.-                 parseLinkerInfo (lines stdo) (lines stde) exitc-            )-            (\err -> do-                debugTraceMsg dflags 2-                    (text "Error (figuring out linker information):" <+>-                     text (show err))-                errorMsg dflags $ hang (text "Warning:") 9 $-                  text "Couldn't figure out linker information!" $$-                  text "Make sure you're using GNU ld, GNU gold" <+>-                  text "or the built in OS X linker, etc."-                return UnknownLD)-  return info+  catchIO (+    case os of+      OSSolaris2 ->+        -- Solaris uses its own Solaris linker. Even all+        -- GNU C are recommended to configure with Solaris+        -- linker instead of using GNU binutils linker. Also+        -- all GCC distributed with Solaris follows this rule+        -- precisely so we assume here, the Solaris linker is+        -- used.+        return $ SolarisLD []+      OSAIX ->+        -- IBM AIX uses its own non-binutils linker as well+        return $ AixLD []+      OSDarwin ->+        -- Darwin has neither GNU Gold or GNU LD, but a strange linker+        -- that doesn't support --version. We can just assume that's+        -- what we're using.+        return $ DarwinLD []+      OSMinGW32 ->+        -- GHC doesn't support anything but GNU ld on Windows anyway.+        -- Process creation is also fairly expensive on win32, so+        -- we short-circuit here.+        return $ GnuLD $ map Option+          [ -- Reduce ld memory usage+            "-Wl,--hash-size=31"+          , "-Wl,--reduce-memory-overheads"+            -- Emit gcc stack checks+            -- Note [Windows stack usage]+          , "-fstack-check"+            -- Force static linking of libGCC+            -- Note [Windows static libGCC]+          , "-static-libgcc" ]+      _ -> do+        -- In practice, we use the compiler as the linker here. Pass+        -- -Wl,--version to get linker version info.+        (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm+                               (["-Wl,--version"] ++ args3)+                               c_locale_env+        -- Split the output by lines to make certain kinds+        -- of processing easier. In particular, 'clang' and 'gcc'+        -- have slightly different outputs for '-Wl,--version', but+        -- it's still easy to figure out.+        parseLinkerInfo (lines stdo) (lines stde) exitc+    )+    (\err -> do+        debugTraceMsg logger dflags 2+            (text "Error (figuring out linker information):" <+>+             text (show err))+        errorMsg logger dflags $ hang (text "Warning:") 9 $+          text "Couldn't figure out linker information!" $$+          text "Make sure you're using GNU ld, GNU gold" <+>+          text "or the built in OS X linker, etc."+        return UnknownLD+    )  -- Grab compiler info and cache it in DynFlags.-getCompilerInfo :: DynFlags -> IO CompilerInfo-getCompilerInfo dflags = do+getCompilerInfo :: Logger -> DynFlags -> IO CompilerInfo+getCompilerInfo logger dflags = do   info <- readIORef (rtccInfo dflags)   case info of     Just v  -> return v     Nothing -> do-      v <- getCompilerInfo' dflags+      v <- getCompilerInfo' logger dflags       writeIORef (rtccInfo dflags) (Just v)       return v  -- See Note [Run-time linker info].-getCompilerInfo' :: DynFlags -> IO CompilerInfo-getCompilerInfo' dflags = do+getCompilerInfo' :: Logger -> DynFlags -> IO CompilerInfo+getCompilerInfo' logger dflags = do   let pgm = pgm_c dflags       -- Try to grab the info from the process output.       parseCompilerInfo _stdo stde _exitc@@ -244,19 +244,19 @@         | otherwise = fail $ "invalid -v output, or compiler is unsupported: " ++ unlines stde    -- Process the executable call-  info <- catchIO (do-                (exitc, stdo, stde) <--                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env-                -- Split the output by lines to make certain kinds-                -- of processing easier.-                parseCompilerInfo (lines stdo) (lines stde) exitc-            )-            (\err -> do-                debugTraceMsg dflags 2-                    (text "Error (figuring out C compiler information):" <+>-                     text (show err))-                errorMsg dflags $ hang (text "Warning:") 9 $-                  text "Couldn't figure out C compiler information!" $$-                  text "Make sure you're using GNU gcc, or clang"-                return UnknownCC)-  return info+  catchIO (do+      (exitc, stdo, stde) <-+          readProcessEnvWithExitCode pgm ["-v"] c_locale_env+      -- Split the output by lines to make certain kinds+      -- of processing easier.+      parseCompilerInfo (lines stdo) (lines stde) exitc+      )+      (\err -> do+          debugTraceMsg logger dflags 2+              (text "Error (figuring out C compiler information):" <+>+               text (show err))+          errorMsg logger dflags $ hang (text "Warning:") 9 $+            text "Couldn't figure out C compiler information!" $$+            text "Make sure you're using GNU gcc, or clang"+          return UnknownCC+      )

GHC/SysTools/Process.hs view

@@ -10,16 +10,20 @@  #include "HsVersions.h" +import GHC.Prelude++import GHC.Driver.Session+ import GHC.Utils.Exception import GHC.Utils.Error-import GHC.Driver.Session-import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Prelude import GHC.Utils.Misc-import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )+import GHC.Utils.Logger +import GHC.Types.SrcLoc ( SrcLoc, mkSrcLoc, mkSrcSpan )+import GHC.Data.FastString+ import Control.Concurrent import Data.Char @@ -30,19 +34,24 @@ import System.IO.Error as IO import System.Process -import GHC.SysTools.FileCleanup+import GHC.Utils.TmpFs  -- | Enable process jobs support on Windows if it can be expected to work (e.g. -- @process >= 1.6.9.0@). enableProcessJobs :: CreateProcess -> CreateProcess #if defined(MIN_VERSION_process)-#if MIN_VERSION_process(1,6,9) enableProcessJobs opts = opts { use_process_jobs = True } #else enableProcessJobs opts = opts #endif-#else-enableProcessJobs opts = opts++#if !MIN_VERSION_base(4,15,0)+-- TODO: This can be dropped with GHC 8.16+hGetContents' :: Handle -> IO String+hGetContents' hdl = do+  output  <- hGetContents hdl+  _ <- evaluate $ length output+  return output #endif  -- Similar to System.Process.readCreateProcessWithExitCode, but stderr is@@ -55,13 +64,19 @@         createProcess $ enableProcessJobs $ proc{ std_out = CreatePipe }      -- fork off a thread to start consuming the output-    output  <- hGetContents outh     outMVar <- newEmptyMVar-    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()+    let onError :: SomeException -> IO ()+        onError exc = putMVar outMVar (Left exc)+    _ <- forkIO $ handle onError $ do+      output <- hGetContents' outh+      putMVar outMVar $ Right output      -- wait on the output-    takeMVar outMVar+    result <- takeMVar outMVar     hClose outh+    output <- case result of+      Left exc -> throwIO exc+      Right output -> return output      -- wait on the process     ex <- waitForProcess pid@@ -117,7 +132,8 @@ ----------------------------------------------------------------------------- -- Running an external program -runSomething :: DynFlags+runSomething :: Logger+             -> DynFlags              -> String          -- For -v message              -> String          -- Command name (possibly a full path)                                 --      assumed already dos-ified@@ -125,8 +141,8 @@                                 --      runSomething will dos-ify them              -> IO () -runSomething dflags phase_name pgm args =-  runSomethingFiltered dflags id phase_name pgm args Nothing Nothing+runSomething logger dflags phase_name pgm args =+  runSomethingFiltered logger dflags id phase_name pgm args Nothing Nothing  -- | Run a command, placing the arguments in an external response file. --@@ -138,18 +154,24 @@ --     https://gcc.gnu.org/wiki/Response_Files --     https://gitlab.haskell.org/ghc/ghc/issues/10777 runSomethingResponseFile-  :: DynFlags -> (String->String) -> String -> String -> [Option]-  -> Maybe [(String,String)] -> IO ()--runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =-    runSomethingWith dflags phase_name pgm args $ \real_args -> do+  :: Logger+  -> TmpFs+  -> DynFlags+  -> (String->String)+  -> String+  -> String+  -> [Option]+  -> Maybe [(String,String)]+  -> IO ()+runSomethingResponseFile logger tmpfs dflags filter_fn phase_name pgm args mb_env =+    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do         fp <- getResponseFile real_args         let args = ['@':fp]-        r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env+        r <- builderMainLoop logger dflags filter_fn pgm args Nothing mb_env         return (r,())   where     getResponseFile args = do-      fp <- newTempName dflags TFL_CurrentModule "rsp"+      fp <- newTempName logger tmpfs dflags TFL_CurrentModule "rsp"       withFile fp WriteMode $ \h -> do #if defined(mingw32_HOST_OS)           hSetEncoding h latin1@@ -185,23 +207,23 @@         ]  runSomethingFiltered-  :: DynFlags -> (String->String) -> String -> String -> [Option]+  :: Logger -> DynFlags -> (String->String) -> String -> String -> [Option]   -> Maybe FilePath -> Maybe [(String,String)] -> IO () -runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do-    runSomethingWith dflags phase_name pgm args $ \real_args -> do-        r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env+runSomethingFiltered logger dflags filter_fn phase_name pgm args mb_cwd mb_env =+    runSomethingWith logger dflags phase_name pgm args $ \real_args -> do+        r <- builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env         return (r,())  runSomethingWith-  :: DynFlags -> String -> String -> [Option]+  :: Logger -> DynFlags -> String -> String -> [Option]   -> ([String] -> IO (ExitCode, a))   -> IO a -runSomethingWith dflags phase_name pgm args io = do+runSomethingWith logger dflags phase_name pgm args io = do   let real_args = filter notNull (map showOpt args)       cmdLine = showCommandForUser pgm real_args-  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args+  traceCmd logger dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args  handleProc :: String -> String -> IO (ExitCode, r) -> IO r handleProc pgm phase_name proc = do@@ -221,10 +243,10 @@     does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))  -builderMainLoop :: DynFlags -> (String -> String) -> FilePath+builderMainLoop :: Logger -> DynFlags -> (String -> String) -> FilePath                 -> [String] -> Maybe FilePath -> Maybe [(String, String)]                 -> IO ExitCode-builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do+builderMainLoop logger dflags filter_fn pgm real_args mb_cwd mb_env = do   chan <- newChan    -- We use a mask here rather than a bracket because we want@@ -285,11 +307,10 @@       msg <- readChan chan       case msg of         BuildMsg msg -> do-          putLogMsg dflags NoReason SevInfo noSrcSpan-              $ withPprStyle defaultUserStyle msg+          logInfo logger dflags $ withPprStyle defaultUserStyle msg           log_loop chan t         BuildError loc msg -> do-          putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)+          putLogMsg logger dflags NoReason SevError (mkSrcSpan loc loc)               $ withPprStyle defaultUserStyle msg           log_loop chan t         EOF ->@@ -310,12 +331,12 @@         loop (l:ls) in_err     =                 case in_err of                   Just err@(BuildError srcLoc msg)-                    | leading_whitespace l -> do+                    | leading_whitespace l ->                         loop ls (Just (BuildError srcLoc (msg $$ text l)))                     | otherwise -> do                         writeChan chan err                         checkError l ls-                  Nothing -> do+                  Nothing ->                         checkError l ls                   _ -> panic "readerProc/loop"

GHC/SysTools/Tasks.hs view

@@ -9,31 +9,28 @@ ----------------------------------------------------------------------------- module GHC.SysTools.Tasks where -import GHC.Utils.Exception as Exception-import GHC.Utils.Error+import GHC.Prelude+import GHC.Platform+import GHC.ForeignSrcLang+ import GHC.CmmToLlvm.Base (LlvmVersion, llvmVersionStr, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound, llvmVersionStr, parseLlvmVersion)-import GHC.Driver.Types++import GHC.SysTools.Process+import GHC.SysTools.Info+ import GHC.Driver.Session++import GHC.Utils.Exception as Exception+import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Platform import GHC.Utils.Misc--import Data.List-import Data.Char-import Data.Maybe+import GHC.Utils.Logger+import GHC.Utils.TmpFs +import Data.List (tails, isPrefixOf) import System.IO import System.Process-import GHC.Prelude -import GHC.SysTools.Process-import GHC.SysTools.Info--import Control.Monad (join, forM, filterM, void)-import System.Directory (doesFileExist)-import System.FilePath ((</>))-import Text.ParserCombinators.ReadP as Parser- {- ************************************************************************ *                                                                      *@@ -42,39 +39,39 @@ ************************************************************************ -} -runUnlit :: DynFlags -> [Option] -> IO ()-runUnlit dflags args = traceToolCommand dflags "unlit" $ do+runUnlit :: Logger -> DynFlags -> [Option] -> IO ()+runUnlit logger dflags args = traceToolCommand logger dflags "unlit" $ do   let prog = pgm_L dflags       opts = getOpts dflags opt_L-  runSomething dflags "Literate pre-processor" prog+  runSomething logger dflags "Literate pre-processor" prog                (map Option opts ++ args) -runCpp :: DynFlags -> [Option] -> IO ()-runCpp dflags args = traceToolCommand dflags "cpp" $ do+runCpp :: Logger -> DynFlags -> [Option] -> IO ()+runCpp logger dflags args = traceToolCommand logger dflags "cpp" $ do   let (p,args0) = pgm_P dflags       args1 = map Option (getOpts dflags opt_P)       args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]                 ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]   mb_env <- getGccEnv args2-  runSomethingFiltered dflags id  "C pre-processor" p+  runSomethingFiltered logger dflags id  "C pre-processor" p                        (args0 ++ args1 ++ args2 ++ args) Nothing mb_env -runPp :: DynFlags -> [Option] -> IO ()-runPp dflags args = traceToolCommand dflags "pp" $ do+runPp :: Logger -> DynFlags -> [Option] -> IO ()+runPp logger dflags args = traceToolCommand logger dflags "pp" $ do   let prog = pgm_F dflags       opts = map Option (getOpts dflags opt_F)-  runSomething dflags "Haskell pre-processor" prog (args ++ opts)+  runSomething logger dflags "Haskell pre-processor" prog (args ++ opts)  -- | Run compiler of C-like languages and raw objects (such as gcc or clang).-runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()-runCc mLanguage dflags args = traceToolCommand dflags "cc" $ do+runCc :: Maybe ForeignSrcLang -> Logger -> TmpFs -> DynFlags -> [Option] -> IO ()+runCc mLanguage logger tmpfs dflags args = traceToolCommand logger dflags "cc" $ do   let p = pgm_c dflags       args1 = map Option userOpts       args2 = languageOptions ++ args ++ args1       -- We take care to pass -optc flags in args1 last to ensure that the       -- user can override flags passed by GHC. See #14452.   mb_env <- getGccEnv args2-  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env+  runSomethingResponseFile logger tmpfs dflags cc_filter "C Compiler" p args2 mb_env  where   -- discard some harmless warnings from gcc that we can't turn off   cc_filter = unlines . doFilter . lines@@ -148,44 +145,44 @@ xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)  -- | Run the linker with some arguments and return the output-askLd :: DynFlags -> [Option] -> IO String-askLd dflags args = traceToolCommand dflags "linker" $ do+askLd :: Logger -> DynFlags -> [Option] -> IO String+askLd logger dflags args = traceToolCommand logger dflags "linker" $ do   let (p,args0) = pgm_l dflags       args1     = map Option (getOpts dflags opt_l)       args2     = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  runSomethingWith dflags "gcc" p args2 $ \real_args ->+  runSomethingWith logger dflags "gcc" p args2 $ \real_args ->     readCreateProcessWithExitCode' (proc p real_args){ env = mb_env } -runAs :: DynFlags -> [Option] -> IO ()-runAs dflags args = traceToolCommand dflags "as" $ do+runAs :: Logger -> DynFlags -> [Option] -> IO ()+runAs logger dflags args = traceToolCommand logger dflags "as" $ do   let (p,args0) = pgm_a dflags       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env+  runSomethingFiltered logger dflags id "Assembler" p args2 Nothing mb_env  -- | Run the LLVM Optimiser-runLlvmOpt :: DynFlags -> [Option] -> IO ()-runLlvmOpt dflags args = traceToolCommand dflags "opt" $ do+runLlvmOpt :: Logger -> DynFlags -> [Option] -> IO ()+runLlvmOpt logger dflags args = traceToolCommand logger dflags "opt" $ do   let (p,args0) = pgm_lo dflags       args1 = map Option (getOpts dflags opt_lo)       -- We take care to pass -optlo flags (e.g. args0) last to ensure that the       -- user can override flags passed by GHC. See #14821.-  runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0)+  runSomething logger dflags "LLVM Optimiser" p (args1 ++ args ++ args0)  -- | Run the LLVM Compiler-runLlvmLlc :: DynFlags -> [Option] -> IO ()-runLlvmLlc dflags args = traceToolCommand dflags "llc" $ do+runLlvmLlc :: Logger -> DynFlags -> [Option] -> IO ()+runLlvmLlc logger dflags args = traceToolCommand logger dflags "llc" $ do   let (p,args0) = pgm_lc dflags       args1 = map Option (getOpts dflags opt_lc)-  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)+  runSomething logger dflags "LLVM Compiler" p (args0 ++ args1 ++ args)  -- | Run the clang compiler (used as an assembler for the LLVM -- backend on OS X as LLVM doesn't support the OS X system -- assembler)-runClang :: DynFlags -> [Option] -> IO ()-runClang dflags args = traceToolCommand dflags "clang" $ do+runClang :: Logger -> DynFlags -> [Option] -> IO ()+runClang logger dflags args = traceToolCommand logger dflags "clang" $ do   let (clang,_) = pgm_lcc dflags       -- be careful what options we call clang with       -- see #5903 and #7617 for bugs caused by this.@@ -193,11 +190,10 @@       args1 = map Option (getOpts dflags opt_a)       args2 = args0 ++ args1 ++ args   mb_env <- getGccEnv args2-  catch (do-        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env-    )+  catch+    (runSomethingFiltered logger dflags id "Clang (Assembler)" clang args2 Nothing mb_env)     (\(err :: SomeException) -> do-        errorMsg dflags $+        errorMsg logger dflags $             text ("Error running clang! you need clang installed to use the" ++                   " LLVM backend") $+$             text "(or GHC tried to execute clang incorrectly)"@@ -205,8 +201,8 @@     )  -- | Figure out which version of LLVM we are running this session-figureLlvmVersion :: DynFlags -> IO (Maybe LlvmVersion)-figureLlvmVersion dflags = traceToolCommand dflags "llc" $ do+figureLlvmVersion :: Logger -> DynFlags -> IO (Maybe LlvmVersion)+figureLlvmVersion logger dflags = traceToolCommand logger dflags "llc" $ do   let (pgm,opts) = pgm_lc dflags       args = filter notNull (map showOpt opts)       -- we grab the args even though they should be useless just in@@ -233,10 +229,10 @@               return mb_ver             )             (\err -> do-                debugTraceMsg dflags 2+                debugTraceMsg logger dflags 2                     (text "Error (figuring out LLVM version):" <+>                       text (show err))-                errorMsg dflags $ vcat+                errorMsg logger dflags $ vcat                     [ text "Warning:", nest 9 $                           text "Couldn't figure out LLVM version!" $$                           text ("Make sure you have installed LLVM between ["@@ -247,72 +243,20 @@                 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 _ _ | not (gopt Opt_RPath dflags) = return ()-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 <- lines <$> askOtool dflags Nothing [Option "-l", Option dylib] -  let paths = mapMaybe get_rpath info-      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]--get_rpath :: String -> Maybe FilePath-get_rpath l = case readP_to_S rpath_parser l of-                [(rpath, "")] -> Just rpath-                _ -> Nothing---rpath_parser :: ReadP FilePath-rpath_parser = do-  skipSpaces-  void $ string "path"-  void $ many1 (satisfy isSpace)-  rpath <- many get-  void $ many1 (satisfy isSpace)-  void $ string "(offset "-  void $ munch1 isDigit-  void $ Parser.char ')'-  skipSpaces-  return rpath--runLink :: DynFlags -> [Option] -> IO ()-runLink dflags args = traceToolCommand dflags "linker" $ do+runLink :: Logger -> TmpFs -> DynFlags -> [Option] -> IO ()+runLink logger tmpfs dflags args = traceToolCommand logger dflags "linker" $ do   -- See Note [Run-time linker info]   --   -- `-optl` args come at the end, so that later `-l` options   -- given there manually can fill in symbols needed by   -- Haskell libraries coming in via `args`.-  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags+  linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags   let (p,args0) = pgm_l dflags       optl_args = map Option (getOpts dflags opt_l)       args2     = args0 ++ linkargs ++ args ++ optl_args   mb_env <- getGccEnv args2-  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env+  runSomethingResponseFile logger tmpfs dflags ld_filter "Linker" p args2 mb_env   where     ld_filter = case (platformOS (targetPlatform dflags)) of                   OSSolaris2 -> sunos_ld_filter@@ -364,52 +308,57 @@     ld_warning_found = not . null . snd . ld_warn_break  -- See Note [Merging object files for GHCi] in GHC.Driver.Pipeline.-runMergeObjects :: DynFlags -> [Option] -> IO ()-runMergeObjects dflags args = traceToolCommand dflags "merge-objects" $ do-  let (p,args0) = pgm_lm dflags-      optl_args = map Option (getOpts dflags opt_lm)-      args2     = args0 ++ args ++ optl_args-  -- N.B. Darwin's ld64 doesn't support response files. Consequently we only-  -- use them on Windows where they are truly necessary.+runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () #if defined(mingw32_HOST_OS)-  mb_env <- getGccEnv args2-  runSomethingResponseFile dflags id "Merge objects" p args2 mb_env+runMergeObjects logger tmpfs  dflags args = #else-  runSomething dflags "Merge objects" p args2+runMergeObjects logger _tmpfs dflags args = #endif+  traceToolCommand logger dflags "merge-objects" $ do+    let (p,args0) = pgm_lm dflags+        optl_args = map Option (getOpts dflags opt_lm)+        args2     = args0 ++ args ++ optl_args+    -- N.B. Darwin's ld64 doesn't support response files. Consequently we only+    -- use them on Windows where they are truly necessary.+#if defined(mingw32_HOST_OS)+    mb_env <- getGccEnv args2+    runSomethingResponseFile logger tmpfs dflags id "Merge objects" p args2 mb_env+#else+    runSomething logger dflags "Merge objects" p args2+#endif -runLibtool :: DynFlags -> [Option] -> IO ()-runLibtool dflags args = traceToolCommand dflags "libtool" $ do-  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags+runLibtool :: Logger -> DynFlags -> [Option] -> IO ()+runLibtool logger dflags args = traceToolCommand logger dflags "libtool" $ do+  linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags   let args1      = map Option (getOpts dflags opt_l)       args2      = [Option "-static"] ++ args1 ++ args ++ linkargs       libtool    = pgm_libtool dflags   mb_env <- getGccEnv args2-  runSomethingFiltered dflags id "Libtool" libtool args2 Nothing mb_env+  runSomethingFiltered logger dflags id "Libtool" libtool args2 Nothing mb_env -runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()-runAr dflags cwd args = traceToolCommand dflags "ar" $ do+runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO ()+runAr logger dflags cwd args = traceToolCommand logger dflags "ar" $ do   let ar = pgm_ar dflags-  runSomethingFiltered dflags id "Ar" ar args cwd Nothing+  runSomethingFiltered logger dflags id "Ar" ar args cwd Nothing -askOtool :: DynFlags -> Maybe FilePath -> [Option] -> IO String-askOtool dflags mb_cwd args = do+askOtool :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO String+askOtool logger dflags mb_cwd args = do   let otool = pgm_otool dflags-  runSomethingWith dflags "otool" otool args $ \real_args ->+  runSomethingWith logger dflags "otool" otool args $ \real_args ->     readCreateProcessWithExitCode' (proc otool real_args){ cwd = mb_cwd } -runInstallNameTool :: DynFlags -> [Option] -> IO ()-runInstallNameTool dflags args = do+runInstallNameTool :: Logger -> DynFlags -> [Option] -> IO ()+runInstallNameTool logger dflags args = do   let tool = pgm_install_name_tool dflags-  runSomethingFiltered dflags id "Install Name Tool" tool args Nothing Nothing+  runSomethingFiltered logger dflags id "Install Name Tool" tool args Nothing Nothing -runRanlib :: DynFlags -> [Option] -> IO ()-runRanlib dflags args = traceToolCommand dflags "ranlib" $ do+runRanlib :: Logger -> DynFlags -> [Option] -> IO ()+runRanlib logger dflags args = traceToolCommand logger dflags "ranlib" $ do   let ranlib = pgm_ranlib dflags-  runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing+  runSomethingFiltered logger dflags id "Ranlib" ranlib args Nothing Nothing -runWindres :: DynFlags -> [Option] -> IO ()-runWindres dflags args = traceToolCommand dflags "windres" $ do+runWindres :: Logger -> DynFlags -> [Option] -> IO ()+runWindres logger dflags args = traceToolCommand logger dflags "windres" $ do   let cc = pgm_c dflags       cc_args = map Option (sOpt_c (settings dflags))       windres = pgm_windres dflags@@ -429,11 +378,11 @@             : Option "--use-temp-file"             : args   mb_env <- getGccEnv cc_args-  runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env+  runSomethingFiltered logger dflags id "Windres" windres args' Nothing mb_env -touch :: DynFlags -> String -> String -> IO ()-touch dflags purpose arg = traceToolCommand dflags "touch" $-  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]+touch :: Logger -> DynFlags -> String -> String -> IO ()+touch logger dflags purpose arg = traceToolCommand logger dflags "touch" $+  runSomething logger dflags purpose (pgm_T dflags) [FileOption "" arg]  -- * Tracing utility @@ -444,6 +393,6 @@ -- --   For those events to show up in the eventlog, you need --   to run GHC with @-v2@ or @-ddump-timings@.-traceToolCommand :: DynFlags -> String -> IO a -> IO a-traceToolCommand dflags tool = withTiming+traceToolCommand :: Logger -> DynFlags -> String -> IO a -> IO a+traceToolCommand logger dflags tool = withTiming logger   dflags (text $ "systool:" ++ tool) (const ())

GHC/SysTools/Terminal.hs view

@@ -12,7 +12,7 @@ import System.Posix (queryTerminal, stdError) #elif defined(mingw32_HOST_OS) import Control.Exception (catch, try)-import Data.Bits ((.|.), (.&.))+-- import Data.Bits ((.|.), (.&.)) import Foreign (Ptr, peek, with) import qualified Graphics.Win32 as Win32 import qualified System.Win32 as Win32

GHC/Tc/Deriv.hs view

@@ -26,11 +26,10 @@ import GHC.Core.Predicate import GHC.Tc.Deriv.Infer import GHC.Tc.Deriv.Utils-import GHC.Tc.Validity( allDistinctTyVars ) import GHC.Tc.TyCl.Class( instDeclCtxt3, tcATDefault ) import GHC.Tc.Utils.Env import GHC.Tc.Deriv.Generate-import GHC.Tc.Validity( checkValidInstHead )+import GHC.Tc.Validity( allDistinctTyVars, checkValidInstHead ) import GHC.Core.InstEnv import GHC.Tc.Utils.Instantiate import GHC.Core.FamInstEnv@@ -61,6 +60,8 @@ import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger import GHC.Data.FastString import GHC.Data.Bag import GHC.Utils.FV as FV (fvVarList, unionFV, mkFVs)@@ -199,6 +200,7 @@         ; insts2 <- mapM genInst infer_specs          ; dflags <- getDynFlags+        ; logger <- getLogger          ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)         ; loc <- getSrcSpanM@@ -233,7 +235,7 @@         ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds          ; unless (isEmptyBag inst_info) $-             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"+             liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Derived instances"                         FormatHaskell                         (ddump_deriving inst_info rn_binds famInsts)) @@ -292,7 +294,7 @@         -- before renaming the instances themselves         ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))         ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds-        ; let aux_val_binds = ValBinds noExtField aux_binds (bagToList aux_sigs)+        ; let aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)         -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename         -- auxiliary bindings as if they were defined locally.         -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.@@ -436,17 +438,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.@@ -495,7 +502,7 @@   -- We carefully set up uses of recoverM to minimize error message   -- cascades. See Note [Recovering from failures in deriving clauses].   recoverM (pure Nothing) $-  setSrcSpan (getLoc (hsSigType deriv_pred)) $ do+  setSrcSpan (getLocA deriv_pred) $ do     traceTc "derivePred" $ vcat       [ text "tc"              <+> ppr tc       , text "tys"             <+> ppr tys@@ -618,7 +625,7 @@ -- This returns a Maybe because the user might try to derive Typeable, which is -- a no-op nowadays. deriveStandalone (L loc (DerivDecl _ deriv_ty mb_lderiv_strat overlap_mode))-  = setSrcSpan loc                   $+  = setSrcSpanA loc                       $     addErrCtxt (standaloneCtxt deriv_ty)  $     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)        ; let ctxt = GHC.Tc.Types.Origin.InstDeclCtxt True@@ -713,20 +720,17 @@   :: UserTypeCtxt -> LHsSigWcType GhcRn   -> TcM ([TyVar], DerivContext, Class, [Type]) tcStandaloneDerivInstType ctxt-    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars-                                       , hsib_body   = deriv_ty_body })})-  | (tvs, theta, rho) <- splitLHsSigmaTyInvis deriv_ty_body-  , L _ [wc_pred] <- theta+    (HsWC { hswc_body = deriv_ty@(L loc (HsSig { sig_bndrs = outer_bndrs+                                               , sig_body = deriv_ty_body }))})+  | (theta, rho) <- splitLHsQualTy deriv_ty_body+  , [wc_pred] <- fromMaybeContext theta   , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred-  = do dfun_ty <- tcHsClsInstType ctxt $-                  HsIB { hsib_ext = vars-                       , hsib_body-                           = L (getLoc deriv_ty_body) $-                             HsForAllTy { hst_tele = mkHsForAllInvisTele tvs-                                        , hst_xforall = noExtField-                                        , hst_body  = rho }}+  = do dfun_ty <- tcHsClsInstType ctxt $ L loc $+                  HsSig { sig_ext   = noExtField+                        , sig_bndrs = outer_bndrs+                        , sig_body  = rho }        let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty-       pure (tvs, InferContext (Just wc_span), cls, inst_tys)+       pure (tvs, InferContext (Just (locA wc_span)), cls, inst_tys)   | otherwise   = do dfun_ty <- tcHsClsInstType ctxt deriv_ty        let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty@@ -1167,18 +1171,18 @@       DerivEnv { denv_inst_tys = cls_args                , denv_strat    = mb_strat } <- ask       case mb_strat of-        Just StockStrategy -> do+        Just (StockStrategy _) -> do           (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args           dit                <- expectAlgTyConApp cls_tys inst_ty           mk_eqn_stock dit -        Just AnyclassStrategy -> mk_eqn_anyclass+        Just (AnyclassStrategy _) -> mk_eqn_anyclass          Just (ViaStrategy via_ty) -> do           (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args           mk_eqn_via cls_tys inst_ty via_ty -        Just NewtypeStrategy -> do+        Just (NewtypeStrategy _) -> do           (cls_tys, inst_ty) <- expectNonNullaryClsArgs cls_args           dit                <- expectAlgTyConApp cls_tys inst_ty           unless (isNewTyCon (dit_rep_tc dit)) $@@ -2038,10 +2042,12 @@         -> gen_newtype_or_via rhs_ty        -- Try a stock deriver-      DerivSpecStock { dsm_stock_dit    = DerivInstTys{dit_rep_tc = rep_tc}+      DerivSpecStock { dsm_stock_dit    = DerivInstTys+                        { dit_rep_tc = rep_tc+                        , dit_rep_tc_args = rep_tc_args+                        }                      , dsm_stock_gen_fn = gen_fn }-        -> do (binds, faminsts, field_names) <- gen_fn loc rep_tc inst_tys-              pure (binds, [], faminsts, field_names)+        -> gen_fn loc rep_tc rep_tc_args inst_tys        -- Try DeriveAnyClass       DerivSpecAnyClass -> do@@ -2215,10 +2221,10 @@ gndNonNewtypeErr =   text "GeneralizedNewtypeDeriving cannot be used on non-newtypes" -derivingNullaryErr :: MsgDoc+derivingNullaryErr :: SDoc derivingNullaryErr = text "Cannot derive instances for nullary classes" -derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc+derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> SDoc derivingKindErr tc cls cls_tys cls_kind enough_args   = sep [ hang (text "Cannot derive well-kinded instance of form"                       <+> quotes (pprClassPred cls cls_tys@@ -2233,7 +2239,7 @@                     = text "(Perhaps you intended to use PolyKinds)"                     | otherwise = Outputable.empty -derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc+derivingViaKindErr :: Class -> Kind -> Type -> Kind -> SDoc derivingViaKindErr cls cls_kind via_ty via_kind   = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))        2 (text "Class" <+> quotes (ppr cls)@@ -2242,26 +2248,26 @@       $+$ text "but" <+> quotes (pprType via_ty)                <+> text "has kind" <+> quotes (pprKind via_kind)) -derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc+derivingEtaErr :: Class -> [Type] -> Type -> SDoc derivingEtaErr cls cls_tys inst_ty   = sep [text "Cannot eta-reduce to an instance of form",          nest 2 (text "instance (...) =>"                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]  derivingThingErr :: Bool -> Class -> [Type]-                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc+                 -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc derivingThingErr newtype_deriving cls cls_args mb_strat why   = derivingThingErr' newtype_deriving cls cls_args mb_strat                       (maybe empty derivStrategyName mb_strat) why -derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc+derivingThingErrM :: Bool -> SDoc -> DerivM SDoc derivingThingErrM newtype_deriving why   = do DerivEnv { denv_cls      = cls                 , denv_inst_tys = cls_args                 , denv_strat    = mb_strat } <- ask        pure $ derivingThingErr newtype_deriving cls cls_args mb_strat why -derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc+derivingThingErrMechanism :: DerivSpecMechanism -> SDoc -> DerivM SDoc derivingThingErrMechanism mechanism why   = do DerivEnv { denv_cls      = cls                 , denv_inst_tys = cls_args@@ -2270,7 +2276,7 @@                 (derivStrategyName $ derivSpecMechanismToStrategy mechanism) why  derivingThingErr' :: Bool -> Class -> [Type]-                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc+                  -> Maybe (DerivStrategy GhcTc) -> SDoc -> SDoc -> SDoc derivingThingErr' newtype_deriving cls cls_args mb_strat strat_msg why   = sep [(hang (text "Can't make a derived instance of")              2 (quotes (ppr pred) <+> via_mechanism)

GHC/Tc/Deriv/Functor.hs view

@@ -30,7 +30,7 @@ import GHC.Core.DataCon import GHC.Data.FastString import GHC.Hs-import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Types.Name.Reader import GHC.Types.SrcLoc@@ -151,25 +151,25 @@   $(coreplace 'a '(tb -> tc) x) = \(y:tb[b/a]) -> $(coreplace 'a' 'tc' (x $(replace 'a 'tb y))) -} -gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Functor_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use  fmap _ = coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Functor_binds loc tycon+gen_Functor_binds loc tycon _   | Phantom <- last (tyConRoles tycon)   = (unitBag fmap_bind, emptyBag)   where-    fmap_name = L loc fmap_RDR+    fmap_name = L (noAnnSrcSpan loc) fmap_RDR     fmap_bind = mkRdrFunBind fmap_name fmap_eqns     fmap_eqns = [mkSimpleMatch fmap_match_ctxt                                [nlWildPat]                                coerce_Expr]     fmap_match_ctxt = mkPrefixFunRhs fmap_name -gen_Functor_binds loc tycon+gen_Functor_binds loc tycon tycon_args   = (listToBag [fmap_bind, replace_bind], emptyBag)   where-    data_cons = tyConDataCons tycon-    fmap_name = L loc fmap_RDR+    data_cons = getPossibleDataCons tycon tycon_args+    fmap_name = L (noAnnSrcSpan loc) fmap_RDR      -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]     fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns@@ -208,7 +208,7 @@                  , ft_co_var = panic "contravariant in ft_fmap" }      -- See Note [Deriving <$]-    replace_name = L loc replace_RDR+    replace_name = L (noAnnSrcSpan loc) replace_RDR      -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]     replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns@@ -617,8 +617,7 @@           else nlParPat bare_pat     rhs <- fold con_name                 (zipWith (\i v -> i $ nlHsVar v) insides vars_needed)-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs-                     (noLoc emptyLocalBinds)+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds  -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)" --@@ -668,8 +667,7 @@               in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)      rhs <- fold con_expr exps-    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs-                     (noLoc emptyLocalBinds)+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs emptyLocalBinds  -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]" mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]@@ -787,21 +785,21 @@ think it's okay to do it for now. -} -gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Foldable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the parameter is phantom, we can use foldMap _ _ = mempty -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Foldable_binds loc tycon+gen_Foldable_binds loc tycon _   | Phantom <- last (tyConRoles tycon)   = (unitBag foldMap_bind, emptyBag)   where-    foldMap_name = L loc foldMap_RDR+    foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR     foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns     foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt                                   [nlWildPat, nlWildPat]                                   mempty_Expr]     foldMap_match_ctxt = mkPrefixFunRhs foldMap_name -gen_Foldable_binds loc tycon+gen_Foldable_binds loc tycon tycon_args   | null data_cons  -- There's no real point producing anything but                     -- foldMap for a type with no constructors.   = (unitBag foldMap_bind, emptyBag)@@ -809,16 +807,16 @@   | otherwise   = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)   where-    data_cons = tyConDataCons tycon+    data_cons = getPossibleDataCons tycon tycon_args -    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns+    foldr_bind = mkRdrFunBind (L (noAnnSrcSpan loc) foldable_foldr_RDR) eqns     eqns = map foldr_eqn data_cons     foldr_eqn con       = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs       where         parts = sequence $ foldDataConArgs ft_foldr con -    foldMap_name = L loc foldMap_RDR+    foldMap_name = L (noAnnSrcSpan loc) foldMap_RDR      -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]     foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)@@ -841,7 +839,7 @@       go NotNull = Nothing       go (NullM a) = Just (Just a) -    null_name = L loc null_RDR+    null_name = L (noAnnSrcSpan loc) null_RDR     null_match_ctxt = mkPrefixFunRhs null_name     null_bind = mkRdrFunBind null_name null_eqns     null_eqns = map null_eqn data_cons@@ -851,7 +849,7 @@           case convert parts of             Nothing -> return $               mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]-                false_Expr (noLoc emptyLocalBinds)+                false_Expr emptyLocalBinds             Just cp -> match_null [] con cp      -- Yields 'Just' an expression if we're folding over a type that mentions@@ -1016,14 +1014,14 @@ See Note [Generated code for DeriveFoldable and DeriveTraversable]. -} -gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Traversable_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff) -- When the argument is phantom, we can use traverse = pure . coerce -- See Note [Phantom types with Functor, Foldable, and Traversable]-gen_Traversable_binds loc tycon+gen_Traversable_binds loc tycon _   | Phantom <- last (tyConRoles tycon)   = (unitBag traverse_bind, emptyBag)   where-    traverse_name = L loc traverse_RDR+    traverse_name = L (noAnnSrcSpan loc) traverse_RDR     traverse_bind = mkRdrFunBind traverse_name traverse_eqns     traverse_eqns =         [mkSimpleMatch traverse_match_ctxt@@ -1031,12 +1029,12 @@                        (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]     traverse_match_ctxt = mkPrefixFunRhs traverse_name -gen_Traversable_binds loc tycon+gen_Traversable_binds loc tycon tycon_args   = (unitBag traverse_bind, emptyBag)   where-    data_cons = tyConDataCons tycon+    data_cons = getPossibleDataCons tycon tycon_args -    traverse_name = L loc traverse_RDR+    traverse_name = L (noAnnSrcSpan loc) traverse_RDR      -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]     traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)

GHC/Tc/Deriv/Generate.hs view

@@ -8,6 +8,7 @@ {-# LANGUAGE CPP, ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -33,7 +34,9 @@         mkCoerceClassMethEqn,         genAuxBinds,         ordOpTbl, boxConTbl, litConTbl,-        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr+        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,++        getPossibleDataCons, tyConInstArgTys     ) where  #include "HsVersions.h"@@ -44,8 +47,10 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Core.DataCon import GHC.Types.Name+import GHC.Types.SourceText  import GHC.Driver.Session import GHC.Builtin.Utils@@ -71,6 +76,7 @@ import GHC.Utils.Misc import GHC.Types.Var import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Lexeme import GHC.Data.FastString import GHC.Data.Pair@@ -84,19 +90,13 @@ -- generated. See @Note [Auxiliary binders]@ for a more detailed description -- of how these are used. data AuxBindSpec-  -- DerivCon2Tag, DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,+  -- DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,   -- Enum, and Ix instances.   -- All these generate ZERO-BASED tag operations   -- I.e first constructor has tag 0 -    -- | @$con2tag@: Computes the tag for a given constructor-  = DerivCon2Tag-      TyCon   -- The type constructor of the data type to which the-              -- constructors belong-      RdrName -- The to-be-generated $con2tag binding's RdrName-     -- | @$tag2con@: Given a tag, computes the corresponding data constructor-  | DerivTag2Con+  = DerivTag2Con       TyCon   -- The type constructor of the data type to which the               -- constructors belong       RdrName -- The to-be-generated $tag2con binding's RdrName@@ -130,7 +130,6 @@ -- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec' -- describes. auxBindSpecRdrName :: AuxBindSpec -> RdrName-auxBindSpecRdrName (DerivCon2Tag      _ con2tag_RDR) = con2tag_RDR auxBindSpecRdrName (DerivTag2Con      _ tag2con_RDR) = tag2con_RDR auxBindSpecRdrName (DerivMaxTag       _ maxtag_RDR)  = maxtag_RDR auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR@@ -180,17 +179,17 @@        case (a1 `eqFloat#` a2) of r -> r   for that particular test. -* If there are a lot of (more than ten) nullary constructors, we emit a+* For nullary constructors, we emit a   catch-all clause of the form: -      (==) a b  = case (con2tag_Foo a) of { a# ->-                  case (con2tag_Foo b) of { b# ->+      (==) a b  = case (dataToTag# a) of { a# ->+                  case (dataToTag# b) of { b# ->                   case (a# ==# b#)     of {                     r -> r }}} -  If con2tag gets inlined this leads to join point stuff, so-  it's better to use regular pattern matching if there aren't too-  many nullary constructors.  "Ten" is arbitrary, of course+  An older approach preferred regular pattern matches in some cases+  but with dataToTag# forcing it's argument, and work on improving+  join points, this seems no longer necessary.  * If there aren't any nullary constructors, we emit a simpler   catch-all:@@ -199,7 +198,7 @@  * For the @(/=)@ method, we normally just use the default method.   If the type is an enumeration type, we could/may/should? generate-  special code that calls @con2tag_Foo@, much like for @(==)@ shown+  special code that calls @dataToTag#@, much like for @(==)@ shown   above.  We thought about doing this: If we're also deriving 'Ord' for this@@ -212,26 +211,20 @@ produced don't get through the typechecker. -} -gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Eq_binds loc tycon = do-    -- See Note [Auxiliary binders]-    con2tag_RDR <- new_con2tag_rdr_name loc tycon--    return (method_binds con2tag_RDR, aux_binds con2tag_RDR)+gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Eq_binds loc tycon tycon_args = do+    return (method_binds, emptyBag)   where-    all_cons = tyConDataCons tycon+    all_cons = getPossibleDataCons tycon tycon_args     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons -    -- If there are ten or more (arbitrary number) nullary constructors,-    -- use the con2tag stuff.  For small types it's better to use-    -- ordinary pattern matching.-    (tag_match_cons, pat_match_cons)-       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)-       | otherwise                       = ([],           all_cons)-+    -- For nullary constructors, use the getTag stuff.+    (tag_match_cons, pat_match_cons) = (nullary_cons, non_nullary_cons)     no_tag_match_cons = null tag_match_cons -    fall_through_eqn con2tag_RDR+    -- (LHS patterns, result)+    fall_through_eqn :: [([LPat (GhcPass 'Parsed)] , LHsExpr GhcPs)]+    fall_through_eqn       | no_tag_match_cons   -- All constructors have arguments       = case pat_match_cons of           []  -> []   -- No constructors; no fall-though case@@ -241,20 +234,18 @@                  [([nlWildPat, nlWildPat], false_Expr)]        | otherwise -- One or more tag_match cons; add fall-through of-                  -- extract tags compare for equality+                  -- extract tags compare for equality,+                  -- The case `(C1 x) == (C1 y)` can no longer happen+                  -- at this point as it's matched earlier.       = [([a_Pat, b_Pat],-         untag_Expr con2tag_RDR [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+         untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]                     (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] -    aux_binds con2tag_RDR-      | no_tag_match_cons = emptyBag-      | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR--    method_binds con2tag_RDR = unitBag (eq_bind con2tag_RDR)-    eq_bind con2tag_RDR+    method_binds = unitBag eq_bind+    eq_bind       = mkFunBindEC 2 loc eq_RDR (const true_Expr)                     (map pats_etc pat_match_cons-                      ++ fall_through_eqn con2tag_RDR)+                      ++ fall_through_eqn)      ------------------------------------------------------------------     pats_etc data_con@@ -320,8 +311,8 @@   Take care on the last field to tail-call into comparing av,bv  * To make nullary_rhs generate this-     case con2tag a of a# ->-     case con2tag b of ->+     case dataToTag# a of a# ->+     case dataToTag# b of ->      a# `compare` b#  Several special cases:@@ -396,27 +387,22 @@ gtResult OrdGT      = true_Expr  -------------gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Ord_binds loc tycon = do-    -- See Note [Auxiliary binders]-    con2tag_RDR <- new_con2tag_rdr_name loc tycon-+gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ord_binds loc tycon tycon_args = do     return $ if null tycon_data_cons -- No data-cons => invoke bale-out case       then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []            , emptyBag)-      else ( unitBag (mkOrdOp con2tag_RDR OrdCompare)-             `unionBags` other_ops con2tag_RDR-           , aux_binds con2tag_RDR)+      else ( unitBag (mkOrdOp OrdCompare)+             `unionBags` other_ops+           , aux_binds)   where-    aux_binds con2tag_RDR-      | single_con_type = emptyBag-      | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR+    aux_binds = emptyBag          -- Note [Game plan for deriving Ord]-    other_ops con2tag_RDR+    other_ops       | (last_tag - first_tag) <= 2     -- 1-3 constructors         || null non_nullary_cons        -- Or it's an enumeration-      = listToBag [mkOrdOp con2tag_RDR OrdLT, lE, gT, gE]+      = listToBag [mkOrdOp OrdLT, lE, gT, gE]       | otherwise       = emptyBag @@ -432,7 +418,7 @@         -- We want *zero-based* tags, because that's what         -- con2Tag returns (generated by untag_Expr)! -    tycon_data_cons = tyConDataCons tycon+    tycon_data_cons = getPossibleDataCons tycon tycon_args     single_con_type = isSingleton tycon_data_cons     (first_con : _) = tycon_data_cons     (last_con : _)  = reverse tycon_data_cons@@ -442,40 +428,40 @@     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons  -    mkOrdOp :: RdrName -> OrdOp -> LHsBind GhcPs+    mkOrdOp :: OrdOp -> LHsBind GhcPs     -- Returns a binding   op a b = ... compares a and b according to op ....-    mkOrdOp con2tag_RDR op+    mkOrdOp op       = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]-                        (mkOrdOpRhs con2tag_RDR op)+                        (mkOrdOpRhs op) -    mkOrdOpRhs :: RdrName -> OrdOp -> LHsExpr GhcPs-    mkOrdOpRhs con2tag_RDR op -- RHS for comparing 'a' and 'b' according to op+    mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs+    mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op       | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases       = nlHsCase (nlHsVar a_RDR) $-        map (mkOrdOpAlt con2tag_RDR op) tycon_data_cons+        map (mkOrdOpAlt op) tycon_data_cons         -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...         --                   C2 x   -> case b of C2 x -> ....comopare x.... }        | null non_nullary_cons    -- All nullary, so go straight to comparing tags-      = mkTagCmp con2tag_RDR op+      = mkTagCmp op        | otherwise                -- Mixed nullary and non-nullary       = nlHsCase (nlHsVar a_RDR) $-        (map (mkOrdOpAlt con2tag_RDR op) non_nullary_cons-         ++ [mkHsCaseAlt nlWildPat (mkTagCmp con2tag_RDR op)])+        (map (mkOrdOpAlt op) non_nullary_cons+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])  -    mkOrdOpAlt :: RdrName -> OrdOp -> DataCon+    mkOrdOpAlt :: OrdOp -> DataCon                -> LMatch GhcPs (LHsExpr GhcPs)     -- Make the alternative  (Ki a1 a2 .. av ->-    mkOrdOpAlt con2tag_RDR op data_con+    mkOrdOpAlt op data_con       = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)-                    (mkInnerRhs con2tag_RDR op data_con)+                    (mkInnerRhs op data_con)       where         as_needed    = take (dataConSourceArity data_con) as_RDRs         data_con_RDR = getRdrName data_con -    mkInnerRhs con2tag_RDR op data_con+    mkInnerRhs op data_con       | single_con_type       = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ] @@ -498,21 +484,22 @@                                  , mkHsCaseAlt nlWildPat (gtResult op) ]        | tag > last_tag `div` 2  -- lower range is larger-      = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $+      = untag_Expr [(b_RDR, bh_RDR)] $         nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)                (gtResult op) $  -- Definitely GT         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con                                  , mkHsCaseAlt nlWildPat (ltResult op) ]        | otherwise               -- upper range is larger-      = untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $+      = untag_Expr [(b_RDR, bh_RDR)] $         nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)                (ltResult op) $  -- Definitely LT         nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con                                  , mkHsCaseAlt nlWildPat (gtResult op) ]       where         tag     = get_tag data_con-        tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag)))+        tag_lit+             = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag)))      mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)     -- First argument 'a' known to be built with K@@ -524,11 +511,11 @@         data_con_RDR = getRdrName data_con         bs_needed    = take (dataConSourceArity data_con) bs_RDRs -    mkTagCmp :: RdrName -> OrdOp -> LHsExpr GhcPs+    mkTagCmp :: OrdOp -> LHsExpr GhcPs     -- Both constructors known to be nullary     -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#-    mkTagCmp con2tag_RDR op =-      untag_Expr con2tag_RDR [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $+    mkTagCmp op =+      untag_Expr [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $         unliftedOrdOp intPrimTy op ah_RDR bh_RDR  mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs@@ -591,13 +578,15 @@                         -- mean more tests (dynamically)         nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt   where-    ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR+    ascribeBool e = noLocA $ ExprWithTySig noAnn e+                           $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType+                           $ nlHsTyVar boolTyCon_RDR  nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {})-nlConWildPat con = noLoc $ ConPat-  { pat_con_ext = noExtField-  , pat_con = noLoc $ getRdrName con+nlConWildPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA $ getRdrName con   , pat_args = RecCon $ HsRecFields       { rec_flds = []       , rec_dotdot = Nothing }@@ -615,8 +604,8 @@ data Foo ... = N1 | N2 | ... | Nn \end{verbatim} -we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a-@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).+we use both dataToTag# and @tag2con_Foo@ functions, as well as a+@maxtag_Foo@ variable, the later generated by @gen_tag_n_con_binds.  \begin{verbatim} instance ... Enum (Foo ...) where@@ -625,20 +614,20 @@      toEnum i = tag2con_Foo i -    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]+    enumFrom a = map tag2con_Foo [dataToTag# a .. maxtag_Foo]      -- or, really...     enumFrom a-      = case con2tag_Foo a of+      = case dataToTag# a of           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)     enumFromThen a b-     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]+     = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo]      -- or, really...     enumFromThen a b-      = case con2tag_Foo a of { a# ->-        case con2tag_Foo b of { b# ->+      = case dataToTag# a of { a# ->+        case dataToTag# b of { b# ->         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)         }} \end{verbatim}@@ -646,35 +635,33 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. -} -gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)-gen_Enum_binds loc tycon = do+gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Enum_binds loc tycon _ = do     -- See Note [Auxiliary binders]-    con2tag_RDR <- new_con2tag_rdr_name loc tycon     tag2con_RDR <- new_tag2con_rdr_name loc tycon     maxtag_RDR  <- new_maxtag_rdr_name  loc tycon -    return ( method_binds con2tag_RDR tag2con_RDR maxtag_RDR-           , aux_binds    con2tag_RDR tag2con_RDR maxtag_RDR )+    return ( method_binds tag2con_RDR maxtag_RDR+           , aux_binds    tag2con_RDR maxtag_RDR )   where-    method_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag-      [ succ_enum      con2tag_RDR tag2con_RDR maxtag_RDR-      , pred_enum      con2tag_RDR tag2con_RDR-      , to_enum                    tag2con_RDR maxtag_RDR-      , enum_from      con2tag_RDR tag2con_RDR maxtag_RDR -- [0 ..]-      , enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR -- [0, 1 ..]-      , from_enum      con2tag_RDR+    method_binds tag2con_RDR maxtag_RDR = listToBag+      [ succ_enum      tag2con_RDR maxtag_RDR+      , pred_enum      tag2con_RDR+      , to_enum        tag2con_RDR maxtag_RDR+      , enum_from      tag2con_RDR maxtag_RDR -- [0 ..]+      , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..]+      , from_enum       ]-    aux_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind-      [ DerivCon2Tag tycon con2tag_RDR-      , DerivTag2Con tycon tag2con_RDR+    aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind+      [ DerivTag2Con tycon tag2con_RDR       , DerivMaxTag  tycon maxtag_RDR       ]      occ_nm = getOccString tycon -    succ_enum con2tag_RDR tag2con_RDR maxtag_RDR+    succ_enum tag2con_RDR maxtag_RDR       = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $-        untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $+        untag_Expr [(a_RDR, ah_RDR)] $         nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR,                                nlHsVarApps intDataCon_RDR [ah_RDR]])              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")@@ -682,9 +669,9 @@                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],                                         nlHsIntLit 1])) -    pred_enum con2tag_RDR tag2con_RDR+    pred_enum tag2con_RDR       = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $-        untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $+        untag_Expr [(a_RDR, ah_RDR)] $         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,                                nlHsVarApps intDataCon_RDR [ah_RDR]])              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")@@ -703,18 +690,18 @@              (nlHsVarApps tag2con_RDR [a_RDR])              (illegal_toEnum_tag occ_nm maxtag_RDR) -    enum_from con2tag_RDR tag2con_RDR maxtag_RDR+    enum_from tag2con_RDR maxtag_RDR       = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $-          untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $+          untag_Expr [(a_RDR, ah_RDR)] $           nlHsApps map_RDR                 [nlHsVar tag2con_RDR,                  nlHsPar (enum_from_to_Expr                             (nlHsVarApps intDataCon_RDR [ah_RDR])                             (nlHsVar maxtag_RDR))] -    enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR+    enum_from_then tag2con_RDR maxtag_RDR       = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $-          untag_Expr con2tag_RDR [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $+          untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $             nlHsPar (enum_from_then_to_Expr                     (nlHsVarApps intDataCon_RDR [ah_RDR])@@ -725,9 +712,9 @@                            (nlHsVar maxtag_RDR)                            )) -    from_enum con2tag_RDR+    from_enum       = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $-          untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $+          untag_Expr [(a_RDR, ah_RDR)] $           (nlHsVarApps intDataCon_RDR [ah_RDR])  {-@@ -738,8 +725,8 @@ ************************************************************************ -} -gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)-gen_Bounded_binds loc tycon+gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Bounded_binds loc tycon _   | isEnumerationTyCon tycon   = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)   | otherwise@@ -783,32 +770,32 @@ \begin{verbatim} instance ... Ix (Foo ...) where     range (a, b)-      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]+      = map tag2con_Foo [dataToTag# a .. dataToTag# b]      -- or, really...     range (a, b)-      = case (con2tag_Foo a) of { a# ->-        case (con2tag_Foo b) of { b# ->+      = case (dataToTag# a) of { a# ->+        case (dataToTag# b) of { b# ->         map tag2con_Foo (enumFromTo (I# a#) (I# b#))         }}      -- Generate code for unsafeIndex, because using index leads     -- to lots of redundant range tests     unsafeIndex c@(a, b) d-      = case (con2tag_Foo d -# con2tag_Foo a) of+      = case (dataToTag# d -# dataToTag# a) of                r# -> I# r#      inRange (a, b) c       = let-            p_tag = con2tag_Foo c+            p_tag = dataToTag# c         in-        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b+        p_tag >= dataToTag# a && p_tag <= dataToTag# b      -- or, really...     inRange (a, b) c-      = case (con2tag_Foo a)   of { a_tag ->-        case (con2tag_Foo b)   of { b_tag ->-        case (con2tag_Foo c)   of { c_tag ->+      = case (dataToTag# a)   of { a_tag ->+        case (dataToTag# b)   of { b_tag ->+        case (dataToTag# c)   of { c_tag ->         if (c_tag >=# a_tag) then           c_tag <=# b_tag         else@@ -825,43 +812,41 @@ (p.~147). -} -gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff) -gen_Ix_binds loc tycon = do+gen_Ix_binds loc tycon _ = do     -- See Note [Auxiliary binders]-    con2tag_RDR <- new_con2tag_rdr_name loc tycon     tag2con_RDR <- new_tag2con_rdr_name loc tycon      return $ if isEnumerationTyCon tycon-      then (enum_ixes con2tag_RDR tag2con_RDR, listToBag $ map DerivAuxBind-                   [ DerivCon2Tag tycon con2tag_RDR-                   , DerivTag2Con tycon tag2con_RDR+      then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind+                   [ DerivTag2Con tycon tag2con_RDR                    ])-      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon con2tag_RDR)))+      else (single_con_ixes, emptyBag)   where     ---------------------------------------------------------------    enum_ixes con2tag_RDR tag2con_RDR = listToBag-      [ enum_range   con2tag_RDR tag2con_RDR-      , enum_index   con2tag_RDR-      , enum_inRange con2tag_RDR+    enum_ixes tag2con_RDR = listToBag+      [ enum_range   tag2con_RDR+      , enum_index+      , enum_inRange       ] -    enum_range con2tag_RDR tag2con_RDR+    enum_range tag2con_RDR       = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $-          untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $-          untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $+          untag_Expr [(a_RDR, ah_RDR)] $+          untag_Expr [(b_RDR, bh_RDR)] $           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $               nlHsPar (enum_from_to_Expr                         (nlHsVarApps intDataCon_RDR [ah_RDR])                         (nlHsVarApps intDataCon_RDR [bh_RDR])) -    enum_index con2tag_RDR+    enum_index       = mkSimpleGeneratedFunBind loc unsafeIndex_RDR-                [noLoc (AsPat noExtField (noLoc c_RDR)+                [noLocA (AsPat noAnn (noLocA c_RDR)                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),                                 d_Pat] (-           untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (-           untag_Expr con2tag_RDR [(d_RDR, dh_RDR)] (+           untag_Expr [(a_RDR, ah_RDR)] (+           untag_Expr [(d_RDR, dh_RDR)] (            let                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]            in@@ -872,11 +857,11 @@         )      -- This produces something like `(ch >= ah) && (ch <= bh)`-    enum_inRange con2tag_RDR+    enum_inRange       = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $-          untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (-          untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] (-          untag_Expr con2tag_RDR [(c_RDR, ch_RDR)] (+          untag_Expr [(a_RDR, ah_RDR)] (+          untag_Expr [(b_RDR, bh_RDR)] (+          untag_Expr [(c_RDR, ch_RDR)] (           -- This used to use `if`, which interacts badly with RebindableSyntax.           -- See #11396.           nlHsApps and_RDR@@ -908,13 +893,13 @@     single_con_range       = mkSimpleGeneratedFunBind loc range_RDR           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $-        noLoc (mkHsComp ListComp stmts con_expr)+        noLocA (mkHsComp ListComp stmts con_expr)       where         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed -        mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c)+        mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c)                                  (nlHsApp (nlHsVar range_RDR)-                                          (mkLHsVarTuple [a,b]))+                                          (mkLHsVarTuple [a,b] noAnn))      ----------------     single_con_index@@ -936,11 +921,11 @@             ) plus_RDR (                 genOpApp (                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)-                             (mkLHsVarTuple [l,u]))+                             (mkLHsVarTuple [l,u] noAnn))                 ) times_RDR (mk_index rest)            )         mk_one l u i-          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]+          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, nlHsVar i]      ------------------     single_con_inRange@@ -954,7 +939,8 @@              else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range                     as_needed bs_needed cs_needed)       where-        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]+        in_range a b c+          = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c]  {- ************************************************************************@@ -1028,10 +1014,10 @@ we want to be able to parse (Left 3) just fine. -} -gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon+gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]                -> (LHsBinds GhcPs, BagDerivStuff) -gen_Read_binds get_fixity loc tycon+gen_Read_binds get_fixity loc tycon _   = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)   where     -----------------------------------------------------------------------@@ -1059,7 +1045,7 @@     read_nullary_cons       = case nullary_cons of             []    -> []-            [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]+            [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLocA $ mkLastStmt (result_expr con [])])]             _     -> [nlHsApp (nlHsVar choose_RDR)                               (nlList (map mk_pair nullary_cons))]         -- NB For operators the parens around (:=:) are matched by the@@ -1074,7 +1060,7 @@         -- and   Symbol s   for operators      mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),-                                  result_expr con []]+                                  result_expr con []] noAnn      read_non_nullary_con data_con       | is_infix  = mk_parser infix_prec  infix_stmts  body@@ -1133,7 +1119,7 @@     ------------------------------------------------------------------------     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })-                                           , nlHsDo (DoExpr Nothing) (ss ++ [noLoc $ mkLastStmt b])]+                                           , nlHsDo (DoExpr Nothing) (ss ++ [noLocA $ mkLastStmt b])]     con_app con as     = nlHsVarApps (getRdrName con) as                -- con as     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) @@ -1143,7 +1129,7 @@     ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]                   | otherwise                    = [ ident_pat s ] -    bindLex pat  = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))  -- expectP p+    bindLex pat  = noLocA (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p                    -- See Note [Use expectP]     ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")     symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")@@ -1152,7 +1138,7 @@     data_con_str con = occNameString (getOccName con)      read_arg a ty = ASSERT( not (isUnliftedType ty) )-                    noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))+                    noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))      -- When reading field labels we might encounter     --      a  = 3@@ -1160,8 +1146,8 @@     -- or   (#) = 4     -- Note the parens!     read_field lbl a =-        [noLoc-          (mkPsBindStmt+        [noLocA+          (mkPsBindStmt noAnn             (nlVarPat a)             (nlHsApp               read_field@@ -1212,13 +1198,13 @@                     -- the most tightly-binding operator -} -gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon+gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]                -> (LHsBinds GhcPs, BagDerivStuff) -gen_Show_binds get_fixity loc tycon+gen_Show_binds get_fixity loc tycon tycon_args   = (unitBag shows_prec, emptyBag)   where-    data_cons = tyConDataCons tycon+    data_cons = getPossibleDataCons tycon tycon_args     shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)     comma_space = nlHsVar showCommaSpace_RDR @@ -1385,9 +1371,10 @@ gen_Data_binds :: SrcSpan                -> TyCon                 -- For data families, this is the                                         --  *representation* TyCon+               -> [Type]                -> TcM (LHsBinds GhcPs,  -- The method bindings                        BagDerivStuff)   -- Auxiliary bindings-gen_Data_binds loc rep_tc+gen_Data_binds loc rep_tc _   = do { -- See Note [Auxiliary binders]          dataT_RDR  <- new_dataT_rdr_name loc rep_tc        ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons@@ -1495,7 +1482,7 @@ kind1 = typeToTypeKind kind2 = liftedTypeKind `mkVisFunTyMany` kind1 -gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,+gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,     mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,     dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,     constr_RDR, dataType_RDR,@@ -1503,14 +1490,20 @@     eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,     eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,     eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,+    eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,+    eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR ,     eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,     eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,     eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,+    eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR,+    eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR,     eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,     eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,     eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,-    extendWord8_RDR, extendInt8_RDR,-    extendWord16_RDR, extendInt16_RDR :: RdrName+    word8ToWord_RDR , int8ToInt_RDR ,+    word16ToWord_RDR, int16ToInt_RDR,+    word32ToWord_RDR, int32ToInt_RDR+    :: RdrName gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl") gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold") toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")@@ -1519,7 +1512,7 @@ dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2") gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1") gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")-mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")+mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag") constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr") mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType") dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")@@ -1551,6 +1544,18 @@ gtInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt16#" ) geInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt16#") +eqInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt32#")+ltInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt32#" )+leInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt32#")+gtInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt32#" )+geInt32_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt32#")++eqInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt64#")+ltInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt64#" )+leInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt64#")+gtInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt64#" )+geInt64_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt64#")+ eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#") ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#") leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")@@ -1569,6 +1574,18 @@ gtWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord16#" ) geWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord16#") +eqWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord32#")+ltWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord32#" )+leWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord32#")+gtWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord32#" )+geWord32_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord32#")++eqWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord64#")+ltWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord64#" )+leWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord64#")+gtWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord64#" )+geWord64_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord64#")+ eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#") ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#") leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")@@ -1587,13 +1604,16 @@ gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" ) geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##") -extendWord8_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord8#")-extendInt8_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt8#")+word8ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word8ToWord#")+int8ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int8ToInt#") -extendWord16_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord16#")-extendInt16_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt16#")+word16ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word16ToWord#")+int16ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int16ToInt#") +word32ToWord_RDR = varQual_RDR  gHC_PRIM (fsLit "word32ToWord#")+int32ToInt_RDR   = varQual_RDR  gHC_PRIM (fsLit "int32ToInt#") + {- ************************************************************************ *                                                                      *@@ -1616,8 +1636,8 @@ -}  -gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)-gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)+gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)+gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)   where     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)                                  (map (pats_etc mk_exp) data_cons)@@ -1626,7 +1646,7 @@      mk_exp = ExpBr noExtField     mk_texp = TExpBr noExtField-    data_cons = tyConDataCons tycon+    data_cons = getPossibleDataCons tycon tycon_args      pats_etc mk_bracket data_con       = ([con_pat], lift_Expr)@@ -1635,7 +1655,7 @@             data_con_RDR = getRdrName data_con             con_arity    = dataConSourceArity data_con             as_needed    = take con_arity as_RDRs-            lift_Expr    = noLoc (HsBracket noExtField (mk_bracket br_body))+            lift_Expr    = noLocA (HsBracket noAnn (mk_bracket br_body))             br_body      = nlHsApps (Exact (dataConName data_con))                                     (map nlHsVar as_needed) @@ -1687,19 +1707,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1803,9 +1818,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@@ -1817,6 +1831,94 @@ Then the same situation will arise again. But at least it won't arise for the common case of methods with ordinary, prenex-quantified types. +-----+-- Wrinkle: Use HsOuterExplicit+-----++One minor complication with the plan above is that we need to ensure that the+type variables from a method's instance signature properly scope over the body+of the method. For example, recall:++  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>+      C (T m) where+    join :: forall a. T m (T m a) -> T m a+    join = coerce @(  m   (m a) ->   m a)+                  @(T m (T m a) -> T m a)+                  join++In the example above, it is imperative that the `a` in the instance signature+for `join` scope over the body of `join` by way of ScopedTypeVariables.+This might sound obvious, but note that in gen_Newtype_binds, which is+responsible for generating the code above, the type in `join`'s instance+signature is given as a Core type, whereas gen_Newtype_binds will eventually+produce HsBinds (i.e., source Haskell) that is renamed and typechecked. We+must ensure that `a` is in scope over the body of `join` during renaming+or else the generated code will be rejected.++In short, we need to convert the instance signature from a Core type to an+HsType (i.e., a source Haskell type). Two possible options are:++1. Convert the Core type entirely to an HsType (i.e., a source Haskell type).+2. Embed the entire Core type using HsCoreTy.++Neither option is quite satisfactory:++1. Converting a Core type to an HsType in full generality is surprisingly+   complicated. Previous versions of GHCs did this, but it was the source of+   numerous bugs (see #14579 and #16518, for instance).+2. While HsCoreTy is much less complicated that option (1), it's not quite+   what we want. In order for `a` to be in scope over the body of `join` during+   renaming, the `forall` must be contained in an HsOuterExplicit.+   (See Note [Lexically scoped type variables] in GHC.Hs.Type.) HsCoreTy+   bypasses HsOuterExplicit, so this won't work either.++As a compromise, we adopt a combination of the two options above:++* Split apart the top-level ForAllTys in the instance signature's Core type,+* Convert the top-level ForAllTys to an HsOuterExplicit, and+* Embed the remainder of the Core type in an HsCoreTy.++This retains most of the simplicity of option (2) while still ensuring that+the type variables are correctly scoped.++Note that splitting apart top-level ForAllTys will expand any type synonyms+in the Core type itself. This ends up being important to fix a corner case+observed in #18914. Consider this example:++  type T f = forall a. f a++  class C f where+    m :: T f++  newtype N f a = MkN (f a)+    deriving C++What code should `deriving C` generate? It will have roughly the following+shape:++  instance C f => C (N f) where+    m :: T (N f)+    m = coerce @(...) (...) (m @f)++At a minimum, we must instantiate `coerce` with `@(T f)` and `@(T (N f))`, but+with the `forall`s removed in order to make them monotypes. However, the+`forall` is hidden underneath the `T` type synonym, so we must first expand `T`+before we can strip of the `forall`. Expanding `T`, we get+`coerce @(forall a. f a) @(forall a. N f a)`, and after omitting the `forall`s,+we get `coerce @(f a) @(N f a)`.++We can't stop there, however, or else we would end up with this code:++  instance C f => C (N f) where+    m :: T (N f)+    m = coerce @(f a) @(N f a) (m @f)++Notice that the type variable `a` is completely unbound. In order to make sure+that `a` is in scope, we must /also/ expand the `T` in `m :: T (N f)` to get+`m :: forall a. N f a`. Fortunately, we will do just that in the plan outlined+above, since when we split off the top-level ForAllTys in the instance+signature, we must first expand the T type synonym.+ Note [GND and ambiguity] ~~~~~~~~~~~~~~~~~~~~~~~~ We make an effort to make the code generated through GND be robust w.r.t.@@ -1854,7 +1956,7 @@                   -> Type    -- the representation type                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff) -- See Note [Newtype-deriving instances]-gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty+gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty   = do let ats = classATs cls            (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)        atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )@@ -1863,6 +1965,8 @@               , sigs               , listToBag $ map DerivFamInst atf_insts )   where+    locn = noAnnSrcSpan loc'+    loca = noAnnSrcSpan loc'     -- For each class method, generate its derived binding and instance     -- signature. Using the first example from     -- Note [Newtype-deriving instances]:@@ -1889,16 +1993,33 @@         , -- The derived instance signature, e.g.,           --           --   op :: forall c. a -> [T x] -> c -> Int-          L loc $ ClassOpSig noExtField False [loc_meth_RDR]-                $ mkLHsSigType $ nlHsCoreTy to_ty+          --+          -- Make sure that `forall c` is in an HsOuterExplicit so that it+          -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in+          -- Note [GND and QuantifiedConstraints].+          L loca $ ClassOpSig noAnn False [loc_meth_RDR]+                 $ L loca $ mkHsExplicitSigType noAnn+                              (map mk_hs_tvb to_tvbs)+                              (nlHsCoreTy to_rho)         )       where         Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id-        (_, _, from_tau) = tcSplitSigmaTy from_ty-        (_, _, to_tau)   = tcSplitSigmaTy to_ty+        (_, _, from_tau)  = tcSplitSigmaTy from_ty+        (to_tvbs, to_rho) = tcSplitForAllInvisTVBinders to_ty+        (_, to_tau)       = tcSplitPhiTy to_rho+        -- The use of tcSplitForAllInvisTVBinders above expands type synonyms,+        -- which is important to ensure correct type variable scoping.+        -- See "Wrinkle: Use HsOuterExplicit" in+        -- Note [GND and QuantifiedConstraints]. +        mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs+        mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn+                                                        flag+                                                        (noLocA (getRdrName tv))+                                                        (nlHsCoreTy (tyVarKind tv))+         meth_RDR = getRdrName meth_id-        loc_meth_RDR = L loc meth_RDR+        loc_meth_RDR = L locn meth_RDR          rhs_expr = nlHsVar (getRdrName coerceId)                                       `nlHsAppType`     from_tau@@ -1915,7 +2036,7 @@      mk_atf_inst :: TyCon -> TcM FamInst     mk_atf_inst fam_tc = do-        rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))+        rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))                                            rep_lhs_tys         let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'                                     fam_tc rep_lhs_tys rep_rhs_ty@@ -1944,17 +2065,12 @@     underlying_inst_tys = changeLast inst_tys rhs_ty  nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs-nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty)+nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)   where     hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s -nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs-nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty-  where-    hs_ty = mkLHsSigWcType s--nlHsCoreTy :: Type -> LHsType GhcPs-nlHsCoreTy = noLoc . XHsType . NHsCoreTy+nlHsCoreTy :: HsCoreTy -> LHsType GhcPs+nlHsCoreTy = noLocA . XHsType  mkCoerceClassMethEqn :: Class   -- the class being derived                      -> [TyVar] -- the tvs in the instance head (this includes@@ -1982,14 +2098,13 @@ {- ************************************************************************ *                                                                      *-\subsection{Generating extra binds (@con2tag@, @tag2con@, etc.)}+\subsection{Generating extra binds (@tag2con@, etc.)} *                                                                      * ************************************************************************  \begin{verbatim} data Foo ... = ... -con2tag_Foo :: Foo ... -> Int# tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int# maxtag_Foo  :: Int              -- ditto (NB: not unlifted) \end{verbatim}@@ -2004,27 +2119,12 @@                        -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpecOriginal dflags loc spec   = (gen_bind spec,-     L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)]+     L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]            (genAuxBindSpecSig loc spec)))   where+    loca = noAnnSrcSpan loc+    locn = noAnnSrcSpan loc     gen_bind :: AuxBindSpec -> LHsBind GhcPs-    gen_bind (DerivCon2Tag tycon con2tag_RDR)-      = mkFunBindSE 0 loc con2tag_RDR eqns-      where-        lots_of_constructors = tyConFamilySize tycon > 8-                            -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS-                            -- but we don't do vectored returns any more.--        eqns | lots_of_constructors = [get_tag_eqn]-             | otherwise = map mk_eqn (tyConDataCons tycon)--        get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)--        mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)-        mk_eqn con = ([nlWildConPat con],-                      nlHsLit (HsIntPrim NoSourceText-                                        (toInteger ((dataConTag con) - fIRST_TAG))))-     gen_bind (DerivTag2Con _ tag2con_RDR)       = mkFunBindSE 0 loc tag2con_RDR            [([nlConVarPat intDataCon_RDR [a_RDR]],@@ -2049,12 +2149,12 @@     gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)       = mkHsVarBind loc dataC_RDR rhs       where-        rhs = nlHsApps mkConstr_RDR constr_args+        rhs = nlHsApps mkConstrTag_RDR constr_args          constr_args-           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag-               nlHsVar dataT_RDR                            -- DataType-             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name+           = [ nlHsVar dataT_RDR                            -- DataType+             , nlHsLit (mkHsString (occNameString dc_occ))  -- Constructor name+             , nlHsIntLit (toInteger (dataConTag dc))       -- Constructor tag              , nlList  labels                               -- Field labels              , nlHsVar fixity ]                             -- Fixity @@ -2072,29 +2172,29 @@                   -> (LHsBind GhcPs, LSig GhcPs) genAuxBindSpecDup loc original_rdr_name dup_spec   = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),-     L loc (TypeSig noExtField [L loc dup_rdr_name]+     L loca (TypeSig noAnn [L locn dup_rdr_name]            (genAuxBindSpecSig loc dup_spec)))   where+    loca = noAnnSrcSpan loc+    locn = noAnnSrcSpan loc     dup_rdr_name = auxBindSpecRdrName dup_spec  -- | Generate the type signature of an auxiliary binding. -- See @Note [Auxiliary binders]@. genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs genAuxBindSpecSig loc spec = case spec of-  DerivCon2Tag tycon _-    -> mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $-       mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $-       mkParentType tycon `mkVisFunTyMany` intPrimTy   DerivTag2Con tycon _-    -> mkLHsSigWcType $ L loc $-       XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $+    -> mk_sig $ L (noAnnSrcSpan loc) $+       XHsType $ mkSpecForAllTys (tyConTyVars tycon) $        intTy `mkVisFunTyMany` mkParentType tycon   DerivMaxTag _ _-    -> mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))+    -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))   DerivDataDataType _ _ _-    -> mkLHsSigWcType (nlHsTyVar dataType_RDR)+    -> mk_sig (nlHsTyVar dataType_RDR)   DerivDataConstr _ _ _-    -> mkLHsSigWcType (nlHsTyVar constr_RDR)+    -> mk_sig (nlHsTyVar constr_RDR)+  where+    mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType  type SeparateBagsDerivStuff =   -- DerivAuxBinds@@ -2157,17 +2257,17 @@              -> [([LPat GhcPs], LHsExpr GhcPs)]              -> LHsBind GhcPs mkFunBindSE arity loc fun pats_and_exprs-  = mkRdrFunBindSE arity (L loc fun) matches+  = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches   where-    matches = [mkMatch (mkPrefixFunRhs (L loc fun))+    matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))                                (map (parenthesizePat appPrec) p) e-                               (noLoc emptyLocalBinds)+                               emptyLocalBinds               | (p,e) <-pats_and_exprs] -mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]+mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]              -> LHsBind GhcPs mkRdrFunBind fun@(L loc _fun_rdr) matches-  = L loc (mkFunBind Generated fun matches)+  = L (na2la loc) (mkFunBind Generated fun matches)  -- | Make a function binding. If no equations are given, produce a function -- with the given arity that uses an empty case expression for the last@@ -2178,11 +2278,11 @@             -> [([LPat GhcPs], LHsExpr GhcPs)]             -> LHsBind GhcPs mkFunBindEC arity loc fun catch_all pats_and_exprs-  = mkRdrFunBindEC arity catch_all (L loc fun) matches+  = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches   where-    matches = [ mkMatch (mkPrefixFunRhs (L loc fun))+    matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))                                 (map (parenthesizePat appPrec) p) e-                                (noLoc emptyLocalBinds)+                                emptyLocalBinds               | (p,e) <- pats_and_exprs ]  -- | Produces a function binding. When no equations are given, it generates@@ -2191,11 +2291,11 @@ -- the right-hand side. mkRdrFunBindEC :: Arity                -> (LHsExpr GhcPs -> LHsExpr GhcPs)-               -> Located RdrName+               -> LocatedN RdrName                -> [LMatch GhcPs (LHsExpr GhcPs)]                -> LHsBind GhcPs-mkRdrFunBindEC arity catch_all-                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches')+mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches+  = L (na2la loc) (mkFunBind Generated fun matches')  where    -- Catch-all eqn looks like    --     fmap _ z = case z of {}@@ -2210,16 +2310,16 @@               then [mkMatch (mkPrefixFunRhs fun)                             (replicate (arity - 1) nlWildPat ++ [z_Pat])                             (catch_all $ nlHsCase z_Expr [])-                            (noLoc emptyLocalBinds)]+                            emptyLocalBinds]               else matches  -- | Produces a function binding. When there are no equations, it generates -- a binding with the given arity that produces an error based on the name of -- the type of the last argument.-mkRdrFunBindSE :: Arity -> Located RdrName ->+mkRdrFunBindSE :: Arity -> LocatedN RdrName ->                     [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs-mkRdrFunBindSE arity-                 fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches')+mkRdrFunBindSE arity fun@(L loc fun_rdr) matches+  = L (na2la loc) (mkFunBind Generated fun matches')  where    -- Catch-all eqn looks like    --     compare _ _ = error "Void compare"@@ -2229,7 +2329,7 @@    matches' = if null matches               then [mkMatch (mkPrefixFunRhs fun)                             (replicate arity nlWildPat)-                            (error_Expr str) (noLoc emptyLocalBinds)]+                            (error_Expr str) emptyLocalBinds]               else matches    str = "Void " ++ occNameString (rdrNameOcc fun_rdr) @@ -2258,12 +2358,20 @@      , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))     ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR      , eqInt16_RDR , geInt16_RDR , gtInt16_RDR   ))+    ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR+     , eqInt32_RDR , geInt32_RDR , gtInt32_RDR   ))+    ,(int64PrimTy , (ltInt64_RDR , leInt64_RDR+     , eqInt64_RDR , geInt64_RDR , gtInt64_RDR   ))     ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR      , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))     ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR      , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))     ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR      , eqWord16_RDR, geWord16_RDR, gtWord16_RDR  ))+    ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR+     , eqWord32_RDR, geWord32_RDR, gtWord32_RDR  ))+    ,(word64PrimTy, (ltWord64_RDR, leWord64_RDR+     , eqWord64_RDR, geWord64_RDR, gtWord64_RDR  ))     ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR      , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))     ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR@@ -2283,16 +2391,22 @@     , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))     , (int8PrimTy,         nlHsApp (nlHsVar $ getRdrName intDataCon)-        . nlHsApp (nlHsVar extendInt8_RDR))+        . nlHsApp (nlHsVar int8ToInt_RDR))     , (word8PrimTy,         nlHsApp (nlHsVar $ getRdrName wordDataCon)-        .  nlHsApp (nlHsVar extendWord8_RDR))+        . nlHsApp (nlHsVar word8ToWord_RDR))     , (int16PrimTy,         nlHsApp (nlHsVar $ getRdrName intDataCon)-        . nlHsApp (nlHsVar extendInt16_RDR))+        . nlHsApp (nlHsVar int16ToInt_RDR))     , (word16PrimTy,         nlHsApp (nlHsVar $ getRdrName wordDataCon)-        .  nlHsApp (nlHsVar extendWord16_RDR))+        . nlHsApp (nlHsVar word16ToWord_RDR))+    , (int32PrimTy,+        nlHsApp (nlHsVar $ getRdrName intDataCon)+        . nlHsApp (nlHsVar int32ToInt_RDR))+    , (word32PrimTy,+        nlHsApp (nlHsVar $ getRdrName wordDataCon)+        . nlHsApp (nlHsVar word32ToWord_RDR))     ]  @@ -2308,14 +2422,18 @@     ,(word8PrimTy, "##")     ,(int16PrimTy, "#")     ,(word16PrimTy, "##")+    ,(int32PrimTy, "#")+    ,(word32PrimTy, "##")     ]  primConvTbl :: [(Type, String)] primConvTbl =-    [ (int8PrimTy, "narrowInt8#")-    , (word8PrimTy, "narrowWord8#")-    , (int16PrimTy, "narrowInt16#")-    , (word16PrimTy, "narrowWord16#")+    [ (int8PrimTy, "intToInt8#")+    , (word8PrimTy, "wordToWord8#")+    , (int16PrimTy, "intToInt16#")+    , (word16PrimTy, "wordToWord16#")+    , (int32PrimTy, "intToInt32#")+    , (word32PrimTy, "wordToWord32#")     ]  litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]@@ -2368,12 +2486,12 @@  where    (_, _, prim_eq, _, _) = primOrdOps "Eq" ty -untag_Expr :: RdrName -> [(RdrName, RdrName)]+untag_Expr :: [(RdrName, RdrName)]            -> LHsExpr GhcPs -> LHsExpr GhcPs-untag_Expr _ [] expr = expr-untag_Expr con2tag_RDR ((untag_this, put_tag_here) : more) expr-  = nlHsCase (nlHsPar (nlHsVarApps con2tag_RDR [untag_this])) {-of-}-      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr con2tag_RDR more expr)]+untag_Expr [] expr = expr+untag_Expr ((untag_this, put_tag_here) : more) expr+  = nlHsCase (nlHsPar (nlHsVarApps dataToTag_RDR [untag_this])) {-of-}+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr more expr)]  enum_from_to_Expr         :: LHsExpr GhcPs -> LHsExpr GhcPs@@ -2486,10 +2604,9 @@ minusInt_RDR  = getRdrName (primOpId IntSubOp   ) tagToEnum_RDR = getRdrName (primOpId TagToEnumOp) -new_con2tag_rdr_name, new_tag2con_rdr_name, new_maxtag_rdr_name+new_tag2con_rdr_name, new_maxtag_rdr_name   :: SrcSpan -> TyCon -> TcM RdrName -- Generates Exact RdrNames, for the binding positions-new_con2tag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkCon2TagOcc new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc new_maxtag_rdr_name  dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc @@ -2515,57 +2632,90 @@   uniq <- newUnique   pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc +-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@+-- whose return types match when checked against @tycon_args@.+--+-- See Note [Filter out impossible GADT data constructors]+getPossibleDataCons :: TyCon -> [Type] -> [DataCon]+getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon+  where+    isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args) +-- | Given a type constructor @tycon@ of arity /n/ and a list of argument types+-- @tycon_args@ of length /m/,+--+-- @+-- tyConInstArgTys tycon tycon_args+-- @+--+-- returns+--+-- @+-- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]+-- @+--+-- where @extra_args@ are distinct type variables.+--+-- Examples:+--+-- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.+--+-- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.+tyConInstArgTys :: TyCon -> [Type] -> [Type]+tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix+  where+    tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon+ {- Note [Auxiliary binders] ~~~~~~~~~~~~~~~~~~~~~~~~ We often want to make top-level auxiliary bindings in derived instances.-For example, derived Eq instances sometimes generate code like this:+For example, derived Ix instances sometimes generate code like this:    data T = ...-  deriving instance Eq T+  deriving instance Ix T    ==> -  instance Eq T where-    a == b = $con2tag_T a == $con2tag_T b+  instance Ix T where+    range (a, b) = map tag2con_T [dataToTag# a .. dataToTag# b] -  $con2tag_T :: T -> Int-  $con2tag_T = ...code....+  $tag2con_T :: Int -> T+  $tag2con_T = ...code....  Note that multiple instances of the same type might need to use the same sort-of auxiliary binding. For example, $con2tag is used not only in derived Eq-instances, but also in derived Ord instances:+of auxiliary binding. For example, $tag2con is used not only in derived Ix+instances, but also in derived Enum instances: -  deriving instance Ord T+  deriving instance Enum T    ==> -  instance Ord T where-    compare a b = $con2tag_T a `compare` $con2tag_T b+  instance Enum T where+    toEnum i = tag2con_T i -  $con2tag_T :: T -> Int-  $con2tag_T = ...code....+  $tag2con_T :: Int -> T+  $tag2con_T = ...code.... -How do we ensure that the two usages of $con2tag_T do not conflict with each-other? We do so by generating a separate $con2tag_T definition for each+How do we ensure that the two usages of $tag2con_T do not conflict with each+other? We do so by generating a separate $tag2con_T definition for each instance, giving each definition an Exact RdrName with a separate Unique to avoid name clashes: -   instance Eq T where-     a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b+  instance Ix T where+    range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] -   instance Ord T where-     compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b+  instance Enum T where+    toEnum a = $tag2con_T{Uniq2} a -   -- $con2tag_T{Uniq1} and $con2tag_T{Uniq2} are Exact RdrNames with-   -- underyling System Names+   -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with+   -- underlying System Names -   $con2tag_T{Uniq1} :: T -> Int-   $con2tag_T{Uniq1} = ...code....+   $tag2con_T{Uniq1} :: Int -> T+   $tag2con_T{Uniq1} = ...code.... -   $con2tag_T{Uniq2} :: T -> Int-   $con2tag_T{Uniq2} = ...code....+   $tag2con_T{Uniq2} :: Int -> T+   $tag2con_T{Uniq2} = ...code....  Note that: @@ -2581,8 +2731,8 @@   de-duplication mechanism isn't perfect, so we fall back to CSE   (which is very effective within a single module). -* Note that the "_T" part of "$con2tag_T" is just for debug-printing-  purposes. We could call them all "$con2tag", or even just "aux".+* Note that the "_T" part of "$tag2con_T" is just for debug-printing+  purposes. We could call them all "$tag2con", or even just "aux".   The Unique is enough to keep them separate.    This is important: we might be generating an Eq instance for two@@ -2595,17 +2745,17 @@ are used. Using some hypothetical Haskell syntax, it might look like this:    let {-    $con2tag_T{Uniq1} :: T -> Int-    $con2tag_T{Uniq1} = ...code....+    $tag2con_T{Uniq1} :: Int -> T+    $tag2con_T{Uniq1} = ...code.... -    $con2tag_T{Uniq2} :: T -> Int-    $con2tag_T{Uniq2} = ...code....+    $tag2con_T{Uniq2} :: Int -> T+    $tag2con_T{Uniq2} = ...code....   } in {-    instance Eq T where-      a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b+    instance Ix T where+      range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] -    instance Ord T where-      compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b+    instance Enum T where+      toEnum a = $tag2con_T{Uniq2} a   }  Making auxiliary bindings local is key to making this work, since GHC will@@ -2636,29 +2786,29 @@    ==> -  instance Eq T where-    a == b = $con2tag_T{Uniq1} a == $con2tag_T{Uniq1} b+  instance Ix T where+    range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b] -  instance Ord T where-    compare a b = $con2tag_T{Uniq2} a `compare` $con2tag_T{Uniq2} b+  instance Enum T where+    toEnum a = $tag2con_T{Uniq2} a -  $con2tag_T{Uniq1} :: T -> Int-  $con2tag_T{Uniq1} = ...code....+  $tag2con_T{Uniq1} :: Int -> T+  $tag2con_T{Uniq1} = ...code.... -  $con2tag_T{Uniq2} :: T -> Int-  $con2tag_T{Uniq2} = ...code....+  $tag2con_T{Uniq2} :: Int -> T+  $tag2con_T{Uniq2} = ...code.... -$con2tag_T{Uniq1} and $con2tag_T{Uniq2} are blatant duplicates of each other,+$tag2con_T{Uniq1} and $tag2con_T{Uniq2} are blatant duplicates of each other, which is not ideal. Surely GHC can do better than that at the very least! And indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like pass to define duplicate auxiliary binders in terms of the original one. On the example above, that would look like this: -  $con2tag_T{Uniq1} :: T -> Int-  $con2tag_T{Uniq1} = ...code....+  $tag2con_T{Uniq1} :: Int -> T+  $tag2con_T{Uniq1} = ...code.... -  $con2tag_T{Uniq2} :: T -> Int-  $con2tag_T{Uniq2} = $con2tag_T{Uniq1}+  $tag2con_T{Uniq2} :: Int -> T+  $tag2con_T{Uniq2} = $tag2con_T{Uniq1}  (Note that this pass does not cover all possible forms of code duplication. See "Wrinkle: Why we sometimes do generate duplicate code" for situations@@ -2668,19 +2818,19 @@ of auxiliary bindings that must be generates along with their RdrNames. As genAuxBinds processes this list, it marks the first occurrence of each sort of auxiliary binding as the "original". For example, if genAuxBinds sees a-DerivCon2Tag for the first time (with the RdrName $con2tag_T{Uniq1}), then it-will generate the full code for a $con2tag binding:+DerivCon2Tag for the first time (with the RdrName $tag2con_T{Uniq1}), then it+will generate the full code for a $tag2con binding: -  $con2tag_T{Uniq1} :: T -> Int-  $con2tag_T{Uniq1} = ...code....+  $tag2con_T{Uniq1} :: Int -> T+  $tag2con_T{Uniq1} = ...code....  Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with-the RdrName $con2tag_T{Uniq2}, it will generate this code, which is much more+the RdrName $tag2con_T{Uniq2}, it will generate this code, which is much more compact: -  $con2tag_T{Uniq2} :: T -> Int-  $con2tag_T{Uniq2} = $con2tag_T{Uniq1}+  $tag2con_T{Uniq2} :: Int -> T+  $tag2con_T{Uniq2} = $tag2con_T{Uniq1}  An alternative approach would be /not/ performing any kind of deduplication in genAuxBinds at all and simply relying on GHC's simplifier to perform this kind@@ -2702,14 +2852,14 @@        data T = ...      module B where        import A-       deriving instance Eq T+       deriving instance Ix T      module C where        import B        deriving instance Enum T -   The derived Eq and Enum instances for T make use of $con2tag_T, and since+   The derived Eq and Enum instances for T make use of $tag2con_T, and since    they are defined in separate modules, each module must produce its own copy-   of $con2tag_T.+   of $tag2con_T.  2. When derived instances are separated by TH splices (#18321), as in the    following example:@@ -2717,14 +2867,14 @@      module M where       data T = ...-     deriving instance Eq T+     deriving instance Ix T      $(pure [])      deriving instance Enum T     Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice    in this program: once for all the declarations before the TH splice, and    once again for all the declarations after the TH splice. As a result,-   $con2tag_T will be generated twice, since genAuxBinds will be unable to+   $tag2con_T will be generated twice, since genAuxBinds will be unable to    recognize the presence of duplicates.  These situations are much rarer, so we do not spend any effort to deduplicate@@ -2733,4 +2883,56 @@ (This is the case described in "Wrinkle: Reducing code duplication".) In situation (1), we can at least fall back on GHC's simplifier to pick up genAuxBinds' slack.++Note [Filter out impossible GADT data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Some stock-derivable classes will filter out impossible GADT data constructors,+to rule out problematic constructors when deriving instances. e.g.++```+data Foo a where+  X :: Foo Int+  Y :: (Bool -> Bool) -> Foo Bool+```++when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't+exist in the first place. For instance, if we write++```+deriving instance Eq (Foo Int)+```++it should generate:++```+instance Eq (Foo Int) where+  X == X = True+```++Classes that filter constructors:++* Eq+* Ord+* Show+* Lift+* Functor+* Foldable+* Traversable++Classes that do not filter constructors:++* Enum: doesn't make sense for GADTs in the first place+* Bounded: only makes sense for GADTs with a single constructor+* Ix: only makes sense for GADTs with a single constructor+* Read: `Read a` returns `a` instead of consumes `a`, so filtering data+  constructors would make this function _more_ partial instead of less+* Data: derived implementations of gunfold rely on a constructor-indexing+  scheme that wouldn't work if certain constructors were filtered out+* Generic/Generic1: doesn't make sense for GADTs++Classes that do not currently filter constructors may do so in the future, if+there is a valid use-case and we have requirements for how they should work.++See #16341 and the T16341.hs test case. -}

GHC/Tc/Deriv/Generics.hs view

@@ -1,14 +1,15 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2011  -} -{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | The deriving code for the Generic class module GHC.Tc.Deriv.Generics    (canDoGenerics@@ -36,19 +37,23 @@ import GHC.Iface.Env    ( newGlobalBinder ) import GHC.Types.Name hiding ( varName ) import GHC.Types.Name.Reader+import GHC.Types.Fixity.Env+import GHC.Types.SourceText+import GHC.Types.Fixity import GHC.Types.Basic import GHC.Builtin.Types.Prim import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad-import GHC.Driver.Types+import GHC.Driver.Session import GHC.Utils.Error( Validity(..), andValid ) import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Types.Var.Env import GHC.Types.Var.Set (elemVarSet) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Utils.Misc @@ -74,10 +79,12 @@ -}  gen_Generic_binds :: GenericKind -> TyCon -> [Type]-                 -> TcM (LHsBinds GhcPs, FamInst)+                 -> TcM (LHsBinds GhcPs, [LSig GhcPs], FamInst) gen_Generic_binds gk tc inst_tys = do+  dflags <- getDynFlags   repTyInsts <- tc_mkRepFamInsts gk tc inst_tys-  return (mkBindsRep gk tc, repTyInsts)+  let (binds, sigs) = mkBindsRep dflags gk tc+  return (binds, sigs, repTyInsts)  {- ************************************************************************@@ -330,12 +337,33 @@   -- Bindings for the Generic instance-mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs-mkBindsRep gk tycon =-    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])-  `unionBags`-    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])+mkBindsRep :: DynFlags -> GenericKind -> TyCon -> (LHsBinds GhcPs, [LSig GhcPs])+mkBindsRep dflags gk tycon = (binds, sigs)       where+        binds = unitBag (mkRdrFunBind (L loc' from01_RDR) [from_eqn])+              `unionBags`+                unitBag (mkRdrFunBind (L loc' to01_RDR) [to_eqn])++        -- See Note [Generics performance tricks]+        sigs = if     gopt Opt_InlineGenericsAggressively dflags+                  || (gopt Opt_InlineGenerics dflags && inlining_useful)+               then [inline1 from01_RDR, inline1 to01_RDR]+               else []+         where+           inlining_useful+             | cons <= 1  = True+             | cons <= 4  = max_fields <= 5+             | cons <= 8  = max_fields <= 2+             | cons <= 16 = max_fields <= 1+             | cons <= 24 = max_fields == 0+             | otherwise  = False+             where+               cons       = length datacons+               max_fields = maximum $ map dataConSourceArity datacons++           inline1 f = L loc'' . InlineSig noAnn (L loc' f)+                     $ alwaysInlinePragma { inl_act = ActiveAfter NoSourceText 1 }+         -- The topmost M1 (the datatype metadata) has the exact same type         -- across all cases of a from/to definition, and can be factored out         -- to save some allocations during typechecking.@@ -347,6 +375,8 @@         from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]         to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]         loc           = srcLocSpan (getSrcLoc tycon)+        loc'          = noAnnSrcSpan loc+        loc''         = noAnnSrcSpan loc         datacons      = tyConDataCons tycon          (from01_RDR, to01_RDR) = case gk of@@ -872,10 +902,17 @@  -- | Variant of foldr for producing balanced lists foldBal :: (a -> a -> a) -> a -> [a] -> a-foldBal _  x []  = x-foldBal _  _ [y] = y-foldBal op x l   = let (a,b) = splitAt (length l `div` 2) l-                   in foldBal op x a `op` foldBal op x b+{-# INLINE foldBal #-} -- inlined to produce specialised code for each op+foldBal op0 x0 xs0 = fold_bal op0 x0 (length xs0) xs0+  where+    fold_bal op x !n xs = case xs of+      []  -> x+      [a] -> a+      _   -> let !nl = n `div` 2+                 !nr = n - nl+                 (l,r) = splitAt nl xs+             in fold_bal op x nl l+                `op` fold_bal op x nr r  {- Note [Generics and unlifted types]@@ -1037,4 +1074,48 @@  A simple change, but one that pays off, since it goes turns an O(n) amount of coercions to an O(1) amount.++Note [Generics performance tricks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generics-based algorithms tend to rely on GHC optimizing away the intermediate+representation for optimal performance. However, the default unfolding threshold+is usually too small for GHC to do that.++The recommended approach thus far was to increase unfolding threshold, but this+makes GHC inline more aggressively in general, whereas it should only be more+aggresive with generics-based code.++The solution is to use a heuristic that'll annotate Generic class methods with+INLINE[1] pragmas (the explicit phase is used to give users phase control as+they can annotate their functions with INLINE[2] or INLINE[0] if appropriate).++The current heuristic was chosen by looking at how annotating Generic methods+INLINE[1] helps with optimal code generation for several types of generic+algorithms:++* Round trip through the generic representation.++* Generation of NFData instances.++* Generation of field lenses.++The experimentation was done by picking data types having N constructors with M+fields each and using their derived Generic instances to generate code with the+above algorithms.++The results are threshold values for N and M (contained in+`mkBindsRep.inlining_useful`) for which inlining is beneficial, i.e. it usually+leads to performance improvements at both compile time (the simplifier has to do+more work, but then there's much less code left for subsequent phases to work+with) and run time (the generic representation of a data type is optimized+away).++The T11068 test case, which includes the algorithms mentioned above, tests that+the generic representations of several data types optimize away using the+threshold values in `mkBindsRep.inlining_useful`.++If one uses threshold values higher what is found in+`mkBindsRep.inlining_useful`, then annotating Generic class methods with INLINE+pragmas tends to be at best useless and at worst lead to code size blowup+without runtime performance improvements. -}

GHC/Tc/Deriv/Infer.hs view

@@ -25,6 +25,7 @@ import GHC.Utils.Error import GHC.Tc.Utils.Instantiate import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.Pair import GHC.Builtin.Names import GHC.Tc.Deriv.Utils@@ -260,9 +261,7 @@            -- substitute each type variable with its counterpart in the derived            -- instance. rep_tc_args lists each of these counterpart types in            -- the same order as the type variables.-           all_rep_tc_args-             = rep_tc_args ++ map mkTyVarTy-                                  (drop (length rep_tc_args) rep_tc_tvs)+           all_rep_tc_args = tyConInstArgTys rep_tc rep_tc_args                 -- Stupid constraints            stupid_constraints@@ -369,8 +368,7 @@                     ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel                                 meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) } -       ; theta_origins <- lift $ mapM do_one_meth gen_dms-       ; return theta_origins }+       ; lift $ mapM do_one_meth gen_dms }  -- Like 'inferConstraints', but used only for @GeneralizedNewtypeDeriving@ and -- @DerivingVia@. Since both strategies generate code involving 'coerce', the@@ -465,8 +463,7 @@ Note [Simplifying the instance context].  In the functor-like case, we may need to unify some kind variables with * in-order for the generated instance to be well-kinded. An example from-#10524:+order for the generated instance to be well-kinded. An example from #10524:    newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)     = Compose (f (g a)) deriving Functor@@ -703,7 +700,7 @@       where         the_pred = mkClassPred clas inst_tys -derivInstCtxt :: PredType -> MsgDoc+derivInstCtxt :: PredType -> SDoc derivInstCtxt pred   = text "When deriving the instance for" <+> parens (ppr pred)

GHC/Tc/Deriv/Utils.hs view

@@ -30,14 +30,16 @@ import GHC.Core.DataCon import GHC.Driver.Session import GHC.Utils.Error-import GHC.Driver.Types (lookupFixity, mi_fix)+import GHC.Types.Fixity.Env (lookupFixity) import GHC.Hs import GHC.Tc.Utils.Instantiate import GHC.Core.InstEnv import GHC.Iface.Load   (loadInterfaceForName) import GHC.Unit.Module (getModule)+import GHC.Unit.Module.ModIface (mi_fix) import GHC.Types.Name import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Tc.Deriv.Generate@@ -218,21 +220,25 @@       -- instance, including what type constructor the last argument is       -- headed by. See @Note [DerivEnv and DerivSpecMechanism]@.     , dsm_stock_gen_fn ::-        SrcSpan -> TyCon-                -> [Type]-                -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])-      -- ^ This function returns three things:+        SrcSpan -> TyCon  -- dit_rep_tc+                -> [Type] -- dit_rep_tc_args+                -> [Type] -- inst_tys+                -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])+      -- ^ This function returns four things:       --       -- 1. @LHsBinds GhcPs@: The derived instance's function bindings       --    (e.g., @compare (T x) (T y) = compare x y@)       ---      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived+      -- 2. @[LSig GhcPs]@: A list of instance specific signatures/pragmas.+      --    Most likely INLINE pragmas for class methods.+      --+      -- 3. @BagDerivStuff@: Auxiliary bindings needed to support the derived       --    instance. As examples, derived 'Generic' instances require       --    associated type family instances, and derived 'Eq' and 'Ord'       --    instances require top-level @con2tag@ functions.       --    See @Note [Auxiliary binders]@ in "GHC.Tc.Deriv.Generate".       ---      -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be+      -- 4. @[Name]@: A list of Names for which @-Wunused-binds@ should be       --    suppressed. This is used to suppress unused warnings for record       --    selectors when deriving 'Read', 'Show', or 'Generic'.       --    See @Note [Deriving and unused record selectors]@.@@ -263,9 +269,9 @@  -- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'. derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc-derivSpecMechanismToStrategy DerivSpecStock{}               = StockStrategy-derivSpecMechanismToStrategy DerivSpecNewtype{}             = NewtypeStrategy-derivSpecMechanismToStrategy DerivSpecAnyClass              = AnyclassStrategy+derivSpecMechanismToStrategy DerivSpecStock{}      = StockStrategy noExtField+derivSpecMechanismToStrategy DerivSpecNewtype{}    = NewtypeStrategy noExtField+derivSpecMechanismToStrategy DerivSpecAnyClass     = AnyclassStrategy noExtField derivSpecMechanismToStrategy (DerivSpecVia{dsm_via_ty = t}) = ViaStrategy t  isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia@@ -424,8 +430,8 @@ -- See @Note [Deriving strategies]@ in "GHC.Tc.Deriv". data OriginativeDerivStatus   = CanDeriveStock            -- Stock class, can derive-      (SrcSpan -> TyCon -> [Type]-               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+      (SrcSpan -> TyCon -> [Type] -> [Type]+               -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))   | StockClassError SDoc      -- Stock class, but can't do it   | CanDeriveAnyClass         -- See Note [Deriving any class]   | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass@@ -563,7 +569,8 @@   :: Class -> Maybe (SrcSpan                      -> TyCon                      -> [Type]-                     -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+                     -> [Type]+                     -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])) hasStockDeriving clas   = assocMaybe gen_list (getUnique clas)   where@@ -571,7 +578,8 @@       :: [(Unique, SrcSpan                    -> TyCon                    -> [Type]-                   -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]+                   -> [Type]+                   -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name]))]     gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)                , (ordClassKey,         simpleM gen_Ord_binds)                , (enumClassKey,        simpleM gen_Enum_binds)@@ -587,28 +595,28 @@                , (genClassKey,         generic (gen_Generic_binds Gen0))                , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ] -    simple gen_fn loc tc _-      = let (binds, deriv_stuff) = gen_fn loc tc-        in return (binds, deriv_stuff, [])+    simple gen_fn loc tc tc_args _+      = let (binds, deriv_stuff) = gen_fn loc tc tc_args+        in return (binds, [], deriv_stuff, [])      -- Like `simple`, but monadic. The only monadic thing that these functions     -- do is allocate new Uniques, which are used for generating the names of     -- auxiliary bindings.     -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.-    simpleM gen_fn loc tc _-      = do { (binds, deriv_stuff) <- gen_fn loc tc-           ; return (binds, deriv_stuff, []) }+    simpleM gen_fn loc tc tc_args _+      = do { (binds, deriv_stuff) <- gen_fn loc tc tc_args+           ; return (binds, [], deriv_stuff, []) } -    read_or_show gen_fn loc tc _+    read_or_show gen_fn loc tc tc_args _       = do { fix_env <- getDataConFixityFun tc-           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc tc_args                  field_names          = all_field_names tc-           ; return (binds, deriv_stuff, field_names) }+           ; return (binds, [], deriv_stuff, field_names) } -    generic gen_fn _ tc inst_tys-      = do { (binds, faminst) <- gen_fn tc inst_tys+    generic gen_fn _ tc _ inst_tys+      = do { (binds, sigs, faminst) <- gen_fn tc inst_tys            ; let field_names = all_field_names tc-           ; return (binds, unitBag (DerivFamInst faminst), field_names) }+           ; return (binds, sigs, unitBag (DerivFamInst faminst), field_names) }      -- See Note [Deriving and unused record selectors]     all_field_names = map flSelector . concatMap dataConFieldLabels@@ -920,8 +928,8 @@  cond_isProduct :: Condition cond_isProduct _ _ rep_tc-  | isProductTyCon rep_tc = IsValid-  | otherwise             = NotValid why+  | Just _ <- tyConSingleDataCon_maybe rep_tc = IsValid+  | otherwise                                 = NotValid why   where     why = quotes (pprSourceTyCon rep_tc) <+>           text "must have precisely one constructor"@@ -1109,8 +1117,7 @@     data T a b = C (Show a) b => MkT b  Here, the existential context (C (Show a) b) does technically mention the last-type variable b. But this is OK, because expanding the type synonym C would-give us the context (Show a), which doesn't mention b. Therefore, we must make-sure to expand type synonyms before performing this check. Not doing so led to-#13813.+type variable b. But this is OK, because expanding the type synonym C would give+us the context (Show a), which doesn't mention b. Therefore, we must make sure+to expand type synonyms before performing this check. Not doing so led to #13813. -}

GHC/Tc/Errors.hs view

@@ -1,7 +1,6 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -22,19 +21,18 @@ import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.Unify( occCheckForErrors, MetaTyVarUpdateResult(..) ) import GHC.Tc.Utils.Env( tcInitTidyEnv ) import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify ( checkTyVarEq ) import GHC.Tc.Types.Origin import GHC.Rename.Unbound ( unknownNameSuggestions ) import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Ppr  ( pprTyVars, pprWithExplicitKindsWhen, pprSourceTyCon, pprWithTYPE )-import GHC.Core.Unify     ( tcMatchTys )+import GHC.Core.Unify     ( tcMatchTys, flattenTys ) import GHC.Unit.Module import GHC.Tc.Instance.Family-import GHC.Core.FamInstEnv ( flattenTys ) import GHC.Tc.Utils.Instantiate import GHC.Core.InstEnv import GHC.Core.TyCon@@ -52,15 +50,17 @@ import GHC.Types.Var.Env import GHC.Types.Name.Set import GHC.Data.Bag-import GHC.Utils.Error  ( ErrMsg, errDoc, pprLocErrMsg )+import GHC.Utils.Error  ( pprLocMsgEnvelope ) import GHC.Types.Basic-import GHC.Types.Unique.Set ( nonDetEltsUniqSet )+import GHC.Types.Error import GHC.Core.ConLike ( ConLike(..)) import GHC.Utils.Misc import GHC.Data.FastString-import GHC.Utils.Outputable+import GHC.Utils.Outputable as O+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Data.List.SetOps ( equivClasses ) import GHC.Data.Maybe import qualified GHC.LanguageExtensions as LangExt@@ -68,7 +68,7 @@  import Control.Monad    ( when, unless ) 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 ) @@ -168,7 +168,6 @@ -- See Note [Deferring coercion errors to runtime] -- Used by solveEqualities for kind equalities --      (see Note [Fail fast on kind errors] in "GHC.Tc.Solver")--- and for simplifyDefault. reportAllUnsolved :: WantedConstraints -> TcM () reportAllUnsolved wanted   = do { ev_binds <- newNoTcEvBinds@@ -211,10 +210,14 @@        ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)         ; wanted <- zonkWC wanted   -- Zonk to reveal all information-            -- 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@@ -375,15 +378,30 @@                           , cec_out_of_scope_holes = HoleError }) = False deferringAnyBindings _                                            = True --- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings--- at all.-noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt-noDeferredBindings ctxt = ctxt { cec_defer_type_errors  = TypeError-                               , cec_expr_holes         = HoleError-                               , cec_out_of_scope_holes = HoleError }+maybeSwitchOffDefer :: EvBindsVar -> ReportErrCtxt -> ReportErrCtxt+-- Switch off defer-type-errors inside CoEvBindsVar+-- See Note [Failing equalities with no evidence bindings]+maybeSwitchOffDefer evb ctxt+ | CoEvBindsVar{} <- evb+ = ctxt { cec_defer_type_errors  = TypeError+        , cec_expr_holes         = HoleError+        , cec_out_of_scope_holes = HoleError }+ | otherwise+ = ctxt -{- Note [Suppressing error messages]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Failing equalities with no evidence bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we go inside an implication that has no term evidence+(e.g. unifying under a forall), we can't defer type errors.  You could+imagine using the /enclosing/ bindings (in cec_binds), but that may+not have enough stuff in scope for the bindings to be well typed.  So+we just switch off deferred type errors altogether.  See #14605.++This is done by maybeSwitchOffDefer.  It's also useful in one other+place: see Note [Wrapping failing kind equalities] in GHC.Tc.Solver.++Note [Suppressing error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The cec_suppress flag says "don't report any errors".  Instead, just create evidence bindings (as usual).  It's used when more important errors have occurred. @@ -432,20 +450,18 @@   where     tcl_env      = ic_env implic     insoluble    = isInsolubleStatus status-    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs-    info'        = tidySkolemInfo env1 info+    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) $+                   scopedSort tvs+        -- scopedSort: the ic_skols may not be in dependency order+        -- (see Note [Skolems in an implication] in GHC.Tc.Types.Constraint)+        -- but tidying goes wrong on out-of-order constraints;+        -- so we sort them here before tidying+    info'   = tidySkolemInfo env1 info     implic' = implic { ic_skols = tvs'                      , ic_given = map (tidyEvVar env1) given                      , ic_info  = info' }-    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt-          | otherwise                = ctxt-          -- If we go inside an implication that has no term-          -- evidence (e.g. unifying under a forall), we can't defer-          -- type errors.  You could imagine using the /enclosing/-          -- bindings (in cec_binds), but that may not have enough stuff-          -- in scope for the bindings to be well typed.  So we just-          -- switch off deferred type errors altogether.  See #14605. +    ctxt1 = maybeSwitchOffDefer evb ctxt     ctxt' = ctxt1 { cec_tidy     = env1                   , cec_encl     = implic' : cec_encl ctxt @@ -501,7 +517,7 @@      = any isImprovementPred (pred : transSuperClasses pred)  reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [TcTyVar] -> TcM ()-reportBadTelescope ctxt env (ForAllSkol _ telescope) skols+reportBadTelescope ctxt env (ForAllSkol telescope) skols   = do { msg <- mkErrorReport ctxt env (important doc)        ; reportError msg }   where@@ -606,10 +622,10 @@               , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)               , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ] -    -- also checks to make sure the constraint isn't BlockedCIS+    -- also checks to make sure the constraint isn't HoleBlockerReason     -- See TcCanonical Note [Equalities with incompatible kinds], (4)     unblocked :: (Ct -> Pred -> Bool) -> Ct -> Pred -> Bool-    unblocked _ (CIrredCan { cc_status = BlockedCIS }) _ = False+    unblocked _ (CIrredCan { cc_reason = HoleBlockerReason {}}) _ = False     unblocked checker ct pred = checker ct pred      -- rigid_nom_eq, rigid_nom_tv_eq,@@ -668,7 +684,7 @@     has_gadt_match [] = False     has_gadt_match (implic : implics)       | PatSkol {} <- ic_info implic-      , not (ic_no_eqs implic)+      , ic_given_eqs implic /= NoGivenEqs       , ic_warn_inaccessible implic           -- Don't bother doing this if -Winaccessible-code isn't enabled.           -- See Note [Avoid -Winaccessible-code when deriving] in GHC.Tc.TyCl.Instance.@@ -735,6 +751,7 @@   = case hole_sort hole of        ExprHole {}    -> False        TypeHole       -> ignore_type_hole+       ConstraintHole -> ignore_type_hole   where     ignore_type_hole = case cec_type_holes ctxt of                          HoleDefer -> True@@ -759,7 +776,7 @@                       ; maybeReportError ctxt err                       ; addDeferredBinding ctxt err ct } -mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkUserTypeError :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc) mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct                         $ important                         $ pprUserTypeErrorTy@@ -835,7 +852,7 @@ find one, we report the insoluble Given. -} -mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)+mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc))                              -- Make error message for a group                 -> Reporter  -- Deal with lots of constraints -- Group together errors from same location,@@ -844,7 +861,7 @@   = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)  -- Like mkGroupReporter, but doesn't actually print error messages-mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter+mkSuppressReporter :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter mkSuppressReporter mk_err ctxt cts   = mapM_ (suppressGroup mk_err ctxt . toList) (equivClasses cmp_loc cts) @@ -856,9 +873,13 @@        _ -> 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 :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter reportGroup mk_err ctxt cts =   ASSERT( not (null cts))   do { err <- mk_err ctxt cts@@ -877,13 +898,13 @@  -- like reportGroup, but does not actually report messages. It still adds -- -fdefer-type-errors bindings, though.-suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> Reporter+suppressGroup :: (ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc)) -> Reporter suppressGroup mk_err ctxt cts  = do { err <- mk_err ctxt cts       ; traceTc "Suppressing errors for" (ppr cts)       ; mapM_ (addDeferredBinding ctxt err) cts } -maybeReportHoleError :: ReportErrCtxt -> Hole -> ErrMsg -> TcM ()+maybeReportHoleError :: ReportErrCtxt -> Hole -> MsgEnvelope DecoratedSDoc -> TcM () maybeReportHoleError ctxt hole err   | isOutOfScopeHole hole   -- Always report an error for out-of-scope variables@@ -899,7 +920,10 @@  -- Unlike maybeReportError, these "hole" errors are -- /not/ suppressed by cec_suppress.  We want to see them!-maybeReportHoleError ctxt (Hole { hole_sort = TypeHole }) err+maybeReportHoleError ctxt (Hole { hole_sort = hole_sort }) err+  | case hole_sort of TypeHole       -> True+                      ConstraintHole -> True+                      _              -> False   -- When -XPartialTypeSignatures is on, warnings (instead of errors) are   -- generated for holes in partial type signatures.   -- Unless -fwarn-partial-type-signatures is not on,@@ -911,7 +935,7 @@        HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err        HoleDefer -> return () -maybeReportHoleError ctxt hole@(Hole { hole_sort = ExprHole _ }) err+maybeReportHoleError ctxt hole err   -- Otherwise this is a typed hole in an expression,   -- but not for an out-of-scope variable (because that goes through a   -- different function)@@ -922,7 +946,7 @@        HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err        HoleDefer -> return () -maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()+maybeReportError :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> TcM () -- Report the error and/or make a deferred binding for it maybeReportError ctxt err   | cec_suppress ctxt    -- Some worse error has occurred;@@ -934,7 +958,7 @@       TypeWarn reason -> reportWarning reason err       TypeError       -> reportError err -addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()+addDeferredBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Ct -> TcM () -- See Note [Deferring coercion errors to runtime] addDeferredBinding ctxt err ct   | deferringAnyBindings ctxt@@ -957,27 +981,30 @@   = return ()  mkErrorTerm :: DynFlags -> Type  -- of the error term-            -> ErrMsg -> EvTerm+            -> MsgEnvelope DecoratedSDoc -> EvTerm mkErrorTerm dflags ty err = evDelayedError ty err_fs   where-    err_msg = pprLocErrMsg err+    err_msg = pprLocMsgEnvelope err     err_fs  = mkFastString $ showSDoc dflags $               err_msg $$ text "(deferred type error)"-maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Hole -> TcM ()-maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole ev_id })++maybeAddDeferredHoleBinding :: ReportErrCtxt -> MsgEnvelope DecoratedSDoc -> Hole -> TcM ()+maybeAddDeferredHoleBinding ctxt err (Hole { hole_sort = ExprHole (HER ref ref_ty _) }) -- Only add bindings for holes in expressions -- not for holes in partial type signatures -- cf. addDeferredBinding   | deferringAnyBindings ctxt   = do { dflags <- getDynFlags-       ; let err_tm = mkErrorTerm dflags (idType ev_id) err-           -- NB: idType ev_id, not hole_ty. hole_ty might be rewritten.+       ; let err_tm = mkErrorTerm dflags ref_ty err+           -- NB: ref_ty, not hole_ty. hole_ty might be rewritten.            -- See Note [Holes] in GHC.Tc.Types.Constraint-       ; addTcEvBind (cec_binds ctxt) $ mkWantedEvBind ev_id err_tm }+       ; writeMutVar ref err_tm }   | otherwise   = return () maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = TypeHole })   = return ()+maybeAddDeferredHoleBinding _ _ (Hole { hole_sort = ConstraintHole })+  = return ()  tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct]) -- Use the first reporter in the list whose predicate says True@@ -1047,15 +1074,17 @@     ppr_one ct' = hang (parens (pprType (ctPred ct')))                      2 (pprCtLoc (ctLoc ct')) -mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg+mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM (MsgEnvelope DecoratedSDoc) mkErrorMsgFromCt ctxt ct report   = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report -mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg+mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM (MsgEnvelope DecoratedSDoc) mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)   = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)-       ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)-            (errDoc important [context] (relevant_bindings ++ valid_subs))+       ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc tcl_env) Nothing)+                           (vcat important)+                           context+                           (vcat $ relevant_bindings ++ valid_subs)        }  type UserGiven = Implication@@ -1152,7 +1181,7 @@ ************************************************************************ -} -mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkIrredErr ctxt cts   = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1        ; let orig = ctOrigin ct1@@ -1163,7 +1192,7 @@     (ct1:_) = cts  -----------------mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM ErrMsg+mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc) mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ                                            , hole_ty = hole_ty                                            , hole_loc = ct_loc })@@ -1173,10 +1202,10 @@        ; imp_info <- getImports        ; curr_mod <- getModule        ; hpt <- getHpt-       ; mkErrDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing) $-                    errDoc [out_of_scope_msg] []-                           [unknownNameSuggestions dflags hpt curr_mod rdr_env-                            (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)] }+       ; mkDecoratedSDocAt (RealSrcSpan (tcl_loc lcl_env) Nothing)+                           out_of_scope_msg O.empty+                           (unknownNameSuggestions dflags hpt curr_mod rdr_env+                            (tcl_rdr lcl_env) imp_info (mkRdrUnqual occ)) }   where     herald | isDataOcc occ = text "Data constructor not in scope:"            | otherwise     = text "Variable not in scope:"@@ -1226,6 +1255,9 @@       TypeHole -> vcat [ hang (text "Found type wildcard" <+> quotes (ppr occ))                             2 (text "standing for" <+> quotes pp_hole_type_with_kind)                        , tyvars_msg, type_hole_hint ]+      ConstraintHole -> vcat [ hang (text "Found extra-constraints wildcard standing for")+                                  2 (quotes $ pprType hole_ty)  -- always kind constraint+                             , tyvars_msg, type_hole_hint ]      pp_hole_type_with_kind       | isLiftedTypeKind hole_kind@@ -1301,7 +1333,7 @@             2 (vcat $ map pprConstraint constraints)  -----------------mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkIPErr ctxt cts   = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1        ; let orig    = ctOrigin ct1@@ -1378,11 +1410,11 @@  -- Don't have multiple equality errors from the same location -- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!-mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct mkEqErr _ [] = panic "mkEqErr" -mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkEqErr1 :: ReportErrCtxt -> Ct -> TcM (MsgEnvelope DecoratedSDoc) mkEqErr1 ctxt ct   -- Wanted or derived;                    -- givens handled in mkGivenErrorReporter   = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct@@ -1448,7 +1480,7 @@  mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report              -> Ct-             -> TcType -> TcType -> TcM ErrMsg+             -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc) mkEqErr_help dflags ctxt report ct ty1 ty2   | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1   = mkTyVarEqErr dflags ctxt report ct tv1 ty2@@ -1459,7 +1491,7 @@  reportEqErr :: ReportErrCtxt -> Report             -> Ct-            -> TcType -> TcType -> TcM ErrMsg+            -> TcType -> TcType -> TcM (MsgEnvelope DecoratedSDoc) reportEqErr ctxt report ct ty1 ty2   = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])   where@@ -1468,25 +1500,43 @@  mkTyVarEqErr, mkTyVarEqErr'   :: DynFlags -> ReportErrCtxt -> Report -> Ct-             -> TcTyVar -> TcType -> TcM ErrMsg+             -> TcTyVar -> TcType -> TcM (MsgEnvelope DecoratedSDoc) -- tv1 and ty2 are already tidied mkTyVarEqErr dflags ctxt report ct tv1 ty2   = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr ty2)        ; 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+     -- impredicativity is a simple error to understand; try it first+  | check_eq_result `cterHasProblem` cteImpredicative+  = let msg = vcat [ (if isSkolemTyVar tv1+                      then text "Cannot equate type variable"+                      else text "Cannot instantiate unification variable")+                     <+> quotes (ppr tv1)+                   , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]+    in+       -- Unlike the other reports, this discards the old 'report_important'+       -- instead of augmenting it.  This is because the details are not likely+       -- to be helpful since this is just an unimplemented feature.+    mkErrorMsgFromCt ctxt ct $ mconcat+        [ headline_msg+        , important msg+        , if isSkolemTyVar tv1 then extraTyVarEqInfo ctxt tv1 ty2 else mempty+        , report ]++  | 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         ] -  | MTVU_Occurs <- occ_check_expand+  | cterHasOccursCheck check_eq_result     -- We report an "occurs check" even for  a ~ F t a, where F is a type     -- function; it's not insoluble (because in principle F could reduce)     -- but we have certainly been unable to solve it@@ -1507,15 +1557,6 @@        ; mkErrorMsgFromCt ctxt ct $          mconcat [headline_msg, extra2, extra3, report] } -  | MTVU_Bad <- occ_check_expand-  = do { let msg = vcat [ text "Cannot instantiate unification variable"-                          <+> quotes (ppr tv1)-                        , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2) ]-       -- Unlike the other reports, this discards the old 'report_important'-       -- instead of augmenting it.  This is because the details are not likely-       -- to be helpful since this is just an unimplemented feature.-       ; mkErrorMsgFromCt ctxt ct $ mconcat [ headline_msg, important msg, report ] }-   -- If the immediately-enclosing implication has 'tv' a skolem, and   -- we know by now its an InferSkol kind of skolem, then presumably   -- it started life as a TyVarTv, else it'd have been unified, given@@ -1577,16 +1618,25 @@    | otherwise   = reportEqErr ctxt report ct (mkTyVarTy tv1) ty2-        -- This *can* happen (#6123, and test T2627b)+        -- This *can* happen (#6123)         -- Consider an ambiguous top-level constraint (a ~ F a)         -- Not an occurs check, because F is a type function.   where     headline_msg = misMatchOrCND insoluble_occurs_check ctxt ct ty1 ty2      ty1 = mkTyVarTy tv1-    occ_check_expand       = occCheckForErrors dflags tv1 ty2-    insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2 +    check_eq_result = case ct of+      CIrredCan { cc_reason = NonCanonicalReason result } -> result+      CIrredCan { cc_reason = HoleBlockerReason {} }      -> cteProblem cteHoleBlocker+      _ -> checkTyVarEq dflags tv1 ty2+        -- in T2627b, we report an error for F (F a0) ~ a0. Note that the type+        -- variable is on the right, so we don't get useful info for the CIrredCan,+        -- and have to compute the result of checkTyVarEq here.+++    insoluble_occurs_check = check_eq_result `cterHasProblem` cteInsolubleOccurs+     what = text $ levelString $            ctLocTypeOrKind_maybe (ctLoc ct) `orElse` TypeLevel @@ -1618,17 +1668,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@@ -1649,7 +1688,7 @@     eq_pred = ctEvPred ev     orig    = ctEvOrigin ev     level   = ctLocTypeOrKind_maybe (ctEvLoc ev) `orElse` TypeLevel-    givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]+    givens  = [ given | given <- getUserGivens ctxt, ic_given_eqs given /= NoGivenEqs ]               -- Keep only UserGivens that have some equalities.               -- See Note [Suppress redundant givens during error reporting] @@ -1678,7 +1717,7 @@ -- always be another unsolved wanted around, which will ordinarily suppress -- this message. But this can still be printed out with -fdefer-type-errors -- (sigh), so we must produce a message.-mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkBlockedEqErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkBlockedEqErr ctxt (ct:_) = mkErrorMsgFromCt ctxt ct report   where     report = important msg@@ -1707,7 +1746,10 @@ redundant), so it's not terribly useful to report it in an error message. To accomplish this, we discard any Implications that do not bind any equalities by filtering the `givens` selected in `misMatchOrCND` (based on-the `ic_no_eqs` field of the Implication).+the `ic_given_eqs` field of the Implication). Note that we discard givens+that have no equalities whatsoever, but we want to keep ones with only *local*+equalities, as these may be helpful to the user in understanding what went+wrong.  But this is not enough to avoid all redundant givens! Consider this example, from #15361:@@ -1720,7 +1762,7 @@ The (* ~ *) part arises due the kinds of (:~~:) being unified. More importantly, (* ~ *) is redundant, so we'd like not to report it. However, the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its-ic_no_eqs field), so the test above will keep it wholesale.+ic_given_eqs field), so the test above will keep it wholesale.  To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b) part. This works because mkMinimalBySCs eliminates reflexive equalities in@@ -1748,22 +1790,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_given_eqs /= NoGivenEqs (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 || ic_given_eqs implic /= NoGivenEqs) tv+ -------------------- misMatchMsg :: ReportErrCtxt -> Ct -> TcType -> TcType -> Report -- Types are already tidy@@ -1786,7 +1836,9 @@ headline_eq_msg add_ea ct ty1 ty2    | (isLiftedRuntimeRep ty1 && isUnliftedRuntimeRep ty2) ||-    (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1)+    (isLiftedRuntimeRep ty2 && isUnliftedRuntimeRep ty1) ||+    (isLiftedLevity ty1 && isUnliftedLevity ty2) ||+    (isLiftedLevity ty2 && isUnliftedLevity ty1)   = text "Couldn't match a lifted type with an unlifted type"    | isAtomicTy ty1 || isAtomicTy ty2@@ -1894,7 +1946,7 @@     count_args ty = count isVisibleBinder $ fst $ splitPiTys ty  tk_eq_msg ctxt ct ty1 ty2-          (KindEqOrigin cty1 mb_cty2 sub_o mb_sub_t_or_k)+          (KindEqOrigin cty1 cty2 sub_o mb_sub_t_or_k)   = vcat [ headline_eq_msg False ct ty1 ty2          , supplementary_msg ]   where@@ -1904,17 +1956,15 @@      supplementary_msg       = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->-        case mb_cty2 of-          Just cty2-            |  printExplicitCoercions-            || not (cty1 `pickyEqType` cty2)-            -> vcat [ hang (text "When matching" <+> sub_whats)-                         2 (vcat [ ppr cty1 <+> dcolon <+>+        if printExplicitCoercions+           || not (cty1 `pickyEqType` cty2)+          then vcat [ hang (text "When matching" <+> sub_whats)+                          2 (vcat [ ppr cty1 <+> dcolon <+>                                    ppr (tcTypeKind cty1)                                  , ppr cty2 <+> dcolon <+>                                    ppr (tcTypeKind cty2) ])                     , mk_supplementary_ea_msg ctxt sub_t_or_k cty1 cty2 sub_o ]-          _ -> text "When matching the kind of" <+> quotes (ppr cty1)+          else text "When matching the kind of" <+> quotes (ppr cty1)  tk_eq_msg _ _ _ _ _ = panic "typeeq_mismatch_msg" @@ -2004,8 +2054,6 @@                  -- True when the visible bit of the types look the same,                  -- so we want to show the kinds in the displayed type -- {- Note [Insoluble occurs check] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble@@ -2016,7 +2064,7 @@ And indeed even thinking about the Givens is silly; [W] a ~ [a] is just as insoluble as Int ~ Bool. -Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)+Conclusion: if there's an insoluble occurs check (cteInsolubleOccurs) then report it directly, not in the "cannot deduce X from Y" form. This is done in misMatchOrCND (via the insoluble_occurs_check arg) @@ -2207,9 +2255,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@@ -2223,6 +2270,15 @@ 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.  Note [Disambiguating (X ~ X) errors]@@ -2266,7 +2322,7 @@ ************************************************************************ -} -mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkDictErr :: ReportErrCtxt -> [Ct] -> TcM (MsgEnvelope DecoratedSDoc) mkDictErr ctxt cts   = ASSERT( not (null cts) )     do { inst_envs <- tcGetInstEnvs@@ -2302,17 +2358,6 @@     -- but we really only want to report the latter     elim_superclasses cts = mkMinimalBySCs ctPred cts --- [Note: mk_dict_err]--- ~~~~~~~~~~~~~~~~~~~--- Different dictionary error messages are reported depending on the number of--- matches and unifiers:------   - No matches, regardless of unifiers: report "No instance for ...".---   - Two or more matches, regardless of unifiers: report "Overlapping instances for ...",---     and show the matching and unifying instances.---   - One match, one or more unifiers: report "Overlapping instances for", show the---     matching and unifying instances, and say "The choice depends on the instantion of ...,---     and the result of evaluating ...". mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)             -> TcM (ReportErrCtxt, SDoc) -- Report an overlap error if this class constraint results@@ -2478,24 +2523,12 @@                       , nest 2 (vcat (pp_givens useful_givens))]               ,  ppWhen (isSingleton matches) $-                parens (vcat [ ppUnless (null tyCoVars) $-                                 text "The choice depends on the instantiation of" <+>-                                   quotes (pprWithCommas ppr tyCoVars)-                             , ppUnless (null famTyCons) $-                                 if (null tyCoVars)-                                   then-                                     text "The choice depends on the result of evaluating" <+>-                                       quotes (pprWithCommas ppr famTyCons)-                                   else-                                     text "and the result of evaluating" <+>-                                       quotes (pprWithCommas ppr famTyCons)+                parens (vcat [ text "The choice depends on the instantiation of" <+>+                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))                              , ppWhen (null (matching_givens)) $                                vcat [ text "To pick the first instance above, use IncoherentInstances"                                     , text "when compiling the other instance declarations"]                         ])]-      where-        tyCoVars = tyCoVarsOfTypesList tys-        famTyCons = filter isFamilyTyCon $ concatMap (nonDetEltsUniqSet . tyConsOfType) tys      matching_givens = mapMaybe matchable useful_givens @@ -2755,16 +2788,12 @@ instances                 C (Maybe Int) and C (Maybe a) Since (F x) might turn into Int, this is an overlap situation, and-indeed (because of flattening) the main solver will have refrained+indeed the main solver will have refrained from solving.  But by the time we get to error message generation, we've un-flattened the constraint.  So we must *re*-flatten it before looking up in the instance environment, lest we only report one matching instance when in fact there are two. -Re-flattening is pretty easy, because we don't need to keep track of-evidence.  We don't re-use the code in GHC.Tc.Solver.Canonical because that's in-the TcS monad, and we are in TcM here.- Note [Kind arguments in error messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It can be terribly confusing to get an error message like (#9171)@@ -2885,8 +2914,7 @@              -- For *kind* errors, report the relevant bindings of the              -- enclosing *type* equality, because that's more useful for the programmer        ; let extra_tvs = case tidy_orig of-                             KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $-                                                         t1 : maybeToList m_t2+                             KindEqOrigin t1 t2 _ _ -> tyCoVarsOfTypes [t1,t2]                              _                        -> emptyVarSet              ct_fvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs

GHC/Tc/Errors/Hole.hs view

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ExistentialQuantification #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -39,14 +40,17 @@ import GHC.Core.Type import GHC.Core.DataCon import GHC.Types.Name-import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )+import GHC.Types.Name.Reader ( pprNameProvenance , GlobalRdrElt (..)+                             , globalRdrEnvElts, greMangledName, grePrintableName ) import GHC.Builtin.Names ( gHC_ERR ) import GHC.Types.Id import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.TyThing import GHC.Data.Bag import GHC.Core.ConLike ( ConLike(..) ) import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Tc.Utils.Env (tcLookup) import GHC.Utils.Outputable import GHC.Driver.Session@@ -60,13 +64,13 @@ 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 ) import qualified Data.Map as Map import GHC.Hs.Doc      ( unpackHDS, DeclDocMap(..) )-import GHC.Driver.Types        ( ModIface_(..) )+import GHC.Unit.Module.ModIface ( ModIface_(..) ) import GHC.Iface.Load  ( loadInterfaceForNameMaybe )  import GHC.Builtin.Utils (knownKeyNames)@@ -433,7 +437,7 @@ addHoleFitDocs fits =   do { showDocs <- goptM Opt_ShowDocsOfHoleFits      ; if showDocs-       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv+       then do { (_, DeclDocMap lclDocs, _) <- getGblEnv >>= extractDocs                ; mapM (upd lclDocs) fits }        else return fits }   where@@ -456,8 +460,7 @@ pprHoleFit _ (RawHoleFit sd) = sd pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) (HoleFit {..}) =  hang display 2 provenance- where name =  getName hfCand-       tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap+ where tyApp = sep $ zipWithEqual "pprHoleFit" pprArg vars hfWrap          where pprArg b arg = case binderArgFlag b of                                 -- See Note [Explicit Case Statement for Specificity]                                 (Invisible spec) -> case spec of@@ -482,11 +485,14 @@            unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of                                Just (_, _, unfunned) -> unwrapTypeVars unfunned                                _ -> []-             where (vars, unforalled) = splitForAllVarBndrs t+             where (vars, unforalled) = splitForAllTyCoVarBinders t        holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) hfMatches        holeDisp = if sMs then holeVs                   else sep $ replicate (length hfMatches) $ text "_"-       occDisp = pprPrefixOcc name+       occDisp = case hfCand of+                   GreHFCand gre   -> pprPrefixOcc (grePrintableName gre)+                   NameHFCand name -> pprPrefixOcc name+                   IdHFCand id_    -> pprPrefixOcc id_        tyDisp = ppWhen sTy $ dcolon <+> ppr hfType        has = not . null        wrapDisp = ppWhen (has hfWrap && (sWrp || sWrpVars))@@ -505,7 +511,8 @@        provenance = ppWhen sProv $ parens $              case hfCand of                  GreHFCand gre -> pprNameProvenance gre-                 _ -> text "bound at" <+> ppr (getSrcLoc name)+                 NameHFCand name -> text "bound at" <+> ppr (getSrcLoc name)+                 IdHFCand id_ -> text "bound at" <+> ppr (getSrcLoc id_)  getLocalBindings :: TidyEnv -> CtLoc -> TcM [Id] getLocalBindings tidy_orig ct_loc@@ -805,8 +812,10 @@                                            Just (dataConWrapId con, dataConNonlinearType con)                                        _ -> Nothing }             where name = case hfc of+#if __GLASGOW_HASKELL__ < 901                            IdHFCand id -> idName id-                           GreHFCand gre -> gre_name gre+#endif+                           GreHFCand gre -> greMangledName gre                            NameHFCand name -> name           discard_it = go subs seen maxleft ty elts           keep_it eid eid_ty wrp ms = go (fit:subs) (extendVarSet seen eid)@@ -969,7 +978,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

GHC/Tc/Errors/Hole/FitTypes.hs view

@@ -56,11 +56,11 @@   getName hfc = case hfc of                      IdHFCand cid -> idName cid                      NameHFCand cname -> cname-                     GreHFCand cgre -> gre_name cgre+                     GreHFCand cgre -> greMangledName cgre   getOccName hfc = case hfc of                      IdHFCand cid -> occName cid                      NameHFCand cname -> occName cname-                     GreHFCand cgre -> occName (gre_name cgre)+                     GreHFCand cgre -> occName (greMangledName cgre)  instance HasOccName HoleFitCandidate where   occName = getOccName

GHC/Tc/Gen/Annotation.hs view

@@ -12,19 +12,24 @@  import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Env+ import {-# SOURCE #-} GHC.Tc.Gen.Splice ( runAnnotation )+import GHC.Tc.Utils.Monad+ import GHC.Unit.Module-import GHC.Driver.Session-import Control.Monad ( when )  import GHC.Hs++import GHC.Utils.Outputable+ import GHC.Types.Name import GHC.Types.Annotations-import GHC.Tc.Utils.Monad import GHC.Types.SrcLoc-import GHC.Utils.Outputable-import GHC.Driver.Types +import Control.Monad ( when )+ -- Some platforms don't support the interpreter, and compilation on those -- platforms shouldn't fail just due to annotations tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]@@ -38,7 +43,7 @@ --- No GHCI; emit a warning (not an error) and ignore. cf #4268 warnAnns [] = return [] warnAnns anns@(L loc _ : _)-  = do { setSrcSpan loc $ addWarnTc NoReason $+  = do { setSrcSpanA loc $ addWarnTc NoReason $              (text "Ignoring ANN annotation" <> plural anns <> comma              <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")        ; return [] }@@ -50,7 +55,7 @@     let target = annProvenanceToTarget mod provenance      -- Run that annotation and construct the full Annotation data structure-    setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do+    setSrcSpanA loc $ addErrCtxt (annCtxt ann) $ do       -- See #10826 -- Annotations allow one to bypass Safe Haskell.       dflags <- getDynFlags       when (safeLanguageOn dflags) $ failWithTc safeHsErr@@ -59,7 +64,7 @@       safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."                   , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ] -annProvenanceToTarget :: Module -> AnnProvenance Name+annProvenanceToTarget :: Module -> AnnProvenance GhcRn                       -> AnnTarget Name annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name

+ GHC/Tc/Gen/App.hs view

@@ -0,0 +1,1208 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module GHC.Tc.Gen.App+       ( tcApp+       , tcInferSigma+       , tcExprPrag ) where++import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcPolyExpr )++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 "HsVersions.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/ unification varibles!  See also+  Note [Instantiation variables are short lived].++* We cleverly avoid the quadratic cost of QL, alluded to in the paper.+  See Note [Quick Look at value arguments]++Note [Instantiation variables are short lived]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By the time QL is done, all filled-in occurrences of instantiation+variables have been zonked away (see "Crucial step" in tcValArgs),+and so the constraint /generator/ never subsequently sees a meta-type+variable filled in with a polytype -- a meta type variable stands+(only) for a monotype.  See Section 4.3 "Applications and instantiation"+of the paper.++However, the constraint /solver/ can see a meta-type-variable filled+in with a polytype (#18987). Suppose+  f :: forall a. Dict a => [a] -> [a]+  xs :: [forall b. b->b]+and consider the call (f xs).  QL will+* Instantiate f, with a := kappa, where kappa is an instantiation variable+* Emit a constraint (Dict kappa), via instantiateSigma, called from tcInstFun+* Do QL on the argument, to discover kappa := forall b. b->b++But by the time the third step has happened, the constraint has been+emitted into the monad.  The constraint solver will later find it, and+rewrite it to (Dict (forall b. b->b)). That's fine -- the constraint+solver does no implicit instantiation (which is what makes it so+tricky to have foralls hiding inside unification variables), so there+is no difficulty with allowing those filled-in kappa's to persist.+(We could find them and zonk them away, but that would cost code and+execution time, for no purpose.)++Since the constraint solver does not do implicit instantiation (as the+constraint generator does), the fact that a unification variable might+stand for a polytype does not matter.+-}+++{- *********************************************************************+*                                                                      *+              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)+  | (fun@(rn_fun,_), rn_args) <- splitHsApps rn_expr+  = addExprCtxt rn_expr $+    setSrcSpanA loc     $+    do { do_ql <- wantQuickLook rn_fun+       ; (_tc_fun, fun_sigma) <- tcInferAppHead fun rn_args Nothing+       ; (_delta, inst_args, app_res_sigma) <- tcInstFun do_ql inst fun fun_sigma rn_args+       ; _tc_args <- tcValArgs do_ql 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+      |  lit           -- HsOverLit: overloaded literals+      |  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 function,+     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 unifyResultType to match up the result type of the call+   with that expected by the context.  See Note [Unify with+   expected type before typechecking arguments]++6. Use tcValArgs to typecheck the value arguments++7. 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!++Note [Quick Look for particular Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We switch on Quick Look (regardless of -XImpredicativeTypes) for certain+particular Ids:++* ($): For a long time GHC has had a special typing rule for ($), that+  allows it to type (runST $ foo), which requires impredicative instantiation+  of ($), without language flags.  It's a bit ad-hoc, but it's been that+  way for ages.  Using quickLookIds is the only special treatment ($) needs+  now, which is a lot better.++* leftSection, rightSection: these are introduced by the expansion step in+  the renamer (Note [Handling overloaded and rebindable constructs] in+  GHC.Rename.Expr), and we want them to be instantiated impredicatively+  so that (f `op`), say, will work OK even if `f` is higher rank.++Note [Unify with expected type before typechecking arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#19364)+  data Pair a b = Pair a b+  baz :: MkPair Int Bool+  baz = MkPair "yes" "no"++We instantiate MkPair with `alpha`, `beta`, and push its argument+types (`alpha` and `beta`) into the arguments ("yes" and "no").+But if we first unify the result type (Pair alpha beta) with the expected+type (Pair Int Bool) we will push the much more informative types+`Int` and `Bool` into the arguments.   This makes a difference:++Unify result type /after/ typechecking the args+    • Couldn't match type ‘[Char]’ with ‘Bool’+      Expected type: Pair Foo Bar+        Actual type: Pair [Char] [Char]+    • In the expression: Pair "yes" "no"++Unify result type /before/ typechecking the args+    • Couldn't match type ‘[Char]’ with ‘Bool’+      Expected: Foo+        Actual: String+    • In the first argument of ‘Pair’, namely ‘"yes"’++The latter is much better. That is why we call unifyExpectedType+before tcValArgs.+-}++tcApp :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+-- See Note [tcApp: typechecking applications]+tcApp rn_expr exp_res_ty+  | (fun@(rn_fun, fun_ctxt), rn_args) <- splitHsApps rn_expr+  = do { (tc_fun, fun_sigma) <- tcInferAppHead fun rn_args+                                    (checkingExpType_maybe exp_res_ty)++       -- Instantiate+       ; do_ql <- wantQuickLook rn_fun+       ; (delta, inst_args, app_res_rho) <- tcInstFun do_ql True fun fun_sigma rn_args++       -- Quick look at result+       ; app_res_rho <- if do_ql+                        then quickLookResultType delta app_res_rho exp_res_ty+                        else return app_res_rho++       -- Unify with expected type from the context+       -- See Note [Unify with expected type before typechecking arguments]+       --+       -- perhaps_add_res_ty_ctxt: Inside an expansion, the addFunResCtxt stuff is+       --    more confusing than helpful because the function at the head isn't in+       --    the source program; it was added by the renamer.  See+       --    Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr+       ; let  perhaps_add_res_ty_ctxt thing_inside+                 | insideExpansion fun_ctxt+                 = thing_inside+                 | otherwise+                 = addFunResCtxt rn_fun rn_args app_res_rho exp_res_ty $+                   thing_inside++       ; res_co <- perhaps_add_res_ty_ctxt $+                   unifyExpectedType rn_expr 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 inst_args++       -- Reconstruct, with special case for tagToEnum#+       ; tc_expr <- if isTagToEnum rn_fun+                    then tcTagToEnum tc_fun fun_ctxt tc_args app_res_rho+                    else return (rebuildHsApps tc_fun fun_ctxt tc_args)++       -- Wrap the result+       ; return (mkHsWrapCo res_co tc_expr) }++--------------------+wantQuickLook :: HsExpr GhcRn -> TcM Bool+-- GHC switches on impredicativity all the time for ($)+wantQuickLook (HsVar _ (L _ f))+  | getUnique f `elem` quickLookKeys = return True+wantQuickLook _                      = xoptM LangExt.ImpredicativeTypes++quickLookKeys :: [Unique]+-- See Note [Quick Look for particular Ids]+quickLookKeys = [dollarIdKey, leftSectionKey, rightSectionKey]++zonkQuickLook :: Bool -> TcType -> TcM TcType+-- After all Quick Look unifications are done, zonk to ensure that all+-- instantiation variables are substituted away+--+-- 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 type+--+-- In implementation terms this ensures that no unification variable+-- linger on that have been filled in with a polytype+zonkQuickLook do_ql ty+  | do_ql     = zonkTcType ty+  | otherwise = return 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++++----------------+tcValArgs :: Bool                    -- Quick-look on?+          -> [HsExprArg 'TcpInst]    -- Actual argument+          -> TcM [HsExprArg 'TcpTc]  -- Resulting argument+tcValArgs do_ql args+  = mapM tc_arg args+  where+    tc_arg :: HsExprArg 'TcpInst -> TcM (HsExprArg 'TcpTc)+    tc_arg (EPrag l p)           = return (EPrag l (tcExprPrag p))+    tc_arg (EWrap w)             = return (EWrap w)+    tc_arg (ETypeArg l hs_ty ty) = return (ETypeArg l hs_ty ty)++    tc_arg eva@(EValArg { eva_arg = arg, eva_arg_ty = Scaled mult arg_ty+                        , eva_ctxt = ctxt })+      = 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)+             -- See Note [Instantiation variables are short lived]+             arg_ty <- zonkQuickLook do_ql arg_ty++             -- Now check the argument+           ; arg' <- tcScalingUsage mult $+                     do { traceTc "tcEValArg" $+                          vcat [ ppr ctxt+                               , text "arg type:" <+> ppr arg_ty+                               , text "arg:" <+> ppr arg ]+                        ; tcEValArg ctxt arg arg_ty }++           ; return (eva { eva_arg    = ValArg arg'+                         , eva_arg_ty = Scaled mult arg_ty }) }++tcEValArg :: AppCtxt -> EValArg 'TcpInst -> TcSigmaType -> TcM (LHsExpr GhcTc)+-- Typecheck one value argument of a function call+tcEValArg ctxt (ValArg larg@(L arg_loc arg)) exp_arg_sigma+  = addArgCtxt ctxt larg $+    do { arg' <- tcPolyExpr arg (mkCheckExpType exp_arg_sigma)+       ; return (L arg_loc arg') }++tcEValArg ctxt (ValArgQL { va_expr = larg@(L arg_loc _)+                         , va_fun = (inner_fun, fun_ctxt)+                         , va_args = inner_args+                         , va_ty = app_res_rho }) exp_arg_sigma+  = addArgCtxt ctxt larg $+    do { traceTc "tcEValArgQL {" (vcat [ ppr inner_fun <+> ppr inner_args ])+       ; tc_args <- tcValArgs True inner_args+       ; co      <- unifyType Nothing app_res_rho exp_arg_sigma+       ; traceTc "tcEValArg }" empty+       ; return (L arg_loc $ mkHsWrapCo co $+                 rebuildHsApps inner_fun fun_ctxt tc_args) }++{- *********************************************************************+*                                                                      *+              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, AppCtxt)        -- Error messages only+          -> 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_ctxt) fun_sigma rn_args+  = do { traceTc "tcInstFun" (vcat [ ppr rn_fun, ppr fun_sigma+                                   , text "args:" <+> ppr rn_args+                                   , text "do_ql" <+> ppr do_ql ])+       ; go emptyVarSet [] [] fun_sigma rn_args }+  where+    fun_loc  = appCtxtLoc fun_ctxt+    fun_orig = exprCtOrigin (case fun_ctxt of+                               VAExpansion e _ -> e+                               VACall e _ _    -> e)+    set_fun_ctxt thing_inside+      | not (isGoodSrcSpan fun_loc)   -- noSrcSpan => no arguments+      = thing_inside                  -- => context is already set+      | otherwise+      = setSrcSpan fun_loc $+        case fun_ctxt of+          VAExpansion orig _ -> addExprCtxt orig thing_inside+          VACall {}          -> thing_inside++    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+    -- c.f. GHC.Tc.Utils.Instantiate.topInstantiate+    go1 delta acc so_far fun_ty args+      | (tvs,   body1) <- tcSplitSomeForAllTyVars (inst_fun args) fun_ty+      , (theta, body2) <- tcSplitPhiTy body1+      , not (null tvs && null theta)+      = do { (inst_tvs, wrap, fun_rho) <- set_fun_ctxt $+                                          instantiateSigma fun_orig tvs theta body2+                 -- set_fun_ctxt: 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 (EWrap w : args)+      = go1 delta (EWrap w : 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_ctxt = ctxt, 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_ctxt = ctxt, 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, eva_ctxt = ctxt })  : rest_args)+      = do { (wrap, arg_ty, res_ty) <- matchActualFunTySigma herald+                                          (Just (ppr rn_fun))+                                          (n_val_args, so_far) fun_ty+          ; (delta', arg') <- if do_ql+                              then addArgCtxt ctxt arg $+                                   -- 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 }+++addArgCtxt :: AppCtxt -> LHsExpr GhcRn+           -> TcM a -> TcM a+-- Adds a "In the third argument of f, namely blah"+-- context, unless we are in generated code, in which case+-- use "In the expression: arg"+---See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr+addArgCtxt (VACall fun arg_no _) (L arg_loc arg) thing_inside+  = setSrcSpanA arg_loc $+    addErrCtxt (funAppCtxt fun arg arg_no) $+    thing_inside++addArgCtxt (VAExpansion {}) (L arg_loc arg) thing_inside+  = setSrcSpanA arg_loc $+    addExprCtxt arg    $  -- Auto-suppressed if arg_loc is generated+    thing_inside++{- *********************************************************************+*                                                                      *+              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) <- tcSplitForAllTyVarBinder_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 = (undefined :: 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) because+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 _ arg) arg_ty+  = do { let (fun@(rn_fun, fun_ctxt), rn_args) = 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 (tc_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+              , text "tc_fun:" <+> ppr tc_fun+              , text "fun_sigma:" <+> ppr fun_sigma ]+       ; 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 fun fun_sigma rn_args+       ; traceTc "quickLookArg 3" $+         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   = (tc_fun, fun_ctxt)+                               , va_args  = inst_args+                               , va_ty    = app_res_rho }+       ; return (delta', ql_arg) } } } }++skipQuickLook :: Delta -> LHsExpr GhcRn -> TcM (Delta, EValArg 'TcpInst)+skipQuickLook delta larg = return (delta, ValArg larg)++----------------+quickLookResultType :: Delta -> TcRhoType -> ExpRhoType -> TcM TcRhoType+-- This function implements the shaded bit of rule APP-Downarrow in+-- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20).+-- It returns its second argument, but with any variables in Delta+-- substituted out, so no variables in Delta escape++quickLookResultType delta app_res_rho (Check exp_rho)+  = -- In checking mode only, do qlUnify with the expected result type+    do { unless (isEmptyVarSet delta)  $ -- Optimisation only+         qlUnify delta app_res_rho exp_rho+       ; return app_res_rho }++quickLookResultType _ app_res_rho (Infer {})+  = zonkTcType app_res_rho+    -- Zonk the result type, to ensure that we substitute out any+    -- filled-in instantiation variable before calling+    -- unifyExpectedType. In the Check case, this isn't necessary,+    -- because unifyExpectedType just drops to tcUnify; but in the+    -- Infer case a filled-in instantiation variable (filled in by+    -- tcInstFun) might perhaps escape into the constraint+    -- generator. The safe thing to do is to zonk any instantiation+    -- variables away.  See Note [Instantiation variables are short lived]++---------------------+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.++* checkTypeEq 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 (EWrap {} : 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) <- tcSplitSomeForAllTyVars (== Inferred) fun_ty+      , (theta, body2) <- tcSplitPhiTy body1+      , not (null tvs && null theta)+      = go (bvs `extendVarSetList` tvs) body2 args+      | Just (_tv, res_ty) <- tcSplitForAllTyVarBinder_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.  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 GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]+            -> TcRhoType+            -> TcM (HsExpr GhcTc)+-- tagToEnum# :: forall a. Int# -> a+-- See Note [tagToEnum#]   Urgh!+tcTagToEnum tc_fun fun_ctxt tc_args res_ty+  | [val_arg] <- dropWhile (not . isHsValArg) tc_args+  = do { res_ty <- zonkTcType res_ty++       -- Check that the type is algebraic+       ; case tcSplitTyConApp_maybe res_ty of {+           Nothing -> do { addErrTc (mk_error res_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 res_ty tc+                         ; vanilla_result } ;+           Just (rep_tc, rep_args, coi) ->++    do { -- coi :: tc tc_args ~R rep_tc rep_args+         check_enumeration res_ty rep_tc+       ; let rep_ty  = mkTyConApp rep_tc rep_args+             tc_fun' = mkHsWrap (WpTyApp rep_ty) tc_fun+             tc_expr = rebuildHsApps tc_fun' fun_ctxt [val_arg]+             df_wrap = mkWpCastR (mkTcSymCo coi)+       ; return (mkHsWrap df_wrap tc_expr) }}}}}++  | otherwise+  = failWithTc (text "tagToEnum# must appear applied to one value argument")++  where+    vanilla_result = return (rebuildHsApps tc_fun fun_ctxt tc_args)++    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

GHC/Tc/Gen/Arrow.hs view

@@ -1,24 +1,25 @@+{-# LANGUAGE RankNTypes    #-}+{-# LANGUAGE TypeFamilies  #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE RankNTypes, TupleSections #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Typecheck arrow notation module GHC.Tc.Gen.Arrow ( tcProc ) where  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@@ -38,6 +39,7 @@ import GHC.Types.Basic( Arity ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc  import Control.Monad@@ -87,14 +89,17 @@        -> ExpRhoType                            -- Expected type of whole proc expression        -> TcM (LPat GhcTc, LHsCmdTop GhcTc, TcCoercion) -tcProc pat cmd exp_ty-  = newArrowScope $-    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows+tcProc pat cmd@(L _ (HsCmdTop names _)) exp_ty+  = do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows         ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty         ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1+        -- start with the names as they are used to desugar the proc itself+        -- See #17423+        ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names         ; let cmd_env = CmdEnv { cmd_arr = arr_ty }-        ; (pat', cmd') <- tcCheckPat ProcExpr pat (unrestricted arg_ty) $-                          tcCmdTop cmd_env cmd (unitTy, res_ty)+        ; (pat', cmd') <- newArrowScope+                          $ tcCheckPat (ArrowMatchCtxt ProcExpr) pat (unrestricted arg_ty)+                          $ tcCmdTop cmd_env names' cmd (unitTy, res_ty)         ; let res_co = mkTcTransCo co                          (mkTcAppCo co1 (mkTcNomReflCo res_ty))         ; return (pat', cmd', res_co) }@@ -113,7 +118,7 @@  data CmdEnv   = CmdEnv {-        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*+        cmd_arr :: TcType -- ^ Arrow type constructor, of kind *->*->*     }  mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType@@ -121,21 +126,21 @@  --------------------------------------- tcCmdTop :: CmdEnv+         -> CmdSyntaxTable GhcTc -- ^ Type-checked Arrow class methods (arr, (>>>), ...)          -> LHsCmdTop GhcRn          -> CmdType          -> TcM (LHsCmdTop GhcTc) -tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)+tcCmdTop env names (L loc (HsCmdTop _names cmd)) cmd_ty@(cmd_stk, res_ty)   = setSrcSpan loc $-    do  { cmd'   <- tcCmd env cmd cmd_ty-        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names-        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }+    do  { cmd' <- tcCmd env cmd cmd_ty+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names) cmd') }  ---------------------------------------- tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTc)         -- The main recursive function tcCmd env (L loc cmd) res_ty-  = setSrcSpan loc $ do+  = setSrcSpan (locA loc) $ do         { cmd' <- tc_cmd env cmd res_ty         ; return (L loc cmd') } @@ -144,11 +149,11 @@   = do  { cmd' <- tcCmd env cmd res_ty         ; return (HsCmdPar x cmd') } -tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty+tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty   = do  { (binds', body') <- tcLocalBinds binds         $-                             setSrcSpan body_loc        $+                             setSrcSpan (locA body_loc) $                              tc_cmd env body res_ty-        ; return (HsCmdLet x (L l binds') (L body_loc body')) }+        ; return (HsCmdLet x binds' (L body_loc body')) }  tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)   = addErrCtxt (cmdCtxt in_cmd) $ do@@ -254,12 +259,14 @@     do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk                  -- Check the patterns, and the GRHSs inside-        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $-                             tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $+        ; (pats', grhss') <- setSrcSpanA mtch_loc                                 $+                             tcPats (ArrowMatchCtxt KappaExpr)+                               pats (map (unrestricted . mkCheckExpType) arg_tys) $                              tc_grhss grhss cmd_stk' (mkCheckExpType res_ty) -        ; let match' = L mtch_loc (Match { m_ext = noExtField-                                         , m_ctxt = LambdaExpr, m_pats = pats'+        ; let match' = L mtch_loc (Match { m_ext = noAnn+                                         , m_ctxt = ArrowMatchCtxt KappaExpr+                                         , m_pats = pats'                                          , m_grhss = grhss' })               arg_tys = map (unrestricted . hsLPatType) pats'               cmd' = HsCmdLam x (MG { mg_alts = L l [match']@@ -268,13 +275,13 @@         ; return (mkHsCmdWrap (mkWpCastN co) cmd') }   where     n_pats     = length pats-    match_ctxt = (LambdaExpr :: HsMatchContext GhcRn)    -- Maybe KappaExpr?+    match_ctxt = ArrowMatchCtxt KappaExpr     pg_ctxt    = PatGuard match_ctxt -    tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty+    tc_grhss (GRHSs x grhss binds) stk_ty res_ty         = do { (binds', grhss') <- tcLocalBinds binds $                                    mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss-             ; return (GRHSs x grhss' (L l binds')) }+             ; return (GRHSs x grhss' binds') }      tc_grhs stk_ty res_ty (GRHS x guards body)         = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $@@ -317,12 +324,13 @@    where     tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTc, TcType)-    tc_cmd_arg cmd+    tc_cmd_arg cmd@(L _ (HsCmdTop names _))        = do { arr_ty <- newFlexiTyVarTy arrowTyConKind             ; stk_ty <- newFlexiTyVarTy liftedTypeKind             ; res_ty <- newFlexiTyVarTy liftedTypeKind+            ; names' <- mapM (tcSyntaxName ProcOrigin arr_ty) names             ; let env' = env { cmd_arr = arr_ty }-            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)+            ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }  -----------------------------------------------------------------@@ -343,7 +351,7 @@ tcCmdMatches env scrut_ty matches (stk, res_ty)   = tcMatchesCase match_ctxt (unrestricted scrut_ty) matches (mkCheckExpType res_ty)   where-    match_ctxt = MC { mc_what = CaseAlt,+    match_ctxt = MC { mc_what = ArrowMatchCtxt ArrowCaseAlt,                       mc_body = mc_body }     mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'                               ; tcCmd env body (stk, res_ty') }@@ -387,7 +395,7 @@                             thing_inside res_ty         ; return (mkTcBindStmt pat' rhs', thing) } -tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names+tcArrDoStmt env ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names                             , recS_rec_ids = rec_names }) res_ty thing_inside   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind@@ -411,13 +419,18 @@         ; let ret_table = zip tup_ids tup_rets         ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j] -        ; return (emptyRecStmtId { recS_stmts = stmts'+        ; let+            stmt :: Stmt GhcTc (LocatedA (HsCmd GhcTc))+            stmt = emptyRecStmtId+                                 { recS_stmts = L l stmts'+                                 -- { recS_stmts = _ stmts'                                  , recS_later_ids = later_ids                                  , recS_rec_ids = rec_ids                                  , recS_ext = unitRecStmtTc                                      { recS_later_rets = later_rets                                      , recS_rec_rets = rec_rets-                                     , recS_ret_ty = res_ty} }, thing)+                                     , recS_ret_ty = res_ty} }+        ; return (stmt, thing)         }}  tcArrDoStmt _ _ stmt _ _

GHC/Tc/Gen/Bind.hs view

@@ -1,14 +1,16 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}- module GHC.Tc.Gen.Bind    ( tcLocalBinds    , tcTopBinds@@ -26,7 +28,7 @@ import {-# SOURCE #-} GHC.Tc.Gen.Expr  ( tcCheckMonoExpr ) import {-# SOURCE #-} GHC.Tc.TyCl.PatSyn ( tcPatSynDecl, tcPatSynBuilderBind ) -import GHC.Core (Tickish (..))+import GHC.Types.Tickish (CoreTickish, GenTickish (..)) import GHC.Types.CostCentre (mkUserCC, CCFlavour(DeclCC)) import GHC.Driver.Session import GHC.Data.FastString@@ -44,11 +46,11 @@ 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 ( mkBoxedTupleTy ) import GHC.Builtin.Types.Prim-import GHC.Builtin.Types( mkBoxedTupleTy )+import GHC.Types.SourceText import GHC.Types.Id import GHC.Types.Var as Var import GHC.Types.Var.Set@@ -64,13 +66,15 @@ import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Types.Basic+import GHC.Types.CompleteMatch import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic 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)@@ -196,119 +200,32 @@         -- 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.+      -- There it is also where we consider if the type of the pattern match is+      -- compatible with the result type constructor 'mb_tc'.+      doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm))+        = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do+            cls   <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns+            mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm+            pure CompleteMatch { cmConLikes = cls, cmResultTyCon = mb_tc }       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 -- signatures in it.  The renamer checked all this tcHsBootSigs binds sigs   = do  { checkTc (null binds) badBootDeclErr-        ; concatMapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }+        ; concatMapM (addLocMA tc_boot_sig) (filter isTypeLSig sigs) }   where     tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames       where@@ -318,7 +235,7 @@         -- Notice that we make GlobalIds, not LocalIds     tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) -badBootDeclErr :: MsgDoc+badBootDeclErr :: SDoc badBootDeclErr = text "Illegal declarations in an hs-boot file"  ------------------------@@ -337,7 +254,7 @@ tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside   = do  { ipClass <- tcLookupClass ipClassName         ; (given_ips, ip_binds') <--            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds+            mapAndUnzipM (wrapLocSndMA (tc_ip_bind ipClass)) ip_binds          -- If the binding binds ?x = E, we  must now         -- discharge any ?x constraints in expr_lie@@ -358,7 +275,7 @@             ; ip_id <- newDict ipClass [ p, ty ]             ; expr' <- tcCheckMonoExpr expr ty             ; let d = toDict ipClass p ty `fmap` expr'-            ; return (ip_id, (IPBind noExtField (Right ip_id) d)) }+            ; return (ip_id, (IPBind noAnn (Right ip_id) d)) }     tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"      -- Coerces a `t` into a dictionary for `IP "x" t`.@@ -408,7 +325,7 @@                  do { thing <- thing_inside                        -- See Note [Pattern synonym builders don't yield dependencies]                        --     in GHC.Rename.Bind-                    ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns+                    ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns                     ; let extra_binds = [ (NonRecursive, builder)                                         | builder <- patsyn_builders ]                     ; return (extra_binds, thing) }@@ -487,7 +404,7 @@         -- See Note [Polymorphic recursion] in "GHC.Hs.Binds".     do  { traceTc "tc_group rec" (pprLHsBinds binds)         ; whenIsJust mbFirstPatSyn $ \lpat_syn ->-            recursivePatSynErr (getLoc lpat_syn) binds+            recursivePatSynErr (locA $ getLoc lpat_syn) binds         ; (binds1, thing) <- go sccs         ; return ([(Recursive, binds1)], thing) }                 -- Rec them all together@@ -526,17 +443,17 @@        2 (vcat $ map pprLBind . bagToList $ binds)   where     pprLoc loc  = parens (text "defined at" <+> ppr loc)-    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)-                                <+> pprLoc loc+    pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)+                                <+> pprLoc (locA loc)  tc_single :: forall thing.             TopLevelFlag -> TcSigFun -> TcPragEnv           -> LHsBind GhcRn -> IsGroupClosed -> TcM thing           -> TcM (LHsBinds GhcTc, thing)-tc_single _top_lvl sig_fn _prag_fn+tc_single _top_lvl sig_fn prag_fn           (L _ (PatSynBind _ psb@PSB{ psb_id = L _ name }))           _ thing_inside-  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name) prag_fn        ; thing <- setGblEnv tcg_env thing_inside        ; return (aux_binds, thing)        }@@ -576,7 +493,7 @@      key_map :: NameEnv BKey     -- Which binding it comes from     key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds-                                     , bndr <- collectHsBindBinders bind ]+                                     , bndr <- collectHsBindBinders CollNoDictBinders bind ]  ------------------------ tcPolyBinds :: TcSigFun -> TcPragEnv@@ -619,8 +536,8 @@      ; return result }   where-    binder_names = collectHsBindListBinders bind_list-    loc = foldr1 combineSrcSpans (map getLoc bind_list)+    binder_names = collectHsBindListBinders CollNoDictBinders bind_list+    loc = foldr1 combineSrcSpans (map (locA . getLoc) bind_list)          -- The mbinds have been dependency analysed and          -- may no longer be adjacent; so find the narrowest          -- span that includes them all@@ -701,7 +618,7 @@                                  , fun_matches = matches }))   = do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc) -       ; mono_name <- newNameAt (nameOccName name) nm_loc+       ; mono_name <- newNameAt (nameOccName name) (locA nm_loc)        ; (wrap_gen, (wrap_res, matches'))              <- setSrcSpan sig_loc $ -- Sets the binding location for the skolems                 tcSkolemiseScoped ctxt (idType poly_id) $ \rho_ty ->@@ -715,12 +632,12 @@                 -- Why mono_id in the BinderStack?                 --    See Note [Relevant bindings and the binder stack] -                setSrcSpan bind_loc $+                setSrcSpanA bind_loc $                 tcMatchesFun (L nm_loc mono_name) matches                              (mkCheckExpType rho_ty)         -- We make a funny AbsBinds, abstracting over nothing,-       -- just so we haev somewhere to put the SpecPrags.+       -- just so we have somewhere to put the SpecPrags.        -- Otherwise we could just use the FunBind        -- Hence poly_id2 is just a clone of poly_id;        -- We re-use mono-name, but we could equally well use a fresh one@@ -731,7 +648,7 @@        ; poly_id    <- addInlinePrags poly_id prag_sigs         ; mod <- getModule-       ; tick <- funBindTicks nm_loc poly_id mod prag_sigs+       ; tick <- funBindTicks (locA nm_loc) poly_id mod prag_sigs         ; let bind' = FunBind { fun_id      = L nm_loc poly_id2                              , fun_matches = matches'@@ -759,7 +676,7 @@   = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)  funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]-             -> TcM [Tickish TcId]+             -> TcM [CoreTickish] funBindTicks loc fun_id mod sigs   | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ]       -- this can only be a singleton list, as duplicate pragmas are rejected@@ -771,7 +688,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@@ -817,9 +734,8 @@        ; mapM_ (checkOverloadedSig mono) sigs         ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)-       ; (qtvs, givens, ev_binds, residual, insoluble)+       ; (qtvs, givens, ev_binds, insoluble)                  <- simplifyInfer tclvl infer_mode sigs name_taus wanted-       ; emitConstraints residual         ; let inferred_theta = map evVarPred givens        ; exports <- checkNoErrs $@@ -827,7 +743,7 @@         ; loc <- getSrcSpanM        ; let poly_ids = map abe_poly exports-             abs_bind = L loc $+             abs_bind = L (noAnnSrcSpan loc) $                         AbsBinds { abs_ext = noExtField                                  , abs_tvs = qtvs                                  , abs_ev_vars = givens, abs_ev_binds = [ev_binds]@@ -917,8 +833,7 @@     do { fam_envs <- tcGetFamInstEnvs        ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty                -- Unification may not have normalised the type,-               -- (see Note [Lazy flattening] in GHC.Tc.Solver.Flatten) so do it-               -- here to make it as uncomplicated as possible.+               -- so do it here to make it as uncomplicated as possible.                -- Example: f :: [F Int] -> Bool                -- should be rewritten to f :: [Char] -> Bool, if possible                --@@ -1035,29 +950,30 @@            -- so that the Hole constraint we have already emitted            -- (in tcHsPartialSigType) can report what filled it in.            -- NB: my_theta already includes all the annotated constraints-           ; let inferred_diff = [ pred-                                 | pred <- my_theta-                                 , all (not . (`eqType` pred)) annotated_theta ]-           ; ctuple <- mk_ctuple inferred_diff+           ; diff_theta <- findInferredDiff annotated_theta my_theta             ; case tcGetCastedTyVar_maybe wc_var_ty of                -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it-               -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc. So, to-               -- make the kinds work out, we reverse the cast here.-               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)+               -- comes from the checkExpectedKind in GHC.Tc.Gen.HsType.tcAnonWildCardOcc.+               -- So, to make the kinds work out, we reverse the cast here.+               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (mk_ctuple diff_theta+                                                              `mkCastTy` mkTcSymCo wc_co)                Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)             ; traceTc "completeTheta" $                 vcat [ ppr sig-                     , ppr annotated_theta, ppr inferred_theta-                     , ppr inferred_diff ]-           ; return (free_tvs, my_theta) }+                     , text "annotated_theta:" <+> ppr annotated_theta+                     , text "inferred_theta:" <+> ppr inferred_theta+                     , text "my_theta:" <+> ppr my_theta+                     , text "diff_theta:" <+> ppr diff_theta ]+           ; return (free_tvs, annotated_theta ++ diff_theta) }+             -- Return (annotated_theta ++ diff_theta)+             -- See Note [Extra-constraints wildcards] -    mk_ctuple preds = return (mkBoxedTupleTy preds)+    mk_ctuple preds = mkBoxedTupleTy preds        -- Hack alert!  See GHC.Tc.Gen.HsType:        -- Note [Extra-constraint holes in partial type signatures] - mk_impedance_match_msg :: MonoBindInfo                        -> TcType -> TcType                        -> TidyEnv -> TcM (TidyEnv, SDoc)@@ -1175,7 +1091,22 @@ explicitly-quantified type variables have not been unified together. #14449 showed this up. +Note [Extra-constraints wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this from #18646+    class Foo x where+      foo :: x +    bar :: (Foo (), _) => f ()+    bar = pure foo++We get [W] Foo (), [W] Applicative f.   When we do pickCapturedPreds in+choose_psig_context, we'll discard Foo ()!  Usually would not quantify over+such (closed) predicates.  So my_theta will be (Applicative f). But we really+do want to quantify over (Foo ()) -- it was speicfied by the programmer.+Solution: always return annotated_theta (user-specified) plus the extra piece+diff_theta.+ Note [Validity of inferred types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We need to check inferred type for validity, in case it uses language@@ -1273,20 +1204,15 @@             -> TcSigFun -> LetBndrSpec             -> [LHsBind GhcRn]             -> TcM (LHsBinds GhcTc, [MonoBindInfo])++-- SPECIAL CASE 1: see Note [Inference for non-recursive function bindings] tcMonoBinds is_rec sig_fn no_gen            [ L b_loc (FunBind { fun_id = L nm_loc name                               , fun_matches = matches })]                              -- Single function binding,   | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS   , Nothing <- sig_fn name   -- ...with no type signature-  =     -- Note [Single function non-recursive binding special-case]-        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-        -- In this very special case we infer the type of the-        -- right hand side first (it may have a higher-rank type)-        -- and *then* make the monomorphic Id for the LHS-        -- e.g.         f = \(x::forall a. a->a) -> <body>-        --      We want to infer a higher-rank type for f-    setSrcSpan b_loc    $+  = setSrcSpanA b_loc    $     do  { ((co_fn, matches'), rhs_ty)             <- tcInfer $ \ exp_ty ->                tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $@@ -1304,8 +1230,31 @@                        , mbi_sig       = Nothing                        , mbi_mono_id   = mono_id }]) } +-- SPECIAL CASE 2: see Note [Inference for non-recursive pattern bindings]+tcMonoBinds is_rec sig_fn no_gen+           [L b_loc (PatBind { pat_lhs = pat, pat_rhs = grhss })]+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS+  , all (isNothing . sig_fn) bndrs+  = addErrCtxt (patMonoBindsCtxt pat grhss) $+    do { (grhss', pat_ty) <- tcInfer $ \ exp_ty ->+                             tcGRHSsPat grhss exp_ty++       ; let exp_pat_ty :: Scaled ExpSigmaType+             exp_pat_ty = unrestricted (mkCheckExpType pat_ty)+       ; (pat', mbis) <- tcLetPat (const Nothing) no_gen pat exp_pat_ty $+                         mapM lookupMBI bndrs++       ; return ( unitBag $ L b_loc $+                     PatBind { pat_lhs = pat', pat_rhs = grhss'+                             , pat_ext = pat_ty, pat_ticks = ([],[]) }++                , mbis ) }+  where+    bndrs = collectPatBinders CollNoDictBinders pat++-- GENERAL CASE tcMonoBinds _ sig_fn no_gen binds-  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds+  = do  { tc_binds <- mapM (wrapLocMA (tcLhs sig_fn no_gen)) binds          -- Bring the monomorphic Ids, into scope for the RHSs         ; let mono_infos = getMonoBindInfo tc_binds@@ -1322,11 +1271,71 @@         ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)                                        | (n,id) <- rhs_id_env]         ; binds' <- tcExtendRecIds rhs_id_env $-                    mapM (wrapLocM tcRhs) tc_binds+                    mapM (wrapLocMA tcRhs) tc_binds          ; return (listToBag binds', mono_infos) } +{- Note [Special case for non-recursive function bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the special case of+* A non-recursive FunBind+* With no type signature+we infer the type of the right hand side first (it may have a+higher-rank type) and *then* make the monomorphic Id for the LHS e.g.+   f = \(x::forall a. a->a) -> <body> +We want to infer a higher-rank type for f++Note [Special case for non-recursive pattern bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the special case of+* A pattern binding+* With no type signature for any of the binders+we can /infer/ the type of the RHS, and /check/ the pattern+against that type.  For example (#18323)++  ids :: [forall a. a -> a]+  combine :: (forall a . [a] -> a) -> [forall a. a -> a]+          -> ((forall a . [a] -> a), [forall a. a -> a])++  (x,y) = combine head ids++with -XImpredicativeTypes we can infer a good type for+(combine head ids), and use that to tell us the polymorphic+types of x and y.++We don't need to check -XImpredicativeTypes beucase without it+these types like [forall a. a->a] are illegal anyway, so this+special case code only really has an effect if -XImpredicativeTypes+is on.  Small exception:+  (x) = e+is currently treated as a pattern binding so, even absent+-XImpredicativeTypes, we will get a small improvement in behaviour.+But I don't think it's worth an extension flag.++Why do we require no type signatures on /any/ of the binders?+Consider+   x :: forall a. a->a+   y :: forall a. a->a+   (x,y) = (id,id)++Here we should /check/ the RHS with expected type+  (forall a. a->a, forall a. a->a).++If we have no signatures, we can the approach of this Note+to /infer/ the type of the RHS.++But what if we have some signatures, but not all? Say this:+  p :: forall a. a->a+  (p,q) = (id,  (\(x::forall b. b->b). x True))++Here we want to push p's signature inwards, i.e. /checking/, to+correctly elaborate 'id'. But we want to /infer/ q's higher rank+type.  There seems to be no way to do this.  So currently we only+switch to inference when we have no signature for any of the binders.+-}++ ------------------------ -- tcLhs typechecks the LHS of the bindings, to construct the environment in which -- we typecheck the RHSs.  Basically what we are doing is this: for each binder:@@ -1364,7 +1373,7 @@     --           Just g = ...f...     -- Hence always typechecked with InferGen     do { mono_info <- tcLhsSigId no_gen (name, sig)-       ; return (TcFunBind mono_info nm_loc matches) }+       ; return (TcFunBind mono_info (locA nm_loc) matches) }    | otherwise  -- No type signature   = do { mono_ty <- newOpenFlexiTyVarTy@@ -1375,7 +1384,7 @@        ; let mono_info = MBI { mbi_poly_name = name                              , mbi_sig       = Nothing                              , mbi_mono_id   = mono_id }-       ; return (TcFunBind mono_info nm_loc matches) }+       ; return (TcFunBind mono_info (locA nm_loc) matches) }  tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })   = -- See Note [Typechecking pattern bindings]@@ -1393,7 +1402,7 @@                  -- The above inferred type get an unrestricted multiplicity. It may be                  -- worth it to try and find a finer-grained multiplicity here                  -- if examples warrant it.-               mapM lookup_info nosig_names+               mapM lookupMBI nosig_names          ; let mbis = sig_mbis ++ nosig_mbis @@ -1403,7 +1412,7 @@          ; return (TcPatBind mbis pat' grhss pat_ty) }   where-    bndr_names = collectPatBinders pat+    bndr_names = collectPatBinders CollNoDictBinders pat     (nosig_names, sig_names) = partitionWith find_sig bndr_names      find_sig :: Name -> Either Name (Name, TcIdSigInfo)@@ -1411,19 +1420,19 @@                       Just (TcIdSig sig) -> Right (name, sig)                       _                  -> Left name -      -- After typechecking the pattern, look up the binder-      -- names that lack a signature, which the pattern has brought-      -- into scope.-    lookup_info :: Name -> TcM MonoBindInfo-    lookup_info name-      = do { mono_id <- tcLookupId name-           ; return (MBI { mbi_poly_name = name-                         , mbi_sig       = Nothing-                         , mbi_mono_id   = mono_id }) }- tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)         -- AbsBind, VarBind impossible +lookupMBI :: Name -> TcM MonoBindInfo+-- After typechecking the pattern, look up the binder+-- names that lack a signature, which the pattern has brought+-- into scope.+lookupMBI name+  = do { mono_id <- tcLookupId name+       ; return (MBI { mbi_poly_name = name+                     , mbi_sig       = Nothing+                     , mbi_mono_id   = mono_id }) }+ ------------------- tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo tcLhsSigId no_gen (name, sig)@@ -1451,9 +1460,9 @@   = tcExtendIdBinderStackForRhs [info]  $     tcExtendTyVarEnvForRhs mb_sig       $     do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))-        ; (co_fn, matches') <- tcMatchesFun (L loc (idName mono_id))+        ; (co_fn, matches') <- tcMatchesFun (L (noAnnSrcSpan loc) (idName mono_id))                                  matches (mkCheckExpType $ idType mono_id)-        ; return ( FunBind { fun_id = L loc mono_id+        ; return ( FunBind { fun_id = L (noAnnSrcSpan loc) mono_id                            , fun_matches = matches'                            , fun_ext = co_fn                            , fun_tick = [] } ) }@@ -1466,15 +1475,9 @@     tcExtendIdBinderStackForRhs infos        $     do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)         ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $-                    tcScalingUsage Many $-                    -- Like in tcMatchesFun, this scaling happens because all-                    -- let bindings are unrestricted. A difference, here, is-                    -- that when this is not the case, any more, we will have to-                    -- make sure that the pattern is strict, otherwise this will-                    -- be desugar to incorrect code.-                    tcGRHSsPat grhss pat_ty+                    tcGRHSsPat grhss (mkCheckExpType pat_ty)         ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'-                           , pat_ext = NPatBindTc emptyNameSet pat_ty+                           , pat_ext = pat_ty                            , pat_ticks = ([],[]) } )}  tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a@@ -1499,7 +1502,7 @@     -- NotTopLevel: it's a monomorphic binding  ----------------------getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]+getMonoBindInfo :: [LocatedA TcMonoBind] -> [MonoBindInfo] getMonoBindInfo tc_binds   = foldr (get_info . unLoc) [] tc_binds   where@@ -1672,10 +1675,10 @@     --      so we should apply the MR     -- See Note [Partial type signatures and generalisation]     partial_sig_mrs-      = [ null theta+      = [ null $ fromMaybeContext mtheta         | TcIdSig (PartialSig { psig_hs_ty = hs_ty })-            <- mapMaybe sig_fn (collectHsBindListBinders lbinds)-        , let (_, L _ theta, _) = splitLHsSigmaTyInvis (hsSigWcType hs_ty) ]+            <- mapMaybe sig_fn (collectHsBindListBinders CollNoDictBinders lbinds)+        , let (mtheta, _) = splitLHsQualTy (hsSigWcType hs_ty) ]      has_partial_sigs   = not (null partial_sig_mrs) @@ -1726,7 +1729,7 @@          in [(f, open_fvs)]     bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })        = let open_fvs = get_open_fvs fvs-         in [(b, open_fvs) | b <- collectPatBinders pat]+         in [(b, open_fvs) | b <- collectPatBinders CollNoDictBinders pat]     bindFvs _        = [] @@ -1770,7 +1773,7 @@  -- This one is called on LHS, when pat and grhss are both Name -- and on RHS, when pat is TcId and grhss is still Name-patMonoBindsCtxt :: (OutputableBndrId p, Outputable body)-                 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc+patMonoBindsCtxt :: (OutputableBndrId p)+                 => LPat (GhcPass p) -> GRHSs GhcRn (LHsExpr GhcRn) -> SDoc patMonoBindsCtxt pat grhss   = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)

GHC/Tc/Gen/Default.hs view

@@ -12,6 +12,8 @@  import GHC.Hs import GHC.Core.Class+import GHC.Core.Type ( typeKind )+import GHC.Types.Var( tyVarKind ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.HsType@@ -22,6 +24,7 @@ import GHC.Builtin.Names import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt @@ -46,7 +49,7 @@   = return (Just [])            -- Default declaration specifying no types  tcDefaults [L locn (DefaultDecl _ mono_tys)]-  = setSrcSpan locn                     $+  = setSrcSpan (locA locn)              $     addErrCtxt defaultDeclCtxt          $     do  { ovl_str   <- xoptM LangExt.OverloadedStrings         ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules@@ -64,13 +67,13 @@         ; return (Just tau_tys) }  tcDefaults decls@(L locn (DefaultDecl _ _) : _)-  = setSrcSpan locn $+  = setSrcSpan (locA locn) $     failWithTc (dupDefaultDeclErr decls)   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@@ -81,25 +84,32 @@         ; return ty }  check_instance :: Type -> Class -> TcM Bool-  -- Check that ty is an instance of cls-  -- We only care about whether it worked or not; return a boolean+-- Check that ty is an instance of cls+-- We only care about whether it worked or not; return a boolean+-- This checks that  cls :: k -> Constraint+-- with just one argument and no polymorphism; if we need to add+-- polymorphism we can make it more complicated.  For now we are+-- concerned with classes like+--    Num      :: Type -> Constraint+--    Foldable :: (Type->Type) -> Constraint check_instance ty cls-  = do  { (_, success) <- discardErrs $-                          askNoErrs $-                          simplifyDefault [mkClassPred cls [ty]]-        ; return success }+  | [cls_tv] <- classTyVars cls+  , tyVarKind cls_tv `tcEqType` typeKind ty+  = simplifyDefault [mkClassPred cls [ty]]+  | otherwise+  = return False  defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc+dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> SDoc dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)   = hang (text "Multiple default declarations")        2 (vcat (map pp dup_things))   where-    pp :: Located (DefaultDecl GhcRn) -> SDoc+    pp :: LDefaultDecl GhcRn -> SDoc     pp (L locn (DefaultDecl _ _))-      = text "here was another default declaration" <+> ppr locn+      = text "here was another default declaration" <+> ppr (locA locn) dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"  badDefaultTy :: Type -> [Class] -> SDoc

GHC/Tc/Gen/Export.hs view

@@ -1,17 +1,15 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE RankNTypes        #-}+{-# LANGUAGE TypeFamilies      #-}  module GHC.Tc.Gen.Export (rnExports, exports_from_avail) where  import GHC.Prelude  import GHC.Hs+import GHC.Types.FieldLabel import GHC.Builtin.Names-import GHC.Types.Name.Reader import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType@@ -19,28 +17,32 @@ import GHC.Rename.Env import GHC.Rename.Unbound ( reportUnboundName ) import GHC.Utils.Error-import GHC.Types.Id-import GHC.Types.Id.Info import GHC.Unit.Module-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set-import GHC.Types.Avail+import GHC.Unit.Module.Imported import GHC.Core.TyCon-import GHC.Types.SrcLoc as SrcLoc-import GHC.Driver.Types import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Core.ConLike-import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Data.Maybe-import GHC.Types.Unique.Set import GHC.Utils.Misc (capitalise) import GHC.Data.FastString (fsLit)+import GHC.Driver.Env +import GHC.Types.TyThing( tyThingCategory )+import GHC.Types.Unique.Set+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Avail+import GHC.Types.SourceFile+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name.Reader+ import Control.Monad import GHC.Driver.Session-import GHC.Rename.Doc         ( rnHsDoc ) import GHC.Parser.PostProcess ( setRdrNameSpace ) import Data.Either            ( partitionEithers ) @@ -145,14 +147,14 @@             Just (Just (acc', y)) -> (acc', Just y)             _                     -> (acc, Nothing) -type ExportOccMap = OccEnv (Name, IE GhcPs)+type ExportOccMap = OccEnv (GreName, IE GhcPs)         -- Tracks what a particular exported OccName         --   in an export list refers to, and which item         --   it came from.  It's illegal to export two distinct things         --   that have the same occurrence name  rnExports :: Bool       -- False => no 'module M(..) where' header at all-          -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list+          -> Maybe (LocatedL [LIE GhcPs]) -- Nothing => no explicit export list           -> RnM TcGblEnv          -- Complains if two distinct exports have same OccName@@ -166,13 +168,14 @@        -- Do not report deprecations arising from the export        -- list, to avoid bleating about re-exporting a deprecated        -- thing (especially via 'module Foo' export item)-   do   { dflags <- getDynFlags+   do   { hsc_env <- getTopEnv         ; tcg_env <- getGblEnv-        ; let TcGblEnv { tcg_mod     = this_mod+        ; let dflags = hsc_dflags hsc_env+              TcGblEnv { tcg_mod     = this_mod                        , tcg_rdr_env = rdr_env                        , tcg_imports = imports                        , tcg_src     = hsc_src } = tcg_env-              default_main | mainModIs dflags == this_mod+              default_main | mainModIs hsc_env == this_mod                            , Just main_fun <- mainFunIs dflags                            = mkUnqual varName (fsLit main_fun)                            | otherwise@@ -185,10 +188,11 @@         -- See Note [Modules without a module header]         ; let real_exports                  | explicit_mod = exports-                 | has_main = Just (noLoc [noLoc (IEVar noExtField-                                     (noLoc (IEName $ noLoc default_main)))])-                              -- ToDo: the 'noLoc' here is unhelpful if 'main'-                              --       turns out to be out of scope+                 | has_main+                          = Just (noLocA [noLocA (IEVar noExtField+                                     (noLocA (IEName $ noLocA default_main)))])+                        -- ToDo: the 'noLoc' here is unhelpful if 'main'+                        --       turns out to be out of scope                  | otherwise = Nothing          -- Rename the export list@@ -213,7 +217,7 @@                           , tcg_dus = tcg_dus tcg_env `plusDU`                                       usesOnly final_ns }) } -exports_from_avail :: Maybe (Located [LIE GhcPs])+exports_from_avail :: Maybe (LocatedL [LIE GhcPs])                          -- ^ 'Nothing' means no explicit export list                    -> GlobalRdrEnv                    -> ImportAvails@@ -246,13 +250,9 @@     -- Even though we don't check whether this is actually a data family     -- only data families can locally define subordinate things (`ns` here)     -- without locally defining (and instead importing) the parent (`n`)-    fix_faminst (AvailTC n ns flds) =-      let new_ns =-            case ns of-              [] -> [n]-              (p:_) -> if p == n then ns else n:ns-      in AvailTC n new_ns flds-+    fix_faminst avail@(AvailTC n ns)+      | availExportsDecl avail = avail+      | otherwise = AvailTC n (NormalGreName n:ns)     fix_faminst avail = avail  @@ -263,7 +263,7 @@   where     do_litem :: ExportAccum -> LIE GhcPs              -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))-    do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)+    do_litem acc lie = setSrcSpan (getLocA lie) (exports_from_item acc lie)      -- Maps a parent to its in-scope children     kids_env :: NameEnv [GlobalRdrElt]@@ -271,8 +271,8 @@      -- See Note [Avails of associated data families]     expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]-    expand_tyty_gre (gre@GRE { gre_name = me, gre_par = ParentIs p })-      | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]+    expand_tyty_gre (gre@GRE { gre_par = ParentIs p })+      | isTyConName p, isTyConName (greMangledName gre) = [gre, gre{ gre_par = NoParent }]     expand_tyty_gre gre = [gre]      imported_modules = [ imv_name imv@@ -323,9 +323,8 @@                               , new_exports))) }      exports_from_item acc@(ExportAccum occs mods) (L loc ie)-        | isDoc ie-        = do new_ie <- lookup_doc_ie ie-             return (Just (acc, (L loc new_ie, [])))+        | Just new_ie <- lookup_doc_ie ie+        = return (Just (acc, (L loc new_ie, [])))          | otherwise         = do (new_ie, avail) <- lookup_ie ie@@ -346,18 +345,18 @@      lookup_ie (IEThingAbs _ (L l rdr))         = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr-             return (IEThingAbs noExtField (L l (replaceWrappedName rdr name))+             return (IEThingAbs noAnn (L l (replaceWrappedName rdr name))                     , avail)      lookup_ie ie@(IEThingAll _ n')         = do             (n, avail, flds) <- lookup_ie_all ie n'             let name = unLoc n-            return (IEThingAll noExtField (replaceLWrappedName n' (unLoc n))-                   , AvailTC name (name:avail) flds)+            return (IEThingAll noAnn (replaceLWrappedName n' (unLoc n))+                   , availTC name (name:avail) flds)  -    lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)+    lookup_ie ie@(IEThingWith _ l wc sub_rdrs)         = do             (lname, subs, avails, flds)               <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs@@ -366,9 +365,9 @@                 NoIEWildcard -> return (lname, [], [])                 IEWildcard _ -> lookup_ie_all ie l             let name = unLoc lname-            return (IEThingWith noExtField (replaceLWrappedName l name) wc subs-                                (flds ++ (map noLoc all_flds)),-                    AvailTC name (name : avails ++ all_avail)+            let flds' = flds ++ (map noLoc all_flds)+            return (IEThingWith flds' (replaceLWrappedName l name) wc subs,+                    availTC name (name : avails ++ all_avail)                                  (map unLoc flds ++ all_flds))  @@ -382,8 +381,8 @@         = do name <- lookupGlobalOccRn $ ieWrappedName rdr              (non_flds, flds) <- lookupChildrenExport name sub_rdrs              if isUnboundName name-                then return (L l name, [], [name], [])-                else return (L l name, non_flds+                then return (L (locA l) name, [], [name], [])+                else return (L (locA l) name, non_flds                             , map (ieWrappedName . unLoc) non_flds                             , flds) @@ -403,16 +402,14 @@                   else -- This occurs when you export T(..), but                        -- only import T abstractly, or T is a synonym.                        addErr (exportItemErr ie)-             return (L l name, non_flds, flds)+             return (L (locA l) name, non_flds, flds)      --------------    lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)-    lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc-                                           return (IEGroup noExtField lev rn_doc)-    lookup_doc_ie (IEDoc _ doc)       = do rn_doc <- rnHsDoc doc-                                           return (IEDoc noExtField rn_doc)-    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExtField str)-    lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier+    lookup_doc_ie :: IE GhcPs -> Maybe (IE GhcRn)+    lookup_doc_ie (IEGroup _ lev doc) = Just (IEGroup noExtField lev doc)+    lookup_doc_ie (IEDoc _ doc)       = Just (IEDoc noExtField doc)+    lookup_doc_ie (IEDocNamed _ str)  = Just (IEDocNamed noExtField str)+    lookup_doc_ie _ = Nothing      -- In an export item M.T(A,B,C), we want to treat the uses of     -- A,B,C as if they were M.A, M.B, M.C@@ -421,21 +418,7 @@     addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)  classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])-classifyGREs = partitionEithers . map classifyGRE--classifyGRE :: GlobalRdrElt -> Either Name FieldLabel-classifyGRE gre = case gre_par gre of-  FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)-  FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)-  _                      -> Left  n-  where-    n = gre_name gre--isDoc :: IE GhcPs -> Bool-isDoc (IEDoc {})      = True-isDoc (IEDocNamed {}) = True-isDoc (IEGroup {})    = True-isDoc _ = False+classifyGREs = partitionGreNames . map gre_name  -- Renaming and typechecking of exports happens after everything else has -- been typechecked.@@ -535,12 +518,13 @@           case name of             NameNotFound -> do { ub <- reportUnboundName unboundName                                ; let l = getLoc n-                               ; return (Left (L l (IEName (L l ub))))}-            FoundFL fls -> return $ Right (L (getLoc n) fls)-            FoundName par name -> do { checkPatSynParent spec_parent par name-                                     ; return-                                       $ Left (replaceLWrappedName n name) }-            IncorrectParent p g td gs -> failWithDcErr p g td gs+                               ; return (Left (L l (IEName (L (la2na l) ub))))}+            FoundChild par child -> do { checkPatSynParent spec_parent par child+                                       ; return $ case child of+                                           FieldGreName fl   -> Right (L (getLocA n) fl)+                                           NormalGreName  name -> Left (replaceLWrappedName n name)+                                       }+            IncorrectParent p c gs -> failWithDcErr p c gs   -- Note: [Typing Pattern Synonym Exports]@@ -589,7 +573,7 @@ -- -- Note: [Types of TyCon] ----- This check appears to be overlly complicated, Richard asked why it+-- This check appears to be overly complicated, Richard asked why it -- is not simply just `isAlgTyCon`. The answer for this is that -- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow. -- (It is either a newtype or data depending on the number of methods)@@ -602,33 +586,30 @@ checkPatSynParent :: Name    -- ^ Alleged parent type constructor                              -- User wrote T( P, Q )                   -> Parent  -- The parent of P we discovered-                  -> Name    -- ^ Either a+                  -> GreName   -- ^ Either a                              --   a) Pattern Synonym Constructor                              --   b) A pattern synonym selector                   -> TcM ()  -- Fails if wrong parent checkPatSynParent _ (ParentIs {}) _   = return () -checkPatSynParent _ (FldParent {}) _-  = return ()--checkPatSynParent parent NoParent mpat_syn+checkPatSynParent parent NoParent gname   | isUnboundName parent -- Avoid an error cascade   = return ()    | otherwise   = do { parent_ty_con  <- tcLookupTyCon parent-       ; mpat_syn_thing <- tcLookupGlobal mpat_syn+       ; mpat_syn_thing <- tcLookupGlobal (greNameMangledName gname)          -- 1. Check that the Id was actually from a thing associated with patsyns        ; case mpat_syn_thing of             AnId i | isId i                    , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i-                   -> handle_pat_syn (selErr i) parent_ty_con p+                   -> handle_pat_syn (selErr gname) parent_ty_con p              AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p -            _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }+            _ -> failWithDcErr parent gname [] }   where     psErr  = exportErrCtxt "pattern synonym"     selErr = exportErrCtxt "pattern synonym record selector"@@ -676,40 +657,47 @@ check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]            -> RnM ExportOccMap check_occs ie occs avails-  -- 'names' and 'fls' are the entities specified by 'ie'-  = foldlM check occs names_with_occs+  -- 'avails' are the entities specified by 'ie'+  = foldlM check occs children   where-    -- Each Name specified by 'ie', paired with the OccName used to-    -- refer to it in the GlobalRdrEnv-    -- (see Note [Representing fields in AvailInfo] in GHC.Types.Avail).-    ---    -- We check for export clashes using the selector Name, but need-    -- the field label OccName for presenting error messages.-    names_with_occs = availsNamesWithOccs avails+    children = concatMap availGreNames avails -    check occs (name, occ)-      = case lookupOccEnv occs name_occ of-          Nothing -> return (extendOccEnv occs name_occ (name, ie))+    -- Check for distinct children exported with the same OccName (an error) or+    -- for duplicate exports of the same child (a warning).+    check :: ExportOccMap -> GreName -> RnM ExportOccMap+    check occs child+      = case try_insert occs child of+          Right occs' -> return occs' -          Just (name', ie')-            | name == name'   -- Duplicate export+          Left (child', ie')+            | greNameMangledName child == greNameMangledName child'   -- Duplicate export             -- But we don't want to warn if the same thing is exported             -- by two different module exports. See ticket #4478.             -> do { warnIfFlag Opt_WarnDuplicateExports-                               (not (dupExport_ok name ie ie'))-                               (dupExportWarn occ ie ie')+                               (not (dupExport_ok child ie ie'))+                               (dupExportWarn child ie ie')                   ; return occs }              | otherwise    -- Same occ name but different names: an error             ->  do { global_env <- getGlobalRdrEnv ;-                     addErr (exportClashErr global_env occ name' name ie' ie) ;+                     addErr (exportClashErr global_env child' child ie' ie) ;                      return occs }++    -- Try to insert a child into the map, returning Left if there is something+    -- already exported with the same OccName+    try_insert :: ExportOccMap -> GreName -> Either (GreName, IE GhcPs) ExportOccMap+    try_insert occs child+      = case lookupOccEnv occs name_occ of+          Nothing -> Right (extendOccEnv occs name_occ (child, ie))+          Just x  -> Left x       where-        name_occ = nameOccName name+        -- For fields, we check for export clashes using the (OccName of the)+        -- selector Name+        name_occ = nameOccName (greNameMangledName child)  -dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool--- The Name is exported by both IEs. Is that ok?+dupExport_ok :: GreName -> IE GhcPs -> IE GhcPs -> Bool+-- The GreName is exported by both IEs. Is that ok? -- "No"  iff the name is mentioned explicitly in both IEs --        or one of the IEs mentions the name *alone* -- "Yes" otherwise@@ -735,13 +723,13 @@ --        import Foo --        data instance T Int = TInt -dupExport_ok n ie1 ie2+dupExport_ok child ie1 ie2   = not (  single ie1 || single ie2         || (explicit_in ie1 && explicit_in ie2) )   where     explicit_in (IEModuleContents {}) = False                   -- module M     explicit_in (IEThingAll _ r)-      = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)+      = occName child == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)     explicit_in _              = True      single IEVar {}      = True@@ -795,9 +783,9 @@           text "attempts to export constructors or class methods that are not visible here" ]  -dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc-dupExportWarn occ_name ie1 ie2-  = hsep [quotes (ppr occ_name),+dupExportWarn :: GreName -> IE GhcPs -> IE GhcPs -> SDoc+dupExportWarn child ie1 ie2+  = hsep [quotes (ppr child),           text "is exported by", quotes (ppr ie1),           text "and",            quotes (ppr ie2)] @@ -813,11 +801,11 @@                       [_] -> text "Parent:"                       _  -> text "Parents:") <+> fsep (punctuate comma parents) -failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a-failWithDcErr parent thing thing_doc parents = do-  ty_thing <- tcLookupGlobal thing+failWithDcErr :: Name -> GreName -> [Name] -> TcM a+failWithDcErr parent child parents = do+  ty_thing <- tcLookupGlobal (greNameMangledName child)   failWithTc $ dcErrMsg parent (pp_category ty_thing)-                        thing_doc (map ppr parents)+                        (ppr child) (map ppr parents)   where     pp_category :: TyThing -> String     pp_category (AnId i)@@ -825,32 +813,37 @@     pp_category i = tyThingCategory i  -exportClashErr :: GlobalRdrEnv -> OccName-               -> Name -> Name+exportClashErr :: GlobalRdrEnv+               -> GreName -> GreName                -> IE GhcPs -> IE GhcPs-               -> MsgDoc-exportClashErr global_env occ name1 name2 ie1 ie2+               -> SDoc+exportClashErr global_env child1 child2 ie1 ie2   = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon-         , ppr_export ie1' name1'-         , ppr_export ie2' name2' ]+         , ppr_export child1' gre1' ie1'+         , ppr_export child2' gre2' ie2'+         ]   where-    ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>-                                       quotes (ppr_name name))-                                    2 (pprNameProvenance (get_gre name)))+    occ = occName child1 +    ppr_export child gre ie = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>+                                            quotes (ppr_name child))+                                        2 (pprNameProvenance gre))+     -- DuplicateRecordFields means that nameOccName might be a mangled     -- $sel-prefixed thing, in which case show the correct OccName alone-    ppr_name name-      | nameOccName name == occ = ppr name-      | otherwise               = ppr occ+    -- (but otherwise show the Name so it will have a module qualifier)+    ppr_name (FieldGreName fl) | flIsOverloaded fl = ppr fl+                               | otherwise         = ppr (flSelector fl)+    ppr_name (NormalGreName name) = ppr name      -- get_gre finds a GRE for the Name, so that we can show its provenance-    get_gre name-        = fromMaybe (pprPanic "exportClashErr" (ppr name))-                    (lookupGRE_Name_OccName global_env name occ)-    get_loc name = greSrcSpan (get_gre name)-    (name1', ie1', name2', ie2') =-      case SrcLoc.leftmost_smallest (get_loc name1) (get_loc name2) of-        LT -> (name1, ie1, name2, ie2)-        GT -> (name2, ie2, name1, ie1)+    gre1 = get_gre child1+    gre2 = get_gre child2+    get_gre child+        = fromMaybe (pprPanic "exportClashErr" (ppr child))+                    (lookupGRE_GreName global_env child)+    (child1', gre1', ie1', child2', gre2', ie2') =+      case SrcLoc.leftmost_smallest (greSrcSpan gre1) (greSrcSpan gre2) of+        LT -> (child1, gre1, ie1, child2, gre2, ie2)+        GT -> (child2, gre2, ie2, child1, gre1, ie1)         EQ -> panic "exportClashErr: clashing exports have idential location"

GHC/Tc/Gen/Expr.hs view

@@ -1,2955 +1,1639 @@-{--%-(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}--{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies, DataKinds, TypeApplications #-}-{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension--{-# 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 "HsVersions.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.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--{--************************************************************************-*                                                                      *-\subsection{Static Pointers}-*                                                                      *-************************************************************************--}---- | A data type to describe why a variable is not closed.-data NotClosedReason = NotLetBoundReason-                     | NotTypeClosed VarSet-                     | NotClosed Name NotClosedReason---- | Checks if the given name is closed and emits an error if not.------ See Note [Not-closed error messages].-checkClosedInStaticForm :: Name -> TcM ()-checkClosedInStaticForm name = do-    type_env <- getLclTypeEnv-    case checkClosed type_env name of-      Nothing -> return ()-      Just reason -> addErrTc $ explain name reason-  where-    -- See Note [Checking closedness].-    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason-    checkClosed type_env n = checkLoop type_env (unitNameSet n) n--    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason-    checkLoop type_env visited n = do+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++module GHC.Tc.Gen.Expr+       ( tcCheckPolyExpr, tcCheckPolyExprNC,+         tcCheckMonoExpr, tcCheckMonoExprNC,+         tcMonoExpr, tcMonoExprNC,+         tcInferRho, tcInferRhoNC,+         tcPolyExpr, tcExpr,+         tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,+         tcCheckId,+         addAmbiguousNameErr,+         getFixedTyVars ) where++#include "HsVersions.h"++import GHC.Prelude++import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )++import GHC.Hs+import GHC.Rename.Utils+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 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 themselves.++tcCheckPolyExpr   expr res_ty = tcPolyLExpr   expr (mkCheckExpType res_ty)+tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty)++-- These versions take an ExpType+tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType+                           -> TcM (LHsExpr GhcTc)++tcPolyLExpr (L loc expr) res_ty+  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad+    addExprCtxt expr $  -- Note [Error contexts in generated code]+    do { expr' <- tcPolyExpr expr res_ty+       ; return (L loc expr') }++tcPolyLExprNC (L loc expr) res_ty+  = setSrcSpanA loc    $+    do { expr' <- tcPolyExpr expr res_ty+       ; return (L loc expr') }++---------------+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 (L loc expr) res_ty+  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad+    addExprCtxt expr $  -- Note [Error contexts in generated code]+    do  { expr' <- tcExpr expr res_ty+        ; return (L loc expr') }++tcMonoExprNC (L loc expr) res_ty+  = setSrcSpanA 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 (L loc expr)+  = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad+    addExprCtxt expr $  -- Note [Error contexts in generated code]+    do { (expr', rho) <- tcInfer (tcExpr expr)+       ; return (L loc expr', rho) }++tcInferRhoNC (L loc expr)+  = setSrcSpanA loc $+    do { (expr', rho) <- tcInfer (tcExpr expr)+       ; return (L loc expr', rho) }+++{- *********************************************************************+*                                                                      *+        tcExpr: the main expression typechecker+*                                                                      *+********************************************************************* -}++tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)+tcPolyExpr expr res_ty+  = do { traceTc "tcPolyExpr" (ppr res_ty)+       ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+                          tcExpr expr res_ty+       ; return $ mkHsWrap wrap expr' }++tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)++-- Use tcApp to typecheck appplications, which are treated specially+-- by Quick Look.  Specifically:+--   - HsVar         lone variables, to ensure that they can get an+--                     impredicative instantiation (via Quick Look+--                     driven by res_ty (in checking mode)).+--   - HsApp         value applications+--   - HsAppType     type applications+--   - ExprWithTySig (e :: type)+--   - HsRecFld      overloaded record fields+--   - HsExpanded    renamer expansions+--   - HsOpApp       operator applications+--   - HsOverLit     overloaded literals+-- These constructors are the union of+--   - ones taken apart by GHC.Tc.Gen.Head.splitHsApps+--   - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe+-- 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@(OpApp {})              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+tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty++tcExpr e@(HsOverLit _ lit) res_ty+  = do { mb_res <- tcShortCutLit lit res_ty+         -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk+       ; case mb_res of+           Just lit' -> return (HsOverLit noAnn lit')+           Nothing   -> 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 (HsUnboundVar _ occ) res_ty+  = do { ty <- expTypeToType res_ty    -- Allow Int# etc (#12531)+       ; her <- emitNewExprHole occ ty+       ; tcEmitBindingUsage bottomUE   -- Holes fit any usage environment+                                       -- (#18491)+       ; return (HsUnboundVar her occ) }++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 (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 (noLocA 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 (HsLam _ match) res_ty+  = do  { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty+        ; return (mkHsWrap wrap (HsLam noExtField 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 }++++{-+************************************************************************+*                                                                      *+                Explicit lists+*                                                                      *+************************************************************************+-}++-- Explict lists [e1,e2,e3] have been expanded already in the renamer+-- The expansion includes an ExplicitList, but it is always the built-in+-- list type, so that's all we need concern ourselves with here.  See+-- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]+tcExpr (ExplicitList _ exprs) res_ty+  = do  { res_ty <- expTypeToType res_ty+        ; (coi, elt_ty) <- matchExpectedListTy res_ty+        ; let tc_elt expr = tcCheckPolyExpr expr elt_ty+        ; exprs' <- mapM tc_elt exprs+        ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }++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 | (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' ) }+++{-+************************************************************************+*                                                                      *+                Let, case, if, do+*                                                                      *+************************************************************************+-}++tcExpr (HsLet x binds expr) res_ty+  = do  { (binds', expr') <- tcLocalBinds binds $+                             tcMonoExpr expr res_ty+        ; return (HsLet x 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+          mult <- newFlexiTyVarTy multiplicityTy++          -- 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+  = tcDoStmts do_or_lc stmts res_ty++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 noComments+                            (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)+                            (L (noAnnSrcSpan loc) (HsStatic fvs expr'))+        }++{-+************************************************************************+*                                                                      *+                Record construction and update+*                                                                      *+************************************************************************+-}++tcExpr expr@(RecordCon { rcon_con = L loc con_name+                       , rcon_flds = rbinds }) res_ty+  = do  { con_like <- tcLookupConLike con_name++        ; (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++        ; checkTc (conLikeHasBuilder con_like) $+          nonBidirectionalErr (conLikeName con_like)++        ; 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 = mkHsWrap con_wrap con_expr+              expr' = RecordCon { rcon_ext = rcon_tc+                                , rcon_con = L loc con_like+                                , rcon_flds = rbinds' }++        ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty++        -- Check for missing fields.  We do this after type-checking to get+        -- better types in error messages (cf #18869).  For example:+        --     data T a = MkT { x :: a, y :: a }+        --     r = MkT { y = True }+        -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`.+        --+        -- NB: to do this really properly we should delay reporting until typechecking is complete,+        -- via a new `HoleSort`.  But that seems too much work.+        ; checkMissingFields con_like rbinds arg_tys++        ; return ret }+  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"++-}++-- Record updates via dot syntax are replaced by desugared expressions+-- in the renamer. See Note [Overview of record dot syntax] in+-- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here+-- and panic otherwise.+tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left 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+        ; checkTc (conLikeHasBuilder 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 = Left rbinds'+                                , rupd_ext = upd_tc }++        ; tcWrapResult expr expr' rec_res_ty res_ty }+tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"+++{-+************************************************************************+*                                                                      *+        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++{-+************************************************************************+*                                                                      *+                Record dot syntax+*                                                                      *+************************************************************************+-}++-- These terms have been replaced by desugaring in the renamer. See+-- Note [Overview of record dot syntax].+tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"+tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"++{-+************************************************************************+*                                                                      *+                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++{-+************************************************************************+*                                                                      *+                Catch-all+*                                                                      *+************************************************************************+-}++tcExpr (HsConLikeOut {})   ty = pprPanic "tcExpr:HsConLikeOut" (ppr ty)+tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty)+tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty)+tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)+tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut"    (ppr ty)+tcExpr (HsTick {})         ty = pprPanic "tcExpr:HsTick"    (ppr ty)+tcExpr (HsBinTick {})      ty = pprPanic "tcExpr:HsBinTick"    (ppr 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') }++----------------+tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]+tcTupArgs args tys+  = do MASSERT( equalLength args tys )+       checkTupSize (length args)+       mapM go (args `zip` tys)+  where+    go (Missing {},     arg_ty) = do { mult <- newFlexiTyVarTy multiplicityTy+                                     ; return (Missing (Scaled mult arg_ty)) }+    go (Present x expr, arg_ty) = do { expr' <- tcCheckPolyExpr expr arg_ty+                                     ; return (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, VACall op 0 noSrcSpan) [] Nothing+             -- Ugh!! 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' GhcTc (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 False . 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 ->+              do { reportAmbiguousField p+                 ; 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+            -> do { reportAmbiguousField tc+                  ; 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' GhcTc (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, greMangledName 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, greMangledName (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' GhcRn (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 (noAnnSrcSpan loc) lbl)) }+           ; return $ L l HsRecField+               { hsRecFieldAnn = hsRecFieldAnn upd+               , hsRecFieldLbl+                       = L loc (Unambiguous i (L (noAnnSrcSpan loc) lbl))+               , hsRecFieldArg = hsRecFieldArg upd+               , hsRecPun = hsRecPun upd+               }+           }++    -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head+    reportAmbiguousField :: TyCon -> TcM ()+    reportAmbiguousField parent_type =+        setSrcSpan loc $ warnIfFlag Opt_WarnAmbiguousFields True $+          vcat [ text "The record update" <+> ppr rupd+                   <+> text "with type" <+> ppr parent_type+                   <+> text "is ambiguous."+               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."+               ]+      where+        rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }+        loc  = getLocA (head rbnds)++{-+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 tcCheckPolyExprNC (in tcRecordField),+   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' }))) }+               Just (f', rhs') -> return (Just (L l (HsRecField+                                                     { hsRecFieldAnn = hsRecFieldAnn fld+                                                     , hsRecFieldLbl = f'+                                                     , hsRecFieldArg = rhs'+                                                     , hsRecPun = hsRecPun fld}))) }++tcRecordUpd+        :: ConLike+        -> [TcType]     -- Expected type for each field+        -> [LHsRecField' GhcTc (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' GhcTc (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 (noAnnSrcSpan 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 (noAnnSrcSpan 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 -> [Scaled TcType] -> TcM ()+checkMissingFields con_like rbinds arg_tys+  | 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) $ do+        fs <- zonk_fields missing_s_fields+        -- It is an error to omit a strict field, because+        -- we can't substitute it with (error "Missing field f")+        addErrTc (missingStrictFields con_like fs)++    warn <- woptM Opt_WarnMissingFields+    when (warn && notNull missing_ns_fields) $ do+        fs <- zonk_fields missing_ns_fields+        -- It is not an error (though we may want) to omit a+        -- lazy field, because we can always use+        -- (error "Missing field f") instead.+        warnTc (Reason Opt_WarnMissingFields) True+             (missingFields con_like fs)++  where+    -- we zonk the fields to get better types in error messages (#18869)+    zonk_fields fs = forM fs $ \(str,ty) -> do+        ty' <- zonkTcType ty+        return (str,ty')+    missing_s_fields+        = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,+                 isBanged str,+                 not (fl `elemField` field_names_used)+          ]+    missing_ns_fields+        = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,+                 not (isBanged str),+                 not (fl `elemField` field_names_used)+          ]++    field_names_used = hsRecFields rbinds+    field_labels     = conLikeFieldLabels con_like++    field_info = zip3 field_labels field_strs arg_tys++    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")++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' GhcTc (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, TcType)] -> SDoc+missingStrictFields con fields+  = vcat [header, nest 2 rest]+  where+    pprField (f,ty) = ppr f <+> dcolon <+> ppr ty+    rest | null fields = Outputable.empty  -- Happens for non-record constructors+                                           -- with strict fields+         | otherwise   = vcat (fmap pprField fields)++    header = text "Constructor" <+> quotes (ppr con) <+>+             text "does not have the required strict field(s)" <>+             if null fields then Outputable.empty else colon++missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc+missingFields con fields+  = vcat [header, nest 2 rest]+  where+    pprField (f,ty) = ppr f <+> text "::" <+> ppr ty+    rest | null fields = Outputable.empty+         | otherwise   = vcat (fmap pprField fields)+    header = text "Fields of" <+> quotes (ppr con) <+>+             text "not initialised" <>+             if null fields then Outputable.empty else colon++-- 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"++{-+************************************************************************+*                                                                      *+\subsection{Static Pointers}+*                                                                      *+************************************************************************+-}++-- | A data type to describe why a variable is not closed.+data NotClosedReason = NotLetBoundReason+                     | NotTypeClosed VarSet+                     | NotClosed Name NotClosedReason++-- | Checks if the given name is closed and emits an error if not.+--+-- See Note [Not-closed error messages].+checkClosedInStaticForm :: Name -> TcM ()+checkClosedInStaticForm name = do+    type_env <- getLclTypeEnv+    case checkClosed type_env name of+      Nothing -> return ()+      Just reason -> addErrTc $ explain name reason+  where+    -- See Note [Checking closedness].+    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason+    checkClosed type_env n = checkLoop type_env (unitNameSet n) n++    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason+    checkLoop type_env visited n =       -- The @visited@ set is an accumulating parameter that contains the set of       -- visited nodes, so we avoid repeating cycles in the traversal.       case lookupNameEnv type_env n of

GHC/Tc/Gen/Expr.hs-boot view

@@ -1,13 +1,14 @@ module GHC.Tc.Gen.Expr where-import GHC.Types.Name-import GHC.Hs              ( HsExpr, LHsExpr, SyntaxExprRn, SyntaxExprTc )-import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )+import GHC.Hs              ( HsExpr, LHsExpr, SyntaxExprRn+                           , SyntaxExprTc )+import GHC.Tc.Utils.TcType ( TcRhoType, TcSigmaType, SyntaxOpType+                           , ExpType, ExpRhoType, ExpSigmaType ) import GHC.Tc.Types        ( TcM ) import GHC.Tc.Types.Origin ( CtOrigin ) import GHC.Core.Type ( Mult )-import GHC.Hs.Extension    ( GhcRn, GhcTc )+import GHC.Hs.Extension ( GhcRn, GhcTc ) -tcCheckPolyExpr ::+tcCheckPolyExpr, tcCheckPolyExprNC ::           LHsExpr GhcRn        -> TcSigmaType        -> TcM (LHsExpr GhcTc)@@ -21,9 +22,8 @@        -> TcRhoType        -> TcM (LHsExpr GhcTc) -tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)--tcInferSigma :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcSigmaType)+tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)+tcExpr     :: HsExpr GhcRn -> ExpRhoType   -> TcM (HsExpr GhcTc)  tcInferRho, tcInferRhoNC ::           LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)@@ -42,5 +42,3 @@               -> ([TcSigmaType] -> [Mult] -> TcM a)               -> TcM (a, SyntaxExprTc) --tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)

GHC/Tc/Gen/Foreign.hs view

@@ -6,6 +6,10 @@  {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ViewPatterns #-}  -- | Typechecking @foreign@ declarations --@@ -54,10 +58,13 @@ import GHC.Types.Name.Reader import GHC.Core.DataCon import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Tc.Utils.TcType import GHC.Builtin.Names import GHC.Driver.Session+import GHC.Driver.Backend import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import GHC.Platform import GHC.Types.SrcLoc import GHC.Data.Bag@@ -67,13 +74,13 @@ import Control.Monad  -- Defines a binding-isForeignImport :: LForeignDecl name -> Bool-isForeignImport (L _ (ForeignImport {})) = True+isForeignImport :: forall name. UnXRec name => LForeignDecl name -> Bool+isForeignImport (unXRec @name -> ForeignImport {}) = True isForeignImport _                        = False  -- Exports a binding-isForeignExport :: LForeignDecl name -> Bool-isForeignExport (L _ (ForeignExport {})) = True+isForeignExport :: forall name. UnXRec name => LForeignDecl name -> Bool+isForeignExport (unXRec @name -> ForeignExport {}) = True isForeignExport _                        = False  {-@@ -117,7 +124,7 @@       | Just (tc, tys) <- splitTyConApp_maybe ty       = go_tc_app role rec_nts tc tys -      | (bndrs, inner_ty) <- splitForAllVarBndrs ty+      | (bndrs, inner_ty) <- splitForAllTyCoVarBinders ty       , not (null bndrs)       = do (coi, nty1, gres1) <- go role rec_nts inner_ty            return ( mkHomoForAllCos (binderVars bndrs) coi@@ -209,8 +216,11 @@  tcForeignImports :: [LForeignDecl GhcRn]                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)-tcForeignImports decls-  = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)+tcForeignImports decls = do+    hooks <- getHooks+    case tcForeignImportsHook hooks of+        Nothing -> tcForeignImports' decls+        Just h  -> h decls  tcForeignImports' :: [LForeignDecl GhcRn]                   -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)@@ -225,7 +235,7 @@           -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt) tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty                                     , fd_fi = imp_decl }))-  = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $+  = setSrcSpanA dloc $ addErrCtxt (foreignDeclCtxt fo)  $     do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty        ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty        ; let@@ -352,8 +362,11 @@  tcForeignExports :: [LForeignDecl GhcRn]              -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)-tcForeignExports decls =-  getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)+tcForeignExports decls = do+    hooks <- getHooks+    case tcForeignExportsHook hooks of+        Nothing -> tcForeignExports' decls+        Just h  -> h decls  tcForeignExports' :: [LForeignDecl GhcRn]              -> TcM (LHsBinds GhcTc, [LForeignDecl GhcTc], Bag GlobalRdrElt)@@ -363,7 +376,7 @@   = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)   where    combine (binds, fs, gres1) (L loc fe) = do-       (b, f, gres2) <- setSrcSpan loc (tcFExport fe)+       (b, f, gres2) <- setSrcSpanA loc (tcFExport fe)        return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)  tcFExport :: ForeignDecl GhcRn@@ -387,7 +400,7 @@     -- We need to give a name to the new top-level binding that     -- is *stable* (i.e. the compiler won't change it later),     -- because this name will be referred to by the C code stub.-    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc+    id  <- mkStableIdFromName nm sig_ty (locA loc) mkForeignExportOcc     return ( mkVarBind id rhs            , ForeignExport { fd_name = L loc id                            , fd_sig_ty = undefined@@ -483,31 +496,31 @@ checkSafe   = True noCheckSafe = False --- Checking a supported backend is in use--checkCOrAsmOrLlvm :: HscTarget -> Validity-checkCOrAsmOrLlvm HscC    = IsValid-checkCOrAsmOrLlvm HscAsm  = IsValid-checkCOrAsmOrLlvm HscLlvm = IsValid+-- | Checking a supported backend is in use+checkCOrAsmOrLlvm :: Backend -> Validity+checkCOrAsmOrLlvm ViaC = IsValid+checkCOrAsmOrLlvm NCG  = IsValid+checkCOrAsmOrLlvm LLVM = IsValid checkCOrAsmOrLlvm _   = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)") -checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity-checkCOrAsmOrLlvmOrInterp HscC           = IsValid-checkCOrAsmOrLlvmOrInterp HscAsm         = IsValid-checkCOrAsmOrLlvmOrInterp HscLlvm        = IsValid-checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid+-- | Checking a supported backend is in use+checkCOrAsmOrLlvmOrInterp :: Backend -> Validity+checkCOrAsmOrLlvmOrInterp ViaC        = IsValid+checkCOrAsmOrLlvmOrInterp NCG         = IsValid+checkCOrAsmOrLlvmOrInterp LLVM        = IsValid+checkCOrAsmOrLlvmOrInterp Interpreter = IsValid checkCOrAsmOrLlvmOrInterp _   = NotValid (text "requires interpreted, unregisterised, llvm or native code generation") -checkCg :: (HscTarget -> Validity) -> TcM ()+checkCg :: (Backend -> Validity) -> TcM () checkCg check = do     dflags <- getDynFlags-    let target = hscTarget dflags-    case target of-      HscNothing -> return ()+    let bcknd = backend dflags+    case bcknd of+      NoBackend -> return ()       _ ->-        case check target of+        case check bcknd of           IsValid      -> return ()           NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err) @@ -535,7 +548,7 @@  -- Warnings -check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()+check :: Validity -> (SDoc -> SDoc) -> TcM () check IsValid _             = return () check (NotValid doc) err_fn = addErrTc (err_fn doc) @@ -551,7 +564,7 @@ argument = text "argument" result   = text "result" -badCName :: CLabelString -> MsgDoc+badCName :: CLabelString -> SDoc badCName target   = sep [quotes (ppr target) <+> text "is not a valid C identifier"]

+ GHC/Tc/Gen/Head.hs view

@@ -0,0 +1,1285 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}++{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module GHC.Tc.Gen.Head+       ( HsExprArg(..), EValArg(..), TcPass(..)+       , AppCtxt(..), appCtxtLoc, insideExpansion+       , splitHsApps, rebuildHsApps+       , addArgWrap, isHsValArg+       , countLeadingValArgs, isVisibleArg, pprHsExprArgTc++       , tcInferAppHead, tcInferAppHead_maybe+       , tcInferId, tcCheckId+       , obviousSig, addAmbiguousNameErr+       , tyConOf, tyConOfET, lookupParents, fieldNotInType+       , notSelector, nonBidirectionalErr++       , addExprCtxt, 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.Zonk      ( hsLitType )+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+import qualified Data.List.NonEmpty as NE++#include "HsVersions.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]+~~~~~~~~~~~~~~~~~~+The key function+  splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn])+takes apart either an HsApp, or an infix OpApp, returning++* The "head" of the application, an expression that is often a variable;+  this is used for typechecking++* The "user head" or "error head" of the application, to be reported to the+  user in case of an error.  Example:+         (`op` e)+  expands (via HsExpanded) to+         (rightSection op e)+  but we don't want to see 'rightSection' in error messages. So we keep the+  innermost un-expanded head as the "error head".++* A list of HsExprArg, the arguments+-}++data TcPass = TcpRn     -- Arguments decomposed+            | TcpInst   -- Function instantiated+            | TcpTc     -- Typechecked++data HsExprArg (p :: TcPass)+  = -- See Note [HsExprArg]+    EValArg  { eva_ctxt   :: AppCtxt+             , eva_arg    :: EValArg p+             , eva_arg_ty :: !(XEVAType p) }++  | ETypeArg { eva_ctxt  :: AppCtxt+             , eva_hs_ty :: LHsWcType GhcRn  -- The type arg+             , eva_ty    :: !(XETAType p) }  -- Kind-checked type arg++  | EPrag    AppCtxt+             (HsPragE (GhcPass (XPass p)))++  | EWrap    EWrap++data EWrap = EPar    AppCtxt+           | EExpand (HsExpr GhcRn)+           | EHsWrap HsWrapper++data EValArg (p :: TcPass) where  -- See Note [EValArg]+  ValArg   :: LHsExpr (GhcPass (XPass p))+           -> EValArg p++  ValArgQL :: { va_expr :: LHsExpr GhcRn        -- Original application+                                                -- For location and error msgs+              , va_fun  :: (HsExpr GhcTc, AppCtxt) -- Function of the application,+                                                   -- typechecked, plus its context+              , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated+              , va_ty   :: TcRhoType }          -- Result type+           -> EValArg 'TcpInst  -- Only exists in TcpInst phase++data AppCtxt+  = VAExpansion+       (HsExpr GhcRn)    -- Inside an expansion of this expression+       SrcSpan           -- The SrcSpan of the expression+                         --    noSrcSpan if outermost++  | VACall+       (HsExpr GhcRn) Int  -- In the third argument of function f+       SrcSpan             -- The SrcSpan of the application (f e1 e2 e3)++appCtxtLoc :: AppCtxt -> SrcSpan+appCtxtLoc (VAExpansion _ l) = l+appCtxtLoc (VACall _ _ l)    = l++insideExpansion :: AppCtxt -> Bool+insideExpansion (VAExpansion {}) = True+insideExpansion (VACall {})      = False++instance Outputable AppCtxt where+  ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e+  ppr (VACall f n _)    = text "VACall" <+> int n <+> ppr f++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++mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn+mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt+                           , eva_arg_ty = noExtField }++mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn+mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty+                                 , eva_ty = noExtField }++addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]+addArgWrap wrap args+ | isIdHsWrapper wrap = args+ | otherwise          = EWrap (EHsWrap wrap) : args++splitHsApps :: HsExpr GhcRn+            -> ( (HsExpr GhcRn, AppCtxt)  -- Head+               , [HsExprArg 'TcpRn])      -- Args+-- See Note [splitHsApps]+splitHsApps e = go e (top_ctxt 0 e) []+  where+    top_ctxt n (HsPar _ fun)               = top_lctxt n fun+    top_ctxt n (HsPragE _ _ fun)           = top_lctxt n fun+    top_ctxt n (HsAppType _ fun _)         = top_lctxt (n+1) fun+    top_ctxt n (HsApp _ fun _)             = top_lctxt (n+1) fun+    top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig      n noSrcSpan+    top_ctxt n other_fun                   = VACall other_fun n noSrcSpan++    top_lctxt n (L _ fun) = top_ctxt n fun++    go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]+       -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])+    go (HsPar _     (L l fun))    ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt)   : args)+    go (HsPragE _ p (L l fun))    ctxt args = go fun (set l ctxt) (EPrag      ctxt p   : args)+    go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty  : args)+    go (HsApp _ (L l fun) arg)    ctxt args = go fun (dec l ctxt) (mkEValArg  ctxt arg : args)++    -- See Note [Looking through HsExpanded]+    go (XExpr (HsExpanded orig fun)) ctxt args+      = go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args)++    -- See Note [Desugar OpApp in the typechecker]+    go e@(OpApp _ arg1 (L l op) arg2) _ args+      = ( (op, VACall op 0 (locA l))+        ,   mkEValArg (VACall op 1 generatedSrcSpan) arg1+          : mkEValArg (VACall op 2 generatedSrcSpan) arg2+          : EWrap (EExpand e)+          : args )++    go e ctxt args = ((e,ctxt), args)++    set :: SrcSpanAnnA -> AppCtxt -> AppCtxt+    set l (VACall f n _)        = VACall f n (locA l)+    set _ ctxt@(VAExpansion {}) = ctxt++    dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt+    dec l (VACall f n _)        = VACall f (n-1) (locA l)+    dec _ ctxt@(VAExpansion {}) = ctxt++rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc+rebuildHsApps fun _ [] = fun+rebuildHsApps fun ctxt (arg : args)+  = case arg of+      EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }+        -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args+      ETypeArg { eva_hs_ty = hs_ty, eva_ty  = ty, eva_ctxt = ctxt' }+        -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args+      EPrag ctxt' p+        -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args+      EWrap (EPar ctxt')+        -> rebuildHsApps (HsPar noAnn lfun) ctxt' args+      EWrap (EExpand orig)+        -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args+      EWrap (EHsWrap wrap)+        -> rebuildHsApps (mkHsWrap wrap fun) ctxt args+  where+    lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun++isHsValArg :: HsExprArg id -> Bool+isHsValArg (EValArg {}) = True+isHsValArg _            = False++countLeadingValArgs :: [HsExprArg id] -> Int+countLeadingValArgs []                   = 0+countLeadingValArgs (EValArg {}  : args) = 1 + countLeadingValArgs args+countLeadingValArgs (EWrap {}    : args) = countLeadingValArgs args+countLeadingValArgs (EPrag {}    : args) = countLeadingValArgs args+countLeadingValArgs (ETypeArg {} : _)    = 0++isValArg :: HsExprArg id -> Bool+isValArg (EValArg {}) = True+isValArg _            = False++isVisibleArg :: HsExprArg id -> Bool+isVisibleArg (EValArg {})  = True+isVisibleArg (ETypeArg {}) = True+isVisibleArg _             = False++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 (EWrap wrap)                     = ppr wrap++instance Outputable EWrap where+  ppr (EPar _)       = text "EPar"+  ppr (EHsWrap w)    = text "EHsWrap" <+> ppr w+  ppr (EExpand orig) = text "EExpand" <+> ppr orig++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++{- Note [Desugar OpApp in the typechecker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Operator sections are desugared in the renamer; see GHC.Rename.Expr+Note [Handling overloaded and rebindable constructs].+But for reasons explained there, we rename OpApp to OpApp.  Then,+here in the typechecker, we desugar it to a use of HsExpanded.+That makes it possible to typecheck something like+     e1 `f` e2+where+   f :: forall a. t1 -> forall b. t2 -> t3++Note [Looking through HsExpanded]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When creating an application chain in splitHsApps, we must deal with+     HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3++as a single application chain `f e1 e2 e3`.  Otherwise stuff like overloaded+labels (#19154) won't work.++It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.+-}++{- *********************************************************************+*                                                                      *+                 tcInferAppHead+*                                                                      *+********************************************************************* -}++tcInferAppHead :: (HsExpr GhcRn, AppCtxt)+               -> [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 selector 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,ctxt) args mb_res_ty+  = setSrcSpan (appCtxtLoc ctxt) $+    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+      HsOverLit _ lit           -> Just <$> tcInferOverLit lit+      _                         -> 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 [Deprecating ambiguous fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the future, the -XDuplicateRecordFields extension will no longer support+disambiguating record fields during type-checking (as described in Note+[Disambiguating record fields]).  For now, the -Wambiguous-fields option will+emit a warning whenever an ambiguous field is resolved using type information.+In a subsequent GHC release, this functionality will be removed and the warning+will turn into an ambiguity error in the renamer.++For background information, see GHC proposal #366+(https://github.com/ghc-proposals/ghc-proposals/pull/366).+++Note [Disambiguating record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB. The following is going to be removed: see+Note [Deprecating ambiguous 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 :: LocatedN 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_naughty occ id+                     ; check_local_id id+                     ; return id }++             AGlobal (AnId id)+               -> do { check_naughty 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 :: LocatedN 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 :: LocatedN 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 True rdr+       ; let parent = RecSelData p+       ; case lookup parent xs of {+           Nothing  -> failWithTc (fieldNotInType parent rdr) ;+           Just gre ->++    -- See Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class+    do { addUsedGRE True gre+       ; keepAlive (greMangledName gre)+         -- See Note [Deprecating ambiguous fields]+       ; warnIfFlag Opt_WarnAmbiguousFields True $+          vcat [ text "The field" <+> quotes (ppr rdr)+                   <+> text "belonging to type" <+> ppr parent_type+                   <+> text "is ambiguous."+               , text "This will not be supported by -XDuplicateRecordFields in future releases of GHC."+               , if isLocalGRE gre+                 then text "You can use explicit case analysis to resolve the ambiguity."+                 else text "You can use a qualified import or explicit case analysis to resolve the ambiguity."+               ]+       ; return (greMangledName gre) } } } } }++-- This field name really is ambiguous, so add a suitable "ambiguous+-- occurrence" error, then give up.+ambiguousSelector :: LocatedN 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+       ; case gres of+         [] -> panic "addAmbiguousNameErr: not found"+         gre : gres -> setErrCtxt [] $ addNameClashErrRn rdr $ gre NE.:| 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 :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]+lookupParents is_selector rdr+  = do { env <- getGlobalRdrEnv+        -- Filter by isRecFldGRE because otherwise a non-selector variable with+        -- an overlapping name can get through when NoFieldSelectors is enabled.+        -- See Note [NoFieldSelectors] in GHC.Rename.Env.+       ; let all_gres = lookupGRE_RdrName' rdr env+       ; let gres | is_selector = filter isFieldSelectorGRE all_gres+                  | otherwise   = filter isRecFldGRE all_gres+       ; mapM lookupParent gres }+  where+    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)+    lookupParent gre = do { id <- tcLookupId (greMangledName gre)+                          ; case recordSelectorTyCon_maybe id of+                              Just rstc -> return (rstc, gre)+                              Nothing -> failWithTc (notSelector (greMangledName 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 = getLocA (dropWildCards 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, _)+                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted++       ; 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.+-}+++{- *********************************************************************+*                                                                      *+                 Overloaded literals+*                                                                      *+********************************************************************* -}++tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)+tcInferOverLit lit@(OverLit { ol_val = val+                            , ol_witness = HsVar _ (L loc from_name)+                            , ol_ext = rebindable })+  = -- Desugar "3" to (fromInteger (3 :: Integer))+    --   where fromInteger is gotten by looking up from_name, and+    --   the (3 :: Integer) is returned by mkOverLit+    -- Ditto the string literal "foo" to (fromString ("foo" :: String))+    do { from_id <- tcLookupId from_name+       ; (wrap1, from_ty) <- topInstantiate orig (idType from_id)++       ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc+                                                           (1, []) from_ty+       ; hs_lit <- mkOverLit val+       ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty)++       ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $+                        HsLit noAnn hs_lit+             from_expr = mkHsWrap (wrap2 <.> wrap1) $+                         HsVar noExtField (L loc from_id)+             lit' = lit { ol_witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr+                        , ol_ext = OverLitTc rebindable res_ty }+       ; return (HsOverLit noAnn lit', res_ty) }+  where+    orig   = LiteralOrigin lit+    mb_doc = Just (ppr from_name)+    herald = sep [ text "The function" <+> quotes (ppr from_name)+                 , text "is applied to"]++tcInferOverLit lit+  = pprPanic "tcInferOverLit" (ppr lit)+++{- *********************************************************************+*                                                                      *+                 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 rn_fun [] actual_res_ty res_ty $+         tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }+  where+    rn_fun = HsVar noExtField (noLocA name)++------------------------+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 (noLocA assert_error_id)), id_rho)+       }++tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)+tc_infer_id id_name+ = do { thing <- tcLookup id_name+      ; global_env <- getGlobalRdrEnv+      ; case thing of+             ATcId { tct_id = id }+               -> do { check_local_id id+                     ; return_id id }++             AGlobal (AnId 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+                   | Just (expr, ty) <- patSynBuilderOcc ps+                   -> return (expr, ty)+                   | otherwise+                   -> failWithTc (nonBidirectionalErr id_name)++             AGlobal (ATyCon ty_con)+               -> fail_tycon global_env ty_con++             ATyVar name _+                -> failWithTc $+                     text "Illegal term-level use of the type variable"+                       <+> quotes (ppr name)+                       $$ nest 2 (text "bound at" <+> ppr (getSrcLoc name))++             ATcTyCon ty_con+               -> fail_tycon global_env ty_con++             _ -> failWithTc $+                  ppr thing <+> text "used where a value identifier was expected" }+  where+    fail_tycon global_env ty_con =+      let pprov = case lookupGRE_Name global_env (tyConName ty_con) of+            Just gre -> nest 2 (pprNameProvenance gre)+            Nothing  -> empty+      in failWithTc (term_level_tycons ty_con $$ pprov)++    term_level_tycons ty_con+      = text "Illegal term-level use of the type constructor"+          <+> quotes (ppr (tyConName ty_con))++    return_id id = return (HsVar noExtField (noLocA 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 :: Id -> TcM ()+check_local_id id+  = do { checkThLocalId id+       ; tcEmitBindingUsage $ unitUE (idName id) One }++check_naughty :: OccName -> TcId -> TcM ()+check_naughty lbl id+  | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)+  | otherwise                  = return ()++nonBidirectionalErr :: Outputable name => name -> SDoc+nonBidirectionalErr name = text "non-bidirectional pattern synonym"+                           <+> quotes (ppr name) <+> text "used in an expression"++{-+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 (noLocA 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]++                   -- Warning for implicit lift (#17804)+        ; whenWOptM Opt_WarnImplicitLift $+            addWarnTc (Reason Opt_WarnImplicitLift)+                       (text "The variable" <+> quotes (ppr id) <+>+                        text "is implicitly lifted in the TH quotation")++                   -- Update the pending splices+        ; ps <- readMutVar ps_var+        ; let pending_splice = PendingTcSplice id_name+                                 (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA 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 GhcRn -> [HsExprArg 'TcpRn]+              -> 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+-- But not in generated code, where we don't want+-- to mention internal (rebindable syntax) function names+addFunResCtxt fun args fun_res_ty env_ty thing_inside+  = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) thing_inside+      -- 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 }++    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 Ticket #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+*                                                                      *+********************************************************************* -}++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))

GHC/Tc/Gen/HsType.hs view

@@ -1,3916 +1,4209 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}--{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Typechecking user-specified @MonoTypes@-module GHC.Tc.Gen.HsType (-        -- Type signatures-        kcClassSigType, tcClassSigType,-        tcHsSigType, tcHsSigWcType,-        tcHsPartialSigType,-        tcStandaloneKindSig,-        funsSigCtxt, addSigCtxt, pprSigCtxt,--        tcHsClsInstType,-        tcHsDeriv, tcDerivStrategy,-        tcHsTypeApp,-        UserTypeCtxt(..),-        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,-            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,-        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,-            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,-        ContextKind(..),--        -- Type checking type and class decls, and instances thereof-        bindTyClTyVars, tcFamTyPats,-        etaExpandAlgTyCon, tcbVisibilities,--          -- tyvars-        zonkAndScopedSort,--        -- Kind-checking types-        -- No kind generalisation, no checkValidType-        InitialKindStrategy(..),-        SAKS_or_CUSK(..),-        kcDeclHeader,-        tcNamedWildCardBinders,-        tcHsLiftedType,   tcHsOpenType,-        tcHsLiftedTypeNC, tcHsOpenTypeNC,-        tcInferLHsTypeKind, tcInferLHsType, tcInferLHsTypeUnsaturated,-        tcCheckLHsType,-        tcHsMbContext, tcHsContext, tcLHsPredType,-        failIfEmitsConstraints,-        solveEqualities, -- useful re-export--        kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,--        -- Sort-checking kinds-        tcLHsKindSig, checkDataKindSig, DataSort(..),-        checkClassKindSig,--        -- Multiplicity-        tcMult,--        -- Pattern type signatures-        tcHsPatSigType,--        -- Error messages-        funAppCtxt, addTyConFlavCtxt-   ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Hs-import GHC.Tc.Utils.Monad-import GHC.Tc.Types.Origin-import GHC.Core.Predicate-import GHC.Tc.Types.Constraint-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.Instantiate( tcInstInvisibleTyBinders )-import GHC.Tc.Utils.TcMType-import GHC.Tc.Validity-import GHC.Tc.Utils.Unify-import GHC.IfaceToCore-import GHC.Tc.Solver-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-import GHC.Builtin.Types.Prim-import GHC.Types.Name.Env-import GHC.Types.Name.Reader( lookupLocalRdrOcc )-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Core.TyCon-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.Class-import GHC.Types.Name--- import GHC.Types.Name.Set-import GHC.Types.Var.Env-import GHC.Builtin.Types-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Settings.Constants ( mAX_CTUPLE_SIZE )-import GHC.Utils.Error( MsgDoc )-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Utils.Misc-import GHC.Types.Unique.Supply-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Builtin.Names hiding ( wildCardName )-import GHC.Driver.Session-import qualified GHC.LanguageExtensions as LangExt-import GHC.Parser.Annotation--import GHC.Data.Maybe-import GHC.Data.Bag( unitBag )-import Data.List ( find )-import Control.Monad--{--        -----------------------------                General notes-        ------------------------------Unlike with expressions, type-checking types both does some checking and-desugars at the same time. This is necessary because we often want to perform-equality checks on the types right away, and it would be incredibly painful-to do this on un-desugared types. Luckily, desugared types are close enough-to HsTypes to make the error messages sane.--During type-checking, we perform as little validity checking as possible.-Generally, after type-checking, you will want to do validity checking, say-with GHC.Tc.Validity.checkValidType.--Validity checking-~~~~~~~~~~~~~~~~~-Some of the validity check could in principle be done by the kind checker,-but not all:--- During desugaring, we normalise by expanding type synonyms.  Only-  after this step can we check things like type-synonym saturation-  e.g.  type T k = k Int-        type S a = a-  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);-  and then S is saturated.  This is a GHC extension.--- Similarly, also a GHC extension, we look through synonyms before complaining-  about the form of a class or instance declaration--- Ambiguity checks involve functional dependencies--Also, in a mutually recursive group of types, we can't look at the TyCon until we've-finished building the loop.  So to keep things simple, we postpone most validity-checking until step (3).--%************************************************************************-%*                                                                      *-              Check types AND do validity checking-*                                                                      *-************************************************************************--Note [Keeping implicitly quantified variables in order]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When the user implicitly quantifies over variables (say, in a type-signature), we need to come up with some ordering on these variables.-This is done by bumping the TcLevel, bringing the tyvars into scope,-and then type-checking the thing_inside. The constraints are all-wrapped in an implication, which is then solved. Finally, we can-zonk all the binders and then order them with scopedSort.--It's critical to solve before zonking and ordering in order to uncover-any unifications. You might worry that this eager solving could cause-trouble elsewhere. I don't think it will. Because it will solve only-in an increased TcLevel, it can't unify anything that was mentioned-elsewhere. Additionally, we require that the order of implicitly-quantified variables is manifest by the scope of these variables, so-we're not going to learn more information later that will help order-these variables.--Note [Recipe for checking a signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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.--There may be some surprises in here:--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.--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:--  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--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.--After promoting/generalizing, we need to zonk again because both-promoting and generalizing fill in metavariables.--Note [Promotion in signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If an unsolved metavariable in a signature is not generalized-(because we're not generalizing the construct -- e.g., pattern-sig -- or because the metavars are constrained -- see kindGeneralizeSome)-we need to promote to maintain (WantedTvInv) of Note [TcLevel and untouchable type variables]-in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing-and the reinstantiating with a fresh metavariable at the current level.-So in some sense, we generalize *all* variables, but then re-instantiate-some of them.--Here is an example of why we must promote:-  foo (x :: forall a. a -> Proxy b) = ...--In the pattern signature, `b` is unbound, and will thus be brought into-scope. We do not know its kind: it will be assigned kappa[2]. Note that-kappa is at TcLevel 2, because it is invented under a forall. (A priori,-the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel-than the surrounding context.) This kappa cannot be solved for while checking-the pattern signature (which is not kind-generalized). When we are checking-the *body* of foo, though, we need to unify the type of x with the argument-type of bar. At this point, the ambient TcLevel is 1, and spotting a-matavariable with level 2 would violate the (WantedTvInv) invariant of-Note [TcLevel and untouchable type variables]. So, instead of kind-generalizing,-we promote the metavariable to level 1. This is all done in kindGeneralizeNone.---}--funsSigCtxt :: [Located Name] -> UserTypeCtxt--- Returns FunSigCtxt, with no redundant-context-reporting,--- form a list of located names-funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False-funsSigCtxt []              = panic "funSigCtxt"--addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a-addSigCtxt ctxt hs_ty thing_inside-  = setSrcSpan (getLoc hs_ty) $-    addErrCtxt (pprSigCtxt ctxt hs_ty) $-    thing_inside--pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc--- (pprSigCtxt ctxt <extra> <type>)--- prints    In the type signature for 'f':---              f :: <type>--- The <extra> is either empty or "the ambiguity check for"-pprSigCtxt ctxt hs_ty-  | Just n <- isSigMaybe ctxt-  = hang (text "In the type signature:")-       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)--  | otherwise-  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)-       2 (ppr hs_ty)--tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type--- This one is used when we have a LHsSigWcType, but in--- a place where wildcards aren't allowed. The renamer has--- already checked this, so we can simply ignore it.-tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)--kcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM ()--- This is a special form of tcClassSigType that is used during the--- kind-checking phase to infer the kind of class variables. Cf. tc_hs_sig_type.--- Importantly, this does *not* kind-generalize. Consider---   class SC f where---     meth :: forall a (x :: f a). Proxy x -> ()--- When instantiating Proxy with kappa, we must unify kappa := f a. But we're--- still working out the kind of f, and thus f a will have a coercion in it.--- Coercions block unification (Note [Equalities with incompatible kinds] in--- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll--- end up promoting kappa to the top level (because kind-generalization is--- normally done right before adding a binding to the context), and then we--- can't set kappa := f a, because a is local.-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      $-              tcLHsType hs_ty liftedTypeKind--       ; emitResidualTvConstraint skol_info spec_tkvs tc_lvl wanted }--tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type--- Does not do validity checking-tcClassSigType skol_info names sig_ty-  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $-    do { (implic, ty) <- tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)-       ; emitImplication implic-       ; return ty }-       -- Do not zonk-to-Type, nor perform a validity check-       -- We are in a knot with the class and associated types-       -- Zonking and validity checking is done by tcClassDecl-       ---       -- No need to fail here if the type has an error:-       --   If we're in the kind-checking phase, the solveEqualities-       --     in kcTyClGroup catches the error-       --   If we're in the type-checking phase, the solveEqualities-       --     in tcClassDecl1 gets it-       -- Failing fast here degrades the error message in, e.g., tcfail135:-       --   class Foo f where-       --     baa :: f a -> f-       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.-       -- It should be that f has kind `k2 -> *`, but we never get a chance-       -- to run the solver where the kind of f is touchable. This is-       -- painfully delicate.--tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type--- Does validity checking--- See Note [Recipe for checking a signature]-tcHsSigType ctxt sig_ty-  = addSigCtxt ctxt (hsSigType sig_ty) $-    do { traceTc "tcHsSigType {" (ppr sig_ty)--          -- Generalise here: see Note [Kind generalisation]-       ; (implic, ty) <- tc_hs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)--       -- Spit out the implication (and perhaps fail fast)-       -- See Note [Failure in local type signatures] in GHC.Tc.Solver-       ; emitFlatConstraints (mkImplicWC (unitBag implic))--       ; ty <- zonkTcType ty-       ; checkValidType ctxt ty-       ; traceTc "end tcHsSigType }" (ppr ty)-       ; return ty }-  where-    skol_info = SigTypeSkol ctxt--tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn-               -> ContextKind -> TcM (Implication, TcType)--- Kind-checks/desugars an 'LHsSigType',---   solve equalities,---   and then kind-generalizes.--- This will never emit constraints, as it uses solveEqualities internally.--- No validity checking or zonking--- 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" $-                 -- 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)-       -- 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--       -- Build an implication for any as-yet-unsolved kind equalities-       -- See Note [Skolem escape in type signatures]-       ; implic <- buildTvImplication skol_info (kvs ++ spec_tkvs) tc_lvl wanted--       ; return (implic, mkInfForAllTys kvs ty1) }--{- Note [Skolem escape in type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcHsSigType is tricky.  Consider (T11142)-  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()-This is ill-kinded becuase of a nested skolem-escape.--That will show up as an un-solvable constraint in the implication-returned by buildTvImplication in tc_hs_sig_type.  See Note [Skolem-escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable-(the unification variable for b's kind is untouchable).--Then, in GHC.Tc.Solver.emitFlatConstraints (called from tcHsSigType)-we'll try to float out the constraint, be unable to do so, and fail.-See GHC.Tc.Solver Note [Failure in local type signatures] for more-detail on this.--The separation between tcHsSigType and tc_hs_sig_type is because-tcClassSigType wants to use the latter, but *not* fail fast, because-there are skolems from the class decl which are in scope; but it's fine-not to because tcClassDecl1 has a solveEqualities wrapped around all-the tcClassSigType calls.--That's why tcHsSigType does emitFlatConstraints (which fails fast) but-tcClassSigType just does emitImplication (which does not).  Ugh.--c.f. see also Note [Skolem escape and forall-types]. The difference-is that we don't need to simplify at a forall type, only at the-top level of a signature.--}---- Does validity checking and zonking.-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)-tcStandaloneKindSig (L _ kisig) = case kisig of-  StandaloneKindSig _ (L _ name) ksig ->-    let ctxt = StandaloneKindSigCtxt name in-    addSigCtxt ctxt (hsSigType ksig) $-    do { let mode = mkMode KindLevel-       ; kind <- tc_top_lhs_type mode ksig (expectedKindInCtxt ctxt)-       ; checkValidType ctxt kind-       ; return (name, kind) }---tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type-tcTopLHsType hs_ty ctxt_kind-  = tc_top_lhs_type (mkMode TypeLevel) hs_ty ctxt_kind--tc_top_lhs_type :: TcTyMode -> LHsSigType GhcRn -> ContextKind -> TcM Type--- tcTopLHsType is used for kind-checking top-level HsType where---   we want to fully solve /all/ equalities, and report errors--- Does zonking, but not validity checking because it's used---   for things (like deriving and instances) that aren't---   ordinary types--- Used for both types and kinds-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 $-                 do { kind <- newExpectedKind ctxt_kind-                    ; tc_lhs_type mode hs_ty kind }--       ; spec_tkvs <- zonkAndScopedSort spec_tkvs-       ; let ty1 = mkSpecForAllTys spec_tkvs ty-       ; kvs <- kindGeneralizeAll ty1  -- "All" because it's a top-level type-       ; final_ty <- zonkTcTypeToType (mkInfForAllTys kvs ty1)-       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])-       ; return final_ty}--------------------tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])--- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause--- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments--- E.g.    class C (a::*) (b::k->k)---         data T a b = ... deriving( C Int )---    returns ([k], C, [k, Int], [k->k])--- Return values are fully zonked-tcHsDeriv hs_ty-  = do { ty <- checkNoErrs $  -- Avoid redundant error report-                              -- with "illegal deriving", below-               tcTopLHsType hs_ty AnyKind-       ; let (tvs, pred)    = splitForAllTys ty-             (kind_args, _) = splitFunTys (tcTypeKind pred)-       ; case getClassPredTys_maybe pred of-           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)-           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }---- | Typecheck a deriving strategy. For most deriving strategies, this is a--- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.-tcDerivStrategy ::-     Maybe (LDerivStrategy GhcRn)-     -- ^ The deriving strategy-  -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])-     -- ^ The typechecked deriving strategy and the tyvars that it binds-     -- (if using 'ViaStrategy').-tcDerivStrategy mb_lds-  = case mb_lds of-      Nothing -> boring_case Nothing-      Just (L loc ds) ->-        setSrcSpan loc $ do-          (ds', tvs) <- tc_deriv_strategy ds-          pure (Just (L loc ds'), tvs)-  where-    tc_deriv_strategy :: DerivStrategy GhcRn-                      -> TcM (DerivStrategy GhcTc, [TyVar])-    tc_deriv_strategy StockStrategy    = boring_case StockStrategy-    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy-    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy-    tc_deriv_strategy (ViaStrategy ty) = do-      ty' <- checkNoErrs $ tcTopLHsType ty AnyKind-      let (via_tvs, via_pred) = splitForAllTys ty'-      pure (ViaStrategy via_pred, via_tvs)--    boring_case :: ds -> TcM (ds, [TyVar])-    boring_case ds = pure (ds, [])--tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt-                -> LHsSigType GhcRn-                -> TcM Type--- Like tcHsSigType, but for a class instance declaration-tcHsClsInstType user_ctxt hs_inst_ty-  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $-    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so-         -- these constraints will never be solved later. And failing-         -- eagerly avoids follow-on errors when checkValidInstance-         -- sees an unsolved coercion hole-         inst_ty <- checkNoErrs $-                    tcTopLHsType hs_inst_ty (TheKind constraintKind)-       ; checkValidInstance user_ctxt hs_inst_ty inst_ty-       ; return inst_ty }--------------------------------------------------- | Type-check a visible type application-tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type--- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType-tcHsTypeApp wc_ty kind-  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty-  = do { mode <- mkHoleMode TypeLevel HM_VTA-                 -- HM_VTA: See Note [Wildcards in visible type application]-       ; ty <- addTypeCtxt hs_ty                  $-               solveLocalEqualities "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 $ \ _ ->-               tc_lhs_type mode hs_ty kind--       -- We do not kind-generalize type applications: we just-       -- instantiate with exactly what the user says.-       -- See Note [No generalization in type application]-       -- We still must call kindGeneralizeNone, though, according-       -- to Note [Recipe for checking a signature]-       ; kindGeneralizeNone ty-       ; ty <- zonkTcType ty-       ; checkValidType TypeAppCtxt ty-       ; return ty }--{- Note [Wildcards in visible type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so-any unnamed wildcards stay unchanged in hswc_body.  When called in-tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole-on these anonymous wildcards. However, this would trigger-error/warning when an anonymous wildcard is passed in as a visible type-argument, which we do not want because users should be able to write-@_ to skip a instantiating a type variable variable without fuss. The-solution is to switch the PartialTypeSignatures flags here to let the-typechecker know that it's checking a '@_' and do not emit hole-constraints on it.  See related Note [Wildcards in visible kind-application] and Note [The wildcard story for types] in GHC.Hs.Type--Ugh!--Note [No generalization in type application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not kind-generalize type applications. Imagine--  id @(Proxy Nothing)--If we kind-generalized, we would get--  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))--which is very sneakily impredicative instantiation.--There is also the possibility of mentioning a wildcard-(`id @(Proxy _)`), which definitely should not be kind-generalized.---}--tcFamTyPats :: TyCon-            -> HsTyPats GhcRn                -- Patterns-            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)--- Check the LHS of a type/data family instance--- e.g.   type instance F ty1 .. tyn = ...--- Used for both type and data families-tcFamTyPats fam_tc hs_pats-  = do { traceTc "tcFamTyPats {" $-         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]--       ; mode <- mkHoleMode TypeLevel HM_FamPat-                 -- HM_FamPat: See Note [Wildcards in family instances] in-                 -- GHC.Rename.Module-       ; let fun_ty = mkTyConApp fam_tc []-       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats--       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]-       ; res_kind <- zonkTcType res_kind--       ; traceTc "End tcFamTyPats }" $-         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]--       ; return (fam_app, res_kind) }-  where-    fam_name  = tyConName fam_tc-    fam_arity = tyConArity fam_tc-    lhs_fun   = noLoc (HsTyVar noExtField NotPromoted (noLoc fam_name))--{- Note [tcFamTyPats: zonking the result kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#19250)-    F :: forall k. k -> k-    type instance F (x :: Constraint) = ()--The tricky point is this:-  is that () an empty type tuple (() :: Type), or-  an empty constraint tuple (() :: Constraint)?-We work this out in a hacky way, by looking at the expected kind:-see Note [Inferring tuple kinds].--In this case, we kind-check the RHS using the kind gotten from the LHS:-see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.--But we want the kind from the LHS to be /zonked/, so that when-kind-checking the RHS (tcCheckLHsType) we can "see" what we learned-from kind-checking the LHS (tcFamTyPats).  In our example above, the-type of the LHS is just `kappa` (by instantiating the forall k), but-then we learn (from x::Constraint) that kappa ~ Constraint.  We want-that info when kind-checking the RHS.--Easy solution: just zonk that return kind.  Of course this won't help-if there is lots of type-family reduction to do, but it works fine in-common cases.--}---{--************************************************************************-*                                                                      *-            The main kind checker: no validity checks here-*                                                                      *-************************************************************************--}------------------------------tcHsOpenType, tcHsLiftedType,-  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType--- Used for type signatures--- Do not do validity checking-tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty-tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty--tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }-tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind---- Like tcHsType, but takes an expected kind-tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType-tcCheckLHsType hs_ty exp_kind-  = addTypeCtxt hs_ty $-    do { ek <- newExpectedKind exp_kind-       ; tcLHsType hs_ty ek }--tcInferLHsType :: LHsType GhcRn -> TcM TcType-tcInferLHsType hs_ty-  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty-       ; return ty }--tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)--- Called from outside: set the context--- Eagerly instantiate any trailing invisible binders-tcInferLHsTypeKind lhs_ty@(L loc hs_ty)-  = addTypeCtxt lhs_ty $-    setSrcSpan loc     $  -- Cover the tcInstInvisibleTyBinders-    do { (res_ty, res_kind) <- tc_infer_hs_type (mkMode TypeLevel) hs_ty-       ; tcInstInvisibleTyBinders res_ty res_kind }-  -- See Note [Do not always instantiate eagerly in types]---- Used to check the argument of GHCi :kind--- Allow and report wildcards, e.g. :kind T _--- Do not saturate family applications: see Note [Dealing with :kind]--- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]-tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)-tcInferLHsTypeUnsaturated hs_ty-  = addTypeCtxt hs_ty $-    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes-       ; case splitHsAppTys (unLoc hs_ty) of-           Just (hs_fun_ty, hs_args)-              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }-                      -- Notice the 'nosat'; do not instantiate trailing-                      -- invisible arguments of a type family.-                      -- See Note [Dealing with :kind]-           Nothing -> tc_infer_lhs_type mode hs_ty }--{- Note [Dealing with :kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this GHCi command-  ghci> type family F :: Either j k-  ghci> :kind F-  F :: forall {j,k}. Either j k--We will only get the 'forall' if we /refrain/ from saturating those-invisible binders. But generally we /do/ saturate those invisible-binders (see tcInferTyApps), and we want to do so for nested application-even in GHCi.  Consider for example (#16287)-  ghci> type family F :: k-  ghci> data T :: (forall k. k) -> Type-  ghci> :kind T F-We want to reject this. It's just at the very top level that we want-to switch off saturation.--So tcInferLHsTypeUnsaturated does a little special case for top level-applications.  Actually the common case is a bare variable, as above.--Note [Do not always instantiate eagerly in types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Terms are eagerly instantiated. This means that if you say--  x = id--then `id` gets instantiated to have type alpha -> alpha. The variable-alpha is then unconstrained and regeneralized. But we cannot do this-in types, as we have no type-level lambda. So, when we are sure-that we will not want to regeneralize later -- because we are done-checking a type, for example -- we can instantiate. But we do not-instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,-which is used by :kind in GHCi.--************************************************************************-*                                                                      *-      Type-checking modes-*                                                                      *-************************************************************************--The kind-checker is parameterised by a TcTyMode, which contains some-information about where we're checking a type.--The renamer issues errors about what it can. All errors issued here must-concern things that the renamer can't handle.---}--tcMult :: HsArrow GhcRn -> TcM Mult-tcMult hc = tc_mult (mkMode TypeLevel) hc---- | Info about the context in which we're checking a type. Currently,--- differentiates only between types and kinds, but this will likely--- grow, at least to include the distinction between patterns and--- not-patterns.------ To find out where the mode is used, search for 'mode_tyki'------ This data type is purely local, not exported from this module-data TcTyMode-  = TcTyMode { mode_tyki :: TypeOrKind--             -- See Note [Levels for wildcards]-             -- Nothing <=> no wildcards expected-             , mode_holes :: Maybe (TcLevel, HoleMode)-    }---- HoleMode says how to treat the occurrences--- of anonymous wildcards; see tcAnonWildCardOcc-data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int-              | HM_FamPat   -- Family instances: F _ Int = Bool-              | HM_VTA      -- Visible type and kind application:-                            --   f @(Maybe _)-                            --   Maybe @(_ -> _)--mkMode :: TypeOrKind -> TcTyMode-mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }--mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode-mkHoleMode tyki hm-  = do { lvl <- getTcLevel-       ; return (TcTyMode { mode_tyki  = tyki-                          , mode_holes = Just (lvl,hm) }) }--kindLevel :: TcTyMode -> TcTyMode-kindLevel mode = mode { mode_tyki = KindLevel }--instance Outputable HoleMode where-  ppr HM_Sig     = text "HM_Sig"-  ppr HM_FamPat  = text "HM_FamPat"-  ppr HM_VTA     = text "HM_VTA"--instance Outputable TcTyMode where-  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })-    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma-                                      , ppr hm ])--{--Note [Bidirectional type checking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In expressions, whenever we see a polymorphic identifier, say `id`, we are-free to instantiate it with metavariables, knowing that we can always-re-generalize with type-lambdas when necessary. For example:--  rank2 :: (forall a. a -> a) -> ()-  x = rank2 id--When checking the body of `x`, we can instantiate `id` with a metavariable.-Then, when we're checking the application of `rank2`, we notice that we really-need a polymorphic `id`, and then re-generalize over the unconstrained-metavariable.--In types, however, we're not so lucky, because *we cannot re-generalize*!-There is no lambda. So, we must be careful only to instantiate at the last-possible moment, when we're sure we're never going to want the lost polymorphism-again. This is done in calls to tcInstInvisibleTyBinders.--To implement this behavior, we use bidirectional type checking, where we-explicitly think about whether we know the kind of the type we're checking-or not. Note that there is a difference between not knowing a kind and-knowing a metavariable kind: the metavariables are TauTvs, and cannot become-forall-quantified kinds. Previously (before dependent types), there were-no higher-rank kinds, and so we could instantiate early and be sure that-no types would have polymorphic kinds, and so we could always assume that-the kind of a type was a fresh metavariable. Not so anymore, thus the-need for two algorithms.--For HsType forms that can never be kind-polymorphic, we implement only the-"down" direction, where we safely assume a metavariable kind. For HsType forms-that *can* be kind-polymorphic, we implement just the "up" (functions with-"infer" in their name) version, as we gain nothing by also implementing the-"down" version.--Note [Future-proofing the type checker]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As discussed in Note [Bidirectional type checking], each HsType form is-handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions-are mutually recursive, so that either one can work for any type former.-But, we want to make sure that our pattern-matches are complete. So,-we have a bunch of repetitive code just so that we get warnings if we're-missing any patterns.---}----------------------------------------------- | Check and desugar a type, returning the core type and its--- possibly-polymorphic kind. Much like 'tcInferRho' at the expression--- level.-tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)-tc_infer_lhs_type mode (L span ty)-  = setSrcSpan span $-    tc_infer_hs_type mode ty-------------------------------- | Call 'tc_infer_hs_type' and check its result against an expected kind.-tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType-tc_infer_hs_type_ek mode hs_ty ek-  = do { (ty, k) <- tc_infer_hs_type mode hs_ty-       ; checkExpectedKind hs_ty ty k ek }-------------------------------- | Infer the kind of a type and desugar. This is the "up" type-checker,--- as described in Note [Bidirectional type checking]-tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)--tc_infer_hs_type mode (HsParTy _ t)-  = tc_infer_lhs_type mode t--tc_infer_hs_type mode ty-  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty-  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty-       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }--tc_infer_hs_type mode (HsKindSig _ ty sig)-  = do { let mode' = mode { mode_tyki = KindLevel }-       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig-                 -- We must typecheck the kind signature, and solve all-                 -- its equalities etc; from this point on we may do-                 -- things like instantiate its foralls, so it needs-                 -- to be fully determined (#14904)-       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')-       ; ty' <- tc_lhs_type mode ty sig'-       ; return (ty', sig') }---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate--- the splice location to the typechecker. Here we skip over it in order to have--- the same kind inferred for a given expression whether it was produced from--- splices or not.------ See Note [Delaying modFinalizers in untyped splices].-tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))-  = tc_infer_hs_type mode ty--tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty---- See Note [Typechecking NHsCoreTys]-tc_infer_hs_type _ (XHsType (NHsCoreTy ty))-  = do env <- getLclEnv-       -- Raw uniques since we go from NameEnv to TvSubstEnv.-       let subst_prs :: [(Unique, TcTyVar)]-           subst_prs = [ (getUnique nm, tv)-                       | ATyVar nm tv <- nameEnvElts (tcl_env env) ]-           subst = mkTvSubst-                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)-                     (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)-           ty' = substTy subst ty-       return (ty', tcTypeKind ty')--tc_infer_hs_type _ (HsExplicitListTy _ _ tys)-  | null tys  -- this is so that we can use visible kind application with '[]-              -- e.g ... '[] @Bool-  = return (mkTyConTy promotedNilDataCon,-            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)--tc_infer_hs_type mode other_ty-  = do { kv <- newMetaKindVar-       ; ty' <- tc_hs_type mode other_ty kv-       ; return (ty', kv) }--{--Note [Typechecking NHsCoreTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NHsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.-As such, there's not much to be done in order to typecheck an NHsCoreTy,-since it's already been typechecked to some extent. There is one thing that-we must do, however: we must substitute the type variables from the tcl_env.-To see why, consider GeneralizedNewtypeDeriving, which is one of the main-clients of NHsCoreTy (example adapted from #14579):--  newtype T a = MkT a deriving newtype Eq--This will produce an InstInfo GhcPs that looks roughly like this:--  instance forall a_1. Eq a_1 => Eq (T a_1) where-    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an NHsCoreTy-                  @(T a_1 -> T a_1 -> Bool) -- So is this-                  (==)--This is then fed into the renamer. Since all of the type variables in this-InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically-identical. Things get more interesting when the InstInfo is fed into the-typechecker, however. GHC will first generate fresh skolems to instantiate-the instance-bound type variables with. In the example above, we might generate-the skolem a_2 and use that to instantiate a_1, which extends the local type-environment (tcl_env) with [a_1 :-> a_2]. This gives us:--  instance forall a_2. Eq a_2 => Eq (T a_2) where ...--To ensure that the body of this instance is well scoped, every occurrence of-the `a` type variable should refer to a_2, the new skolem. However, the-NHsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the-substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this-substitution to each NHsCoreTy and all is well:--  instance forall a_2. Eq a_2 => Eq (T a_2) where-    (==) = coerce @(  a_2 ->   a_2 -> Bool)-                  @(T a_2 -> T a_2 -> Bool)-                  (==)--}---------------------------------------------tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType-tcLHsType hs_ty exp_kind-  = tc_lhs_type (mkMode TypeLevel) hs_ty exp_kind--tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType-tc_lhs_type mode (L span ty) exp_kind-  = setSrcSpan span $-    tc_hs_type mode ty exp_kind--tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType--- See Note [Bidirectional type checking]--tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind-tc_hs_type _ ty@(HsBangTy _ bang _) _-    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),-    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of-    -- bangs are invalid, so fail. (#7210, #14761)-    = do { let bangError err = failWith $-                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$-                 text err <+> text "annotation cannot appear nested inside a type"-         ; case bang of-             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"-             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"-             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"-             HsSrcBang _ _ _                   -> bangError "strictness" }-tc_hs_type _ ty@(HsRecTy {})      _-      -- Record types (which only show up temporarily in constructor-      -- signatures) should have been removed by now-    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)---- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.--- Here we get rid of it and add the finalizers to the global environment--- while capturing the local environment.------ See Note [Delaying modFinalizers in untyped splices].-tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))-           exp_kind-  = do addModFinalizersWithLclEnv mod_finalizers-       tc_hs_type mode ty exp_kind---- This should never happen; type splices are expanded by the renamer-tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind-  = failWithTc (text "Unexpected type splice:" <+> ppr ty)------------ Functions and applications-tc_hs_type mode ty@(HsFunTy _ mult ty1 ty2) exp_kind-  | mode_tyki mode == KindLevel && not (isUnrestricted mult)-    = failWithTc (text "Linear arrows disallowed in kinds:" <+> ppr ty)-  | otherwise-    = tc_fun_type mode mult ty1 ty2 exp_kind--tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind-  | op `hasKey` funTyConKey-  = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind----------- 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 $-                 -- 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-               tc_lhs_type mode ty exp_kind-                 -- Why exp_kind?  See Note [Body kind of HsForAllTy]--       -- Do not kind-generalise here!  See Note [Kind generalisation]--       ; let skol_info = ForAllSkol (ppr forall) $ sep $ case tele of-                           HsForAllVis { hsf_vis_bndrs = hs_tvs } ->-                             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'-       ; 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--tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind-  | null (unLoc ctxt)-  = tc_lhs_type mode rn_ty exp_kind--  -- See Note [Body kind of a HsQualTy]-  | tcIsConstraintKind exp_kind-  = do { ctxt' <- tc_hs_context mode ctxt-       ; ty'   <- tc_lhs_type mode rn_ty constraintKind-       ; return (mkPhiTy ctxt' ty') }--  | otherwise-  = do { ctxt' <- tc_hs_context mode ctxt--       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can-                                -- be TYPE r, for any r, hence newOpenTypeKind-       ; ty' <- tc_lhs_type mode rn_ty ek-       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')-                           liftedTypeKind exp_kind }----------- Lists, arrays, and tuples-tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind-  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind-       ; checkWiredInTyCon listTyCon-       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }---- See Note [Distinguishing tuple kinds] in GHC.Hs.Type--- See Note [Inferring tuple kinds]-tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind-     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)-  | Just tup_sort <- tupKindSort_maybe exp_kind-  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>-    tc_tuple rn_ty mode tup_sort hs_tys exp_kind-  | otherwise-  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)-       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys-       ; kinds <- mapM zonkTcType kinds-           -- Infer each arg type separately, because errors can be-           -- confusing if we give them a shared kind.  Eg #7410-           -- (Either Int, Int), we do not want to get an error saying-           -- "the second argument of a tuple should have kind *->*"--       ; let (arg_kind, tup_sort)-               = case [ (k,s) | k <- kinds-                              , Just s <- [tupKindSort_maybe k] ] of-                    ((k,s) : _) -> (k,s)-                    [] -> (liftedTypeKind, BoxedTuple)-         -- In the [] case, it's not clear what the kind is, so guess *--       ; tys' <- sequence [ setSrcSpan loc $-                            checkExpectedKind hs_ty ty kind arg_kind-                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]--       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }---tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind-  = tc_tuple rn_ty mode tup_sort tys exp_kind-  where-    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above-                  HsUnboxedTuple    -> UnboxedTuple-                  HsBoxedTuple      -> BoxedTuple-                  HsConstraintTuple -> ConstraintTuple-                  _                 -> panic "tc_hs_type HsTupleTy"--tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind-  = do { let arity = length hs_tys-       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys-       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds-       ; let arg_reps = map kindRep arg_kinds-             arg_tys  = arg_reps ++ tau_tys-             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys-             sum_kind = unboxedSumKind arg_reps-       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind-       }----------- Promoted lists and tuples-tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind-  = do { tks <- mapM (tc_infer_lhs_type mode) tys-       ; (taus', kind) <- unifyKinds tys tks-       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')-       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }-  where-    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]-    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]--tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind-  -- using newMetaKindVar means that we force instantiations of any polykinded-  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.-  = do { ks   <- replicateM arity newMetaKindVar-       ; taus <- zipWithM (tc_lhs_type mode) tys ks-       ; let kind_con   = tupleTyCon           Boxed arity-             ty_con     = promotedTupleDataCon Boxed arity-             tup_k      = mkTyConApp kind_con ks-       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }-  where-    arity = length tys----------- Constraint types-tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind-  = do { MASSERT( isTypeLevel (mode_tyki mode) )-       ; ty' <- tc_lhs_type mode ty liftedTypeKind-       ; let n' = mkStrLitTy $ hsIPNameFS n-       ; ipClass <- tcLookupClass ipClassName-       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])-                           constraintKind exp_kind }--tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind-  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to-  -- handle it in 'coreView' and 'tcView'.-  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind----------- Literals-tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind-  = do { checkWiredInTyCon typeNatKindCon-       ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }--tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind-  = do { checkWiredInTyCon typeSymbolKindCon-       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }----------- Potentially kind-polymorphic types: call the "up" checker--- See Note [Future-proofing the type checker]-tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek-tc_hs_type mode ty@(HsWildCardTy _)        ek = tcAnonWildCardOcc mode ty ek--{--Note [Variable Specificity and Forall Visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall-binder. Furthermore, each invisible type variable binder also has a-Specificity. Together, these determine the variable binders (ArgFlag) for each-variable in the generated ForAllTy type.--This table summarises this relation:------------------------------------------------------------------------------| User-written type         HsForAllTelescope   Specificity        ArgFlag-|----------------------------------------------------------------------------| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified-| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred-| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required-| f :: forall {a} -> type   HsForAllVis         InferredSpec       /-|   This last form is non-sensical and is thus rejected.-------------------------------------------------------------------------------For more information regarding the interpretation of the resulting ArgFlag, see-Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".--}---------------------------------------------tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult-tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy--------------------------------------------tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind-            -> TcM TcType-tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of-  TypeLevel ->-    do { arg_k <- newOpenTypeKind-       ; res_k <- newOpenTypeKind-       ; ty1' <- tc_lhs_type mode ty1 arg_k-       ; ty2' <- tc_lhs_type mode ty2 res_k-       ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }-  KindLevel ->  -- no representation polymorphism in kinds. yet.-    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind-       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind-       ; mult' <- tc_mult mode mult-       ; checkExpectedKind (HsFunTy noExtField mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')-                           liftedTypeKind exp_kind }--{- Note [Skolem escape and forall-types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Checking telescopes].--Consider-  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()--The Proxy '[a,b] forces a and b to have the same kind.  But a's-kind must be bound outside the 'forall a', and hence escapes.-We discover this by building an implication constraint for-each forall.  So the inner implication constraint will look like-    forall kb (b::kb).  kb ~ ka-where ka is a's kind.  We can't unify these two, /even/ if ka is-unification variable, because it would be untouchable inside-this inner implication.--That's what the pushLevelAndCaptureConstraints, plus subsequent-buildTvImplication/emitImplication is all about, when kind-checking-HsForAllTy.--Note that--* We don't need to /simplify/ the constraints here-  because we aren't generalising. We just capture them.--* We can't use emitResidualTvConstraint, because that has a fast-path-  for empty constraints.  We can't take that fast path here, because-  we must do the bad-telescope check even if there are no inner wanted-  constraints. See Note [Checking telescopes] in-  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.--}--{- *********************************************************************-*                                                                      *-                Tuples-*                                                                      *-********************************************************************* -}------------------------------tupKindSort_maybe :: TcKind -> Maybe TupleSort-tupKindSort_maybe k-  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'-  | Just k'      <- tcView k            = tupKindSort_maybe k'-  | tcIsConstraintKind k = Just ConstraintTuple-  | tcIsLiftedTypeKind k   = Just BoxedTuple-  | otherwise            = Nothing--tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType-tc_tuple rn_ty mode tup_sort tys exp_kind-  = do { arg_kinds <- case tup_sort of-           BoxedTuple      -> return (replicate arity liftedTypeKind)-           UnboxedTuple    -> replicateM arity newOpenTypeKind-           ConstraintTuple -> return (replicate arity constraintKind)-       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds-       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }-  where-    arity   = length tys--finish_tuple :: HsType GhcRn-             -> TupleSort-             -> [TcType]    -- ^ argument types-             -> [TcKind]    -- ^ of these kinds-             -> TcKind      -- ^ expected kind of the whole tuple-             -> TcM TcType-finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do-  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)-  case tup_sort of-    ConstraintTuple-      |  [tau_ty] <- tau_tys-         -- Drop any uses of 1-tuple constraints here.-         -- See Note [Ignore unary constraint tuples]-      -> check_expected_kind tau_ty constraintKind-      |  arity > mAX_CTUPLE_SIZE-      -> failWith (bigConstraintTuple arity)-      |  otherwise-      -> do tycon <- tcLookupTyCon (cTupleTyConName arity)-            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind-    BoxedTuple -> do-      let tycon = tupleTyCon Boxed arity-      checkWiredInTyCon tycon-      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind-    UnboxedTuple ->-      let tycon    = tupleTyCon Unboxed arity-          tau_reps = map kindRep tau_kinds-          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-          arg_tys  = tau_reps ++ tau_tys-          res_kind = unboxedTupleKind tau_reps in-      check_expected_kind (mkTyConApp tycon arg_tys) res_kind-  where-    arity = length tau_tys-    check_expected_kind ty act_kind =-      checkExpectedKind rn_ty ty act_kind exp_kind--bigConstraintTuple :: Arity -> MsgDoc-bigConstraintTuple arity-  = hang (text "Constraint tuple arity too large:" <+> int arity-          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))-       2 (text "Instead, use a nested tuple")--{--Note [Ignore unary constraint tuples]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in-GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,-recall the definition of a unary tuple data type:--  data Solo a = Solo a--Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and-lazy. Therefore, the presence of `Solo` matters semantically. On the other-hand, suppose we had a unary constraint tuple:--  class a => Solo% a--This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is-semantically equivalent to `a`. Therefore, a 1-tuple constraint would have-no user-visible impact, nor would it allow you to express anything that-you couldn't otherwise.--We could simply add Solo% for consistency with tuples (Solo) and unboxed-tuples (Solo#), but that would require even more magic to wire in another-magical class, so we opt not to do so. We must be careful, however, since-one can try to sneak in uses of unary constraint tuples through Template-Haskell, such as in this program (from #17511):--  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]-                       (ConT ''String)))-  -- f :: Solo% (Show Int) => String-  f = "abc"--This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,-and since it is used in a Constraint position, GHC will attempt to treat-it as thought it were a constraint tuple, which can potentially lead to-trouble if one attempts to look up the name of a constraint tuple of arity-1 (as it won't exist). To avoid this trouble, we simply take any unary-constraint tuples discovered when typechecking and drop them—i.e., treat-"Solo% a" as though the user had written "a". This is always safe to do-since the two constraints should be semantically equivalent.--}--{- *********************************************************************-*                                                                      *-                Type applications-*                                                                      *-********************************************************************* -}--splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])-splitHsAppTys hs_ty-  | is_app hs_ty = Just (go (noLoc hs_ty) [])-  | otherwise    = Nothing-  where-    is_app :: HsType GhcRn -> Bool-    is_app (HsAppKindTy {})        = True-    is_app (HsAppTy {})            = True-    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)-      -- I'm not sure why this funTyConKey test is necessary-      -- Can it even happen?  Perhaps for   t1 `(->)` t2-      -- but then maybe it's ok to treat that like a normal-      -- application rather than using the special rule for HsFunTy-    is_app (HsTyVar {})            = True-    is_app (HsParTy _ (L _ ty))    = is_app ty-    is_app _                       = False--    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)-    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)-    go (L sp (HsParTy _ f))        as = go f (HsArgPar sp : as)-    go (L _  (HsOpTy _ l op@(L sp _) r)) as-      = ( L sp (HsTyVar noExtField NotPromoted op)-        , HsValArg l : HsValArg r : as )-    go f as = (f, as)------------------------------tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)--- Version of tc_infer_lhs_type specialised for the head of an--- application. In particular, for a HsTyVar (which includes type--- constructors, it does not zoom off into tcInferTyApps and family--- saturation-tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv)))-  = tcTyVar mode tv-tcInferTyAppHead mode ty-  = tc_infer_lhs_type mode ty-------------------------------- | Apply a type of a given kind to a list of arguments. This instantiates--- invisible parameters as necessary. Always consumes all the arguments,--- using matchExpectedFunKind as necessary.--- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.---- These kinds should be used to instantiate invisible kind variables;--- they come from an enclosing class for an associated type/data family.------ tcInferTyApps also arranges to saturate any trailing invisible arguments---   of a type-family application, which is usually the right thing to do--- tcInferTyApps_nosat does not do this saturation; it is used only---   by ":kind" in GHCi-tcInferTyApps, tcInferTyApps_nosat-    :: TcTyMode-    -> LHsType GhcRn        -- ^ Function (for printing only)-    -> TcType               -- ^ Function-    -> [LHsTypeArg GhcRn]   -- ^ Args-    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)-tcInferTyApps mode hs_ty fun hs_args-  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args-       ; saturateFamApp f_args res_k }--tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args-  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)-       ; (f_args, res_k) <- go_init 1 fun orig_hs_args-       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)-       ; return (f_args, res_k) }-  where--    -- go_init just initialises the auxiliary-    -- arguments of the 'go' loop-    go_init n fun all_args-      = go n fun empty_subst fun_ki all_args-      where-        fun_ki = tcTypeKind fun-           -- We do (tcTypeKind fun) here, even though the caller-           -- knows the function kind, to absolutely guarantee-           -- INVARIANT for 'go'-           -- Note that in a typical application (F t1 t2 t3),-           -- the 'fun' is just a TyCon, so tcTypeKind is fast--        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $-                      tyCoVarsOfType fun_ki--    go :: Int             -- The # of the next argument-       -> TcType          -- Function applied to some args-       -> TCvSubst        -- Applies to function kind-       -> TcKind          -- Function kind-       -> [LHsTypeArg GhcRn]    -- Un-type-checked args-       -> TcM (TcType, TcKind)  -- Result type and its kind-    -- INVARIANT: in any call (go n fun subst fun_ki args)-    --               tcTypeKind fun  =  subst(fun_ki)-    -- So the 'subst' and 'fun_ki' arguments are simply-    -- there to avoid repeatedly calling tcTypeKind.-    ---    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant-    -- it's important that if fun_ki has a forall, then so does-    -- (tcTypeKind fun), because the next thing we are going to do-    -- is apply 'fun' to an argument type.--    -- Dispatch on all_args first, for performance reasons-    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of--      ---------------- No user-written args left. We're done!-      ([], _) -> return (fun, substTy subst fun_ki)--      ---------------- HsArgPar: We don't care about parens here-      (HsArgPar _ : args, _) -> go n fun subst fun_ki args--      ---------------- HsTypeArg: a kind application (fun @ki)-      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->-        case ki_binder of--        -- FunTy with PredTy on LHS, or ForAllTy with Inferred-        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki-        Anon InvisArg _         -> instantiate ki_binder inner_ki--        Named (Bndr _ Specified) ->  -- Visible kind application-          do { traceTc "tcInferTyApps (vis kind app)"-                       (vcat [ ppr ki_binder, ppr hs_ki_arg-                             , ppr (tyBinderType ki_binder)-                             , ppr subst ])--             ; let exp_kind = substTy subst $ tyBinderType ki_binder-             ; arg_mode <- mkHoleMode KindLevel HM_VTA-                   -- HM_VKA: see Note [Wildcards in visible kind application]-             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $-                         tc_lhs_type arg_mode hs_ki_arg exp_kind--             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)-             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg-             ; go (n+1) fun' subst' inner_ki hs_args }--        -- Attempted visible kind application (fun @ki), but fun_ki is-        --   forall k -> blah   or   k1 -> k2-        -- So we need a normal application.  Error.-        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki--      -- No binder; try applying the substitution, or fail if that's not possible-      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $-                                           ty_app_err ki_arg substed_fun_ki--      ---------------- HsValArg: a normal argument (fun ty)-      (HsValArg arg : args, Just (ki_binder, inner_ki))-        -- next binder is invisible; need to instantiate it-        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;-                                        -- or ForAllTy with Inferred or Specified-         -> instantiate ki_binder inner_ki--        -- "normal" case-        | otherwise-         -> do { traceTc "tcInferTyApps (vis normal app)"-                          (vcat [ ppr ki_binder-                                , ppr arg-                                , ppr (tyBinderType ki_binder)-                                , ppr subst ])-                ; let exp_kind = substTy subst $ tyBinderType ki_binder-                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $-                          tc_lhs_type mode arg exp_kind-                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)-                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'-                ; go (n+1) fun' subst' inner_ki args }--          -- no binder; try applying the substitution, or infer another arrow in fun kind-      (HsValArg _ : _, Nothing)-        -> try_again_after_substing_or $-           do { let arrows_needed = n_initial_val_args all_args-              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki--              ; fun' <- zonkTcType (fun `mkTcCastTy` co)-                     -- This zonk is essential, to expose the fruits-                     -- of matchExpectedFunKind to the 'go' loop--              ; traceTc "tcInferTyApps (no binder)" $-                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki-                        , ppr arrows_needed-                        , ppr co-                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]-              ; go_init n fun' all_args }-                -- Use go_init to establish go's INVARIANT-      where-        instantiate ki_binder inner_ki-          = do { traceTc "tcInferTyApps (need to instantiate)"-                         (vcat [ ppr ki_binder, ppr subst])-               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder-               ; go n (mkAppTy fun arg') subst' inner_ki all_args }-                 -- Because tcInvisibleTyBinder instantiate ki_binder,-                 -- the kind of arg' will have the same shape as the kind-                 -- of ki_binder.  So we don't need mkAppTyM here.--        try_again_after_substing_or fallthrough-          | not (isEmptyTCvSubst subst)-          = go n fun zapped_subst substed_fun_ki all_args-          | otherwise-          = fallthrough--        zapped_subst   = zapTCvSubst subst-        substed_fun_ki = substTy subst fun_ki-        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)--    n_initial_val_args :: [HsArg tm ty] -> Arity-    -- Count how many leading HsValArgs we have-    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args-    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args-    n_initial_val_args _                    = 0--    ty_app_err arg ty-      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)-                $$ text "to visible kind argument" <+> quotes (ppr arg)---mkAppTyM :: TCvSubst-         -> TcType -> TyCoBinder    -- fun, plus its top-level binder-         -> TcType                  -- arg-         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)--- Precondition: the application (fun arg) is well-kinded after zonking---               That is, the application makes sense------ Precondition: for (mkAppTyM subst fun bndr arg)---       tcTypeKind fun  =  Pi bndr. body---  That is, fun always has a ForAllTy or FunTy at the top---           and 'bndr' is fun's pi-binder------ Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type---                invariant, then so does the result type (fun arg)------ We do not require that---    tcTypeKind arg = tyVarKind (binderVar bndr)--- This must be true after zonking (precondition 1), but it's not--- required for the (PKTI).-mkAppTyM subst fun ki_binder arg-  | -- See Note [mkAppTyM]: Nasty case 2-    TyConApp tc args <- fun-  , isTypeSynonymTyCon tc-  , args `lengthIs` (tyConArity tc - 1)-  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym-  = do { arg'  <- zonkTcType  arg-       ; args' <- zonkTcTypes args-       ; let subst' = case ki_binder of-                        Anon {}           -> subst-                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'-       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }---mkAppTyM subst fun (Anon {}) arg-   = return (subst, mk_app_ty fun arg)--mkAppTyM subst fun (Named (Bndr tv _)) arg-  = do { arg' <- if isTrickyTvBinder tv-                 then -- See Note [mkAppTyM]: Nasty case 1-                      zonkTcType arg-                 else return     arg-       ; return ( extendTvSubstAndInScope subst tv arg'-                , mk_app_ty fun arg' ) }--mk_app_ty :: TcType -> TcType -> TcType--- This function just adds an ASSERT for mkAppTyM's precondition-mk_app_ty fun arg-  = ASSERT2( isPiTy fun_kind-           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )-    mkAppTy fun arg-  where-    fun_kind = tcTypeKind fun--isTrickyTvBinder :: TcTyVar -> Bool--- NB: isTrickyTvBinder is just an optimisation--- It would be absolutely sound to return True always-isTrickyTvBinder tv = isPiTy (tyVarKind tv)--{- Note [The Purely Kinded Type Invariant (PKTI)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-During type inference, we maintain this invariant-- (PKTI) It is legal to call 'tcTypeKind' on any Type ty,-        on any sub-term of ty, /without/ zonking ty--        Moreover, any such returned kind-        will itself satisfy (PKTI)--By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".-The way in which tcTypeKind can crash is in applications-    (a t1 t2 .. tn)-if 'a' is a type variable whose kind doesn't have enough arrows-or foralls.  (The crash is in piResultTys.)--The loop in tcInferTyApps has to be very careful to maintain the (PKTI).-For example, suppose-    kappa is a unification variable-    We have already unified kappa := Type-      yielding    co :: Refl (Type -> Type)-    a :: kappa-then consider the type-    (a Int)-If we call tcTypeKind on that, we'll crash, because the (un-zonked)-kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.--So the type inference engine is very careful when building applications.-This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),-where (a :: kappa).  Then in tcInferApps we'll run out of binders on-a's kind, so we'll call matchExpectedFunKind, and unify-   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)-At this point we must zonk the function type to expose the arrrow, so-that (a Int) will satisfy (PKTI).--The absence of this caused #14174 and #14520.--The calls to mkAppTyM is the other place we are very careful.--Note [mkAppTyM]-~~~~~~~~~~~~~~~-mkAppTyM is trying to guarantee the Purely Kinded Type Invariant-(PKTI) for its result type (fun arg).  There are two ways it can go wrong:--* Nasty case 1: forall types (polykinds/T14174a)-    T :: forall (p :: *->*). p Int -> p Bool-  Now kind-check (T x), where x::kappa.-  Well, T and x both satisfy the PKTI, but-     T x :: x Int -> x Bool-  and (x Int) does /not/ satisfy the PKTI.--* Nasty case 2: type synonyms-    type S f a = f a-  Even though (S ff aa) would satisfy the (PKTI) if S was a data type-  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)-  if S is a type synonym, because the /expansion/ of (S ff aa) is-  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps-  (ff :: kappa), where 'kappa' has already been unified with (*->*).--  We check for nasty case 2 on the final argument of a type synonym.--Notice that in both cases the trickiness only happens if the-bound variable has a pi-type.  Hence isTrickyTvBinder.--}---saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)--- Precondition for (saturateFamApp ty kind):---     tcTypeKind ty = kind------ If 'ty' is an unsaturated family application with trailing--- invisible arguments, instantiate them.--- See Note [saturateFamApp]--saturateFamApp ty kind-  | Just (tc, args) <- tcSplitTyConApp_maybe ty-  , mustBeSaturated tc-  , let n_to_inst = tyConArity tc - length args-  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind-       ; return (ty `mkTcAppTys` extra_args, ki') }-  | otherwise-  = return (ty, kind)--{- Note [saturateFamApp]-~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   type family F :: Either j k-   type instance F @Type = Right Maybe-   type instance F @Type = Right Either```--Then F :: forall {j,k}. Either j k--The two type instances do a visible kind application that instantiates-'j' but not 'k'.  But we want to end up with instances that look like-  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe--so that F has arity 2.  We must instantiate that trailing invisible-binder. In general, Invisible binders precede Specified and Required,-so this is only going to bite for apparently-nullary families.--Note that-  type family F2 :: forall k. k -> *-is quite different and really does have arity 0.--It's not just type instances where we need to saturate those-unsaturated arguments: see #11246.  Hence doing this in tcInferApps.--}--appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn-appTypeToArg f []                       = f-appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args-appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args-appTypeToArg f (HsTypeArg l arg : args)-  = appTypeToArg (mkHsAppKindTy l f arg) args---{- *********************************************************************-*                                                                      *-                checkExpectedKind-*                                                                      *-********************************************************************* -}---- | This instantiates invisible arguments for the type being checked if it must--- be saturated and is not yet saturated. It then calls and uses the result--- from checkExpectedKindX to build the final type-checkExpectedKind :: HasDebugCallStack-                  => HsType GhcRn       -- ^ type we're checking (for printing)-                  -> TcType             -- ^ type we're checking-                  -> TcKind             -- ^ the known kind of that type-                  -> TcKind             -- ^ the expected kind-                  -> TcM TcType--- Just a convenience wrapper to save calls to 'ppr'-checkExpectedKind hs_ty ty act_kind exp_kind-  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)--       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind--       ; let origin = TypeEqOrigin { uo_actual   = act_kind'-                                   , uo_expected = exp_kind-                                   , uo_thing    = Just (ppr hs_ty)-                                   , uo_visible  = True } -- the hs_ty is visible--       ; traceTc "checkExpectedKindX" $-         vcat [ ppr hs_ty-              , text "act_kind':" <+> ppr act_kind'-              , text "exp_kind:" <+> ppr exp_kind ]--       ; let res_ty = ty `mkTcAppTys` new_args--       ; if act_kind' `tcEqType` exp_kind-         then return res_ty  -- This is very common-         else do { co_k <- uType KindLevel origin act_kind' exp_kind-                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind-                                                     , ppr exp_kind-                                                     , ppr co_k ])-                ; return (res_ty `mkTcCastTy` co_k) } }-    where-      -- We need to make sure that both kinds have the same number of implicit-      -- foralls out front. If the actual kind has more, instantiate accordingly.-      -- Otherwise, just pass the type & kind through: the errors are caught-      -- in unifyType.-      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind-      n_act_invis_bndrs = invisibleTyBndrCount act_kind-      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs------------------------------tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]-tcHsMbContext Nothing    = return []-tcHsMbContext (Just cxt) = tcHsContext cxt--tcHsContext :: LHsContext GhcRn -> TcM [PredType]-tcHsContext cxt = tc_hs_context (mkMode TypeLevel) cxt--tcLHsPredType :: LHsType GhcRn -> TcM PredType-tcLHsPredType pred = tc_lhs_pred (mkMode TypeLevel) pred--tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]-tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)--tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType-tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind------------------------------tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)--- See Note [Type checking recursive type and class declarations]--- in GHC.Tc.TyCl--- This does not instantiate. See Note [Do not always instantiate eagerly in types]-tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon-  = do { traceTc "lk1" (ppr name)-       ; thing <- tcLookup name-       ; case thing of-           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)--           ATcTyCon tc_tc-             -> do { -- See Note [GADT kind self-reference]-                     unless (isTypeLevel (mode_tyki mode))-                            (promotionErr name TyConPE)-                   ; check_tc tc_tc-                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }--           AGlobal (ATyCon tc)-             -> do { check_tc tc-                   ; return (mkTyConTy tc, tyConKind tc) }--           AGlobal (AConLike (RealDataCon dc))-             -> do { data_kinds <- xoptM LangExt.DataKinds-                   ; unless (data_kinds || specialPromotedDc dc) $-                       promotionErr name NoDataKindsDC-                   ; when (isFamInstTyCon (dataConTyCon dc)) $-                       -- see #15245-                       promotionErr name FamDataConPE-                   ; let (_, _, _, theta, _, _) = dataConFullSig dc-                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))-                   ; case dc_theta_illegal_constraint theta of-                       Just pred -> promotionErr name $-                                    ConstrainedDataConPE pred-                       Nothing   -> pure ()-                   ; let tc = promoteDataCon dc-                   ; return (mkTyConApp tc [], tyConKind tc) }--           APromotionErr err -> promotionErr name err--           _  -> wrongThingErr "type" thing name }-  where-    check_tc :: TyCon -> TcM ()-    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds-                     ; unless (isTypeLevel (mode_tyki mode) ||-                               data_kinds ||-                               isKindTyCon tc) $-                       promotionErr name NoDataKindsTC }--    -- We cannot promote a data constructor with a context that contains-    -- constraints other than equalities, so error if we find one.-    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep-    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType-    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:--  import Data.Kind-  data P (x :: k) = Q-  data A :: Type where-    B :: 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.--#11962 proposes checking the head of a data declaration separately from-its constructors. This would allow the example above to pass.--Note [Body kind of a HsForAllTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The body of a forall is usually a type, but in principle-there's no reason to prohibit *unlifted* types.-In fact, GHC can itself construct a function with an-unboxed tuple inside a for-all (via CPR analysis; see-typecheck/should_compile/tc170).--Moreover in instance heads we get forall-types with-kind Constraint.--It's tempting to check that the body kind is either * or #. But this is-wrong. For example:--  class C a b-  newtype N = Mk Foo deriving (C a)--We're doing newtype-deriving for C. But notice how `a` isn't in scope in-the predicate `C a`. So we quantify, yielding `forall a. C a` even though-`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but-convenient. Bottom line: don't check for * or # here.--Note [Body kind of a HsQualTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If ctxt is non-empty, the HsQualTy really is a /function/, so the-kind of the result really is '*', and in that case the kind of the-body-type can be lifted or unlifted.--However, consider-    instance Eq a => Eq [a] where ...-or-    f :: (Eq a => Eq [a]) => blah-Here both body-kind of the HsQualTy is Constraint rather than *.-Rather crudely we tell the difference by looking at exp_kind. It's-very convenient to typecheck instance types like any other HsSigType.--Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's-better to reject in checkValidType.  If we say that the body kind-should be '*' we risk getting TWO error messages, one saying that Eq-[a] doesn't have kind '*', and one saying that we need a Constraint to-the left of the outer (=>).--How do we figure out the right body kind?  Well, it's a bit of a-kludge: I just look at the expected kind.  If it's Constraint, we-must be in this instance situation context. It's a kludge because it-wouldn't work if any unification was involved to compute that result-kind -- but it isn't.  (The true way might be to use the 'mode'-parameter, but that seemed like a sledgehammer to crack a nut.)--Note [Inferring tuple kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,-we try to figure out whether it's a tuple of kind * or Constraint.-  Step 1: look at the expected kind-  Step 2: infer argument kinds--If after Step 2 it's not clear from the arguments that it's-Constraint, then it must be *.  Once having decided that we re-check-the arguments to give good error messages in-  e.g.  (Maybe, Maybe)--Note that we will still fail to infer the correct kind in this case:--  type T a = ((a,a), D a)-  type family D :: Constraint -> Constraint--While kind checking T, we do not yet know the kind of D, so we will default the-kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.--Note [Desugaring types]-~~~~~~~~~~~~~~~~~~~~~~~-The type desugarer is phase 2 of dealing with HsTypes.  Specifically:--  * It transforms from HsType to Type--  * It zonks any kinds.  The returned type should have no mutable kind-    or type variables (hence returning Type not TcType):-      - any unconstrained kind variables are defaulted to (Any *) just-        as in GHC.Tc.Utils.Zonk.-      - there are no mutable type variables because we are-        kind-checking a type-    Reason: the returned type may be put in a TyCon or DataCon where-    it will never subsequently be zonked.--You might worry about nested scopes:-        ..a:kappa in scope..-            let f :: forall b. T '[a,b] -> Int-In this case, f's type could have a mutable kind variable kappa in it;-and we might then default it to (Any *) when dealing with f's type-signature.  But we don't expect this to happen because we can't get a-lexically scoped type variable with a mutable kind variable in it.  A-delicate point, this.  If it becomes an issue we might need to-distinguish top-level from nested uses.--Moreover-  * it cannot fail,-  * it does no unifications-  * it does no validity checking, except for structural matters, such as-        (a) spurious ! annotations.-        (b) a class used as a type--Note [Kind of a type splice]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider these terms, each with TH type splice inside:-     [| e1 :: Maybe $(..blah..) |]-     [| e2 :: $(..blah..) |]-When kind-checking the type signature, we'll kind-check the splice-$(..blah..); we want to give it a kind that can fit in any context,-as if $(..blah..) :: forall k. k.--In the e1 example, the context of the splice fixes kappa to *.  But-in the e2 example, we'll desugar the type, zonking the kind unification-variables as we go.  When we encounter the unconstrained kappa, we-want to default it to '*', not to (Any *).---}--addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a-        -- Wrap a context around only if we want to show that contexts.-        -- Omit invisible ones and ones user's won't grok-addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.-addTypeCtxt (L _ ty) thing-  = addErrCtxt doc thing-  where-    doc = text "In the type" <+> quotes (ppr ty)---{- *********************************************************************-*                                                                      *-                Type-variable binders-*                                                                      *-********************************************************************* -}--tcNamedWildCardBinders :: [Name]-                       -> ([(Name, TcTyVar)] -> TcM a)-                       -> TcM a--- Bring into scope the /named/ wildcard binders.  Remember that--- plain wildcards _ are anonymous and dealt with by HsWildCardTy--- Soe Note [The wildcard story for types] in GHC.Hs.Type-tcNamedWildCardBinders wc_names thing_inside-  = do { wcs <- mapM newNamedWildTyVar wc_names-       ; let wc_prs = wc_names `zip` wcs-       ; tcExtendNameTyVarEnv wc_prs $-         thing_inside wc_prs }--newNamedWildTyVar :: Name -> TcM TcTyVar--- ^ New unification variable '_' for a wildcard-newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type-  = do { kind <- newMetaKindVar-       ; details <- newMetaDetails TauTv-       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]-       ; let tyvar = mkTcTyVar wc_name kind details-       ; traceTc "newWildTyVar" (ppr tyvar)-       ; return tyvar }------------------------------tcAnonWildCardOcc :: TcTyMode -> HsType GhcRn -> Kind -> TcM TcType-tcAnonWildCardOcc (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })-                  ty exp_kind-    -- hole_lvl: see Note [Checking partial type signatures]-    --           esp the bullet on nested forall types-  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl-       ; kv_name    <- newMetaTyVarName (fsLit "k")-       ; wc_details <- newTauTvDetailsAtLevel hole_lvl-       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)-       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details-             wc_kind = mkTyVarTy kv-             wc_tv   = mkTcTyVar wc_name wc_kind wc_details--       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)-       ; when emit_holes $-         emitAnonTypeHole wc_tv-         -- Why the 'when' guard?-         -- See Note [Wildcards in visible kind application]--       -- You might think that this would always just unify-       -- wc_kind with exp_kind, so we could avoid even creating kv-       -- But the level numbers might not allow that unification,-       -- so we have to do it properly (T14140a)-       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }-  where-     -- See Note [Wildcard names]-     wc_nm = case hole_mode of-               HM_Sig     -> "w"-               HM_FamPat  -> "_"-               HM_VTA     -> "w"--     emit_holes = case hole_mode of-                     HM_Sig     -> True-                     HM_FamPat  -> False-                     HM_VTA     -> False--tcAnonWildCardOcc mode ty _--- mode_holes is Nothing.  Should not happen, because renamer--- should already have rejected holes in unexpected places-  = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)--{- Note [Wildcard names]-~~~~~~~~~~~~~~~~~~~~~~~~-So we hackily use the mode_holes flag to control the name used-for wildcards:--* For proper holes (whether in a visible type application (VTA) or no),-  we rename the '_' to 'w'. This is so that we see variables like 'w0'-  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For-  example, we prefer-       Found type wildcard ‘_’ standing for ‘w0’-  over-       Found type wildcard ‘_’ standing for ‘_1’--  Even in the VTA case, where we do not emit an error to be printed, we-  want to do the renaming, as the variables may appear in other,-  non-wildcard error messages.--* However, holes in the left-hand sides of type families ("type-  patterns") stand for type variables which we do not care to name ---  much like the use of an underscore in an ordinary term-level-  pattern. When we spot these, we neither wish to generate an error-  message nor to rename the variable.  We don't rename the variable so-  that we can pretty-print a type family LHS as, e.g.,-    F _ Int _ = ...-  and not-     F w1 Int w2 = ...--  See also Note [Wildcards in family instances] in-  GHC.Rename.Module. The choice of HM_FamPat is made in-  tcFamTyPats. There is also some unsavory magic, relying on that-  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.--Note [Wildcards in visible kind application]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are cases where users might want to pass in a wildcard as a visible kind-argument, for instance:--data T :: forall k1 k2. k1 → k2 → Type where-  MkT :: T a b-x :: T @_ @Nat False n-x = MkT--So we should allow '@_' without emitting any hole constraints, and-regardless of whether PartialTypeSignatures is enabled or not. But how-would the typechecker know which '_' is being used in VKA and which is-not when it calls emitNamedTypeHole in-tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither-rename nor include unnamed wildcards in HsWildCardBndrs, but instead-give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.--And whenever we see a '@', we set mode_holes to HM_VKA, so that-we do not call emitAnonTypeHole in tcAnonWildCardOcc.-See related Note [Wildcards in visible type application] here and-Note [The wildcard story for types] in GHC.Hs.Type--}--{- *********************************************************************-*                                                                      *-             Kind inference for type declarations-*                                                                      *-********************************************************************* -}---- See Note [kcCheckDeclHeader vs kcInferDeclHeader]-data InitialKindStrategy-  = InitialKindCheck SAKS_or_CUSK-  | InitialKindInfer---- Does the declaration have a standalone kind signature (SAKS) or a complete--- user-specified kind (CUSK)?-data SAKS_or_CUSK-  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)-  | CUSK       -- Complete user-specified kind (CUSK)--instance Outputable SAKS_or_CUSK where-  ppr (SAKS k) = text "SAKS" <+> ppr k-  ppr CUSK = text "CUSK"---- See Note [kcCheckDeclHeader vs kcInferDeclHeader]-kcDeclHeader-  :: InitialKindStrategy-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig-kcDeclHeader InitialKindInfer = kcInferDeclHeader--{- Note [kcCheckDeclHeader vs kcInferDeclHeader]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind-of a type constructor.--* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that-  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a-  term-level binding where we have a complete type signature for the function.--* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a-  CUSK. Find a monomorphic kind, with unification variables in it; they will be-  generalised later.  It's very like a term-level binding where we do not have a-  type signature (or, more accurately, where we have a partial type signature),-  so we infer the type and generalise.--}---------------------------------kcCheckDeclHeader-  :: SAKS_or_CUSK-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature-  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon-kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig-kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk--kcCheckDeclHeader_cusk-  :: Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon-kcCheckDeclHeader_cusk name flav-              (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) kc_res_ki-  -- 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 $-              newExpectedKind =<< kc_res_ki--           -- Now, because we're in a CUSK,-           -- we quantify over the mentioned kind vars-       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs-             all_kinds     = res_kind : map tyVarKind spec_req_tkvs--       ; candidates' <- candidateQTyVarsOfKinds all_kinds-             -- 'candidates' are all the variables that we are going to-             -- skolemise and then quantify over.  We do not include spec_req_tvs-             -- because they are /already/ skolems--       ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds))-             candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates }-             inf_candidates = candidates `delCandidates` spec_req_tkvs--       ; inferred <- quantifyTyVars inf_candidates-                     -- NB: 'inferred' comes back sorted in dependency order--       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs-       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs-       ; res_kind   <- zonkTcType           res_kind--       ; let mentioned_kv_set = candidateKindVars candidates-             specified        = scopedSort scoped_kvs-                                -- NB: maintain the L-R order of scoped_kvs--             final_tc_binders =  mkNamedTyConBinders Inferred  inferred-                              ++ mkNamedTyConBinders Specified specified-                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs--             all_tv_prs =  mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-             tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs-                               True -- it is generalised-                               flav-         -- 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-       ; checkTyConTelescope tycon--       ; traceTc "kcCheckDeclHeader_cusk " $-         vcat [ text "name" <+> ppr name-              , text "kv_ns" <+> ppr kv_ns-              , text "hs_tvs" <+> ppr hs_tvs-              , text "scoped_kvs" <+> ppr scoped_kvs-              , text "tc_tvs" <+> ppr tc_tvs-              , text "res_kind" <+> ppr res_kind-              , text "candidates" <+> ppr candidates-              , text "inferred" <+> ppr inferred-              , text "specified" <+> ppr specified-              , text "final_tc_binders" <+> ppr final_tc_binders-              , text "mkTyConKind final_tc_bndrs res_kind"-                <+> ppr (mkTyConKind final_tc_binders res_kind)-              , text "all_tv_prs" <+> ppr all_tv_prs ]--       ; return tycon }-  where-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind---- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and--- other kinds).------ This function does not do telescope checking.-kcInferDeclHeader-  :: Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn-  -> TcM ContextKind   -- ^ The result kind-  -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon-kcInferDeclHeader name flav-              (HsQTvs { hsq_ext = kv_ns-                      , hsq_explicit = hs_tvs }) kc_res_ki-  -- No standalane kind signature and no CUSK.-  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl-  = addTyConFlavCtxt name flav $-    do { (scoped_kvs, (tc_tvs, res_kind))-           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?-           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl-           <- bindImplicitTKBndrs_Q_Tv kv_ns            $-              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $-              newExpectedKind =<< kc_res_ki-              -- Why "_Tv" not "_Skol"? See third wrinkle in-              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,--       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they-               -- might unify with kind vars in other types in a mutually-               -- recursive group.-               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl--             tc_binders = mkAnonTyConBinders VisArg tc_tvs-               -- Also, note that tc_binders has the tyvars from only the-               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]-               -- in GHC.Tc.TyCl-               ---               -- mkAnonTyConBinder: see Note [No polymorphic recursion]--             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;-               --     ditto Implicit-               -- See Note [Non-cloning for tyvar binders]--             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs-                               False -- not yet generalised-                               flav--       ; traceTc "kcInferDeclHeader: not-cusk" $-         vcat [ ppr name, ppr kv_ns, ppr hs_tvs-              , ppr scoped_kvs-              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]-       ; return tycon }-  where-    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind-              | otherwise            = AnyKind---- | Kind-check a declaration header against a standalone kind signature.--- See Note [Arity inference in kcCheckDeclHeader_sig]-kcCheckDeclHeader_sig-  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)-  -> Name              -- ^ of the thing being checked-  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked-  -> LHsQTyVars GhcRn  -- ^ Binders in the header-  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature-  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon-kcCheckDeclHeader_sig kisig name flav-          (HsQTvs { hsq_ext      = implicit_nms-                  , hsq_explicit = explicit_nms }) kc_res_ki-  = addTyConFlavCtxt name flav $-    do {  -- Step 1: zip user-written binders with quantifiers from the kind signature.-          -- For example:-          ---          --   type F :: forall k -> k -> forall j. j -> Type-          --   data F i a b = ...-          ---          -- Results in the following 'zipped_binders':-          ---          --                   TyBinder      LHsTyVarBndr-          --    ----------------------------------------          --    ZippedBinder   forall k ->   i-          --    ZippedBinder   k ->          a-          --    ZippedBinder   forall j.-          --    ZippedBinder   j ->          b-          ---          let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms--          -- Report binders that don't have a corresponding quantifier.-          -- For example:-          ---          --   type T :: Type -> Type-          --   data T b1 b2 b3 = ...-          ---          -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders.-          ---        ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs)--          -- Convert each ZippedBinder to TyConBinder        for  tyConBinders-          --                       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  $-                do { -- Check that inline kind annotations on binders are valid.-                     -- For example:-                     ---                     --   type T :: Maybe k -> Type-                     --   data T (a :: Maybe j) = ...-                     ---                     -- Here we unify   Maybe k ~ Maybe j-                     mapM_ check_zipped_binder zipped_binders--                     -- Kind-check the result kind annotation, if present:-                     ---                     --    data T a b :: res_ki where-                     --               ^^^^^^^^^-                     -- We do it here because at this point the environment has been-                     -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.-                   ; ctx_k <- kc_res_ki-                   ; m_res_ki <- case ctx_k of-                                  AnyKind -> return Nothing-                                  _ -> Just <$> newExpectedKind ctx_k--                     -- Step 2: split off invisible binders.-                     -- For example:-                     ---                     --   type F :: forall k1 k2. (k1, k2) -> Type-                     --   type family F-                     ---                     -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?-                     -- See Note [Arity inference in kcCheckDeclHeader_sig]-                   ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki--                     -- Check that the inline result kind annotation is valid.-                     -- For example:-                     ---                     --   type T :: Type -> Maybe k-                     --   type family T a :: Maybe j where-                     ---                     -- Here we unify   Maybe k ~ Maybe j-                   ; whenIsJust m_res_ki $ \res_ki ->-                      discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]-                      unifyKind Nothing r_ki res_ki--                   ; return (invis_binders, r_ki) }--        -- Zonk the implicitly quantified variables.-        ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs--        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.-        ; invis_tcbs <- mapM invis_to_tcb invis_binders--        -- Build the final, generalized TcTyCon-        ; 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--        ; traceTc "kcCheckDeclHeader_sig done:" $ vcat-          [ text "tyConName = " <+> ppr (tyConName tc)-          , text "kisig =" <+> debugPprType kisig-          , text "tyConKind =" <+> debugPprType (tyConKind tc)-          , text "tyConBinders = " <+> ppr (tyConBinders tc)-          , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)-          , text "tyConResKind" <+> debugPprType (tyConResKind tc)-          ]-        ; return tc }-  where-    -- Consider this declaration:-    ---    --    type T :: forall a. forall b -> (a~b) => Proxy a -> Type-    --    data T x p = MkT-    ---    -- Here, we have every possible variant of ZippedBinder:-    ---    --                   TyBinder           LHsTyVarBndr-    --    -----------------------------------------------    --    ZippedBinder   forall {k}.-    --    ZippedBinder   forall (a::k).-    --    ZippedBinder   forall (b::k) ->   x-    --    ZippedBinder   (a~b) =>-    --    ZippedBinder   Proxy a ->         p-    ---    -- Given a ZippedBinder zipped_to_tcb produces:-    ---    --  * TyConBinder      for  tyConBinders-    --  * (Name, TcTyVar)  for  tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr-    ---    zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])-    zipped_to_tcb zb = case zb of--      -- Inferred variable, no user-written binder.-      -- Example:   forall {k}.-      ZippedBinder (Named (Bndr v Specified)) Nothing ->-        return (mkNamedTyConBinder Specified v, [])--      -- Specified variable, no user-written binder.-      -- Example:   forall (a::k).-      ZippedBinder (Named (Bndr v Inferred)) Nothing ->-        return (mkNamedTyConBinder Inferred v, [])--      -- Constraint, no user-written binder.-      -- Example:   (a~b) =>-      ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do-        name <- newSysName (mkTyVarOccFS (fsLit "ev"))-        let tv = mkTyVar name (scaledThing bndr_ki)-        return (mkAnonTyConBinder InvisArg tv, [])--      -- Non-dependent visible argument with a user-written binder.-      -- Example:   Proxy a ->-      ZippedBinder (Anon VisArg bndr_ki) (Just b) ->-        return $-          let v_name = getName b-              tv = mkTyVar v_name (scaledThing bndr_ki)-              tcb = mkAnonTyConBinder VisArg tv-          in (tcb, [(v_name, tv)])--      -- Dependent visible argument with a user-written binder.-      -- Example:   forall (b::k) ->-      ZippedBinder (Named (Bndr v Required)) (Just b) ->-        return $-          let v_name = getName b-              tcb = mkNamedTyConBinder Required v-          in (tcb, [(v_name, v)])--      -- 'zipBinders' does not produce any other variants of ZippedBinder.-      _ -> panic "goVis: invalid ZippedBinder"--    -- Given an invisible binder that comes from 'split_invis',-    -- convert it to TyConBinder.-    invis_to_tcb :: TyCoBinder -> TcM TyConBinder-    invis_to_tcb tb = do-      (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)-      MASSERT(null stv)-      return tcb--    -- Check that the inline kind annotation on a binder is valid-    -- by unifying it with the kind of the quantifier.-    check_zipped_binder :: ZippedBinder -> TcM ()-    check_zipped_binder (ZippedBinder _ Nothing) = return ()-    check_zipped_binder (ZippedBinder tb (Just b)) =-      case unLoc b of-        UserTyVar _ _ _ -> return ()-        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))-                      (tyBinderType tb)-                      v_ki--    -- Split the invisible binders that should become a part of 'tyConBinders'-    -- rather than 'tyConResKind'.-    -- See Note [Arity inference in kcCheckDeclHeader_sig]-    split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)-    split_invis sig_ki Nothing =-      -- instantiate all invisible binders-      splitPiTysInvisible sig_ki-    split_invis sig_ki (Just res_ki) =-      -- subtraction a la checkExpectedKind-      let n_res_invis_bndrs = invisibleTyBndrCount res_ki-          n_sig_invis_bndrs = invisibleTyBndrCount sig_ki-          n_inst = n_sig_invis_bndrs - n_res_invis_bndrs-      in splitPiTysInvisibleN n_inst sig_ki---- A quantifier from a kind signature zipped with a user-written binder for it.-data ZippedBinder =-  ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn))---- See Note [Arity inference in kcCheckDeclHeader_sig]-zipBinders-  :: Kind                      -- kind signature-  -> [LHsTyVarBndr () GhcRn]   -- user-written binders-  -> ([ZippedBinder],          -- zipped binders-      [LHsTyVarBndr () GhcRn], -- remaining user-written binders-      Kind)                    -- remainder of the kind signature-zipBinders = zip_binders []-  where-    zip_binders acc ki [] = (reverse acc, [], ki)-    zip_binders acc ki (b:bs) =-      case tcSplitPiTy_maybe ki of-        Nothing -> (reverse acc, b:bs, ki)-        Just (tb, ki') ->-          let-            (zb, bs') | zippable  = (ZippedBinder tb (Just b),  bs)-                      | otherwise = (ZippedBinder tb Nothing, b:bs)-            zippable =-              case tb of-                Named (Bndr _ (Invisible _)) -> False-                Named (Bndr _ Required)      -> True-                Anon InvisArg _ -> False-                Anon VisArg   _ -> True-          in-            zip_binders (zb:acc) ki' bs'--tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc-tooManyBindersErr ki bndrs =-   hang (text "Not a function kind:")-      4 (ppr ki) $$-   hang (text "but extra binders found:")-      4 (fsep (map ppr bndrs))--{- Note [Arity inference in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig-verifies that the declaration conforms to the signature. The end result is a-TcTyCon 'tc' such that:--  tyConKind tc == kisig--This TcTyCon would be rather easy to produce if we didn't have to worry about-arity. Consider these declarations:--  type family S1 :: forall k. k -> Type-  type family S2 (a :: k) :: Type--Both S1 and S2 can be given the same standalone kind signature:--  type S2 :: forall k. k -> Type--And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from-tyConBinders and tyConResKind, such that--  tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc)--For S1 and S2, tyConBinders and tyConResKind are different:--  tyConBinders S1  ==  []-  tyConResKind S1  ==  forall k. k -> Type-  tyConKind    S1  ==  forall k. k -> Type--  tyConBinders S2  ==  [spec k, anon-vis (a :: k)]-  tyConResKind S2  ==  Type-  tyConKind    S1  ==  forall k. k -> Type--This difference determines the arity:--  tyConArity tc == length (tyConBinders tc)--That is, the arity of S1 is 0, while the arity of S2 is 2.--'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone-kind signature into binders and the result kind. It does so in two rounds:--1. zip user-written binders (vis_tcbs)-2. split off invisible binders (invis_tcbs)--Consider the following declarations:--    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type-    type family F a b--    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type-    type family G a b :: forall r2. (r1, r2) -> Type--In step 1 (zip user-written binders), we zip the quantifiers in the signature-with the binders in the header using 'zipBinders'. In both F and G, this results in-the following zipped binders:--                   TyBinder     LHsTyVarBndr-    ----------------------------------------    ZippedBinder   Type ->      a-    ZippedBinder   forall j.-    ZippedBinder   j ->         b---At this point, we have accumulated three zipped binders which correspond to a-prefix of the standalone kind signature:--  Type -> forall j. j -> ...--In step 2 (split off invisible binders), we have to decide how much remaining-invisible binders of the standalone kind signature to split off:--    forall k1 k2. (k1, k2) -> Type-    ^^^^^^^^^^^^^-    split off or not?--This decision is made in 'split_invis':--* If a user-written result kind signature is not provided, as in F,-  then split off all invisible binders. This is why we need special treatment-  for AnyKind.-* If a user-written result kind signature is provided, as in G,-  then do as checkExpectedKind does and split off (n_sig - n_res) binders.-  That is, split off such an amount of binders that the remainder of the-  standalone kind signature and the user-written result kind signature have the-  same amount of invisible quantifiers.--For F, split_invis splits away all invisible binders, and we have 2:--    forall k1 k2. (k1, k2) -> Type-    ^^^^^^^^^^^^^-    split away both binders--The resulting arity of F is 3+2=5.  (length vis_tcbs = 3,-                                     length invis_tcbs = 2,-                                     length tcbs = 5)--For G, split_invis decides to split off 1 invisible binder, so that we have the-same amount of invisible quantifiers left:--    res_ki  =  forall    r2. (r1, r2) -> Type-    kisig   =  forall k1 k2. (k1, k2) -> Type-                     ^^^-                     split off this one.--The resulting arity of G is 3+1=4. (length vis_tcbs = 3,-                                    length invis_tcbs = 1,-                                    length tcbs = 4)---}--{- Note [discardResult in kcCheckDeclHeader_sig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use 'unifyKind' to check inline kind annotations in declaration headers-against the signature.--  type T :: [i] -> Maybe j -> Type-  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...--Here, we will unify:--       [k1] ~ [i]-  Maybe k2  ~ Maybe j-      Type  ~ Type--The end result is that we fill in unification variables k1, k2:--    k1  :=  i-    k2  :=  j--We also validate that the user isn't confused:--  type T :: Type -> Type-  data T (a :: Bool) = ...--This will report that (Type ~ Bool) failed to unify.--Now, consider the following example:--  type family Id a where Id x = x-  type T :: Bool -> Type-  type T (a :: Id Bool) = ...--We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.-However, we are free to discard it, as the kind of 'T' is determined by the-signature, not by the inline kind annotation:--      we have   T ::    Bool -> Type-  rather than   T :: Id Bool -> Type--This (Id Bool) will not show up anywhere after we're done validating it, so we-have no use for the produced coercion.--}--{- Note [No polymorphic recursion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Should this kind-check?-  data T ka (a::ka) b  = MkT (T Type           Int   Bool)-                             (T (Type -> Type) Maybe Bool)--Notice that T is used at two different kinds in its RHS.  No!-This should not kind-check.  Polymorphic recursion is known to-be a tough nut.--Previously, we laboriously (with help from the renamer)-tried to give T the polymorphic kind-   T :: forall ka -> ka -> kappa -> Type-where kappa is a unification variable, even in the inferInitialKinds-phase (which is what kcInferDeclHeader is all about).  But-that is dangerously fragile (see the ticket).--Solution: make kcInferDeclHeader give T a straightforward-monomorphic kind, with no quantification whatsoever. That's why-we use mkAnonTyConBinder for all arguments when figuring out-tc_binders.--But notice that (#16322 comment:3)--* The algorithm successfully kind-checks this declaration:-    data T2 ka (a::ka) = MkT2 (T2 Type a)--  Starting with (inferInitialKinds)-    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *-  we get-    kappa4 := kappa1   -- from the (a:ka) kind signature-    kappa1 := Type     -- From application T2 Type--  These constraints are soluble so generaliseTcTyCon gives-    T2 :: forall (k::Type) -> k -> *--  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase-  fails, because the call (T2 Type a) in the RHS is ill-kinded.--  We'd really prefer all errors to show up in the kind checking-  phase.--* This algorithm still accepts (in all phases)-     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)-  although T3 is really polymorphic-recursive too.-  Perhaps we should somehow reject that.--Note [Kind-checking tyvar binders for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When kind-checking the type-variable binders for associated-   data/newtype decls-   family decls-we behave specially for type variables that are already in scope;-that is, bound by the enclosing class decl.  This is done in-kcLHsQTyVarBndrs:-  * The use of tcImplicitQTKBndrs-  * The tcLookupLocal_maybe code in kc_hs_tv--See Note [Associated type tyvar names] in GHC.Core.Class and-    Note [TyVar binders for associated decls] in GHC.Hs.Decls--We must do the same for family instance decls, where the in-scope-variables may be bound by the enclosing class instance decl.-Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.--Note [Kind variable ordering for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What should be the kind of `T` in the following example? (#15591)--  class C (a :: Type) where-    type T (x :: f a)--As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify-the kind variables in left-to-right order of first occurrence in order to-support visible kind application. But we cannot perform this analysis on just-T alone, since its variable `a` actually occurs /before/ `f` if you consider-the fact that `a` was previously bound by the parent class `C`. That is to say,-the kind of `T` should end up being:--  T :: forall a f. f a -> Type--(It wouldn't necessarily be /wrong/ if the kind ended up being, say,-forall f a. f a -> Type, but that would not be as predictable for users of-visible kind application.)--In contrast, if `T` were redefined to be a top-level type family, like `T2`-below:--  type family T2 (x :: f (a :: Type))--Then `a` first appears /after/ `f`, so the kind of `T2` should be:--  T2 :: forall f a. f a -> Type--In order to make this distinction, we need to know (in kcCheckDeclHeader) which-type variables have been bound by the parent class (if there is one). With-the class-bound variables in hand, we can ensure that we always quantify-these first.--}---{- *********************************************************************-*                                                                      *-             Expected kinds-*                                                                      *-********************************************************************* -}---- | Describes the kind expected in a certain context.-data ContextKind = TheKind Kind   -- ^ a specific kind-                 | AnyKind        -- ^ any kind will do-                 | OpenKind       -- ^ something of the form @TYPE _@--------------------------newExpectedKind :: ContextKind -> TcM Kind-newExpectedKind (TheKind k) = return k-newExpectedKind AnyKind     = newMetaKindVar-newExpectedKind OpenKind    = newOpenTypeKind--------------------------expectedKindInCtxt :: UserTypeCtxt -> ContextKind--- 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-expectedKindInCtxt DefaultDeclCtxt     = AnyKind-expectedKindInCtxt TypeAppCtxt         = AnyKind-expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind-expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind-expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind-expectedKindInCtxt _                   = OpenKind---{- *********************************************************************-*                                                                      *-             Bringing type variables into scope-*                                                                      *-********************************************************************* -}--{- Note [Non-cloning for tyvar binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-bindExplictTKBndrs_Q_Skol, bindExplictTKBndrs_Skol, do not clone;-and nor do the Implicit versions.  There is no need.--bindExplictTKBndrs_Q_Tv does not clone; and similarly Implicit.-We take advantage of this in kcInferDeclHeader:-     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)-If we cloned, we'd need to take a bit more care here; not hard.--The main payoff is that avoidng gratuitious cloning means that we can-almost always take the fast path in swizzleTcTyConBndrs.  "Almost-always" means not the case of mutual recursion with polymorphic kinds.---Note [Cloning for tyvar binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-bindExplicitTKBndrs_Tv does cloning, making up a Name with a fresh Unique,-unlike bindExplicitTKBndrs_Q_Tv.  (Nor do the Skol variants clone.)-And similarly for bindImplicit...--This for a narrow and tricky reason which, alas, I couldn't find a-simpler way round.  #16221 is the poster child:--   data SameKind :: k -> k -> *-   data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int--When kind-checking T, we give (a :: kappa1). Then:--- In kcConDecl we make a TyVarTv unification variable kappa2 for k2-  (as described in Note [Kind-checking for GADTs], even though this-  example is an existential)-- So we get (b :: kappa2) via bindExplicitTKBndrs_Tv-- We end up unifying kappa1 := kappa2, because of the (SameKind a b)--Now we generalise over kappa2. But if kappa2's Name is precisely k2-(i.e. we did not clone) we'll end up giving T the utterlly final kind-  T :: forall k2. k2 -> *-Nothing directly wrong with that but when we typecheck the data constructor-we have k2 in scope; but then it's brought into scope /again/ when we find-the forall k2.  This is chaotic, and we end up giving it the type-  MkT :: forall k2 (a :: k2) k2 (b :: k2).-         SameKind @k2 a b -> Int -> T @{k2} a-which is bogus -- because of the shadowing of k2, we can't-apply T to the kind or a!--And there no reason /not/ to clone the Name when making a unification-variable.  So that's what we do.--}------------------------------------------- Implicit binders-----------------------------------------bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,-  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv-  :: [Name] -> TcM a -> TcM ([TcTyVar], a)-bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedSkolemTyVar)-bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (newImplicitTyVarQ newFlexiKindedTyVarTyVar)-bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX newFlexiKindedSkolemTyVar-bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX cloneFlexiKindedTyVarTyVar-  -- newFlexiKinded...           see Note [Non-cloning for tyvar binders]-  -- cloneFlexiKindedTyVarTyVar: see Note [Cloning for tyvar binders]--bindImplicitTKBndrsX-   :: (Name -> TcM TcTyVar) -- new_tv function-   -> [Name]-   -> TcM a-   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence-                           -- with the passed in [Name]-bindImplicitTKBndrsX new_tv tv_names thing_inside-  = do { tkvs <- mapM new_tv tv_names-       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)-       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)-                thing_inside-       ; return (tkvs, res) }--newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar--- Behave like new_tv, except that if the tyvar is in scope, use it-newImplicitTyVarQ new_tv name-  = do { mb_tv <- tcLookupLcl_maybe name-       ; case mb_tv of-           Just (ATyVar _ tv) -> return tv-           _ -> new_tv name }--newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar-newFlexiKindedTyVar new_tv name-  = do { kind <- newMetaKindVar-       ; new_tv name kind }--newFlexiKindedSkolemTyVar :: Name -> TcM TyVar-newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar--newFlexiKindedTyVarTyVar :: Name -> TcM TyVar-newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar--cloneFlexiKindedTyVarTyVar :: Name -> TcM TyVar-cloneFlexiKindedTyVarTyVar = newFlexiKindedTyVar cloneTyVarTyVar-   -- See Note [Cloning for tyvar binders]------------------------------------------- Explicit binders------------------------------------------- | 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)-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)--bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv-    :: (OutputableBndrFlag flag)-    => [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)--bindExplicitTKBndrs_Skol_M, bindExplicitTKBndrs_Tv_M-    :: (OutputableBndrFlag flag)-    => TcTyMode-    -> [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)--bindExplicitTKBndrs_Skol        = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) newSkolemTyVar)-bindExplicitTKBndrs_Skol_M mode = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode)   newSkolemTyVar)-bindExplicitTKBndrs_Tv          = bindExplicitTKBndrsX (tcHsTyVarBndr (mkMode KindLevel) cloneTyVarTyVar)-bindExplicitTKBndrs_Tv_M mode   = bindExplicitTKBndrsX (tcHsTyVarBndr (kindLevel mode)   cloneTyVarTyVar)-  -- newSkolemTyVar:  see Note [Non-cloning for tyvar binders]-  -- cloneTyVarTyVar: see Note [Cloning for tyvar binders]--bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv-    :: ContextKind-    -> [LHsTyVarBndr () GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)--bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)-bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX_Q (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)-  -- See Note [Non-cloning for tyvar binders]--bindExplicitTKBndrsX_Q-    :: (HsTyVarBndr () GhcRn -> TcM TcTyVar)-    -> [LHsTyVarBndr () GhcRn]-    -> TcM a-    -> TcM ([TcTyVar], a)  -- Returned [TcTyVar] are in 1-1 correspondence-                           -- 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) }--bindExplicitTKBndrsX :: (OutputableBndrFlag flag)-    => (HsTyVarBndr flag GhcRn -> TcM TcTyVar)-    -> [LHsTyVarBndr flag GhcRn]-    -> TcM a-    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence-                                      -- with the passed-in [LHsTyVarBndr]-bindExplicitTKBndrsX tc_tv hs_tvs thing_inside-  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)-       ; go hs_tvs }-  where-    go [] = do { res <- thing_inside-               ; return ([], res) }-    go (L _ hs_tv : hs_tvs)-       = do { tv <- tc_tv hs_tv-            -- Extend the environment as we go, in case a binder-            -- is mentioned in the kind of a later binder-            --   e.g. forall k (a::k). blah-            -- NB: tv's Name may differ from hs_tv's-            -- 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) }--------------------tcHsTyVarBndr :: TcTyMode -> (Name -> Kind -> TcM TyVar)-              -> HsTyVarBndr flag GhcRn -> TcM TcTyVar-tcHsTyVarBndr _ new_tv (UserTyVar _ _ (L _ tv_nm))-  = do { kind <- newMetaKindVar-       ; new_tv tv_nm kind }-tcHsTyVarBndr mode new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)-  = do { kind <- tc_lhs_kind_sig mode (TyVarBndrKindCtxt tv_nm) lhs_kind-       ; new_tv tv_nm kind }--------------------tcHsQTyVarBndr :: ContextKind-               -> (Name -> Kind -> TcM TyVar)-               -> HsTyVarBndr () GhcRn -> TcM TcTyVar--- Just like tcHsTyVarBndr, but also---   - uses the in-scope TyVar from class, if it exists---   - takes a ContextKind to use for the no-sig case-tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ _ (L _ tv_nm))-  = do { mb_tv <- tcLookupLcl_maybe tv_nm-       ; case mb_tv of-           Just (ATyVar _ tv) -> return tv-           _ -> do { kind <- newExpectedKind ctxt_kind-                   ; new_tv tv_nm kind } }--tcHsQTyVarBndr _ new_tv (KindedTyVar _ _ (L _ tv_nm) lhs_kind)-  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind-       ; mb_tv <- tcLookupLcl_maybe tv_nm-       ; case mb_tv of-           Just (ATyVar _ tv)-             -> do { discardResult $ unifyKind (Just hs_tv)-                                        kind (tyVarKind tv)-                       -- This unify rejects:-                       --    class C (m :: * -> *) where-                       --      type F (m :: *) = ...-                   ; 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--- kind-checking and typechecking phases-----------------------------------------bindTyClTyVars :: Name-               -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a--- ^ Used for the type variables of a type or class decl--- in the "kind checking" and "type checking" pass,--- but not in the initial-kind run.-bindTyClTyVars tycon_name thing_inside-  = do { tycon <- tcLookupTcTyCon tycon_name-       ; let scoped_prs = tcTyConScopedTyVars tycon-             res_kind   = tyConResKind tycon-             binders    = tyConBinders tycon-       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)-       ; tcExtendNameTyVarEnv scoped_prs $-         thing_inside tycon binders res_kind }---{- *********************************************************************-*                                                                      *-             Kind generalisation-*                                                                      *-********************************************************************* -}--zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]-zonkAndScopedSort spec_tkvs-  = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs-          -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv--       -- Do a stable topological sort, following-       -- Note [Ordering of implicit variables] in GHC.Rename.HsType-       ; return (scopedSort spec_tkvs) }---- | 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)-                   -> 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-         -- 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)--       ; _ <- 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 }---- | 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 }---- | Specialized version of 'kindGeneralizeSome', but where no variables--- can be generalized, but perhaps some may neeed to be promoted.--- Use this variant when it is unknowable whether metavariables might--- later be constrained.------ To see why this promotion is needed, see--- Note [Recipe for checking a signature], and especially--- 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 )-       }--{- Note [Levels and generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f x = e-with no type signature. We are currently at level i.-We must-  * Push the level to level (i+1)-  * Allocate a fresh alpha[i+1] for the result type-  * Check that e :: alpha[i+1], gathering constraint WC-  * Solve WC as far as possible-  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]-  * Find the free variables with level > i, in this case gamma[i]-  * Skolemise those free variables and quantify over them, giving-       f :: forall g. beta[i-1] -> g-  * Emit the residiual constraint wrapped in an implication for g,-    thus   forall g. WC--All of this happens for types too.  Consider-  f :: Int -> (forall a. Proxy a -> Int)--Note [Kind generalisation]-~~~~~~~~~~~~~~~~~~~~~~~~~~-We do kind generalisation only at the outer level of a type signature.-For example, consider-  T :: forall k. k -> *-  f :: (forall a. T a -> Int) -> Int-When kind-checking f's type signature we generalise the kind at-the outermost level, thus:-  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!-and *not* at the inner forall:-  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!-Reason: same as for HM inference on value level declarations,-we want to infer the most general type.  The f2 type signature-would be *less applicable* than f1, because it requires a more-polymorphic argument.--NB: There are no explicit kind variables written in f's signature.-When there are, the renamer adds these kind variables to the list of-variables bound by the forall, so you can indeed have a type that's-higher-rank in its kind. But only by explicit request.--Note [Kinds of quantified type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcTyVarBndrsGen quantifies over a specified list of type variables,-*and* over the kind variables mentioned in the kinds of those tyvars.--Note that we must zonk those kinds (obviously) but less obviously, we-must return type variables whose kinds are zonked too. Example-    (a :: k7)  where  k7 := k9 -> k9-We must return-    [k9, a:k9->k9]-and NOT-    [k9, a:k7]-Reason: we're going to turn this into a for-all type,-   forall k9. forall (a:k7). blah-which the type checker will then instantiate, and instantiate does not-look through unification variables!--Hence using zonked_kinds when forming tvs'.---}--------------------------------------etaExpandAlgTyCon :: [TyConBinder]-                  -> Kind   -- must be zonked-                  -> TcM ([TyConBinder], Kind)--- GADT decls can have a (perhaps partial) kind signature---      e.g.  data T a :: * -> * -> * where ...--- This function makes up suitable (kinded) TyConBinders for the--- argument kinds.  E.g. in this case it might return---   ([b::*, c::*], *)--- Never emits constraints.--- It's a little trickier than you might think: see--- Note [TyConBinders for the result kind signature of a data type]--- See Note [Datatype return kinds] in GHC.Tc.TyCl-etaExpandAlgTyCon tc_bndrs kind-  = do  { loc     <- getSrcSpanM-        ; uniqs   <- newUniqueSupply-        ; rdr_env <- getLocalRdrEnv-        ; let new_occs = [ occ-                         | str <- allNameStrings-                         , let occ = mkOccName tvName str-                         , isNothing (lookupLocalRdrOcc rdr_env occ)-                         -- Note [Avoid name clashes for associated data types]-                         , not (occ `elem` lhs_occs) ]-              new_uniqs = uniqsFromSupply uniqs-              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))-        ; return (go loc new_occs new_uniqs subst [] kind) }-  where-    lhs_tvs  = map binderVar tc_bndrs-    lhs_occs = map getOccName lhs_tvs--    go loc occs uniqs subst acc kind-      = case splitPiTy_maybe kind of-          Nothing -> (reverse acc, substTy subst kind)--          Just (Anon af arg, kind')-            -> go loc occs' uniqs' subst' (tcb : acc) kind'-            where-              arg'   = substTy subst (scaledThing arg)-              tv     = mkTyVar (mkInternalName uniq occ loc) arg'-              subst' = extendTCvInScope subst tv-              tcb    = Bndr tv (AnonTCB af)-              (uniq:uniqs') = uniqs-              (occ:occs')   = occs--          Just (Named (Bndr tv vis), kind')-            -> go loc occs uniqs subst' (tcb : acc) kind'-            where-              (subst', tv') = substTyVarBndr subst tv-              tcb = Bndr tv' (NamedTCB vis)---- | A description of whether something is a------ * @data@ or @newtype@ ('DataDeclSort')------ * @data instance@ or @newtype instance@ ('DataInstanceSort')------ * @data family@ ('DataFamilySort')------ At present, this data type is only consumed by 'checkDataKindSig'.-data DataSort-  = DataDeclSort     NewOrData-  | DataInstanceSort NewOrData-  | DataFamilySort---- | Checks that the return kind in a data declaration's kind signature is--- permissible. There are three cases:------ If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@--- declaration, check that the return kind is @Type@.------ If the declaration is a @newtype@ or @newtype instance@ and the--- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so--- that a return kind of the form @TYPE r@ (for some @r@) is permitted.--- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".------ If dealing with a @data family@ declaration, check that the return kind is--- either of the form:------ 1. @TYPE r@ (for some @r@), or------ 2. @k@ (where @k@ is a bare kind variable; see #12369)------ See also Note [Datatype return kinds] in "GHC.Tc.TyCl"-checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off-                 -> TcM ()-checkDataKindSig data_sort kind-  = do { dflags <- getDynFlags-       ; traceTc "checkDataKindSig" (ppr kind)-       ; checkTc (is_TYPE_or_Type dflags || is_kind_var)-                 (err_msg dflags) }-  where-    res_kind = snd (tcSplitPiTys kind)-       -- Look for the result kind after-       -- peeling off any foralls and arrows--    pp_dec :: SDoc-    pp_dec = text $-      case data_sort of-        DataDeclSort     DataType -> "Data type"-        DataDeclSort     NewType  -> "Newtype"-        DataInstanceSort DataType -> "Data instance"-        DataInstanceSort NewType  -> "Newtype instance"-        DataFamilySort            -> "Data family"--    is_newtype :: Bool-    is_newtype =-      case data_sort of-        DataDeclSort     new_or_data -> new_or_data == NewType-        DataInstanceSort new_or_data -> new_or_data == NewType-        DataFamilySort               -> False--    is_data_family :: Bool-    is_data_family =-      case data_sort of-        DataDeclSort{}     -> False-        DataInstanceSort{} -> False-        DataFamilySort     -> True--    tYPE_ok :: DynFlags -> Bool-    tYPE_ok dflags =-         (is_newtype && xopt LangExt.UnliftedNewtypes dflags)-           -- With UnliftedNewtypes, we allow kinds other than Type, but they-           -- must still be of the form `TYPE r` since we don't want to accept-           -- Constraint or Nat.-           -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.-      || is_data_family-           -- If this is a `data family` declaration, we don't need to check if-           -- UnliftedNewtypes is enabled, since data family declarations can-           -- have return kind `TYPE r` unconditionally (#16827).--    is_TYPE :: Bool-    is_TYPE = tcIsRuntimeTypeKind res_kind--    is_Type :: Bool-    is_Type = tcIsLiftedTypeKind res_kind--    is_TYPE_or_Type :: DynFlags -> Bool-    is_TYPE_or_Type dflags | tYPE_ok dflags = is_TYPE-                           | otherwise      = is_Type--    -- In the particular case of a data family, permit a return kind of the-    -- form `:: k` (where `k` is a bare kind variable).-    is_kind_var :: Bool-    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)-                | otherwise      = False--    err_msg :: DynFlags -> SDoc-    err_msg dflags =-      sep [ (sep [ pp_dec <+>-                   text "has non-" <>-                   (if tYPE_ok dflags then text "TYPE" else ppr liftedTypeKind)-                 , (if is_data_family then text "and non-variable" else empty) <+>-                   text "return kind" <+> quotes (ppr res_kind) ])-          , if not (tYPE_ok dflags) && is_TYPE && is_newtype &&-               not (xopt LangExt.UnliftedNewtypes dflags)-            then text "Perhaps you intended to use UnliftedNewtypes"-            else empty ]---- | Checks that the result kind of a class is exactly `Constraint`, rejecting--- type synonyms and type families that reduce to `Constraint`. See #16826.-checkClassKindSig :: Kind -> TcM ()-checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg-  where-    err_msg :: SDoc-    err_msg =-      text "Kind signature on a class must end with" <+> ppr constraintKind $$-      text "unobscured by type families"--tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]--- Result is in 1-1 correspondence with orig_args-tcbVisibilities tc orig_args-  = go (tyConKind tc) init_subst orig_args-  where-    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))-    go _ _ []-      = []--    go fun_kind subst all_args@(arg : args)-      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind-      = case tcb of-          Anon af _           -> AnonTCB af   : go inner_kind subst  args-          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args-                 where-                    subst' = extendTCvSubst subst tv arg--      | not (isEmptyTCvSubst subst)-      = go (substTy subst fun_kind) init_subst all_args--      | otherwise-      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)---{- Note [TyConBinders for the result kind signature of a data type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-  data T (a::*) :: * -> forall k. k -> *-we want to generate the extra TyConBinders for T, so we finally get-  (a::*) (b::*) (k::*) (c::k)-The function etaExpandAlgTyCon generates these extra TyConBinders from-the result kind signature.--We need to take care to give the TyConBinders-  (a) OccNames that are fresh (because the TyConBinders of a TyCon-      must have distinct OccNames--  (b) Uniques that are fresh (obviously)--For (a) we need to avoid clashes with the tyvars declared by-the user before the "::"; in the above example that is 'a'.-And also see Note [Avoid name clashes for associated data types].--For (b) suppose we have-   data T :: forall k. k -> forall k. k -> *-where the two k's are identical even up to their uniques.  Surprisingly,-this can happen: see #14515.--It's reasonably easy to solve all this; just run down the list with a-substitution; hence the recursive 'go' function.  But it has to be-done.--Note [Avoid name clashes for associated data types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider    class C a b where-               data D b :: * -> *-When typechecking the decl for D, we'll invent an extra type variable-for D, to fill out its kind.  Ideally we don't want this type variable-to be 'a', because when pretty printing we'll get-            class C a b where-               data D b a0-(NB: the tidying happens in the conversion to Iface syntax, which happens-as part of pretty-printing a TyThing.)--That's why we look in the LocalRdrEnv to see what's in scope. This is-important only to get nice-looking output when doing ":info C" in GHCi.-It isn't essential for correctness.---************************************************************************-*                                                                      *-             Partial signatures-*                                                                      *-************************************************************************---}--tcHsPartialSigType-  :: UserTypeCtxt-  -> LHsSigWcType GhcRn       -- The type signature-  -> TcM ( [(Name, TcTyVar)]  -- Wildcards-         , Maybe TcType       -- Extra-constraints wildcard-         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with-                              --   the implicitly and explicitly bound type variables-         , TcThetaType        -- Theta part-         , TcType )           -- Tau part--- See Note [Checking partial type signatures]-tcHsPartialSigType ctxt sig_ty-  | HsWC { hswc_ext  = sig_wcs, hswc_body = ib_ty } <- sig_ty-  , HsIB { hsib_ext = implicit_hs_tvs-         , hsib_body = hs_ty } <- ib_ty-  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTyInvis hs_ty-  = addSigCtxt ctxt hs_ty $-    do { mode <- mkHoleMode TypeLevel HM_Sig-       ; (implicit_tvs, (explicit_tvbndrs, (wcs, wcx, theta, tau)))-            <- solveLocalEqualities "tcHsPartialSigType"    $-               -- See Note [Failure in local type signatures]-               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-                    (theta, wcx) <- tcPartialContext mode hs_ctxt--                  ; ek <- newOpenTypeKind-                  ; tau <- addTypeCtxt hs_tau $-                           tc_lhs_type mode hs_tau ek--                  ; return (wcs, wcx, theta, tau) }--       ; let implicit_tvbndrs = map (mkTyVarBinder SpecifiedSpec) implicit_tvs--         -- No kind-generalization here:-       ; kindGeneralizeNone (mkInvisForAllTys implicit_tvbndrs $-                             mkInvisForAllTys explicit_tvbndrs $-                             mkPhiTy theta $-                             tau)--       -- Spit out the wildcards (including the extra-constraints one)-       -- as "hole" constraints, so that they'll be reported if necessary-       -- See Note [Extra-constraint holes in partial type signatures]-       ; mapM_ emitNamedTypeHole wcs--       -- Zonk, so that any nested foralls can "see" their occurrences-       -- See Note [Checking partial type signatures], and in particular-       -- Note [Levels for wildcards]-       ; implicit_tvbndrs <- mapM zonkInvisTVBinder implicit_tvbndrs-       ; explicit_tvbndrs <- mapM zonkInvisTVBinder explicit_tvbndrs-       ; theta            <- mapM zonkTcType theta-       ; tau              <- zonkTcType tau--         -- We return a proper (Name,InvisTVBinder) environment, to be sure that-         -- we bring the right name into scope in the function body.-         -- Test case: partial-sigs/should_compile/LocalDefinitionBug-       ; let tv_prs = (implicit_hs_tvs                  `zip` implicit_tvbndrs)-                      ++ (hsLTyVarNames explicit_hs_tvs `zip` explicit_tvbndrs)--      -- NB: checkValidType on the final inferred type will be-      --     done later by checkInferredPolyId.  We can't do it-      --     here because we don't have a complete type to check--       ; traceTc "tcHsPartialSigType" (ppr tv_prs)-       ; return (wcs, wcx, tv_prs, theta, tau) }--tcPartialContext :: TcTyMode -> HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)-tcPartialContext mode hs_theta-  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta-  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last-  = do { wc_tv_ty <- setSrcSpan wc_loc $-                     tcAnonWildCardOcc mode ty constraintKind-       ; theta <- mapM (tc_lhs_pred mode) hs_theta1-       ; return (theta, Just wc_tv_ty) }-  | otherwise-  = do { theta <- mapM (tc_lhs_pred mode) hs_theta-       ; return (theta, Nothing) }--{- Note [Checking partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note is about tcHsPartialSigType.  See also-Note [Recipe for checking a signature]--When we have a partial signature like-   f :: forall a. a -> _-we do the following--* tcHsPartialSigType does not make quantified type (forall a. blah)-  and then instantiate it -- it makes no sense to instantiate a type-  with wildcards in it.  Rather, tcHsPartialSigType just returns the-  'a' and the 'blah' separately.--  Nor, for the same reason, do we push a level in tcHsPartialSigType.--* We instantiate 'a' to a unification variable, a TyVarTv, and /not/-  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider-    f :: forall a. a -> _-    g :: forall b. _ -> b-    f = g-    g = f-  They are typechecked as a recursive group, with monomorphic types,-  so 'a' and 'b' will get unified together.  Very like kind inference-  for mutually recursive data types (sans CUSKs or SAKS); see-  Note [Cloning for tyvar binders] in GHC.Tc.Gen.HsType--* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike-  the companion CompleteSig) contains the original, as-yet-unchecked-  source-code LHsSigWcType--* Then, for f and g /separately/, we call tcInstSig, which in turn-  call tchsPartialSig (defined near this Note).  It kind-checks the-  LHsSigWcType, creating fresh unification variables for each "_"-  wildcard.  It's important that the wildcards for f and g are distinct-  because they might get instantiated completely differently.  E.g.-     f,g :: forall a. a -> _-     f x = a-     g x = True-  It's really as if we'd written two distinct signatures.--* Nested foralls. See Note [Levels for wildcards]--* Just as for ordinary signatures, we must solve local equalities and-  zonk the type after kind-checking it, to ensure that all the nested-  forall binders can "see" their occurrenceds--  Just as for ordinary signatures, this zonk also gets any Refl casts-  out of the way of instantiation.  Example: #18008 had-       foo :: (forall a. (Show a => blah) |> Refl) -> _-  and that Refl cast messed things up.  See #18062.--Note [Levels for wildcards]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-     f :: forall b. (forall a. a -> _) -> b-We do /not/ allow the "_" to be instantiated to 'a'; although we do-(as before) allow it to be instantiated to the (top level) 'b'.-Why not?  Suppose-   f x = (x True, x 'c')--During typecking the RHS we must instantiate that (forall a. a -> _),-so we must know /precisely/ where all the a's are; they must not be-hidden under (possibly-not-yet-filled-in) unification variables!--We achieve this as follows:--- For /named/ wildcards such sas-     g :: forall b. (forall la. a -> _x) -> b-  there is no problem: we create them at the outer level (ie the-  ambient level of teh signature itself), and push the level when we-  go inside a forall.  So now the unification variable for the "_x"-  can't unify with skolem 'a'.--- For /anonymous/ wildcards, such as 'f' above, we carry the ambient-  level of the signature to the hole in the TcLevel part of the-  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that-  level (and /not/ the level ambient at the occurrence of "_") to-  create the unification variable for the wildcard.  That is the sole-  purpose of the TcLevel in the mode_holes field: to transport the-  ambient level of the signature down to the anonymous wildcard-  occurrences.--Note [Extra-constraint holes in partial type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  f :: (_) => a -> a-  f x = ...--* The renamer leaves '_' untouched.--* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in-  tcWildCardBinders.--* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar-  with the inferred constraints, e.g. (Eq a, Show a)--* GHC.Tc.Errors.mkHoleError finally reports the error.--An annoying difficulty happens if there are more than 62 inferred-constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.-Where do we find the TyCon?  For good reasons we only have constraint-tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how-can we make a 70-tuple?  This was the root cause of #14217.--It's incredibly tiresome, because we only need this type to fill-in the hole, to communicate to the error reporting machinery.  Nothing-more.  So I use a HACK:--* I make an /ordinary/ tuple of the constraints, in-  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because-  ordinary tuples can't contain constraints, but it works fine. And for-  ordinary tuples we don't have the same limit as for constraint-  tuples (which need selectors and an associated class).--* Because it is ill-kinded, it trips an assert in writeMetaTyVar,-  so now I disable the assertion if we are writing a type of-  kind Constraint.  (That seldom/never normally happens so we aren't-  losing much.)--Result works fine, but it may eventually bite us.---************************************************************************-*                                                                      *-      Pattern signatures (i.e signatures that occur in patterns)-*                                                                      *-********************************************************************* -}--tcHsPatSigType :: UserTypeCtxt-               -> HsPatSigType GhcRn          -- The type signature-               -> TcM ( [(Name, TcTyVar)]     -- Wildcards-                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding-                                              -- the scoped type variables-                      , TcType)       -- The type--- Used for type-checking type signatures in--- (a) patterns           e.g  f (x::Int) = e--- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x--- See Note [Pattern signature binders and scoping] in GHC.Hs.Type------ This may emit constraints--- See Note [Recipe for checking a signature]-tcHsPatSigType ctxt-  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }-        , hsps_body = hs_ty })-  = addSigCtxt ctxt hs_ty $-    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns-       ; mode <- mkHoleMode TypeLevel HM_Sig-       ; (wcs, sig_ty)-            <- addTypeCtxt hs_ty $-               solveLocalEqualities "tcHsPatSigType" $-                 -- See Note [Failure in local type signatures]-                 -- and c.f #16033-               tcNamedWildCardBinders sig_wcs        $ \ wcs ->-               tcExtendNameTyVarEnv sig_tkv_prs $-               do { ek     <- newOpenTypeKind-                  ; sig_ty <- tc_lhs_type mode hs_ty ek-                  ; return (wcs, sig_ty) }--        ; mapM_ emitNamedTypeHole wcs--          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty-          -- contains a forall). Promote these.-          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...-          -- When we instantiate x, we have to compare the kind of the argument-          -- to a's kind, which will be a metavariable.-          -- kindGeneralizeNone does this:-        ; kindGeneralizeNone sig_ty-        ; sig_ty <- zonkTcType sig_ty-        ; checkValidType ctxt sig_ty--        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)-        ; return (wcs, sig_tkv_prs, sig_ty) }-  where-    new_implicit_tv name-      = do { kind <- newMetaKindVar-           ; tv   <- case ctxt of-                       RuleSigCtxt {} -> newSkolemTyVar name kind-                       _              -> newPatSigTyVar name kind-                       -- See Note [Typechecking pattern signature binders]-             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)-           ; return (name, tv) }--{- Note [Typechecking pattern signature binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [Type variables in the type environment] in GHC.Tc.Utils.-Consider--  data T where-    MkT :: forall a. a -> (a -> Int) -> T--  f :: T -> ...-  f (MkT x (f :: b -> c)) = <blah>--Here- * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',-   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-   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the-   environment-- * Then unification makes beta := a_sk, gamma := Int-   That's why we must make beta and gamma a MetaTv,-   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).-- * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,-   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,--Another example (#13881):-   fl :: forall (l :: [a]). Sing l -> Sing l-   fl (SNil :: Sing (l :: [y])) = SNil-When we reach the pattern signature, 'l' is in scope from the-outer 'forall':-   "a" :-> a_sk :: *-   "l" :-> l_sk :: [a_sk]-We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check-the pattern signature-   Sing (l :: [y])-That unifies y_sig := a_sk.  We return from tcHsPatSigType with-the pair ("y" :-> y_sig).--For RULE binders, though, things are a bit different (yuk).-  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.---************************************************************************-*                                                                      *-        Checking kinds-*                                                                      *-************************************************************************---}--unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)-unifyKinds rn_tys act_kinds-  = do { kind <- newMetaKindVar-       ; let check rn_ty (ty, act_kind)-               = checkExpectedKind (unLoc rn_ty) ty act_kind kind-       ; tys' <- zipWithM check rn_tys act_kinds-       ; return (tys', kind) }--{--************************************************************************-*                                                                      *-        Sort checking kinds-*                                                                      *-************************************************************************--tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.-It does sort checking and desugaring at the same time, in one single pass.--}--tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tcLHsKindSig ctxt hs_kind-  = tc_lhs_kind_sig (mkMode KindLevel) ctxt hs_kind--tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind-tc_lhs_kind_sig mode ctxt hs_kind--- 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" $-                 tc_lhs_type mode hs_kind liftedTypeKind-       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)-       -- No generalization:-       ; kindGeneralizeNone kind-       ; kind <- zonkTcType kind-         -- This zonk is very important in the case of higher rank kinds-         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).-         --                          <more blah>-         --      When instantiating p's kind at occurrences of p in <more blah>-         --      it's crucial that the kind we instantiate is fully zonked,-         --      else we may fail to substitute properly--       ; checkValidType ctxt kind-       ; traceTc "tcLHsKindSig2" (ppr kind)-       ; return kind }--promotionErr :: Name -> PromotionErr -> TcM a-promotionErr name err-  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")-                   2 (parens reason))-  where-    reason = case err of-               ConstrainedDataConPE pred-                              -> text "it has an unpromotable context"-                                 <+> quotes (ppr pred)-               FamDataConPE   -> text "it comes from a data family instance"-               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"-               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"-               PatSynPE       -> text "pattern synonyms cannot be promoted"-               _ -> text "it is defined and used in the same recursive group"--{--************************************************************************-*                                                                      *-          Error messages and such-*                                                                      *-************************************************************************--}----- | 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-       }+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE ViewPatterns        #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++-- | Typechecking user-specified @MonoTypes@+module GHC.Tc.Gen.HsType (+        -- Type signatures+        kcClassSigType, tcClassSigType,+        tcHsSigType, tcHsSigWcType,+        tcHsPartialSigType,+        tcStandaloneKindSig,+        funsSigCtxt, addSigCtxt, pprSigCtxt,++        tcHsClsInstType,+        tcHsDeriv, tcDerivStrategy,+        tcHsTypeApp,+        UserTypeCtxt(..),+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,++        bindOuterFamEqnTKBndrs, bindOuterFamEqnTKBndrs_Q_Tv,+        tcOuterTKBndrs, scopedSortOuter,+        bindOuterSigTKBndrs_Tv,+        tcExplicitTKBndrs,+        bindNamedWildCardBinders,++        -- Type checking type and class decls, and instances thereof+        bindTyClTyVars, tcFamTyPats,+        etaExpandAlgTyCon, tcbVisibilities,++          -- tyvars+        zonkAndScopedSort,++        -- Kind-checking types+        -- No kind generalisation, no checkValidType+        InitialKindStrategy(..),+        SAKS_or_CUSK(..),+        ContextKind(..),+        kcDeclHeader,+        tcHsLiftedType,   tcHsOpenType,+        tcHsLiftedTypeNC, tcHsOpenTypeNC,+        tcInferLHsType, tcInferLHsTypeKind, tcInferLHsTypeUnsaturated,+        tcCheckLHsType,+        tcHsContext, tcLHsPredType,++        kindGeneralizeAll, kindGeneralizeSome, kindGeneralizeNone,++        -- Sort-checking kinds+        tcLHsKindSig, checkDataKindSig, DataSort(..),+        checkClassKindSig,++        -- Multiplicity+        tcMult,++        -- Pattern type signatures+        tcHsPatSigType,+        HoleMode(..),++        -- Error messages+        funAppCtxt, addTyConFlavCtxt+   ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Hs+import GHC.Rename.Utils+import GHC.Tc.Utils.Monad+import GHC.Tc.Types.Origin+import GHC.Core.Predicate+import GHC.Tc.Types.Constraint+import GHC.Tc.Utils.Env+import GHC.Tc.Utils.TcMType+import GHC.Tc.Validity+import GHC.Tc.Utils.Unify+import GHC.IfaceToCore+import GHC.Tc.Solver+import GHC.Tc.Utils.Zonk+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Instantiate ( tcInstInvisibleTyBinders, tcInstInvisibleTyBindersN,+                                  tcInstInvisibleTyBinder )+import GHC.Core.Type+import GHC.Builtin.Types.Prim+import GHC.Types.Name.Env+import GHC.Types.Name.Reader( lookupLocalRdrOcc )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Class+import GHC.Types.Name+-- import GHC.Types.Name.Set+import GHC.Types.Var.Env+import GHC.Builtin.Types+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Utils.Misc+import GHC.Types.Unique.Supply+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Builtin.Names hiding ( wildCardName )+import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.Maybe+import GHC.Data.Bag( unitBag )+import Data.List ( find )+import Control.Monad++{-+        ----------------------------+                General notes+        ----------------------------++Unlike with expressions, type-checking types both does some checking and+desugars at the same time. This is necessary because we often want to perform+equality checks on the types right away, and it would be incredibly painful+to do this on un-desugared types. Luckily, desugared types are close enough+to HsTypes to make the error messages sane.++During type-checking, we perform as little validity checking as possible.+Generally, after type-checking, you will want to do validity checking, say+with GHC.Tc.Validity.checkValidType.++Validity checking+~~~~~~~~~~~~~~~~~+Some of the validity check could in principle be done by the kind checker,+but not all:++- During desugaring, we normalise by expanding type synonyms.  Only+  after this step can we check things like type-synonym saturation+  e.g.  type T k = k Int+        type S a = a+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);+  and then S is saturated.  This is a GHC extension.++- Similarly, also a GHC extension, we look through synonyms before complaining+  about the form of a class or instance declaration++- Ambiguity checks involve functional dependencies++Also, in a mutually recursive group of types, we can't look at the TyCon until we've+finished building the loop.  So to keep things simple, we postpone most validity+checking until step (3).++%************************************************************************+%*                                                                      *+              Check types AND do validity checking+*                                                                      *+************************************************************************++Note [Keeping implicitly quantified variables in order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user implicitly quantifies over variables (say, in a type+signature), we need to come up with some ordering on these variables.+This is done by bumping the TcLevel, bringing the tyvars into scope,+and then type-checking the thing_inside. The constraints are all+wrapped in an implication, which is then solved. Finally, we can+zonk all the binders and then order them with scopedSort.++It's critical to solve before zonking and ordering in order to uncover+any unifications. You might worry that this eager solving could cause+trouble elsewhere. I don't think it will. Because it will solve only+in an increased TcLevel, it can't unify anything that was mentioned+elsewhere. Additionally, we require that the order of implicitly+quantified variables is manifest by the scope of these variables, so+we're not going to learn more information later that will help order+these variables.++Note [Recipe for checking a signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind-checking a user-written signature requires several steps:++ 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.++Very similar steps also apply when kind-checking a type or class+declaration.++The general pattern looks something like this.  (But NB every+specific instance varies in one way or another!)++    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++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.++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.++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]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If an unsolved metavariable in a signature is not generalized+(because we're not generalizing the construct -- e.g., pattern+sig -- or because the metavars are constrained -- see kindGeneralizeSome)+we need to promote to maintain (WantedTvInv) of Note [TcLevel invariants]+in GHC.Tc.Utils.TcType. Note that promotion is identical in effect to generalizing+and the reinstantiating with a fresh metavariable at the current level.+So in some sense, we generalize *all* variables, but then re-instantiate+some of them.++Here is an example of why we must promote:+  foo (x :: forall a. a -> Proxy b) = ...++In the pattern signature, `b` is unbound, and will thus be brought into+scope. We do not know its kind: it will be assigned kappa[2]. Note that+kappa is at TcLevel 2, because it is invented under a forall. (A priori,+the kind kappa might depend on `a`, so kappa rightly has a higher TcLevel+than the surrounding context.) This kappa cannot be solved for while checking+the pattern signature (which is not kind-generalized). When we are checking+the *body* of foo, though, we need to unify the type of x with the argument+type of bar. At this point, the ambient TcLevel is 1, and spotting a+matavariable with level 2 would violate the (WantedTvInv) invariant of+Note [TcLevel invariants]. So, instead of kind-generalizing,+we promote the metavariable to level 1. This is all done in kindGeneralizeNone.++-}++funsSigCtxt :: [LocatedN Name] -> UserTypeCtxt+-- Returns FunSigCtxt, with no redundant-context-reporting,+-- form a list of located names+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False+funsSigCtxt []              = panic "funSigCtxt"++addSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> TcM a -> TcM a+addSigCtxt ctxt hs_ty thing_inside+  = setSrcSpan (getLocA hs_ty) $+    addErrCtxt (pprSigCtxt ctxt hs_ty) $+    thing_inside++pprSigCtxt :: Outputable hs_ty => UserTypeCtxt -> LocatedA hs_ty -> SDoc+-- (pprSigCtxt ctxt <extra> <type>)+-- prints    In the type signature for 'f':+--              f :: <type>+-- The <extra> is either empty or "the ambiguity check for"+pprSigCtxt ctxt hs_ty+  | Just n <- isSigMaybe ctxt+  = hang (text "In the type signature:")+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)++  | otherwise+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+       2 (ppr hs_ty)++tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type+-- This one is used when we have a LHsSigWcType, but in+-- a place where wildcards aren't allowed. The renamer has+-- already checked this, so we can simply ignore it.+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)++kcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM ()+-- This is a special form of tcClassSigType that is used during the+-- kind-checking phase to infer the kind of class variables. Cf. tc_lhs_sig_type.+-- Importantly, this does *not* kind-generalize. Consider+--   class SC f where+--     meth :: forall a (x :: f a). Proxy x -> ()+-- When instantiating Proxy with kappa, we must unify kappa := f a. But we're+-- still working out the kind of f, and thus f a will have a coercion in it.+-- Coercions block unification (Note [Equalities with incompatible kinds] in+-- TcCanonical) and so we fail to unify. If we try to kind-generalize, we'll+-- end up promoting kappa to the top level (because kind-generalization is+-- normally done right before adding a binding to the context), and then we+-- can't set kappa := f a, because a is local.+kcClassSigType names+    sig_ty@(L _ (HsSig { sig_bndrs = hs_outer_bndrs, sig_body = hs_ty }))+  = addSigCtxt (funsSigCtxt names) sig_ty $+    do { _ <- bindOuterSigTKBndrs_Tv hs_outer_bndrs    $+              tcLHsType hs_ty liftedTypeKind+       ; return () }++tcClassSigType :: [LocatedN Name] -> LHsSigType GhcRn -> TcM Type+-- Does not do validity checking+tcClassSigType names sig_ty+  = addSigCtxt sig_ctxt sig_ty $+    do { (implic, ty) <- tc_lhs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+       ; emitImplication implic+       ; return ty }+       -- Do not zonk-to-Type, nor perform a validity check+       -- We are in a knot with the class and associated types+       -- Zonking and validity checking is done by tcClassDecl+       --+       -- No need to fail here if the type has an error:+       --   If we're in the kind-checking phase, the solveEqualities+       --     in kcTyClGroup catches the error+       --   If we're in the type-checking phase, the solveEqualities+       --     in tcClassDecl1 gets it+       -- Failing fast here degrades the error message in, e.g., tcfail135:+       --   class Foo f where+       --     baa :: f a -> f+       -- If we fail fast, we're told that f has kind `k1` when we wanted `*`.+       -- It should be that f has kind `k2 -> *`, but we never get a chance+       -- to run the solver where the kind of f is touchable. This is+       -- painfully delicate.+  where+    sig_ctxt = funsSigCtxt names+    skol_info = SigTypeSkol sig_ctxt++tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- Does validity checking+-- See Note [Recipe for checking a signature]+tcHsSigType ctxt sig_ty+  = addSigCtxt ctxt sig_ty $+    do { traceTc "tcHsSigType {" (ppr sig_ty)++          -- Generalise here: see Note [Kind generalisation]+       ; (implic, ty) <- tc_lhs_sig_type skol_info sig_ty  (expectedKindInCtxt ctxt)++       -- Float out constraints, failing fast if not possible+       -- See Note [Failure in local type signatures] in GHC.Tc.Solver+       ; traceTc "tcHsSigType 2" (ppr implic)+       ; simplifyAndEmitFlatConstraints (mkImplicWC (unitBag implic))++       ; ty <- zonkTcType ty+       ; checkValidType ctxt ty+       ; traceTc "end tcHsSigType }" (ppr ty)+       ; return ty }+  where+    skol_info = SigTypeSkol ctxt++tc_lhs_sig_type :: SkolemInfo -> LHsSigType GhcRn+               -> ContextKind -> TcM (Implication, TcType)+-- Kind-checks/desugars an 'LHsSigType',+--   solve equalities,+--   and then kind-generalizes.+-- This will never emit constraints, as it uses solveEqualities internally.+-- No validity checking or zonking+-- Returns also an implication for the unsolved constraints+tc_lhs_sig_type skol_info (L loc (HsSig { sig_bndrs = hs_outer_bndrs+                                       , sig_body = hs_ty })) ctxt_kind+  = setSrcSpanA loc $+    do { (tc_lvl, wanted, (outer_bndrs, ty))+              <- pushLevelAndSolveEqualitiesX "tc_lhs_sig_type" $+                 -- See Note [Failure in local type signatures]+                 tcOuterTKBndrs skol_info hs_outer_bndrs $+                 do { kind <- newExpectedKind ctxt_kind+                    ; tcLHsType hs_ty kind }+       -- Any remaining variables (unsolved in the solveEqualities)+       -- should be in the global tyvars, and therefore won't be quantified++       ; traceTc "tc_lhs_sig_type" (ppr hs_outer_bndrs $$ ppr outer_bndrs)+       ; (outer_tv_bndrs :: [InvisTVBinder]) <- scopedSortOuter outer_bndrs++       ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty++       ; kvs <- kindGeneralizeSome wanted ty1++       -- Build an implication for any as-yet-unsolved kind equalities+       -- See Note [Skolem escape in type signatures]+       ; implic <- buildTvImplication skol_info kvs tc_lvl wanted++       ; return (implic, mkInfForAllTys kvs ty1) }++{- Note [Skolem escape in type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcHsSigType is tricky.  Consider (T11142)+  foo :: forall b. (forall k (a :: k). SameKind a b) -> ()+This is ill-kinded because of a nested skolem-escape.++That will show up as an un-solvable constraint in the implication+returned by buildTvImplication in tc_lhs_sig_type.  See Note [Skolem+escape prevention] in GHC.Tc.Utils.TcType for why it is unsolvable+(the unification variable for b's kind is untouchable).++Then, in GHC.Tc.Solver.simplifyAndEmitFlatConstraints (called from tcHsSigType)+we'll try to float out the constraint, be unable to do so, and fail.+See GHC.Tc.Solver Note [Failure in local type signatures] for more+detail on this.++The separation between tcHsSigType and tc_lhs_sig_type is because+tcClassSigType wants to use the latter, but *not* fail fast, because+there are skolems from the class decl which are in scope; but it's fine+not to because tcClassDecl1 has a solveEqualities wrapped around all+the tcClassSigType calls.++That's why tcHsSigType does simplifyAndEmitFlatConstraints (which+fails fast) but tcClassSigType just does emitImplication (which does+not).  Ugh.++c.f. see also Note [Skolem escape and forall-types]. The difference+is that we don't need to simplify at a forall type, only at the+top level of a signature.+-}++-- Does validity checking and zonking.+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)+tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))+  = addSigCtxt ctxt ksig $+    do { kind <- tc_top_lhs_type KindLevel ctxt ksig+       ; checkValidType ctxt kind+       ; return (name, kind) }+  where+   ctxt = StandaloneKindSigCtxt name++tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+tcTopLHsType ctxt lsig_ty+  = tc_top_lhs_type TypeLevel ctxt lsig_ty++tc_top_lhs_type :: TypeOrKind -> UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- tc_top_lhs_type is used for kind-checking top-level LHsSigTypes where+--   we want to fully solve /all/ equalities, and report errors+-- Does zonking, but not validity checking because it's used+--   for things (like deriving and instances) that aren't+--   ordinary types+-- Used for both types and kinds+tc_top_lhs_type tyki ctxt (L loc sig_ty@(HsSig { sig_bndrs = hs_outer_bndrs+                                               , sig_body = body }))+  = setSrcSpanA loc $+    do { traceTc "tc_top_lhs_type {" (ppr sig_ty)+       ; (tclvl, wanted, (outer_bndrs, ty))+              <- pushLevelAndSolveEqualitiesX "tc_top_lhs_type"    $+                 tcOuterTKBndrs skol_info hs_outer_bndrs $+                 do { kind <- newExpectedKind (expectedKindInCtxt ctxt)+                    ; tc_lhs_type (mkMode tyki) body kind }++       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs+       ; let ty1 = mkInvisForAllTys outer_tv_bndrs ty++       ; kvs <- kindGeneralizeAll ty1  -- "All" because it's a top-level type+       ; reportUnsolvedEqualities skol_info kvs tclvl wanted++       ; ze       <- mkEmptyZonkEnv NoFlexi+       ; final_ty <- zonkTcTypeToTypeX ze (mkInfForAllTys kvs ty1)+       ; traceTc "tc_top_lhs_type }" (vcat [ppr sig_ty, ppr final_ty])+       ; return final_ty }+  where+    skol_info = SigTypeSkol ctxt++-----------------+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], Class, [Type], [Kind])+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+-- E.g.    class C (a::*) (b::k->k)+--         data T a b = ... deriving( C Int )+--    returns ([k], C, [k, Int], [k->k])+-- Return values are fully zonked+tcHsDeriv hs_ty+  = do { ty <- checkNoErrs $  -- Avoid redundant error report+                              -- with "illegal deriving", below+               tcTopLHsType DerivClauseCtxt hs_ty+       ; let (tvs, pred)    = splitForAllTyCoVars ty+             (kind_args, _) = splitFunTys (tcTypeKind pred)+       ; case getClassPredTys_maybe pred of+           Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)+           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }++-- | Typecheck a deriving strategy. For most deriving strategies, this is a+-- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.+tcDerivStrategy ::+     Maybe (LDerivStrategy GhcRn)+     -- ^ The deriving strategy+  -> TcM (Maybe (LDerivStrategy GhcTc), [TyVar])+     -- ^ The typechecked deriving strategy and the tyvars that it binds+     -- (if using 'ViaStrategy').+tcDerivStrategy mb_lds+  = case mb_lds of+      Nothing -> boring_case Nothing+      Just (L loc ds) ->+        setSrcSpan loc $ do+          (ds', tvs) <- tc_deriv_strategy ds+          pure (Just (L loc ds'), tvs)+  where+    tc_deriv_strategy :: DerivStrategy GhcRn+                      -> TcM (DerivStrategy GhcTc, [TyVar])+    tc_deriv_strategy (StockStrategy    _)+                                     = boring_case (StockStrategy noExtField)+    tc_deriv_strategy (AnyclassStrategy _)+                                     = boring_case (AnyclassStrategy noExtField)+    tc_deriv_strategy (NewtypeStrategy  _)+                                     = boring_case (NewtypeStrategy noExtField)+    tc_deriv_strategy (ViaStrategy ty) = do+      ty' <- checkNoErrs $ tcTopLHsType DerivClauseCtxt ty+      let (via_tvs, via_pred) = splitForAllTyCoVars ty'+      pure (ViaStrategy via_pred, via_tvs)++    boring_case :: ds -> TcM (ds, [TyVar])+    boring_case ds = pure (ds, [])++tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt+                -> LHsSigType GhcRn+                -> TcM Type+-- Like tcHsSigType, but for a class instance declaration+tcHsClsInstType user_ctxt hs_inst_ty+  = setSrcSpan (getLocA hs_inst_ty) $+    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so+         -- these constraints will never be solved later. And failing+         -- eagerly avoids follow-on errors when checkValidInstance+         -- sees an unsolved coercion hole+         inst_ty <- checkNoErrs $+                    tcTopLHsType user_ctxt hs_inst_ty+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty+       ; return inst_ty }++----------------------------------------------+-- | Type-check a visible type application+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type+-- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType+tcHsTypeApp wc_ty kind+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty+  = do { mode <- mkHoleMode TypeLevel HM_VTA+                 -- HM_VTA: See Note [Wildcards in visible type application]+       ; ty <- addTypeCtxt hs_ty                  $+               solveEqualities "tcHsTypeApp" $+               -- We are looking at a user-written type, very like a+               -- signature so we want to solve its equalities right now+               bindNamedWildCardBinders sig_wcs $ \ _ ->+               tc_lhs_type mode hs_ty kind++       -- We do not kind-generalize type applications: we just+       -- instantiate with exactly what the user says.+       -- See Note [No generalization in type application]+       -- We still must call kindGeneralizeNone, though, according+       -- to Note [Recipe for checking a signature]+       ; kindGeneralizeNone ty+       ; ty <- zonkTcType ty+       ; checkValidType TypeAppCtxt ty+       ; return ty }++{- Note [Wildcards in visible type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsWildCardBndrs's hswc_ext now only includes /named/ wildcards, so+any unnamed wildcards stay unchanged in hswc_body.  When called in+tcHsTypeApp, tcCheckLHsType will call emitAnonTypeHole+on these anonymous wildcards. However, this would trigger+error/warning when an anonymous wildcard is passed in as a visible type+argument, which we do not want because users should be able to write+@_ to skip a instantiating a type variable variable without fuss. The+solution is to switch the PartialTypeSignatures flags here to let the+typechecker know that it's checking a '@_' and do not emit hole+constraints on it.  See related Note [Wildcards in visible kind+application] and Note [The wildcard story for types] in GHC.Hs.Type++Ugh!++Note [No generalization in type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not kind-generalize type applications. Imagine++  id @(Proxy Nothing)++If we kind-generalized, we would get++  id @(forall {k}. Proxy @(Maybe k) (Nothing @k))++which is very sneakily impredicative instantiation.++There is also the possibility of mentioning a wildcard+(`id @(Proxy _)`), which definitely should not be kind-generalized.++-}++tcFamTyPats :: TyCon+            -> HsTyPats GhcRn                -- Patterns+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)+-- Check the LHS of a type/data family instance+-- e.g.   type instance F ty1 .. tyn = ...+-- Used for both type and data families+tcFamTyPats fam_tc hs_pats+  = do { traceTc "tcFamTyPats {" $+         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]++       ; mode <- mkHoleMode TypeLevel HM_FamPat+                 -- HM_FamPat: See Note [Wildcards in family instances] in+                 -- GHC.Rename.Module+       ; let fun_ty = mkTyConApp fam_tc []+       ; (fam_app, res_kind) <- tcInferTyApps mode lhs_fun fun_ty hs_pats++       -- Hack alert: see Note [tcFamTyPats: zonking the result kind]+       ; res_kind <- zonkTcType res_kind++       ; traceTc "End tcFamTyPats }" $+         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]++       ; return (fam_app, res_kind) }+  where+    fam_name  = tyConName fam_tc+    fam_arity = tyConArity fam_tc+    lhs_fun   = noLocA (HsTyVar noAnn NotPromoted (noLocA fam_name))++{- Note [tcFamTyPats: zonking the result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#19250)+    F :: forall k. k -> k+    type instance F (x :: Constraint) = ()++The tricky point is this:+  is that () an empty type tuple (() :: Type), or+  an empty constraint tuple (() :: Constraint)?+We work this out in a hacky way, by looking at the expected kind:+see Note [Inferring tuple kinds].++In this case, we kind-check the RHS using the kind gotten from the LHS:+see the call to tcCheckLHsType in tcTyFamInstEqnGuts in GHC.Tc.Tycl.++But we want the kind from the LHS to be /zonked/, so that when+kind-checking the RHS (tcCheckLHsType) we can "see" what we learned+from kind-checking the LHS (tcFamTyPats).  In our example above, the+type of the LHS is just `kappa` (by instantiating the forall k), but+then we learn (from x::Constraint) that kappa ~ Constraint.  We want+that info when kind-checking the RHS.++Easy solution: just zonk that return kind.  Of course this won't help+if there is lots of type-family reduction to do, but it works fine in+common cases.+-}+++{-+************************************************************************+*                                                                      *+            The main kind checker: no validity checks here+*                                                                      *+************************************************************************+-}++---------------------------+tcHsOpenType, tcHsLiftedType,+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType+-- Used for type signatures+-- Do not do validity checking+tcHsOpenType   hs_ty = addTypeCtxt hs_ty $ tcHsOpenTypeNC hs_ty+tcHsLiftedType hs_ty = addTypeCtxt hs_ty $ tcHsLiftedTypeNC hs_ty++tcHsOpenTypeNC   hs_ty = do { ek <- newOpenTypeKind; tcLHsType hs_ty ek }+tcHsLiftedTypeNC hs_ty = tcLHsType hs_ty liftedTypeKind++-- Like tcHsType, but takes an expected kind+tcCheckLHsType :: LHsType GhcRn -> ContextKind -> TcM TcType+tcCheckLHsType hs_ty exp_kind+  = addTypeCtxt hs_ty $+    do { ek <- newExpectedKind exp_kind+       ; tcLHsType hs_ty ek }++tcInferLHsType :: LHsType GhcRn -> TcM TcType+tcInferLHsType hs_ty+  = do { (ty,_kind) <- tcInferLHsTypeKind hs_ty+       ; return ty }++tcInferLHsTypeKind :: LHsType GhcRn -> TcM (TcType, TcKind)+-- Called from outside: set the context+-- Eagerly instantiate any trailing invisible binders+tcInferLHsTypeKind lhs_ty@(L loc hs_ty)+  = addTypeCtxt lhs_ty $+    setSrcSpanA loc    $  -- Cover the tcInstInvisibleTyBinders+    do { (res_ty, res_kind) <- tc_infer_hs_type typeLevelMode hs_ty+       ; tcInstInvisibleTyBinders res_ty res_kind }+  -- See Note [Do not always instantiate eagerly in types]++-- Used to check the argument of GHCi :kind+-- Allow and report wildcards, e.g. :kind T _+-- Do not saturate family applications: see Note [Dealing with :kind]+-- Does not instantiate eagerly; See Note [Do not always instantiate eagerly in types]+tcInferLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)+tcInferLHsTypeUnsaturated hs_ty+  = addTypeCtxt hs_ty $+    do { mode <- mkHoleMode TypeLevel HM_Sig  -- Allow and report holes+       ; case splitHsAppTys (unLoc hs_ty) of+           Just (hs_fun_ty, hs_args)+              -> do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+                    ; tcInferTyApps_nosat mode hs_fun_ty fun_ty hs_args }+                      -- Notice the 'nosat'; do not instantiate trailing+                      -- invisible arguments of a type family.+                      -- See Note [Dealing with :kind]+           Nothing -> tc_infer_lhs_type mode hs_ty }++{- Note [Dealing with :kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GHCi command+  ghci> type family F :: Either j k+  ghci> :kind F+  F :: forall {j,k}. Either j k++We will only get the 'forall' if we /refrain/ from saturating those+invisible binders. But generally we /do/ saturate those invisible+binders (see tcInferTyApps), and we want to do so for nested application+even in GHCi.  Consider for example (#16287)+  ghci> type family F :: k+  ghci> data T :: (forall k. k) -> Type+  ghci> :kind T F+We want to reject this. It's just at the very top level that we want+to switch off saturation.++So tcInferLHsTypeUnsaturated does a little special case for top level+applications.  Actually the common case is a bare variable, as above.++Note [Do not always instantiate eagerly in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terms are eagerly instantiated. This means that if you say++  x = id++then `id` gets instantiated to have type alpha -> alpha. The variable+alpha is then unconstrained and regeneralized. But we cannot do this+in types, as we have no type-level lambda. So, when we are sure+that we will not want to regeneralize later -- because we are done+checking a type, for example -- we can instantiate. But we do not+instantiate at variables, nor do we in tcInferLHsTypeUnsaturated,+which is used by :kind in GHCi.++************************************************************************+*                                                                      *+      Type-checking modes+*                                                                      *+************************************************************************++The kind-checker is parameterised by a TcTyMode, which contains some+information about where we're checking a type.++The renamer issues errors about what it can. All errors issued here must+concern things that the renamer can't handle.++-}++tcMult :: HsArrow GhcRn -> TcM Mult+tcMult hc = tc_mult typeLevelMode hc++-- | Info about the context in which we're checking a type. Currently,+-- differentiates only between types and kinds, but this will likely+-- grow, at least to include the distinction between patterns and+-- not-patterns.+--+-- To find out where the mode is used, search for 'mode_tyki'+--+-- This data type is purely local, not exported from this module+data TcTyMode+  = TcTyMode { mode_tyki :: TypeOrKind+             , mode_holes :: HoleInfo   }++-- See Note [Levels for wildcards]+-- Nothing <=> no wildcards expected+type HoleInfo = Maybe (TcLevel, HoleMode)++-- HoleMode says how to treat the occurrences+-- of anonymous wildcards; see tcAnonWildCardOcc+data HoleMode = HM_Sig      -- Partial type signatures: f :: _ -> Int+              | HM_FamPat   -- Family instances: F _ Int = Bool+              | HM_VTA      -- Visible type and kind application:+                            --   f @(Maybe _)+                            --   Maybe @(_ -> _)+              | HM_TyAppPat -- Visible type applications in patterns:+                            --   foo (Con @_ @t x) = ...+                            --   case x of Con @_ @t v -> ...++mkMode :: TypeOrKind -> TcTyMode+mkMode tyki = TcTyMode { mode_tyki = tyki, mode_holes = Nothing }++typeLevelMode, kindLevelMode :: TcTyMode+-- These modes expect no wildcards (holes) in the type+kindLevelMode = mkMode KindLevel+typeLevelMode = mkMode TypeLevel++mkHoleMode :: TypeOrKind -> HoleMode -> TcM TcTyMode+mkHoleMode tyki hm+  = do { lvl <- getTcLevel+       ; return (TcTyMode { mode_tyki  = tyki+                          , mode_holes = Just (lvl,hm) }) }++instance Outputable HoleMode where+  ppr HM_Sig      = text "HM_Sig"+  ppr HM_FamPat   = text "HM_FamPat"+  ppr HM_VTA      = text "HM_VTA"+  ppr HM_TyAppPat = text "HM_TyAppPat"++instance Outputable TcTyMode where+  ppr (TcTyMode { mode_tyki = tyki, mode_holes = hm })+    = text "TcTyMode" <+> braces (sep [ ppr tyki <> comma+                                      , ppr hm ])++{-+Note [Bidirectional type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In expressions, whenever we see a polymorphic identifier, say `id`, we are+free to instantiate it with metavariables, knowing that we can always+re-generalize with type-lambdas when necessary. For example:++  rank2 :: (forall a. a -> a) -> ()+  x = rank2 id++When checking the body of `x`, we can instantiate `id` with a metavariable.+Then, when we're checking the application of `rank2`, we notice that we really+need a polymorphic `id`, and then re-generalize over the unconstrained+metavariable.++In types, however, we're not so lucky, because *we cannot re-generalize*!+There is no lambda. So, we must be careful only to instantiate at the last+possible moment, when we're sure we're never going to want the lost polymorphism+again. This is done in calls to tcInstInvisibleTyBinders.++To implement this behavior, we use bidirectional type checking, where we+explicitly think about whether we know the kind of the type we're checking+or not. Note that there is a difference between not knowing a kind and+knowing a metavariable kind: the metavariables are TauTvs, and cannot become+forall-quantified kinds. Previously (before dependent types), there were+no higher-rank kinds, and so we could instantiate early and be sure that+no types would have polymorphic kinds, and so we could always assume that+the kind of a type was a fresh metavariable. Not so anymore, thus the+need for two algorithms.++For HsType forms that can never be kind-polymorphic, we implement only the+"down" direction, where we safely assume a metavariable kind. For HsType forms+that *can* be kind-polymorphic, we implement just the "up" (functions with+"infer" in their name) version, as we gain nothing by also implementing the+"down" version.++Note [Future-proofing the type checker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As discussed in Note [Bidirectional type checking], each HsType form is+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions+are mutually recursive, so that either one can work for any type former.+But, we want to make sure that our pattern-matches are complete. So,+we have a bunch of repetitive code just so that we get warnings if we're+missing any patterns.++-}++------------------------------------------+-- | Check and desugar a type, returning the core type and its+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression+-- level.+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+tc_infer_lhs_type mode (L span ty)+  = setSrcSpanA span $+    tc_infer_hs_type mode ty++---------------------------+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+tc_infer_hs_type_ek mode hs_ty ek+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty+       ; checkExpectedKind hs_ty ty k ek }++---------------------------+-- | Infer the kind of a type and desugar. This is the "up" type-checker,+-- as described in Note [Bidirectional type checking]+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)++tc_infer_hs_type mode (HsParTy _ t)+  = tc_infer_lhs_type mode t++tc_infer_hs_type mode ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty+  = do { (fun_ty, _ki) <- tcInferTyAppHead mode hs_fun_ty+       ; tcInferTyApps mode hs_fun_ty fun_ty hs_args }++tc_infer_hs_type mode (HsKindSig _ ty sig)+  = do { let mode' = mode { mode_tyki = KindLevel }+       ; sig' <- tc_lhs_kind_sig mode' KindSigCtxt sig+                 -- We must typecheck the kind signature, and solve all+                 -- its equalities etc; from this point on we may do+                 -- things like instantiate its foralls, so it needs+                 -- to be fully determined (#14904)+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')+       ; ty' <- tc_lhs_type mode ty sig'+       ; return (ty', sig') }++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType' to communicate+-- the splice location to the typechecker. Here we skip over it in order to have+-- the same kind inferred for a given expression whether it was produced from+-- splices or not.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))+  = tc_infer_hs_type mode ty++tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty++-- See Note [Typechecking HsCoreTys]+tc_infer_hs_type _ (XHsType ty)+  = do env <- getLclEnv+       -- Raw uniques since we go from NameEnv to TvSubstEnv.+       let subst_prs :: [(Unique, TcTyVar)]+           subst_prs = [ (getUnique nm, tv)+                       | ATyVar nm tv <- nameEnvElts (tcl_env env) ]+           subst = mkTvSubst+                     (mkInScopeSet $ mkVarSet $ map snd subst_prs)+                     (listToUFM_Directly $ map (liftSnd mkTyVarTy) subst_prs)+           ty' = substTy subst ty+       return (ty', tcTypeKind ty')++tc_infer_hs_type _ (HsExplicitListTy _ _ tys)+  | null tys  -- this is so that we can use visible kind application with '[]+              -- e.g ... '[] @Bool+  = return (mkTyConTy promotedNilDataCon,+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)++tc_infer_hs_type mode other_ty+  = do { kv <- newMetaKindVar+       ; ty' <- tc_hs_type mode other_ty kv+       ; return (ty', kv) }++{-+Note [Typechecking HsCoreTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsCoreTy is an escape hatch that allows embedding Core Types in HsTypes.+As such, there's not much to be done in order to typecheck an HsCoreTy,+since it's already been typechecked to some extent. There is one thing that+we must do, however: we must substitute the type variables from the tcl_env.+To see why, consider GeneralizedNewtypeDeriving, which is one of the main+clients of HsCoreTy (example adapted from #14579):++  newtype T a = MkT a deriving newtype Eq++This will produce an InstInfo GhcPs that looks roughly like this:++  instance forall a_1. Eq a_1 => Eq (T a_1) where+    (==) = coerce @(  a_1 ->   a_1 -> Bool) -- The type within @(...) is an HsCoreTy+                  @(T a_1 -> T a_1 -> Bool) -- So is this+                  (==)++This is then fed into the renamer. Since all of the type variables in this+InstInfo use Exact RdrNames, the resulting InstInfo GhcRn looks basically+identical. Things get more interesting when the InstInfo is fed into the+typechecker, however. GHC will first generate fresh skolems to instantiate+the instance-bound type variables with. In the example above, we might generate+the skolem a_2 and use that to instantiate a_1, which extends the local type+environment (tcl_env) with [a_1 :-> a_2]. This gives us:++  instance forall a_2. Eq a_2 => Eq (T a_2) where ...++To ensure that the body of this instance is well scoped, every occurrence of+the `a` type variable should refer to a_2, the new skolem. However, the+HsCoreTys mention a_1, not a_2. Luckily, the tcl_env provides exactly the+substitution we need ([a_1 :-> a_2]) to fix up the scoping. We apply this+substitution to each HsCoreTy and all is well:++  instance forall a_2. Eq a_2 => Eq (T a_2) where+    (==) = coerce @(  a_2 ->   a_2 -> Bool)+                  @(T a_2 -> T a_2 -> Bool)+                  (==)+-}++------------------------------------------+tcLHsType :: LHsType GhcRn -> TcKind -> TcM TcType+tcLHsType hs_ty exp_kind+  = tc_lhs_type typeLevelMode hs_ty exp_kind++tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType+tc_lhs_type mode (L span ty) exp_kind+  = setSrcSpanA span $+    tc_hs_type mode ty exp_kind++tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+-- See Note [Bidirectional type checking]++tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type _ ty@(HsBangTy _ bang _) _+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+    -- bangs are invalid, so fail. (#7210, #14761)+    = do { let bangError err = failWith $+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$+                 text err <+> text "annotation cannot appear nested inside a type"+         ; case bang of+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"+             HsSrcBang _ _ _                   -> bangError "strictness" }+tc_hs_type _ ty@(HsRecTy {})      _+      -- Record types (which only show up temporarily in constructor+      -- signatures) should have been removed by now+    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)++-- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'.+-- Here we get rid of it and add the finalizers to the global environment+-- while capturing the local environment.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))+           exp_kind+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_hs_type mode ty exp_kind++-- This should never happen; type splices are expanded by the renamer+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind+  = failWithTc (text "Unexpected type splice:" <+> ppr ty)++---------- Functions and applications+tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind+  = tc_fun_type mode mult ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind+  | op `hasKey` funTyConKey+  = tc_fun_type mode (HsUnrestrictedArrow NormalSyntax) ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode (HsForAllTy { hst_tele = tele, hst_body = ty }) exp_kind+  = do { (tv_bndrs, ty') <- tcTKTelescope mode tele $+                            tc_lhs_type mode ty exp_kind+                 -- Pass on the mode from the type, to any wildcards+                 -- in kind signatures on the forall'd variables+                 -- e.g.      f :: _ -> Int -> forall (a :: _). blah+                 -- Why exp_kind?  See Note [Body kind of HsForAllTy]++       -- Do not kind-generalise here!  See Note [Kind generalisation]++       ; return (mkForAllTys tv_bndrs ty') }++tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind+  | null (fromMaybeContext ctxt)+  = tc_lhs_type mode rn_ty exp_kind++  -- See Note [Body kind of a HsQualTy]+  | tcIsConstraintKind exp_kind+  = do { ctxt' <- tc_hs_context mode ctxt+       ; ty'   <- tc_lhs_type mode rn_ty constraintKind+       ; return (mkPhiTy ctxt' ty') }++  | otherwise+  = do { ctxt' <- tc_hs_context mode ctxt++       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can+                                -- be TYPE r, for any r, hence newOpenTypeKind+       ; ty' <- tc_lhs_type mode rn_ty ek+       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')+                           liftedTypeKind exp_kind }++--------- Lists, arrays, and tuples+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon listTyCon+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }++-- See Note [Distinguishing tuple kinds] in GHC.Hs.Type+-- See Note [Inferring tuple kinds]+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpanA loc $+                            checkExpectedKind hs_ty ty kind arg_kind+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }+++tc_hs_type mode rn_ty@(HsTupleTy _ HsUnboxedTuple tys) exp_kind+  = tc_tuple rn_ty mode UnboxedTuple tys exp_kind++tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind+  = do { let arity = length hs_tys+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; let arg_reps = map kindRep arg_kinds+             arg_tys  = arg_reps ++ tau_tys+             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys+             sum_kind = unboxedSumKind arg_reps+       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind+       }++--------- Promoted lists and tuples+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind+  = do { tks <- mapM (tc_infer_lhs_type mode) tys+       ; (taus', kind) <- unifyKinds tys tks+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }+  where+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]++tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind+  -- using newMetaKindVar means that we force instantiations of any polykinded+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.+  = do { ks   <- replicateM arity newMetaKindVar+       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; let kind_con   = tupleTyCon           Boxed arity+             ty_con     = promotedTupleDataCon Boxed arity+             tup_k      = mkTyConApp kind_con ks+       ; checkTupSize arity+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+  where+    arity = length tys++--------- Constraint types+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind+  = do { MASSERT( isTypeLevel (mode_tyki mode) )+       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; let n' = mkStrLitTy $ hsIPNameFS n+       ; ipClass <- tcLookupClass ipClassName+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])+                           constraintKind exp_kind }++tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to+  -- handle it in 'coreView' and 'tcView'.+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind++--------- Literals+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind+  = do { checkWiredInTyCon naturalTyCon+       ; checkExpectedKind rn_ty (mkNumLitTy n) naturalTy exp_kind }++tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind+  = do { checkWiredInTyCon typeSymbolKindCon+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }+tc_hs_type _ rn_ty@(HsTyLit _ (HsCharTy _ c)) exp_kind+  = do { checkWiredInTyCon charTyCon+       ; checkExpectedKind rn_ty (mkCharLitTy c) charTy exp_kind }++--------- Wildcards++tc_hs_type mode ty@(HsWildCardTy _)        ek+  = tcAnonWildCardOcc NoExtraConstraint mode ty ek++--------- Potentially kind-polymorphic types: call the "up" checker+-- See Note [Future-proofing the type checker]+tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(XHsType {})            ek = tc_infer_hs_type_ek mode ty ek++{-+Note [Variable Specificity and Forall Visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A HsForAllTy contains an HsForAllTelescope to denote the visibility of the forall+binder. Furthermore, each invisible type variable binder also has a+Specificity. Together, these determine the variable binders (ArgFlag) for each+variable in the generated ForAllTy type.++This table summarises this relation:+----------------------------------------------------------------------------+| User-written type         HsForAllTelescope   Specificity        ArgFlag+|---------------------------------------------------------------------------+| f :: forall a. type       HsForAllInvis       SpecifiedSpec      Specified+| f :: forall {a}. type     HsForAllInvis       InferredSpec       Inferred+| f :: forall a -> type     HsForAllVis         SpecifiedSpec      Required+| f :: forall {a} -> type   HsForAllVis         InferredSpec       /+|   This last form is non-sensical and is thus rejected.+----------------------------------------------------------------------------++For more information regarding the interpretation of the resulting ArgFlag, see+Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep".+-}++------------------------------------------+tc_mult :: TcTyMode -> HsArrow GhcRn -> TcM Mult+tc_mult mode ty = tc_lhs_type mode (arrowToHsType ty) multiplicityTy+------------------------------------------+tc_fun_type :: TcTyMode -> HsArrow GhcRn -> LHsType GhcRn -> LHsType GhcRn -> TcKind+            -> TcM TcType+tc_fun_type mode mult ty1 ty2 exp_kind = case mode_tyki mode of+  TypeLevel ->+    do { arg_k <- newOpenTypeKind+       ; res_k <- newOpenTypeKind+       ; ty1' <- tc_lhs_type mode ty1 arg_k+       ; ty2' <- tc_lhs_type mode ty2 res_k+       ; mult' <- tc_mult mode mult+       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+                           liftedTypeKind exp_kind }+  KindLevel ->  -- no representation polymorphism in kinds. yet.+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind+       ; mult' <- tc_mult mode mult+       ; checkExpectedKind (HsFunTy noAnn mult ty1 ty2) (mkVisFunTy mult' ty1' ty2')+                           liftedTypeKind exp_kind }++{- Note [Skolem escape and forall-types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Checking telescopes].++Consider+  f :: forall a. (forall kb (b :: kb). Proxy '[a, b]) -> ()++The Proxy '[a,b] forces a and b to have the same kind.  But a's+kind must be bound outside the 'forall a', and hence escapes.+We discover this by building an implication constraint for+each forall.  So the inner implication constraint will look like+    forall kb (b::kb).  kb ~ ka+where ka is a's kind.  We can't unify these two, /even/ if ka is+unification variable, because it would be untouchable inside+this inner implication.++That's what the pushLevelAndCaptureConstraints, plus subsequent+buildTvImplication/emitImplication is all about, when kind-checking+HsForAllTy.++Note that++* We don't need to /simplify/ the constraints here+  because we aren't generalising. We just capture them.++* We can't use emitResidualTvConstraint, because that has a fast-path+  for empty constraints.  We can't take that fast path here, because+  we must do the bad-telescope check even if there are no inner wanted+  constraints. See Note [Checking telescopes] in+  GHC.Tc.Types.Constraint.  Lacking this check led to #16247.+-}++{- *********************************************************************+*                                                                      *+                Tuples+*                                                                      *+********************************************************************* -}++---------------------------+tupKindSort_maybe :: TcKind -> Maybe TupleSort+tupKindSort_maybe k+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'+  | Just k'      <- tcView k            = tupKindSort_maybe k'+  | tcIsConstraintKind k = Just ConstraintTuple+  | tcIsLiftedTypeKind k   = Just BoxedTuple+  | otherwise            = Nothing++tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType+tc_tuple rn_ty mode tup_sort tys exp_kind+  = do { arg_kinds <- case tup_sort of+           BoxedTuple      -> return (replicate arity liftedTypeKind)+           UnboxedTuple    -> replicateM arity newOpenTypeKind+           ConstraintTuple -> return (replicate arity constraintKind)+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }+  where+    arity   = length tys++finish_tuple :: HsType GhcRn+             -> TupleSort+             -> [TcType]    -- ^ argument types+             -> [TcKind]    -- ^ of these kinds+             -> TcKind      -- ^ expected kind of the whole tuple+             -> TcM TcType+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind = do+  traceTc "finish_tuple" (ppr tup_sort $$ ppr tau_kinds $$ ppr exp_kind)+  case tup_sort of+    ConstraintTuple+      |  [tau_ty] <- tau_tys+         -- Drop any uses of 1-tuple constraints here.+         -- See Note [Ignore unary constraint tuples]+      -> check_expected_kind tau_ty constraintKind+      |  otherwise+      -> do let tycon = cTupleTyCon arity+            checkCTupSize arity+            check_expected_kind (mkTyConApp tycon tau_tys) constraintKind+    BoxedTuple -> do+      let tycon = tupleTyCon Boxed arity+      checkTupSize arity+      checkWiredInTyCon tycon+      check_expected_kind (mkTyConApp tycon tau_tys) liftedTypeKind+    UnboxedTuple -> do+      let tycon    = tupleTyCon Unboxed arity+          tau_reps = map kindRep tau_kinds+          -- See also Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+          arg_tys  = tau_reps ++ tau_tys+          res_kind = unboxedTupleKind tau_reps+      checkTupSize arity+      check_expected_kind (mkTyConApp tycon arg_tys) res_kind+  where+    arity = length tau_tys+    check_expected_kind ty act_kind =+      checkExpectedKind rn_ty ty act_kind exp_kind++{-+Note [Ignore unary constraint tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC provides unary tuples and unboxed tuples (see Note [One-tuples] in+GHC.Builtin.Types) but does *not* provide unary constraint tuples. Why? First,+recall the definition of a unary tuple data type:++  data Solo a = Solo a++Note that `Solo a` is *not* the same thing as `a`, since Solo is boxed and+lazy. Therefore, the presence of `Solo` matters semantically. On the other+hand, suppose we had a unary constraint tuple:++  class a => Solo% a++This compiles down a newtype (i.e., a cast) in Core, so `Solo% a` is+semantically equivalent to `a`. Therefore, a 1-tuple constraint would have+no user-visible impact, nor would it allow you to express anything that+you couldn't otherwise.++We could simply add Solo% for consistency with tuples (Solo) and unboxed+tuples (Solo#), but that would require even more magic to wire in another+magical class, so we opt not to do so. We must be careful, however, since+one can try to sneak in uses of unary constraint tuples through Template+Haskell, such as in this program (from #17511):++  f :: $(pure (ForallT [] [TupleT 1 `AppT` (ConT ''Show `AppT` ConT ''Int)]+                       (ConT ''String)))+  -- f :: Solo% (Show Int) => String+  f = "abc"++This use of `TupleT 1` will produce an HsBoxedOrConstraintTuple of arity 1,+and since it is used in a Constraint position, GHC will attempt to treat+it as thought it were a constraint tuple, which can potentially lead to+trouble if one attempts to look up the name of a constraint tuple of arity+1 (as it won't exist). To avoid this trouble, we simply take any unary+constraint tuples discovered when typechecking and drop them—i.e., treat+"Solo% a" as though the user had written "a". This is always safe to do+since the two constraints should be semantically equivalent.+-}++{- *********************************************************************+*                                                                      *+                Type applications+*                                                                      *+********************************************************************* -}++splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])+splitHsAppTys hs_ty+  | is_app hs_ty = Just (go (noLocA hs_ty) [])+  | otherwise    = Nothing+  where+    is_app :: HsType GhcRn -> Bool+    is_app (HsAppKindTy {})        = True+    is_app (HsAppTy {})            = True+    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)+      -- I'm not sure why this funTyConKey test is necessary+      -- Can it even happen?  Perhaps for   t1 `(->)` t2+      -- but then maybe it's ok to treat that like a normal+      -- application rather than using the special rule for HsFunTy+    is_app (HsTyVar {})            = True+    is_app (HsParTy _ (L _ ty))    = is_app ty+    is_app _                       = False++    go :: LHsType GhcRn+       -> [HsArg (LHsType GhcRn) (LHsKind GhcRn)]+       -> (LHsType GhcRn,+           [HsArg (LHsType GhcRn) (LHsKind GhcRn)]) -- AZ temp+    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)+    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)+    go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)+    go (L _  (HsOpTy _ l op@(L sp _) r)) as+      = ( L (na2la sp) (HsTyVar noAnn NotPromoted op)+        , HsValArg l : HsValArg r : as )+    go f as = (f, as)++---------------------------+tcInferTyAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+-- Version of tc_infer_lhs_type specialised for the head of an+-- application. In particular, for a HsTyVar (which includes type+-- constructors, it does not zoom off into tcInferTyApps and family+-- saturation+tcInferTyAppHead mode (L _ (HsTyVar _ _ (L _ tv)))+  = tcTyVar mode tv+tcInferTyAppHead mode ty+  = tc_infer_lhs_type mode ty++---------------------------+-- | Apply a type of a given kind to a list of arguments. This instantiates+-- invisible parameters as necessary. Always consumes all the arguments,+-- using matchExpectedFunKind as necessary.+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-+-- These kinds should be used to instantiate invisible kind variables;+-- they come from an enclosing class for an associated type/data family.+--+-- tcInferTyApps also arranges to saturate any trailing invisible arguments+--   of a type-family application, which is usually the right thing to do+-- tcInferTyApps_nosat does not do this saturation; it is used only+--   by ":kind" in GHCi+tcInferTyApps, tcInferTyApps_nosat+    :: TcTyMode+    -> LHsType GhcRn        -- ^ Function (for printing only)+    -> TcType               -- ^ Function+    -> [LHsTypeArg GhcRn]   -- ^ Args+    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)+tcInferTyApps mode hs_ty fun hs_args+  = do { (f_args, res_k) <- tcInferTyApps_nosat mode hs_ty fun hs_args+       ; saturateFamApp f_args res_k }++tcInferTyApps_nosat mode orig_hs_ty fun orig_hs_args+  = do { traceTc "tcInferTyApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)+       ; (f_args, res_k) <- go_init 1 fun orig_hs_args+       ; traceTc "tcInferTyApps }" (ppr f_args <+> dcolon <+> ppr res_k)+       ; return (f_args, res_k) }+  where++    -- go_init just initialises the auxiliary+    -- arguments of the 'go' loop+    go_init n fun all_args+      = go n fun empty_subst fun_ki all_args+      where+        fun_ki = tcTypeKind fun+           -- We do (tcTypeKind fun) here, even though the caller+           -- knows the function kind, to absolutely guarantee+           -- INVARIANT for 'go'+           -- Note that in a typical application (F t1 t2 t3),+           -- the 'fun' is just a TyCon, so tcTypeKind is fast++        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfType fun_ki++    go :: Int             -- The # of the next argument+       -> TcType          -- Function applied to some args+       -> TCvSubst        -- Applies to function kind+       -> TcKind          -- Function kind+       -> [LHsTypeArg GhcRn]    -- Un-type-checked args+       -> TcM (TcType, TcKind)  -- Result type and its kind+    -- INVARIANT: in any call (go n fun subst fun_ki args)+    --               tcTypeKind fun  =  subst(fun_ki)+    -- So the 'subst' and 'fun_ki' arguments are simply+    -- there to avoid repeatedly calling tcTypeKind.+    --+    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant+    -- it's important that if fun_ki has a forall, then so does+    -- (tcTypeKind fun), because the next thing we are going to do+    -- is apply 'fun' to an argument type.++    -- Dispatch on all_args first, for performance reasons+    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of++      ---------------- No user-written args left. We're done!+      ([], _) -> return (fun, substTy subst fun_ki)++      ---------------- HsArgPar: We don't care about parens here+      (HsArgPar _ : args, _) -> go n fun subst fun_ki args++      ---------------- HsTypeArg: a kind application (fun @ki)+      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->+        case ki_binder of++        -- FunTy with PredTy on LHS, or ForAllTy with Inferred+        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki+        Anon InvisArg _         -> instantiate ki_binder inner_ki++        Named (Bndr _ Specified) ->  -- Visible kind application+          do { traceTc "tcInferTyApps (vis kind app)"+                       (vcat [ ppr ki_binder, ppr hs_ki_arg+                             , ppr (tyBinderType ki_binder)+                             , ppr subst ])++             ; let exp_kind = substTy subst $ tyBinderType ki_binder+             ; arg_mode <- mkHoleMode KindLevel HM_VTA+                   -- HM_VKA: see Note [Wildcards in visible kind application]+             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+                         tc_lhs_type arg_mode hs_ki_arg exp_kind++             ; traceTc "tcInferTyApps (vis kind app)" (ppr exp_kind)+             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg+             ; go (n+1) fun' subst' inner_ki hs_args }++        -- Attempted visible kind application (fun @ki), but fun_ki is+        --   forall k -> blah   or   k1 -> k2+        -- So we need a normal application.  Error.+        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki++      -- No binder; try applying the substitution, or fail if that's not possible+      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $+                                           ty_app_err ki_arg substed_fun_ki++      ---------------- HsValArg: a normal argument (fun ty)+      (HsValArg arg : args, Just (ki_binder, inner_ki))+        -- next binder is invisible; need to instantiate it+        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;+                                        -- or ForAllTy with Inferred or Specified+         -> instantiate ki_binder inner_ki++        -- "normal" case+        | otherwise+         -> do { traceTc "tcInferTyApps (vis normal app)"+                          (vcat [ ppr ki_binder+                                , ppr arg+                                , ppr (tyBinderType ki_binder)+                                , ppr subst ])+                ; let exp_kind = substTy subst $ tyBinderType ki_binder+                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $+                          tc_lhs_type mode arg exp_kind+                ; traceTc "tcInferTyApps (vis normal app) 2" (ppr exp_kind)+                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'+                ; go (n+1) fun' subst' inner_ki args }++          -- no binder; try applying the substitution, or infer another arrow in fun kind+      (HsValArg _ : _, Nothing)+        -> try_again_after_substing_or $+           do { let arrows_needed = n_initial_val_args all_args+              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki++              ; fun' <- zonkTcType (fun `mkTcCastTy` co)+                     -- This zonk is essential, to expose the fruits+                     -- of matchExpectedFunKind to the 'go' loop++              ; traceTc "tcInferTyApps (no binder)" $+                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki+                        , ppr arrows_needed+                        , ppr co+                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]+              ; go_init n fun' all_args }+                -- Use go_init to establish go's INVARIANT+      where+        instantiate ki_binder inner_ki+          = do { traceTc "tcInferTyApps (need to instantiate)"+                         (vcat [ ppr ki_binder, ppr subst])+               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder+               ; go n (mkAppTy fun arg') subst' inner_ki all_args }+                 -- Because tcInvisibleTyBinder instantiate ki_binder,+                 -- the kind of arg' will have the same shape as the kind+                 -- of ki_binder.  So we don't need mkAppTyM here.++        try_again_after_substing_or fallthrough+          | not (isEmptyTCvSubst subst)+          = go n fun zapped_subst substed_fun_ki all_args+          | otherwise+          = fallthrough++        zapped_subst   = zapTCvSubst subst+        substed_fun_ki = substTy subst fun_ki+        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)++    n_initial_val_args :: [HsArg tm ty] -> Arity+    -- Count how many leading HsValArgs we have+    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args+    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args+    n_initial_val_args _                    = 0++    ty_app_err arg ty+      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)+                $$ text "to visible kind argument" <+> quotes (ppr arg)+++mkAppTyM :: TCvSubst+         -> TcType -> TyCoBinder    -- fun, plus its top-level binder+         -> TcType                  -- arg+         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)+-- Precondition: the application (fun arg) is well-kinded after zonking+--               That is, the application makes sense+--+-- Precondition: for (mkAppTyM subst fun bndr arg)+--       tcTypeKind fun  =  Pi bndr. body+--  That is, fun always has a ForAllTy or FunTy at the top+--           and 'bndr' is fun's pi-binder+--+-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type+--                invariant, then so does the result type (fun arg)+--+-- We do not require that+--    tcTypeKind arg = tyVarKind (binderVar bndr)+-- This must be true after zonking (precondition 1), but it's not+-- required for the (PKTI).+mkAppTyM subst fun ki_binder arg+  | -- See Note [mkAppTyM]: Nasty case 2+    TyConApp tc args <- fun+  , isTypeSynonymTyCon tc+  , args `lengthIs` (tyConArity tc - 1)+  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym+  = do { arg'  <- zonkTcType  arg+       ; args' <- zonkTcTypes args+       ; let subst' = case ki_binder of+                        Anon {}           -> subst+                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'+       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }+++mkAppTyM subst fun (Anon {}) arg+   = return (subst, mk_app_ty fun arg)++mkAppTyM subst fun (Named (Bndr tv _)) arg+  = do { arg' <- if isTrickyTvBinder tv+                 then -- See Note [mkAppTyM]: Nasty case 1+                      zonkTcType arg+                 else return     arg+       ; return ( extendTvSubstAndInScope subst tv arg'+                , mk_app_ty fun arg' ) }++mk_app_ty :: TcType -> TcType -> TcType+-- This function just adds an ASSERT for mkAppTyM's precondition+mk_app_ty fun arg+  = ASSERT2( isPiTy fun_kind+           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )+    mkAppTy fun arg+  where+    fun_kind = tcTypeKind fun++isTrickyTvBinder :: TcTyVar -> Bool+-- NB: isTrickyTvBinder is just an optimisation+-- It would be absolutely sound to return True always+isTrickyTvBinder tv = isPiTy (tyVarKind tv)++{- Note [The Purely Kinded Type Invariant (PKTI)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type inference, we maintain this invariant++ (PKTI) It is legal to call 'tcTypeKind' on any Type ty,+        on any sub-term of ty, /without/ zonking ty++        Moreover, any such returned kind+        will itself satisfy (PKTI)++By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".+The way in which tcTypeKind can crash is in applications+    (a t1 t2 .. tn)+if 'a' is a type variable whose kind doesn't have enough arrows+or foralls.  (The crash is in piResultTys.)++The loop in tcInferTyApps has to be very careful to maintain the (PKTI).+For example, suppose+    kappa is a unification variable+    We have already unified kappa := Type+      yielding    co :: Refl (Type -> Type)+    a :: kappa+then consider the type+    (a Int)+If we call tcTypeKind on that, we'll crash, because the (un-zonked)+kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.++So the type inference engine is very careful when building applications.+This happens in tcInferTyApps. Suppose we are kind-checking the type (a Int),+where (a :: kappa).  Then in tcInferApps we'll run out of binders on+a's kind, so we'll call matchExpectedFunKind, and unify+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)+At this point we must zonk the function type to expose the arrrow, so+that (a Int) will satisfy (PKTI).++The absence of this caused #14174 and #14520.++The calls to mkAppTyM is the other place we are very careful.++Note [mkAppTyM]+~~~~~~~~~~~~~~~+mkAppTyM is trying to guarantee the Purely Kinded Type Invariant+(PKTI) for its result type (fun arg).  There are two ways it can go wrong:++* Nasty case 1: forall types (polykinds/T14174a)+    T :: forall (p :: *->*). p Int -> p Bool+  Now kind-check (T x), where x::kappa.+  Well, T and x both satisfy the PKTI, but+     T x :: x Int -> x Bool+  and (x Int) does /not/ satisfy the PKTI.++* Nasty case 2: type synonyms+    type S f a = f a+  Even though (S ff aa) would satisfy the (PKTI) if S was a data type+  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)+  if S is a type synonym, because the /expansion/ of (S ff aa) is+  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps+  (ff :: kappa), where 'kappa' has already been unified with (*->*).++  We check for nasty case 2 on the final argument of a type synonym.++Notice that in both cases the trickiness only happens if the+bound variable has a pi-type.  Hence isTrickyTvBinder.+-}+++saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)+-- Precondition for (saturateFamApp ty kind):+--     tcTypeKind ty = kind+--+-- If 'ty' is an unsaturated family application with trailing+-- invisible arguments, instantiate them.+-- See Note [saturateFamApp]++saturateFamApp ty kind+  | Just (tc, args) <- tcSplitTyConApp_maybe ty+  , mustBeSaturated tc+  , let n_to_inst = tyConArity tc - length args+  = do { (extra_args, ki') <- tcInstInvisibleTyBindersN n_to_inst kind+       ; return (ty `mkTcAppTys` extra_args, ki') }+  | otherwise+  = return (ty, kind)++{- Note [saturateFamApp]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type family F :: Either j k+   type instance F @Type = Right Maybe+   type instance F @Type = Right Either```++Then F :: forall {j,k}. Either j k++The two type instances do a visible kind application that instantiates+'j' but not 'k'.  But we want to end up with instances that look like+  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe++so that F has arity 2.  We must instantiate that trailing invisible+binder. In general, Invisible binders precede Specified and Required,+so this is only going to bite for apparently-nullary families.++Note that+  type family F2 :: forall k. k -> *+is quite different and really does have arity 0.++It's not just type instances where we need to saturate those+unsaturated arguments: see #11246.  Hence doing this in tcInferApps.+-}++appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn+appTypeToArg f []                       = f+appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args+appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args+appTypeToArg f (HsTypeArg l arg : args)+  = appTypeToArg (mkHsAppKindTy l f arg) args+++{- *********************************************************************+*                                                                      *+                checkExpectedKind+*                                                                      *+********************************************************************* -}++-- | This instantiates invisible arguments for the type being checked if it must+-- be saturated and is not yet saturated. It then calls and uses the result+-- from checkExpectedKindX to build the final type+checkExpectedKind :: HasDebugCallStack+                  => HsType GhcRn       -- ^ type we're checking (for printing)+                  -> TcType             -- ^ type we're checking+                  -> TcKind             -- ^ the known kind of that type+                  -> TcKind             -- ^ the expected kind+                  -> TcM TcType+-- Just a convenience wrapper to save calls to 'ppr'+checkExpectedKind hs_ty ty act_kind exp_kind+  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)++       ; (new_args, act_kind') <- tcInstInvisibleTyBindersN n_to_inst act_kind++       ; let origin = TypeEqOrigin { uo_actual   = act_kind'+                                   , uo_expected = exp_kind+                                   , uo_thing    = Just (ppr hs_ty)+                                   , uo_visible  = True } -- the hs_ty is visible++       ; traceTc "checkExpectedKindX" $+         vcat [ ppr hs_ty+              , text "act_kind':" <+> ppr act_kind'+              , text "exp_kind:" <+> ppr exp_kind ]++       ; let res_ty = ty `mkTcAppTys` new_args++       ; if act_kind' `tcEqType` exp_kind+         then return res_ty  -- This is very common+         else do { co_k <- uType KindLevel origin act_kind' exp_kind+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind+                                                     , ppr exp_kind+                                                     , ppr co_k ])+                ; return (res_ty `mkTcCastTy` co_k) } }+    where+      -- We need to make sure that both kinds have the same number of implicit+      -- foralls out front. If the actual kind has more, instantiate accordingly.+      -- Otherwise, just pass the type & kind through: the errors are caught+      -- in unifyType.+      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind+      n_act_invis_bndrs = invisibleTyBndrCount act_kind+      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs++---------------------------++tcHsContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]+tcHsContext cxt = tc_hs_context typeLevelMode cxt++tcLHsPredType :: LHsType GhcRn -> TcM PredType+tcLHsPredType pred = tc_lhs_pred typeLevelMode pred++tc_hs_context :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM [PredType]+tc_hs_context _ Nothing = return []+tc_hs_context mode (Just ctxt) = mapM (tc_lhs_pred mode) (unLoc ctxt)++tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind++---------------------------+tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)+-- See Note [Type checking recursive type and class declarations]+-- in GHC.Tc.TyCl+-- This does not instantiate. See Note [Do not always instantiate eagerly in types]+tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon+  = do { traceTc "lk1" (ppr name)+       ; thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)++           -- See Note [Recursion through the kinds]+           ATcTyCon tc_tc+             -> do { check_tc tc_tc+                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }++           AGlobal (ATyCon tc)+             -> do { check_tc tc+                   ; return (mkTyConTy tc, tyConKind tc) }++           AGlobal (AConLike (RealDataCon dc))+             -> do { data_kinds <- xoptM LangExt.DataKinds+                   ; unless (data_kinds || specialPromotedDc dc) $+                       promotionErr name NoDataKindsDC+                   ; when (isFamInstTyCon (dataConTyCon dc)) $+                       -- see #15245+                       promotionErr name FamDataConPE+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc+                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))+                   ; case dc_theta_illegal_constraint theta of+                       Just pred -> promotionErr name $+                                    ConstrainedDataConPE pred+                       Nothing   -> pure ()+                   ; let tc = promoteDataCon dc+                   ; return (mkTyConApp tc [], tyConKind tc) }++           APromotionErr err -> promotionErr name err++           _  -> wrongThingErr "type" thing name }+  where+    check_tc :: TyCon -> TcM ()+    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds+                     ; unless (isTypeLevel (mode_tyki mode) ||+                               data_kinds ||+                               isKindTyCon tc) $+                       promotionErr name NoDataKindsTC }++    -- We cannot promote a data constructor with a context that contains+    -- constraints other than equalities, so error if we find one.+    -- See Note [Constraints in kinds] in GHC.Core.TyCo.Rep+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType+    dc_theta_illegal_constraint = find (not . isEqPred)++{-+Note [Recursion through the kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples++Ticket #11554:+  data P (x :: k) = Q+  data A :: Type where+    MkA :: forall (a :: A). P a -> A++Ticket #12174+  data V a+  data T = forall (a :: T). MkT (V a)++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+there's no reason to prohibit *unlifted* types.+In fact, GHC can itself construct a function with an+unboxed tuple inside a for-all (via CPR analysis; see+typecheck/should_compile/tc170).++Moreover in instance heads we get forall-types with+kind Constraint.++It's tempting to check that the body kind is either * or #. But this is+wrong. For example:++  class C a b+  newtype N = Mk Foo deriving (C a)++We're doing newtype-deriving for C. But notice how `a` isn't in scope in+the predicate `C a`. So we quantify, yielding `forall a. C a` even though+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but+convenient. Bottom line: don't check for * or # here.++Note [Body kind of a HsQualTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If ctxt is non-empty, the HsQualTy really is a /function/, so the+kind of the result really is '*', and in that case the kind of the+body-type can be lifted or unlifted.++However, consider+    instance Eq a => Eq [a] where ...+or+    f :: (Eq a => Eq [a]) => blah+Here both body-kind of the HsQualTy is Constraint rather than *.+Rather crudely we tell the difference by looking at exp_kind. It's+very convenient to typecheck instance types like any other HsSigType.++Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's+better to reject in checkValidType.  If we say that the body kind+should be '*' we risk getting TWO error messages, one saying that Eq+[a] doesn't have kind '*', and one saying that we need a Constraint to+the left of the outer (=>).++How do we figure out the right body kind?  Well, it's a bit of a+kludge: I just look at the expected kind.  If it's Constraint, we+must be in this instance situation context. It's a kludge because it+wouldn't work if any unification was involved to compute that result+kind -- but it isn't.  (The true way might be to use the 'mode'+parameter, but that seemed like a sledgehammer to crack a nut.)++Note [Inferring tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,+we try to figure out whether it's a tuple of kind * or Constraint.+  Step 1: look at the expected kind+  Step 2: infer argument kinds++If after Step 2 it's not clear from the arguments that it's+Constraint, then it must be *.  Once having decided that we re-check+the arguments to give good error messages in+  e.g.  (Maybe, Maybe)++Note that we will still fail to infer the correct kind in this case:++  type T a = ((a,a), D a)+  type family D :: Constraint -> Constraint++While kind checking T, we do not yet know the kind of D, so we will default the+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.++Note [Desugaring types]+~~~~~~~~~~~~~~~~~~~~~~~+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:++  * It transforms from HsType to Type++  * It zonks any kinds.  The returned type should have no mutable kind+    or type variables (hence returning Type not TcType):+      - any unconstrained kind variables are defaulted to (Any *) just+        as in GHC.Tc.Utils.Zonk.+      - there are no mutable type variables because we are+        kind-checking a type+    Reason: the returned type may be put in a TyCon or DataCon where+    it will never subsequently be zonked.++You might worry about nested scopes:+        ..a:kappa in scope..+            let f :: forall b. T '[a,b] -> Int+In this case, f's type could have a mutable kind variable kappa in it;+and we might then default it to (Any *) when dealing with f's type+signature.  But we don't expect this to happen because we can't get a+lexically scoped type variable with a mutable kind variable in it.  A+delicate point, this.  If it becomes an issue we might need to+distinguish top-level from nested uses.++Moreover+  * it cannot fail,+  * it does no unifications+  * it does no validity checking, except for structural matters, such as+        (a) spurious ! annotations.+        (b) a class used as a type++Note [Kind of a type splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these terms, each with TH type splice inside:+     [| e1 :: Maybe $(..blah..) |]+     [| e2 :: $(..blah..) |]+When kind-checking the type signature, we'll kind-check the splice+$(..blah..); we want to give it a kind that can fit in any context,+as if $(..blah..) :: forall k. k.++In the e1 example, the context of the splice fixes kappa to *.  But+in the e2 example, we'll desugar the type, zonking the kind unification+variables as we go.  When we encounter the unconstrained kappa, we+want to default it to '*', not to (Any *).++-}++addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a+        -- Wrap a context around only if we want to show that contexts.+        -- Omit invisible ones and ones user's won't grok+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.+addTypeCtxt (L _ ty) thing+  = addErrCtxt doc thing+  where+    doc = text "In the type" <+> quotes (ppr ty)+++{- *********************************************************************+*                                                                      *+                Type-variable binders+*                                                                      *+********************************************************************* -}++bindNamedWildCardBinders :: [Name]+                         -> ([(Name, TcTyVar)] -> TcM a)+                         -> TcM a+-- Bring into scope the /named/ wildcard binders.  Remember that+-- plain wildcards _ are anonymous and dealt with by HsWildCardTy+-- Soe Note [The wildcard story for types] in GHC.Hs.Type+bindNamedWildCardBinders wc_names thing_inside+  = do { wcs <- mapM newNamedWildTyVar wc_names+       ; let wc_prs = wc_names `zip` wcs+       ; tcExtendNameTyVarEnv wc_prs $+         thing_inside wc_prs }++newNamedWildTyVar :: Name -> TcM TcTyVar+-- ^ New unification variable '_' for a wildcard+newNamedWildTyVar _name   -- Currently ignoring the "_x" wildcard name used in the type+  = do { kind <- newMetaKindVar+       ; details <- newMetaDetails TauTv+       ; wc_name <- newMetaTyVarName (fsLit "w")   -- See Note [Wildcard names]+       ; let tyvar = mkTcTyVar wc_name kind details+       ; traceTc "newWildTyVar" (ppr tyvar)+       ; return tyvar }++---------------------------+tcAnonWildCardOcc :: IsExtraConstraint+                  -> TcTyMode -> HsType GhcRn -> Kind -> TcM TcType+tcAnonWildCardOcc is_extra (TcTyMode { mode_holes = Just (hole_lvl, hole_mode) })+                  ty exp_kind+    -- hole_lvl: see Note [Checking partial type signatures]+    --           esp the bullet on nested forall types+  = do { kv_details <- newTauTvDetailsAtLevel hole_lvl+       ; kv_name    <- newMetaTyVarName (fsLit "k")+       ; wc_details <- newTauTvDetailsAtLevel hole_lvl+       ; wc_name    <- newMetaTyVarName (fsLit wc_nm)+       ; let kv      = mkTcTyVar kv_name liftedTypeKind kv_details+             wc_kind = mkTyVarTy kv+             wc_tv   = mkTcTyVar wc_name wc_kind wc_details++       ; traceTc "tcAnonWildCardOcc" (ppr hole_lvl <+> ppr emit_holes)+       ; when emit_holes $+         emitAnonTypeHole is_extra wc_tv+         -- Why the 'when' guard?+         -- See Note [Wildcards in visible kind application]++       -- You might think that this would always just unify+       -- wc_kind with exp_kind, so we could avoid even creating kv+       -- But the level numbers might not allow that unification,+       -- so we have to do it properly (T14140a)+       ; checkExpectedKind ty (mkTyVarTy wc_tv) wc_kind exp_kind }+  where+     -- See Note [Wildcard names]+     wc_nm = case hole_mode of+               HM_Sig      -> "w"+               HM_FamPat   -> "_"+               HM_VTA      -> "w"+               HM_TyAppPat -> "_"++     emit_holes = case hole_mode of+                     HM_Sig     -> True+                     HM_FamPat  -> False+                     HM_VTA     -> False+                     HM_TyAppPat -> False++tcAnonWildCardOcc _ mode ty _+-- mode_holes is Nothing.  Should not happen, because renamer+-- should already have rejected holes in unexpected places+  = pprPanic "tcWildCardOcc" (ppr mode $$ ppr ty)++{- Note [Wildcard names]+~~~~~~~~~~~~~~~~~~~~~~~~+So we hackily use the mode_holes flag to control the name used+for wildcards:++* For proper holes (whether in a visible type application (VTA) or no),+  we rename the '_' to 'w'. This is so that we see variables like 'w0'+  or 'w1' in error messages, a vast improvement upon '_0' and '_1'. For+  example, we prefer+       Found type wildcard ‘_’ standing for ‘w0’+  over+       Found type wildcard ‘_’ standing for ‘_1’++  Even in the VTA case, where we do not emit an error to be printed, we+  want to do the renaming, as the variables may appear in other,+  non-wildcard error messages.++* However, holes in the left-hand sides of type families ("type+  patterns") stand for type variables which we do not care to name --+  much like the use of an underscore in an ordinary term-level+  pattern. When we spot these, we neither wish to generate an error+  message nor to rename the variable.  We don't rename the variable so+  that we can pretty-print a type family LHS as, e.g.,+    F _ Int _ = ...+  and not+     F w1 Int w2 = ...++  See also Note [Wildcards in family instances] in+  GHC.Rename.Module. The choice of HM_FamPat is made in+  tcFamTyPats. There is also some unsavory magic, relying on that+  underscore, in GHC.Core.Coercion.tidyCoAxBndrsForUser.++Note [Wildcards in visible kind application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are cases where users might want to pass in a wildcard as a visible kind+argument, for instance:++data T :: forall k1 k2. k1 → k2 → Type where+  MkT :: T a b+x :: T @_ @Nat False n+x = MkT++So we should allow '@_' without emitting any hole constraints, and+regardless of whether PartialTypeSignatures is enabled or not. But how+would the typechecker know which '_' is being used in VKA and which is+not when it calls emitNamedTypeHole in+tcHsPartialSigType on all HsWildCardBndrs?  The solution is to neither+rename nor include unnamed wildcards in HsWildCardBndrs, but instead+give every anonymous wildcard a fresh wild tyvar in tcAnonWildCardOcc.++And whenever we see a '@', we set mode_holes to HM_VKA, so that+we do not call emitAnonTypeHole in tcAnonWildCardOcc.+See related Note [Wildcards in visible type application] here and+Note [The wildcard story for types] in GHC.Hs.Type+-}++{- *********************************************************************+*                                                                      *+             Kind inference for type declarations+*                                                                      *+********************************************************************* -}++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+data InitialKindStrategy+  = InitialKindCheck SAKS_or_CUSK+  | InitialKindInfer++-- Does the declaration have a standalone kind signature (SAKS) or a complete+-- user-specified kind (CUSK)?+data SAKS_or_CUSK+  = SAKS Kind  -- Standalone kind signature, fully zonked! (zonkTcTypeToType)+  | CUSK       -- Complete user-specified kind (CUSK)++instance Outputable SAKS_or_CUSK where+  ppr (SAKS k) = text "SAKS" <+> ppr k+  ppr CUSK = text "CUSK"++-- See Note [kcCheckDeclHeader vs kcInferDeclHeader]+kcDeclHeader+  :: InitialKindStrategy+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcDeclHeader (InitialKindCheck msig) = kcCheckDeclHeader msig+kcDeclHeader InitialKindInfer = kcInferDeclHeader++{- Note [kcCheckDeclHeader vs kcInferDeclHeader]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcCheckDeclHeader and kcInferDeclHeader are responsible for getting the initial kind+of a type constructor.++* kcCheckDeclHeader: the TyCon has a standalone kind signature or a CUSK. In that+  case, find the full, final, poly-kinded kind of the TyCon.  It's very like a+  term-level binding where we have a complete type signature for the function.++* kcInferDeclHeader: the TyCon has neither a standalone kind signature nor a+  CUSK. Find a monomorphic kind, with unification variables in it; they will be+  generalised later.  It's very like a term-level binding where we do not have a+  type signature (or, more accurately, where we have a partial type signature),+  so we infer the type and generalise.+-}++------------------------------+kcCheckDeclHeader+  :: SAKS_or_CUSK+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader (SAKS sig) = kcCheckDeclHeader_sig sig+kcCheckDeclHeader CUSK       = kcCheckDeclHeader_cusk++kcCheckDeclHeader_cusk+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded generalized TcTyCon+kcCheckDeclHeader_cusk name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- CUSK case+  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+  = addTyConFlavCtxt name flav $+    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,+           -- we quantify over the mentioned kind vars+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs++       ; candidates' <- candidateQTyVarsOfKinds all_kinds+             -- 'candidates' are all the variables that we are going to+             -- skolemise and then quantify over.  We do not include spec_req_tvs+             -- because they are /already/ skolems++       ; let non_tc_candidates = filter (not . isTcTyVar) (nonDetEltsUniqSet (tyCoVarsOfTypes all_kinds))+             candidates = candidates' { dv_kvs = dv_kvs candidates' `extendDVarSetList` non_tc_candidates }+             inf_candidates = candidates `delCandidates` spec_req_tkvs++       ; inferred <- quantifyTyVars inf_candidates+                     -- NB: 'inferred' comes back sorted in dependency order++       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs+       ; res_kind   <- zonkTcType           res_kind++       ; let mentioned_kv_set = candidateKindVars candidates+             specified        = scopedSort scoped_kvs+                                -- NB: maintain the L-R order of scoped_kvs++             final_tc_binders =  mkNamedTyConBinders Inferred  inferred+                              ++ mkNamedTyConBinders Specified specified+                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs++             all_tv_prs =  mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+             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+       ; checkTyConTelescope tycon++       ; traceTc "kcCheckDeclHeader_cusk " $+         vcat [ text "name" <+> ppr name+              , text "kv_ns" <+> ppr kv_ns+              , text "hs_tvs" <+> ppr hs_tvs+              , text "scoped_kvs" <+> ppr scoped_kvs+              , text "tc_tvs" <+> ppr tc_tvs+              , text "res_kind" <+> ppr res_kind+              , text "candidates" <+> ppr candidates+              , text "inferred" <+> ppr inferred+              , text "specified" <+> ppr specified+              , text "final_tc_binders" <+> ppr final_tc_binders+              , text "mkTyConKind final_tc_bndrs res_kind"+                <+> ppr (mkTyConKind final_tc_binders res_kind)+              , text "all_tv_prs" <+> ppr all_tv_prs ]++       ; return tycon }+  where+    skol_info = TyConSkol flav name+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++-- | Kind-check a 'LHsQTyVars'. Used in 'inferInitialKind' (for tycon kinds and+-- other kinds).+--+-- This function does not do telescope checking.+kcInferDeclHeader+  :: Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn+  -> TcM ContextKind   -- ^ The result kind+  -> TcM TcTyCon       -- ^ A suitably-kinded non-generalized TcTyCon+kcInferDeclHeader name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) kc_res_ki+  -- No standalane kind signature and no CUSK.+  -- See note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+  = addTyConFlavCtxt name flav $+    do { (scoped_kvs, (tc_tvs, res_kind))+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?+           -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $+              newExpectedKind =<< kc_res_ki+              -- Why "_Tv" not "_Skol"? See third wrinkle in+              -- Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,++       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they+               -- might unify with kind vars in other types in a mutually+               -- recursive group.+               -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl++             tc_binders = mkAnonTyConBinders VisArg tc_tvs+               -- Also, note that tc_binders has the tyvars from only the+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]+               -- in GHC.Tc.TyCl+               --+               -- mkAnonTyConBinder: see Note [No polymorphic recursion]++             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+               -- NB: bindExplicitTKBndrs_Q_Tv does not clone;+               --     ditto Implicit+               -- See Note [Cloning for type variable binders]++             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs+                               False -- not yet generalised+                               flav++       ; traceTc "kcInferDeclHeader: not-cusk" $+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs+              , ppr scoped_kvs+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]+       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++-- | Kind-check a declaration header against a standalone kind signature.+-- See Note [Arity inference in kcCheckDeclHeader_sig]+kcCheckDeclHeader_sig+  :: Kind              -- ^ Standalone kind signature, fully zonked! (zonkTcTypeToType)+  -> Name              -- ^ of the thing being checked+  -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+  -> LHsQTyVars GhcRn  -- ^ Binders in the header+  -> TcM ContextKind   -- ^ The result kind. AnyKind == no result signature+  -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcCheckDeclHeader_sig kisig name flav+          (HsQTvs { hsq_ext      = implicit_nms+                  , hsq_explicit = explicit_nms }) kc_res_ki+  = addTyConFlavCtxt name flav $+    do {  -- Step 1: zip user-written binders with quantifiers from the kind signature.+          -- For example:+          --+          --   type F :: forall k -> k -> forall j. j -> Type+          --   data F i a b = ...+          --+          -- Results in the following 'zipped_binders':+          --+          --                   TyBinder      LHsTyVarBndr+          --    ---------------------------------------+          --    ZippedBinder   forall k ->   i+          --    ZippedBinder   k ->          a+          --    ZippedBinder   forall j.+          --    ZippedBinder   j ->          b+          --+          let (zipped_binders, excess_bndrs, kisig') = zipBinders kisig explicit_nms++          -- Report binders that don't have a corresponding quantifier.+          -- For example:+          --+          --   type T :: Type -> Type+          --   data T b1 b2 b3 = ...+          --+          -- Here, b1 is zipped with Type->, while b2 and b3 are excess binders.+          --+        ; unless (null excess_bndrs) $ failWithTc (tooManyBindersErr kisig' excess_bndrs)++          -- Convert each ZippedBinder to TyConBinder        for  tyConBinders+          --                       and to [(Name, TcTyVar)]  for  tcTyConScopedTyVars+        ; (vis_tcbs, concat -> explicit_tv_prs) <- mapAndUnzipM zipped_to_tcb zipped_binders++        ; (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:+                     --+                     --   type T :: Maybe k -> Type+                     --   data T (a :: Maybe j) = ...+                     --+                     -- Here we unify   Maybe k ~ Maybe j+                     mapM_ check_zipped_binder zipped_binders++                     -- Kind-check the result kind annotation, if present:+                     --+                     --    data T a b :: res_ki where+                     --               ^^^^^^^^^+                     -- We do it here because at this point the environment has been+                     -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.+                   ; ctx_k    <- kc_res_ki+                   ; m_res_ki <- case ctx_k of+                                  AnyKind -> return Nothing+                                  _ -> Just <$> newExpectedKind ctx_k++                     -- Step 2: split off invisible binders.+                     -- For example:+                     --+                     --   type F :: forall k1 k2. (k1, k2) -> Type+                     --   type family F+                     --+                     -- Does 'forall k1 k2' become a part of 'tyConBinders' or 'tyConResKind'?+                     -- See Note [Arity inference in kcCheckDeclHeader_sig]+                   ; let (invis_binders, r_ki) = split_invis kisig' m_res_ki++                     -- Check that the inline result kind annotation is valid.+                     -- For example:+                     --+                     --   type T :: Type -> Maybe k+                     --   type family T a :: Maybe j where+                     --+                     -- Here we unify   Maybe k ~ Maybe j+                   ; whenIsJust m_res_ki $ \res_ki ->+                      discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+                      unifyKind Nothing r_ki res_ki++                   ; return (invis_binders, r_ki) }++        -- Convert each invisible TyCoBinder to TyConBinder for tyConBinders.+        ; invis_tcbs <- mapM invis_to_tcb invis_binders++        -- Zonk the implicitly quantified variables.+        ; implicit_tvs <- mapM zonkTcTyVarToTyVar implicit_tvs++        -- Build the final, generalized TcTyCon+        ; 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+              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+          , text "tyConKind =" <+> debugPprType (tyConKind tc)+          , text "tyConBinders = " <+> ppr (tyConBinders tc)+          , text "tcTyConScopedTyVars" <+> ppr (tcTyConScopedTyVars tc)+          , text "tyConResKind" <+> debugPprType (tyConResKind tc)+          ]+        ; return tc }+  where+    -- Consider this declaration:+    --+    --    type T :: forall a. forall b -> (a~b) => Proxy a -> Type+    --    data T x p = MkT+    --+    -- Here, we have every possible variant of ZippedBinder:+    --+    --                   TyBinder           LHsTyVarBndr+    --    ----------------------------------------------+    --    ZippedBinder   forall {k}.+    --    ZippedBinder   forall (a::k).+    --    ZippedBinder   forall (b::k) ->   x+    --    ZippedBinder   (a~b) =>+    --    ZippedBinder   Proxy a ->         p+    --+    -- Given a ZippedBinder zipped_to_tcb produces:+    --+    --  * TyConBinder      for  tyConBinders+    --  * (Name, TcTyVar)  for  tcTyConScopedTyVars, if there's a user-written LHsTyVarBndr+    --+    zipped_to_tcb :: ZippedBinder -> TcM (TyConBinder, [(Name, TcTyVar)])+    zipped_to_tcb zb = case zb of++      -- Inferred variable, no user-written binder.+      -- Example:   forall {k}.+      ZippedBinder (Named (Bndr v Specified)) Nothing ->+        return (mkNamedTyConBinder Specified v, [])++      -- Specified variable, no user-written binder.+      -- Example:   forall (a::k).+      ZippedBinder (Named (Bndr v Inferred)) Nothing ->+        return (mkNamedTyConBinder Inferred v, [])++      -- Constraint, no user-written binder.+      -- Example:   (a~b) =>+      ZippedBinder (Anon InvisArg bndr_ki) Nothing -> do+        name <- newSysName (mkTyVarOccFS (fsLit "ev"))+        let tv = mkTyVar name (scaledThing bndr_ki)+        return (mkAnonTyConBinder InvisArg tv, [])++      -- Non-dependent visible argument with a user-written binder.+      -- Example:   Proxy a ->+      ZippedBinder (Anon VisArg bndr_ki) (Just b) ->+        return $+          let v_name = getName b+              tv = mkTyVar v_name (scaledThing bndr_ki)+              tcb = mkAnonTyConBinder VisArg tv+          in (tcb, [(v_name, tv)])++      -- Dependent visible argument with a user-written binder.+      -- Example:   forall (b::k) ->+      ZippedBinder (Named (Bndr v Required)) (Just b) ->+        return $+          let v_name = getName b+              tcb = mkNamedTyConBinder Required v+          in (tcb, [(v_name, v)])++      -- 'zipBinders' does not produce any other variants of ZippedBinder.+      _ -> panic "goVis: invalid ZippedBinder"++    -- Given an invisible binder that comes from 'split_invis',+    -- convert it to TyConBinder.+    invis_to_tcb :: TyCoBinder -> TcM TyConBinder+    invis_to_tcb tb = do+      (tcb, stv) <- zipped_to_tcb (ZippedBinder tb Nothing)+      MASSERT(null stv)+      return tcb++    -- Check that the inline kind annotation on a binder is valid+    -- by unifying it with the kind of the quantifier.+    check_zipped_binder :: ZippedBinder -> TcM ()+    check_zipped_binder (ZippedBinder _ Nothing) = return ()+    check_zipped_binder (ZippedBinder tb (Just b)) =+      case unLoc b of+        UserTyVar _ _ _ -> return ()+        KindedTyVar _ _ v v_hs_ki -> do+          v_ki <- tcLHsKindSig (TyVarBndrKindCtxt (unLoc v)) v_hs_ki+          discardResult $ -- See Note [discardResult in kcCheckDeclHeader_sig]+            unifyKind (Just (ppr v))+                      (tyBinderType tb)+                      v_ki++    -- Split the invisible binders that should become a part of 'tyConBinders'+    -- rather than 'tyConResKind'.+    -- See Note [Arity inference in kcCheckDeclHeader_sig]+    split_invis :: Kind -> Maybe Kind -> ([TyCoBinder], Kind)+    split_invis sig_ki Nothing =+      -- instantiate all invisible binders+      splitInvisPiTys sig_ki+    split_invis sig_ki (Just res_ki) =+      -- subtraction a la checkExpectedKind+      let n_res_invis_bndrs = invisibleTyBndrCount res_ki+          n_sig_invis_bndrs = invisibleTyBndrCount sig_ki+          n_inst = n_sig_invis_bndrs - n_res_invis_bndrs+      in splitInvisPiTysN n_inst sig_ki++-- A quantifier from a kind signature zipped with a user-written binder for it.+data ZippedBinder = ZippedBinder TyBinder (Maybe (LHsTyVarBndr () GhcRn))++-- See Note [Arity inference in kcCheckDeclHeader_sig]+zipBinders+  :: Kind                      -- Kind signature+  -> [LHsTyVarBndr () GhcRn]   -- User-written binders+  -> ( [ZippedBinder]          -- Zipped binders+     , [LHsTyVarBndr () GhcRn] -- Leftover user-written binders+     , Kind )                  -- Remainder of the kind signature+zipBinders = zip_binders [] emptyTCvSubst+  where+    -- subst: we substitute as we go, to ensure that the resulting+    -- binders in the [ZippedBndr] all have distinct uniques.+    -- If not, the TyCon may get multiple binders with the same unique,+    -- which results in chaos (see #19092,3,4)+    -- (The incoming kind might be forall k. k -> forall k. k -> Type+    --  where those two k's have the same unique. Without the substitution+    --  we'd get a repeated 'k'.)+    zip_binders acc subst ki bs+      | (b:bs') <- bs  -- Stop as soon as 'bs' becomes empty+      , Just (tb,ki') <- tcSplitPiTy_maybe ki+      , let (subst', tb') = substTyCoBndr subst tb+      = if isInvisibleBinder tb+        then zip_binders (ZippedBinder tb' Nothing  : acc) subst' ki' bs+        else zip_binders (ZippedBinder tb' (Just b) : acc) subst' ki' bs'++      | otherwise+      = (reverse acc, bs, substTy subst ki)++tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> SDoc+tooManyBindersErr ki bndrs =+   hang (text "Not a function kind:")+      4 (ppr ki) $$+   hang (text "but extra binders found:")+      4 (fsep (map ppr bndrs))++{- Note [Arity inference in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a kind signature 'kisig' and a declaration header, kcCheckDeclHeader_sig+verifies that the declaration conforms to the signature. The end result is a+TcTyCon 'tc' such that:++  tyConKind tc == kisig++This TcTyCon would be rather easy to produce if we didn't have to worry about+arity. Consider these declarations:++  type family S1 :: forall k. k -> Type+  type family S2 (a :: k) :: Type++Both S1 and S2 can be given the same standalone kind signature:++  type S2 :: forall k. k -> Type++And, indeed, tyConKind S1 == tyConKind S2. However, tyConKind is built from+tyConBinders and tyConResKind, such that++  tyConKind tc == mkTyConKind (tyConBinders tc) (tyConResKind tc)++For S1 and S2, tyConBinders and tyConResKind are different:++  tyConBinders S1  ==  []+  tyConResKind S1  ==  forall k. k -> Type+  tyConKind    S1  ==  forall k. k -> Type++  tyConBinders S2  ==  [spec k, anon-vis (a :: k)]+  tyConResKind S2  ==  Type+  tyConKind    S1  ==  forall k. k -> Type++This difference determines the arity:++  tyConArity tc == length (tyConBinders tc)++That is, the arity of S1 is 0, while the arity of S2 is 2.++'kcCheckDeclHeader_sig' needs to infer the desired arity to split the standalone+kind signature into binders and the result kind. It does so in two rounds:++1. zip user-written binders (vis_tcbs)+2. split off invisible binders (invis_tcbs)++Consider the following declarations:++    type F :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family F a b++    type G :: Type -> forall j. j -> forall k1 k2. (k1, k2) -> Type+    type family G a b :: forall r2. (r1, r2) -> Type++In step 1 (zip user-written binders), we zip the quantifiers in the signature+with the binders in the header using 'zipBinders'. In both F and G, this results in+the following zipped binders:++                   TyBinder     LHsTyVarBndr+    ---------------------------------------+    ZippedBinder   Type ->      a+    ZippedBinder   forall j.+    ZippedBinder   j ->         b+++At this point, we have accumulated three zipped binders which correspond to a+prefix of the standalone kind signature:++  Type -> forall j. j -> ...++In step 2 (split off invisible binders), we have to decide how much remaining+invisible binders of the standalone kind signature to split off:++    forall k1 k2. (k1, k2) -> Type+    ^^^^^^^^^^^^^+    split off or not?++This decision is made in 'split_invis':++* If a user-written result kind signature is not provided, as in F,+  then split off all invisible binders. This is why we need special treatment+  for AnyKind.+* If a user-written result kind signature is provided, as in G,+  then do as checkExpectedKind does and split off (n_sig - n_res) binders.+  That is, split off such an amount of binders that the remainder of the+  standalone kind signature and the user-written result kind signature have the+  same amount of invisible quantifiers.++For F, split_invis splits away all invisible binders, and we have 2:++    forall k1 k2. (k1, k2) -> Type+    ^^^^^^^^^^^^^+    split away both binders++The resulting arity of F is 3+2=5.  (length vis_tcbs = 3,+                                     length invis_tcbs = 2,+                                     length tcbs = 5)++For G, split_invis decides to split off 1 invisible binder, so that we have the+same amount of invisible quantifiers left:++    res_ki  =  forall    r2. (r1, r2) -> Type+    kisig   =  forall k1 k2. (k1, k2) -> Type+                     ^^^+                     split off this one.++The resulting arity of G is 3+1=4. (length vis_tcbs = 3,+                                    length invis_tcbs = 1,+                                    length tcbs = 4)++-}++{- Note [discardResult in kcCheckDeclHeader_sig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use 'unifyKind' to check inline kind annotations in declaration headers+against the signature.++  type T :: [i] -> Maybe j -> Type+  data T (a :: [k1]) (b :: Maybe k2) :: Type where ...++Here, we will unify:++       [k1] ~ [i]+  Maybe k2  ~ Maybe j+      Type  ~ Type++The end result is that we fill in unification variables k1, k2:++    k1  :=  i+    k2  :=  j++We also validate that the user isn't confused:++  type T :: Type -> Type+  data T (a :: Bool) = ...++This will report that (Type ~ Bool) failed to unify.++Now, consider the following example:++  type family Id a where Id x = x+  type T :: Bool -> Type+  type T (a :: Id Bool) = ...++We will unify (Bool ~ Id Bool), and this will produce a non-reflexive coercion.+However, we are free to discard it, as the kind of 'T' is determined by the+signature, not by the inline kind annotation:++      we have   T ::    Bool -> Type+  rather than   T :: Id Bool -> Type++This (Id Bool) will not show up anywhere after we're done validating it, so we+have no use for the produced coercion.+-}++{- Note [No polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should this kind-check?+  data T ka (a::ka) b  = MkT (T Type           Int   Bool)+                             (T (Type -> Type) Maybe Bool)++Notice that T is used at two different kinds in its RHS.  No!+This should not kind-check.  Polymorphic recursion is known to+be a tough nut.++Previously, we laboriously (with help from the renamer)+tried to give T the polymorphic kind+   T :: forall ka -> ka -> kappa -> Type+where kappa is a unification variable, even in the inferInitialKinds+phase (which is what kcInferDeclHeader is all about).  But+that is dangerously fragile (see the ticket).++Solution: make kcInferDeclHeader give T a straightforward+monomorphic kind, with no quantification whatsoever. That's why+we use mkAnonTyConBinder for all arguments when figuring out+tc_binders.++But notice that (#16322 comment:3)++* The algorithm successfully kind-checks this declaration:+    data T2 ka (a::ka) = MkT2 (T2 Type a)++  Starting with (inferInitialKinds)+    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *+  we get+    kappa4 := kappa1   -- from the (a:ka) kind signature+    kappa1 := Type     -- From application T2 Type++  These constraints are soluble so generaliseTcTyCon gives+    T2 :: forall (k::Type) -> k -> *++  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase+  fails, because the call (T2 Type a) in the RHS is ill-kinded.++  We'd really prefer all errors to show up in the kind checking+  phase.++* This algorithm still accepts (in all phases)+     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)+  although T3 is really polymorphic-recursive too.+  Perhaps we should somehow reject that.++Note [Kind variable ordering for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should be the kind of `T` in the following example? (#15591)++  class C (a :: Type) where+    type T (x :: f a)++As per Note [Ordering of implicit variables] in GHC.Rename.HsType, we want to quantify+the kind variables in left-to-right order of first occurrence in order to+support visible kind application. But we cannot perform this analysis on just+T alone, since its variable `a` actually occurs /before/ `f` if you consider+the fact that `a` was previously bound by the parent class `C`. That is to say,+the kind of `T` should end up being:++  T :: forall a f. f a -> Type++(It wouldn't necessarily be /wrong/ if the kind ended up being, say,+forall f a. f a -> Type, but that would not be as predictable for users of+visible kind application.)++In contrast, if `T` were redefined to be a top-level type family, like `T2`+below:++  type family T2 (x :: f (a :: Type))++Then `a` first appears /after/ `f`, so the kind of `T2` should be:++  T2 :: forall f a. f a -> Type++In order to make this distinction, we need to know (in kcCheckDeclHeader) which+type variables have been bound by the parent class (if there is one). With+the class-bound variables in hand, we can ensure that we always quantify+these first.+-}+++{- *********************************************************************+*                                                                      *+             Expected kinds+*                                                                      *+********************************************************************* -}++-- | Describes the kind expected in a certain context.+data ContextKind = TheKind Kind   -- ^ a specific kind+                 | AnyKind        -- ^ any kind will do+                 | OpenKind       -- ^ something of the form @TYPE _@++-----------------------+newExpectedKind :: ContextKind -> TcM Kind+newExpectedKind (TheKind k)   = return k+newExpectedKind AnyKind       = newMetaKindVar+newExpectedKind OpenKind      = newOpenTypeKind++-----------------------+expectedKindInCtxt :: UserTypeCtxt -> ContextKind+-- 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 (GhciCtxt {})   = AnyKind+-- The types in a 'default' decl can have varying kinds+-- See Note [Extended defaults]" in GHC.Tc.Utils.Env+expectedKindInCtxt DefaultDeclCtxt     = AnyKind+expectedKindInCtxt DerivClauseCtxt     = AnyKind+expectedKindInCtxt TypeAppCtxt         = AnyKind+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind+expectedKindInCtxt _                   = OpenKind+++{- *********************************************************************+*                                                                      *+             Bringing type variables into scope+*                                                                      *+********************************************************************* -}++--------------------------------------+--    HsForAllTelescope+--------------------------------------++tcTKTelescope :: TcTyMode+              -> HsForAllTelescope GhcRn+              -> TcM a+              -> TcM ([TcTyVarBinder], a)+tcTKTelescope mode tele thing_inside = case tele of+  HsForAllVis { hsf_vis_bndrs = bndrs }+    -> do { (req_tv_bndrs, thing) <- tcExplicitTKBndrsX skol_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) <- tcExplicitTKBndrsX skol_mode bndrs thing_inside+            -- inv_tv_bndrs :: [VarBndr TyVar Specificity],+            -- but we want [VarBndr TyVar ArgFlag]+          ; return (tyVarSpecToBinders inv_tv_bndrs, thing) }+  where+    skol_mode = smVanilla { sm_clone = False, sm_holes = mode_holes mode }++--------------------------------------+--    HsOuterTyVarBndrs+--------------------------------------++bindOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed+                  => SkolemMode+                  -> HsOuterTyVarBndrs flag GhcRn+                  -> TcM a+                  -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+bindOuterTKBndrsX skol_mode outer_bndrs thing_inside+  = case outer_bndrs of+      HsOuterImplicit{hso_ximplicit = imp_tvs} ->+        do { (imp_tvs', thing) <- bindImplicitTKBndrsX skol_mode imp_tvs thing_inside+           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}+                    , thing) }+      HsOuterExplicit{hso_bndrs = exp_bndrs} ->+        do { (exp_tvs', thing) <- bindExplicitTKBndrsX skol_mode exp_bndrs thing_inside+           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'+                                      , hso_bndrs     = exp_bndrs }+                    , thing) }++getOuterTyVars :: HsOuterTyVarBndrs flag GhcTc -> [TcTyVar]+-- The returned [TcTyVar] is not necessarily in dependency order+-- at least for the HsOuterImplicit case+getOuterTyVars (HsOuterImplicit { hso_ximplicit = tvs })  = tvs+getOuterTyVars (HsOuterExplicit { hso_xexplicit = tvbs }) = binderVars tvbs++---------------+scopedSortOuter :: HsOuterTyVarBndrs Specificity GhcTc -> TcM [InvisTVBinder]+-- Sort any /implicit/ binders into dependency order+--     (zonking first so we can see the dependencies)+-- /Explicit/ ones are already in the right order+scopedSortOuter (HsOuterImplicit{hso_ximplicit = imp_tvs})+  = do { imp_tvs <- zonkAndScopedSort imp_tvs+       ; return [Bndr tv SpecifiedSpec | tv <- imp_tvs] }+scopedSortOuter (HsOuterExplicit{hso_xexplicit = exp_tvs})+  = -- No need to dependency-sort (or zonk) explicit quantifiers+    return exp_tvs++---------------+bindOuterSigTKBndrs_Tv :: HsOuterSigTyVarBndrs GhcRn+                       -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)+bindOuterSigTKBndrs_Tv+  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })++bindOuterSigTKBndrs_Tv_M :: TcTyMode+                         -> HsOuterSigTyVarBndrs GhcRn+                         -> TcM a -> TcM (HsOuterSigTyVarBndrs GhcTc, a)+-- Do not push level; do not make implication constraint; use Tvs+-- Two major clients of this "bind-only" path are:+--    Note [Using TyVarTvs for kind-checking GADTs] in GHC.Tc.TyCl+--    Note [Checking partial type signatures]+bindOuterSigTKBndrs_Tv_M mode+  = bindOuterTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True+                                 , sm_holes = mode_holes mode })++bindOuterFamEqnTKBndrs_Q_Tv :: HsOuterFamEqnTyVarBndrs GhcRn+                            -> TcM a+                            -> TcM ([TcTyVar], a)+bindOuterFamEqnTKBndrs_Q_Tv hs_bndrs thing_inside+  = liftFstM getOuterTyVars $+    bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                 , sm_tvtv = True })+                      hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindOuterFamEqnTKBndrs :: HsOuterFamEqnTyVarBndrs GhcRn+                       -> TcM a+                       -> TcM ([TcTyVar], a)+bindOuterFamEqnTKBndrs hs_bndrs thing_inside+  = liftFstM getOuterTyVars $+    bindOuterTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })+                      hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++---------------+tcOuterTKBndrs :: OutputableBndrFlag flag 'Renamed+               => SkolemInfo+               -> HsOuterTyVarBndrs flag GhcRn+               -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+tcOuterTKBndrs = tcOuterTKBndrsX (smVanilla { sm_clone = False })+  -- Do not clone the outer binders+  -- See Note [Cloning for type variable binder] under "must not"++tcOuterTKBndrsX :: OutputableBndrFlag flag 'Renamed+                => SkolemMode -> SkolemInfo+                -> HsOuterTyVarBndrs flag GhcRn+                -> TcM a -> TcM (HsOuterTyVarBndrs flag GhcTc, a)+-- Push level, capture constraints, make implication+tcOuterTKBndrsX skol_mode skol_info outer_bndrs thing_inside+  = case outer_bndrs of+      HsOuterImplicit{hso_ximplicit = imp_tvs} ->+        do { (imp_tvs', thing) <- tcImplicitTKBndrsX skol_mode skol_info imp_tvs thing_inside+           ; return ( HsOuterImplicit{hso_ximplicit = imp_tvs'}+                    , thing) }+      HsOuterExplicit{hso_bndrs = exp_bndrs} ->+        do { (exp_tvs', thing) <- tcExplicitTKBndrsX skol_mode exp_bndrs thing_inside+           ; return ( HsOuterExplicit { hso_xexplicit = exp_tvs'+                                      , hso_bndrs     = exp_bndrs }+                    , thing) }++--------------------------------------+--    Explicit tyvar binders+--------------------------------------++tcExplicitTKBndrs :: OutputableBndrFlag flag 'Renamed+                  => [LHsTyVarBndr flag GhcRn]+                  -> TcM a+                  -> TcM ([VarBndr TyVar flag], a)+tcExplicitTKBndrs = tcExplicitTKBndrsX (smVanilla { sm_clone = True })++tcExplicitTKBndrsX :: OutputableBndrFlag flag 'Renamed+                   => SkolemMode+                   -> [LHsTyVarBndr flag GhcRn]+                   -> TcM a+                   -> TcM ([VarBndr TyVar flag], a)+-- Push level, capture constraints,+-- and emit an implication constraint with a ForAllSkol ic_info,+-- so that it is subject to a telescope test.+tcExplicitTKBndrsX skol_mode bndrs thing_inside+  = do { (tclvl, wanted, (skol_tvs, res))+             <- pushLevelAndCaptureConstraints $+                bindExplicitTKBndrsX skol_mode bndrs $+                thing_inside++       ; let skol_info = ForAllSkol (fsep (map ppr bndrs))+             -- Notice that we use ForAllSkol here, ignoring the enclosing+             -- skol_info unlike tc_implicit_tk_bndrs, because the bad-telescope+             -- test applies only to ForAllSkol+       ; emitResidualTvConstraint skol_info (binderVars skol_tvs) tclvl wanted++       ; return (skol_tvs, res) }++----------------+-- | Skolemise the 'HsTyVarBndr's in an 'HsForAllTelescope' with the supplied+-- 'TcTyMode'.+bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv+    :: (OutputableBndrFlag flag 'Renamed)+    => [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)++bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (smVanilla { sm_clone = False })+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })+   -- sm_clone: see Note [Cloning for type variable binders]++bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv+    :: ContextKind+    -> [LHsTyVarBndr () GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)+-- These do not clone: see Note [Cloning for type variable binders]+bindExplicitTKBndrs_Q_Skol ctxt_kind hs_bndrs thing_inside+  = liftFstM binderVars $+    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                    , sm_kind = ctxt_kind })+                         hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindExplicitTKBndrs_Q_Tv ctxt_kind hs_bndrs thing_inside+  = liftFstM binderVars $+    bindExplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True+                                    , sm_tvtv = True, sm_kind = ctxt_kind })+                         hs_bndrs thing_inside+    -- sm_clone=False: see Note [Cloning for type variable binders]++bindExplicitTKBndrsX :: (OutputableBndrFlag flag 'Renamed)+    => SkolemMode+    -> [LHsTyVarBndr flag GhcRn]+    -> TcM a+    -> TcM ([VarBndr TyVar flag], a)  -- Returned [TcTyVar] are in 1-1 correspondence+                                      -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind+                                   , sm_holes = hole_info })+                     hs_tvs thing_inside+  = do { traceTc "bindExplicitTKBndrs" (ppr hs_tvs)+       ; go hs_tvs }+  where+    tc_ki_mode = TcTyMode { mode_tyki = KindLevel, mode_holes = hole_info }+                 -- Inherit the HoleInfo from the context++    go [] = do { res <- thing_inside+               ; return ([], res) }+    go (L _ hs_tv : hs_tvs)+       = do { lcl_env <- getLclTypeEnv+            ; tv <- tc_hs_bndr lcl_env hs_tv+            -- Extend the environment as we go, in case a binder+            -- is mentioned in the kind of a later binder+            --   e.g. forall k (a::k). blah+            -- NB: tv's Name may differ from hs_tv's+            -- See Note [Cloning for type variable binders]+            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $+                           go hs_tvs+            ; return (Bndr tv (hsTyVarBndrFlag hs_tv):tvs, res) }+++    tc_hs_bndr lcl_env (UserTyVar _ _ (L _ name))+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = return tv+      | otherwise+      = do { kind <- newExpectedKind ctxt_kind+           ; newTyVarBndr skol_mode name kind }++    tc_hs_bndr lcl_env (KindedTyVar _ _ (L _ name) lhs_kind)+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind+           ; discardResult $+             unifyKind (Just (ppr name)) kind (tyVarKind tv)+                          -- This unify rejects:+                          --    class C (m :: * -> *) where+                          --      type F (m :: *) = ...+           ; return tv }++      | otherwise+      = do { kind <- tc_lhs_kind_sig tc_ki_mode (TyVarBndrKindCtxt name) lhs_kind+           ; newTyVarBndr skol_mode name kind }++newTyVarBndr :: SkolemMode -> Name -> Kind -> TcM TcTyVar+newTyVarBndr (SM { sm_clone = clone, sm_tvtv = tvtv }) name kind+  = do { name <- case clone of+              True -> do { uniq <- newUnique+                         ; return (setNameUnique name uniq) }+              False -> return name+       ; details <- case tvtv of+                 True  -> newMetaDetails TyVarTv+                 False -> do { lvl <- getTcLevel+                             ; return (SkolemTv lvl False) }+       ; return (mkTcTyVar name kind details) }++--------------------------------------+--    Implicit tyvar binders+--------------------------------------++tcImplicitTKBndrsX :: SkolemMode -> SkolemInfo+                   -> [Name]+                   -> TcM a+                   -> TcM ([TcTyVar], a)+-- The workhorse:+--    push level, capture constraints,+--    and emit an implication constraint with a ForAllSkol ic_info,+--    so that it is subject to a telescope test.+tcImplicitTKBndrsX skol_mode skol_info bndrs thing_inside+  = do { (tclvl, wanted, (skol_tvs, res))+             <- pushLevelAndCaptureConstraints       $+                bindImplicitTKBndrsX skol_mode bndrs $+                thing_inside++       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted++       ; return (skol_tvs, res) }++------------------+bindImplicitTKBndrs_Skol, bindImplicitTKBndrs_Tv,+  bindImplicitTKBndrs_Q_Skol, bindImplicitTKBndrs_Q_Tv+  :: [Name] -> TcM a -> TcM ([TcTyVar], a)+bindImplicitTKBndrs_Skol   = bindImplicitTKBndrsX (smVanilla { sm_clone = True })+bindImplicitTKBndrs_Tv     = bindImplicitTKBndrsX (smVanilla { sm_clone = True, sm_tvtv = True })+bindImplicitTKBndrs_Q_Skol = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True })+bindImplicitTKBndrs_Q_Tv   = bindImplicitTKBndrsX (smVanilla { sm_clone = False, sm_parent = True, sm_tvtv = True })++bindImplicitTKBndrsX+   :: SkolemMode+   -> [Name]+   -> TcM a+   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed in [Name]+bindImplicitTKBndrsX skol_mode@(SM { sm_parent = check_parent, sm_kind = ctxt_kind })+                     tv_names thing_inside+  = do { lcl_env <- getLclTypeEnv+       ; tkvs <- mapM (new_tv lcl_env) tv_names+       ; traceTc "bindImplicitTKBndrsX" (ppr tv_names $$ ppr tkvs)+       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)+                thing_inside+       ; return (tkvs, res) }+  where+    new_tv lcl_env name+      | check_parent+      , Just (ATyVar _ tv) <- lookupNameEnv lcl_env name+      = return tv+      | otherwise+      = do { kind <- newExpectedKind ctxt_kind+           ; newTyVarBndr skol_mode name kind }++--------------------------------------+--           SkolemMode+--------------------------------------++-- | 'SkolemMode' describes how to typecheck an explicit ('HsTyVarBndr') or+-- implicit ('Name') binder in a type. It is just a record of flags+-- that describe what sort of 'TcTyVar' to create.+data SkolemMode+  = SM { sm_parent :: Bool    -- True <=> check the in-scope parent type variable+                              -- Used only for asssociated types++       , sm_clone  :: Bool    -- True <=> fresh unique+                              -- See Note [Cloning for type variable binders]++       , sm_tvtv   :: Bool    -- True <=> use a TyVarTv, rather than SkolemTv+                              -- Why?  See Note [Inferring kinds for type declarations]+                              -- in GHC.Tc.TyCl, and (in this module)+                              -- Note [Checking partial type signatures]++       , sm_kind   :: ContextKind  -- Use this for the kind of any new binders++       , sm_holes  :: HoleInfo     -- What to do for wildcards in the kind+       }++smVanilla :: SkolemMode+smVanilla = SM { sm_clone  = panic "sm_clone"  -- We always override this+               , sm_parent = False+               , sm_tvtv   = False+               , sm_kind   = AnyKind+               , sm_holes  = Nothing }++{- Note [Cloning for type variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we must clone the Name of a type variable binder (written in+the source program); and sometimes we must not. This is controlled by+the sm_clone field of SkolemMode.++In some cases it doesn't matter whether or not we clone. Perhaps+it'd be better to use MustClone/MayClone/MustNotClone.++When we /must not/ clone+* In the binders of a type signature (tcOuterTKBndrs)+      f :: forall a{27}. blah+      f = rhs+  Then 'a' scopes over 'rhs'. When we kind-check the signature (tcHsSigType),+  we must get the type (forall a{27}. blah) for the Id f, because+  we bring that type variable into scope when we typecheck 'rhs'.++* In the binders of a data family instance (bindOuterFamEqnTKBndrs)+     data instance+       forall p q. D (p,q) = D1 p | D2 q+  We kind-check the LHS in tcDataFamInstHeader, and then separately+  (in tcDataFamInstDecl) bring p,q into scope before looking at the+  the constructor decls.++* bindExplicitTKBndrs_Q_Tv/bindImplicitTKBndrs_Q_Tv do not clone+  We take advantage of this in kcInferDeclHeader:+     all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+  If we cloned, we'd need to take a bit more care here; not hard.++* bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Skol, do not clone.+  There is no need, I think.++  The payoff here is that avoiding gratuitous cloning means that we can+  almost always take the fast path in swizzleTcTyConBndrs.++When we /must/ clone.+* bindOuterSigTKBndrs_Tv, bindExplicitTKBndrs_Tv do cloning++  This for a narrow and tricky reason which, alas, I couldn't find a+  simpler way round.  #16221 is the poster child:++     data SameKind :: k -> k -> *+     data T a = forall k2 (b :: k2). MkT (SameKind a b) !Int++  When kind-checking T, we give (a :: kappa1). Then:++  - In kcConDecl we make a TyVarTv unification variable kappa2 for k2+    (as described in Note [Using TyVarTvs for kind-checking GADTs],+    even though this example is an existential)+  - So we get (b :: kappa2) via bindExplicitTKBndrs_Tv+  - We end up unifying kappa1 := kappa2, because of the (SameKind a b)++  Now we generalise over kappa2. But if kappa2's Name is precisely k2+  (i.e. we did not clone) we'll end up giving T the utterly final kind+    T :: forall k2. k2 -> *+  Nothing directly wrong with that but when we typecheck the data constructor+  we have k2 in scope; but then it's brought into scope /again/ when we find+  the forall k2.  This is chaotic, and we end up giving it the type+    MkT :: forall k2 (a :: k2) k2 (b :: k2).+           SameKind @k2 a b -> Int -> T @{k2} a+  which is bogus -- because of the shadowing of k2, we can't+  apply T to the kind or a!++  And there no reason /not/ to clone the Name when making a unification+  variable.  So that's what we do.+-}++--------------------------------------+-- Binding type/class variables in the+-- kind-checking and typechecking phases+--------------------------------------++bindTyClTyVars :: Name+               -> (TcTyCon -> [TyConBinder] -> Kind -> TcM a) -> TcM a+-- ^ Used for the type variables of a type or class decl+-- in the "kind checking" and "type checking" pass,+-- but not in the initial-kind run.+bindTyClTyVars tycon_name thing_inside+  = do { tycon <- tcLookupTcTyCon tycon_name+       ; let scoped_prs = tcTyConScopedTyVars tycon+             res_kind   = tyConResKind tycon+             binders    = tyConBinders tycon+       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)+       ; tcExtendNameTyVarEnv scoped_prs $+         thing_inside tycon binders res_kind }+++{- *********************************************************************+*                                                                      *+             Kind generalisation+*                                                                      *+********************************************************************* -}++zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]+zonkAndScopedSort spec_tkvs+  = do { spec_tkvs <- mapM zonkTcTyVarToTyVar spec_tkvs+         -- Zonk the kinds, to we can do the dependency analayis++       -- Do a stable topological sort, following+       -- Note [Ordering of implicit variables] in GHC.Rename.HsType+       ; return (scopedSort spec_tkvs) }++-- | 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 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 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+       ; 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+       ; return dvs' }++-- |- Specialised version 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 need to be promoted.+-- Use this variant when it is unknowable whether metavariables might+-- later be constrained.+--+-- To see why this promotion is needed, see+-- Note [Recipe for checking a signature], and especially+-- Note [Promotion in signatures].+kindGeneralizeNone :: TcType  -- needn't be zonked+                   -> TcM ()+kindGeneralizeNone kind_or_type+  = do { traceTc "kindGeneralizeNone" (ppr kind_or_type)+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; _ <- promoteTyVarSet (candidateKindVars dvs)+       ; return () }++{- Note [Levels and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = e+with no type signature. We are currently at level i.+We must+  * Push the level to level (i+1)+  * Allocate a fresh alpha[i+1] for the result type+  * Check that e :: alpha[i+1], gathering constraint WC+  * Solve WC as far as possible+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]+  * Find the free variables with level > i, in this case gamma[i]+  * Skolemise those free variables and quantify over them, giving+       f :: forall g. beta[i-1] -> g+  * Emit the residiual constraint wrapped in an implication for g,+    thus   forall g. WC++All of this happens for types too.  Consider+  f :: Int -> (forall a. Proxy a -> Int)++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We do kind generalisation only at the outer level of a type signature.+For example, consider+  T :: forall k. k -> *+  f :: (forall a. T a -> Int) -> Int+When kind-checking f's type signature we generalise the kind at+the outermost level, thus:+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!+and *not* at the inner forall:+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!+Reason: same as for HM inference on value level declarations,+we want to infer the most general type.  The f2 type signature+would be *less applicable* than f1, because it requires a more+polymorphic argument.++NB: There are no explicit kind variables written in f's signature.+When there are, the renamer adds these kind variables to the list of+variables bound by the forall, so you can indeed have a type that's+higher-rank in its kind. But only by explicit request.++Note [Kinds of quantified type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyVarBndrsGen quantifies over a specified list of type variables,+*and* over the kind variables mentioned in the kinds of those tyvars.++Note that we must zonk those kinds (obviously) but less obviously, we+must return type variables whose kinds are zonked too. Example+    (a :: k7)  where  k7 := k9 -> k9+We must return+    [k9, a:k9->k9]+and NOT+    [k9, a:k7]+Reason: we're going to turn this into a for-all type,+   forall k9. forall (a:k7). blah+which the type checker will then instantiate, and instantiate does not+look through unification variables!++Hence using zonked_kinds when forming tvs'.++-}++-----------------------------------+etaExpandAlgTyCon :: [TyConBinder]+                  -> Kind   -- must be zonked+                  -> TcM ([TyConBinder], Kind)+-- GADT decls can have a (perhaps partial) kind signature+--      e.g.  data T a :: * -> * -> * where ...+-- This function makes up suitable (kinded) TyConBinders for the+-- argument kinds.  E.g. in this case it might return+--   ([b::*, c::*], *)+-- Never emits constraints.+-- It's a little trickier than you might think: see+-- Note [TyConBinders for the result kind signature of a data type]+-- See Note [Datatype return kinds] in GHC.Tc.TyCl+etaExpandAlgTyCon tc_bndrs kind+  = do  { loc     <- getSrcSpanM+        ; uniqs   <- newUniqueSupply+        ; rdr_env <- getLocalRdrEnv+        ; let new_occs = [ occ+                         | str <- allNameStrings+                         , let occ = mkOccName tvName str+                         , isNothing (lookupLocalRdrOcc rdr_env occ)+                         -- Note [Avoid name clashes for associated data types]+                         , not (occ `elem` lhs_occs) ]+              new_uniqs = uniqsFromSupply uniqs+              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))+        ; return (go loc new_occs new_uniqs subst [] kind) }+  where+    lhs_tvs  = map binderVar tc_bndrs+    lhs_occs = map getOccName lhs_tvs++    go loc occs uniqs subst acc kind+      = case splitPiTy_maybe kind of+          Nothing -> (reverse acc, substTy subst kind)++          Just (Anon af arg, kind')+            -> go loc occs' uniqs' subst' (tcb : acc) kind'+            where+              arg'   = substTy subst (scaledThing arg)+              tv     = mkTyVar (mkInternalName uniq occ loc) arg'+              subst' = extendTCvInScope subst tv+              tcb    = Bndr tv (AnonTCB af)+              (uniq:uniqs') = uniqs+              (occ:occs')   = occs++          Just (Named (Bndr tv vis), kind')+            -> go loc occs uniqs subst' (tcb : acc) kind'+            where+              (subst', tv') = substTyVarBndr subst tv+              tcb = Bndr tv' (NamedTCB vis)++-- | A description of whether something is a+--+-- * @data@ or @newtype@ ('DataDeclSort')+--+-- * @data instance@ or @newtype instance@ ('DataInstanceSort')+--+-- * @data family@ ('DataFamilySort')+--+-- At present, this data type is only consumed by 'checkDataKindSig'.+data DataSort+  = DataDeclSort     NewOrData+  | DataInstanceSort NewOrData+  | DataFamilySort++-- | Local helper type used in 'checkDataKindSig'.+--+-- Superficially similar to 'ContextKind', but it lacks 'AnyKind'+-- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@+-- provides 'LiftedKind', which is much simpler to match on and+-- handle in 'isAllowedDataResKind'.+data AllowedDataResKind+  = AnyTYPEKind+  | AnyBoxedKind+  | LiftedKind++isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool+isAllowedDataResKind AnyTYPEKind  kind = tcIsRuntimeTypeKind kind+isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind+isAllowedDataResKind LiftedKind   kind = tcIsLiftedTypeKind kind++-- | Checks that the return kind in a data declaration's kind signature is+-- permissible. There are three cases:+--+-- If dealing with a @data@, @newtype@, @data instance@, or @newtype instance@+-- declaration, check that the return kind is @Type@.+--+-- If the declaration is a @newtype@ or @newtype instance@ and the+-- @UnliftedNewtypes@ extension is enabled, this check is slightly relaxed so+-- that a return kind of the form @TYPE r@ (for some @r@) is permitted.+-- See @Note [Implementation of UnliftedNewtypes]@ in "GHC.Tc.TyCl".+--+-- If dealing with a @data family@ declaration, check that the return kind is+-- either of the form:+--+-- 1. @TYPE r@ (for some @r@), or+--+-- 2. @k@ (where @k@ is a bare kind variable; see #12369)+--+-- See also Note [Datatype return kinds] in "GHC.Tc.TyCl"+checkDataKindSig :: DataSort -> Kind  -- any arguments in the kind are stripped off+                 -> TcM ()+checkDataKindSig data_sort kind+  = do { dflags <- getDynFlags+       ; traceTc "checkDataKindSig" (ppr kind)+       ; checkTc (tYPE_ok dflags || is_kind_var)+                 (err_msg dflags) }+  where+    res_kind = snd (tcSplitPiTys kind)+       -- Look for the result kind after+       -- peeling off any foralls and arrows++    pp_dec :: SDoc+    pp_dec = text $+      case data_sort of+        DataDeclSort     DataType -> "Data type"+        DataDeclSort     NewType  -> "Newtype"+        DataInstanceSort DataType -> "Data instance"+        DataInstanceSort NewType  -> "Newtype instance"+        DataFamilySort            -> "Data family"++    is_newtype :: Bool+    is_newtype =+      case data_sort of+        DataDeclSort     new_or_data -> new_or_data == NewType+        DataInstanceSort new_or_data -> new_or_data == NewType+        DataFamilySort               -> False++    is_datatype :: Bool+    is_datatype =+      case data_sort of+        DataDeclSort     DataType -> True+        DataInstanceSort DataType -> True+        _                         -> False++    is_data_family :: Bool+    is_data_family =+      case data_sort of+        DataDeclSort{}     -> False+        DataInstanceSort{} -> False+        DataFamilySort     -> True++    allowed_kind :: DynFlags -> AllowedDataResKind+    allowed_kind dflags+      | is_newtype && xopt LangExt.UnliftedNewtypes dflags+        -- With UnliftedNewtypes, we allow kinds other than Type, but they+        -- must still be of the form `TYPE r` since we don't want to accept+        -- Constraint or Nat.+        -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl.+      = AnyTYPEKind+      | is_data_family+        -- If this is a `data family` declaration, we don't need to check if+        -- UnliftedNewtypes is enabled, since data family declarations can+        -- have return kind `TYPE r` unconditionally (#16827).+      = AnyTYPEKind+      | is_datatype && xopt LangExt.UnliftedDatatypes dflags+        -- With UnliftedDatatypes, we allow kinds other than Type, but they+        -- must still be of the form `TYPE (BoxedRep l)`, so that we don't+        -- accept result kinds like `TYPE IntRep`.+        -- See Note [Implementation of UnliftedDatatypes] in GHC.Tc.TyCl.+      = AnyBoxedKind+      | otherwise+      = LiftedKind++    tYPE_ok :: DynFlags -> Bool+    tYPE_ok dflags = isAllowedDataResKind (allowed_kind dflags) res_kind++    -- In the particular case of a data family, permit a return kind of the+    -- form `:: k` (where `k` is a bare kind variable).+    is_kind_var :: Bool+    is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)+                | otherwise      = False++    pp_allowed_kind dflags =+      case allowed_kind dflags of+        AnyTYPEKind  -> ppr tYPETyCon+        AnyBoxedKind -> ppr boxedRepDataConTyCon+        LiftedKind   -> ppr liftedTypeKind++    err_msg :: DynFlags -> SDoc+    err_msg dflags =+      sep [ sep [ pp_dec <+>+                  text "has non-" <>+                  pp_allowed_kind dflags+                , (if is_data_family then text "and non-variable" else empty) <+>+                  text "return kind" <+> quotes (ppr kind) ]+          , ext_hint dflags ]++    ext_hint dflags+      | tcIsRuntimeTypeKind kind+      , is_newtype+      , not (xopt LangExt.UnliftedNewtypes dflags)+      = text "Perhaps you intended to use UnliftedNewtypes"+      | tcIsBoxedTypeKind kind+      , is_datatype+      , not (xopt LangExt.UnliftedDatatypes dflags)+      = text "Perhaps you intended to use UnliftedDatatypes"+      | otherwise+      = empty++-- | Checks that the result kind of a class is exactly `Constraint`, rejecting+-- type synonyms and type families that reduce to `Constraint`. See #16826.+checkClassKindSig :: Kind -> TcM ()+checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg+  where+    err_msg :: SDoc+    err_msg =+      text "Kind signature on a class must end with" <+> ppr constraintKind $$+      text "unobscured by type families"++tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]+-- Result is in 1-1 correspondence with orig_args+tcbVisibilities tc orig_args+  = go (tyConKind tc) init_subst orig_args+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))+    go _ _ []+      = []++    go fun_kind subst all_args@(arg : args)+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind+      = case tcb of+          Anon af _           -> AnonTCB af   : go inner_kind subst  args+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args+                 where+                    subst' = extendTCvSubst subst tv arg++      | not (isEmptyTCvSubst subst)+      = go (substTy subst fun_kind) init_subst all_args++      | otherwise+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)+++{- Note [TyConBinders for the result kind signature of a data type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+  data T (a::*) :: * -> forall k. k -> *+we want to generate the extra TyConBinders for T, so we finally get+  (a::*) (b::*) (k::*) (c::k)+The function etaExpandAlgTyCon generates these extra TyConBinders from+the result kind signature.++We need to take care to give the TyConBinders+  (a) OccNames that are fresh (because the TyConBinders of a TyCon+      must have distinct OccNames++  (b) Uniques that are fresh (obviously)++For (a) we need to avoid clashes with the tyvars declared by+the user before the "::"; in the above example that is 'a'.+And also see Note [Avoid name clashes for associated data types].++For (b) suppose we have+   data T :: forall k. k -> forall k. k -> *+where the two k's are identical even up to their uniques.  Surprisingly,+this can happen: see #14515.++It's reasonably easy to solve all this; just run down the list with a+substitution; hence the recursive 'go' function.  But it has to be+done.++Note [Avoid name clashes for associated data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    class C a b where+               data D b :: * -> *+When typechecking the decl for D, we'll invent an extra type variable+for D, to fill out its kind.  Ideally we don't want this type variable+to be 'a', because when pretty printing we'll get+            class C a b where+               data D b a0+(NB: the tidying happens in the conversion to Iface syntax, which happens+as part of pretty-printing a TyThing.)++That's why we look in the LocalRdrEnv to see what's in scope. This is+important only to get nice-looking output when doing ":info C" in GHCi.+It isn't essential for correctness.+++************************************************************************+*                                                                      *+             Partial signatures+*                                                                      *+************************************************************************++-}++tcHsPartialSigType+  :: UserTypeCtxt+  -> LHsSigWcType GhcRn       -- The type signature+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards+         , Maybe TcType       -- Extra-constraints wildcard+         , [(Name,InvisTVBinder)] -- Original tyvar names, in correspondence with+                              --   the implicitly and explicitly bound type variables+         , TcThetaType        -- Theta part+         , TcType )           -- Tau part+-- See Note [Checking partial type signatures]+tcHsPartialSigType ctxt sig_ty+  | HsWC { hswc_ext  = sig_wcs, hswc_body = sig_ty } <- sig_ty+  , L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = body_ty}) <- sig_ty+  , (hs_ctxt, hs_tau) <- splitLHsQualTy body_ty+  = addSigCtxt ctxt sig_ty $+    do { mode <- mkHoleMode TypeLevel HM_Sig+       ; (outer_bndrs, (wcs, wcx, theta, tau))+            <- solveEqualities "tcHsPartialSigType" $+               -- See Note [Failure in local type signatures]+               bindNamedWildCardBinders sig_wcs             $ \ wcs ->+               bindOuterSigTKBndrs_Tv_M mode hs_outer_bndrs $+               do {   -- Instantiate the type-class context; but if there+                      -- is an extra-constraints wildcard, just discard it here+                    (theta, wcx) <- tcPartialContext mode hs_ctxt++                  ; ek <- newOpenTypeKind+                  ; tau <- addTypeCtxt hs_tau $+                           tc_lhs_type mode hs_tau ek++                  ; return (wcs, wcx, theta, tau) }++       ; traceTc "tcHsPartialSigType 2" empty+       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs+       ; traceTc "tcHsPartialSigType 3" empty++         -- No kind-generalization here:+       ; kindGeneralizeNone (mkInvisForAllTys outer_tv_bndrs $+                             mkPhiTy theta $+                             tau)++       -- Spit out the wildcards (including the extra-constraints one)+       -- as "hole" constraints, so that they'll be reported if necessary+       -- See Note [Extra-constraint holes in partial type signatures]+       ; mapM_ emitNamedTypeHole wcs++       -- Zonk, so that any nested foralls can "see" their occurrences+       -- See Note [Checking partial type signatures], and in particular+       -- Note [Levels for wildcards]+       ; outer_tv_bndrs <- mapM zonkInvisTVBinder outer_tv_bndrs+       ; theta          <- mapM zonkTcType theta+       ; tau            <- zonkTcType tau++         -- We return a proper (Name,InvisTVBinder) environment, to be sure that+         -- we bring the right name into scope in the function body.+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug+       ; let outer_bndr_names :: [Name]+             outer_bndr_names = hsOuterTyVarNames hs_outer_bndrs+             tv_prs :: [(Name,InvisTVBinder)]+             tv_prs = outer_bndr_names `zip` outer_tv_bndrs++      -- NB: checkValidType on the final inferred type will be+      --     done later by checkInferredPolyId.  We can't do it+      --     here because we don't have a complete type to check++       ; traceTc "tcHsPartialSigType" (ppr tv_prs)+       ; return (wcs, wcx, tv_prs, theta, tau) }++tcPartialContext :: TcTyMode -> Maybe (LHsContext GhcRn) -> TcM (TcThetaType, Maybe TcType)+tcPartialContext _ Nothing = return ([], Nothing)+tcPartialContext mode (Just (L _ hs_theta))+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+  , L wc_loc ty@(HsWildCardTy _) <- ignoreParens hs_ctxt_last+  = do { wc_tv_ty <- setSrcSpanA wc_loc $+                     tcAnonWildCardOcc YesExtraConstraint mode ty constraintKind+       ; theta <- mapM (tc_lhs_pred mode) hs_theta1+       ; return (theta, Just wc_tv_ty) }+  | otherwise+  = do { theta <- mapM (tc_lhs_pred mode) hs_theta+       ; return (theta, Nothing) }++{- Note [Checking partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is about tcHsPartialSigType.  See also+Note [Recipe for checking a signature]++When we have a partial signature like+   f :: forall a. a -> _+we do the following++* tcHsPartialSigType does not make quantified type (forall a. blah)+  and then instantiate it -- it makes no sense to instantiate a type+  with wildcards in it.  Rather, tcHsPartialSigType just returns the+  'a' and the 'blah' separately.++  Nor, for the same reason, do we push a level in tcHsPartialSigType.++* We instantiate 'a' to a unification variable, a TyVarTv, and /not/+  a skolem; hence the "_Tv" in bindExplicitTKBndrs_Tv.  Consider+    f :: forall a. a -> _+    g :: forall b. _ -> b+    f = g+    g = f+  They are typechecked as a recursive group, with monomorphic types,+  so 'a' and 'b' will get unified together.  Very like kind inference+  for mutually recursive data types (sans CUSKs or SAKS); see+  Note [Cloning for type variable binders]++* In GHC.Tc.Gen.Sig.tcUserSigType we return a PartialSig, which (unlike+  the companion CompleteSig) contains the original, as-yet-unchecked+  source-code LHsSigWcType++* Then, for f and g /separately/, we call tcInstSig, which in turn+  call tchsPartialSig (defined near this Note).  It kind-checks the+  LHsSigWcType, creating fresh unification variables for each "_"+  wildcard.  It's important that the wildcards for f and g are distinct+  because they might get instantiated completely differently.  E.g.+     f,g :: forall a. a -> _+     f x = a+     g x = True+  It's really as if we'd written two distinct signatures.++* Nested foralls. See Note [Levels for wildcards]++* Just as for ordinary signatures, we must solve local equalities and+  zonk the type after kind-checking it, to ensure that all the nested+  forall binders can "see" their occurrenceds++  Just as for ordinary signatures, this zonk also gets any Refl casts+  out of the way of instantiation.  Example: #18008 had+       foo :: (forall a. (Show a => blah) |> Refl) -> _+  and that Refl cast messed things up.  See #18062.++Note [Levels for wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     f :: forall b. (forall a. a -> _) -> b+We do /not/ allow the "_" to be instantiated to 'a'; although we do+(as before) allow it to be instantiated to the (top level) 'b'.+Why not?  Suppose+   f x = (x True, x 'c')++During typecking the RHS we must instantiate that (forall a. a -> _),+so we must know /precisely/ where all the a's are; they must not be+hidden under (possibly-not-yet-filled-in) unification variables!++We achieve this as follows:++- For /named/ wildcards such sas+     g :: forall b. (forall la. a -> _x) -> b+  there is no problem: we create them at the outer level (ie the+  ambient level of the signature itself), and push the level when we+  go inside a forall.  So now the unification variable for the "_x"+  can't unify with skolem 'a'.++- For /anonymous/ wildcards, such as 'f' above, we carry the ambient+  level of the signature to the hole in the TcLevel part of the+  mode_holes field of TcTyMode.  Then, in tcAnonWildCardOcc we us that+  level (and /not/ the level ambient at the occurrence of "_") to+  create the unification variable for the wildcard.  That is the sole+  purpose of the TcLevel in the mode_holes field: to transport the+  ambient level of the signature down to the anonymous wildcard+  occurrences.++Note [Extra-constraint holes in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: (_) => a -> a+  f x = ...++* The renamer leaves '_' untouched.++* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in+  tcWildCardBinders.++* GHC.Tc.Gen.Bind.chooseInferredQuantifiers fills in that hole TcTyVar+  with the inferred constraints, e.g. (Eq a, Show a)++* GHC.Tc.Errors.mkHoleError finally reports the error.++An annoying difficulty happens if there are more than 64 inferred+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.+Where do we find the TyCon?  For good reasons we only have constraint+tuples up to 62 (see Note [How tuples work] in GHC.Builtin.Types).  So how+can we make a 70-tuple?  This was the root cause of #14217.++It's incredibly tiresome, because we only need this type to fill+in the hole, to communicate to the error reporting machinery.  Nothing+more.  So I use a HACK:++* I make an /ordinary/ tuple of the constraints, in+  GHC.Tc.Gen.Bind.chooseInferredQuantifiers. This is ill-kinded because+  ordinary tuples can't contain constraints, but it works fine. And for+  ordinary tuples we don't have the same limit as for constraint+  tuples (which need selectors and an associated class).++* Because it is ill-kinded, it trips an assert in writeMetaTyVar,+  so now I disable the assertion if we are writing a type of+  kind Constraint.  (That seldom/never normally happens so we aren't+  losing much.)++Result works fine, but it may eventually bite us.++See also Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver for+information about how these are printed.++************************************************************************+*                                                                      *+      Pattern signatures (i.e signatures that occur in patterns)+*                                                                      *+********************************************************************* -}++tcHsPatSigType :: UserTypeCtxt+               -> HoleMode -- HM_Sig when in a SigPat, HM_TyAppPat when in a ConPat checking type applications.+               -> HsPatSigType GhcRn          -- The type signature+               -> ContextKind                -- What kind is expected+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                              -- the scoped type variables+                      , TcType)       -- The type+-- Used for type-checking type signatures in+-- (a) patterns           e.g  f (x::Int) = e+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x+-- See Note [Pattern signature binders and scoping] in GHC.Hs.Type+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcHsPatSigType ctxt hole_mode+  (HsPS { hsps_ext  = HsPSRn { hsps_nwcs = sig_wcs, hsps_imp_tvs = sig_ns }+        , hsps_body = hs_ty })+  ctxt_kind+  = addSigCtxt ctxt hs_ty $+    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns+       ; mode <- mkHoleMode TypeLevel hole_mode+       ; (wcs, sig_ty)+            <- addTypeCtxt hs_ty                     $+               solveEqualities "tcHsPatSigType" $+                 -- See Note [Failure in local type signatures]+                 -- and c.f #16033+               bindNamedWildCardBinders sig_wcs $ \ wcs ->+               tcExtendNameTyVarEnv sig_tkv_prs $+               do { ek     <- newExpectedKind ctxt_kind+                  ; sig_ty <- tc_lhs_type mode hs_ty ek+                  ; return (wcs, sig_ty) }++        ; mapM_ emitNamedTypeHole wcs++          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty+          -- contains a forall). Promote these.+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...+          -- When we instantiate x, we have to compare the kind of the argument+          -- to a's kind, which will be a metavariable.+          -- kindGeneralizeNone does this:+        ; kindGeneralizeNone sig_ty+        ; sig_ty <- zonkTcType sig_ty+        ; checkValidType ctxt sig_ty++        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)+        ; return (wcs, sig_tkv_prs, sig_ty) }+  where+    new_implicit_tv name+      = do { kind <- newMetaKindVar+           ; tv   <- case ctxt of+                       RuleSigCtxt {} -> newSkolemTyVar name kind+                       _              -> newPatSigTyVar name kind+                       -- See Note [Typechecking pattern signature binders]+             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)+           ; return (name, tv) }++{- Note [Typechecking pattern signature binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Type variables in the type environment] in GHC.Tc.Utils.+Consider++  data T where+    MkT :: forall a. a -> (a -> Int) -> T++  f :: T -> ...+  f (MkT x (f :: b -> c)) = <blah>++Here+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',+   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 fresh meta-tyvars+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the+   environment++ * Then unification makes beta := a_sk, gamma := Int+   That's why we must make beta and gamma a MetaTv,+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).++ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,++Another example (#13881):+   fl :: forall (l :: [a]). Sing l -> Sing l+   fl (SNil :: Sing (l :: [y])) = SNil+When we reach the pattern signature, 'l' is in scope from the+outer 'forall':+   "a" :-> a_sk :: *+   "l" :-> l_sk :: [a_sk]+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check+the pattern signature+   Sing (l :: [y])+That unifies y_sig := a_sk.  We return from tcHsPatSigType with+the pair ("y" :-> y_sig).++For RULE binders, though, things are a bit different (yuk).+  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_implicit_tv function in tcHsPatSigType.+++************************************************************************+*                                                                      *+        Checking kinds+*                                                                      *+************************************************************************++-}++unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)+unifyKinds rn_tys act_kinds+  = do { kind <- newMetaKindVar+       ; let check rn_ty (ty, act_kind)+               = checkExpectedKind (unLoc rn_ty) ty act_kind kind+       ; tys' <- zipWithM check rn_tys act_kinds+       ; return (tys', kind) }++{-+************************************************************************+*                                                                      *+        Sort checking kinds+*                                                                      *+************************************************************************++tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.+It does sort checking and desugaring at the same time, in one single pass.+-}++tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tcLHsKindSig ctxt hs_kind+  = tc_lhs_kind_sig kindLevelMode ctxt hs_kind++tc_lhs_kind_sig :: TcTyMode -> UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tc_lhs_kind_sig mode ctxt hs_kind+-- 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)) $+                 solveEqualities "tcLHsKindSig" $+                 tc_lhs_type mode hs_kind liftedTypeKind+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)+       -- No generalization:+       ; kindGeneralizeNone kind+       ; kind <- zonkTcType kind+         -- This zonk is very important in the case of higher rank kinds+         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).+         --                          <more blah>+         --      When instantiating p's kind at occurrences of p in <more blah>+         --      it's crucial that the kind we instantiate is fully zonked,+         --      else we may fail to substitute properly++       ; checkValidType ctxt kind+       ; traceTc "tcLHsKindSig2" (ppr kind)+       ; return kind }++promotionErr :: Name -> PromotionErr -> TcM a+promotionErr name err+  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                   2 (parens reason))+  where+    reason = case err of+               ConstrainedDataConPE pred+                              -> text "it has an unpromotable context"+                                 <+> quotes (ppr pred)+               FamDataConPE   -> text "it comes from a data family instance"+               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"+               PatSynPE       -> text "pattern synonyms cannot be promoted"+               RecDataConPE   -> same_rec_group_msg+               ClassPE        -> same_rec_group_msg+               TyConPE        -> same_rec_group_msg++    same_rec_group_msg = text "it is defined and used in the same recursive group"++{-+************************************************************************+*                                                                      *+          Error messages and such+*                                                                      *+************************************************************************+-}+  -- | Make an appropriate message for an error in a function argument. -- Used for both expressions and types.

GHC/Tc/Gen/Match.hs view

@@ -1,19 +1,19 @@+{-# LANGUAGE CPP              #-}+{-# LANGUAGE ConstraintKinds  #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE TypeFamilies     #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RecordWildCards #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- -- | Typecheck some @Matches@ module GHC.Tc.Gen.Match    ( tcMatchesFun@@ -39,33 +39,39 @@ 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 import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+ import GHC.Core.Multiplicity import GHC.Core.UsageEnv-import GHC.Types.Name-import GHC.Builtin.Types-import GHC.Types.Id import GHC.Core.TyCon+-- Create chunkified tuple tybes for monad comprehensions+import GHC.Core.Make++import GHC.Hs++import GHC.Builtin.Types import GHC.Builtin.Types.Prim-import GHC.Tc.Types.Evidence+ import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Types.SrcLoc import GHC.Driver.Session ( getDynFlags ) --- Create chunkified tuple tybes for monad comprehensions-import GHC.Core.Make+import GHC.Types.Fixity (LexicalFixity(..))+import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.SrcLoc  import Control.Monad import Control.Arrow ( second )@@ -85,7 +91,7 @@ same number of arguments before using @tcMatches@ to do the work. -} -tcMatchesFun :: Located Name+tcMatchesFun :: LocatedN Name              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpRhoType    -- Expected type of function              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))@@ -131,12 +137,12 @@ parser guarantees that each equation has exactly one argument. -} -tcMatchesCase :: (Outputable (body GhcRn)) =>-                TcMatchCtxt body                        -- Case context-             -> Scaled TcSigmaType                      -- Type of scrutinee-             -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives+tcMatchesCase :: (AnnoBody body) =>+                TcMatchCtxt body                         -- Case context+             -> Scaled TcSigmaType                       -- Type of scrutinee+             -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives              -> ExpRhoType                    -- Type of whole case expressions-             -> TcM (MatchGroup GhcTc (Located (body GhcTc)))+             -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))                 -- Translated alternatives                 -- wrapper goes from MatchGroup's ty to expected ty @@ -157,11 +163,19 @@  -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. -tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType+tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType            -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -- Used for pattern bindings-tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)+tcGRHSsPat grhss res_ty+  = tcScalingUsage Many $+      -- Like in tcMatchesFun, this scaling happens because all+      -- let bindings are unrestricted. A difference, here, is+      -- that when this is not the case, any more, we will have to+      -- make sure that the pattern is strict, otherwise this will+      -- desugar to incorrect code.+    tcGRHSs match_ctxt grhss res_ty   where+    match_ctxt :: TcMatchCtxt HsExpr -- AZ     match_ctxt = MC { mc_what = PatBindRhs,                       mc_body = tcBody } @@ -173,17 +187,29 @@  data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module   = MC { mc_what :: HsMatchContext GhcRn,  -- What kind of thing this is-         mc_body :: Located (body GhcRn)   -- Type checker for a body of+         mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of                                            -- an alternative                  -> ExpRhoType-                 -> TcM (Located (body GhcTc)) }+                 -> TcM (LocatedA (body GhcTc)) } +type AnnoBody body+  = ( Outputable (body GhcRn)+    , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA+    , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA+    , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL+    , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL+    , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcSpan+    , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+    , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA+    )+ -- | Type-check a MatchGroup.-tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body+tcMatches :: (AnnoBody body ) => TcMatchCtxt body           -> [Scaled ExpSigmaType]      -- Expected pattern types-          -> ExpRhoType                 -- Expected result-type of the Match.-          -> MatchGroup GhcRn (Located (body GhcRn))-          -> TcM (MatchGroup GhcTc (Located (body GhcTc)))+          -> ExpRhoType          -- Expected result-type of the Match.+          -> MatchGroup GhcRn (LocatedA (body GhcRn))+          -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))  tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches                                   , mg_origin = origin })@@ -209,21 +235,21 @@                     , mg_origin = origin }) }  --------------tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body+tcMatch :: (AnnoBody body) => TcMatchCtxt body         -> [Scaled ExpSigmaType]        -- Expected pattern types         -> ExpRhoType            -- Expected result-type of the Match.-        -> LMatch GhcRn (Located (body GhcRn))-        -> TcM (LMatch GhcTc (Located (body GhcTc)))+        -> LMatch GhcRn (LocatedA (body GhcRn))+        -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))  tcMatch ctxt pat_tys rhs_ty match-  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match+  = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match   where     tc_match ctxt pat_tys rhs_ty              match@(Match { m_pats = pats, m_grhss = grhss })       = add_match_ctxt match $         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $                                 tcGRHSs ctxt grhss rhs_ty-           ; return (Match { m_ext = noExtField+           ; return (Match { m_ext = noAnn                            , m_ctxt = mc_what ctxt, m_pats = pats'                            , m_grhss = grhss' }) } @@ -235,8 +261,9 @@             _          -> addErrCtxt (pprMatchInCtxt match) thing_inside  --------------tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType-        -> TcM (GRHSs GhcTc (Located (body GhcTc)))+tcGRHSs :: AnnoBody body+        => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType+        -> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))  -- Notice that we pass in the full res_ty, so that we get -- good inference from simple things like@@ -244,23 +271,23 @@ -- We used to force it to be a monotype when there was more than one guard -- but we don't need to do that any more -tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty+tcGRHSs ctxt (GRHSs _ grhss binds) res_ty   = do  { (binds', ugrhss)             <- tcLocalBinds binds $                mapM (tcCollectingUsage . wrapLocM (tcGRHS ctxt res_ty)) grhss         ; let (usages, grhss') = unzip ugrhss         ; tcEmitBindingUsage $ supUEs usages-        ; return (GRHSs noExtField grhss' (L l binds')) }+        ; return (GRHSs emptyComments grhss' binds') }  --------------tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))-       -> TcM (GRHS GhcTc (Located (body GhcTc)))+tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))+       -> TcM (GRHS GhcTc (LocatedA (body GhcTc)))  tcGRHS ctxt res_ty (GRHS _ guards rhs)   = do  { (guards', rhs')             <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $                mc_body ctxt rhs-        ; return (GRHS noExtField guards' rhs') }+        ; return (GRHS noAnn guards' rhs') }   where     stmt_ctxt  = PatGuard (mc_what ctxt) @@ -273,7 +300,7 @@ -}  tcDoStmts :: HsStmtContext GhcRn-          -> Located [LStmt GhcRn (LHsExpr GhcRn)]+          -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]           -> ExpRhoType           -> TcM (HsExpr GhcTc)          -- Returns a HsDo tcDoStmts ListComp (L l stmts) res_ty@@ -320,27 +347,27 @@  type TcStmtChecker body rho_type   =  forall thing. HsStmtContext GhcRn-                -> Stmt GhcRn (Located (body GhcRn))+                -> Stmt GhcRn (LocatedA (body GhcRn))                 -> rho_type                 -- Result type for comprehension                 -> (rho_type -> TcM thing)  -- Checker for what follows the stmt-                -> TcM (Stmt GhcTc (Located (body GhcTc)), thing)+                -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing) -tcStmts :: (Outputable (body GhcRn)) => HsStmtContext GhcRn+tcStmts :: (AnnoBody body) => HsStmtContext GhcRn         -> TcStmtChecker body rho_type   -- NB: higher-rank type-        -> [LStmt GhcRn (Located (body GhcRn))]+        -> [LStmt GhcRn (LocatedA (body GhcRn))]         -> rho_type-        -> TcM [LStmt GhcTc (Located (body GhcTc))]+        -> TcM [LStmt GhcTc (LocatedA (body GhcTc))] tcStmts ctxt stmt_chk stmts res_ty   = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $                         const (return ())        ; return stmts' } -tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext GhcRn+tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcRn                -> TcStmtChecker body rho_type    -- NB: higher-rank type-               -> [LStmt GhcRn (Located (body GhcRn))]+               -> [LStmt GhcRn (LocatedA (body GhcRn))]                -> rho_type                -> (rho_type -> TcM thing)-               -> TcM ([LStmt GhcTc (Located (body GhcTc))], thing)+               -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)  -- Note the higher-rank type.  stmt_chk is applied at different -- types in the equations for tcStmts@@ -350,11 +377,11 @@         ; return ([], thing) }  -- LetStmts are handled uniformly, regardless of context-tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts)                                                              res_ty thing_inside   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $               tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside-        ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }+        ; return (L loc (LetStmt x binds') : stmts', thing) }  -- Don't set the error context for an ApplicativeStmt.  It ought to be -- possible to do this with a popErrCtxt in the tcStmt case for@@ -370,7 +397,7 @@   -- For the vanilla case, handle the location-setting part   | otherwise   = do  { (stmt', (stmts', thing)) <--                setSrcSpan loc                              $+                setSrcSpanA loc                             $                 addErrCtxt (pprStmtInCtxt ctxt stmt)        $                 stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->                 popErrCtxt                                  $@@ -674,7 +701,7 @@        --------------- Typecheck the 'fmap' function -------------        ; fmap_op' <- case form of                        ThenForm -> return noExpr-                       _ -> fmap unLoc . tcCheckPolyExpr (noLoc fmap_op) $+                       _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $                             mkInfForAllTy alphaTyVar $                             mkInfForAllTy betaTyVar  $                             (alphaTy `mkVisFunTyMany` betaTy)@@ -746,7 +773,7 @@                         (m_ty `mkAppTy` betaTy)                         `mkVisFunTyMany`                         (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])-       ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLoc mzip_op) mzip_ty+       ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty          -- type dummies since we don't know all binder types yet        ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))@@ -860,7 +887,7 @@                   ; return (rhs', rhs_ty, thing) }         ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) } -tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names+tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })          res_ty thing_inside@@ -902,7 +929,7 @@         ; later_ids <- tcLookupLocalIds later_names         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),                                  ppr later_ids <+> ppr (map idType later_ids)]-        ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids+        ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'                           , recS_ext = RecStmtTc@@ -1024,7 +1051,7 @@                     , arg_expr = rhs                     , ..                     }, pat_ty, exp_ty)-      = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $+      = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $         addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs))   $         do { rhs'      <- tcCheckMonoExprNC rhs exp_ty            ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $@@ -1051,8 +1078,8 @@            ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }      get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]-    get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat-    get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat }) = collectPatBinders pat+    get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat+    get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat })    = collectPatBinders CollNoDictBinders pat  {- Note [ApplicativeDo and constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1091,7 +1118,8 @@ number of args are used in each equation. -} -checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()+checkArgs :: AnnoBody body+          => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM () checkArgs _ (MG { mg_alts = L _ [] })     = return () checkArgs fun (MG { mg_alts = L _ (match1:matches) })@@ -1100,11 +1128,11 @@     | otherwise     = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>                          text "have different numbers of arguments"-                       , nest 2 (ppr (getLoc match1))-                       , nest 2 (ppr (getLoc (head bad_matches)))])+                       , nest 2 (ppr (getLocA match1))+                       , nest 2 (ppr (getLocA (head bad_matches)))])   where     n_args1 = args_in_match match1     bad_matches = [m | m <- matches, args_in_match m /= n_args1] -    args_in_match :: LMatch GhcRn body -> Int+    args_in_match :: (LocatedA (Match GhcRn body1) -> Int)     args_in_match (L _ (Match { m_pats = pats })) = length pats

GHC/Tc/Gen/Match.hs-boot view

@@ -2,16 +2,16 @@ import GHC.Hs           ( GRHSs, MatchGroup, LHsExpr ) import GHC.Tc.Types.Evidence  ( HsWrapper ) import GHC.Types.Name   ( Name )-import GHC.Tc.Utils.TcType( ExpSigmaType, TcRhoType )+import GHC.Tc.Utils.TcType( ExpSigmaType, ExpRhoType ) import GHC.Tc.Types     ( TcM )-import GHC.Types.SrcLoc ( Located ) import GHC.Hs.Extension ( GhcRn, GhcTc )+import GHC.Parser.Annotation ( LocatedN )  tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)-              -> TcRhoType+              -> ExpRhoType               -> TcM (GRHSs GhcTc (LHsExpr GhcTc)) -tcMatchesFun :: Located Name+tcMatchesFun :: LocatedN Name              -> MatchGroup GhcRn (LHsExpr GhcRn)              -> ExpSigmaType              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))

GHC/Tc/Gen/Pat.hs view

@@ -1,18 +1,18 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}- {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}+ -- | Typechecking patterns module GHC.Tc.Gen.Pat    ( tcLetPat@@ -33,6 +33,7 @@ import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcSyntaxOpGen, tcInferRho )  import GHC.Hs+import GHC.Rename.Utils import GHC.Tc.Utils.Zonk import GHC.Tc.Gen.Sig( TcPragEnv, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Monad@@ -53,6 +54,7 @@ import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin import GHC.Core.TyCon+import GHC.Core.Type import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Core.ConLike@@ -63,9 +65,10 @@ import GHC.Types.Var.Set import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic import qualified GHC.LanguageExtensions as LangExt import Control.Arrow  ( second )-import Control.Monad  ( when )+import Control.Monad import GHC.Data.List.SetOps ( getNth )  {-@@ -329,7 +332,7 @@ tc_lpat :: Scaled ExpSigmaType         -> Checker (LPat GhcRn) (LPat GhcTc) tc_lpat pat_ty penv (L span pat) thing_inside-  = setSrcSpan span $+  = setSrcSpanA span $     do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat pat_ty penv pat)                                           thing_inside         ; return (L span pat', res) }@@ -398,7 +401,7 @@   AsPat x (L nm_loc name) pat -> do         { mult_wrap <- checkManyPattern pat_ty             -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.-        ; (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)+        ; (wrap, bndr_id) <- setSrcSpanA nm_loc (tcPatBndr penv name pat_ty)         ; (pat', res) <- tcExtendIdEnv1 name bndr_id $                          tc_lpat (pat_ty `scaledSet`(mkCheckExpType $ idType bndr_id))                                  penv pat thing_inside@@ -425,10 +428,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) @@ -457,7 +459,7 @@    f :: Int -> blah    f (pair True -> x) = ...here (x :: forall b. b -> (Int,b)) -The expresion (pair True) should have type+The expression (pair True) should have type     pair True :: Int -> forall b. b -> (Int,b) so that it is ready to consume the incoming Int. It should be an arrow type (t1 -> t2); hence using (tcInferRho expr).@@ -510,6 +512,7 @@               tc = tupleTyCon boxity arity               -- NB: tupleTyCon does not flatten 1-tuples               -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make+        ; checkTupSize arity         ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)                                                penv (scaledThing pat_ty)                      -- Unboxed tuples have RuntimeRep vars, which we discard:@@ -530,8 +533,8 @@                                  -- pat_ty /= pat_ty iff coi /= IdCo               possibly_mangled_result                 | gopt Opt_IrrefutableTuples dflags &&-                  isBoxed boxity      = LazyPat noExtField (noLoc unmangled_result)-                | otherwise           = unmangled_result+                  isBoxed boxity   = LazyPat noExtField (noLocA unmangled_result)+                | otherwise        = unmangled_result          ; pat_ty <- readExpType (scaledThing pat_ty)         ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced@@ -553,7 +556,7 @@  ------------------------ -- Data constructors-  ConPat NoExtField con arg_pats ->+  ConPat _ con arg_pats ->     tcConPat penv con pat_ty arg_pats thing_inside  ------------------------@@ -651,7 +654,7 @@             <- tcSyntaxOpGen orig minus [SynType pat_exp_ty, SynRho] SynAny $                \ [lit2_ty, var_ty] _ ->                do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)-                  ; (wrap, bndr_id) <- setSrcSpan nm_loc $+                  ; (wrap, bndr_id) <- setSrcSpanA nm_loc $                                      tcPatBndr penv name (unrestricted $ mkCheckExpType var_ty)                            -- co :: var_ty ~ idType bndr_id @@ -735,7 +738,7 @@                  HsWrapper)         -- Coercion due to unification with actual ty                                     -- Of shape:  res_ty ~ sig_ty tcPatSig in_pat_bind sig res_ty- = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig+ = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt HM_Sig sig OpenKind         -- sig_tvs are the type variables free in 'sig',         -- and not already in scope. These are the ones         -- that should be brought into scope@@ -837,13 +840,22 @@ RIP GADT refinement: refinements have been replaced by the use of explicit equality constraints that are used in conjunction with implication constraints to express the local scope of GADT refinements.++Note [Freshen existentials]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is essential that these existentials are freshened.+Otherwise, if we have something like+  case (a :: Ex, b :: Ex) of (MkEx ..., MkEx ...) -> ...+we'll give both unpacked existential variables the+same name, leading to shadowing.+ -}  --      Running example: -- MkT :: forall a b c. (a~[b]) => b -> c -> T a --       with scrutinee of type (T ty) -tcConPat :: PatEnv -> Located Name+tcConPat :: PatEnv -> LocatedN Name          -> Scaled ExpSigmaType    -- Type of the pattern          -> HsConPatDetails GhcRn -> TcM a          -> TcM (Pat GhcTc, a)@@ -856,7 +868,7 @@                                              pat_ty arg_pats thing_inside         } -tcDataConPat :: PatEnv -> Located Name -> DataCon+tcDataConPat :: PatEnv -> LocatedN Name -> DataCon              -> Scaled ExpSigmaType        -- Type of the pattern              -> HsConPatDetails GhcRn -> TcM a              -> TcM (Pat GhcTc, a)@@ -875,24 +887,25 @@         ; pat_ty <- readExpType (scaledThing pat_ty_scaled)            -- Add the stupid theta-        ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys+        ; setSrcSpanA con_span $ addDataConStupidTheta data_con ctxt_res_tys +        -- Check that this isn't a GADT pattern match+        -- in situations in which that isn't allowed.         ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys)-        ; checkExistentials ex_tvs all_arg_tys penv+        ; checkGADT (RealDataCon data_con) ex_tvs all_arg_tys penv -        ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys+        ; tenv1 <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys                   -- NB: Do not use zipTvSubst!  See #14154                   -- We want to create a well-kinded substitution, so                   -- that the instantiated type is well-kinded -        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv1 ex_tvs                      -- Get location from monad, not from ex_tvs--        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys-              -- pat_ty' is type of the actual constructor application-              -- pat_ty' /= pat_ty iff coi /= IdCo+                     -- This freshens: See Note [Freshen existentials]+                     -- Why "super"? See Note [Binding when lookup up instances]+                     -- in GHC.Core.InstEnv. -              arg_tys' = substScaledTys tenv arg_tys+        ; let arg_tys' = substScaledTys tenv arg_tys               pat_mult = scaledMult pat_ty_scaled               arg_tys_scaled = map (scaleScaled pat_mult) arg_tys' @@ -909,7 +922,7 @@           then do { -- The common case; no class bindings etc                     -- (see Note [Arrows and patterns])                     (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys_scaled-                                                  penv arg_pats thing_inside+                                                  tenv penv arg_pats thing_inside                   ; let res_pat = ConPat { pat_con = header                                          , pat_args = arg_pats'                                          , pat_con_ext = ConPatTc@@ -945,7 +958,7 @@         ; given <- newEvVars theta'         ; (ev_binds, (arg_pats', res))              <- checkConstraints skol_info ex_tvs' given $-                tcConArgs (RealDataCon data_con) arg_tys_scaled penv arg_pats thing_inside+                tcConArgs (RealDataCon data_con) arg_tys_scaled tenv penv arg_pats thing_inside          ; let res_pat = ConPat                 { pat_con   = header@@ -961,18 +974,23 @@         ; return (mkHsWrapPat wrap res_pat pat_ty, res)         } } -tcPatSynPat :: PatEnv -> Located Name -> PatSyn+tcPatSynPat :: PatEnv -> LocatedN Name -> PatSyn             -> Scaled ExpSigmaType         -- Type of the pattern             -> HsConPatDetails GhcRn -> TcM a             -> TcM (Pat GhcTc, a)-tcPatSynPat penv (L con_span _) pat_syn pat_ty arg_pats thing_inside+tcPatSynPat penv (L con_span con_name) pat_syn pat_ty arg_pats thing_inside   = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn          ; (subst, univ_tvs') <- newMetaTyVars univ_tvs +        -- Check that we aren't matching on a GADT-like pattern synonym+        -- in situations in which that isn't allowed.         ; let all_arg_tys = ty : prov_theta ++ (map scaledThing arg_tys)-        ; checkExistentials ex_tvs all_arg_tys penv+        ; checkGADT (PatSynCon pat_syn) ex_tvs all_arg_tys penv+         ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs+           -- This freshens: Note [Freshen existentials]+         ; let ty'         = substTy tenv ty               arg_tys'    = substScaledTys tenv arg_tys               pat_mult    = scaledMult pat_ty@@ -998,13 +1016,15 @@                             LamPat mc -> PatSkol (PatSynCon pat_syn) mc                             LetPat {} -> UnkSkol -- Doesn't matter -        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'+        ; req_wrap <- instCall (OccurrenceOf con_name) (mkTyVarTys univ_tvs') req_theta'+                      -- Origin (OccurrenceOf con_name):+                      -- see Note [Call-stack tracing of pattern synonyms]         ; traceTc "instCall" (ppr req_wrap)          ; traceTc "checkConstraints {" Outputable.empty         ; (ev_binds, (arg_pats', res))              <- checkConstraints skol_info ex_tvs' prov_dicts' $-                tcConArgs (PatSynCon pat_syn) arg_tys_scaled penv arg_pats thing_inside+                tcConArgs (PatSynCon pat_syn) arg_tys_scaled tenv penv arg_pats thing_inside          ; traceTc "checkConstraints }" (ppr ev_binds)         ; let res_pat = ConPat { pat_con   = L con_span $ PatSynCon pat_syn@@ -1020,6 +1040,29 @@         ; pat_ty <- readExpType (scaledThing pat_ty)         ; return (mkHsWrapPat (wrap <.> mult_wrap) res_pat pat_ty, res) } +{- Note [Call-stack tracing of pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: HasCallStack => blah++   pattern Annotated :: HasCallStack => (CallStack, a) -> a+   pattern Annotated x <- (f -> x)++When we pattern-match against `Annotated` we will call `f`, and must+pass a call-stack.  We may want `Annotated` itself to propagate the call+stack, so we give it a HasCallStack constraint too.  But then we expect+to see `Annotated` in the call stack.++This is achieve easily, but a bit trickily.  When we instantiate+Annotated's "required" constraints, in tcPatSynPat, give them a+CtOrigin of (OccurrenceOf "Annotated"). That way the special magic+in GHC.Tc.Solver.Canonical.canClassNC which deals with CallStack+constraints will kick in: that logic only fires on constraints+whose Origin is (OccurrenceOf f).++See also Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+-} ---------------------------- -- | Convenient wrapper for calling a matchExpectedXXX function matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))@@ -1110,17 +1153,84 @@    error messages; it's a purely internal thing -} -tcConArgs :: ConLike -> [Scaled TcSigmaType]-          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)+{-+Note [Typechecking type applications in patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How should we typecheck type applications in patterns, such as+   f :: Either (Maybe a) [b] -> blah+   f (Left @x @[y] (v::Maybe x)) = blah -tcConArgs con_like arg_tys penv con_args thing_inside = case con_args of-  PrefixCon arg_pats -> do+It's quite straightforward, and very similar to the treatment of+pattern signatures.++* Step 1: bind the newly-in-scope type variables x and y to fresh+  unification variables, say x0 and y0.++* Step 2: typecheck those type arguments, @x and @[y], to get the+  types x0 and [y0].++* Step 3: Unify those types with the type arguments we expect,+  in this case (Maybe a) and [b].  These unifications will+  (perhaps after the constraint solver has done its work)+  unify   x0 := Maybe a+          y0 := b+  Thus we learn that x stands for (Maybe a) and y for b.++Wrinkles:++* Surprisingly, we can discard the coercions arising from+  these unifications.  The *only* thing the unification does is+  to side-effect those unification variables, so that we know+  what type x and y stand for; and cause an error if the equality+  is not soluble.  It's a bit like a Derived constraint arising+  from a functional dependency.++* Exactly the same works for existential arguments+     data T where+        MkT :: a -> a -> T+     f :: T -> blah+     f (MkT @x v w) = ...+   Here we create a fresh unification variable x0 for x, and+   unify it with the fresh existential variable bound by the pattern.++* Note that both here and in pattern signatures the unification may+  not even end up unifying the variable.  For example+     type S a b = a+     f :: Maybe a -> Bool+     f (Just @(S a b) x) = True :: b+   In Step 3 we will unify (S a0 b0 ~ a), which succeeds, but has no+   effect on the unification variable b0, to which 'b' is bound.+   Later, in the RHS, we find that b0 must be Bool, and unify it there.+   All is fine.+-}++tcConArgs :: ConLike+          -> [Scaled TcSigmaType]+          -> TCvSubst            -- Instantiating substitution for constructor type+          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)+tcConArgs con_like arg_tys tenv penv con_args thing_inside = case con_args of+  PrefixCon type_args arg_pats -> do         { checkTc (con_arity == no_of_args)     -- Check correct arity                   (arityErr (text "constructor") con_like con_arity no_of_args)++        ; let con_binders = conLikeUserTyVarBinders con_like+        ; checkTc (type_args `leLength` con_binders)+                  (conTyArgArityErr con_like (length con_binders) (length type_args))+         ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys-        ; (arg_pats', res) <- tcMultiple tcConArg penv pats_w_tys-                                              thing_inside-        ; return (PrefixCon arg_pats', res) }+        ; (type_args', (arg_pats', res))+            <- tcMultiple tcConTyArg penv type_args $+               tcMultiple tcConArg penv pats_w_tys thing_inside++          -- This unification is straight from Figure 7 of+          -- "Type Variables in Patterns", Haskell'18+        ; _ <- zipWithM (unifyType Nothing) type_args' (substTyVars tenv $+                                                        binderVars con_binders)+          -- OK to drop coercions here. These unifications are all about+          -- guiding inference based on a user-written type annotation+          -- See Note [Typechecking type applications in patterns]++        ; return (PrefixCon type_args arg_pats', res) }     where       con_arity  = conLikeArity con_like       no_of_args = length arg_pats@@ -1142,14 +1252,14 @@       tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))                           (LHsRecField GhcTc (LPat GhcTc))       tc_field penv-               (L l (HsRecField (L loc (FieldOcc sel (L lr rdr))) pat pun))+               (L l (HsRecField ann (L loc (FieldOcc sel (L lr rdr))) pat pun))                thing_inside         = do { sel'   <- tcLookupId sel              ; pat_ty <- setSrcSpan loc $ find_field_ty sel                                             (occNameFS $ rdrNameOcc rdr)              ; (pat', res) <- tcConArg penv (pat, pat_ty) thing_inside-             ; return (L l (HsRecField (L loc (FieldOcc sel' (L lr rdr))) pat'-                                                                      pun), res) }+             ; return (L l (HsRecField ann (L loc (FieldOcc sel' (L lr rdr))) pat'+                                                                        pun), res) }         find_field_ty :: Name -> FieldLabelString -> TcM (Scaled TcType)@@ -1175,6 +1285,22 @@           -- dataConFieldLabels will be empty (and each field in the pattern           -- will generate an error below). +tcConTyArg :: Checker (HsPatSigType GhcRn) TcType+tcConTyArg penv rn_ty thing_inside+  = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsPatSigType TypeAppCtxt HM_TyAppPat rn_ty AnyKind+               -- AnyKind is a bit suspect: it really should be the kind gotten+               -- from instantiating the constructor type. But this would be+               -- hard to get right, because earlier type patterns might influence+               -- the kinds of later patterns. In any case, it all gets checked+               -- by the calls to unifyType in tcConArgs, which will also unify+               -- kinds.+       ; when (not (null sig_ibs) && inPatBind penv) $+           addErr (text "Binding type variables is not allowed in pattern bindings")+       ; result <- tcExtendNameTyVarEnv sig_wcs $+                   tcExtendNameTyVarEnv sig_ibs $+                   thing_inside+       ; return (arg_ty, result) }+ tcConArg :: Checker (LPat GhcRn, Scaled TcSigmaType) (LPat GhcTc) tcConArg penv (arg_pat, Scaled arg_mult arg_ty)   = tc_lpat (Scaled arg_mult (mkCheckExpType arg_ty)) penv arg_pat@@ -1196,6 +1322,14 @@          --     because the constructor might have existentials     inst_theta = substTheta tenv stupid_theta +conTyArgArityErr :: ConLike+                 -> Int   -- expected # of arguments+                 -> Int   -- actual # of arguments+                 -> SDoc+conTyArgArityErr con_like expected_number actual_number+  = text "Too many type arguments in constructor pattern for" <+> quotes (ppr con_like) $$+    text "Expected no more than" <+> ppr expected_number <> semi <+> text "got" <+> ppr actual_number+ {- Note [Arrows and patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1215,12 +1349,16 @@  The Right Thing is not to confuse these constraints together. But for now the Easy Thing is to ensure that we do not have existential or-GADT constraints in a 'proc', and to short-cut the constraint-simplification for such vanilla patterns so that it binds no-constraints. Hence the 'fast path' in tcConPat; but it's also a good-plan for ordinary vanilla patterns to bypass the constraint-simplification step.+GADT constraints in a 'proc', which we do by disallowing any+non-vanilla pattern match (i.e. one that introduces existential+variables or provided constraints), in tcDataConPat and tcPatSynPat. +We also short-cut the constraint simplification for such vanilla patterns,+so that we bind no constraints. Hence the 'fast path' in tcDataConPat;+which applies more generally (not just within 'proc'), as it's a good+plan in general to bypass the constraint simplification step entirely+when it's not needed.+ ************************************************************************ *                                                                      *                 Note [Pattern coercions]@@ -1313,17 +1451,30 @@    msg = hang (text "In the pattern:") 2 (ppr pat)  ------------------------------------------------checkExistentials :: [TyVar]   -- existentials-                  -> [Type]    -- argument types-                  -> PatEnv -> TcM ()-    -- See Note [Existential check]]++-- | Check that a pattern isn't a GADT, or doesn't have existential variables,+-- in a situation in which that is not permitted (inside a lazy pattern, or+-- in arrow notation).+checkGADT :: ConLike+          -> [TyVar] -- ^ existentials+          -> [Type]  -- ^ argument types+          -> PatEnv+          -> TcM ()+checkGADT conlike ex_tvs arg_tys = \case+  PE { pe_ctxt = LetPat {} }+    -> return ()+  PE { pe_ctxt = LamPat (ArrowMatchCtxt {}) }+    | not $ isVanillaConLike conlike     -- See Note [Arrows and patterns]-checkExistentials ex_tvs tys _-  | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return ()-checkExistentials _ _ (PE { pe_ctxt = LetPat {}})         = return ()-checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr })  = failWithTc existentialProcPat-checkExistentials _ _ (PE { pe_lazy = True })             = failWithTc existentialLazyPat-checkExistentials _ _ _                                   = return ()+    -> failWithTc existentialProcPat+  PE { pe_lazy = True }+    | has_existentials+    -- See Note [Existential check]+    -> failWithTc existentialLazyPat+  _ -> return ()+  where+    has_existentials :: Bool+    has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs  existentialLazyPat :: SDoc existentialLazyPat

GHC/Tc/Gen/Rule.hs view

@@ -1,12 +1,11 @@+{-# LANGUAGE TypeFamilies #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1993-1998  -} -{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TypeFamilies #-}- -- | Typechecking rewrite rules module GHC.Tc.Gen.Rule ( tcRules ) where @@ -34,6 +33,7 @@ import GHC.Types.Basic ( RuleName ) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Bag @@ -99,12 +99,12 @@ -}  tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTc]-tcRules decls = mapM (wrapLocM tcRuleDecls) decls+tcRules decls = mapM (wrapLocMA tcRuleDecls) decls  tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTc) tcRuleDecls (HsRules { rds_src = src                      , rds_rules = decls })-   = do { tc_decls <- mapM (wrapLocM tcRule) decls+   = do { tc_decls <- mapM (wrapLocMA tcRule) decls         ; return $ HsRules { rds_ext   = noExtField                            , rds_src   = src                            , rds_rules = tc_decls } }@@ -175,7 +175,7 @@                          , rd_name = rname                          , rd_act = act                          , rd_tyvs = ty_bndrs -- preserved for ppr-ing-                         , rd_tmvs = map (noLoc . RuleBndr noExtField . noLoc)+                         , rd_tmvs = map (noLoc . RuleBndr noAnn . noLocA)                                          (qtkvs ++ tpl_ids)                          , rd_lhs  = mkHsDictLet lhs_binds lhs'                          , rd_rhs  = mkHsDictLet rhs_binds rhs' } }@@ -229,7 +229,7 @@ --  If there's an explicit forall, the renamer would have already reported an --   error for each out-of-scope type variable used   = do  { let ctxt = RuleSigCtxt name-        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty+        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt HM_Sig rn_ty OpenKind         ; let id  = mkLocalId name Many id_ty                     -- See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType

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,7 +30,9 @@ 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.Utils.Zonk import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType@@ -39,18 +41,23 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs ) import GHC.Tc.Utils.Env( tcLookupId ) import GHC.Tc.Types.Evidence( HsWrapper, (<.>) )+import GHC.Core( hasSomeUnfolding ) import GHC.Core.Type ( mkTyVarBinders ) import GHC.Core.Multiplicity  import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Ppr import GHC.Types.Var ( TyVar, Specificity(..), tyVarKind, binderVars )-import GHC.Types.Id  ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )+import GHC.Types.Id  ( Id, idName, idType, setInlinePragma+                     , mkLocalId, realIdUnfolding ) import GHC.Builtin.Names( mkUnboundName ) import GHC.Types.Basic import GHC.Unit.Module( getModule ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Utils.Misc as Utils ( singleton ) import GHC.Data.Maybe( orElse )@@ -100,21 +107,8 @@   unification variables is correct because we are in tcMonoBinds.  -Note [Scoped tyvars]-~~~~~~~~~~~~~~~~~~~~-The -XScopedTypeVariables flag brings lexically-scoped type variables-into scope for any explicitly forall-quantified type variables:-        f :: forall a. a -> a-        f x = e-Then 'a' is in scope inside 'e'.--However, we do *not* support this-  - For pattern bindings e.g-        f :: forall a. a->a-        (f,g) = e- Note [Binding scoped type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The type variables *brought into lexical scope* by a type signature may be a subset of the *quantified type variables* of the signatures, for two reasons:@@ -193,13 +187,13 @@        ; return [TcIdSig sig] }  tcTySig (L loc (TypeSig _ names sig_ty))-  = setSrcSpan loc $-    do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)+  = setSrcSpanA loc $+    do { sigs <- sequence [ tcUserTypeSig (locA loc) sig_ty (Just name)                           | L _ name <- names ]        ; return (map TcIdSig sigs) }  tcTySig (L loc (PatSynSig _ names sig_ty))-  = setSrcSpan loc $+  = setSrcSpanA loc $     do { tpsigs <- sequence [ tcPatSynSig name sig_ty                             | L _ name <- names ]        ; return (map TcPatSynSig tpsigs) }@@ -260,13 +254,17 @@                 , sig_loc  = getSrcSpan id }  isCompleteHsSig :: LHsSigWcType GhcRn -> Bool--- ^ If there are no wildcards, return a LHsSigType-isCompleteHsSig (HsWC { hswc_ext  = wcs-                      , hswc_body = HsIB { hsib_body = hs_ty } })-   = null wcs && no_anon_wc hs_ty+-- ^ If there are no wildcards, return a LHsSigWcType+isCompleteHsSig (HsWC { hswc_ext = wcs, hswc_body = hs_sig_ty })+   = null wcs && no_anon_wc_sig_ty hs_sig_ty -no_anon_wc :: LHsType GhcRn -> Bool-no_anon_wc lty = go lty+no_anon_wc_sig_ty :: LHsSigType GhcRn -> Bool+no_anon_wc_sig_ty (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = body}))+  =  all no_anon_wc_tvb (hsOuterExplicitBndrs outer_bndrs)+  && no_anon_wc_ty body++no_anon_wc_ty :: LHsType GhcRn -> Bool+no_anon_wc_ty lty = go lty   where     go (L _ ty) = case ty of       HsWildCardTy _                 -> False@@ -288,25 +286,27 @@       HsForAllTy { hst_tele = tele                  , hst_body = ty } -> no_anon_wc_tele tele                                         && go ty-      HsQualTy { hst_ctxt = L _ ctxt-               , hst_body = ty }  -> gos ctxt && go ty-      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty+      HsQualTy { hst_ctxt = ctxt+               , hst_body = ty }  -> gos (fromMaybeContext ctxt) && go ty+      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpanA ty       HsSpliceTy{} -> True       HsTyLit{} -> True       HsTyVar{} -> True       HsStarTy{} -> True-      XHsType (NHsCoreTy{}) -> True      -- Core type, which does not have any wildcard+      XHsType{} -> True       -- HsCoreTy, which does not have any wildcard      gos = all go  no_anon_wc_tele :: HsForAllTelescope GhcRn -> Bool no_anon_wc_tele tele = case tele of-  HsForAllVis   { hsf_vis_bndrs   = ltvs } -> all (go . unLoc) ltvs-  HsForAllInvis { hsf_invis_bndrs = ltvs } -> all (go . unLoc) ltvs-  where-    go (UserTyVar _ _ _)      = True-    go (KindedTyVar _ _ _ ki) = no_anon_wc ki+  HsForAllVis   { hsf_vis_bndrs   = ltvs } -> all no_anon_wc_tvb ltvs+  HsForAllInvis { hsf_invis_bndrs = ltvs } -> all no_anon_wc_tvb ltvs +no_anon_wc_tvb :: LHsTyVarBndr flag GhcRn -> Bool+no_anon_wc_tvb (L _ tvb) = case tvb of+  UserTyVar _ _ _      -> True+  KindedTyVar _ _ _ ki -> no_anon_wc_ty ki+ {- Note [Fail eagerly on bad signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a type signature is wrong, fail immediately:@@ -357,40 +357,34 @@  * 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 -- See Note [Pattern synonym signatures] -- See Note [Recipe for checking a signature] in GHC.Tc.Gen.HsType-tcPatSynSig name sig_ty-  | HsIB { hsib_ext = implicit_hs_tvs-         , hsib_body = hs_ty }  <- sig_ty-  , (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   $+tcPatSynSig name sig_ty@(L _ (HsSig{sig_bndrs = hs_outer_bndrs, sig_body = hs_ty}))+  | (hs_req, hs_ty1) <- splitLHsQualTy hs_ty+  , (ex_hs_tvbndrs, hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1+  = do { traceTc "tcPatSynSig 1" (ppr sig_ty)++       ; let skol_info = DataConSkol name+       ; (tclvl, wanted, (outer_bndrs, (ex_bndrs, (req, prov, body_ty))))+           <- pushLevelAndSolveEqualitiesX "tcPatSynSig"           $+                     -- See Note [solveEqualities in tcPatSynSig]+              tcOuterTKBndrs skol_info hs_outer_bndrs $+              tcExplicitTKBndrs ex_hs_tvbndrs         $               do { req     <- tcHsContext hs_req                  ; prov    <- tcHsContext hs_prov                  ; body_ty <- tcHsOpenType hs_body_ty@@ -398,74 +392,64 @@                      -- e.g. pattern Zero <- 0#   (#12094)                  ; return (req, prov, body_ty) } -       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvbndrs-                                                 req ex_tvbndrs prov body_ty+       ; let implicit_tvs :: [TcTyVar]+             univ_bndrs   :: [TcInvisTVBinder]+             (implicit_tvs, univ_bndrs) = case outer_bndrs of+               HsOuterImplicit{hso_ximplicit = implicit_tvs} -> (implicit_tvs, [])+               HsOuterExplicit{hso_xexplicit = univ_bndrs}   -> ([], univ_bndrs) +       ; implicit_tvs <- zonkAndScopedSort implicit_tvs+       ; let implicit_bndrs = mkTyVarBinders SpecifiedSpec implicit_tvs+        -- Kind generalisation-       ; kvs <- kindGeneralizeAll ungen_patsyn_ty+       ; let ungen_patsyn_ty = build_patsyn_type implicit_bndrs univ_bndrs+                                                 req ex_bndrs prov body_ty        ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)+       ; kvs <- kindGeneralizeAll ungen_patsyn_ty+       ; reportUnsolvedEqualities skol_info kvs 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-       ; 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+       ; ze                   <- mkEmptyZonkEnv NoFlexi+       ; (ze, kv_bndrs)       <- zonkTyVarBindersX   ze (mkTyVarBinders InferredSpec kvs)+       ; (ze, implicit_bndrs) <- zonkTyVarBindersX   ze implicit_bndrs+       ; (ze, univ_bndrs)     <- zonkTyVarBindersX   ze univ_bndrs+       ; (ze, ex_bndrs)       <- zonkTyVarBindersX   ze ex_bndrs+       ; req                  <- zonkTcTypesToTypesX ze req+       ; prov                 <- zonkTcTypesToTypesX ze prov+       ; body_ty              <- zonkTcTypeToTypeX   ze 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 implicit_bndrs univ_bndrs req ex_bndrs 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'-              , 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' ]+         vcat [ text "kvs"          <+> ppr_tvs (binderVars kv_bndrs)+              , text "implicit_tvs" <+> ppr_tvs (binderVars implicit_bndrs)+              , text "univ_tvs"     <+> ppr_tvs (binderVars univ_bndrs)+              , text "req" <+> ppr req+              , text "ex_tvs" <+> ppr_tvs (binderVars ex_bndrs)+              , 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' }) }+                      , patsig_implicit_bndrs = kv_bndrs ++ implicit_bndrs+                      , patsig_univ_bndrs     = univ_bndrs+                      , patsig_req            = req+                      , patsig_ex_bndrs       = ex_bndrs+                      , patsig_prov           = prov+                      , patsig_body_ty        = body_ty }) }   where     ctxt = PatSynCtxt name -    build_patsyn_type kvs imp univ_bndrs req ex_bndrs prov body-      = mkInfForAllTys kvs $-        mkSpecForAllTys imp $+    build_patsyn_type implicit_bndrs univ_bndrs req ex_bndrs prov body+      = mkInvisForAllTys implicit_bndrs $         mkInvisForAllTys univ_bndrs $         mkPhiTy req $         mkInvisForAllTys ex_bndrs $@@ -530,7 +514,7 @@ unification takes place, we'll find out when we do the final impedance-matching check in GHC.Tc.Gen.Bind.mkExport -See Note [Signature skolems] in GHC.Tc.Utils.TcType+See Note [TyVarTv] in GHC.Tc.Utils.TcMType  None of this applies to a function binding with a complete signature, which doesn't use tcInstSig.  See GHC.Tc.Gen.Bind.tcPolyCheck.@@ -611,7 +595,7 @@             -- and inl2 is a user NOINLINE pragma; we don't want to complain          warn_multiple_inlines inl2 inls        | otherwise-       = setSrcSpan loc $+       = setSrcSpanA loc $          addWarnTc NoReason                      (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)                        2 (vcat (text "Ignoring all but the first"@@ -737,8 +721,8 @@ tcSpecPrags poly_id prag_sigs   = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)        ; unless (null bad_sigs) warn_discarded_sigs-       ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs-       ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }+       ; pss <- mapAndRecoverM (wrapLocMA (tcSpecPrag poly_id)) spec_sigs+       ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss }   where     spec_sigs = filter isSpecLSig prag_sigs     bad_sigs  = filter is_bad_sig prag_sigs@@ -805,11 +789,11 @@        ; if (not_specialising dflags) then             return []          else do-            { pss <- mapAndRecoverM (wrapLocM tcImpSpec)+            { pss <- mapAndRecoverM (wrapLocMA tcImpSpec)                      [L loc (name,prag)                              | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags                              , not (nameIsLocalOrFrom this_mod name) ]-            ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }+            ; return $ concatMap (\(L l ps) -> map (L (locA l)) ps) pss } }   where     -- Ignore SPECIALISE pragmas for imported things     -- when we aren't specialising, or when we aren't generating@@ -817,28 +801,44 @@     -- we don't want complaints about lack of INLINABLE pragmas     not_specialising dflags       | not (gopt Opt_Specialise dflags) = True-      | otherwise = case hscTarget dflags of-                      HscNothing -> True-                      HscInterpreted -> True-                      _other         -> False+      | otherwise = case backend dflags of+                      NoBackend   -> True+                      Interpreter -> True+                      _other      -> False  tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag] tcImpSpec (name, prag)  = do { id <- tcLookupId name-      ; if isAnyInlinePragma (idInlinePragma id)+      ; if hasSomeUnfolding (realIdUnfolding id)+           -- See Note [SPECIALISE pragmas for imported Ids]         then tcSpecPrag id prag         else do { addWarnTc NoReason (impSpecErr name)                 ; return [] } }-      -- If there is no INLINE/INLINABLE pragma there will be no unfolding. In-      -- that case, just delete the SPECIALISE pragma altogether, lest the-      -- desugarer fall over because it can't find the unfolding. See #18118.  impSpecErr :: Name -> SDoc impSpecErr name   = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))-       2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"-               , parens $ sep-                   [ text "or its defining module" <+> quotes (ppr mod)-                   , text "was compiled without -O"]])+       2 (vcat [ text "because its definition is not visible in this module"+               , text "Hint: make sure" <+> ppr mod <+> text "is compiled with -O"+               , text "      and that" <+> quotes (ppr name)+                 <+> text "has an INLINABLE pragma" ])   where     mod = nameModule name++{- Note [SPECIALISE pragmas for imported Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An imported Id may or may not have an unfolding.  If not, we obviously+can't specialise it here; indeed the desugar falls over (#18118).++We used to test whether it had a user-specified INLINABLE pragma but,+because of Note [Worker-wrapper for INLINABLE functions] in+GHC.Core.Opt.WorkWrap, even an INLINABLE function may end up with+a wrapper that has no pragma, just an unfolding (#19246).  So now+we just test whether the function has an unfolding.++There's a risk that a pragma-free function may have an unfolding now+(because it is fairly small), and then gets a bit bigger, and no+longer has an unfolding in the future.  But then you'll get a helpful+error message suggesting an INLINABLE pragma, which you can follow.+That seems enough for now.+-}

GHC/Tc/Gen/Splice.hs view

@@ -1,26 +1,22 @@+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE InstanceSigs           #-}+{-# LANGUAGE MultiWayIf             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TupleSections          #-}+{-# LANGUAGE TypeFamilies           #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Template Haskell splices module GHC.Tc.Gen.Splice(      tcSpliceExpr, tcTypedBracket, tcUntypedBracket,@@ -38,89 +34,99 @@  import GHC.Prelude +import GHC.Driver.Plugins+import GHC.Driver.Main+import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Hooks+ import GHC.Hs-import GHC.Types.Annotations-import GHC.Driver.Finder-import GHC.Types.Name+ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Core.Multiplicity--import GHC.Utils.Outputable import GHC.Tc.Gen.Expr-import GHC.Types.SrcLoc-import GHC.Builtin.Names.TH import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Env import GHC.Tc.Types.Origin+import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.Zonk+import GHC.Tc.Solver+import GHC.Tc.Utils.TcMType+import GHC.Tc.Gen.HsType+import GHC.Tc.Instance.Family+import GHC.Tc.Utils.Instantiate++import GHC.Core.Multiplicity import GHC.Core.Coercion( etaExpandCoAxBranch )-import GHC.SysTools.FileCleanup ( newTempName, TempFileLifetime(..) )+import GHC.Core.Type as Type+import GHC.Core.TyCo.Rep as TyCoRep+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv as InstEnv -import Control.Monad+import GHC.Builtin.Names.TH+import GHC.Builtin.Names+import GHC.Builtin.Types +import GHC.ThToHs+import GHC.HsToCore.Docs+import GHC.HsToCore.Expr+import GHC.HsToCore.Monad+import GHC.IfaceToCore+import GHC.Iface.Load+ import GHCi.Message import GHCi.RemoteTypes import GHC.Runtime.Interpreter-import GHC.Runtime.Interpreter.Types-import GHC.Driver.Main-        -- These imports are the reason that GHC.Tc.Gen.Splice-        -- is very high up the module hierarchy+ import GHC.Rename.Splice( traceSplice, SpliceInfo(..))-import GHC.Types.Name.Reader-import GHC.Driver.Types-import GHC.ThToHs import GHC.Rename.Expr import GHC.Rename.Env import GHC.Rename.Utils  ( HsDocContext(..) ) import GHC.Rename.Fixity ( lookupFixityRn_help ) import GHC.Rename.HsType-import GHC.Tc.Utils.Zonk-import GHC.Tc.Solver-import GHC.Core.Type as Type-import GHC.Types.Name.Set-import GHC.Tc.Utils.TcMType-import GHC.Tc.Gen.HsType-import GHC.IfaceToCore-import GHC.Core.TyCo.Rep as TyCoRep-import GHC.Tc.Instance.Family-import GHC.Core.FamInstEnv-import GHC.Core.InstEnv as InstEnv-import GHC.Tc.Utils.Instantiate-import GHC.Types.Name.Env-import GHC.Builtin.Names-import GHC.Builtin.Types-import GHC.Types.Name.Occurrence as OccName-import GHC.Driver.Hooks-import GHC.Types.Var-import GHC.Unit.Module-import GHC.Iface.Load+ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.PatSyn import GHC.Core.ConLike import GHC.Core.DataCon as DataCon-import GHC.Tc.Types.Evidence++import GHC.Types.FieldLabel+import GHC.Types.SrcLoc+import GHC.Types.Name.Env+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Types.Name.Occurrence as OccName+import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info-import GHC.HsToCore.Expr-import GHC.HsToCore.Monad-import GHC.Serialized-import GHC.Utils.Error-import GHC.Utils.Misc import GHC.Types.Unique import GHC.Types.Var.Set-import Data.List        ( find )-import Data.Maybe-import GHC.Data.FastString-import GHC.Types.Basic as BasicTypes hiding( SuccessFlag(..) )-import GHC.Data.Maybe( MaybeErr(..) )-import GHC.Driver.Session+import GHC.Types.Meta+import GHC.Types.Basic hiding( SuccessFlag(..) )+import GHC.Types.Error+import GHC.Types.Fixity as Hs+import GHC.Types.Annotations+import GHC.Types.Name+import GHC.Serialized++import GHC.Unit.Finder+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Deps++import GHC.Utils.Misc import GHC.Utils.Panic as Panic import GHC.Utils.Lexeme+import GHC.Utils.Outputable+import GHC.Utils.Logger++import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) )++import GHC.Data.FastString+import GHC.Data.Maybe( MaybeErr(..) ) import qualified GHC.Data.EnumSet as EnumSet-import GHC.Driver.Plugins-import GHC.Data.Bag  import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types@@ -132,12 +138,16 @@ import Unsafe.Coerce    ( unsafeCoerce ) #endif +import Control.Monad import Control.Exception import Data.Binary import Data.Binary.Get+import Data.List        ( find )+import Data.Maybe import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Dynamic  ( fromDynamic, toDyn )+import qualified Data.IntMap as IntMap import qualified Data.Map as Map import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep ) import Data.Data (Data)@@ -204,7 +214,7 @@                        rn_expr                        (unLoc (mkHsApp (mkLHsWrap (applyQuoteWrapper wrapper)                                                   (nlHsTyApp texpco [rep, expr_ty]))-                                      (noLoc (HsTcBracketOut noExtField (Just wrapper) brack ps'))))+                                      (noLocA (HsTcBracketOut noExtField (Just wrapper) brack ps'))))                        meta_ty res_ty } tcTypedBracket _ other_brack _   = pprPanic "tcTypedBracket" (ppr other_brack)@@ -557,7 +567,7 @@ (-fenable-th-splice-warnings). There are multiple reasons:    * It's not clear that the user that compiles a splice is the author of the code-    that produces the warning. Think of the situation where she just splices in+    that produces the warning. Think of the situation where they just splice in     code from a third-party library that produces incomplete pattern matches.     In this scenario, the user isn't even able to fix that warning.   * Gathering information for producing the warnings (pattern-match check@@ -573,8 +583,8 @@ consistently (#17270). In the future we could offer the Origin as part of the TH AST. That would enable us to give quotes from the current module get FromSource origin, and/or third library authors to tag certain parts of-generated code as FromSource to enable warnings. That effort is tracked in-#14838.+generated code as FromSource to enable warnings.+That effort is tracked in #14838. -}  {-@@ -587,7 +597,7 @@  tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty   = addErrCtxt (spliceCtxtDoc splice) $-    setSrcSpan (getLoc expr)    $ do+    setSrcSpan (getLocA expr)    $ do     { stage <- getStage     ; case stage of           Splice {}            -> tcTopSplice expr res_ty@@ -634,7 +644,7 @@        -- But we still return a plausible expression        --   (a) in case we print it in debug messages, and        --   (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp-       ; return (HsSpliceE noExtField $+       ; return (HsSpliceE noAnn $                  HsSpliced noExtField (ThModFinalizers []) $                  HsSplicedExpr (unLoc expr'')) } @@ -655,7 +665,7 @@        ; lcl_env <- getLclEnv        ; let delayed_splice               = DelayedSplice lcl_env expr res_ty q_expr-       ; return (HsSpliceE noExtField (XSplice (HsSplicedT delayed_splice)))+       ; return (HsSpliceE noAnn (XSplice (HsSplicedT delayed_splice)))         } @@ -775,10 +785,11 @@                 -- LIE consulted by tcTopSpliceExpr                 -- and hence ensures the appropriate dictionary is bound by const_binds               ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]+              ; let loc' = noAnnSrcSpan loc               ; let specialised_to_annotation_wrapper_expr-                      = L loc (mkHsWrap wrapper-                                 (HsVar noExtField (L loc to_annotation_wrapper_id)))-              ; return (L loc (HsApp noExtField+                      = L loc' (mkHsWrap wrapper+                                 (HsVar noExtField (L (noAnnSrcSpan loc) to_annotation_wrapper_id)))+              ; return (L loc' (HsApp noComments                                 specialised_to_annotation_wrapper_expr expr'))                                 }) @@ -792,14 +803,14 @@                ann_value = serialized            } -convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)+convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized) convertAnnotationWrapper fhv = do   interp <- tcGetInterp-  case interp of+  case interpInstance interp of     ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv #if defined(HAVE_INTERNAL_INTERPRETER)     InternalInterp    -> do-      annotation_wrapper <- liftIO $ wormhole InternalInterp fhv+      annotation_wrapper <- liftIO $ wormhole interp fhv       return $ Right $         case unsafeCoerce annotation_wrapper of            AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->@@ -834,7 +845,7 @@       withForeignRefs (x : xs) f = withForeignRef x $ \r ->         withForeignRefs xs $ \rs -> f (r : rs)   interp <- tcGetInterp-  case interp of+  case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)     InternalInterp -> do       qs <- liftIO (withForeignRefs finRefs $ mapM localRef)@@ -871,9 +882,11 @@ runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)         -> LHsExpr GhcTc         -> TcM hs_syn-runMeta unwrap e-  = do { h <- getHooked runMetaHook defaultRunMeta-       ; unwrap h e }+runMeta unwrap e = do+    hooks <- getHooks+    case runMetaHook hooks of+        Nothing -> unwrap defaultRunMeta e+        Just h  -> unwrap h e  defaultRunMeta :: MetaHook TcM defaultRunMeta (MetaE r)@@ -913,7 +926,7 @@ --------------- runMeta' :: Bool                 -- Whether code should be printed in the exception message          -> (hs_syn -> SDoc)                                    -- how to print the code-         -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn))        -- How to run x+         -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn))        -- How to run x          -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or                                  --    something like that          -> TcM hs_syn           -- Of type t@@ -934,7 +947,7 @@          -- run plugins         ; hsc_env <- getTopEnv-        ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr+        ; expr' <- withPlugins hsc_env spliceRunAction expr          -- Desugar         ; ds_expr <- initDsTc (dsLExpr expr')@@ -958,7 +971,7 @@                 -- encounter them inside the try                 --                 -- See Note [Exceptions in TH]-          let expr_span = getLoc expr+          let expr_span = getLocA expr         ; either_tval <- tryAllM $                          setSrcSpan expr_span $ -- Set the span so that qLocation can                                                 -- see where this splice is@@ -1138,7 +1151,9 @@    qAddTempFile suffix = do     dflags <- getDynFlags-    liftIO $ newTempName dflags TFL_GhcSession suffix+    logger <- getLogger+    tmpfs  <- hsc_tmpfs <$> getTopEnv+    liftIO $ newTempName logger tmpfs dflags TFL_GhcSession suffix    qAddTopDecls thds = do       l <- getSrcSpanM@@ -1155,7 +1170,7 @@     where       checkTopDecl :: HsDecl GhcPs -> TcM ()       checkTopDecl (ValD _ binds)-        = mapM_ bindName (collectHsBindBinders binds)+        = mapM_ bindName (collectHsBindBinders CollNoDictBinders binds)       checkTopDecl (SigD _ _)         = return ()       checkTopDecl (AnnD _ _)@@ -1217,6 +1232,148 @@   qExtsEnabled =     EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv +  qPutDoc doc_loc s = do+    th_doc_var <- tcg_th_docs <$> getGblEnv+    resolved_doc_loc <- resolve_loc doc_loc+    is_local <- checkLocalName resolved_doc_loc+    unless is_local $ failWithTc $ text+      "Can't add documentation to" <+> ppr_loc doc_loc <+>+      text "as it isn't inside the current module"+    updTcRef th_doc_var (Map.insert resolved_doc_loc s)+    where+      resolve_loc (TH.DeclDoc n) = DeclDoc <$> lookupThName n+      resolve_loc (TH.ArgDoc n i) = ArgDoc <$> lookupThName n <*> pure i+      resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t)+      resolve_loc TH.ModuleDoc = pure ModuleDoc++      ppr_loc (TH.DeclDoc n) = ppr_th n+      ppr_loc (TH.ArgDoc n _) = ppr_th n+      ppr_loc (TH.InstDoc t) = ppr_th t+      ppr_loc TH.ModuleDoc = text "the module header"++      -- It doesn't make sense to add documentation to something not inside+      -- the current module. So check for it!+      checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n+      checkLocalName (ArgDoc n _) = nameIsLocalOrFrom <$> getModule <*> pure n+      checkLocalName (InstDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n+      checkLocalName ModuleDoc = pure True+++  qGetDoc (TH.DeclDoc n) = lookupThName n >>= lookupDeclDoc+  qGetDoc (TH.InstDoc t) = lookupThInstName t >>= lookupDeclDoc+  qGetDoc (TH.ArgDoc n i) = lookupThName n >>= lookupArgDoc i+  qGetDoc TH.ModuleDoc = do+    (moduleDoc, _, _) <- getGblEnv >>= extractDocs+    return (fmap unpackHDS moduleDoc)++-- | Looks up documentation for a declaration in first the current module,+-- otherwise tries to find it in another module via 'hscGetModuleInterface'.+lookupDeclDoc :: Name -> TcM (Maybe String)+lookupDeclDoc nm = do+  (_, DeclDocMap declDocs, _) <- getGblEnv >>= extractDocs+  fam_insts <- tcg_fam_insts <$> getGblEnv+  traceTc "lookupDeclDoc" (ppr nm <+> ppr declDocs <+> ppr fam_insts)+  case Map.lookup nm declDocs of+    Just doc -> pure $ Just (unpackHDS doc)+    Nothing -> do+      -- Wasn't in the current module. Try searching other external ones!+      mIface <- getExternalModIface nm+      case mIface of+        Nothing -> pure Nothing+        Just ModIface { mi_decl_docs = DeclDocMap dmap } ->+          pure $ unpackHDS <$> Map.lookup nm dmap++-- | Like 'lookupDeclDoc', looks up documentation for a function argument. If+-- it can't find any documentation for a function in this module, it tries to+-- find it in another module.+lookupArgDoc :: Int -> Name -> TcM (Maybe String)+lookupArgDoc i nm = do+  (_, _, ArgDocMap argDocs) <- getGblEnv >>= extractDocs+  case Map.lookup nm argDocs of+    Just m -> pure $ unpackHDS <$> IntMap.lookup i m+    Nothing -> do+      mIface <- getExternalModIface nm+      case mIface of+        Nothing -> pure Nothing+        Just ModIface { mi_arg_docs = ArgDocMap amap } ->+          pure $ unpackHDS <$> (Map.lookup nm amap >>= IntMap.lookup i)++-- | Returns the module a Name belongs to, if it is isn't local.+getExternalModIface :: Name -> TcM (Maybe ModIface)+getExternalModIface nm = do+  isLocal <- nameIsLocalOrFrom <$> getModule <*> pure nm+  if isLocal+    then pure Nothing+    else case nameModule_maybe nm of+          Nothing -> pure Nothing+          Just modNm -> do+            hsc_env <- getTopEnv+            iface <- liftIO $ hscGetModuleInterface hsc_env modNm+            pure (Just iface)++-- | Find the GHC name of the first instance that matches the TH type+lookupThInstName :: TH.Type -> TcM Name+lookupThInstName th_type = do+  cls_name <- inst_cls_name th_type+  insts <- reifyInstances' cls_name (inst_arg_types th_type)+  case insts of   -- This expands any type synonyms+    Left  (_, (inst:_)) -> return $ getName inst+    Left  (_, [])       -> noMatches+    Right (_, (inst:_)) -> return $ getName inst+    Right (_, [])       -> noMatches+  where+    noMatches = failWithTc $+      text "Couldn't find any instances of"+        <+> ppr_th th_type+        <+> text "to add documentation to"++    -- | Get the name of the class for the instance we are documenting+    -- > inst_cls_name (Monad Maybe) == Monad+    -- > inst_cls_name C = C+    inst_cls_name :: TH.Type -> TcM TH.Name+    inst_cls_name (TH.AppT t _)           = inst_cls_name t+    inst_cls_name (TH.SigT n _)           = inst_cls_name n+    inst_cls_name (TH.VarT n)             = pure n+    inst_cls_name (TH.ConT n)             = pure n+    inst_cls_name (TH.PromotedT n)        = pure n+    inst_cls_name (TH.InfixT _ n _)       = pure n+    inst_cls_name (TH.UInfixT _ n _)      = pure n+    inst_cls_name (TH.ParensT t)          = inst_cls_name t++    inst_cls_name (TH.ForallT _ _ _)      = inst_cls_name_err+    inst_cls_name (TH.ForallVisT _ _)     = inst_cls_name_err+    inst_cls_name (TH.AppKindT _ _)       = inst_cls_name_err+    inst_cls_name (TH.TupleT _)           = inst_cls_name_err+    inst_cls_name (TH.UnboxedTupleT _)    = inst_cls_name_err+    inst_cls_name (TH.UnboxedSumT _)      = inst_cls_name_err+    inst_cls_name TH.ArrowT               = inst_cls_name_err+    inst_cls_name TH.MulArrowT            = inst_cls_name_err+    inst_cls_name TH.EqualityT            = inst_cls_name_err+    inst_cls_name TH.ListT                = inst_cls_name_err+    inst_cls_name (TH.PromotedTupleT _)   = inst_cls_name_err+    inst_cls_name TH.PromotedNilT         = inst_cls_name_err+    inst_cls_name TH.PromotedConsT        = inst_cls_name_err+    inst_cls_name TH.StarT                = inst_cls_name_err+    inst_cls_name TH.ConstraintT          = inst_cls_name_err+    inst_cls_name (TH.LitT _)             = inst_cls_name_err+    inst_cls_name TH.WildCardT            = inst_cls_name_err+    inst_cls_name (TH.ImplicitParamT _ _) = inst_cls_name_err++    inst_cls_name_err = failWithTc $+      text "Couldn't work out what instance"+        <+> ppr_th th_type+        <+> text "is supposed to be"++    -- | Basically does the opposite of 'mkThAppTs'+    -- > inst_arg_types (Monad Maybe) == [Maybe]+    -- > inst_arg_types C == []+    inst_arg_types :: TH.Type -> [TH.Type]+    inst_arg_types (TH.AppT _ args) =+      let go (TH.AppT t ts) = t:go ts+          go t = [t]+        in go args+    inst_arg_types _ = []+ -- | Adds a mod finalizer reference to the local environment. addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM () addModFinalizerRef finRef = do@@ -1234,7 +1391,7 @@ finishTH :: TcM () finishTH = do   hsc_env <- getTopEnv-  case hsc_interp hsc_env of+  case interpInstance <$> hsc_interp hsc_env of     Nothing                  -> pure () #if defined(HAVE_INTERNAL_INTERPRETER)     Just InternalInterp      -> pure ()@@ -1259,11 +1416,11 @@ runTH :: Binary a => THResultType -> ForeignHValue -> TcM a runTH ty fhv = do   interp <- tcGetInterp-  case interp of+  case interpInstance interp of #if defined(HAVE_INTERNAL_INTERPRETER)     InternalInterp -> do        -- Run it in the local TcM-      hv <- liftIO $ wormhole InternalInterp fhv+      hv <- liftIO $ wormhole interp fhv       r <- runQuasi (unsafeCoerce hv :: TH.Q a)       return r #endif@@ -1288,7 +1445,7 @@ -- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs. runRemoteTH   :: IServInstance-  -> [Messages]   --  saved from nested calls to qRecover+  -> [Messages DecoratedSDoc]   --  saved from nested calls to qRecover   -> TcM () runRemoteTH iserv recovers = do   THMsg msg <- liftIO $ readIServ iserv getTHMessage@@ -1300,15 +1457,15 @@       writeTcRef v emptyMessages       runRemoteTH iserv (msgs : recovers)     EndRecover caught_error -> do-      let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of+      let (prev_msgs, rest) = case recovers of              [] -> panic "EndRecover"              a : b -> (a,b)       v <- getErrsVar-      (warn_msgs,_) <- readTcRef v+      warn_msgs <- getWarningMessages <$> readTcRef v       -- keep the warnings only if there were no errors       writeTcRef v $ if caught_error         then prev_msgs-        else (prev_warns `unionBags` warn_msgs, prev_errs)+        else mkMessages warn_msgs `unionMessages` prev_msgs       runRemoteTH iserv rest     _other -> do       r <- handleTHMessage msg@@ -1372,8 +1529,8 @@   case th_state of     Just rhv -> return rhv     Nothing -> do-      hsc_env <- getTopEnv-      fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH+      interp <- tcGetInterp+      fhv <- liftIO $ mkFinalizedHValue interp =<< iservCall i StartTH       writeTcRef (tcg_th_remote_state tcg) (Just fhv)       return fhv @@ -1401,13 +1558,15 @@   AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f   AddTempFile s -> wrapTHResult $ TH.qAddTempFile s   AddModFinalizer r -> do-    hsc_env <- getTopEnv-    wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef+    interp <- hscInterp <$> getTopEnv+    wrapTHResult $ liftIO (mkFinalizedHValue interp r) >>= addModFinalizerRef   AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str   AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs   AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str   IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext   ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled+  PutDoc l s -> wrapTHResult $ TH.qPutDoc l s+  GetDoc l -> wrapTHResult $ TH.qGetDoc l   FailIfErrs -> wrapTHResult failIfErrsM   _ -> panic ("handleTHMessage: unexpected message " ++ show msg) @@ -1431,6 +1590,19 @@  reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec] reifyInstances th_nm th_tys+  = do { insts <- reifyInstances' th_nm th_tys+       ; case insts of+           Left (cls, cls_insts) ->+             reifyClassInstances cls cls_insts+           Right (tc, fam_insts) ->+             reifyFamilyInstances tc fam_insts }++reifyInstances' :: TH.Name+                -> [TH.Type]+                -> TcM (Either (Class, [ClsInst]) (TyCon, [FamInst]))+                -- ^ Returns 'Left' in the case that the instances were found to+                -- be class instances, or 'Right' if they are family instances.+reifyInstances' th_nm th_tys    = addErrCtxt (text "In the argument of reifyInstances:"                  <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $      do { loc <- getSrcSpanM@@ -1445,32 +1617,38 @@                              -- must error before proceeding to typecheck the                              -- renamed type, as that will result in GHC                              -- internal errors (#13837).-               rnImplicitBndrs Nothing tv_rdrs $ \ tv_names ->+               rnImplicitTvOccs 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                 -- variables inside it (#7477) -        ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))+        ; traceTc "reifyInstances'" (ppr ty $$ ppr (tcTypeKind ty))         ; case splitTyConApp_maybe ty of   -- This expands any type synonyms             Just (tc, tys)                 -- See #7910                | Just cls <- tyConClass_maybe tc                -> do { inst_envs <- tcGetInstEnvs                      ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys-                     ; traceTc "reifyInstances1" (ppr matches)-                     ; reifyClassInstances cls (map fst matches ++ unifies) }+                     ; traceTc "reifyInstances'1" (ppr matches)+                     ; return $ Left (cls, map fst matches ++ unifies) }                | isOpenFamilyTyCon tc                -> do { inst_envs <- tcGetFamInstEnvs                      ; let matches = lookupFamInstEnv inst_envs tc tys-                     ; traceTc "reifyInstances2" (ppr matches)-                     ; reifyFamilyInstances tc (map fim_instance matches) }+                     ; traceTc "reifyInstances'2" (ppr matches)+                     ; return $ Right (tc, map fim_instance matches) }             _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))                                2 (text "is not a class constraint or type family application")) }   where@@ -1494,11 +1672,8 @@                         -- False <=> value namespace            -> String -> TcM (Maybe TH.Name) lookupName is_type_name s-  = do { lcl_env <- getLocalRdrEnv-       ; case lookupLocalRdrEnv lcl_env rdr_name of-           Just n  -> return (Just (reifyName n))-           Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name-                         ; return (fmap reifyName mb_nm) } }+  = do { mb_nm <- lookupOccRn_maybe rdr_name+       ; return (fmap reifyName mb_nm) }   where     th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M' @@ -1547,18 +1722,10 @@  lookupThName_maybe :: TH.Name -> TcM (Maybe Name) lookupThName_maybe th_name-  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)+  =  do { names <- mapMaybeM lookupOccRn_maybe (thRdrNameGuesses th_name)           -- Pick the first that works           -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A         ; return (listToMaybe names) }-  where-    lookup rdr_name-        = do {  -- Repeat much of lookupOccRn, because we want-                -- to report errors in a TH-relevant way-             ; rdr_env <- getLocalRdrEnv-             ; case lookupLocalRdrEnv rdr_env rdr_name of-                 Just name -> return (Just name)-                 Nothing   -> lookupGlobalOccRn_maybe rdr_name }  tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of GHC.Tc.Utils.Env.tcLookup; specialised mainly in that@@ -2144,12 +2311,12 @@ -- Arg of reify_for_all is always ForAllTy or a predicate FunTy reify_for_all argf ty   | isVisibleArgFlag argf-  = do let (req_bndrs, phi) = tcSplitForAllTysReq ty+  = do let (req_bndrs, phi) = tcSplitForAllReqTVBinders ty        tvbndrs' <- reifyTyVarBndrs req_bndrs        phi' <- reifyType phi        pure $ TH.ForallVisT tvbndrs' phi'   | otherwise-  = do let (inv_bndrs, phi) = tcSplitForAllTysInvis ty+  = do let (inv_bndrs, phi) = tcSplitForAllInvisTVBinders ty        tvbndrs' <- reifyTyVarBndrs inv_bndrs        let (cxt, tau) = tcSplitPhiTy phi        cxt' <- reifyCxt cxt@@ -2159,6 +2326,7 @@ reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit reifyTyLit (NumTyLit n) = return (TH.NumTyLit n) reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))+reifyTyLit (CharTyLit c) = return (TH.CharTyLit c)  reifyTypes :: [Type] -> TcM [TH.Type] reifyTypes = mapM reifyType@@ -2303,10 +2471,10 @@   = do { (found, fix) <- lookupFixityRn_help name        ; return (if found then Just (conv_fix fix) else Nothing) }     where-      conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)-      conv_dir BasicTypes.InfixR = TH.InfixR-      conv_dir BasicTypes.InfixL = TH.InfixL-      conv_dir BasicTypes.InfixN = TH.InfixN+      conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d)+      conv_dir Hs.InfixR = TH.InfixR+      conv_dir Hs.InfixL = TH.InfixL+      conv_dir Hs.InfixN = TH.InfixN  reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness

GHC/Tc/Gen/Splice.hs-boot view

@@ -9,7 +9,7 @@ import GHC.Tc.Types( TcM , SpliceType ) import GHC.Tc.Utils.TcType   ( ExpRhoType ) import GHC.Types.Annotations ( Annotation, CoreAnnTarget )-import GHC.Hs.Extension      ( GhcRn, GhcPs, GhcTc )+import GHC.Hs.Extension ( GhcRn, GhcPs, GhcTc )  import GHC.Hs     ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,                     LHsDecl, ThModFinalizers )

GHC/Tc/Instance/Class.hs view

@@ -13,36 +13,41 @@  import GHC.Prelude +import GHC.Driver.Session++ import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Instantiate( tcInstType )+import GHC.Tc.Utils.Instantiate(instDFunType, tcInstType) import GHC.Tc.Instance.Typeable import GHC.Tc.Utils.TcMType import GHC.Tc.Types.Evidence-import GHC.Core.Predicate-import GHC.Rename.Env( addUsedGRE )-import GHC.Types.Name.Reader( lookupGRE_FieldLabel )-import GHC.Core.InstEnv-import GHC.Tc.Utils.Instantiate( instDFunType ) import GHC.Tc.Instance.Family( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )+import GHC.Rename.Env( addUsedGRE )  import GHC.Builtin.Types import GHC.Builtin.Types.Prim( eqPrimTyCon, eqReprPrimTyCon ) import GHC.Builtin.Names -import GHC.Types.Id-import GHC.Core.Type-import GHC.Core.Make ( mkStringExprFS, mkNaturalExpr )-+import GHC.Types.Name.Reader( lookupGRE_FieldLabel, greMangledName )+import GHC.Types.SafeHaskell import GHC.Types.Name   ( Name, pprDefinedAt ) import GHC.Types.Var.Env ( VarEnv )+import GHC.Types.Id++import GHC.Core.Predicate+import GHC.Core.InstEnv+import GHC.Core.Type+import GHC.Core.Make ( mkCharExpr, mkStringExprFS, mkNaturalExpr ) import GHC.Core.DataCon import GHC.Core.TyCon import GHC.Core.Class-import GHC.Driver.Session+ import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc( splitAtList, fstOf3 )+ import Data.Maybe  {- *******************************************************************@@ -136,6 +141,8 @@   = matchKnownNat    dflags short_cut clas tys   | cls_name == knownSymbolClassName   = matchKnownSymbol dflags short_cut clas tys+  | cls_name == knownCharClassName+  = matchKnownChar dflags short_cut clas tys   | isCTupleClass clas                = matchCTuple          clas tys   | cls_name == typeableClassName     = matchTypeable        clas tys   | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys@@ -296,7 +303,7 @@  The reason we don't use this directly in the class is that it is simpler and more efficient to pass around a Natural rather than an entire function,-especially when the `KnowNat` evidence is packaged up in an existential.+especially when the `KnownNat` evidence is packaged up in an existential.  The story for kind `Symbol` is analogous:   * class KnownSymbol@@ -372,6 +379,16 @@  -- See Note [Fabricating Evidence for Literals in Backpack] for why  -- this lookup into the instance environment is required. +matchKnownChar :: DynFlags+                 -> Bool      -- True <=> caller is the short-cut solver+                              -- See Note [Shortcut solving: overlap]+                 -> Class -> [Type] -> TcM ClsInstResult+matchKnownChar _ _ clas [ty]  -- clas = KnownChar+  | Just s <- isCharLitTy ty = makeLitDict clas ty (mkCharExpr s)+matchKnownChar df sc clas tys = matchInstEnv df sc clas tys+ -- See Note [Fabricating Evidence for Literals in Backpack] for why+ -- this lookup into the instance environment is required.+ makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult -- makeLitDict adds a coercion that will convert the literal into a dictionary -- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]@@ -417,8 +434,9 @@   | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type    -- Now cases that do work-  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t+  | k `eqType` naturalTy                   = doTyLit knownNatClassName         t   | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t+  | k `eqType` charTy                      = doTyLit knownCharClassName        t   | tcIsConstraintKind t                   = doTyConApp clas t constraintKindTyCon []   | Just (mult,arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t mult arg ret   | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]@@ -547,7 +565,7 @@       instance KnownNat n => Typeable (n :: Nat) where          typeRep = typeNatTypeRep @n where-   Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a+   Data.Typeable.Internal.typeNatTypeRep :: KnownNat a => TypeRep a  Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a runtime value 'n'; it turns it into a string with 'show' and uses@@ -654,6 +672,20 @@ encounter a HasField constraint where the field is not a literal string, or does not belong to the type, then we fall back on the normal constraint solver behaviour.+++Note [Unused name reporting and HasField]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When a HasField constraint is solved by the type-checker, we must record a use+of the corresponding field name, as otherwise it might be reported as unused.+See #19213.  We need to call keepAlive to add the name to the tcg_keep set,+which accumulates names used by the constraint solver, as described by+Note [Tracking unused binding and imports] in GHC.Tc.Types.++We need to call addUsedGRE as well because there may be a deprecation warning on+the field, which will be reported by addUsedGRE.  But calling addUsedGRE without+keepAlive is not enough, because the field might be defined locally, and+addUsedGRE extends tcg_used_gres with imported GREs only. -}  -- See Note [HasField instances]@@ -703,7 +735,9 @@                      -- cannot have an existentially quantified type), and                      -- it must not be higher-rank.                    ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty-                     then do { addUsedGRE True gre+                     then do { -- See Note [Unused name reporting and HasField]+                               addUsedGRE True gre+                             ; keepAlive (greMangledName gre)                              ; return OneInst { cir_new_theta = theta                                               , cir_mk_ev     = mk_ev                                               , cir_what      = BuiltinInstance } }

GHC/Tc/Instance/Family.hs view

@@ -14,33 +14,46 @@  import GHC.Prelude -import GHC.Driver.Types+import GHC.Driver.Session+import GHC.Driver.Env+ import GHC.Core.FamInstEnv import GHC.Core.InstEnv( roughMatchTcs ) import GHC.Core.Coercion-import GHC.Tc.Types.Evidence-import GHC.Iface.Load-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )-import GHC.Types.SrcLoc as SrcLoc import GHC.Core.TyCon-import GHC.Tc.Utils.TcType import GHC.Core.Coercion.Axiom-import GHC.Driver.Session-import GHC.Unit.Module-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Types.Name.Reader import GHC.Core.DataCon ( dataConName )-import GHC.Data.Maybe import GHC.Core.TyCo.Rep import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr ( pprWithExplicitKindsWhen )++import GHC.Iface.Load++import GHC.Tc.Types.Evidence+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Instantiate( freshenTyVarBndrs, freshenCoVarBndrsX )+import GHC.Tc.Utils.TcType++import GHC.Unit.External+import GHC.Unit.Module+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+import GHC.Unit.Home.ModInfo++import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Name.Reader import GHC.Types.Name-import GHC.Utils.Panic import GHC.Types.Var.Set++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.FV+ import GHC.Data.Bag( Bag, unionBags, unitBag )+import GHC.Data.Maybe+ import Control.Monad import Data.List ( sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )@@ -215,7 +228,7 @@  For every other pair of family instance modules we import (directly or indirectly), we check that they are consistent now. (So that we can be-certain that the modules in our `GHC.Driver.Types.dep_finsts' are consistent.)+certain that the modules in our `GHC.Driver.Env.dep_finsts' are consistent.)  There is some fancy footwork regarding hs-boot module loops, see Note [Don't check hs-boot type family instances too early]@@ -510,7 +523,7 @@ -- It is only used by the type inference engine (specifically, when -- solving representational equality), and hence it is careful to unwrap -- only if the relevant data constructor is in scope.  That's why--- it get a GlobalRdrEnv argument.+-- it gets a GlobalRdrEnv argument. -- -- It is careful not to unwrap data/newtype instances if it can't -- continue unwrapping.  Such care is necessary for proper error

GHC/Tc/Instance/FunDeps.hs view

@@ -38,11 +38,13 @@ import GHC.Types.Var.Env import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr( pprWithExplicitKindsWhen )-import GHC.Utils.FV+import GHC.Types.SrcLoc+ import GHC.Utils.Outputable+import GHC.Utils.FV import GHC.Utils.Error( Validity(..), allValid )-import GHC.Types.SrcLoc import GHC.Utils.Misc+import GHC.Utils.Panic  import GHC.Data.Pair             ( Pair(..) ) import Data.List        ( nubBy )@@ -234,7 +236,7 @@  improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class              -> ClsInst                    -- An instance template-             -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate+             -> [Type] -> [RoughMatchTc]   -- Arguments of this (C tys) predicate              -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton  improveClsFD clas_tvs fd@@ -654,9 +656,7 @@         (ltys1, rtys1) = instFD fd cls_tvs tys1         (ltys2, rtys2) = instFD fd cls_tvs tys2         qtv_set2       = mkVarSet qtvs2-        bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe-                   | tv `elemVarSet` qtv_set2 = BindMe-                   | otherwise                = Skolem+        bind_fn        = matchBindFun (qtv_set1 `unionVarSet` qtv_set2)      eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2         -- A single instance may appear twice in the un-nubbed conflict list@@ -666,7 +666,7 @@         --      instance C Int Char Char         -- The second instance conflicts with the first by *both* fundeps -trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]+trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [RoughMatchTc] -> [RoughMatchTc] -- Computing rough_tcs for a particular fundep --     class C a b c | a -> b where ... -- For each instance .... => C ta tb tc@@ -679,4 +679,4 @@   = zipWith select clas_tvs mb_tcs   where     select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc-                         | otherwise           = Nothing+                         | otherwise           = OtherTc

GHC/Tc/Instance/Typeable.hs view

@@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}  module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where @@ -15,19 +16,20 @@ import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( Boxity(..), neverInlinePragma, SourceText(..) )+import GHC.Types.Basic ( Boxity(..), neverInlinePragma )+import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence ( mkWpTyApps ) import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcType-import GHC.Driver.Types ( lookupId )+import GHC.Types.TyThing ( lookupId ) import GHC.Builtin.Names import GHC.Builtin.Types.Prim ( primTyCons ) import GHC.Builtin.Types                   ( tupleTyCon, sumTyCon, runtimeRepTyCon-                  , vecCountTyCon, vecElemTyCon+                  , levityTyCon, vecCountTyCon, vecElemTyCon                   , nilDataCon, consDataCon ) import GHC.Types.Name import GHC.Types.Id@@ -39,10 +41,11 @@ import GHC.Driver.Session import GHC.Data.Bag import GHC.Types.Var ( VarBndr(..) )-import GHC.Core.Map+import GHC.Core.Map.Type import GHC.Settings.Constants import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString ( FastString, mkFastString, fsLit )  import Control.Monad.Trans.State@@ -173,7 +176,7 @@        } } }   where     needs_typeable_binds tc-      | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]+      | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon]       = False       | otherwise =           isAlgTyCon tc@@ -349,7 +352,7 @@ -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat-    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]+    [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ]     , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]     , map sumTyCon [2..mAX_SUM_SIZE]     , primTyCons@@ -369,6 +372,7 @@             , kindRepTYPEDataCon     :: DataCon             , kindRepTypeLitSDataCon :: DataCon             , typeLitSymbolDataCon   :: DataCon+            , typeLitCharDataCon     :: DataCon             , typeLitNatDataCon      :: DataCon             } @@ -386,6 +390,7 @@     kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName     typeLitSymbolDataCon   <- tcLookupDataCon typeLitSymbolDataConName     typeLitNatDataCon      <- tcLookupDataCon typeLitNatDataConName+    typeLitCharDataCon     <- tcLookupDataCon typeLitCharDataConName     trNameLit              <- mkTrNameLit     return Stuff {..} @@ -405,7 +410,7 @@                 -> TypeableTyCon -> KindRepM (LHsBinds GhcTc) mkTyConRepBinds stuff todo (TypeableTyCon {..})   = do -- Make a KindRep-       let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)+       let (bndrs, kind) = splitForAllTyCoVarBinders (tyConKind tycon)        liftTc $ traceTc "mkTyConKindRepBinds"                         (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)        let ctx = mkDeBruijnContext (map binderVar bndrs)@@ -553,9 +558,9 @@              -> CmEnv       -- ^ in-scope kind variables              -> Kind        -- ^ the kind we want a 'KindRep' for              -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression-mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep+mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep_shortcut   where-    new_kind_rep k+    new_kind_rep_shortcut k         -- We handle (TYPE LiftedRep) etc separately to make it         -- clear to consumers (e.g. serializers) that there is         -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)@@ -563,10 +568,21 @@               -- Typeable respects the Constraint/Type distinction               -- so do not follow the special case here       , Just arg <- kindRep_maybe k-      , Just (tc, []) <- splitTyConApp_maybe arg-      , Just dc <- isPromotedDataCon_maybe tc-      = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc+      = case splitTyConApp_maybe arg of+          Just (tc, [])+            | Just dc <- isPromotedDataCon_maybe tc+              -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc +          Just (rep, [levArg])+            | Just dcRep <- isPromotedDataCon_maybe rep+            , Just (lev, []) <- splitTyConApp_maybe levArg+            , Just dcLev <- isPromotedDataCon_maybe lev+              -> return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` (nlHsDataCon dcRep `nlHsApp` nlHsDataCon dcLev)++          _   -> new_kind_rep k+      | otherwise = new_kind_rep k++     new_kind_rep (TyVarTy v)       | Just idx <- lookupCME in_scope v       = return $ nlHsDataCon kindRepVarDataCon@@ -608,6 +624,11 @@       = return $ nlHsDataCon kindRepTypeLitSDataCon                  `nlHsApp` nlHsDataCon typeLitSymbolDataCon                  `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)++    new_kind_rep (LitTy (CharTyLit c))+      = return $ nlHsDataCon kindRepTypeLitSDataCon+                 `nlHsApp` nlHsDataCon typeLitCharDataCon+                 `nlHsApp` nlHsLit (mkHsCharPrimLit c)      -- See Note [Typeable instances for casted types]     new_kind_rep (CastTy ty co)

GHC/Tc/Module.hs view

@@ -1,22 +1,20 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}- {-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE MultiWayIf #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}+ -- | Typechecking a whole module -- -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker@@ -51,103 +49,133 @@  import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Plugins+import GHC.Driver.Session++import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) ) import {-# SOURCE #-} GHC.Tc.Gen.Splice ( finishTH, runRemoteModFinalizers )-import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )-import GHC.Iface.Env     ( externaliseName ) import GHC.Tc.Gen.HsType import GHC.Tc.Validity( checkValidType ) import GHC.Tc.Gen.Match import GHC.Tc.Utils.Unify( checkConstraints, tcSubTypeSigma )-import GHC.Rename.HsType-import GHC.Rename.Expr-import GHC.Rename.Utils  ( HsDocContext(..) )-import GHC.Rename.Fixity ( lookupFixityRn )-import GHC.Builtin.Types ( unitTy, mkListTy )-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.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.Gen.App( tcInferSigma ) import GHC.Tc.Utils.Monad import GHC.Tc.Gen.Export import GHC.Tc.Types.Evidence import GHC.Tc.Types.Constraint import GHC.Tc.Types.Origin-import qualified GHC.Data.BooleanFormula as BF-import GHC.Core.Ppr.TyThing ( pprTyThingInContext )-import GHC.Core.FVs         ( orphNamesOfFamInst ) import GHC.Tc.Instance.Family-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv-   ( FamInst, pprFamInst, famInstsRepTyCons-   , famInstEnvElts, extendFamInstEnvList, normaliseType ) import GHC.Tc.Gen.Annotation import GHC.Tc.Gen.Bind-import GHC.Iface.Make   ( coAxiomToIfaceDecl )-import GHC.Parser.Header       ( mkPrelImports ) import GHC.Tc.Gen.Default import GHC.Tc.Utils.Env import GHC.Tc.Gen.Rule import GHC.Tc.Gen.Foreign import GHC.Tc.TyCl.Instance-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 ) import GHC.Tc.Utils.Backpack-import GHC.Iface.Load++import GHC.Rename.Splice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )+import GHC.Rename.HsType+import GHC.Rename.Expr+import GHC.Rename.Utils  ( HsDocContext(..) )+import GHC.Rename.Fixity ( lookupFixityRn ) import GHC.Rename.Names import GHC.Rename.Env import GHC.Rename.Module++import GHC.Iface.Syntax   ( ShowSub(..), showToHeader )+import GHC.Iface.Type     ( ShowForAllFlag(..) )+import GHC.Iface.Env     ( externaliseName )+import GHC.Iface.Make   ( coAxiomToIfaceDecl )+import GHC.Iface.Load++import GHC.Builtin.Types ( unitTy, mkListTy )+import GHC.Builtin.Names+import GHC.Builtin.Utils++import GHC.Hs+import GHC.Hs.Dump++import GHC.Core.PatSyn    ( pprPatSynType )+import GHC.Core.Predicate ( classMethodTy )+import GHC.Core.FVs         ( orphNamesOfFamInst )+import GHC.Core.InstEnv+import GHC.Core.TyCon+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.Type+import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.Unify( RoughMatchTc(..) )+import GHC.Core.FamInstEnv+   ( FamInst, pprFamInst, famInstsRepTyCons+   , famInstEnvElts, extendFamInstEnvList, normaliseType )++import GHC.Parser.Header       ( mkPrelImports )++import GHC.IfaceToCore++import GHC.Runtime.Context+ import GHC.Utils.Error+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Logger++import GHC.Types.Error+import GHC.Types.Name.Reader+import GHC.Types.Fixity.Env import GHC.Types.Id as Id import GHC.Types.Id.Info( IdDetails(..) ) import GHC.Types.Var.Env-import GHC.Unit.Module+import GHC.Types.TypeEnv import GHC.Types.Unique.FM import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail-import GHC.Core.TyCon-import GHC.Types.SrcLoc-import GHC.Driver.Types-import GHC.Data.List.SetOps-import GHC.Utils.Outputable as Outputable-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.Type-import GHC.Core.Class import GHC.Types.Basic hiding( SuccessFlag(..) )-import GHC.Core.Coercion.Axiom import GHC.Types.Annotations-import Data.List ( sortBy, sort )-import Data.Ord+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Types.SourceFile+import GHC.Types.TyThing.Ppr ( pprTyThingInContext )+import qualified GHC.LanguageExtensions as LangExt++import GHC.Unit.External+import GHC.Unit.Types+import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Deps+ import GHC.Data.FastString import GHC.Data.Maybe-import GHC.Utils.Misc+import GHC.Data.List.SetOps import GHC.Data.Bag-import GHC.Tc.Utils.Instantiate (tcGetInsts)-import qualified GHC.LanguageExtensions as LangExt+import qualified GHC.Data.BooleanFormula as BF++import Data.List ( sortBy, sort )+import Data.Ord import Data.Data ( Data )-import GHC.Hs.Dump import qualified Data.Set as S- import Control.DeepSeq import Control.Monad -import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR (..) )-- #include "HsVersions.h"  {-@@ -163,12 +191,12 @@            -> ModSummary            -> Bool              -- True <=> save renamed syntax            -> HsParsedModule-           -> IO (Messages, Maybe TcGblEnv)+           -> IO (Messages DecoratedSDoc, Maybe TcGblEnv)  tcRnModule hsc_env mod_sum save_rn_syntax    parsedModule@HsParsedModule {hpm_module= L loc this_module}  | RealSrcSpan real_loc _ <- loc- = withTiming dflags+ = withTiming logger dflags               (text "Renamer/typechecker"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $@@ -177,23 +205,23 @@           tcRnModuleTcRnM hsc_env mod_sum parsedModule pair    | otherwise-  = return ((emptyBag, unitBag err_msg), Nothing)+  = return (err_msg `addMessage` emptyMessages, Nothing)    where     hsc_src = ms_hsc_src mod_sum-    dflags = hsc_dflags hsc_env-    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $+    dflags  = hsc_dflags hsc_env+    logger  = hsc_logger hsc_env+    home_unit = hsc_home_unit hsc_env+    err_msg = mkPlainMsgEnvelope loc $               text "Module does not have a RealSrcSpan:" <+> ppr this_mod -    this_pkg = homeUnit (hsc_dflags hsc_env)-     pair :: (Module, SrcSpan)     pair@(this_mod,_)       | Just (L mod_loc mod) <- hsmodName this_module-      = (mkModule this_pkg mod, mod_loc)+      = (mkHomeModule home_unit mod, locA mod_loc)        | otherwise   -- 'module M where' is omitted-      = (mAIN, srcLocSpan (srcSpanStart loc))+      = (mkHomeModule home_unit mAIN_NAME, srcLocSpan (srcSpanStart loc))   @@ -208,7 +236,7 @@ tcRnModuleTcRnM hsc_env mod_sum                 (HsParsedModule {                    hpm_module =-                      (L loc (HsModule _ maybe_mod export_ies+                      (L loc (HsModule _ _ maybe_mod export_ies                                        import_decls local_decls mod_deprec                                        maybe_doc_hdr)),                    hpm_src_files = src_files@@ -236,7 +264,7 @@          ; -- TODO This is a little skeevy; maybe handle a bit more directly           let { simplifyImport (L _ idecl) =-                  ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl)+                  ( fmap sl_fs (ideclPkgQual idecl) , reLoc $ ideclName idecl)               }         ; raw_sig_imports <- liftIO                              $ findExtraSigImports hsc_env hsc_src@@ -245,9 +273,9 @@                              $ implicitRequirements hsc_env                                 (map simplifyImport (prel_imports                                                      ++ import_decls))-        ; let { mkImport (Nothing, L _ mod_name) = noLoc+        ; let { mkImport (Nothing, L _ mod_name) = noLocA                 $ (simpleImportDecl mod_name)-                  { ideclHiding = Just (False, noLoc [])}+                  { ideclHiding = Just (False, noLocA [])}               ; mkImport _ = panic "mkImport" }         ; let { all_imports = prel_imports ++ import_decls                        ++ map mkImport (raw_sig_imports ++ raw_req_imports) }@@ -255,6 +283,14 @@           tcg_env <- {-# SCC "tcRnImports" #-}                      tcRnImports hsc_env all_imports +       ;  -- Don't need to rename the Haddock documentation,+          -- it's not parsed by GHC anymore.+          -- Make sure to do this before 'tcRnSrcDecls', because we need the+          -- module header when we're splicing TH, since it can be accessed via+          -- 'getDoc'.+          tcg_env <- return (tcg_env+                              { tcg_doc_hdr = maybe_doc_hdr })+         ; -- If the whole module is warned about or deprecated           -- (via mod_deprec) record that in tcg_warns. If we do thereby add           -- a WarnAll, it will override any subsequent deprecations added to tcg_warns@@ -279,11 +315,7 @@                                  tcRnSrcDecls explicit_mod_hdr export_ies local_decls                 ; whenM (goptM Opt_DoCoreLinting) $-                 do { let (warns, errs) = lintGblEnv (hsc_dflags hsc_env) tcg_env-                    ; mapBagM_ (addWarn NoReason) warns-                    ; mapBagM_ addErr errs-                    ; failIfErrsM }  -- if we have a lint error, we're only-                                     -- going to get in deeper trouble by proceeding+                 lintGblEnv (hsc_logger hsc_env) (hsc_dflags hsc_env) tcg_env                 ; setGblEnv tcg_env                  $ do { -- Compare hi-boot iface (if any) with the real thing@@ -296,12 +328,7 @@                         -- because the latter might add new bindings for                         -- boot_dfuns, which may be mentioned in imported                         -- unfoldings.--                        -- Don't need to rename the Haddock documentation,-                        -- it's not parsed by GHC anymore.-                        tcg_env <- return (tcg_env-                                           { tcg_doc_hdr = maybe_doc_hdr })-                      ; -- Report unused names+                        -- Report unused names                         -- Do this /after/ typeinference, so that when reporting                         -- a function with no type signature we can give the                         -- inferred type@@ -310,7 +337,7 @@                         addDependentFiles src_files                         -- Ensure plugins run with the same tcg_env that we pass in                       ; setGblEnv tcg_env-                        $ do { tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env+                        $ do { tcg_env <- runTypecheckerPlugin mod_sum tcg_env                              ; -- Dump output and return                                tcDump tcg_env                              ; return tcg_env@@ -410,7 +437,7 @@ -}  tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all-             -> Maybe (Located [LIE GhcPs])+             -> Maybe (LocatedL [LIE GhcPs])              -> [LHsDecl GhcPs]               -- Declarations              -> TcM TcGblEnv tcRnSrcDecls explicit_mod_hdr export_ies decls@@ -580,7 +607,7 @@                     ; case th_group_tail of                         { Nothing -> return ()                         ; Just (SpliceDecl _ (L loc _) _, _) ->-                            setSrcSpan loc+                            setSrcSpanA loc                             $ addErr (text                                 ("Declaration splices are not "                                   ++ "permitted inside top-level "@@ -701,9 +728,9 @@    }}}    ; traceTc "boot" (ppr lie); return gbl_env } -badBootDecl :: HscSource -> String -> Located decl -> TcM ()+badBootDecl :: HscSource -> String -> LocatedA decl -> TcM () badBootDecl hsc_src what (L loc _)-  = addErrAt loc (char 'A' <+> text what+  = addErrAt (locA loc) (char 'A' <+> text what       <+> text "declaration is not (currently) allowed in a"       <+> (case hsc_src of             HsBootFile -> text "hs-boot"@@ -1487,10 +1514,10 @@                           foe_binds              ; fo_gres = fi_gres `unionBags` foe_gres-            ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` gre_name gre)+            ; fo_fvs = foldr (\gre fvs -> fvs `addOneFV` greMangledName gre)                                 emptyFVs fo_gres -            ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)+            ; sig_names = mkNameSet (collectHsValBinders CollNoDictBinders hs_val_binds)                           `minusNameSet` getTypeSigNames val_sigs                  -- Extend the GblEnv with the (as yet un-zonked)@@ -1552,11 +1579,11 @@             where               isLocalDef = gre_lcl x == True               -- Names are identical ...-              nameClashes = nameOccName (gre_name x) == nameOccName name+              nameClashes = nameOccName (greMangledName x) == nameOccName name               -- ... but not the actual definitions, because we don't want to               -- warn about a bad definition of e.g. <> in Data.Semigroup, which               -- is the (only) proper place where this should be defined-              isNotInProperModule = gre_name x /= name+              isNotInProperModule = greMangledName x /= name            -- List of all offending definitions           clashingElts :: [GlobalRdrElt]@@ -1565,9 +1592,9 @@     ; traceTc "tcPreludeClashWarn/prelude_functions"                 (hang (ppr name) 4 (sep [ppr clashingElts])) -    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep+    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (greMangledName x)) (hsep               [ text "Local definition of"-              , (quotes . ppr . nameOccName . gre_name) x+              , (quotes . ppr . nameOccName . greMangledName) x               , text "clashes with a future Prelude name." ]               $$               text "This will become an error in a future release." )@@ -1675,7 +1702,7 @@            -- "<location>: Warning: <type> is an instance of <is> but not            -- <should>" e.g. "Foo is an instance of Monad but not Applicative"            ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst-                 warnMsg (Just name:_) =+                 warnMsg (KnownTc name:_) =                       addWarnAt (Reason warnFlag) instLoc $                            hsep [ (quotes . ppr . nameOccName) name                                 , text "is an instance of"@@ -1741,19 +1768,20 @@ -- If not, do nothing -- See Note [Dealing with main] checkMainType tcg_env-  = do { dflags <- getDynFlags-       ; if tcg_mod tcg_env /= mainModIs dflags+  = do { hsc_env <- getTopEnv+       ; if tcg_mod tcg_env /= mainModIs hsc_env          then return emptyWC else      do { rdr_env <- getGlobalRdrEnv-       ; let main_occ  = getMainOcc dflags+       ; let dflags    = hsc_dflags hsc_env+             main_occ  = getMainOcc dflags              main_gres = lookupGlobalRdrEnv rdr_env main_occ        ; case filter isLocalGRE main_gres of {             []         -> return emptyWC ;             (_:_:_)    -> return emptyWC ;             [main_gre] -> -    do { let main_name = gre_name main_gre+    do { let main_name = greMangledName main_gre              ctxt      = FunSigCtxt main_name False        ; main_id   <- tcLookupId main_name        ; (io_ty,_) <- getIOType@@ -1763,16 +1791,17 @@        ; return lie } } } }  checkMain :: Bool  -- False => no 'module M(..) where' header at all-          -> Maybe (Located [LIE GhcPs])  -- Export specs of Main module+          -> Maybe (LocatedL [LIE GhcPs])  -- Export specs of Main module           -> TcM TcGblEnv -- If we are in module Main, check that 'main' is exported, -- and generate the runMainIO binding that calls it -- See Note [Dealing with main] checkMain explicit_mod_hdr export_ies- = do { dflags <- getDynFlags+ = do { hsc_env  <- getTopEnv       ; tcg_env <- getGblEnv -      ; let main_mod    = mainModIs dflags+      ; let dflags      = hsc_dflags hsc_env+            main_mod    = mainModIs hsc_env             main_occ    = getMainOcc dflags              exported_mains :: [Name]@@ -1843,7 +1872,7 @@     { traceTc "checkMain found" (ppr main_name)     ; (io_ty, res_ty) <- getIOType     ; let loc = getSrcSpan main_name-          main_expr_rn = L loc (HsVar noExtField (L loc main_name))+          main_expr_rn = L (noAnnSrcSpan loc) (HsVar noExtField (L (noAnnSrcSpan loc) main_name))     ; (ev_binds, main_expr) <- setMainCtxt main_name io_ty $                                tcCheckMonoExpr main_expr_rn io_ty @@ -1897,7 +1926,7 @@  * The flag -main-is=M.foo allows you to set the main module to 'M',   and the main function to 'foo'.  We access them through-      mainModIs  :: DynFlags -> Module   -- returns M+      mainModIs  :: HscEnv -> Module     -- returns M       getMainOcc :: DynFlags -> OccName  -- returns foo   Of course usually M = Main, and foo = main. @@ -1982,7 +2011,7 @@ ********************************************************* -} -runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)+runTcInteractive :: HscEnv -> TcRn a -> IO (Messages DecoratedSDoc, Maybe a) -- Initialise the tcg_inst_env with instances from all home modules. -- This mimics the more selective call to hptInstances in tcRnImports runTcInteractive hsc_env thing_inside@@ -2098,7 +2127,7 @@ -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound -- values, coerced to (). tcRnStmt :: HscEnv -> GhciLStmt GhcPs-         -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))+         -> IO (Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv)) tcRnStmt hsc_env rdr_stmt   = runTcInteractive hsc_env $ do { @@ -2117,7 +2146,7 @@     traceTc "tcs 1" empty ;     this_mod <- getModule ;     global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;-        -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Types+        -- Note [Interactively-bound Ids in GHCi] in GHC.Driver.Env  {- ---------------------------------------------    At one stage I removed any shadowed bindings from the type_env;@@ -2188,7 +2217,7 @@ -- -- By 'lift' and 'environment we mean that the code is changed to -- execute properly in an IO monad. See Note [Interactively-bound Ids--- in GHCi] in GHC.Driver.Types for more details. We do this lifting by trying+-- in GHCi] in GHC.Driver.Env for more details. We do this lifting by trying -- different ways ('plans') of lifting the code into the IO monad and -- type checking each plan until one succeeds. tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)@@ -2199,20 +2228,21 @@                -- Don't try to typecheck if the renamer fails!         ; ghciStep <- getGhciStepIO         ; uniq <- newUnique+        ; let loc' = noAnnSrcSpan $ locA loc         ; interPrintName <- getInteractivePrintName-        ; let fresh_it  = itName uniq loc-              matches   = [mkMatch (mkPrefixFunRhs (L loc fresh_it)) [] rn_expr-                                   (noLoc emptyLocalBinds)]+        ; let fresh_it  = itName uniq (locA loc)+              matches   = [mkMatch (mkPrefixFunRhs (L loc' fresh_it)) [] rn_expr+                                   emptyLocalBinds]               -- [it = expr]               the_bind  = L loc $ (mkTopFunBind FromSource-                                     (L loc fresh_it) matches)+                                     (L loc' fresh_it) matches)                                          { fun_ext = fvs }               -- Care here!  In GHCi the expression might have               -- free variables, and they in turn may have free type variables               -- (if we are at a breakpoint, say).  We must put those free vars                -- [let it = expr]-              let_stmt  = L loc $ LetStmt noExtField $ noLoc $ HsValBinds noExtField+              let_stmt  = L loc $ LetStmt noAnn $ HsValBinds noAnn                            $ XValBindsLR                                (NValBinds [(NonRecursive,unitBag the_bind)] []) @@ -2222,7 +2252,7 @@                                           { xbsrn_bindOp = mkRnSyntaxExpr bindIOName                                           , xbsrn_failOp = Nothing                                           })-                                       (L loc (VarPat noExtField (L loc fresh_it)))+                                       (L loc (VarPat noExtField (L loc' fresh_it)))                                        (nlHsApp ghciStep rn_expr)                -- [; print it]@@ -2344,7 +2374,7 @@  tcUserStmt rdr_stmt@(L loc _)   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $-           rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do+           rnStmts GhciStmtCtxt rnExpr [rdr_stmt] $ \_ -> do              fix_env <- getFixityEnv              return (fix_env, emptyFVs)             -- Don't try to typecheck if the renamer fails!@@ -2360,8 +2390,8 @@        ; opt_pr_flag <- goptM Opt_PrintBindResult        ; let print_result_plan                | opt_pr_flag                         -- The flag says "print result"-               , [v] <- collectLStmtBinders gi_stmt  -- One binder-                           =  [mk_print_result_plan gi_stmt v]+               , [v] <- collectLStmtBinders CollNoDictBinders gi_stmt  -- One binder+               = [mk_print_result_plan gi_stmt v]                | otherwise = []          -- The plans are:@@ -2411,7 +2441,7 @@             io_ret_ty   = mkTyConApp ioTyCon [ret_ty]             tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts                                          (mkCheckExpType io_ret_ty)-            names = collectLStmtsBinders stmts+            names = collectLStmtsBinders CollNoDictBinders stmts          -- OK, we're ready to typecheck the stmts       ; traceTc "GHC.Tc.Module.tcGhciStmts: tc stmts" empty@@ -2446,17 +2476,17 @@            -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce        ; let ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) $-                       noLoc $ ExplicitList unitTy Nothing $+                       noLocA $ ExplicitList unitTy $                        map mk_item ids              mk_item id = unsafe_coerce_id `nlHsTyApp` [ getRuntimeRep (idType id)                                                       , getRuntimeRep unitTy                                                       , idType id, unitTy]                                           `nlHsApp` nlHsVar id-            stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]+            stmts = tc_stmts ++ [noLocA (mkLastStmt ret_expr)]        ; return (ids, mkHsDictLet (EvBinds const_binds) $-                     noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))+                     noLocA (HsDo io_ret_ty GhciStmtCtxt (noLocA stmts)))     }  -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)@@ -2467,25 +2497,25 @@     let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)         ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv) -        step_ty = noLoc $ HsForAllTy-                     { hst_tele = mkHsForAllInvisTele-                                  [noLoc $ UserTyVar noExtField SpecifiedSpec (noLoc a_tv)]-                     , hst_xforall = noExtField-                     , hst_body  = nlHsFunTy ghciM ioM }+        step_ty :: LHsSigType GhcRn+        step_ty = noLocA $ HsSig+                     { sig_bndrs = HsOuterImplicit{hso_ximplicit = [a_tv]}+                     , sig_ext = noExtField+                     , sig_body = nlHsFunTy ghciM ioM }          stepTy :: LHsSigWcType GhcRn-        stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)+        stepTy = mkEmptyWildCardBndrs step_ty -    return (noLoc $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy)+    return (noLocA $ ExprWithTySig noExtField (nlHsVar ghciStepIoMName) stepTy) -isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)+isGHCiMonad :: HscEnv -> String -> IO (Messages DecoratedSDoc, Maybe Name) isGHCiMonad hsc_env ty   = runTcInteractive hsc_env $ do         rdrEnv <- getGlobalRdrEnv         let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)         case occIO of             Just [n] -> do-                let name = gre_name n+                let name = greMangledName n                 ghciClass <- tcLookupClass ghciIoClassName                 userTyCon <- tcLookupTyCon name                 let userTy = mkTyConApp userTyCon []@@ -2496,16 +2526,16 @@             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 tcRnExpr :: HscEnv          -> TcRnExprMode          -> LHsExpr GhcPs-         -> IO (Messages, Maybe Type)+         -> IO (Messages DecoratedSDoc, Maybe Type) tcRnExpr hsc_env mode rdr_expr   = runTcInteractive hsc_env $     do {@@ -2513,18 +2543,18 @@     (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-    (qtvs, dicts, _, residual, _)-         <- simplifyInfer tclvl infer_mode+    uniq <- newUnique ;+    let { fresh_it = itName uniq (getLocA rdr_expr) } ;+    ((qtvs, dicts, _, _), residual)+         <- captureConstraints $+            simplifyInfer tclvl infer_mode                           []    {- No sig vars -}                           [(fresh_it, res_ty)]                           lie ;@@ -2546,14 +2576,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]@@ -2578,7 +2604,7 @@ -------------------------- tcRnImportDecls :: HscEnv                 -> [LImportDecl GhcPs]-                -> IO (Messages, Maybe GlobalRdrEnv)+                -> IO (Messages DecoratedSDoc, Maybe GlobalRdrEnv) -- Find the new chunk of GlobalRdrEnv created by this list of import -- decls.  In contract tcRnImports *extends* the TcGblEnv. tcRnImportDecls hsc_env import_decls@@ -2594,7 +2620,7 @@          -> ZonkFlexi          -> Bool        -- Normalise the returned type          -> LHsType GhcPs-         -> IO (Messages, Maybe (Type, Kind))+         -> IO (Messages DecoratedSDoc, Maybe (Type, Kind)) tcRnType hsc_env flexi normalise rdr_type   = runTcInteractive hsc_env $     setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]@@ -2610,61 +2636,54 @@         -- 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 }+       ; ((ty, kind), wanted)+               <- captureTopConstraints $+                  pushTcLevelM_         $+                  bindNamedWildCardBinders wcs $ \ wcs' ->+                  do { mapM_ emitNamedTypeHole wcs'+                     ; tcInferLHsTypeUnsaturated rn_type } +       -- Since all the wanteds are equalities, the returned bindings will be empty+       ; empty_binds <- simplifyTop wanted+       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )+        -- 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        ; checkValidType (GhciCtxt True) ty -       ; ty' <- if normalise-                then do { fam_envs <- tcGetFamInstEnvs-                        ; let (_, ty')-                                = normaliseType fam_envs Nominal ty-                        ; return ty' }-                else return ty ;+       -- Optionally (:k vs :k!) normalise the type. Does two things:+       --   normaliseType: expand type-family applications+       --   expandTypeSynonyms: expand type synonyms (#18828)+       ; fam_envs <- tcGetFamInstEnvs+       ; let ty' | normalise = expandTypeSynonyms $ snd $+                               normaliseType fam_envs Nominal ty+                 | otherwise = ty         ; 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 @@ -2673,12 +2692,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 @@ -2694,6 +2718,10 @@   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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We switch on PolyKinds when kind-checking a user type, so that we will@@ -2726,7 +2754,7 @@  tcRnDeclsi :: HscEnv            -> [LHsDecl GhcPs]-           -> IO (Messages, Maybe TcGblEnv)+           -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnDeclsi hsc_env local_decls   = runTcInteractive hsc_env $     tcRnSrcDecls False Nothing local_decls@@ -2751,17 +2779,17 @@ -- a package module with an interface on disk.  If neither of these is -- true, then the result will be an error indicating the interface -- could not be found.-getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)+getModuleInterface :: HscEnv -> Module -> IO (Messages DecoratedSDoc, Maybe ModIface) getModuleInterface hsc_env mod   = runTcInteractive hsc_env $     loadModuleInterface (text "getModuleInterface") mod -tcRnLookupRdrName :: HscEnv -> Located RdrName-                  -> IO (Messages, Maybe [Name])+tcRnLookupRdrName :: HscEnv -> LocatedN RdrName+                  -> IO (Messages DecoratedSDoc, Maybe [Name]) -- ^ Find all the Names that this RdrName could mean, in GHCi tcRnLookupRdrName hsc_env (L loc rdr_name)   = runTcInteractive hsc_env $-    setSrcSpan loc           $+    setSrcSpanA loc          $     do {   -- If the identifier is a constructor (begins with an            -- upper-case letter), then we need to consider both            -- constructor and type class identifiers.@@ -2771,7 +2799,7 @@        ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))        ; return names } -tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)+tcRnLookupName :: HscEnv -> Name -> IO (Messages DecoratedSDoc, Maybe TyThing) tcRnLookupName hsc_env name   = runTcInteractive hsc_env $     tcRnLookupName' name@@ -2790,7 +2818,7 @@  tcRnGetInfo :: HscEnv             -> Name-            -> IO ( Messages+            -> IO ( Messages DecoratedSDoc                   , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))  -- Used to implement :info in GHCi@@ -2852,15 +2880,15 @@ -- This is so that we can accurately report the instances for -- something loadUnqualIfaces hsc_env ictxt-  = initIfaceTcRn $ do+  = initIfaceTcRn $     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))   where-    this_pkg = homeUnit (hsc_dflags hsc_env)+    home_unit = hsc_home_unit hsc_env      unqual_mods = [ nameModule name                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)-                  , let name = gre_name gre-                  , nameIsFromExternalPackage this_pkg name+                  , let name = greMangledName gre+                  , nameIsFromExternalPackage home_unit name                   , isTcOcc (nameOccName name)   -- Types and classes only                   , unQualOK gre ]               -- In scope unqualified     doc = text "Need interface for module whose export(s) are in scope unqualified"@@ -2883,11 +2911,12 @@ tcDump :: TcGblEnv -> TcRn () tcDump env  = do { dflags <- getDynFlags ;+        unit_state <- hsc_units <$> getTopEnv ;          -- Dump short output if -ddump-types or -ddump-tc         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)-          (dumpTcRn True (dumpOptionsFromFlag Opt_D_dump_types)-            "" FormatText short_dump) ;+          (dumpTcRn True Opt_D_dump_types+            "" FormatText (pprWithUnitState unit_state short_dump)) ;          -- Dump bindings if -ddump-tc         dumpOptTcRn Opt_D_dump_tc "Typechecker" FormatHaskell full_dump;@@ -2900,7 +2929,7 @@     full_dump  = pprLHsBinds (tcg_binds env)         -- NB: foreign x-d's have undefined's in their types;         --     hence can't show the tc_fords-    ast_dump = showAstData NoBlankSrcSpan (tcg_binds env)+    ast_dump = showAstData NoBlankSrcSpan NoBlankEpAnnotations (tcg_binds env)  -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc@@ -2990,8 +3019,8 @@   = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs       -- The filter gets rid of class data constructors   where-    ppr_dc dc = sdocWithDynFlags (\dflags ->-                ppr dc <+> dcolon <+> ppr (dataConDisplayType dflags dc))+    ppr_dc dc = sdocOption sdocLinearTypes (\show_linear_types ->+                ppr dc <+> dcolon <+> ppr (dataConDisplayType show_linear_types dc))     all_dcs    = typeEnvDataCons type_env     wanted_dcs | debug     = all_dcs                | otherwise = filterOut is_cls_dc all_dcs@@ -3036,14 +3065,14 @@  withTcPlugins :: HscEnv -> TcM a -> TcM a withTcPlugins hsc_env m =-  do let plugins = getTcPlugins (hsc_dflags hsc_env)-     case plugins of-       [] -> m  -- Common fast case-       _  -> do ev_binds_var <- newTcEvBinds+    case getTcPlugins hsc_env of+       []      -> m  -- Common fast case+       plugins -> do+                ev_binds_var <- newTcEvBinds                 (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins                 -- This ensures that tcPluginStop is called even if a type                 -- error occurs during compilation (Fix of #10078)-                eitherRes <- tryM $ do+                eitherRes <- tryM $                   updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m                 mapM_ (flip runTcPluginM ev_binds_var) stops                 case eitherRes of@@ -3054,18 +3083,18 @@     do s <- runTcPluginM start ev_binds_var        return (solve s, stop s) -getTcPlugins :: DynFlags -> [GHC.Tc.Utils.Monad.TcPlugin]-getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)+getTcPlugins :: HscEnv -> [GHC.Tc.Utils.Monad.TcPlugin]+getTcPlugins hsc_env = catMaybes $ mapPlugins hsc_env (\p args -> tcPlugin p args)   withHoleFitPlugins :: HscEnv -> TcM a -> TcM a withHoleFitPlugins hsc_env m =-  case (getHfPlugins (hsc_dflags hsc_env)) of+  case getHfPlugins hsc_env of     [] -> m  -- Common fast case     plugins -> do (plugins,stops) <- unzip `fmap` mapM startPlugin plugins                   -- This ensures that hfPluginStop is called even if a type                   -- error occurs during compilation.-                  eitherRes <- tryM $ do+                  eitherRes <- tryM $                     updGblEnv (\e -> e { tcg_hf_plugins = plugins }) m                   sequence_ stops                   case eitherRes of@@ -3076,18 +3105,19 @@       do ref <- init          return (plugin ref, stop ref) -getHfPlugins :: DynFlags -> [HoleFitPluginR]-getHfPlugins dflags =-  catMaybes $ mapPlugins dflags (\p args -> holeFitPlugin p args)+getHfPlugins :: HscEnv -> [HoleFitPluginR]+getHfPlugins hsc_env =+  catMaybes $ mapPlugins hsc_env (\p args -> holeFitPlugin p args)   runRenamerPlugin :: TcGblEnv                  -> HsGroup GhcRn                  -> TcM (TcGblEnv, HsGroup GhcRn) runRenamerPlugin gbl_env hs_group = do-    dflags <- getDynFlags-    withPlugins dflags-      (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))+    hsc_env <- getTopEnv+    withPlugins hsc_env+      (\p opts (e, g) -> ( mark_plugin_unsafe (hsc_dflags hsc_env)+                            >> renamedResultAction p opts e g))       (gbl_env, hs_group)  @@ -3105,11 +3135,11 @@                     , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )          (tcg_rn_decls tc_result) -runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv-runTypecheckerPlugin sum hsc_env gbl_env = do-    let dflags = hsc_dflags hsc_env-    withPlugins dflags-      (\p opts env -> mark_plugin_unsafe dflags+runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv+runTypecheckerPlugin sum gbl_env = do+    hsc_env <- getTopEnv+    withPlugins hsc_env+      (\p opts env -> mark_plugin_unsafe (hsc_dflags hsc_env)                         >> typeCheckResultAction p opts sum env)       gbl_env @@ -3118,5 +3148,5 @@   recordUnsafeInfer pluginUnsafe   where     unsafeText = "Use of plugins makes the module unsafe"-    pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan+    pluginUnsafe = unitBag ( mkPlainWarnMsg noSrcSpan                                    (Outputable.text unsafeText) )

GHC/Tc/Module.hs-boot view

@@ -1,7 +1,7 @@ module GHC.Tc.Module where  import GHC.Prelude-import GHC.Core.Type(TyThing)+import GHC.Types.TyThing(TyThing) import GHC.Tc.Types (TcM) import GHC.Utils.Outputable (SDoc) import GHC.Types.Name (Name)

GHC/Tc/Plugin.hs view

@@ -10,7 +10,7 @@         unsafeTcPluginTcM,          -- * Finding Modules and Names-        FindResult(..),+        Finder.FindResult(..),         findImportedModule,         lookupOrig, @@ -52,13 +52,13 @@  import GHC.Prelude -import qualified GHC.Tc.Utils.Monad           as TcM+import qualified GHC.Tc.Utils.Monad     as TcM import qualified GHC.Tc.Solver.Monad    as TcS-import qualified GHC.Tc.Utils.Env             as TcM+import qualified GHC.Tc.Utils.Env       as TcM import qualified GHC.Tc.Utils.TcMType   as TcM import qualified GHC.Tc.Instance.Family as TcM import qualified GHC.Iface.Env          as IfaceEnv-import qualified GHC.Driver.Finder      as Finder+import qualified GHC.Unit.Finder        as Finder  import GHC.Core.FamInstEnv     ( FamInstEnv ) import GHC.Tc.Utils.Monad      ( TcGblEnv, TcLclEnv, TcPluginM@@ -73,13 +73,13 @@  import GHC.Unit.Module import GHC.Types.Name+import GHC.Types.TyThing import GHC.Core.TyCon import GHC.Core.DataCon import GHC.Core.Class-import GHC.Driver.Types+import GHC.Driver.Env import GHC.Utils.Outputable import GHC.Core.Type-import GHC.Core.Coercion   ( BlockSubstFlag(..) ) import GHC.Types.Id import GHC.Core.InstEnv import GHC.Data.FastString@@ -95,7 +95,7 @@ tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)  -findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult+findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM Finder.FindResult findImportedModule mod_name mb_pkg = do     hsc_env <- getTopEnv     tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg@@ -180,7 +180,7 @@  -- | Create a fresh coercion hole. newCoercionHole :: PredType -> TcPluginM CoercionHole-newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole YesBlockSubst+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole  -- | Bind an evidence variable.  This must not be invoked from -- 'tcPluginInit' or 'tcPluginStop', or it will panic.

GHC/Tc/Solver.hs view

@@ -1,2651 +1,2522 @@ {-# LANGUAGE CPP #-}  module GHC.Tc.Solver(-       simplifyInfer, InferMode(..),-       growThetaTyVars,-       simplifyAmbiguityCheck,-       simplifyDefault,-       simplifyTop, simplifyTopImplic,-       simplifyInteractive,-       solveEqualities, solveLocalEqualities, solveLocalEqualitiesX,-       simplifyWantedsTcM,-       tcCheckSatisfiability,-       tcNormalise,--       captureTopConstraints,--       simpl_top,--       promoteTyVarSet, emitFlatConstraints,--       -- For Rules we need these-       solveWanteds, solveWantedsAndDrop,-       approximateWC, runTcSDeriveds-  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Data.Bag-import GHC.Core.Class ( Class, classKey, classTyCon )-import GHC.Driver.Session-import GHC.Types.Id   ( idType )-import GHC.Tc.Utils.Instantiate-import GHC.Data.List.SetOps-import GHC.Types.Name-import GHC.Utils.Outputable-import GHC.Builtin.Utils-import GHC.Builtin.Names-import GHC.Tc.Errors-import GHC.Tc.Types.Evidence-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.Solver.Monad  as TcS-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate-import GHC.Tc.Types.Origin-import GHC.Tc.Utils.TcType-import GHC.Core.Type-import GHC.Builtin.Types ( liftedRepTy, manyDataConTy )-import GHC.Core.Unify    ( tcMatchTyKi )-import GHC.Utils.Misc-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Basic    ( IntWithInf, intGtLimit )-import GHC.Utils.Error    ( emptyMessages )-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.Foldable      ( toList )-import Data.List          ( partition )-import Data.List.NonEmpty ( NonEmpty(..) )--{--*********************************************************************************-*                                                                               *-*                           External interface                                  *-*                                                                               *-*********************************************************************************--}--captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)--- (captureTopConstraints m) runs m, and returns the type constraints it--- generates plus the constraints produced by static forms inside.--- If it fails with an exception, it reports any insolubles--- (out of scope variables) before doing so------ captureTopConstraints is used exclusively by GHC.Tc.Module at the top--- level of a module.------ Importantly, if captureTopConstraints propagates an exception, it--- reports any insoluble constraints first, lest they be lost--- altogether.  This is important, because solveLocalEqualities (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]--- #16376 is an example of what goes wrong if you don't do this.------ NB: the caller should bring any environments into scope before--- calling this, so that the reportUnsolved has access to the most--- complete GlobalRdrEnv-captureTopConstraints thing_inside-  = do { static_wc_var <- TcM.newTcRef emptyWC ;-       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $-                          TcM.tryCaptureConstraints thing_inside-       ; stWC <- TcM.readTcRef static_wc_var--       -- See GHC.Tc.Utils.Monad Note [Constraints and errors]-       -- If the thing_inside threw an exception, but generated some insoluble-       -- constraints, report the latter before propagating the exception-       -- Otherwise they will be lost altogether-       ; case mb_res of-           Just res -> return (res, lie `andWC` stWC)-           Nothing  -> do { _ <- simplifyTop lie; failM } }-                -- This call to simplifyTop is the reason-                -- this function is here instead of GHC.Tc.Utils.Monad-                -- We call simplifyTop so that it does defaulting-                -- (esp of runtime-reps) before reporting errors--simplifyTopImplic :: Bag Implication -> TcM ()-simplifyTopImplic implics-  = do { empty_binds <- simplifyTop (mkImplicWC implics)--       -- Since all the inputs are implications the returned bindings will be empty-       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )--       ; return () }--simplifyTop :: WantedConstraints -> TcM (Bag EvBind)--- Simplify top-level constraints--- Usually these will be implications,--- but when there is nothing to quantify we don't wrap--- in a degenerate implication, so we do that here instead-simplifyTop wanteds-  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds-       ; ((final_wc, unsafe_ol), binds1) <- runTcS $-            do { final_wc <- simpl_top wanteds-               ; unsafe_ol <- getSafeOverlapFailures-               ; return (final_wc, unsafe_ol) }-       ; traceTc "End simplifyTop }" empty--       ; binds2 <- reportUnsolved final_wc--       ; traceTc "reportUnsolved (unsafe overlapping) {" empty-       ; unless (isEmptyCts unsafe_ol) $ do {-           -- grab current error messages and clear, warnAllUnsolved will-           -- update error messages which we'll grab and then restore saved-           -- messages.-           ; errs_var  <- getErrsVar-           ; saved_msg <- TcM.readTcRef errs_var-           ; TcM.writeTcRef errs_var emptyMessages--           ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol }--           ; whyUnsafe <- fst <$> TcM.readTcRef errs_var-           ; TcM.writeTcRef errs_var saved_msg-           ; recordUnsafeInfer whyUnsafe-           }-       ; traceTc "reportUnsolved (unsafe overlapping) }" empty--       ; return (evBindMapBinds binds1 `unionBags` binds2) }----- | 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-       ; return res }--emitFlatConstraints :: WantedConstraints -> TcM ()--- See Note [Failure in local type signatures]-emitFlatConstraints wanted-  = do { wanted <- TcM.zonkWC wanted-       ; case floatKindEqualities wanted of-           Nothing -> do { traceTc "emitFlatConstraints: failing" (ppr wanted)-                         ; emitConstraints wanted -- So they get reported!-                         ; failM }-           Just (simples, holes)-              -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)-                    ; traceTc "emitFlatConstraints:" $-                      vcat [ text "simples:" <+> ppr simples-                           , text "holes:  " <+> ppr holes ]-                    ; emitHoles holes -- Holes don't need promotion-                    ; emitSimples simples } }--floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)--- Float out all the constraints from the WantedConstraints,--- Return Nothing if any constraints can't be floated (captured--- by skolems), or if there is an insoluble constraint, or--- IC_Telescope telescope error-floatKindEqualities wc = float_wc emptyVarSet wc-  where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)-    float_wc trapping_tvs (WC { wc_simple = simples-                              , wc_impl = implics-                              , wc_holes = holes })-      | all is_floatable simples-      = do { (inner_simples, inner_holes)-                <- flatMapBagPairM (float_implic trapping_tvs) implics-           ; return ( simples `unionBags` inner_simples-                    , holes `unionBags` inner_holes) }-      | otherwise-      = Nothing-      where-        is_floatable ct-           | insolubleEqCt ct = False-           | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs--    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)-    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_no_eqs = no_eqs-                                      , ic_skols = skols, ic_status = status })-      | isInsolubleStatus status-      = Nothing   -- A short cut /plus/ we must keep track of IC_BadTelescope-      | otherwise-      = do { (simples, holes) <- float_wc new_trapping_tvs wanted-           ; when (not (isEmptyBag simples) && not no_eqs) $-             Nothing-                 -- If there are some constraints to float out, but we can't-                 -- because we don't float out past local equalities-                 -- (c.f GHC.Tc.Solver.approximateWC), then fail-           ; return (simples, holes) }-      where-        new_trapping_tvs = trapping_tvs `extendVarSetList` skols---{- 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):--  class (a ~ b) => C a b-  data SameKind :: k -> k -> Type where { SK :: SameKind a b }--  bar :: forall (a :: Type) (b :: Type).-         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-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-later.--Another possiblity is that we might have something like-   F alpha ~ [Int]-where alpha is bound further out, which might become soluble-"later" when we learn more about alpha.  So we want to emit-those residual constraints.--BUT it's no good simply wrapping all unsolved constraints from-a type signature in an implication constraint to solve later. The-problem is that we are going to /use/ that signature, including-instantiate it.  Say we have-     f :: forall a.  (forall b. blah) -> blah2-     f x = <body>-To typecheck the definition of f, we have to instantiate those-foralls.  Moreover, any unsolved kind equalities will be coercion-holes in the type.  If we naively wrap them in an implication like-     forall a. (co1:k1~k2,  forall b.  co2:k3~k4)-hoping to solve it later, we might end up filling in the holes-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-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:--* solveLocalEqualitiesX: try to solve the constraints (solveLocalEqualitiesX)--* buildTvImplication: build an implication for the residual, unsolved-  constraint--* emitFlatConstraints: try to float out every unsolved equalities-  inside that implication, in the hope that it constrains only global-  type variables, not the locally-quantified ones.--  * If we fail, or find an insoluble constraint, emit the implication,-    so that the errors will be reported, and fail.--  * If we succeed in floating all the equalities, promote them and-    re-emit them as flat constraint, not wrapped at all (since they-    don't mention any of the quantified variables.--* Note that this float-and-promote step means that anonymous-  wildcards get floated to top level, as we want; see-  Note [Checking partial type signatures] in GHC.Tc.Gen.HsType.--All this is done:--* in solveLocalEqualities, where there is no kind-generalisation-  to complicate matters.--* in GHC.Tc.Gen.HsType.tcHsSigType, where quantification intervenes.--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--       ; 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-    -- See Note [Top-level Defaulting Plan]-simpl_top wanteds-  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)-                            -- This is where the main work happens-       ; dflags <- getDynFlags-       ; try_tyvar_defaulting dflags wc_first_go }-  where-    try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints-    try_tyvar_defaulting dflags wc-      | isEmptyWC wc-      = return wc-      | insolubleWC wc-      , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]-      = try_class_defaulting wc-      | otherwise-      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)-           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs-                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked-                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,-                   -- and we definitely don't want to try to assign to those!-                   -- The isTyVar is needed to weed out coercion variables--           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects-           ; if or defaulted-             then do { wc_residual <- nestTcS (solveWanteds wc)-                            -- See Note [Must simplify after defaulting]-                     ; try_class_defaulting wc_residual }-             else try_class_defaulting wc }     -- No defaulting took place--    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints-    try_class_defaulting wc-      | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]-      = return wc-      | otherwise  -- See Note [When to do type-class defaulting]-      = do { something_happened <- applyDefaultingRules wc-                                   -- See Note [Top-level Defaulting Plan]-           ; if something_happened-             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)-                     ; try_class_defaulting wc_residual }-                  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-             else try_callstack_defaulting wc }--    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints-    try_callstack_defaulting wc-      | isEmptyWC wc-      = return wc-      | otherwise-      = defaultCallStacks wc---- | Default any remaining @CallStack@ constraints to empty @CallStack@s.-defaultCallStacks :: WantedConstraints -> TcS WantedConstraints--- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-defaultCallStacks wanteds-  = do simples <- handle_simples (wc_simple wanteds)-       mb_implics <- mapBagM handle_implic (wc_impl wanteds)-       return (wanteds { wc_simple = simples-                       , wc_impl = catBagMaybes mb_implics })--  where--  handle_simples simples-    = catBagMaybes <$> mapBagM defaultCallStack simples--  handle_implic :: Implication -> TcS (Maybe Implication)-  -- The Maybe is because solving the CallStack constraint-  -- may well allow us to discard the implication entirely-  handle_implic implic-    | isSolvedStatus (ic_status implic)-    = return (Just implic)-    | otherwise-    = do { wanteds <- setEvBindsTcS (ic_binds implic) $-                      -- defaultCallStack sets a binding, so-                      -- we must set the correct binding group-                      defaultCallStacks (ic_wanted implic)-         ; setImplicationStatus (implic { ic_wanted = wanteds }) }--  defaultCallStack ct-    | ClassPred cls tys <- classifyPredType (ctPred ct)-    , Just {} <- isCallStackPred cls tys-    = do { solveCallStack (ctEvidence ct) EvCsEmpty-         ; return Nothing }--  defaultCallStack ct-    = 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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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-lot of errors that would be solved by defaulting; these errors are-quite spurious because fixing the single insoluble error means that-defaulting happens again, which makes all the other errors go away.-This is jolly confusing: #9033.--So it seems better to always do type-class defaulting.--However, always doing defaulting does mean that we'll do it in-situations like this (#5934):-   run :: (forall s. GenST s) -> Int-   run = fromInteger 0-We don't unify the return type of fromInteger with the given function-type, because the latter involves foralls.  So we're left with-    (Num alpha, alpha ~ (forall s. GenST s) -> Int)-Now we do defaulting, get alpha := Integer, and report that we can't-match Integer with (forall s. GenST s) -> Int.  That's not totally-stupid, but perhaps a little strange.--Another potential alternative would be to suppress *all* non-insoluble-errors if there are *any* insoluble errors, anywhere, but that seems-too drastic.--Note [Must simplify after defaulting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We may have a deeply buried constraint-    (t:*) ~ (a:Open)-which we couldn't solve because of the kind incompatibility, and 'a' is free.-Then when we default 'a' we can solve the constraint.  And we want to do-that before starting in on type classes.  We MUST do it before reporting-errors, because it isn't an error!  #7967 was due to this.--Note [Top-level Defaulting Plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have considered two design choices for where/when to apply defaulting.-   (i) Do it in SimplCheck mode only /whenever/ you try to solve some-       simple constraints, maybe deep inside the context of implications.-       This used to be the case in GHC 7.4.1.-   (ii) Do it in a tight loop at simplifyTop, once all other constraints have-        finished. This is the current story.--Option (i) had many disadvantages:-   a) Firstly, it was deep inside the actual solver.-   b) Secondly, it was dependent on the context (Infer a type signature,-      or Check a type signature, or Interactive) since we did not want-      to always start defaulting when inferring (though there is an exception to-      this, see Note [Default while Inferring]).-   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:-          f :: Int -> Bool-          f x = const True (\y -> let w :: a -> a-                                      w a = const a (y+1)-                                  in w y)-      We will get an implication constraint (for beta the type of y):-               [untch=beta] forall a. 0 => Num beta-      which we really cannot default /while solving/ the implication, since beta is-      untouchable.--Instead our new defaulting story is to pull defaulting out of the solver loop and-go with option (ii), implemented at SimplifyTop. Namely:-     - First, have a go at solving the residual constraint of the whole-       program-     - Try to approximate it with a simple constraint-     - Figure out derived defaulting equations for that simple constraint-     - Go round the loop again if you did manage to get some equations--Now, that has to do with class defaulting. However there exists type variable /kind/-defaulting. Again this is done at the top-level and the plan is:-     - At the top-level, once you had a go at solving the constraint, do-       figure out /all/ the touchable unification variables of the wanted constraints.-     - Apply defaulting to their kinds--More details in Note [DefaultTyVar].--Note [Safe Haskell Overlapping Instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In Safe Haskell, we apply an extra restriction to overlapping instances. The-motive is to prevent untrusted code provided by a third-party, changing the-behavior of trusted code through type-classes. This is due to the global and-implicit nature of type-classes that can hide the source of the dictionary.--Another way to state this is: if a module M compiles without importing another-module N, changing M to import N shouldn't change the behavior of M.--Overlapping instances with type-classes can violate this principle. However,-overlapping instances aren't always unsafe. They are just unsafe when the most-selected dictionary comes from untrusted code (code compiled with -XSafe) and-overlaps instances provided by other modules.--In particular, in Safe Haskell at a call site with overlapping instances, we-apply the following rule to determine if it is a 'unsafe' overlap:-- 1) Most specific instance, I1, defined in an `-XSafe` compiled module.- 2) I1 is an orphan instance or a MPTC.- 3) At least one overlapped instance, Ix, is both:-    A) from a different module than I1-    B) Ix is not marked `OVERLAPPABLE`--This is a slightly involved heuristic, but captures the situation of an-imported module N changing the behavior of existing code. For example, if-condition (2) isn't violated, then the module author M must depend either on a-type-class or type defined in N.--Secondly, when should these heuristics be enforced? We enforced them when the-type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.-This allows `-XUnsafe` modules to operate without restriction, and for Safe-Haskell inferrence to infer modules with unsafe overlaps as unsafe.--One alternative design would be to also consider if an instance was imported as-a `safe` import or not and only apply the restriction to instances imported-safely. However, since instances are global and can be imported through more-than one path, this alternative doesn't work.--Note [Safe Haskell Overlapping Instances Implementation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--How is this implemented? It's complicated! So we'll step through it all:-- 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where-    we check if a particular type-class method call is safe or unsafe. We do this-    through the return type, `ClsInstLookupResult`, where the last parameter is a-    list of instances that are unsafe to overlap. When the method call is safe,-    the list is null.-- 2) `GHC.Tc.Solver.Interact.matchClassInst` -- This module drives the instance resolution-    / dictionary generation. The return type is `ClsInstResult`, which either-    says no instance matched, or one found, and if it was a safe or unsafe-    overlap.-- 3) `GHC.Tc.Solver.Interact.doTopReactDict` -- Takes a dictionary / class constraint and-     tries to resolve it by calling (in part) `matchClassInst`. The resolving-     mechanism has a work list (of constraints) that it process one at a time. If-     the constraint can't be resolved, it's added to an inert set. When compiling-     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know-     compilation should fail. These are handled as normal constraint resolution-     failures from here-on (see step 6).--     Otherwise, we may be inferring safety (or using `-Wunsafe`), and-     compilation should succeed, but print warnings and/or mark the compiled module-     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds-     the unsafe (but resolved!) constraint to the `inert_safehask` field of-     `InertCans`.-- 4) `GHC.Tc.Solver.simplifyTop`:-       * Call simpl_top, the top-level function for driving the simplifier for-         constraint resolution.--       * Once finished, call `getSafeOverlapFailures` to retrieve the-         list of overlapping instances that were successfully resolved,-         but unsafe. Remember, this is only applicable for generating warnings-         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`-         cause compilation failure by not resolving the unsafe constraint at all.--       * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`,-         while for resolved but unsafe overlapping dictionary constraints, call-         `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a-         warning message for the user.--       * In the case of `warnAllUnsolved` for resolved, but unsafe-         dictionary constraints, we collect the generated warning-         message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to-         mark the module we are compiling as unsafe, passing the-         warning message along as the reason.-- 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by-    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we-    know is the constraint that is unresolved or unsafe. For dictionary, all we-    know is that we need a dictionary of type C, but not what instances are-    available and how they overlap. So we once again call `lookupInstEnv` to-    figure that out so we can generate a helpful error message.-- 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an-      IORef called `tcg_safeInfer`.-- 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling-    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence-    failed.--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.-#11947 was an example:-   f :: Num a => Int -> Int-This is ambiguous of course, but we don't want to default the-(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting-warning, but no error.--Note [Defaulting insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a set of wanteds is insoluble, we have no hope of accepting the-program. Yet we do not stop constraint solving, etc., because we may-simplify the wanteds to produce better error messages. So, once-we have an insoluble constraint, everything we do is just about producing-helpful error messages.--Should we default in this case or not? Let's look at an example (tcfail004):--  (f,g) = (1,2,3)--With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).-Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)-find the latter more helpful. Several other test cases (e.g. tcfail005) suggest-similarly. So: we should not do class defaulting with insolubles.--On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:--  f :: Integer i => i-  f =               0--Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind-TYPE r0 -> Constraint and then complains that r0 is actually untouchable-(presumably, because it can't be sure if `Integer i` entails an equality).-If we default, we are told of a clash between (* -> Constraint) and Constraint.-The latter seems far better, suggesting we *should* do RuntimeRep-defaulting-even on insolubles.--But, evidently, not always. Witness UnliftedNewtypesInfinite:--  newtype Foo = FooC (# Int#, Foo #)--This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).-If we default RuntimeRep-vars, we get--  Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted--which is just plain wrong.--Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not-want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps-is not set.--}---------------------simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()-simplifyAmbiguityCheck ty wanteds-  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)-       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds-             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]--       ; traceTc "End simplifyAmbiguityCheck }" empty--       -- Normally report all errors; but with -XAllowAmbiguousTypes-       -- report only insoluble ones, since they represent genuinely-       -- inaccessible code-       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes-       ; traceTc "reportUnsolved(ambig) {" empty-       ; unless (allow_ambiguous && not (insolubleWC final_wc))-                (discardResult (reportUnsolved final_wc))-       ; traceTc "reportUnsolved(ambig) }" empty--       ; return () }---------------------simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)-simplifyInteractive wanteds-  = traceTc "simplifyInteractive" empty >>-    simplifyTop wanteds---------------------simplifyDefault :: ThetaType    -- Wanted; has no type variables in it-                -> TcM ()       -- Succeeds if the constraint is soluble-simplifyDefault theta-  = do { traceTc "simplifyDefault" empty-       ; wanteds  <- newWanteds DefaultOrigin theta-       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))-       ; reportAllUnsolved unsolved-       ; 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-    try_harder :: Cts -> TcS Cts-    -- Maybe we have to search up the superclass chain to find-    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.-    -- At the moment we try just once-    try_harder insols-      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable-      = return insols             -- Hurrah -- stop now.-      | otherwise-      = do { pending_given <- getPendingGivenScs-           ; new_given <- makeSuperClasses pending_given-           ; solveSimpleGivens new_given-           ; getInertInsols }---- | 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-                ; ty' <- flattenType norm_loc ty-                ; traceTcS "tcNormalise }" (ppr ty')-                ; pure ty' }-       ; return res }--{- Note [Superclasses and satisfiability]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Expand superclasses before starting, because (Int ~ Bool), has-(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)-as a superclass, and it's the latter that is insoluble.  See-Note [The equality types story] in GHC.Builtin.Types.Prim.--If we fail to prove unsatisfiability we (arbitrarily) try just once to-find superclasses, using try_harder.  Reason: we might have a type-signature-   f :: F op (Implements push) => ..-where F is a type function.  This happened in #3972.--We could do more than once but we'd have to have /some/ limit: in the-the recursive case, we would go on forever in the common case where-the constraints /are/ satisfiable (#10592 comment:12!).--For stratightforard situations without type functions the try_harder-step does nothing.--Note [tcNormalise]-~~~~~~~~~~~~~~~~~~-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.--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".--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.--***********************************************************************************-*                                                                                 *-*                            Inference-*                                                                                 *-***********************************************************************************--Note [Inferring the type of a let-bound variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = rhs--To infer f's type we do the following:- * Gather the constraints for the RHS with ambient level *one more than*-   the current one.  This is done by the call-        pushLevelAndCaptureConstraints (tcMonoBinds...)-   in GHC.Tc.Gen.Bind.tcPolyInfer-- * Call simplifyInfer to simplify the constraints and decide what to-   quantify over. We pass in the level used for the RHS constraints,-   here called rhs_tclvl.--This ensures that the implication constraint we generate, if any,-has a strictly-increased level compared to the ambient level outside-the let binding.---}---- | How should we choose which constraints to quantify over?-data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,-                                  -- never quantifying over any constraints-               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module",-                                  -- the :type +d case; this mode refuses-                                  -- to quantify over any defaultable constraint-               | NoRestrictions   -- ^ Quantify over any constraint that-                                  -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds'--instance Outputable InferMode where-  ppr ApplyMR         = text "ApplyMR"-  ppr EagerDefaulting = text "EagerDefaulting"-  ppr NoRestrictions  = text "NoRestrictions"--simplifyInfer :: TcLevel               -- Used when generating the constraints-              -> InferMode-              -> [TcIdSigInst]         -- Any signatures (possibly partial)-              -> [(Name, TcTauType)]   -- Variables to be generalised,-                                       -- and their tau-types-              -> WantedConstraints-              -> TcM ([TcTyVar],    -- Quantify over these type variables-                      [EvVar],      -- ... and these constraints (fully zonked)-                      TcEvBinds,    -- ... binding these evidence variables-                      WantedConstraints, -- Redidual as-yet-unsolved constraints-                      Bool)         -- True <=> the residual constraints are insoluble--simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds-  | isEmptyWC wanteds-   = do { -- When quantifying, we want to preserve any order of variables as they-          -- appear in partial signatures. cf. decideQuantifiedTyVars-          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs-                                          , (_,Bndr tv _) <- sig_inst_skols sig ]-              psig_theta  = [ pred | sig <- partial_sigs-                                   , pred <- sig_inst_theta sig ]--       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)-       ; qtkvs <- quantifyTyVars dep_vars-       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)-       ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }--  | otherwise-  = do { traceTc "simplifyInfer {"  $ vcat-             [ text "sigs =" <+> ppr sigs-             , text "binds =" <+> ppr name_taus-             , text "rhs_tclvl =" <+> ppr rhs_tclvl-             , text "infer_mode =" <+> ppr infer_mode-             , text "(unzonked) wanted =" <+> ppr wanteds-             ]--       ; let psig_theta = concatMap sig_inst_theta partial_sigs--       -- First do full-blown solving-       -- NB: we must gather up all the bindings from doing-       -- this solving; hence (runTcSWithEvBinds ev_binds_var).-       -- And note that since there are nested implications,-       -- calling solveWanteds will side-effect their evidence-       -- bindings, so we can't just revert to the input-       -- constraint.--       ; tc_env          <- TcM.getEnv-       ; ev_binds_var    <- TcM.newTcEvBinds-       ; psig_theta_vars <- mapM TcM.newEvVar psig_theta-       ; wanted_transformed_incl_derivs-            <- setTcLevel rhs_tclvl $-               runTcSWithEvBinds ev_binds_var $-               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $-                                      env_lcl tc_env-                        psig_givens = mkGivens loc psig_theta_vars-                  ; _ <- solveSimpleGivens psig_givens-                         -- See Note [Add signature contexts as givens]-                  ; solveWanteds wanteds }--       -- Find quant_pred_candidates, the predicates that-       -- we'll consider quantifying over-       -- NB1: wanted_transformed does not include anything provable from-       --      the psig_theta; it's just the extra bit-       -- NB2: We do not do any defaulting when inferring a type, this can lead-       --      to less polymorphic types, see Note [Default while Inferring]-       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs-       ; let definite_error = insolubleWC wanted_transformed_incl_derivs-                              -- See Note [Quantification with errors]-                              -- NB: must include derived errors in this test,-                              --     hence "incl_derivs"-             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs-             quant_pred_candidates-               | definite_error = []-               | otherwise      = ctsPreds (approximateWC False wanted_transformed)--       -- Decide what type variables and constraints to quantify-       -- NB: quant_pred_candidates is already fully zonked-       -- NB: bound_theta are constraints we want to quantify over,-       --     including the psig_theta, which we always quantify over-       -- NB: bound_theta are fully zonked-       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl-                                                     name_taus partial_sigs-                                                     quant_pred_candidates-       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta--       -- We must produce bindings for the psig_theta_vars, because we may have-       -- used them in evidence bindings constructed by solveWanteds earlier-       -- Easiest way to do this is to emit them as new Wanteds (#14643)-       ; ct_loc <- getCtLocM AnnOrigin Nothing-       ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var-                                      , ctev_dest = EvVarDest psig_theta_var-                                      , ctev_nosh = WDeriv-                                      , ctev_loc  = ct_loc }-                           | psig_theta_var <- psig_theta_vars ]--       -- Now construct the residual constraint-       ; residual_wanted <- mkResidualConstraints rhs_tclvl ev_binds_var-                                 name_taus co_vars qtvs bound_theta_vars-                                 (wanted_transformed `andWC` mkSimpleWC psig_wanted)--         -- All done!-       ; traceTc "} simplifyInfer/produced residual implication for quantification" $-         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates-              , text "psig_theta =" <+> ppr psig_theta-              , text "bound_theta =" <+> ppr bound_theta-              , text "qtvs ="       <+> ppr qtvs-              , text "definite_error =" <+> ppr definite_error ]--       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var-                , residual_wanted, definite_error ) }-         -- NB: bound_theta_vars must be fully zonked-  where-    partial_sigs = filter isPartialSig sigs-----------------------mkResidualConstraints :: TcLevel -> EvBindsVar-                      -> [(Name, TcTauType)]-                      -> VarSet -> [TcTyVar] -> [EvVar]-                      -> WantedConstraints -> TcM WantedConstraints--- Emit the remaining constraints from the RHS.--- See Note [Emitting the residual implication in simplifyInfer]-mkResidualConstraints rhs_tclvl ev_binds_var-                        name_taus co_vars qtvs full_theta_vars wanteds-  | isEmptyWC wanteds-  = return wanteds--  | otherwise-  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)-       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple-             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars--        ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)--        ; let inner_wanted = wanteds { wc_simple = inner_simple }-        ; implics <- if isEmptyWC inner_wanted-                     then return emptyBag-                     else do implic1 <- newImplication-                             return $ unitBag $-                                      implic1  { ic_tclvl  = rhs_tclvl-                                               , ic_skols  = qtvs-                                               , ic_given  = full_theta_vars-                                               , ic_wanted = inner_wanted-                                               , ic_binds  = ev_binds_var-                                               , ic_no_eqs = False-                                               , ic_info   = skol_info }--        ; return (emptyWC { wc_simple = outer_simple-                          , wc_impl   = implics })}-  where-    full_theta = map idType full_theta_vars-    skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)-                           | (name, ty) <- name_taus ]-                 -- Don't add the quantified variables here, because-                 -- they are also bound in ic_skols and we want them-                 -- to be tidied uniformly-----------------------ctsPreds :: Cts -> [PredType]-ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts-                             , let ev = ctEvidence ct ]--{- Note [Emitting the residual implication in simplifyInfer]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f = e-where f's type is inferred to be something like (a, Proxy k (Int |> co))-and we have an as-yet-unsolved, or perhaps insoluble, constraint-   [W] co :: Type ~ k-We can't form types like (forall co. blah), so we can't generalise over-the coercion variable, and hence we can't generalise over things free in-its kind, in the case 'k'.  But we can still generalise over 'a'.  So-we'll generalise to-   f :: forall a. (a, Proxy k (Int |> co))-Now we do NOT want to form the residual implication constraint-   forall a. [W] co :: Type ~ k-because then co's eventual binding (which will be a value binding if we-use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose-type mentions 'co').  Instead, just as we don't generalise over 'co', we-should not bury its constraint inside the implication.  Instead, we must-put it outside.--That is the reason for the partitionBag in emitResidualConstraints,-which takes the CoVars free in the inferred type, and pulls their-constraints out.  (NB: this set of CoVars should be closed-over-kinds.)--All rather subtle; see #14584.--Note [Add signature contexts as givens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#11016):-  f2 :: (?x :: Int) => _-  f2 = ?x-or this-  f3 :: a ~ Bool => (a, _)-  f3 = (True, False)-or theis-  f4 :: (Ord a, _) => a -> Bool-  f4 x = x==x--We'll use plan InferGen because there are holes in the type.  But:- * For f2 we want to have the (?x :: Int) constraint floating around-   so that the functional dependencies kick in.  Otherwise the-   occurrence of ?x on the RHS produces constraint (?x :: alpha), and-   we won't unify alpha:=Int.- * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool)-   in the RHS- * For f4 we want to use the (Ord a) in the signature to solve the Eq a-   constraint.--Solution: in simplifyInfer, just before simplifying the constraints-gathered from the RHS, add Given constraints for the context of any-type signatures.--************************************************************************-*                                                                      *-                Quantification-*                                                                      *-************************************************************************--Note [Deciding quantification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the monomorphism restriction does not apply, then we quantify as follows:--* Step 1. Take the global tyvars, and "grow" them using the equality-  constraints-     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can-          happen because alpha is untouchable here) then do not quantify over-          beta, because alpha fixes beta, and beta is effectively free in-          the environment too--  We also account for the monomorphism restriction; if it applies,-  add the free vars of all the constraints.--  Result is mono_tvs; we will not quantify over these.--* Step 2. Default any non-mono tyvars (i.e ones that are definitely-  not going to become further constrained), and re-simplify the-  candidate constraints.--  Motivation for re-simplification (#7857): imagine we have a-  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are-  not free in the envt, and instance forall (a::*) (b::*). (C a) => C-  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but-  it will match when we default them to LiftedRep.--  This is all very tiresome.--* Step 3: decide which variables to quantify over, as follows:--  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"-    them using all the constraints.  These are tau_tvs_plus--  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being-    careful to close over kinds, and to skolemise the quantified tyvars.-    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)--  Result is qtvs.--* Step 4: Filter the constraints using pickQuantifiablePreds and the-  qtvs. We have to zonk the constraints first, so they "see" the-  freshly created skolems.---}--decideQuantification-  :: InferMode-  -> TcLevel-  -> [(Name, TcTauType)]   -- Variables to be generalised-  -> [TcIdSigInst]         -- Partial type signatures (if any)-  -> [PredType]            -- Candidate theta; already zonked-  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)-         , [PredType]      -- and this context (fully zonked)-         , VarSet)--- See Note [Deciding quantification]-decideQuantification infer_mode rhs_tclvl name_taus psigs candidates-  = do { -- Step 1: find the mono_tvs-       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode-                                              name_taus psigs candidates--       -- Step 2: default any non-mono tyvars, and re-simplify-       -- This step may do some unification, but result candidates is zonked-       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates--       -- Step 3: decide which kind/type variables to quantify over-       ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates--       -- Step 4: choose which of the remaining candidate-       --         predicates to actually quantify over-       -- NB: decideQuantifiedTyVars turned some meta tyvars-       -- into quantified skolems, so we have to zonk again-       ; candidates <- TcM.zonkTcTypes candidates-       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)-       ; let quantifiable_candidates-               = pickQuantifiablePreds (mkVarSet qtvs) candidates-             -- NB: do /not/ run pickQuantifiablePreds over psig_theta,-             -- because we always want to quantify over psig_theta, and not-             -- drop any of them; e.g. CallStack constraints.  c.f #14658--             theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]-                     (psig_theta ++ quantifiable_candidates)--       ; traceTc "decideQuantification"-           (vcat [ text "infer_mode:" <+> ppr infer_mode-                 , text "candidates:" <+> ppr candidates-                 , text "psig_theta:" <+> ppr psig_theta-                 , text "mono_tvs:"   <+> ppr mono_tvs-                 , text "co_vars:"    <+> ppr co_vars-                 , text "qtvs:"       <+> ppr qtvs-                 , text "theta:"      <+> ppr theta ])-       ; return (qtvs, theta, co_vars) }---------------------decideMonoTyVars :: InferMode-                 -> [(Name,TcType)]-                 -> [TcIdSigInst]-                 -> [PredType]-                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)--- Decide which tyvars and covars cannot be generalised:---   (a) Free in the environment---   (b) Mentioned in a constraint we can't generalise---   (c) Connected by an equality to (a) or (b)--- Also return CoVars that appear free in the final quantified types---   we can't quantify over these, and we must make sure they are in scope-decideMonoTyVars infer_mode name_taus psigs candidates-  = do { (no_quant, maybe_quant) <- pick infer_mode candidates--       -- If possible, we quantify over partial-sig qtvs, so they are-       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs-       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $-                      concatMap (map snd . sig_inst_skols) psigs--       ; psig_theta <- mapM TcM.zonkTcType $-                       concatMap sig_inst_theta psigs--       ; taus <- mapM (TcM.zonkTcType . snd) name_taus--       ; tc_lvl <- TcM.getTcLevel-       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta--             co_vars = coVarsOfTypes (psig_tys ++ taus)-             co_var_tvs = closeOverKinds co_vars-               -- The co_var_tvs are tvs mentioned in the types of covars or-               -- coercion holes. We can't quantify over these covars, so we-               -- must include the variable in their types in the mono_tvs.-               -- E.g.  If we can't quantify over co :: k~Type, then we can't-               --       quantify over k either!  Hence closeOverKinds--             mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $-                         tyCoVarsOfTypes candidates-               -- We need to grab all the non-quantifiable tyvars in the-               -- candidates so that we can grow this set to find other-               -- non-quantifiable tyvars. This can happen with something-               -- like-               --    f x y = ...-               --      where z = x 3-               -- The body of z tries to unify the type of x (call it alpha[1])-               -- with (beta[2] -> gamma[2]). This unification fails because-               -- alpha is untouchable. But we need to know not to quantify over-               -- beta or gamma, because they are in the equality constraint with-               -- alpha. Actual test case: typecheck/should_compile/tc213--             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs--             eq_constraints = filter isEqPrimPred candidates-             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1--             constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $-                               (growThetaTyVars eq_constraints-                                               (tyCoVarsOfTypes no_quant)-                                `minusVarSet` mono_tvs2)-                               `delVarSetList` psig_qtvs-             -- constrained_tvs: the tyvars that we are not going to-             -- quantify solely because of the monomorphism restriction-             ---             -- (`minusVarSet` mono_tvs2`): a type variable is only-             --   "constrained" (so that the MR bites) if it is not-             --   free in the environment (#13785)-             ---             -- (`delVarSetList` psig_qtvs): if the user has explicitly-             --   asked for quantification, then that request "wins"-             --   over the MR.  Note: do /not/ delete psig_qtvs from-             --   mono_tvs1, because mono_tvs1 cannot under any circumstances-             --   be quantified (#14479); see-             --   Note [Quantification and partial signatures], Wrinkle 3, 4--             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs--           -- Warn about the monomorphism restriction-       ; warn_mono <- woptM Opt_WarnMonomorphism-       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $-         warnTc (Reason Opt_WarnMonomorphism)-                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)-                mr_msg--       ; traceTc "decideMonoTyVars" $ vcat-           [ text "mono_tvs0 =" <+> ppr mono_tvs0-           , text "no_quant =" <+> ppr no_quant-           , text "maybe_quant =" <+> ppr maybe_quant-           , text "eq_constraints =" <+> ppr eq_constraints-           , text "mono_tvs =" <+> ppr mono_tvs-           , text "co_vars =" <+> ppr co_vars ]--       ; return (mono_tvs, maybe_quant, co_vars) }-  where-    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])-    -- Split the candidates into ones we definitely-    -- won't quantify, and ones that we might-    pick NoRestrictions  cand = return ([], cand)-    pick ApplyMR         cand = return (cand, [])-    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings-                                   ; return (partition (is_int_ct os) cand) }--    -- For EagerDefaulting, do not quantify over-    -- over any interactive class constraint-    is_int_ct ovl_strings pred-      | Just (cls, _) <- getClassPredTys_maybe pred-      = isInteractiveClass ovl_strings cls-      | otherwise-      = False--    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus-    mr_msg =-         hang (sep [ text "The Monomorphism Restriction applies to the binding"-                     <> plural name_taus-                   , text "for" <+> pp_bndrs ])-            2 (hsep [ text "Consider giving"-                    , text (if isSingleton name_taus then "it" else "them")-                    , text "a type signature"])----------------------defaultTyVarsAndSimplify :: TcLevel-                         -> TyCoVarSet-                         -> [PredType]          -- Assumed zonked-                         -> TcM [PredType]      -- Guaranteed zonked--- Default any tyvar free in the constraints,--- and re-simplify in case the defaulting allows further simplification-defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates-  = do {  -- Promote any tyvars that we cannot generalise-          -- See Note [Promote momomorphic tyvars]-       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)-       ; any_promoted <- promoteTyVarSet mono_tvs--       -- Default any kind/levity vars-       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}-                <- candidateQTyVarsOfTypes candidates-                -- any covars should already be handled by-                -- the logic in decideMonoTyVars, which looks at-                -- the constraints generated--       ; poly_kinds  <- xoptM LangExt.PolyKinds-       ; default_kvs <- mapM (default_one poly_kinds True)-                             (dVarSetElems cand_kvs)-       ; default_tvs <- mapM (default_one poly_kinds False)-                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))-       ; let some_default = or default_kvs || or default_tvs--       ; case () of-           _ | some_default -> simplify_cand candidates-             | any_promoted -> mapM TcM.zonkTcType candidates-             | otherwise    -> return candidates-       }-  where-    default_one poly_kinds is_kind_var tv-      | not (isMetaTyVar tv)-      = return False-      | tv `elemVarSet` mono_tvs-      = return False-      | otherwise-      = defaultTyVar (not poly_kinds && is_kind_var) tv--    simplify_cand candidates-      = do { clone_wanteds <- newWanteds DefaultOrigin candidates-           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $-                                           simplifyWantedsTcM clone_wanteds-              -- Discard evidence; simples is fully zonked--           ; let new_candidates = ctsPreds simples-           ; traceTc "Simplified after defaulting" $-                      vcat [ text "Before:" <+> ppr candidates-                           , text "After:"  <+> ppr new_candidates ]-           ; return new_candidates }---------------------decideQuantifiedTyVars-   :: [(Name,TcType)]   -- Annotated theta and (name,tau) pairs-   -> [TcIdSigInst]     -- Partial signatures-   -> [PredType]        -- Candidates, zonked-   -> TcM [TyVar]--- Fix what tyvars we are going to quantify over, and quantify them-decideQuantifiedTyVars name_taus psigs candidates-  = do {     -- Why psig_tys? We try to quantify over everything free in here-             -- See Note [Quantification and partial signatures]-             --     Wrinkles 2 and 3-       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs-                                                  , (_,Bndr tv _) <- sig_inst_skols sig ]-       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs-                                                  , pred <- sig_inst_theta sig ]-       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus--       ; let -- Try to quantify over variables free in these types-             psig_tys = psig_tv_tys ++ psig_theta-             seed_tys = psig_tys ++ tau_tys--             -- Now "grow" those seeds to find ones reachable via 'candidates'-             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)--       -- Now we have to classify them into kind variables and type variables-       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars-       ---       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces-       -- them in that order, so that the final qtvs quantifies in the same-       -- order as the partial signatures do (#13524)-       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $-                                                         psig_tys ++ candidates ++ tau_tys-       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)-             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }--       ; traceTc "decideQuantifiedTyVars" (vcat-           [ text "candidates =" <+> ppr candidates-           , text "tau_tys =" <+> ppr tau_tys-           , text "seed_tys =" <+> ppr seed_tys-           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)-           , text "grown_tcvs =" <+> ppr grown_tcvs-           , text "dvs =" <+> ppr dvs_plus])--       ; quantifyTyVars dvs_plus }---------------------growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet--- See Note [Growing the tau-tvs using constraints]-growThetaTyVars theta tcvs-  | null theta = tcvs-  | otherwise  = transCloVarSet mk_next seed_tcvs-  where-    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips-    (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-    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips-    grow_one so_far pred tcvs-       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs-       | otherwise                           = tcvs-       where-         pred_tcvs = tyCoVarsOfType pred---{- Note [Promote momomorphic tyvars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Promote any type variables that are free in the environment.  Eg-   f :: forall qtvs. bound_theta => zonked_tau-The free vars of f's type become free in the envt, and hence will show-up whenever 'f' is called.  They may currently at rhs_tclvl, but they-had better be unifiable at the outer_tclvl!  Example: envt mentions-alpha[1]-           tau_ty = beta[2] -> beta[2]-           constraints = alpha ~ [beta]-we don't quantify over beta (since it is fixed by envt)-so we must promote it!  The inferred type is just-  f :: beta -> beta--NB: promoteTyVar ignores coercion variables--Note [Quantification and partial signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When choosing type variables to quantify, the basic plan is to-quantify over all type variables that are- * free in the tau_tvs, and- * not forced to be monomorphic (mono_tvs),-   for example by being free in the environment.--However, in the case of a partial type signature, be doing inference-*in the presence of a type signature*. For example:-   f :: _ -> a-   f x = ...-or-   g :: (Eq _a) => _b -> _b-In both cases we use plan InferGen, and hence call simplifyInfer.  But-those 'a' variables are skolems (actually TyVarTvs), and we should be-sure to quantify over them.  This leads to several wrinkles:--* Wrinkle 1.  In the case of a type error-     f :: _ -> Maybe a-     f x = True && x-  The inferred type of 'f' is f :: Bool -> Bool, but there's a-  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting-  machine expects to find a binding site for the skolem 'a', so we-  add it to the quantified tyvars.--* Wrinkle 2.  Consider the partial type signature-     f :: (Eq _) => Int -> Int-     f x = x-  In normal cases that makes sense; e.g.-     g :: Eq _a => _a -> _a-     g x = x-  where the signature makes the type less general than it could-  be. But for 'f' we must therefore quantify over the user-annotated-  constraints, to get-     f :: forall a. Eq a => Int -> Int-  (thereby correctly triggering an ambiguity error later).  If we don't-  we'll end up with a strange open type-     f :: Eq alpha => Int -> Int-  which isn't ambiguous but is still very wrong.--  Bottom line: Try to quantify over any variable free in psig_theta,-  just like the tau-part of the type.--* Wrinkle 3 (#13482). Also consider-    f :: forall a. _ => Int -> Int-    f x = if (undefined :: a) == undefined then x else 0-  Here we get an (Eq a) constraint, but it's not mentioned in the-  psig_theta nor the type of 'f'.  But we still want to quantify-  over 'a' even if the monomorphism restriction is on.--* Wrinkle 4 (#14479)-    foo :: Num a => a -> a-    foo xxx = g xxx-      where-        g :: forall b. Num b => _ -> b-        g y = xxx + y--  In the signature for 'g', we cannot quantify over 'b' because it turns out to-  get unified with 'a', which is free in g's environment.  So we carefully-  refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars.  We-  report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.--Note [Growing the tau-tvs using constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(growThetaTyVars insts tvs) is the result of extending the set-    of tyvars, tvs, using all conceivable links from pred--E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}-Then growThetaTyVars preds tvs = {a,b,c}--Notice that-   growThetaTyVars is conservative       if v might be fixed by vs-                                         => v `elem` grow(vs,C)--Note [Quantification with errors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we find that the RHS of the definition has some absolutely-insoluble-constraints (including especially "variable not in scope"), we--* Abandon all attempts to find a context to quantify over,-  and instead make the function fully-polymorphic in whatever-  type we have found--* Return a flag from simplifyInfer, indicating that we found an-  insoluble constraint.  This flag is used to suppress the ambiguity-  check for the inferred type, which may well be bogus, and which-  tends to obscure the real error.  This fix feels a bit clunky,-  but I failed to come up with anything better.--Reasons:-    - Avoid downstream errors-    - Do not perform an ambiguity test on a bogus type, which might well-      fail spuriously, thereby obfuscating the original insoluble error.-      #14000 is an example--I tried an alternative approach: simply failM, after emitting the-residual implication constraint; the exception will be caught in-GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type-(forall a. a).  But that didn't work with -fdefer-type-errors, because-the recovery from failM emits no code at all, so there is no function-to run!   But -fdefer-type-errors aspires to produce a runnable program.--NB that we must include *derived* errors in the check for insolubles.-Example:-    (a::*) ~ Int#-We get an insoluble derived error *~#, and we don't want to discard-it before doing the isInsolubleWC test!  (#8262)--Note [Default while Inferring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Our current plan is that defaulting only happens at simplifyTop and-not simplifyInfer.  This may lead to some insoluble deferred constraints.-Example:--instance D g => C g Int b--constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha-type inferred       = gamma -> gamma--Now, if we try to default (alpha := Int) we will be able to refine the implication to-  (forall b. 0 => C gamma Int b)-which can then be simplified further to-  (forall b. 0 => D gamma)-Finally, we /can/ approximate this implication with (D gamma) and infer the quantified-type:  forall g. D g => g -> g--Instead what will currently happen is that we will get a quantified type-(forall g. g -> g) and an implication:-       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha--Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an-unsolvable implication:-       forall g. 0 => (forall b. 0 => D g)--The concrete example would be:-       h :: C g a s => g -> a -> ST s a-       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)--But it is quite tedious to do defaulting and resolve the implication constraints, and-we have not observed code breaking because of the lack of defaulting in inference, so-we don't do it for now.----Note [Minimize by Superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we quantify over a constraint, in simplifyInfer we need to-quantify over a constraint that is minimal in some sense: For-instance, if the final wanted constraint is (Eq alpha, Ord alpha),-we'd like to quantify over Ord alpha, because we can just get Eq alpha-from superclass selection from Ord alpha. This minimization is what-mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint-to check the original wanted.---Note [Avoid unnecessary constraint simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    -------- NB NB NB (Jun 12) --------------    This note not longer applies; see the notes with #4361.-    But I'm leaving it in here so we remember the issue.)-    -----------------------------------------When inferring the type of a let-binding, with simplifyInfer,-try to avoid unnecessarily simplifying class constraints.-Doing so aids sharing, but it also helps with delicate-situations like--   instance C t => C [t] where ..--   f :: C [t] => ....-   f x = let g y = ...(constraint C [t])...-         in ...-When inferring a type for 'g', we don't want to apply the-instance decl, because then we can't satisfy (C t).  So we-just notice that g isn't quantified over 't' and partition-the constraints before simplifying.--This only half-works, but then let-generalisation only half-works.--*********************************************************************************-*                                                                                 *-*                                 Main Simplifier                                 *-*                                                                                 *-***********************************************************************************---}--simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints--- Solve the specified Wanted constraints--- Discard the evidence binds--- Discards all Derived stuff in result--- Postcondition: fully zonked and unflattened constraints-simplifyWantedsTcM wanted-  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)-       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))-       ; result <- TcM.zonkWC result-       ; traceTc "simplifyWantedsTcM }" (ppr result)-       ; return result }--solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints--- Since solveWanteds returns the residual WantedConstraints,--- it should always be called within a runTcS or something similar,--- Result is not zonked-solveWantedsAndDrop wanted-  = do { wc <- solveWanteds wanted-       ; return (dropDerivedWC wc) }--solveWanteds :: WantedConstraints -> TcS WantedConstraints--- so that the inert set doesn't mindlessly propagate.--- NB: wc_simples may be wanted /or/ derived now-solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })-  = do { cur_lvl <- TcS.getTcLevel-       ; traceTcS "solveWanteds {" $-         vcat [ text "Level =" <+> ppr cur_lvl-              , ppr wc ]--       ; wc1 <- solveSimpleWanteds simples-                -- Any insoluble constraints are in 'simples' and so get rewritten-                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad--       ; (floated_eqs, implics2) <- solveNestedImplications $-                                    implics `unionBags` wc_impl wc1--       ; dflags   <- getDynFlags-       ; solved_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs-                                (wc1 { wc_impl = implics2 })--       ; holes' <- simplifyHoles holes-       ; let final_wc = solved_wc { wc_holes = holes' }--       ; ev_binds_var <- getTcEvBindsVar-       ; bb <- TcS.getTcEvBindsMap ev_binds_var-       ; traceTcS "solveWanteds }" $-                 vcat [ text "final wc =" <+> ppr final_wc-                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]--       ; return final_wc }--simpl_loop :: Int -> IntWithInf -> Cts-           -> WantedConstraints -> TcS WantedConstraints-simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples })-  | n `intGtLimit` limit-  = do { -- Add an error (not a warning) if we blow the limit,-         -- Typically if we blow the limit we are going to report some other error-         -- (an unsolved constraint), and we don't want that error to suppress-         -- the iteration limit warning!-         addErrTcS (hang (text "solveWanteds: too many iterations"-                   <+> parens (text "limit =" <+> ppr limit))-                2 (vcat [ text "Unsolved:" <+> ppr wc-                        , ppUnless (isEmptyBag floated_eqs) $-                          text "Floated equalities:" <+> ppr floated_eqs-                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"-                  ]))-       ; return wc }--  | not (isEmptyBag floated_eqs)-  = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples })-            -- Put floated_eqs first so they get solved first-            -- NB: the floated_eqs may include /derived/ equalities-            -- arising from fundeps inside an implication--  | superClassesMightHelp wc-  = -- We still have unsolved goals, and apparently no way to solve them,-    -- so try expanding superclasses at this level, both Given and Wanted-    do { pending_given <- getPendingGivenScs-       ; let (pending_wanted, simples1) = getPendingWantedScs simples-       ; if null pending_given && null pending_wanted-           then return wc  -- After all, superclasses did not help-           else-    do { new_given  <- makeSuperClasses pending_given-       ; new_wanted <- makeSuperClasses pending_wanted-       ; solveSimpleGivens new_given -- Add the new Givens to the inert set-       ; simplify_again n limit (null pending_given)-         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }--  | otherwise-  = return wc--simplify_again :: Int -> IntWithInf -> Bool-               -> WantedConstraints -> TcS WantedConstraints--- We have definitely decided to have another go at solving--- the wanted constraints (we have tried at least once already-simplify_again n limit no_new_given_scs-               wc@(WC { wc_simple = simples, wc_impl = implics })-  = do { csTraceTcS $-         text "simpl_loop iteration=" <> int n-         <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma-                            , int (lengthBag simples) <+> text "simples to solve" ])-       ; traceTcS "simpl_loop: wc =" (ppr wc)--       ; (unifs1, wc1) <- reportUnifications $-                          solveSimpleWanteds $-                          simples--       -- See Note [Cutting off simpl_loop]-       -- We have already tried to solve the nested implications once-       -- Try again only if we have unified some meta-variables-       -- (which is a bit like adding more givens), or we have some-       -- new Given superclasses-       ; let new_implics = wc_impl wc1-       ; if unifs1 == 0       &&-            no_new_given_scs  &&-            isEmptyBag new_implics--           then -- Do not even try to solve the implications-                simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics })--           else -- Try to solve the implications-                do { (floated_eqs2, implics2) <- solveNestedImplications $-                                                 implics `unionBags` new_implics-                   ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 })-    } }--solveNestedImplications :: Bag Implication-                        -> TcS (Cts, Bag Implication)--- Precondition: the TcS inerts may contain unsolved simples which have--- to be converted to givens before we go inside a nested implication.-solveNestedImplications implics-  | isEmptyBag implics-  = return (emptyBag, emptyBag)-  | otherwise-  = do { traceTcS "solveNestedImplications starting {" empty-       ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics-       ; let floated_eqs = concatBag floated_eqs_s--       -- ... and we are back in the original TcS inerts-       -- Notice that the original includes the _insoluble_simples so it was safe to ignore-       -- them in the beginning of this function.-       ; traceTcS "solveNestedImplications end }" $-                  vcat [ text "all floated_eqs ="  <+> ppr floated_eqs-                       , text "unsolved_implics =" <+> ppr unsolved_implics ]--       ; return (floated_eqs, catBagMaybes unsolved_implics) }--solveImplication :: Implication    -- Wanted-                 -> TcS (Cts,      -- All wanted or derived floated equalities: var = type-                         Maybe Implication) -- Simplified implication (empty or singleton)--- Precondition: The TcS monad contains an empty worklist and given-only inerts--- which after trying to solve this implication we must restore to their original value-solveImplication imp@(Implic { ic_tclvl  = tclvl-                             , ic_binds  = ev_binds_var-                             , ic_skols  = skols-                             , ic_given  = given_ids-                             , ic_wanted = wanteds-                             , ic_info   = info-                             , ic_status = status })-  | isSolvedStatus status-  = return (emptyCts, Just imp)  -- Do nothing--  | otherwise  -- Even for IC_Insoluble it is worth doing more work-               -- The insoluble stuff might be in one sub-implication-               -- and other unsolved goals in another; and we want to-               -- solve the latter as much as possible-  = do { inerts <- getTcSInerts-       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)--       -- commented out; see `where` clause below-       -- ; when debugIsOn check_tc_level--         -- Solve the nested constraints-       ; (no_given_eqs, given_insols, residual_wanted)-            <- nestImplicTcS ev_binds_var tclvl $-               do { let loc    = mkGivenLoc tclvl info (ic_env imp)-                        givens = mkGivens loc given_ids-                  ; solveSimpleGivens givens--                  ; residual_wanted <- solveWanteds wanteds-                        -- solveWanteds, *not* solveWantedsAndDrop, because-                        -- we want to retain derived equalities so we can float-                        -- them out in floatEqualities--                  ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols-                        -- Call getNoGivenEqs /after/ solveWanteds, because-                        -- solveWanteds can augment the givens, via expandSuperClasses,-                        -- to reveal given superclass equalities--                  ; return (no_eqs, given_insols, residual_wanted) }--       ; (floated_eqs, residual_wanted)-             <- floatEqualities skols given_ids ev_binds_var-                                no_given_eqs residual_wanted--       ; traceTcS "solveImplication 2"-           (ppr given_insols $$ ppr residual_wanted)-       ; let final_wanted = residual_wanted `addInsols` given_insols-             -- Don't lose track of the insoluble givens,-             -- which signal unreachable code; put them in ic_wanted--       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs-                                                 , ic_wanted = final_wanted })--       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var-       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var-       ; traceTcS "solveImplication end }" $ vcat-             [ text "no_given_eqs =" <+> ppr no_given_eqs-             , text "floated_eqs =" <+> ppr floated_eqs-             , text "res_implic =" <+> ppr res_implic-             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)-             , text "implication tvcs =" <+> ppr tcvs ]--       ; return (floated_eqs, res_implic) }--  where-    -- TcLevels must be strictly increasing (see (ImplicInv) in-    -- Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType),-    -- and in fact I think they should always increase one level at a time.--    -- Though sensible, this check causes lots of testsuite failures. It is-    -- remaining commented out for now.-    {--    check_tc_level = do { cur_lvl <- TcS.getTcLevel-                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }-    -}-------------------------setImplicationStatus :: Implication -> TcS (Maybe Implication)--- Finalise the implication returned from solveImplication:---    * Set the ic_status field---    * Trim the ic_wanted field to remove Derived constraints--- Precondition: the ic_status field is not already IC_Solved--- Return Nothing if we can discard the implication altogether-setImplicationStatus implic@(Implic { ic_status     = status-                                    , ic_info       = info-                                    , ic_wanted     = wc-                                    , ic_given      = givens })- | ASSERT2( not (isSolvedStatus status ), ppr info )-   -- Precondition: we only set the status if it is not already solved-   not (isSolvedWC pruned_wc)- = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)--      ; implic <- neededEvVars implic--      ; let new_status | insolubleWC pruned_wc = IC_Insoluble-                       | otherwise             = IC_Unsolved-            new_implic = implic { ic_status = new_status-                                , ic_wanted = pruned_wc }--      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)--      ; return $ Just new_implic }-- | otherwise  -- Everything is solved-              -- Set status to IC_Solved,-              -- and compute the dead givens and outer needs-              -- See Note [Tracking redundant constraints]- = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)--      ; implic@(Implic { ic_need_inner = need_inner-                       , ic_need_outer = need_outer }) <- neededEvVars implic--      ; bad_telescope <- checkBadTelescope implic--      ; let dead_givens | warnRedundantGivens info-                        = filterOut (`elemVarSet` need_inner) givens-                        | otherwise = []   -- None to report--            discard_entire_implication  -- Can we discard the entire implication?-              =  null dead_givens           -- No warning from this implication-              && not bad_telescope-              && isEmptyWC pruned_wc        -- No live children-              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent--            final_status-              | bad_telescope = IC_BadTelescope-              | otherwise     = IC_Solved { ics_dead = dead_givens }-            final_implic = implic { ic_status = final_status-                                  , ic_wanted = pruned_wc }--      ; traceTcS "setImplicationStatus(all-solved) }" $-        vcat [ text "discard:" <+> ppr discard_entire_implication-             , text "new_implic:" <+> ppr final_implic ]--      ; return $ if discard_entire_implication-                 then Nothing-                 else Just final_implic }- where-   WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc--   pruned_simples = dropDerivedSimples simples-   pruned_implics = filterBag keep_me implics-   pruned_wc = WC { wc_simple = pruned_simples-                  , wc_impl   = pruned_implics-                  , wc_holes  = holes }   -- do not prune holes; these should be reported--   keep_me :: Implication -> Bool-   keep_me ic-     | IC_Solved { ics_dead = dead_givens } <- ic_status ic-                          -- Fully solved-     , null dead_givens   -- No redundant givens to report-     , isEmptyBag (wc_impl (ic_wanted ic))-           -- And no children that might have things to report-     = False       -- Tnen we don't need to keep it-     | otherwise-     = True        -- Otherwise, keep it--checkBadTelescope :: Implication -> TcS Bool--- True <=> the skolems form a bad telescope--- See Note [Checking telescopes] in GHC.Tc.Types.Constraint-checkBadTelescope (Implic { ic_info  = info-                          , ic_skols = skols })-  | ForAllSkol {} <- info-  = do{ skols <- mapM TcS.zonkTyCoVarKind skols-      ; return (go emptyVarSet (reverse skols))}--  | otherwise-  = return False--  where-    go :: TyVarSet   -- skolems that appear *later* than the current ones-       -> [TcTyVar]  -- ordered skolems, in reverse order-       -> Bool       -- True <=> there is an out-of-order skolem-    go _ [] = False-    go later_skols (one_skol : earlier_skols)-      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols-      = True-      | otherwise-      = go (later_skols `extendVarSet` one_skol) earlier_skols--warnRedundantGivens :: SkolemInfo -> Bool-warnRedundantGivens (SigSkol ctxt _ _)-  = case ctxt of-       FunSigCtxt _ warn_redundant -> warn_redundant-       ExprSigCtxt                 -> True-       _                           -> False--  -- To think about: do we want to report redundant givens for-  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.-warnRedundantGivens (InstSkol {}) = True-warnRedundantGivens _             = False--neededEvVars :: Implication -> TcS Implication--- Find all the evidence variables that are "needed",--- and delete dead evidence bindings---   See Note [Tracking redundant constraints]---   See Note [Delete dead Given evidence bindings]------   - Start from initial_seeds (from nested implications)------   - Add free vars of RHS of all Wanted evidence bindings---     and coercion variables accumulated in tcvs (all Wanted)------   - Generate 'needed', the needed set of EvVars, by doing transitive---     closure through Given bindings---     e.g.   Needed {a,b}---            Given  a = sc_sel a2---            Then a2 is needed too------   - Prune out all Given bindings that are not needed------   - From the 'needed' set, delete ev_bndrs, the binders of the---     evidence bindings, to give the final needed variables----neededEvVars implic@(Implic { ic_given = givens-                            , ic_binds = ev_binds_var-                            , ic_wanted = WC { wc_impl = implics }-                            , ic_need_inner = old_needs })- = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var-      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var--      ; let seeds1        = foldr add_implic_seeds old_needs implics-            seeds2        = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds-                            -- It's OK to use a non-deterministic fold here-                            -- because add_wanted is commutative-            seeds3        = seeds2 `unionVarSet` tcvs-            need_inner    = findNeededEvVars ev_binds seeds3-            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds-            need_outer    = varSetMinusEvBindMap need_inner live_ev_binds-                            `delVarSetList` givens--      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds-           -- See Note [Delete dead Given evidence bindings]--      ; traceTcS "neededEvVars" $-        vcat [ text "old_needs:" <+> ppr old_needs-             , text "seeds3:" <+> ppr seeds3-             , text "tcvs:" <+> ppr tcvs-             , text "ev_binds:" <+> ppr ev_binds-             , text "live_ev_binds:" <+> ppr live_ev_binds ]--      ; return (implic { ic_need_inner = need_inner-                       , ic_need_outer = need_outer }) }- where-   add_implic_seeds (Implic { ic_need_outer = needs }) acc-      = needs `unionVarSet` acc--   needed_ev_bind needed (EvBind { eb_lhs = ev_var-                                 , eb_is_given = is_given })-     | is_given  = ev_var `elemVarSet` needed-     | otherwise = True   -- Keep all wanted bindings--   add_wanted :: EvBind -> VarSet -> VarSet-   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs-     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only-     | otherwise = evVarsOfTerm rhs `unionVarSet` needs----------------------------------------------------simplifyHoles :: Bag Hole -> TcS (Bag Hole)-simplifyHoles = mapBagM simpl_hole-  where-    simpl_hole :: Hole -> TcS Hole-    simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc })-      = do { ty' <- flattenType loc ty-           ; return (h { hole_ty = ty' }) }--{- Note [Delete dead Given evidence bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As a result of superclass expansion, we speculatively-generate evidence bindings for Givens. E.g.-   f :: (a ~ b) => a -> b -> Bool-   f x y = ...-We'll have-   [G] d1 :: (a~b)-and we'll speculatively generate the evidence binding-   [G] d2 :: (a ~# b) = sc_sel d--Now d2 is available for solving.  But it may not be needed!  Usually-such dead superclass selections will eventually be dropped as dead-code, but:-- * It won't always be dropped (#13032).  In the case of an-   unlifted-equality superclass like d2 above, we generate-       case heq_sc d1 of d2 -> ...-   and we can't (in general) drop that case expression in case-   d1 is bottom.  So it's technically unsound to have added it-   in the first place.-- * Simply generating all those extra superclasses can generate lots of-   code that has to be zonked, only to be discarded later.  Better not-   to generate it in the first place.--   Moreover, if we simplify this implication more than once-   (e.g. because we can't solve it completely on the first iteration-   of simpl_looop), we'll generate all the same bindings AGAIN!--Easy solution: take advantage of the work we are doing to track dead-(unused) Givens, and use it to prune the Given bindings too.  This is-all done by neededEvVars.--This led to a remarkable 25% overall compiler allocation decrease in-test T12227.--But we don't get to discard all redundant equality superclasses, alas;-see #15205.--Note [Tracking redundant constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-With Opt_WarnRedundantConstraints, GHC can report which-constraints of a type signature (or instance declaration) are-redundant, and can be omitted.  Here is an overview of how it-works:------- What is a redundant constraint?--* The things that can be redundant are precisely the Given-  constraints of an implication.--* A constraint can be redundant in two different ways:-  a) It is implied by other givens.  E.g.-       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary-       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary-  b) It is not needed by the Wanted constraints covered by the-     implication E.g.-       f :: Eq a => a -> Bool-       f x = True  -- Equality not used--*  To find (a), when we have two Given constraints,-   we must be careful to drop the one that is a naked variable (if poss).-   So if we have-       f :: (Eq a, Ord a) => blah-   then we may find [G] sc_sel (d1::Ord a) :: Eq a-                    [G] d2 :: Eq a-   We want to discard d2 in favour of the superclass selection from-   the Ord dictionary.  This is done by GHC.Tc.Solver.Interact.solveOneFromTheOther-   See Note [Replacement vs keeping].--* To find (b) we need to know which evidence bindings are 'wanted';-  hence the eb_is_given field on an EvBind.------- How tracking works--* The ic_need fields of an Implic records in-scope (given) evidence-  variables bound by the context, that were needed to solve this-  implication (so far).  See the declaration of Implication.--* When the constraint solver finishes solving all the wanteds in-  an implication, it sets its status to IC_Solved--  - The ics_dead field, of IC_Solved, records the subset of this-    implication's ic_given that are redundant (not needed).--* We compute which evidence variables are needed by an implication-  in setImplicationStatus.  A variable is needed if-    a) it is free in the RHS of a Wanted EvBind,-    b) it is free in the RHS of an EvBind whose LHS is needed,-    c) it is in the ics_need of a nested implication.--* We need to be careful not to discard an implication-  prematurely, even one that is fully solved, because we might-  thereby forget which variables it needs, and hence wrongly-  report a constraint as redundant.  But we can discard it once-  its free vars have been incorporated into its parent; or if it-  simply has no free vars. This careful discarding is also-  handled in setImplicationStatus.------- Reporting redundant constraints--* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints.--* We don't report redundant givens for *every* implication; only-  for those which reply True to GHC.Tc.Solver.warnRedundantGivens:--   - For example, in a class declaration, the default method *can*-     use the class constraint, but it certainly doesn't *have* to,-     and we don't want to report an error there.--   - More subtly, in a function definition-       f :: (Ord a, Ord a, Ix a) => a -> a-       f x = rhs-     we do an ambiguity check on the type (which would find that one-     of the Ord a constraints was redundant), and then we check that-     the definition has that type (which might find that both are-     redundant).  We don't want to report the same error twice, so we-     disable it for the ambiguity check.  Hence using two different-     FunSigCtxts, one with the warn-redundant field set True, and the-     other set False in-        - GHC.Tc.Gen.Bind.tcSpecPrag-        - GHC.Tc.Gen.Bind.tcTySig--  This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors-  so that we can discard implication constraints that we don't need.-  So ics_dead consists only of the *reportable* redundant givens.------- Shortcomings--Consider (see #9939)-    f2 :: (Eq a, Ord a) => a -> a -> Bool-    -- Ord a redundant, but Eq a is reported-    f2 x y = (x == y)--We report (Eq a) as redundant, whereas actually (Ord a) is.  But it's-really not easy to detect that!---Note [Cutting off simpl_loop]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It is very important not to iterate in simpl_loop unless there is a chance-of progress.  #8474 is a classic example:--  * There's a deeply-nested chain of implication constraints.-       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int--  * From the innermost one we get a [D] alpha ~ Int,-    but alpha is untouchable until we get out to the outermost one--  * We float [D] alpha~Int out (it is in floated_eqs), but since alpha-    is untouchable, the solveInteract in simpl_loop makes no progress--  * So there is no point in attempting to re-solve-       ?yn:betan => [W] ?x:Int-    via solveNestedImplications, because we'll just get the-    same [D] again--  * If we *do* re-solve, we'll get an infinite loop. It is cut off by-    the fixed bound of 10, but solving the next takes 10*10*...*10 (ie-    exponentially many) iterations!--Conclusion: we should call solveNestedImplications only if we did-some unification in solveSimpleWanteds; because that's the only way-we'll get more Givens (a unification is like adding a Given) to-allow the implication to make progress.--}--promoteTyVarTcS :: TcTyVar  -> TcS ()--- 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--- See Note [Promoting unification variables]--- We don't just call promoteTyVar because we want to use unifyTyVar,--- not writeMetaTyVar-promoteTyVarTcS tv-  = do { tclvl <- TcS.getTcLevel-       ; when (isFloatedTouchableMetaTyVar tclvl tv) $-         do { cloned_tv <- TcS.cloneMetaTyVar tv-            ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl-            ; unifyTyVar tv (mkTyVarTy rhs_tv) } }---- | Like 'defaultTyVar', but in the TcS monad.-defaultTyVarTcS :: TcTyVar -> TcS Bool-defaultTyVarTcS the_tv-  | isRuntimeRepVar the_tv-  , not (isTyVarTyVar the_tv)-    -- TyVarTvs should only be unified with a tyvar-    -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar-    -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl-  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)-       ; unifyTyVar the_tv liftedRepTy-       ; return True }-  | isMultiplicityVar the_tv-  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar-                             -- never with a type; c.f. TcMType.defaultTyVar-                             -- See Note [Kind generalisation and SigTvs]-  = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)-       ; unifyTyVar the_tv manyDataConTy-       ; return True }-  | otherwise-  = return False  -- the common case--approximateWC :: Bool -> WantedConstraints -> Cts--- Postcondition: Wanted or Derived Cts--- See Note [ApproximateWC]-approximateWC float_past_equalities wc-  = float_wc emptyVarSet wc-  where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts-    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })-      = filterBag (is_floatable trapping_tvs) simples `unionBags`-        concatMapBag (float_implic trapping_tvs) implics-      where--    float_implic :: TcTyCoVarSet -> Implication -> Cts-    float_implic trapping_tvs imp-      | float_past_equalities || ic_no_eqs imp-      = float_wc new_trapping_tvs (ic_wanted imp)-      | otherwise   -- Take care with equalities-      = emptyCts    -- See (1) under Note [ApproximateWC]-      where-        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp--    is_floatable skol_tvs ct-       | isGivenCt ct     = False-       | insolubleEqCt ct = False-       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs--{- Note [ApproximateWC]-~~~~~~~~~~~~~~~~~~~~~~~-approximateWC takes a constraint, typically arising from the RHS of a-let-binding whose type we are *inferring*, and extracts from it some-*simple* constraints that we might plausibly abstract over.  Of course-the top-level simple constraints are plausible, but we also float constraints-out from inside, if they are not captured by skolems.--The same function is used when doing type-class defaulting (see the call-to applyDefaultingRules) to extract constraints that might be defaulted.--There is one caveat:--1.  When inferring most-general types (in simplifyInfer), we do *not*-    float anything out if the implication binds equality constraints,-    because that defeats the OutsideIn story.  Consider-       data T a where-         TInt :: T Int-         MkT :: T a--       f TInt = 3::Int--    We get the implication (a ~ Int => res ~ Int), where so far we've decided-      f :: T a -> res-    We don't want to float (res~Int) out because then we'll infer-      f :: T a -> Int-    which is only on of the possible types. (GHC 7.6 accidentally *did*-    float out of such implications, which meant it would happily infer-    non-principal types.)--   HOWEVER (#12797) in findDefaultableGroups we are not worried about-   the most-general type; and we /do/ want to float out of equalities.-   Hence the boolean flag to approximateWC.-------- Historical note ------------There used to be a second caveat, driven by #8155--   2. We do not float out an inner constraint that shares a type variable-      (transitively) with one that is trapped by a skolem.  Eg-          forall a.  F a ~ beta, Integral beta-      We don't want to float out (Integral beta).  Doing so would be bad-      when defaulting, because then we'll default beta:=Integer, and that-      makes the error message much worse; we'd get-          Can't solve  F a ~ Integer-      rather than-          Can't solve  Integral (F a)--      Moreover, floating out these "contaminated" constraints doesn't help-      when generalising either. If we generalise over (Integral b), we still-      can't solve the retained implication (forall a. F a ~ b).  Indeed,-      arguably that too would be a harder error to understand.--But this transitive closure stuff gives rise to a complex rule for-when defaulting actually happens, and one that was never documented.-Moreover (#12923), the more complex rule is sometimes NOT what-you want.  So I simply removed the extra code to implement the-contamination stuff.  There was zero effect on the testsuite (not even-#8155).------- End of historical note --------------Note [DefaultTyVar]-~~~~~~~~~~~~~~~~~~~-defaultTyVar is used on any un-instantiated meta type variables to-default any RuntimeRep variables to LiftedRep.  This is important-to ensure that instance declarations match.  For example consider--     instance Show (a->b)-     foo x = show (\_ -> True)--Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),-and that won't match the tcTypeKind (*) in the instance decl.  See tests-tc217 and tc175.--We look only at touchable type variables. No further constraints-are going to affect these type variables, so it's time to do it by-hand.  However we aren't ready to default them fully to () or-whatever, because the type-class defaulting rules have yet to run.--An alternate implementation would be to emit a derived constraint setting-the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.--Note [Promote _and_ default when inferring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are inferring a type, we simplify the constraint, and then use-approximateWC to produce a list of candidate constraints.  Then we MUST--  a) Promote any meta-tyvars that have been floated out by-     approximateWC, to restore invariant (WantedInv) described in-     Note [TcLevel and untouchable type variables] in GHC.Tc.Utils.TcType.--  b) Default the kind of any meta-tyvars that are not mentioned in-     in the environment.--To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we-have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it-should!  If we don't solve the constraint, we'll stupidly quantify over-(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over-(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.-#7641 is a simpler example.--Note [Promoting unification variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we float an equality out of an implication we must "promote" free-unification variables of the equality, in order to maintain Invariant-(WantedInv) from Note [TcLevel and untouchable type variables] in-TcType.  for the leftover implication.--This is absolutely necessary. Consider the following example. We start-with two implications and a class with a functional dependency.--    class C x y | x -> y-    instance C [a] [a]--    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]-    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]--We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.-They may react to yield that (beta := [alpha]) which can then be pushed inwards-the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that-(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable-beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:--    class C x y | x -> y where-     op :: x -> y -> ()--    instance C [a] [a]--    type family F a :: *--    h :: F Int -> ()-    h = undefined--    data TEx where-      TEx :: a -> TEx--    f (x::beta) =-        let g1 :: forall b. b -> ()-            g1 _ = h [x]-            g2 z = case z of TEx y -> (h [[undefined]], op x [y])-        in (g1 '3', g2 undefined)----*********************************************************************************-*                                                                               *-*                          Floating equalities                                  *-*                                                                               *-*********************************************************************************--Note [Float Equalities out of Implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For ordinary pattern matches (including existentials) we float-equalities out of implications, for instance:-     data T where-       MkT :: Eq a => a -> T-     f x y = case x of MkT _ -> (y::Int)-We get the implication constraint (x::T) (y::alpha):-     forall a. [untouchable=alpha] Eq a => alpha ~ Int-We want to float out the equality into a scope where alpha is no-longer untouchable, to solve the implication!--But we cannot float equalities out of implications whose givens may-yield or contain equalities:--      data T a where-        T1 :: T Int-        T2 :: T Bool-        T3 :: T a--      h :: T a -> a -> Int--      f x y = case x of-                T1 -> y::Int-                T2 -> y::Bool-                T3 -> h x y--We generate constraint, for (x::T alpha) and (y :: beta):-   [untouchables = beta] (alpha ~ Int => beta ~ Int)   -- From 1st branch-   [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch-   (alpha ~ beta)                                      -- From 3rd branch--If we float the equality (beta ~ Int) outside of the first implication and-the equality (beta ~ Bool) out of the second we get an insoluble constraint.-But if we just leave them inside the implications, we unify alpha := beta and-solve everything.--Principle:-    We do not want to float equalities out which may-    need the given *evidence* to become soluble.--Consequence: classes with functional dependencies don't matter (since there is-no evidence for a fundep equality), but equality superclasses do matter (since-they carry evidence).--}--floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool-                -> WantedConstraints-                -> TcS (Cts, WantedConstraints)--- Main idea: see Note [Float Equalities out of Implications]------ Precondition: the wc_simple of the incoming WantedConstraints are---               fully zonked, so that we can see their free variables------ Postcondition: The returned floated constraints (Cts) are only---                Wanted or Derived------ Also performs some unifications (via promoteTyVar), adding to--- monadically-carried ty_binds. These will be used when processing--- floated_eqs later------ Subtleties: Note [Float equalities from under a skolem binding]---             Note [Skolem escape]---             Note [What prevents a constraint from floating]-floatEqualities skols given_ids ev_binds_var no_given_eqs-                wanteds@(WC { wc_simple = simples })-  | not no_given_eqs  -- There are some given equalities, so don't float-  = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]--  | otherwise-  = do { -- First zonk: the inert set (from whence they came) is fully-         -- zonked, but unflattening may have filled in unification-         -- variables, and we /must/ see them.  Otherwise we may float-         -- constraints that mention the skolems!-         simples <- TcS.zonkSimples simples-       ; binds   <- TcS.getTcEvBindsMap ev_binds_var--       -- Now we can pick the ones to float-       -- The constraints are un-flattened and de-canonicalised-       ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples--             seed_skols = mkVarSet skols     `unionVarSet`-                          mkVarSet given_ids `unionVarSet`-                          foldr add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`-                          evBindMapToVarSet binds-             -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)-             -- Include the EvIds of any non-floating constraints--             extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols-                 -- extended_skols contains the EvIds of all the trapped constraints-                 -- See Note [What prevents a constraint from floating] (3)--             (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols)-                                                  candidate_eqs--             remaining_simples = no_float_cts `andCts` no_flt_eqs--       -- Promote any unification variables mentioned in the floated equalities-       -- See Note [Promoting unification variables]-       ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs)--       ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols-                                          , text "Extended skols =" <+> ppr extended_skols-                                          , text "Simples =" <+> ppr simples-                                          , text "Candidate eqs =" <+> ppr candidate_eqs-                                          , text "Floated eqs =" <+> ppr flt_eqs])-       ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }--  where-    add_non_flt_ct :: Ct -> VarSet -> VarSet-    add_non_flt_ct ct acc | isDerivedCt ct = acc-                          | otherwise      = extendVarSet acc (ctEvId ct)--    is_floatable :: VarSet -> Ct -> Bool-    is_floatable skols ct-      | isDerivedCt ct = tyCoVarsOfCt ct `disjointVarSet` skols-      | otherwise      = not (ctEvId ct `elemVarSet` skols)--    add_captured_ev_ids :: Cts -> VarSet -> VarSet-    add_captured_ev_ids cts skols = foldr extra_skol emptyVarSet cts-       where-         extra_skol ct acc-           | isDerivedCt ct                           = acc-           | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct)-           | otherwise                                = acc--    -- Identify which equalities are candidates for floating-    -- Float out alpha ~ ty which might be unified outside-    -- See Note [Which equalities to float]-    is_float_eq_candidate ct-      | pred <- ctPred ct-      , EqPred NomEq ty1 ty2 <- classifyPredType pred-      , case ct of-           CIrredCan {} -> False   -- See Note [Do not float blocked constraints]-           _            -> True    --   See #18855-      = float_eq ty1 ty2 || float_eq ty2 ty1-      | otherwise-      = False--    float_eq ty1 ty2-      = case getTyVar_maybe ty1 of-          Just tv1 -> isMetaTyVar tv1-                   && (not (isTyVarTyVar tv1) || isTyVarTy ty2)-          Nothing  -> False--{- Note [Do not float blocked constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As #18855 showed, we must not float an equality that is blocked.-Consider-     forall a[4]. [W] co1: alpha[4] ~ Maybe (a[4] |> bco)-                  [W] co2: alpha[4] ~ Maybe (beta[4] |> bco])-                  [W] bco: kappa[2] ~ Type--Now co1, co2 are blocked by bco.  We will eventually float out bco-and solve it at level 2.  But the danger is that we will *also*-float out co2, and that is bad bad bad.  Because we'll promote alpha-and beta to level 2, and then fail to unify the promoted beta-with the skolem a[4].--Solution: don't float out blocked equalities. Remember: we only want-to float out if we can solve; see Note [Which equalities to float].--(Future plan: kill floating altogether.)--Note [Float equalities from under a skolem binding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Which of the simple equalities can we float out?  Obviously, only-ones that don't mention the skolem-bound variables.  But that is-over-eager. Consider-   [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int-The second constraint doesn't mention 'a'.  But if we float it,-we'll promote gamma[2] to gamma'[1].  Now suppose that we learn that-beta := Bool, and F a Bool = a, and G Bool _ = Int.  Then we'll-we left with the constraint-   [2] forall a. a ~ gamma'[1]-which is insoluble because gamma became untouchable.--Solution: float only constraints that stand a jolly good chance of-being soluble simply by being floated, namely ones of form-      a ~ ty-where 'a' is a currently-untouchable unification variable, but may-become touchable by being floated (perhaps by more than one level).--We had a very complicated rule previously, but this is nice and-simple.  (To see the notes, look at this Note in a version of-GHC.Tc.Solver prior to Oct 2014).--Note [Which equalities to float]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Which equalities should we float?  We want to float ones where there-is a decent chance that floating outwards will allow unification to-happen.  In particular, float out equalities that are:--* Of form (alpha ~# ty) or (ty ~# alpha), where-   * alpha is a meta-tyvar.-   * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar.  In that-     case, floating out won't help either, and it may affect grouping-     of error messages.--  NB: generally we won't see (ty ~ alpha), with alpha on the right because-  of Note [Unification variables on the left] in GHC.Tc.Utils.Unify.-  But if we start with (F tys ~ alpha), it will orient as (fmv ~ alpha),-  and unflatten back to (F tys ~ alpha). So we must look for alpha on-  the right too.  Example T4494.--* Nominal.  No point in floating (alpha ~R# ty), because we do not-  unify representational equalities even if alpha is touchable.-  See Note [Do not unify representational equalities] in GHC.Tc.Solver.Interact.--Note [Skolem escape]-~~~~~~~~~~~~~~~~~~~~-You might worry about skolem escape with all this floating.-For example, consider-    [2] forall a. (a ~ F beta[2] delta,-                   Maybe beta[2] ~ gamma[1])--The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and-solve with gamma := beta. But what if later delta:=Int, and-  F b Int = b.-Then we'd get a ~ beta[2], and solve to get beta:=a, and now the-skolem has escaped!--But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2]-to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.--Note [What prevents a constraint from floating]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What /prevents/ a constraint from floating?  If it mentions one of the-"bound variables of the implication".  What are they?--The "bound variables of the implication" are--  1. The skolem type variables `ic_skols`--  2. The "given" evidence variables `ic_given`.  Example:-         forall a. (co :: t1 ~# t2) =>  [W] co2 : (a ~# b |> co)-     Here 'co' is bound--  3. The binders of all evidence bindings in `ic_binds`. Example-         forall a. (d :: t1 ~ t2)-            EvBinds { (co :: t1 ~# t2) = superclass-sel d }-            => [W] co2 : (a ~# b |> co)-     Here `co` is gotten by superclass selection from `d`, and the-     wanted constraint co2 must not float.--  4. And the evidence variable of any equality constraint (incl-     Wanted ones) whose type mentions a bound variable.  Example:-        forall k. [W] co1 :: t1 ~# t2 |> co2-                  [W] co2 :: k ~# *-     Here, since `k` is bound, so is `co2` and hence so is `co1`.--Here (1,2,3) are handled by the "seed_skols" calculation, and-(4) is done by the transCloVarSet call.--The possible dependence on givens, and evidence bindings, is more-subtle than we'd realised at first.  See #14584.--How can (4) arise? Suppose we have (k :: *), (a :: k), and ([G} k ~ *).-Then form an equality like (a ~ Int) we might end up with-    [W] co1 :: k ~ *-    [W] co2 :: (a |> co1) ~ Int+       InferMode(..), simplifyInfer, findInferredDiff,+       growThetaTyVars,+       simplifyAmbiguityCheck,+       simplifyDefault,+       simplifyTop, simplifyTopImplic,+       simplifyInteractive,+       solveEqualities,+       pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX,+       reportUnsolvedEqualities,+       simplifyWantedsTcM,+       tcCheckGivens,+       tcCheckWanteds,+       tcNormalise,++       captureTopConstraints,++       simplifyTopWanteds,++       promoteTyVarSet, simplifyAndEmitFlatConstraints,++       -- For Rules we need these+       solveWanteds, solveWantedsAndDrop,+       approximateWC, runTcSDeriveds+  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Data.Bag+import GHC.Core.Class ( Class, classKey, classTyCon )+import GHC.Driver.Session+import GHC.Tc.Utils.Instantiate+import GHC.Data.List.SetOps+import GHC.Types.Name+import GHC.Types.Id( idType )+import GHC.Utils.Outputable+import GHC.Builtin.Utils+import GHC.Builtin.Names+import GHC.Tc.Errors+import GHC.Tc.Types.Evidence+import GHC.Tc.Solver.Interact+import GHC.Tc.Solver.Canonical   ( makeSuperClasses, solveCallStack )+import GHC.Tc.Solver.Rewrite     ( rewriteType )+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+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType+import GHC.Core.Type+import GHC.Builtin.Types ( liftedRepTy, manyDataConTy )+import GHC.Core.Unify    ( tcMatchTyKi )+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Basic    ( IntWithInf, intGtLimit )+import GHC.Types.Error+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable      ( toList )+import Data.List          ( partition )+import Data.List.NonEmpty ( NonEmpty(..) )++{-+*********************************************************************************+*                                                                               *+*                           External interface                                  *+*                                                                               *+*********************************************************************************+-}++captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureTopConstraints m) runs m, and returns the type constraints it+-- generates plus the constraints produced by static forms inside.+-- If it fails with an exception, it reports any insolubles+-- (out of scope variables) before doing so+--+-- captureTopConstraints is used exclusively by GHC.Tc.Module at the top+-- level of a module.+--+-- Importantly, if captureTopConstraints propagates an exception, it+-- reports any insoluble constraints first, lest they be lost+-- 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]+-- #16376 is an example of what goes wrong if you don't do this.+--+-- NB: the caller should bring any environments into scope before+-- calling this, so that the reportUnsolved has access to the most+-- complete GlobalRdrEnv+captureTopConstraints thing_inside+  = do { static_wc_var <- TcM.newTcRef emptyWC ;+       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $+                          TcM.tryCaptureConstraints thing_inside+       ; stWC <- TcM.readTcRef static_wc_var++       -- See GHC.Tc.Utils.Monad Note [Constraints and errors]+       -- If the thing_inside threw an exception, but generated some insoluble+       -- constraints, report the latter before propagating the exception+       -- Otherwise they will be lost altogether+       ; case mb_res of+           Just res -> return (res, lie `andWC` stWC)+           Nothing  -> do { _ <- simplifyTop lie; failM } }+                -- This call to simplifyTop is the reason+                -- this function is here instead of GHC.Tc.Utils.Monad+                -- We call simplifyTop so that it does defaulting+                -- (esp of runtime-reps) before reporting errors++simplifyTopImplic :: Bag Implication -> TcM ()+simplifyTopImplic implics+  = do { empty_binds <- simplifyTop (mkImplicWC implics)++       -- Since all the inputs are implications the returned bindings will be empty+       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )++       ; return () }++simplifyTop :: WantedConstraints -> TcM (Bag EvBind)+-- Simplify top-level constraints+-- Usually these will be implications,+-- but when there is nothing to quantify we don't wrap+-- in a degenerate implication, so we do that here instead+simplifyTop wanteds+  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds+       ; ((final_wc, unsafe_ol), binds1) <- runTcS $+            do { final_wc <- simplifyTopWanteds wanteds+               ; unsafe_ol <- getSafeOverlapFailures+               ; return (final_wc, unsafe_ol) }+       ; traceTc "End simplifyTop }" empty++       ; binds2 <- reportUnsolved final_wc++       ; traceTc "reportUnsolved (unsafe overlapping) {" empty+       ; unless (isEmptyCts unsafe_ol) $ do {+           -- grab current error messages and clear, warnAllUnsolved will+           -- update error messages which we'll grab and then restore saved+           -- messages.+           ; errs_var  <- getErrsVar+           ; saved_msg <- TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var emptyMessages++           ; warnAllUnsolved $ emptyWC { wc_simple = unsafe_ol }++           ; whyUnsafe <- getWarningMessages <$> TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var saved_msg+           ; recordUnsafeInfer whyUnsafe+           }+       ; traceTc "reportUnsolved (unsafe overlapping) }" empty++       ; 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.+-- 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+       ; simplifyAndEmitFlatConstraints wanted+            -- simplifyAndEmitFlatConstraints fails outright unless+            --  the only unsolved constraints are soluble-looking+            --  equalities that can float out+       ; traceTc "solveEqualities }" empty+       ; return res }++simplifyAndEmitFlatConstraints :: WantedConstraints -> TcM ()+-- See Note [Failure in local type signatures]+simplifyAndEmitFlatConstraints wanted+  = do { -- Solve and zonk to esablish the+         -- preconditions for floatKindEqualities+         wanted <- runTcSEqualities (solveWanteds wanted)+       ; wanted <- TcM.zonkWC wanted++       ; traceTc "emitFlatConstraints {" (ppr wanted)+       ; case floatKindEqualities wanted of+           Nothing -> do { traceTc "emitFlatConstraints } failing" (ppr wanted)+                         -- Emit the bad constraints, wrapped in an implication+                         -- See Note [Wrapping failing kind equalities]+                         ; tclvl  <- TcM.getTcLevel+                         ; implic <- buildTvImplication UnkSkol [] (pushTcLevel tclvl) wanted+                                    --                  ^^^^^^   |  ^^^^^^^^^^^^^^^^^+                                    -- it's OK to use UnkSkol    |  we must increase the TcLevel,+                                    -- because we don't bind     |  as explained in+                                    -- any skolem variables here |  Note [Wrapping failing kind equalities]+                         ; emitImplication implic+                         ; failM }+           Just (simples, holes)+              -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)+                    ; traceTc "emitFlatConstraints }" $+                      vcat [ text "simples:" <+> ppr simples+                           , text "holes:  " <+> ppr holes ]+                    ; emitHoles holes -- Holes don't need promotion+                    ; emitSimples simples } }++floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)+-- Float out all the constraints from the WantedConstraints,+-- Return Nothing if any constraints can't be floated (captured+-- by skolems), or if there is an insoluble constraint, or+-- IC_Telescope telescope error+-- Precondition 1: we have tried to solve the 'wanteds', both so that+--    the ic_status field is set, and because solving can make constraints+--    more floatable.+-- Precondition 2: the 'wanteds' are zonked, since floatKindEqualities+--    is not monadic+-- See Note [floatKindEqualities vs approximateWC]+floatKindEqualities wc = float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)+    float_wc trapping_tvs (WC { wc_simple = simples+                              , wc_impl = implics+                              , wc_holes = holes })+      | all is_floatable simples+      = do { (inner_simples, inner_holes)+                <- flatMapBagPairM (float_implic trapping_tvs) implics+           ; return ( simples `unionBags` inner_simples+                    , holes `unionBags` inner_holes) }+      | otherwise+      = Nothing+      where+        is_floatable ct+           | insolubleEqCt ct = False+           | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs++    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)+    float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs+                                      , ic_skols = skols, ic_status = status })+      | isInsolubleStatus status+      = Nothing   -- A short cut /plus/ we must keep track of IC_BadTelescope+      | otherwise+      = do { (simples, holes) <- float_wc new_trapping_tvs wanted+           ; when (not (isEmptyBag simples) && given_eqs == MaybeGivenEqs) $+             Nothing+                 -- If there are some constraints to float out, but we can't+                 -- because we don't float out past local equalities+                 -- (c.f GHC.Tc.Solver.approximateWC), then fail+           ; return (simples, holes) }+      where+        new_trapping_tvs = trapping_tvs `extendVarSetList` skols+++{- 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, 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 }++  bar :: forall (a :: Type) (b :: Type).+         C a b => Proxy a -> Proxy b -> ()+  bar _ _ = const () (undefined :: forall (x :: a) (y :: b). SameKind x y)++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+later.++Another possibility is that we might have something like+   F alpha ~ [Int]+where alpha is bound further out, which might become soluble+"later" when we learn more about alpha.  So we want to emit+those residual constraints.++BUT it's no good simply wrapping all unsolved constraints from+a type signature in an implication constraint to solve later. The+problem is that we are going to /use/ that signature, including+instantiate it.  Say we have+     f :: forall a.  (forall b. blah) -> blah2+     f x = <body>+To typecheck the definition of f, we have to instantiate those+foralls.  Moreover, any unsolved kind equalities will be coercion+holes in the type.  If we naively wrap them in an implication like+     forall a. (co1:k1~k2,  forall b.  co2:k3~k4)+hoping to solve it later, we might end up filling in the holes+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-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 (see tcHsSigType):++* pushLevelAndSolveEqualitiesX: try to solve the constraints++* kindGeneraliseSome: do kind generalisation++* buildTvImplication: build an implication for the residual, unsolved+  constraint++* simplifyAndEmitFlatConstraints: try to float out every unsolved equality+  inside that implication, in the hope that it constrains only global+  type variables, not the locally-quantified ones.++  * If we fail, or find an insoluble constraint, emit the implication,+    so that the errors will be reported, and fail.++  * If we succeed in floating all the equalities, promote them and+    re-emit them as flat constraint, not wrapped at all (since they+    don't mention any of the quantified variables.++* Note that this float-and-promote step means that anonymous+  wildcards get floated to top level, as we want; see+  Note [Checking partial type signatures] in GHC.Tc.Gen.HsType.++All this is done:++* In GHC.Tc.Gen.HsType.tcHsSigType, as above++* 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++Note [Wrapping failing kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In simplifyAndEmitFlatConstraints, if we fail to get down to simple+flat constraints we will+* re-emit the constraints so that they are reported+* fail in the monad+But there is a Terrible Danger that, if -fdefer-type-errors is on, and+we just re-emit an insoluble constraint like (* ~ (*->*)), that we'll+report only a warning and proceed with compilation.  But if we ever fail+in the monad it should be fatal; we should report an error and stop after+the type checker.  If not, chaos results: #19142.++Our solution is this:+* Even with -fdefer-type-errors, inside an implication with no place for+  value bindings (ic_binds = CoEvBindsVar), report failing equalities as+  errors.  We have to do this anyway; see GHC.Tc.Errors+  Note [Failing equalities with no evidence bindings].++* Right here in simplifyAndEmitFlatConstraints, use buildTvImplication+  to wrap the failing constraint in a degenerate implication (no+  skolems, no theta), with ic_binds = CoEvBindsVar.  This setting of+  `ic_binds` means that any failing equalities will lead to an+  error not a warning, irrespective of -fdefer-type-errors: see+  Note [Failing equalities with no evidence bindings] in GHC.Tc.Errors,+  and `maybeSwitchOffDefer` in that module.++  We still take care to bump the TcLevel of the implication.  Partly,+  that ensures that nested implications have increasing level numbers+  which seems nice.  But more specifically, suppose the outer level+  has a Given `(C ty)`, which has pending (not-yet-expanded)+  superclasses. Consider what happens when we process this implication+  constraint (which we have re-emitted) in that context:+    - in the inner implication we'll call `getPendingGivenScs`,+    - we /do not/ want to get the `(C ty)` from the outer level,+    lest we try to add an evidence term for the superclass,+    which we can't do because we have specifically set+    `ic_binds` = `CoEvBindsVar`.+    - as `getPendingGivenSCcs is careful to only get Givens from+    the /current/ level, and we bumped the `TcLevel` of the implication,+    we're OK.++  TL;DR: bump the `TcLevel` when creating the nested implication.+  If we don't we get a panic in `GHC.Tc.Utils.Monad.addTcEvBind` (#20043).+++We re-emit the implication rather than reporting the errors right now,+so that the error mesages are improved by other solving and defaulting.+e.g. we prefer+    Cannot match 'Type->Type' with 'Type'+to  Cannot match 'Type->Type' with 'TYPE r0'+++Note [floatKindEqualities vs approximateWC]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+floatKindEqualities and approximateWC are strikingly similar to each+other, but++* floatKindEqualites tries to float /all/ equalities, and fails if+  it can't, or if any implication is insoluble.+* approximateWC just floats out any constraints+  (not just equalities) that can float; it never fails.+-}+++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)) }+++-- | Simplify top-level constraints, but without reporting any unsolved+-- constraints nor unsafe overlapping.+simplifyTopWanteds :: WantedConstraints -> TcS WantedConstraints+    -- See Note [Top-level Defaulting Plan]+simplifyTopWanteds wanteds+  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)+                            -- This is where the main work happens+       ; dflags <- getDynFlags+       ; try_tyvar_defaulting dflags wc_first_go }+  where+    try_tyvar_defaulting :: DynFlags -> WantedConstraints -> TcS WantedConstraints+    try_tyvar_defaulting dflags wc+      | isEmptyWC wc+      = return wc+      | insolubleWC wc+      , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]+      = try_class_defaulting wc+      | otherwise+      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs+                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked+                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,+                   -- and we definitely don't want to try to assign to those!+                   -- The isTyVar is needed to weed out coercion variables++           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects+           ; if or defaulted+             then do { wc_residual <- nestTcS (solveWanteds wc)+                            -- See Note [Must simplify after defaulting]+                     ; try_class_defaulting wc_residual }+             else try_class_defaulting wc }     -- No defaulting took place++    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_class_defaulting wc+      | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]+      = return wc+      | otherwise  -- See Note [When to do type-class defaulting]+      = do { something_happened <- applyDefaultingRules wc+                                   -- See Note [Top-level Defaulting Plan]+           ; if something_happened+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)+                     ; try_class_defaulting wc_residual }+                  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+             else try_callstack_defaulting wc }++    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_callstack_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise+      = defaultCallStacks wc++-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.+defaultCallStacks :: WantedConstraints -> TcS WantedConstraints+-- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+defaultCallStacks wanteds+  = do simples <- handle_simples (wc_simple wanteds)+       mb_implics <- mapBagM handle_implic (wc_impl wanteds)+       return (wanteds { wc_simple = simples+                       , wc_impl = catBagMaybes mb_implics })++  where++  handle_simples simples+    = catBagMaybes <$> mapBagM defaultCallStack simples++  handle_implic :: Implication -> TcS (Maybe Implication)+  -- The Maybe is because solving the CallStack constraint+  -- may well allow us to discard the implication entirely+  handle_implic implic+    | isSolvedStatus (ic_status implic)+    = return (Just implic)+    | otherwise+    = do { wanteds <- setEvBindsTcS (ic_binds implic) $+                      -- defaultCallStack sets a binding, so+                      -- we must set the correct binding group+                      defaultCallStacks (ic_wanted implic)+         ; setImplicationStatus (implic { ic_wanted = wanteds }) }++  defaultCallStack ct+    | ClassPred cls tys <- classifyPredType (ctPred ct)+    , Just {} <- isCallStackPred cls tys+    = do { solveCallStack (ctEvidence ct) EvCsEmpty+         ; return Nothing }++  defaultCallStack ct+    = return (Just ct)+++{- 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+lot of errors that would be solved by defaulting; these errors are+quite spurious because fixing the single insoluble error means that+defaulting happens again, which makes all the other errors go away.+This is jolly confusing: #9033.++So it seems better to always do type-class defaulting.++However, always doing defaulting does mean that we'll do it in+situations like this (#5934):+   run :: (forall s. GenST s) -> Int+   run = fromInteger 0+We don't unify the return type of fromInteger with the given function+type, because the latter involves foralls.  So we're left with+    (Num alpha, alpha ~ (forall s. GenST s) -> Int)+Now we do defaulting, get alpha := Integer, and report that we can't+match Integer with (forall s. GenST s) -> Int.  That's not totally+stupid, but perhaps a little strange.++Another potential alternative would be to suppress *all* non-insoluble+errors if there are *any* insoluble errors, anywhere, but that seems+too drastic.++Note [Must simplify after defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a deeply buried constraint+    (t:*) ~ (a:Open)+which we couldn't solve because of the kind incompatibility, and 'a' is free.+Then when we default 'a' we can solve the constraint.  And we want to do+that before starting in on type classes.  We MUST do it before reporting+errors, because it isn't an error!  #7967 was due to this.++Note [Top-level Defaulting Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have considered two design choices for where/when to apply defaulting.+   (i) Do it in SimplCheck mode only /whenever/ you try to solve some+       simple constraints, maybe deep inside the context of implications.+       This used to be the case in GHC 7.4.1.+   (ii) Do it in a tight loop at simplifyTop, once all other constraints have+        finished. This is the current story.++Option (i) had many disadvantages:+   a) Firstly, it was deep inside the actual solver.+   b) Secondly, it was dependent on the context (Infer a type signature,+      or Check a type signature, or Interactive) since we did not want+      to always start defaulting when inferring (though there is an exception to+      this, see Note [Default while Inferring]).+   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:+          f :: Int -> Bool+          f x = const True (\y -> let w :: a -> a+                                      w a = const a (y+1)+                                  in w y)+      We will get an implication constraint (for beta the type of y):+               [untch=beta] forall a. 0 => Num beta+      which we really cannot default /while solving/ the implication, since beta is+      untouchable.++Instead our new defaulting story is to pull defaulting out of the solver loop and+go with option (ii), implemented at SimplifyTop. Namely:+     - First, have a go at solving the residual constraint of the whole+       program+     - Try to approximate it with a simple constraint+     - Figure out derived defaulting equations for that simple constraint+     - Go round the loop again if you did manage to get some equations++Now, that has to do with class defaulting. However there exists type variable /kind/+defaulting. Again this is done at the top-level and the plan is:+     - At the top-level, once you had a go at solving the constraint, do+       figure out /all/ the touchable unification variables of the wanted constraints.+     - Apply defaulting to their kinds++More details in Note [DefaultTyVar].++Note [Safe Haskell Overlapping Instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Safe Haskell, we apply an extra restriction to overlapping instances. The+motive is to prevent untrusted code provided by a third-party, changing the+behavior of trusted code through type-classes. This is due to the global and+implicit nature of type-classes that can hide the source of the dictionary.++Another way to state this is: if a module M compiles without importing another+module N, changing M to import N shouldn't change the behavior of M.++Overlapping instances with type-classes can violate this principle. However,+overlapping instances aren't always unsafe. They are just unsafe when the most+selected dictionary comes from untrusted code (code compiled with -XSafe) and+overlaps instances provided by other modules.++In particular, in Safe Haskell at a call site with overlapping instances, we+apply the following rule to determine if it is a 'unsafe' overlap:++ 1) Most specific instance, I1, defined in an `-XSafe` compiled module.+ 2) I1 is an orphan instance or a MPTC.+ 3) At least one overlapped instance, Ix, is both:+    A) from a different module than I1+    B) Ix is not marked `OVERLAPPABLE`++This is a slightly involved heuristic, but captures the situation of an+imported module N changing the behavior of existing code. For example, if+condition (2) isn't violated, then the module author M must depend either on a+type-class or type defined in N.++Secondly, when should these heuristics be enforced? We enforced them when the+type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.+This allows `-XUnsafe` modules to operate without restriction, and for Safe+Haskell inferrence to infer modules with unsafe overlaps as unsafe.++One alternative design would be to also consider if an instance was imported as+a `safe` import or not and only apply the restriction to instances imported+safely. However, since instances are global and can be imported through more+than one path, this alternative doesn't work.++Note [Safe Haskell Overlapping Instances Implementation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++How is this implemented? It's complicated! So we'll step through it all:++ 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where+    we check if a particular type-class method call is safe or unsafe. We do this+    through the return type, `ClsInstLookupResult`, where the last parameter is a+    list of instances that are unsafe to overlap. When the method call is safe,+    the list is null.++ 2) `GHC.Tc.Solver.Interact.matchClassInst` -- This module drives the instance resolution+    / dictionary generation. The return type is `ClsInstResult`, which either+    says no instance matched, or one found, and if it was a safe or unsafe+    overlap.++ 3) `GHC.Tc.Solver.Interact.doTopReactDict` -- Takes a dictionary / class constraint and+     tries to resolve it by calling (in part) `matchClassInst`. The resolving+     mechanism has a work list (of constraints) that it process one at a time. If+     the constraint can't be resolved, it's added to an inert set. When compiling+     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know+     compilation should fail. These are handled as normal constraint resolution+     failures from here-on (see step 6).++     Otherwise, we may be inferring safety (or using `-Wunsafe`), and+     compilation should succeed, but print warnings and/or mark the compiled module+     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds+     the unsafe (but resolved!) constraint to the `inert_safehask` field of+     `InertCans`.++ 4) `GHC.Tc.Solver.simplifyTop`:+       * Call simplifyTopWanteds, the top-level function for driving the simplifier for+         constraint resolution.++       * Once finished, call `getSafeOverlapFailures` to retrieve the+         list of overlapping instances that were successfully resolved,+         but unsafe. Remember, this is only applicable for generating warnings+         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`+         cause compilation failure by not resolving the unsafe constraint at all.++       * For unresolved constraints (all types), call `GHC.Tc.Errors.reportUnsolved`,+         while for resolved but unsafe overlapping dictionary constraints, call+         `GHC.Tc.Errors.warnAllUnsolved`. Both functions convert constraints into a+         warning message for the user.++       * In the case of `warnAllUnsolved` for resolved, but unsafe+         dictionary constraints, we collect the generated warning+         message (pop it) and call `GHC.Tc.Utils.Monad.recordUnsafeInfer` to+         mark the module we are compiling as unsafe, passing the+         warning message along as the reason.++ 5) `GHC.Tc.Errors.*Unsolved` -- Generates error messages for constraints by+    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we+    know is the constraint that is unresolved or unsafe. For dictionary, all we+    know is that we need a dictionary of type C, but not what instances are+    available and how they overlap. So we once again call `lookupInstEnv` to+    figure that out so we can generate a helpful error message.++ 6) `GHC.Tc.Utils.Monad.recordUnsafeInfer` -- Save the unsafe result and reason in an+      IORef called `tcg_safeInfer`.++ 7) `GHC.Driver.Main.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling+    `GHC.Driver.Main.markUnsafeInfer` (passing the reason along) when safe-inferrence+    failed.++Note [No defaulting in the ambiguity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying constraints for the ambiguity check, we use+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+(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting+warning, but no error.++Note [Defaulting insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a set of wanteds is insoluble, we have no hope of accepting the+program. Yet we do not stop constraint solving, etc., because we may+simplify the wanteds to produce better error messages. So, once+we have an insoluble constraint, everything we do is just about producing+helpful error messages.++Should we default in this case or not? Let's look at an example (tcfail004):++  (f,g) = (1,2,3)++With defaulting, we get a conflict between (a0,b0) and (Integer,Integer,Integer).+Without defaulting, we get a conflict between (a0,b0) and (a1,b1,c1). I (Richard)+find the latter more helpful. Several other test cases (e.g. tcfail005) suggest+similarly. So: we should not do class defaulting with insolubles.++On the other hand, RuntimeRep-defaulting is different. Witness tcfail078:++  f :: Integer i => i+  f =               0++Without RuntimeRep-defaulting, we GHC suggests that Integer should have kind+TYPE r0 -> Constraint and then complains that r0 is actually untouchable+(presumably, because it can't be sure if `Integer i` entails an equality).+If we default, we are told of a clash between (* -> Constraint) and Constraint.+The latter seems far better, suggesting we *should* do RuntimeRep-defaulting+even on insolubles.++But, evidently, not always. Witness UnliftedNewtypesInfinite:++  newtype Foo = FooC (# Int#, Foo #)++This should fail with an occurs-check error on the kind of Foo (with -XUnliftedNewtypes).+If we default RuntimeRep-vars, we get++  Expecting a lifted type, but ‘(# Int#, Foo #)’ is unlifted++which is just plain wrong.++Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not+want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps+is not set.+-}++------------------+simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()+simplifyAmbiguityCheck ty wanteds+  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)+       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds+             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]++       ; traceTc "End simplifyAmbiguityCheck }" empty++       -- Normally report all errors; but with -XAllowAmbiguousTypes+       -- report only insoluble ones, since they represent genuinely+       -- inaccessible code+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes+       ; traceTc "reportUnsolved(ambig) {" empty+       ; unless (allow_ambiguous && not (insolubleWC final_wc))+                (discardResult (reportUnsolved final_wc))+       ; traceTc "reportUnsolved(ambig) }" empty++       ; return () }++------------------+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)+simplifyInteractive wanteds+  = traceTc "simplifyInteractive" empty >>+    simplifyTop wanteds++------------------+simplifyDefault :: ThetaType    -- Wanted; has no type variables in it+                -> TcM Bool     -- Return if the constraint is soluble+simplifyDefault theta+  = do { traceTc "simplifyDefault" empty+       ; wanteds  <- newWanteds DefaultOrigin theta+       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))+       ; return (isEmptyWC unsolved) }++------------------+tcCheckGivens :: InertSet -> Bag EvVar -> TcM (Maybe InertSet)+-- ^ Return (Just new_inerts) if the Givens are satisfiable, Nothing if definitely+-- contradictory+tcCheckGivens inerts given_ids = do+  (sat, new_inerts) <- runTcSInerts inerts $ do+    traceTcS "checkGivens {" (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 "checkGivens }" (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.+    -- At the moment we try just once+    try_harder insols+      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable+      = return insols             -- Hurrah -- stop now.+      | otherwise+      = do { pending_given <- getPendingGivenScs+           ; new_given <- makeSuperClasses pending_given+           ; solveSimpleGivens new_given+           ; getInertInsols }++tcCheckWanteds :: InertSet -> ThetaType -> TcM Bool+-- ^ Return True if the Wanteds are soluble, False if not+tcCheckWanteds inerts wanteds = do+  cts <- newWanteds PatCheckOrigin wanteds+  (sat, _new_inerts) <- runTcSInerts inerts $ do+    traceTcS "checkWanteds {" (ppr inerts <+> ppr wanteds)+    -- See Note [Superclasses and satisfiability]+    wcs <- solveWantedsAndDrop (mkSimpleWC cts)+    traceTcS "checkWanteds }" (ppr wcs)+    return (isSolvedWC wcs)+  return sat++-- | Normalise a type as much as possible using the given constraints.+-- See @Note [tcNormalise]@.+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' <- rewriteType norm_loc ty+                ; traceTcS "tcNormalise }" (ppr ty')+                ; pure ty' }+       ; return res }++{- Note [Superclasses and satisfiability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expand superclasses before starting, because (Int ~ Bool), has+(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)+as a superclass, and it's the latter that is insoluble.  See+Note [The equality types story] in GHC.Builtin.Types.Prim.++If we fail to prove unsatisfiability we (arbitrarily) try just once to+find superclasses, using try_harder.  Reason: we might have a type+signature+   f :: F op (Implements push) => ..+where F is a type function.  This happened in #3972.++We could do more than once but we'd have to have /some/ limit: in the+the recursive case, we would go on forever in the common case where+the constraints /are/ satisfiable (#10592 comment:12!).++For stratightforard situations without type functions the try_harder+step does nothing.++Note [tcNormalise]+~~~~~~~~~~~~~~~~~~+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 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.Pmc".++To accomplish its stated goal, tcNormalise first initialises the solver monad+with the given InertCans, then uses rewriteType to simplify the desired type+with respect to the Givens in the InertCans.++***********************************************************************************+*                                                                                 *+*                            Inference+*                                                                                 *+***********************************************************************************++Note [Inferring the type of a let-bound variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = rhs++To infer f's type we do the following:+ * Gather the constraints for the RHS with ambient level *one more than*+   the current one.  This is done by the call+        pushLevelAndCaptureConstraints (tcMonoBinds...)+   in GHC.Tc.Gen.Bind.tcPolyInfer++ * Call simplifyInfer to simplify the constraints and decide what to+   quantify over. We pass in the level used for the RHS constraints,+   here called rhs_tclvl.++This ensures that the implication constraint we generate, if any,+has a strictly-increased level compared to the ambient level outside+the let binding.++-}++-- | How should we choose which constraints to quantify over?+data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,+                                  -- never quantifying over any constraints+               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in "GHC.Tc.Module",+                                  -- the :type +d case; this mode refuses+                                  -- to quantify over any defaultable constraint+               | NoRestrictions   -- ^ Quantify over any constraint that+                                  -- satisfies 'GHC.Tc.Utils.TcType.pickQuantifiablePreds'++instance Outputable InferMode where+  ppr ApplyMR         = text "ApplyMR"+  ppr EagerDefaulting = text "EagerDefaulting"+  ppr NoRestrictions  = text "NoRestrictions"++simplifyInfer :: TcLevel               -- Used when generating the constraints+              -> InferMode+              -> [TcIdSigInst]         -- Any signatures (possibly partial)+              -> [(Name, TcTauType)]   -- Variables to be generalised,+                                       -- and their tau-types+              -> WantedConstraints+              -> TcM ([TcTyVar],    -- Quantify over these type variables+                      [EvVar],      -- ... and these constraints (fully zonked)+                      TcEvBinds,    -- ... binding these evidence variables+                      Bool)         -- True <=> the residual constraints are insoluble++simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds+  | isEmptyWC wanteds+   = do { -- When quantifying, we want to preserve any order of variables as they+          -- appear in partial signatures. cf. decideQuantifiedTyVars+          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs+                                          , (_,Bndr tv _) <- sig_inst_skols sig ]+              psig_theta  = [ pred | sig <- partial_sigs+                                   , pred <- sig_inst_theta sig ]++       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)+       ; qtkvs <- quantifyTyVars dep_vars+       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)+       ; return (qtkvs, [], emptyTcEvBinds, False) }++  | otherwise+  = do { traceTc "simplifyInfer {"  $ vcat+             [ text "sigs =" <+> ppr sigs+             , text "binds =" <+> ppr name_taus+             , text "rhs_tclvl =" <+> ppr rhs_tclvl+             , text "infer_mode =" <+> ppr infer_mode+             , text "(unzonked) wanted =" <+> ppr wanteds+             ]++       ; let psig_theta = concatMap sig_inst_theta partial_sigs++       -- First do full-blown solving+       -- NB: we must gather up all the bindings from doing+       -- this solving; hence (runTcSWithEvBinds ev_binds_var).+       -- And note that since there are nested implications,+       -- calling solveWanteds will side-effect their evidence+       -- bindings, so we can't just revert to the input+       -- constraint.++       ; ev_binds_var <- TcM.newTcEvBinds+       ; psig_evs     <- newWanteds AnnOrigin psig_theta+       ; wanted_transformed_incl_derivs+            <- setTcLevel rhs_tclvl $+               runTcSWithEvBinds ev_binds_var $+               solveWanteds (mkSimpleWC psig_evs `andWC` wanteds)+               -- psig_evs : see Note [Add signature contexts as givens]++       -- Find quant_pred_candidates, the predicates that+       -- we'll consider quantifying over+       -- NB1: wanted_transformed does not include anything provable from+       --      the psig_theta; it's just the extra bit+       -- NB2: We do not do any defaulting when inferring a type, this can lead+       --      to less polymorphic types, see Note [Default while Inferring]+       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs+       ; let definite_error = insolubleWC wanted_transformed_incl_derivs+                              -- See Note [Quantification with errors]+                              -- NB: must include derived errors in this test,+                              --     hence "incl_derivs"+             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs+             quant_pred_candidates+               | definite_error = []+               | otherwise      = ctsPreds (approximateWC False wanted_transformed)++       -- Decide what type variables and constraints to quantify+       -- NB: quant_pred_candidates is already fully zonked+       -- NB: bound_theta are constraints we want to quantify over,+       --     including the psig_theta, which we always quantify over+       -- NB: bound_theta are fully zonked+       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl+                                                     name_taus partial_sigs+                                                     quant_pred_candidates+       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta++       -- Now emit the residual constraint+       ; emitResidualConstraints rhs_tclvl ev_binds_var+                                 name_taus co_vars qtvs bound_theta_vars+                                 wanted_transformed++         -- All done!+       ; traceTc "} simplifyInfer/produced residual implication for quantification" $+         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates+              , text "psig_theta =" <+> ppr psig_theta+              , text "bound_theta =" <+> ppr bound_theta+              , text "qtvs ="       <+> ppr qtvs+              , text "definite_error =" <+> ppr definite_error ]++       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var, definite_error ) }+         -- NB: bound_theta_vars must be fully zonked+  where+    partial_sigs = filter isPartialSig sigs++--------------------+emitResidualConstraints :: TcLevel -> EvBindsVar+                        -> [(Name, TcTauType)]+                        -> VarSet -> [TcTyVar] -> [EvVar]+                        -> WantedConstraints -> TcM ()+-- Emit the remaining constraints from the RHS.+emitResidualConstraints rhs_tclvl ev_binds_var+                        name_taus co_vars qtvs full_theta_vars wanteds+  | isEmptyWC wanteds+  = return ()++  | otherwise+  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)+       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple+             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars+             -- Reason for the partition:+             -- see Note [Emitting the residual implication in simplifyInfer]++-- Already done by defaultTyVarsAndSimplify+--      ; _ <- TcM.promoteTyVarSet (tyCoVarsOfCts outer_simple)++        ; let inner_wanted = wanteds { wc_simple = inner_simple }+        ; implics <- if isEmptyWC inner_wanted+                     then return emptyBag+                     else do implic1 <- newImplication+                             return $ unitBag $+                                      implic1  { ic_tclvl     = rhs_tclvl+                                               , ic_skols     = qtvs+                                               , ic_given     = full_theta_vars+                                               , ic_wanted    = inner_wanted+                                               , ic_binds     = ev_binds_var+                                               , ic_given_eqs = MaybeGivenEqs+                                               , ic_info      = skol_info }++        ; emitConstraints (emptyWC { wc_simple = outer_simple+                                   , wc_impl   = implics }) }+  where+    full_theta = map idType full_theta_vars+    skol_info = InferSkol [ (name, mkSigmaTy [] full_theta ty)+                          | (name, ty) <- name_taus ]+    -- We don't add the quantified variables here, because they are+    -- also bound in ic_skols and we want them to be tidied+    -- uniformly.++--------------------+ctsPreds :: Cts -> [PredType]+ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts+                             , let ev = ctEvidence ct ]++findInferredDiff :: TcThetaType -> TcThetaType -> TcM TcThetaType+findInferredDiff annotated_theta inferred_theta+  = pushTcLevelM_ $+    do { lcl_env   <- TcM.getLclEnv+       ; given_ids <- mapM TcM.newEvVar annotated_theta+       ; wanteds   <- newWanteds AnnOrigin inferred_theta+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+             given_cts = mkGivens given_loc given_ids++       ; residual <- runTcSDeriveds $+                     do { _ <- solveSimpleGivens given_cts+                        ; solveSimpleWanteds (listToBag (map mkNonCanonical wanteds)) }+         -- NB: There are no meta tyvars fromn this level annotated_theta+         -- because we have either promoted them or unified them+         -- See `Note [Quantification and partial signatures]` Wrinkle 2++       ; return (map (box_pred . ctPred) $+                 bagToList               $+                 wc_simple residual) }+  where+     box_pred :: PredType -> PredType+     box_pred pred = case classifyPredType pred of+                        EqPred rel ty1 ty2+                          | Just (cls,tys) <- boxEqPred rel ty1 ty2+                          -> mkClassPred cls tys+                          | otherwise+                          -> pprPanic "findInferredDiff" (ppr pred)+                        _other -> pred++{- Note [Emitting the residual implication in simplifyInfer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f = e+where f's type is inferred to be something like (a, Proxy k (Int |> co))+and we have an as-yet-unsolved, or perhaps insoluble, constraint+   [W] co :: Type ~ k+We can't form types like (forall co. blah), so we can't generalise over+the coercion variable, and hence we can't generalise over things free in+its kind, in the case 'k'.  But we can still generalise over 'a'.  So+we'll generalise to+   f :: forall a. (a, Proxy k (Int |> co))+Now we do NOT want to form the residual implication constraint+   forall a. [W] co :: Type ~ k+because then co's eventual binding (which will be a value binding if we+use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose+type mentions 'co').  Instead, just as we don't generalise over 'co', we+should not bury its constraint inside the implication.  Instead, we must+put it outside.++That is the reason for the partitionBag in emitResidualConstraints,+which takes the CoVars free in the inferred type, and pulls their+constraints out.  (NB: this set of CoVars should be closed-over-kinds.)++All rather subtle; see #14584.++Note [Add signature contexts as wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#11016):+  f2 :: (?x :: Int) => _+  f2 = ?x++or this+  class C a b | a -> b+  g :: C p q => p -> q+  f3 :: C Int b => _+  f3 = g (3::Int)++We'll use plan InferGen because there are holes in the type.  But:+ * For f2 we want to have the (?x :: Int) constraint floating around+   so that the functional dependencies kick in.  Otherwise the+   occurrence of ?x on the RHS produces constraint (?x :: alpha), and+   we won't unify alpha:=Int.++ * For f3 want the (C Int b) constraint from the partial signature+   to meet the (C Int beta) constraint we get from the call to g; again,+   fundeps++Solution: in simplifyInfer, we add the constraints from the signature+as extra Wanteds++************************************************************************+*                                                                      *+                Quantification+*                                                                      *+************************************************************************++Note [Deciding quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the monomorphism restriction does not apply, then we quantify as follows:++* Step 1. Take the global tyvars, and "grow" them using the equality+  constraints+     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can+          happen because alpha is untouchable here) then do not quantify over+          beta, because alpha fixes beta, and beta is effectively free in+          the environment too++  We also account for the monomorphism restriction; if it applies,+  add the free vars of all the constraints.++  Result is mono_tvs; we will not quantify over these.++* Step 2. Default any non-mono tyvars (i.e ones that are definitely+  not going to become further constrained), and re-simplify the+  candidate constraints.++  Motivation for re-simplification (#7857): imagine we have a+  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are+  not free in the envt, and instance forall (a::*) (b::*). (C a) => C+  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but+  it will match when we default them to LiftedRep.++  This is all very tiresome.++* Step 3: decide which variables to quantify over, as follows:++  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"+    them using all the constraints.  These are tau_tvs_plus++  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being+    careful to close over kinds, and to skolemise the quantified tyvars.+    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)++  Result is qtvs.++* Step 4: Filter the constraints using pickQuantifiablePreds and the+  qtvs. We have to zonk the constraints first, so they "see" the+  freshly created skolems.++-}++decideQuantification+  :: InferMode+  -> TcLevel+  -> [(Name, TcTauType)]   -- Variables to be generalised+  -> [TcIdSigInst]         -- Partial type signatures (if any)+  -> [PredType]            -- Candidate theta; already zonked+  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)+         , [PredType]      -- and this context (fully zonked)+         , VarSet)+-- See Note [Deciding quantification]+decideQuantification infer_mode rhs_tclvl name_taus psigs candidates+  = do { -- Step 1: find the mono_tvs+       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode+                                              name_taus psigs candidates++       -- Step 2: default any non-mono tyvars, and re-simplify+       -- This step may do some unification, but result candidates is zonked+       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates++       -- Step 3: decide which kind/type variables to quantify over+       ; qtvs <- decideQuantifiedTyVars name_taus psigs candidates++       -- Step 4: choose which of the remaining candidate+       --         predicates to actually quantify over+       -- NB: decideQuantifiedTyVars turned some meta tyvars+       -- into quantified skolems, so we have to zonk again+       ; candidates <- TcM.zonkTcTypes candidates+       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)+       ; let quantifiable_candidates+               = pickQuantifiablePreds (mkVarSet qtvs) candidates++             theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]+                     psig_theta ++ quantifiable_candidates+             -- NB: add psig_theta back in here, even though it's already+             -- part of candidates, because we always want to quantify over+             -- psig_theta, and pickQuantifiableCandidates might have+             -- dropped some e.g. CallStack constraints.  c.f #14658+             --                   equalities (a ~ Bool)+             -- Remember, this is the theta for the residual constraint++       ; traceTc "decideQuantification"+           (vcat [ text "infer_mode:" <+> ppr infer_mode+                 , text "candidates:" <+> ppr candidates+                 , text "psig_theta:" <+> ppr psig_theta+                 , text "mono_tvs:"   <+> ppr mono_tvs+                 , text "co_vars:"    <+> ppr co_vars+                 , text "qtvs:"       <+> ppr qtvs+                 , text "theta:"      <+> ppr theta ])+       ; return (qtvs, theta, co_vars) }++------------------+decideMonoTyVars :: InferMode+                 -> [(Name,TcType)]+                 -> [TcIdSigInst]+                 -> [PredType]+                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)+-- Decide which tyvars and covars cannot be generalised:+--   (a) Free in the environment+--   (b) Mentioned in a constraint we can't generalise+--   (c) Connected by an equality to (a) or (b)+-- Also return CoVars that appear free in the final quantified types+--   we can't quantify over these, and we must make sure they are in scope+decideMonoTyVars infer_mode name_taus psigs candidates+  = do { (no_quant, maybe_quant) <- pick infer_mode candidates++       -- If possible, we quantify over partial-sig qtvs, so they are+       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs+       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $ binderVars $+                      concatMap (map snd . sig_inst_skols) psigs++       ; psig_theta <- mapM TcM.zonkTcType $+                       concatMap sig_inst_theta psigs++       ; taus <- mapM (TcM.zonkTcType . snd) name_taus++       ; tc_lvl <- TcM.getTcLevel+       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta++             co_vars = coVarsOfTypes (psig_tys ++ taus)+             co_var_tvs = closeOverKinds co_vars+               -- The co_var_tvs are tvs mentioned in the types of covars or+               -- coercion holes. We can't quantify over these covars, so we+               -- must include the variable in their types in the mono_tvs.+               -- E.g.  If we can't quantify over co :: k~Type, then we can't+               --       quantify over k either!  Hence closeOverKinds++             mono_tvs0 = filterVarSet (not . isQuantifiableTv tc_lvl) $+                         tyCoVarsOfTypes candidates+               -- We need to grab all the non-quantifiable tyvars in the+               -- candidates so that we can grow this set to find other+               -- non-quantifiable tyvars. This can happen with something+               -- like+               --    f x y = ...+               --      where z = x 3+               -- The body of z tries to unify the type of x (call it alpha[1])+               -- with (beta[2] -> gamma[2]). This unification fails because+               -- alpha is untouchable. But we need to know not to quantify over+               -- beta or gamma, because they are in the equality constraint with+               -- alpha. Actual test case: typecheck/should_compile/tc213++             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs++             eq_constraints = filter isEqPrimPred candidates+             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1++             constrained_tvs = filterVarSet (isQuantifiableTv tc_lvl) $+                               (growThetaTyVars eq_constraints+                                               (tyCoVarsOfTypes no_quant)+                                `minusVarSet` mono_tvs2)+                               `delVarSetList` psig_qtvs+             -- constrained_tvs: the tyvars that we are not going to+             -- quantify solely because of the monomorphism restriction+             --+             -- (`minusVarSet` mono_tvs2`): a type variable is only+             --   "constrained" (so that the MR bites) if it is not+             --   free in the environment (#13785)+             --+             -- (`delVarSetList` psig_qtvs): if the user has explicitly+             --   asked for quantification, then that request "wins"+             --   over the MR.  Note: do /not/ delete psig_qtvs from+             --   mono_tvs1, because mono_tvs1 cannot under any circumstances+             --   be quantified (#14479); see+             --   Note [Quantification and partial signatures], Wrinkle 3, 4++             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs++           -- Warn about the monomorphism restriction+       ; warn_mono <- woptM Opt_WarnMonomorphism+       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $+         warnTc (Reason Opt_WarnMonomorphism)+                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)+                mr_msg++       ; traceTc "decideMonoTyVars" $ vcat+           [ text "infer_mode =" <+> ppr infer_mode+           , text "mono_tvs0 =" <+> ppr mono_tvs0+           , text "no_quant =" <+> ppr no_quant+           , text "maybe_quant =" <+> ppr maybe_quant+           , text "eq_constraints =" <+> ppr eq_constraints+           , text "mono_tvs =" <+> ppr mono_tvs+           , text "co_vars =" <+> ppr co_vars ]++       ; return (mono_tvs, maybe_quant, co_vars) }+  where+    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])+    -- Split the candidates into ones we definitely+    -- won't quantify, and ones that we might+    pick NoRestrictions  cand = return ([], cand)+    pick ApplyMR         cand = return (cand, [])+    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings+                                   ; return (partition (is_int_ct os) cand) }++    -- For EagerDefaulting, do not quantify over+    -- over any interactive class constraint+    is_int_ct ovl_strings pred+      | Just (cls, _) <- getClassPredTys_maybe pred+      = isInteractiveClass ovl_strings cls+      | otherwise+      = False++    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus+    mr_msg =+         hang (sep [ text "The Monomorphism Restriction applies to the binding"+                     <> plural name_taus+                   , text "for" <+> pp_bndrs ])+            2 (hsep [ text "Consider giving"+                    , text (if isSingleton name_taus then "it" else "them")+                    , text "a type signature"])++-------------------+defaultTyVarsAndSimplify :: TcLevel+                         -> TyCoVarSet+                         -> [PredType]          -- Assumed zonked+                         -> TcM [PredType]      -- Guaranteed zonked+-- Default any tyvar free in the constraints,+-- and re-simplify in case the defaulting allows further simplification+defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates+  = do {  -- Promote any tyvars that we cannot generalise+          -- See Note [Promote monomorphic tyvars]+       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)+       ; any_promoted <- promoteTyVarSet mono_tvs++       -- Default any kind/levity vars+       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}+                <- candidateQTyVarsOfTypes candidates+                -- any covars should already be handled by+                -- the logic in decideMonoTyVars, which looks at+                -- the constraints generated++       ; poly_kinds  <- xoptM LangExt.PolyKinds+       ; default_kvs <- mapM (default_one poly_kinds True)+                             (dVarSetElems cand_kvs)+       ; default_tvs <- mapM (default_one poly_kinds False)+                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))+       ; let some_default = or default_kvs || or default_tvs++       ; case () of+           _ | some_default -> simplify_cand candidates+             | any_promoted -> mapM TcM.zonkTcType candidates+             | otherwise    -> return candidates+       }+  where+    default_one poly_kinds is_kind_var tv+      | not (isMetaTyVar tv)+      = return False+      | tv `elemVarSet` mono_tvs+      = return False+      | otherwise+      = defaultTyVar (not poly_kinds && is_kind_var) tv++    simplify_cand candidates+      = do { clone_wanteds <- newWanteds DefaultOrigin candidates+           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $+                                           simplifyWantedsTcM clone_wanteds+              -- Discard evidence; simples is fully zonked++           ; let new_candidates = ctsPreds simples+           ; traceTc "Simplified after defaulting" $+                      vcat [ text "Before:" <+> ppr candidates+                           , text "After:"  <+> ppr new_candidates ]+           ; return new_candidates }++------------------+decideQuantifiedTyVars+   :: [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   -> [TcIdSigInst]     -- Partial signatures+   -> [PredType]        -- Candidates, zonked+   -> TcM [TyVar]+-- Fix what tyvars we are going to quantify over, and quantify them+decideQuantifiedTyVars name_taus psigs candidates+  = do {     -- Why psig_tys? We try to quantify over everything free in here+             -- See Note [Quantification and partial signatures]+             --     Wrinkles 2 and 3+       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs+                                                  , (_,Bndr tv _) <- sig_inst_skols sig ]+       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs+                                                  , pred <- sig_inst_theta sig ]+       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus++       ; let -- Try to quantify over variables free in these types+             psig_tys = psig_tv_tys ++ psig_theta+             seed_tys = psig_tys ++ tau_tys++             -- Now "grow" those seeds to find ones reachable via 'candidates'+             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)++       -- Now we have to classify them into kind variables and type variables+       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars+       --+       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces+       -- them in that order, so that the final qtvs quantifies in the same+       -- order as the partial signatures do (#13524)+       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $+                                                         psig_tys ++ candidates ++ tau_tys+       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)+             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }++       ; traceTc "decideQuantifiedTyVars" (vcat+           [ text "tau_tys =" <+> ppr tau_tys+           , text "candidates =" <+> ppr candidates+           , text "cand_kvs =" <+> ppr cand_kvs+           , text "cand_tvs =" <+> ppr cand_tvs+           , text "tau_tys =" <+> ppr tau_tys+           , text "seed_tys =" <+> ppr seed_tys+           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)+           , text "grown_tcvs =" <+> ppr grown_tcvs+           , text "dvs =" <+> ppr dvs_plus])++       ; quantifyTyVars dvs_plus }++------------------+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet+-- See Note [Growing the tau-tvs using constraints]+growThetaTyVars theta tcvs+  | null theta = tcvs+  | otherwise  = transCloVarSet mk_next seed_tcvs+  where+    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips+    (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+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips+    grow_one so_far pred tcvs+       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs+       | otherwise                           = tcvs+       where+         pred_tcvs = tyCoVarsOfType pred+++{- Note [Promote monomorphic tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Promote any type variables that are free in the environment.  Eg+   f :: forall qtvs. bound_theta => zonked_tau+The free vars of f's type become free in the envt, and hence will show+up whenever 'f' is called.  They may currently at rhs_tclvl, but they+had better be unifiable at the outer_tclvl!  Example: envt mentions+alpha[1]+           tau_ty = beta[2] -> beta[2]+           constraints = alpha ~ [beta]+we don't quantify over beta (since it is fixed by envt)+so we must promote it!  The inferred type is just+  f :: beta -> beta++NB: promoteTyVarSet ignores coercion variables++Note [Quantification and partial signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When choosing type variables to quantify, the basic plan is to+quantify over all type variables that are+ * free in the tau_tvs, and+ * not forced to be monomorphic (mono_tvs),+   for example by being free in the environment.++However, in the case of a partial type signature, be doing inference+*in the presence of a type signature*. For example:+   f :: _ -> a+   f x = ...+or+   g :: (Eq _a) => _b -> _b+In both cases we use plan InferGen, and hence call simplifyInfer.  But+those 'a' variables are skolems (actually TyVarTvs), and we should be+sure to quantify over them.  This leads to several wrinkles:++* Wrinkle 1.  In the case of a type error+     f :: _ -> Maybe a+     f x = True && x+  The inferred type of 'f' is f :: Bool -> Bool, but there's a+  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting+  machine expects to find a binding site for the skolem 'a', so we+  add it to the quantified tyvars.++* Wrinkle 2.  Consider the partial type signature+     f :: (Eq _) => Int -> Int+     f x = x+  In normal cases that makes sense; e.g.+     g :: Eq _a => _a -> _a+     g x = x+  where the signature makes the type less general than it could+  be. But for 'f' we must therefore quantify over the user-annotated+  constraints, to get+     f :: forall a. Eq a => Int -> Int+  (thereby correctly triggering an ambiguity error later).  If we don't+  we'll end up with a strange open type+     f :: Eq alpha => Int -> Int+  which isn't ambiguous but is still very wrong.++  Bottom line: Try to quantify over any variable free in psig_theta,+  just like the tau-part of the type.++* Wrinkle 3 (#13482). Also consider+    f :: forall a. _ => Int -> Int+    f x = if (undefined :: a) == undefined then x else 0+  Here we get an (Eq a) constraint, but it's not mentioned in the+  psig_theta nor the type of 'f'.  But we still want to quantify+  over 'a' even if the monomorphism restriction is on.++* Wrinkle 4 (#14479)+    foo :: Num a => a -> a+    foo xxx = g xxx+      where+        g :: forall b. Num b => _ -> b+        g y = xxx + y++  In the signature for 'g', we cannot quantify over 'b' because it turns out to+  get unified with 'a', which is free in g's environment.  So we carefully+  refrain from bogusly quantifying, in GHC.Tc.Solver.decideMonoTyVars.  We+  report the error later, in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.++Note [Growing the tau-tvs using constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(growThetaTyVars insts tvs) is the result of extending the set+    of tyvars, tvs, using all conceivable links from pred++E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}+Then growThetaTyVars preds tvs = {a,b,c}++Notice that+   growThetaTyVars is conservative       if v might be fixed by vs+                                         => v `elem` grow(vs,C)++Note [Quantification with errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find that the RHS of the definition has some absolutely-insoluble+constraints (including especially "variable not in scope"), we++* Abandon all attempts to find a context to quantify over,+  and instead make the function fully-polymorphic in whatever+  type we have found++* Return a flag from simplifyInfer, indicating that we found an+  insoluble constraint.  This flag is used to suppress the ambiguity+  check for the inferred type, which may well be bogus, and which+  tends to obscure the real error.  This fix feels a bit clunky,+  but I failed to come up with anything better.++Reasons:+    - Avoid downstream errors+    - Do not perform an ambiguity test on a bogus type, which might well+      fail spuriously, thereby obfuscating the original insoluble error.+      #14000 is an example++I tried an alternative approach: simply failM, after emitting the+residual implication constraint; the exception will be caught in+GHC.Tc.Gen.Bind.tcPolyBinds, which gives all the binders in the group the type+(forall a. a).  But that didn't work with -fdefer-type-errors, because+the recovery from failM emits no code at all, so there is no function+to run!   But -fdefer-type-errors aspires to produce a runnable program.++NB that we must include *derived* errors in the check for insolubles.+Example:+    (a::*) ~ Int#+We get an insoluble derived error *~#, and we don't want to discard+it before doing the isInsolubleWC test!  (#8262)++Note [Default while Inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our current plan is that defaulting only happens at simplifyTop and+not simplifyInfer.  This may lead to some insoluble deferred constraints.+Example:++instance D g => C g Int b++constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha+type inferred       = gamma -> gamma++Now, if we try to default (alpha := Int) we will be able to refine the implication to+  (forall b. 0 => C gamma Int b)+which can then be simplified further to+  (forall b. 0 => D gamma)+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified+type:  forall g. D g => g -> g++Instead what will currently happen is that we will get a quantified type+(forall g. g -> g) and an implication:+       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha++Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an+unsolvable implication:+       forall g. 0 => (forall b. 0 => D g)++The concrete example would be:+       h :: C g a s => g -> a -> ST s a+       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)++But it is quite tedious to do defaulting and resolve the implication constraints, and+we have not observed code breaking because of the lack of defaulting in inference, so+we don't do it for now.++++Note [Minimize by Superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we quantify over a constraint, in simplifyInfer we need to+quantify over a constraint that is minimal in some sense: For+instance, if the final wanted constraint is (Eq alpha, Ord alpha),+we'd like to quantify over Ord alpha, because we can just get Eq alpha+from superclass selection from Ord alpha. This minimization is what+mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint+to check the original wanted.+++Note [Avoid unnecessary constraint simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -------- NB NB NB (Jun 12) -------------+    This note not longer applies; see the notes with #4361.+    But I'm leaving it in here so we remember the issue.)+    ----------------------------------------+When inferring the type of a let-binding, with simplifyInfer,+try to avoid unnecessarily simplifying class constraints.+Doing so aids sharing, but it also helps with delicate+situations like++   instance C t => C [t] where ..++   f :: C [t] => ....+   f x = let g y = ...(constraint C [t])...+         in ...+When inferring a type for 'g', we don't want to apply the+instance decl, because then we can't satisfy (C t).  So we+just notice that g isn't quantified over 't' and partition+the constraints before simplifying.++This only half-works, but then let-generalisation only half-works.++*********************************************************************************+*                                                                                 *+*                                 Main Simplifier                                 *+*                                                                                 *+***********************************************************************************++-}++simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints+-- Solve the specified Wanted constraints+-- Discard the evidence binds+-- Discards all Derived stuff in result+-- Postcondition: fully zonked+simplifyWantedsTcM wanted+  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)+       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))+       ; result <- TcM.zonkWC result+       ; traceTc "simplifyWantedsTcM }" (ppr result)+       ; return result }++solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints+-- Since solveWanteds returns the residual WantedConstraints,+-- it should always be called within a runTcS or something similar,+-- Result is not zonked+solveWantedsAndDrop wanted+  = do { wc <- solveWanteds wanted+       ; return (dropDerivedWC wc) }++solveWanteds :: WantedConstraints -> TcS WantedConstraints+-- so that the inert set doesn't mindlessly propagate.+-- NB: wc_simples may be wanted /or/ derived now+solveWanteds wc@(WC { wc_holes = holes })+  = do { cur_lvl <- TcS.getTcLevel+       ; traceTcS "solveWanteds {" $+         vcat [ text "Level =" <+> ppr cur_lvl+              , ppr wc ]++       ; dflags <- getDynFlags+       ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc++       ; holes' <- simplifyHoles holes+       ; let final_wc = solved_wc { wc_holes = holes' }++       ; ev_binds_var <- getTcEvBindsVar+       ; bb <- TcS.getTcEvBindsMap ev_binds_var+       ; traceTcS "solveWanteds }" $+                 vcat [ text "final wc =" <+> ppr final_wc+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]++       ; return final_wc }++simplify_loop :: Int -> IntWithInf -> Bool+              -> WantedConstraints -> TcS WantedConstraints+-- Do a round of solving, and call maybe_simplify_again to iterate+-- The 'definitely_redo_implications' flags is False if the only reason we+-- are iterating is that we have added some new Derived superclasses (from Wanteds)+-- hoping for fundeps to help us; see Note [Superclass iteration]+--+-- Does not affect wc_holes at all; reason: wc_holes never affects anything+-- else, so we do them once, at the end in solveWanteds+simplify_loop n limit definitely_redo_implications+              wc@(WC { wc_simple = simples, wc_impl = implics })+  = do { csTraceTcS $+         text "simplify_loop iteration=" <> int n+         <+> (parens $ hsep [ text "definitely_redo =" <+> ppr definitely_redo_implications <> comma+                            , int (lengthBag simples) <+> text "simples to solve" ])+       ; traceTcS "simplify_loop: wc =" (ppr wc)++       ; (unifs1, wc1) <- reportUnifications $  -- See Note [Superclass iteration]+                          solveSimpleWanteds simples+                -- Any insoluble constraints are in 'simples' and so get rewritten+                -- See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad++       ; wc2 <- if not definitely_redo_implications  -- See Note [Superclass iteration]+                   && unifs1 == 0                    -- for this conditional+                   && isEmptyBag (wc_impl wc1)+                then return (wc { wc_simple = wc_simple wc1 })  -- Short cut+                else do { implics2 <- solveNestedImplications $+                                      implics `unionBags` (wc_impl wc1)+                        ; return (wc { wc_simple = wc_simple wc1+                                     , wc_impl = implics2 }) }++       ; unif_happened <- resetUnificationFlag+         -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad+       ; maybe_simplify_again (n+1) limit unif_happened wc2 }++maybe_simplify_again :: Int -> IntWithInf -> Bool+                     -> WantedConstraints -> TcS WantedConstraints+maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })+  | n `intGtLimit` limit+  = do { -- Add an error (not a warning) if we blow the limit,+         -- Typically if we blow the limit we are going to report some other error+         -- (an unsolved constraint), and we don't want that error to suppress+         -- the iteration limit warning!+         addErrTcS (hang (text "solveWanteds: too many iterations"+                   <+> parens (text "limit =" <+> ppr limit))+                2 (vcat [ text "Unsolved:" <+> ppr wc+                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"+                  ]))+       ; return wc }++  | unif_happened+  = simplify_loop n limit True wc++  | superClassesMightHelp wc+  = -- We still have unsolved goals, and apparently no way to solve them,+    -- so try expanding superclasses at this level, both Given and Wanted+    do { pending_given <- getPendingGivenScs+       ; let (pending_wanted, simples1) = getPendingWantedScs simples+       ; if null pending_given && null pending_wanted+           then return wc  -- After all, superclasses did not help+           else+    do { new_given  <- makeSuperClasses pending_given+       ; new_wanted <- makeSuperClasses pending_wanted+       ; solveSimpleGivens new_given -- Add the new Givens to the inert set+       ; simplify_loop n limit (not (null pending_given)) $+         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }+         -- (not (null pending_given)): see Note [Superclass iteration]++  | otherwise+  = return wc++{- Note [Superclass iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this implication constraint+    forall a.+       [W] d: C Int beta+       forall b. blah+where+  class D a b | a -> b+  class D a b => C a b+We will expand d's superclasses, giving [D] D Int beta, in the hope of geting+fundeps to unify beta.  Doing so is usually fruitless (no useful fundeps),+and if so it seems a pity to waste time iterating the implications (forall b. blah)+(If we add new Given superclasses it's a different matter: it's really worth looking+at the implications.)++Hence the definitely_redo_implications flag to simplify_loop.  It's usually+True, but False in the case where the only reason to iterate is new Derived+superclasses.  In that case we check whether the new Deriveds actually led to+any new unifications, and iterate the implications only if so.+-}++solveNestedImplications :: Bag Implication+                        -> TcS (Bag Implication)+-- Precondition: the TcS inerts may contain unsolved simples which have+-- to be converted to givens before we go inside a nested implication.+solveNestedImplications implics+  | isEmptyBag implics+  = return (emptyBag)+  | otherwise+  = do { traceTcS "solveNestedImplications starting {" empty+       ; unsolved_implics <- mapBagM solveImplication implics++       -- ... and we are back in the original TcS inerts+       -- Notice that the original includes the _insoluble_simples so it was safe to ignore+       -- them in the beginning of this function.+       ; traceTcS "solveNestedImplications end }" $+                  vcat [ text "unsolved_implics =" <+> ppr unsolved_implics ]++       ; return (catBagMaybes unsolved_implics) }++solveImplication :: Implication    -- Wanted+                 -> TcS (Maybe Implication) -- Simplified implication (empty or singleton)+-- Precondition: The TcS monad contains an empty worklist and given-only inerts+-- which after trying to solve this implication we must restore to their original value+solveImplication imp@(Implic { ic_tclvl  = tclvl+                             , ic_binds  = ev_binds_var+                             , ic_given  = given_ids+                             , ic_wanted = wanteds+                             , ic_info   = info+                             , ic_status = status })+  | isSolvedStatus status+  = return (Just imp)  -- Do nothing++  | otherwise  -- Even for IC_Insoluble it is worth doing more work+               -- The insoluble stuff might be in one sub-implication+               -- and other unsolved goals in another; and we want to+               -- solve the latter as much as possible+  = do { inerts <- getTcSInerts+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)++       -- commented out; see `where` clause below+       -- ; when debugIsOn check_tc_level++         -- Solve the nested constraints+       ; (has_given_eqs, given_insols, residual_wanted)+            <- nestImplicTcS ev_binds_var tclvl $+               do { let loc    = mkGivenLoc tclvl info (ic_env imp)+                        givens = mkGivens loc given_ids+                  ; solveSimpleGivens givens++                  ; residual_wanted <- solveWanteds wanteds+                        -- solveWanteds, *not* solveWantedsAndDrop, because+                        -- we want to retain derived equalities so we can float+                        -- them out in floatEqualities.++                  ; (has_eqs, given_insols) <- getHasGivenEqs tclvl+                        -- Call getHasGivenEqs /after/ solveWanteds, because+                        -- solveWanteds can augment the givens, via expandSuperClasses,+                        -- to reveal given superclass equalities++                  ; return (has_eqs, given_insols, residual_wanted) }++       ; traceTcS "solveImplication 2"+           (ppr given_insols $$ ppr residual_wanted)+       ; let final_wanted = residual_wanted `addInsols` given_insols+             -- Don't lose track of the insoluble givens,+             -- which signal unreachable code; put them in ic_wanted++       ; res_implic <- setImplicationStatus (imp { ic_given_eqs = has_given_eqs+                                                 , ic_wanted = final_wanted })++       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var+       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var+       ; traceTcS "solveImplication end }" $ vcat+             [ text "has_given_eqs =" <+> ppr has_given_eqs+             , text "res_implic =" <+> ppr res_implic+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)+             , text "implication tvcs =" <+> ppr tcvs ]++       ; return res_implic }++    -- TcLevels must be strictly increasing (see (ImplicInv) in+    -- Note [TcLevel invariants] in GHC.Tc.Utils.TcType),+    -- and in fact I think they should always increase one level at a time.++    -- Though sensible, this check causes lots of testsuite failures. It is+    -- remaining commented out for now.+    {-+    check_tc_level = do { cur_lvl <- TcS.getTcLevel+                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }+    -}++----------------------+setImplicationStatus :: Implication -> TcS (Maybe Implication)+-- Finalise the implication returned from solveImplication:+--    * Set the ic_status field+--    * Trim the ic_wanted field to remove Derived constraints+-- Precondition: the ic_status field is not already IC_Solved+-- Return Nothing if we can discard the implication altogether+setImplicationStatus implic@(Implic { ic_status     = status+                                    , ic_info       = info+                                    , ic_wanted     = wc+                                    , ic_given      = givens })+ | ASSERT2( not (isSolvedStatus status ), ppr info )+   -- Precondition: we only set the status if it is not already solved+   not (isSolvedWC pruned_wc)+ = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)++      ; implic <- neededEvVars implic++      ; let new_status | insolubleWC pruned_wc = IC_Insoluble+                       | otherwise             = IC_Unsolved+            new_implic = implic { ic_status = new_status+                                , ic_wanted = pruned_wc }++      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)++      ; return $ Just new_implic }++ | otherwise  -- Everything is solved+              -- Set status to IC_Solved,+              -- and compute the dead givens and outer needs+              -- See Note [Tracking redundant constraints]+ = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)++      ; implic@(Implic { ic_need_inner = need_inner+                       , ic_need_outer = need_outer }) <- neededEvVars implic++      ; bad_telescope <- checkBadTelescope implic++      ; let dead_givens | warnRedundantGivens info+                        = filterOut (`elemVarSet` need_inner) givens+                        | otherwise = []   -- None to report++            discard_entire_implication  -- Can we discard the entire implication?+              =  null dead_givens           -- No warning from this implication+              && not bad_telescope+              && isEmptyWC pruned_wc        -- No live children+              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent++            final_status+              | bad_telescope = IC_BadTelescope+              | otherwise     = IC_Solved { ics_dead = dead_givens }+            final_implic = implic { ic_status = final_status+                                  , ic_wanted = pruned_wc }++      ; traceTcS "setImplicationStatus(all-solved) }" $+        vcat [ text "discard:" <+> ppr discard_entire_implication+             , text "new_implic:" <+> ppr final_implic ]++      ; return $ if discard_entire_implication+                 then Nothing+                 else Just final_implic }+ where+   WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc++   pruned_simples = dropDerivedSimples simples+   pruned_implics = filterBag keep_me implics+   pruned_wc = WC { wc_simple = pruned_simples+                  , wc_impl   = pruned_implics+                  , wc_holes  = holes }   -- do not prune holes; these should be reported++   keep_me :: Implication -> Bool+   keep_me ic+     | IC_Solved { ics_dead = dead_givens } <- ic_status ic+                          -- Fully solved+     , null dead_givens   -- No redundant givens to report+     , isEmptyBag (wc_impl (ic_wanted ic))+           -- And no children that might have things to report+     = False       -- Tnen we don't need to keep it+     | otherwise+     = True        -- Otherwise, keep it++checkBadTelescope :: Implication -> TcS Bool+-- True <=> the skolems form a bad telescope+-- See Note [Checking telescopes] in GHC.Tc.Types.Constraint+checkBadTelescope (Implic { ic_info  = info+                          , ic_skols = skols })+  | checkTelescopeSkol info+  = do{ skols <- mapM TcS.zonkTyCoVarKind skols+      ; return (go emptyVarSet (reverse skols))}++  | otherwise+  = return False++  where+    go :: TyVarSet   -- skolems that appear *later* than the current ones+       -> [TcTyVar]  -- ordered skolems, in reverse order+       -> Bool       -- True <=> there is an out-of-order skolem+    go _ [] = False+    go later_skols (one_skol : earlier_skols)+      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols+      = True+      | otherwise+      = go (later_skols `extendVarSet` one_skol) earlier_skols++warnRedundantGivens :: SkolemInfo -> Bool+warnRedundantGivens (SigSkol ctxt _ _)+  = case ctxt of+       FunSigCtxt _ warn_redundant -> warn_redundant+       ExprSigCtxt                 -> True+       _                           -> False++  -- To think about: do we want to report redundant givens for+  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.+warnRedundantGivens (InstSkol {}) = True+warnRedundantGivens _             = False++neededEvVars :: Implication -> TcS Implication+-- Find all the evidence variables that are "needed",+-- and delete dead evidence bindings+--   See Note [Tracking redundant constraints]+--   See Note [Delete dead Given evidence bindings]+--+--   - Start from initial_seeds (from nested implications)+--+--   - Add free vars of RHS of all Wanted evidence bindings+--     and coercion variables accumulated in tcvs (all Wanted)+--+--   - Generate 'needed', the needed set of EvVars, by doing transitive+--     closure through Given bindings+--     e.g.   Needed {a,b}+--            Given  a = sc_sel a2+--            Then a2 is needed too+--+--   - Prune out all Given bindings that are not needed+--+--   - From the 'needed' set, delete ev_bndrs, the binders of the+--     evidence bindings, to give the final needed variables+--+neededEvVars implic@(Implic { ic_given = givens+                            , ic_binds = ev_binds_var+                            , ic_wanted = WC { wc_impl = implics }+                            , ic_need_inner = old_needs })+ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var+      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var++      ; let seeds1        = foldr add_implic_seeds old_needs implics+            seeds2        = nonDetStrictFoldEvBindMap add_wanted seeds1 ev_binds+                            -- It's OK to use a non-deterministic fold here+                            -- because add_wanted is commutative+            seeds3        = seeds2 `unionVarSet` tcvs+            need_inner    = findNeededEvVars ev_binds seeds3+            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds+            need_outer    = varSetMinusEvBindMap need_inner live_ev_binds+                            `delVarSetList` givens++      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds+           -- See Note [Delete dead Given evidence bindings]++      ; traceTcS "neededEvVars" $+        vcat [ text "old_needs:" <+> ppr old_needs+             , text "seeds3:" <+> ppr seeds3+             , text "tcvs:" <+> ppr tcvs+             , text "ev_binds:" <+> ppr ev_binds+             , text "live_ev_binds:" <+> ppr live_ev_binds ]++      ; return (implic { ic_need_inner = need_inner+                       , ic_need_outer = need_outer }) }+ where+   add_implic_seeds (Implic { ic_need_outer = needs }) acc+      = needs `unionVarSet` acc++   needed_ev_bind needed (EvBind { eb_lhs = ev_var+                                 , eb_is_given = is_given })+     | is_given  = ev_var `elemVarSet` needed+     | otherwise = True   -- Keep all wanted bindings++   add_wanted :: EvBind -> VarSet -> VarSet+   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs+     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only+     | otherwise = evVarsOfTerm rhs `unionVarSet` needs++-------------------------------------------------+simplifyHoles :: Bag Hole -> TcS (Bag Hole)+simplifyHoles = mapBagM simpl_hole+  where+    simpl_hole :: Hole -> TcS Hole++     -- See Note [Do not simplify ConstraintHoles]+    simpl_hole h@(Hole { hole_sort = ConstraintHole }) = return h++     -- other wildcards should be simplified for printing+     -- we must do so here, and not in the error-message generation+     -- code, because we have all the givens already set up+    simpl_hole h@(Hole { hole_ty = ty, hole_loc = loc })+      = do { ty' <- rewriteType loc ty+           ; return (h { hole_ty = ty' }) }++{- Note [Delete dead Given evidence bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As a result of superclass expansion, we speculatively+generate evidence bindings for Givens. E.g.+   f :: (a ~ b) => a -> b -> Bool+   f x y = ...+We'll have+   [G] d1 :: (a~b)+and we'll speculatively generate the evidence binding+   [G] d2 :: (a ~# b) = sc_sel d++Now d2 is available for solving.  But it may not be needed!  Usually+such dead superclass selections will eventually be dropped as dead+code, but:++ * It won't always be dropped (#13032).  In the case of an+   unlifted-equality superclass like d2 above, we generate+       case heq_sc d1 of d2 -> ...+   and we can't (in general) drop that case expression in case+   d1 is bottom.  So it's technically unsound to have added it+   in the first place.++ * Simply generating all those extra superclasses can generate lots of+   code that has to be zonked, only to be discarded later.  Better not+   to generate it in the first place.++   Moreover, if we simplify this implication more than once+   (e.g. because we can't solve it completely on the first iteration+   of simpl_looop), we'll generate all the same bindings AGAIN!++Easy solution: take advantage of the work we are doing to track dead+(unused) Givens, and use it to prune the Given bindings too.  This is+all done by neededEvVars.++This led to a remarkable 25% overall compiler allocation decrease in+test T12227.++But we don't get to discard all redundant equality superclasses, alas;+see #15205.++Note [Do not simplify ConstraintHoles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before printing the inferred value for a type hole (a _ wildcard in+a partial type signature), we simplify it w.r.t. any Givens. This+makes for an easier-to-understand diagnostic for the user.++However, we do not wish to do this for extra-constraint holes. Here is+the example for why (partial-sigs/should_compile/T12844):++  bar :: _ => FooData rngs+  bar = foo++  data FooData rngs++  class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs++  type family Head (xs :: [k]) where Head (x ': xs) = x++GHC correctly infers that the extra-constraints wildcard on `bar`+should be (Head rngs ~ '(r, r'), Foo rngs). It then adds this+constraint as a Given on the implication constraint for `bar`. (This+implication is emitted by emitResidualConstraints.) The Hole for the _+is stored within the implication's WantedConstraints.  When+simplifyHoles is called, that constraint is already assumed as a+Given. Simplifying with respect to it turns it into ('(r, r') ~ '(r,+r'), Foo rngs), which is disastrous.++Furthermore, there is no need to simplify here: extra-constraints wildcards+are filled in with the output of the solver, in chooseInferredQuantifiers+(choose_psig_context), so they are already simplified. (Contrast to normal+type holes, which are just bound to a meta-variable.) Avoiding the poor output+is simple: just don't simplify extra-constraints wildcards.++This is the only reason we need to track ConstraintHole separately+from TypeHole in HoleSort.++See also Note [Extra-constraint holes in partial type signatures]+in GHC.Tc.Gen.HsType.++Note [Tracking redundant constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Opt_WarnRedundantConstraints, GHC can report which+constraints of a type signature (or instance declaration) are+redundant, and can be omitted.  Here is an overview of how it+works:++----- What is a redundant constraint?++* The things that can be redundant are precisely the Given+  constraints of an implication.++* A constraint can be redundant in two different ways:+  a) It is implied by other givens.  E.g.+       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary+       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary+  b) It is not needed by the Wanted constraints covered by the+     implication E.g.+       f :: Eq a => a -> Bool+       f x = True  -- Equality not used++*  To find (a), when we have two Given constraints,+   we must be careful to drop the one that is a naked variable (if poss).+   So if we have+       f :: (Eq a, Ord a) => blah+   then we may find [G] sc_sel (d1::Ord a) :: Eq a+                    [G] d2 :: Eq a+   We want to discard d2 in favour of the superclass selection from+   the Ord dictionary.  This is done by GHC.Tc.Solver.Interact.solveOneFromTheOther+   See Note [Replacement vs keeping].++* To find (b) we need to know which evidence bindings are 'wanted';+  hence the eb_is_given field on an EvBind.++----- How tracking works++* The ic_need fields of an Implic records in-scope (given) evidence+  variables bound by the context, that were needed to solve this+  implication (so far).  See the declaration of Implication.++* When the constraint solver finishes solving all the wanteds in+  an implication, it sets its status to IC_Solved++  - The ics_dead field, of IC_Solved, records the subset of this+    implication's ic_given that are redundant (not needed).++* We compute which evidence variables are needed by an implication+  in setImplicationStatus.  A variable is needed if+    a) it is free in the RHS of a Wanted EvBind,+    b) it is free in the RHS of an EvBind whose LHS is needed,+    c) it is in the ics_need of a nested implication.++* We need to be careful not to discard an implication+  prematurely, even one that is fully solved, because we might+  thereby forget which variables it needs, and hence wrongly+  report a constraint as redundant.  But we can discard it once+  its free vars have been incorporated into its parent; or if it+  simply has no free vars. This careful discarding is also+  handled in setImplicationStatus.++----- Reporting redundant constraints++* GHC.Tc.Errors does the actual warning, in warnRedundantConstraints.++* We don't report redundant givens for *every* implication; only+  for those which reply True to GHC.Tc.Solver.warnRedundantGivens:++   - For example, in a class declaration, the default method *can*+     use the class constraint, but it certainly doesn't *have* to,+     and we don't want to report an error there.++   - More subtly, in a function definition+       f :: (Ord a, Ord a, Ix a) => a -> a+       f x = rhs+     we do an ambiguity check on the type (which would find that one+     of the Ord a constraints was redundant), and then we check that+     the definition has that type (which might find that both are+     redundant).  We don't want to report the same error twice, so we+     disable it for the ambiguity check.  Hence using two different+     FunSigCtxts, one with the warn-redundant field set True, and the+     other set False in+        - GHC.Tc.Gen.Bind.tcSpecPrag+        - GHC.Tc.Gen.Bind.tcTySig++  This decision is taken in setImplicationStatus, rather than GHC.Tc.Errors+  so that we can discard implication constraints that we don't need.+  So ics_dead consists only of the *reportable* redundant givens.++----- Shortcomings++Consider (see #9939)+    f2 :: (Eq a, Ord a) => a -> a -> Bool+    -- Ord a redundant, but Eq a is reported+    f2 x y = (x == y)++We report (Eq a) as redundant, whereas actually (Ord a) is.  But it's+really not easy to detect that!++-}++-- | Like 'defaultTyVar', but in the TcS monad.+defaultTyVarTcS :: TcTyVar -> TcS Bool+defaultTyVarTcS the_tv+  | isRuntimeRepVar the_tv+  , not (isTyVarTyVar the_tv)+    -- TyVarTvs should only be unified with a tyvar+    -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar+    -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)+       ; unifyTyVar the_tv liftedRepTy+       ; return True }+  | isMultiplicityVar the_tv+  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar+                             -- never with a type; c.f. TcMType.defaultTyVar+                             -- See Note [Kind generalisation and SigTvs]+  = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)+       ; unifyTyVar the_tv manyDataConTy+       ; return True }+  | otherwise+  = return False  -- the common case++approximateWC :: Bool -> WantedConstraints -> Cts+-- Postcondition: Wanted or Derived Cts+-- See Note [ApproximateWC]+-- See Note [floatKindEqualities vs approximateWC]+approximateWC float_past_equalities wc+  = float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts+    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })+      = filterBag (is_floatable trapping_tvs) simples `unionBags`+        concatMapBag (float_implic trapping_tvs) implics+    float_implic :: TcTyCoVarSet -> Implication -> Cts+    float_implic trapping_tvs imp+      | float_past_equalities || ic_given_eqs imp /= MaybeGivenEqs+      = float_wc new_trapping_tvs (ic_wanted imp)+      | otherwise   -- Take care with equalities+      = emptyCts    -- See (1) under Note [ApproximateWC]+      where+        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp++    is_floatable skol_tvs ct+       | isGivenCt ct     = False+       | insolubleEqCt ct = False+       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs++{- Note [ApproximateWC]+~~~~~~~~~~~~~~~~~~~~~~~+approximateWC takes a constraint, typically arising from the RHS of a+let-binding whose type we are *inferring*, and extracts from it some+*simple* constraints that we might plausibly abstract over.  Of course+the top-level simple constraints are plausible, but we also float constraints+out from inside, if they are not captured by skolems.++The same function is used when doing type-class defaulting (see the call+to applyDefaultingRules) to extract constraints that might be defaulted.++There is one caveat:++1.  When inferring most-general types (in simplifyInfer), we do *not*+    float anything out if the implication binds equality constraints,+    because that defeats the OutsideIn story.  Consider+       data T a where+         TInt :: T Int+         MkT :: T a++       f TInt = 3::Int++    We get the implication (a ~ Int => res ~ Int), where so far we've decided+      f :: T a -> res+    We don't want to float (res~Int) out because then we'll infer+      f :: T a -> Int+    which is only on of the possible types. (GHC 7.6 accidentally *did*+    float out of such implications, which meant it would happily infer+    non-principal types.)++   HOWEVER (#12797) in findDefaultableGroups we are not worried about+   the most-general type; and we /do/ want to float out of equalities.+   Hence the boolean flag to approximateWC.++------ Historical note -----------+There used to be a second caveat, driven by #8155++   2. We do not float out an inner constraint that shares a type variable+      (transitively) with one that is trapped by a skolem.  Eg+          forall a.  F a ~ beta, Integral beta+      We don't want to float out (Integral beta).  Doing so would be bad+      when defaulting, because then we'll default beta:=Integer, and that+      makes the error message much worse; we'd get+          Can't solve  F a ~ Integer+      rather than+          Can't solve  Integral (F a)++      Moreover, floating out these "contaminated" constraints doesn't help+      when generalising either. If we generalise over (Integral b), we still+      can't solve the retained implication (forall a. F a ~ b).  Indeed,+      arguably that too would be a harder error to understand.++But this transitive closure stuff gives rise to a complex rule for+when defaulting actually happens, and one that was never documented.+Moreover (#12923), the more complex rule is sometimes NOT what+you want.  So I simply removed the extra code to implement the+contamination stuff.  There was zero effect on the testsuite (not even #8155).+------ End of historical note -----------+++Note [DefaultTyVar]+~~~~~~~~~~~~~~~~~~~+defaultTyVar is used on any un-instantiated meta type variables to+default any RuntimeRep variables to LiftedRep.  This is important+to ensure that instance declarations match.  For example consider++     instance Show (a->b)+     foo x = show (\_ -> True)++Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),+and that won't match the tcTypeKind (*) in the instance decl.  See tests+tc217 and tc175.++We look only at touchable type variables. No further constraints+are going to affect these type variables, so it's time to do it by+hand.  However we aren't ready to default them fully to () or+whatever, because the type-class defaulting rules have yet to run.++An alternate implementation would be to emit a derived constraint setting+the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.++Note [Promote _and_ default when inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are inferring a type, we simplify the constraint, and then use+approximateWC to produce a list of candidate constraints.  Then we MUST++  a) Promote any meta-tyvars that have been floated out by+     approximateWC, to restore invariant (WantedInv) described in+     Note [TcLevel invariants] in GHC.Tc.Utils.TcType.++  b) Default the kind of any meta-tyvars that are not mentioned in+     in the environment.++To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we+have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it+should!  If we don't solve the constraint, we'll stupidly quantify over+(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over+(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.+#7641 is a simpler example.++Note [Promoting unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we float an equality out of an implication we must "promote" free+unification variables of the equality, in order to maintain Invariant+(WantedInv) from Note [TcLevel invariants] in GHC.Tc.Types.TcType.++This is absolutely necessary. Consider the following example. We start+with two implications and a class with a functional dependency.++    class C x y | x -> y+    instance C [a] [a]++    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]+    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]++We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.+They may react to yield that (beta := [alpha]) which can then be pushed inwards+the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that+(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable+beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:++    class C x y | x -> y where+     op :: x -> y -> ()++    instance C [a] [a]++    type family F a :: *++    h :: F Int -> ()+    h = undefined++    data TEx where+      TEx :: a -> TEx++    f (x::beta) =+        let g1 :: forall b. b -> ()+            g1 _ = h [x]+            g2 z = case z of TEx y -> (h [[undefined]], op x [y])+        in (g1 '3', g2 undefined)   *********************************************************************************

GHC/Tc/Solver/Canonical.hs view

@@ -1,2553 +1,3191 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}--module GHC.Tc.Solver.Canonical(-     canonicalize,-     unifyDerived,-     makeSuperClasses, maybeSym,-     StopOrContinue(..), stopWith, continueWith,-     solveCallStack    -- For GHC.Tc.Solver-  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Tc.Types.Constraint-import GHC.Core.Predicate-import GHC.Tc.Types.Origin-import GHC.Tc.Utils.Unify( swapOverTyVars, metaTyVarUpdateOK, MetaTyVarUpdateResult(..) )-import GHC.Tc.Utils.TcType-import GHC.Core.Type-import GHC.Tc.Solver.Flatten-import GHC.Tc.Solver.Monad-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.EvTerm-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Core.Multiplicity-import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking-import GHC.Core.Coercion-import GHC.Core-import GHC.Types.Id( mkTemplateLocals )-import GHC.Core.FamInstEnv ( FamInstEnvs )-import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )-import GHC.Types.Var-import GHC.Types.Var.Env( mkInScopeSet )-import GHC.Types.Var.Set( delVarSetList )-import GHC.Utils.Outputable-import GHC.Driver.Session( DynFlags )-import GHC.Types.Name.Set-import GHC.Types.Name.Reader-import GHC.Hs.Type( HsIPName(..) )--import GHC.Data.Pair-import GHC.Utils.Misc-import GHC.Data.Bag-import GHC.Utils.Monad-import Control.Monad-import Data.Maybe ( isJust )-import Data.List  ( zip4 )-import GHC.Types.Basic--import Data.Bifunctor ( bimap )-import Data.Foldable ( traverse_ )--{--************************************************************************-*                                                                      *-*                      The Canonicaliser                               *-*                                                                      *-************************************************************************--Note [Canonicalization]-~~~~~~~~~~~~~~~~~~~~~~~--Canonicalization converts a simple constraint to a canonical form. It is-unary (i.e. treats individual constraints one at a time).--Constraints originating from user-written code come into being as-CNonCanonicals. We know nothing about these constraints. So, first:--     Classify CNonCanoncal constraints, depending on whether they-     are equalities, class predicates, or other.--Then proceed depending on the shape of the constraint. Generally speaking,-each constraint gets flattened and then decomposed into one of several forms-(see type Ct in GHC.Tc.Types).--When an already-canonicalized constraint gets kicked out of the inert set,-it must be recanonicalized. But we know a bit about its shape from the-last time through, so we can skip the classification step.---}---- Top-level canonicalization--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--canonicalize :: Ct -> TcS (StopOrContinue Ct)-canonicalize (CNonCanonical { cc_ev = ev })-  = {-# SCC "canNC" #-}-    case classifyPredType pred of-      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)-                                  canClassNC ev cls tys-      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)-                                  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-  where-    pred = ctEvPred ev--canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))-  = canForAll ev pend_sc--canonicalize (CIrredCan { cc_ev = ev, cc_status = status })-  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)-  = -- For insolubles (all of which are equalities, do /not/ flatten the arguments-    -- In #14350 doing so led entire-unnecessary and ridiculously large-    -- type function expansion.  Instead, canEqNC just applies-    -- the substitution to the predicate, and may do decomposition;-    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose-    canEqNC ev eq_rel ty1 ty2--  | otherwise-  = canIrred status ev--canonicalize (CDictCan { cc_ev = ev, cc_class  = cls-                       , cc_tyargs = xis, cc_pend_sc = pend_sc })-  = {-# SCC "canClass" #-}-    canClass ev cls xis pend_sc--canonicalize (CTyEqCan { cc_ev = ev-                       , cc_tyvar  = tv-                       , cc_rhs    = xi-                       , cc_eq_rel = eq_rel })-  = {-# SCC "canEqLeafTyVarEq" #-}-    canEqNC ev eq_rel (mkTyVarTy tv) xi-      -- NB: Don't use canEqTyVar because that expects flattened types,-      -- and tv and xi may not be flat w.r.t. an updated inert set--canonicalize (CFunEqCan { cc_ev = ev-                        , cc_fun    = fn-                        , cc_tyargs = xis1-                        , cc_fsk    = fsk })-  = {-# SCC "canEqLeafFunEq" #-}-    canCFunEqCan ev fn xis1 fsk--{--************************************************************************-*                                                                      *-*                      Class Canonicalization-*                                                                      *-************************************************************************--}--canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)--- "NC" means "non-canonical"; that is, we have got here--- from a NonCanonical constraint, not from a CDictCan--- Precondition: EvVar is class evidence-canClassNC ev cls tys-  | isGiven ev  -- See Note [Eagerly expand given superclasses]-  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys-       ; emitWork sc_cts-       ; canClass ev cls tys False }--  | isWanted ev-  , Just ip_name <- isCallStackPred cls tys-  , OccurrenceOf func <- ctLocOrigin loc-  -- If we're given a CallStack constraint that arose from a function-  -- call, we need to push the current call-site onto the stack instead-  -- of solving it directly from a given.-  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence-  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad-  = do { -- First we emit a new constraint that will capture the-         -- given CallStack.-       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))-                            -- We change the origin to IPOccOrigin so-                            -- this rule does not fire again.-                            -- See Note [Overview of implicit CallStacks]--       ; new_ev <- newWantedEvVarNC new_loc pred--         -- Then we solve the wanted by pushing the call-site-         -- onto the newly emitted CallStack-       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)-       ; solveCallStack ev ev_cs--       ; canClass new_ev cls tys False }--  | otherwise-  = canClass ev cls tys (has_scs cls)--  where-    has_scs cls = not (null (classSCTheta cls))-    loc  = ctEvLoc ev-    pred = ctEvPred ev--solveCallStack :: CtEvidence -> EvCallStack -> TcS ()--- Also called from GHC.Tc.Solver when defaulting call stacks-solveCallStack ev ev_cs = do-  -- We're given ev_cs :: CallStack, but the evidence term should be a-  -- dictionary, so we have to coerce ev_cs to a dictionary for-  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]-  cs_tm <- evCallStack ev_cs-  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))-  setEvBindIfWanted ev ev_tm--canClass :: CtEvidence-         -> Class -> [Type]-         -> Bool            -- True <=> un-explored superclasses-         -> TcS (StopOrContinue Ct)--- Precondition: EvVar is class evidence--canClass ev cls tys pend_sc-  =   -- all classes do *nominal* matching-    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )-    do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys-       ; MASSERT( isTcReflCo _kind_co )-       ; let co = mkTcTyConAppCo Nominal cls_tc cos-             xi = mkClassPred cls xis-             mk_ct new_ev = CDictCan { cc_ev = new_ev-                                     , cc_tyargs = xis-                                     , cc_class = cls-                                     , cc_pend_sc = pend_sc }-       ; mb <- rewriteEvidence ev xi co-       ; traceTcS "canClass" (vcat [ ppr ev-                                   , ppr xi, ppr mb ])-       ; return (fmap mk_ct mb) }-  where-    cls_tc = classTyCon cls--{- Note [The superclass story]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to add superclass constraints for two reasons:--* For givens [G], they give us a route to proof.  E.g.-    f :: Ord a => a -> Bool-    f x = x == x-  We get a Wanted (Eq a), which can only be solved from the superclass-  of the Given (Ord a).--* For wanteds [W], and deriveds [WD], [D], they may give useful-  functional dependencies.  E.g.-     class C a b | a -> b where ...-     class C a b => D a b where ...-  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass-  and that might tell us about beta, via C's fundeps.  We can get this-  by generating a [D] (C Int beta) constraint.  It's derived because-  we don't actually have to cough up any evidence for it; it's only there-  to generate fundep equalities.--See Note [Why adding superclasses can help].--For these reasons we want to generate superclass constraints for both-Givens and Wanteds. But:--* (Minor) they are often not needed, so generating them aggressively-  is a waste of time.--* (Major) if we want recursive superclasses, there would be an infinite-  number of them.  Here is a real-life example (#10318);--     class (Frac (Frac a) ~ Frac a,-            Fractional (Frac a),-            IntegralDomain (Frac a))-         => IntegralDomain a where-      type Frac a :: *--  Notice that IntegralDomain has an associated type Frac, and one-  of IntegralDomain's superclasses is another IntegralDomain constraint.--So here's the plan:--1. Eagerly generate superclasses for given (but not wanted)-   constraints; see Note [Eagerly expand given superclasses].-   This is done using mkStrictSuperClasses in canClassNC, when-   we take a non-canonical Given constraint and cannonicalise it.--   However stop if you encounter the same class twice.  That is,-   mkStrictSuperClasses expands eagerly, but has a conservative-   termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType.--2. Solve the wanteds as usual, but do no further expansion of-   superclasses for canonical CDictCans in solveSimpleGivens or-   solveSimpleWanteds; Note [Danger of adding superclasses during solving]--   However, /do/ continue to eagerly expand superclasses for new /given/-   /non-canonical/ constraints (canClassNC does this).  As #12175-   showed, a type-family application can expand to a class constraint,-   and we want to see its superclasses for just the same reason as-   Note [Eagerly expand given superclasses].--3. If we have any remaining unsolved wanteds-        (see Note [When superclasses help] in GHC.Tc.Types.Constraint)-   try harder: take both the Givens and Wanteds, and expand-   superclasses again.  See the calls to expandSuperClasses in-   GHC.Tc.Solver.simpl_loop and solveWanteds.--   This may succeed in generating (a finite number of) extra Givens,-   and extra Deriveds. Both may help the proof.--3a An important wrinkle: only expand Givens from the current level.-   Two reasons:-      - We only want to expand it once, and that is best done at-        the level it is bound, rather than repeatedly at the leaves-        of the implication tree-      - We may be inside a type where we can't create term-level-        evidence anyway, so we can't superclass-expand, say,-        (a ~ b) to get (a ~# b).  This happened in #15290.--4. Go round to (2) again.  This loop (2,3,4) is implemented-   in GHC.Tc.Solver.simpl_loop.--The cc_pend_sc flag in a CDictCan records whether the superclasses of-this constraint have been expanded.  Specifically, in Step 3 we only-expand superclasses for constraints with cc_pend_sc set to true (i.e.-isPendingScDict holds).--Why do we do this?  Two reasons:--* To avoid repeated work, by repeatedly expanding the superclasses of-  same constraint,--* To terminate the above loop, at least in the -XNoRecursiveSuperClasses-  case.  If there are recursive superclasses we could, in principle,-  expand forever, always encountering new constraints.--When we take a CNonCanonical or CIrredCan, but end up classifying it-as a CDictCan, we set the cc_pend_sc flag to False.--Note [Superclass loops]-~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  class C a => D a-  class D a => C a--Then, when we expand superclasses, we'll get back to the self-same-predicate, so we have reached a fixpoint in expansion and there is no-point in fruitlessly expanding further.  This case just falls out from-our strategy.  Consider-  f :: C a => a -> Bool-  f x = x==x-Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses-G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)-When processing d3 we find a match with d1 in the inert set, and we always-keep the inert item (d1) if possible: see Note [Replacement vs keeping] in-GHC.Tc.Solver.Interact.  So d3 dies a quick, happy death.--Note [Eagerly expand given superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In step (1) of Note [The superclass story], why do we eagerly expand-Given superclasses by one layer?  (By "one layer" we mean expand transitively-until you meet the same class again -- the conservative criterion embodied-in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)-We do this eagerly for Givens mainly because of some very obscure-cases like this:--   instance Bad a => Eq (T a)--   f :: (Ord (T a)) => blah-   f x = ....needs Eq (T a), Ord (T a)....--Here if we can't satisfy (Eq (T a)) from the givens we'll use the-instance declaration; but then we are stuck with (Bad a).  Sigh.-This is really a case of non-confluent proofs, but to stop our users-complaining we expand one layer in advance.--Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.--We also want to do this if we have--   f :: F (T a) => blah--where-   type instance F (T a) = Ord (T a)--So we may need to do a little work on the givens to expose the-class that has the superclasses.  That's why the superclass-expansion for Givens happens in canClassNC.--This same scenario happens with quantified constraints, whose superclasses-are also eagerly expanded. Test case: typecheck/should_compile/T16502b-These are handled in canForAllNC, analogously to canClassNC.--Note [Why adding superclasses can help]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Examples of how adding superclasses can help:--    --- Example 1-        class C a b | a -> b-    Suppose we want to solve-         [G] C a b-         [W] C a beta-    Then adding [D] beta~b will let us solve it.--    -- Example 2 (similar but using a type-equality superclass)-        class (F a ~ b) => C a b-    And try to sllve:-         [G] C a b-         [W] C a beta-    Follow the superclass rules to add-         [G] F a ~ b-         [D] F a ~ beta-    Now we get [D] beta ~ b, and can solve that.--    -- Example (tcfail138)-      class L a b | a -> b-      class (G a, L a b) => C a b--      instance C a b' => G (Maybe a)-      instance C a b  => C (Maybe a) a-      instance L (Maybe a) a--    When solving the superclasses of the (C (Maybe a) a) instance, we get-      [G] C a b, and hance by superclasses, [G] G a, [G] L a b-      [W] G (Maybe a)-    Use the instance decl to get-      [W] C a beta-    Generate its derived superclass-      [D] L a beta.  Now using fundeps, combine with [G] L a b to get-      [D] beta ~ b-    which is what we want.--Note [Danger of adding superclasses during solving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Here's a serious, but now out-dated example, from #4497:--   class Num (RealOf t) => Normed t-   type family RealOf x--Assume the generated wanted constraint is:-   [W] RealOf e ~ e-   [W] Normed e--If we were to be adding the superclasses during simplification we'd get:-   [W] RealOf e ~ e-   [W] Normed e-   [D] RealOf e ~ fuv-   [D] Num fuv-==>-   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv--While looks exactly like our original constraint. If we add the-superclass of (Normed fuv) again we'd loop.  By adding superclasses-definitely only once, during canonicalisation, this situation can't-happen.--Mind you, now that Wanteds cannot rewrite Derived, I think this particular-situation can't happen.--Note [Nested quantified constraint superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (typecheck/should_compile/T17202)--  class C1 a-  class (forall c. C1 c) => C2 a-  class (forall b. (b ~ F a) => C2 a) => C3 a--Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass-to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a-superclass, as well. But we now must be careful: we cannot just add-(forall c. C1 c) as a Given, because we need to remember g2's context.-That new constraint is Given only when forall b. (b ~ F a) is true.--It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c),-but that's problematic, because it's nested, and ForAllPred is not capable-of representing a nested quantified constraint. (We could change ForAllPred-to allow this, but the solution in this Note is much more local and simpler.)--So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c).--More generally, if we are expanding the superclasses of-  g0 :: forall tvs. theta => cls tys-and find a superclass constraint-  forall sc_tvs. sc_theta => sc_inner_pred-we must have a selector-  sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred-and thus build-  g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred-  g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids.-         sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids--Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the-last bound variables and the last arguments. This avoids the need to produce-the sc_theta_ids at all. So our final construction is--  g_sc = /\ tvs. /\ sc_tvs. \ theta_ids.-         sel_id tys (g0 tvs theta_ids) sc_tvs--  -}--makeSuperClasses :: [Ct] -> TcS [Ct]--- Returns strict superclasses, transitively, see Note [The superclasses story]--- See Note [The superclass story]--- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType--- Specifically, for an incoming (C t) constraint, we return all of (C t)'s---    superclasses, up to /and including/ the first repetition of C------ Example:  class D a => C a---           class C [a] => D a--- makeSuperClasses (C x) will return (D x, C [x])------ NB: the incoming constraints have had their cc_pend_sc flag already---     flipped to False, by isPendingScDict, so we are /obliged/ to at---     least produce the immediate superclasses-makeSuperClasses cts = concatMapM go cts-  where-    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })-      = mkStrictSuperClasses ev [] [] cls tys-    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))-      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have-                                               -- class pred heads-        mkStrictSuperClasses ev tvs theta cls tys-      where-        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)-    go ct = pprPanic "makeSuperClasses" (ppr ct)--mkStrictSuperClasses-    :: CtEvidence-    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking-                             -- superclasses of a /quantified/ constraint-    -> Class -> [Type] -> TcS [Ct]--- Return constraints for the strict superclasses of---   ev :: forall as. theta => cls tys-mkStrictSuperClasses ev tvs theta cls tys-  = mk_strict_superclasses (unitNameSet (className cls))-                           ev tvs theta cls tys--mk_strict_superclasses :: NameSet -> CtEvidence-                       -> [TyVar] -> ThetaType-                       -> Class -> [Type] -> TcS [Ct]--- Always return the immediate superclasses of (cls tys);--- and expand their superclasses, provided none of them are in rec_clss--- nor are repeated-mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })-                       tvs theta cls tys-  = concatMapM (do_one_given (mk_given_loc loc)) $-    classSCSelIds cls-  where-    dict_ids  = mkTemplateLocals theta-    size      = sizeTypes tys--    do_one_given given_loc sel_id-      | isUnliftedType sc_pred-      , not (null tvs && null theta)-      = -- See Note [Equality superclasses in quantified constraints]-        return []-      | otherwise-      = do { given_ev <- newGivenEvVar given_loc $-                         mk_given_desc sel_id sc_pred-           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }-      where-        sc_pred = classMethodInstTy sel_id tys--      -- See Note [Nested quantified constraint superclasses]-    mk_given_desc :: Id -> PredType -> (PredType, EvTerm)-    mk_given_desc sel_id sc_pred-      = (swizzled_pred, swizzled_evterm)-      where-        (sc_tvs, sc_rho)          = splitForAllTys sc_pred-        (sc_theta, sc_inner_pred) = splitFunTys sc_rho--        all_tvs       = tvs `chkAppend` sc_tvs-        all_theta     = theta `chkAppend` (map scaledThing sc_theta)-        swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred--        -- evar :: forall tvs. theta => cls tys-        -- sel_id :: forall cls_tvs. cls cls_tvs-        --                        -> forall sc_tvs. sc_theta => sc_inner_pred-        -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred-        swizzled_evterm = EvExpr $-          mkLams all_tvs $-          mkLams dict_ids $-          Var sel_id-            `mkTyApps` tys-            `App` (evId evar `mkVarApps` (tvs ++ dict_ids))-            `mkVarApps` sc_tvs--    mk_given_loc loc-       | isCTupleClass cls-       = loc   -- For tuple predicates, just take them apart, without-               -- adding their (large) size into the chain.  When we-               -- get down to a base predicate, we'll include its size.-               -- #10335--       | GivenOrigin skol_info <- ctLocOrigin loc-         -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance-         -- for explantation of this transformation for givens-       = case skol_info of-            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }-            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }-            _        -> loc--       | otherwise  -- Probably doesn't happen, since this function-       = loc        -- is only used for Givens, but does no harm--mk_strict_superclasses rec_clss ev tvs theta cls tys-  | all noFreeVarsOfType tys-  = return [] -- Wanteds with no variables yield no deriveds.-              -- See Note [Improvement from Ground Wanteds]--  | otherwise -- Wanted/Derived case, just add Derived superclasses-              -- that can lead to improvement.-  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )-    concatMapM do_one_derived (immSuperClasses cls tys)-  where-    loc = ctEvLoc ev--    do_one_derived sc_pred-      = do { sc_ev <- newDerivedNC loc sc_pred-           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }--{- Note [Improvement from Ground Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose class C b a => D a b-and consider-  [W] D Int Bool-Is there any point in emitting [D] C Bool Int?  No!  The only point of-emitting superclass constraints for W/D constraints is to get-improvement, extra unifications that result from functional-dependencies.  See Note [Why adding superclasses can help] above.--But no variables means no improvement; case closed.--}--mk_superclasses :: NameSet -> CtEvidence-                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]--- Return this constraint, plus its superclasses, if any-mk_superclasses rec_clss ev tvs theta pred-  | ClassPred cls tys <- classifyPredType pred-  = mk_superclasses_of rec_clss ev tvs theta cls tys--  | otherwise   -- Superclass is not a class predicate-  = return [mkNonCanonical ev]--mk_superclasses_of :: NameSet -> CtEvidence-                   -> [TyVar] -> ThetaType -> Class -> [Type]-                   -> TcS [Ct]--- Always return this class constraint,--- and expand its superclasses-mk_superclasses_of rec_clss ev tvs theta cls tys-  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)-                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True-  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys-                                                          , ppr (isCTupleClass cls)-                                                          , ppr rec_clss-                                                          ])-                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys-                    ; return (this_ct : sc_cts) }-                                   -- cc_pend_sc of this_ct = False-  where-    cls_nm     = className cls-    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss-                 -- Tuples never contribute to recursion, and can be nested-    rec_clss'  = rec_clss `extendNameSet` cls_nm--    this_ct | null tvs, null theta-            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys-                       , cc_pend_sc = loop_found }-                 -- NB: If there is a loop, we cut off, so we have not-                 --     added the superclasses, hence cc_pend_sc = True-            | otherwise-            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys-                             , qci_ev = ev-                             , qci_pend_sc = loop_found })---{- Note [Equality superclasses in quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider (#15359, #15593, #15625)-  f :: (forall a. theta => a ~ b) => stuff--It's a bit odd to have a local, quantified constraint for `(a~b)`,-but some people want such a thing (see the tickets). And for-Coercible it is definitely useful-  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))-                 => stuff--Moreover it's not hard to arrange; we just need to look up /equality/-constraints in the quantified-constraint environment, which we do in-GHC.Tc.Solver.Interact.doTopReactOther.--There is a wrinkle though, in the case where 'theta' is empty, so-we have-  f :: (forall a. a~b) => stuff--Now, potentially, the superclass machinery kicks in, in-makeSuperClasses, giving us a a second quantified constraint-       (forall a. a ~# b)-BUT this is an unboxed value!  And nothing has prepared us for-dictionary "functions" that are unboxed.  Actually it does just-about work, but the simplifier ends up with stuff like-   case (/\a. eq_sel d) of df -> ...(df @Int)...-and fails to simplify that any further.  And it doesn't satisfy-isPredTy any more.--So for now we simply decline to take superclasses in the quantified-case.  Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther,-which looks for primitive equalities specially in the quantified-constraints.--See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.---************************************************************************-*                                                                      *-*                      Irreducibles canonicalization-*                                                                      *-************************************************************************--}--canIrred :: CtIrredStatus -> CtEvidence -> TcS (StopOrContinue Ct)--- Precondition: ty not a tuple and no other evidence form-canIrred status ev-  = do { let pred = ctEvPred ev-       ; 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-       ; 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 $-                                    mkIrredCt status new_ev } }--{- *********************************************************************-*                                                                      *-*                      Quantified predicates-*                                                                      *-********************************************************************* -}--{- Note [Quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The -XQuantifiedConstraints extension allows type-class contexts like this:--  data Rose f x = Rose x (f (Rose f x))--  instance (Eq a, forall b. Eq b => Eq (f b))-        => Eq (Rose f a)  where-    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2--Note the (forall b. Eq b => Eq (f b)) in the instance contexts.-This quantified constraint is needed to solve the- [W] (Eq (f (Rose f x)))-constraint which arises form the (==) definition.--The wiki page is-  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints-which in turn contains a link to the GHC Proposal where the change-is specified, and a Haskell Symposium paper about it.--We implement two main extensions to the design in the paper:-- 1. We allow a variable in the instance head, e.g.-      f :: forall m a. (forall b. m b) => D (m a)-    Notice the 'm' in the head of the quantified constraint, not-    a class.-- 2. We support superclasses to quantified constraints.-    For example (contrived):-      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool-      f x y = x==y-    Here we need (Eq (m a)); but the quantified constraint deals only-    with Ord.  But we can make it work by using its superclass.--Here are the moving parts-  * Language extension {-# LANGUAGE QuantifiedConstraints #-}-    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension--  * A new form of evidence, EvDFun, that is used to discharge-    such wanted constraints--  * checkValidType gets some changes to accept forall-constraints-    only in the right places.--  * Predicate.Pred gets a new constructor ForAllPred, and-    and classifyPredType analyses a PredType to decompose-    the new forall-constraints--  * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts,-    which holds all the Given forall-constraints.  In effect,-    such Given constraints are like local instance decls.--  * When trying to solve a class constraint, via-    GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts-    so that we include the local Given forall-constraints-    in the lookup.  (See GHC.Tc.Solver.Monad.getInstEnvs.)--  * GHC.Tc.Solver.Canonical.canForAll deals with solving a-    forall-constraint.  See-       Note [Solving a Wanted forall-constraint]--  * We augment the kick-out code to kick out an inert-    forall constraint if it can be rewritten by a new-    type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable--Note that a quantified constraint is never /inferred/-(by GHC.Tc.Solver.simplifyInfer).  A function can only have a-quantified constraint in its type if it is given an explicit-type signature.---}--canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType-            -> TcS (StopOrContinue Ct)-canForAllNC ev tvs theta pred-  | isGiven ev  -- See Note [Eagerly expand given superclasses]-  , Just (cls, tys) <- cls_pred_tys_maybe-  = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys-       ; emitWork sc_cts-       ; canForAll ev False }--  | otherwise-  = canForAll ev (isJust cls_pred_tys_maybe)--  where-    cls_pred_tys_maybe = getClassPredTys_maybe pred--canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)--- We have a constraint (forall as. blah => C tys)-canForAll ev pend_sc-  = do { -- First rewrite it to apply the current substitution-         -- Do not bother with type-family reductions; we can't-         -- do them under a forall anyway (c.f. Flatten.flatten_one-         -- on a forall type)-         let pred = ctEvPred ev-       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred-       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->--    do { -- Now decompose into its pieces and solve it-         -- (It takes a lot less code to flatten before decomposing.)-       ; case classifyPredType (ctEvPred new_ev) of-           ForAllPred tvs theta pred-              -> solveForAll new_ev tvs theta pred pend_sc-           _  -> pprPanic "canForAll" (ppr new_ev)-    } }--solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool-            -> TcS (StopOrContinue Ct)-solveForAll ev tvs theta pred pend_sc-  | CtWanted { ctev_dest = dest } <- ev-  = -- See Note [Solving a Wanted forall-constraint]-    do { let skol_info = QuantCtxtSkol-             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $-                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs-       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs-       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)--       ; (lvl, (w_id, wanteds))-             <- pushLevelNoWorkList (ppr skol_info) $-                do { wanted_ev <- newWantedEvVarNC loc $-                                  substTy subst pred-                   ; return ( ctEvEvId wanted_ev-                            , unitBag (mkNonCanonical wanted_ev)) }--      ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs-                                       given_ev_vars wanteds--      ; setWantedEvTerm dest $-        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars-              , et_binds = ev_binds, et_body = w_id }--      ; stopWith ev "Wanted forall-constraint" }--  | isGiven ev   -- See Note [Solving a Given forall-constraint]-  = do { addInertForAll qci-       ; stopWith ev "Given forall-constraint" }--  | otherwise-  = do { traceTcS "discarding derived forall-constraint" (ppr ev)-       ; stopWith ev "Derived forall-constraint" }-  where-    loc = ctEvLoc ev-    qci = QCI { qci_ev = ev, qci_tvs = tvs-              , qci_pred = pred, qci_pend_sc = pend_sc }--{- Note [Solving a Wanted forall-constraint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Solving a wanted forall (quantified) constraint-  [W] df :: forall ab. (Eq a, Ord b) => C x a b-is delightfully easy.   Just build an implication constraint-    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a-and discharge df thus:-    df = /\ab. \g1 g2. let <binds> in d-where <binds> is filled in by solving the implication constraint.-All the machinery is to hand; there is little to do.--Note [Solving a Given forall-constraint]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For a Given constraint-  [G] df :: forall ab. (Eq a, Ord b) => C x a b-we just add it to TcS's local InstEnv of known instances,-via addInertForall.  Then, if we look up (C x Int Bool), say,-we'll find a match in the InstEnv.---************************************************************************-*                                                                      *-*        Equalities-*                                                                      *-************************************************************************--Note [Canonicalising equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In order to canonicalise an equality, we look at the structure of the-two types at hand, looking for similarities. A difficulty is that the-types may look dissimilar before flattening but similar after flattening.-However, we don't just want to jump in and flatten right away, because-this might be wasted effort. So, after looking for similarities and failing,-we flatten and then try again. Of course, we don't want to loop, so we-track whether or not we've already flattened.--It is conceivable to do a better job at tracking whether or not a type-is flattened, but this is left as future work. (Mar '15)---Note [Decomposing FunTy]-~~~~~~~~~~~~~~~~~~~~~~~~-can_eq_nc' may attempt to decompose a FunTy that is un-zonked.  This-means that we may very well have a FunTy containing a type of some-unknown kind. For instance, we may have,--    FunTy (a :: k) Int--Where k is a unification variable. So the calls to getRuntimeRep_maybe may-fail (returning Nothing).  In that case we'll fall through, zonk, and try again.-Zonking should fill the variable k, meaning that decomposition will succeed the-second time around.--Also note that we require the AnonArgFlag to match.  This will stop-us decomposing-   (Int -> Bool)  ~  (Show a => blah)-It's as if we treat (->) and (=>) as different type constructors.--}--canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)-canEqNC ev eq_rel ty1 ty2-  = do { result <- zonk_eq_types ty1 ty2-       ; case result of-           Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2-           Right ty              -> canEqReflexive ev eq_rel ty }--can_eq_nc-   :: Bool            -- True => both types are flat-   -> CtEvidence-   -> EqRel-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp-   -> TcS (StopOrContinue Ct)-can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2-  = do { traceTcS "can_eq_nc" $-         vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]-       ; rdr_env <- getGlobalRdrEnvTcS-       ; fam_insts <- getFamInstEnvs-       ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }--can_eq_nc'-   :: Bool           -- True => both input types are flattened-   -> GlobalRdrEnv   -- needed to see which newtypes are in scope-   -> FamInstEnvs    -- needed to unwrap data instances-   -> CtEvidence-   -> EqRel-   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp-   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp-   -> TcS (StopOrContinue Ct)---- Expand synonyms first; see Note [Type synonyms and canonicalization]-can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2-  | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2-  | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2---- need to check for reflexivity in the ReprEq case.--- See Note [Eager reflexivity check]--- Check only when flat because the zonk_eq_types check in canEqNC takes--- care of the non-flat case.-can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _-  | ty1 `tcEqType` ty2-  = canEqReflexive ev ReprEq ty1---- When working with ReprEq, unwrap newtypes.--- See Note [Unwrap newtypes first]--- This must be above the TyVarTy case, in order to guarantee (TyEq:N)-can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2-  | ReprEq <- eq_rel-  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1-  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2--  | ReprEq <- eq_rel-  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2-  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1---- Then, get rid of casts-can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2-  | not (isTyVarTy ty2)  -- See (3) in Note [Equalities with incompatible kinds]-  = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2-can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _-  | not (isTyVarTy ty1)  -- See (3) in Note [Equalities with incompatible kinds]-  = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1---- NB: pattern match on True: we want only flat types sent to canEqTyVar.--- See also Note [No top-level newtypes on RHS of representational equalities]-can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2-  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2-  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1--------------------------- Otherwise try to decompose--------------------------- Literals-can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _- | l1 == l2-  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)-       ; stopWith ev "Equal LitTy" }---- Decompose FunTy: (s -> t) and (c => t)--- NB: don't decompose (Int -> blah) ~ (Show a => blah)-can_eq_nc' _flat _rdr_env _envs ev eq_rel-           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _-           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _-  | af1 == af2   -- Don't decompose (Int -> blah) ~ (Show a => blah)-  , Just ty1a_rep <- getRuntimeRep_maybe ty1a  -- getRutimeRep_maybe:-  , Just ty1b_rep <- getRuntimeRep_maybe ty1b  -- see Note [Decomposing FunTy]-  , Just ty2a_rep <- getRuntimeRep_maybe ty2a-  , Just ty2b_rep <- getRuntimeRep_maybe ty2b-  = canDecomposableTyConAppOK ev eq_rel funTyCon-                              [am1, ty1a_rep, ty1b_rep, ty1a, ty1b]-                              [am2, ty2a_rep, ty2b_rep, ty2a, ty2b]---- Decompose type constructor applications--- NB: e have expanded type synonyms already-can_eq_nc' _flat _rdr_env _envs ev eq_rel-           (TyConApp tc1 tys1) _-           (TyConApp tc2 tys2) _-  | not (isTypeFamilyTyCon tc1)-  , not (isTypeFamilyTyCon tc2)-  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2--can_eq_nc' _flat _rdr_env _envs ev eq_rel-           s1@(ForAllTy {}) _ s2@(ForAllTy {}) _-  = can_eq_nc_forall ev eq_rel s1 s2---- See Note [Canonicalising type applications] about why we require flat types-can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _-  | NomEq <- eq_rel-  , Just (t2, s2) <- tcSplitAppTy_maybe ty2-  = can_eq_app ev t1 s1 t2 s2-can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _-  | NomEq <- eq_rel-  , Just (t1, s1) <- tcSplitAppTy_maybe ty1-  = can_eq_app ev t1 s1 t2 s2---- No similarity in type structure detected. Flatten and try again.-can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2-  = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1-       ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2-       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2-       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }---- We've flattened and the types don't match. Give up.-can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2-  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)-       ; case eq_rel of -- See Note [Unsolved equalities]-            ReprEq -> continueWith (mkIrredCt OtherCIS ev)-            NomEq  -> continueWith (mkIrredCt InsolubleCIS ev) }-          -- No need to call canEqFailure/canEqHardFailure because they-          -- flatten, and the types involved here are already flat--{- Note [Unsolved equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an unsolved equality like-  (a b ~R# Int)-that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.-So we want to make it a potentially-soluble Irred not an insoluble one.-Missing this point is what caused #15431--}------------------------------------can_eq_nc_forall :: CtEvidence -> EqRel-                 -> Type -> Type    -- LHS and RHS-                 -> TcS (StopOrContinue Ct)--- (forall as. phi1) ~ (forall bs. phi2)--- Check for length match of as, bs--- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]--- But remember also to unify the kinds of as and bs---  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]--- Remember also that we might have forall z (a:z). blah---  so we must proceed one binder at a time (#13879)--can_eq_nc_forall ev eq_rel s1 s2- | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev- = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]-            (bndrs1, phi1) = tcSplitForAllVarBndrs s1-            (bndrs2, phi2) = tcSplitForAllVarBndrs s2-      ; if not (equalLength bndrs1 bndrs2)-        then do { traceTcS "Forall failure" $-                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2-                          , ppr (map binderArgFlag bndrs1)-                          , ppr (map binderArgFlag bndrs2) ]-                ; canEqHardFailure ev s1 s2 }-        else-   do { traceTcS "Creating implication for polytype equality" $ ppr ev-      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs-      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $-                              binderVars bndrs1--      ; let skol_info = UnifyForAllSkol phi1-            phi1' = substTy subst1 phi1--            -- Unify the kinds, extend the substitution-            go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]-               -> TcS (TcCoercion, Cts)-            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)-              = do { let tv2 = binderVar bndr2-                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)-                                                  (substTy subst (tyVarKind tv2))-                   ; let subst' = extendTvSubstAndInScope subst tv2-                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)-                         -- skol_tv is already in the in-scope set, but the-                         -- free vars of kind_co are not; hence "...AndInScope"-                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2-                   ; return ( mkTcForAllCo skol_tv kind_co co-                            , wanteds1 `unionBags` wanteds2 ) }--            -- Done: unify phi1 ~ phi2-            go [] subst bndrs2-              = ASSERT( null bndrs2 )-                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)--            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []--            empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)--      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $-                                    go skol_tvs empty_subst2 bndrs2-      ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds--      ; setWantedEq orig_dest all_co-      ; stopWith ev "Deferred polytype equality" } }-- | otherwise- = do { traceTcS "Omitting decomposition of given polytype equality" $-        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]-      ; stopWith ev "Discard given polytype equality" }-- where-    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)-    -- This version returns the wanted constraint rather-    -- than putting it in the work list-    unify loc role ty1 ty2-      | ty1 `tcEqType` ty2-      = return (mkTcReflCo role ty1, emptyBag)-      | otherwise-      = do { (wanted, co) <- newWantedEq loc role ty1 ty2-           ; return (co, unitBag (mkNonCanonical wanted)) }-------------------------------------- | Compare types for equality, while zonking as necessary. Gives up--- as soon as it finds that two types are not equal.--- This is quite handy when some unification has made two--- types in an inert Wanted to be equal. We can discover the equality without--- flattening, which is sometimes very expensive (in the case of type functions).--- In particular, this function makes a ~20% improvement in test case--- perf/compiler/T5030.------ Returns either the (partially zonked) types in the case of--- inequality, or the one type in the case of equality. canEqReflexive is--- a good next step in the 'Right' case. Returning 'Left' is always safe.------ NB: This does *not* look through type synonyms. In fact, it treats type--- synonyms as rigid constructors. In the future, it might be convenient--- to look at only those arguments of type synonyms that actually appear--- in the synonym RHS. But we're not there yet.-zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)-zonk_eq_types = go-  where-    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2-    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2-    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1--    -- We handle FunTys explicitly here despite the fact that they could also be-    -- treated as an application. Why? Well, for one it's cheaper to just look-    -- at two types (the argument and result types) than four (the argument,-    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,-    -- so we may run into an unzonked type variable while trying to compute the-    -- RuntimeReps of the argument and result types. This can be observed in-    -- testcase tc269.-    go ty1 ty2-      | Just (Scaled w1 arg1, res1) <- split1-      , Just (Scaled w2 arg2, res2) <- split2-      , eqType w1 w2-      = do { res_a <- go arg1 arg2-           ; res_b <- go res1 res2-           ; return $ combine_rev (mkVisFunTy w1) res_b res_a-           }-      | isJust split1 || isJust split2-      = bale_out ty1 ty2-      where-        split1 = tcSplitFunTy_maybe ty1-        split2 = tcSplitFunTy_maybe ty2--    go ty1 ty2-      | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1-      , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2-      = if tc1 == tc2 && tys1 `equalLength` tys2-          -- Crucial to check for equal-length args, because-          -- we cannot assume that the two args to 'go' have-          -- the same kind.  E.g go (Proxy *      (Maybe Int))-          --                        (Proxy (*->*) Maybe)-          -- We'll call (go (Maybe Int) Maybe)-          -- See #13083-        then tycon tc1 tys1 tys2-        else bale_out ty1 ty2--    go ty1 ty2-      | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1-      , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2-      = do { res_a <- go ty1a ty2a-           ; res_b <- go ty1b ty2b-           ; return $ combine_rev mkAppTy res_b res_a }--    go ty1@(LitTy lit1) (LitTy lit2)-      | lit1 == lit2-      = return (Right ty1)--    go ty1 ty2 = bale_out ty1 ty2-      -- We don't handle more complex forms here--    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)--    tyvar :: SwapFlag -> TcTyVar -> TcType-          -> TcS (Either (Pair TcType) TcType)-      -- Try to do as little as possible, as anything we do here is redundant-      -- with flattening. In particular, no need to zonk kinds. That's why-      -- we don't use the already-defined zonking functions-    tyvar swapped tv ty-      = case tcTyVarDetails tv of-          MetaTv { mtv_ref = ref }-            -> do { cts <- readTcRef ref-                  ; case cts of-                      Flexi        -> give_up-                      Indirect ty' -> do { trace_indirect tv ty'-                                         ; unSwap swapped go ty' ty } }-          _ -> give_up-      where-        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty--    tyvar_tyvar tv1 tv2-      | tv1 == tv2 = return (Right (mkTyVarTy tv1))-      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1-                        ; (ty2', progress2) <- quick_zonk tv2-                        ; if progress1 || progress2-                          then go ty1' ty2'-                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }--    trace_indirect tv ty-       = traceTcS "Following filled tyvar (zonk_eq_types)"-                  (ppr tv <+> equals <+> ppr ty)--    quick_zonk tv = case tcTyVarDetails tv of-      MetaTv { mtv_ref = ref }-        -> do { cts <- readTcRef ref-              ; case cts of-                  Flexi        -> return (TyVarTy tv, False)-                  Indirect ty' -> do { trace_indirect tv ty'-                                     ; return (ty', True) } }-      _ -> return (TyVarTy tv, False)--      -- This happens for type families, too. But recall that failure-      -- here just means to try harder, so it's OK if the type function-      -- isn't injective.-    tycon :: TyCon -> [TcType] -> [TcType]-          -> TcS (Either (Pair TcType) TcType)-    tycon tc tys1 tys2-      = do { results <- zipWithM go tys1 tys2-           ; return $ case combine_results results of-               Left tys  -> Left (mkTyConApp tc <$> tys)-               Right tys -> Right (mkTyConApp tc tys) }--    combine_results :: [Either (Pair TcType) TcType]-                    -> Either (Pair [TcType]) [TcType]-    combine_results = bimap (fmap reverse) reverse .-                      foldl' (combine_rev (:)) (Right [])--      -- combine (in reverse) a new result onto an already-combined result-    combine_rev :: (a -> b -> c)-                -> Either (Pair b) b-                -> Either (Pair a) a-                -> Either (Pair c) c-    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)-    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)-    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)-    combine_rev f (Right tys) (Right ty) = Right (f ty tys)--{- See Note [Unwrap newtypes first]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  newtype N m a = MkN (m a)-Then N will get a conservative, Nominal role for its second parameter 'a',-because it appears as an argument to the unknown 'm'. Now consider-  [W] N Maybe a  ~R#  N Maybe b--If we decompose, we'll get-  [W] a ~N# b--But if instead we unwrap we'll get-  [W] Maybe a ~R# Maybe b-which in turn gives us-  [W] a ~R# b-which is easier to satisfy.--Bottom line: unwrap newtypes before decomposing them!-c.f. #9123 comment:52,53 for a compelling example.--Note [Newtypes can blow the stack]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--  newtype X = MkX (Int -> X)-  newtype Y = MkY (Int -> Y)--and now wish to prove--  [W] X ~R Y--This Wanted will loop, expanding out the newtypes ever deeper looking-for a solid match or a solid discrepancy. Indeed, there is something-appropriate to this looping, because X and Y *do* have the same representation,-in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized-coercion will ever witness it. This loop won't actually cause GHC to hang,-though, because we check our depth when unwrapping newtypes.--Note [Eager reflexivity check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--  newtype X = MkX (Int -> X)--and--  [W] X ~R X--Naively, we would start unwrapping X and end up in a loop. Instead,-we do this eager reflexivity check. This is necessary only for representational-equality because the flattener technology deals with the similar case-(recursive type families) for nominal equality.--Note that this check does not catch all cases, but it will catch the cases-we're most worried about, types like X above that are actually inhabited.--Here's another place where this reflexivity check is key:-Consider trying to prove (f a) ~R (f a). The AppTys in there can't-be decomposed, because representational equality isn't congruent with respect-to AppTy. So, when canonicalising the equality above, we get stuck and-would normally produce a CIrredCan. However, we really do want to-be able to solve (f a) ~R (f a). So, in the representational case only,-we do a reflexivity check.--(This would be sound in the nominal case, but unnecessary, and I [Richard-E.] am worried that it would slow down the common case.)--}----------------------------- | We're able to unwrap a newtype. Update the bits accordingly.-can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2-                  -> SwapFlag-                  -> TcType                                    -- ^ ty1-                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'-                  -> TcType               -- ^ ty2-                  -> TcType               -- ^ ty2, with type synonyms-                  -> TcS (StopOrContinue Ct)-can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2-  = do { traceTcS "can_eq_newtype_nc" $-         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]--         -- check for blowing our stack:-         -- See Note [Newtypes can blow the stack]-       ; checkReductionDepth (ctEvLoc ev) ty1--         -- Next, we record uses of newtype constructors, since coercing-         -- through newtypes is tantamount to using their constructors.-       ; addUsedGREs gre_list-         -- If a newtype constructor was imported, don't warn about not-         -- importing it...-       ; traverse_ keepAlive $ map gre_name gre_list-         -- ...and similarly, if a newtype constructor was defined in the same-         -- module, don't warn about it being unused.-         -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.--       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2-                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)-       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }-  where-    gre_list = bagToList gres-------------- ^ Decompose a type application.--- All input types must be flat. See Note [Canonicalising type applications]--- Nominal equality only!-can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2-           -> Xi -> Xi         -- s1 t1-           -> Xi -> Xi         -- s2 t2-           -> TcS (StopOrContinue Ct)---- AppTys only decompose for nominal equality, so this case just leads--- to an irreducible constraint; see typecheck/should_compile/T10494--- See Note [Decomposing equality], note {4}-can_eq_app ev s1 t1 s2 t2-  | CtDerived {} <- ev-  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]-       ; stopWith ev "Decomposed [D] AppTy" }--  | CtWanted { ctev_dest = dest } <- ev-  = do { co_s <- unifyWanted loc Nominal s1 s2-       ; let arg_loc-               | isNextArgVisible s1 = loc-               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin-       ; co_t <- unifyWanted arg_loc Nominal t1 t2-       ; let co = mkAppCo co_s co_t-       ; setWantedEq dest co-       ; stopWith ev "Decomposed [W] AppTy" }--    -- If there is a ForAll/(->) mismatch, the use of the Left coercion-    -- below is ill-typed, potentially leading to a panic in splitTyConApp-    -- Test case: typecheck/should_run/Typeable1-    -- We could also include this mismatch check above (for W and D), but it's slow-    -- and we'll get a better error message not doing it-  | s1k `mismatches` s2k-  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)--  | CtGiven { ctev_evar = evar } <- ev-  = do { let co   = mkTcCoVarCo evar-             co_s = mkTcLRCo CLeft  co-             co_t = mkTcLRCo CRight co-       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2-                                     , evCoercion co_s )-       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2-                                     , evCoercion co_t )-       ; emitWorkNC [evar_t]-       ; canEqNC evar_s NomEq s1 s2 }--  where-    loc = ctEvLoc ev--    s1k = tcTypeKind s1-    s2k = tcTypeKind s2--    k1 `mismatches` k2-      =  isForAllTy k1 && not (isForAllTy k2)-      || not (isForAllTy k1) && isForAllTy k2---------------------------- | Break apart an equality over a casted type--- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)-canEqCast :: Bool         -- are both types flat?-          -> CtEvidence-          -> EqRel-          -> SwapFlag-          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1-          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty-          -> TcS (StopOrContinue Ct)-canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2-  = do { traceTcS "Decomposing cast" (vcat [ ppr ev-                                           , ppr ty1 <+> text "|>" <+> ppr co1-                                           , ppr ps_ty2 ])-       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2-                                     (mkTcGReflRightCo role ty1 co1)-                                     (mkTcReflCo role ps_ty2)-       ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }-  where-    role = eqRelRole eq_rel---------------------------canTyConApp :: CtEvidence -> EqRel-            -> TyCon -> [TcType]-            -> TyCon -> [TcType]-            -> TcS (StopOrContinue Ct)--- See Note [Decomposing TyConApps]--- Neither tc1 nor tc2 is a saturated funTyCon-canTyConApp ev eq_rel tc1 tys1 tc2 tys2-  | tc1 == tc2-  , tys1 `equalLength` tys2-  = do { inerts <- getTcSInerts-       ; if can_decompose inerts-         then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2-         else canEqFailure ev eq_rel ty1 ty2 }--  -- See Note [Skolem abstract data] (at tyConSkolem)-  | tyConSkolem tc1 || tyConSkolem tc2-  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)-       ; continueWith (mkIrredCt OtherCIS ev) }--  -- Fail straight away for better error messages-  -- See Note [Use canEqFailure in canDecomposableTyConApp]-  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&-                             isGenerativeTyCon tc2 Representational)-  = canEqFailure ev eq_rel ty1 ty2-  | otherwise-  = canEqHardFailure ev ty1 ty2-  where-    -- Reconstruct the types for error messages. This would do-    -- the wrong thing (from a pretty printing point of view)-    -- for functions, because we've lost the AnonArgFlag; but-    -- in fact we never call canTyConApp on a saturated FunTyCon-    ty1 = mkTyConApp tc1 tys1-    ty2 = mkTyConApp tc2 tys2--    loc  = ctEvLoc ev-    pred = ctEvPred ev--     -- See Note [Decomposing equality]-    can_decompose inerts-      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)-      || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))--{--Note [Use canEqFailure in canDecomposableTyConApp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must use canEqFailure, not canEqHardFailure here, because there is-the possibility of success if working with a representational equality.-Here is one case:--  type family TF a where TF Char = Bool-  data family DF a-  newtype instance DF Bool = MkDF Int--Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet-know `a`. This is *not* a hard failure, because we might soon learn-that `a` is, in fact, Char, and then the equality succeeds.--Here is another case:--  [G] Age ~R Int--where Age's constructor is not in scope. We don't want to report-an "inaccessible code" error in the context of this Given!--For example, see typecheck/should_compile/T10493, repeated here:--  import Data.Ord (Down)  -- no constructor--  foo :: Coercible (Down Int) Int => Down Int -> Int-  foo = coerce--That should compile, but only because we use canEqFailure and not-canEqHardFailure.--Note [Decomposing equality]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have a constraint (of any flavour and role) that looks like-T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,-of course, is "it depends". This Note spells it all out.--In this Note, "decomposition" refers to taking the constraint-  [fl] (T tys1 ~X T tys2)-(for some flavour fl and some role X) and replacing it with-  [fls'] (tys1 ~Xs' tys2)-where that notation indicates a list of new constraints, where the-new constraints may have different flavours and different roles.--The key property to consider is injectivity. When decomposing a Given the-decomposition is sound if and only if T is injective in all of its type-arguments. When decomposing a Wanted, the decomposition is sound (assuming the-correct roles in the produced equality constraints), but it may be a guess ---that is, an unforced decision by the constraint solver. Decomposing Wanteds-over injective TyCons does not entail guessing. But sometimes we want to-decompose a Wanted even when the TyCon involved is not injective! (See below.)--So, in broad strokes, we want this rule:--(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective-at role X.--Pursuing the details requires exploring three axes:-* Flavour: Given vs. Derived vs. Wanted-* Role: Nominal vs. Representational-* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable--(So a type variable isn't a TyCon, but it's convenient to put the AppTy case-in the same table.)--Right away, we can say that Derived behaves just as Wanted for the purposes-of decomposition. The difference between Derived and Wanted is the handling of-evidence. Since decomposition in these cases isn't a matter of soundness but of-guessing, we want the same behavior regardless of evidence.--Here is a table (discussion following) detailing where decomposition of-   (T s1 ... sn) ~r (T t1 .. tn)-is allowed.  The first four lines (Data types ... type family) refer-to TyConApps with various TyCons T; the last line is for AppTy, where-there is presumably a type variable at the head, so it's actually-   (s s1 ... sn) ~r (t t1 .. tn)--NOMINAL               GIVEN                       WANTED--Datatype               YES                         YES-Newtype                YES                         YES-Data family            YES                         YES-Type family            YES, in injective args{1}   YES, in injective args{1}-Type variable          YES                         YES--REPRESENTATIONAL      GIVEN                       WANTED--Datatype               YES                         YES-Newtype                NO{2}                      MAYBE{2}-Data family            NO{3}                      MAYBE{3}-Type family             NO                          NO-Type variable          NO{4}                       NO{4}--{1}: Type families can be injective in some, but not all, of their arguments,-so we want to do partial decomposition. This is quite different than the way-other decomposition is done, where the decomposed equalities replace the original-one. We thus proceed much like we do with superclasses: emitting new Givens-when "decomposing" a partially-injective type family Given and new Deriveds-when "decomposing" a partially-injective type family Wanted. (As of the time of-writing, 13 June 2015, the implementation of injective type families has not-been merged, but it should be soon. Please delete this parenthetical if the-implementation is indeed merged.)--{2}: See Note [Decomposing newtypes at representational role]--{3}: Because of the possibility of newtype instances, we must treat-data families like newtypes. See also Note [Decomposing newtypes at-representational role]. See #10534 and test case-typecheck/should_fail/T10534.--{4}: Because type variables can stand in for newtypes, we conservatively do not-decompose AppTys over representational equality.--In the implementation of can_eq_nc and friends, we don't directly pattern-match using lines like in the tables above, as those tables don't cover-all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,-boiling the tables above down to rule (*). The exceptions to rule (*) are for-injective type families, which are handled separately from other decompositions,-and the MAYBE entries above.--Note [Decomposing newtypes at representational role]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This note discusses the 'newtype' line in the REPRESENTATIONAL table-in Note [Decomposing equality]. (At nominal role, newtypes are fully-decomposable.)--Here is a representative example of why representational equality over-newtypes is tricky:--  newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,-  type role Nt representational  -- but the user gives it an R role anyway--If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to-[W] alpha ~R beta, because it's possible that alpha and beta aren't-representationally equal. Here's another example.--  newtype Nt a = MkNt (Id a)-  type family Id a where Id a = a--  [W] Nt Int ~R Nt Age--Because of its use of a type family, Nt's parameter will get inferred to have-a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which-is unsatisfiable. Unwrapping, though, leads to a solution.--Conclusion:- * Unwrap newtypes before attempting to decompose them.-   This is done in can_eq_nc'.--It all comes from the fact that newtypes aren't necessarily injective-w.r.t. representational equality.--Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use-NthCo on representational coercions over newtypes. NthCo comes into play-only when decomposing givens.--Conclusion:- * Do not decompose [G] N s ~R N t--Is it sensible to decompose *Wanted* constraints over newtypes?  Yes!-It's the only way we could ever prove (IO Int ~R IO Age), recalling-that IO is a newtype.--However we must be careful.  Consider--  type role Nt representational--  [G] Nt a ~R Nt b       (1)-  [W] NT alpha ~R Nt b   (2)-  [W] alpha ~ a          (3)--If we focus on (3) first, we'll substitute in (2), and now it's-identical to the given (1), so we succeed.  But if we focus on (2)-first, and decompose it, we'll get (alpha ~R b), which is not soluble.-This is exactly like the question of overlapping Givens for class-constraints: see Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.--Conclusion:-  * Decompose [W] N s ~R N t  iff there no given constraint that could-    later solve it.---}--canDecomposableTyConAppOK :: CtEvidence -> EqRel-                          -> TyCon -> [TcType] -> [TcType]-                          -> TcS (StopOrContinue Ct)--- Precondition: tys1 and tys2 are the same length, hence "OK"-canDecomposableTyConAppOK ev eq_rel tc tys1 tys2-  = ASSERT( tys1 `equalLength` tys2 )-    do { traceTcS "canDecomposableTyConAppOK"-                  (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)-       ; case ev of-           CtDerived {}-             -> unifyDeriveds loc tc_roles tys1 tys2--           CtWanted { ctev_dest = dest }-                  -- new_locs and tc_roles are both infinite, so-                  -- we are guaranteed that cos has the same length-                  -- as tys1 and tys2-             -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2-                   ; setWantedEq dest (mkTyConAppCo role tc cos) }--           CtGiven { ctev_evar = evar }-             -> do { let ev_co = mkCoVarCo evar-                   ; given_evs <- newGivenEvVars loc $-                                  [ ( mkPrimEqPredRole r ty1 ty2-                                    , evCoercion $ mkNthCo r i ev_co )-                                  | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]-                                  , r /= Phantom-                                  , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]-                   ; emitWorkNC given_evs }--    ; stopWith ev "Decomposed TyConApp" }--  where-    loc        = ctEvLoc ev-    role       = eqRelRole eq_rel--      -- infinite, as tyConRolesX returns an infinite tail of Nominal-    tc_roles   = tyConRolesX role tc--      -- Add nuances to the location during decomposition:-      --  * if the argument is a kind argument, remember this, so that error-      --    messages say "kind", not "type". This is determined based on whether-      --    the corresponding tyConBinder is named (that is, dependent)-      --  * if the argument is invisible, note this as well, again by-      --    looking at the corresponding binder-      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't-      -- do either of these changes. (Forgetting to do so led to #16188)-      ---      -- NB: infinite in length-    new_locs = [ new_loc-               | bndr <- tyConBinders tc-               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc-                              | otherwise               = loc-                     new_loc  | isVisibleTyConBinder bndr-                              = updateCtLocOrigin new_loc0 toInvisibleOrigin-                              | otherwise-                              = new_loc0 ]-               ++ repeat loc---- | Call when canonicalizing an equality fails, but if the equality is--- representational, there is some hope for the future.--- Examples in Note [Use canEqFailure in canDecomposableTyConApp]-canEqFailure :: CtEvidence -> EqRel-             -> TcType -> TcType -> TcS (StopOrContinue Ct)-canEqFailure ev NomEq ty1 ty2-  = canEqHardFailure ev ty1 ty2-canEqFailure ev ReprEq ty1 ty2-  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1-       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2-            -- We must flatten the types before putting them in the-            -- inert set, so that we are sure to kick them out when-            -- new equalities become available-       ; traceTcS "canEqFailure with ReprEq" $-         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]-       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2-       ; continueWith (mkIrredCt OtherCIS new_ev) }---- | Call when canonicalizing an equality fails with utterly no hope.-canEqHardFailure :: CtEvidence-                 -> TcType -> TcType -> TcS (StopOrContinue Ct)--- See Note [Make sure that insolubles are fully rewritten]-canEqHardFailure ev ty1 ty2-  = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)-       ; (s1, co1) <- flatten FM_SubstOnly ev ty1-       ; (s2, co2) <- flatten FM_SubstOnly ev ty2-       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2-       ; continueWith (mkIrredCt InsolubleCIS new_ev) }--{--Note [Decomposing TyConApps]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we see (T s1 t1 ~ T s2 t2), then we can just decompose to-  (s1 ~ s2, t1 ~ t2)-and push those back into the work list.  But if-  s1 = K k1    s2 = K k2-then we will just decomopose s1~s2, and it might be better to-do so on the spot.  An important special case is where s1=s2,-and we get just Refl.--So canDecomposableTyCon is a fast-path decomposition that uses-unifyWanted etc to short-cut that work.--Note [Canonicalising type applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given (s1 t1) ~ ty2, how should we proceed?-The simple things is to see if ty2 is of form (s2 t2), and-decompose.  By this time s1 and s2 can't be saturated type-function applications, because those have been dealt with-by an earlier equation in can_eq_nc, so it is always sound to-decompose.--However, over-eager decomposition gives bad error messages-for things like-   a b ~ Maybe c-   e f ~ p -> q-Suppose (in the first example) we already know a~Array.  Then if we-decompose the application eagerly, yielding-   a ~ Maybe-   b ~ c-we get an error        "Can't match Array ~ Maybe",-but we'd prefer to get "Can't match Array b ~ Maybe c".--So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of-replacing (a b) by (Array b), before using try_decompose_app to-decompose it.--Note [Make sure that insolubles are fully rewritten]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When an equality fails, we still want to rewrite the equality-all the way down, so that it accurately reflects- (a) the mutable reference substitution in force at start of solving- (b) any ty-binds in force at this point in solving-See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad.-And if we don't do this there is a bad danger that-GHC.Tc.Solver.applyTyVarDefaulting will find a variable-that has in fact been substituted.--Note [Do not decompose Given polytype equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?-No -- what would the evidence look like?  So instead we simply discard-this given evidence.---Note [Combining insoluble constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As this point we have an insoluble constraint, like Int~Bool.-- * If it is Wanted, delete it from the cache, so that subsequent-   Int~Bool constraints give rise to separate error messages-- * But if it is Derived, DO NOT delete from cache.  A class constraint-   may get kicked out of the inert set, and then have its functional-   dependency Derived constraints generated a second time. In that-   case we don't want to get two (or more) error messages by-   generating two (or more) insoluble fundep constraints from the same-   class constraint.--Note [No top-level newtypes on RHS of representational equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we're in this situation:-- work item:  [W] c1 : a ~R b-     inert:  [G] c2 : b ~R Id a--where-  newtype Id a = Id a--We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened-and the Id newtype is unwrapped. This is assured by requiring only flat-types in canEqTyVar *and* having the newtype-unwrapping check above-the tyvar check in can_eq_nc.--Note [Occurs check error]-~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an occurs check error, are we necessarily hosed? Say our-tyvar is tv1 and the type it appears in is xi2. Because xi2 is function-free, then if we're computing w.r.t. nominal equality, then, yes, we're-hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t.-representational equality, this is a little subtler. Once again, (a ~R [a])-is a bad thing, but (a ~R N a) for a newtype N might be just fine. This-means also that (a ~ b a) might be fine, because `b` might become a newtype.--So, we must check: does tv1 appear in xi2 under any type constructor-that is generative w.r.t. representational equality? That's what-isInsolubleOccursCheck does.--See also #10715, which induced this addition.--Note [canCFunEqCan]-~~~~~~~~~~~~~~~~~~~-Flattening the arguments to a type family can change the kind of the type-family application. As an easy example, consider (Any k) where (k ~ Type)-is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).-The problem here is that the fsk in the CFunEqCan will have the old kind.--The solution is to come up with a new fsk/fmv of the right kind. For-givens, this is easy: just introduce a new fsk and update the flat-cache-with the new one. For wanteds, we want to solve the old one if favor of-the new one, so we use dischargeFmv. This also kicks out constraints-from the inert set; this behavior is correct, as the kind-change may-allow more constraints to be solved.--We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case-if we really need to.  Of course `flattenArgsNom` should return `Refl`-whenever possible, but #15577 was an infinite loop because even-though the coercion was homo-kinded, `kind_co` was not `Refl`, so we-made a new (identical) CFunEqCan, and then the entire process repeated.--}--canCFunEqCan :: CtEvidence-             -> TyCon -> [TcType]   -- LHS-             -> TcTyVar             -- RHS-             -> TcS (StopOrContinue Ct)--- ^ Canonicalise a CFunEqCan.  We know that---     the arg types are already flat,--- and the RHS is a fsk, which we must *not* substitute.--- So just substitute in the LHS-canCFunEqCan ev fn tys fsk-  = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys-                        -- cos :: tys' ~ tys--       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos-                        -- :: F tys' ~ F tys-             new_lhs = mkTyConApp fn tys'--             flav    = ctEvFlavour ev-       ; (ev', fsk')-           <- if isTcReflexiveCo kind_co   -- See Note [canCFunEqCan]-              then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)-                      ; let fsk_ty = mkTyVarTy fsk-                      ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty-                                                 lhs_co (mkTcNomReflCo fsk_ty)-                      ; return (ev', fsk) }-              else do { traceTcS "canCFunEqCan: non-refl" $-                        vcat [ text "Kind co:" <+> ppr kind_co-                             , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)-                             , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))-                                                  2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys)))-                             , text "New LHS" <+> hang (ppr new_lhs)-                                                     2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]-                      ; (ev', new_co, new_fsk)-                          <- newFlattenSkolem flav (ctEvLoc ev) fn tys'-                      ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co-                               -- sym lhs_co :: F tys ~ F tys'-                               -- new_co     :: F tys' ~ new_fsk-                               -- co         :: F tys ~ (new_fsk |> kind_co)-                            co = mkTcSymCo lhs_co `mkTcTransCo`-                                 mkTcCoherenceRightCo Nominal-                                                      (mkTyVarTy new_fsk)-                                                      kind_co-                                                      new_co--                      ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)-                      ; dischargeFunEq ev fsk co xi-                      ; return (ev', new_fsk) }--       ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')-       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn-                                 , cc_tyargs = tys', cc_fsk = fsk' }) }------------------------canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs-           -> EqRel -> SwapFlag-           -> TcTyVar               -- tv1-           -> TcType                -- lhs: pretty lhs, already flat-           -> TcType -> TcType      -- rhs: already flat-           -> TcS (StopOrContinue Ct)-canEqTyVar ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2-  | k1 `tcEqType` k2-  = canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 ps_xi2--  | otherwise-  = canEqTyVarHetero ev eq_rel swapped tv1 ps_xi1 k1 xi2 ps_xi2 k2--  where-    k1 = tyVarKind tv1-    k2 = tcTypeKind xi2--canEqTyVarHetero :: CtEvidence         -- :: (tv1 :: ki1) ~ (xi2 :: ki2)-                 -> EqRel -> SwapFlag-                 -> TcTyVar -> TcType  -- tv1, pretty tv1-                 -> TcKind             -- ki1-                 -> TcType -> TcType   -- xi2, pretty xi2 :: ki2-                 -> TcKind             -- ki2-                 -> TcS (StopOrContinue Ct)-canEqTyVarHetero ev eq_rel swapped tv1 ps_tv1 ki1 xi2 ps_xi2 ki2-  -- See Note [Equalities with incompatible kinds]-  = do { kind_co <- emit_kind_co   -- :: ki2 ~N ki1--       ; let  -- kind_co :: (ki2 :: *) ~N (ki1 :: *)   (whether swapped or not)-              -- co1     :: kind(tv1) ~N ki1-             rhs'    = xi2    `mkCastTy` kind_co   -- :: ki1-             ps_rhs' = ps_xi2 `mkCastTy` kind_co   -- :: ki1-             rhs_co  = mkTcGReflLeftCo role xi2 kind_co-               -- rhs_co :: (xi2 |> kind_co) ~ xi2--             lhs'   = mkTyVarTy tv1  -- same as old lhs-             lhs_co = mkTcReflCo role lhs'--       ; traceTcS "Hetero equality gives rise to kind equality"-           (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])-       ; type_ev <- rewriteEqEvidence ev swapped lhs' rhs' lhs_co rhs_co--          -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more-       ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }-  where-    emit_kind_co :: TcS CoercionN-    emit_kind_co-      | CtGiven { ctev_evar = evar } <- ev-      = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar)  -- :: k2 ~ k1-           ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)-           ; emitWorkNC [kind_ev]-           ; return (ctEvCoercion kind_ev) }--      | otherwise-      = unifyWanted kind_loc Nominal ki2 ki1--    loc      = ctev_loc ev-    role     = eqRelRole eq_rel-    kind_loc = mkKindLoc (mkTyVarTy tv1) xi2 loc-    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1--    maybe_sym = case swapped of-          IsSwapped  -> id         -- if the input is swapped, then we already-                                   -- will have k2 ~ k1-          NotSwapped -> mkTcSymCo---- guaranteed that tcTypeKind lhs == tcTypeKind rhs-canEqTyVarHomo :: CtEvidence-               -> EqRel -> SwapFlag-               -> TcTyVar                -- lhs: tv1-               -> TcType                 -- pretty lhs, flat-               -> TcType -> TcType       -- rhs, flat-               -> TcS (StopOrContinue Ct)-canEqTyVarHomo ev eq_rel swapped tv1 ps_xi1 xi2 _-  | Just (tv2, _) <- tcGetCastedTyVar_maybe xi2-  , tv1 == tv2-  = canEqReflexive ev eq_rel (mkTyVarTy tv1)-    -- we don't need to check co because it must be reflexive--    -- this guarantees (TyEq:TV)-  | Just (tv2, co2) <- tcGetCastedTyVar_maybe xi2-  , swapOverTyVars (isGiven ev) tv1 tv2-  = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)-       ; let role    = eqRelRole eq_rel-             sym_co2 = mkTcSymCo co2-             ty1     = mkTyVarTy tv1-             new_lhs = ty1 `mkCastTy` sym_co2-             lhs_co  = mkTcGReflLeftCo role ty1 sym_co2--             new_rhs = mkTyVarTy tv2-             rhs_co  = mkTcGReflRightCo role new_rhs co2--       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co--       ; dflags <- getDynFlags-       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_xi1 `mkCastTy` sym_co2) }--canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_xi2-  = do { dflags <- getDynFlags-       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_xi2 }---- The RHS here is either not a casted tyvar, or it's a tyvar but we want--- to rewrite the LHS to the RHS (as per swapOverTyVars)-canEqTyVar2 :: DynFlags-            -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)-            -> EqRel-            -> SwapFlag-            -> TcTyVar                  -- lhs = tv, flat-            -> TcType                   -- rhs, flat-            -> TcS (StopOrContinue Ct)--- LHS is an inert type variable,--- and RHS is fully rewritten, but with type synonyms--- preserved as much as possible--- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K)--- the "flat" requirement guarantees (TyEq:AFF)--- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqTyVarHomo-canEqTyVar2 dflags ev eq_rel swapped tv1 rhs-    -- this next line checks also for coercion holes; see-    -- Note [Equalities with incompatible kinds]-  | MTVU_OK rhs' <- mtvu  -- No occurs check-     -- Must do the occurs check even on tyvar/tyvar-     -- equalities, in case have  x ~ (y :: ..x...)-     -- #12593-     -- guarantees (TyEq:OC), (TyEq:F), and (TyEq:H)-  = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2-       ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1-                                , cc_rhs = rhs', cc_eq_rel = eq_rel }) }--  | otherwise  -- For some reason (occurs check, or forall) we can't unify-               -- We must not use it for further rewriting!-  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)-       ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2-       ; let status | isInsolubleOccursCheck eq_rel tv1 rhs-                    = InsolubleCIS-             -- If we have a ~ [a], it is not canonical, and in particular-             -- we don't want to rewrite existing inerts with it, otherwise-             -- we'd risk divergence in the constraint solver--                    | MTVU_HoleBlocker <- mtvu-                    = BlockedCIS-             -- This is the case detailed in-             -- Note [Equalities with incompatible kinds]--                    | otherwise-                    = OtherCIS-             -- A representational equality with an occurs-check problem isn't-             -- insoluble! For example:-             --   a ~R b a-             -- We might learn that b is the newtype Id.-             -- But, the occurs-check certainly prevents the equality from being-             -- canonical, and we might loop if we were to use it in rewriting.--       ; continueWith (mkIrredCt status new_ev) }-  where-    mtvu = metaTyVarUpdateOK dflags tv1 rhs--    role = eqRelRole eq_rel--    lhs = mkTyVarTy tv1--    rewrite_co1  = mkTcReflCo role lhs-    rewrite_co2  = mkTcReflCo role rhs---- | Solve a reflexive equality constraint-canEqReflexive :: CtEvidence    -- ty ~ ty-               -> EqRel-               -> TcType        -- ty-               -> TcS (StopOrContinue Ct)   -- always Stop-canEqReflexive ev eq_rel ty-  = do { setEvBindIfWanted ev (evCoercion $-                               mkTcReflCo (eqRelRole eq_rel) ty)-       ; stopWith ev "Solved by reflexivity" }--{- Note [Equalities with incompatible kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What do we do when we have an equality--  (tv :: k1) ~ (rhs :: k2)--where k1 and k2 differ? Easy: we create a coercion that relates k1 and-k2 and use this to cast. To wit, from--  [X] (tv :: k1) ~ (rhs :: k2)--we go to--  [noDerived X] co :: k2 ~ k1-  [X]           (tv :: k1) ~ ((rhs |> co) :: k1)--where--  noDerived G = G-  noDerived _ = W--Wrinkles:-- (1) The noDerived step is because Derived equalities have no evidence.-     And yet we absolutely need evidence to be able to proceed here.-     Given evidence will use the KindCo coercion; Wanted evidence will-     be a coercion hole. Even a Derived hetero equality begets a Wanted-     kind equality.-- (2) Though it would be sound to do so, we must not mark the rewritten Wanted-       [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]-     in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for-     tales of destruction.--     So, we have an invariant on CTyEqCan (TyEq:H) that the RHS does not have-     any coercion holes. This is checked in metaTyVarUpdateOK. We also-     must be sure to kick out any constraints that mention coercion holes-     when those holes get filled in.--     (2a) We don't want to do this for CoercionHoles that witness-          CFunEqCans (that are produced by the flattener), as these will disappear-          once we unflatten. So we remember in the CoercionHole structure-          whether the presence of the hole should block substitution or not.-          A bit gross, this.--     (2b) We must now absolutely make sure to kick out any constraints that-          mention a newly-filled-in coercion hole. This is done in-          kickOutAfterFillingCoercionHole.-- (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the-     algorithm detailed here, producing [W] co :: k2 ~ k1, and adding-     [W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time-     later, we solve co, and fill in co's coercion hole. This kicks out-     the irreducible as described in (2b).-     But now, during canonicalization, we see the cast-     and remove it, in canEqCast. By the time we get into canEqTyVar, the equality-     is heterogeneous again, and the process repeats.--     To avoid this, we don't strip casts off a type if the other type-     in the equality is a tyvar. And this is an improvement regardless:-     because tyvars can, generally, unify with casted types, there's no-     reason to go through the work of stripping off the cast when the-     cast appears opposite a tyvar. This is implemented in the cast case-     of can_eq_nc'.-- (4) Reporting an error for a constraint that is blocked only because-     of wrinkle (2) is hard: what would we say to users? And we don't-     really need to report, because if a constraint is blocked, then-     there is unsolved wanted blocking it; that unsolved wanted will-     be reported. We thus push such errors to the bottom of the queue-     in the error-reporting code; they should never be printed.--     (4a) It would seem possible to do this filtering just based on the-          presence of a blocking coercion hole. However, this is no good,-          as it suppresses e.g. no-instance-found errors. We thus record-          a CtIrredStatus in CIrredCan and filter based on this status.-          This happened in T14584. An alternative approach is to expressly-          look for *equalities* with blocking coercion holes, but actually-          recording the blockage in a status field seems nicer.--     (4b) The error message might be printed with -fdefer-type-errors,-          so it still must exist. This is the only reason why there is-          a message at all. Otherwise, we could simply do nothing.--Historical note:--We used to do this via emitting a Derived kind equality and then parking-the heterogeneous equality as irreducible. But this new approach is much-more direct. And it doesn't produce duplicate Deriveds (as the old one did).--Note [Type synonyms and canonicalization]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We treat type synonym applications as xi types, that is, they do not-count as type function applications.  However, we do need to be a bit-careful with type synonyms: like type functions they may not be-generative or injective.  However, unlike type functions, they are-parametric, so there is no problem in expanding them whenever we see-them, since we do not need to know anything about their arguments in-order to expand them; this is what justifies not having to treat them-as specially as type function applications.  The thing that causes-some subtleties is that we prefer to leave type synonym applications-*unexpanded* whenever possible, in order to generate better error-messages.--If we encounter an equality constraint with type synonym applications-on both sides, or a type synonym application on one side and some sort-of type application on the other, we simply must expand out the type-synonyms in order to continue decomposing the equality constraint into-primitive equality constraints.  For example, suppose we have--  type F a = [Int]--and we encounter the equality--  F a ~ [b]--In order to continue we must expand F a into [Int], giving us the-equality--  [Int] ~ [b]--which we can then decompose into the more primitive equality-constraint--  Int ~ b.--However, if we encounter an equality constraint with a type synonym-application on one side and a variable on the other side, we should-NOT (necessarily) expand the type synonym, since for the purpose of-good error messages we want to leave type synonyms unexpanded as much-as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqTyVar.---}--{--************************************************************************-*                                                                      *-                  Evidence transformation-*                                                                      *-************************************************************************--}--data StopOrContinue a-  = ContinueWith a    -- The constraint was not solved, although it may have-                      --   been rewritten--  | Stop CtEvidence   -- The (rewritten) constraint was solved-         SDoc         -- Tells how it was solved-                      -- Any new sub-goals have been put on the work list-  deriving (Functor)--instance Outputable a => Outputable (StopOrContinue a) where-  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev-  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w--continueWith :: a -> TcS (StopOrContinue a)-continueWith = return . ContinueWith--stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)-stopWith ev s = return (Stop ev (text s))--andWhenContinue :: TcS (StopOrContinue a)-                -> (a -> TcS (StopOrContinue b))-                -> TcS (StopOrContinue b)-andWhenContinue tcs1 tcs2-  = do { r <- tcs1-       ; case r of-           Stop ev s       -> return (Stop ev s)-           ContinueWith ct -> tcs2 ct }-infixr 0 `andWhenContinue`    -- allow chaining with ($)--rewriteEvidence :: CtEvidence   -- old evidence-                -> TcPredType   -- new predicate-                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>-                -> TcS (StopOrContinue CtEvidence)--- Returns Just new_ev iff either (i)  'co' is reflexivity---                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached--- In either case, there is nothing new to do with new_ev-{--     rewriteEvidence old_ev new_pred co-Main purpose: create new evidence for new_pred;-              unless new_pred is cached already-* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev-* If old_ev was wanted, create a binding for old_ev, in terms of new_ev-* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev-* Returns Nothing if new_ev is already cached--        Old evidence    New predicate is               Return new evidence-        flavour                                        of same flavor-        --------------------------------------------------------------------        Wanted          Already solved or in inert     Nothing-        or Derived      Not                            Just new_evidence--        Given           Already in inert               Nothing-                        Not                            Just new_evidence--Note [Rewriting with Refl]-~~~~~~~~~~~~~~~~~~~~~~~~~~-If the coercion is just reflexivity then you may re-use the same-variable.  But be careful!  Although the coercion is Refl, new_pred-may reflect the result of unification alpha := ty, so new_pred might-not _look_ the same as old_pred, and it's vital to proceed from now on-using new_pred.--qThe flattener preserves type synonyms, so they should appear in new_pred-as well as in old_pred; that is important for good error messages.- -}---rewriteEvidence old_ev@(CtDerived {}) new_pred _co-  = -- If derived, don't even look at the coercion.-    -- This is very important, DO NOT re-order the equations for-    -- rewriteEvidence to put the isTcReflCo test first!-    -- Why?  Because for *Derived* constraints, c, the coercion, which-    -- was produced by flattening, may contain suspended calls to-    -- (ctEvExpr c), which fails for Derived constraints.-    -- (Getting this wrong caused #7384.)-    continueWith (old_ev { ctev_pred = new_pred })--rewriteEvidence old_ev new_pred co-  | isTcReflCo co -- See Note [Rewriting with Refl]-  = continueWith (old_ev { ctev_pred = new_pred })--rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co-  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)-       ; continueWith new_ev }-  where-    -- mkEvCast optimises ReflCo-    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational-                                                       (ctEvRole ev)-                                                       (mkTcSymCo co))--rewriteEvidence ev@(CtWanted { ctev_dest = dest-                             , ctev_nosh = si-                             , ctev_loc = loc }) new_pred co-  = do { mb_new_ev <- newWanted_SI si loc new_pred-               -- The "_SI" variant ensures that we make a new Wanted-               -- with the same shadow-info as the existing one-               -- with the same shadow-info as the existing one (#16735)-       ; MASSERT( tcCoercionRole co == ctEvRole ev )-       ; setWantedEvTerm dest-            (mkEvCast (getEvExpr mb_new_ev)-                      (tcDowngradeRole Representational (ctEvRole ev) co))-       ; case mb_new_ev of-            Fresh  new_ev -> continueWith new_ev-            Cached _      -> stopWith ev "Cached wanted" }---rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)-                                        --              or orhs ~ olhs (swapped)-                  -> SwapFlag-                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs-                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs-                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs-                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs--- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)--- we generate--- If not swapped---      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co--- If 'swapped'---      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co------ For (Wanted w) we do the dual thing.--- New  w1 : nlhs ~ nrhs--- If not swapped---      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co--- If swapped---      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co------ It's all a form of rewwriteEvidence, specialised for equalities-rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co-  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived-  = return (old_ev { ctev_pred = new_pred })--  | NotSwapped <- swapped-  , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]-  , isTcReflCo rhs_co-  = return (old_ev { ctev_pred = new_pred })--  | CtGiven { ctev_evar = old_evar } <- old_ev-  = do { let new_tm = evCoercion (lhs_co-                                  `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)-                                  `mkTcTransCo` mkTcSymCo rhs_co)-       ; newGivenEvVar loc' (new_pred, new_tm) }--  | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev-  = case dest of-      HoleDest hole ->-        do { (new_ev, hole_co) <- newWantedEq_SI (ch_blocker hole) si loc'-                                                 (ctEvRole old_ev) nlhs nrhs-                   -- The "_SI" variant ensures that we make a new Wanted-                   -- with the same shadow-info as the existing one (#16735)-           ; let co = maybeSym swapped $-                      mkSymCo lhs_co-                      `mkTransCo` hole_co-                      `mkTransCo` rhs_co-           ; setWantedEq dest co-           ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])-           ; return new_ev }--      _ -> panic "rewriteEqEvidence"--#if __GLASGOW_HASKELL__ <= 810-  | otherwise-  = panic "rewriteEvidence"-#endif-  where-    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs--      -- equality is like a type class. Bumping the depth is necessary because-      -- of recursive newtypes, where "reducing" a newtype can actually make-      -- it bigger. See Note [Newtypes can blow the stack].-    loc      = ctEvLoc old_ev-    loc'     = bumpCtLocDepth loc--{- Note [unifyWanted and unifyDerived]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When decomposing equalities we often create new wanted constraints for-(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.-Similar remarks apply for Derived.--Rather than making an equality test (which traverses the structure of the-type, perhaps fruitlessly), unifyWanted traverses the common structure, and-bales out when it finds a difference by creating a new Wanted constraint.-But where it succeeds in finding common structure, it just builds a coercion-to reflect it.--}--unifyWanted :: CtLoc -> Role-            -> TcType -> TcType -> TcS Coercion--- Return coercion witnessing the equality of the two types,--- emitting new work equalities where necessary to achieve that--- Very good short-cut when the two types are equal, or nearly so--- See Note [unifyWanted and unifyDerived]--- The returned coercion's role matches the input parameter-unifyWanted loc Phantom ty1 ty2-  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)-       ; return (mkPhantomCo kind_co ty1 ty2) }--unifyWanted loc role orig_ty1 orig_ty2-  = go orig_ty1 orig_ty2-  where-    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2-    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'--    go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = do { co_s <- unifyWanted loc role s1 s2-           ; co_t <- unifyWanted loc role t1 t2-           ; co_w <- unifyWanted loc Nominal w1 w2-           ; return (mkFunCo role co_w co_s co_t) }-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2, tys1 `equalLength` tys2-      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality-      = do { cos <- zipWith3M (unifyWanted loc)-                              (tyConRolesX role tc1) tys1 tys2-           ; return (mkTyConAppCo role tc1 cos) }--    go ty1@(TyVarTy tv) ty2-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty1' -> go ty1' ty2-                Nothing   -> bale_out ty1 ty2}-    go ty1 ty2@(TyVarTy tv)-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty2' -> go ty1 ty2'-                Nothing   -> bale_out ty1 ty2 }--    go ty1@(CoercionTy {}) (CoercionTy {})-      = return (mkReflCo role ty1) -- we just don't care about coercions!--    go ty1 ty2 = bale_out ty1 ty2--    bale_out ty1 ty2-       | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)-        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)-       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2--unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2--unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()--- See Note [unifyWanted and unifyDerived]-unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2--unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new Derived and put it in the work list--- Should do nothing if the two types are equal--- See Note [unifyWanted and unifyDerived]-unify_derived _   Phantom _        _        = return ()-unify_derived loc role    orig_ty1 orig_ty2-  = go orig_ty1 orig_ty2-  where-    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2-    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'--    go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)-      = do { unify_derived loc role s1 s2-           ; unify_derived loc role t1 t2-           ; unify_derived loc Nominal w1 w2 }-    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      | tc1 == tc2, tys1 `equalLength` tys2-      , isInjectiveTyCon tc1 role-      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2-    go ty1@(TyVarTy tv) ty2-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty1' -> go ty1' ty2-                Nothing   -> bale_out ty1 ty2 }-    go ty1 ty2@(TyVarTy tv)-      = do { mb_ty <- isFilledMetaTyVar_maybe tv-           ; case mb_ty of-                Just ty2' -> go ty1 ty2'-                Nothing   -> bale_out ty1 ty2 }-    go ty1 ty2 = bale_out ty1 ty2--    bale_out ty1 ty2-       | ty1 `tcEqType` ty2 = return ()-        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)-       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2--maybeSym :: SwapFlag -> TcCoercion -> TcCoercion-maybeSym IsSwapped  co = mkTcSymCo co-maybeSym NotSwapped co = co+{-# LANGUAGE MultiWayIf #-}++module GHC.Tc.Solver.Canonical(+     canonicalize,+     unifyDerived,+     makeSuperClasses,+     StopOrContinue(..), stopWith, continueWith, andWhenContinue,+     solveCallStack    -- For GHC.Tc.Solver+  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Tc.Types.Constraint+import GHC.Core.Predicate+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.Unify+import GHC.Tc.Utils.TcType+import GHC.Core.Type+import GHC.Tc.Solver.Rewrite+import GHC.Tc.Solver.Monad+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.EvTerm+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Core.Multiplicity+import GHC.Core.TyCo.Rep   -- cleverly decomposes types, good for completeness checking+import GHC.Core.Coercion+import GHC.Core.Coercion.Axiom+import GHC.Core+import GHC.Types.Id( mkTemplateLocals )+import GHC.Core.FamInstEnv ( FamInstEnvs )+import GHC.Tc.Instance.Family ( tcTopNormaliseNewTypeTF_maybe )+import GHC.Types.Var+import GHC.Types.Var.Env( mkInScopeSet )+import GHC.Types.Var.Set( delVarSetList, anyVarSet )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Builtin.Types ( anyTypeOfKind )+import GHC.Types.Name.Set+import GHC.Types.Name.Reader+import GHC.Hs.Type( HsIPName(..) )++import GHC.Data.Pair+import GHC.Utils.Misc+import GHC.Data.Bag+import GHC.Utils.Monad+import Control.Monad+import Data.Maybe ( isJust, isNothing )+import Data.List  ( zip4 )+import GHC.Types.Basic++import Data.Bifunctor ( bimap )+import Data.Foldable ( traverse_ )++{-+************************************************************************+*                                                                      *+*                      The Canonicaliser                               *+*                                                                      *+************************************************************************++Note [Canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~++Canonicalization converts a simple constraint to a canonical form. It is+unary (i.e. treats individual constraints one at a time).++Constraints originating from user-written code come into being as+CNonCanonicals. We know nothing about these constraints. So, first:++     Classify CNonCanoncal constraints, depending on whether they+     are equalities, class predicates, or other.++Then proceed depending on the shape of the constraint. Generally speaking,+each constraint gets rewritten and then decomposed into one of several forms+(see type Ct in GHC.Tc.Types).++When an already-canonicalized constraint gets kicked out of the inert set,+it must be recanonicalized. But we know a bit about its shape from the+last time through, so we can skip the classification step.++-}++-- Top-level canonicalization+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++canonicalize :: Ct -> TcS (StopOrContinue Ct)+canonicalize (CNonCanonical { cc_ev = ev })+  = {-# SCC "canNC" #-}+    canNC ev++canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))+  = canForAll ev pend_sc++canonicalize (CIrredCan { cc_ev = ev })+  = canNC ev+    -- Instead of rewriting the evidence before classifying, it's possible we+    -- can make progress without the rewrite. Try this first.+    -- For insolubles (all of which are equalities), do /not/ rewrite the arguments+    -- In #14350 doing so led entire-unnecessary and ridiculously large+    -- type function expansion.  Instead, canEqNC just applies+    -- the substitution to the predicate, and may do decomposition;+    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose++canonicalize (CDictCan { cc_ev = ev, cc_class  = cls+                       , cc_tyargs = xis, cc_pend_sc = pend_sc })+  = {-# SCC "canClass" #-}+    canClass ev cls xis pend_sc++canonicalize (CEqCan { cc_ev     = ev+                     , cc_lhs    = lhs+                     , cc_rhs    = rhs+                     , cc_eq_rel = eq_rel })+  = {-# SCC "canEqLeafTyVarEq" #-}+    canEqNC ev eq_rel (canEqLHSType lhs) rhs++canNC :: CtEvidence -> TcS (StopOrContinue Ct)+canNC ev =+  case classifyPredType pred of+      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)+                                  canClassNC ev cls tys+      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)+                                  canEqNC    ev eq_rel ty1 ty2+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)+                                  canIrred ev+      ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)+                                  canForAllNC ev tvs th p+  where+    pred = ctEvPred ev++{-+************************************************************************+*                                                                      *+*                      Class Canonicalization+*                                                                      *+************************************************************************+-}++canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)+-- "NC" means "non-canonical"; that is, we have got here+-- from a NonCanonical constraint, not from a CDictCan+-- Precondition: EvVar is class evidence+canClassNC ev cls tys+  | isGiven ev  -- See Note [Eagerly expand given superclasses]+  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys+       ; emitWork sc_cts+       ; canClass ev cls tys False }++  | isWanted ev+  , Just ip_name <- isCallStackPred cls tys+  , OccurrenceOf func <- ctLocOrigin loc+  -- If we're given a CallStack constraint that arose from a function+  -- call, we need to push the current call-site onto the stack instead+  -- of solving it directly from a given.+  -- See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence+  -- and Note [Solving CallStack constraints] in GHC.Tc.Solver.Monad+  = do { -- First we emit a new constraint that will capture the+         -- given CallStack.+       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))+                            -- We change the origin to IPOccOrigin so+                            -- this rule does not fire again.+                            -- See Note [Overview of implicit CallStacks]++       ; new_ev <- newWantedEvVarNC new_loc pred++         -- Then we solve the wanted by pushing the call-site+         -- onto the newly emitted CallStack+       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)+       ; solveCallStack ev ev_cs++       ; canClass new_ev cls tys False }++  | otherwise+  = canClass ev cls tys (has_scs cls)++  where+    has_scs cls = not (null (classSCTheta cls))+    loc  = ctEvLoc ev+    pred = ctEvPred ev++solveCallStack :: CtEvidence -> EvCallStack -> TcS ()+-- Also called from GHC.Tc.Solver when defaulting call stacks+solveCallStack ev ev_cs = do+  -- We're given ev_cs :: CallStack, but the evidence term should be a+  -- dictionary, so we have to coerce ev_cs to a dictionary for+  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]+  cs_tm <- evCallStack ev_cs+  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))+  setEvBindIfWanted ev ev_tm++canClass :: CtEvidence+         -> Class -> [Type]+         -> Bool            -- True <=> un-explored superclasses+         -> TcS (StopOrContinue Ct)+-- Precondition: EvVar is class evidence++canClass ev cls tys pend_sc+  =   -- all classes do *nominal* matching+    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )+    do { (xis, cos) <- rewriteArgsNom ev cls_tc tys+       ; let co = mkTcTyConAppCo Nominal cls_tc cos+             xi = mkClassPred cls xis+             mk_ct new_ev = CDictCan { cc_ev = new_ev+                                     , cc_tyargs = xis+                                     , cc_class = cls+                                     , cc_pend_sc = pend_sc }+       ; mb <- rewriteEvidence ev xi co+       ; traceTcS "canClass" (vcat [ ppr ev+                                   , ppr xi, ppr mb ])+       ; return (fmap mk_ct mb) }+  where+    cls_tc = classTyCon cls++{- Note [The superclass story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to add superclass constraints for two reasons:++* For givens [G], they give us a route to proof.  E.g.+    f :: Ord a => a -> Bool+    f x = x == x+  We get a Wanted (Eq a), which can only be solved from the superclass+  of the Given (Ord a).++* For wanteds [W], and deriveds [WD], [D], they may give useful+  functional dependencies.  E.g.+     class C a b | a -> b where ...+     class C a b => D a b where ...+  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass+  and that might tell us about beta, via C's fundeps.  We can get this+  by generating a [D] (C Int beta) constraint.  It's derived because+  we don't actually have to cough up any evidence for it; it's only there+  to generate fundep equalities.++See Note [Why adding superclasses can help].++For these reasons we want to generate superclass constraints for both+Givens and Wanteds. But:++* (Minor) they are often not needed, so generating them aggressively+  is a waste of time.++* (Major) if we want recursive superclasses, there would be an infinite+  number of them.  Here is a real-life example (#10318);++     class (Frac (Frac a) ~ Frac a,+            Fractional (Frac a),+            IntegralDomain (Frac a))+         => IntegralDomain a where+      type Frac a :: *++  Notice that IntegralDomain has an associated type Frac, and one+  of IntegralDomain's superclasses is another IntegralDomain constraint.++So here's the plan:++1. Eagerly generate superclasses for given (but not wanted)+   constraints; see Note [Eagerly expand given superclasses].+   This is done using mkStrictSuperClasses in canClassNC, when+   we take a non-canonical Given constraint and cannonicalise it.++   However stop if you encounter the same class twice.  That is,+   mkStrictSuperClasses expands eagerly, but has a conservative+   termination condition: see Note [Expanding superclasses] in GHC.Tc.Utils.TcType.++2. Solve the wanteds as usual, but do no further expansion of+   superclasses for canonical CDictCans in solveSimpleGivens or+   solveSimpleWanteds; Note [Danger of adding superclasses during solving]++   However, /do/ continue to eagerly expand superclasses for new /given/+   /non-canonical/ constraints (canClassNC does this).  As #12175+   showed, a type-family application can expand to a class constraint,+   and we want to see its superclasses for just the same reason as+   Note [Eagerly expand given superclasses].++3. If we have any remaining unsolved wanteds+        (see Note [When superclasses help] in GHC.Tc.Types.Constraint)+   try harder: take both the Givens and Wanteds, and expand+   superclasses again.  See the calls to expandSuperClasses in+   GHC.Tc.Solver.simpl_loop and solveWanteds.++   This may succeed in generating (a finite number of) extra Givens,+   and extra Deriveds. Both may help the proof.++3a An important wrinkle: only expand Givens from the current level.+   Two reasons:+      - We only want to expand it once, and that is best done at+        the level it is bound, rather than repeatedly at the leaves+        of the implication tree+      - We may be inside a type where we can't create term-level+        evidence anyway, so we can't superclass-expand, say,+        (a ~ b) to get (a ~# b).  This happened in #15290.++4. Go round to (2) again.  This loop (2,3,4) is implemented+   in GHC.Tc.Solver.simpl_loop.++The cc_pend_sc flag in a CDictCan records whether the superclasses of+this constraint have been expanded.  Specifically, in Step 3 we only+expand superclasses for constraints with cc_pend_sc set to true (i.e.+isPendingScDict holds).++Why do we do this?  Two reasons:++* To avoid repeated work, by repeatedly expanding the superclasses of+  same constraint,++* To terminate the above loop, at least in the -XNoRecursiveSuperClasses+  case.  If there are recursive superclasses we could, in principle,+  expand forever, always encountering new constraints.++When we take a CNonCanonical or CIrredCan, but end up classifying it+as a CDictCan, we set the cc_pend_sc flag to False.++Note [Superclass loops]+~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class C a => D a+  class D a => C a++Then, when we expand superclasses, we'll get back to the self-same+predicate, so we have reached a fixpoint in expansion and there is no+point in fruitlessly expanding further.  This case just falls out from+our strategy.  Consider+  f :: C a => a -> Bool+  f x = x==x+Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses+G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)+When processing d3 we find a match with d1 in the inert set, and we always+keep the inert item (d1) if possible: see Note [Replacement vs keeping] in+GHC.Tc.Solver.Interact.  So d3 dies a quick, happy death.++Note [Eagerly expand given superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In step (1) of Note [The superclass story], why do we eagerly expand+Given superclasses by one layer?  (By "one layer" we mean expand transitively+until you meet the same class again -- the conservative criterion embodied+in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)+We do this eagerly for Givens mainly because of some very obscure+cases like this:++   instance Bad a => Eq (T a)++   f :: (Ord (T a)) => blah+   f x = ....needs Eq (T a), Ord (T a)....++Here if we can't satisfy (Eq (T a)) from the givens we'll use the+instance declaration; but then we are stuck with (Bad a).  Sigh.+This is really a case of non-confluent proofs, but to stop our users+complaining we expand one layer in advance.++Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.++We also want to do this if we have++   f :: F (T a) => blah++where+   type instance F (T a) = Ord (T a)++So we may need to do a little work on the givens to expose the+class that has the superclasses.  That's why the superclass+expansion for Givens happens in canClassNC.++This same scenario happens with quantified constraints, whose superclasses+are also eagerly expanded. Test case: typecheck/should_compile/T16502b+These are handled in canForAllNC, analogously to canClassNC.++Note [Why adding superclasses can help]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Examples of how adding superclasses can help:++    --- Example 1+        class C a b | a -> b+    Suppose we want to solve+         [G] C a b+         [W] C a beta+    Then adding [D] beta~b will let us solve it.++    -- Example 2 (similar but using a type-equality superclass)+        class (F a ~ b) => C a b+    And try to sllve:+         [G] C a b+         [W] C a beta+    Follow the superclass rules to add+         [G] F a ~ b+         [D] F a ~ beta+    Now we get [D] beta ~ b, and can solve that.++    -- Example (tcfail138)+      class L a b | a -> b+      class (G a, L a b) => C a b++      instance C a b' => G (Maybe a)+      instance C a b  => C (Maybe a) a+      instance L (Maybe a) a++    When solving the superclasses of the (C (Maybe a) a) instance, we get+      [G] C a b, and hance by superclasses, [G] G a, [G] L a b+      [W] G (Maybe a)+    Use the instance decl to get+      [W] C a beta+    Generate its derived superclass+      [D] L a beta.  Now using fundeps, combine with [G] L a b to get+      [D] beta ~ b+    which is what we want.++Note [Danger of adding superclasses during solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's a serious, but now out-dated example, from #4497:++   class Num (RealOf t) => Normed t+   type family RealOf x++Assume the generated wanted constraint is:+   [W] RealOf e ~ e+   [W] Normed e++If we were to be adding the superclasses during simplification we'd get:+   [W] RealOf e ~ e+   [W] Normed e+   [D] RealOf e ~ fuv+   [D] Num fuv+==>+   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv++While looks exactly like our original constraint. If we add the+superclass of (Normed fuv) again we'd loop.  By adding superclasses+definitely only once, during canonicalisation, this situation can't+happen.++Mind you, now that Wanteds cannot rewrite Derived, I think this particular+situation can't happen.++Note [Nested quantified constraint superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (typecheck/should_compile/T17202)++  class C1 a+  class (forall c. C1 c) => C2 a+  class (forall b. (b ~ F a) => C2 a) => C3 a++Elsewhere in the code, we get a [G] g1 :: C3 a. We expand its superclass+to get [G] g2 :: (forall b. (b ~ F a) => C2 a). This constraint has a+superclass, as well. But we now must be careful: we cannot just add+(forall c. C1 c) as a Given, because we need to remember g2's context.+That new constraint is Given only when forall b. (b ~ F a) is true.++It's tempting to make the new Given be (forall b. (b ~ F a) => forall c. C1 c),+but that's problematic, because it's nested, and ForAllPred is not capable+of representing a nested quantified constraint. (We could change ForAllPred+to allow this, but the solution in this Note is much more local and simpler.)++So, we swizzle it around to get (forall b c. (b ~ F a) => C1 c).++More generally, if we are expanding the superclasses of+  g0 :: forall tvs. theta => cls tys+and find a superclass constraint+  forall sc_tvs. sc_theta => sc_inner_pred+we must have a selector+  sel_id :: forall cls_tvs. cls cls_tvs -> forall sc_tvs. sc_theta => sc_inner_pred+and thus build+  g_sc :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred+  g_sc = /\ tvs. /\ sc_tvs. \ theta_ids. \ sc_theta_ids.+         sel_id tys (g0 tvs theta_ids) sc_tvs sc_theta_ids++Actually, we cheat a bit by eta-reducing: note that sc_theta_ids are both the+last bound variables and the last arguments. This avoids the need to produce+the sc_theta_ids at all. So our final construction is++  g_sc = /\ tvs. /\ sc_tvs. \ theta_ids.+         sel_id tys (g0 tvs theta_ids) sc_tvs++  -}++makeSuperClasses :: [Ct] -> TcS [Ct]+-- Returns strict superclasses, transitively, see Note [The superclasses story]+-- See Note [The superclass story]+-- The loop-breaking here follows Note [Expanding superclasses] in GHC.Tc.Utils.TcType+-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s+--    superclasses, up to /and including/ the first repetition of C+--+-- Example:  class D a => C a+--           class C [a] => D a+-- makeSuperClasses (C x) will return (D x, C [x])+--+-- NB: the incoming constraints have had their cc_pend_sc flag already+--     flipped to False, by isPendingScDict, so we are /obliged/ to at+--     least produce the immediate superclasses+makeSuperClasses cts = concatMapM go cts+  where+    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })+      = mkStrictSuperClasses ev [] [] cls tys+    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))+      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have+                                               -- class pred heads+        mkStrictSuperClasses ev tvs theta cls tys+      where+        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)+    go ct = pprPanic "makeSuperClasses" (ppr ct)++mkStrictSuperClasses+    :: CtEvidence+    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking+                             -- superclasses of a /quantified/ constraint+    -> Class -> [Type] -> TcS [Ct]+-- Return constraints for the strict superclasses of+--   ev :: forall as. theta => cls tys+mkStrictSuperClasses ev tvs theta cls tys+  = mk_strict_superclasses (unitNameSet (className cls))+                           ev tvs theta cls tys++mk_strict_superclasses :: NameSet -> CtEvidence+                       -> [TyVar] -> ThetaType+                       -> Class -> [Type] -> TcS [Ct]+-- Always return the immediate superclasses of (cls tys);+-- and expand their superclasses, provided none of them are in rec_clss+-- nor are repeated+mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })+                       tvs theta cls tys+  = concatMapM (do_one_given (mk_given_loc loc)) $+    classSCSelIds cls+  where+    dict_ids  = mkTemplateLocals theta+    size      = sizeTypes tys++    do_one_given given_loc sel_id+      | isUnliftedType sc_pred+      , not (null tvs && null theta)+      = -- See Note [Equality superclasses in quantified constraints]+        return []+      | otherwise+      = do { given_ev <- newGivenEvVar given_loc $+                         mk_given_desc sel_id sc_pred+           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }+      where+        sc_pred = classMethodInstTy sel_id tys++      -- See Note [Nested quantified constraint superclasses]+    mk_given_desc :: Id -> PredType -> (PredType, EvTerm)+    mk_given_desc sel_id sc_pred+      = (swizzled_pred, swizzled_evterm)+      where+        (sc_tvs, sc_rho)          = splitForAllTyCoVars sc_pred+        (sc_theta, sc_inner_pred) = splitFunTys sc_rho++        all_tvs       = tvs `chkAppend` sc_tvs+        all_theta     = theta `chkAppend` (map scaledThing sc_theta)+        swizzled_pred = mkInfSigmaTy all_tvs all_theta sc_inner_pred++        -- evar :: forall tvs. theta => cls tys+        -- sel_id :: forall cls_tvs. cls cls_tvs+        --                        -> forall sc_tvs. sc_theta => sc_inner_pred+        -- swizzled_evterm :: forall tvs sc_tvs. theta => sc_theta => sc_inner_pred+        swizzled_evterm = EvExpr $+          mkLams all_tvs $+          mkLams dict_ids $+          Var sel_id+            `mkTyApps` tys+            `App` (evId evar `mkVarApps` (tvs ++ dict_ids))+            `mkVarApps` sc_tvs++    mk_given_loc loc+       | isCTupleClass cls+       = loc   -- For tuple predicates, just take them apart, without+               -- adding their (large) size into the chain.  When we+               -- get down to a base predicate, we'll include its size.+               -- #10335++       | GivenOrigin skol_info <- ctLocOrigin loc+         -- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+         -- for explantation of this transformation for givens+       = case skol_info of+            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }+            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }+            _        -> loc++       | otherwise  -- Probably doesn't happen, since this function+       = loc        -- is only used for Givens, but does no harm++mk_strict_superclasses rec_clss ev tvs theta cls tys+  | all noFreeVarsOfType tys+  = return [] -- Wanteds with no variables yield no deriveds.+              -- See Note [Improvement from Ground Wanteds]++  | otherwise -- Wanted/Derived case, just add Derived superclasses+              -- that can lead to improvement.+  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )+    concatMapM do_one_derived (immSuperClasses cls tys)+  where+    loc = ctEvLoc ev++    do_one_derived sc_pred+      = do { sc_ev <- newDerivedNC loc sc_pred+           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }++{- Note [Improvement from Ground Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose class C b a => D a b+and consider+  [W] D Int Bool+Is there any point in emitting [D] C Bool Int?  No!  The only point of+emitting superclass constraints for W/D constraints is to get+improvement, extra unifications that result from functional+dependencies.  See Note [Why adding superclasses can help] above.++But no variables means no improvement; case closed.+-}++mk_superclasses :: NameSet -> CtEvidence+                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]+-- Return this constraint, plus its superclasses, if any+mk_superclasses rec_clss ev tvs theta pred+  | ClassPred cls tys <- classifyPredType pred+  = mk_superclasses_of rec_clss ev tvs theta cls tys++  | otherwise   -- Superclass is not a class predicate+  = return [mkNonCanonical ev]++mk_superclasses_of :: NameSet -> CtEvidence+                   -> [TyVar] -> ThetaType -> Class -> [Type]+                   -> TcS [Ct]+-- Always return this class constraint,+-- and expand its superclasses+mk_superclasses_of rec_clss ev tvs theta cls tys+  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)+                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True+  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys+                                                          , ppr (isCTupleClass cls)+                                                          , ppr rec_clss+                                                          ])+                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys+                    ; return (this_ct : sc_cts) }+                                   -- cc_pend_sc of this_ct = False+  where+    cls_nm     = className cls+    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss+                 -- Tuples never contribute to recursion, and can be nested+    rec_clss'  = rec_clss `extendNameSet` cls_nm++    this_ct | null tvs, null theta+            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys+                       , cc_pend_sc = loop_found }+                 -- NB: If there is a loop, we cut off, so we have not+                 --     added the superclasses, hence cc_pend_sc = True+            | otherwise+            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys+                             , qci_ev = ev+                             , qci_pend_sc = loop_found })+++{- Note [Equality superclasses in quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#15359, #15593, #15625)+  f :: (forall a. theta => a ~ b) => stuff++It's a bit odd to have a local, quantified constraint for `(a~b)`,+but some people want such a thing (see the tickets). And for+Coercible it is definitely useful+  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))+                 => stuff++Moreover it's not hard to arrange; we just need to look up /equality/+constraints in the quantified-constraint environment, which we do in+GHC.Tc.Solver.Interact.doTopReactOther.++There is a wrinkle though, in the case where 'theta' is empty, so+we have+  f :: (forall a. a~b) => stuff++Now, potentially, the superclass machinery kicks in, in+makeSuperClasses, giving us a a second quantified constraint+       (forall a. a ~# b)+BUT this is an unboxed value!  And nothing has prepared us for+dictionary "functions" that are unboxed.  Actually it does just+about work, but the simplifier ends up with stuff like+   case (/\a. eq_sel d) of df -> ...(df @Int)...+and fails to simplify that any further.  And it doesn't satisfy+isPredTy any more.++So for now we simply decline to take superclasses in the quantified+case.  Instead we have a special case in GHC.Tc.Solver.Interact.doTopReactOther,+which looks for primitive equalities specially in the quantified+constraints.++See also Note [Evidence for quantified constraints] in GHC.Core.Predicate.+++************************************************************************+*                                                                      *+*                      Irreducibles canonicalization+*                                                                      *+************************************************************************+-}++canIrred :: CtEvidence -> TcS (StopOrContinue Ct)+-- Precondition: ty not a tuple and no other evidence form+canIrred ev+  = do { let pred = ctEvPred ev+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)+       ; (xi,co) <- rewrite ev pred -- co :: xi ~ pred+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->++    do { -- Re-classify, in case rewriting has improved its shape+         -- Code is like the canNC, 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+           ForAllPred tvs th p   -> -- this is highly suspect; Quick Look+                                    -- should never leave a meta-var filled+                                    -- in with a polytype. This is #18987.+                                    do traceTcS "canEvNC:forall" (ppr pred)+                                       canForAllNC ev tvs th p+           IrredPred {}          -> continueWith $+                                    mkIrredCt IrredShapeReason new_ev } }++{- *********************************************************************+*                                                                      *+*                      Quantified predicates+*                                                                      *+********************************************************************* -}++{- Note [Quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The -XQuantifiedConstraints extension allows type-class contexts like this:++  data Rose f x = Rose x (f (Rose f x))++  instance (Eq a, forall b. Eq b => Eq (f b))+        => Eq (Rose f a)  where+    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2++Note the (forall b. Eq b => Eq (f b)) in the instance contexts.+This quantified constraint is needed to solve the+ [W] (Eq (f (Rose f x)))+constraint which arises form the (==) definition.++The wiki page is+  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints+which in turn contains a link to the GHC Proposal where the change+is specified, and a Haskell Symposium paper about it.++We implement two main extensions to the design in the paper:++ 1. We allow a variable in the instance head, e.g.+      f :: forall m a. (forall b. m b) => D (m a)+    Notice the 'm' in the head of the quantified constraint, not+    a class.++ 2. We support superclasses to quantified constraints.+    For example (contrived):+      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool+      f x y = x==y+    Here we need (Eq (m a)); but the quantified constraint deals only+    with Ord.  But we can make it work by using its superclass.++Here are the moving parts+  * Language extension {-# LANGUAGE QuantifiedConstraints #-}+    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension++  * A new form of evidence, EvDFun, that is used to discharge+    such wanted constraints++  * checkValidType gets some changes to accept forall-constraints+    only in the right places.++  * Predicate.Pred gets a new constructor ForAllPred, and+    and classifyPredType analyses a PredType to decompose+    the new forall-constraints++  * GHC.Tc.Solver.Monad.InertCans gets an extra field, inert_insts,+    which holds all the Given forall-constraints.  In effect,+    such Given constraints are like local instance decls.++  * When trying to solve a class constraint, via+    GHC.Tc.Solver.Interact.matchInstEnv, use the InstEnv from inert_insts+    so that we include the local Given forall-constraints+    in the lookup.  (See GHC.Tc.Solver.Monad.getInstEnvs.)++  * GHC.Tc.Solver.Canonical.canForAll deals with solving a+    forall-constraint.  See+       Note [Solving a Wanted forall-constraint]++  * We augment the kick-out code to kick out an inert+    forall constraint if it can be rewritten by a new+    type equality; see GHC.Tc.Solver.Monad.kick_out_rewritable++Note that a quantified constraint is never /inferred/+(by GHC.Tc.Solver.simplifyInfer).  A function can only have a+quantified constraint in its type if it is given an explicit+type signature.++-}++canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType+            -> TcS (StopOrContinue Ct)+canForAllNC ev tvs theta pred+  | isGiven ev  -- See Note [Eagerly expand given superclasses]+  , Just (cls, tys) <- cls_pred_tys_maybe+  = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys+       ; emitWork sc_cts+       ; canForAll ev False }++  | otherwise+  = canForAll ev (isJust cls_pred_tys_maybe)++  where+    cls_pred_tys_maybe = getClassPredTys_maybe pred++canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)+-- We have a constraint (forall as. blah => C tys)+canForAll ev pend_sc+  = do { -- First rewrite it to apply the current substitution+         let pred = ctEvPred ev+       ; (xi,co) <- rewrite ev pred -- co :: xi ~ pred+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->++    do { -- Now decompose into its pieces and solve it+         -- (It takes a lot less code to rewrite before decomposing.)+       ; case classifyPredType (ctEvPred new_ev) of+           ForAllPred tvs theta pred+              -> solveForAll new_ev tvs theta pred pend_sc+           _  -> pprPanic "canForAll" (ppr new_ev)+    } }++solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool+            -> TcS (StopOrContinue Ct)+solveForAll ev tvs theta pred pend_sc+  | CtWanted { ctev_dest = dest } <- ev+  = -- See Note [Solving a Wanted forall-constraint]+    do { let skol_info = QuantCtxtSkol+             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs+       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)++       ; (lvl, (w_id, wanteds))+             <- pushLevelNoWorkList (ppr skol_info) $+                do { wanted_ev <- newWantedEvVarNC loc $+                                  substTy subst pred+                   ; return ( ctEvEvId wanted_ev+                            , unitBag (mkNonCanonical wanted_ev)) }++      ; ev_binds <- emitImplicationTcS lvl skol_info skol_tvs+                                       given_ev_vars wanteds++      ; setWantedEvTerm dest $+        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars+              , et_binds = ev_binds, et_body = w_id }++      ; stopWith ev "Wanted forall-constraint" }++  | isGiven ev   -- See Note [Solving a Given forall-constraint]+  = do { addInertForAll qci+       ; stopWith ev "Given forall-constraint" }++  | otherwise+  = do { traceTcS "discarding derived forall-constraint" (ppr ev)+       ; stopWith ev "Derived forall-constraint" }+  where+    loc = ctEvLoc ev+    qci = QCI { qci_ev = ev, qci_tvs = tvs+              , qci_pred = pred, qci_pend_sc = pend_sc }++{- Note [Solving a Wanted forall-constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Solving a wanted forall (quantified) constraint+  [W] df :: forall ab. (Eq a, Ord b) => C x a b+is delightfully easy.   Just build an implication constraint+    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a+and discharge df thus:+    df = /\ab. \g1 g2. let <binds> in d+where <binds> is filled in by solving the implication constraint.+All the machinery is to hand; there is little to do.++Note [Solving a Given forall-constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a Given constraint+  [G] df :: forall ab. (Eq a, Ord b) => C x a b+we just add it to TcS's local InstEnv of known instances,+via addInertForall.  Then, if we look up (C x Int Bool), say,+we'll find a match in the InstEnv.+++************************************************************************+*                                                                      *+*        Equalities+*                                                                      *+************************************************************************++Note [Canonicalising equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to canonicalise an equality, we look at the structure of the+two types at hand, looking for similarities. A difficulty is that the+types may look dissimilar before rewriting but similar after rewriting.+However, we don't just want to jump in and rewrite right away, because+this might be wasted effort. So, after looking for similarities and failing,+we rewrite and then try again. Of course, we don't want to loop, so we+track whether or not we've already rewritten.++It is conceivable to do a better job at tracking whether or not a type+is rewritten, but this is left as future work. (Mar '15)+++Note [Decomposing FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~+can_eq_nc' may attempt to decompose a FunTy that is un-zonked.  This+means that we may very well have a FunTy containing a type of some+unknown kind. For instance, we may have,++    FunTy (a :: k) Int++Where k is a unification variable. So the calls to getRuntimeRep_maybe may+fail (returning Nothing).  In that case we'll fall through, zonk, and try again.+Zonking should fill the variable k, meaning that decomposition will succeed the+second time around.++Also note that we require the AnonArgFlag to match.  This will stop+us decomposing+   (Int -> Bool)  ~  (Show a => blah)+It's as if we treat (->) and (=>) as different type constructors.+-}++canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)+canEqNC ev eq_rel ty1 ty2+  = do { result <- zonk_eq_types ty1 ty2+       ; case result of+           Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2+           Right ty              -> canEqReflexive ev eq_rel ty }++can_eq_nc+   :: Bool            -- True => both types are rewritten+   -> CtEvidence+   -> EqRel+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp+   -> TcS (StopOrContinue Ct)+can_eq_nc rewritten ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  = do { traceTcS "can_eq_nc" $+         vcat [ ppr rewritten, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]+       ; rdr_env <- getGlobalRdrEnvTcS+       ; fam_insts <- getFamInstEnvs+       ; can_eq_nc' rewritten rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }++can_eq_nc'+   :: Bool           -- True => both input types are rewritten+   -> GlobalRdrEnv   -- needed to see which newtypes are in scope+   -> FamInstEnvs    -- needed to unwrap data instances+   -> CtEvidence+   -> EqRel+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp+   -> TcS (StopOrContinue Ct)++-- See Note [Comparing nullary type synonyms] in GHC.Core.Type.+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(TyConApp tc1 []) _ps_ty1 (TyConApp tc2 []) _ps_ty2+  | tc1 == tc2+  = canEqReflexive ev eq_rel ty1++-- Expand synonyms first; see Note [Type synonyms and canonicalization]+can_eq_nc' rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | Just ty1' <- tcView ty1 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2+  | Just ty2' <- tcView ty2 = can_eq_nc' rewritten rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2++-- need to check for reflexivity in the ReprEq case.+-- See Note [Eager reflexivity check]+-- Check only when rewritten because the zonk_eq_types check in canEqNC takes+-- care of the non-rewritten case.+can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _+  | ty1 `tcEqType` ty2+  = canEqReflexive ev ReprEq ty1++-- When working with ReprEq, unwrap newtypes.+-- See Note [Unwrap newtypes first]+-- This must be above the TyVarTy case, in order to guarantee (TyEq:N)+can_eq_nc' _rewritten rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | ReprEq <- eq_rel+  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2++  | ReprEq <- eq_rel+  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2+  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1++-- Then, get rid of casts+can_eq_nc' rewritten _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2+  | isNothing (canEqLHS_maybe ty2)  -- See (3) in Note [Equalities with incompatible kinds]+  = canEqCast rewritten ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2+can_eq_nc' rewritten _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _+  | isNothing (canEqLHS_maybe ty1)  -- See (3) in Note [Equalities with incompatible kinds]+  = canEqCast rewritten ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1++----------------------+-- Otherwise try to decompose+----------------------++-- Literals+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _+ | l1 == l2+  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)+       ; stopWith ev "Equal LitTy" }++-- Decompose FunTy: (s -> t) and (c => t)+-- NB: don't decompose (Int -> blah) ~ (Show a => blah)+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel+           (FunTy { ft_mult = am1, ft_af = af1, ft_arg = ty1a, ft_res = ty1b }) _ps_ty1+           (FunTy { ft_mult = am2, ft_af = af2, ft_arg = ty2a, ft_res = ty2b }) _ps_ty2+  | af1 == af2   -- Don't decompose (Int -> blah) ~ (Show a => blah)+  , Just ty1a_rep <- getRuntimeRep_maybe ty1a  -- getRutimeRep_maybe:+  , Just ty1b_rep <- getRuntimeRep_maybe ty1b  -- see Note [Decomposing FunTy]+  , Just ty2a_rep <- getRuntimeRep_maybe ty2a+  , Just ty2b_rep <- getRuntimeRep_maybe ty2b+  = canDecomposableTyConAppOK ev eq_rel funTyCon+                              [am1, ty1a_rep, ty1b_rep, ty1a, ty1b]+                              [am2, ty2a_rep, ty2b_rep, ty2a, ty2b]++-- Decompose type constructor applications+-- NB: we have expanded type synonyms already+can_eq_nc' _rewritten _rdr_env _envs ev eq_rel ty1 _ ty2 _+  | Just (tc1, tys1) <- tcSplitTyConApp_maybe ty1+  , Just (tc2, tys2) <- tcSplitTyConApp_maybe ty2+   -- we want to catch e.g. Maybe Int ~ (Int -> Int) here for better+   -- error messages rather than decomposing into AppTys;+   -- hence no direct match on TyConApp+  , not (isTypeFamilyTyCon tc1)+  , not (isTypeFamilyTyCon tc2)+  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2++can_eq_nc' _rewritten _rdr_env _envs ev eq_rel+           s1@(ForAllTy (Bndr _ vis1) _) _+           s2@(ForAllTy (Bndr _ vis2) _) _+  | vis1 `sameVis` vis2 -- Note [ForAllTy and typechecker equality]+  = can_eq_nc_forall ev eq_rel s1 s2++-- See Note [Canonicalising type applications] about why we require rewritten types+-- Use tcSplitAppTy, not matching on AppTy, to catch oversaturated type families+-- NB: Only decompose AppTy for nominal equality. See Note [Decomposing equality]+can_eq_nc' True _rdr_env _envs ev NomEq ty1 _ ty2 _+  | Just (t1, s1) <- tcSplitAppTy_maybe ty1+  , Just (t2, s2) <- tcSplitAppTy_maybe ty2+  = can_eq_app ev t1 s1 t2 s2++-------------------+-- Can't decompose.+-------------------++-- No similarity in type structure detected. Rewrite and try again.+can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2+  = do { (xi1, co1) <- rewrite ev ps_ty1+       ; (xi2, co2) <- rewrite ev ps_ty2+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }++----------------------------+-- Look for a canonical LHS. See Note [Canonical LHS].+-- Only rewritten types end up below here.+----------------------------++-- NB: pattern match on True: we want only rewritten types sent to canEqLHS+-- This means we've rewritten any variables and reduced any type family redexes+-- See also Note [No top-level newtypes on RHS of representational equalities]+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | Just can_eq_lhs1 <- canEqLHS_maybe ty1+  = canEqCanLHS ev eq_rel NotSwapped can_eq_lhs1 ps_ty1 ty2 ps_ty2++  | Just can_eq_lhs2 <- canEqLHS_maybe ty2+  = canEqCanLHS ev eq_rel IsSwapped can_eq_lhs2 ps_ty2 ty1 ps_ty1++     -- If the type is TyConApp tc1 args1, then args1 really can't be less+     -- than tyConArity tc1. It could be *more* than tyConArity, but then we+     -- should have handled the case as an AppTy. That case only fires if+     -- _both_ sides of the equality are AppTy-like... but if one side is+     -- AppTy-like and the other isn't (and it also isn't a variable or+     -- saturated type family application, both of which are handled by+     -- can_eq_nc'), we're in a failure mode and can just fall through.++----------------------------+-- Fall-through. Give up.+----------------------------++-- We've rewritten and the types don't match. Give up.+can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2+  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)+       ; case eq_rel of -- See Note [Unsolved equalities]+            ReprEq -> continueWith (mkIrredCt ReprEqReason ev)+            NomEq  -> continueWith (mkIrredCt ShapeMismatchReason ev) }+          -- No need to call canEqFailure/canEqHardFailure because they+          -- rewrite, and the types involved here are already rewritten++{- Note [Unsolved equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an unsolved equality like+  (a b ~R# Int)+that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.+So we want to make it a potentially-soluble Irred not an insoluble one.+Missing this point is what caused #15431++Note [ForAllTy and typechecker equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should GHC type-check the following program (adapted from #15740)?++  {-# LANGUAGE PolyKinds, ... #-}+  data D a+  type family F :: forall k. k -> Type+  type instance F = D++Due to the way F is declared, any instance of F must have a right-hand side+whose kind is equal to `forall k. k -> Type`. The kind of D is+`forall {k}. k -> Type`, which is very close, but technically uses distinct+Core:++  -----------------------------------------------------------+  | Source Haskell    | Core                                |+  -----------------------------------------------------------+  | forall  k.  <...> | ForAllTy (Bndr k Specified) (<...>) |+  | forall {k}. <...> | ForAllTy (Bndr k Inferred)  (<...>) |+  -----------------------------------------------------------++We could deem these kinds to be unequal, but that would imply rejecting+programs like the one above. Whether a kind variable binder ends up being+specified or inferred can be somewhat subtle, however, especially for kinds+that aren't explicitly written out in the source code (like in D above).+For now, we decide to not make the specified/inferred status of an invisible+type variable binder affect GHC's notion of typechecker equality+(see Note [Typechecker equality vs definitional equality] in+GHC.Tc.Utils.TcType). That is, we have the following:++  --------------------------------------------------+  | Type 1            | Type 2            | Equal? |+  --------------------|-----------------------------+  | forall k. <...>   | forall k. <...>   | Yes    |+  |                   | forall {k}. <...> | Yes    |+  |                   | forall k -> <...> | No     |+  --------------------------------------------------+  | forall {k}. <...> | forall k. <...>   | Yes    |+  |                   | forall {k}. <...> | Yes    |+  |                   | forall k -> <...> | No     |+  --------------------------------------------------+  | forall k -> <...> | forall k. <...>   | No     |+  |                   | forall {k}. <...> | No     |+  |                   | forall k -> <...> | Yes    |+  --------------------------------------------------++We implement this nuance by using the GHC.Types.Var.sameVis function in+GHC.Tc.Solver.Canonical.canEqNC and GHC.Tc.Utils.TcType.tcEqType, which+respect typechecker equality. sameVis puts both forms of invisible type+variable binders into the same equivalence class.++Note that we do /not/ use sameVis in GHC.Core.Type.eqType, which implements+/definitional/ equality, a slighty more coarse-grained notion of equality+(see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep) that does+not consider the ArgFlag of ForAllTys at all. That is, eqType would equate all+of forall k. <...>, forall {k}. <...>, and forall k -> <...>.+-}++---------------------------------+can_eq_nc_forall :: CtEvidence -> EqRel+                 -> Type -> Type    -- LHS and RHS+                 -> TcS (StopOrContinue Ct)+-- (forall as. phi1) ~ (forall bs. phi2)+-- Check for length match of as, bs+-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]+-- But remember also to unify the kinds of as and bs+--  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]+-- Remember also that we might have forall z (a:z). blah+--  so we must proceed one binder at a time (#13879)++can_eq_nc_forall ev eq_rel s1 s2+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev+ = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]+            (bndrs1, phi1) = tcSplitForAllTyVarBinders s1+            (bndrs2, phi2) = tcSplitForAllTyVarBinders s2+      ; if not (equalLength bndrs1 bndrs2)+        then do { traceTcS "Forall failure" $+                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2+                          , ppr (map binderArgFlag bndrs1)+                          , ppr (map binderArgFlag bndrs2) ]+                ; canEqHardFailure ev s1 s2 }+        else+   do { traceTcS "Creating implication for polytype equality" $ ppr ev+      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $+                              binderVars bndrs1++      ; let skol_info = UnifyForAllSkol phi1+            phi1' = substTy subst1 phi1++            -- Unify the kinds, extend the substitution+            go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]+               -> TcS (TcCoercion, Cts)+            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)+              = do { let tv2 = binderVar bndr2+                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)+                                                  (substTy subst (tyVarKind tv2))+                   ; let subst' = extendTvSubstAndInScope subst tv2+                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)+                         -- skol_tv is already in the in-scope set, but the+                         -- free vars of kind_co are not; hence "...AndInScope"+                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2+                   ; return ( mkTcForAllCo skol_tv kind_co co+                            , wanteds1 `unionBags` wanteds2 ) }++            -- Done: unify phi1 ~ phi2+            go [] subst bndrs2+              = ASSERT( null bndrs2 )+                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)++            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []++            empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)++      ; (lvl, (all_co, wanteds)) <- pushLevelNoWorkList (ppr skol_info) $+                                    go skol_tvs empty_subst2 bndrs2+      ; emitTvImplicationTcS lvl skol_info skol_tvs wanteds++      ; setWantedEq orig_dest all_co+      ; stopWith ev "Deferred polytype equality" } }++ | otherwise+ = do { traceTcS "Omitting decomposition of given polytype equality" $+        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]+      ; stopWith ev "Discard given polytype equality" }++ where+    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)+    -- This version returns the wanted constraint rather+    -- than putting it in the work list+    unify loc role ty1 ty2+      | ty1 `tcEqType` ty2+      = return (mkTcReflCo role ty1, emptyBag)+      | otherwise+      = do { (wanted, co) <- newWantedEq loc role ty1 ty2+           ; return (co, unitBag (mkNonCanonical wanted)) }++---------------------------------+-- | Compare types for equality, while zonking as necessary. Gives up+-- as soon as it finds that two types are not equal.+-- This is quite handy when some unification has made two+-- types in an inert Wanted to be equal. We can discover the equality without+-- rewriting, which is sometimes very expensive (in the case of type functions).+-- In particular, this function makes a ~20% improvement in test case+-- perf/compiler/T5030.+--+-- Returns either the (partially zonked) types in the case of+-- inequality, or the one type in the case of equality. canEqReflexive is+-- a good next step in the 'Right' case. Returning 'Left' is always safe.+--+-- NB: This does *not* look through type synonyms. In fact, it treats type+-- synonyms as rigid constructors. In the future, it might be convenient+-- to look at only those arguments of type synonyms that actually appear+-- in the synonym RHS. But we're not there yet.+zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)+zonk_eq_types = go+  where+    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2+    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2+    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1++    -- We handle FunTys explicitly here despite the fact that they could also be+    -- treated as an application. Why? Well, for one it's cheaper to just look+    -- at two types (the argument and result types) than four (the argument,+    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,+    -- so we may run into an unzonked type variable while trying to compute the+    -- RuntimeReps of the argument and result types. This can be observed in+    -- testcase tc269.+    go ty1 ty2+      | Just (Scaled w1 arg1, res1) <- split1+      , Just (Scaled w2 arg2, res2) <- split2+      , eqType w1 w2+      = do { res_a <- go arg1 arg2+           ; res_b <- go res1 res2+           ; return $ combine_rev (mkVisFunTy w1) res_b res_a+           }+      | isJust split1 || isJust split2+      = bale_out ty1 ty2+      where+        split1 = tcSplitFunTy_maybe ty1+        split2 = tcSplitFunTy_maybe ty2++    go ty1 ty2+      | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1+      , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2+      = if tc1 == tc2 && tys1 `equalLength` tys2+          -- Crucial to check for equal-length args, because+          -- we cannot assume that the two args to 'go' have+          -- the same kind.  E.g go (Proxy *      (Maybe Int))+          --                        (Proxy (*->*) Maybe)+          -- We'll call (go (Maybe Int) Maybe)+          -- See #13083+        then tycon tc1 tys1 tys2+        else bale_out ty1 ty2++    go ty1 ty2+      | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+      , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+      = do { res_a <- go ty1a ty2a+           ; res_b <- go ty1b ty2b+           ; return $ combine_rev mkAppTy res_b res_a }++    go ty1@(LitTy lit1) (LitTy lit2)+      | lit1 == lit2+      = return (Right ty1)++    go ty1 ty2 = bale_out ty1 ty2+      -- We don't handle more complex forms here++    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)++    tyvar :: SwapFlag -> TcTyVar -> TcType+          -> TcS (Either (Pair TcType) TcType)+      -- Try to do as little as possible, as anything we do here is redundant+      -- with rewriting. In particular, no need to zonk kinds. That's why+      -- we don't use the already-defined zonking functions+    tyvar swapped tv ty+      = case tcTyVarDetails tv of+          MetaTv { mtv_ref = ref }+            -> do { cts <- readTcRef ref+                  ; case cts of+                      Flexi        -> give_up+                      Indirect ty' -> do { trace_indirect tv ty'+                                         ; unSwap swapped go ty' ty } }+          _ -> give_up+      where+        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty++    tyvar_tyvar tv1 tv2+      | tv1 == tv2 = return (Right (mkTyVarTy tv1))+      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1+                        ; (ty2', progress2) <- quick_zonk tv2+                        ; if progress1 || progress2+                          then go ty1' ty2'+                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }++    trace_indirect tv ty+       = traceTcS "Following filled tyvar (zonk_eq_types)"+                  (ppr tv <+> equals <+> ppr ty)++    quick_zonk tv = case tcTyVarDetails tv of+      MetaTv { mtv_ref = ref }+        -> do { cts <- readTcRef ref+              ; case cts of+                  Flexi        -> return (TyVarTy tv, False)+                  Indirect ty' -> do { trace_indirect tv ty'+                                     ; return (ty', True) } }+      _ -> return (TyVarTy tv, False)++      -- This happens for type families, too. But recall that failure+      -- here just means to try harder, so it's OK if the type function+      -- isn't injective.+    tycon :: TyCon -> [TcType] -> [TcType]+          -> TcS (Either (Pair TcType) TcType)+    tycon tc tys1 tys2+      = do { results <- zipWithM go tys1 tys2+           ; return $ case combine_results results of+               Left tys  -> Left (mkTyConApp tc <$> tys)+               Right tys -> Right (mkTyConApp tc tys) }++    combine_results :: [Either (Pair TcType) TcType]+                    -> Either (Pair [TcType]) [TcType]+    combine_results = bimap (fmap reverse) reverse .+                      foldl' (combine_rev (:)) (Right [])++      -- combine (in reverse) a new result onto an already-combined result+    combine_rev :: (a -> b -> c)+                -> Either (Pair b) b+                -> Either (Pair a) a+                -> Either (Pair c) c+    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)+    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)+    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)+    combine_rev f (Right tys) (Right ty) = Right (f ty tys)++{- See Note [Unwrap newtypes first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  newtype N m a = MkN (m a)+Then N will get a conservative, Nominal role for its second parameter 'a',+because it appears as an argument to the unknown 'm'. Now consider+  [W] N Maybe a  ~R#  N Maybe b++If we decompose, we'll get+  [W] a ~N# b++But if instead we unwrap we'll get+  [W] Maybe a ~R# Maybe b+which in turn gives us+  [W] a ~R# b+which is easier to satisfy.++Bottom line: unwrap newtypes before decomposing them!+c.f. #9123 comment:52,53 for a compelling example.++Note [Newtypes can blow the stack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype X = MkX (Int -> X)+  newtype Y = MkY (Int -> Y)++and now wish to prove++  [W] X ~R Y++This Wanted will loop, expanding out the newtypes ever deeper looking+for a solid match or a solid discrepancy. Indeed, there is something+appropriate to this looping, because X and Y *do* have the same representation,+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized+coercion will ever witness it. This loop won't actually cause GHC to hang,+though, because we check our depth when unwrapping newtypes.++Note [Eager reflexivity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype X = MkX (Int -> X)++and++  [W] X ~R X++Naively, we would start unwrapping X and end up in a loop. Instead,+we do this eager reflexivity check. This is necessary only for representational+equality because the rewriter technology deals with the similar case+(recursive type families) for nominal equality.++Note that this check does not catch all cases, but it will catch the cases+we're most worried about, types like X above that are actually inhabited.++Here's another place where this reflexivity check is key:+Consider trying to prove (f a) ~R (f a). The AppTys in there can't+be decomposed, because representational equality isn't congruent with respect+to AppTy. So, when canonicalising the equality above, we get stuck and+would normally produce a CIrredCan. However, we really do want to+be able to solve (f a) ~R (f a). So, in the representational case only,+we do a reflexivity check.++(This would be sound in the nominal case, but unnecessary, and I [Richard+E.] am worried that it would slow down the common case.)+-}++------------------------+-- | We're able to unwrap a newtype. Update the bits accordingly.+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2+                  -> SwapFlag+                  -> TcType                                    -- ^ ty1+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'+                  -> TcType               -- ^ ty2+                  -> TcType               -- ^ ty2, with type synonyms+                  -> TcS (StopOrContinue Ct)+can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2+  = do { traceTcS "can_eq_newtype_nc" $+         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]++         -- check for blowing our stack:+         -- See Note [Newtypes can blow the stack]+       ; checkReductionDepth (ctEvLoc ev) ty1++         -- Next, we record uses of newtype constructors, since coercing+         -- through newtypes is tantamount to using their constructors.+       ; addUsedGREs gre_list+         -- If a newtype constructor was imported, don't warn about not+         -- importing it...+       ; traverse_ keepAlive $ map greMangledName gre_list+         -- ...and similarly, if a newtype constructor was defined in the same+         -- module, don't warn about it being unused.+         -- See Note [Tracking unused binding and imports] in GHC.Tc.Utils.++       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2+                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)+       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }+  where+    gre_list = bagToList gres++---------+-- ^ Decompose a type application.+-- All input types must be rewritten. See Note [Canonicalising type applications]+-- Nominal equality only!+can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2+           -> Xi -> Xi         -- s1 t1+           -> Xi -> Xi         -- s2 t2+           -> TcS (StopOrContinue Ct)++-- AppTys only decompose for nominal equality, so this case just leads+-- to an irreducible constraint; see typecheck/should_compile/T10494+-- See Note [Decomposing AppTy at representational role]+can_eq_app ev s1 t1 s2 t2+  | CtDerived {} <- ev+  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]+       ; stopWith ev "Decomposed [D] AppTy" }++  | CtWanted { ctev_dest = dest } <- ev+  = do { co_s <- unifyWanted loc Nominal s1 s2+       ; let arg_loc+               | isNextArgVisible s1 = loc+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin+       ; co_t <- unifyWanted arg_loc Nominal t1 t2+       ; let co = mkAppCo co_s co_t+       ; setWantedEq dest co+       ; stopWith ev "Decomposed [W] AppTy" }++    -- If there is a ForAll/(->) mismatch, the use of the Left coercion+    -- below is ill-typed, potentially leading to a panic in splitTyConApp+    -- Test case: typecheck/should_run/Typeable1+    -- We could also include this mismatch check above (for W and D), but it's slow+    -- and we'll get a better error message not doing it+  | s1k `mismatches` s2k+  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)++  | CtGiven { ctev_evar = evar } <- ev+  = do { let co   = mkTcCoVarCo evar+             co_s = mkTcLRCo CLeft  co+             co_t = mkTcLRCo CRight co+       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2+                                     , evCoercion co_s )+       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2+                                     , evCoercion co_t )+       ; emitWorkNC [evar_t]+       ; canEqNC evar_s NomEq s1 s2 }++  where+    loc = ctEvLoc ev++    s1k = tcTypeKind s1+    s2k = tcTypeKind s2++    k1 `mismatches` k2+      =  isForAllTy k1 && not (isForAllTy k2)+      || not (isForAllTy k1) && isForAllTy k2++-----------------------+-- | Break apart an equality over a casted type+-- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)+canEqCast :: Bool         -- are both types rewritten?+          -> CtEvidence+          -> EqRel+          -> SwapFlag+          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1+          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty+          -> TcS (StopOrContinue Ct)+canEqCast rewritten ev eq_rel swapped ty1 co1 ty2 ps_ty2+  = do { traceTcS "Decomposing cast" (vcat [ ppr ev+                                           , ppr ty1 <+> text "|>" <+> ppr co1+                                           , ppr ps_ty2 ])+       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2+                                     (mkTcGReflRightCo role ty1 co1)+                                     (mkTcReflCo role ps_ty2)+       ; can_eq_nc rewritten new_ev eq_rel ty1 ty1 ty2 ps_ty2 }+  where+    role = eqRelRole eq_rel++------------------------+canTyConApp :: CtEvidence -> EqRel+            -> TyCon -> [TcType]+            -> TyCon -> [TcType]+            -> TcS (StopOrContinue Ct)+-- See Note [Decomposing TyConApps]+-- Neither tc1 nor tc2 is a saturated funTyCon+canTyConApp ev eq_rel tc1 tys1 tc2 tys2+  | tc1 == tc2+  , tys1 `equalLength` tys2+  = do { inerts <- getTcSInerts+       ; if can_decompose inerts+         then canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2+         else canEqFailure ev eq_rel ty1 ty2 }++  -- See Note [Skolem abstract data] in GHC.Core.Tycon+  | tyConSkolem tc1 || tyConSkolem tc2+  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)+       ; continueWith (mkIrredCt AbstractTyConReason ev) }++  -- Fail straight away for better error messages+  -- See Note [Use canEqFailure in canDecomposableTyConApp]+  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&+                             isGenerativeTyCon tc2 Representational)+  = canEqFailure ev eq_rel ty1 ty2+  | otherwise+  = canEqHardFailure ev ty1 ty2+  where+    -- Reconstruct the types for error messages. This would do+    -- the wrong thing (from a pretty printing point of view)+    -- for functions, because we've lost the AnonArgFlag; but+    -- in fact we never call canTyConApp on a saturated FunTyCon+    ty1 = mkTyConApp tc1 tys1+    ty2 = mkTyConApp tc2 tys2++    loc  = ctEvLoc ev+    pred = ctEvPred ev++     -- See Note [Decomposing equality]+    can_decompose inerts+      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)+      || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))++{-+Note [Use canEqFailure in canDecomposableTyConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must use canEqFailure, not canEqHardFailure here, because there is+the possibility of success if working with a representational equality.+Here is one case:++  type family TF a where TF Char = Bool+  data family DF a+  newtype instance DF Bool = MkDF Int++Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet+know `a`. This is *not* a hard failure, because we might soon learn+that `a` is, in fact, Char, and then the equality succeeds.++Here is another case:++  [G] Age ~R Int++where Age's constructor is not in scope. We don't want to report+an "inaccessible code" error in the context of this Given!++For example, see typecheck/should_compile/T10493, repeated here:++  import Data.Ord (Down)  -- no constructor++  foo :: Coercible (Down Int) Int => Down Int -> Int+  foo = coerce++That should compile, but only because we use canEqFailure and not+canEqHardFailure.++Note [Decomposing equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a constraint (of any flavour and role) that looks like+T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,+of course, is "it depends". This Note spells it all out.++In this Note, "decomposition" refers to taking the constraint+  [fl] (T tys1 ~X T tys2)+(for some flavour fl and some role X) and replacing it with+  [fls'] (tys1 ~Xs' tys2)+where that notation indicates a list of new constraints, where the+new constraints may have different flavours and different roles.++The key property to consider is injectivity. When decomposing a Given, the+decomposition is sound if and only if T is injective in all of its type+arguments. When decomposing a Wanted, the decomposition is sound (assuming the+correct roles in the produced equality constraints), but it may be a guess --+that is, an unforced decision by the constraint solver. Decomposing Wanteds+over injective TyCons does not entail guessing. But sometimes we want to+decompose a Wanted even when the TyCon involved is not injective! (See below.)++So, in broad strokes, we want this rule:++(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective+at role X.++Pursuing the details requires exploring three axes:+* Flavour: Given vs. Derived vs. Wanted+* Role: Nominal vs. Representational+* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable++(A type variable isn't a TyCon, of course, but it's convenient to put the AppTy case+in the same table.)++Right away, we can say that Derived behaves just as Wanted for the purposes+of decomposition. The difference between Derived and Wanted is the handling of+evidence. Since decomposition in these cases isn't a matter of soundness but of+guessing, we want the same behaviour regardless of evidence.++Here is a table (discussion following) detailing where decomposition of+   (T s1 ... sn) ~r (T t1 .. tn)+is allowed.  The first four lines (Data types ... type family) refer+to TyConApps with various TyCons T; the last line is for AppTy, covering+both where there is a type variable at the head and the case for an over-+saturated type family.++NOMINAL               GIVEN        WANTED                         WHERE++Datatype               YES          YES                           canTyConApp+Newtype                YES          YES                           canTyConApp+Data family            YES          YES                           canTyConApp+Type family            NO{1}        YES, in injective args{1}     canEqCanLHS2+AppTy                  YES          YES                           can_eq_app++REPRESENTATIONAL      GIVEN        WANTED++Datatype               YES          YES                           canTyConApp+Newtype                NO{2}       MAYBE{2}                canTyConApp(can_decompose)+Data family            NO{3}       MAYBE{3}                canTyConApp(can_decompose)+Type family            NO           NO                            canEqCanLHS2+AppTy                  NO{4}        NO{4}                         can_eq_nc'++{1}: Type families can be injective in some, but not all, of their arguments,+so we want to do partial decomposition. This is quite different than the way+other decomposition is done, where the decomposed equalities replace the original+one. We thus proceed much like we do with superclasses, emitting new Deriveds+when "decomposing" a partially-injective type family Wanted. Injective type+families have no corresponding evidence of their injectivity, so we cannot+decompose an injective-type-family Given.++{2}: See Note [Decomposing newtypes at representational role]++{3}: Because of the possibility of newtype instances, we must treat+data families like newtypes. See also+Note [Decomposing newtypes at representational role]. See #10534 and+test case typecheck/should_fail/T10534.++{4}: See Note [Decomposing AppTy at representational role]++In the implementation of can_eq_nc and friends, we don't directly pattern+match using lines like in the tables above, as those tables don't cover+all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,+boiling the tables above down to rule (*). The exceptions to rule (*) are for+injective type families, which are handled separately from other decompositions,+and the MAYBE entries above.++Note [Decomposing newtypes at representational role]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note discusses the 'newtype' line in the REPRESENTATIONAL table+in Note [Decomposing equality]. (At nominal role, newtypes are fully+decomposable.)++Here is a representative example of why representational equality over+newtypes is tricky:++  newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,+  type role Nt representational  -- but the user gives it an R role anyway++If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to+[W] alpha ~R beta, because it's possible that alpha and beta aren't+representationally equal. Here's another example.++  newtype Nt a = MkNt (Id a)+  type family Id a where Id a = a++  [W] Nt Int ~R Nt Age++Because of its use of a type family, Nt's parameter will get inferred to have+a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which+is unsatisfiable. Unwrapping, though, leads to a solution.++Conclusion:+ * Unwrap newtypes before attempting to decompose them.+   This is done in can_eq_nc'.++It all comes from the fact that newtypes aren't necessarily injective+w.r.t. representational equality.++Furthermore, as explained in Note [NthCo and newtypes] in GHC.Core.TyCo.Rep, we can't use+NthCo on representational coercions over newtypes. NthCo comes into play+only when decomposing givens.++Conclusion:+ * Do not decompose [G] N s ~R N t++Is it sensible to decompose *Wanted* constraints over newtypes?  Yes!+It's the only way we could ever prove (IO Int ~R IO Age), recalling+that IO is a newtype.++However we must be careful.  Consider++  type role Nt representational++  [G] Nt a ~R Nt b       (1)+  [W] NT alpha ~R Nt b   (2)+  [W] alpha ~ a          (3)++If we focus on (3) first, we'll substitute in (2), and now it's+identical to the given (1), so we succeed.  But if we focus on (2)+first, and decompose it, we'll get (alpha ~R b), which is not soluble.+This is exactly like the question of overlapping Givens for class+constraints: see Note [Instance and Given overlap] in GHC.Tc.Solver.Interact.++Conclusion:+  * Decompose [W] N s ~R N t  iff there no given constraint that could+    later solve it.++Note [Decomposing AppTy at representational role]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never decompose AppTy at a representational role. For Givens, doing+so is simply unsound: the LRCo coercion former requires a nominal-roled+arguments. (See (1) for an example of why.) For Wanteds, decomposing+would be sound, but it would be a guess, and a non-confluent one at that.++Here is an example:++    [G] g1 :: a ~R b+    [W] w1 :: Maybe b ~R alpha a+    [W] w2 :: alpha ~ Maybe++Suppose we see w1 before w2. If we were to decompose, we would decompose+this to become++    [W] w3 :: Maybe ~R alpha+    [W] w4 :: b ~ a++Note that w4 is *nominal*. A nominal role here is necessary because AppCo+requires a nominal role on its second argument. (See (2) for an example of+why.) If we decomposed w1 to w3,w4, we would then get stuck, because w4+is insoluble. On the other hand, if we see w2 first, setting alpha := Maybe,+all is well, as we can decompose Maybe b ~R Maybe a into b ~R a.++Another example:++    newtype Phant x = MkPhant Int++    [W] w1 :: Phant Int ~R alpha Bool+    [W] w2 :: alpha ~ Phant++If we see w1 first, decomposing would be disastrous, as we would then try+to solve Int ~ Bool. Instead, spotting w2 allows us to simplify w1 to become++    [W] w1' :: Phant Int ~R Phant Bool++which can then (assuming MkPhant is in scope) be simplified to Int ~R Int,+and all will be well. See also Note [Unwrap newtypes first].++Bottom line: never decompose AppTy with representational roles.++(1) Decomposing a Given AppTy over a representational role is simply+unsound. For example, if we have co1 :: Phant Int ~R a Bool (for+the newtype Phant, above), then we surely don't want any relationship+between Int and Bool, lest we also have co2 :: Phant ~ a around.++(2) The role on the AppCo coercion is a conservative choice, because we don't+know the role signature of the function. For example, let's assume we could+have a representational role on the second argument of AppCo. Then, consider++    data G a where    -- G will have a nominal role, as G is a GADT+      MkG :: G Int+    newtype Age = MkAge Int++    co1 :: G ~R a        -- by assumption+    co2 :: Age ~R Int    -- by newtype axiom+    co3 = AppCo co1 co2 :: G Age ~R a Int    -- by our broken AppCo++and now co3 can be used to cast MkG to have type G Age, in violation of+the way GADTs are supposed to work (which is to use nominal equality).++-}++canDecomposableTyConAppOK :: CtEvidence -> EqRel+                          -> TyCon -> [TcType] -> [TcType]+                          -> TcS (StopOrContinue Ct)+-- Precondition: tys1 and tys2 are the same length, hence "OK"+canDecomposableTyConAppOK ev eq_rel tc tys1 tys2+  = ASSERT( tys1 `equalLength` tys2 )+    do { traceTcS "canDecomposableTyConAppOK"+                  (ppr ev $$ ppr eq_rel $$ ppr tc $$ ppr tys1 $$ ppr tys2)+       ; case ev of+           CtDerived {}+             -> unifyDeriveds loc tc_roles tys1 tys2++           CtWanted { ctev_dest = dest }+                  -- new_locs and tc_roles are both infinite, so+                  -- we are guaranteed that cos has the same length+                  -- as tys1 and tys2+             -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2+                   ; setWantedEq dest (mkTyConAppCo role tc cos) }++           CtGiven { ctev_evar = evar }+             -> do { let ev_co = mkCoVarCo evar+                   ; given_evs <- newGivenEvVars loc $+                                  [ ( mkPrimEqPredRole r ty1 ty2+                                    , evCoercion $ mkNthCo r i ev_co )+                                  | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]+                                  , r /= Phantom+                                  , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]+                   ; emitWorkNC given_evs }++    ; stopWith ev "Decomposed TyConApp" }++  where+    loc        = ctEvLoc ev+    role       = eqRelRole eq_rel++      -- infinite, as tyConRolesX returns an infinite tail of Nominal+    tc_roles   = tyConRolesX role tc++      -- Add nuances to the location during decomposition:+      --  * if the argument is a kind argument, remember this, so that error+      --    messages say "kind", not "type". This is determined based on whether+      --    the corresponding tyConBinder is named (that is, dependent)+      --  * if the argument is invisible, note this as well, again by+      --    looking at the corresponding binder+      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't+      -- do either of these changes. (Forgetting to do so led to #16188)+      --+      -- NB: infinite in length+    new_locs = [ new_loc+               | bndr <- tyConBinders tc+               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc+                              | otherwise               = loc+                     new_loc  | isInvisibleTyConBinder bndr+                              = updateCtLocOrigin new_loc0 toInvisibleOrigin+                              | otherwise+                              = new_loc0 ]+               ++ repeat loc++-- | Call when canonicalizing an equality fails, but if the equality is+-- representational, there is some hope for the future.+-- Examples in Note [Use canEqFailure in canDecomposableTyConApp]+canEqFailure :: CtEvidence -> EqRel+             -> TcType -> TcType -> TcS (StopOrContinue Ct)+canEqFailure ev NomEq ty1 ty2+  = canEqHardFailure ev ty1 ty2+canEqFailure ev ReprEq ty1 ty2+  = do { (xi1, co1) <- rewrite ev ty1+       ; (xi2, co2) <- rewrite ev ty2+            -- We must rewrite the types before putting them in the+            -- inert set, so that we are sure to kick them out when+            -- new equalities become available+       ; traceTcS "canEqFailure with ReprEq" $+         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+       ; continueWith (mkIrredCt ReprEqReason new_ev) }++-- | Call when canonicalizing an equality fails with utterly no hope.+canEqHardFailure :: CtEvidence+                 -> TcType -> TcType -> TcS (StopOrContinue Ct)+-- See Note [Make sure that insolubles are fully rewritten]+canEqHardFailure ev ty1 ty2+  = do { traceTcS "canEqHardFailure" (ppr ty1 $$ ppr ty2)+       ; (s1, co1) <- rewrite ev ty1+       ; (s2, co2) <- rewrite ev ty2+       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2+       ; continueWith (mkIrredCt ShapeMismatchReason new_ev) }++{-+Note [Decomposing TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see (T s1 t1 ~ T s2 t2), then we can just decompose to+  (s1 ~ s2, t1 ~ t2)+and push those back into the work list.  But if+  s1 = K k1    s2 = K k2+then we will just decomopose s1~s2, and it might be better to+do so on the spot.  An important special case is where s1=s2,+and we get just Refl.++So canDecomposableTyCon is a fast-path decomposition that uses+unifyWanted etc to short-cut that work.++Note [Canonicalising type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (s1 t1) ~ ty2, how should we proceed?+The simple thing is to see if ty2 is of form (s2 t2), and+decompose.++However, over-eager decomposition gives bad error messages+for things like+   a b ~ Maybe c+   e f ~ p -> q+Suppose (in the first example) we already know a~Array.  Then if we+decompose the application eagerly, yielding+   a ~ Maybe+   b ~ c+we get an error        "Can't match Array ~ Maybe",+but we'd prefer to get "Can't match Array b ~ Maybe c".++So instead can_eq_wanted_app rewrites the LHS and RHS, in the hope of+replacing (a b) by (Array b), before using try_decompose_app to+decompose it.++Note [Make sure that insolubles are fully rewritten]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When an equality fails, we still want to rewrite the equality+all the way down, so that it accurately reflects+ (a) the mutable reference substitution in force at start of solving+ (b) any ty-binds in force at this point in solving+See Note [Rewrite insolubles] in GHC.Tc.Solver.Monad.+And if we don't do this there is a bad danger that+GHC.Tc.Solver.applyTyVarDefaulting will find a variable+that has in fact been substituted.++Note [Do not decompose Given polytype equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?+No -- what would the evidence look like?  So instead we simply discard+this given evidence.+++Note [Combining insoluble constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As this point we have an insoluble constraint, like Int~Bool.++ * If it is Wanted, delete it from the cache, so that subsequent+   Int~Bool constraints give rise to separate error messages++ * But if it is Derived, DO NOT delete from cache.  A class constraint+   may get kicked out of the inert set, and then have its functional+   dependency Derived constraints generated a second time. In that+   case we don't want to get two (or more) error messages by+   generating two (or more) insoluble fundep constraints from the same+   class constraint.++Note [No top-level newtypes on RHS of representational equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we're in this situation:++ work item:  [W] c1 : a ~R b+     inert:  [G] c2 : b ~R Id a++where+  newtype Id a = Id a++We want to make sure canEqCanLHS sees [W] a ~R a, after b is rewritten+and the Id newtype is unwrapped. This is assured by requiring only rewritten+types in canEqCanLHS *and* having the newtype-unwrapping check above+the tyvar check in can_eq_nc.++Note [Put touchable variables on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket #10009, a very nasty example:++    f :: (UnF (F b) ~ b) => F b -> ()++    g :: forall a. (UnF (F a) ~ a) => a -> ()+    g _ = f (undefined :: F a)++For g we get [G]  g1 : UnF (F a) ~ a+             [WD] w1 : UnF (F beta) ~ beta+             [WD] w2 : F a ~ F beta++g1 is canonical (CEqCan). It is oriented as above because a is not touchable.+See canEqTyVarFunEq.++w1 is similarly canonical, though the occurs-check in canEqTyVarFunEq is key+here.++w2 is canonical. But which way should it be oriented? As written, we'll be+stuck. When w2 is added to the inert set, nothing gets kicked out: g1 is+a Given (and Wanteds don't rewrite Givens), and w2 doesn't mention the LHS+of w2. We'll thus lose.++But if w2 is swapped around, to++    [D] w3 : F beta ~ F a++then (after emitting shadow Deriveds, etc. See GHC.Tc.Solver.Monad+Note [The improvement story and derived shadows]) we'll kick w1 out of the inert+set (it mentions the LHS of w3). We then rewrite w1 to++    [D] w4 : UnF (F a) ~ beta++and then, using g1, to++    [D] w5 : a ~ beta++at which point we can unify and go on to glory. (This rewriting actually+happens all at once, in the call to rewrite during canonicalisation.)++But what about the new LHS makes it better? It mentions a variable (beta)+that can appear in a Wanted -- a touchable metavariable never appears+in a Given. On the other hand, the original LHS mentioned only variables+that appear in Givens. We thus choose to put variables that can appear+in Wanteds on the left.++Ticket #12526 is another good example of this in action.++-}++---------------------+canEqCanLHS :: CtEvidence          -- ev :: lhs ~ rhs+            -> EqRel -> SwapFlag+            -> CanEqLHS              -- lhs (or, if swapped, rhs)+            -> TcType                -- lhs: pretty lhs, already rewritten+            -> TcType -> TcType      -- rhs: already rewritten+            -> TcS (StopOrContinue Ct)+canEqCanLHS ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2+  | k1 `tcEqType` k2+  = canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2++  | otherwise+  = canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 k1 xi2 ps_xi2 k2++  where+    k1 = canEqLHSKind lhs1+    k2 = tcTypeKind xi2++canEqCanLHSHetero :: CtEvidence         -- :: (xi1 :: ki1) ~ (xi2 :: ki2)+                  -> EqRel -> SwapFlag+                  -> CanEqLHS -> TcType -- xi1, pretty xi1+                  -> TcKind             -- ki1+                  -> TcType -> TcType   -- xi2, pretty xi2 :: ki2+                  -> TcKind             -- ki2+                  -> TcS (StopOrContinue Ct)+canEqCanLHSHetero ev eq_rel swapped lhs1 ps_xi1 ki1 xi2 ps_xi2 ki2+  -- See Note [Equalities with incompatible kinds]+  = do { kind_co <- emit_kind_co   -- :: ki2 ~N ki1++       ; let  -- kind_co :: (ki2 :: *) ~N (ki1 :: *)   (whether swapped or not)+              -- co1     :: kind(tv1) ~N ki1+             rhs'    = xi2    `mkCastTy` kind_co   -- :: ki1+             ps_rhs' = ps_xi2 `mkCastTy` kind_co   -- :: ki1+             rhs_co  = mkTcGReflLeftCo role xi2 kind_co+               -- rhs_co :: (xi2 |> kind_co) ~ xi2++             lhs_co = mkTcReflCo role xi1++       ; traceTcS "Hetero equality gives rise to kind equality"+           (ppr kind_co <+> dcolon <+> sep [ ppr ki2, text "~#", ppr ki1 ])+       ; type_ev <- rewriteEqEvidence ev swapped xi1 rhs' lhs_co rhs_co++          -- rewriteEqEvidence carries out the swap, so we're NotSwapped any more+       ; canEqCanLHSHomo type_ev eq_rel NotSwapped lhs1 ps_xi1 rhs' ps_rhs' }+  where+    emit_kind_co :: TcS CoercionN+    emit_kind_co+      | CtGiven { ctev_evar = evar } <- ev+      = do { let kind_co = maybe_sym $ mkTcKindCo (mkTcCoVarCo evar)  -- :: k2 ~ k1+           ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)+           ; emitWorkNC [kind_ev]+           ; return (ctEvCoercion kind_ev) }++      | otherwise+      = unifyWanted kind_loc Nominal ki2 ki1++    xi1      = canEqLHSType lhs1+    loc      = ctev_loc ev+    role     = eqRelRole eq_rel+    kind_loc = mkKindLoc xi1 xi2 loc+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki2 ki1++    maybe_sym = case swapped of+          IsSwapped  -> id         -- if the input is swapped, then we already+                                   -- will have k2 ~ k1+          NotSwapped -> mkTcSymCo++-- guaranteed that tcTypeKind lhs == tcTypeKind rhs+canEqCanLHSHomo :: CtEvidence+                -> EqRel -> SwapFlag+                -> CanEqLHS           -- lhs (or, if swapped, rhs)+                -> TcType             -- pretty lhs+                -> TcType -> TcType   -- rhs, pretty rhs+                -> TcS (StopOrContinue Ct)+canEqCanLHSHomo ev eq_rel swapped lhs1 ps_xi1 xi2 ps_xi2+  | (xi2', mco) <- split_cast_ty xi2+  , Just lhs2 <- canEqLHS_maybe xi2'+  = canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 (ps_xi2 `mkCastTyMCo` mkTcSymMCo mco) mco++  | otherwise+  = canEqCanLHSFinish ev eq_rel swapped lhs1 ps_xi2++  where+    split_cast_ty (CastTy ty co) = (ty, MCo co)+    split_cast_ty other          = (other, MRefl)++-- This function deals with the case that both LHS and RHS are potential+-- CanEqLHSs.+canEqCanLHS2 :: CtEvidence              -- lhs ~ (rhs |> mco)+                                        -- or, if swapped: (rhs |> mco) ~ lhs+             -> EqRel -> SwapFlag+             -> CanEqLHS                -- lhs (or, if swapped, rhs)+             -> TcType                  -- pretty lhs+             -> CanEqLHS                -- rhs+             -> TcType                  -- pretty rhs+             -> MCoercion               -- :: kind(rhs) ~N kind(lhs)+             -> TcS (StopOrContinue Ct)+canEqCanLHS2 ev eq_rel swapped lhs1 ps_xi1 lhs2 ps_xi2 mco+  | lhs1 `eqCanEqLHS` lhs2+    -- It must be the case that mco is reflexive+  = canEqReflexive ev eq_rel (canEqLHSType lhs1)++  | TyVarLHS tv1 <- lhs1+  , TyVarLHS tv2 <- lhs2+  , swapOverTyVars (isGiven ev) tv1 tv2+  = do { traceTcS "canEqLHS2 swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)+       ; new_ev <- do_swap+       ; canEqCanLHSFinish new_ev eq_rel IsSwapped (TyVarLHS tv2)+                                                   (ps_xi1 `mkCastTyMCo` sym_mco) }++  | TyVarLHS tv1 <- lhs1+  , TyFamLHS fun_tc2 fun_args2 <- lhs2+  = canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco++  | TyFamLHS fun_tc1 fun_args1 <- lhs1+  , TyVarLHS tv2 <- lhs2+  = do { new_ev <- do_swap+       ; canEqTyVarFunEq new_ev eq_rel IsSwapped tv2 ps_xi2+                                                 fun_tc1 fun_args1 ps_xi1 sym_mco }++  | TyFamLHS fun_tc1 fun_args1 <- lhs1+  , TyFamLHS fun_tc2 fun_args2 <- lhs2+  = do { traceTcS "canEqCanLHS2 two type families" (ppr lhs1 $$ ppr lhs2)++         -- emit derived equalities for injective type families+       ; let inj_eqns :: [TypeEqn]  -- TypeEqn = Pair Type+             inj_eqns+               | ReprEq <- eq_rel   = []   -- injectivity applies only for nom. eqs.+               | fun_tc1 /= fun_tc2 = []   -- if the families don't match, stop.++               | Injective inj <- tyConInjectivityInfo fun_tc1+               = [ Pair arg1 arg2+                 | (arg1, arg2, True) <- zip3 fun_args1 fun_args2 inj ]++                 -- built-in synonym families don't have an entry point+                 -- for this use case. So, we just use sfInteractInert+                 -- and pass two equal RHSs. We *could* add another entry+                 -- point, but then there would be a burden to make+                 -- sure the new entry point and existing ones were+                 -- internally consistent. This is slightly distasteful,+                 -- but it works well in practice and localises the+                 -- problem.+               | Just ops <- isBuiltInSynFamTyCon_maybe fun_tc1+               = let ki1 = canEqLHSKind lhs1+                     ki2 | MRefl <- mco+                         = ki1   -- just a small optimisation+                         | otherwise+                         = canEqLHSKind lhs2++                     fake_rhs1 = anyTypeOfKind ki1+                     fake_rhs2 = anyTypeOfKind ki2+                 in+                 sfInteractInert ops fun_args1 fake_rhs1 fun_args2 fake_rhs2++               | otherwise  -- ordinary, non-injective type family+               = []++       ; unless (isGiven ev) $+         mapM_ (unifyDerived (ctEvLoc ev) Nominal) inj_eqns++       ; tclvl <- getTcLevel+       ; dflags <- getDynFlags+       ; let tvs1 = tyCoVarsOfTypes fun_args1+             tvs2 = tyCoVarsOfTypes fun_args2++             swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&+                          -- swap 'em: Note [Put touchable variables on the left]+                                  not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1)+                          -- this check is just to avoid unfruitful swapping++               -- If we have F a ~ F (F a), we want to swap.+             swap_for_occurs+               | cterHasNoProblem   $ checkTyFamEq dflags fun_tc2 fun_args2+                                                   (mkTyConApp fun_tc1 fun_args1)+               , cterHasOccursCheck $ checkTyFamEq dflags fun_tc1 fun_args1+                                                   (mkTyConApp fun_tc2 fun_args2)+               = True++               | otherwise+               = False++       ; if swap_for_rewriting || swap_for_occurs+         then do { new_ev <- do_swap+                 ; canEqCanLHSFinish new_ev eq_rel IsSwapped lhs2 (ps_xi1 `mkCastTyMCo` sym_mco) }+         else finish_without_swapping }++  -- that's all the special cases. Now we just figure out which non-special case+  -- to continue to.+  | otherwise+  = finish_without_swapping++  where+    sym_mco = mkTcSymMCo mco++    do_swap = rewriteCastedEquality ev eq_rel swapped (canEqLHSType lhs1) (canEqLHSType lhs2) mco+    finish_without_swapping = canEqCanLHSFinish ev eq_rel swapped lhs1 (ps_xi2 `mkCastTyMCo` mco)+++-- This function handles the case where one side is a tyvar and the other is+-- a type family application. Which to put on the left?+--   If the tyvar is a touchable meta-tyvar, put it on the left, as this may+--   be our only shot to unify.+--   Otherwise, put the function on the left, because it's generally better to+--   rewrite away function calls. This makes types smaller. And it seems necessary:+--     [W] F alpha ~ alpha+--     [W] F alpha ~ beta+--     [W] G alpha beta ~ Int   ( where we have type instance G a a = a )+--   If we end up with a stuck alpha ~ F alpha, we won't be able to solve this.+--   Test case: indexed-types/should_compile/CEqCanOccursCheck+canEqTyVarFunEq :: CtEvidence               -- :: lhs ~ (rhs |> mco)+                                            -- or (rhs |> mco) ~ lhs if swapped+                -> EqRel -> SwapFlag+                -> TyVar -> TcType          -- lhs (or if swapped rhs), pretty lhs+                -> TyCon -> [Xi] -> TcType  -- rhs (or if swapped lhs) fun and args, pretty rhs+                -> MCoercion                -- :: kind(rhs) ~N kind(lhs)+                -> TcS (StopOrContinue Ct)+canEqTyVarFunEq ev eq_rel swapped tv1 ps_xi1 fun_tc2 fun_args2 ps_xi2 mco+  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv1 rhs+       ; dflags       <- getDynFlags+       ; if | case is_touchable of { Untouchable -> False; _ -> True }+            , cterHasNoProblem $+                checkTyVarEq dflags tv1 rhs `cterRemoveProblem` cteTypeFamily+            -> canEqCanLHSFinish ev eq_rel swapped (TyVarLHS tv1) rhs++            | otherwise+              -> do { new_ev <- rewriteCastedEquality ev eq_rel swapped+                                  (mkTyVarTy tv1) (mkTyConApp fun_tc2 fun_args2)+                                  mco+                    ; canEqCanLHSFinish new_ev eq_rel IsSwapped+                                  (TyFamLHS fun_tc2 fun_args2)+                                  (ps_xi1 `mkCastTyMCo` sym_mco) } }+  where+    sym_mco = mkTcSymMCo mco+    rhs = ps_xi2 `mkCastTyMCo` mco++-- The RHS here is either not CanEqLHS, or it's one that we+-- want to rewrite the LHS to (as per e.g. swapOverTyVars)+canEqCanLHSFinish :: CtEvidence+                  -> EqRel -> SwapFlag+                  -> CanEqLHS              -- lhs (or, if swapped, rhs)+                  -> TcType          -- rhs, pretty rhs+                  -> TcS (StopOrContinue Ct)+canEqCanLHSFinish ev eq_rel swapped lhs rhs+-- RHS is fully rewritten, but with type synonyms+-- preserved as much as possible+-- guaranteed that tyVarKind lhs == typeKind rhs, for (TyEq:K)+-- (TyEq:N) is checked in can_eq_nc', and (TyEq:TV) is handled in canEqCanLHS2++  = do { dflags <- getDynFlags+       ; new_ev <- rewriteEqEvidence ev swapped lhs_ty rhs rewrite_co1 rewrite_co2++     -- by now, (TyEq:K) is already satisfied+       ; MASSERT(canEqLHSKind lhs `eqType` tcTypeKind rhs)++     -- by now, (TyEq:N) is already satisfied (if applicable)+       ; MASSERT(not bad_newtype)++     -- guarantees (TyEq:OC), (TyEq:F)+     -- Must do the occurs check even on tyvar/tyvar+     -- equalities, in case have  x ~ (y :: ..x...); this is #12593.+     -- This next line checks also for coercion holes (TyEq:H); see+     -- Note [Equalities with incompatible kinds]+       ; let result0 = checkTypeEq dflags lhs rhs `cterRemoveProblem` cteTypeFamily+     -- type families are OK here+     -- NB: no occCheckExpand here; see Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite+++              -- a ~R# b a is soluble if b later turns out to be Identity+             result = case eq_rel of+                        NomEq  -> result0+                        ReprEq -> cterSetOccursCheckSoluble result0++             reason | result `cterHasOnlyProblem` cteHoleBlocker+                    = HoleBlockerReason (coercionHolesOfType rhs)+                    | otherwise+                    = NonCanonicalReason result++       ; if cterHasNoProblem result+         then do { traceTcS "CEqCan" (ppr lhs $$ ppr rhs)+                 ; continueWith (CEqCan { cc_ev = new_ev, cc_lhs = lhs+                                        , cc_rhs = rhs, cc_eq_rel = eq_rel }) }++         else do { m_stuff <- breakTyVarCycle_maybe ev result lhs rhs+                           -- See Note [Type variable cycles];+                           -- returning Nothing is the vastly common case+                 ; case m_stuff of+                     { Nothing ->+                         do { traceTcS "canEqCanLHSFinish can't make a canonical"+                                       (ppr lhs $$ ppr rhs)+                            ; continueWith (mkIrredCt reason new_ev) }+                     ; Just (lhs_tv, co, new_rhs) ->+              do { traceTcS "canEqCanLHSFinish breaking a cycle" $+                            ppr lhs $$ ppr rhs+                 ; traceTcS "new RHS:" (ppr new_rhs)++                   -- This check is Detail (1) in the Note+                 ; if cterHasOccursCheck (checkTyVarEq dflags lhs_tv new_rhs)++                   then do { traceTcS "Note [Type variable cycles] Detail (1)"+                                      (ppr new_rhs)+                           ; continueWith (mkIrredCt reason new_ev) }++                   else do { -- See Detail (6) of Note [Type variable cycles]+                             new_new_ev <- rewriteEqEvidence new_ev NotSwapped+                                             lhs_ty new_rhs+                                             (mkTcNomReflCo lhs_ty) co++                           ; continueWith (CEqCan { cc_ev = new_new_ev+                                                  , cc_lhs = lhs+                                                  , cc_rhs = new_rhs+                                                  , cc_eq_rel = eq_rel }) }}}}}+  where+    role = eqRelRole eq_rel++    lhs_ty = canEqLHSType lhs++    rewrite_co1  = mkTcReflCo role lhs_ty+    rewrite_co2  = mkTcReflCo role rhs++    -- This is about (TyEq:N)+    bad_newtype | ReprEq <- eq_rel+                , Just tc <- tyConAppTyCon_maybe rhs+                = isNewTyCon tc+                | otherwise+                = False++-- | Solve a reflexive equality constraint+canEqReflexive :: CtEvidence    -- ty ~ ty+               -> EqRel+               -> TcType        -- ty+               -> TcS (StopOrContinue Ct)   -- always Stop+canEqReflexive ev eq_rel ty+  = do { setEvBindIfWanted ev (evCoercion $+                               mkTcReflCo (eqRelRole eq_rel) ty)+       ; stopWith ev "Solved by reflexivity" }++rewriteCastedEquality :: CtEvidence     -- :: lhs ~ (rhs |> mco), or (rhs |> mco) ~ lhs+                      -> EqRel -> SwapFlag+                      -> TcType         -- lhs+                      -> TcType         -- rhs+                      -> MCoercion      -- mco+                      -> TcS CtEvidence -- :: (lhs |> sym mco) ~ rhs+                                        -- result is independent of SwapFlag+rewriteCastedEquality ev eq_rel swapped lhs rhs mco+  = rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co+  where+    new_lhs = lhs `mkCastTyMCo` sym_mco+    lhs_co  = mkTcGReflLeftMCo role lhs sym_mco++    new_rhs = rhs+    rhs_co  = mkTcGReflRightMCo role rhs mco++    sym_mco = mkTcSymMCo mco+    role    = eqRelRole eq_rel++{- Note [Equalities with incompatible kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What do we do when we have an equality++  (tv :: k1) ~ (rhs :: k2)++where k1 and k2 differ? Easy: we create a coercion that relates k1 and+k2 and use this to cast. To wit, from++  [X] (tv :: k1) ~ (rhs :: k2)++(where [X] is [G], [W], or [D]), we go to++  [noDerived X] co :: k2 ~ k1+  [X]           (tv :: k1) ~ ((rhs |> co) :: k1)++where++  noDerived G = G+  noDerived _ = W++For reasons described in Wrinkle (2) below, we want the [X] constraint to be "blocked";+that is, it should be put aside, and not used to rewrite any other constraint,+until the kind-equality on which it depends (namely 'co' above) is solved.+To achieve this+* The [X] constraint is a CIrredCan+* With a cc_reason of HoleBlockerReason bchs+* Where 'bchs' is the set of "blocking coercion holes".  The blocking coercion+  holes are the free coercion holes of [X]'s type+* When all the blocking coercion holes in the CIrredCan are filled (solved),+  we convert [X] to a CNonCanonical and put it in the work list.+All this is described in more detail in Wrinkle (2).++Wrinkles:++ (1) The noDerived step is because Derived equalities have no evidence.+     And yet we absolutely need evidence to be able to proceed here.+     Given evidence will use the KindCo coercion; Wanted evidence will+     be a coercion hole. Even a Derived hetero equality begets a Wanted+     kind equality.++ (2) Though it would be sound to do so, we must not mark the rewritten Wanted+       [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 do not rewrite Wanteds]+     in GHC.Tc.Types.Constraint. The problem is about poor error messages. See #11198 for+     tales of destruction.++     So, we have an invariant on CEqCan (TyEq:H) that the RHS does not have+     any coercion holes. This is checked in checkTypeEq. Any equalities that+     have such an RHS are turned into CIrredCans with a HoleBlockerReason. We also+     must be sure to kick out any such CIrredCan constraints that mention coercion holes+     when those holes get filled in, so that the unification step can now proceed.++     The kicking out is done in kickOutAfterFillingCoercionHole, and the inerts+     are stored in the inert_blocked field of InertCans.++     However, we must be careful: we kick out only when no coercion holes are+     left. The holes in the type are stored in the HoleBlockerReason CtIrredReason.+     The extra check that there are no more remaining holes avoids+     needless work when rewriting evidence (which fills coercion holes) and+     aids efficiency.++     Moreover, kicking out when there are remaining unfilled holes can+     cause a loop in the solver in this case:+          [W] w1 :: (ty1 :: F a) ~ (ty2 :: s)+     After canonicalisation, we discover that this equality is heterogeneous.+     So we emit+          [W] co_abc :: F a ~ s+     and preserve the original as+          [W] w2 :: (ty1 |> co_abc) ~ ty2    (blocked on co_abc)+     Then, co_abc comes becomes the work item. It gets swapped in+     canEqCanLHS2 and then back again in canEqTyVarFunEq. We thus get+     co_abc := sym co_abd, and then co_abd := sym co_abe, with+          [W] co_abe :: F a ~ s+     This process has filled in co_abc. Suppose w2 were kicked out.+     When it gets processed,+     would get this whole chain going again. The solution is to+     kick out a blocked constraint only when the result of filling+     in the blocking coercion involves no further blocking coercions.+     Alternatively, we could be careful not to do unnecessary swaps during+     canonicalisation, but that seems hard to do, in general.++ (3) Suppose we have [W] (a :: k1) ~ (rhs :: k2). We duly follow the+     algorithm detailed here, producing [W] co :: k2 ~ k1, and adding+     [W] (a :: k1) ~ ((rhs |> co) :: k1) to the irreducibles. Some time+     later, we solve co, and fill in co's coercion hole. This kicks out+     the irreducible as described in (2).+     But now, during canonicalization, we see the cast+     and remove it, in canEqCast. By the time we get into canEqCanLHS, the equality+     is heterogeneous again, and the process repeats.++     To avoid this, we don't strip casts off a type if the other type+     in the equality is a CanEqLHS (the scenario above can happen with a+     type family, too. testcase: typecheck/should_compile/T13822).+     And this is an improvement regardless:+     because tyvars can, generally, unify with casted types, there's no+     reason to go through the work of stripping off the cast when the+     cast appears opposite a tyvar. This is implemented in the cast case+     of can_eq_nc'.++ (4) Reporting an error for a constraint that is blocked with HoleBlockerReason+     is hard: what would we say to users? And we don't+     really need to report, because if a constraint is blocked, then+     there is unsolved wanted blocking it; that unsolved wanted will+     be reported. We thus push such errors to the bottom of the queue+     in the error-reporting code; they should never be printed.++     (4a) It would seem possible to do this filtering just based on the+          presence of a blocking coercion hole. However, this is no good,+          as it suppresses e.g. no-instance-found errors. We thus record+          a CtIrredReason in CIrredCan and filter based on this status.+          This happened in T14584. An alternative approach is to expressly+          look for *equalities* with blocking coercion holes, but actually+          recording the blockage in a status field seems nicer.++     (4b) The error message might be printed with -fdefer-type-errors,+          so it still must exist. This is the only reason why there is+          a message at all. Otherwise, we could simply do nothing.++Historical note:++We used to do this via emitting a Derived kind equality and then parking+the heterogeneous equality as irreducible. But this new approach is much+more direct. And it doesn't produce duplicate Deriveds (as the old one did).++Note [Type synonyms and canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat type synonym applications as xi types, that is, they do not+count as type function applications.  However, we do need to be a bit+careful with type synonyms: like type functions they may not be+generative or injective.  However, unlike type functions, they are+parametric, so there is no problem in expanding them whenever we see+them, since we do not need to know anything about their arguments in+order to expand them; this is what justifies not having to treat them+as specially as type function applications.  The thing that causes+some subtleties is that we prefer to leave type synonym applications+*unexpanded* whenever possible, in order to generate better error+messages.++If we encounter an equality constraint with type synonym applications+on both sides, or a type synonym application on one side and some sort+of type application on the other, we simply must expand out the type+synonyms in order to continue decomposing the equality constraint into+primitive equality constraints.  For example, suppose we have++  type F a = [Int]++and we encounter the equality++  F a ~ [b]++In order to continue we must expand F a into [Int], giving us the+equality++  [Int] ~ [b]++which we can then decompose into the more primitive equality+constraint++  Int ~ b.++However, if we encounter an equality constraint with a type synonym+application on one side and a variable on the other side, we should+NOT (necessarily) expand the type synonym, since for the purpose of+good error messages we want to leave type synonyms unexpanded as much+as possible.  Hence the ps_xi1, ps_xi2 argument passed to canEqCanLHS.++Note [Type variable cycles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this situation (from indexed-types/should_compile/GivenLoop):++  instance C (Maybe b)+  *[G] a ~ Maybe (F a)+  [W] C a++or (typecheck/should_compile/T19682b):++  instance C (a -> b)+  *[WD] alpha ~ (Arg alpha -> Res alpha)+  [W] C alpha++In order to solve the final Wanted, we must use the starred constraint+for rewriting. But note that both starred constraints have occurs-check failures,+and so we can't straightforwardly add these to the inert set and+use them for rewriting. (NB: A rigid type constructor is at the+top of both RHSs. If the type family were at the top, we'd just reorient+in canEqTyVarFunEq.)++The key idea is to replace the type family applications in the RHS of the+starred constraints with a fresh variable, which we'll call a cycle-breaker+variable, or cbv. Then, relate the cbv back with the original type family application+via new equality constraints. Our situations thus become:++  instance C (Maybe b)+  [G] a ~ Maybe cbv+  [G] F a ~ cbv+  [W] C a++or++  instance C (a -> b)+  [WD] alpha ~ (cbv1 -> cbv2)+  [WD] Arg alpha ~ cbv1+  [WD] Res alpha ~ cbv2+  [W] C alpha++This transformation (creating the new types and emitting new equality+constraints) is done in breakTyVarCycle_maybe.++The details depend on whether we're working with a Given or a Derived.+(Note that the Wanteds are really WDs, above. This is because Wanteds+are not used for rewriting.)++Given+-----++We emit a new Given, [G] F a ~ cbv, equating the type family application to+our new cbv. Note its orientation: The type family ends up on the left; see+commentary on canEqTyVarFunEq, which decides how to orient such cases. No+special treatment for CycleBreakerTvs is necessary. This scenario is now+easily soluble, by using the first Given to rewrite the Wanted, which can now+be solved.++(The first Given actually also rewrites the second one, giving+[G] F (Maybe cbv) ~ cbv, but this causes no trouble.)++Of course, we don't want our fresh variables leaking into e.g. error messages.+So we fill in the metavariables with their original type family applications+after we're done running the solver (in nestImplicTcS and runTcSWithEvBinds).+This is done by restoreTyVarCycles, which uses the inert_cycle_breakers field in+InertSet, which contains the pairings invented in breakTyVarCycle_maybe.++That is:++We transform+  [G] g : a ~ ...(F a)...+to+  [G] (Refl a) : F a ~ cbv      -- CEqCan+  [G] g        : a ~ ...cbv...  -- CEqCan++Note that+* `cbv` is a fresh cycle breaker variable.+* `cbv` is a is a meta-tyvar, but it is completely untouchable.+* We track the cycle-breaker variables in inert_cycle_breakers in InertSet+* We eventually fill in the cycle-breakers, with `cbv := F a`.+  No one else fills in cycle-breakers!+* In inert_cycle_breakers, we remember the (cbv, F a) pair; that is, we+  remember the /original/ type.  The [G] F a ~ cbv constraint may be rewritten+  by other givens (eg if we have another [G] a ~ (b,c), but at the end we+  still fill in with cbv := F a+* This fill-in is done when solving is complete, by restoreTyVarCycles+  in nestImplicTcS and runTcSWithEvBinds.+* The evidence for the new `F a ~ cbv` constraint is Refl, because we know this fill-in is+  ultimately going to happen.++Wanted/Derived+--------------+The fresh cycle-breaker variables here must actually be normal, touchable+metavariables. That is, they are TauTvs. Nothing at all unusual. Repeating+the example from above, we have++  *[WD] alpha ~ (Arg alpha -> Res alpha)++and we turn this into++  *[WD] alpha ~ (cbv1 -> cbv2)+  [WD] Arg alpha ~ cbv1+  [WD] Res alpha ~ cbv2++where cbv1 and cbv2 are fresh TauTvs. Why TauTvs? See [Why TauTvs] below.++Critically, we emit the constraint directly instead of calling unifyWanted.+Next, we unify alpha := cbv1 -> cbv2, having eliminated the occurs check. This+unification happens in the course of normal behavior of top-level+interactions, later in the solver pipeline. We know this unification will+indeed happen, because breakTyVarCycle_maybe, which decides whether to apply+this logic, goes to pains to make sure unification will succeed. Now, we're+here (including further context from our original example, from the top of the+Note):++  instance C (a -> b)+  [WD] Arg (cbv1 -> cbv2) ~ cbv1+  [WD] Res (cbv1 -> cbv2) ~ cbv2+  [W] C (cbv1 -> cbv2)++The first two WD constraints reduce to reflexivity and are discarded,+and the last is easily soluble.++[Why TauTvs]:+Let's look at another example (typecheck/should_compile/T19682) where we need+to unify the cbvs:++  class    (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys+  instance (AllEqF xs ys, SameShapeAs xs ys) => AllEq xs ys++  type family SameShapeAs xs ys :: Constraint where+    SameShapeAs '[] ys      = (ys ~ '[])+    SameShapeAs (x : xs) ys = (ys ~ (Head ys : Tail ys))++  type family AllEqF xs ys :: Constraint where+    AllEqF '[]      '[]      = ()+    AllEqF (x : xs) (y : ys) = (x ~ y, AllEq xs ys)++  [WD] alpha ~ (Head alpha : Tail alpha)+  [WD] AllEqF '[Bool] alpha++Without the logic detailed in this Note, we're stuck here, as AllEqF cannot+reduce and alpha cannot unify. Let's instead apply our cycle-breaker approach,+just as described above. We thus invent cbv1 and cbv2 and unify+alpha := cbv1 -> cbv2, yielding (after zonking)++  [WD] Head (cbv1 : cbv2) ~ cbv1+  [WD] Tail (cbv1 : cbv2) ~ cbv2+  [WD] AllEqF '[Bool] (cbv1 : cbv2)++The first two WD constraints simplify to reflexivity and are discarded.+But the last reduces:++  [WD] Bool ~ cbv1+  [WD] AllEq '[] cbv2++The first of these is solved by unification: cbv1 := Bool. The second+is solved by the instance for AllEq to become++  [WD] AllEqF '[] cbv2+  [WD] SameShapeAs '[] cbv2++While the first of these is stuck, the second makes progress, to lead to++  [WD] AllEqF '[] cbv2+  [WD] cbv2 ~ '[]++This second constraint is solved by unification: cbv2 := '[]. We now+have++  [WD] AllEqF '[] '[]++which reduces to++  [WD] ()++which is trivially satisfiable. Hooray!++Note that we need to unify the cbvs here; if we did not, there would be+no way to solve those constraints. That's why the cycle-breakers are+ordinary TauTvs.++In all cases+------------++We detect this scenario by the following characteristics:+ - a constraint with a tyvar on its LHS+ - with a soluble occurs-check failure+ - and a nominal equality+ - and either+    - a Given flavour (but see also Detail (7) below)+    - a Wanted/Derived or just plain Derived flavour, with a touchable metavariable+      on the left++We don't use this trick for representational equalities, as there is no+concrete use case where it is helpful (unlike for nominal equalities).+Furthermore, because function applications can be CanEqLHSs, but newtype+applications cannot, the disparities between the cases are enough that it+would be effortful to expand the idea to representational equalities. A quick+attempt, with++      data family N a b++      f :: (Coercible a (N a b), Coercible (N a b) b) => a -> b+      f = coerce++failed with "Could not match 'b' with 'b'." Further work is held off+until when we have a concrete incentive to explore this dark corner.++Details:++ (1) We don't look under foralls, at all, when substituting away type family+     applications, because doing so can never be fruitful. Recall that we+     are in a case like [G] a ~ forall b. ... a ....   Until we have a type+     family that can pull the body out from a forall, this will always be+     insoluble. Note also that the forall cannot be in an argument to a+     type family, or that outer type family application would already have+     been substituted away.++     However, we still must check to make sure that breakTyVarCycle_maybe actually+     succeeds in getting rid of all occurrences of the offending variable. If+     one is hidden under a forall, this won't be true. A similar problem can+     happen if the variable appears only in a kind+     (e.g. k ~ ... (a :: k) ...). So we perform an additional check after+     performing the substitution. It is tiresome to re-run all of checkTyVarEq+     here, but reimplementing just the occurs-check is even more tiresome.++     Skipping this check causes typecheck/should_fail/GivenForallLoop and+     polykinds/T18451 to loop.++ (2) Our goal here is to avoid loops in rewriting. We can thus skip looking+     in coercions, as we don't rewrite in coercions. (This is another reason+     we need to re-check that we've gotten rid of all occurrences of the+     offending variable.)++ (3) As we're substituting, we can build ill-kinded+     types. For example, if we have Proxy (F a) b, where (b :: F a), then+     replacing this with Proxy cbv b is ill-kinded. However, we will later+     set cbv := F a, and so the zonked type will be well-kinded again.+     The temporary ill-kinded type hurts no one, and avoiding this would+     be quite painfully difficult.++     Specifically, this detail does not contravene the Purely Kinded Type Invariant+     (Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType).+     The PKTI says that we can call typeKind on any type, without failure.+     It would be violated if we, say, replaced a kind (a -> b) with a kind c,+     because an arrow kind might be consulted in piResultTys. Here, we are+     replacing one opaque type like (F a b c) with another, cbv (opaque in+     that we never assume anything about its structure, like that it has a+     result type or a RuntimeRep argument).++ (4) The evidence for the produced Givens is all just reflexive, because+     we will eventually set the cycle-breaker variable to be the type family,+     and then, after the zonk, all will be well.++ (5) The approach here is inefficient. For instance, we could choose to+     affect only type family applications that mention the offending variable:+     in a ~ (F b, G a), we need to replace only G a, not F b. Furthermore,+     we could try to detect cases like a ~ (F a, F a) and use the same+     tyvar to replace F a. (Cf.+     Note [Flattening type-family applications when matching instances]+     in GHC.Core.Unify, which+     goes to this extra effort.) There may be other opportunities for+     improvement. However, this is really a very small corner case.+     The investment to craft a clever,+     performant solution seems unworthwhile.++ (6) We often get the predicate associated with a constraint from its+     evidence. We thus must not only make sure the generated CEqCan's+     fields have the updated RHS type, but we must also update the+     evidence itself. This is done by the call to rewriteEqEvidence+     in canEqCanLHSFinish.++ (7) We don't wish to apply this magic on the equalities created+     by this very same process.+     Consider this, from typecheck/should_compile/ContextStack2:++       type instance TF (a, b) = (TF a, TF b)+       t :: (a ~ TF (a, Int)) => ...++       [G] a ~ TF (a, Int)++     The RHS reduces, so we get++       [G] a ~ (TF a, TF Int)++     We then break cycles, to get++       [G] g1 :: a ~ (cbv1, cbv2)+       [G] g2 :: TF a ~ cbv1+       [G] g3 :: TF Int ~ cbv2++     g1 gets added to the inert set, as written. But then g2 becomes+     the work item. g1 rewrites g2 to become++       [G] TF (cbv1, cbv2) ~ cbv1++     which then uses the type instance to become++       [G] (TF cbv1, TF cbv2) ~ cbv1++     which looks remarkably like the Given we started with. If left+     unchecked, this will end up breaking cycles again, looping ad+     infinitum (and resulting in a context-stack reduction error,+     not an outright loop). The solution is easy: don't break cycles+     on an equality generated by breaking cycles. Instead, we mark this+     final Given as a CIrredCan with a NonCanonicalReason with the soluble+     occurs-check bit set (only).++     We track these equalities by giving them a special CtOrigin,+     CycleBreakerOrigin. This works for both Givens and WDs, as+     we need the logic in the WD case for e.g. typecheck/should_fail/T17139.++ (8) We really want to do this all only when there is a soluble occurs-check+     failure, not when other problems arise (such as an impredicative+     equality like alpha ~ forall a. a -> a). That is why breakTyVarCycle_maybe+     uses cterHasOnlyProblem when looking at the result of checkTypeEq, which+     checks for many of the invariants on a CEqCan.+-}++{-+************************************************************************+*                                                                      *+                  Evidence transformation+*                                                                      *+************************************************************************+-}++data StopOrContinue a+  = ContinueWith a    -- The constraint was not solved, although it may have+                      --   been rewritten++  | Stop CtEvidence   -- The (rewritten) constraint was solved+         SDoc         -- Tells how it was solved+                      -- Any new sub-goals have been put on the work list+  deriving (Functor)++instance Outputable a => Outputable (StopOrContinue a) where+  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w++continueWith :: a -> TcS (StopOrContinue a)+continueWith = return . ContinueWith++stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)+stopWith ev s = return (Stop ev (text s))++andWhenContinue :: TcS (StopOrContinue a)+                -> (a -> TcS (StopOrContinue b))+                -> TcS (StopOrContinue b)+andWhenContinue tcs1 tcs2+  = do { r <- tcs1+       ; case r of+           Stop ev s       -> return (Stop ev s)+           ContinueWith ct -> tcs2 ct }+infixr 0 `andWhenContinue`    -- allow chaining with ($)++rewriteEvidence :: CtEvidence   -- old evidence+                -> TcPredType   -- new predicate+                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>+                -> TcS (StopOrContinue CtEvidence)+-- Returns Just new_ev iff either (i)  'co' is reflexivity+--                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached+-- In either case, there is nothing new to do with new_ev+{-+     rewriteEvidence old_ev new_pred co+Main purpose: create new evidence for new_pred;+              unless new_pred is cached already+* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev+* If old_ev was wanted, create a binding for old_ev, in terms of new_ev+* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev+* Returns Nothing if new_ev is already cached++        Old evidence    New predicate is               Return new evidence+        flavour                                        of same flavor+        -------------------------------------------------------------------+        Wanted          Already solved or in inert     Nothing+        or Derived      Not                            Just new_evidence++        Given           Already in inert               Nothing+                        Not                            Just new_evidence++Note [Rewriting with Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~+If the coercion is just reflexivity then you may re-use the same+variable.  But be careful!  Although the coercion is Refl, new_pred+may reflect the result of unification alpha := ty, so new_pred might+not _look_ the same as old_pred, and it's vital to proceed from now on+using new_pred.++The rewriter preserves type synonyms, so they should appear in new_pred+as well as in old_pred; that is important for good error messages.+ -}+++rewriteEvidence old_ev@(CtDerived {}) new_pred _co+  = -- If derived, don't even look at the coercion.+    -- This is very important, DO NOT re-order the equations for+    -- rewriteEvidence to put the isTcReflCo test first!+    -- Why?  Because for *Derived* constraints, c, the coercion, which+    -- was produced by rewriting, may contain suspended calls to+    -- (ctEvExpr c), which fails for Derived constraints.+    -- (Getting this wrong caused #7384.)+    continueWith (old_ev { ctev_pred = new_pred })++rewriteEvidence old_ev new_pred co+  | isTcReflCo co -- See Note [Rewriting with Refl]+  = continueWith (old_ev { ctev_pred = new_pred })++rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co+  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)+       ; continueWith new_ev }+  where+    -- mkEvCast optimises ReflCo+    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational+                                                       (ctEvRole ev)+                                                       (mkTcSymCo co))++rewriteEvidence ev@(CtWanted { ctev_dest = dest+                             , ctev_nosh = si+                             , ctev_loc = loc }) new_pred co+  = do { mb_new_ev <- newWanted_SI si loc new_pred+               -- The "_SI" variant ensures that we make a new Wanted+               -- with the same shadow-info as the existing one+               -- with the same shadow-info as the existing one (#16735)+       ; MASSERT( tcCoercionRole co == ctEvRole ev )+       ; setWantedEvTerm dest+            (mkEvCast (getEvExpr mb_new_ev)+                      (tcDowngradeRole Representational (ctEvRole ev) co))+       ; case mb_new_ev of+            Fresh  new_ev -> continueWith new_ev+            Cached _      -> stopWith ev "Cached wanted" }+++rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)+                                        --              or orhs ~ olhs (swapped)+                  -> SwapFlag+                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs+                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs+                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs+                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs+-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)+-- we generate+-- If not swapped+--      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co+-- If 'swapped'+--      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co+--+-- For (Wanted w) we do the dual thing.+-- New  w1 : nlhs ~ nrhs+-- If not swapped+--      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co+-- If swapped+--      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co+--+-- It's all a form of rewwriteEvidence, specialised for equalities+rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co+  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived+  = return (old_ev { ctev_pred = new_pred })++  | NotSwapped <- swapped+  , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]+  , isTcReflCo rhs_co+  = return (old_ev { ctev_pred = new_pred })++  | CtGiven { ctev_evar = old_evar } <- old_ev+  = do { let new_tm = evCoercion (lhs_co+                                  `mkTcTransCo` maybeTcSymCo swapped (mkTcCoVarCo old_evar)+                                  `mkTcTransCo` mkTcSymCo rhs_co)+       ; newGivenEvVar loc' (new_pred, new_tm) }++  | CtWanted { ctev_dest = dest, ctev_nosh = si } <- old_ev+  = do { (new_ev, hole_co) <- newWantedEq_SI si loc'+                                             (ctEvRole old_ev) nlhs nrhs+               -- The "_SI" variant ensures that we make a new Wanted+               -- with the same shadow-info as the existing one (#16735)+       ; let co = maybeTcSymCo swapped $+                  mkSymCo lhs_co+                  `mkTransCo` hole_co+                  `mkTransCo` rhs_co+       ; setWantedEq dest co+       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+       ; return new_ev }++#if __GLASGOW_HASKELL__ <= 810+  | otherwise+  = panic "rewriteEvidence"+#endif+  where+    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs++      -- equality is like a type class. Bumping the depth is necessary because+      -- of recursive newtypes, where "reducing" a newtype can actually make+      -- it bigger. See Note [Newtypes can blow the stack].+    loc      = ctEvLoc old_ev+    loc'     = bumpCtLocDepth loc++{-+************************************************************************+*                                                                      *+              Unification+*                                                                      *+************************************************************************++Note [unifyWanted and unifyDerived]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When decomposing equalities we often create new wanted constraints for+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.+Similar remarks apply for Derived.++Rather than making an equality test (which traverses the structure of the+type, perhaps fruitlessly), unifyWanted traverses the common structure, and+bales out when it finds a difference by creating a new Wanted constraint.+But where it succeeds in finding common structure, it just builds a coercion+to reflect it.+-}++unifyWanted :: CtLoc -> Role+            -> TcType -> TcType -> TcS Coercion+-- Return coercion witnessing the equality of the two types,+-- emitting new work equalities where necessary to achieve that+-- Very good short-cut when the two types are equal, or nearly so+-- See Note [unifyWanted and unifyDerived]+-- The returned coercion's role matches the input parameter+unifyWanted loc Phantom ty1 ty2+  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)+       ; return (mkPhantomCo kind_co ty1 ty2) }++unifyWanted loc role orig_ty1 orig_ty2+  = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'++    go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)+      = do { co_s <- unifyWanted loc role s1 s2+           ; co_t <- unifyWanted loc role t1 t2+           ; co_w <- unifyWanted loc Nominal w1 w2+           ; return (mkFunCo role co_w co_s co_t) }+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2, tys1 `equalLength` tys2+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality+      = do { cos <- zipWith3M (unifyWanted loc)+                              (tyConRolesX role tc1) tys1 tys2+           ; return (mkTyConAppCo role tc1 cos) }++    go ty1@(TyVarTy tv) ty2+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty1' -> go ty1' ty2+                Nothing   -> bale_out ty1 ty2}+    go ty1 ty2@(TyVarTy tv)+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty2' -> go ty1 ty2'+                Nothing   -> bale_out ty1 ty2 }++    go ty1@(CoercionTy {}) (CoercionTy {})+      = return (mkReflCo role ty1) -- we just don't care about coercions!++    go ty1 ty2 = bale_out ty1 ty2++    bale_out ty1 ty2+       | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)+       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2++unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()+-- See Note [unifyWanted and unifyDerived]+unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2++unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()+-- See Note [unifyWanted and unifyDerived]+unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2++unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new Derived and put it in the work list+-- Should do nothing if the two types are equal+-- See Note [unifyWanted and unifyDerived]+unify_derived _   Phantom _        _        = return ()+unify_derived loc role    orig_ty1 orig_ty2+  = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'++    go (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)+      = do { unify_derived loc role s1 s2+           ; unify_derived loc role t1 t2+           ; unify_derived loc Nominal w1 w2 }+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2, tys1 `equalLength` tys2+      , isInjectiveTyCon tc1 role+      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2+    go ty1@(TyVarTy tv) ty2+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty1' -> go ty1' ty2+                Nothing   -> bale_out ty1 ty2 }+    go ty1 ty2@(TyVarTy tv)+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty2' -> go ty1 ty2'+                Nothing   -> bale_out ty1 ty2 }+    go ty1 ty2 = bale_out ty1 ty2++    bale_out ty1 ty2+       | ty1 `tcEqType` ty2 = return ()+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)+       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2

− GHC/Tc/Solver/Flatten.hs

@@ -1,1948 +0,0 @@-{-# LANGUAGE CPP, DeriveFunctor, ViewPatterns, BangPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module GHC.Tc.Solver.Flatten(-   FlattenMode(..),-   flatten, flattenKind, flattenArgsNom,-   rewriteTyVar, flattenType,--   unflattenWanteds- ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Tc.Types-import GHC.Core.TyCo.Ppr ( pprTyVar )-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate-import GHC.Tc.Utils.TcType-import GHC.Core.Type-import GHC.Tc.Types.Evidence-import GHC.Core.TyCon-import GHC.Core.TyCo.Rep   -- performs delicate algorithm on types-import GHC.Core.Coercion-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Utils.Outputable-import GHC.Tc.Solver.Monad as TcS-import GHC.Types.Basic( SwapFlag(..) )--import GHC.Utils.Misc-import GHC.Data.Bag-import Control.Monad-import GHC.Utils.Monad ( zipWith3M )-import Data.Foldable ( foldrM )--import Control.Arrow ( first )--{--Note [The flattening story]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* A CFunEqCan is either of form-     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkolTv-     [W]       x : F xis ~ fmv   -- fmv is a FlatMetaTv-  where-     x is the witness variable-     xis are function-free-     fsk/fmv is a flatten skolem;-        it is always untouchable (level 0)--* CFunEqCans can have any flavour: [G], [W], [WD] or [D]--* KEY INSIGHTS:--   - A given flatten-skolem, fsk, is known a-priori to be equal to-     F xis (the LHS), with <F xis> evidence.  The fsk is still a-     unification variable, but it is "owned" by its CFunEqCan, and-     is filled in (unflattened) only by unflattenGivens.--   - A unification flatten-skolem, fmv, stands for the as-yet-unknown-     type to which (F xis) will eventually reduce.  It is filled in---   - All fsk/fmv variables are "untouchable".  To make it simple to test,-     we simply give them TcLevel=0.  This means that in a CTyVarEq, say,-       fmv ~ Int-     we NEVER unify fmv.--   - A unification flatten-skolem, fmv, ONLY gets unified when either-       a) The CFunEqCan takes a step, using an axiom-       b) By unflattenWanteds-    They are never unified in any other form of equality.-    For example [W] ffmv ~ Int  is stuck; it does not unify with fmv.--* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.-  That would destroy the invariant about the shape of a CFunEqCan,-  and it would risk wanted/wanted interactions. The only way we-  learn information about fsk is when the CFunEqCan takes a step.--  However we *do* substitute in the LHS of a CFunEqCan (else it-  would never get to fire!)--* Unflattening:-   - We unflatten Givens when leaving their scope (see unflattenGivens)-   - We unflatten Wanteds at the end of each attempt to simplify the-     wanteds; see unflattenWanteds, called from solveSimpleWanteds.--* Ownership of fsk/fmv.  Each canonical [G], [W], or [WD]-       CFunEqCan x : F xis ~ fsk/fmv-  "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.-  Why? We make a fresh fsk/fmv when the constraint is born;-  and we never rewrite the RHS of a CFunEqCan.--  In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],-  but does not "own" it.  If we reduce a [D] F Int ~ fmv, where-  say type instance F Int = ty, then we don't discharge fmv := ty.-  Rather we simply generate [D] fmv ~ ty (in GHC.Tc.Solver.Interact.reduce_top_fun_eq,-  and dischargeFmv)--* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2-                       then xis1 /= xis2-  i.e. at most one CFunEqCan with a particular LHS--* Flattening a type (F xis):-    - If we are flattening in a Wanted/Derived constraint-      then create new [W] x : F xis ~ fmv-      else create new [G] x : F xis ~ fsk-      with fresh evidence variable x and flatten-skolem fsk/fmv--    - Add it to the work list--    - Replace (F xis) with fsk/fmv in the type you are flattening--    - You can also add the CFunEqCan to the "flat cache", which-      simply keeps track of all the function applications you-      have flattened.--    - If (F xis) is in the cache already, just-      use its fsk/fmv and evidence x, and emit nothing.--    - No need to substitute in the flat-cache. It's not the end-      of the world if we start with, say (F alpha ~ fmv1) and-      (F Int ~ fmv2) and then find alpha := Int.  Athat will-      simply give rise to fmv1 := fmv2 via [Interacting rule] below--* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv-    - Flatten xis (to substitute any tyvars; there are already no functions)-                  cos :: xis ~ flat_xis-    - New wanted  x2 :: F flat_xis ~ fsk/fmv-    - Add new wanted to flat cache-    - Discharge x = F cos ; x2--* [Interacting rule]-    (inert)     [W] x1 : F tys ~ fmv1-    (work item) [W] x2 : F tys ~ fmv2-  Just solve one from the other:-    x2 := x1-    fmv2 := fmv1-  This just unites the two fsks into one.-  Always solve given from wanted if poss.--* For top-level reductions, see Note [Top-level reductions for type functions]-  in GHC.Tc.Solver.Interact---Why given-fsks, alone, doesn't work-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.--  [W] w : alpha ~ [F alpha Int]-----> flatten-  w = ...w'...-  [W] w' : alpha ~ [fsk]-  [G] <F alpha Int> : F alpha Int ~ fsk----> unify (no occurs check)-  alpha := [fsk]--But since fsk = F alpha Int, this is really an occurs check error.  If-that is all we know about alpha, we will succeed in constraint-solving, producing a program with an infinite type.--Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)-using axiom, zonking would not see it, so (x::alpha) sitting in the-tree will get zonked to an infinite type.  (Zonking always only does-refl stuff.)--Why flatten-meta-vars, alone doesn't work-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Look at Simple13, with unification-fmvs only--  [G] g : a ~ [F a]-----> Flatten given-  g' = g;[x]-  [G] g'  : a ~ [fmv]-  [W] x : F a ~ fmv----> subst a in x-  g' = g;[x]-  x = F g' ; x2-  [W] x2 : F [fmv] ~ fmv--And now we have an evidence cycle between g' and x!--If we used a given instead (ie current story)--  [G] g : a ~ [F a]-----> Flatten given-  g' = g;[x]-  [G] g'  : a ~ [fsk]-  [G] <F a> : F a ~ fsk-----> Substitute for a-  [G] g'  : a ~ [fsk]-  [G] F (sym g'); <F a> : F [fsk] ~ fsk---Why is it right to treat fmv's differently to ordinary unification vars?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  f :: forall a. a -> a -> Bool-  g :: F Int -> F Int -> Bool--Consider-  f (x:Int) (y:Bool)-This gives alpha~Int, alpha~Bool.  There is an inconsistency,-but really only one error.  SherLoc may tell you which location-is most likely, based on other occurrences of alpha.--Consider-  g (x:Int) (y:Bool)-Here we get (F Int ~ Int, F Int ~ Bool), which flattens to-  (fmv ~ Int, fmv ~ Bool)-But there are really TWO separate errors.--  ** We must not complain about Int~Bool. **--Moreover these two errors could arise in entirely unrelated parts of-the code.  (In the alpha case, there must be *some* connection (eg-v:alpha in common envt).)--Note [Unflattening can force the solver to iterate]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Look at #10340:-   type family Any :: *   -- No instances-   get :: MonadState s m => m s-   instance MonadState s (State s) where ...--   foo :: State Any Any-   foo = get--For 'foo' we instantiate 'get' at types mm ss-   [WD] MonadState ss mm, [WD] mm ss ~ State Any Any-Flatten, and decompose-   [WD] MonadState ss mm, [WD] Any ~ fmv-   [WD] mm ~ State fmv, [WD] fmv ~ ss-Unify mm := State fmv:-   [WD] MonadState ss (State fmv)-   [WD] Any ~ fmv, [WD] fmv ~ ss-Now we are stuck; the instance does not match!!  So unflatten:-   fmv := Any-   ss := Any    (*)-   [WD] MonadState Any (State Any)--The unification (*) represents progress, so we must do a second-round of solving; this time it succeeds. This is done by the 'go'-loop in solveSimpleWanteds.--This story does not feel right but it's the best I can do; and the-iteration only happens in pretty obscure circumstances.---************************************************************************-*                                                                      *-*                  Examples-     Here is a long series of examples I had to work through-*                                                                      *-************************************************************************--Simple20-~~~~~~~~-axiom F [a] = [F a]-- [G] F [a] ~ a--->- [G] fsk ~ a- [G] [F a] ~ fsk  (nc)--->- [G] F a ~ fsk2- [G] fsk ~ [fsk2]- [G] fsk ~ a--->- [G] F a ~ fsk2- [G] a ~ [fsk2]- [G] fsk ~ a-------------------------------------------indexed-types/should_compile/T44984--  [W] H (F Bool) ~ H alpha-  [W] alpha ~ F Bool--->-  F Bool  ~ fmv0-  H fmv0  ~ fmv1-  H alpha ~ fmv2--  fmv1 ~ fmv2-  fmv0 ~ alpha--flatten-~~~~~~~-  fmv0  := F Bool-  fmv1  := H (F Bool)-  fmv2  := H alpha-  alpha := F Bool-plus-  fmv1 ~ fmv2--But these two are equal under the above assumptions.-Solve by Refl.------ under plan B, namely solve fmv1:=fmv2 eagerly ----  [W] H (F Bool) ~ H alpha-  [W] alpha ~ F Bool--->-  F Bool  ~ fmv0-  H fmv0  ~ fmv1-  H alpha ~ fmv2--  fmv1 ~ fmv2-  fmv0 ~ alpha--->-  F Bool  ~ fmv0-  H fmv0  ~ fmv1-  H alpha ~ fmv2    fmv2 := fmv1--  fmv0 ~ alpha--flatten-  fmv0 := F Bool-  fmv1 := H fmv0 = H (F Bool)-  retain   H alpha ~ fmv2-    because fmv2 has been filled-  alpha := F Bool--------------------------------indexed-types/should_failt/T4179--after solving-  [W] fmv_1 ~ fmv_2-  [W] A3 (FCon x)           ~ fmv_1    (CFunEqCan)-  [W] A3 (x (aoa -> fmv_2)) ~ fmv_2    (CFunEqCan)-------------------------------------------indexed-types/should_fail/T7729a--a)  [W]   BasePrimMonad (Rand m) ~ m1-b)  [W]   tt m1 ~ BasePrimMonad (Rand m)----->  process (b) first-    BasePrimMonad (Ramd m) ~ fmv_atH-    fmv_atH ~ tt m1----->  now process (a)-    m1 ~ s_atH ~ tt m1    -- An obscure occurs check--------------------------------------------typecheck/TcTypeNatSimple--Original constraint-  [W] x + y ~ x + alpha  (non-canonical)-==>-  [W] x + y     ~ fmv1   (CFunEqCan)-  [W] x + alpha ~ fmv2   (CFuneqCan)-  [W] fmv1 ~ fmv2        (CTyEqCan)--(sigh)-------------------------------------------indexed-types/should_fail/GADTwrong1--  [G] Const a ~ ()-==> flatten-  [G] fsk ~ ()-  work item: Const a ~ fsk-==> fire top rule-  [G] fsk ~ ()-  work item fsk ~ ()--Surely the work item should rewrite to () ~ ()?  Well, maybe not;-it'a very special case.  More generally, our givens look like-F a ~ Int, where (F a) is not reducible.--------------------------------------------indexed_types/should_fail/T8227:--Why using a different can-rewrite rule in CFunEqCan heads-does not work.--Assuming NOT rewriting wanteds with wanteds--   Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk-          [W] fmv_aBk ~ fsk_aBh--          [G] Scalar fsk_aBg ~ fsk_aBh-          [G] V a ~ f_aBg--   Worklist includes  [W] Scalar fmv_aBi ~ fmv_aBk-   fmv_aBi, fmv_aBk are flatten unification variables--   Work item: [W] V fsk_aBh ~ fmv_aBi--Note that the inert wanteds are cyclic, because we do not rewrite-wanteds with wanteds.---Then we go into a loop when normalise the work-item, because we-use rewriteOrSame on the argument of V.--Conclusion: Don't make canRewrite context specific; instead use-[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.---------------------------------------------Here is a somewhat similar case:--   type family G a :: *--   blah :: (G a ~ Bool, Eq (G a)) => a -> a-   blah = error "urk"--   foo x = blah x--For foo we get-   [W] Eq (G a), G a ~ Bool-Flattening-   [W] G a ~ fmv, Eq fmv, fmv ~ Bool-We can't simplify away the Eq Bool unless we substitute for fmv.-Maybe that doesn't matter: we would still be left with unsolved-G a ~ Bool.-----------------------------#9318 has a very simple program leading to--  [W] F Int ~ Int-  [W] F Int ~ Bool--We don't want to get "Error Int~Bool".  But if fmv's can rewrite-wanteds, we will--  [W] fmv ~ Int-  [W] fmv ~ Bool---->-  [W] Int ~ Bool---************************************************************************-*                                                                      *-*                FlattenEnv & FlatM-*             The flattening environment & monad-*                                                                      *-************************************************************************---}--type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]--data FlattenEnv-  = FE { fe_mode    :: !FlattenMode-       , fe_loc     :: CtLoc              -- See Note [Flattener CtLoc]-                      -- unbanged because it's bogus in rewriteTyVar-       , fe_flavour :: !CtFlavour-       , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]-       , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]--data FlattenMode  -- Postcondition for all three: inert wrt the type substitution-  = FM_FlattenAll          -- Postcondition: function-free-  | FM_SubstOnly           -- See Note [Flattening under a forall]----  | FM_Avoid TcTyVar Bool  -- See Note [Lazy flattening]---                           -- Postcondition:---                           --  * tyvar is only mentioned in result under a rigid path---                           --    e.g.   [a] is ok, but F a won't happen---                           --  * If flat_top is True, top level is not a function application---                           --   (but under type constructors is ok e.g. [F a])--instance Outputable FlattenMode where-  ppr FM_FlattenAll = text "FM_FlattenAll"-  ppr FM_SubstOnly  = text "FM_SubstOnly"--eqFlattenMode :: FlattenMode -> FlattenMode -> Bool-eqFlattenMode FM_FlattenAll FM_FlattenAll = True-eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True---  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2-eqFlattenMode _  _ = False---- | The 'FlatM' monad is a wrapper around 'TcS' with the following--- extra capabilities: (1) it offers access to a 'FlattenEnv';--- and (2) it maintains the flattening worklist.--- See Note [The flattening work list].-newtype FlatM a-  = FlatM { runFlatM :: FlattenEnv -> TcS a }-  deriving (Functor)--instance Monad FlatM where-  m >>= k  = FlatM $ \env ->-             do { a  <- runFlatM m env-                ; runFlatM (k a) env }--instance Applicative FlatM where-  pure x = FlatM $ const (pure x)-  (<*>) = ap--liftTcS :: TcS a -> FlatM a-liftTcS thing_inside-  = FlatM $ const thing_inside--emitFlatWork :: Ct -> FlatM ()--- See Note [The flattening work list]-emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)---- convenient wrapper when you have a CtEvidence describing--- the flattening operation-runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a-runFlattenCtEv mode ev-  = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)---- Run thing_inside (which does flattening), and put all--- the work it generates onto the main work list--- See Note [The flattening work list]-runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a-runFlatten mode loc flav eq_rel thing_inside-  = do { flat_ref <- newTcRef []-       ; let fmode = FE { fe_mode = mode-                        , fe_loc  = bumpCtLocDepth loc-                            -- See Note [Flatten when discharging CFunEqCan]-                        , fe_flavour = flav-                        , fe_eq_rel = eq_rel-                        , fe_work = flat_ref }-       ; res <- runFlatM thing_inside fmode-       ; new_flats <- readTcRef flat_ref-       ; updWorkListTcS (add_flats new_flats)-       ; return res }-  where-    add_flats new_flats wl-      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }--    add_funeqs []     wl = wl-    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)-      -- add_funeqs fs ws = reverse fs ++ ws-      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]-      --        = [f3,f2,f1,w1,w2,w3,w4]--traceFlat :: String -> SDoc -> FlatM ()-traceFlat herald doc = liftTcS $ traceTcS herald doc-{-# INLINE traceFlat #-}  -- see Note [INLINE conditional tracing utilities]--getFlatEnvField :: (FlattenEnv -> a) -> FlatM a-getFlatEnvField accessor-  = FlatM $ \env -> return (accessor env)--getEqRel :: FlatM EqRel-getEqRel = getFlatEnvField fe_eq_rel--getRole :: FlatM Role-getRole = eqRelRole <$> getEqRel--getFlavour :: FlatM CtFlavour-getFlavour = getFlatEnvField fe_flavour--getFlavourRole :: FlatM CtFlavourRole-getFlavourRole-  = do { flavour <- getFlavour-       ; eq_rel <- getEqRel-       ; return (flavour, eq_rel) }--getMode :: FlatM FlattenMode-getMode = getFlatEnvField fe_mode--getLoc :: FlatM CtLoc-getLoc = getFlatEnvField fe_loc--checkStackDepth :: Type -> FlatM ()-checkStackDepth ty-  = do { loc <- getLoc-       ; liftTcS $ checkReductionDepth loc ty }---- | Change the 'EqRel' in a 'FlatM'.-setEqRel :: EqRel -> FlatM a -> FlatM a-setEqRel new_eq_rel thing_inside-  = FlatM $ \env ->-    if new_eq_rel == fe_eq_rel env-    then runFlatM thing_inside env-    else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })---- | Change the 'FlattenMode' in a 'FlattenEnv'.-setMode :: FlattenMode -> FlatM a -> FlatM a-setMode new_mode thing_inside-  = FlatM $ \env ->-    if new_mode `eqFlattenMode` fe_mode env-    then runFlatM thing_inside env-    else runFlatM thing_inside (env { fe_mode = new_mode })---- | Make sure that flattening actually produces a coercion (in other--- words, make sure our flavour is not Derived)--- Note [No derived kind equalities]-noBogusCoercions :: FlatM a -> FlatM a-noBogusCoercions thing_inside-  = FlatM $ \env ->-    -- No new thunk is made if the flavour hasn't changed (note the bang).-    let !env' = case fe_flavour env of-          Derived -> env { fe_flavour = Wanted WDeriv }-          _       -> env-    in-    runFlatM thing_inside env'--bumpDepth :: FlatM a -> FlatM a-bumpDepth (FlatM thing_inside)-  = FlatM $ \env -> do-      -- bumpDepth can be called a lot during flattening so we force the-      -- new env to avoid accumulating thunks.-      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }-      ; thing_inside env' }--{--Note [The flattening work list]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The "flattening work list", held in the fe_work field of FlattenEnv,-is a list of CFunEqCans generated during flattening.  The key idea-is this.  Consider flattening (Eq (F (G Int) (H Bool)):-  * The flattener recursively calls itself on sub-terms before building-    the main term, so it will encounter the terms in order-              G Int-              H Bool-              F (G Int) (H Bool)-    flattening to sub-goals-              w1: G Int ~ fuv0-              w2: H Bool ~ fuv1-              w3: F fuv0 fuv1 ~ fuv2--  * Processing w3 first is BAD, because we can't reduce i t,so it'll-    get put into the inert set, and later kicked out when w1, w2 are-    solved.  In #9872 this led to inert sets containing hundreds-    of suspended calls.--  * So we want to process w1, w2 first.--  * So you might think that we should just use a FIFO deque for the work-list,-    so that putting adding goals in order w1,w2,w3 would mean we processed-    w1 first.--  * BUT suppose we have 'type instance G Int = H Char'.  Then processing-    w1 leads to a new goal-                w4: H Char ~ fuv0-    We do NOT want to put that on the far end of a deque!  Instead we want-    to put it at the *front* of the work-list so that we continue to work-    on it.--So the work-list structure is this:--  * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on-    top (extendWorkListFunEq), and take new work from the top-    (selectWorkItem).--  * When flattening, emitFlatWork pushes new flattening goals (like-    w1,w2,w3) onto the flattening work list, fe_work, another-    push-down stack.--  * When we finish flattening, we *reverse* the fe_work stack-    onto the wl_funeqs stack (which brings w1 to the top).--The function runFlatten initialises the fe_work stack, and reverses-it onto wl_fun_eqs at the end.--Note [Flattener EqRels]-~~~~~~~~~~~~~~~~~~~~~~~-When flattening, we need to know which equality relation -- nominal-or representation -- we should be respecting. The only difference is-that we rewrite variables by representational equalities when fe_eq_rel-is ReprEq, and that we unwrap newtypes when flattening w.r.t.-representational equality.--Note [Flattener CtLoc]-~~~~~~~~~~~~~~~~~~~~~~-The flattener does eager type-family reduction.-Type families might loop, and we-don't want GHC to do so. A natural solution is to have a bounded depth-to these processes. A central difficulty is that such a solution isn't-quite compositional. For example, say it takes F Int 10 steps to get to Bool.-How many steps does it take to get from F Int -> F Int to Bool -> Bool?-10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to-know and hard to track. So, we punt, essentially. We store a CtLoc in-the FlattenEnv and just update the environment when recurring. In the-TyConApp case, where there may be multiple type families to flatten,-we just copy the current CtLoc into each branch. If any branch hits the-stack limit, then the whole thing fails.--A consequence of this is that setting the stack limits appropriately-will be essentially impossible. So, the official recommendation if a-stack limit is hit is to disable the check entirely. Otherwise, there-will be baffling, unpredictable errors.--Note [Lazy flattening]-~~~~~~~~~~~~~~~~~~~~~~-The idea of FM_Avoid mode is to flatten less aggressively.  If we have-       a ~ [F Int]-there seems to be no great merit in lifting out (F Int).  But if it was-       a ~ [G a Int]-then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,-which gets rid of the occurs-check problem.  (For the flat_top Bool, see-comments above and at call sites.)--HOWEVER, the lazy flattening actually seems to make type inference go-*slower*, not faster.  perf/compiler/T3064 is a case in point; it gets-*dramatically* worse with FM_Avoid.  I think it may be because-floating the types out means we normalise them, and that often makes-them smaller and perhaps allows more re-use of previously solved-goals.  But to be honest I'm not absolutely certain, so I am leaving-FM_Avoid in the code base.  What I'm removing is the unique place-where it is *used*, namely in GHC.Tc.Solver.Canonical.canEqTyVar.--See also Note [Conservative unification check] in GHC.Tc.Utils.Unify, which gives-other examples where lazy flattening caused problems.--Bottom line: FM_Avoid is unused for now (Nov 14).-Note: T5321Fun got faster when I disabled FM_Avoid-      T5837 did too, but it's pathological anyway--Note [Phantoms in the flattener]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--data Proxy p = Proxy--and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`-is really irrelevant -- it will be ignored when solving for representational-equality later on. So, we omit flattening `ty` entirely. This may-violate the expectation of "xi"s for a bit, but the canonicaliser will-soon throw out the phantoms when decomposing a TyConApp. (Or, the-canonicaliser will emit an insoluble, in which case the unflattened version-yields a better error message anyway.)--Note [No derived kind equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A kind-level coercion can appear in types, via mkCastTy. So, whenever-we are generating a coercion in a dependent context (in other words,-in a kind) we need to make sure that our flavour is never Derived-(as Derived constraints have no evidence). The noBogusCoercions function-changes the flavour from Derived just for this purpose.---}--{- *********************************************************************-*                                                                      *-*      Externally callable flattening functions                        *-*                                                                      *-*  They are all wrapped in runFlatten, so their                        *-*  flattening work gets put into the work list                         *-*                                                                      *-*********************************************************************--Note [rewriteTyVar]-~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an injective function F and-  inert_funeqs:   F t1 ~ fsk1-                  F t2 ~ fsk2-  inert_eqs:      fsk1 ~ [a]-                  a ~ Int-                  fsk2 ~ [Int]--We never rewrite the RHS (cc_fsk) of a CFunEqCan. But we /do/ want to get the-[D] t1 ~ t2 from the injectiveness of F. So we flatten cc_fsk of CFunEqCans-when trying to find derived equalities arising from injectivity.--}---- | See Note [Flattening].--- If (xi, co) <- flatten mode ev ty, then co :: xi ~r ty--- where r is the role in @ev@. If @mode@ is 'FM_FlattenAll',--- then 'xi' is almost function-free (Note [Almost function-free]--- in "GHC.Tc.Types").-flatten :: FlattenMode -> CtEvidence -> TcType-        -> TcS (Xi, TcCoercion)-flatten mode ev ty-  = do { traceTcS "flatten {" (ppr mode <+> ppr ty)-       ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)-       ; traceTcS "flatten }" (ppr ty')-       ; return (ty', co) }---- Apply the inert set as an *inert generalised substitution* to--- a variable, zonking along the way.--- See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad.--- Equivalently, this flattens the variable with respect to NomEq--- in a Derived constraint. (Why Derived? Because Derived allows the--- most about of rewriting.) Returns no coercion, because we're--- using Derived constraints.--- See Note [rewriteTyVar]-rewriteTyVar :: TcTyVar -> TcS TcType-rewriteTyVar tv-  = do { traceTcS "rewriteTyVar {" (ppr tv)-       ; (ty, _) <- runFlatten FM_SubstOnly fake_loc Derived NomEq $-                    flattenTyVar tv-       ; traceTcS "rewriteTyVar }" (ppr ty)-       ; return ty }-  where-    fake_loc = pprPanic "rewriteTyVar used a CtLoc" (ppr tv)---- specialized to flattening kinds: never Derived, always Nominal--- See Note [No derived kind equalities]--- See Note [Flattening]-flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)-flattenKind loc flav ty-  = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)-       ; let flav' = case flav of-                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not-                       _       -> flav-       ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)-       ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic-       ; return (ty', co) }---- See Note [Flattening]-flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)--- Externally-callable, hence runFlatten--- Flatten a vector of types all at once; in fact they are--- always the arguments of type family or class, so---      ctEvFlavour ev = Nominal--- and we want to flatten all at nominal role--- The kind passed in is the kind of the type family or class, call it T--- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys))------ For Derived constraints the returned coercion may be undefined--- because flattening may use a Derived equality ([D] a ~ ty)-flattenArgsNom ev tc tys-  = do { traceTcS "flatten_args {" (vcat (map ppr tys))-       ; (tys', cos, kind_co)-           <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)-       ; traceTcS "flatten }" (vcat (map ppr tys'))-       ; return (tys', cos, kind_co) }---- | Flatten a type w.r.t. nominal equality. This is useful to rewrite--- a type w.r.t. any givens. It does not do type-family reduction. This--- will never emit new constraints. Call this when the inert set contains--- only givens.-flattenType :: CtLoc -> TcType -> TcS TcType-flattenType loc ty-          -- More info about FM_SubstOnly in Note [Holes] in GHC.Tc.Types.Constraint-  = do { (xi, _) <- runFlatten FM_SubstOnly loc Given NomEq $-                    flatten_one ty-                     -- use Given flavor so that it is rewritten-                     -- only w.r.t. Givens, never Wanteds/Deriveds-                     -- (Shouldn't matter, if only Givens are present-                     -- anyway)-       ; return xi }--{- *********************************************************************-*                                                                      *-*           The main flattening functions-*                                                                      *-********************************************************************* -}--{- Note [Flattening]-~~~~~~~~~~~~~~~~~~~~-  flatten ty  ==>   (xi, co)-    where-      xi has no type functions, unless they appear under ForAlls-         has no skolems that are mapped in the inert set-         has no filled-in metavariables-      co :: xi ~ ty--Key invariants:-  (F0) co :: xi ~ zonk(ty)-  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind-  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))--Note that it is flatten's job to flatten *every type function it sees*.-flatten is only called on *arguments* to type functions, by canEqGiven.--Flattening also:-  * zonks, removing any metavariables, and-  * applies the substitution embodied in the inert set--The result of flattening is *almost function-free*. See-Note [Almost function-free] in GHC.Tc.Utils.--Because flattening zonks and the returned coercion ("co" above) is also-zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,-we can rely on this fact:--  (F0) co :: xi ~ zonk(ty)--Note that the left-hand type of co is *always* precisely xi. The right-hand-type may or may not be ty, however: if ty has unzonked filled-in metavariables,-then the right-hand type of co will be the zonked version of ty.-It is for this reason that we-occasionally have to explicitly zonk, when (co :: xi ~ ty) is important-even before we zonk the whole program. For example, see the FTRNotFollowed-case in flattenTyVar.--Why have these invariants on flattening? Because we sometimes use tcTypeKind-during canonicalisation, and we want this kind to be zonked (e.g., see-GHC.Tc.Solver.Canonical.canEqTyVar).--Flattening is always homogeneous. That is, the kind of the result of flattening is-always the same as the kind of the input, modulo zonking. More formally:--  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))--This invariant means that the kind of a flattened type might not itself be flat.--Recall that in comments we use alpha[flat = ty] to represent a-flattening skolem variable alpha which has been generated to stand in-for ty.------- Example of flattening a constraint: -------  flatten (List (F (G Int)))  ==>  (xi, cc)-    where-      xi  = List alpha-      cc  = { G Int ~ beta[flat = G Int],-              F beta ~ alpha[flat = F beta] }-Here-  * alpha and beta are 'flattening skolem variables'.-  * All the constraints in cc are 'given', and all their coercion terms-    are the identity.--NB: Flattening Skolems only occur in canonical constraints, which-are never zonked, so we don't need to worry about zonking doing-accidental unflattening.--Note that we prefer to leave type synonyms unexpanded when possible,-so when the flattener encounters one, it first asks whether its-transitive expansion contains any type function applications.  If so,-it expands the synonym and proceeds; if not, it simply returns the-unexpanded synonym.--Note [flatten_args performance]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In programs with lots of type-level evaluation, flatten_args becomes-part of a tight loop. For example, see test perf/compiler/T9872a, which-calls flatten_args a whopping 7,106,808 times. It is thus important-that flatten_args be efficient.--Performance testing showed that the current implementation is indeed-efficient. It's critically important that zipWithAndUnzipM be-specialized to TcS, and it's also quite helpful to actually `inline`-it. On test T9872a, here are the allocation stats (Dec 16, 2014):-- * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap- * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap- * Specialized, inlined:         6,281,539,792 bytes allocated in the heap--To improve performance even further, flatten_args_nom is split off-from flatten_args, as nominal equality is the common case. This would-be natural to write using mapAndUnzipM, but even inlined, that function-is not as performant as a hand-written loop.-- * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap- * hand-written recursion:       5,848,602,848 bytes allocated in the heap--If you make any change here, pay close attention to the T9872{a,b,c} tests-and T5321Fun.--If we need to make this yet more performant, a possible way forward is to-duplicate the flattener code for the nominal case, and make that case-faster. This doesn't seem quite worth it, yet.--Note [flatten_exact_fam_app_fully performance]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The refactor of GRefl seems to cause performance trouble for T9872x:-the allocation of flatten_exact_fam_app_fully_performance-increased. See note [Generalized reflexive coercion] in-GHC.Core.TyCo.Rep for more information about GRefl and #15192 for the-current state.--The explicit pattern match in homogenise_result helps with T9872a, b, c.--Still, it increases the expected allocation of T9872d by ~2%.--TODO: a step-by-step replay of the refactor to analyze the performance.---}--{-# INLINE flatten_args_tc #-}-flatten_args_tc-  :: TyCon         -- T-  -> [Role]        -- Role r-  -> [Type]        -- Arg types [t1,..,tn]-  -> FlatM ( [Xi]  -- List of flattened args [x1,..,xn]-                   -- 1-1 corresp with [t1,..,tn]-           , [Coercion]  -- List of arg coercions [co1,..,con]-                         -- 1-1 corresp with [t1,..,tn]-                         --    coi :: xi ~r ti-           , CoercionN)  -- Result coercion, rco-                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))-flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet-  -- NB: TyCon kinds are always closed-  where-    (bndrs, named)-      = ty_con_binders_ty_binders' (tyConBinders tc)-    -- it's possible that the result kind has arrows (for, e.g., a type family)-    -- so we must split it-    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)-    !all_bndrs                           = bndrs `chkAppend` inner_bndrs-    !any_named_bndrs                     = named || inner_named-    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.--{-# INLINE flatten_args #-}-flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are-                                     -- named.-             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars-             -> [Role] -> [Type]     -- these are in 1-to-1 correspondence-             -> FlatM ([Xi], [Coercion], CoercionN)--- Coercions :: Xi ~ Type, at roles given--- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)--- That is, the third coercion relates the kind of some function (whose kind is--- passed as the first parameter) instantiated at xis to the kind of that--- function instantiated at the tys. This is useful in keeping flattening--- homoegeneous. The list of roles must be at least as long as the list of--- types.-flatten_args orig_binders-             any_named_bndrs-             orig_inner_ki-             orig_fvs-             orig_roles-             orig_tys-  = if any_named_bndrs-    then flatten_args_slow orig_binders-                           orig_inner_ki-                           orig_fvs-                           orig_roles-                           orig_tys-    else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys--{-# INLINE flatten_args_fast #-}--- | fast path flatten_args, in which none of the binders are named and--- therefore we can avoid tracking a lifting context.--- There are many bang patterns in here. It's been observed that they--- greatly improve performance of an optimized build.--- The T9872 test cases are good witnesses of this fact.-flatten_args_fast :: [TyCoBinder]-                  -> Kind-                  -> [Role]-                  -> [Type]-                  -> FlatM ([Xi], [Coercion], CoercionN)-flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys-  = fmap finish (iterate orig_tys orig_roles orig_binders)-  where--    iterate :: [Type]-            -> [Role]-            -> [TyCoBinder]-            -> FlatM ([Xi], [Coercion], [TyCoBinder])-    iterate (ty:tys) (role:roles) (_:binders) = do-      (xi, co) <- go role ty-      (xis, cos, binders) <- iterate tys roles binders-      pure (xi : xis, co : cos, binders)-    iterate [] _ binders = pure ([], [], binders)-    iterate _ _ _ = pprPanic-        "flatten_args wandered into deeper water than usual" (vcat [])-           -- This debug information is commented out because leaving it in-           -- causes a ~2% increase in allocations in T9872{a,c,d}.-           {--             (vcat [ppr orig_binders,-                    ppr orig_inner_ki,-                    ppr (take 10 orig_roles), -- often infinite!-                    ppr orig_tys])-           -}--    {-# INLINE go #-}-    go :: Role-       -> Type-       -> FlatM (Xi, Coercion)-    go role ty-      = case role of-          -- In the slow path we bind the Xi and Coercion from the recursive-          -- call and then use it such-          ---          --   let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)-          --       casted_xi = xi `mkCastTy` kind_co-          --       casted_co = xi |> kind_co ~r xi ; co-          ---          -- but this isn't necessary:-          --   mkTcSymCo (Refl a b) = Refl a b,-          --   mkCastTy x (Refl _ _) = x-          --   mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co-          ---          -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since-          -- we've already established that they're all anonymous.-          Nominal          -> setEqRel NomEq  $ flatten_one ty-          Representational -> setEqRel ReprEq $ flatten_one ty-          Phantom          -> -- See Note [Phantoms in the flattener]-                              do { ty <- liftTcS $ zonkTcType ty-                                 ; return (ty, mkReflCo Phantom ty) }---    {-# INLINE finish #-}-    finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)-    finish (xis, cos, binders) = (xis, cos, kind_co)-      where-        final_kind = mkPiTys binders orig_inner_ki-        kind_co    = mkNomReflCo final_kind--{-# INLINE flatten_args_slow #-}--- | Slow path, compared to flatten_args_fast, because this one must track--- a lifting context.-flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet-                  -> [Role] -> [Type]-                  -> FlatM ([Xi], [Coercion], CoercionN)-flatten_args_slow binders inner_ki fvs roles tys--- Arguments used dependently must be flattened with proper coercions, but--- we're not guaranteed to get a proper coercion when flattening with the--- "Derived" flavour. So we must call noBogusCoercions when flattening arguments--- corresponding to binders that are dependent. However, we might legitimately--- have *more* arguments than binders, in the case that the inner_ki is a variable--- that gets instantiated with a Π-type. We conservatively choose not to produce--- bogus coercions for these, too. Note that this might miss an opportunity for--- a Derived rewriting a Derived. The solution would be to generate evidence for--- Deriveds, thus avoiding this whole noBogusCoercions idea. See also--- Note [No derived kind equalities]-  = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)-                                        roles tys-       ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) }-  where-    {-# INLINE fl #-}-    fl :: Bool   -- must we ensure to produce a real coercion here?-                  -- see comment at top of function-       -> Role -> Type -> FlatM (Xi, Coercion)-    fl True  r ty = noBogusCoercions $ fl1 r ty-    fl False r ty =                    fl1 r ty--    {-# INLINE fl1 #-}-    fl1 :: Role -> Type -> FlatM (Xi, Coercion)-    fl1 Nominal ty-      = setEqRel NomEq $-        flatten_one ty--    fl1 Representational ty-      = setEqRel ReprEq $-        flatten_one ty--    fl1 Phantom ty-    -- See Note [Phantoms in the flattener]-      = do { ty <- liftTcS $ zonkTcType ty-           ; return (ty, mkReflCo Phantom ty) }---------------------flatten_one :: TcType -> FlatM (Xi, Coercion)--- Flatten a type to get rid of type function applications, returning--- the new type-function-free type, and a collection of new equality--- constraints.  See Note [Flattening] for more detail.------ Postcondition: Coercion :: Xi ~ TcType--- The role on the result coercion matches the EqRel in the FlattenEnv--flatten_one xi@(LitTy {})-  = do { role <- getRole-       ; return (xi, mkReflCo role xi) }--flatten_one (TyVarTy tv)-  = flattenTyVar tv--flatten_one (AppTy ty1 ty2)-  = flatten_app_tys ty1 [ty2]--flatten_one (TyConApp tc tys)-  -- Expand type synonyms that mention type families-  -- on the RHS; see Note [Flattening synonyms]-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'-  = do { mode <- getMode-       ; case mode of-           FM_FlattenAll | not (isFamFreeTyCon tc)-                         -> flatten_one expanded_ty-           _             -> flatten_ty_con_app tc tys }--  -- Otherwise, it's a type function application, and we have to-  -- flatten it away as well, and generate a new given equality constraint-  -- between the application and a newly generated flattening skolem variable.-  | isTypeFamilyTyCon tc-  = flatten_fam_app tc tys--  -- For * a normal data type application-  --     * data family application-  -- we just recursively flatten the arguments.-  | otherwise--- FM_Avoid stuff commented out; see Note [Lazy flattening]---  , let fmode' = case fmode of  -- Switch off the flat_top bit in FM_Avoid---                   FE { fe_mode = FM_Avoid tv _ }---                     -> fmode { fe_mode = FM_Avoid tv False }---                   _ -> fmode-  = flatten_ty_con_app tc tys--flatten_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-  = do { (xi1,co1) <- flatten_one ty1-       ; (xi2,co2) <- flatten_one ty2-       ; (xi3,co3) <- setEqRel NomEq $ flatten_one mult-       ; role <- getRole-       ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 }-                , mkFunCo role co3 co1 co2) }--flatten_one ty@(ForAllTy {})--- TODO (RAE): This is inadequate, as it doesn't flatten the kind of--- the bound tyvar. Doing so will require carrying around a substitution--- and the usual substTyVarBndr-like silliness. Argh.---- We allow for-alls when, but only when, no type function--- applications inside the forall involve the bound type variables.-  = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty-             tvs           = binderVars bndrs-       ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho-                         -- Substitute only under a forall-                         -- See Note [Flattening under a forall]-       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }--flatten_one (CastTy ty g)-  = do { (xi, co) <- flatten_one ty-       ; (g', _)   <- flatten_co g-       ; role <- getRole-       ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }-         -- It makes a /big/ difference to call castCoercionKind1 not-         -- the more general castCoercionKind2.-         -- See Note [castCoercionKind1] in GHC.Core.Coercion--flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co---- | "Flatten" a coercion. Really, just zonk it so we can uphold--- (F1) of Note [Flattening]-flatten_co :: Coercion -> FlatM (Coercion, Coercion)-flatten_co co-  = do { co <- liftTcS $ zonkCo co-       ; env_role <- getRole-       ; let co' = mkTcReflCo env_role (mkCoercionTy co)-       ; return (co, co') }---- flatten (nested) AppTys-flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion)--- commoning up nested applications allows us to look up the function's kind--- only once. Without commoning up like this, we would spend a quadratic amount--- of time looking up functions' types-flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys)-flatten_app_tys fun_ty arg_tys-  = do { (fun_xi, fun_co) <- flatten_one fun_ty-       ; flatten_app_ty_args fun_xi fun_co arg_tys }---- Given a flattened function (with the coercion produced by flattening) and--- a bunch of unflattened arguments, flatten the arguments and apply.--- The coercion argument's role matches the role stored in the FlatM monad.------ The bang patterns used here were observed to improve performance. If you--- wish to remove them, be sure to check for regeressions in allocations.-flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion)-flatten_app_ty_args fun_xi fun_co []-  -- this will be a common case when called from flatten_fam_app, so shortcut-  = return (fun_xi, fun_co)-flatten_app_ty_args fun_xi fun_co arg_tys-  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of-           Just (tc, xis) ->-             do { let tc_roles  = tyConRolesRepresentational tc-                      arg_roles = dropList xis tc_roles-                ; (arg_xis, arg_cos, kind_co)-                    <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys--                  -- Here, we have fun_co :: T xi1 xi2 ~ ty-                  -- and we need to apply fun_co to the arg_cos. The problem is-                  -- that using mkAppCo is wrong because that function expects-                  -- its second coercion to be Nominal, and the arg_cos might-                  -- not be. The solution is to use transitivity:-                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>-                ; eq_rel <- getEqRel-                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)-                      app_co = case eq_rel of-                        NomEq  -> mkAppCos fun_co arg_cos-                        ReprEq -> mkTcTyConAppCo Representational tc-                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)-                                  `mkTcTransCo`-                                  mkAppCos fun_co (map mkNomReflCo arg_tys)-                ; return (app_xi, app_co, kind_co) }-           Nothing ->-             do { (arg_xis, arg_cos, kind_co)-                    <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys-                ; let arg_xi = mkAppTys fun_xi arg_xis-                      arg_co = mkAppCos fun_co arg_cos-                ; return (arg_xi, arg_co, kind_co) }--       ; role <- getRole-       ; return (homogenise_result xi co role kind_co) }--flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)-flatten_ty_con_app tc tys-  = do { role <- getRole-       ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys-       ; let tyconapp_xi = mkTyConApp tc xis-             tyconapp_co = mkTyConAppCo role tc cos-       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }---- Make the result of flattening homogeneous (Note [Flattening] (F2))-homogenise_result :: Xi              -- a flattened type-                  -> Coercion        -- :: xi ~r original ty-                  -> Role            -- r-                  -> CoercionN       -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)-                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)-                                     --   ~r original ty)-homogenise_result xi co r kind_co-  -- the explicit pattern match here improves the performance of T9872a, b, c by-  -- ~2%-  | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)-  | otherwise         = (xi `mkCastTy` kind_co-                        , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)-{-# INLINE homogenise_result #-}---- Flatten a vector (list of arguments).-flatten_vector :: Kind   -- of the function being applied to these arguments-               -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the-                         -- args have?-               -> [Type] -- the args to flatten-               -> FlatM ([Xi], [Coercion], CoercionN)-flatten_vector ki roles tys-  = do { eq_rel <- getEqRel-       ; case eq_rel of-           NomEq  -> flatten_args bndrs-                                  any_named_bndrs-                                  inner_ki-                                  fvs-                                  (repeat Nominal)-                                  tys-           ReprEq -> flatten_args bndrs-                                  any_named_bndrs-                                  inner_ki-                                  fvs-                                  roles-                                  tys-       }-  where-    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki-    fvs                                = tyCoVarsOfType ki-{-# INLINE flatten_vector #-}--{--Note [Flattening synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Not expanding synonyms aggressively improves error messages, and-keeps types smaller. But we need to take care.--Suppose-   type T a = a -> a-and we want to flatten the type (T (F a)).  Then we can safely flatten-the (F a) to a skolem, and return (T fsk).  We don't need to expand the-synonym.  This works because TcTyConAppCo can deal with synonyms-(unlike TyConAppCo), see Note [TcCoercions] in GHC.Tc.Types.Evidence.--But (#8979) for-   type T a = (F a, a)    where F is a type function-we must expand the synonym in (say) T Int, to expose the type function-to the flattener.---Note [Flattening under a forall]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Under a forall, we-  (a) MUST apply the inert substitution-  (b) MUST NOT flatten type family applications-Hence FMSubstOnly.--For (a) consider   c ~ a, a ~ T (forall b. (b, [c]))-If we don't apply the c~a substitution to the second constraint-we won't see the occurs-check error.--For (b) consider  (a ~ forall b. F a b), we don't want to flatten-to     (a ~ forall b.fsk, F a b ~ fsk)-because now the 'b' has escaped its scope.  We'd have to flatten to-       (a ~ forall b. fsk b, forall b. F a b ~ fsk b)-and we have not begun to think about how to make that work!--************************************************************************-*                                                                      *-             Flattening a type-family application-*                                                                      *-************************************************************************--}--flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)-  --   flatten_fam_app            can be over-saturated-  --   flatten_exact_fam_app       is exactly saturated-  --   flatten_exact_fam_app_fully lifts out the application to top level-  -- Postcondition: Coercion :: Xi ~ F tys-flatten_fam_app tc tys  -- Can be over-saturated-    = ASSERT2( tys `lengthAtLeast` tyConArity tc-             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)--      do { mode <- getMode-         ; case mode of-             { FM_SubstOnly  -> flatten_ty_con_app tc tys-             ; FM_FlattenAll ->--                 -- Type functions are saturated-                 -- The type function might be *over* saturated-                 -- in which case the remaining arguments should-                 -- be dealt with by AppTys-      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys-         ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1-               -- co1 :: xi1 ~ F tys1--         ; flatten_app_ty_args xi1 co1 tys_rest } } }---- the [TcType] exactly saturate the TyCon--- See note [flatten_exact_fam_app_fully performance]-flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)-flatten_exact_fam_app_fully tc tys-  -- See Note [Reduce type family applications eagerly]-     -- the following tcTypeKind should never be evaluated, as it's just used in-     -- casting, and casts by refl are dropped-  = do { mOut <- try_to_reduce_nocache tc tys-       ; case mOut of-           Just out -> pure out-           Nothing -> do-               { -- First, flatten the arguments-               ; (xis, cos, kind_co)-                   <- setEqRel NomEq $  -- just do this once, instead of for-                                        -- each arg-                      flatten_args_tc tc (repeat Nominal) tys-                      -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)-               ; eq_rel   <- getEqRel-               ; cur_flav <- getFlavour-               ; let role   = eqRelRole eq_rel-                     ret_co = mkTyConAppCo role tc cos-                      -- ret_co :: F xis ~ F tys; might be heterogeneous--                -- Now, look in the cache-               ; mb_ct <- liftTcS $ lookupFlatCache tc xis-               ; case mb_ct of-                   Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk-                        -- flav is [G] or [WD]-                        -- See Note [Type family equations] in GHC.Tc.Solver.Monad-                     | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav-                     ->  -- Usable hit in the flat-cache-                        do { traceFlat "flatten/flat-cache hit" $-                               (ppr tc <+> ppr xis $$ ppr rhs_ty)-                           ; (fsk_xi, fsk_co) <- flatten_one rhs_ty-                                  -- The fsk may already have been unified, so-                                  -- flatten it-                                  -- fsk_co :: fsk_xi ~ fsk-                           ; let xi  = fsk_xi `mkCastTy` kind_co-                                 co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co-                                       `mkTransCo`-                                       maybeTcSubCo eq_rel (mkSymCo co)-                                       `mkTransCo` ret_co-                           ; return (xi, co')-                           }-                                            -- :: fsk_xi ~ F xis--                   -- Try to reduce the family application right now-                   -- See Note [Reduce type family applications eagerly]-                   _ -> do { mOut <- try_to_reduce tc-                                                   xis-                                                   kind_co-                                                   (`mkTransCo` ret_co)-                           ; case mOut of-                               Just out -> pure out-                               Nothing -> do-                                 { loc <- getLoc-                                 ; (ev, co, fsk) <- liftTcS $-                                     newFlattenSkolem cur_flav loc tc xis--                                 -- The new constraint (F xis ~ fsk) is not-                                 -- necessarily inert (e.g. the LHS may be a-                                 -- redex) so we must put it in the work list-                                 ; let ct = CFunEqCan { cc_ev     = ev-                                                      , cc_fun    = tc-                                                      , cc_tyargs = xis-                                                      , cc_fsk    = fsk }-                                 ; emitFlatWork ct--                                 ; traceFlat "flatten/flat-cache miss" $-                                     (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)--                                 -- NB: fsk's kind is already flattened because-                                 --     the xis are flattened-                                 ; let fsk_ty = mkTyVarTy fsk-                                       xi = fsk_ty `mkCastTy` kind_co-                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeTcSubCo eq_rel (mkSymCo co))-                                             `mkTransCo` ret_co-                                 ; return (xi, co')-                                 }-                           }-               }-        }--  where--    -- try_to_reduce and try_to_reduce_nocache (below) could be unified into-    -- a more general definition, but it was observed that separating them-    -- gives better performance (lower allocation numbers in T9872x).--    try_to_reduce :: TyCon   -- F, family tycon-                  -> [Type]  -- args, not necessarily flattened-                  -> CoercionN -- kind_co :: tcTypeKind(F args) ~N-                               --            tcTypeKind(F orig_args)-                               -- where-                               -- orig_args is what was passed to the outer-                               -- function-                  -> (   Coercion     -- :: (xi |> kind_co) ~ F args-                      -> Coercion )   -- what to return from outer function-                  -> FlatM (Maybe (Xi, Coercion))-    try_to_reduce tc tys kind_co update_co-      = do { checkStackDepth (mkTyConApp tc tys)-           ; mb_match <- liftTcS $ matchFam tc tys-           ; case mb_match of-                 -- NB: norm_co will always be homogeneous. All type families-                 -- are homogeneous.-               Just (norm_co, norm_ty)-                 -> do { traceFlat "Eager T.F. reduction success" $-                         vcat [ ppr tc, ppr tys, ppr norm_ty-                              , ppr norm_co <+> dcolon-                                            <+> ppr (coercionKind norm_co)-                              ]-                       ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty-                       ; eq_rel <- getEqRel-                       ; let co = maybeTcSubCo eq_rel norm_co-                                   `mkTransCo` mkSymCo final_co-                       ; flavour <- getFlavour-                           -- NB: only extend cache with nominal equalities-                       ; when (eq_rel == NomEq) $-                         liftTcS $-                         extendFlatCache tc tys ( co, xi, flavour )-                       ; let role = eqRelRole eq_rel-                             xi' = xi `mkCastTy` kind_co-                             co' = update_co $-                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)-                       ; return $ Just (xi', co') }-               Nothing -> pure Nothing }--    try_to_reduce_nocache :: TyCon   -- F, family tycon-                          -> [Type]  -- args, not necessarily flattened-                          -> FlatM (Maybe (Xi, Coercion))-    try_to_reduce_nocache tc tys-      = do { checkStackDepth (mkTyConApp tc tys)-           ; mb_match <- liftTcS $ matchFam tc tys-           ; case mb_match of-                 -- NB: norm_co will always be homogeneous. All type families-                 -- are homogeneous.-               Just (norm_co, norm_ty)-                 -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty-                       ; eq_rel <- getEqRel-                       ; let co  = mkSymCo (maybeTcSubCo eq_rel norm_co-                                            `mkTransCo` mkSymCo final_co)-                       ; return $ Just (xi, co) }-               Nothing -> pure Nothing }--{- Note [Reduce type family applications eagerly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we come across a type-family application like (Append (Cons x Nil) t),-then, rather than flattening to a skolem etc, we may as well just reduce-it on the spot to (Cons x t).  This saves a lot of intermediate steps.-Examples that are helped are tests T9872, and T5321Fun.--Performance testing indicates that it's best to try this *twice*, once-before flattening arguments and once after flattening arguments.-Adding the extra reduction attempt before flattening arguments cut-the allocation amounts for the T9872{a,b,c} tests by half.--An example of where the early reduction appears helpful:--  type family Last x where-    Last '[x]     = x-    Last (h ': t) = Last t--  workitem: (x ~ Last '[1,2,3,4,5,6])--Flattening the argument never gets us anywhere, but trying to flatten-it at every step is quadratic in the length of the list. Reducing more-eagerly makes simplifying the right-hand type linear in its length.--Testing also indicated that the early reduction should *not* use the-flat-cache, but that the later reduction *should*. (Although the-effect was not large.)  Hence the Bool argument to try_to_reduce.  To-me (SLPJ) this seems odd; I get that eager reduction usually succeeds;-and if don't use the cache for eager reduction, we will miss most of-the opportunities for using it at all.  More exploration would be good-here.--At the end, once we've got a flat rhs, we extend the flatten-cache to record-the result. Doing so can save lots of work when the same redex shows up more-than once. Note that we record the link from the redex all the way to its-*final* value, not just the single step reduction. Interestingly, using the-flat-cache for the first reduction resulted in an increase in allocations-of about 3% for the four T9872x tests. However, using the flat-cache in-the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)-have any knowledge as to *why* these facts are true.--************************************************************************-*                                                                      *-             Flattening a type variable-*                                                                      *-********************************************************************* -}---- | The result of flattening a tyvar "one step".-data FlattenTvResult-  = FTRNotFollowed-      -- ^ The inert set doesn't make the tyvar equal to anything else--  | FTRFollowed TcType Coercion-      -- ^ The tyvar flattens to a not-necessarily flat other type.-      -- co :: new type ~r old type, where the role is determined by-      -- the FlattenEnv--flattenTyVar :: TyVar -> FlatM (Xi, Coercion)-flattenTyVar tv-  = do { mb_yes <- flatten_tyvar1 tv-       ; case mb_yes of-           FTRFollowed ty1 co1  -- Recur-             -> do { (ty2, co2) <- flatten_one ty1-                   -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2)-                   ; return (ty2, co2 `mkTransCo` co1) }--           FTRNotFollowed   -- Done, but make sure the kind is zonked-                            -- Note [Flattening] invariant (F0) and (F1)-             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv-                   ; role <- getRole-                   ; let ty' = mkTyVarTy tv'-                   ; return (ty', mkTcReflCo role ty') } }--flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult--- "Flattening" a type variable means to apply the substitution to it--- Specifically, look up the tyvar in---   * the internal MetaTyVar box---   * the inerts--- See also the documentation for FlattenTvResult--flatten_tyvar1 tv-  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv-       ; case mb_ty of-           Just ty -> do { traceFlat "Following filled tyvar"-                             (ppr tv <+> equals <+> ppr ty)-                         ; role <- getRole-                         ; return (FTRFollowed ty (mkReflCo role ty)) } ;-           Nothing -> do { traceFlat "Unfilled tyvar" (pprTyVar tv)-                         ; fr <- getFlavourRole-                         ; flatten_tyvar2 tv fr } }--flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult--- The tyvar is not a filled-in meta-tyvar--- Try in the inert equalities--- See Definition [Applying a generalised substitution] in GHC.Tc.Solver.Monad--- See Note [Stability of flattening] in GHC.Tc.Solver.Monad--flatten_tyvar2 tv fr@(_, eq_rel)-  = do { ieqs <- liftTcS $ getInertEqs-       ; mode <- getMode-       ; case lookupDVarEnv ieqs tv of-           Just (ct:_)   -- If the first doesn't work,-                         -- the subsequent ones won't either-             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv-                        , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct-             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)-             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR-             -> do { traceFlat "Following inert tyvar"-                        (ppr mode <+>-                         ppr tv <+>-                         equals <+>-                         ppr rhs_ty $$ ppr ctev)-                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)-                          rewrite_co  = case (ct_eq_rel, eq_rel) of-                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )-                                    -- if this ASSERT fails, then-                                    -- eqCanRewriteFR answered incorrectly-                                               rewrite_co1-                            (NomEq, NomEq)  -> rewrite_co1-                            (NomEq, ReprEq) -> mkSubCo rewrite_co1--                    ; return (FTRFollowed rhs_ty rewrite_co) }-                    -- NB: ct is Derived then fmode must be also, hence-                    -- we are not going to touch the returned coercion-                    -- so ctEvCoercion is fine.--           _other -> return FTRNotFollowed }--{--Note [An alternative story for the inert substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(This entire note is just background, left here in case we ever want- to return the previous state of affairs)--We used (GHC 7.8) to have this story for the inert substitution inert_eqs-- * 'a' is not in fvs(ty)- * They are *inert* in the weaker sense that there is no infinite chain of-   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc--This means that flattening must be recursive, but it does allow-  [G] a ~ [b]-  [G] b ~ Maybe c--This avoids "saturating" the Givens, which can save a modest amount of work.-It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert-only if (a) the work item can rewrite the inert AND-        (b) the inert cannot rewrite the work item--This is significantly harder to think about. It can save a LOT of work-in occurs-check cases, but we don't care about them much.  #5837-is an example; all the constraints here are Givens--             [G] a ~ TF (a,Int)-    -->-    work     TF (a,Int) ~ fsk-    inert    fsk ~ a--    --->-    work     fsk ~ (TF a, TF Int)-    inert    fsk ~ a--    --->-    work     a ~ (TF a, TF Int)-    inert    fsk ~ a--    ---> (attempting to flatten (TF a) so that it does not mention a-    work     TF a ~ fsk2-    inert    a ~ (fsk2, TF Int)-    inert    fsk ~ (fsk2, TF Int)--    ---> (substitute for a)-    work     TF (fsk2, TF Int) ~ fsk2-    inert    a ~ (fsk2, TF Int)-    inert    fsk ~ (fsk2, TF Int)--    ---> (top-level reduction, re-orient)-    work     fsk2 ~ (TF fsk2, TF Int)-    inert    a ~ (fsk2, TF Int)-    inert    fsk ~ (fsk2, TF Int)--    ---> (attempt to flatten (TF fsk2) to get rid of fsk2-    work     TF fsk2 ~ fsk3-    work     fsk2 ~ (fsk3, TF Int)-    inert    a   ~ (fsk2, TF Int)-    inert    fsk ~ (fsk2, TF Int)--    --->-    work     TF fsk2 ~ fsk3-    inert    fsk2 ~ (fsk3, TF Int)-    inert    a   ~ ((fsk3, TF Int), TF Int)-    inert    fsk ~ ((fsk3, TF Int), TF Int)--Because the incoming given rewrites all the inert givens, we get more and-more duplication in the inert set.  But this really only happens in pathological-casee, so we don't care.---************************************************************************-*                                                                      *-             Unflattening-*                                                                      *-************************************************************************--An unflattening example:-    [W] F a ~ alpha-flattens to-    [W] F a ~ fmv   (CFunEqCan)-    [W] fmv ~ alpha (CTyEqCan)-We must solve both!--}--unflattenWanteds :: Cts -> Cts -> TcS Cts-unflattenWanteds tv_eqs funeqs- = do { tclvl    <- getTcLevel--      ; traceTcS "Unflattening" $ braces $-        vcat [ text "Funeqs =" <+> pprCts funeqs-             , text "Tv eqs =" <+> pprCts tv_eqs ]--         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check-         -- Occurs check: consider  [W] alpha ~ [F alpha]-         --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]-         --                 ==> (unify)   [W] F [fmv] ~ fmv-         -- See Note [Unflatten using funeqs first]-      ; funeqs <- foldrM unflatten_funeq emptyCts funeqs-      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)--          -- Step 2: unify the tv_eqs, if possible-      ; tv_eqs  <- foldrM (unflatten_eq tclvl) emptyCts tv_eqs-      ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)--          -- Step 3: fill any remaining fmvs with fresh unification variables-      ; funeqs <- mapBagM finalise_funeq funeqs-      ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)--          -- Step 4: remove any tv_eqs that look like ty ~ ty-      ; tv_eqs <- foldrM finalise_eq emptyCts tv_eqs--      ; let all_flat = tv_eqs `andCts` funeqs-      ; traceTcS "Unflattening done" $ braces (pprCts all_flat)--      ; return all_flat }-  where-    -----------------    unflatten_funeq :: Ct -> Cts -> TcS Cts-    unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis-                                  , cc_fsk = fmv, cc_ev = ev }) rest-      = do {   -- fmv should be an un-filled flatten meta-tv;-               -- we now fix its final value by filling it, being careful-               -- to observe the occurs check.  Zonking will eliminate it-               -- altogether in due course-             rhs' <- zonkTcType (mkTyConApp tc xis)-           ; case occCheckExpand [fmv] rhs' of-               Just rhs''    -- Normal case: fill the tyvar-                 -> do { setReflEvidence ev NomEq rhs''-                       ; unflattenFmv fmv rhs''-                       ; return rest }--               Nothing ->  -- Occurs check-                          return (ct `consCts` rest) }--    unflatten_funeq other_ct _-      = pprPanic "unflatten_funeq" (ppr other_ct)--    -----------------    finalise_funeq :: Ct -> TcS Ct-    finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })-      = do { demoteUnfilledFmv fmv-           ; return (mkNonCanonical ev) }-    finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)--    -----------------    unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts-    unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv-                                    , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest--      | NomEq <- eq_rel -- See Note [Do not unify representational equalities]-                        --     in GHC.Tc.Solver.Interact-      , isFmvTyVar tv   -- Previously these fmvs were untouchable,-                        -- but now they are touchable-                        -- NB: unlike unflattenFmv, filling a fmv here /does/-                        --     bump the unification count; it is "improvement"-                        -- Note [Unflattening can force the solver to iterate]-      = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )-           -- CTyEqCan invariant (TyEq:K) should ensure this is true-        do { is_filled <- isFilledMetaTyVar tv-           ; elim <- case is_filled of-               False -> do { traceTcS "unflatten_eq 2" (ppr ct)-                           ; tryFill ev tv rhs }-               True  -> do { traceTcS "unflatten_eq 3" (ppr ct)-                           ; try_fill_rhs ev tclvl tv rhs }-           ; if elim-             then do { setReflEvidence ev eq_rel (mkTyVarTy tv)-                     ; return rest }-             else return (ct `consCts` rest) }--      | otherwise-      = return (ct `consCts` rest)--    unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)--    -----------------    try_fill_rhs ev tclvl lhs_tv rhs-         -- Constraint is lhs_tv ~ rhs_tv,-         -- and lhs_tv is filled, so try RHS-      | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs-                             -- co :: kind(rhs_tv) ~ kind(lhs_tv)-      , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv-                              && not (isTyVarTyVar rhs_tv))-                              -- LHS is a filled fmv, and so is a type-                              -- family application, which a TyVarTv should-                              -- not unify with-      = do { is_filled <- isFilledMetaTyVar rhs_tv-           ; if is_filled then return False-             else tryFill ev rhs_tv-                          (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }--      | otherwise-      = return False--    -----------------    finalise_eq :: Ct -> Cts -> TcS Cts-    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv-                          , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest-      | isFmvTyVar tv-      = do { ty1 <- zonkTcTyVar tv-           ; rhs' <- zonkTcType rhs-           ; if ty1 `tcEqType` rhs'-             then do { setReflEvidence ev eq_rel rhs'-                     ; return rest }-             else return (mkNonCanonical ev `consCts` rest) }--      | otherwise-      = return (mkNonCanonical ev `consCts` rest)--    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)--tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool--- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv--- If tv does not appear in 'rhs', it set tv := rhs,--- binds the evidence (which should be a CtWanted) to Refl<rhs>--- and return True.  Otherwise returns False-tryFill ev tv rhs-  = ASSERT2( not (isGiven ev), ppr ev )-    do { rhs' <- zonkTcType rhs-       ; case () of-            _ | Just tv' <- tcGetTyVar_maybe rhs'-              , tv == tv'   -- tv == rhs-              -> return True--            _ | Just rhs'' <- occCheckExpand [tv] rhs'-              -> do {       -- Fill the tyvar-                      unifyTyVar tv rhs''-                    ; return True }--            _ | otherwise   -- Occurs check-              -> return False-    }--setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()-setReflEvidence ev eq_rel rhs-  = setEvBindIfWanted ev (evCoercion refl_co)-  where-    refl_co = mkTcReflCo (eqRelRole eq_rel) rhs--{--Note [Unflatten using funeqs first]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    [W] G a ~ Int-    [W] F (G a) ~ G a--do not want to end up with-    [W] F Int ~ Int-because that might actually hold!  Better to end up with the two above-unsolved constraints.  The flat form will be--    G a ~ fmv1     (CFunEqCan)-    F fmv1 ~ fmv2  (CFunEqCan)-    fmv1 ~ Int     (CTyEqCan)-    fmv1 ~ fmv2    (CTyEqCan)--Flatten using the fun-eqs first.--}---- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at--- least one named binder.-split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)-split_pi_tys' ty = split ty ty-  where-     -- put common cases first-  split _       (ForAllTy b res) = let (bs, ty, _) = split res res-                                   in  (Named b : bs, ty, True)-  split _       (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })-                                 = let (bs, ty, named) = split res res-                                   in  (Anon af (mkScaled w arg) : bs, ty, named)--  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'-  split orig_ty _                = ([], orig_ty, False)-{-# INLINE split_pi_tys' #-}---- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff--- there is at least one named binder.-ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)-ty_con_binders_ty_binders' = foldr go ([], False)-  where-    go (Bndr tv (NamedTCB vis)) (bndrs, _)-      = (Named (Bndr tv vis) : bndrs, True)-    go (Bndr tv (AnonTCB af))   (bndrs, n)-      = (Anon af (unrestricted (tyVarKind tv))   : bndrs, n)-    {-# INLINE go #-}-{-# INLINE ty_con_binders_ty_binders' #-}

GHC/Tc/Solver/Interact.hs view

@@ -11,37 +11,34 @@ #include "HsVersions.h"  import GHC.Prelude-import GHC.Types.Basic ( SwapFlag(..), isSwapped,+import GHC.Types.Basic ( SwapFlag(..),                          infinity, IntWithInf, intGtLimit ) import GHC.Tc.Solver.Canonical-import GHC.Tc.Solver.Flatten-import GHC.Tc.Utils.Unify( canSolveByUnification ) import GHC.Types.Var.Set import GHC.Core.Type as Type-import GHC.Core.Coercion        ( BlockSubstFlag(..) ) import GHC.Core.InstEnv         ( DFunInstType )-import GHC.Core.Coercion.Axiom  ( sfInteractTop, sfInteractInert )  import GHC.Types.Var import GHC.Tc.Utils.TcType-import GHC.Builtin.Names ( coercibleTyConKey,-                   heqTyConKey, eqTyConKey, ipClassKey )-import GHC.Core.Coercion.Axiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )+import GHC.Builtin.Names ( coercibleTyConKey, heqTyConKey, eqTyConKey, ipClassKey )+import GHC.Core.Coercion.Axiom ( CoAxBranch (..), CoAxiom (..), TypeEqn, fromBranches, sfInteractInert, sfInteractTop ) import GHC.Core.Class import GHC.Core.TyCon import GHC.Tc.Instance.FunDeps import GHC.Tc.Instance.Family-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap )+import GHC.Tc.Instance.Class ( InstanceWhat(..), safeOverlap ) import GHC.Core.FamInstEnv import GHC.Core.Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )  import GHC.Tc.Types.Evidence import GHC.Utils.Outputable+import GHC.Utils.Panic  import GHC.Tc.Types import GHC.Tc.Types.Constraint import GHC.Core.Predicate import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcMType( promoteMetaTyVarTo ) import GHC.Tc.Solver.Monad import GHC.Data.Bag import GHC.Utils.Monad ( concatMapM, foldlM )@@ -58,6 +55,7 @@ import GHC.Driver.Session import GHC.Utils.Misc import qualified GHC.LanguageExtensions as LangExt+import Data.List.NonEmpty ( NonEmpty(..) )  import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe@@ -87,54 +85,10 @@       - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to         the next stage in the pipeline. 4. If the element has survived (i.e. ContinueWith x) the last stage-   then we add him in the inerts and jump back to Step 1.+   then we add it in the inerts and jump back to Step 1.  If in Step 1 no such element exists, we have exceeded our context-stack depth and will simply fail.--Note [Unflatten after solving the simple wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We unflatten after solving the wc_simples of an implication, and before attempting-to float. This means that-- * The fsk/fmv flatten-skolems only survive during solveSimples.  We don't-   need to worry about them across successive passes over the constraint tree.-   (E.g. we don't need the old ic_fsk field of an implication.-- * When floating an equality outwards, we don't need to worry about floating its-   associated flattening constraints.-- * Another tricky case becomes easy: #4935-       type instance F True a b = a-       type instance F False a b = b--       [w] F c a b ~ gamma-       (c ~ True) => a ~ gamma-       (c ~ False) => b ~ gamma--   Obviously this is soluble with gamma := F c a b, and unflattening-   will do exactly that after solving the simple constraints and before-   attempting the implications.  Before, when we were not unflattening,-   we had to push Wanted funeqs in as new givens.  Yuk!--   Another example that becomes easy: indexed_types/should_fail/T7786-      [W] BuriedUnder sub k Empty ~ fsk-      [W] Intersect fsk inv ~ s-      [w] xxx[1] ~ s-      [W] forall[2] . (xxx[1] ~ Empty)-                   => Intersect (BuriedUnder sub k Empty) inv ~ Empty--Note [Running plugins on unflattened wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is an annoying mismatch between solveSimpleGivens and-solveSimpleWanteds, because the latter needs to fiddle with the inert-set, unflatten and zonk the wanteds.  It passes the zonked wanteds-to runTcPluginsWanteds, which produces a replacement set of wanteds,-some additional insolubles and a flag indicating whether to go round-the loop again.  If so, prepareInertsForImplications is used to remove-the previous wanteds (which will still be in the inert set).  Note-that prepareInertsForImplications will discard the insolubles, so we-must keep track of them separately. -}  solveSimpleGivens :: [Ct] -> TcS ()@@ -152,8 +106,6 @@                      go new_givens }  solveSimpleWanteds :: Cts -> TcS WantedConstraints--- NB: 'simples' may contain /derived/ equalities, floated---     out from a nested implication. So don't discard deriveds! -- The result is not necessarily zonked solveSimpleWanteds simples   = do { traceTcS "solveSimpleWanteds {" (ppr simples)@@ -178,48 +130,36 @@       | otherwise      = do { -- Solve-            (unif_count, wc1) <- solve_simple_wanteds wc+            wc1 <- solve_simple_wanteds wc              -- Run plugins           ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1-             -- See Note [Running plugins on unflattened wanteds] -          ; if unif_count == 0 && not rerun_plugin-            then return (n, wc2)             -- Done-            else do { traceTcS "solveSimple going round again:" $-                      ppr unif_count $$ ppr rerun_plugin-                    ; go (n+1) limit wc2 } }      -- Loop+          ; if rerun_plugin+            then do { traceTcS "solveSimple going round again:" (ppr rerun_plugin)+                    ; go (n+1) limit wc2 }   -- Loop+            else return (n, wc2) }           -- Done  -solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)+solve_simple_wanteds :: WantedConstraints -> TcS WantedConstraints -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes })   = nestTcS $     do { solveSimples simples1-       ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts-       ; (unif_count, unflattened_eqs) <- reportUnifications $-                                          unflattenWanteds tv_eqs fun_eqs-            -- See Note [Unflatten after solving the simple wanteds]-       ; return ( unif_count-                , WC { wc_simple = others `andCts` unflattened_eqs-                     , wc_impl   = implics1 `unionBags` implics2-                     , wc_holes  = holes }) }+       ; (implics2, unsolved) <- getUnsolvedInerts+       ; return (WC { wc_simple = unsolved+                    , wc_impl   = implics1 `unionBags` implics2+                    , wc_holes  = holes }) }  {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Solving a bunch of simple constraints is done in a loop, (the 'go' loop of 'solveSimpleWanteds'):-  1. Try to solve them; unflattening may lead to improvement that-     was not exploitable during solving+  1. Try to solve them   2. Try the plugin-  3. If step 1 did improvement during unflattening; or if the plugin-     wants to run again, go back to step 1--Non-obviously, improvement can also take place during-the unflattening that takes place in step (1). See GHC.Tc.Solver.Flatten,-See Note [Unflattening can force the solver to iterate]+  3. If the plugin wants to run again, go back to step 1 -}  -- The main solver loop implements Note [Basic Simplifier Plan]@@ -259,7 +199,7 @@        ; updInertIrreds (\irreds -> extendCtsList irreds insols)        ; return (pluginNewCts p) } } } --- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on+-- | Given a bag of (rewritten, zonked) wanteds, invoke the plugins on -- them and produce an updated bag of wanteds (possibly with some new -- work) and a bag of insolubles.  The boolean indicates whether -- 'solveSimpleWanteds' should feed the updated wanteds back into the@@ -482,17 +422,17 @@ -- Interaction result of  WorkItem <~> Ct  interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)--- Precondition: if the workitem is a CTyEqCan then it will not be able to--- react with anything at this stage.+-- Precondition: if the workitem is a CEqCan then it will not be able to+-- react with anything at this stage (except, maybe, via a type family+-- dependency)  interactWithInertsStage wi   = do { inerts <- getTcSInerts        ; let ics = inert_cans inerts        ; case wi of-             CTyEqCan  {} -> interactTyVarEq ics wi-             CFunEqCan {} -> interactFunEq   ics wi-             CIrredCan {} -> interactIrred   ics wi-             CDictCan  {} -> interactDict    ics wi+             CEqCan    {} -> interactEq    ics wi+             CIrredCan {} -> interactIrred ics wi+             CDictCan  {} -> interactDict  ics wi              _ -> pprPanic "interactWithInerts" (ppr wi) }                 -- CNonCanonical have been canonicalised @@ -525,11 +465,12 @@ rare and it doesn't seem worth trying to put them back together again.) -} -solveOneFromTheOther :: CtEvidence  -- Inert-                     -> CtEvidence  -- WorkItem+solveOneFromTheOther :: CtEvidence  -- Inert    (Dict or Irred)+                     -> CtEvidence  -- WorkItem (same predicate as inert)                      -> TcS InteractResult -- Precondition: -- * inert and work item represent evidence for the /same/ predicate+-- * Both are CDictCan or CIrredCan -- -- We can always solve one from the other: even if both are wanted, -- although we don't rewrite wanteds with wanteds, we can combine@@ -559,8 +500,8 @@        -- Inert is Given or Wanted   = case ev_i of       CtWanted { ctev_nosh = WOnly }-          | WDeriv <- nosh_w -> return KeepWork-      _                      -> return KeepInert+          | WDeriv <- nosh_w           -> return KeepWork+      _                                -> return KeepInert       -- Consider work  item [WD] C ty1 ty2       --          inert item [W]  C ty1 ty2       -- Then we must keep the work item.  But if the@@ -571,7 +512,7 @@   -- From here on the work-item is Given    | CtWanted { ctev_loc = loc_i } <- ev_i-  , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i+  , prohibitedSuperClassSolve loc_w loc_i   = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)        ; return KeepInert }      -- Just discard the un-usable Given                                  -- This never actually happens because@@ -722,8 +663,8 @@ -- mean that (ty1 ~ ty2) interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct) -interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_status = status })-  | InsolubleCIS <- status+interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_reason = reason })+  | isInsolubleReason reason                -- For insolubles, don't allow the constraint to be dropped                -- which can happen with solveOneFromTheOther, so that                -- we get distinct error messages with -fdefer-type-errors@@ -827,25 +768,26 @@  Assume we have started with an implication: -  forall c. Eq c => { wc_simple = D [c] c [W] }+  forall c. Eq c => { wc_simple = [W] D [c] c } -which we have simplified to:+which we have simplified to, with a Derived constraing coming from+D's functional dependency: -  forall c. Eq c => { wc_simple = D [c] c [W]-                                  (c ~ [c]) [D] }+  forall c. Eq c => { wc_simple = [W] D [c] c [W]+                                  [D] (c ~ [c]) } -For some reason, e.g. because we floated an equality somewhere else,-we might try to re-solve this implication. If we do not do a-dropDerivedWC, then we will end up trying to solve the following-constraints the second time:+When iterating the solver, we might try to re-solve this+implication. If we do not do a dropDerivedWC, then we will end up+trying to solve the following constraints the second time: -  (D [c] c) [W]-  (c ~ [c]) [D]+  [W] (D [c] c)+  [D] (c ~ [c])  which will result in two Deriveds to end up in the insoluble set: -  wc_simple   = D [c] c [W]-               (c ~ [c]) [D], (c ~ [c]) [D]+  wc_simple = [W] D [c] c+              [D] (c ~ [c])+              [D] (c ~ [c]) -}  {-@@ -955,7 +897,7 @@   instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..  And we have [W] Take 3.  That only matches one instance so we get-[W] Take (3-1).  Really we should now flatten to reduce the (3-1) to 2, and+[W] Take (3-1).  Really we should now rewrite to reduce the (3-1) to 2, and so on -- but that is reproducing yet more of the solver.  Sigh.  For now, we just give up (remember all this is just an optimisation). @@ -974,7 +916,7 @@ The following four modules produce a program whose output would change depending on whether we apply this optimization when IncoherentInstances is in effect: -#########+=========     {-# LANGUAGE MultiParamTypeClasses #-}     module A where @@ -984,8 +926,9 @@     class A a => C a b where       m :: b -> a -> a -#########-    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+=========+    {-# LANGUAGE FlexibleInstances     #-}+    {-# LANGUAGE MultiParamTypeClasses #-}     module B where      import A@@ -996,9 +939,11 @@     instance C a [b] where       m _ = id -#########-    {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}-    {-# LANGUAGE IncoherentInstances #-}+=========+    {-# LANGUAGE FlexibleContexts      #-}+    {-# LANGUAGE FlexibleInstances     #-}+    {-# LANGUAGE IncoherentInstances   #-}+    {-# LANGUAGE MultiParamTypeClasses #-}     module C where      import A@@ -1012,7 +957,7 @@     intC :: C Int a => a -> Int -> Int     intC _ x = int x -#########+=========     module Main where      import A@@ -1163,7 +1108,9 @@                         ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)                        ; loc' <- lift $ checkInstanceOK loc what pred+                       ; lift $ checkReductionDepth loc' pred +                        ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds                                   -- Emit work for subgoals but use our local cache                                   -- so we can solve recursive dictionaries.@@ -1334,113 +1281,63 @@ ********************************************************************** -} -interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)--- Try interacting the work item with the inert set-interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc-                                          , cc_tyargs = args, cc_fsk = fsk })-  | Just inert_ct@(CFunEqCan { cc_ev = ev_i-                             , cc_fsk = fsk_i })-         <- findFunEq (inert_funeqs inerts) tc args-  , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev-  = do { traceTcS "reactFunEq (rewrite inert item):" $-         vcat [ text "work_item =" <+> ppr work_item-              , text "inertItem=" <+> ppr ev_i-              , text "(swap_flag, upgrade)" <+> ppr pr ]-       ; if isSwapped swap_flag-         then do {   -- Rewrite inert using work-item-                   let work_item' | upgrade_flag = upgradeWanted work_item-                                  | otherwise    = work_item-                 ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'-                      -- Do the updInertFunEqs before the reactFunEq, so that-                      -- we don't kick out the inertItem as well as consuming it!-                 ; reactFunEq ev fsk ev_i fsk_i-                 ; stopWith ev "Work item rewrites inert" }-         else do {   -- Rewrite work-item using inert-                 ; when upgrade_flag $-                   updInertFunEqs $ \ feqs -> insertFunEq feqs tc args-                                                 (upgradeWanted inert_ct)-                 ; reactFunEq ev_i fsk_i ev fsk-                 ; stopWith ev "Inert rewrites work item" } }--  | otherwise   -- Try improvement-  = do { improveLocalFunEqs ev inerts tc args fsk-       ; continueWith work_item }--interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)--upgradeWanted :: Ct -> Ct--- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2--- so upgrade the [W] to [WD] before putting it in the inert set-upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }-  where-    upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )-                    ev { ctev_nosh = WDeriv }--improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar+improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcType                    -> TcS () -- Generate derived improvement equalities, by comparing -- the current work item with inert CFunEqs -- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y' -- -- See Note [FunDep and implicit parameter reactions]-improveLocalFunEqs work_ev inerts fam_tc args fsk-  | isGiven work_ev -- See Note [No FunEq improvement for Givens]-    || not (isImprovable work_ev)-  = return ()--  | otherwise-  = do { eqns <- improvement_eqns-       ; if not (null eqns)-         then do { traceTcS "interactFunEq improvements: " $-                   vcat [ text "Eqns:" <+> ppr eqns+-- Precondition: isImprovable work_ev+improveLocalFunEqs work_ev inerts fam_tc args rhs+  = ASSERT( isImprovable work_ev )+    unless (null improvement_eqns) $+    do { traceTcS "interactFunEq improvements: " $+                   vcat [ text "Eqns:" <+> ppr improvement_eqns                         , text "Candidates:" <+> ppr funeqs_for_tc                         , text "Inert eqs:" <+> ppr (inert_eqs inerts) ]-                 ; emitFunDepDeriveds eqns }-         else return () }-+       ; emitFunDepDeriveds improvement_eqns }   where     funeqs        = inert_funeqs inerts-    funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc+    funeqs_for_tc = [ funeq_ct | EqualCtList (funeq_ct :| _)+                                   <- findFunEqsByTyCon funeqs fam_tc+                               , NomEq == ctEqRel funeq_ct ]+                                  -- representational equalities don't interact+                                  -- with type family dependencies     work_loc      = ctEvLoc work_ev     work_pred     = ctEvPred work_ev     fam_inj_info  = tyConInjectivityInfo fam_tc      ---------------------    improvement_eqns :: TcS [FunDepEqn CtLoc]+    improvement_eqns :: [FunDepEqn CtLoc]     improvement_eqns       | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc       =    -- Try built-in families, notably for arithmethic-        do { rhs <- rewriteTyVar fsk-           ; concatMapM (do_one_built_in ops rhs) funeqs_for_tc }+        concatMap (do_one_built_in ops rhs) funeqs_for_tc        | Injective injective_args <- fam_inj_info       =    -- Try improvement from type families with injectivity annotations-        do { rhs <- rewriteTyVar fsk-           ; concatMapM (do_one_injective injective_args rhs) funeqs_for_tc }+        concatMap (do_one_injective injective_args rhs) funeqs_for_tc        | otherwise-      = return []+      = []      ---------------------    do_one_built_in ops rhs (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })-      = do { inert_rhs <- rewriteTyVar ifsk-           ; return $ mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs inert_rhs) }+    do_one_built_in ops rhs (CEqCan { cc_lhs = TyFamLHS _ iargs, cc_rhs = irhs, cc_ev = inert_ev })+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs irhs)      do_one_built_in _ _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)      --------------------     -- See Note [Type inference for type families with injectivity]-    do_one_injective inj_args rhs (CFunEqCan { cc_tyargs = inert_args-                                             , cc_fsk = ifsk, cc_ev = inert_ev })+    do_one_injective inj_args rhs (CEqCan { cc_lhs = TyFamLHS _ inert_args+                                          , cc_rhs = irhs, cc_ev = inert_ev })       | isImprovable inert_ev-      = do { inert_rhs <- rewriteTyVar ifsk-           ; return $ if rhs `tcEqType` inert_rhs-                      then mk_fd_eqns inert_ev $-                             [ Pair arg iarg-                             | (arg, iarg, True) <- zip3 args inert_args inj_args ]-                      else [] }+      , rhs `tcEqType` irhs+      = mk_fd_eqns inert_ev $ [ Pair arg iarg+                              | (arg, iarg, True) <- zip3 args inert_args inj_args ]       | otherwise-      = return []+      = []      do_one_injective _ _ _ = pprPanic "interactFunEq 2" (ppr fam_tc) @@ -1457,26 +1354,13 @@         loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`                                       ctl_depth work_loc } ---------------reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1-           -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2-           -> TcS ()-reactFunEq from_this fsk1 solve_this fsk2-  = do { traceTcS "reactFunEq"-            (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])-       ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)-       ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$-                                     ppr solve_this $$ ppr fsk2) }- {- Note [Type inference for type families with injectivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have a type family with an injectivity annotation:     type family F a b = r | r -> b -Then if we have two CFunEqCan constraints for F with the same RHS-   F s1 t1 ~ rhs-   F s2 t2 ~ rhs-then we can use the injectivity to get a new Derived constraint on+Then if we have an equality like F s1 t1 ~ F s2 t2,+we can use the injectivity to get a new Derived constraint on the injective argument   [D] t1 ~ t2 @@ -1503,9 +1387,21 @@ applications, but that would require new evidence forms, and an extension to FC, so we don't do that right now (Dec 14). -See also Note [Injective type families] in GHC.Core.TyCon+We generate these Deriveds in three places, depending on how we notice the+injectivity. +1. When we have a [W/D] F tys1 ~ F tys2. This is handled in canEqCanLHS2, and+described in Note [Decomposing equality] in GHC.Tc.Solver.Canonical. +2. When we have [W] F tys1 ~ T and [W] F tys2 ~ T. Note that neither of these+constraints rewrites the other, as they have different LHSs. This is done+in improveLocalFunEqs, called during the interactWithInertsStage.++3. When we have [W] F tys ~ T and an equation for F that looks like F tys' = T.+This is done in improve_top_fun_eqs, called from the top-level reactions stage.++See also Note [Injective type families] in GHC.Core.TyCon+ Note [Cache-caused loops] ~~~~~~~~~~~~~~~~~~~~~~~~~ It is very dangerous to cache a rewritten wanted family equation as 'solved' in our@@ -1537,110 +1433,116 @@ just an optimization so we don't lose anything in terms of completeness of solving. +**********************************************************************+*                                                                    *+                   interactEq+*                                                                    *+**********************************************************************+-} -Note [Efficient Orientation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are interacting two FunEqCans with the same LHS:-          (inert)  ci :: (F ty ~ xi_i)-          (work)   cw :: (F ty ~ xi_w)-We prefer to keep the inert (else we pass the work item on down-the pipeline, which is a bit silly).  If we keep the inert, we-will (a) discharge 'cw'-     (b) produce a new equality work-item (xi_w ~ xi_i)-Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):-    new_work :: xi_w ~ xi_i-    cw := ci ; sym new_work-Why?  Consider the simplest case when xi1 is a type variable.  If-we generate xi1~xi2, processing that constraint will kick out 'ci'.-If we generate xi2~xi1, there is less chance of that happening.-Of course it can and should still happen if xi1=a, xi1=Int, say.-But we want to avoid it happening needlessly.+{- Note [Combining equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   Inert:     g1 :: a ~ t+   Work item: g2 :: a ~ t -Similarly, if we *can't* keep the inert item (because inert is Wanted,-and work is Given, say), we prefer to orient the new equality (xi_i ~-xi_w).+Then we can simply solve g2 from g1, thus g2 := g1.  Easy!+But it's not so simple: -Note [Carefully solve the right CFunEqCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   ---- OLD COMMENT, NOW NOT NEEDED-   ---- because we now allow multiple-   ---- wanted FunEqs with the same head-Consider the constraints-  c1 :: F Int ~ a      -- Arising from an application line 5-  c2 :: F Int ~ Bool   -- Arising from an application line 10-Suppose that 'a' is a unification variable, arising only from-flattening.  So there is no error on line 5; it's just a flattening-variable.  But there is (or might be) an error on line 10.+* If t is a type variable, the equalties might be oriented differently:+      e.g. (g1 :: a~b) and (g2 :: b~a)+  So we look both ways round.  Hence the SwapFlag result to+  inertsCanDischarge. -Two ways to combine them, leaving either (Plan A)-  c1 :: F Int ~ a      -- Arising from an application line 5-  c3 :: a ~ Bool       -- Arising from an application line 10-or (Plan B)-  c2 :: F Int ~ Bool   -- Arising from an application line 10-  c4 :: a ~ Bool       -- Arising from an application line 5+* We can only do g2 := g1 if g1 can discharge g2; that depends on+  (a) the role and (b) the flavour.  E.g. a representational equality+  cannot discharge a nominal one; a Wanted cannot discharge a Given.+  The predicate is eqCanDischargeFR. -Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error-on the *totally innocent* line 5.  An example is test SimpleFail16-where the expected/actual message comes out backwards if we use-the wrong plan.+* If the inert is [W] and the work-item is [WD] we don't want to+  forget the [D] part; hence the Bool result of inertsCanDischarge. -The second is the right thing to do.  Hence the isMetaTyVarTy-test when solving pairwise CFunEqCan.+* Visibility. Suppose  S :: forall k. k -> Type, and consider unifying+      S @Type (a::Type)  ~   S @(Type->Type) (b::Type->Type)+  From the first argument we get (Type ~ Type->Type); from the second+  argument we get (a ~ b) which in turn gives (Type ~ Type->Type).+  See typecheck/should_fail/T16204c. +  That first argument is invisible in the source program (aside from+  visible type application), so we'd much prefer to get the error from+  the second. We track visiblity in the uo_visible field of a TypeEqOrigin.+  We use this to prioritise visible errors (see GHC.Tc.Errors.tryReporters,+  the partition on isVisibleOrigin). -**********************************************************************-*                                                                    *-                   interactTyVarEq-*                                                                    *-**********************************************************************+  So when combining two otherwise-identical equalites, we want to+  keep the visible one, and discharge the invisible one.  Hence the+  call to strictly_more_visible. -} -inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole+inertsCanDischarge :: InertCans -> Ct                    -> Maybe ( CtEvidence  -- The evidence for the inert                             , SwapFlag    -- Whether we need mkSymCo                             , Bool)       -- True <=> keep a [D] version                                           --          of the [WD] constraint-inertsCanDischarge inerts tv rhs fr-  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i-                                    , cc_eq_rel = eq_rel }-                             <- findTyEqs inerts tv-                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr-                         , rhs_i `tcEqType` rhs ]+inertsCanDischarge inerts (CEqCan { cc_lhs = lhs_w, cc_rhs = rhs_w+                                  , cc_ev = ev_w, cc_eq_rel = eq_rel })+  | (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i+                                  , cc_eq_rel = eq_rel }+                             <- findEq inerts lhs_w+                         , rhs_i `tcEqType` rhs_w+                         , inert_beats_wanted ev_i eq_rel ]   =  -- Inert:     a ~ ty      -- Work item: a ~ ty     Just (ev_i, NotSwapped, keep_deriv ev_i) -  | Just tv_rhs <- getTyVar_maybe rhs-  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i-                                    , cc_eq_rel = eq_rel }-                             <- findTyEqs inerts tv_rhs-                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr-                         , rhs_i `tcEqType` mkTyVarTy tv ]+  | Just rhs_lhs <- canEqLHS_maybe rhs_w+  , (ev_i : _) <- [ ev_i | CEqCan { cc_ev = ev_i, cc_rhs = rhs_i+                                  , cc_eq_rel = eq_rel }+                             <- findEq inerts rhs_lhs+                         , rhs_i `tcEqType` canEqLHSType lhs_w+                         , inert_beats_wanted ev_i eq_rel ]   =  -- Inert:     a ~ b      -- Work item: b ~ a      Just (ev_i, IsSwapped, keep_deriv ev_i) -  | otherwise-  = Nothing-   where+    loc_w  = ctEvLoc ev_w+    flav_w = ctEvFlavour ev_w+    fr_w   = (flav_w, eq_rel)++    inert_beats_wanted ev_i eq_rel+      = -- eqCanDischargeFR:    see second bullet of Note [Combining equalities]+        -- strictly_more_visible: see last bullet of Note [Combining equalities]+        fr_i`eqCanDischargeFR` fr_w+        && not ((loc_w `strictly_more_visible` ctEvLoc ev_i)+                 && (fr_w `eqCanDischargeFR` fr_i))+      where+        fr_i = (ctEvFlavour ev_i, eq_rel)++    -- See Note [Combining equalities], third bullet     keep_deriv ev_i       | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]-      , (Wanted WDeriv, _) <- fr           -- work item is [WD]+      , Wanted WDeriv <- flav_w            -- work item is [WD]       = True   -- Keep a derived version of the work item       | otherwise       = False  -- Work item is fully discharged -interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)--- CTyEqCans are always consumed, so always returns Stop-interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv-                                          , cc_rhs = rhs-                                          , cc_ev = ev-                                          , cc_eq_rel = eq_rel })-  | Just (ev_i, swapped, keep_deriv)-       <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)+    -- See Note [Combining equalities], final bullet+    strictly_more_visible loc1 loc2+       = not (isVisibleOrigin (ctLocOrigin loc2)) &&+         isVisibleOrigin (ctLocOrigin loc1)++inertsCanDischarge _ _ = Nothing+++interactEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)+interactEq inerts workItem@(CEqCan { cc_lhs = lhs+                                   , cc_rhs = rhs+                                   , cc_ev = ev+                                   , cc_eq_rel = eq_rel })+  | Just (ev_i, swapped, keep_deriv) <- inertsCanDischarge inerts workItem   = do { setEvBindIfWanted ev $-         evCoercion (maybeSym swapped $+         evCoercion (maybeTcSymCo swapped $                      tcDowngradeRole (eqRelRole eq_rel)                                      (ctEvRole ev_i)                                      (ctEvCoercion ev_i))@@ -1658,21 +1560,43 @@   = do { traceTcS "Not unifying representational equality" (ppr workItem)        ; continueWith workItem } -  | isGiven ev         -- See Note [Touchables and givens]-  = continueWith workItem-   | otherwise-  = do { tclvl <- getTcLevel-       ; if canSolveByUnification tclvl tv rhs-         then do { solveByUnification ev tv rhs-                 ; n_kicked <- kickOutAfterUnification tv-                 ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }+  = case lhs of+       TyVarLHS tv -> tryToSolveByUnification workItem ev tv rhs -         else continueWith workItem }+       TyFamLHS tc args -> do { when (isImprovable ev) $+                                 -- Try improvement, if possible+                                improveLocalFunEqs ev inerts tc args rhs+                              ; continueWith workItem } -interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)+interactEq _ wi = pprPanic "interactEq" (ppr wi) -solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()+----------------------+-- We have a meta-tyvar on the left, and metaTyVarUpateOK has said "yes"+-- So try to solve by unifying.+-- Three reasons why not:+--    Skolem escape+--    Given equalities (GADTs)+--    Unifying a TyVarTv with a non-tyvar type+tryToSolveByUnification :: Ct -> CtEvidence+                        -> TcTyVar   -- LHS tyvar+                        -> TcType    -- RHS+                        -> TcS (StopOrContinue Ct)+tryToSolveByUnification work_item ev tv rhs+  = do { is_touchable <- touchabilityTest (ctEvFlavour ev) tv rhs+       ; traceTcS "tryToSolveByUnification" (vcat [ ppr tv <+> char '~' <+> ppr rhs+                                                  , ppr is_touchable ])++       ; case is_touchable of+           Untouchable -> continueWith work_item+           -- For the latter two cases see Note [Solve by unification]+           TouchableSameLevel -> solveByUnification ev tv rhs+           TouchableOuterLevel free_metas tv_lvl+             -> do { wrapTcS $ mapM_ (promoteMetaTyVarTo tv_lvl) free_metas+                   ; setUnificationFlag tv_lvl+                   ; solveByUnification ev tv rhs } }++solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS (StopOrContinue Ct) -- Solve with the identity coercion -- Precondition: kind(xi) equals kind(tv) -- Precondition: CtEvidence is Wanted or Derived@@ -1681,7 +1605,7 @@ --        workItem = the new Given constraint -- -- NB: No need for an occurs check here, because solveByUnification always---     arises from a CTyEqCan, a *canonical* constraint.  Its invariant (TyEq:OC)+--     arises from a CEqCan, a *canonical* constraint.  Its invariant (TyEq:OC) --     says that in (a ~ xi), the type variable a does not appear in xi. --     See GHC.Tc.Types.Constraint.Ct invariants. --@@ -1694,9 +1618,10 @@                              text "Coercion:" <+> pprEq tv_ty xi,                              text "Left Kind is:" <+> ppr (tcTypeKind tv_ty),                              text "Right Kind is:" <+> ppr (tcTypeKind xi) ]-        ; unifyTyVar tv xi-       ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }+       ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi))+       ; n_kicked <- kickOutAfterUnification tv+       ; return (Stop wd (text "Solved by unification" <+> pprKicked n_kicked)) }  {- Note [Avoid double unifications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1705,7 +1630,7 @@   Original wanted:  (a ~ alpha),  (alpha ~ Int) We spontaneously solve the first wanted, without changing the order!       given : a ~ alpha      [having unified alpha := a]-Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.+Now the second wanted comes along, but it cannot rewrite the given, so we simply continue. At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]  We avoid this problem by orienting the resulting given so that the unification@@ -1730,9 +1655,37 @@ and we want to get alpha := N b.  See also #15144, which was caused by unifying a representational-equality (in the unflattener).+equality. +Note [Solve by unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we solve+   alpha[n] ~ ty+by unification, there are two cases to consider +* TouchableSameLevel: if the ambient level is 'n', then+  we can simply update alpha := ty, and do nothing else++* TouchableOuterLevel free_metas n: if the ambient level is greater than+  'n' (the level of alpha), in addition to setting alpha := ty we must+  do two other things:++  1. Promote all the free meta-vars of 'ty' to level n.  After all,+     alpha[n] is at level n, and so if we set, say,+          alpha[n] := Maybe beta[m],+     we must ensure that when unifying beta we do skolem-escape checks+     etc relevant to level n.  Simple way to do that: promote beta to+     level n.++  2. Set the Unification Level Flag to record that a level-n unification has+     taken place. See Note [The Unification Level Flag] in GHC.Tc.Solver.Monad++NB: TouchableSameLevel is just an optimisation for TouchableOuterLevel. Promotion+would be a no-op, and setting the unification flag unnecessarily would just+make the solver iterate more often.  (We don't need to iterate when unifying+at the ambient level because of the kick-out mechanism.)++ ************************************************************************ *                                                                      * *          Functional dependencies, instantiation of equations@@ -1858,9 +1811,8 @@        ; case work_item of            CDictCan {}  -> do { inerts <- getTcSInerts                               ; doTopReactDict inerts work_item }-           CFunEqCan {} -> doTopReactFunEq work_item+           CEqCan {}    -> doTopReactEq    work_item            CIrredCan {} -> doTopReactOther work_item-           CTyEqCan {}  -> doTopReactOther work_item            _  -> -- Any other work item does not react with any top-level equations                  continueWith work_item  } @@ -1868,7 +1820,7 @@ -------------------- doTopReactOther :: Ct -> TcS (StopOrContinue Ct) -- Try local quantified constraints for---     CTyEqCan  e.g.  (a ~# ty)+--     CEqCan    e.g.  (lhs ~# ty) -- and CIrredCan e.g.  (c a) -- -- Why equalities? See GHC.Tc.Solver.Canonical@@ -1925,126 +1877,24 @@  * Note [Evidence for quantified constraints] in GHC.Core.Predicate  * Note [Equality superclasses in quantified constraints]    in GHC.Tc.Solver.Canonical--Note [Flatten when discharging CFunEqCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have the following scenario (#16512):--type family LV (as :: [Type]) (b :: Type) = (r :: Type) | r -> as b where-  LV (a ': as) b = a -> LV as b--[WD] w1 :: LV as0 (a -> b) ~ fmv1 (CFunEqCan)-[WD] w2 :: fmv1 ~ (a -> fmv2) (CTyEqCan)-[WD] w3 :: LV as0 b ~ fmv2 (CFunEqCan)--We start with w1. Because LV is injective, we wish to see if the RHS of the-equation matches the RHS of the CFunEqCan. The RHS of a CFunEqCan is always an-fmv, so we "look through" to get (a -> fmv2). Then we run tcUnifyTyWithTFs.-That performs the match, but it allows a type family application (such as the-LV in the RHS of the equation) to match with anything. (See "Injective type-families" by Stolarek et al., HS'15, Fig. 2) The matching succeeds, which-means we can improve as0 (and b, but that's not interesting here). However,-because the RHS of w1 can't see through fmv2 (we have no way of looking up a-LHS of a CFunEqCan from its RHS, and this use case isn't compelling enough),-we invent a new unification variable here. We thus get (as0 := a : as1).-Rewriting:--[WD] w1 :: LV (a : as1) (a -> b) ~ fmv1-[WD] w2 :: fmv1 ~ (a -> fmv2)-[WD] w3 :: LV (a : as1) b ~ fmv2--We can now reduce both CFunEqCans, using the equation for LV. We get--[WD] w2 :: (a -> LV as1 (a -> b)) ~ (a -> a -> LV as1 b)--Now we decompose (and flatten) to--[WD] w4 :: LV as1 (a -> b) ~ fmv3-[WD] w5 :: fmv3 ~ (a -> fmv1)-[WD] w6 :: LV as1 b ~ fmv4--which is exactly where we started. These goals really are insoluble, but-we would prefer not to loop. We thus need to find a way to bump the reduction-depth, so that we can detect the loop and abort.--The key observation is that we are performing a reduction. We thus wish-to bump the level when discharging a CFunEqCan. Where does this bumped-level go, though? It can't just go on the reduct, as that's a type. Instead,-it must go on any CFunEqCans produced after flattening. We thus flatten-when discharging, making sure that the level is bumped in the new-fun-eqs. The flattening happens in reduce_top_fun_eq and the level-is bumped when setting up the FlatM monad in GHC.Tc.Solver.Flatten.runFlatten.-(This bumping will happen for call sites other than this one, but that-makes sense -- any constraints emitted by the flattener are offshoots-the work item and should have a higher level. We don't have any test-cases that require the bumping in this other cases, but it's convenient-and causes no harm to bump at every flatten.)--Test case: typecheck/should_fail/T16512a- -}  ---------------------doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)-doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc-                                     , cc_tyargs = args, cc_fsk = fsk })--  | fsk `elemVarSet` tyCoVarsOfTypes args-  = no_reduction    -- See Note [FunEq occurs-check principle]--  | otherwise  -- Note [Reduction for Derived CFunEqCans]-  = do { match_res <- matchFam fam_tc args-                           -- Look up in top-level instances, or built-in axiom-                           -- See Note [MATCHING-SYNONYMS]-       ; case match_res of-           Nothing         -> no_reduction-           Just match_info -> reduce_top_fun_eq old_ev fsk match_info }-  where-    no_reduction-      = do { improveTopFunEqs old_ev fam_tc args fsk-           ; continueWith work_item }--doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)--reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)-                  -> TcS (StopOrContinue Ct)--- We have found an applicable top-level axiom: use it to reduce--- Precondition: fsk is not free in rhs_ty--- ax_co :: F tys ~ rhs_ty, where F tys is the LHS of the old_ev-reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)-  | not (isDerived old_ev)  -- Precondition of shortCutReduction-  , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty-  , isTypeFamilyTyCon tc-  , tc_args `lengthIs` tyConArity tc    -- Short-cut-  = -- RHS is another type-family application-    -- Try shortcut; see Note [Top-level reductions for type functions]-    do { shortCutReduction old_ev fsk ax_co tc tc_args-       ; stopWith old_ev "Fun/Top (shortcut)" }--  | otherwise-  = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)-           , ppr old_ev $$ ppr rhs_ty )-           -- Guaranteed by Note [FunEq occurs-check principle]-    do { (rhs_xi, flatten_co) <- flatten FM_FlattenAll old_ev rhs_ty-             -- flatten_co :: rhs_xi ~ rhs_ty-             -- See Note [Flatten when discharging CFunEqCan]-       ; let total_co = ax_co `mkTcTransCo` mkTcSymCo flatten_co-       ; dischargeFunEq old_ev fsk total_co rhs_xi-       ; traceTcS "doTopReactFunEq" $-         vcat [ text "old_ev:" <+> ppr old_ev-              , nest 2 (text ":=") <+> ppr ax_co ]-       ; stopWith old_ev "Fun/Top" }+doTopReactEq :: Ct -> TcS (StopOrContinue Ct)+doTopReactEq work_item@(CEqCan { cc_ev = old_ev, cc_lhs = TyFamLHS fam_tc args+                               , cc_rhs = rhs })+  = do { improveTopFunEqs old_ev fam_tc args rhs+       ; doTopReactOther work_item }+doTopReactEq work_item = doTopReactOther work_item -improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()+improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcType -> TcS () -- See Note [FunDep and implicit parameter reactions]-improveTopFunEqs ev fam_tc args fsk-  | isGiven ev            -- See Note [No FunEq improvement for Givens]-    || not (isImprovable ev)+improveTopFunEqs ev fam_tc args rhs+  | not (isImprovable ev)   = return ()    | otherwise   = do { fam_envs <- getFamInstEnvs-       ; rhs <- rewriteTyVar fsk        ; eqns <- improve_top_fun_eqs fam_envs fam_tc args rhs        ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr rhs                                           , ppr eqns ])@@ -2126,127 +1976,7 @@                           _          -> True                       , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] } --shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion-                  -> TyCon -> [TcType] -> TcS ()--- See Note [Top-level reductions for type functions]--- Previously, we flattened the tc_args here, but there's no need to do so.--- And, if we did, this function would have all the complication of--- GHC.Tc.Solver.Canonical.canCFunEqCan. See Note [canCFunEqCan]-shortCutReduction old_ev fsk ax_co fam_tc tc_args-  = ASSERT( ctEvEqRel old_ev == NomEq)-               -- ax_co :: F args ~ G tc_args-               -- old_ev :: F args ~ fsk-    do { new_ev <- case ctEvFlavour old_ev of-           Given -> newGivenEvVar deeper_loc-                         ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)-                         , evCoercion (mkTcSymCo ax_co-                                       `mkTcTransCo` ctEvCoercion old_ev) )--           Wanted {} ->-             -- See TcCanonical Note [Equalities with incompatible kinds] about NoBlockSubst-             do { (new_ev, new_co) <- newWantedEq_SI NoBlockSubst WDeriv deeper_loc Nominal-                                        (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)-                ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co-                ; return new_ev }--           Derived -> pprPanic "shortCutReduction" (ppr old_ev)--       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc-                                , cc_tyargs = tc_args, cc_fsk = fsk }-       ; updWorkListTcS (extendWorkListFunEq new_ct) }-  where-    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)--{- Note [Top-level reductions for type functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-c.f. Note [The flattening story] in GHC.Tc.Solver.Flatten--Suppose we have a CFunEqCan  F tys ~ fmv/fsk, and a matching axiom.-Here is what we do, in four cases:--* Wanteds: general firing rule-    (work item) [W]        x : F tys ~ fmv-    instantiate axiom: ax_co : F tys ~ rhs--   Then:-      Discharge   fmv := rhs-      Discharge   x := ax_co ; sym x2-   This is *the* way that fmv's get unified; even though they are-   "untouchable".--   NB: Given Note [FunEq occurs-check principle], fmv does not appear-   in tys, and hence does not appear in the instantiated RHS.  So-   the unification can't make an infinite type.--* Wanteds: short cut firing rule-  Applies when the RHS of the axiom is another type-function application-      (work item)        [W] x : F tys ~ fmv-      instantiate axiom: ax_co : F tys ~ G rhs_tys--  It would be a waste to create yet another fmv for (G rhs_tys).-  Instead (shortCutReduction):-      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)-      - Add G rhs_xis ~ fmv to flat cache  (note: the same old fmv)-      - New canonical wanted   [W] x2 : G rhs_xis ~ fmv  (CFunEqCan)-      - Discharge x := ax_co ; G cos ; x2--* Givens: general firing rule-      (work item)        [G] g : F tys ~ fsk-      instantiate axiom: ax_co : F tys ~ rhs--   Now add non-canonical given (since rhs is not flat)-      [G] (sym g ; ax_co) : fsk ~ rhs  (Non-canonical)--* Givens: short cut firing rule-  Applies when the RHS of the axiom is another type-function application-      (work item)        [G] g : F tys ~ fsk-      instantiate axiom: ax_co : F tys ~ G rhs_tys--  It would be a waste to create yet another fsk for (G rhs_tys).-  Instead (shortCutReduction):-     - Flatten rhs_tys: flat_cos : tys ~ flat_tys-     - Add new Canonical given-          [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk   (CFunEqCan)--Note [FunEq occurs-check principle]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-I have spent a lot of time finding a good way to deal with-CFunEqCan constraints like-    F (fuv, a) ~ fuv-where flatten-skolem occurs on the LHS.  Now in principle we-might may progress by doing a reduction, but in practice its-hard to find examples where it is useful, and easy to find examples-where we fall into an infinite reduction loop.  A rule that works-very well is this:--  *** FunEq occurs-check principle ***--      Do not reduce a CFunEqCan-          F tys ~ fsk-      if fsk appears free in tys-      Instead we treat it as stuck.--Examples:--* #5837 has [G] a ~ TF (a,Int), with an instance-    type instance TF (a,b) = (TF a, TF b)-  This readily loops when solving givens.  But with the FunEq occurs-  check principle, it rapidly gets stuck which is fine.--* #12444 is a good example, explained in comment:2.  We have-    type instance F (Succ x) = Succ (F x)-    [W] alpha ~ Succ (F alpha)-  If we allow the reduction to happen, we get an infinite loop--Note [Cached solved FunEqs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-When trying to solve, say (FunExpensive big-type ~ ty), it's important-to see if we have reduced (FunExpensive big-type) before, lest we-simply repeat it.  Hence the lookup in inert_solved_funeqs.  Moreover-we must use `funEqCanDischarge` because both uses might (say) be Wanteds,-and we *still* want to save the re-computation.-+{- Note [MATCHING-SYNONYMS] ~~~~~~~~~~~~~~~~~~~~~~~~ When trying to match a dictionary (D tau) to a top-level instance, or a@@ -2290,68 +2020,6 @@ handle it.  Instead we are careful to orient the new derived equality with the template on the left.  Delicate, but it works. -Note [No FunEq improvement for Givens]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't do improvements (injectivity etc) for Givens. Why?--* It generates Derived constraints on skolems, which don't do us-  much good, except perhaps identify inaccessible branches.-  (They'd be perfectly valid though.)--* For type-nat stuff the derived constraints include type families;-  e.g.  (a < b), (b < c) ==> a < c If we generate a Derived for this,-  we'll generate a Derived/Wanted CFunEqCan; and, since the same-  InertCans (after solving Givens) are used for each iteration, that-  massively confused the unflattening step (GHC.Tc.Solver.Flatten.unflatten).--  In fact it led to some infinite loops:-     indexed-types/should_compile/T10806-     indexed-types/should_compile/T10507-     polykinds/T10742--Note [Reduction for Derived CFunEqCans]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You may wonder if it's important to use top-level instances to-simplify [D] CFunEqCan's.  But it is.  Here's an example (T10226).--   type instance F    Int = Int-   type instance FInv Int = Int--Suppose we have to solve-    [WD] FInv (F alpha) ~ alpha-    [WD] F alpha ~ Int--  --> flatten-    [WD] F alpha ~ fuv0-    [WD] FInv fuv0 ~ fuv1  -- (A)-    [WD] fuv1 ~ alpha-    [WD] fuv0 ~ Int        -- (B)--  --> Rewwrite (A) with (B), splitting it-    [WD] F alpha ~ fuv0-    [W] FInv fuv0 ~ fuv1-    [D] FInv Int ~ fuv1    -- (C)-    [WD] fuv1 ~ alpha-    [WD] fuv0 ~ Int--  --> Reduce (C) with top-level instance-      **** This is the key step ***-    [WD] F alpha ~ fuv0-    [W] FInv fuv0 ~ fuv1-    [D] fuv1 ~ Int        -- (D)-    [WD] fuv1 ~ alpha     -- (E)-    [WD] fuv0 ~ Int--  --> Rewrite (D) with (E)-    [WD] F alpha ~ fuv0-    [W] FInv fuv0 ~ fuv1-    [D] alpha ~ Int       -- (F)-    [WD] fuv1 ~ alpha-    [WD] fuv0 ~ Int--  --> unify (F)  alpha := Int, and that solves it--Another example is indexed-types/should_compile/T10634 -}  {- *******************************************************************@@ -2415,47 +2083,48 @@                         , cir_mk_ev     = mk_ev })   = do { traceTcS "doTopReact/found instance for" $ ppr ev        ; deeper_loc <- checkInstanceOK loc what pred-       ; if isDerived ev then finish_derived deeper_loc theta-                         else finish_wanted  deeper_loc theta mk_ev }+       ; if isDerived ev+         then -- Use type-class instances for Deriveds, in the hope+              -- of generating some improvements+              -- C.f. Example 3 of Note [The improvement story]+              -- It's easy because no evidence is involved+           do { dflags <- getDynFlags+              ; unless (subGoalDepthExceeded dflags (ctLocDepth deeper_loc)) $+                emitNewDeriveds deeper_loc theta+                  -- If we have a runaway Derived, let's not issue a+                  -- "reduction stack overflow" error, which is not particularly+                  -- friendly. Instead, just drop the Derived.+              ; traceTcS "finish_derived" (ppr (ctl_depth deeper_loc))+              ; stopWith ev "Dict/Top (solved derived)" }++         else -- wanted+           do { checkReductionDepth deeper_loc pred+              ; evb <- getTcEvBindsVar+              ; if isCoEvBindsVar evb+                then continueWith work_item+                  -- See Note [Instances in no-evidence implications]++                else+           do { evc_vars <- mapM (newWanted deeper_loc) theta+              ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))+              ; emitWorkNC (freshGoals evc_vars)+              ; stopWith ev "Dict/Top (solved wanted)" }}}   where      ev         = ctEvidence work_item      pred       = ctEvPred ev      loc        = ctEvLoc ev -     finish_wanted :: CtLoc -> [TcPredType]-                   -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)-      -- Precondition: evidence term matches the predicate workItem-     finish_wanted loc theta mk_ev-        = do { evb <- getTcEvBindsVar-             ; if isCoEvBindsVar evb-               then -- See Note [Instances in no-evidence implications]-                    continueWith work_item-               else-          do { evc_vars <- mapM (newWanted loc) theta-             ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))-             ; emitWorkNC (freshGoals evc_vars)-             ; stopWith ev "Dict/Top (solved wanted)" } }--     finish_derived loc theta-       = -- Use type-class instances for Deriveds, in the hope-         -- of generating some improvements-         -- C.f. Example 3 of Note [The improvement story]-         -- It's easy because no evidence is involved-         do { emitNewDeriveds loc theta-            ; traceTcS "finish_derived" (ppr (ctl_depth loc))-            ; stopWith ev "Dict/Top (solved derived)" }- chooseInstance work_item lookup_res   = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)  checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc -- Check that it's OK to use this insstance: --    (a) the use is well staged in the Template Haskell sense---    (b) we have not recursed too deep -- Returns the CtLoc to used for sub-goals+-- Probably also want to call checkReductionDepth, but this function+-- does not do so to enable special handling for Deriveds in chooseInstance checkInstanceOK loc what pred   = do { checkWellStagedDFun loc what pred-       ; checkReductionDepth deeper_loc pred        ; return deeper_loc }   where      deeper_loc = zap_origin (bumpCtLocDepth loc)@@ -2496,7 +2165,7 @@ -- First check whether there is an in-scope Given that could -- match this constraint.  In that case, do not use any instance -- whether top level, or local quantified constraints.--- ee Note [Instance and Given overlap]+-- See Note [Instance and Given overlap]   | not (xopt LangExt.IncoherentInstances dflags)   , not (naturallyCoherentClass clas)   , let matchable_givens = matchableGivens loc pred inerts@@ -2569,7 +2238,7 @@ The end effect is that, much as we do for overlapping instances, we delay choosing a class instance if there is a possibility of another instance OR a given to match our constraint later on. This fixes-#4981 and #5002.+tickets #4981 and #5002.  Other notes: @@ -2579,12 +2248,7 @@      - natural numbers      - Typeable -* Flatten-skolems: we do not treat a flatten-skolem as unifiable-  for this purpose.-  E.g.   f :: Eq (F a) => [a] -> [a]-         f xs = ....(xs==xs).....-  Here we get [W] Eq [a], and we don't want to refrain from solving-  it because of the given (Eq (F a)) constraint!+* See also Note [What might equal later?] in GHC.Tc.Solver.Monad.  * The given-overlap problem is arguably not easy to appear in practice   due to our aggressive prioritization of equality solving over other@@ -2643,7 +2307,7 @@  The same reasoning applies to -* (~~)        heqTyCOn+* (~~)        heqTyCon * (~)         eqTyCon * Coercible   coercibleTyCon @@ -2696,8 +2360,8 @@ -- Look up the predicate in Given quantified constraints, -- which are effectively just local instance declarations. matchLocalInst pred loc-  = do { ics <- getInertCans-       ; case match_local_inst (inert_insts ics) of+  = do { inerts@(IS { inert_cans = ics }) <- getTcSInerts+       ; case match_local_inst inerts (inert_insts ics) of            ([], False) -> do { traceTcS "No local instance for" (ppr pred)                              ; return NoInstance }            ([(dfun_ev, inst_tys)], unifs)@@ -2714,14 +2378,15 @@   where     pred_tv_set = tyCoVarsOfType pred -    match_local_inst :: [QCInst]+    match_local_inst :: InertSet+                     -> [QCInst]                      -> ( [(CtEvidence, [DFunInstType])]                         , Bool )      -- True <=> Some unify but do not match-    match_local_inst []+    match_local_inst _inerts []       = ([], False)-    match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred+    match_local_inst inerts (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred                                , qci_ev = ev })-                     : qcis)+                             : qcis)       | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)       , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)                                         emptyTvSubstEnv qpred pred@@ -2736,5 +2401,5 @@         (matches, unif || this_unif)       where         qtv_set = mkVarSet qtvs-        this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc-        (matches, unif) = match_local_inst qcis+        this_unif = mightEqualLater inerts qpred (ctEvLoc ev) pred loc+        (matches, unif) = match_local_inst inerts qcis

GHC/Tc/Solver/Monad.hs view

@@ -1,3665 +1,4228 @@-{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Type definitions for the constraint solver-module GHC.Tc.Solver.Monad (--    -- The work list-    WorkList(..), isEmptyWorkList, emptyWorkList,-    extendWorkListNonEq, extendWorkListCt,-    extendWorkListCts, extendWorkListEq, extendWorkListFunEq,-    appendWorkList,-    selectNextWorkItem,-    workListSize, workListWantedCount,-    getWorkList, updWorkListTcS, pushLevelNoWorkList,--    -- The TcS monad-    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,-    failTcS, warnTcS, addErrTcS,-    runTcSEqualities,-    nestTcS, nestImplicTcS, setEvBindsTcS,-    emitImplicationTcS, emitTvImplicationTcS,--    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,-    matchGlobalInst, TcM.ClsInstResult(..),--    QCInst(..),--    -- Tracing etc-    panicTcS, traceTcS,-    traceFireTcS, bumpStepCountTcS, csTraceTcS,-    wrapErrTcS, wrapWarnTcS,--    -- Evidence creation and transformation-    MaybeNew(..), freshGoals, isFresh, getEvExpr,--    newTcEvBinds, newNoTcEvBinds,-    newWantedEq, newWantedEq_SI, emitNewWantedEq,-    newWanted, newWanted_SI, newWantedEvVar,-    newWantedNC, newWantedEvVarNC,-    newDerivedNC,-    newBoundEvVarId,-    unifyTyVar, unflattenFmv, reportUnifications,-    setEvBind, setWantedEq,-    setWantedEvTerm, setEvBindIfWanted,-    newEvVar, newGivenEvVar, newGivenEvVars,-    emitNewDeriveds, emitNewDerivedEq,-    checkReductionDepth,-    getSolvedDicts, setSolvedDicts,--    getInstEnvs, getFamInstEnvs,                -- Getting the environments-    getTopEnv, getGblEnv, getLclEnv,-    getTcEvBindsVar, getTcLevel,-    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,-    tcLookupClass, tcLookupId,--    -- Inerts-    InertSet(..), InertCans(..),-    updInertTcS, updInertCans, updInertDicts, updInertIrreds,-    getNoGivenEqs, setInertCans,-    getInertEqs, getInertCans, getInertGivens,-    getInertInsols,-    getTcSInerts, setTcSInerts,-    matchableGivens, prohibitedSuperClassSolve, mightMatchLater,-    getUnsolvedInerts,-    removeInertCts, getPendingGivenScs,-    addInertCan, insertFunEq, addInertForAll,-    emitWorkNC, emitWork,-    isImprovable,--    -- The Model-    kickOutAfterUnification,--    -- Inert Safe Haskell safe-overlap failures-    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,-    getSafeOverlapFailures,--    -- Inert CDictCans-    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,-    addDictsByClass, delDict, foldDicts, filterDicts, findDict,--    -- Inert CTyEqCans-    EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,-    lookupInertTyVar,--    -- Inert solved dictionaries-    addSolvedDict, lookupSolvedDict,--    -- Irreds-    foldIrreds,--    -- The flattening cache-    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems-    dischargeFunEq, pprKicked,--    -- Inert CFunEqCans-    updInertFunEqs, findFunEq,-    findFunEqsByTyCon,--    instDFunType,                              -- Instantiation--    -- MetaTyVars-    newFlexiTcSTy, instFlexi, instFlexiX,-    cloneMetaTyVar, demoteUnfilledFmv,-    tcInstSkolTyVarsX,--    TcLevel,-    isFilledMetaTyVar_maybe, isFilledMetaTyVar,-    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,-    zonkTyCoVarsAndFVList,-    zonkSimples, zonkWC,-    zonkTyCoVarKind,--    -- References-    newTcRef, readTcRef, writeTcRef, updTcRef,--    -- Misc-    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,-    matchFam, matchFamTcM,-    checkWellStagedDFun,-    pprEq                                    -- Smaller utils, re-exported from TcM-                                             -- TODO (DV): these are only really used in the-                                             -- instance matcher in GHC.Tc.Solver. I am wondering-                                             -- if the whole instance matcher simply belongs-                                             -- here-) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Driver.Types--import qualified GHC.Tc.Utils.Instantiate as TcM-import GHC.Core.InstEnv-import GHC.Tc.Instance.Family as FamInst-import GHC.Core.FamInstEnv--import qualified GHC.Tc.Utils.Monad    as TcM-import qualified GHC.Tc.Utils.TcMType  as TcM-import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )-import qualified GHC.Tc.Utils.Env      as TcM-       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )-import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )-import GHC.Tc.Utils.TcType-import GHC.Driver.Session-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Core.Unify--import GHC.Utils.Error-import GHC.Tc.Types.Evidence-import GHC.Core.Class-import GHC.Core.TyCon-import GHC.Tc.Errors   ( solverDepthErrorTcS )--import GHC.Types.Name-import GHC.Unit.Module ( HasModule, getModule )-import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )-import qualified GHC.Rename.Env as TcM-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Utils.Outputable-import GHC.Data.Bag as Bag-import GHC.Types.Unique.Supply-import GHC.Utils.Misc-import GHC.Tc.Types-import GHC.Tc.Types.Origin-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate--import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.DFM-import GHC.Data.Maybe--import GHC.Core.Map-import Control.Monad-import GHC.Utils.Monad-import Data.IORef-import Data.List ( partition, mapAccumL )--#if defined(DEBUG)-import GHC.Data.Graph.Directed-import GHC.Types.Unique.Set-#endif--{--************************************************************************-*                                                                      *-*                            Worklists                                *-*  Canonical and non-canonical constraints that the simplifier has to  *-*  work on. Including their simplification depths.                     *-*                                                                      *-*                                                                      *-************************************************************************--Note [WorkList priorities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A WorkList contains canonical and non-canonical items (of all flavours).-Notice that each Ct now has a simplification depth. We may-consider using this depth for prioritization as well in the future.--As a simple form of priority queue, our worklist separates out--* equalities (wl_eqs); see Note [Prioritise equalities]-* type-function equalities (wl_funeqs)-* all the rest (wl_rest)--Note [Prioritise equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very important to process equalities /first/:--* (Efficiency)  The general reason to do so is that if we process a-  class constraint first, we may end up putting it into the inert set-  and then kicking it out later.  That's extra work compared to just-  doing the equality first.--* (Avoiding fundep iteration) As #14723 showed, it's possible to-  get non-termination if we-      - Emit the Derived fundep equalities for a class constraint,-        generating some fresh unification variables.-      - That leads to some unification-      - Which kicks out the class constraint-      - Which isn't solved (because there are still some more Derived-        equalities in the work-list), but generates yet more fundeps-  Solution: prioritise derived equalities over class constraints--* (Class equalities) We need to prioritise equalities even if they-  are hidden inside a class constraint;-  see Note [Prioritise class equalities]--* (Kick-out) We want to apply this priority scheme to kicked-out-  constraints too (see the call to extendWorkListCt in kick_out_rewritable-  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become-  homo-kinded when kicked out, and hence we want to prioritise it.--* (Derived equalities) Originally we tried to postpone processing-  Derived equalities, in the hope that we might never need to deal-  with them at all; but in fact we must process Derived equalities-  eagerly, partly for the (Efficiency) reason, and more importantly-  for (Avoiding fundep iteration).--Note [Prioritise class equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prioritise equalities in the solver (see selectWorkItem). But class-constraints like (a ~ b) and (a ~~ b) are actually equalities too;-see Note [The equality types story] in GHC.Builtin.Types.Prim.--Failing to prioritise these is inefficient (more kick-outs etc).-But, worse, it can prevent us spotting a "recursive knot" among-Wanted constraints.  See comment:10 of #12734 for a worked-out-example.--So we arrange to put these particular class constraints in the wl_eqs.--  NB: since we do not currently apply the substitution to the-  inert_solved_dicts, the knot-tying still seems a bit fragile.-  But this makes it better.---}---- See Note [WorkList priorities]-data WorkList-  = WL { wl_eqs     :: [Ct]  -- CTyEqCan, CDictCan, CIrredCan-                             -- Given, Wanted, and Derived-                       -- Contains both equality constraints and their-                       -- class-level variants (a~b) and (a~~b);-                       -- See Note [Prioritise equalities]-                       -- See Note [Prioritise class equalities]--       , wl_funeqs  :: [Ct]--       , wl_rest    :: [Ct]--       , wl_implics :: Bag Implication  -- See Note [Residual implications]-    }--appendWorkList :: WorkList -> WorkList -> WorkList-appendWorkList-    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1-        , wl_implics = implics1 })-    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2-        , wl_implics = implics2 })-   = WL { wl_eqs     = eqs1     ++ eqs2-        , wl_funeqs  = funeqs1  ++ funeqs2-        , wl_rest    = rest1    ++ rest2-        , wl_implics = implics1 `unionBags`   implics2 }--workListSize :: WorkList -> Int-workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })-  = length eqs + length funeqs + length rest--workListWantedCount :: WorkList -> Int--- Count the things we need to solve--- excluding the insolubles (c.f. inert_count)-workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })-  = count isWantedCt eqs + count is_wanted rest-  where-    is_wanted ct-     | CIrredCan { cc_status = InsolubleCIS } <- ct-     = False-     | otherwise-     = isWantedCt ct--extendWorkListEq :: Ct -> WorkList -> WorkList-extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }--extendWorkListFunEq :: Ct -> WorkList -> WorkList-extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }--extendWorkListNonEq :: Ct -> WorkList -> WorkList--- Extension by non equality-extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }--extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList-extendWorkListDeriveds evs wl-  = extendWorkListCts (map mkNonCanonical evs) wl--extendWorkListImplic :: Implication -> WorkList -> WorkList-extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }--extendWorkListCt :: Ct -> WorkList -> WorkList--- Agnostic-extendWorkListCt ct wl- = case classifyPredType (ctPred ct) of-     EqPred NomEq ty1 _-       | Just tc <- tcTyConAppTyCon_maybe ty1-       , isTypeFamilyTyCon tc-       -> extendWorkListFunEq ct wl--     EqPred {}-       -> extendWorkListEq ct wl--     ClassPred cls _  -- See Note [Prioritise class equalities]-       |  isEqPredClass cls-       -> extendWorkListEq ct wl--     _ -> extendWorkListNonEq ct wl--extendWorkListCts :: [Ct] -> WorkList -> WorkList--- Agnostic-extendWorkListCts cts wl = foldr extendWorkListCt wl cts--isEmptyWorkList :: WorkList -> Bool-isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs-                    , wl_rest = rest, wl_implics = implics })-  = null eqs && null rest && null funeqs && isEmptyBag implics--emptyWorkList :: WorkList-emptyWorkList = WL { wl_eqs  = [], wl_rest = []-                   , wl_funeqs = [], wl_implics = emptyBag }--selectWorkItem :: WorkList -> Maybe (Ct, WorkList)--- See Note [Prioritise equalities]-selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs-                      , wl_rest = rest })-  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })-  | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })-  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })-  | otherwise      = Nothing--getWorkList :: TcS WorkList-getWorkList = do { wl_var <- getTcSWorkListRef-                 ; wrapTcS (TcM.readTcRef wl_var) }--selectNextWorkItem :: TcS (Maybe Ct)--- Pick which work item to do next--- See Note [Prioritise equalities]-selectNextWorkItem-  = do { wl_var <- getTcSWorkListRef-       ; wl <- readTcRef wl_var-       ; case selectWorkItem wl of {-           Nothing -> return Nothing ;-           Just (ct, new_wl) ->-    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)-         -- This is done by GHC.Tc.Solver.Interact.chooseInstance-       ; writeTcRef wl_var new_wl-       ; return (Just ct) } } }---- Pretty printing-instance Outputable WorkList where-  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs-          , wl_rest = rest, wl_implics = implics })-   = text "WL" <+> (braces $-     vcat [ ppUnless (null eqs) $-            text "Eqs =" <+> vcat (map ppr eqs)-          , ppUnless (null feqs) $-            text "Funeqs =" <+> vcat (map ppr feqs)-          , ppUnless (null rest) $-            text "Non-eqs =" <+> vcat (map ppr rest)-          , ppUnless (isEmptyBag implics) $-            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))-                       (text "(Implics omitted)")-          ])---{- *********************************************************************-*                                                                      *-                InertSet: the inert set-*                                                                      *-*                                                                      *-********************************************************************* -}--data InertSet-  = IS { inert_cans :: InertCans-              -- Canonical Given, Wanted, Derived-              -- Sometimes called "the inert set"--       , inert_fsks :: [(TcTyVar, TcType)]-              -- A list of (fsk, ty) pairs; we add one element when we flatten-              -- a function application in a Given constraint, creating-              -- a new fsk in newFlattenSkolem.  When leaving a nested scope,-              -- unflattenGivens unifies fsk := ty-              ---              -- We could also get this info from inert_funeqs, filtered by-              -- level, but it seems simpler and more direct to capture the-              -- fsk as we generate them.--       , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)-              -- See Note [Type family equations]-              -- If    F tys :-> (co, rhs, flav),-              -- then  co :: F tys ~ rhs-              --       flav is [G] or [WD]-              ---              -- Just a hash-cons cache for use when flattening only-              -- These include entirely un-processed goals, so don't use-              -- them to solve a top-level goal, else you may end up solving-              -- (w:F ty ~ a) by setting w:=w!  We just use the flat-cache-              -- when allocating a new flatten-skolem.-              -- Not necessarily inert wrt top-level equations (or inert_cans)--              -- NB: An ExactFunEqMap -- this doesn't match via loose types!--       , inert_solved_dicts   :: DictMap CtEvidence-              -- All Wanteds, of form ev :: C t1 .. tn-              -- See Note [Solved dictionaries]-              -- and Note [Do not add superclasses of solved dictionaries]-       }--instance Outputable InertSet where-  ppr (IS { inert_cans = ics-          , inert_fsks = ifsks-          , inert_solved_dicts = solved_dicts })-      = vcat [ ppr ics-             , text "Inert fsks =" <+> ppr ifsks-             , ppUnless (null dicts) $-               text "Solved dicts =" <+> vcat (map ppr dicts) ]-         where-           dicts = bagToList (dictsToBag solved_dicts)--emptyInertCans :: InertCans-emptyInertCans-  = IC { inert_count    = 0-       , inert_eqs      = emptyDVarEnv-       , inert_dicts    = emptyDicts-       , inert_safehask = emptyDicts-       , inert_funeqs   = emptyFunEqs-       , inert_insts    = []-       , inert_irreds   = emptyCts }--emptyInert :: InertSet-emptyInert-  = IS { inert_cans         = emptyInertCans-       , inert_fsks         = []-       , inert_flat_cache   = emptyExactFunEqs-       , inert_solved_dicts = emptyDictMap }---{- Note [Solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we apply a top-level instance declaration, we add the "solved"-dictionary to the inert_solved_dicts.  In general, we use it to avoid-creating a new EvVar when we have a new goal that we have solved in-the past.--But in particular, we can use it to create *recursive* dictionaries.-The simplest, degenerate case is-    instance C [a] => C [a] where ...-If we have-    [W] d1 :: C [x]-then we can apply the instance to get-    d1 = $dfCList d-    [W] d2 :: C [x]-Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.-    d1 = $dfCList d-    d2 = d1--See Note [Example of recursive dictionaries]--VERY IMPORTANT INVARIANT:-- (Solved Dictionary Invariant)-    Every member of the inert_solved_dicts is the result-    of applying an instance declaration that "takes a step"--    An instance "takes a step" if it has the form-        dfunDList d1 d2 = MkD (...) (...) (...)-    That is, the dfun is lazy in its arguments, and guarantees to-    immediately return a dictionary constructor.  NB: all dictionary-    data constructors are lazy in their arguments.--    This property is crucial to ensure that all dictionaries are-    non-bottom, which in turn ensures that the whole "recursive-    dictionary" idea works at all, even if we get something like-        rec { d = dfunDList d dx }-    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.-- Reason:-   - All instances, except two exceptions listed below, "take a step"-     in the above sense--   - Exception 1: local quantified constraints have no such guarantee;-     indeed, adding a "solved dictionary" when appling a quantified-     constraint led to the ability to define unsafeCoerce-     in #17267.--   - Exception 2: the magic built-in instance for (~) has no-     such guarantee.  It behaves as if we had-         class    (a ~# b) => (a ~ b) where {}-         instance (a ~# b) => (a ~ b) where {}-     The "dfun" for the instance is strict in the coercion.-     Anyway there's no point in recording a "solved dict" for-     (t1 ~ t2); it's not going to allow a recursive dictionary-     to be constructed.  Ditto (~~) and Coercible.--THEREFORE we only add a "solved dictionary"-  - when applying an instance declaration-  - subject to Exceptions 1 and 2 above--In implementation terms-  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,-    conditional on the kind of instance--  - It is only called when applying an instance decl,-    in GHC.Tc.Solver.Interact.doTopReactDict--  - ClsInst.InstanceWhat says what kind of instance was-    used to solve the constraint.  In particular-      * LocalInstance identifies quantified constraints-      * BuiltinEqInstance identifies the strange built-in-        instances for equality.--  - ClsInst.instanceReturnsDictCon says which kind of-    instance guarantees to return a dictionary constructor--Other notes about solved dictionaries--* See also Note [Do not add superclasses of solved dictionaries]--* The inert_solved_dicts field is not rewritten by equalities,-  so it may get out of date.--* The inert_solved_dicts are all Wanteds, never givens--* We only cache dictionaries from top-level instances, not from-  local quantified constraints.  Reason: if we cached the latter-  we'd need to purge the cache when bringing new quantified-  constraints into scope, because quantified constraints "shadow"-  top-level instances.--Note [Do not add superclasses of solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Every member of inert_solved_dicts is the result of applying a-dictionary function, NOT of applying superclass selection to anything.-Consider--        class Ord a => C a where-        instance Ord [a] => C [a] where ...--Suppose we are trying to solve-  [G] d1 : Ord a-  [W] d2 : C [a]--Then we'll use the instance decl to give--  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3-  [W] d3 : Ord [a]--We must not add d4 : Ord [a] to the 'solved' set (by taking the-superclass of d2), otherwise we'll use it to solve d3, without ever-using d1, which would be a catastrophe.--Solution: when extending the solved dictionaries, do not add superclasses.-That's why each element of the inert_solved_dicts is the result of applying-a dictionary function.--Note [Example of recursive dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Example 1--    data D r = ZeroD | SuccD (r (D r));--    instance (Eq (r (D r))) => Eq (D r) where-        ZeroD     == ZeroD     = True-        (SuccD a) == (SuccD b) = a == b-        _         == _         = False;--    equalDC :: D [] -> D [] -> Bool;-    equalDC = (==);--We need to prove (Eq (D [])). Here's how we go:--   [W] d1 : Eq (D [])-By instance decl of Eq (D r):-   [W] d2 : Eq [D []]      where   d1 = dfEqD d2-By instance decl of Eq [a]:-   [W] d3 : Eq (D [])      where   d2 = dfEqList d3-                                   d1 = dfEqD d2-Now this wanted can interact with our "solved" d1 to get:-    d3 = d1---- Example 2:-This code arises in the context of "Scrap Your Boilerplate with Class"--    class Sat a-    class Data ctx a-    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1-    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2--    class Data Maybe a => Foo a--    instance Foo t => Sat (Maybe t)                             -- dfunSat--    instance Data Maybe a => Foo a                              -- dfunFoo1-    instance Foo a        => Foo [a]                            -- dfunFoo2-    instance                 Foo [Char]                         -- dfunFoo3--Consider generating the superclasses of the instance declaration-         instance Foo a => Foo [a]--So our problem is this-    [G] d0 : Foo t-    [W] d1 : Data Maybe [t]   -- Desired superclass--We may add the given in the inert set, along with its superclasses-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  WorkList-    [W] d1 : Data Maybe [t]--Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-  WorkList:-    [W] d2 : Sat (Maybe [t])-    [W] d3 : Data Maybe t--Now, we may simplify d2 using dfunSat; d2 := dfunSat d4-  Inert:-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList:-    [W] d3 : Data Maybe t-    [W] d4 : Foo [t]--Now, we can just solve d3 from d01; d3 := d01-  Inert-    [G] d0 : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-  WorkList-    [W] d4 : Foo [t]--Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5-  Inert-    [G] d0  : Foo t-    [G] d01 : Data Maybe t   -- Superclass of d0-  Solved:-        d1 : Data Maybe [t]-        d2 : Sat (Maybe [t])-        d4 : Foo [t]-  WorkList:-    [W] d5 : Foo t--Now, d5 can be solved! d5 := d0--Result-   d1 := dfunData2 d2 d3-   d2 := dfunSat d4-   d3 := d01-   d4 := dfunFoo2 d5-   d5 := d0--}--{- *********************************************************************-*                                                                      *-                InertCans: the canonical inerts-*                                                                      *-*                                                                      *-********************************************************************* -}--data InertCans   -- See Note [Detailed InertCans Invariants] for more-  = IC { inert_eqs :: InertEqs-              -- See Note [inert_eqs: the inert equalities]-              -- All CTyEqCans; index is the LHS tyvar-              -- Domain = skolems and untouchables; a touchable would be unified--       , inert_funeqs :: FunEqMap Ct-              -- All CFunEqCans; index is the whole family head type.-              -- All Nominal (that's an invariant of all CFunEqCans)-              -- LHS is fully rewritten (modulo eqCanRewrite constraints)-              --     wrt inert_eqs-              -- Can include all flavours, [G], [W], [WD], [D]-              -- See Note [Type family equations]--       , inert_dicts :: DictMap Ct-              -- Dictionaries only-              -- All fully rewritten (modulo flavour constraints)-              --     wrt inert_eqs--       , inert_insts :: [QCInst]--       , inert_safehask :: DictMap Ct-              -- Failed dictionary resolution due to Safe Haskell overlapping-              -- instances restriction. We keep this separate from inert_dicts-              -- as it doesn't cause compilation failure, just safe inference-              -- failure.-              ---              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]-              -- in "GHC.Tc.Solver"--       , inert_irreds :: Cts-              -- Irreducible predicates that cannot be made canonical,-              --     and which don't interact with others (e.g.  (c a))-              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])--       , inert_count :: Int-              -- Number of Wanted goals in-              --     inert_eqs, inert_dicts, inert_safehask, inert_irreds-              -- Does not include insolubles-              -- When non-zero, keep trying to solve-       }--type InertEqs    = DTyVarEnv EqualCtList-type EqualCtList = [Ct]  -- See Note [EqualCtList invariants]--{- Note [Detailed InertCans Invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The InertCans represents a collection of constraints with the following properties:--  * All canonical--  * No two dictionaries with the same head-  * No two CIrreds with the same type--  * Family equations inert wrt top-level family axioms--  * Dictionaries have no matching top-level instance--  * Given family or dictionary constraints don't mention touchable-    unification variables--  * Non-CTyEqCan constraints are fully rewritten with respect-    to the CTyEqCan equalities (modulo canRewrite of course;-    eg a wanted cannot rewrite a given)--  * CTyEqCan equalities: see Note [inert_eqs: the inert equalities]-    Also see documentation in Constraint.Ct for a list of invariants--Note [EqualCtList invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    * All are equalities-    * All these equalities have the same LHS-    * The list is never empty-    * No element of the list can rewrite any other-    * Derived before Wanted--From the fourth invariant it follows that the list is-   - A single [G], or-   - Zero or one [D] or [WD], followed by any number of [W]--The Wanteds can't rewrite anything which is why we put them last--Note [Type family equations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),-live in three places--  * The work-list, of course--  * The inert_funeqs are un-solved but fully processed, and in-    the InertCans. They can be [G], [W], [WD], or [D].--  * The inert_flat_cache.  This is used when flattening, to get maximal-    sharing. Everything in the inert_flat_cache is [G] or [WD]--    It contains lots of things that are still in the work-list.-    E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the-        work list.  Then we flatten w1, dumping (w3: G a ~ f1) in the work-        list.  Now if we flatten w2 before we get to w3, we still want to-        share that (G a).-    Because it contains work-list things, DO NOT use the flat cache to solve-    a top-level goal.  Eg in the above example we don't want to solve w3-    using w3 itself!--The CFunEqCan Ownership Invariant:--  * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv-    It "owns" that fsk/fmv, in the sense that:-      - reducing a [W/WD] CFunEqCan fills in the fmv-      - unflattening a [W/WD] CFunEqCan fills in the fmv-      (in both cases unless an occurs-check would result)--  * In contrast a [D] CFunEqCan does not "own" its fmv:-      - reducing a [D] CFunEqCan does not fill in the fmv;-        it just generates an equality-      - unflattening ignores [D] CFunEqCans altogether---Note [inert_eqs: the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Definition [Can-rewrite relation]-A "can-rewrite" relation between flavours, written f1 >= f2, is a-binary relation with the following properties--  (R1) >= is transitive-  (R2) If f1 >= f, and f2 >= f,-       then either f1 >= f2 or f2 >= f1--Lemma.  If f1 >= f then f1 >= f1-Proof.  By property (R2), with f1=f2--Definition [Generalised substitution]-A "generalised substitution" S is a set of triples (a -f-> t), where-  a is a type variable-  t is a type-  f is a flavour-such that-  (WF1) if (a -f1-> t1) in S-           (a -f2-> t2) in S-        then neither (f1 >= f2) nor (f2 >= f1) hold-  (WF2) if (a -f-> t) is in S, then t /= a--Definition [Applying a generalised substitution]-If S is a generalised substitution-   S(f,a) = t,  if (a -fs-> t) in S, and fs >= f-          = a,  otherwise-Application extends naturally to types S(f,t), modulo roles.-See Note [Flavours with roles].--Theorem: S(f,a) is well defined as a function.-Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,-               and  f1 >= f and f2 >= f-       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)--Notation: repeated application.-  S^0(f,t)     = t-  S^(n+1)(f,t) = S(f, S^n(t))--Definition: inert generalised substitution-A generalised substitution S is "inert" iff--  (IG1) there is an n such that-        for every f,t, S^n(f,t) = S^(n+1)(f,t)--By (IG1) we define S*(f,t) to be the result of exahaustively-applying S(f,_) to t.-------------------------------------------------------------------Our main invariant:-   the inert CTyEqCans should be an inert generalised substitution-------------------------------------------------------------------Note that inertness is not the same as idempotence.  To apply S to a-type, you may have to apply it recursive.  But inertness does-guarantee that this recursive use will terminate.--Note [Extending the inert equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Main Theorem [Stability under extension]-   Suppose we have a "work item"-       a -fw-> t-   and an inert generalised substitution S,-   THEN the extended substitution T = S+(a -fw-> t)-        is an inert generalised substitution-   PROVIDED-      (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)-      (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)-      (T3) a not in t      -- No occurs check in the work item--      AND, for every (b -fs-> s) in S:-           (K0) not (fw >= fs)-                Reason: suppose we kick out (a -fs-> s),-                        and add (a -fw-> t) to the inert set.-                        The latter can't rewrite the former,-                        so the kick-out achieved nothing--           OR { (K1) not (a = b)-                     Reason: if fw >= fs, WF1 says we can't have both-                             a -fw-> t  and  a -fs-> s--                AND (K2): guarantees inertness of the new substitution-                    {  (K2a) not (fs >= fs)-                    OR (K2b) fs >= fw-                    OR (K2d) a not in s }--                AND (K3) See Note [K3: completeness of solving]-                    { (K3a) If the role of fs is nominal: s /= a-                      (K3b) If the role of fs is representational:-                            s is not of form (a t1 .. tn) } }---Conditions (T1-T3) are established by the canonicaliser-Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable--The idea is that-* (T1-2) are guaranteed by exhaustively rewriting the work-item-  with S(fw,_).--* T3 is guaranteed by a simple occurs-check on the work item.-  This is done during canonicalisation, in canEqTyVar; invariant-  (TyEq:OC) of CTyEqCan.--* (K1-3) are the "kick-out" criteria.  (As stated, they are really the-  "keep" criteria.) If the current inert S contains a triple that does-  not satisfy (K1-3), then we remove it from S by "kicking it out",-  and re-processing it.--* Note that kicking out is a Bad Thing, because it means we have to-  re-process a constraint.  The less we kick out, the better.-  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed-  this but haven't done the empirical study to check.--* Assume we have  G>=G, G>=W and that's all.  Then, when performing-  a unification we add a new given  a -G-> ty.  But doing so does NOT require-  us to kick out an inert wanted that mentions a, because of (K2a).  This-  is a common case, hence good not to kick out.--* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing-  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything-         and so K0 holds.  Intuitively, since fw can't rewrite anything,-         adding it cannot cause any loops-  This is a common case, because Wanteds cannot rewrite Wanteds.-  It's used to avoid even looking for constraint to kick out.--* Lemma (L1): The conditions of the Main Theorem imply that there is no-              (a -fs-> t) in S, s.t.  (fs >= fw).-  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),-  S(fw,a)=a.  But since fs>=fw, S(fw,a) = s, hence s=a.  But now we-  have (a -fs-> a) in S, which contradicts (WF2).--* The extended substitution satisfies (WF1) and (WF2)-  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).-  - (T3) guarantees (WF2).--* (K2) is about inertness.  Intuitively, any infinite chain T^0(f,t),-  T^1(f,t), T^2(f,T).... must pass through the new work item infinitely-  often, since the substitution without the work item is inert; and must-  pass through at least one of the triples in S infinitely often.--  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),-    and hence this triple never plays a role in application S(f,a).-    It is always safe to extend S with such a triple.--    (NB: we could strengten K1) in this way too, but see K3.--  - (K2b): If this holds then, by (T2), b is not in t.  So applying the-    work item does not generate any new opportunities for applying S--  - (K2c): If this holds, we can't pass through this triple infinitely-    often, because if we did then fs>=f, fw>=f, hence by (R2)-      * either fw>=fs, contradicting K2c-      * or fs>=fw; so by the argument in K2b we can't have a loop--  - (K2d): if a not in s, we hae no further opportunity to apply the-    work item, similar to (K2b)--  NB: Dimitrios has a PDF that does this in more detail--Key lemma to make it watertight.-  Under the conditions of the Main Theorem,-  forall f st fw >= f, a is not in S^k(f,t), for any k--Also, consider roles more carefully. See Note [Flavours with roles]--Note [K3: completeness of solving]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(K3) is not necessary for the extended substitution-to be inert.  In fact K1 could be made stronger by saying-   ... then (not (fw >= fs) or not (fs >= fs))-But it's not enough for S to be inert; we also want completeness.-That is, we want to be able to solve all soluble wanted equalities.-Suppose we have--   work-item   b -G-> a-   inert-item  a -W-> b--Assuming (G >= W) but not (W >= W), this fulfills all the conditions,-so we could extend the inerts, thus:--   inert-items   b -G-> a-                 a -W-> b--But if we kicked-out the inert item, we'd get--   work-item     a -W-> b-   inert-item    b -G-> a--Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.-So we add one more clause to the kick-out criteria--Another way to understand (K3) is that we treat an inert item-        a -f-> b-in the same way as-        b -f-> a-So if we kick out one, we should kick out the other.  The orientation-is somewhat accidental.--When considering roles, we also need the second clause (K3b). Consider--  work-item    c -G/N-> a-  inert-item   a -W/R-> b c--The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.-But we don't kick out the inert item because not (W/R >= W/R).  So we just-add the work item. But then, consider if we hit the following:--  work-item    b -G/N-> Id-  inert-items  a -W/R-> b c-               c -G/N-> a-where-  newtype Id x = Id x--For similar reasons, if we only had (K3a), we wouldn't kick the-representational inert out. And then, we'd miss solving the inert, which-now reduced to reflexivity.--The solution here is to kick out representational inerts whenever the-tyvar of a work item is "exposed", where exposed means being at the-head of the top-level application chain (a t1 .. tn).  See-TcType.isTyVarHead. This is encoded in (K3b).--Beware: if we make this test succeed too often, we kick out too much,-and the solver might loop.  Consider (#14363)-  work item:   [G] a ~R f b-  inert item:  [G] b ~R f a-In GHC 8.2 the completeness tests more aggressive, and kicked out-the inert item; but no rewriting happened and there was an infinite-loop.  All we need is to have the tyvar at the head.--Note [Flavours with roles]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The system described in Note [inert_eqs: the inert equalities]-discusses an abstract-set of flavours. In GHC, flavours have two components: the flavour proper,-taken from {Wanted, Derived, Given} and the equality relation (often called-role), taken from {NomEq, ReprEq}.-When substituting w.r.t. the inert set,-as described in Note [inert_eqs: the inert equalities],-we must be careful to respect all components of a flavour.-For example, if we have--  inert set: a -G/R-> Int-             b -G/R-> Bool--  type role T nominal representational--and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT-T Int Bool. The reason is that T's first parameter has a nominal role, and-thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of-substitution means that the proof in Note [The inert equalities] may need-to be revisited, but we don't think that the end conclusion is wrong.--}--instance Outputable InertCans where-  ppr (IC { inert_eqs = eqs-          , inert_funeqs = funeqs, inert_dicts = dicts-          , inert_safehask = safehask, inert_irreds = irreds-          , inert_insts = insts-          , inert_count = count })-    = braces $ vcat-      [ ppUnless (isEmptyDVarEnv eqs) $-        text "Equalities:"-          <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)-      , ppUnless (isEmptyTcAppMap funeqs) $-        text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)-      , ppUnless (isEmptyTcAppMap dicts) $-        text "Dictionaries =" <+> pprCts (dictsToBag dicts)-      , ppUnless (isEmptyTcAppMap safehask) $-        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)-      , ppUnless (isEmptyCts irreds) $-        text "Irreds =" <+> pprCts irreds-      , ppUnless (null insts) $-        text "Given instances =" <+> vcat (map ppr insts)-      , text "Unsolved goals =" <+> int count-      ]--{- *********************************************************************-*                                                                      *-             Shadow constraints and improvement-*                                                                      *-************************************************************************--Note [The improvement story and derived shadows]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not-rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for-solving.  Here's a classic example (indexed-types/should_fail/T4093a)--    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e--    We get [G] Foo e ~ Maybe e-           [W] Foo e ~ Foo ee      -- ee is a unification variable-           [W] Foo ee ~ Maybe ee--    Flatten: [G] Foo e ~ fsk-             [G] fsk ~ Maybe e   -- (A)--             [W] Foo ee ~ fmv-             [W] fmv ~ fsk       -- (B) From Foo e ~ Foo ee-             [W] fmv ~ Maybe ee--    --> rewrite (B) with (A)-             [W] Foo ee ~ fmv-             [W] fmv ~ Maybe e-             [W] fmv ~ Maybe ee--    But now we appear to be stuck, since we don't rewrite Wanteds with-    Wanteds.  This is silly because we can see that ee := e is the-    only solution.--The basic plan is-  * generate Derived constraints that shadow Wanted constraints-  * allow Derived to rewrite Derived-  * in order to cause some unifications to take place-  * that in turn solve the original Wanteds--The ONLY reason for all these Derived equalities is to tell us how to-unify a variable: that is, what Mark Jones calls "improvement".--The same idea is sometimes also called "saturation"; find all the-equalities that must hold in any solution.--Or, equivalently, you can think of the derived shadows as implementing-the "model": a non-idempotent but no-occurs-check substitution,-reflecting *all* *Nominal* equalities (a ~N ty) that are not-immediately soluble by unification.--More specifically, here's how it works (Oct 16):--* Wanted constraints are born as [WD]; this behaves like a-  [W] and a [D] paired together.--* When we are about to add a [WD] to the inert set, if it can-  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],-  putting the latter into the work list (see maybeEmitShadow).--In the example above, we get to the point where we are stuck:-    [WD] Foo ee ~ fmv-    [WD] fmv ~ Maybe e-    [WD] fmv ~ Maybe ee--But now when [WD] fmv ~ Maybe ee is about to be added, we'll-split it into [W] and [D], since the inert [WD] fmv ~ Maybe e-can rewrite it.  Then:-    work item: [D] fmv ~ Maybe ee-    inert:     [W] fmv ~ Maybe ee-               [WD] fmv ~ Maybe e   -- (C)-               [WD] Foo ee ~ fmv--See Note [Splitting WD constraints].  Now the work item is rewritten-by (C) and we soon get ee := e.--Additional notes:--  * The derived shadow equalities live in inert_eqs, along with-    the Givens and Wanteds; see Note [EqualCtList invariants].--  * We make Derived shadows only for Wanteds, not Givens.  So we-    have only [G], not [GD] and [G] plus splitting.  See-    Note [Add derived shadows only for Wanteds]--  * We also get Derived equalities from functional dependencies-    and type-function injectivity; see calls to unifyDerived.--  * This splitting business applies to CFunEqCans too; and then-    we do apply type-function reductions to the [D] CFunEqCan.-    See Note [Reduction for Derived CFunEqCans]--  * It's worth having [WD] rather than just [W] and [D] because-    * efficiency: silly to process the same thing twice-    * inert_funeqs, inert_dicts is a finite map keyed by-      the type; it's inconvenient for it to map to TWO constraints--Note [Splitting WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We are about to add a [WD] constraint to the inert set; and we-know that the inert set has fully rewritten it.  Should we split-it into [W] and [D], and put the [D] in the work list for further-work?--* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):-  Yes if the inert set could rewrite tys to make the class constraint,-  or type family, fire.  That is, yes if the inert_eqs intersects-  with the free vars of tys.  For this test we use-  (anyRewritableTyVar True) which ignores casts and coercions in tys,-  because rewriting the casts or coercions won't make the thing fire-  more often.--* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.-  We need to check both 'a' and 'ty' against the inert set:-    - Inert set contains  [D] a ~ ty2-      Then we want to put [D] a ~ ty in the worklist, so we'll-      get [D] ty ~ ty2 with consequent good things--    - Inert set contains [D] b ~ a, where b is in ty.-      We can't just add [WD] a ~ ty[b] to the inert set, because-      that breaks the inert-set invariants.  If we tried to-      canonicalise another [D] constraint mentioning 'a', we'd-      get an infinite loop--  Moreover we must use (anyRewritableTyVar False) for the RHS,-  because even tyvars in the casts and coercions could give-  an infinite loop if we don't expose it--* CIrredCan: Yes if the inert set can rewrite the constraint.-  We used to think splitting irreds was unnecessary, but-  see Note [Splitting Irred WD constraints]--* Others: nothing is gained by splitting.--Note [Splitting Irred WD constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Splitting Irred constraints can make a difference. Here is the-scenario:--  a[sk] :: F v     -- F is a type family-  beta :: alpha--  work item: [WD] a ~ beta--This is heterogeneous, so we try flattening the kinds.--  co :: F v ~ fmv-  [WD] (a |> co) ~ beta--This is still hetero, so we emit a kind equality and make the work item an-inert Irred.--  work item: [D] fmv ~ alpha-  inert: [WD] (a |> co) ~ beta (CIrredCan)--Can't make progress on the work item. Add to inert set. This kicks out the-old inert, because a [D] can rewrite a [WD].--  work item: [WD] (a |> co) ~ beta-  inert: [D] fmv ~ alpha (CTyEqCan)--Can't make progress on this work item either (although GHC tries by-decomposing the cast and reflattening... but that doesn't make a difference),-which is still hetero. Emit a new kind equality and add to inert set. But,-critically, we split the Irred.--  work list:-   [D] fmv ~ alpha (CTyEqCan)-   [D] (a |> co) ~ beta (CIrred) -- this one was split off-  inert:-   [W] (a |> co) ~ beta-   [D] fmv ~ alpha--We quickly solve the first work item, as it's the same as an inert.--  work item: [D] (a |> co) ~ beta-  inert:-   [W] (a |> co) ~ beta-   [D] fmv ~ alpha--We decompose the cast, yielding--  [D] a ~ beta--We then flatten the kinds. The lhs kind is F v, which flattens to fmv which-then rewrites to alpha.--  co' :: F v ~ alpha-  [D] (a |> co') ~ beta--Now this equality is homo-kinded. So we swizzle it around to--  [D] beta ~ (a |> co')--and set beta := a |> co', and go home happy.--If we don't split the Irreds, we loop. This is all dangerously subtle.--This is triggered by test case typecheck/should_compile/SplitWD.--Note [Examples of how Derived shadows helps completeness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#10009, a very nasty example:--    f :: (UnF (F b) ~ b) => F b -> ()--    g :: forall a. (UnF (F a) ~ a) => a -> ()-    g _ = f (undefined :: F a)--  For g we get [G] UnF (F a) ~ a-               [WD] UnF (F beta) ~ beta-               [WD] F a ~ F beta-  Flatten:-      [G] g1: F a ~ fsk1         fsk1 := F a-      [G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1-      [G] g3: fsk2 ~ a--      [WD] w1: F beta ~ fmv1-      [WD] w2: UnF fmv1 ~ fmv2-      [WD] w3: fmv2 ~ beta-      [WD] w4: fmv1 ~ fsk1   -- From F a ~ F beta using flat-cache-                             -- and re-orient to put meta-var on left--Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2-React that with g2: [D] d2: fmv2 ~ fsk2-React that with w3: [D] beta ~ fsk2-            and g3: [D] beta ~ a -- Hooray beta := a-And that is enough to solve everything--Note [Add derived shadows only for Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only add shadows for Wanted constraints. That is, we have-[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]-constraints.--It does just possibly make sense ot add a derived shadow for a-Given. If we created a Derived shadow of a Given, it could be-rewritten by other Deriveds, and that could, conceivably, lead to a-useful unification.--But (a) I have been unable to come up with an example of this-        happening-    (b) see #12660 for how adding the derived shadows-        of a Given led to an infinite loop.-    (c) It's unlikely that rewriting derived Givens will lead-        to a unification because Givens don't mention touchable-        unification variables--For (b) there may be other ways to solve the loop, but simply-reraining from adding derived shadows of Givens is particularly-simple.  And it's more efficient too!--Still, here's one possible reason for adding derived shadows-for Givens.  Consider-           work-item [G] a ~ [b], inerts has [D] b ~ a.-If we added the derived shadow (into the work list)-         [D] a ~ [b]-When we process it, we'll rewrite to a ~ [a] and get an-occurs check.  Without it we'll miss the occurs check (reporting-inaccessible code); but that's probably OK.--Note [Keep CDictCan shadows as CDictCan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  class C a => D a b-and [G] D a b, [G] C a in the inert set.  Now we insert-[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,-so we can rewrite it with the new constraint, and perhaps get-instance reduction or other consequences.--BUT we do not want to kick out a *non-canonical* (D a b). If we-did, we would do this:-  - rewrite it to [D] D a c, with pend_sc = True-  - use expandSuperClasses to add C a-  - go round again, which solves C a from the givens-This loop goes on for ever and triggers the simpl_loop limit.--Solution: kick out the CDictCan which will have pend_sc = False,-because we've already added its superclasses.  So we won't re-add-them.  If we forget the pend_sc flag, our cunning scheme for avoiding-generating superclasses repeatedly will fail.--See #11379 for a case of this.--Note [Do not do improvement for WOnly]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do improvement between two constraints (e.g. for injectivity-or functional dependencies) only if both are "improvable". And-we improve a constraint wrt the top-level instances only if-it is improvable.--Improvable:     [G] [WD] [D}-Not improvable: [W]--Reasons:--* It's less work: fewer pairs to compare--* Every [W] has a shadow [D] so nothing is lost--* Consider [WD] C Int b,  where 'b' is a skolem, and-    class C a b | a -> b-    instance C Int Bool-  We'll do a fundep on it and emit [D] b ~ Bool-  That will kick out constraint [WD] C Int b-  Then we'll split it to [W] C Int b (keep in inert)-                     and [D] C Int b (in work list)-  When processing the latter we'll rewrite it to-        [D] C Int Bool-  At that point it would be /stupid/ to interact it-  with the inert [W] C Int b in the inert set; after all,-  it's the very constraint from which the [D] C Int Bool-  was split!  We can avoid this by not doing improvement-  on [W] constraints. This came up in #12860.--}--maybeEmitShadow :: InertCans -> Ct -> TcS Ct--- See Note [The improvement story and derived shadows]-maybeEmitShadow ics ct-  | let ev = ctEvidence ct-  , CtWanted { ctev_pred = pred, ctev_loc = loc-             , ctev_nosh = WDeriv } <- ev-  , shouldSplitWD (inert_eqs ics) ct-  = do { traceTcS "Emit derived shadow" (ppr ct)-       ; let derived_ev = CtDerived { ctev_pred = pred-                                    , ctev_loc  = loc }-             shadow_ct = ct { cc_ev = derived_ev }-               -- Te shadow constraint keeps the canonical shape.-               -- This just saves work, but is sometimes important;-               -- see Note [Keep CDictCan shadows as CDictCan]-       ; emitWork [shadow_ct]--       ; let ev' = ev { ctev_nosh = WOnly }-             ct' = ct { cc_ev = ev' }-                 -- Record that it now has a shadow-                 -- This is /the/ place we set the flag to WOnly-       ; return ct' }--  | otherwise-  = return ct--shouldSplitWD :: InertEqs -> Ct -> Bool--- Precondition: 'ct' is [WD], and is inert--- True <=> we should split ct ito [W] and [D] because---          the inert_eqs can make progress on the [D]--- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })-  = should_split_match_args inert_eqs tys-    -- We don't need to split if the tv is the RHS fsk--shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })-  = should_split_match_args inert_eqs tys-    -- NB True: ignore coercions-    -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty-                                  , cc_eq_rel = eq_rel })-  =  tv `elemDVarEnv` inert_eqs-  || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty-  -- NB False: do not ignore casts and coercions-  -- See Note [Splitting WD constraints]--shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })-  = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)--shouldSplitWD _ _ = False   -- No point in splitting otherwise--should_split_match_args :: InertEqs -> [TcType] -> Bool--- True if the inert_eqs can rewrite anything in the argument--- types, ignoring casts and coercions-should_split_match_args inert_eqs tys-  = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys-    -- NB True: ignore casts coercions-    -- See Note [Splitting WD constraints]--canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool-canRewriteTv inert_eqs eq_rel tv-  | Just (ct : _) <- lookupDVarEnv inert_eqs tv-  , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct-  = eq_rel1 `eqCanRewrite` eq_rel-  | otherwise-  = False--isImprovable :: CtEvidence -> Bool--- See Note [Do not do improvement for WOnly]-isImprovable (CtWanted { ctev_nosh = WOnly }) = False-isImprovable _                                = True---{- *********************************************************************-*                                                                      *-                   Inert equalities-*                                                                      *-********************************************************************* -}--addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs-addTyEq old_eqs tv ct-  = extendDVarEnv_C add_eq old_eqs tv [ct]-  where-    add_eq old_eqs _-      | isWantedCt ct-      , (eq1 : eqs) <- old_eqs-      = eq1 : ct : eqs-      | otherwise-      = ct : old_eqs--foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b-foldTyEqs k eqs z-  = foldDVarEnv (\cts z -> foldr k z cts) z eqs--findTyEqs :: InertCans -> TyVar -> EqualCtList-findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []--delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs-delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv-  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1-        isThisOne _                          = False--lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType-lookupInertTyVar ieqs tv-  = case lookupDVarEnv ieqs tv of-      Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs-      _                                                        -> Nothing--{- *********************************************************************-*                                                                      *-                   Inert instances: inert_insts-*                                                                      *-********************************************************************* -}--addInertForAll :: QCInst -> TcS ()--- Add a local Given instance, typically arising from a type signature-addInertForAll new_qci-  = do { ics <- getInertCans-       ; insts' <- add_qci (inert_insts ics)-       ; setInertCans (ics { inert_insts = insts' }) }-  where-    add_qci :: [QCInst] -> TcS [QCInst]-    -- See Note [Do not add duplicate quantified instances]-    add_qci qcis-      | any same_qci qcis-      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)-           ; return qcis }--      | otherwise-      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)-           ; return (new_qci : qcis) }--    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))-                                (ctEvPred (qci_ev new_qci))--{- Note [Do not add duplicate quantified instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#15244):--  f :: (C g, D g) => ....-  class S g => C g where ...-  class S g => D g where ...-  class (forall a. Eq a => Eq (g a)) => S g where ...--Then in f's RHS there are two identical quantified constraints-available, one via the superclasses of C and one via the superclasses-of D.  The two are identical, and it seems wrong to reject the program-because of that. But without doing duplicate-elimination we will have-two matching QCInsts when we try to solve constraints arising from f's-RHS.--The simplest thing is simply to eliminate duplicates, which we do here.--}--{- *********************************************************************-*                                                                      *-                  Adding an inert-*                                                                      *-************************************************************************--Note [Adding an equality to the InertCans]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When adding an equality to the inerts:--* Split [WD] into [W] and [D] if the inerts can rewrite the latter;-  done by maybeEmitShadow.--* Kick out any constraints that can be rewritten by the thing-  we are adding.  Done by kickOutRewritable.--* Note that unifying a:=ty, is like adding [G] a~ty; just use-  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.--Note [Kicking out CFunEqCan for fundeps]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-   New:    [D] fmv1 ~ fmv2-   Inert:  [W] F alpha ~ fmv1-           [W] F beta  ~ fmv2--where F is injective. The new (derived) equality certainly can't-rewrite the inerts. But we *must* kick out the first one, to get:--   New:   [W] F alpha ~ fmv1-   Inert: [W] F beta ~ fmv2-          [D] fmv1 ~ fmv2--and now improvement will discover [D] alpha ~ beta. This is important;-eg in #9587.--So in kickOutRewritable we look at all the tyvars of the-CFunEqCan, including the fsk.--}--addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities--- Precondition: item /is/ canonical--- See Note [Adding an equality to the InertCans]-addInertCan ct-  = do { traceTcS "insertInertCan {" $-         text "Trying to insert new inert item:" <+> ppr ct--       ; ics <- getInertCans-       ; ct  <- maybeEmitShadow ics ct-       ; ics <- maybeKickOut ics ct-       ; setInertCans (add_item ics ct)--       ; traceTcS "addInertCan }" $ empty }--maybeKickOut :: InertCans -> Ct -> TcS InertCans--- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan-maybeKickOut ics ct-  | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct-  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics-       ; return ics' }-  | otherwise-  = return ics--add_item :: InertCans -> Ct -> InertCans-add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })-  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }--add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })-  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item-        , inert_count = bumpUnsolvedCount ev (inert_count ics) }--add_item ics@(IC { inert_irreds = irreds, inert_count = count })-         item@(CIrredCan { cc_ev = ev, cc_status = status })-  = ics { inert_irreds = irreds `Bag.snocBag` item-        , inert_count  = case status of-                           InsolubleCIS -> count-                           _            -> bumpUnsolvedCount ev count }-                              -- inert_count does not include insolubles---add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })-  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item-        , inert_count = bumpUnsolvedCount ev (inert_count ics) }--add_item _ item-  = pprPanic "upd_inert set: can't happen! Inserting " $-    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds--bumpUnsolvedCount :: CtEvidence -> Int -> Int-bumpUnsolvedCount ev n | isWanted ev = n+1-                       | otherwise   = n---------------------------------------------kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                    -> TcTyVar        -- The new equality is tv ~ ty-                    -> InertCans-                    -> TcS (Int, InertCans)-kickOutRewritable new_fr new_tv ics-  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics-             n_kicked = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)-            ; csTraceTcS $-              hang (text "Kick out, tv =" <+> ppr new_tv)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; return (n_kicked, ics') }--kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that-                                      -- is being added to the inert set-                    -> TcTyVar        -- The new equality is tv ~ ty-                    -> InertCans-                    -> (WorkList, InertCans)--- See Note [kickOutRewritable]-kick_out_rewritable new_fr new_tv-                    ics@(IC { inert_eqs      = tv_eqs-                            , inert_dicts    = dictmap-                            , inert_safehask = safehask-                            , inert_funeqs   = funeqmap-                            , inert_irreds   = irreds-                            , inert_insts    = old_insts-                            , inert_count    = n })-  | not (new_fr `eqMayRewriteFR` new_fr)-  = (emptyWorkList, ics)-        -- If new_fr can't rewrite itself, it can't rewrite-        -- anything else, so no need to kick out anything.-        -- (This is a common case: wanteds can't rewrite wanteds)-        -- Lemma (L2) in Note [Extending the inert equalities]--  | otherwise-  = (kicked_out, inert_cans_in)-  where-    inert_cans_in = IC { inert_eqs      = tv_eqs_in-                       , inert_dicts    = dicts_in-                       , inert_safehask = safehask   -- ??-                       , inert_funeqs   = feqs_in-                       , inert_irreds   = irs_in-                       , inert_insts    = insts_in-                       , inert_count    = n - workListWantedCount kicked_out }--    kicked_out :: WorkList-    -- NB: use extendWorkList to ensure that kicked-out equalities get priority-    -- See Note [Prioritise equalities] (Kick-out).-    -- The irreds may include non-canonical (hetero-kinded) equality-    -- constraints, which perhaps may have become soluble after new_tv-    -- is substituted; ditto the dictionaries, which may include (a~b)-    -- or (a~~b) constraints.-    kicked_out = foldr extendWorkListCt-                          (emptyWorkList { wl_eqs    = tv_eqs_out-                                         , wl_funeqs = feqs_out })-                          ((dicts_out `andCts` irs_out)-                            `extendCtsList` insts_out)--    (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs-    (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap-           -- See Note [Kicking out CFunEqCan for fundeps]-    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap-    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds-      -- Kick out even insolubles: See Note [Rewrite insolubles]-      -- Of course we must kick out irreducibles like (c a), in case-      -- we can rewrite 'c' to something more useful--    -- Kick-out for inert instances-    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical-    insts_out :: [Ct]-    insts_in  :: [QCInst]-    (insts_out, insts_in)-       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens-       = partitionWith kick_out_qci old_insts-       | otherwise-       = ([], old_insts)-    kick_out_qci qci-      | let ev = qci_ev qci-      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))-      = Left (mkNonCanonical ev)-      | otherwise-      = Right qci--    (_, new_role) = new_fr--    fr_can_rewrite_ty :: EqRel -> Type -> Bool-    fr_can_rewrite_ty role ty = anyRewritableTyVar False role-                                                   fr_can_rewrite_tv ty-    fr_can_rewrite_tv :: EqRel -> TyVar -> Bool-    fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role-                             && tv == new_tv--    fr_may_rewrite :: CtFlavourRole -> Bool-    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs-        -- Can the new item rewrite the inert item?--    kick_out_ct :: Ct -> Bool-    -- Kick it out if the new CTyEqCan can rewrite the inert one-    -- See Note [kickOutRewritable]-    kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct-                   = fr_may_rewrite fs-                   && fr_can_rewrite_ty role (ctPred ct)-                  -- False: ignore casts and coercions-                  -- NB: this includes the fsk of a CFunEqCan.  It can't-                  --     actually be rewritten, but we need to kick it out-                  --     so we get to take advantage of injectivity-                  -- See Note [Kicking out CFunEqCan for fundeps]--    kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)-                 -> ([Ct], DTyVarEnv EqualCtList)-    kick_out_eqs eqs (acc_out, acc_in)-      = (eqs_out ++ acc_out, case eqs_in of-                               []      -> acc_in-                               (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)-      where-        (eqs_out, eqs_in) = partition kick_out_eq eqs--    -- Implements criteria K1-K3 in Note [Extending the inert equalities]-    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty-                          , cc_ev = ev, cc_eq_rel = eq_rel })-      | not (fr_may_rewrite fs)-      = False  -- Keep it in the inert set if the new thing can't rewrite it--      -- Below here (fr_may_rewrite fs) is True-      | tv == new_tv              = True        -- (K1)-      | kick_out_for_inertness    = True-      | kick_out_for_completeness = True-      | otherwise                 = False--      where-        fs = (ctEvFlavour ev, eq_rel)-        kick_out_for_inertness-          =        (fs `eqMayRewriteFR` fs)       -- (K2a)-            && not (fs `eqMayRewriteFR` new_fr)   -- (K2b)-            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2d)-            -- (K2c) is guaranteed by the first guard of keep_eq--        kick_out_for_completeness-          = case eq_rel of-              NomEq  -> rhs_ty `eqType` mkTyVarTy new_tv-              ReprEq -> isTyVarHead new_tv rhs_ty--    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)--kickOutAfterUnification :: TcTyVar -> TcS Int-kickOutAfterUnification new_tv-  = do { ics <- getInertCans-       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)-                                                 new_tv ics-                     -- Given because the tv := xi is given; NomEq because-                     -- only nominal equalities are solved by unification--       ; setInertCans ics2-       ; return n_kicked }---- See Wrinkle (2b) in Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"-kickOutAfterFillingCoercionHole :: CoercionHole -> TcS ()-kickOutAfterFillingCoercionHole hole-  = do { ics <- getInertCans-       ; let (kicked_out, ics') = kick_out ics-             n_kicked           = workListSize kicked_out--       ; unless (n_kicked == 0) $-         do { updWorkListTcS (appendWorkList kicked_out)-            ; csTraceTcS $-              hang (text "Kick out, hole =" <+> ppr hole)-                 2 (vcat [ text "n-kicked =" <+> int n_kicked-                         , text "kicked_out =" <+> ppr kicked_out-                         , text "Residual inerts =" <+> ppr ics' ]) }--       ; setInertCans ics' }-  where-    kick_out :: InertCans -> (WorkList, InertCans)-    kick_out ics@(IC { inert_irreds = irreds })-      = let (to_kick, to_keep) = partitionBag kick_ct irreds--            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList-            ics'       = ics { inert_irreds = to_keep }-        in-        (kicked_out, ics')--    kick_ct :: Ct -> Bool-    -- This is not particularly efficient. Ways to do better:-    --  1) Have a custom function that looks for a coercion hole and returns a Bool-    --  2) Keep co-hole-blocked constraints in a separate part of the inert set,-    --     keyed by their co-hole. (Is it possible for more than one co-hole to be-    --     in a constraint? I doubt it.)-    kick_ct (CIrredCan { cc_ev = ev, cc_status = BlockedCIS })-      = coHoleCoVar hole `elemVarSet` tyCoVarsOfType (ctEvPred ev)-    kick_ct _other = False--{- Note [kickOutRewritable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [inert_eqs: the inert equalities].--When we add a new inert equality (a ~N ty) to the inert set,-we must kick out any inert items that could be rewritten by the-new equality, to maintain the inert-set invariants.--  - We want to kick out an existing inert constraint if-    a) the new constraint can rewrite the inert one-    b) 'a' is free in the inert constraint (so that it *will*)-       rewrite it if we kick it out.--    For (b) we use tyCoVarsOfCt, which returns the type variables /and-    the kind variables/ that are directly visible in the type. Hence-    we will have exposed all the rewriting we care about to make the-    most precise kinds visible for matching classes etc. No need to-    kick out constraints that mention type variables whose kinds-    contain this variable!--  - A Derived equality can kick out [D] constraints in inert_eqs,-    inert_dicts, inert_irreds etc.--  - We don't kick out constraints from inert_solved_dicts, and-    inert_solved_funeqs optimistically. But when we lookup we have to-    take the substitution into account---Note [Rewrite insolubles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have an insoluble alpha ~ [alpha], which is insoluble-because an occurs check.  And then we unify alpha := [Int].  Then we-really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can-be decomposed.  Otherwise we end up with a "Can't match [Int] ~-[[Int]]" which is true, but a bit confusing because the outer type-constructors match.--Hence:- * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,-   simpl_loop), we feed the insolubles in solveSimpleWanteds,-   so that they get rewritten (albeit not solved).-- * We kick insolubles out of the inert set, if they can be-   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)-- * We rewrite those insolubles in GHC.Tc.Solver.Canonical.-   See Note [Make sure that insolubles are fully rewritten]--}-------------------addInertSafehask :: InertCans -> Ct -> InertCans-addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })-  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }--addInertSafehask _ item-  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item--insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-insertSafeOverlapFailureTcS what item-  | safeOverlap what = return ()-  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)--getSafeOverlapFailures :: TcS Cts--- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver-getSafeOverlapFailures- = do { IC { inert_safehask = safehask } <- getInertCans-      ; return $ foldDicts consCts safehask emptyCts }-----------------addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()--- Conditionally add a new item in the solved set of the monad--- See Note [Solved dictionaries]-addSolvedDict what item cls tys-  | isWanted item-  , instanceReturnsDictCon what-  = do { traceTcS "updSolvedSetTcs:" $ ppr item-       ; updInertTcS $ \ ics ->-             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }-  | otherwise-  = return ()--getSolvedDicts :: TcS (DictMap CtEvidence)-getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }--setSolvedDicts :: DictMap CtEvidence -> TcS ()-setSolvedDicts solved_dicts-  = updInertTcS $ \ ics ->-    ics { inert_solved_dicts = solved_dicts }---{- *********************************************************************-*                                                                      *-                  Other inert-set operations-*                                                                      *-********************************************************************* -}--updInertTcS :: (InertSet -> InertSet) -> TcS ()--- Modify the inert set with the supplied function-updInertTcS upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var-                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }--getInertCans :: TcS InertCans-getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }--setInertCans :: InertCans -> TcS ()-setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }--updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a--- Modify the inert set with the supplied function-updRetInertCans upd_fn-  = do { is_var <- getTcSInertsRef-       ; wrapTcS (do { inerts <- TcM.readTcRef is_var-                     ; let (res, cans') = upd_fn (inert_cans inerts)-                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })-                     ; return res }) }--updInertCans :: (InertCans -> InertCans) -> TcS ()--- Modify the inert set with the supplied function-updInertCans upd_fn-  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }--updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertDicts upd_fn-  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }--updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertSafehask upd_fn-  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }--updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()--- Modify the inert set with the supplied function-updInertFunEqs upd_fn-  = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }--updInertIrreds :: (Cts -> Cts) -> TcS ()--- Modify the inert set with the supplied function-updInertIrreds upd_fn-  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }--getInertEqs :: TcS (DTyVarEnv EqualCtList)-getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }--getInertInsols :: TcS Cts--- Returns insoluble equality constraints--- specifically including Givens-getInertInsols = do { inert <- getInertCans-                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }--getInertGivens :: TcS [Ct]--- Returns the Given constraints in the inert set,--- with type functions *not* unflattened-getInertGivens-  = do { inerts <- getInertCans-       ; let all_cts = foldDicts (:) (inert_dicts inerts)-                     $ foldFunEqs (:) (inert_funeqs inerts)-                     $ concat (dVarEnvElts (inert_eqs inerts))-       ; return (filter isGivenCt all_cts) }--getPendingGivenScs :: TcS [Ct]--- Find all inert Given dictionaries, or quantified constraints,---     whose cc_pend_sc flag is True---     and that belong to the current level--- Set their cc_pend_sc flag to False in the inert set, and return that Ct-getPendingGivenScs = do { lvl <- getTcLevel-                        ; updRetInertCans (get_sc_pending lvl) }--get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)-get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })-  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )-       -- When getPendingScDics is called,-       -- there are never any Wanteds in the inert set-    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })-  where-    sc_pending = sc_pend_insts ++ sc_pend_dicts--    sc_pend_dicts = foldDicts get_pending dicts []-    dicts' = foldr add dicts sc_pend_dicts--    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts--    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True-                                       -- but flipping the flag-    get_pending dict dicts-        | Just dict' <- isPendingScDict dict-        , belongs_to_this_level (ctEvidence dict)-        = dict' : dicts-        | otherwise-        = dicts--    add :: Ct -> DictMap Ct -> DictMap Ct-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts-        = addDictCt dicts cls tys ct-    add ct _ = pprPanic "getPendingScDicts" (ppr ct)--    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)-    get_pending_inst cts qci@(QCI { qci_ev = ev })-       | Just qci' <- isPendingScInst qci-       , belongs_to_this_level ev-       = (CQuantCan qci' : cts, qci')-       | otherwise-       = (cts, qci)--    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl-    -- We only want Givens from this level; see (3a) in-    -- Note [The superclass story] in GHC.Tc.Solver.Canonical--getUnsolvedInerts :: TcS ( Bag Implication-                         , Cts     -- Tyvar eqs: a ~ ty-                         , Cts     -- Fun eqs:   F a ~ ty-                         , Cts )   -- All others--- Return all the unsolved [Wanted] or [Derived] constraints------ Post-condition: the returned simple constraints are all fully zonked---                     (because they come from the inert set)---                 the unsolved implics may not be-getUnsolvedInerts- = do { IC { inert_eqs    = tv_eqs-           , inert_funeqs = fun_eqs-           , inert_irreds = irreds-           , inert_dicts  = idicts-           } <- getInertCans--      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts-            unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts-            unsolved_irreds  = Bag.filterBag is_unsolved irreds-            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts-            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts--      ; implics <- getWorkListImplics--      ; traceTcS "getUnsolvedInerts" $-        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs-             , text "fun eqs =" <+> ppr unsolved_fun_eqs-             , text "others =" <+> ppr unsolved_others-             , text "implics =" <+> ppr implics ]--      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }-  where-    add_if_unsolved :: Ct -> Cts -> Cts-    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts-                           | otherwise      = cts--    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived--    -- For CFunEqCans we ignore the Derived ones, and keep-    -- only the Wanteds for flattening.  The Derived ones-    -- share a unification variable with the corresponding-    -- Wanted, so we definitely don't want to participate-    -- in unflattening-    -- See Note [Type family equations]-    add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts-                         | otherwise     = cts--isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool--- True if (a ~N ty) is in the inert set, in either Given or Wanted-isInInertEqs eqs tv rhs-  = case lookupDVarEnv eqs tv of-      Nothing  -> False-      Just cts -> any (same_pred rhs) cts-  where-    same_pred rhs ct-      | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct-      , NomEq <- eq_rel-      , rhs `eqType` rhs2 = True-      | otherwise         = False--getNoGivenEqs :: TcLevel          -- TcLevel of this implication-               -> [TcTyVar]       -- Skolems of this implication-               -> TcS ( Bool      -- True <=> definitely no residual given equalities-                      , Cts )     -- Insoluble equalities arising from givens--- See Note [When does an implication have given equalities?]-getNoGivenEqs tclvl skol_tvs-  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })-              <- getInertCans-       ; let has_given_eqs = foldr ((||) . ct_given_here) False irreds-                          || anyDVarEnv eqs_given_here ieqs-             insols = filterBag insolubleEqCt irreds-                      -- Specifically includes ones that originated in some-                      -- outer context but were refined to an insoluble by-                      -- a local equality; so do /not/ add ct_given_here.--       ; traceTcS "getNoGivenEqs" $-         vcat [ if has_given_eqs then text "May have given equalities"-                                 else text "No given equalities"-              , text "Skols:" <+> ppr skol_tvs-              , text "Inerts:" <+> ppr inerts-              , text "Insols:" <+> ppr insols]-       ; return (not has_given_eqs, insols) }-  where-    eqs_given_here :: EqualCtList -> Bool-    eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]-                              -- Givens are always a singleton-      = not (skolem_bound_here tv) && ct_given_here ct-    eqs_given_here _ = False--    ct_given_here :: Ct -> Bool-    -- True for a Given bound by the current implication,-    -- i.e. the current level-    ct_given_here ct =  isGiven ev-                     && tclvl == ctLocLevel (ctEvLoc ev)-        where-          ev = ctEvidence ct--    skol_tv_set = mkVarSet skol_tvs-    skolem_bound_here tv -- See Note [Let-bound skolems]-      = case tcTyVarDetails tv of-          SkolemTv {} -> tv `elemVarSet` skol_tv_set-          _           -> False---- | Returns Given constraints that might,--- potentially, match the given pred. This is used when checking to see if a--- Given might overlap with an instance. See Note [Instance and Given overlap]--- in "GHC.Tc.Solver.Interact"-matchableGivens :: CtLoc -> PredType -> InertSet -> Cts-matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })-  = filterBag matchable_given all_relevant_givens-  where-    -- just look in class constraints and irreds. matchableGivens does get called-    -- for ~R constraints, but we don't need to look through equalities, because-    -- canonical equalities are used for rewriting. We'll only get caught by-    -- non-canonical -- that is, irreducible -- equalities.-    all_relevant_givens :: Cts-    all_relevant_givens-      | Just (clas, _) <- getClassPredTys_maybe pred_w-      = findDictsByClass (inert_dicts inert_cans) clas-        `unionBags` inert_irreds inert_cans-      | otherwise-      = inert_irreds inert_cans--    matchable_given :: Ct -> Bool-    matchable_given ct-      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct-      = mightMatchLater pred_g loc_g pred_w loc_w--      | otherwise-      = False--mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool-mightMatchLater given_pred given_loc wanted_pred wanted_loc-  =  not (prohibitedSuperClassSolve given_loc wanted_loc)-  && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])-  where-    bind_meta_tv :: TcTyVar -> BindFlag-    -- Any meta tyvar may be unified later, so we treat it as-    -- bindable when unifying with givens. That ensures that we-    -- conservatively assume that a meta tyvar might get unified with-    -- something that matches the 'given', until demonstrated-    -- otherwise.  More info in Note [Instance and Given overlap]-    -- in GHC.Tc.Solver.Interact-    bind_meta_tv tv | isMetaTyVar tv-                    , not (isFskTyVar tv) = BindMe-                    | otherwise           = Skolem--prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool--- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance-prohibitedSuperClassSolve from_loc solve_loc-  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc-  , ScOrigin wanted_size <- ctLocOrigin solve_loc-  = given_size >= wanted_size-  | otherwise-  = False--{- Note [Unsolved Derived equalities]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In getUnsolvedInerts, we return a derived equality from the inert_eqs-because it is a candidate for floating out of this implication.  We-only float equalities with a meta-tyvar on the left, so we only pull-those out here.--Note [When does an implication have given equalities?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an implication-   beta => alpha ~ Int-where beta is a unification variable that has already been unified-to () in an outer scope.  Then we can float the (alpha ~ Int) out-just fine. So when deciding whether the givens contain an equality,-we should canonicalise first, rather than just looking at the original-givens (#8644).--So we simply look at the inert, canonical Givens and see if there are-any equalities among them, the calculation of has_given_eqs.  There-are some wrinkles:-- * We must know which ones are bound in *this* implication and which-   are bound further out.  We can find that out from the TcLevel-   of the Given, which is itself recorded in the tcl_tclvl field-   of the TcLclEnv stored in the Given (ev_given_here).--   What about interactions between inner and outer givens?-      - Outer given is rewritten by an inner given, then there must-        have been an inner given equality, hence the “given-eq” flag-        will be true anyway.--      - Inner given rewritten by outer, retains its level (ie. The inner one)-- * We must take account of *potential* equalities, like the one above:-      beta => ...blah...-   If we still don't know what beta is, we conservatively treat it as potentially-   becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.-- * When flattening givens, we generate Given equalities like-     <F [a]> : F [a] ~ f,-   with Refl evidence, and we *don't* want those to count as an equality-   in the givens!  After all, the entire flattening business is just an-   internal matter, and the evidence does not mention any of the 'givens'-   of this implication.  So we do not treat inert_funeqs as a 'given equality'.-- * See Note [Let-bound skolems] for another wrinkle-- * We do *not* need to worry about representational equalities, because-   these do not affect the ability to float constraints.--Note [Let-bound skolems]-~~~~~~~~~~~~~~~~~~~~~~~~-If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)-and  * 'a' is a skolem bound in this very implication,--then:-a) The Given is pretty much a let-binding, like-      f :: (a ~ b->c) => a -> a-   Here the equality constraint is like saying-      let a = b->c in ...-   It is not adding any new, local equality  information,-   and hence can be ignored by has_given_eqs--b) 'a' will have been completely substituted out in the inert set,-   so we can safely discard it.  Notably, it doesn't need to be-   returned as part of 'fsks'--For an example, see #9211.--See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure-that the right variable is on the left of the equality when both are-tyvars.--You might wonder whether the skokem really needs to be bound "in the-very same implication" as the equuality constraint.-(c.f. #15009) Consider this:--  data S a where-    MkS :: (a ~ Int) => S a--  g :: forall a. S a -> a -> blah-  g x y = let h = \z. ( z :: Int-                      , case x of-                           MkS -> [y,z])-          in ...--From the type signature for `g`, we get `y::a` .  Then when we-encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the-body of the lambda we'll get--  [W] alpha[1] ~ Int                             -- From z::Int-  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]--Now, suppose we decide to float `alpha ~ a` out of the implication-and then unify `alpha := a`.  Now we are stuck!  But if treat-`alpha ~ Int` first, and unify `alpha := Int`, all is fine.-But we absolutely cannot float that equality or we will get stuck.--}--removeInertCts :: [Ct] -> InertCans -> InertCans--- ^ Remove inert constraints from the 'InertCans', for use when a--- typechecker plugin wishes to discard a given.-removeInertCts cts icans = foldl' removeInertCt icans cts--removeInertCt :: InertCans -> Ct -> InertCans-removeInertCt is ct =-  case ct of--    CDictCan  { cc_class = cl, cc_tyargs = tys } ->-      is { inert_dicts = delDict (inert_dicts is) cl tys }--    CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->-      is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }--    CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->-      is { inert_eqs    = delTyEq (inert_eqs is) x ty }--    CQuantCan {}     -> panic "removeInertCt: CQuantCan"-    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"-    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"--lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))-lookupFlatCache fam_tc tys-  = do { IS { inert_flat_cache = flat_cache-            , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts-       ; return (firstJusts [lookup_inerts inert_funeqs,-                             lookup_flats flat_cache]) }-  where-    lookup_inerts inert_funeqs-      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })-           <- 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--    lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys---lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)--- Is this exact predicate type cached in the solved or canonicals of the InertSet?-lookupInInerts loc pty-  | ClassPred cls tys <- classifyPredType pty-  = do { inerts <- getTcSInerts-       ; return (lookupSolvedDict inerts loc cls tys `mplus`-                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }-  | 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].-lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct-lookupInertDict (IC { inert_dicts = dicts }) loc cls tys-  = case findDict dicts loc cls tys of-      Just ct -> Just 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].-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-  = case findDict solved loc cls tys of-      Just ev -> Just ev-      _       -> Nothing--{- *********************************************************************-*                                                                      *-                   Irreds-*                                                                      *-********************************************************************* -}--foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b-foldIrreds k irreds z = foldr k z irreds---{- *********************************************************************-*                                                                      *-                   TcAppMap-*                                                                      *-************************************************************************--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.--We must be careful when using the result of a lookup because it may-not match the requested info exactly!---}--type TcAppMap a = UniqDFM Unique (ListMap LooseTypeMap a)-    -- Indexed by tycon then the arg types, using "loose" matching, where-    -- we don't require kind equality. This allows, for example, (a |> co)-    -- to match (a).-    -- See Note [Use loose types in inert set]-    -- Used for types and classes; hence UniqDFM-    -- See Note [foldTM determinism] for why we use UniqDFM here--isEmptyTcAppMap :: TcAppMap a -> Bool-isEmptyTcAppMap m = isNullUDFM m--emptyTcAppMap :: TcAppMap a-emptyTcAppMap = emptyUDFM--findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a-findTcApp m u tys = do { tys_map <- lookupUDFM m u-                       ; lookupTM tys tys_map }--delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a-delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls--insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a-insertTcApp m cls tys ct = alterUDFM alter_tm m cls-  where-    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))--alterTcApp :: forall a. TcAppMap a -> Unique -> [Type] -> XT a -> TcAppMap a-alterTcApp m cls tys xt_ct = alterUDFM alter_tm m cls-  where-    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)-    alter_tm mb_tm = Just (alterTM tys xt_ct (mb_tm `orElse` emptyTM))---- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b--- mapTcApp f = mapUDFM (mapTM f)--filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct-filterTcAppMap f m-  = mapUDFM do_tm m-  where-    do_tm tm = foldTM insert_mb tm emptyTM-    insert_mb ct tm-       | f ct      = insertTM tys ct tm-       | otherwise = tm-       where-         tys = case ct of-                CFunEqCan { cc_tyargs = tys } -> tys-                CDictCan  { cc_tyargs = tys } -> tys-                _ -> pprPanic "filterTcAppMap" (ppr ct)--tcAppMapToBag :: TcAppMap a -> Bag a-tcAppMapToBag m = foldTcAppMap consBag m emptyBag--foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b-foldTcAppMap k m z = foldUDFM (foldTM k) z m---{- *********************************************************************-*                                                                      *-                   DictMap-*                                                                      *-********************************************************************* -}---{- Note [Tuples hiding implicit parameters]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f,g :: (?x::Int, C a) => a -> a-   f v = let ?x = 4 in g v--The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).-We must /not/ solve this from the Given (?x::Int, C a), because of-the intervening binding for (?x::Int).  #14218.--We deal with this by arranging that we always fail when looking up a-tuple constraint that hides an implicit parameter. Not that this applies-  * both to the inert_dicts (lookupInertDict)-  * and to the solved_dicts (looukpSolvedDict)-An alternative would be not to extend these sets with such tuple-constraints, but it seemed more direct to deal with the lookup.--Note [Solving CallStack constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose f :: HasCallStack => blah.  Then--* Each call to 'f' gives rise to-    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f-  with a CtOrigin that says "OccurrenceOf f".-  Remember that HasCallStack is just shorthand for-    IP "callStack CallStack-  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence--* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by-  pushing the call-site info on the stack, and changing the CtOrigin-  to record that has been done.-   Bind:  s1 = pushCallStack <site-info> s2-   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin--* Then, and only then, we can solve the constraint from an enclosing-  Given.--So we must be careful /not/ to solve 's1' from the Givens.  Again,-we ensure this by arranging that findDict always misses when looking-up souch constraints.--}--type DictMap a = TcAppMap a--emptyDictMap :: DictMap a-emptyDictMap = emptyTcAppMap--findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a-findDict m loc cls tys-  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]-  = Nothing--  | Just {} <- isCallStackPred cls tys-  , OccurrenceOf {} <- ctLocOrigin loc-  = Nothing             -- See Note [Solving CallStack constraints]--  | otherwise-  = findTcApp m (getUnique cls) tys--findDictsByClass :: DictMap a -> Class -> Bag a-findDictsByClass m cls-  | Just tm <- lookupUDFM_Directly m (getUnique cls) = foldTM consBag tm emptyBag-  | otherwise                  = emptyBag--delDict :: DictMap a -> Class -> [Type] -> DictMap a-delDict m cls tys = delTcApp m (getUnique cls) tys--addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a-addDict m cls tys item = insertTcApp m (getUnique cls) tys item--addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct--- Like addDict, but combines [W] and [D] to [WD]--- See Note [KeepBoth] in GHC.Tc.Solver.Interact-addDictCt m cls tys new_ct = alterTcApp m (getUnique cls) tys xt_ct-  where-    new_ct_ev = ctEvidence new_ct--    xt_ct :: Maybe Ct -> Maybe Ct-    xt_ct (Just old_ct)-      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev-      , CtDerived {} <- new_ct_ev-      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})-      | CtDerived {} <- old_ct_ev-      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev-      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})-      where-        old_ct_ev = ctEvidence old_ct--    xt_ct _ = Just new_ct--addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct-addDictsByClass m cls items-  = addToUDFM_Directly m (getUnique cls) (foldr add emptyTM items)-  where-    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm-    add ct _ = pprPanic "addDictsByClass" (ppr ct)--filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct-filterDicts f m = filterTcAppMap f m--partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)-partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)-  where-    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)-                       | otherwise = (yeses,              add ct noes)-    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m-      = addDict m cls tys ct-    add ct _ = pprPanic "partitionDicts" (ppr ct)--dictsToBag :: DictMap a -> Bag a-dictsToBag = tcAppMapToBag--foldDicts :: (a -> b -> b) -> DictMap a -> b -> b-foldDicts = foldTcAppMap--emptyDicts :: DictMap a-emptyDicts = emptyTcAppMap---{- *********************************************************************-*                                                                      *-                   FunEqMap-*                                                                      *-********************************************************************* -}--type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair--emptyFunEqs :: TcAppMap a-emptyFunEqs = emptyTcAppMap--findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a-findFunEq m tc tys = findTcApp m (getUnique tc) tys--funEqsToBag :: FunEqMap a -> Bag a-funEqsToBag m = foldTcAppMap consBag m emptyBag--findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]--- Get inert function equation constraints that have the given tycon--- in their head.  Not that the constraints remain in the inert set.--- We use this to check for derived interactions with built-in type-function--- constructors.-findFunEqsByTyCon m tc-  | Just tm <- lookupUDFM m (getUnique tc) = foldTM (:) tm []-  | otherwise                              = []--foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b-foldFunEqs = foldTcAppMap---- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b--- mapFunEqs = mapTcApp---- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct--- filterFunEqs = filterTcAppMap--insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a-insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val--partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)--- Optimise for the case where the predicate is false--- partitionFunEqs is called only from kick-out, and kick-out usually--- kicks out very few equalities, so we want to optimise for that case-partitionFunEqs f m = (yeses, foldr del m yeses)-  where-    yeses = foldTcAppMap k m []-    k ct yeses | f ct      = ct : yeses-               | otherwise = yeses-    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m-        = delFunEq m tc tys-    del ct _ = pprPanic "partitionFunEqs" (ppr ct)--delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a-delFunEq m tc tys = delTcApp m (getUnique tc) tys---------------------------------type ExactFunEqMap a = UniqFM TyCon (ListMap TypeMap a)--emptyExactFunEqs :: ExactFunEqMap a-emptyExactFunEqs = emptyUFM--findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a-findExactFunEq m tc tys = do { tys_map <- lookupUFM m tc-                             ; lookupTM tys tys_map }--insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a-insertExactFunEq m tc tys val = alterUFM alter_tm m tc-  where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))--{--************************************************************************-*                                                                      *-*              The TcS solver monad                                    *-*                                                                      *-************************************************************************--Note [The TcS monad]-~~~~~~~~~~~~~~~~~~~~-The TcS monad is a weak form of the main Tc monad--All you can do is-    * fail-    * allocate new variables-    * fill in evidence variables--Filling in a dictionary evidence variable means to create a binding-for it, so TcS carries a mutable location where the binding can be-added.  This is initialised from the innermost implication constraint.--}--data TcSEnv-  = TcSEnv {-      tcs_ev_binds    :: EvBindsVar,--      tcs_unified     :: IORef Int,-         -- The number of unification variables we have filled-         -- The important thing is whether it is non-zero--      tcs_count     :: IORef Int, -- Global step count--      tcs_inerts    :: IORef InertSet, -- Current inert set--      -- The main work-list and the flattening worklist-      -- See Note [Work list priorities] and-      tcs_worklist  :: IORef WorkList -- Current worklist-    }------------------newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)--instance Applicative TcS where-  pure x = TcS (\_ -> return x)-  (<*>) = ap--instance Monad TcS where-  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)--instance MonadFail TcS where-  fail err  = TcS (\_ -> fail err)--instance MonadUnique TcS where-   getUniqueSupplyM = wrapTcS getUniqueSupplyM--instance HasModule TcS where-   getModule = wrapTcS getModule--instance MonadThings TcS where-   lookupThing n = wrapTcS (lookupThing n)---- Basic functionality--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-wrapTcS :: TcM a -> TcS a--- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,--- and TcS is supposed to have limited functionality-wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds--wrapErrTcS :: TcM a -> TcS a--- The thing wrapped should just fail--- There's no static check; it's up to the user--- Having a variant for each error message is too painful-wrapErrTcS = wrapTcS--wrapWarnTcS :: TcM a -> TcS a--- The thing wrapped should just add a warning, or no-op--- There's no static check; it's up to the user-wrapWarnTcS = wrapTcS--failTcS, panicTcS  :: SDoc -> TcS a-warnTcS   :: WarningFlag -> SDoc -> TcS ()-addErrTcS :: SDoc -> TcS ()-failTcS      = wrapTcS . TcM.failWith-warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)-addErrTcS    = wrapTcS . TcM.addErr-panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc--traceTcS :: String -> SDoc -> TcS ()-traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)-{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]--runTcPluginTcS :: TcPluginM a -> TcS a-runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar--instance HasDynFlags TcS where-    getDynFlags = wrapTcS getDynFlags--getGlobalRdrEnvTcS :: TcS GlobalRdrEnv-getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv--bumpStepCountTcS :: TcS ()-bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env-                                    ; n <- TcM.readTcRef ref-                                    ; TcM.writeTcRef ref (n+1) }--csTraceTcS :: SDoc -> TcS ()-csTraceTcS doc-  = wrapTcS $ csTraceTcM (return doc)-{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]--traceFireTcS :: CtEvidence -> SDoc -> TcS ()--- Dump a rule-firing trace-traceFireTcS ev doc-  = TcS $ \env -> csTraceTcM $-    do { n <- TcM.readTcRef (tcs_count env)-       ; tclvl <- TcM.getTcLevel-       ; return (hang (text "Step" <+> int n-                       <> brackets (text "l:" <> ppr tclvl <> comma <>-                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))-                       <+> doc <> colon)-                     4 (ppr ev)) }-{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]--csTraceTcM :: TcM SDoc -> TcM ()--- Constraint-solver tracing, -ddump-cs-trace-csTraceTcM mk_doc-  = do { dflags <- getDynFlags-       ; when (  dopt Opt_D_dump_cs_trace dflags-                  || dopt Opt_D_dump_tc_trace dflags )-              ( do { msg <- mk_doc-                   ; TcM.dumpTcRn False-                       (dumpOptionsFromFlag Opt_D_dump_cs_trace)-                       "" FormatText-                       msg }) }-{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]--runTcS :: TcS a                -- What to run-       -> TcM (a, EvBindMap)-runTcS tcs-  = do { ev_binds_var <- TcM.newTcEvBinds-       ; res <- runTcSWithEvBinds ev_binds_var 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 }---- | 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 :: EvBindsVar-                  -> TcS a-                  -> TcM a-runTcSWithEvBinds ev_binds_var tcs-  = do { unified_var <- TcM.newTcRef 0-       ; step_count <- TcM.newTcRef 0-       ; inert_var <- TcM.newTcRef emptyInert-       ; wl_var <- TcM.newTcRef emptyWorkList-       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var-                          , tcs_unified       = unified_var-                          , tcs_count         = step_count-                          , tcs_inerts        = inert_var-                          , tcs_worklist      = wl_var }--             -- Run the computation-       ; res <- unTcS tcs env--       ; count <- TcM.readTcRef step_count-       ; when (count > 0) $-         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)--       ; unflattenGivens inert_var--#if defined(DEBUG)-       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var-       ; checkForCyclicBinds ev_binds-#endif--       ; return res }-------------------------------#if defined(DEBUG)-checkForCyclicBinds :: EvBindMap -> TcM ()-checkForCyclicBinds ev_binds_map-  | null cycles-  = return ()-  | null coercion_cycles-  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles-  | otherwise-  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles-  where-    ev_binds = evBindMapBinds ev_binds_map--    cycles :: [[EvBind]]-    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]--    coercion_cycles = [c | c <- cycles, any is_co_bind c]-    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)--    edges :: [ Node EvVar EvBind ]-    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))-            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]-            -- It's OK to use nonDetEltsUFM here as-            -- stronglyConnCompFromEdgedVertices is still deterministic even-            -- if the edges are in nondeterministic order as explained in-            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-#endif-------------------------------setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a-setEvBindsTcS ref (TcS thing_inside)- = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })--nestImplicTcS :: EvBindsVar-              -> TcLevel -> TcS a-              -> TcS a-nestImplicTcS ref inner_tclvl (TcS thing_inside)-  = TcS $ \ TcSEnv { tcs_unified       = unified_var-                   , tcs_inerts        = old_inert_var-                   , tcs_count         = count-                   } ->-    do { inerts <- TcM.readTcRef old_inert_var-       ; let nest_inert = emptyInert-                            { inert_cans = inert_cans inerts-                            , inert_solved_dicts = inert_solved_dicts inerts }-                              -- See Note [Do not inherit the flat cache]-       ; new_inert_var <- TcM.newTcRef nest_inert-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = TcSEnv { tcs_ev_binds      = ref-                               , tcs_unified       = unified_var-                               , tcs_count         = count-                               , tcs_inerts        = new_inert_var-                               , tcs_worklist      = new_wl_var }-       ; res <- TcM.setTcLevel inner_tclvl $-                thing_inside nest_env--       ; unflattenGivens new_inert_var--#if defined(DEBUG)-       -- Perform a check that the thing_inside did not cause cycles-       ; ev_binds <- TcM.getTcEvBindsMap ref-       ; checkForCyclicBinds ev_binds-#endif-       ; return res }--{- Note [Do not inherit the flat cache]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not want to inherit the flat cache when processing nested-implications.  Consider-   a ~ F b, forall c. b~Int => blah-If we have F b ~ fsk in the flat-cache, and we push that into the-nested implication, we might miss that F b can be rewritten to F Int,-and hence perhaps solve it.  Moreover, the fsk from outside is-flattened out after solving the outer level, but and we don't-do that flattening recursively.--}--nestTcS ::  TcS a -> TcS a--- Use the current untouchables, augmenting the current--- evidence bindings, and solved dictionaries--- But have no effect on the InertCans, or on the inert_flat_cache--- (we want to inherit the latter from processing the Givens)-nestTcS (TcS thing_inside)-  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->-    do { inerts <- TcM.readTcRef inerts_var-       ; new_inert_var <- TcM.newTcRef inerts-       ; new_wl_var    <- TcM.newTcRef emptyWorkList-       ; let nest_env = env { tcs_inerts   = new_inert_var-                            , tcs_worklist = new_wl_var }--       ; res <- thing_inside nest_env--       ; new_inerts <- TcM.readTcRef new_inert_var--       -- we want to propagate the safe haskell failures-       ; let old_ic = inert_cans inerts-             new_ic = inert_cans new_inerts-             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }--       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]-                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts-                                , inert_cans = nxt_ic })--       ; return res }--emitImplicationTcS :: TcLevel -> SkolemInfo-                   -> [TcTyVar]        -- Skolems-                   -> [EvVar]          -- Givens-                   -> Cts              -- Wanteds-                   -> TcS TcEvBinds--- Add an implication to the TcS monad work-list-emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_given  = givens-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp-       ; return (TcEvBinds (ic_binds imp)) }--emitTvImplicationTcS :: TcLevel -> SkolemInfo-                     -> [TcTyVar]        -- Skolems-                     -> Cts              -- Wanteds-                     -> TcS ()--- Just like emitImplicationTcS but no givens and no bindings-emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds-  = do { let wc = emptyWC { wc_simple = wanteds }-       ; imp <- wrapTcS $-                do { ev_binds_var <- TcM.newNoTcEvBinds-                   ; imp <- TcM.newImplication-                   ; return (imp { ic_tclvl  = new_tclvl-                                 , ic_skols  = skol_tvs-                                 , ic_wanted = wc-                                 , ic_binds  = ev_binds_var-                                 , ic_info   = skol_info }) }--       ; emitImplication imp }---{- Note [Propagate the solved dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really quite important that nestTcS does not discard the solved-dictionaries from the thing_inside.-Consider-   Eq [a]-   forall b. empty =>  Eq [a]-We solve the simple (Eq [a]), under nestTcS, and then turn our attention to-the implications.  It's definitely fine to use the solved dictionaries on-the inner implications, and it can make a significant performance difference-if you do so.--}---- Getters and setters of GHC.Tc.Utils.Env fields--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~---- Getter of inerts and worklist-getTcSInertsRef :: TcS (IORef InertSet)-getTcSInertsRef = TcS (return . tcs_inerts)--getTcSWorkListRef :: TcS (IORef WorkList)-getTcSWorkListRef = TcS (return . tcs_worklist)--getTcSInerts :: TcS InertSet-getTcSInerts = getTcSInertsRef >>= readTcRef--setTcSInerts :: InertSet -> TcS ()-setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }--getWorkListImplics :: TcS (Bag Implication)-getWorkListImplics-  = do { wl_var <- getTcSWorkListRef-       ; wl_curr <- readTcRef wl_var-       ; return (wl_implics wl_curr) }--pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)--- Push the level and run thing_inside--- However, thing_inside should not generate any work items-#if defined(DEBUG)-pushLevelNoWorkList err_doc (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM $-                 thing_inside (env { tcs_worklist = wl_panic })-        )-  where-    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc-                         -- This panic checks that the thing-inside-                         -- does not emit any work-list constraints-#else-pushLevelNoWorkList _ (TcS thing_inside)-  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check-#endif--updWorkListTcS :: (WorkList -> WorkList) -> TcS ()-updWorkListTcS f-  = do { wl_var <- getTcSWorkListRef-       ; updTcRef wl_var f }--emitWorkNC :: [CtEvidence] -> TcS ()-emitWorkNC evs-  | null evs-  = return ()-  | otherwise-  = emitWork (map mkNonCanonical evs)--emitWork :: [Ct] -> TcS ()-emitWork [] = return ()   -- avoid printing, among other work-emitWork cts-  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))-       ; updWorkListTcS (extendWorkListCts cts) }--emitImplication :: Implication -> TcS ()-emitImplication implic-  = updWorkListTcS (extendWorkListImplic implic)--newTcRef :: a -> TcS (TcRef a)-newTcRef x = wrapTcS (TcM.newTcRef x)--readTcRef :: TcRef a -> TcS a-readTcRef ref = wrapTcS (TcM.readTcRef ref)--writeTcRef :: TcRef a -> a -> TcS ()-writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)--updTcRef :: TcRef a -> (a->a) -> TcS ()-updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)--getTcEvBindsVar :: TcS EvBindsVar-getTcEvBindsVar = TcS (return . tcs_ev_binds)--getTcLevel :: TcS TcLevel-getTcLevel = wrapTcS TcM.getTcLevel--getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet-getTcEvTyCoVars ev_binds_var-  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var--getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap-getTcEvBindsMap ev_binds_var-  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var--setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()-setTcEvBindsMap ev_binds_var binds-  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds--unifyTyVar :: TcTyVar -> TcType -> TcS ()--- Unify a meta-tyvar with a type--- We keep track of how many unifications have happened in tcs_unified,------ We should never unify the same variable twice!-unifyTyVar tv ty-  = ASSERT2( isMetaTyVar tv, ppr tv )-    TcS $ \ env ->-    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)-       ; TcM.writeMetaTyVar tv ty-       ; TcM.updTcRef (tcs_unified env) (+1) }--reportUnifications :: TcS a -> TcS (Int, a)-reportUnifications (TcS thing_inside)-  = TcS $ \ env ->-    do { inner_unified <- TcM.newTcRef 0-       ; res <- thing_inside (env { tcs_unified = inner_unified })-       ; n_unifs <- TcM.readTcRef inner_unified-       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)-       ; return (n_unifs, res) }--getDefaultInfo ::  TcS ([Type], (Bool, Bool))-getDefaultInfo = wrapTcS TcM.tcGetDefaultTys---- Just get some environments needed for instance looking up and matching--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--getInstEnvs :: TcS InstEnvs-getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs--getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)-getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs--getTopEnv :: TcS HscEnv-getTopEnv = wrapTcS $ TcM.getTopEnv--getGblEnv :: TcS TcGblEnv-getGblEnv = wrapTcS $ TcM.getGblEnv--getLclEnv :: TcS TcLclEnv-getLclEnv = wrapTcS $ TcM.getLclEnv--tcLookupClass :: Name -> TcS Class-tcLookupClass c = wrapTcS $ TcM.tcLookupClass c--tcLookupId :: Name -> TcS Id-tcLookupId n = wrapTcS $ TcM.tcLookupId n---- Setting names as used (used in the deriving of Coercible evidence)--- Too hackish to expose it to TcS? In that case somehow extract the used--- constructors from the result of solveInteract-addUsedGREs :: [GlobalRdrElt] -> TcS ()-addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres--addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()-addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre--keepAlive :: Name -> TcS ()-keepAlive = wrapTcS . TcM.keepAlive---- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()--- Check that we do not try to use an instance before it is available.  E.g.---    instance Eq T where ...---    f x = $( ... (\(p::T) -> p == p)... )--- Here we can't use the equality function from the instance in the splice--checkWellStagedDFun loc what pred-  | TopLevInstance { iw_dfun_id = dfun_id } <- what-  , let bind_lvl = TcM.topIdLvl dfun_id-  , bind_lvl > impLevel-  = wrapTcS $ TcM.setCtLocM loc $-    do { use_stage <- TcM.getStage-       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }--  | otherwise-  = return ()    -- Fast path for common case-  where-    pp_thing = text "instance for" <+> quotes (ppr pred)--pprEq :: TcType -> TcType -> SDoc-pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2--isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)-isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)--isFilledMetaTyVar :: TcTyVar -> TcS Bool-isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)--zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet-zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)--zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]-zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)--zonkCo :: Coercion -> TcS Coercion-zonkCo = wrapTcS . TcM.zonkCo--zonkTcType :: TcType -> TcS TcType-zonkTcType ty = wrapTcS (TcM.zonkTcType ty)--zonkTcTypes :: [TcType] -> TcS [TcType]-zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)--zonkTcTyVar :: TcTyVar -> TcS TcType-zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)--zonkSimples :: Cts -> TcS Cts-zonkSimples cts = wrapTcS (TcM.zonkSimples cts)--zonkWC :: WantedConstraints -> TcS WantedConstraints-zonkWC wc = wrapTcS (TcM.zonkWC wc)--zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar-zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)--{- *********************************************************************-*                                                                      *-*                Flatten skolems                                       *-*                                                                      *-********************************************************************* -}--newFlattenSkolem :: CtFlavour -> CtLoc-                 -> TyCon -> [TcType]                    -- F xis-                 -> TcS (CtEvidence, Coercion, TcTyVar)  -- [G/WD] x:: F xis ~ fsk-newFlattenSkolem flav loc tc xis-  = do { stuff@(ev, co, fsk) <- new_skolem-       ; let fsk_ty = mkTyVarTy fsk-       ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)-       ; return stuff }-  where-    fam_ty = mkTyConApp tc xis--    new_skolem-      | Given <- flav-      = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)--           -- Extend the inert_fsks list, for use by unflattenGivens-           ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is }--           -- Construct the Refl evidence-           ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)-                 co   = mkNomReflCo fam_ty-           ; ev  <- newGivenEvVar loc (pred, evCoercion co)-           ; return (ev, co, fsk) }--      | otherwise  -- Generate a [WD] for both Wanted and Derived-                   -- See Note [No Derived CFunEqCans]-      = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)-              -- See (2a) in "GHC.Tc.Solver.Canonical"-              -- Note [Equalities with incompatible kinds]-           ; (ev, hole_co) <- newWantedEq_SI NoBlockSubst WDeriv loc Nominal-                                             fam_ty (mkTyVarTy fmv)-           ; return (ev, hole_co, fmv) }-------------------------------unflattenGivens :: IORef InertSet -> TcM ()--- Unflatten all the fsks created by flattening types in Given--- constraints. We must be sure to do this, else we end up with--- flatten-skolems buried in any residual Wanteds------ NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)---     is filled in. Nothing else does so.------ It's here (rather than in GHC.Tc.Solver.Flatten) because the Right Places--- to call it are in runTcSWithEvBinds/nestImplicTcS, where it--- is nicely paired with the creation an empty inert_fsks list.-unflattenGivens inert_var- = do { inerts <- TcM.readTcRef inert_var-       ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))-       ; mapM_ flatten_one (inert_fsks inerts) }-  where-    flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty-------------------------------extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()-extendFlatCache tc xi_args stuff@(_, ty, fl)-  | isGivenOrWDeriv fl  -- Maintain the invariant that inert_flat_cache-                        -- only has [G] and [WD] CFunEqCans-  = do { dflags <- getDynFlags-       ; when (gopt Opt_FlatCache dflags) $-    do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args-                                          , ppr fl, ppr ty ])-            -- 'co' can be bottom, in the case of derived items-       ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->-            is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }--  | otherwise-  = return ()-------------------------------unflattenFmv :: TcTyVar -> TcType -> TcS ()--- Fill a flatten-meta-var, simply by unifying it.--- This does NOT count as a unification in tcs_unified.-unflattenFmv tv ty-  = ASSERT2( isMetaTyVar tv, ppr tv )-    TcS $ \ _ ->-    do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)-       ; TcM.writeMetaTyVar tv ty }-------------------------------demoteUnfilledFmv :: TcTyVar -> TcS ()--- If a flatten-meta-var is still un-filled,--- turn it into an ordinary meta-var-demoteUnfilledFmv fmv-  = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv-                 ; unless is_filled $-                   do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)-                      ; TcM.writeMetaTyVar fmv tv_ty } }--------------------------------dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()--- (dischargeFunEq tv co ty)---     Preconditions---       - ev :: F tys ~ tv   is a CFunEqCan---       - tv is a FlatMetaTv of FlatSkolTv---       - co :: F tys ~ xi---       - fmv/fsk `notElem` xi---       - fmv not filled (for Wanteds)---       - xi is flattened (and obeys Note [Almost function-free] in GHC.Tc.Types)------ Then for [W] or [WD], we actually fill in the fmv:---      set fmv := xi,---      set ev  := co---      kick out any inert things that are now rewritable------ For [D], we instead emit an equality that must ultimately hold---      [D] xi ~ fmv---      Does not evaluate 'co' if 'ev' is Derived------ For [G], emit this equality---     [G] (sym ev; co) :: fsk ~ xi---- See GHC.Tc.Solver.Flatten Note [The flattening story],--- especially "Ownership of fsk/fmv"-dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi-  = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co  )-       ; emitWorkNC [new_ev] }-  where-    new_pred = mkPrimEqPred (mkTyVarTy fsk) xi-    new_co   = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co--dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi-  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )-    do { setWantedEvTerm dest (evCoercion co)-       ; unflattenFmv fmv xi-       ; n_kicked <- kickOutAfterUnification fmv-       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }--dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi-  = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)-              -- FunEqs are always at Nominal role--pprKicked :: Int -> SDoc-pprKicked 0 = empty-pprKicked n = parens (int n <+> text "kicked out")--{- *********************************************************************-*                                                                      *-*                Instantiation etc.-*                                                                      *-********************************************************************* -}---- Instantiations--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)-instDFunType dfun_id inst_tys-  = wrapTcS $ TcM.instDFunType dfun_id inst_tys--newFlexiTcSTy :: Kind -> TcS TcType-newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)--cloneMetaTyVar :: TcTyVar -> TcS TcTyVar-cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)--instFlexi :: [TKVar] -> TcS TCvSubst-instFlexi = instFlexiX emptyTCvSubst--instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst-instFlexiX subst tvs-  = wrapTcS (foldlM instFlexiHelper subst tvs)--instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst-instFlexiHelper subst tv-  = do { uniq <- TcM.newUnique-       ; details <- TcM.newMetaDetails TauTv-       ; let name = setNameUnique (tyVarName tv) uniq-             kind = substTyUnchecked subst (tyVarKind tv)-             ty'  = mkTyVarTy (mkTcTyVar name kind details)-       ; TcM.traceTc "instFlexi" (ppr ty')-       ; return (extendTvSubst subst tv ty') }--matchGlobalInst :: DynFlags-                -> Bool      -- True <=> caller is the short-cut solver-                             -- See Note [Shortcut solving: overlap]-                -> Class -> [Type] -> TcS TcM.ClsInstResult-matchGlobalInst dflags short_cut cls tys-  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)--tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])-tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs---- Creating and setting evidence variables and CtFlavors--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--data MaybeNew = Fresh CtEvidence | Cached EvExpr--isFresh :: MaybeNew -> Bool-isFresh (Fresh {})  = True-isFresh (Cached {}) = False--freshGoals :: [MaybeNew] -> [CtEvidence]-freshGoals mns = [ ctev | Fresh ctev <- mns ]--getEvExpr :: MaybeNew -> EvExpr-getEvExpr (Fresh ctev) = ctEvExpr ctev-getEvExpr (Cached evt) = evt--setEvBind :: EvBind -> TcS ()-setEvBind ev_bind-  = do { evb <- getTcEvBindsVar-       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }---- | Mark variables as used filling a coercion hole-useVars :: CoVarSet -> TcS ()-useVars co_vars-  = do { ev_binds_var <- getTcEvBindsVar-       ; let ref = ebv_tcvs ev_binds_var-       ; wrapTcS $-         do { tcvs <- TcM.readTcRef ref-            ; let tcvs' = tcvs `unionVarSet` co_vars-            ; TcM.writeTcRef ref tcvs' } }---- | Equalities only-setWantedEq :: TcEvDest -> Coercion -> TcS ()-setWantedEq (HoleDest hole) co-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)---- | Good for both equalities and non-equalities-setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()-setWantedEvTerm (HoleDest hole) tm-  | Just co <- evTermCoercion_maybe tm-  = do { useVars (coVarsOfCo co)-       ; fillCoercionHole hole co }-  | otherwise-  = -- See Note [Yukky eq_sel for a HoleDest]-    do { let co_var = coHoleCoVar hole-       ; setEvBind (mkWantedEvBind co_var tm)-       ; fillCoercionHole hole (mkTcCoVarCo co_var) }--setWantedEvTerm (EvVarDest ev_id) tm-  = setEvBind (mkWantedEvBind ev_id tm)--{- Note [Yukky eq_sel for a HoleDest]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-How can it be that a Wanted with HoleDest gets evidence that isn't-just a coercion? i.e. evTermCoercion_maybe returns Nothing.--Consider [G] forall a. blah => a ~ T-         [W] S ~# T--Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~-T) in the quantified constraints, and wraps the (boxed) evidence it-gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put-that term into a coercion, so we add a value binding-    h = eq_sel (...)-and the coercion variable h to fill the coercion hole.-We even re-use the CoHole's Id for this binding!--Yuk!--}--fillCoercionHole :: CoercionHole -> Coercion -> TcS ()-fillCoercionHole hole co-  = do { wrapTcS $ TcM.fillCoercionHole hole co-       ; kickOutAfterFillingCoercionHole hole }--setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()-setEvBindIfWanted ev tm-  = case ev of-      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm-      _                             -> return ()--newTcEvBinds :: TcS EvBindsVar-newTcEvBinds = wrapTcS TcM.newTcEvBinds--newNoTcEvBinds :: TcS EvBindsVar-newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds--newEvVar :: TcPredType -> TcS EvVar-newEvVar pred = wrapTcS (TcM.newEvVar pred)--newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence--- Make a new variable of the given PredType,--- immediately bind it to the given term--- and return its CtEvidence--- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint-newGivenEvVar loc (pred, rhs)-  = do { new_ev <- newBoundEvVarId pred rhs-       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }---- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the--- given term-newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar-newBoundEvVarId pred rhs-  = do { new_ev <- newEvVar pred-       ; setEvBind (mkGivenEvBind new_ev rhs)-       ; return new_ev }--newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]-newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts--emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion--- | Emit a new Wanted equality into the work-list-emitNewWantedEq loc role ty1 ty2-  = do { (ev, co) <- newWantedEq loc role ty1 ty2-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))-       ; return co }---- | Make a new equality CtEvidence-newWantedEq :: CtLoc -> Role -> TcType -> TcType-            -> TcS (CtEvidence, Coercion)-newWantedEq = newWantedEq_SI YesBlockSubst WDeriv--newWantedEq_SI :: BlockSubstFlag -> ShadowInfo -> CtLoc -> Role-               -> TcType -> TcType-               -> TcS (CtEvidence, Coercion)-newWantedEq_SI blocker si loc role ty1 ty2-  = do { hole <- wrapTcS $ TcM.newCoercionHole blocker pty-       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)-       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole-                           , ctev_nosh = si-                           , ctev_loc = loc}-                , mkHoleCo hole ) }-  where-    pty = mkPrimEqPredRole role ty1 ty2---- no equalities here. Use newWantedEq instead-newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence-newWantedEvVarNC = newWantedEvVarNC_SI WDeriv--newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence--- Don't look up in the solved/inerts; we know it's not there-newWantedEvVarNC_SI si loc pty-  = do { new_ev <- newEvVar pty-       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$-                                         pprCtLoc loc)-       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev-                          , ctev_nosh = si-                          , ctev_loc = loc })}--newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew-newWantedEvVar = newWantedEvVar_SI WDeriv--newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew--- For anything except ClassPred, this is the same as newWantedEvVarNC-newWantedEvVar_SI si loc pty-  = do { mb_ct <- lookupInInerts loc pty-       ; case mb_ct of-            Just ctev-              | not (isDerived ctev)-              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev-                    ; return $ Cached (ctEvExpr ctev) }-            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty-                    ; return (Fresh ctev) } }--newWanted :: CtLoc -> PredType -> TcS MaybeNew--- Deals with both equalities and non equalities. Tries to look--- up non-equalities in the cache-newWanted = newWanted_SI WDeriv--newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew-newWanted_SI si loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = Fresh . fst <$> newWantedEq_SI YesBlockSubst si loc role ty1 ty2-  | otherwise-  = newWantedEvVar_SI si loc pty---- deals with both equalities and non equalities. Doesn't do any cache lookups.-newWantedNC :: CtLoc -> PredType -> TcS CtEvidence-newWantedNC loc pty-  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty-  = fst <$> newWantedEq loc role ty1 ty2-  | otherwise-  = newWantedEvVarNC loc pty--emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()-emitNewDeriveds loc preds-  | null preds-  = return ()-  | otherwise-  = do { evs <- mapM (newDerivedNC loc) preds-       ; traceTcS "Emitting new deriveds" (ppr evs)-       ; updWorkListTcS (extendWorkListDeriveds evs) }--emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()--- Create new equality Derived and put it in the work list--- There's no caching, no lookupInInerts-emitNewDerivedEq loc role ty1 ty2-  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)-       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)-       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }-         -- Very important: put in the wl_eqs-         -- See Note [Prioritise equalities] (Avoiding fundep iteration)--newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence-newDerivedNC loc pred-  = do { -- checkReductionDepth loc pred-       ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }---- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ------------ | Checks if the depth of the given location is too much. Fails if--- it's too big, with an appropriate error message.-checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced-                    -> TcS ()-checkReductionDepth loc ty-  = do { dflags <- getDynFlags-       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $-         wrapErrTcS $-         solverDepthErrorTcS loc ty }--matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: F tys ~N ty-matchFam tycon args = wrapTcS $ matchFamTcM tycon args--matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))--- Given (F tys) return (ty, co), where co :: F tys ~N ty-matchFamTcM tycon args-  = do { fam_envs <- FamInst.tcGetFamInstEnvs-       ; let match_fam_result-              = reduceTyFamApp_maybe fam_envs Nominal tycon args-       ; TcM.traceTc "matchFamTcM" $-         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)-              , ppr_res match_fam_result ]-       ; return match_fam_result }-  where-    ppr_res Nothing        = text "Match failed"-    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")-                                2 (vcat [ text "Rewrites to:" <+> ppr ty-                                        , text "Coercion:" <+> ppr co ])--{--Note [Residual implications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The wl_implics in the WorkList are the residual implication-constraints that are generated while solving or canonicalising the-current worklist.  Specifically, when canonicalising-   (forall a. t1 ~ forall a. t2)-from which we get the implication-   (forall a. t1 ~ t2)-See GHC.Tc.Solver.Monad.deferTcSForAllEq--}+{-# LANGUAGE CPP, DeriveFunctor, TypeFamilies, ScopedTypeVariables, TypeApplications,+             DerivingStrategies, GeneralizedNewtypeDeriving, ScopedTypeVariables, MultiWayIf, ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}++-- | Type definitions for the constraint solver+module GHC.Tc.Solver.Monad (++    -- The work list+    WorkList(..), isEmptyWorkList, emptyWorkList,+    extendWorkListNonEq, extendWorkListCt,+    extendWorkListCts, extendWorkListEq,+    appendWorkList,+    selectNextWorkItem,+    workListSize,+    getWorkList, updWorkListTcS, pushLevelNoWorkList,++    -- The TcS monad+    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds, runTcSInerts,+    failTcS, warnTcS, addErrTcS, wrapTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, setEvBindsTcS,+    emitImplicationTcS, emitTvImplicationTcS,++    runTcPluginTcS, addUsedGRE, addUsedGREs, keepAlive,+    matchGlobalInst, TcM.ClsInstResult(..),++    QCInst(..),++    -- Tracing etc+    panicTcS, traceTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,+    resetUnificationFlag, setUnificationFlag,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvExpr,++    newTcEvBinds, newNoTcEvBinds,+    newWantedEq, newWantedEq_SI, emitNewWantedEq,+    newWanted, newWanted_SI, newWantedEvVar,+    newWantedNC, newWantedEvVarNC,+    newDerivedNC,+    newBoundEvVarId,+    unifyTyVar, reportUnifications, touchabilityTest, TouchabilityTestResult(..),+    setEvBind, setWantedEq,+    setWantedEvTerm, setEvBindIfWanted,+    newEvVar, newGivenEvVar, newGivenEvVars,+    emitNewDeriveds, emitNewDerivedEq,+    checkReductionDepth,+    getSolvedDicts, setSolvedDicts,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv,+    getTcEvBindsVar, getTcLevel,+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+    tcLookupClass, tcLookupId,++    -- Inerts+    InertSet(..), InertCans(..), emptyInert,+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,+    getHasGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols, getInnermostGivenEqLevel,+    getTcSInerts, setTcSInerts,+    matchableGivens, prohibitedSuperClassSolve, mightEqualLater,+    getUnsolvedInerts,+    removeInertCts, getPendingGivenScs,+    addInertCan, insertFunEq, addInertForAll,+    emitWorkNC, emitWork,+    isImprovable,++    -- The Model+    kickOutAfterUnification,++    -- Inert Safe Haskell safe-overlap failures+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,+    getSafeOverlapFailures,++    -- Inert CDictCans+    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,++    -- Inert CEqCans+    EqualCtList(..), findTyEqs, foldTyEqs,+    findEq,++    -- Inert solved dictionaries+    addSolvedDict, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The family application cache+    lookupFamAppInert, lookupFamAppCache, extendFamAppCache,+    pprKicked,++    -- Inert function equalities+    findFunEq, findFunEqsByTyCon,++    instDFunType,                              -- Instantiation++    -- MetaTyVars+    newFlexiTcSTy, instFlexi, instFlexiX,+    cloneMetaTyVar,+    tcInstSkolTyVarsX,++    TcLevel,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,+    zonkTyCoVarKind,++    -- References+    newTcRef, readTcRef, writeTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellStagedDFun,+    pprEq,                                   -- Smaller utils, re-exported from TcM+                                             -- TODO (DV): these are only really used in the+                                             -- instance matcher in GHC.Tc.Solver. I am wondering+                                             -- if the whole instance matcher simply belongs+                                             -- here++    breakTyVarCycle_maybe, rewriterView+) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Env++import qualified GHC.Tc.Utils.Instantiate as TcM+import GHC.Core.InstEnv+import GHC.Tc.Instance.Family as FamInst+import GHC.Core.FamInstEnv++import qualified GHC.Tc.Utils.Monad    as TcM+import qualified GHC.Tc.Utils.TcMType  as TcM+import qualified GHC.Tc.Instance.Class as TcM( matchGlobalInst, ClsInstResult(..) )+import qualified GHC.Tc.Utils.Env      as TcM+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )+import GHC.Tc.Instance.Class( InstanceWhat(..), safeOverlap, instanceReturnsDictCon )+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Unify ( canSolveByUnification )+import GHC.Driver.Session+import GHC.Core.Type+import qualified GHC.Core.TyCo.Rep as Rep  -- this needs to be used only very locally+import GHC.Core.Coercion+import GHC.Core.Unify++import GHC.Tc.Types.Evidence+import GHC.Core.Class+import GHC.Core.TyCon+import GHC.Tc.Errors   ( solverDepthErrorTcS )++import GHC.Types.Name+import GHC.Types.TyThing+import GHC.Unit.Module ( HasModule, getModule )+import GHC.Types.Name.Reader ( GlobalRdrEnv, GlobalRdrElt )+import qualified GHC.Rename.Env as TcM+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Logger+import GHC.Data.Bag as Bag+import GHC.Types.Unique.Supply+import GHC.Utils.Misc+import GHC.Tc.Types+import GHC.Tc.Types.Origin+import GHC.Tc.Types.Constraint+import GHC.Core.Predicate++import GHC.Types.Unique.Set+import GHC.Core.TyCon.Env+import GHC.Data.Maybe++import GHC.Core.Map.Type+import GHC.Data.TrieMap++import Control.Monad+import GHC.Utils.Monad+import Data.IORef+import GHC.Exts (oneShot)+import Data.List ( partition, mapAccumL )+import Data.List.NonEmpty ( NonEmpty(..), cons, toList, nonEmpty )+import qualified Data.List.NonEmpty as NE+import Control.Arrow ( first )++#if defined(DEBUG)+import GHC.Data.Graph.Directed+#endif++{-+************************************************************************+*                                                                      *+*                            Worklists                                *+*  Canonical and non-canonical constraints that the simplifier has to  *+*  work on. Including their simplification depths.                     *+*                                                                      *+*                                                                      *+************************************************************************++Note [WorkList priorities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkList contains canonical and non-canonical items (of all flavours).+Notice that each Ct now has a simplification depth. We may+consider using this depth for prioritization as well in the future.++As a simple form of priority queue, our worklist separates out++* equalities (wl_eqs); see Note [Prioritise equalities]+* all the rest (wl_rest)++Note [Prioritise equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to process equalities /first/:++* (Efficiency)  The general reason to do so is that if we process a+  class constraint first, we may end up putting it into the inert set+  and then kicking it out later.  That's extra work compared to just+  doing the equality first.++* (Avoiding fundep iteration) As #14723 showed, it's possible to+  get non-termination if we+      - Emit the Derived fundep equalities for a class constraint,+        generating some fresh unification variables.+      - That leads to some unification+      - Which kicks out the class constraint+      - Which isn't solved (because there are still some more Derived+        equalities in the work-list), but generates yet more fundeps+  Solution: prioritise derived equalities over class constraints++* (Class equalities) We need to prioritise equalities even if they+  are hidden inside a class constraint;+  see Note [Prioritise class equalities]++* (Kick-out) We want to apply this priority scheme to kicked-out+  constraints too (see the call to extendWorkListCt in kick_out_rewritable+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become+  homo-kinded when kicked out, and hence we want to prioritise it.++* (Derived equalities) Originally we tried to postpone processing+  Derived equalities, in the hope that we might never need to deal+  with them at all; but in fact we must process Derived equalities+  eagerly, partly for the (Efficiency) reason, and more importantly+  for (Avoiding fundep iteration).++Note [Prioritise class equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prioritise equalities in the solver (see selectWorkItem). But class+constraints like (a ~ b) and (a ~~ b) are actually equalities too;+see Note [The equality types story] in GHC.Builtin.Types.Prim.++Failing to prioritise these is inefficient (more kick-outs etc).+But, worse, it can prevent us spotting a "recursive knot" among+Wanted constraints.  See comment:10 of #12734 for a worked-out+example.++So we arrange to put these particular class constraints in the wl_eqs.++  NB: since we do not currently apply the substitution to the+  inert_solved_dicts, the knot-tying still seems a bit fragile.+  But this makes it better.++-}++-- See Note [WorkList priorities]+data WorkList+  = WL { wl_eqs     :: [Ct]  -- CEqCan, CDictCan, CIrredCan+                             -- Given, Wanted, and Derived+                       -- Contains both equality constraints and their+                       -- class-level variants (a~b) and (a~~b);+                       -- See Note [Prioritise equalities]+                       -- See Note [Prioritise class equalities]++       , wl_rest    :: [Ct]++       , wl_implics :: Bag Implication  -- See Note [Residual implications]+    }++appendWorkList :: WorkList -> WorkList -> WorkList+appendWorkList+    (WL { wl_eqs = eqs1, wl_rest = rest1+        , wl_implics = implics1 })+    (WL { wl_eqs = eqs2, wl_rest = rest2+        , wl_implics = implics2 })+   = WL { wl_eqs     = eqs1     ++ eqs2+        , wl_rest    = rest1    ++ rest2+        , wl_implics = implics1 `unionBags`   implics2 }++workListSize :: WorkList -> Int+workListSize (WL { wl_eqs = eqs, wl_rest = rest })+  = length eqs + length rest++extendWorkListEq :: Ct -> WorkList -> WorkList+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }++extendWorkListNonEq :: Ct -> WorkList -> WorkList+-- Extension by non equality+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }++extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList+extendWorkListDeriveds evs wl+  = extendWorkListCts (map mkNonCanonical evs) wl++extendWorkListImplic :: Implication -> WorkList -> WorkList+extendWorkListImplic implic wl = wl { wl_implics = implic `consBag` wl_implics wl }++extendWorkListCt :: Ct -> WorkList -> WorkList+-- Agnostic+extendWorkListCt ct wl+ = case classifyPredType (ctPred ct) of+     EqPred {}+       -> extendWorkListEq ct wl++     ClassPred cls _  -- See Note [Prioritise class equalities]+       |  isEqPredClass cls+       -> extendWorkListEq ct wl++     _ -> extendWorkListNonEq ct wl++extendWorkListCts :: [Ct] -> WorkList -> WorkList+-- Agnostic+extendWorkListCts cts wl = foldr extendWorkListCt wl cts++isEmptyWorkList :: WorkList -> Bool+isEmptyWorkList (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })+  = null eqs && null rest && isEmptyBag implics++emptyWorkList :: WorkList+emptyWorkList = WL { wl_eqs  = [], wl_rest = [], wl_implics = emptyBag }++selectWorkItem :: WorkList -> Maybe (Ct, WorkList)+-- See Note [Prioritise equalities]+selectWorkItem wl@(WL { wl_eqs = eqs, wl_rest = rest })+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })+  | otherwise      = Nothing++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; wrapTcS (TcM.readTcRef wl_var) }++selectNextWorkItem :: TcS (Maybe Ct)+-- Pick which work item to do next+-- See Note [Prioritise equalities]+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl <- readTcRef wl_var+       ; case selectWorkItem wl of {+           Nothing -> return Nothing ;+           Just (ct, new_wl) ->+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)+         -- This is done by GHC.Tc.Solver.Interact.chooseInstance+       ; writeTcRef wl_var new_wl+       ; return (Just ct) } } }++-- Pretty printing+instance Outputable WorkList where+  ppr (WL { wl_eqs = eqs, wl_rest = rest, wl_implics = implics })+   = text "WL" <+> (braces $+     vcat [ ppUnless (null eqs) $+            text "Eqs =" <+> vcat (map ppr eqs)+          , ppUnless (null rest) $+            text "Non-eqs =" <+> vcat (map ppr rest)+          , ppUnless (isEmptyBag implics) $+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))+                       (text "(Implics omitted)")+          ])+++{- *********************************************************************+*                                                                      *+                InertSet: the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertSet+  = IS { inert_cans :: InertCans+              -- Canonical Given, Wanted, Derived+              -- Sometimes called "the inert set"++       , inert_cycle_breakers :: [(TcTyVar, TcType)]+              -- a list of CycleBreakerTv / original family applications+              -- used to undo the cycle-breaking needed to handle+              -- Note [Type variable cycles in Givens] in GHC.Tc.Solver.Canonical++       , inert_famapp_cache :: FunEqMap (TcCoercion, TcType)+              -- Just a hash-cons cache for use when reducing family applications+              -- only+              --+              -- If    F tys :-> (co, rhs, flav),+              -- then  co :: rhs ~N F tys+              -- all evidence is from instances or Givens; no coercion holes here+              -- (We have no way of "kicking out" from the cache, so putting+              --  wanteds here means we can end up solving a Wanted with itself. Bad)++       , inert_solved_dicts   :: DictMap CtEvidence+              -- All Wanteds, of form ev :: C t1 .. tn+              -- See Note [Solved dictionaries]+              -- and Note [Do not add superclasses of solved dictionaries]+       }++instance Outputable InertSet where+  ppr (IS { inert_cans = ics+          , inert_solved_dicts = solved_dicts })+      = vcat [ ppr ics+             , ppUnless (null dicts) $+               text "Solved dicts =" <+> vcat (map ppr dicts) ]+         where+           dicts = bagToList (dictsToBag solved_dicts)++emptyInertCans :: InertCans+emptyInertCans+  = IC { inert_eqs          = emptyDVarEnv+       , inert_given_eq_lvl = topTcLevel+       , inert_given_eqs    = False+       , inert_dicts        = emptyDicts+       , inert_safehask     = emptyDicts+       , inert_funeqs       = emptyFunEqs+       , inert_insts        = []+       , inert_irreds       = emptyCts+       , inert_blocked      = emptyCts }++emptyInert :: InertSet+emptyInert+  = IS { inert_cans           = emptyInertCans+       , inert_cycle_breakers = []+       , inert_famapp_cache   = emptyFunEqs+       , inert_solved_dicts   = emptyDictMap }+++{- Note [Solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we apply a top-level instance declaration, we add the "solved"+dictionary to the inert_solved_dicts.  In general, we use it to avoid+creating a new EvVar when we have a new goal that we have solved in+the past.++But in particular, we can use it to create *recursive* dictionaries.+The simplest, degenerate case is+    instance C [a] => C [a] where ...+If we have+    [W] d1 :: C [x]+then we can apply the instance to get+    d1 = $dfCList d+    [W] d2 :: C [x]+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.+    d1 = $dfCList d+    d2 = d1++See Note [Example of recursive dictionaries]++VERY IMPORTANT INVARIANT:++ (Solved Dictionary Invariant)+    Every member of the inert_solved_dicts is the result+    of applying an instance declaration that "takes a step"++    An instance "takes a step" if it has the form+        dfunDList d1 d2 = MkD (...) (...) (...)+    That is, the dfun is lazy in its arguments, and guarantees to+    immediately return a dictionary constructor.  NB: all dictionary+    data constructors are lazy in their arguments.++    This property is crucial to ensure that all dictionaries are+    non-bottom, which in turn ensures that the whole "recursive+    dictionary" idea works at all, even if we get something like+        rec { d = dfunDList d dx }+    See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance.++ Reason:+   - All instances, except two exceptions listed below, "take a step"+     in the above sense++   - Exception 1: local quantified constraints have no such guarantee;+     indeed, adding a "solved dictionary" when appling a quantified+     constraint led to the ability to define unsafeCoerce+     in #17267.++   - Exception 2: the magic built-in instance for (~) has no+     such guarantee.  It behaves as if we had+         class    (a ~# b) => (a ~ b) where {}+         instance (a ~# b) => (a ~ b) where {}+     The "dfun" for the instance is strict in the coercion.+     Anyway there's no point in recording a "solved dict" for+     (t1 ~ t2); it's not going to allow a recursive dictionary+     to be constructed.  Ditto (~~) and Coercible.++THEREFORE we only add a "solved dictionary"+  - when applying an instance declaration+  - subject to Exceptions 1 and 2 above++In implementation terms+  - GHC.Tc.Solver.Monad.addSolvedDict adds a new solved dictionary,+    conditional on the kind of instance++  - It is only called when applying an instance decl,+    in GHC.Tc.Solver.Interact.doTopReactDict++  - ClsInst.InstanceWhat says what kind of instance was+    used to solve the constraint.  In particular+      * LocalInstance identifies quantified constraints+      * BuiltinEqInstance identifies the strange built-in+        instances for equality.++  - ClsInst.instanceReturnsDictCon says which kind of+    instance guarantees to return a dictionary constructor++Other notes about solved dictionaries++* See also Note [Do not add superclasses of solved dictionaries]++* The inert_solved_dicts field is not rewritten by equalities,+  so it may get out of date.++* The inert_solved_dicts are all Wanteds, never givens++* We only cache dictionaries from top-level instances, not from+  local quantified constraints.  Reason: if we cached the latter+  we'd need to purge the cache when bringing new quantified+  constraints into scope, because quantified constraints "shadow"+  top-level instances.++Note [Do not add superclasses of solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every member of inert_solved_dicts is the result of applying a+dictionary function, NOT of applying superclass selection to anything.+Consider++        class Ord a => C a where+        instance Ord [a] => C [a] where ...++Suppose we are trying to solve+  [G] d1 : Ord a+  [W] d2 : C [a]++Then we'll use the instance decl to give++  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3+  [W] d3 : Ord [a]++We must not add d4 : Ord [a] to the 'solved' set (by taking the+superclass of d2), otherwise we'll use it to solve d3, without ever+using d1, which would be a catastrophe.++Solution: when extending the solved dictionaries, do not add superclasses.+That's why each element of the inert_solved_dicts is the result of applying+a dictionary function.++Note [Example of recursive dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--- Example 1++    data D r = ZeroD | SuccD (r (D r));++    instance (Eq (r (D r))) => Eq (D r) where+        ZeroD     == ZeroD     = True+        (SuccD a) == (SuccD b) = a == b+        _         == _         = False;++    equalDC :: D [] -> D [] -> Bool;+    equalDC = (==);++We need to prove (Eq (D [])). Here's how we go:++   [W] d1 : Eq (D [])+By instance decl of Eq (D r):+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2+By instance decl of Eq [a]:+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3+                                   d1 = dfEqD d2+Now this wanted can interact with our "solved" d1 to get:+    d3 = d1++-- Example 2:+This code arises in the context of "Scrap Your Boilerplate with Class"++    class Sat a+    class Data ctx a+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2++    class Data Maybe a => Foo a++    instance Foo t => Sat (Maybe t)                             -- dfunSat++    instance Data Maybe a => Foo a                              -- dfunFoo1+    instance Foo a        => Foo [a]                            -- dfunFoo2+    instance                 Foo [Char]                         -- dfunFoo3++Consider generating the superclasses of the instance declaration+         instance Foo a => Foo [a]++So our problem is this+    [G] d0 : Foo t+    [W] d1 : Data Maybe [t]   -- Desired superclass++We may add the given in the inert set, along with its superclasses+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  WorkList+    [W] d1 : Data Maybe [t]++Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+  WorkList:+    [W] d2 : Sat (Maybe [t])+    [W] d3 : Data Maybe t++Now, we may simplify d2 using dfunSat; d2 := dfunSat d4+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList:+    [W] d3 : Data Maybe t+    [W] d4 : Foo [t]++Now, we can just solve d3 from d01; d3 := d01+  Inert+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList+    [W] d4 : Foo [t]++Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5+  Inert+    [G] d0  : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+        d4 : Foo [t]+  WorkList:+    [W] d5 : Foo t++Now, d5 can be solved! d5 := d0++Result+   d1 := dfunData2 d2 d3+   d2 := dfunSat d4+   d3 := d01+   d4 := dfunFoo2 d5+   d5 := d0+-}++{- *********************************************************************+*                                                                      *+                InertCans: the canonical inerts+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertCans   -- See Note [Detailed InertCans Invariants] for more+  = IC { inert_eqs :: InertEqs+              -- See Note [inert_eqs: the inert equalities]+              -- All CEqCans with a TyVarLHS; index is the LHS tyvar+              -- Domain = skolems and untouchables; a touchable would be unified++       , inert_funeqs :: FunEqMap EqualCtList+              -- All CEqCans with a TyFamLHS; index is the whole family head type.+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)+              --     wrt inert_eqs+              -- Can include all flavours, [G], [W], [WD], [D]++       , inert_dicts :: DictMap Ct+              -- Dictionaries only+              -- All fully rewritten (modulo flavour constraints)+              --     wrt inert_eqs++       , inert_insts :: [QCInst]++       , inert_safehask :: DictMap Ct+              -- Failed dictionary resolution due to Safe Haskell overlapping+              -- instances restriction. We keep this separate from inert_dicts+              -- as it doesn't cause compilation failure, just safe inference+              -- failure.+              --+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]+              -- in "GHC.Tc.Solver"++       , inert_irreds :: Cts+              -- Irreducible predicates that cannot be made canonical,+              --     and which don't interact with others (e.g.  (c a))+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])++       , inert_blocked :: Cts+              -- Equality predicates blocked on a coercion hole.+              -- Each Ct is a CIrredCan with cc_reason = HoleBlockerReason+              -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+              -- wrinkle (2)+              -- These are stored separately from inert_irreds because+              -- they get kicked out for different reasons+++       , inert_given_eq_lvl :: TcLevel+              -- The TcLevel of the innermost implication that has a Given+              -- equality of the sort that make a unification variable untouchable+              -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).+              -- See Note [Tracking Given equalities] below++       , inert_given_eqs :: Bool+              -- True <=> The inert Givens *at this level* (tcl_tclvl)+              --          could includes at least one equality /other than/ a+              --          let-bound skolem equality.+              -- Reason: report these givens when reporting a failed equality+              -- See Note [Tracking Given equalities]+       }++type InertEqs    = DTyVarEnv EqualCtList++newtype EqualCtList = EqualCtList (NonEmpty Ct)+  deriving newtype Outputable+  -- See Note [EqualCtList invariants]++unitEqualCtList :: Ct -> EqualCtList+unitEqualCtList ct = EqualCtList (ct :| [])++addToEqualCtList :: Ct -> EqualCtList -> EqualCtList+-- NB: This function maintains the "derived-before-wanted" invariant of EqualCtList,+-- but not the others. See Note [EqualCtList invariants]+addToEqualCtList ct (EqualCtList old_eqs)+  | isWantedCt ct+  , eq1 :| eqs <- old_eqs+  = EqualCtList (eq1 :| ct : eqs)+  | otherwise+  = EqualCtList (ct `cons` old_eqs)++filterEqualCtList :: (Ct -> Bool) -> EqualCtList -> Maybe EqualCtList+filterEqualCtList pred (EqualCtList cts)+  = fmap EqualCtList (nonEmpty $ NE.filter pred cts)++equalCtListToList :: EqualCtList -> [Ct]+equalCtListToList (EqualCtList cts) = toList cts++listToEqualCtList :: [Ct] -> Maybe EqualCtList+-- NB: This does not maintain invariants other than having the EqualCtList be+-- non-empty+listToEqualCtList cts = EqualCtList <$> nonEmpty cts++{- Note [Tracking Given equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For reasons described in (UNTOUCHABLE) in GHC.Tc.Utils.Unify+Note [Unification preconditions], we can't unify+   alpha[2] ~ Int+under a level-4 implication if there are any Given equalities+bound by the implications at level 3 of 4.  To that end, the+InertCans tracks++  inert_given_eq_lvl :: TcLevel+     -- The TcLevel of the innermost implication that has a Given+     -- equality of the sort that make a unification variable untouchable+     -- (see Note [Unification preconditions] in GHC.Tc.Utils.Unify).++We update inert_given_eq_lvl whenever we add a Given to the+inert set, in updateGivenEqs.++Then a unification variable alpha[n] is untouchable iff+    n < inert_given_eq_lvl+that is, if the unification variable was born outside an+enclosing Given equality.++Exactly which constraints should trigger (UNTOUCHABLE), and hence+should update inert_given_eq_lvl?++* We do /not/ need to worry about let-bound skolems, such ast+     forall[2] a. a ~ [b] => blah+  See Note [Let-bound skolems]++* Consider an implication+      forall[2]. beta[1] => alpha[1] ~ Int+  where beta is a unification variable that has already been unified+  to () in an outer scope.  Then alpha[1] is perfectly touchable and+  we can unify alpha := Int. So when deciding whether the givens contain+  an equality, we should canonicalise first, rather than just looking at+  the /original/ givens (#8644).++ * However, we must take account of *potential* equalities. Consider the+   same example again, but this time we have /not/ yet unified beta:+      forall[2] beta[1] => ...blah...++   Because beta might turn into an equality, updateGivenEqs conservatively+   treats it as a potential equality, and updates inert_give_eq_lvl++ * What about something like forall[2] a b. a ~ F b => [W] alpha[1] ~ X y z?++   That Given cannot affect the Wanted, because the Given is entirely+   *local*: it mentions only skolems bound in the very same+   implication. Such equalities need not make alpha untouchable. (Test+   case typecheck/should_compile/LocalGivenEqs has a real-life+   motivating example, with some detailed commentary.)+   Hence the 'mentionsOuterVar' test in updateGivenEqs.++   However, solely to support better error messages+   (see Note [HasGivenEqs] in GHC.Tc.Types.Constraint) we also track+   these "local" equalities in the boolean inert_given_eqs field.+   This field is used only to set the ic_given_eqs field to LocalGivenEqs;+   see the function getHasGivenEqs.++   Here is a simpler case that triggers this behaviour:++     data T where+       MkT :: F a ~ G b => a -> b -> T++     f (MkT _ _) = True++   Because of this behaviour around local equality givens, we can infer the+   type of f. This is typecheck/should_compile/LocalGivenEqs2.++ * We need not look at the equality relation involved (nominal vs+   representational), because representational equalities can still+   imply nominal ones. For example, if (G a ~R G b) and G's argument's+   role is nominal, then we can deduce a ~N b.++Note [Let-bound skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+If   * the inert set contains a canonical Given CEqCan (a ~ ty)+and  * 'a' is a skolem bound in this very implication,++then:+a) The Given is pretty much a let-binding, like+      f :: (a ~ b->c) => a -> a+   Here the equality constraint is like saying+      let a = b->c in ...+   It is not adding any new, local equality  information,+   and hence can be ignored by has_given_eqs++b) 'a' will have been completely substituted out in the inert set,+   so we can safely discard it.++For an example, see #9211.++See also GHC.Tc.Utils.Unify Note [Deeper level on the left] for how we ensure+that the right variable is on the left of the equality when both are+tyvars.++You might wonder whether the skolem really needs to be bound "in the+very same implication" as the equuality constraint.+Consider this (c.f. #15009):++  data S a where+    MkS :: (a ~ Int) => S a++  g :: forall a. S a -> a -> blah+  g x y = let h = \z. ( z :: Int+                      , case x of+                           MkS -> [y,z])+          in ...++From the type signature for `g`, we get `y::a` .  Then when we+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the+body of the lambda we'll get++  [W] alpha[1] ~ Int                             -- From z::Int+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]++Now, unify alpha := a.  Now we are stuck with an unsolved alpha~Int!+So we must treat alpha as untouchable under the forall[2] implication.++Note [Detailed InertCans Invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The InertCans represents a collection of constraints with the following properties:++  * All canonical++  * No two dictionaries with the same head+  * No two CIrreds with the same type++  * Family equations inert wrt top-level family axioms++  * Dictionaries have no matching top-level instance++  * Given family or dictionary constraints don't mention touchable+    unification variables++  * Non-CEqCan constraints are fully rewritten with respect+    to the CEqCan equalities (modulo eqCanRewrite of course;+    eg a wanted cannot rewrite a given)++  * CEqCan equalities: see Note [inert_eqs: the inert equalities]+    Also see documentation in Constraint.Ct for a list of invariants++Note [EqualCtList invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    * All are equalities+    * All these equalities have the same LHS+    * The list is never empty+    * No element of the list can rewrite any other+    * Derived before Wanted++From the fourth invariant it follows that the list is+   - A single [G], or+   - Zero or one [D] or [WD], followed by any number of [W]++The Wanteds can't rewrite anything which is why we put them last++Note [inert_eqs: the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definition [Can-rewrite relation]+A "can-rewrite" relation between flavours, written f1 >= f2, is a+binary relation with the following properties++  (R1) >= is transitive+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1+  (See Note [Why R2?].)++Lemma (L0). If f1 >= f then f1 >= f1+Proof.      By property (R2), with f1=f2++Definition [Generalised substitution]+A "generalised substitution" S is a set of triples (lhs -f-> t), where+  lhs is a type variable or an exactly-saturated type family application+    (that is, lhs is a CanEqLHS)+  t is a type+  f is a flavour+such that+  (WF1) if (lhs1 -f1-> t1) in S+           (lhs2 -f2-> t2) in S+        then (f1 >= f2) implies that lhs1 does not appear within lhs2+  (WF2) if (lhs -f-> t) is in S, then t /= lhs++Definition [Applying a generalised substitution]+If S is a generalised substitution+   S(f,t0) = t,  if (t0 -fs-> t) in S, and fs >= f+           = apply S to components of t0, otherwise+See also Note [Flavours with roles].++Theorem: S(f,t0) is well defined as a function.+Proof: Suppose (lhs -f1-> t1) and (lhs -f2-> t2) are both in S,+               and  f1 >= f and f2 >= f+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)++Notation: repeated application.+  S^0(f,t)     = t+  S^(n+1)(f,t) = S(f, S^n(t))++Definition: terminating generalised substitution+A generalised substitution S is *terminating* iff++  (IG1) there is an n such that+        for every f,t, S^n(f,t) = S^(n+1)(f,t)++By (IG1) we define S*(f,t) to be the result of exahaustively+applying S(f,_) to t.++-----------------------------------------------------------------------------+Our main invariant:+   the CEqCans in inert_eqs should be a terminating generalised substitution+-----------------------------------------------------------------------------++Note that termination is not the same as idempotence.  To apply S to a+type, you may have to apply it recursively.  But termination does+guarantee that this recursive use will terminate.++Note [Why R2?]+~~~~~~~~~~~~~~+R2 states that, if we have f1 >= f and f2 >= f, then either f1 >= f2 or f2 >=+f1. If we do not have R2, we will easily fall into a loop.++To see why, imagine we have f1 >= f, f2 >= f, and that's it. Then, let our+inert set S = {a -f1-> b, b -f2-> a}. Computing S(f,a) does not terminate. And+yet, we have a hard time noticing an occurs-check problem when building S, as+the two equalities cannot rewrite one another.++R2 actually restricts our ability to accept user-written programs. See Note+[Deriveds do rewrite Deriveds] in GHC.Tc.Types.Constraint for an example.++Note [Rewritable]+~~~~~~~~~~~~~~~~~+This Note defines what it means for a type variable or type family application+(that is, a CanEqLHS) to be rewritable in a type. This definition is used+by the anyRewritableXXX family of functions and is meant to model the actual+behaviour in GHC.Tc.Solver.Rewrite.++Ignoring roles (for now): A CanEqLHS lhs is *rewritable* in a type t if the+lhs tree appears as a subtree within t without traversing any of the following+components of t:+  * coercions (whether they appear in casts CastTy or as arguments CoercionTy)+  * kinds of variable occurrences+The check for rewritability *does* look in kinds of the bound variable of a+ForAllTy.++Goal: If lhs is not rewritable in t, then t is a fixpoint of the generalised+substitution containing only {lhs -f*-> t'}, where f* is a flavour such that f* >= f+for all f.++The reason for this definition is that the rewriter does not rewrite in coercions+or variables' kinds. In turn, the rewriter does not need to rewrite there because+those places are never used for controlling the behaviour of the solver: these+places are not used in matching instances or in decomposing equalities.++There is one exception to the claim that non-rewritable parts of the tree do+not affect the solver: we sometimes do an occurs-check to decide e.g. how to+orient an equality. (See the comments on+GHC.Tc.Solver.Canonical.canEqTyVarFunEq.) Accordingly, the presence of a+variable in a kind or coercion just might influence the solver. Here is an+example:++  type family Const x y where+    Const x y = x++  AxConst :: forall x y. Const x y ~# x++  alpha :: Const Type Nat+  [W] alpha ~ Int |> (sym (AxConst Type alpha) ;;+                      AxConst Type alpha ;;+                      sym (AxConst Type Nat))++The cast is clearly ludicrous (it ties together a cast and its symmetric version),+but we can't quite rule it out. (See (EQ1) from+Note [Respecting definitional equality] in GHC.Core.TyCo.Rep to see why we need+the Const Type Nat bit.) And yet this cast will (quite rightly) prevent alpha+from unifying with the RHS. I (Richard E) don't have an example of where this+problem can arise from a Haskell program, but we don't have an air-tight argument+for why the definition of *rewritable* given here is correct.++Taking roles into account: we must consider a rewrite at a given role. That is,+a rewrite arises from some equality, and that equality has a role associated+with it. As we traverse a type, we track what role we are allowed to rewrite with.++For example, suppose we have an inert [G] b ~R# Int. Then b is rewritable in+Maybe b but not in F b, where F is a type function. This role-aware logic is+present in both the anyRewritableXXX functions and in the rewriter.+See also Note [anyRewritableTyVar must be role-aware] in GHC.Tc.Utils.TcType.++Note [Extending the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Main Theorem [Stability under extension]+   Suppose we have a "work item"+       lhs -fw-> t+   and a terminating generalised substitution S,+   THEN the extended substitution T = S+(lhs -fw-> t)+        is a terminating generalised substitution+   PROVIDED+      (T1) S(fw,lhs) = lhs   -- LHS of work-item is a fixpoint of S(fw,_)+      (T2) S(fw,t)   = t     -- RHS of work-item is a fixpoint of S(fw,_)+      (T3) lhs not in t      -- No occurs check in the work item+          -- If lhs is a type family application, we require only that+          -- lhs is not *rewritable* in t. See Note [Rewritable] and+          -- Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.++      AND, for every (lhs1 -fs-> s) in S:+           (K0) not (fw >= fs)+                Reason: suppose we kick out (lhs1 -fs-> s),+                        and add (lhs -fw-> t) to the inert set.+                        The latter can't rewrite the former,+                        so the kick-out achieved nothing++              -- From here, we can assume fw >= fs+           OR (K4) lhs1 is a tyvar AND fs >= fw++           OR { (K1) lhs is not rewritable in lhs1. See Note [Rewritable].+                     Reason: if fw >= fs, WF1 says we can't have both+                             lhs0 -fw-> t  and  F lhs0 -fs-> s++                AND (K2): guarantees termination of the new substitution+                    {  (K2a) not (fs >= fs)+                    OR (K2b) lhs not in s }++                AND (K3) See Note [K3: completeness of solving]+                    { (K3a) If the role of fs is nominal: s /= lhs+                      (K3b) If the role of fs is representational:+                            s is not of form (lhs t1 .. tn) } }+++Conditions (T1-T3) are established by the canonicaliser+Conditions (K1-K3) are established by GHC.Tc.Solver.Monad.kickOutRewritable++The idea is that+* T1 and T2 are guaranteed by exhaustively rewriting the work-item+  with S(fw,_).++* T3 is guaranteed by an occurs-check on the work item.+  This is done during canonicalisation, in checkTypeEq; invariant+  (TyEq:OC) of CEqCan. See also Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.++* (K1-3) are the "kick-out" criteria.  (As stated, they are really the+  "keep" criteria.) If the current inert S contains a triple that does+  not satisfy (K1-3), then we remove it from S by "kicking it out",+  and re-processing it.++* Note that kicking out is a Bad Thing, because it means we have to+  re-process a constraint.  The less we kick out, the better.+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed+  this but haven't done the empirical study to check.++* Assume we have  G>=G, G>=W and that's all.  Then, when performing+  a unification we add a new given  a -G-> ty.  But doing so does NOT require+  us to kick out an inert wanted that mentions a, because of (K2a).  This+  is a common case, hence good not to kick out. See also (K2a) below.++* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing+  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything+         and so K0 holds.  Intuitively, since fw can't rewrite anything (Lemma (L0)),+         adding it cannot cause any loops+  This is a common case, because Wanteds cannot rewrite Wanteds.+  It's used to avoid even looking for constraint to kick out.++* Lemma (L1): The conditions of the Main Theorem imply that there is no+              (lhs -fs-> t) in S, s.t.  (fs >= fw).+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),+  S(fw,lhs)=lhs.  But since fs>=fw, S(fw,lhs) = t, hence t=lhs.  But now we+  have (lhs -fs-> lhs) in S, which contradicts (WF2).++* The extended substitution satisfies (WF1) and (WF2)+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).+  - (T3) guarantees (WF2).++* (K2) and (K4) are about termination.  Intuitively, any infinite chain S^0(f,t),+  S^1(f,t), S^2(f,t).... must pass through the new work item infinitely+  often, since the substitution without the work item is terminating; and must+  pass through at least one of the triples in S infinitely often.++  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f)+    (this is Lemma (L0)), and hence this triple never plays a role in application S(f,t).+    It is always safe to extend S with such a triple.++    (NB: we could strengten K1) in this way too, but see K3.++  - (K2b): if lhs not in s, we have no further opportunity to apply the+    work item++  - (K4): See Note [K4]++* Lemma (L3). Suppose we have f* such that, for all f, f* >= f. Then+  if we are adding lhs -fw-> t (where T1, T2, and T3 hold), we will keep a -f*-> s.+  Proof. K4 holds; thus, we keep.++Key lemma to make it watertight.+  Under the conditions of the Main Theorem,+  forall f st fw >= f, a is not in S^k(f,t), for any k++Also, consider roles more carefully. See Note [Flavours with roles]++Note [K4]+~~~~~~~~~+K4 is a "keep" condition of Note [Extending the inert equalities].+Here is the scenario:++* We are considering adding (lhs -fw-> t) to the inert set S.+* S already has (lhs1 -fs-> s).+* We know S(fw, lhs) = lhs, S(fw, t) = t, and lhs is not rewritable in t.+  See Note [Rewritable]. These are (T1), (T2), and (T3).+* We further know fw >= fs. (If not, then we short-circuit via (K0).)++K4 says that we may keep lhs1 -fs-> s in S if:+  lhs1 is a tyvar AND fs >= fw++Why K4 guarantees termination:+  * If fs >= fw, we know a is not rewritable in t, because of (T2).+  * We further know lhs /= a, because of (T1).+  * Accordingly, a use of the new inert item lhs -fw-> t cannot create the conditions+    for a use of a -fs-> s (precisely because t does not mention a), and hence,+    the extended substitution (with lhs -fw-> t in it) is a terminating+    generalised substitution.++Recall that the termination generalised substitution includes only mappings that+pass an occurs check. This is (T3). At one point, we worried that the+argument here would fail if s mentioned a, but (T3) rules out this possibility.+Put another way: the terminating generalised substitution considers only the inert_eqs,+not other parts of the inert set (such as the irreds).++Can we liberalise K4? No.++Why we cannot drop the (fs >= fw) condition:+  * Suppose not (fs >= fw). It might be the case that t mentions a, and this+    can cause a loop. Example:++      Work:  [G] b ~ a+      Inert: [D] a ~ b++    (where G >= G, G >= D, and D >= D)+    If we don't kick out the inert, then we get a loop on e.g. [D] a ~ Int.++  * Note that the above example is different if the inert is a Given G, because+    (T1) won't hold.++Why we cannot drop the tyvar condition:+  * Presume fs >= fw. Thus, F tys is not rewritable in t, because of (T2).+  * Can the use of lhs -fw-> t create the conditions for a use of F tys -fs-> s?+    Yes! This can happen if t appears within tys.++    Here is an example:++      Work:  [G] a ~ Int+      Inert: [G] F Int ~ F a++    Now, if we have [W] F a ~ Bool, we will rewrite ad infinitum on the left-hand+    side. The key reason why K2b works in the tyvar case is that tyvars are atomic:+    if the right-hand side of an equality does not mention a variable a, then it+    cannot allow an equality with an LHS of a to fire. This is not the case for+    type family applications.++Bottom line: K4 can keep only inerts with tyvars on the left. Put differently,+K4 will never prevent an inert with a type family on the left from being kicked+out.++Consequence: We never kick out a Given/Nominal equality with a tyvar on the left.+This is Lemma (L3) of Note [Extending the inert equalities]. It is good because+it means we can effectively model the mutable filling of metavariables with+Given/Nominal equalities. That is: it should be the case that we could rewrite+our solver never to fill in a metavariable; instead, it would "solve" a wanted+like alpha ~ Int by turning it into a Given, allowing it to be used in rewriting.+We would want the solver to behave the same whether it uses metavariables or+Givens. And (L3) says that no Given/Nominals over tyvars are ever kicked out,+just like we never unfill a metavariable. Nice.++Getting this wrong (that is, allowing K4 to apply to situations with the type+family on the left) led to #19042. (At that point, K4 was known as K2b.)++Originally, this condition was part of K2, but #17672 suggests it should be+a top-level K condition.++Note [K3: completeness of solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(K3) is not necessary for the extended substitution+to be terminating.  In fact K1 could be made stronger by saying+   ... then (not (fw >= fs) or not (fs >= fs))+But it's not enough for S to be terminating; we also want completeness.+That is, we want to be able to solve all soluble wanted equalities.+Suppose we have++   work-item   b -G-> a+   inert-item  a -W-> b++Assuming (G >= W) but not (W >= W), this fulfills all the conditions,+so we could extend the inerts, thus:++   inert-items   b -G-> a+                 a -W-> b++But if we kicked-out the inert item, we'd get++   work-item     a -W-> b+   inert-item    b -G-> a++Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.+So we add one more clause to the kick-out criteria++Another way to understand (K3) is that we treat an inert item+        a -f-> b+in the same way as+        b -f-> a+So if we kick out one, we should kick out the other.  The orientation+is somewhat accidental.++When considering roles, we also need the second clause (K3b). Consider++  work-item    c -G/N-> a+  inert-item   a -W/R-> b c++The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.+But we don't kick out the inert item because not (W/R >= W/R).  So we just+add the work item. But then, consider if we hit the following:++  work-item    b -G/N-> Id+  inert-items  a -W/R-> b c+               c -G/N-> a+where+  newtype Id x = Id x++For similar reasons, if we only had (K3a), we wouldn't kick the+representational inert out. And then, we'd miss solving the inert, which+now reduced to reflexivity.++The solution here is to kick out representational inerts whenever the+lhs of a work item is "exposed", where exposed means being at the+head of the top-level application chain (lhs t1 .. tn).  See+is_can_eq_lhs_head. This is encoded in (K3b).++Beware: if we make this test succeed too often, we kick out too much,+and the solver might loop.  Consider (#14363)+  work item:   [G] a ~R f b+  inert item:  [G] b ~R f a+In GHC 8.2 the completeness tests more aggressive, and kicked out+the inert item; but no rewriting happened and there was an infinite+loop.  All we need is to have the tyvar at the head.++Note [Flavours with roles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The system described in Note [inert_eqs: the inert equalities]+discusses an abstract+set of flavours. In GHC, flavours have two components: the flavour proper,+taken from {Wanted, Derived, Given} and the equality relation (often called+role), taken from {NomEq, ReprEq}.+When substituting w.r.t. the inert set,+as described in Note [inert_eqs: the inert equalities],+we must be careful to respect all components of a flavour.+For example, if we have++  inert set: a -G/R-> Int+             b -G/R-> Bool++  type role T nominal representational++and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT+T Int Bool. The reason is that T's first parameter has a nominal role, and+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of+substitution means that the proof in Note [The inert equalities] may need+to be revisited, but we don't think that the end conclusion is wrong.+-}++instance Outputable InertCans where+  ppr (IC { inert_eqs = eqs+          , inert_funeqs = funeqs+          , inert_dicts = dicts+          , inert_safehask = safehask+          , inert_irreds = irreds+          , inert_blocked = blocked+          , inert_given_eq_lvl = ge_lvl+          , inert_given_eqs = given_eqs+          , inert_insts = insts })++    = braces $ vcat+      [ ppUnless (isEmptyDVarEnv eqs) $+        text "Equalities:"+          <+> pprCts (foldDVarEnv folder emptyCts eqs)+      , ppUnless (isEmptyTcAppMap funeqs) $+        text "Type-function equalities =" <+> pprCts (foldFunEqs folder funeqs emptyCts)+      , ppUnless (isEmptyTcAppMap dicts) $+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)+      , ppUnless (isEmptyTcAppMap safehask) $+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)+      , ppUnless (isEmptyCts irreds) $+        text "Irreds =" <+> pprCts irreds+      , ppUnless (isEmptyCts blocked) $+        text "Blocked =" <+> pprCts blocked+      , ppUnless (null insts) $+        text "Given instances =" <+> vcat (map ppr insts)+      , text "Innermost given equalities =" <+> ppr ge_lvl+      , text "Given eqs at this level =" <+> ppr given_eqs+      ]+    where+      folder (EqualCtList eqs) rest = nonEmptyToBag eqs `andCts` rest++{- *********************************************************************+*                                                                      *+             Shadow constraints and improvement+*                                                                      *+************************************************************************++Note [The improvement story and derived shadows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not+rewrite Wanteds] in GHC.Tc.Types.Constraint), we may miss some opportunities for+solving.  Here's a classic example (indexed-types/should_fail/T4093a)++    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e++    We get [G] Foo e ~ Maybe e    (CEqCan)+           [W] Foo ee ~ Foo e     (CEqCan)       -- ee is a unification variable+           [W] Foo ee ~ Maybe ee  (CEqCan)++    The first Wanted gets rewritten to++           [W] Foo ee ~ Maybe e++    But now we appear to be stuck, since we don't rewrite Wanteds with+    Wanteds.  This is silly because we can see that ee := e is the+    only solution.++The basic plan is+  * generate Derived constraints that shadow Wanted constraints+  * allow Derived to rewrite Derived+  * in order to cause some unifications to take place+  * that in turn solve the original Wanteds++The ONLY reason for all these Derived equalities is to tell us how to+unify a variable: that is, what Mark Jones calls "improvement".++The same idea is sometimes also called "saturation"; find all the+equalities that must hold in any solution.++Or, equivalently, you can think of the derived shadows as implementing+the "model": a non-idempotent but no-occurs-check substitution,+reflecting *all* *Nominal* equalities (a ~N ty) that are not+immediately soluble by unification.++More specifically, here's how it works (Oct 16):++* Wanted constraints are born as [WD]; this behaves like a+  [W] and a [D] paired together.++* When we are about to add a [WD] to the inert set, if it can+  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],+  putting the latter into the work list (see maybeEmitShadow).++In the example above, we get to the point where we are stuck:+    [WD] Foo ee ~ Foo e+    [WD] Foo ee ~ Maybe ee++But now when [WD] Foo ee ~ Maybe ee is about to be added, we'll+split it into [W] and [D], since the inert [WD] Foo ee ~ Foo e+can rewrite it.  Then:+    work item: [D] Foo ee ~ Maybe ee+    inert:     [W] Foo ee ~ Maybe ee+               [WD] Foo ee ~ Maybe e++See Note [Splitting WD constraints].  Now the work item is rewritten+by the [WD] and we soon get ee := e.++Additional notes:++  * The derived shadow equalities live in inert_eqs, along with+    the Givens and Wanteds; see Note [EqualCtList invariants].++  * We make Derived shadows only for Wanteds, not Givens.  So we+    have only [G], not [GD] and [G] plus splitting.  See+    Note [Add derived shadows only for Wanteds]++  * We also get Derived equalities from functional dependencies+    and type-function injectivity; see calls to unifyDerived.++  * It's worth having [WD] rather than just [W] and [D] because+    * efficiency: silly to process the same thing twice+    * inert_dicts is a finite map keyed by+      the type; it's inconvenient for it to map to TWO constraints++Another example requiring Deriveds is in+Note [Put touchable variables on the left] in GHC.Tc.Solver.Canonical.++Note [Splitting WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are about to add a [WD] constraint to the inert set; and we+know that the inert set has fully rewritten it.  Should we split+it into [W] and [D], and put the [D] in the work list for further+work?++* CDictCan (C tys):+  Yes if the inert set could rewrite tys to make the class constraint,+  or type family, fire.  That is, yes if the inert_eqs intersects+  with the free vars of tys.  For this test we use+  (anyRewritableTyVar True) which ignores casts and coercions in tys,+  because rewriting the casts or coercions won't make the thing fire+  more often.++* CEqCan (lhs ~ ty): Yes if the inert set could rewrite 'lhs' or 'ty'.+  We need to check both 'lhs' and 'ty' against the inert set:+    - Inert set contains  [D] a ~ ty2+      Then we want to put [D] a ~ ty in the worklist, so we'll+      get [D] ty ~ ty2 with consequent good things++    - Inert set contains [D] b ~ a, where b is in ty.+      We can't just add [WD] a ~ ty[b] to the inert set, because+      that breaks the inert-set invariants.  If we tried to+      canonicalise another [D] constraint mentioning 'a', we'd+      get an infinite loop++  Moreover we must use (anyRewritableTyVar False) for the RHS,+  because even tyvars in the casts and coercions could give+  an infinite loop if we don't expose it++* CIrredCan: Yes if the inert set can rewrite the constraint.+  We used to think splitting irreds was unnecessary, but+  see Note [Splitting Irred WD constraints]++* Others: nothing is gained by splitting.++Note [Splitting Irred WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Splitting Irred constraints can make a difference. Here is the+scenario:++  a[sk] :: F v     -- F is a type family+  beta :: alpha++  work item: [WD] a ~ beta++This is heterogeneous, so we emit a kind equality and make the work item an+inert Irred.++  work item: [D] F v ~ alpha+  inert: [WD] (a |> co) ~ beta (CIrredCan)++Can't make progress on the work item. Add to inert set. This kicks out the+old inert, because a [D] can rewrite a [WD].++  work item: [WD] (a |> co) ~ beta+  inert: [D] F v ~ alpha (CEqCan)++Can't make progress on this work item either (although GHC tries by+decomposing the cast and rewriting... but that doesn't make a difference),+which is still hetero. Emit a new kind equality and add to inert set. But,+critically, we split the Irred.++  work list:+   [D] F v ~ alpha (CEqCan)+   [D] (a |> co) ~ beta (CIrred) -- this one was split off+  inert:+   [W] (a |> co) ~ beta+   [D] F v ~ alpha++We quickly solve the first work item, as it's the same as an inert.++  work item: [D] (a |> co) ~ beta+  inert:+   [W] (a |> co) ~ beta+   [D] F v ~ alpha++We decompose the cast, yielding++  [D] a ~ beta++We then rewrite the kinds. The lhs kind is F v, which flattens to alpha.++  co' :: F v ~ alpha+  [D] (a |> co') ~ beta++Now this equality is homo-kinded. So we swizzle it around to++  [D] beta ~ (a |> co')++and set beta := a |> co', and go home happy.++If we don't split the Irreds, we loop. This is all dangerously subtle.++This is triggered by test case typecheck/should_compile/SplitWD.++Note [Add derived shadows only for Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only add shadows for Wanted constraints. That is, we have+[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]+constraints.++It does just possibly make sense ot add a derived shadow for a+Given. If we created a Derived shadow of a Given, it could be+rewritten by other Deriveds, and that could, conceivably, lead to a+useful unification.++But (a) I have been unable to come up with an example of this+        happening+    (b) see #12660 for how adding the derived shadows+        of a Given led to an infinite loop.+    (c) It's unlikely that rewriting derived Givens will lead+        to a unification because Givens don't mention touchable+        unification variables++For (b) there may be other ways to solve the loop, but simply+reraining from adding derived shadows of Givens is particularly+simple.  And it's more efficient too!++Still, here's one possible reason for adding derived shadows+for Givens.  Consider+           work-item [G] a ~ [b], inerts has [D] b ~ a.+If we added the derived shadow (into the work list)+         [D] a ~ [b]+When we process it, we'll rewrite to a ~ [a] and get an+occurs check.  Without it we'll miss the occurs check (reporting+inaccessible code); but that's probably OK.++Note [Keep CDictCan shadows as CDictCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class C a => D a b+and [G] D a b, [G] C a in the inert set.  Now we insert+[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,+so we can rewrite it with the new constraint, and perhaps get+instance reduction or other consequences.++BUT we do not want to kick out a *non-canonical* (D a b). If we+did, we would do this:+  - rewrite it to [D] D a c, with pend_sc = True+  - use expandSuperClasses to add C a+  - go round again, which solves C a from the givens+This loop goes on for ever and triggers the simpl_loop limit.++Solution: kick out the CDictCan which will have pend_sc = False,+because we've already added its superclasses.  So we won't re-add+them.  If we forget the pend_sc flag, our cunning scheme for avoiding+generating superclasses repeatedly will fail.++See #11379 for a case of this.++Note [Do not do improvement for WOnly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do improvement between two constraints (e.g. for injectivity+or functional dependencies) only if both are "improvable". And+we improve a constraint wrt the top-level instances only if+it is improvable.++Improvable:     [G] [WD] [D}+Not improvable: [W]++Reasons:++* It's less work: fewer pairs to compare++* Every [W] has a shadow [D] so nothing is lost++* Consider [WD] C Int b,  where 'b' is a skolem, and+    class C a b | a -> b+    instance C Int Bool+  We'll do a fundep on it and emit [D] b ~ Bool+  That will kick out constraint [WD] C Int b+  Then we'll split it to [W] C Int b (keep in inert)+                     and [D] C Int b (in work list)+  When processing the latter we'll rewrite it to+        [D] C Int Bool+  At that point it would be /stupid/ to interact it+  with the inert [W] C Int b in the inert set; after all,+  it's the very constraint from which the [D] C Int Bool+  was split!  We can avoid this by not doing improvement+  on [W] constraints. This came up in #12860.+-}++maybeEmitShadow :: InertCans -> Ct -> TcS Ct+-- See Note [The improvement story and derived shadows]+maybeEmitShadow ics ct+  | let ev = ctEvidence ct+  , CtWanted { ctev_pred = pred, ctev_loc = loc+             , ctev_nosh = WDeriv } <- ev+  , shouldSplitWD (inert_eqs ics) (inert_funeqs ics) ct+  = do { traceTcS "Emit derived shadow" (ppr ct)+       ; let derived_ev = CtDerived { ctev_pred = pred+                                    , ctev_loc  = loc }+             shadow_ct = ct { cc_ev = derived_ev }+               -- Te shadow constraint keeps the canonical shape.+               -- This just saves work, but is sometimes important;+               -- see Note [Keep CDictCan shadows as CDictCan]+       ; emitWork [shadow_ct]++       ; let ev' = ev { ctev_nosh = WOnly }+             ct' = ct { cc_ev = ev' }+                 -- Record that it now has a shadow+                 -- This is /the/ place we set the flag to WOnly+       ; return ct' }++  | otherwise+  = return ct++shouldSplitWD :: InertEqs -> FunEqMap EqualCtList -> Ct -> Bool+-- Precondition: 'ct' is [WD], and is inert+-- True <=> we should split ct ito [W] and [D] because+--          the inert_eqs can make progress on the [D]+-- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs fun_eqs (CDictCan { cc_tyargs = tys })+  = should_split_match_args inert_eqs fun_eqs tys+    -- NB True: ignore coercions+    -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_lhs = TyVarLHS tv, cc_rhs = ty+                                        , cc_eq_rel = eq_rel })+  =  tv `elemDVarEnv` inert_eqs+  || anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs) ty+  -- NB False: do not ignore casts and coercions+  -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs fun_eqs (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })+  = anyRewritableCanEqLHS eq_rel (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)+                          (ctEvPred ev)++shouldSplitWD inert_eqs fun_eqs (CIrredCan { cc_ev = ev })+  = anyRewritableCanEqLHS (ctEvEqRel ev) (canRewriteTv inert_eqs)+                          (canRewriteTyFam fun_eqs) (ctEvPred ev)++shouldSplitWD _ _ _ = False   -- No point in splitting otherwise++should_split_match_args :: InertEqs -> FunEqMap EqualCtList -> [TcType] -> Bool+-- True if the inert_eqs can rewrite anything in the argument types+should_split_match_args inert_eqs fun_eqs tys+  = any (anyRewritableCanEqLHS NomEq (canRewriteTv inert_eqs) (canRewriteTyFam fun_eqs)) tys+    -- See Note [Splitting WD constraints]++canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool+canRewriteTv inert_eqs eq_rel tv+  | Just (EqualCtList (ct :| _)) <- lookupDVarEnv inert_eqs tv+  , CEqCan { cc_eq_rel = eq_rel1 } <- ct+  = eq_rel1 `eqCanRewrite` eq_rel+  | otherwise+  = False++canRewriteTyFam :: FunEqMap EqualCtList -> EqRel -> TyCon -> [Type] -> Bool+canRewriteTyFam fun_eqs eq_rel tf args+  | Just (EqualCtList (ct :| _)) <- findFunEq fun_eqs tf args+  , CEqCan { cc_eq_rel = eq_rel1 } <- ct+  = eq_rel1 `eqCanRewrite` eq_rel+  | otherwise+  = False++isImprovable :: CtEvidence -> Bool+-- See Note [Do not do improvement for WOnly]+isImprovable (CtWanted { ctev_nosh = WOnly }) = False+isImprovable _                                = True+++{- *********************************************************************+*                                                                      *+                   Inert equalities+*                                                                      *+********************************************************************* -}++addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs+addTyEq old_eqs tv ct+  = extendDVarEnv_C add_eq old_eqs tv (unitEqualCtList ct)+  where+    add_eq old_eqs _ = addToEqualCtList ct old_eqs++addCanFunEq :: FunEqMap EqualCtList -> TyCon -> [TcType] -> Ct+            -> FunEqMap EqualCtList+addCanFunEq old_eqs fun_tc fun_args ct+  = alterTcApp old_eqs fun_tc fun_args upd+  where+    upd (Just old_equal_ct_list) = Just $ addToEqualCtList ct old_equal_ct_list+    upd Nothing                  = Just $ unitEqualCtList ct++foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b+foldTyEqs k eqs z+  = foldDVarEnv (\(EqualCtList cts) z -> foldr k z cts) z eqs++findTyEqs :: InertCans -> TyVar -> [Ct]+findTyEqs icans tv = maybe [] id (fmap @Maybe equalCtListToList $+                                  lookupDVarEnv (inert_eqs icans) tv)++delEq :: InertCans -> CanEqLHS -> TcType -> InertCans+delEq ic lhs rhs = case lhs of+    TyVarLHS tv+      -> ic { inert_eqs = alterDVarEnv upd (inert_eqs ic) tv }+    TyFamLHS tf args+      -> ic { inert_funeqs = alterTcApp (inert_funeqs ic) tf args upd }+  where+    isThisOne :: Ct -> Bool+    isThisOne (CEqCan { cc_rhs = t1 }) = tcEqTypeNoKindCheck rhs t1+    isThisOne other = pprPanic "delEq" (ppr lhs $$ ppr ic $$ ppr other)++    upd :: Maybe EqualCtList -> Maybe EqualCtList+    upd (Just eq_ct_list) = filterEqualCtList (not . isThisOne) eq_ct_list+    upd Nothing           = Nothing++findEq :: InertCans -> CanEqLHS -> [Ct]+findEq icans (TyVarLHS tv) = findTyEqs icans tv+findEq icans (TyFamLHS fun_tc fun_args)+  = maybe [] id (fmap @Maybe equalCtListToList $+                 findFunEq (inert_funeqs icans) fun_tc fun_args)++{- *********************************************************************+*                                                                      *+                   Inert instances: inert_insts+*                                                                      *+********************************************************************* -}++addInertForAll :: QCInst -> TcS ()+-- Add a local Given instance, typically arising from a type signature+addInertForAll new_qci+  = do { ics  <- getInertCans+       ; ics1 <- add_qci ics++       -- Update given equalities. C.f updateGivenEqs+       ; tclvl <- getTcLevel+       ; let pred         = qci_pred new_qci+             not_equality = isClassPred pred && not (isEqPred pred)+                  -- True <=> definitely not an equality+                  -- A qci_pred like (f a) might be an equality++             ics2 | not_equality = ics1+                  | otherwise    = ics1 { inert_given_eq_lvl = tclvl+                                        , inert_given_eqs    = True }++       ; setInertCans ics2 }+  where+    add_qci :: InertCans -> TcS InertCans+    -- See Note [Do not add duplicate quantified instances]+    add_qci ics@(IC { inert_insts = qcis })+      | any same_qci qcis+      = do { traceTcS "skipping duplicate quantified instance" (ppr new_qci)+           ; return ics }++      | otherwise+      = do { traceTcS "adding new inert quantified instance" (ppr new_qci)+           ; return (ics { inert_insts = new_qci : qcis }) }++    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))+                                (ctEvPred (qci_ev new_qci))++{- Note [Do not add duplicate quantified instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15244):++  f :: (C g, D g) => ....+  class S g => C g where ...+  class S g => D g where ...+  class (forall a. Eq a => Eq (g a)) => S g where ...++Then in f's RHS there are two identical quantified constraints+available, one via the superclasses of C and one via the superclasses+of D.  The two are identical, and it seems wrong to reject the program+because of that. But without doing duplicate-elimination we will have+two matching QCInsts when we try to solve constraints arising from f's+RHS.++The simplest thing is simply to eliminate duplicates, which we do here.+-}++{- *********************************************************************+*                                                                      *+                  Adding an inert+*                                                                      *+************************************************************************++Note [Adding an equality to the InertCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding an equality to the inerts:++* Split [WD] into [W] and [D] if the inerts can rewrite the latter;+  done by maybeEmitShadow.++* Kick out any constraints that can be rewritten by the thing+  we are adding.  Done by kickOutRewritable.++* Note that unifying a:=ty, is like adding [G] a~ty; just use+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.+-}++addInertCan :: Ct -> TcS ()+-- Precondition: item /is/ canonical+-- See Note [Adding an equality to the InertCans]+addInertCan ct+  = do { traceTcS "addInertCan {" $+         text "Trying to insert new inert item:" <+> ppr ct++       ; ics <- getInertCans+       ; ct  <- maybeEmitShadow ics ct+       ; ics <- maybeKickOut ics ct+       ; tclvl <- getTcLevel+       ; setInertCans (add_item tclvl ics ct)++       ; traceTcS "addInertCan }" $ empty }++maybeKickOut :: InertCans -> Ct -> TcS InertCans+-- For a CEqCan, kick out any inert that can be rewritten by the CEqCan+maybeKickOut ics ct+  | CEqCan { cc_lhs = lhs, cc_ev = ev, cc_eq_rel = eq_rel } <- ct+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) lhs ics+       ; return ics' }+  | otherwise+  = return ics++add_item :: TcLevel -> InertCans -> Ct -> InertCans+add_item tc_lvl+         ics@(IC { inert_funeqs = funeqs, inert_eqs = eqs })+         item@(CEqCan { cc_lhs = lhs })+  = updateGivenEqs tc_lvl item $+    case lhs of+       TyFamLHS tc tys -> ics { inert_funeqs = addCanFunEq funeqs tc tys item }+       TyVarLHS tv     -> ics { inert_eqs    = addTyEq eqs tv item }++add_item tc_lvl ics@(IC { inert_blocked = blocked })+         item@(CIrredCan { cc_reason = HoleBlockerReason {}})+  = updateGivenEqs tc_lvl item $  -- this item is always an equality+    ics { inert_blocked = blocked `snocBag` item }++add_item tc_lvl ics@(IC { inert_irreds = irreds }) item@(CIrredCan {})+  = updateGivenEqs tc_lvl item $   -- An Irred might turn out to be an+                                 -- equality, so we play safe+    ics { inert_irreds = irreds `Bag.snocBag` item }++add_item _ ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_dicts = addDictCt (inert_dicts ics) cls tys item }++add_item _ _ item+  = pprPanic "upd_inert set: can't happen! Inserting " $+    ppr item   -- Can't be CNonCanonical because they only land in inert_irreds++updateGivenEqs :: TcLevel -> Ct -> InertCans -> InertCans+-- Set the inert_given_eq_level to the current level (tclvl)+-- if the constraint is a given equality that should prevent+-- filling in an outer unification variable.+-- See See Note [Tracking Given equalities]+updateGivenEqs tclvl ct inerts@(IC { inert_given_eq_lvl = ge_lvl })+  | not (isGivenCt ct) = inerts+  | not_equality ct    = inerts -- See Note [Let-bound skolems]+  | otherwise          = inerts { inert_given_eq_lvl = ge_lvl'+                                , inert_given_eqs    = True }+  where+    ge_lvl' | mentionsOuterVar tclvl (ctEvidence ct)+              -- Includes things like (c a), which *might* be an equality+            = tclvl+            | otherwise+            = ge_lvl++    not_equality :: Ct -> Bool+    -- True <=> definitely not an equality of any kind+    --          except for a let-bound skolem, which doesn't count+    --          See Note [Let-bound skolems]+    -- NB: no need to spot the boxed CDictCan (a ~ b) because its+    --     superclass (a ~# b) will be a CEqCan+    not_equality (CEqCan { cc_lhs = TyVarLHS tv }) = not (isOuterTyVar tclvl tv)+    not_equality (CDictCan {})                     = True+    not_equality _                                 = False++-----------------------------------------+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                   -> CanEqLHS        -- The new equality is lhs ~ ty+                   -> InertCans+                   -> TcS (Int, InertCans)+kickOutRewritable new_fr new_lhs ics+  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_lhs ics+             n_kicked = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)++              -- The famapp-cache contains Given evidence from the inert set.+              -- If we're kicking out Givens, we need to remove this evidence+              -- from the cache, too.+            ; let kicked_given_ev_vars =+                    [ ev_var | ct <- wl_eqs kicked_out+                             , CtGiven { ctev_evar = ev_var } <- [ctEvidence ct] ]+            ; when (new_fr `eqCanRewriteFR` (Given, NomEq) &&+                   -- if this isn't true, no use looking through the constraints+                    not (null kicked_given_ev_vars)) $+              do { traceTcS "Given(s) have been kicked out; drop from famapp-cache"+                            (ppr kicked_given_ev_vars)+                 ; dropFromFamAppCache (mkVarSet kicked_given_ev_vars) }++            ; csTraceTcS $+              hang (text "Kick out, lhs =" <+> ppr new_lhs)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; return (n_kicked, ics') }++kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                    -> CanEqLHS       -- The new equality is lhs ~ ty+                    -> InertCans+                    -> (WorkList, InertCans)+-- See Note [kickOutRewritable]+kick_out_rewritable new_fr new_lhs+                    ics@(IC { inert_eqs      = tv_eqs+                            , inert_dicts    = dictmap+                            , inert_funeqs   = funeqmap+                            , inert_irreds   = irreds+                            , inert_insts    = old_insts })+  | not (new_fr `eqMayRewriteFR` new_fr)+  = (emptyWorkList, ics)+        -- If new_fr can't rewrite itself, it can't rewrite+        -- anything else, so no need to kick out anything.+        -- (This is a common case: wanteds can't rewrite wanteds)+        -- Lemma (L2) in Note [Extending the inert equalities]++  | otherwise+  = (kicked_out, inert_cans_in)+  where+    -- inert_safehask stays unchanged; is that right?+    inert_cans_in = ics { inert_eqs      = tv_eqs_in+                        , inert_dicts    = dicts_in+                        , inert_funeqs   = feqs_in+                        , inert_irreds   = irs_in+                        , inert_insts    = insts_in }++    kicked_out :: WorkList+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority+    -- See Note [Prioritise equalities] (Kick-out).+    -- The irreds may include non-canonical (hetero-kinded) equality+    -- constraints, which perhaps may have become soluble after new_lhs+    -- is substituted; ditto the dictionaries, which may include (a~b)+    -- or (a~~b) constraints.+    kicked_out = foldr extendWorkListCt+                          (emptyWorkList { wl_eqs = tv_eqs_out ++ feqs_out })+                          ((dicts_out `andCts` irs_out)+                            `extendCtsList` insts_out)++    (tv_eqs_out, tv_eqs_in) = foldDVarEnv (kick_out_eqs extend_tv_eqs)+                                          ([], emptyDVarEnv) tv_eqs+    (feqs_out,   feqs_in)   = foldFunEqs  (kick_out_eqs extend_fun_eqs)+                                          funeqmap ([], emptyFunEqs)+    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap+    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds+      -- Kick out even insolubles: See Note [Rewrite insolubles]+      -- Of course we must kick out irreducibles like (c a), in case+      -- we can rewrite 'c' to something more useful++    -- Kick-out for inert instances+    -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+    insts_out :: [Ct]+    insts_in  :: [QCInst]+    (insts_out, insts_in)+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens+       = partitionWith kick_out_qci old_insts+       | otherwise+       = ([], old_insts)+    kick_out_qci qci+      | let ev = qci_ev qci+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))+      = Left (mkNonCanonical ev)+      | otherwise+      = Right qci++    (_, new_role) = new_fr++    fr_tv_can_rewrite_ty :: TyVar -> EqRel -> Type -> Bool+    fr_tv_can_rewrite_ty new_tv role ty+      = anyRewritableTyVar True role can_rewrite ty+                  -- True: ignore casts and coercions+      where+        can_rewrite :: EqRel -> TyVar -> Bool+        can_rewrite old_role tv = new_role `eqCanRewrite` old_role && tv == new_tv++    fr_tf_can_rewrite_ty :: TyCon -> [TcType] -> EqRel -> Type -> Bool+    fr_tf_can_rewrite_ty new_tf new_tf_args role ty+      = anyRewritableTyFamApp role can_rewrite ty+      where+        can_rewrite :: EqRel -> TyCon -> [TcType] -> Bool+        can_rewrite old_role old_tf old_tf_args+          = new_role `eqCanRewrite` old_role &&+            tcEqTyConApps new_tf new_tf_args old_tf old_tf_args+              -- it's possible for old_tf_args to have too many. This is fine;+              -- we'll only check what we need to.++    {-# INLINE fr_can_rewrite_ty #-}   -- perform the check here only once+    fr_can_rewrite_ty :: EqRel -> Type -> Bool+    fr_can_rewrite_ty = case new_lhs of+      TyVarLHS new_tv             -> fr_tv_can_rewrite_ty new_tv+      TyFamLHS new_tf new_tf_args -> fr_tf_can_rewrite_ty new_tf new_tf_args++    fr_may_rewrite :: CtFlavourRole -> Bool+    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs+        -- Can the new item rewrite the inert item?++    {-# INLINE kick_out_ct #-}   -- perform case on new_lhs here only once+    kick_out_ct :: Ct -> Bool+    -- Kick it out if the new CEqCan can rewrite the inert one+    -- See Note [kickOutRewritable]+    kick_out_ct = case new_lhs of+      TyVarLHS new_tv -> \ct -> let fs@(_,role) = ctFlavourRole ct in+                                fr_may_rewrite fs+                             && fr_tv_can_rewrite_ty new_tv role (ctPred ct)+      TyFamLHS new_tf new_tf_args+        -> \ct -> let fs@(_, role) = ctFlavourRole ct in+                  fr_may_rewrite fs+               && fr_tf_can_rewrite_ty new_tf new_tf_args role (ctPred ct)++    extend_tv_eqs :: InertEqs -> CanEqLHS -> EqualCtList -> InertEqs+    extend_tv_eqs eqs (TyVarLHS tv) cts = extendDVarEnv eqs tv cts+    extend_tv_eqs eqs other _cts = pprPanic "extend_tv_eqs" (ppr eqs $$ ppr other)++    extend_fun_eqs :: FunEqMap EqualCtList -> CanEqLHS -> EqualCtList+                   -> FunEqMap EqualCtList+    extend_fun_eqs eqs (TyFamLHS fam_tc fam_args) cts+      = insertTcApp eqs fam_tc fam_args cts+    extend_fun_eqs eqs other _cts = pprPanic "extend_fun_eqs" (ppr eqs $$ ppr other)++    kick_out_eqs :: (container -> CanEqLHS -> EqualCtList -> container)+                 -> EqualCtList -> ([Ct], container)+                 -> ([Ct], container)+    kick_out_eqs extend eqs (acc_out, acc_in)+      = (eqs_out `chkAppend` acc_out, case listToEqualCtList eqs_in of+            Nothing -> acc_in+            Just eqs_in_ecl@(EqualCtList (eq1 :| _))+                    -> extend acc_in (cc_lhs eq1) eqs_in_ecl)+      where+        (eqs_out, eqs_in) = partition kick_out_eq (equalCtListToList eqs)++    -- Implements criteria K1-K3 in Note [Extending the inert equalities]+    kick_out_eq (CEqCan { cc_lhs = lhs, cc_rhs = rhs_ty+                        , cc_ev = ev, cc_eq_rel = eq_rel })+      | not (fr_may_rewrite fs)+      = False  -- (K0) Keep it in the inert set if the new thing can't rewrite it++      -- Below here (fr_may_rewrite fs) is True++      | TyVarLHS _ <- lhs+      , fs `eqMayRewriteFR` new_fr+      = False  -- (K4) Keep it in the inert set if the LHS is a tyvar and+               -- it can rewrite the work item. See Note [K4]++      | fr_can_rewrite_ty eq_rel (canEqLHSType lhs)+      = True   -- (K1)+         -- The above check redundantly checks the role & flavour,+         -- but it's very convenient++      | kick_out_for_inertness    = True   -- (K2)+      | kick_out_for_completeness = True   -- (K3)+      | otherwise                 = False++      where+        fs = (ctEvFlavour ev, eq_rel)+        kick_out_for_inertness+          =    (fs `eqMayRewriteFR` fs)           -- (K2a)+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2b)++        kick_out_for_completeness  -- (K3) and Note [K3: completeness of solving]+          = case eq_rel of+              NomEq  -> rhs_ty `eqType` canEqLHSType new_lhs -- (K3a)+              ReprEq -> is_can_eq_lhs_head new_lhs rhs_ty    -- (K3b)++    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)++    is_can_eq_lhs_head (TyVarLHS tv) = go+      where+        go (Rep.TyVarTy tv')   = tv == tv'+        go (Rep.AppTy fun _)   = go fun+        go (Rep.CastTy ty _)   = go ty+        go (Rep.TyConApp {})   = False+        go (Rep.LitTy {})      = False+        go (Rep.ForAllTy {})   = False+        go (Rep.FunTy {})      = False+        go (Rep.CoercionTy {}) = False+    is_can_eq_lhs_head (TyFamLHS fun_tc fun_args) = go+      where+        go (Rep.TyVarTy {})       = False+        go (Rep.AppTy {})         = False  -- no TyConApp to the left of an AppTy+        go (Rep.CastTy ty _)      = go ty+        go (Rep.TyConApp tc args) = tcEqTyConApps fun_tc fun_args tc args+        go (Rep.LitTy {})         = False+        go (Rep.ForAllTy {})      = False+        go (Rep.FunTy {})         = False+        go (Rep.CoercionTy {})    = False++kickOutAfterUnification :: TcTyVar -> TcS Int+kickOutAfterUnification new_tv+  = do { ics <- getInertCans+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)+                                                 (TyVarLHS new_tv) ics+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       ; setInertCans ics2+       ; return n_kicked }++-- See Wrinkle (2) in Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+kickOutAfterFillingCoercionHole :: CoercionHole -> Coercion -> TcS ()+kickOutAfterFillingCoercionHole hole filled_co+  = do { ics <- getInertCans+       ; let (kicked_out, ics') = kick_out ics+             n_kicked           = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, hole =" <+> ppr hole)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; setInertCans ics' }+  where+    holes_of_co = coercionHolesOfCo filled_co++    kick_out :: InertCans -> (WorkList, InertCans)+    kick_out ics@(IC { inert_blocked = blocked })+      = let (to_kick, to_keep) = partitionBagWith kick_ct blocked++            kicked_out = extendWorkListCts (bagToList to_kick) emptyWorkList+            ics'       = ics { inert_blocked = to_keep }+        in+        (kicked_out, ics')++    kick_ct :: Ct -> Either Ct Ct+         -- Left: kick out; Right: keep. But even if we keep, we may need+         -- to update the set of blocking holes+    kick_ct ct@(CIrredCan { cc_reason = HoleBlockerReason holes })+      | hole `elementOfUniqSet` holes+      = let new_holes = holes `delOneFromUniqSet` hole+                              `unionUniqSets` holes_of_co+            updated_ct = ct { cc_reason = HoleBlockerReason new_holes }+        in+        if isEmptyUniqSet new_holes+        then Left updated_ct+        else Right updated_ct++      | otherwise+      = Right ct++    kick_ct other = pprPanic "kickOutAfterFillingCoercionHole" (ppr other)++{- Note [kickOutRewritable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [inert_eqs: the inert equalities].++When we add a new inert equality (lhs ~N ty) to the inert set,+we must kick out any inert items that could be rewritten by the+new equality, to maintain the inert-set invariants.++  - We want to kick out an existing inert constraint if+    a) the new constraint can rewrite the inert one+    b) 'lhs' is free in the inert constraint (so that it *will*)+       rewrite it if we kick it out.++    For (b) we use anyRewritableCanLHS, which examines the types /and+    kinds/ that are directly visible in the type. Hence+    we will have exposed all the rewriting we care about to make the+    most precise kinds visible for matching classes etc. No need to+    kick out constraints that mention type variables whose kinds+    contain this LHS!++  - A Derived equality can kick out [D] constraints in inert_eqs,+    inert_dicts, inert_irreds etc.++  - We don't kick out constraints from inert_solved_dicts, and+    inert_solved_funeqs optimistically. But when we lookup we have to+    take the substitution into account++NB: we could in principle avoid kick-out:+  a) When unifying a meta-tyvar from an outer level, because+     then the entire implication will be iterated; see+     Note [The Unification Level Flag]++  b) For Givens, after a unification.  By (GivenInv) in GHC.Tc.Utils.TcType+     Note [TcLevel invariants], a Given can't include a meta-tyvar from+     its own level, so it falls under (a).  Of course, we must still+     kick out Givens when adding a new non-unification Given.++But kicking out more vigorously may lead to earlier unification and fewer+iterations, so we don't take advantage of these possibilities.++Note [Rewrite insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an insoluble alpha ~ [alpha], which is insoluble+because an occurs check.  And then we unify alpha := [Int].  Then we+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can+be decomposed.  Otherwise we end up with a "Can't match [Int] ~+[[Int]]" which is true, but a bit confusing because the outer type+constructors match.++Hence:+ * In the main simplifier loops in GHC.Tc.Solver (solveWanteds,+   simpl_loop), we feed the insolubles in solveSimpleWanteds,+   so that they get rewritten (albeit not solved).++ * We kick insolubles out of the inert set, if they can be+   rewritten (see GHC.Tc.Solver.Monad.kick_out_rewritable)++ * We rewrite those insolubles in GHC.Tc.Solver.Canonical.+   See Note [Make sure that insolubles are fully rewritten]+-}++++--------------+addInertSafehask :: InertCans -> Ct -> InertCans+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_safehask = addDictCt (inert_dicts ics) cls tys item }++addInertSafehask _ item+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item++insertSafeOverlapFailureTcS :: InstanceWhat -> Ct -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+insertSafeOverlapFailureTcS what item+  | safeOverlap what = return ()+  | otherwise        = updInertCans (\ics -> addInertSafehask ics item)++getSafeOverlapFailures :: TcS Cts+-- See Note [Safe Haskell Overlapping Instances Implementation] in GHC.Tc.Solver+getSafeOverlapFailures+ = do { IC { inert_safehask = safehask } <- getInertCans+      ; return $ foldDicts consCts safehask emptyCts }++--------------+addSolvedDict :: InstanceWhat -> CtEvidence -> Class -> [Type] -> TcS ()+-- Conditionally add a new item in the solved set of the monad+-- See Note [Solved dictionaries]+addSolvedDict what item cls tys+  | isWanted item+  , instanceReturnsDictCon what+  = do { traceTcS "updSolvedSetTcs:" $ ppr item+       ; updInertTcS $ \ ics ->+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }+  | otherwise+  = return ()++getSolvedDicts :: TcS (DictMap CtEvidence)+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }++setSolvedDicts :: DictMap CtEvidence -> TcS ()+setSolvedDicts solved_dicts+  = updInertTcS $ \ ics ->+    ics { inert_solved_dicts = solved_dicts }+++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertTcS :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertTcS upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }++updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a+-- Modify the inert set with the supplied function+updRetInertCans upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var+                     ; let (res, cans') = upd_fn (inert_cans inerts)+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })+                     ; return res }) }++updInertCans :: (InertCans -> InertCans) -> TcS ()+-- Modify the inert set with the supplied function+updInertCans upd_fn+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertDicts upd_fn+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }++updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertSafehask upd_fn+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }++updInertIrreds :: (Cts -> Cts) -> TcS ()+-- Modify the inert set with the supplied function+updInertIrreds upd_fn+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }++getInertEqs :: TcS (DTyVarEnv EqualCtList)+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInnermostGivenEqLevel :: TcS TcLevel+getInnermostGivenEqLevel = do { inert <- getInertCans+                              ; return (inert_given_eq_lvl inert) }++getInertInsols :: TcS Cts+-- Returns insoluble equality constraints+-- specifically including Givens+getInertInsols = do { inert <- getInertCans+                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldDicts (:) (inert_dicts inerts)+                     $ foldFunEqs (\ecl out -> equalCtListToList ecl ++ out)+                                  (inert_funeqs inerts)+                     $ concatMap equalCtListToList (dVarEnvElts (inert_eqs inerts))+       ; return (filter isGivenCt all_cts) }++getPendingGivenScs :: TcS [Ct]+-- Find all inert Given dictionaries, or quantified constraints,+--     whose cc_pend_sc flag is True+--     and that belong to the current level+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct+getPendingGivenScs = do { lvl <- getTcLevel+                        ; updRetInertCans (get_sc_pending lvl) }++get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })+  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )+       -- When getPendingScDics is called,+       -- there are never any Wanteds in the inert set+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })+  where+    sc_pending = sc_pend_insts ++ sc_pend_dicts++    sc_pend_dicts = foldDicts get_pending dicts []+    dicts' = foldr add dicts sc_pend_dicts++    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts++    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True+                                       -- but flipping the flag+    get_pending dict dicts+        | Just dict' <- isPendingScDict dict+        , belongs_to_this_level (ctEvidence dict)+        = dict' : dicts+        | otherwise+        = dicts++    add :: Ct -> DictMap Ct -> DictMap Ct+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts+        = addDictCt dicts cls tys ct+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)++    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)+    get_pending_inst cts qci@(QCI { qci_ev = ev })+       | Just qci' <- isPendingScInst qci+       , belongs_to_this_level ev+       = (CQuantCan qci' : cts, qci')+       | otherwise+       = (cts, qci)++    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl+    -- We only want Givens from this level; see (3a) in+    -- Note [The superclass story] in GHC.Tc.Solver.Canonical++getUnsolvedInerts :: TcS ( Bag Implication+                         , Cts )   -- All simple constraints+-- Return all the unsolved [Wanted] or [Derived] constraints+--+-- Post-condition: the returned simple constraints are all fully zonked+--                     (because they come from the inert set)+--                 the unsolved implics may not be+getUnsolvedInerts+ = do { IC { inert_eqs     = tv_eqs+           , inert_funeqs  = fun_eqs+           , inert_irreds  = irreds+           , inert_blocked = blocked+           , inert_dicts   = idicts+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs add_if_unsolveds fun_eqs emptyCts+            unsolved_irreds  = Bag.filterBag is_unsolved irreds+            unsolved_blocked = blocked  -- all blocked equalities are W/D+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts+            unsolved_others  = unionManyBags [ unsolved_irreds+                                             , unsolved_dicts+                                             , unsolved_blocked ]++      ; implics <- getWorkListImplics++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "others =" <+> ppr unsolved_others+             , text "implics =" <+> ppr implics ]++      ; return ( implics, unsolved_tv_eqs `unionBags`+                          unsolved_fun_eqs `unionBags`+                          unsolved_others) }+  where+    add_if_unsolved :: Ct -> Cts -> Cts+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts+                           | otherwise      = cts++    add_if_unsolveds :: EqualCtList -> Cts -> Cts+    add_if_unsolveds new_cts old_cts = foldr add_if_unsolved old_cts+                                             (equalCtListToList new_cts)++    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived++getHasGivenEqs :: TcLevel           -- TcLevel of this implication+               -> TcS ( HasGivenEqs -- are there Given equalities?+                      , Cts )       -- Insoluble equalities arising from givens+-- See Note [Tracking Given equalities]+getHasGivenEqs tclvl+  = do { inerts@(IC { inert_irreds       = irreds+                    , inert_given_eqs    = given_eqs+                    , inert_given_eq_lvl = ge_lvl })+              <- getInertCans+       ; let insols = filterBag insolubleEqCt irreds+                      -- Specifically includes ones that originated in some+                      -- outer context but were refined to an insoluble by+                      -- a local equality; so do /not/ add ct_given_here.++             -- See Note [HasGivenEqs] in GHC.Tc.Types.Constraint, and+             -- Note [Tracking Given equalities] in this module+             has_ge | ge_lvl == tclvl = MaybeGivenEqs+                    | given_eqs       = LocalGivenEqs+                    | otherwise       = NoGivenEqs++       ; traceTcS "getHasGivenEqs" $+         vcat [ text "given_eqs:" <+> ppr given_eqs+              , text "ge_lvl:" <+> ppr ge_lvl+              , text "ambient level:" <+> ppr tclvl+              , text "Inerts:" <+> ppr inerts+              , text "Insols:" <+> ppr insols]+       ; return (has_ge, insols) }++mentionsOuterVar :: TcLevel -> CtEvidence -> Bool+mentionsOuterVar tclvl ev+  = anyFreeVarsOfType (isOuterTyVar tclvl) $+    ctEvPred ev++isOuterTyVar :: TcLevel -> TyCoVar -> Bool+-- True of a type variable that comes from a+-- shallower level than the ambient level (tclvl)+isOuterTyVar tclvl tv+  | isTyVar tv = ASSERT2( not (isTouchableMetaTyVar tclvl tv), ppr tv <+> ppr tclvl  )+                 tclvl `strictlyDeeperThan` tcTyVarLevel tv+    -- ASSERT: we are dealing with Givens here, and invariant (GivenInv) from+    -- Note Note [TcLevel invariants] in GHC.Tc.Utils.TcType ensures that there can't+    -- be a touchable meta tyvar.   If this wasn't true, you might worry that,+    -- at level 3, a meta-tv alpha[3] gets unified with skolem b[2], and thereby+    -- becomes "outer" even though its level numbers says it isn't.+  | otherwise  = False  -- Coercion variables; doesn't much matter++-- | Returns Given constraints that might,+-- potentially, match the given pred. This is used when checking to see if a+-- Given might overlap with an instance. See Note [Instance and Given overlap]+-- in "GHC.Tc.Solver.Interact"+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts+matchableGivens loc_w pred_w inerts@(IS { inert_cans = inert_cans })+  = filterBag matchable_given all_relevant_givens+  where+    -- just look in class constraints and irreds. matchableGivens does get called+    -- for ~R constraints, but we don't need to look through equalities, because+    -- canonical equalities are used for rewriting. We'll only get caught by+    -- non-canonical -- that is, irreducible -- equalities.+    all_relevant_givens :: Cts+    all_relevant_givens+      | Just (clas, _) <- getClassPredTys_maybe pred_w+      = findDictsByClass (inert_dicts inert_cans) clas+        `unionBags` inert_irreds inert_cans+      | otherwise+      = inert_irreds inert_cans++    matchable_given :: Ct -> Bool+    matchable_given ct+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct+      = mightEqualLater inerts pred_g loc_g pred_w loc_w++      | otherwise+      = False++mightEqualLater :: InertSet -> TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool+-- See Note [What might equal later?]+-- Used to implement logic in Note [Instance and Given overlap] in GHC.Tc.Solver.Interact+mightEqualLater (IS { inert_cycle_breakers = cbvs })+                given_pred given_loc wanted_pred wanted_loc+  | prohibitedSuperClassSolve given_loc wanted_loc+  = False++  | otherwise+  = case tcUnifyTysFG bind_fun [flattened_given] [flattened_wanted] of+      SurelyApart              -> False  -- types that are surely apart do not equal later+      MaybeApart MARInfinite _ -> False  -- see Example 7 in the Note.+      _                        -> True++  where+    in_scope  = mkInScopeSet $ tyCoVarsOfTypes [given_pred, wanted_pred]++    -- NB: flatten both at the same time, so that we can share mappings+    -- from type family applications to variables, and also to guarantee+    -- that the fresh variables are really fresh between the given and+    -- the wanted. Flattening both at the same time is needed to get+    -- Example 10 from the Note.+    ([flattened_given, flattened_wanted], var_mapping)+      = flattenTysX in_scope [given_pred, wanted_pred]++    bind_fun :: BindFun+    bind_fun tv rhs_ty+      | isMetaTyVar tv+      , can_unify tv (metaTyVarInfo tv) rhs_ty+         -- this checks for CycleBreakerTvs and TyVarTvs; forgetting+         -- the latter was #19106.+      = BindMe++         -- See Examples 4, 5, and 6 from the Note+      | Just (_fam_tc, fam_args) <- lookupVarEnv var_mapping tv+      , anyFreeVarsOfTypes mentions_meta_ty_var fam_args+      = BindMe++      | otherwise+      = Apart++    -- True for TauTv and TyVarTv (and RuntimeUnkTv) meta-tyvars+    -- (as they can be unified)+    -- and also for CycleBreakerTvs that mentions meta-tyvars+    mentions_meta_ty_var :: TyVar -> Bool+    mentions_meta_ty_var tv+      | isMetaTyVar tv+      = case metaTyVarInfo tv of+          -- See Examples 8 and 9 in the Note+          CycleBreakerTv+            | Just tyfam_app <- lookup tv cbvs+            -> anyFreeVarsOfType mentions_meta_ty_var tyfam_app+            | otherwise+            -> pprPanic "mightEqualLater finds an unbound cbv" (ppr tv $$ ppr cbvs)+          _ -> True+      | otherwise+      = False++    -- like canSolveByUnification, but allows cbv variables to unify+    can_unify :: TcTyVar -> MetaInfo -> Type -> Bool+    can_unify _lhs_tv TyVarTv rhs_ty  -- see Example 3 from the Note+      | Just rhs_tv <- tcGetTyVar_maybe rhs_ty+      = case tcTyVarDetails rhs_tv of+          MetaTv { mtv_info = TyVarTv } -> True+          MetaTv {}                     -> False  -- could unify with anything+          SkolemTv {}                   -> True+          RuntimeUnk                    -> True+      | otherwise  -- not a var on the RHS+      = False+    can_unify lhs_tv _other _rhs_ty = mentions_meta_ty_var lhs_tv++prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool+-- See Note [Solving superclass constraints] in GHC.Tc.TyCl.Instance+prohibitedSuperClassSolve from_loc solve_loc+  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc+  , ScOrigin wanted_size <- ctLocOrigin solve_loc+  = given_size >= wanted_size+  | otherwise+  = False++{- Note [Unsolved Derived equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In getUnsolvedInerts, we return a derived equality from the inert_eqs+because it is a candidate for floating out of this implication.  We+only float equalities with a meta-tyvar on the left, so we only pull+those out here.++Note [What might equal later?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must determine whether a Given might later equal a Wanted. We+definitely need to account for the possibility that any metavariable+might be arbitrarily instantiated. Yet we do *not* want+to allow skolems in to be instantiated, as we've already rewritten+with respect to any Givens. (We're solving a Wanted here, and so+all Givens have already been processed.)++This is best understood by example.++1. C alpha  ~?  C Int++   That given certainly might match later.++2. C a  ~?  C Int++   No. No new givens are going to arise that will get the `a` to rewrite+   to Int.++3. C alpha[tv]   ~?  C Int++   That alpha[tv] is a TyVarTv, unifiable only with other type variables.+   It cannot equal later.++4. C (F alpha)   ~?   C Int++   Sure -- that can equal later, if we learn something useful about alpha.++5. C (F alpha[tv])  ~?  C Int++   This, too, might equal later. Perhaps we have [G] F b ~ Int elsewhere.+   Or maybe we have C (F alpha[tv] beta[tv]), these unify with each other,+   and F x x = Int. Remember: returning True doesn't commit ourselves to+   anything.++6. C (F a)  ~?  C a++   No, this won't match later. If we could rewrite (F a) or a, we would+   have by now.++7. C (Maybe alpha)  ~?  C alpha++   We say this cannot equal later, because it would require+   alpha := Maybe (Maybe (Maybe ...)). While such a type can be contrived,+   we choose not to worry about it. See Note [Infinitary substitution in lookup]+   in GHC.Core.InstEnv. Getting this wrong let to #19107, tested in+   typecheck/should_compile/T19107.++8. C cbv   ~?  C Int+   where cbv = F a++   The cbv is a cycle-breaker var which stands for F a. See+   Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+   This is just like case 6, and we say "no". Saying "no" here is+   essential in getting the parser to type-check, with its use of DisambECP.++9. C cbv   ~?   C Int+   where cbv = F alpha++   Here, we might indeed equal later. Distinguishing between+   this case and Example 8 is why we need the InertSet in mightEqualLater.++10. C (F alpha, Int)  ~?  C (Bool, F alpha)++   This cannot equal later, because F a would have to equal both Bool and+   Int.++To deal with type family applications, we use the Core flattener. See+Note [Flattening type-family applications when matching instances] in GHC.Core.Unify.+The Core flattener replaces all type family applications with+fresh variables. The next question: should we allow these fresh+variables in the domain of a unifying substitution?++A type family application that mentions only skolems (example 6) is settled:+any skolems would have been rewritten w.r.t. Givens by now. These type family+applications match only themselves. A type family application that mentions+metavariables, on the other hand, can match anything. So, if the original type+family application contains a metavariable, we use BindMe to tell the unifier+to allow it in the substitution. On the other hand, a type family application+with only skolems is considered rigid.++This treatment fixes #18910 and is tested in+typecheck/should_compile/InstanceGivenOverlap{,2}+-}++removeInertCts :: [Ct] -> InertCans -> InertCans+-- ^ Remove inert constraints from the 'InertCans', for use when a+-- typechecker plugin wishes to discard a given.+removeInertCts cts icans = foldl' removeInertCt icans cts++removeInertCt :: InertCans -> Ct -> InertCans+removeInertCt is ct =+  case ct of++    CDictCan  { cc_class = cl, cc_tyargs = tys } ->+      is { inert_dicts = delDict (inert_dicts is) cl tys }++    CEqCan    { cc_lhs  = lhs, cc_rhs = rhs } -> delEq is lhs rhs++    CQuantCan {}     -> panic "removeInertCt: CQuantCan"+    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"++-- | Looks up a family application in the inerts; returned coercion+-- is oriented input ~ output+lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavourRole))+lookupFamAppInert fam_tc tys+  = do { IS { inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts+       ; return (lookup_inerts inert_funeqs) }+  where+    lookup_inerts inert_funeqs+      | Just (EqualCtList (CEqCan { cc_ev = ctev, cc_rhs = rhs } :| _))+          <- findFunEq inert_funeqs fam_tc tys+      = Just (ctEvCoercion ctev, rhs, ctEvFlavourRole ctev)+      | otherwise = Nothing++lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?+lookupInInerts loc pty+  | ClassPred cls tys <- classifyPredType pty+  = do { inerts <- getTcSInerts+       ; return (lookupSolvedDict inerts loc cls tys `mplus`+                 fmap ctEvidence (lookupInertDict (inert_cans inerts) loc cls tys)) }+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors+  = return Nothing++-- | Look up a dictionary inert.+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe Ct+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys+  = case findDict dicts loc cls tys of+      Just ct -> Just ct+      _       -> Nothing++-- | 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+  = case findDict solved loc cls tys of+      Just ev -> Just ev+      _       -> Nothing++---------------------------+lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))+lookupFamAppCache fam_tc tys+  = do { IS { inert_famapp_cache = famapp_cache } <- getTcSInerts+       ; case findFunEq famapp_cache fam_tc tys of+           result@(Just (co, ty)) ->+             do { traceTcS "famapp_cache hit" (vcat [ ppr (mkTyConApp fam_tc tys)+                                                    , ppr ty+                                                    , ppr co ])+                ; return result }+           Nothing -> return Nothing }++extendFamAppCache :: TyCon -> [Type] -> (TcCoercion, TcType) -> TcS ()+-- NB: co :: rhs ~ F tys, to match expectations of rewriter+extendFamAppCache tc xi_args stuff@(_, ty)+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FamAppCache dflags) $+    do { traceTcS "extendFamAppCache" (vcat [ ppr tc <+> ppr xi_args+                                            , ppr ty ])+            -- 'co' can be bottom, in the case of derived items+       ; updInertTcS $ \ is@(IS { inert_famapp_cache = fc }) ->+            is { inert_famapp_cache = insertFunEq fc tc xi_args stuff } } }++-- Remove entries from the cache whose evidence mentions variables in the+-- supplied set+dropFromFamAppCache :: VarSet -> TcS ()+dropFromFamAppCache varset+  = do { inerts@(IS { inert_famapp_cache = famapp_cache }) <- getTcSInerts+       ; let filtered = filterTcAppMap check famapp_cache+       ; setTcSInerts $ inerts { inert_famapp_cache = filtered } }+  where+    check :: (TcCoercion, TcType) -> Bool+    check (co, _) = not (anyFreeVarsOfCo (`elemVarSet` varset) co)++{- *********************************************************************+*                                                                      *+                   Irreds+*                                                                      *+********************************************************************* -}++foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b+foldIrreds k irreds z = foldr k z irreds+++{- *********************************************************************+*                                                                      *+                   TcAppMap+*                                                                      *+************************************************************************++Note [Use loose types in inert set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whenever we are looking up an inert dictionary (CDictCan) or function+equality (CEqCan), 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.++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 = DTyConEnv (ListMap LooseTypeMap a)+    -- Indexed by tycon then the arg types, using "loose" matching, where+    -- we don't require kind equality. This allows, for example, (a |> co)+    -- to match (a).+    -- See Note [Use loose types in inert set]+    -- Used for types and classes; hence UniqDFM+    -- See Note [foldTM determinism] in GHC.Data.TrieMap for why we use DTyConEnv here++isEmptyTcAppMap :: TcAppMap a -> Bool+isEmptyTcAppMap m = isEmptyDTyConEnv m++emptyTcAppMap :: TcAppMap a+emptyTcAppMap = emptyDTyConEnv++findTcApp :: TcAppMap a -> TyCon -> [Type] -> Maybe a+findTcApp m tc tys = do { tys_map <- lookupDTyConEnv m tc+                        ; lookupTM tys tys_map }++delTcApp :: TcAppMap a -> TyCon -> [Type] -> TcAppMap a+delTcApp m tc tys = adjustDTyConEnv (deleteTM tys) m tc++insertTcApp :: TcAppMap a -> TyCon -> [Type] -> a -> TcAppMap a+insertTcApp m tc tys ct = alterDTyConEnv alter_tm m tc+  where+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))++alterTcApp :: forall a. TcAppMap a -> TyCon -> [Type] -> XT a -> TcAppMap a+alterTcApp m tc tys upd = alterDTyConEnv alter_tm m tc+  where+    alter_tm :: Maybe (ListMap LooseTypeMap a) -> Maybe (ListMap LooseTypeMap a)+    alter_tm m_elt = Just (alterTM tys upd (m_elt `orElse` emptyTM))++filterTcAppMap :: forall a. (a -> Bool) -> TcAppMap a -> TcAppMap a+filterTcAppMap f m = mapMaybeDTyConEnv one_tycon m+  where+    one_tycon :: ListMap LooseTypeMap a -> Maybe (ListMap LooseTypeMap a)+    one_tycon tm+      | isEmptyTM filtered_tm = Nothing+      | otherwise             = Just filtered_tm+      where+        filtered_tm = filterTM f tm++tcAppMapToBag :: TcAppMap a -> Bag a+tcAppMapToBag m = foldTcAppMap consBag m emptyBag++foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b+foldTcAppMap k m z = foldDTyConEnv (foldTM k) z m+++{- *********************************************************************+*                                                                      *+                   DictMap+*                                                                      *+********************************************************************* -}+++{- Note [Tuples hiding implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f,g :: (?x::Int, C a) => a -> a+   f v = let ?x = 4 in g v++The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).+We must /not/ solve this from the Given (?x::Int, C a), because of+the intervening binding for (?x::Int).  #14218.++We deal with this by arranging that we always fail when looking up a+tuple constraint that hides an implicit parameter. Not that this applies+  * both to the inert_dicts (lookupInertDict)+  * and to the solved_dicts (looukpSolvedDict)+An alternative would be not to extend these sets with such tuple+constraints, but it seemed more direct to deal with the lookup.++Note [Solving CallStack constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose f :: HasCallStack => blah.  Then++* Each call to 'f' gives rise to+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f+  with a CtOrigin that says "OccurrenceOf f".+  Remember that HasCallStack is just shorthand for+    IP "callStack CallStack+  See Note [Overview of implicit CallStacks] in GHC.Tc.Types.Evidence++* We cannonicalise such constraints, in GHC.Tc.Solver.Canonical.canClassNC, by+  pushing the call-site info on the stack, and changing the CtOrigin+  to record that has been done.+   Bind:  s1 = pushCallStack <site-info> s2+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin++* Then, and only then, we can solve the constraint from an enclosing+  Given.++So we must be careful /not/ to solve 's1' from the Givens.  Again,+we ensure this by arranging that findDict always misses when looking+up souch constraints.+-}++type DictMap a = TcAppMap a++emptyDictMap :: DictMap a+emptyDictMap = emptyTcAppMap++findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a+findDict m loc cls tys+  | hasIPSuperClasses cls tys -- See Note [Tuples hiding implicit parameters]+  = Nothing++  | Just {} <- isCallStackPred cls tys+  , OccurrenceOf {} <- ctLocOrigin loc+  = Nothing             -- See Note [Solving CallStack constraints]++  | otherwise+  = findTcApp m (classTyCon cls) tys++findDictsByClass :: DictMap a -> Class -> Bag a+findDictsByClass m cls+  | Just tm <- lookupDTyConEnv m (classTyCon cls) = foldTM consBag tm emptyBag+  | otherwise                                     = emptyBag++delDict :: DictMap a -> Class -> [Type] -> DictMap a+delDict m cls tys = delTcApp m (classTyCon cls) tys++addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a+addDict m cls tys item = insertTcApp m (classTyCon cls) tys item++addDictCt :: DictMap Ct -> Class -> [Type] -> Ct -> DictMap Ct+-- Like addDict, but combines [W] and [D] to [WD]+-- See Note [KeepBoth] in GHC.Tc.Solver.Interact+addDictCt m cls tys new_ct = alterTcApp m (classTyCon cls) tys xt_ct+  where+    new_ct_ev = ctEvidence new_ct++    xt_ct :: Maybe Ct -> Maybe Ct+    xt_ct (Just old_ct)+      | CtWanted { ctev_nosh = WOnly } <- old_ct_ev+      , CtDerived {} <- new_ct_ev+      = Just (old_ct { cc_ev = old_ct_ev { ctev_nosh = WDeriv }})+      | CtDerived {} <- old_ct_ev+      , CtWanted { ctev_nosh = WOnly } <- new_ct_ev+      = Just (new_ct { cc_ev = new_ct_ev { ctev_nosh = WDeriv }})+      where+        old_ct_ev = ctEvidence old_ct++    xt_ct _ = Just new_ct++addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct+addDictsByClass m cls items+  = extendDTyConEnv m (classTyCon cls) (foldr add emptyTM items)+  where+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm+    add ct _ = pprPanic "addDictsByClass" (ppr ct)++filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct+filterDicts f m = filterTcAppMap f m++partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)+  where+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)+                       | otherwise = (yeses,              add ct noes)+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m+      = addDict m cls tys ct+    add ct _ = pprPanic "partitionDicts" (ppr ct)++dictsToBag :: DictMap a -> Bag a+dictsToBag = tcAppMapToBag++foldDicts :: (a -> b -> b) -> DictMap a -> b -> b+foldDicts = foldTcAppMap++emptyDicts :: DictMap a+emptyDicts = emptyTcAppMap+++{- *********************************************************************+*                                                                      *+                   FunEqMap+*                                                                      *+********************************************************************* -}++type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair++emptyFunEqs :: TcAppMap a+emptyFunEqs = emptyTcAppMap++findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a+findFunEq m tc tys = findTcApp m tc tys++findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]+-- Get inert function equation constraints that have the given tycon+-- in their head.  Not that the constraints remain in the inert set.+-- We use this to check for derived interactions with built-in type-function+-- constructors.+findFunEqsByTyCon m tc+  | Just tm <- lookupDTyConEnv m tc = foldTM (:) tm []+  | otherwise                       = []++foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b+foldFunEqs = foldTcAppMap++insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a+insertFunEq m tc tys val = insertTcApp m tc tys val++{-+************************************************************************+*                                                                      *+*              The TcS solver monad                                    *+*                                                                      *+************************************************************************++Note [The TcS monad]+~~~~~~~~~~~~~~~~~~~~+The TcS monad is a weak form of the main Tc monad++All you can do is+    * fail+    * allocate new variables+    * fill in evidence variables++Filling in a dictionary evidence variable means to create a binding+for it, so TcS carries a mutable location where the binding can be+added.  This is initialised from the innermost implication constraint.+-}++data TcSEnv+  = TcSEnv {+      tcs_ev_binds    :: EvBindsVar,++      tcs_unified     :: IORef Int,+         -- The number of unification variables we have filled+         -- The important thing is whether it is non-zero++      tcs_unif_lvl  :: IORef (Maybe TcLevel),+         -- The Unification Level Flag+         -- Outermost level at which we have unified a meta tyvar+         -- Starts at Nothing, then (Just i), then (Just j) where j<i+         -- See Note [The Unification Level Flag]++      tcs_count     :: IORef Int, -- Global step count++      tcs_inerts    :: IORef InertSet, -- Current inert set++      -- See Note [WorkList priorities] and+      tcs_worklist  :: IORef WorkList -- Current worklist+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } deriving (Functor)++-- | Smart constructor for 'TcS', as describe in Note [The one-shot state+-- monad trick] in "GHC.Utils.Monad".+mkTcS :: (TcSEnv -> TcM a) -> TcS a+mkTcS f = TcS (oneShot f)++instance Applicative TcS where+  pure x = mkTcS $ \_ -> return x+  (<*>) = ap++instance Monad TcS where+  m >>= k   = mkTcS $ \ebs -> do+    unTcS m ebs >>= (\r -> unTcS (k r) ebs)++instance MonadFail TcS where+  fail err  = mkTcS $ \_ -> fail err++instance MonadUnique TcS where+   getUniqueSupplyM = wrapTcS getUniqueSupplyM++instance HasModule TcS where+   getModule = wrapTcS getModule++instance MonadThings TcS where+   lookupThing n = wrapTcS (lookupThing n)++-- Basic functionality+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wrapTcS :: TcM a -> TcS a+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,+-- and TcS is supposed to have limited functionality+wrapTcS action = mkTcS $ \_env -> action -- a TcM action will not use the TcEvBinds++wrapErrTcS :: TcM a -> TcS a+-- The thing wrapped should just fail+-- There's no static check; it's up to the user+-- Having a variant for each error message is too painful+wrapErrTcS = wrapTcS++wrapWarnTcS :: TcM a -> TcS a+-- The thing wrapped should just add a warning, or no-op+-- There's no static check; it's up to the user+wrapWarnTcS = wrapTcS++failTcS, panicTcS  :: SDoc -> TcS a+warnTcS   :: WarningFlag -> SDoc -> TcS ()+addErrTcS :: SDoc -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "GHC.Tc.Solver.Canonical" doc++traceTcS :: String -> SDoc -> TcS ()+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)+{-# INLINE traceTcS #-}  -- see Note [INLINE conditional tracing utilities]++runTcPluginTcS :: TcPluginM a -> TcS a+runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar++instance HasDynFlags TcS where+    getDynFlags = wrapTcS getDynFlags++getGlobalRdrEnvTcS :: TcS GlobalRdrEnv+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv++bumpStepCountTcS :: TcS ()+bumpStepCountTcS = mkTcS $ \env ->+  do { let ref = tcs_count env+     ; n <- TcM.readTcRef ref+     ; TcM.writeTcRef ref (n+1) }++csTraceTcS :: SDoc -> TcS ()+csTraceTcS doc+  = wrapTcS $ csTraceTcM (return doc)+{-# INLINE csTraceTcS #-}  -- see Note [INLINE conditional tracing utilities]++traceFireTcS :: CtEvidence -> SDoc -> TcS ()+-- Dump a rule-firing trace+traceFireTcS ev doc+  = mkTcS $ \env -> csTraceTcM $+    do { n <- TcM.readTcRef (tcs_count env)+       ; tclvl <- TcM.getTcLevel+       ; return (hang (text "Step" <+> int n+                       <> brackets (text "l:" <> ppr tclvl <> comma <>+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))+                       <+> doc <> colon)+                     4 (ppr ev)) }+{-# INLINE traceFireTcS #-}  -- see Note [INLINE conditional tracing utilities]++csTraceTcM :: TcM SDoc -> TcM ()+-- Constraint-solver tracing, -ddump-cs-trace+csTraceTcM mk_doc+  = do { dflags <- getDynFlags+       ; when (  dopt Opt_D_dump_cs_trace dflags+                  || dopt Opt_D_dump_tc_trace dflags )+              ( do { msg <- mk_doc+                   ; TcM.dumpTcRn False+                       Opt_D_dump_cs_trace+                       "" FormatText+                       msg }) }+{-# INLINE csTraceTcM #-}  -- see Note [INLINE conditional tracing utilities]++runTcS :: TcS a                -- What to run+       -> TcM (a, EvBindMap)+runTcS tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; res <- runTcSWithEvBinds ev_binds_var 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 }++-- | 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 }++-- | A variant of 'runTcS' that takes and returns an 'InertSet' for+-- later resumption of the 'TcS' session.+runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)+runTcSInerts inerts tcs = do+  ev_binds_var <- TcM.newTcEvBinds+  runTcSWithEvBinds' False ev_binds_var $ do+    setTcSInerts inerts+    a <- tcs+    new_inerts <- getTcSInerts+    return (a, new_inerts)++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds = runTcSWithEvBinds' True++runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?+                           -- Don't if you want to reuse the InertSet.+                           -- See also Note [Type variable cycles]+                           -- in GHC.Tc.Solver.Canonical+                   -> EvBindsVar+                   -> TcS a+                   -> TcM a+runTcSWithEvBinds' restore_cycles ev_binds_var tcs+  = do { unified_var <- TcM.newTcRef 0+       ; step_count <- TcM.newTcRef 0+       ; inert_var <- TcM.newTcRef emptyInert+       ; wl_var <- TcM.newTcRef emptyWorkList+       ; unif_lvl_var <- TcM.newTcRef Nothing+       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var+                          , tcs_unified       = unified_var+                          , tcs_unif_lvl      = unif_lvl_var+                          , tcs_count         = step_count+                          , tcs_inerts        = inert_var+                          , tcs_worklist      = wl_var }++             -- Run the computation+       ; res <- unTcS tcs env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++       ; when restore_cycles $+         do { inert_set <- TcM.readTcRef inert_var+            ; restoreTyVarCycles inert_set }++#if defined(DEBUG)+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; checkForCyclicBinds ev_binds+#endif++       ; return res }++----------------------------+#if defined(DEBUG)+checkForCyclicBinds :: EvBindMap -> TcM ()+checkForCyclicBinds ev_binds_map+  | null cycles+  = return ()+  | null coercion_cycles+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles+  | otherwise+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles+  where+    ev_binds = evBindMapBinds ev_binds_map++    cycles :: [[EvBind]]+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]++    coercion_cycles = [c | c <- cycles, any is_co_bind c]+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)++    edges :: [ Node EvVar EvBind ]+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+#endif++----------------------------+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a+setEvBindsTcS ref (TcS thing_inside)+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ref inner_tclvl (TcS thing_inside)+  = TcS $ \ TcSEnv { tcs_unified       = unified_var+                   , tcs_inerts        = old_inert_var+                   , tcs_count         = count+                   , tcs_unif_lvl      = unif_lvl+                   } ->+    do { inerts <- TcM.readTcRef old_inert_var+       ; let nest_inert = inerts { inert_cycle_breakers = []+                                 , inert_cans = (inert_cans inerts)+                                                   { inert_given_eqs = False } }+                 -- All other InertSet fields are inherited+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = TcSEnv { tcs_count         = count     -- Inherited+                               , tcs_unif_lvl      = unif_lvl  -- Inherited+                               , tcs_ev_binds      = ref+                               , tcs_unified       = unified_var+                               , tcs_inerts        = new_inert_var+                               , tcs_worklist      = new_wl_var }+       ; res <- TcM.setTcLevel inner_tclvl $+                thing_inside nest_env++       ; out_inert_set <- TcM.readTcRef new_inert_var+       ; restoreTyVarCycles out_inert_set++#if defined(DEBUG)+       -- Perform a check that the thing_inside did not cause cycles+       ; ev_binds <- TcM.getTcEvBindsMap ref+       ; checkForCyclicBinds ev_binds+#endif+       ; return res }++nestTcS ::  TcS a -> TcS a+-- Use the current untouchables, augmenting the current+-- evidence bindings, and solved dictionaries+-- But have no effect on the InertCans, or on the inert_famapp_cache+-- (we want to inherit the latter from processing the Givens)+nestTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->+    do { inerts <- TcM.readTcRef inerts_var+       ; new_inert_var <- TcM.newTcRef inerts+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var++       -- we want to propagate the safe haskell failures+       ; let old_ic = inert_cans inerts+             new_ic = inert_cans new_inerts+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }++       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts+                                , inert_cans = nxt_ic })++       ; return res }++emitImplicationTcS :: TcLevel -> SkolemInfo+                   -> [TcTyVar]        -- Skolems+                   -> [EvVar]          -- Givens+                   -> Cts              -- Wanteds+                   -> TcS TcEvBinds+-- Add an implication to the TcS monad work-list+emitImplicationTcS new_tclvl skol_info skol_tvs givens wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_given  = givens+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp+       ; return (TcEvBinds (ic_binds imp)) }++emitTvImplicationTcS :: TcLevel -> SkolemInfo+                     -> [TcTyVar]        -- Skolems+                     -> Cts              -- Wanteds+                     -> TcS ()+-- Just like emitImplicationTcS but no givens and no bindings+emitTvImplicationTcS new_tclvl skol_info skol_tvs wanteds+  = do { let wc = emptyWC { wc_simple = wanteds }+       ; imp <- wrapTcS $+                do { ev_binds_var <- TcM.newNoTcEvBinds+                   ; imp <- TcM.newImplication+                   ; return (imp { ic_tclvl  = new_tclvl+                                 , ic_skols  = skol_tvs+                                 , ic_wanted = wc+                                 , ic_binds  = ev_binds_var+                                 , ic_info   = skol_info }) }++       ; emitImplication imp }+++{- Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really quite important that nestTcS does not discard the solved+dictionaries from the thing_inside.+Consider+   Eq [a]+   forall b. empty =>  Eq [a]+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to+the implications.  It's definitely fine to use the solved dictionaries on+the inner implications, and it can make a significant performance difference+if you do so.+-}++-- Getters and setters of GHC.Tc.Utils.Env fields+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- Getter of inerts and worklist+getTcSInertsRef :: TcS (IORef InertSet)+getTcSInertsRef = TcS (return . tcs_inerts)++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getTcSInerts :: TcS InertSet+getTcSInerts = getTcSInertsRef >>= readTcRef++setTcSInerts :: InertSet -> TcS ()+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }++getWorkListImplics :: TcS (Bag Implication)+getWorkListImplics+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- readTcRef wl_var+       ; return (wl_implics wl_curr) }++pushLevelNoWorkList :: SDoc -> TcS a -> TcS (TcLevel, a)+-- Push the level and run thing_inside+-- However, thing_inside should not generate any work items+#if defined(DEBUG)+pushLevelNoWorkList err_doc (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM $+                 thing_inside (env { tcs_worklist = wl_panic })+        )+  where+    wl_panic  = pprPanic "GHC.Tc.Solver.Monad.buildImplication" err_doc+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+#else+pushLevelNoWorkList _ (TcS thing_inside)+  = TcS (\env -> TcM.pushTcLevelM (thing_inside env))  -- Don't check+#endif++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; updTcRef wl_var f }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (map mkNonCanonical evs)++emitWork :: [Ct] -> TcS ()+emitWork [] = return ()   -- avoid printing, among other work+emitWork cts+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))+       ; updWorkListTcS (extendWorkListCts cts) }++emitImplication :: Implication -> TcS ()+emitImplication implic+  = updWorkListTcS (extendWorkListImplic implic)++newTcRef :: a -> TcS (TcRef a)+newTcRef x = wrapTcS (TcM.newTcRef x)++readTcRef :: TcRef a -> TcS a+readTcRef ref = wrapTcS (TcM.readTcRef ref)++writeTcRef :: TcRef a -> a -> TcS ()+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)++updTcRef :: TcRef a -> (a->a) -> TcS ()+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)++getTcEvBindsVar :: TcS EvBindsVar+getTcEvBindsVar = TcS (return . tcs_ev_binds)++getTcLevel :: TcS TcLevel+getTcLevel = wrapTcS TcM.getTcLevel++getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet+getTcEvTyCoVars ev_binds_var+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var++getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap+getTcEvBindsMap ev_binds_var+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var++setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()+setTcEvBindsMap ev_binds_var binds+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds++unifyTyVar :: TcTyVar -> TcType -> TcS ()+-- Unify a meta-tyvar with a type+-- We keep track of how many unifications have happened in tcs_unified,+--+-- We should never unify the same variable twice!+unifyTyVar tv ty+  = ASSERT2( isMetaTyVar tv, ppr tv )+    TcS $ \ env ->+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++reportUnifications :: TcS a -> TcS (Int, a)+reportUnifications (TcS thing_inside)+  = TcS $ \ env ->+    do { inner_unified <- TcM.newTcRef 0+       ; res <- thing_inside (env { tcs_unified = inner_unified })+       ; n_unifs <- TcM.readTcRef inner_unified+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)+       ; return (n_unifs, res) }++data TouchabilityTestResult+  -- See Note [Solve by unification] in GHC.Tc.Solver.Interact+  -- which points out that having TouchableSameLevel is just an optimisation;+  -- we could manage with TouchableOuterLevel alone (suitably renamed)+  = TouchableSameLevel+  | TouchableOuterLevel [TcTyVar]   -- Promote these+                        TcLevel     -- ..to this level+  | Untouchable++instance Outputable TouchabilityTestResult where+  ppr TouchableSameLevel            = text "TouchableSameLevel"+  ppr (TouchableOuterLevel tvs lvl) = text "TouchableOuterLevel" <> parens (ppr lvl <+> ppr tvs)+  ppr Untouchable                   = text "Untouchable"++touchabilityTest :: CtFlavour -> TcTyVar -> TcType -> TcS TouchabilityTestResult+-- This is the key test for untouchability:+-- See Note [Unification preconditions] in GHC.Tc.Utils.Unify+-- and Note [Solve by unification] in GHC.Tc.Solver.Interact+touchabilityTest flav tv1 rhs+  | flav /= Given  -- See Note [Do not unify Givens]+  , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1+  , canSolveByUnification info rhs+  = do { ambient_lvl  <- getTcLevel+       ; given_eq_lvl <- getInnermostGivenEqLevel++       ; if | tv_lvl `sameDepthAs` ambient_lvl+            -> return TouchableSameLevel++            | tv_lvl `deeperThanOrSame` given_eq_lvl   -- No intervening given equalities+            , all (does_not_escape tv_lvl) free_skols  -- No skolem escapes+            -> return (TouchableOuterLevel free_metas tv_lvl)++            | otherwise+            -> return Untouchable }+  | otherwise+  = return Untouchable+  where+     (free_metas, free_skols) = partition isPromotableMetaTyVar $+                                nonDetEltsUniqSet               $+                                tyCoVarsOfType rhs++     does_not_escape tv_lvl fv+       | isTyVar fv = tv_lvl `deeperThanOrSame` tcTyVarLevel fv+       | otherwise  = True+       -- Coercion variables are not an escape risk+       -- If an implication binds a coercion variable, it'll have equalities,+       -- so the "intervening given equalities" test above will catch it+       -- Coercion holes get filled with coercions, so again no problem.++{- Note [Do not unify Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GADT match+   data T a where+      T1 :: T Int+      ...++   f x = case x of+           T1 -> True+           ...++So we get f :: T alpha[1] -> beta[1]+          x :: T alpha[1]+and from the T1 branch we get the implication+   forall[2] (alpha[1] ~ Int) => beta[1] ~ Bool++Now, clearly we don't want to unify alpha:=Int!  Yet at the moment we+process [G] alpha[1] ~ Int, we don't have any given-equalities in the+inert set, and hence there are no given equalities to make alpha untouchable.++NB: if it were alpha[2] ~ Int, this argument wouldn't hold.  But that+never happens: invariant (GivenInv) in Note [TcLevel invariants]+in GHC.Tc.Utils.TcType.++Simple solution: never unify in Givens!+-}++getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys++-- Just get some environments needed for instance looking up and matching+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getInstEnvs :: TcS InstEnvs+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs++getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs++getTopEnv :: TcS HscEnv+getTopEnv = wrapTcS $ TcM.getTopEnv++getGblEnv :: TcS TcGblEnv+getGblEnv = wrapTcS $ TcM.getGblEnv++getLclEnv :: TcS TcLclEnv+getLclEnv = wrapTcS $ TcM.getLclEnv++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++-- Setting names as used (used in the deriving of Coercible evidence)+-- Too hackish to expose it to TcS? In that case somehow extract the used+-- constructors from the result of solveInteract+addUsedGREs :: [GlobalRdrElt] -> TcS ()+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres++addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre++keepAlive :: Name -> TcS ()+keepAlive = wrapTcS . TcM.keepAlive++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()+-- Check that we do not try to use an instance before it is available.  E.g.+--    instance Eq T where ...+--    f x = $( ... (\(p::T) -> p == p)... )+-- Here we can't use the equality function from the instance in the splice++checkWellStagedDFun loc what pred+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+  , let bind_lvl = TcM.topIdLvl dfun_id+  , bind_lvl > impLevel+  = wrapTcS $ TcM.setCtLocM loc $+    do { use_stage <- TcM.getStage+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }++  | otherwise+  = return ()    -- Fast path for common case+  where+    pp_thing = text "instance for" <+> quotes (ppr pred)++pprEq :: TcType -> TcType -> SDoc+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2++isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)++isFilledMetaTyVar :: TcTyVar -> TcS Bool+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = wrapTcS (TcM.zonkWC wc)++zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)++----------------------------+pprKicked :: Int -> SDoc+pprKicked 0 = empty+pprKicked n = parens (int n <+> text "kicked out")++{- *********************************************************************+*                                                                      *+*              The Unification Level Flag                              *+*                                                                      *+********************************************************************* -}++{- Note [The Unification Level Flag]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a deep tree of implication constraints+   forall[1] a.                              -- Outer-implic+      C alpha[1]                               -- Simple+      forall[2] c. ....(C alpha[1])....        -- Implic-1+      forall[2] b. ....(alpha[1] ~ Int)....    -- Implic-2++The (C alpha) is insoluble until we know alpha.  We solve alpha+by unifying alpha:=Int somewhere deep inside Implic-2. But then we+must try to solve the Outer-implic all over again. This time we can+solve (C alpha) both in Outer-implic, and nested inside Implic-1.++When should we iterate solving a level-n implication?+Answer: if any unification of a tyvar at level n takes place+        in the ic_implics of that implication.++* What if a unification takes place at level n-1? Then don't iterate+  level n, because we'll iterate level n-1, and that will in turn iterate+  level n.++* What if a unification takes place at level n, in the ic_simples of+  level n?  No need to track this, because the kick-out mechanism deals+  with it.  (We can't drop kick-out in favour of iteration, because kick-out+  works for skolem-equalities, not just unifications.)++So the monad-global Unification Level Flag, kept in tcs_unif_lvl keeps+track of+  - Whether any unifications at all have taken place (Nothing => no unifications)+  - If so, what is the outermost level that has seen a unification (Just lvl)++The iteration done in the simplify_loop/maybe_simplify_again loop in GHC.Tc.Solver.++It helpful not to iterate unless there is a chance of progress.  #8474 is+an example:++  * There's a deeply-nested chain of implication constraints.+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int++  * From the innermost one we get a [D] alpha[1] ~ Int,+    so we can unify.++  * It's better not to iterate the inner implications, but go all the+    way out to level 1 before iterating -- because iterating level 1+    will iterate the inner levels anyway.++(In the olden days when we "floated" thse Derived constraints, this was+much, much more important -- we got exponential behaviour, as each iteration+produced the same Derived constraint.)+-}+++resetUnificationFlag :: TcS Bool+-- We are at ambient level i+-- If the unification flag = Just i, reset it to Nothing and return True+-- Otherwise leave it unchanged and return False+resetUnificationFlag+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; ambient_lvl <- TcM.getTcLevel+       ; mb_lvl <- TcM.readTcRef ref+       ; TcM.traceTc "resetUnificationFlag" $+         vcat [ text "ambient:" <+> ppr ambient_lvl+              , text "unif_lvl:" <+> ppr mb_lvl ]+       ; case mb_lvl of+           Nothing       -> return False+           Just unif_lvl | ambient_lvl `strictlyDeeperThan` unif_lvl+                         -> return False+                         | otherwise+                         -> do { TcM.writeTcRef ref Nothing+                               ; return True } }++setUnificationFlag :: TcLevel -> TcS ()+-- (setUnificationFlag i) sets the unification level to (Just i)+-- unless it already is (Just j) where j <= i+setUnificationFlag lvl+  = TcS $ \env ->+    do { let ref = tcs_unif_lvl env+       ; mb_lvl <- TcM.readTcRef ref+       ; case mb_lvl of+           Just unif_lvl | lvl `deeperThanOrSame` unif_lvl+                         -> return ()+           _ -> TcM.writeTcRef ref (Just lvl) }+++{- *********************************************************************+*                                                                      *+*                Instantiation etc.+*                                                                      *+********************************************************************* -}++-- Instantiations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)+instDFunType dfun_id inst_tys+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys++newFlexiTcSTy :: Kind -> TcS TcType+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)++cloneMetaTyVar :: TcTyVar -> TcS TcTyVar+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)++instFlexi :: [TKVar] -> TcS TCvSubst+instFlexi = instFlexiX emptyTCvSubst++instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst+instFlexiX subst tvs+  = wrapTcS (foldlM instFlexiHelper subst tvs)++instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+instFlexiHelper subst tv+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name = setNameUnique (tyVarName tv) uniq+             kind = substTyUnchecked subst (tyVarKind tv)+             ty'  = mkTyVarTy (mkTcTyVar name kind details)+       ; TcM.traceTc "instFlexi" (ppr ty')+       ; return (extendTvSubst subst tv ty') }++matchGlobalInst :: DynFlags+                -> Bool      -- True <=> caller is the short-cut solver+                             -- See Note [Shortcut solving: overlap]+                -> Class -> [Type] -> TcS TcM.ClsInstResult+matchGlobalInst dflags short_cut cls tys+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh CtEvidence | Cached EvExpr++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [CtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvExpr :: MaybeNew -> EvExpr+getEvExpr (Fresh ctev) = ctEvExpr ctev+getEvExpr (Cached evt) = evt++setEvBind :: EvBind -> TcS ()+setEvBind ev_bind+  = do { evb <- getTcEvBindsVar+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }++-- | Mark variables as used filling a coercion hole+useVars :: CoVarSet -> TcS ()+useVars co_vars+  = do { ev_binds_var <- getTcEvBindsVar+       ; let ref = ebv_tcvs ev_binds_var+       ; wrapTcS $+         do { tcvs <- TcM.readTcRef ref+            ; let tcvs' = tcvs `unionVarSet` co_vars+            ; TcM.writeTcRef ref tcvs' } }++-- | Equalities only+setWantedEq :: TcEvDest -> Coercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)++-- | Good for both equalities and non-equalities+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) tm+  | Just co <- evTermCoercion_maybe tm+  = do { useVars (coVarsOfCo co)+       ; fillCoercionHole hole co }+  | otherwise+  = -- See Note [Yukky eq_sel for a HoleDest]+    do { let co_var = coHoleCoVar hole+       ; setEvBind (mkWantedEvBind co_var tm)+       ; fillCoercionHole hole (mkTcCoVarCo co_var) }++setWantedEvTerm (EvVarDest ev_id) tm+  = setEvBind (mkWantedEvBind ev_id tm)++{- Note [Yukky eq_sel for a HoleDest]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How can it be that a Wanted with HoleDest gets evidence that isn't+just a coercion? i.e. evTermCoercion_maybe returns Nothing.++Consider [G] forall a. blah => a ~ T+         [W] S ~# T++Then doTopReactEqPred carefully looks up the (boxed) constraint (S ~+T) in the quantified constraints, and wraps the (boxed) evidence it+gets back in an eq_sel to extract the unboxed (S ~# T).  We can't put+that term into a coercion, so we add a value binding+    h = eq_sel (...)+and the coercion variable h to fill the coercion hole.+We even re-use the CoHole's Id for this binding!++Yuk!+-}++fillCoercionHole :: CoercionHole -> Coercion -> TcS ()+fillCoercionHole hole co+  = do { wrapTcS $ TcM.fillCoercionHole hole co+       ; kickOutAfterFillingCoercionHole hole co }++setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev tm+  = case ev of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm+      _                             -> return ()++newTcEvBinds :: TcS EvBindsVar+newTcEvBinds = wrapTcS TcM.newTcEvBinds++newNoTcEvBinds :: TcS EvBindsVar+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds++newEvVar :: TcPredType -> TcS EvVar+newEvVar pred = wrapTcS (TcM.newEvVar pred)++newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence+-- Make a new variable of the given PredType,+-- immediately bind it to the given term+-- and return its CtEvidence+-- See Note [Bind new Givens immediately] in GHC.Tc.Types.Constraint+newGivenEvVar loc (pred, rhs)+  = do { new_ev <- newBoundEvVarId pred rhs+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }++-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the+-- given term+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar+newBoundEvVarId pred rhs+  = do { new_ev <- newEvVar pred+       ; setEvBind (mkGivenEvBind new_ev rhs)+       ; return new_ev }++newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts++emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc role ty1 ty2+  = do { (ev, co) <- newWantedEq loc role ty1 ty2+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))+       ; return co }++-- | Make a new equality CtEvidence+newWantedEq :: CtLoc -> Role -> TcType -> TcType+            -> TcS (CtEvidence, Coercion)+newWantedEq = newWantedEq_SI WDeriv++newWantedEq_SI :: ShadowInfo -> CtLoc -> Role+               -> TcType -> TcType+               -> TcS (CtEvidence, Coercion)+newWantedEq_SI si loc role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)+       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole+                           , ctev_nosh = si+                           , ctev_loc = loc}+                , mkHoleCo hole ) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- no equalities here. Use newWantedEq instead+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence+newWantedEvVarNC = newWantedEvVarNC_SI WDeriv++newWantedEvVarNC_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS CtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC_SI si loc pty+  = do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev+                          , ctev_nosh = si+                          , ctev_loc = loc })}++newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew+newWantedEvVar = newWantedEvVar_SI WDeriv++newWantedEvVar_SI :: ShadowInfo -> CtLoc -> TcPredType -> TcS MaybeNew+-- For anything except ClassPred, this is the same as newWantedEvVarNC+newWantedEvVar_SI si loc pty+  = do { mb_ct <- lookupInInerts loc pty+       ; case mb_ct of+            Just ctev+              | not (isDerived ctev)+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev+                    ; return $ Cached (ctEvExpr ctev) }+            _ -> do { ctev <- newWantedEvVarNC_SI si loc pty+                    ; return (Fresh ctev) } }++newWanted :: CtLoc -> PredType -> TcS MaybeNew+-- Deals with both equalities and non equalities. Tries to look+-- up non-equalities in the cache+newWanted = newWanted_SI WDeriv++newWanted_SI :: ShadowInfo -> CtLoc -> PredType -> TcS MaybeNew+newWanted_SI si loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq_SI si loc role ty1 ty2+  | otherwise+  = newWantedEvVar_SI si loc pty++-- deals with both equalities and non equalities. Doesn't do any cache lookups.+newWantedNC :: CtLoc -> PredType -> TcS CtEvidence+newWantedNC loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc pty++emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()+emitNewDeriveds loc preds+  | null preds+  = return ()+  | otherwise+  = do { evs <- mapM (newDerivedNC loc) preds+       ; traceTcS "Emitting new deriveds" (ppr evs)+       ; updWorkListTcS (extendWorkListDeriveds evs) }++emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new equality Derived and put it in the work list+-- There's no caching, no lookupInInerts+emitNewDerivedEq loc role ty1 ty2+  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)+       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }+         -- Very important: put in the wl_eqs+         -- See Note [Prioritise equalities] (Avoiding fundep iteration)++newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence+newDerivedNC loc pred+  = return $ CtDerived { ctev_pred = pred, ctev_loc = loc }++-- --------- Check done in GHC.Tc.Solver.Interact.selectNewWorkItem???? ---------+-- | Checks if the depth of the given location is too much. Fails if+-- it's too big, with an appropriate error message.+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced+                    -> TcS ()+checkReductionDepth loc ty+  = do { dflags <- getDynFlags+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $+         wrapErrTcS $+         solverDepthErrorTcS loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe (CoercionN, TcType))+-- Given (F tys) return (ty, co), where co :: ty ~N F tys+matchFam tycon args = fmap (fmap (first mkTcSymCo)) $ wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (CoercionN, TcType))+-- Given (F tys) return (ty, co), where co :: F tys ~N ty+matchFamTcM tycon args+  = do { fam_envs <- FamInst.tcGetFamInstEnvs+       ; let match_fam_result+              = reduceTyFamApp_maybe fam_envs Nominal tycon args+       ; TcM.traceTc "matchFamTcM" $+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)+              , ppr_res match_fam_result ]+       ; return match_fam_result }+  where+    ppr_res Nothing        = text "Match failed"+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")+                                2 (vcat [ text "Rewrites to:" <+> ppr ty+                                        , text "Coercion:" <+> ppr co ])++{-+Note [Residual implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wl_implics in the WorkList are the residual implication+constraints that are generated while solving or canonicalising the+current worklist.  Specifically, when canonicalising+   (forall a. t1 ~ forall a. t2)+from which we get the implication+   (forall a. t1 ~ t2)+See GHC.Tc.Solver.Monad.deferTcSForAllEq+-}++{-+************************************************************************+*                                                                      *+              Breaking type variable cycles+*                                                                      *+************************************************************************+-}++-- | Conditionally replace all type family applications in the RHS with fresh+-- variables, emitting givens that relate the type family application to the+-- variable. See Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+-- This only works under conditions as described in the Note; otherwise, returns+-- Nothing.+breakTyVarCycle_maybe :: CtEvidence+                      -> CheckTyEqResult   -- result of checkTypeEq+                      -> CanEqLHS+                      -> TcType     -- RHS+                      -> TcS (Maybe (TcTyVar, CoercionN, TcType))+                         -- new RHS that doesn't have any type families+                         -- co :: new type ~N old type+                         -- TcTyVar is the LHS tv; convenient for the caller+breakTyVarCycle_maybe (ctLocOrigin . ctEvLoc -> CycleBreakerOrigin _) _ _ _+  -- see Detail (7) of Note+  = return Nothing++breakTyVarCycle_maybe ev cte_result (TyVarLHS lhs_tv) rhs+  | NomEq <- eq_rel++  , cte_result `cterHasOnlyProblem` cteSolubleOccurs+     -- only do this if the only problem is a soluble occurs-check+     -- See Detail (8) of the Note.++  = do { should_break <- final_check+       ; if should_break then do { (co, new_rhs) <- go rhs+                                 ; return (Just (lhs_tv, co, new_rhs)) }+                         else return Nothing }+  where+    flavour = ctEvFlavour ev+    eq_rel  = ctEvEqRel ev++    final_check+      | Given <- flavour+      = return True+      | ctFlavourContainsDerived flavour+      = do { result <- touchabilityTest Derived lhs_tv rhs+           ; return $ case result of+               Untouchable -> False+               _           -> True }+      | otherwise+      = return False++    -- This could be considerably more efficient. See Detail (5) of Note.+    go :: TcType -> TcS (CoercionN, TcType)+    go ty | Just ty' <- rewriterView ty = go ty'+    go (Rep.TyConApp tc tys)+      | isTypeFamilyTyCon tc  -- worried about whether this type family is not actually+                              -- causing trouble? See Detail (5) of Note.+      = do { let (fun_args, extra_args) = splitAt (tyConArity tc) tys+                 fun_app                = mkTyConApp tc fun_args+                 fun_app_kind           = tcTypeKind fun_app+           ; (co, new_ty) <- emit_work fun_app_kind fun_app+           ; (extra_args_cos, extra_args') <- mapAndUnzipM go extra_args+           ; return (mkAppCos co extra_args_cos, mkAppTys new_ty extra_args') }+              -- Worried that this substitution will change kinds?+              -- See Detail (3) of Note++      | otherwise+      = do { (cos, tys) <- mapAndUnzipM go tys+           ; return (mkTyConAppCo Nominal tc cos, mkTyConApp tc tys) }++    go (Rep.AppTy ty1 ty2)+      = do { (co1, ty1') <- go ty1+           ; (co2, ty2') <- go ty2+           ; return (mkAppCo co1 co2, mkAppTy ty1' ty2') }+    go (Rep.FunTy vis w arg res)+      = do { (co_w, w') <- go w+           ; (co_arg, arg') <- go arg+           ; (co_res, res') <- go res+           ; return (mkFunCo Nominal co_w co_arg co_res, mkFunTy vis w' arg' res') }+    go (Rep.CastTy ty cast_co)+      = do { (co, ty') <- go ty+             -- co :: ty' ~N ty+             -- return_co :: (ty' |> cast_co) ~ (ty |> cast_co)+           ; return (castCoercionKind1 co Nominal ty' ty cast_co, mkCastTy ty' cast_co) }++    go ty@(Rep.TyVarTy {})    = skip ty+    go ty@(Rep.LitTy {})      = skip ty+    go ty@(Rep.ForAllTy {})   = skip ty  -- See Detail (1) of Note+    go ty@(Rep.CoercionTy {}) = skip ty  -- See Detail (2) of Note++    skip ty = return (mkNomReflCo ty, ty)++    emit_work :: TcKind                   -- of the function application+              -> TcType                   -- original function application+              -> TcS (CoercionN, TcType)  -- rewritten type (the fresh tyvar)+    emit_work fun_app_kind fun_app = case flavour of+      Given ->+        do { new_tv <- wrapTcS (TcM.newCycleBreakerTyVar fun_app_kind)+           ; let new_ty     = mkTyVarTy new_tv+                 given_pred = mkHeteroPrimEqPred fun_app_kind fun_app_kind+                                                 fun_app new_ty+                 given_term = evCoercion $ mkNomReflCo new_ty  -- See Detail (4) of Note+           ; new_given <- newGivenEvVar new_loc (given_pred, given_term)+           ; traceTcS "breakTyVarCycle replacing type family in Given" (ppr new_given)+           ; emitWorkNC [new_given]+           ; updInertTcS $ \is ->+               is { inert_cycle_breakers = (new_tv, fun_app) :+                                           inert_cycle_breakers is }+           ; return (mkNomReflCo new_ty, new_ty) }+                -- Why reflexive? See Detail (4) of the Note++      _derived_or_wd ->+        do { new_tv <- wrapTcS (TcM.newFlexiTyVar fun_app_kind)+           ; let new_ty = mkTyVarTy new_tv+           ; co <- emitNewWantedEq new_loc Nominal new_ty fun_app+           ; return (co, new_ty) }++      -- See Detail (7) of the Note+    new_loc = updateCtLocOrigin (ctEvLoc ev) CycleBreakerOrigin++-- does not fit scenario from Note+breakTyVarCycle_maybe _ _ _ _ = return Nothing++-- | Fill in CycleBreakerTvs with the variables they stand for.+-- See Note [Type variable cycles] in GHC.Tc.Solver.Canonical.+restoreTyVarCycles :: InertSet -> TcM ()+restoreTyVarCycles is+  = forM_ (inert_cycle_breakers is) $ \ (cycle_breaker_tv, orig_ty) ->+    TcM.writeMetaTyVar cycle_breaker_tv orig_ty++-- Unwrap a type synonym only when either:+--   The type synonym is forgetful, or+--   the type synonym mentions a type family in its expansion+-- See Note [Rewriting synonyms] in GHC.Tc.Solver.Rewrite.+rewriterView :: TcType -> Maybe TcType+rewriterView ty@(Rep.TyConApp tc _)+  | isForgetfulSynTyCon tc || (isTypeSynonymTyCon tc && not (isFamFreeTyCon tc))+  = tcView ty+rewriterView _other = Nothing

+ GHC/Tc/Solver/Rewrite.hs view

@@ -0,0 +1,1046 @@+{-# LANGUAGE BangPatterns  #-}+{-# LANGUAGE CPP           #-}+{-# LANGUAGE DeriveFunctor #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Tc.Solver.Rewrite(+   rewrite, rewriteKind, rewriteArgsNom,+   rewriteType+ ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Core.TyCo.Ppr ( pprTyVar )+import GHC.Tc.Types.Constraint+import GHC.Core.Predicate+import GHC.Tc.Utils.TcType+import GHC.Core.Type+import GHC.Tc.Types.Evidence+import GHC.Core.TyCon+import GHC.Core.TyCo.Rep   -- performs delicate algorithm on types+import GHC.Core.Coercion+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Driver.Session+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Tc.Solver.Monad as TcS++import GHC.Utils.Misc+import GHC.Data.Maybe+import GHC.Exts (oneShot)+import Control.Monad+import GHC.Utils.Monad ( zipWith3M )+import Data.List.NonEmpty ( NonEmpty(..) )++import Control.Arrow ( first )++{-+************************************************************************+*                                                                      *+*                RewriteEnv & RewriteM+*             The rewriting environment & monad+*                                                                      *+************************************************************************+-}++data RewriteEnv+  = FE { fe_loc     :: !CtLoc             -- See Note [Rewriter CtLoc]+       , fe_flavour :: !CtFlavour+       , fe_eq_rel  :: !EqRel             -- See Note [Rewriter EqRels]+       }++-- | The 'RewriteM' monad is a wrapper around 'TcS' with a 'RewriteEnv'+newtype RewriteM a+  = RewriteM { runRewriteM :: RewriteEnv -> TcS a }+  deriving (Functor)++-- | Smart constructor for 'RewriteM', as describe in Note [The one-shot state+-- monad trick] in "GHC.Utils.Monad".+mkRewriteM :: (RewriteEnv -> TcS a) -> RewriteM a+mkRewriteM f = RewriteM (oneShot f)+{-# INLINE mkRewriteM #-}++instance Monad RewriteM where+  m >>= k  = mkRewriteM $ \env ->+             do { a  <- runRewriteM m env+                ; runRewriteM (k a) env }++instance Applicative RewriteM where+  pure x = mkRewriteM $ \_ -> pure x+  (<*>) = ap++instance HasDynFlags RewriteM where+  getDynFlags = liftTcS getDynFlags++liftTcS :: TcS a -> RewriteM a+liftTcS thing_inside+  = mkRewriteM $ \_ -> thing_inside++-- convenient wrapper when you have a CtEvidence describing+-- the rewriting operation+runRewriteCtEv :: CtEvidence -> RewriteM a -> TcS a+runRewriteCtEv ev+  = runRewrite (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)++-- Run thing_inside (which does the rewriting)+runRewrite :: CtLoc -> CtFlavour -> EqRel -> RewriteM a -> TcS a+runRewrite loc flav eq_rel thing_inside+  = runRewriteM thing_inside fmode+  where+    fmode = FE { fe_loc  = loc+               , fe_flavour = flav+               , fe_eq_rel = eq_rel }++traceRewriteM :: String -> SDoc -> RewriteM ()+traceRewriteM herald doc = liftTcS $ traceTcS herald doc+{-# INLINE traceRewriteM #-}  -- see Note [INLINE conditional tracing utilities]++getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a+getRewriteEnvField accessor+  = mkRewriteM $ \env -> return (accessor env)++getEqRel :: RewriteM EqRel+getEqRel = getRewriteEnvField fe_eq_rel++getRole :: RewriteM Role+getRole = eqRelRole <$> getEqRel++getFlavour :: RewriteM CtFlavour+getFlavour = getRewriteEnvField fe_flavour++getFlavourRole :: RewriteM CtFlavourRole+getFlavourRole+  = do { flavour <- getFlavour+       ; eq_rel <- getEqRel+       ; return (flavour, eq_rel) }++getLoc :: RewriteM CtLoc+getLoc = getRewriteEnvField fe_loc++checkStackDepth :: Type -> RewriteM ()+checkStackDepth ty+  = do { loc <- getLoc+       ; liftTcS $ checkReductionDepth loc ty }++-- | Change the 'EqRel' in a 'RewriteM'.+setEqRel :: EqRel -> RewriteM a -> RewriteM a+setEqRel new_eq_rel thing_inside+  = mkRewriteM $ \env ->+    if new_eq_rel == fe_eq_rel env+    then runRewriteM thing_inside env+    else runRewriteM thing_inside (env { fe_eq_rel = new_eq_rel })+{-# INLINE setEqRel #-}++-- | Make sure that rewriting actually produces a coercion (in other+-- words, make sure our flavour is not Derived)+-- Note [No derived kind equalities]+noBogusCoercions :: RewriteM a -> RewriteM a+noBogusCoercions thing_inside+  = mkRewriteM $ \env ->+    -- No new thunk is made if the flavour hasn't changed (note the bang).+    let !env' = case fe_flavour env of+          Derived -> env { fe_flavour = Wanted WDeriv }+          _       -> env+    in+    runRewriteM thing_inside env'++bumpDepth :: RewriteM a -> RewriteM a+bumpDepth (RewriteM thing_inside)+  = mkRewriteM $ \env -> do+      -- bumpDepth can be called a lot during rewriting so we force the+      -- new env to avoid accumulating thunks.+      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }+      ; thing_inside env' }++{-+Note [Rewriter EqRels]+~~~~~~~~~~~~~~~~~~~~~~~+When rewriting, we need to know which equality relation -- nominal+or representation -- we should be respecting. The only difference is+that we rewrite variables by representational equalities when fe_eq_rel+is ReprEq, and that we unwrap newtypes when rewriting w.r.t.+representational equality.++Note [Rewriter CtLoc]+~~~~~~~~~~~~~~~~~~~~~~+The rewriter does eager type-family reduction.+Type families might loop, and we+don't want GHC to do so. A natural solution is to have a bounded depth+to these processes. A central difficulty is that such a solution isn't+quite compositional. For example, say it takes F Int 10 steps to get to Bool.+How many steps does it take to get from F Int -> F Int to Bool -> Bool?+10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to+know and hard to track. So, we punt, essentially. We store a CtLoc in+the RewriteEnv and just update the environment when recurring. In the+TyConApp case, where there may be multiple type families to rewrite,+we just copy the current CtLoc into each branch. If any branch hits the+stack limit, then the whole thing fails.++A consequence of this is that setting the stack limits appropriately+will be essentially impossible. So, the official recommendation if a+stack limit is hit is to disable the check entirely. Otherwise, there+will be baffling, unpredictable errors.++Note [Phantoms in the rewriter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++data Proxy p = Proxy++and we're rewriting (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`+is really irrelevant -- it will be ignored when solving for representational+equality later on. So, we omit rewriting `ty` entirely. This may+violate the expectation of "xi"s for a bit, but the canonicaliser will+soon throw out the phantoms when decomposing a TyConApp. (Or, the+canonicaliser will emit an insoluble, in which case we get+a better error message anyway.)++Note [No derived kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A kind-level coercion can appear in types, via mkCastTy. So, whenever+we are generating a coercion in a dependent context (in other words,+in a kind) we need to make sure that our flavour is never Derived+(as Derived constraints have no evidence). The noBogusCoercions function+changes the flavour from Derived just for this purpose.++-}++{- *********************************************************************+*                                                                      *+*      Externally callable rewriting functions                         *+*                                                                      *+************************************************************************+-}++-- | See Note [Rewriting].+-- If (xi, co) <- rewrite mode ev ty, then co :: xi ~r ty+-- where r is the role in @ev@.+rewrite :: CtEvidence -> TcType+        -> TcS (Xi, TcCoercion)+rewrite ev ty+  = do { traceTcS "rewrite {" (ppr ty)+       ; (ty', co) <- runRewriteCtEv ev (rewrite_one ty)+       ; traceTcS "rewrite }" (ppr ty')+       ; return (ty', co) }++-- specialized to rewriting kinds: never Derived, always Nominal+-- See Note [No derived kind equalities]+-- See Note [Rewriting]+rewriteKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)+rewriteKind loc flav ty+  = do { traceTcS "rewriteKind {" (ppr flav <+> ppr ty)+       ; let flav' = case flav of+                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not+                       _       -> flav+       ; (ty', co) <- runRewrite loc flav' NomEq (rewrite_one ty)+       ; traceTcS "rewriteKind }" (ppr ty' $$ ppr co) -- co is never a panic+       ; return (ty', co) }++-- See Note [Rewriting]+rewriteArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion])+-- Externally-callable, hence runRewrite+-- Rewrite a vector of types all at once; in fact they are+-- always the arguments of type family or class, so+--      ctEvFlavour ev = Nominal+-- and we want to rewrite all at nominal role+-- The kind passed in is the kind of the type family or class, call it T+-- The kind of T args must be constant (i.e. not depend on the args)+--+-- For Derived constraints the returned coercion may be undefined+-- because rewriting may use a Derived equality ([D] a ~ ty)+rewriteArgsNom ev tc tys+  = do { traceTcS "rewrite_args {" (vcat (map ppr tys))+       ; (tys', cos, kind_co)+           <- runRewriteCtEv ev (rewrite_args_tc tc Nothing tys)+       ; MASSERT( isReflMCo kind_co )+       ; traceTcS "rewrite }" (vcat (map ppr tys'))+       ; return (tys', cos) }++-- | Rewrite a type w.r.t. nominal equality. This is useful to rewrite+-- a type w.r.t. any givens. It does not do type-family reduction. This+-- will never emit new constraints. Call this when the inert set contains+-- only givens.+rewriteType :: CtLoc -> TcType -> TcS TcType+rewriteType loc ty+  = do { (xi, _) <- runRewrite loc Given NomEq $+                    rewrite_one ty+                     -- use Given flavor so that it is rewritten+                     -- only w.r.t. Givens, never Wanteds/Deriveds+                     -- (Shouldn't matter, if only Givens are present+                     -- anyway)+       ; return xi }++{- *********************************************************************+*                                                                      *+*           The main rewriting functions+*                                                                      *+********************************************************************* -}++{- Note [Rewriting]+~~~~~~~~~~~~~~~~~~~~+  rewrite ty  ==>   (xi, co)+    where+      xi has no reducible type functions+         has no skolems that are mapped in the inert set+         has no filled-in metavariables+      co :: xi ~ ty++Key invariants:+  (F0) co :: xi ~ zonk(ty')    where zonk(ty') ~ zonk(ty)+  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind+  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))++Note that it is rewrite's job to try to reduce *every type function it sees*.++Rewriting also:+  * zonks, removing any metavariables, and+  * applies the substitution embodied in the inert set++Because rewriting zonks and the returned coercion ("co" above) is also+zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,+we can rely on this fact:++  (F0) co :: xi ~ zonk(ty'), where zonk(ty') ~ zonk(ty)++Note that the left-hand type of co is *always* precisely xi. The right-hand+type may or may not be ty, however: if ty has unzonked filled-in metavariables,+then the right-hand type of co will be the zonk-equal to ty.+It is for this reason that we+occasionally have to explicitly zonk, when (co :: xi ~ ty) is important+even before we zonk the whole program. For example, see the RTRNotFollowed+case in rewriteTyVar.++Why have these invariants on rewriting? Because we sometimes use tcTypeKind+during canonicalisation, and we want this kind to be zonked (e.g., see+GHC.Tc.Solver.Canonical.canEqCanLHS).++Rewriting is always homogeneous. That is, the kind of the result of rewriting is+always the same as the kind of the input, modulo zonking. More formally:++  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))++This invariant means that the kind of a rewritten type might not itself be rewritten.++Note that we prefer to leave type synonyms unexpanded when possible,+so when the rewriter encounters one, it first asks whether its+transitive expansion contains any type function applications or is+forgetful -- that is, omits one or more type variables in its RHS.  If so,+it expands the synonym and proceeds; if not, it simply returns the+unexpanded synonym. See also Note [Rewriting synonyms].++Where do we actually perform rewriting within a type? See Note [Rewritable] in+GHC.Tc.Solver.Monad.++Note [rewrite_args performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In programs with lots of type-level evaluation, rewrite_args becomes+part of a tight loop. For example, see test perf/compiler/T9872a, which+calls rewrite_args a whopping 7,106,808 times. It is thus important+that rewrite_args be efficient.++Performance testing showed that the current implementation is indeed+efficient. It's critically important that zipWithAndUnzipM be+specialized to TcS, and it's also quite helpful to actually `inline`+it. On test T9872a, here are the allocation stats (Dec 16, 2014):++ * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap+ * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap+ * Specialized, inlined:         6,281,539,792 bytes allocated in the heap++To improve performance even further, rewrite_args_nom is split off+from rewrite_args, as nominal equality is the common case. This would+be natural to write using mapAndUnzipM, but even inlined, that function+is not as performant as a hand-written loop.++ * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap+ * hand-written recursion:       5,848,602,848 bytes allocated in the heap++If you make any change here, pay close attention to the T9872{a,b,c} tests+and T5321Fun.++If we need to make this yet more performant, a possible way forward is to+duplicate the rewriter code for the nominal case, and make that case+faster. This doesn't seem quite worth it, yet.++Note [rewrite_exact_fam_app performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Once we've got a rewritten rhs, we extend the famapp-cache to record+the result. Doing so can save lots of work when the same redex shows up more+than once. Note that we record the link from the redex all the way to its+*final* value, not just the single step reduction.++If we can reduce the family application right away (the first call+to try_to_reduce), we do *not* add to the cache. There are two possibilities+here: 1) we just read the result from the cache, or 2) we used one type+family instance. In either case, recording the result in the cache doesn't+save much effort the next time around. And adding to the cache here is+actually disastrous: it more than doubles the allocations for T9872a. So+we skip adding to the cache here.+-}++{-# INLINE rewrite_args_tc #-}+rewrite_args_tc+  :: TyCon         -- T+  -> Maybe [Role]  -- Nothing: ambient role is Nominal; all args are Nominal+                   -- Otherwise: no assumptions; use roles provided+  -> [Type]        -- Arg types [t1,..,tn]+  -> RewriteM ( [Xi]  -- List of rewritten args [x1,..,xn]+                   -- 1-1 corresp with [t1,..,tn]+           , [Coercion]  -- List of arg coercions [co1,..,con]+                         -- 1-1 corresp with [t1,..,tn]+                         --    coi :: xi ~r ti+           , MCoercionN) -- Result coercion, rco+                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))+rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet+  -- NB: TyCon kinds are always closed+  where+    (bndrs, named)+      = ty_con_binders_ty_binders' (tyConBinders tc)+    -- it's possible that the result kind has arrows (for, e.g., a type family)+    -- so we must split it+    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)+    !all_bndrs                           = bndrs `chkAppend` inner_bndrs+    !any_named_bndrs                     = named || inner_named+    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.++{-# INLINE rewrite_args #-}+rewrite_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are+                                     -- named.+             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars+             -> Maybe [Role] -> [Type]    -- these are in 1-to-1 correspondence+                                          -- Nothing: use all Nominal+             -> RewriteM ([Xi], [Coercion], MCoercionN)+-- Coercions :: Xi ~ Type, at roles given+-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)+-- That is, the third coercion relates the kind of some function (whose kind is+-- passed as the first parameter) instantiated at xis to the kind of that+-- function instantiated at the tys. This is useful in keeping rewriting+-- homoegeneous. The list of roles must be at least as long as the list of+-- types.+rewrite_args orig_binders+             any_named_bndrs+             orig_inner_ki+             orig_fvs+             orig_m_roles+             orig_tys+  = case (orig_m_roles, any_named_bndrs) of+      (Nothing, False) -> rewrite_args_fast orig_tys+      _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys+        where orig_roles = fromMaybe (repeat Nominal) orig_m_roles++{-# INLINE rewrite_args_fast #-}+-- | fast path rewrite_args, in which none of the binders are named and+-- therefore we can avoid tracking a lifting context.+-- There are many bang patterns in here. It's been observed that they+-- greatly improve performance of an optimized build.+-- The T9872 test cases are good witnesses of this fact.+rewrite_args_fast :: [Type]+                  -> RewriteM ([Xi], [Coercion], MCoercionN)+rewrite_args_fast orig_tys+  = fmap finish (iterate orig_tys)+  where++    iterate :: [Type]+            -> RewriteM ([Xi], [Coercion])+    iterate (ty:tys) = do+      (xi, co)   <- rewrite_one ty+      (xis, cos) <- iterate tys+      pure (xi : xis, co : cos)+    iterate [] = pure ([], [])++    {-# INLINE finish #-}+    finish :: ([Xi], [Coercion]) -> ([Xi], [Coercion], MCoercionN)+    finish (xis, cos) = (xis, cos, MRefl)++{-# INLINE rewrite_args_slow #-}+-- | Slow path, compared to rewrite_args_fast, because this one must track+-- a lifting context.+rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet+                  -> [Role] -> [Type]+                  -> RewriteM ([Xi], [Coercion], MCoercionN)+rewrite_args_slow binders inner_ki fvs roles tys+-- Arguments used dependently must be rewritten with proper coercions, but+-- we're not guaranteed to get a proper coercion when rewriting with the+-- "Derived" flavour. So we must call noBogusCoercions when rewriting arguments+-- corresponding to binders that are dependent. However, we might legitimately+-- have *more* arguments than binders, in the case that the inner_ki is a variable+-- that gets instantiated with a Π-type. We conservatively choose not to produce+-- bogus coercions for these, too. Note that this might miss an opportunity for+-- a Derived rewriting a Derived. The solution would be to generate evidence for+-- Deriveds, thus avoiding this whole noBogusCoercions idea. See also+-- Note [No derived kind equalities]+  = do { rewritten_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)+                                        roles tys+       ; return (simplifyArgsWorker binders inner_ki fvs roles rewritten_args) }+  where+    {-# INLINE fl #-}+    fl :: Bool   -- must we ensure to produce a real coercion here?+                  -- see comment at top of function+       -> Role -> Type -> RewriteM (Xi, Coercion)+    fl True  r ty = noBogusCoercions $ fl1 r ty+    fl False r ty =                    fl1 r ty++    {-# INLINE fl1 #-}+    fl1 :: Role -> Type -> RewriteM (Xi, Coercion)+    fl1 Nominal ty+      = setEqRel NomEq $+        rewrite_one ty++    fl1 Representational ty+      = setEqRel ReprEq $+        rewrite_one ty++    fl1 Phantom ty+    -- See Note [Phantoms in the rewriter]+      = do { ty <- liftTcS $ zonkTcType ty+           ; return (ty, mkReflCo Phantom ty) }++------------------+rewrite_one :: TcType -> RewriteM (Xi, Coercion)+-- Rewrite a type to get rid of type function applications, returning+-- the new type-function-free type, and a collection of new equality+-- constraints.  See Note [Rewriting] for more detail.+--+-- Postcondition: Coercion :: Xi ~ TcType+-- The role on the result coercion matches the EqRel in the RewriteEnv++rewrite_one ty+  | Just ty' <- rewriterView ty  -- See Note [Rewriting synonyms]+  = rewrite_one ty'++rewrite_one xi@(LitTy {})+  = do { role <- getRole+       ; return (xi, mkReflCo role xi) }++rewrite_one (TyVarTy tv)+  = rewriteTyVar tv++rewrite_one (AppTy ty1 ty2)+  = rewrite_app_tys ty1 [ty2]++rewrite_one (TyConApp tc tys)+  -- If it's a type family application, try to reduce it+  | isTypeFamilyTyCon tc+  = rewrite_fam_app tc tys++  -- For * a normal data type application+  --     * data family application+  -- we just recursively rewrite the arguments.+  | otherwise+  = rewrite_ty_con_app tc tys++rewrite_one ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })+  = do { (xi1,co1) <- rewrite_one ty1+       ; (xi2,co2) <- rewrite_one ty2+       ; (xi3,co3) <- setEqRel NomEq $ rewrite_one mult+       ; role <- getRole+       ; return (ty { ft_mult = xi3, ft_arg = xi1, ft_res = xi2 }+                , mkFunCo role co3 co1 co2) }++rewrite_one ty@(ForAllTy {})+-- TODO (RAE): This is inadequate, as it doesn't rewrite the kind of+-- the bound tyvar. Doing so will require carrying around a substitution+-- and the usual substTyVarBndr-like silliness. Argh.++-- We allow for-alls when, but only when, no type function+-- applications inside the forall involve the bound type variables.+  = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty+             tvs           = binderVars bndrs+       ; (rho', co) <- rewrite_one rho+       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }++rewrite_one (CastTy ty g)+  = do { (xi, co) <- rewrite_one ty+       ; (g', _)  <- rewrite_co g+       ; role <- getRole+       ; return (mkCastTy xi g', castCoercionKind1 co role xi ty g') }+         -- It makes a /big/ difference to call castCoercionKind1 not+         -- the more general castCoercionKind2.+         -- See Note [castCoercionKind1] in GHC.Core.Coercion++rewrite_one (CoercionTy co) = first mkCoercionTy <$> rewrite_co co++-- | "Rewrite" a coercion. Really, just zonk it so we can uphold+-- (F1) of Note [Rewriting]+rewrite_co :: Coercion -> RewriteM (Coercion, Coercion)+rewrite_co co+  = do { co <- liftTcS $ zonkCo co+       ; env_role <- getRole+       ; let co' = mkTcReflCo env_role (mkCoercionTy co)+       ; return (co, co') }++-- rewrite (nested) AppTys+rewrite_app_tys :: Type -> [Type] -> RewriteM (Xi, Coercion)+-- commoning up nested applications allows us to look up the function's kind+-- only once. Without commoning up like this, we would spend a quadratic amount+-- of time looking up functions' types+rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys)+rewrite_app_tys fun_ty arg_tys+  = do { (fun_xi, fun_co) <- rewrite_one fun_ty+       ; rewrite_app_ty_args fun_xi fun_co arg_tys }++-- Given a rewritten function (with the coercion produced by rewriting) and+-- a bunch of unrewritten arguments, rewrite the arguments and apply.+-- The coercion argument's role matches the role stored in the RewriteM monad.+--+-- The bang patterns used here were observed to improve performance. If you+-- wish to remove them, be sure to check for regeressions in allocations.+rewrite_app_ty_args :: Xi -> Coercion -> [Type] -> RewriteM (Xi, Coercion)+rewrite_app_ty_args fun_xi fun_co []+  -- this will be a common case when called from rewrite_fam_app, so shortcut+  = return (fun_xi, fun_co)+rewrite_app_ty_args fun_xi fun_co arg_tys+  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of+           Just (tc, xis) ->+             do { let tc_roles  = tyConRolesRepresentational tc+                      arg_roles = dropList xis tc_roles+                ; (arg_xis, arg_cos, kind_co)+                    <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys++                  -- Here, we have fun_co :: T xi1 xi2 ~ ty+                  -- and we need to apply fun_co to the arg_cos. The problem is+                  -- that using mkAppCo is wrong because that function expects+                  -- its second coercion to be Nominal, and the arg_cos might+                  -- not be. The solution is to use transitivity:+                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>+                ; eq_rel <- getEqRel+                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)+                      app_co = case eq_rel of+                        NomEq  -> mkAppCos fun_co arg_cos+                        ReprEq -> mkTcTyConAppCo Representational tc+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)+                                  `mkTcTransCo`+                                  mkAppCos fun_co (map mkNomReflCo arg_tys)+                ; return (app_xi, app_co, kind_co) }+           Nothing ->+             do { (arg_xis, arg_cos, kind_co)+                    <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys+                ; let arg_xi = mkAppTys fun_xi arg_xis+                      arg_co = mkAppCos fun_co arg_cos+                ; return (arg_xi, arg_co, kind_co) }++       ; role <- getRole+       ; return (homogenise_result xi co role kind_co) }++rewrite_ty_con_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_ty_con_app tc tys+  = do { role <- getRole+       ; let m_roles | Nominal <- role = Nothing+                     | otherwise       = Just $ tyConRolesX role tc+       ; (xis, cos, kind_co) <- rewrite_args_tc tc m_roles tys+       ; let tyconapp_xi = mkTyConApp tc xis+             tyconapp_co = mkTyConAppCo role tc cos+       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }++-- Make the result of rewriting homogeneous (Note [Rewriting] (F2))+homogenise_result :: Xi              -- a rewritten type+                  -> Coercion        -- :: xi ~r original ty+                  -> Role            -- r+                  -> MCoercionN      -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)+                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)+                                     --   ~r original ty)+homogenise_result xi co _ MRefl = (xi, co)+homogenise_result xi co r mco@(MCo kind_co)+  = (xi `mkCastTy` kind_co, (mkSymCo $ GRefl r xi mco) `mkTransCo` co)+{-# INLINE homogenise_result #-}++-- Rewrite a vector (list of arguments).+rewrite_vector :: Kind   -- of the function being applied to these arguments+               -> [Role] -- If we're rewrite w.r.t. ReprEq, what roles do the+                         -- args have?+               -> [Type] -- the args to rewrite+               -> RewriteM ([Xi], [Coercion], MCoercionN)+rewrite_vector ki roles tys+  = do { eq_rel <- getEqRel+       ; case eq_rel of+           NomEq  -> rewrite_args bndrs+                                  any_named_bndrs+                                  inner_ki+                                  fvs+                                  Nothing+                                  tys+           ReprEq -> rewrite_args bndrs+                                  any_named_bndrs+                                  inner_ki+                                  fvs+                                  (Just roles)+                                  tys+       }+  where+    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki+    fvs                                = tyCoVarsOfType ki+{-# INLINE rewrite_vector #-}++{-+Note [Rewriting synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Not expanding synonyms aggressively improves error messages, and+keeps types smaller. But we need to take care.++Suppose+   type Syn a = Int+   type instance F Bool = Syn (F Bool)+   [G] F Bool ~ Syn (F Bool)++If we don't expand the synonym, we'll get a spurious occurs-check+failure. This is normally what occCheckExpand takes care of, but+the LHS is a type family application, and occCheckExpand (already+complex enough as it is) does not know how to expand to avoid+a type family application.++In addition, expanding the forgetful synonym like this+will generally yield a *smaller* type. To wit, if we spot+S ( ... F tys ... ), where S is forgetful, we don't want to bother+doing hard work simplifying (F tys). We thus expand forgetful+synonyms, but not others.++isForgetfulSynTyCon returns True more often than it needs to, so+we err on the side of more expansion.++We also, of course, must expand type synonyms that mention type families,+so those families can get reduced.++************************************************************************+*                                                                      *+             Rewriting a type-family application+*                                                                      *+************************************************************************++Note [How to normalise a family application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given an exactly saturated family application, how should we normalise it?+This Note spells out the algorithm and its reasoning.++STEP 1. Try the famapp-cache. If we get a cache hit, jump to FINISH.++STEP 2. Try top-level instances. Note that we haven't simplified the arguments+  yet. Example:+    type instance F (Maybe a) = Int+    target: F (Maybe (G Bool))+  Instead of first trying to simplify (G Bool), we use the instance first. This+  avoids the work of simplifying G Bool.++  If an instance is found, jump to FINISH.++STEP 3. Rewrite all arguments. This might expose more information so that we+  can use a top-level instance.++  Continue to the next step.++STEP 4. Try the inerts. Note that we try the inerts *after* rewriting the+  arguments, because the inerts will have rewritten LHSs.++  If an inert is found, jump to FINISH.++STEP 5. Try the famapp-cache again. Now that we've revealed more information+  in the arguments, the cache might be helpful.++  If we get a cache hit, jump to FINISH.++STEP 6. Try top-level instances, which might trigger now that we know more+  about the argumnents.++  If an instance is found, jump to FINISH.++STEP 7. No progress to be made. Return what we have. (Do not do FINISH.)++FINISH 1. We've made a reduction, but the new type may still have more+  work to do. So rewrite the new type.++FINISH 2. Add the result to the famapp-cache, connecting the type we started+  with to the one we ended with.++Because STEP 1/2 and STEP 5/6 happen the same way, they are abstracted into+try_to_reduce.++FINISH is naturally implemented in `finish`. But, Note [rewrite_exact_fam_app performance]+tells us that we should not add to the famapp-cache after STEP 1/2. So `finish`+is inlined in that case, and only FINISH 1 is performed.++-}++rewrite_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+  --   rewrite_fam_app            can be over-saturated+  --   rewrite_exact_fam_app      lifts out the application to top level+  -- Postcondition: Coercion :: Xi ~ F tys+rewrite_fam_app tc tys  -- Can be over-saturated+    = ASSERT2( tys `lengthAtLeast` tyConArity tc+             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)++                 -- Type functions are saturated+                 -- The type function might be *over* saturated+                 -- in which case the remaining arguments should+                 -- be dealt with by AppTys+      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys+         ; (xi1, co1) <- rewrite_exact_fam_app tc tys1+               -- co1 :: xi1 ~ F tys1++         ; rewrite_app_ty_args xi1 co1 tys_rest }++-- the [TcType] exactly saturate the TyCon+-- See Note [How to normalise a family application]+rewrite_exact_fam_app :: TyCon -> [TcType] -> RewriteM (Xi, Coercion)+rewrite_exact_fam_app tc tys+  = do { checkStackDepth (mkTyConApp tc tys)++       -- STEP 1/2. Try to reduce without reducing arguments first.+       ; result1 <- try_to_reduce tc tys+       ; case result1 of+             -- Don't use the cache;+             -- See Note [rewrite_exact_fam_app performance]+         { Just (co, xi) -> finish False (xi, co)+         ; Nothing ->++        -- That didn't work. So reduce the arguments, in STEP 3.+    do { eq_rel <- getEqRel+           -- checking eq_rel == NomEq saves ~0.5% in T9872a+       ; (xis, cos, kind_co) <- if eq_rel == NomEq+                                then rewrite_args_tc tc Nothing tys+                                else setEqRel NomEq $+                                     rewrite_args_tc tc Nothing tys+           -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)++       ; let role    = eqRelRole eq_rel+             args_co = mkTyConAppCo role tc cos+           -- args_co :: F xis ~r F tys++             homogenise :: TcType -> TcCoercion -> (TcType, TcCoercion)+               -- in (xi', co') = homogenise xi co+               --   assume co :: xi ~r F xis, co is homogeneous+               --   then xi' :: tcTypeKind(F tys)+               --   and co' :: xi' ~r F tys, which is homogeneous+             homogenise xi co = homogenise_result xi (co `mkTcTransCo` args_co) role kind_co++         -- STEP 4: try the inerts+       ; result2 <- liftTcS $ lookupFamAppInert tc xis+       ; flavour <- getFlavour+       ; case result2 of+         { Just (co, xi, fr@(_, inert_eq_rel))+             -- co :: F xis ~ir xi++             | fr `eqCanRewriteFR` (flavour, eq_rel) ->+                 do { traceRewriteM "rewrite family application with inert"+                                (ppr tc <+> ppr xis $$ ppr xi)+                    ; finish True (homogenise xi downgraded_co) }+               -- this will sometimes duplicate an inert in the cache,+               -- but avoiding doing so had no impact on performance, and+               -- it seems easier not to weed out that special case+             where+               inert_role    = eqRelRole inert_eq_rel+               role          = eqRelRole eq_rel+               downgraded_co = tcDowngradeRole role inert_role (mkTcSymCo co)+                 -- downgraded_co :: xi ~r F xis++         ; _ ->++         -- inert didn't work. Try to reduce again, in STEP 5/6.+    do { result3 <- try_to_reduce tc xis+       ; case result3 of+           Just (co, xi) -> finish True (homogenise xi co)+           Nothing       -> -- we have made no progress at all: STEP 7.+                            return (homogenise reduced (mkTcReflCo role reduced))+             where+               reduced = mkTyConApp tc xis }}}}}+  where+      -- call this if the above attempts made progress.+      -- This recursively rewrites the result and then adds to the cache+    finish :: Bool  -- add to the cache?+           -> (Xi, Coercion) -> RewriteM (Xi, Coercion)+    finish use_cache (xi, co)+      = do { -- rewrite the result: FINISH 1+             (fully, fully_co) <- bumpDepth $ rewrite_one xi+           ; let final_co = fully_co `mkTcTransCo` co+           ; eq_rel <- getEqRel+           ; flavour <- getFlavour++             -- extend the cache: FINISH 2+           ; when (use_cache && eq_rel == NomEq && flavour /= Derived) $+             -- the cache only wants Nominal eqs+             -- and Wanteds can rewrite Deriveds; the cache+             -- has only Givens+             liftTcS $ extendFamAppCache tc tys (final_co, fully)+           ; return (fully, final_co) }+    {-# INLINE finish #-}++-- Returned coercion is output ~r input, where r is the role in the RewriteM monad+-- See Note [How to normalise a family application]+try_to_reduce :: TyCon -> [TcType] -> RewriteM (Maybe (TcCoercion, TcType))+try_to_reduce tc tys+  = do { result <- liftTcS $ firstJustsM [ lookupFamAppCache tc tys  -- STEP 5+                                         , matchFam tc tys ]         -- STEP 6+       ; downgrade result }+  where+    -- The result above is always Nominal. We might want a Representational+    -- coercion; this downgrades (and prints, out of convenience).+    downgrade :: Maybe (TcCoercionN, TcType) -> RewriteM (Maybe (TcCoercion, TcType))+    downgrade Nothing = return Nothing+    downgrade result@(Just (co, xi))+      = do { traceRewriteM "Eager T.F. reduction success" $+             vcat [ ppr tc, ppr tys, ppr xi+                  , ppr co <+> dcolon <+> ppr (coercionKind co)+                  ]+           ; eq_rel <- getEqRel+              -- manually doing it this way avoids allocation in the vastly+              -- common NomEq case+           ; case eq_rel of+               NomEq  -> return result+               ReprEq -> return (Just (mkSubCo co, xi)) }++{-+************************************************************************+*                                                                      *+             Rewriting a type variable+*                                                                      *+********************************************************************* -}++-- | The result of rewriting a tyvar "one step".+data RewriteTvResult+  = RTRNotFollowed+      -- ^ The inert set doesn't make the tyvar equal to anything else++  | RTRFollowed TcType Coercion+      -- ^ The tyvar rewrites to a not-necessarily rewritten other type.+      -- co :: new type ~r old type, where the role is determined by+      -- the RewriteEnv+      --+      -- With Quick Look, the returned TcType can be a polytype;+      -- that is, in the constraint solver, a unification variable+      -- can contain a polytype.  See GHC.Tc.Gen.App+      -- Note [Instantiation variables are short lived]++rewriteTyVar :: TyVar -> RewriteM (Xi, Coercion)+rewriteTyVar tv+  = do { mb_yes <- rewrite_tyvar1 tv+       ; case mb_yes of+           RTRFollowed ty1 co1  -- Recur+             -> do { (ty2, co2) <- rewrite_one ty1+                   -- ; traceRewriteM "rewriteTyVar2" (ppr tv $$ ppr ty2)+                   ; return (ty2, co2 `mkTransCo` co1) }++           RTRNotFollowed   -- Done, but make sure the kind is zonked+                            -- Note [Rewriting] invariant (F0) and (F1)+             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv+                   ; role <- getRole+                   ; let ty' = mkTyVarTy tv'+                   ; return (ty', mkTcReflCo role ty') } }++rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult+-- "Rewriting" a type variable means to apply the substitution to it+-- Specifically, look up the tyvar in+--   * the internal MetaTyVar box+--   * the inerts+-- See also the documentation for RewriteTvResult++rewrite_tyvar1 tv+  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv+       ; case mb_ty of+           Just ty -> do { traceRewriteM "Following filled tyvar"+                             (ppr tv <+> equals <+> ppr ty)+                         ; role <- getRole+                         ; return (RTRFollowed ty (mkReflCo role ty)) } ;+           Nothing -> do { traceRewriteM "Unfilled tyvar" (pprTyVar tv)+                         ; fr <- getFlavourRole+                         ; rewrite_tyvar2 tv fr } }++rewrite_tyvar2 :: TcTyVar -> CtFlavourRole -> RewriteM RewriteTvResult+-- The tyvar is not a filled-in meta-tyvar+-- Try in the inert equalities+-- See Definition [Applying a generalised substitution] in GHC.Tc.Solver.Monad+-- See Note [Stability of rewriting] in GHC.Tc.Solver.Monad++rewrite_tyvar2 tv fr@(_, eq_rel)+  = do { ieqs <- liftTcS $ getInertEqs+       ; case lookupDVarEnv ieqs tv of+           Just (EqualCtList (ct :| _))   -- If the first doesn't work,+                                          -- the subsequent ones won't either+             | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS tv+                      , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct+             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)+             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR+             -> do { traceRewriteM "Following inert tyvar"+                        (ppr tv <+>+                         equals <+>+                         ppr rhs_ty $$ ppr ctev)+                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)+                          rewrite_co  = case (ct_eq_rel, eq_rel) of+                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )+                                    -- if this ASSERT fails, then+                                    -- eqCanRewriteFR answered incorrectly+                                               rewrite_co1+                            (NomEq, NomEq)  -> rewrite_co1+                            (NomEq, ReprEq) -> mkSubCo rewrite_co1++                    ; return (RTRFollowed rhs_ty rewrite_co) }+                    -- NB: ct is Derived then fmode must be also, hence+                    -- we are not going to touch the returned coercion+                    -- so ctEvCoercion is fine.++           _other -> return RTRNotFollowed }++{-+Note [An alternative story for the inert substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This entire note is just background, left here in case we ever want+ to return the previous state of affairs)++We used (GHC 7.8) to have this story for the inert substitution inert_eqs++ * 'a' is not in fvs(ty)+ * They are *inert* in the weaker sense that there is no infinite chain of+   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc++This means that rewriting must be recursive, but it does allow+  [G] a ~ [b]+  [G] b ~ Maybe c++This avoids "saturating" the Givens, which can save a modest amount of work.+It is easy to implement, in GHC.Tc.Solver.Interact.kick_out, by only kicking out an inert+only if (a) the work item can rewrite the inert AND+        (b) the inert cannot rewrite the work item++This is significantly harder to think about. It can save a LOT of work+in occurs-check cases, but we don't care about them much.  #5837+is an example, but it causes trouble only with the old (pre-Fall 2020)+rewriting story. It is unclear if there is any gain w.r.t. to+the new story.++-}++--------------------------------------+-- Utilities++-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at+-- least one named binder.+split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)+split_pi_tys' ty = split ty ty+  where+     -- put common cases first+  split _       (ForAllTy b res) = let -- This bang is necessary lest we see rather+                                       -- terrible reboxing, as noted in #19102.+                                       !(bs, ty, _) = split res res+                                   in  (Named b : bs, ty, True)+  split _       (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })+                                 = let -- See #19102+                                       !(bs, ty, named) = split res res+                                   in  (Anon af (mkScaled w arg) : bs, ty, named)++  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'+  split orig_ty _                = ([], orig_ty, False)+{-# INLINE split_pi_tys' #-}++-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff+-- there is at least one named binder.+ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)+ty_con_binders_ty_binders' = foldr go ([], False)+  where+    go (Bndr tv (NamedTCB vis)) (bndrs, _)+      = (Named (Bndr tv vis) : bndrs, True)+    go (Bndr tv (AnonTCB af))   (bndrs, n)+      = (Anon af (tymult (tyVarKind tv)) : bndrs, n)+    {-# INLINE go #-}+{-# INLINE ty_con_binders_ty_binders' #-}

GHC/Tc/TyCl.hs view

@@ -7,4923 +7,5225 @@ {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables, MultiWayIf #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}---- | Typecheck type and class declarations-module GHC.Tc.TyCl (-        tcTyAndClassDecls,--        -- Functions used by GHC.Tc.TyCl.Instance to check-        -- data/type family instance declarations-        kcConDecls, tcConDecls, dataDeclChecks, checkValidTyCon,-        tcFamTyPats, tcTyFamInstEqn,-        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,-        unravelFamInstPats, addConsistencyConstraints,-        wrongKindOfFamily-    ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Hs-import GHC.Driver.Types-import GHC.Tc.TyCl.Build-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Env-import GHC.Tc.Validity-import GHC.Tc.Utils.Zonk-import GHC.Tc.TyCl.Utils-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-import GHC.Builtin.Types (oneDataConTy,  unitTy, makeRecoveryTyCon )-import GHC.Tc.Utils.TcType-import GHC.Core.Multiplicity-import GHC.Rename.Env( lookupConstructorFields )-import GHC.Tc.Instance.Family-import GHC.Core.FamInstEnv-import GHC.Core.Coercion-import GHC.Tc.Types.Origin-import GHC.Core.Type-import GHC.Core.TyCo.Rep   -- for checkValidRoles-import GHC.Core.TyCo.Ppr( pprTyVars )-import GHC.Core.Class-import GHC.Core.Coercion.Axiom-import GHC.Core.TyCon-import GHC.Core.DataCon-import GHC.Types.Id-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Unit.Module-import GHC.Unit.State-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Types.Name.Env-import GHC.Utils.Outputable-import GHC.Data.Maybe-import GHC.Core.Unify-import GHC.Utils.Misc-import GHC.Types.SrcLoc-import GHC.Data.List.SetOps-import GHC.Driver.Session-import GHC.Types.Unique-import GHC.Core.ConLike( ConLike(..) )-import GHC.Types.Basic-import qualified GHC.LanguageExtensions as LangExt--import Control.Monad-import Data.Function ( on )-import Data.Functor.Identity-import Data.List-import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.Set as Set-import Data.Tuple( swap )--{--************************************************************************-*                                                                      *-\subsection{Type checking for type and class declarations}-*                                                                      *-************************************************************************--Note [Grouping of type and class declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly-connected component of mutually dependent types and classes. We kind check and-type check each group separately to enhance kind polymorphism. Take the-following example:--  type Id a = a-  data X = X (Id Int)--If we were to kind check the two declarations together, we would give Id the-kind * -> *, since we apply it to an Int in the definition of X. But we can do-better than that, since Id really is kind polymorphic, and should get kind-forall (k::*). k -> k. Since it does not depend on anything else, it can be-kind-checked by itself, hence getting the most general kind. We then kind check-X, which works fine because we then know the polymorphic kind of Id, and simply-instantiate k to *.--Note [Check role annotations in a second pass]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Role inference potentially depends on the types of all of the datacons declared-in a mutually recursive group. The validity of a role annotation, in turn,-depends on the result of role inference. Because the types of datacons might-be ill-formed (see #7175 and Note [Checking GADT return types]) we must check-*all* the tycons in a group for validity before checking *any* of the roles.-Thus, we take two passes over the resulting tycons, first checking for general-validity and then checking for valid role annotations.--}--tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in-                                            -- dependency order-                  -> TcM ( TcGblEnv         -- Input env extended by types and-                                            -- classes-                                            -- and their implicit Ids,DataCons-                         , [InstInfo GhcRn] -- Source-code instance decls info-                         , [DerivInfo]      -- Deriving info-                         )--- Fails if there are any errors-tcTyAndClassDecls tyclds_s-  -- The code recovers internally, but if anything gave rise to-  -- an error we'd better stop now, to avoid a cascade-  -- Type check each group in dependency order folding the global env-  = checkNoErrs $ fold_env [] [] tyclds_s-  where-    fold_env :: [InstInfo GhcRn]-             -> [DerivInfo]-             -> [TyClGroup GhcRn]-             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])-    fold_env inst_info deriv_info []-      = do { gbl_env <- getGblEnv-           ; return (gbl_env, inst_info, deriv_info) }-    fold_env inst_info deriv_info (tyclds:tyclds_s)-      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds-           ; setGblEnv tcg_env $-               -- remaining groups are typechecked in the extended global env.-             fold_env (inst_info' ++ inst_info)-                      (deriv_info' ++ deriv_info)-                      tyclds_s }--tcTyClGroup :: TyClGroup GhcRn-            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])--- Typecheck one strongly-connected component of type, class, and instance decls--- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls-tcTyClGroup (TyClGroup { group_tyclds = tyclds-                       , group_roles  = roles-                       , group_kisigs = kisigs-                       , group_instds = instds })-  = do { let role_annots = mkRoleAnnotEnv roles--           -- Step 1: Typecheck the standalone kind signatures and type/class declarations-       ; traceTc "---- tcTyClGroup ---- {" empty-       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))-       ; (tyclss, data_deriv_info) <--           tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]-           do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs-              ; tcTyClDecls tyclds kisig_env role_annots }--           -- Step 1.5: Make sure we don't have any type synonym cycles-       ; traceTc "Starting synonym cycle check" (ppr tyclss)-       ; this_uid <- fmap homeUnit getDynFlags-       ; checkSynCycles this_uid tyclss tyclds-       ; traceTc "Done synonym cycle check" (ppr tyclss)--           -- Step 2: Perform the validity check on those types/classes-           -- We can do this now because we are done with the recursive knot-           -- Do it before Step 3 (adding implicit things) because the latter-           -- expects well-formed TyCons-       ; traceTc "Starting validity check" (ppr tyclss)-       ; tyclss <- concatMapM checkValidTyCl tyclss-       ; traceTc "Done validity check" (ppr tyclss)-       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss-           -- See Note [Check role annotations in a second pass]--       ; traceTc "---- end tcTyClGroup ---- }" empty--           -- Step 3: Add the implicit things;-           -- we want them in the environment because-           -- they may be mentioned in interface files-       ; gbl_env <- addTyConsToGblEnv tyclss--           -- Step 4: check instance declarations-       ; (gbl_env', inst_info, datafam_deriv_info) <--         setGblEnv gbl_env $-         tcInstDecls1 instds--       ; let deriv_info = datafam_deriv_info ++ data_deriv_info-       ; return (gbl_env', inst_info, deriv_info) }---- Gives the kind for every TyCon that has a standalone kind signature-type KindSigEnv = NameEnv Kind--tcTyClDecls-  :: [LTyClDecl GhcRn]-  -> KindSigEnv-  -> RoleAnnotEnv-  -> TcM ([TyCon], [DerivInfo])-tcTyClDecls tyclds kisig_env role_annots-  = do {    -- Step 1: kind-check this group and returns the final-            -- (possibly-polymorphic) kind of each TyCon and Class-            -- See Note [Kind checking for type and class decls]-         tc_tycons <- kcTyClGroup kisig_env tyclds-       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))--            -- Step 2: type-check all groups together, returning-            -- the final TyCons and Classes-            ---            -- NB: We have to be careful here to NOT eagerly unfold-            -- type synonyms, as we have not tested for type synonym-            -- loops yet and could fall into a black hole.-       ; fixM $ \ ~(rec_tyclss, _) -> do-           { tcg_env <- getGblEnv-           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss--                 -- Populate environment with knot-tied ATyCon for TyCons-                 -- NB: if the decls mention any ill-staged data cons-                 -- (see Note [Recursion and promoting data constructors])-                 -- we will have failed already in kcTyClGroup, so no worries here-           ; (tycons, data_deriv_infos) <--             tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $--                 -- Also extend the local type envt with bindings giving-                 -- a TcTyCon for each knot-tied TyCon or Class-                 -- See Note [Type checking recursive type and class declarations]-                 -- and Note [Type environment evolution]-             tcExtendKindEnvWithTyCons tc_tycons $--                 -- Kind and type check declarations for this group-               mapAndUnzipM (tcTyClDecl roles) tyclds-           ; return (tycons, concat data_deriv_infos)-           } }-  where-    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma-                                  , ppr (tyConBinders tc) <> comma-                                  , ppr (tyConResKind tc)-                                  , ppr (isTcTyCon tc) ])--zipRecTyClss :: [TcTyCon]-             -> [TyCon]           -- Knot-tied-             -> [(Name,TyThing)]--- Build a name-TyThing mapping for the TyCons bound by decls--- being careful not to look at the knot-tied [TyThing]--- The TyThings in the result list must have a visible ATyCon,--- because typechecking types (in, say, tcTyClDecl) looks at--- this outer constructor-zipRecTyClss tc_tycons rec_tycons-  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]-  where-    rec_tc_env :: NameEnv TyCon-    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons--    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon-    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)--    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon-    add_one_tc tc env = extendNameEnv env (tyConName tc) tc--    get name = case lookupNameEnv rec_tc_env name of-                 Just tc -> tc-                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)--{--************************************************************************-*                                                                      *-                Kind checking-*                                                                      *-************************************************************************--Note [Kind checking for type and class decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Kind checking is done thus:--   1. Make up a kind variable for each parameter of the declarations,-      and extend the kind environment (which is in the TcLclEnv)--   2. Kind check the declarations--We need to kind check all types in the mutually recursive group-before we know the kind of the type variables.  For example:--  class C a where-     op :: D b => a -> b -> b--  class D c where-     bop :: (Monad c) => ...--Here, the kind of the locally-polymorphic type variable "b"-depends on *all the uses of class D*.  For example, the use of-Monad c in bop's type signature means that D must have kind Type->Type.--Note: we don't treat type synonyms specially (we used to, in the past);-in particular, even if we have a type synonym cycle, we still kind check-it normally, and test for cycles later (checkSynCycles).  The reason-we can get away with this is because we have more systematic TYPE r-inference, which means that we can do unification between kinds that-aren't lifted (this historically was not true.)--The downside of not directly reading off the kinds of the RHS of-type synonyms in topological order is that we don't transparently-support making synonyms of types with higher-rank kinds.  But-you can always specify a CUSK directly to make this work out.-See tc269 for an example.--Note [CUSKs and PolyKinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--    data T (a :: *) = MkT (S a)   -- Has CUSK-    data S a = MkS (T Int) (S a)  -- No CUSK--Via inferInitialKinds we get-  T :: * -> *-  S :: kappa -> *--Then we call kcTyClDecl on each decl in the group, to constrain the-kind unification variables.  BUT we /skip/ the RHS of any decl with-a CUSK.  Here we skip the RHS of T, so we eventually get-  S :: forall k. k -> *--This gets us more polymorphism than we would otherwise get, similar-(but implemented strangely differently from) the treatment of type-signatures in value declarations.--However, we only want to do so when we have PolyKinds.-When we have NoPolyKinds, we don't skip those decls, because we have defaulting-(#16609). Skipping won't bring us more polymorphism when we have defaulting.-Consider--  data T1 a = MkT1 T2        -- No CUSK-  data T2 = MkT2 (T1 Maybe)  -- Has CUSK--If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.-With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the-program type-checks.-But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens-in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking-(T1 Maybe) will throw a type error.--Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.--Open type families-~~~~~~~~~~~~~~~~~~-This treatment of type synonyms only applies to Haskell 98-style synonyms.-General type functions can be recursive, and hence, appear in `alg_decls'.--The kind of an open type family is solely determinded by its kind signature;-hence, only kind signatures participate in the construction of the initial-kind environment (as constructed by `inferInitialKind'). In fact, we ignore-instances of families altogether in the following. However, we need to include-the kinds of *associated* families into the construction of the initial kind-environment. (This is handled by `allDecls').--See also Note [Kind checking recursive type and class declarations]--Note [How TcTyCons work]-~~~~~~~~~~~~~~~~~~~~~~~~-TcTyCons are used for two distinct purposes--1.  When recovering from a type error in a type declaration,-    we want to put the erroneous TyCon in the environment in a-    way that won't lead to more errors.  We use a TcTyCon for this;-    see makeRecoveryTyCon.--2.  When checking a type/class declaration (in module GHC.Tc.TyCl), we come-    upon knowledge of the eventual tycon in bits and pieces.--      S1) First, we use inferInitialKinds to look over the user-provided-          kind signature of a tycon (including, for example, the number-          of parameters written to the tycon) to get an initial shape of-          the tycon's kind.  We record that shape in a TcTyCon.--          For CUSK tycons, the TcTyCon has the final, generalised kind.-          For non-CUSK tycons, the TcTyCon has as its tyConBinders only-          the explicit arguments given -- no kind variables, etc.--      S2) Then, using these initial kinds, we kind-check the body of the-          tycon (class methods, data constructors, etc.), filling in the-          metavariables in the tycon's initial kind.--      S3) We then generalize to get the (non-CUSK) tycon's final, fixed-          kind. Finally, once this has happened for all tycons in a-          mutually recursive group, we can desugar the lot.--    For convenience, we store partially-known tycons in TcTyCons, which-    might store meta-variables. These TcTyCons are stored in the local-    environment in GHC.Tc.TyCl, until the real full TyCons can be created-    during desugaring. A desugared program should never have a TcTyCon.--3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).--4.  tyConScopedTyVars.  A challenging piece in all of this is that we-    end up taking three separate passes over every declaration:-      - one in inferInitialKind (this pass look only at the head, not the body)-      - one in kcTyClDecls (to kind-check the body)-      - a final one in tcTyClDecls (to desugar)--    In the latter two passes, we need to connect the user-written type-    variables in an LHsQTyVars with the variables in the tycon's-    inferred kind. Because the tycon might not have a CUSK, this-    matching up is, in general, quite hard to do.  (Look through the-    git history between Dec 2015 and Apr 2016 for-    GHC.Tc.Gen.HsType.splitTelescopeTvs!)--    Instead of trying, we just store the list of type variables to-    bring into scope, in the tyConScopedTyVars field of the TcTyCon.-    These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars.--    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather-    than just [TcTyVar]?  Consider these mutually-recursive decls-       data T (a :: k1) b = MkT (S a b)-       data S (c :: k2) d = MkS (T c d)-    We start with k1 bound to kappa1, and k2 to kappa2; so initially-    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But-    then kappa1 and kappa2 get unified; so after the zonking in-    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.--See also Note [Type checking recursive type and class declarations].--Note [Swizzling the tyvars before generaliseTcTyCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note only applies when /inferring/ the kind of a TyCon.-If there is a separate kind signature, or a CUSK, we take an entirely-different code path.--For inference, consider-   class C (f :: k) x where-      type T f-      op :: D f => blah-   class D (g :: j) y where-      op :: C g => y -> blah--Here C and D are considered mutually recursive.  Neither has a CUSK.-Just before generalisation we have the (un-quantified) kinds-   C :: k1 -> k2 -> Constraint-   T :: k1 -> Type-   D :: k1 -> Type -> Constraint-Notice that f's kind and g's kind have been unified to 'k1'. We say-that k1 is the "representative" of k in C's decl, and of j in D's decl.--Now when quantifying, we'd like to end up with-   C :: forall {k2}. forall k. k -> k2 -> Constraint-   T :: forall k. k -> Type-   D :: forall j. j -> Type -> Constraint--That is, we want to swizzle the representative to have the Name given-by the user. Partly this is to improve error messages and the output of-:info in GHCi.  But it is /also/ important because the code for a-default method may mention the class variable(s), but at that point-(tcClassDecl2), we only have the final class tyvars available.-(Alternatively, we could record the scoped type variables in the-TyCon, but it's a nuisance to do so.)--Notes:--* On the input to generaliseTyClDecl, the mapping between the-  user-specified Name and the representative TyVar is recorded in the-  tyConScopedTyVars of the TcTyCon.  NB: you first need to zonk to see-  this representative TyVar.--* The swizzling is actually performed by swizzleTcTyConBndrs--* We must do the swizzling across the whole class decl. Consider-     class C f where-       type S (f :: k)-       type T f-  Here f's kind k is a parameter of C, and its identity is shared-  with S and T.  So if we swizzle the representative k at all, we-  must do so consistently for the entire declaration.--  Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl,-  rather than in generaliseTcTyCon.--There are errors to catch here.  Suppose we had-   class E (f :: j) (g :: k) where-     op :: SameKind f g -> blah--Then, just before generalisation we will have the (unquantified)-   E :: k1 -> k1 -> Constraint--That's bad!  Two distinctly-named tyvars (j and k) have ended up with-the same representative k1.  So when swizzling, we check (in-check_duplicate_tc_binders) that two distinct source names map-to the same representative.--Here's an interesting case:-    class C1 f where-      type S (f :: k1)-      type T (f :: k2)-Here k1 and k2 are different Names, but they end up mapped to the-same representative TyVar.  To make the swizzling consistent (remember-we must have a single k across C1, S and T) we reject the program.--Another interesting case-    class C2 f where-      type S (f :: k) (p::Type)-      type T (f :: k) (p::Type->Type)--Here the two k's (and the two p's) get distinct Uniques, because they-are seen by the renamer as locally bound in S and T resp.  But again-the two (distinct) k's end up bound to the same representative TyVar.-You might argue that this should be accepted, but it's definitely-rejected (via an entirely different code path) if you add a kind sig:-    type C2' :: j -> Constraint-    class C2' f where-      type S (f :: k) (p::Type)-We get-    • Expected kind ‘j’, but ‘f’ has kind ‘k’-    • In the associated type family declaration for ‘S’--So we reject C2 too, even without the kind signature.  We have-to do a bit of work to get a good error message, since both k's-look the same to the user.--Another case-    class C3 (f :: k1) where-      type S (f :: k2)--This will be rejected too.---Note [Type environment evolution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As we typecheck a group of declarations the type environment evolves.-Consider for example:-  data B (a :: Type) = MkB (Proxy 'MkB)--We do the following steps:--  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the-     type env with promotion errors-            B   :-> TyConPE-            MkB :-> DataConPE--  2. kcTyCLGroup-      - Do inferInitialKinds, which will signal a promotion-        error if B is used in any of the kinds needed to initialise-        B's kind (e.g. (a :: Type)) here--      - Extend the type env with these initial kinds (monomorphic for-        decls that lack a CUSK)-            B :-> TcTyCon <initial kind>-        (thereby overriding the B :-> TyConPE binding)-        and do kcLTyClDecl on each decl to get equality constraints on-        all those initial kinds--      - Generalise the initial kind, making a poly-kinded TcTyCon--  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded-     TcTyCons, again overriding the promotion-error bindings.--     But note that the data constructor promotion errors are still in place-     so that (in our example) a use of MkB will still be signalled as-     an error.--  4. Typecheck the decls.--  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons---Note [Missed opportunity to retain higher-rank kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In 'kcTyClGroup', there is a missed opportunity to make kind-inference work in a few more cases.  The idea is analogous-to Note [Single function non-recursive binding special-case]:--     * If we have an SCC with a single decl, which is non-recursive,-       instead of creating a unification variable representing the-       kind of the decl and unifying it with the rhs, we can just-       read the type directly of the rhs.--     * Furthermore, we can update our SCC analysis to ignore-       dependencies on declarations which have CUSKs: we don't-       have to kind-check these all at once, since we can use-       the CUSK to initialize the kind environment.--Unfortunately this requires reworking a bit of the code in-'kcLTyClDecl' so I've decided to punt unless someone shouts about it.--Note [Don't process associated types in getInitialKind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Previously, we processed associated types in the thing_inside in getInitialKind,-but this was wrong -- we want to do ATs sepearately.-The consequence for not doing it this way is #15142:--  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where-    type ListToTuple as :: Type--We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify-kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring-`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't-unified with Type. And then, when we generalize the kind of ListToTuple (which-indeed has a CUSK, according to the rules), we skolemize the free metavariable-kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,-because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1]-will unify with Type.--Bottom line: as associated types should have no effect on a CUSK enclosing class,-we move processing them to a separate action, run after the outer kind has-been generalized.---}--kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM [TcTyCon]---- Kind check this group, kind generalize, and return the resulting local env--- This binds the TyCons and Classes of the group, but not the DataCons--- See Note [Kind checking for type and class decls]--- and Note [Inferring kinds for type declarations]-kcTyClGroup kisig_env decls-  = do  { mod <- getModule-        ; traceTc "---- kcTyClGroup ---- {"-                  (text "module" <+> ppr mod $$ vcat (map ppr decls))--          -- Kind checking;-          --    1. Bind kind variables for decls-          --    2. Kind-check decls-          --    3. Generalise the inferred kinds-          -- See Note [Kind checking for type and class decls]--        ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds-                    -- See Note [CUSKs and PolyKinds]-        ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls--              get_kind d-                | Just ki <- lookupNameEnv kisig_env (tcdName (unLoc d))-                = Right (d, SAKS ki)--                | cusks_enabled && hsDeclHasCusk (unLoc d)-                = Right (d, CUSK)--                | otherwise = Left d--        ; checked_tcs <- checkInitialKinds kinded_decls-        ; inferred_tcs-            <- tcExtendKindEnvWithTyCons checked_tcs $-               pushTcLevelM_   $  -- We are going to kind-generalise, so-                                  -- unification variables in here must-                                  -- be one level in-               solveEqualities $-               do {  -- Step 1: Bind kind variables for all decls-                    mono_tcs <- inferInitialKinds kindless_decls--                  ; traceTc "kcTyClGroup: initial kinds" $-                    ppr_tc_kinds mono_tcs--                    -- Step 2: Set extended envt, kind-check the decls-                    -- NB: the environment extension overrides the tycon-                    --     promotion-errors bindings-                    --     See Note [Type environment evolution]-                  ; tcExtendKindEnvWithTyCons mono_tcs $-                    mapM_ kcLTyClDecl kindless_decls--                  ; return mono_tcs }--        -- Step 3: generalisation-        -- Finally, go through each tycon and give it its final kind,-        -- with all the required, specified, and inferred variables-        -- in order.-        ; let inferred_tc_env = mkNameEnv $-                                map (\tc -> (tyConName tc, tc)) inferred_tcs-        ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)-                                        kindless_decls--        ; let poly_tcs = checked_tcs ++ generalized_tcs-        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)-        ; return poly_tcs }-  where-    ppr_tc_kinds tcs = vcat (map pp_tc tcs)-    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)--type ScopedPairs = [(Name, TcTyVar)]-  -- The ScopedPairs for a TcTyCon are precisely-  --    specified-tvs ++ required-tvs-  -- You can distinguish them because there are tyConArity required-tvs--generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon]--- See Note [Swizzling the tyvars before generaliseTcTyCon]-generaliseTyClDecl inferred_tc_env (L _ decl)-  = do { let names_in_this_decl :: [Name]-             names_in_this_decl = tycld_names decl--       -- Extract the specified/required binders and skolemise them-       ; tc_with_tvs  <- mapM skolemise_tc_tycon names_in_this_decl--       -- Zonk, to manifest the side-effects of skolemisation to the swizzler-       -- NB: it's important to skolemise them all before this step. E.g.-       --         class C f where { type T (f :: k) }-       --     We only skolemise k when looking at T's binders,-       --     but k appears in f's kind in C's binders.-       ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs--       -- Swizzle-       ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos)--       -- And finally generalise-       ; mapAndReportM generaliseTcTyCon swizzled_infos }-  where-    tycld_names :: TyClDecl GhcRn -> [Name]-    tycld_names decl = tcdName decl : at_names decl--    at_names :: TyClDecl GhcRn -> [Name]-    at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats-    at_names _ = []  -- Only class decls have associated types--    skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)-    -- Zonk and skolemise the Specified and Required binders-    skolemise_tc_tycon tc_name-      = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name-                      -- This lookup should not fail-           ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc)-           ; return (tc, scoped_prs) }--    zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind)-    zonk_tc_tycon (tc, scoped_prs)-      = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs-                           -- We really have to do this again, even though-                           -- we have just done zonkAndSkolemise-           ; res_kind   <- zonkTcType (tyConResKind tc)-           ; return (tc, scoped_prs, res_kind) }--swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]-                -> TcM [(TcTyCon, ScopedPairs, TcKind)]-swizzleTcTyConBndrs tc_infos-  | all no_swizzle swizzle_prs-    -- This fast path happens almost all the time-    -- See Note [Non-cloning for tyvar binders] in GHC.Tc.Gen.HsType-  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos))-       ; return tc_infos }--  | otherwise-  = do { check_duplicate_tc_binders--       ; traceTc "swizzleTcTyConBndrs" $-         vcat [ text "before" <+> ppr_infos tc_infos-              , text "swizzle_prs" <+> ppr swizzle_prs-              , text "after" <+> ppr_infos swizzled_infos ]--       ; return swizzled_infos }--  where-    swizzled_infos =  [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind)-                      | (tc, scoped_prs, kind) <- tc_infos ]--    swizzle_prs :: [(Name,TyVar)]-    -- Pairs the user-specifed Name with its representative TyVar-    -- See Note [Swizzling the tyvars before generaliseTcTyCon]-    swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ]--    no_swizzle :: (Name,TyVar) -> Bool-    no_swizzle (nm, tv) = nm == tyVarName tv--    ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs)-                           | (tc, prs, _) <- infos ]--    -- Check for duplicates-    -- E.g. data SameKind (a::k) (b::k)-    --      data T (a::k1) (b::k2) = MkT (SameKind a b)-    -- Here k1 and k2 start as TyVarTvs, and get unified with each other-    -- If this happens, things get very confused later, so fail fast-    check_duplicate_tc_binders :: TcM ()-    check_duplicate_tc_binders = unless (null err_prs) $-                                 do { mapM_ report_dup err_prs; failM }--    -------------- Error reporting -------------    err_prs :: [(Name,Name)]-    err_prs = [ (n1,n2)-              | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs-              , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ]-              -- This nubBy avoids bogus error reports when we have-              --    [("f", f), ..., ("f",f)....] in swizzle_prs-              -- which happens with  class C f where { type T f }--    report_dup :: (Name,Name) -> TcM ()-    report_dup (n1,n2)-      = setSrcSpan (getSrcSpan n2) $ addErrTc $-        hang (text "Different names for the same type variable:") 2 info-      where-        info | nameOccName n1 /= nameOccName n2-             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)-             | otherwise -- Same OccNames! See C2 in-                         -- Note [Swizzling the tyvars before generaliseTcTyCon]-             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)-                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]--    -------------- The swizzler -------------    -- This does a deep traverse, simply doing a-    -- Name-to-Name change, governed by swizzle_env-    -- The 'swap' is what gets from the representative TyVar-    -- back to the original user-specified Name-    swizzle_env = mkVarEnv (map swap swizzle_prs)--    swizzleMapper :: TyCoMapper () Identity-    swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv-                               , tcm_covar = swizzle_cv-                               , tcm_hole  = swizzle_hole-                               , tcm_tycobinder = swizzle_bndr-                               , tcm_tycon      = swizzle_tycon }-    swizzle_hole  _ hole = pprPanic "swizzle_hole" (ppr hole)-       -- These types are pre-zonked-    swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc)-       -- TcTyCons can't appear in kinds (yet)-    swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv))-    swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv))--    swizzle_bndr _ tcv _-      = return ((), swizzle_var tcv)--    swizzle_var :: Var -> Var-    swizzle_var v-      | Just nm <- lookupVarEnv swizzle_env v-      = updateVarType swizzle_ty (v `setVarName` nm)-      | otherwise-      = updateVarType swizzle_ty v--    (map_type, _, _, _) = mapTyCo swizzleMapper-    swizzle_ty ty = runIdentity (map_type ty)---generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon-generaliseTcTyCon (tc, scoped_prs, tc_res_kind)-  -- See Note [Required, Specified, and Inferred for types]-  = setSrcSpan (getSrcSpan tc) $-    addTyConCtxt tc $-    do { -- Step 1: Separate Specified from Required variables-         -- NB: spec_req_tvs = spec_tvs ++ req_tvs-         --     And req_tvs is 1-1 with tyConTyVars-         --     See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon-       ; let spec_req_tvs        = map snd scoped_prs-             n_spec              = length spec_req_tvs - tyConArity tc-             (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs-             sorted_spec_tvs     = scopedSort spec_tvs-                 -- NB: We can't do the sort until we've zonked-                 --     Maintain the L-R order of scoped_tvs--       -- Step 2a: find all the Inferred variables we want to quantify over-       ; dvs1 <- candidateQTyVarsOfKinds $-                 (tc_res_kind : map tyVarKind spec_req_tvs)-       ; let dvs2 = dvs1 `delCandidates` spec_req_tvs--       -- Step 2b: quantify, mainly meaning skolemise the free variables-       -- Returned 'inferred' are scope-sorted and skolemised-       ; inferred <- quantifyTyVars dvs2--       ; traceTc "generaliseTcTyCon: pre zonk"-           (vcat [ text "tycon =" <+> ppr tc-                 , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs-                 , text "tc_res_kind =" <+> ppr tc_res_kind-                 , text "dvs1 =" <+> ppr dvs1-                 , text "inferred =" <+> pprTyVars inferred ])--       -- Step 3: Final zonk (following kind generalisation)-       -- See Note [Swizzling the tyvars before generaliseTcTyCon]-       ; ze <- emptyZonkEnv-       ; (ze, inferred)        <- zonkTyBndrsX ze inferred-       ; (ze, sorted_spec_tvs) <- zonkTyBndrsX ze sorted_spec_tvs-       ; (ze, req_tvs)         <- zonkTyBndrsX ze req_tvs-       ; tc_res_kind           <- zonkTcTypeToTypeX ze tc_res_kind--       ; traceTc "generaliseTcTyCon: post zonk" $-         vcat [ text "tycon =" <+> ppr tc-              , text "inferred =" <+> pprTyVars inferred-              , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs-              , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs-              , text "req_tvs =" <+> ppr req_tvs-              , text "zonk-env =" <+> ppr ze ]--       -- Step 4: Make the TyConBinders.-       ; let dep_fv_set     = candidateKindVars dvs1-             inferred_tcbs  = mkNamedTyConBinders Inferred inferred-             specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs-             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs--       -- Step 5: Assemble the final list.-             final_tcbs = concat [ inferred_tcbs-                                 , specified_tcbs-                                 , required_tcbs ]--       -- Step 6: Make the result TcTyCon-             tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind-                            (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))-                            True {- it's generalised now -}-                            (tyConFlavour tc)--       ; traceTc "generaliseTcTyCon done" $-         vcat [ text "tycon =" <+> ppr tc-              , text "tc_res_kind =" <+> ppr tc_res_kind-              , text "dep_fv_set =" <+> ppr dep_fv_set-              , text "inferred_tcbs =" <+> ppr inferred_tcbs-              , text "specified_tcbs =" <+> ppr specified_tcbs-              , text "required_tcbs =" <+> ppr required_tcbs-              , text "final_tcbs =" <+> ppr final_tcbs ]--       -- Step 7: Check for validity.-       -- We do this here because we're about to put the tycon into the-       -- the environment, and we don't want anything malformed there-       ; checkTyConTelescope tycon--       ; return tycon }--{- Note [Required, Specified, and Inferred for types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Each forall'd type variable in a type or kind is one of--  * Required: an argument must be provided at every call site--  * Specified: the argument can be inferred at call sites, but-    may be instantiated with visible type/kind application--  * Inferred: the must be inferred at call sites; it-    is unavailable for use with visible type/kind application.--Why have Inferred at all? Because we just can't make user-facing-promises about the ordering of some variables. These might swizzle-around even between minor released. By forbidding visible type-application, we ensure users aren't caught unawares.--Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.--The question for this Note is this:-   given a TyClDecl, how are its quantified type variables classified?-Much of the debate is memorialized in #15743.--Here is our design choice. When inferring the ordering of variables-for a TyCl declaration (that is, for those variables that he user-has not specified the order with an explicit `forall`), we use the-following order:-- 1. Inferred variables- 2. Specified variables; in the left-to-right order in which-    the user wrote them, modified by scopedSort (see below)-    to put them in depdendency order.- 3. Required variables before a top-level ::- 4. All variables after a top-level ::--If this ordering does not make a valid telescope, we reject the definition.--Example:-  data SameKind :: k -> k -> *-  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)--For Bad:-  - a, c, d, x are Required; they are explicitly listed by the user-    as the positional arguments of Bad-  - b is Specified; it appears explicitly in a kind signature-  - k, the kind of a, is Inferred; it is not mentioned explicitly at all--Putting variables in the order Inferred, Specified, Required-gives us this telescope:-  Inferred:  k-  Specified: b : Proxy a-  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)--But this order is ill-scoped, because b's kind mentions a, which occurs-after b in the telescope. So we reject Bad.--Associated types-~~~~~~~~~~~~~~~~-For associated types everything above is determined by the-associated-type declaration alone, ignoring the class header.-Here is an example (#15592)-  class C (a :: k) b where-    type F (x :: b a)--In the kind of C, 'k' is Specified.  But what about F?-In the kind of F,-- * Should k be Inferred or Specified?  It's Specified for C,-   but not mentioned in F's declaration.-- * In which order should the Specified variables a and b occur?-   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering-   in F's declaration is 'b' then 'a'.--In both cases we make the choice by looking at F's declaration alone,-so it gets the kind-   F :: forall {k}. forall b a. b a -> Type--How it works-~~~~~~~~~~~~-These design choices are implemented by two completely different code-paths for--  * Declarations with a standalone kind signature or a complete user-specified-    kind signature (CUSK). Handled by the kcCheckDeclHeader.--  * Declarations without a kind signature (standalone or CUSK) are handled by-    kcInferDeclHeader; see Note [Inferring kinds for type declarations].--Note that neither code path worries about point (4) above, as this-is nicely handled by not mangling the res_kind. (Mangling res_kinds is done-*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)--We can tell Inferred apart from Specified by looking at the scoped-tyvars; Specified are always included there.--Design alternatives-~~~~~~~~~~~~~~~~~~~-* For associated types we considered putting the class variables-  before the local variables, in a nod to the treatment for class-  methods. But it got too compilicated; see #15592, comment:21ff.--* We rigidly require the ordering above, even though we could be much more-  permissive. Relevant musings are at-  https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623-  The bottom line conclusion is that, if the user wants a different ordering,-  then can specify it themselves, and it is better to be predictable and dumb-  than clever and capricious.--  I (Richard) conjecture we could be fully permissive, allowing all classes-  of variables to intermix. We would have to augment ScopedSort to refuse to-  reorder Required variables (or check that it wouldn't have). But this would-  allow more programs. See #15743 for examples. Interestingly, Idris seems-  to allow this intermixing. The intermixing would be fully specified, in that-  we can be sure that inference wouldn't change between versions. However,-  would users be able to predict it? That I cannot answer.--Test cases (and tickets) relevant to these design decisions-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  T15591*-  T15592*-  T15743*--Note [Inferring kinds for type declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This note deals with /inference/ for type declarations-that do not have a CUSK.  Consider-  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)-  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)--We do kind inference as follows:--* Step 1: inferInitialKinds, and in particular kcInferDeclHeader.-  Make a unification variable for each of the Required and Specified-  type variables in the header.--  Record the connection between the Names the user wrote and the-  fresh unification variables in the tcTyConScopedTyVars field-  of the TcTyCon we are making-      [ (a,  aa)-      , (k1, kk1)-      , (k2, kk2)-      , (x,  xx) ]-  (I'm using the convention that double letter like 'aa' or 'kk'-  mean a unification variable.)--  These unification variables-    - Are TyVarTvs: that is, unification variables that can-      unify only with other type variables.-      See Note [Signature skolems] in GHC.Tc.Utils.TcType--    - Have complete fresh Names; see GHC.Tc.Utils.TcMType-      Note [Unification variables need fresh Names]--  Assign initial monomorphic kinds to S, T-          T :: kk1 -> * -> kk2 -> *-          S :: kk3 -> * -> kk4 -> *--* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and-  T, with these monomorphic kinds.  Now kind-check the declarations,-  and solve the resulting equalities.  The goal here is to discover-  constraints on all these unification variables.--  Here we find that kk1 := kk3, and kk2 := kk4.--  This is why we can't use skolems for kk1 etc; they have to-  unify with each other.--* Step 3: generaliseTcTyCon. Generalise each TyCon in turn.-  We find the free variables of the kind, skolemise them,-  sort them out into Inferred/Required/Specified (see the above-  Note [Required, Specified, and Inferred for types]),-  and perform some validity checks.--  This makes the utterly-final TyConBinders for the TyCon.--  All this is very similar at the level of terms: see GHC.Tc.Gen.Bind-  Note [Quantified variables in partial type signatures]--  But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon]--* Step 4.  Extend the type environment with a TcTyCon for S and T, now-  with their utterly-final polymorphic kinds (needed for recursive-  occurrences of S, T).  Now typecheck the declarations, and build the-  final AlgTyCon for S and T resp.--The first three steps are in kcTyClGroup; the fourth is in-tcTyClDecls.--There are some wrinkles--* Do not default TyVarTvs.  We always want to kind-generalise over-  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is-  not allowed to unify with a type; it must stand for a type-  variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and-  GHC.Tc.Utils.TcMType.defaultTyVar.  Here's another example (#14555):-     data Exp :: [TYPE rep] -> TYPE rep -> Type where-        Lam :: Exp (a:xs) b -> Exp xs (a -> b)-  We want to kind-generalise over the 'rep' variable.-  #14563 is another example.--* Duplicate type variables. Consider #11203-    data SameKind :: k -> k -> *-    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)-  Here we will unify k1 with k2, but this time doing so is an error,-  because k1 and k2 are bound in the same declaration.--  We spot this during validity checking (findDupTyVarTvs),-  in generaliseTcTyCon.--* Required arguments.  Even the Required arguments should be made-  into TyVarTvs, not skolems.  Consider-    data T k (a :: k)-  Here, k is a Required, dependent variable. For uniformity, it is helpful-  to have k be a TyVarTv, in parallel with other dependent variables.--* Duplicate skolemisation is expected.  When generalising in Step 3,-  we may find that one of the variables we want to quantify has-  already been skolemised.  For example, suppose we have already-  generalise S. When we come to T we'll find that kk1 (now the same as-  kk3) has already been skolemised.--  That's fine -- but it means that-    a) when collecting quantification candidates, in-       candidateQTyVarsOfKind, we must collect skolems-    b) quantifyTyVars should be a no-op on such a skolem--Note [Tricky scoping in generaliseTcTyCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider #16342-  class C (a::ka) x where-    cop :: D a x => x -> Proxy a -> Proxy a-    cop _ x = x :: Proxy (a::ka)--  class D (b::kb) y where-    dop :: C b y => y -> Proxy b -> Proxy b-    dop _ x = x :: Proxy (b::kb)--C and D are mutually recursive, by the time we get to-generaliseTcTyCon we'll have unified kka := kkb.--But when typechecking the default declarations for 'cop' and 'dop' in-tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.-But at that point all we have is the utterly-final Class itself.--Conclusion: the classTyVars of a class must have the same Name as-that originally assigned by the user.  In our example, C must have-classTyVars {a, ka, x} while D has classTyVars {a, kb, y}.  Despite-the fact that kka and kkb got unified!--We achieve this sleight of hand in generaliseTcTyCon, using-the specialised function zonkRecTyVarBndrs.  We make the call-   zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx]-where the [ka,a,x] are the Names originally assigned by the user, and-[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars.-zonkRecTyVarBndrs builds a recursive ZonkEnv that binds-   kkb :-> (ka :: <zonked kind of kkb>)-   aa  :-> (a  :: <konked kind of aa>)-   etc-That is, it maps each skolemised TcTyVars to the utterly-final-TyVar to put in the class, with its correct user-specified name.-When generalising D we'll do the same thing, but the ZonkEnv will map-   kkb :-> (kb :: <zonked kind of kkb>)-   bb  :-> (b  :: <konked kind of bb>)-   etc-Note that 'kkb' again appears in the domain of the mapping, but this-time mapped to 'kb'.  That's how C and D end up with differently-named-final TyVars despite the fact that we unified kka:=kkb--zonkRecTyVarBndrs we need to do knot-tying because of the need to-apply this same substitution to the kind of each.--Note [Inferring visible dependent quantification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  data T k :: k -> Type where-    MkT1 :: T Type Int-    MkT2 :: T (Type -> Type) Maybe--This looks like it should work. However, it is polymorphically recursive,-as the uses of T in the constructor types specialize the k in the kind-of T. This trips up our dear users (#17131, #17541), and so we add-a "landmark" context (which cannot be suppressed) whenever we-spot inferred visible dependent quantification (VDQ).--It's hard to know when we've actually been tripped up by polymorphic recursion-specifically, so we just include a note to users whenever we infer VDQ. The-testsuite did not show up a single spurious inclusion of this message.--The context is added in addVDQNote, which looks for a visible TyConBinder-that also appears in the TyCon's kind. (I first looked at the kind for-a visible, dependent quantifier, but Note [No polymorphic recursion] in-GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in kcTyClDecl,-which is used only when inferring the kind of a tycon (never with a CUSK or-SAK).--Once upon a time, I (Richard E) thought that the tycon-kind could-not be a forall-type. But this is wrong: data T :: forall k. k -> Type-(with -XNoCUSKs) could end up here. And this is all OK.----}-----------------tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a-tcExtendKindEnvWithTyCons tcs-  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]-----------------mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv--- Maps each tycon/datacon to a suitable promotion error---    tc :-> APromotionErr TyConPE---    dc :-> APromotionErr RecDataConPE---    See Note [Recursion and promoting data constructors]--mkPromotionErrorEnv decls-  = foldr (plusNameEnv . mk_prom_err_env . unLoc)-          emptyNameEnv decls--mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv-mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })-  = unitNameEnv nm (APromotionErr ClassPE)-    `plusNameEnv`-    mkNameEnv [ (familyDeclName at, APromotionErr TyConPE)-              | L _ at <- ats ]--mk_prom_err_env (DataDecl { tcdLName = L _ name-                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })-  = unitNameEnv name (APromotionErr TyConPE)-    `plusNameEnv`-    mkNameEnv [ (con, APromotionErr RecDataConPE)-              | L _ con' <- cons-              , L _ con  <- getConNames con' ]--mk_prom_err_env decl-  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)-    -- Works for family declarations too-----------------inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]--- Returns a TcTyCon for each TyCon bound by the decls,--- each with its initial kind--inferInitialKinds decls-  = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)-       ; tcs <- concatMapM infer_initial_kind decls-       ; traceTc "inferInitialKinds done }" empty-       ; return tcs }-  where-    infer_initial_kind = addLocM (getInitialKind InitialKindInfer)---- Check type/class declarations against their standalone kind signatures or--- CUSKs, producing a generalized TcTyCon for each.-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]-checkInitialKinds decls-  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)-       ; tcs <- concatMapM check_initial_kind decls-       ; traceTc "checkInitialKinds done }" empty-       ; return tcs }-  where-    check_initial_kind (ldecl, msig) =-      addLocM (getInitialKind (InitialKindCheck msig)) ldecl---- | Get the initial kind of a TyClDecl, either generalized or non-generalized,--- depending on the 'InitialKindStrategy'.-getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]---- Allocate a fresh kind variable for each TyCon and Class--- For each tycon, return a TcTyCon with kind k--- where k is the kind of tc, derived from the LHS---         of the definition (and probably including---         kind unification variables)---      Example: data T a b = ...---      return (T, kv1 -> kv2 -> kv3)------ This pass deals with (ie incorporates into the kind it produces)---   * The kind signatures on type-variable binders---   * The result kinds signature on a TyClDecl------ No family instances are passed to checkInitialKinds/inferInitialKinds-getInitialKind strategy-    (ClassDecl { tcdLName = L _ name-               , tcdTyVars = ktvs-               , tcdATs = ats })-  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $-                return (TheKind constraintKind)-       ; let parent_tv_prs = tcTyConScopedTyVars cls-            -- See Note [Don't process associated types in getInitialKind]-       ; inner_tcs <--           tcExtendNameTyVarEnv parent_tv_prs $-           mapM (addLocM (getAssocFamInitialKind cls)) ats-       ; return (cls : inner_tcs) }-  where-    getAssocFamInitialKind cls =-      case strategy of-        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)-        InitialKindCheck _ -> check_initial_kind_assoc_fam cls--getInitialKind strategy-    (DataDecl { tcdLName = L _ name-              , tcdTyVars = ktvs-              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig-                                         , dd_ND = new_or_data } })-  = do  { let flav = newOrDataToFlavour new_or_data-              ctxt = DataKindCtxt name-        ; tc <- kcDeclHeader strategy name flav ktvs $-                case m_sig of-                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig-                  Nothing -> return $ dataDeclDefaultResultKind new_or_data-        ; return [tc] }--getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })-  = do { tc <- get_fam_decl_initial_kind Nothing decl-       ; return [tc] }--getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =-  FamilyDecl { fdLName     = unLoc -> name-             , fdTyVars    = ktvs-             , fdResultSig = unLoc -> resultSig-             , fdInfo      = info } } )-  = do { let flav = getFamFlav Nothing info-             ctxt = TyFamResKindCtxt name-       ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $-               case famResultKindSignature resultSig of-                 Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig-                 Nothing ->-                   case msig of-                     CUSK -> return (TheKind liftedTypeKind)-                     SAKS _ -> return AnyKind-       ; return [tc] }--getInitialKind strategy-    (SynDecl { tcdLName = L _ name-             , tcdTyVars = ktvs-             , tcdRhs = rhs })-  = do { let ctxt = TySynKindCtxt name-       ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $-               case hsTyKindSig rhs of-                 Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig-                 Nothing -> return AnyKind-       ; return [tc] }--get_fam_decl_initial_kind-  :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls-  -> FamilyDecl GhcRn-  -> TcM TcTyCon-get_fam_decl_initial_kind mb_parent_tycon-    FamilyDecl { fdLName     = L _ name-               , fdTyVars    = ktvs-               , fdResultSig = L _ resultSig-               , fdInfo      = info }-  = kcDeclHeader InitialKindInfer name flav ktvs $-    case resultSig of-      KindSig _ ki                            -> TheKind <$> tcLHsKindSig ctxt ki-      TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki-      _ -- open type families have * return kind by default-        | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)-               -- closed type families have their return kind inferred-               -- by default-        | otherwise                         -> return AnyKind-  where-    flav = getFamFlav mb_parent_tycon info-    ctxt = TyFamResKindCtxt name---- See Note [Standalone kind signatures for associated types]-check_initial_kind_assoc_fam-  :: TcTyCon -- parent class-  -> FamilyDecl GhcRn-  -> TcM TcTyCon-check_initial_kind_assoc_fam cls-  FamilyDecl-    { fdLName     = unLoc -> name-    , fdTyVars    = ktvs-    , fdResultSig = unLoc -> resultSig-    , fdInfo      = info }-  = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $-    case famResultKindSignature resultSig of-      Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig-      Nothing -> return (TheKind liftedTypeKind)-  where-    ctxt = TyFamResKindCtxt name-    flav = getFamFlav (Just cls) info--{- Note [Standalone kind signatures for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--If associated types had standalone kind signatures, would they wear them-----------------------------+-------------------------------  like this? (OUT)         |   or like this? (IN)----------------------------+-------------------------------  type T :: Type -> Type   |   class C a where-  class C a where          |     type T :: Type -> Type-    type T a               |     type T a--The (IN) variant is syntactically ambiguous:--  class C a where-    type T :: a   -- standalone kind signature?-    type T :: a   -- declaration header?--The (OUT) variant does not suffer from this issue, but it might not be the-direction in which we want to take Haskell: we seek to unify type families and-functions, and, by extension, associated types with class methods. And yet we-give class methods their signatures inside the class, not outside. Neither do-we have the counterpart of InstanceSigs for StandaloneKindSignatures.--For now, we dodge the question by using CUSKs for associated types instead of-standalone kind signatures. This is a simple addition to the rule we used to-have before standalone kind signatures:--  old rule:  associated type has a CUSK iff its parent class has a CUSK-  new rule:  associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature---}---- See Note [Data declaration default result kind]-dataDeclDefaultResultKind :: NewOrData -> ContextKind-dataDeclDefaultResultKind NewType  = OpenKind-  -- See Note [Implementation of UnliftedNewtypes], point <Error Messages>.-dataDeclDefaultResultKind DataType = TheKind liftedTypeKind--{- Note [Data declaration default result kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When the user has not written an inline result kind annotation on a data-declaration, we assume it to be 'Type'. That is, the following declarations-D1 and D2 are considered equivalent:--  data D1         where ...-  data D2 :: Type where ...--The consequence of this assumption is that we reject D3 even though we-accept D4:--  data D3 where-    MkD3 :: ... -> D3 param--  data D4 :: Type -> Type where-    MkD4 :: ... -> D4 param--However, there's a twist: for newtypes, we must relax-the assumed result kind to (TYPE r):--  newtype D5 where-    MkD5 :: Int# -> D5--See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note-<Error Messages>.--}------------------------------------getFamFlav-  :: Maybe TcTyCon    -- ^ Just cls <=> this is an associated family of class cls-  -> FamilyInfo pass-  -> TyConFlavour-getFamFlav mb_parent_tycon info =-  case info of-    DataFamily         -> DataFamilyFlavour mb_parent_tycon-    OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon-    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]-                          ClosedTypeFamilyFlavour--{- Note [Closed type family mb_parent_tycon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's no way to write a closed type family inside a class declaration:--  class C a where-    type family F a where  -- error: parse error on input ‘where’--In fact, it is not clear what the meaning of such a declaration would be.-Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.--}---------------------------------------------------------------------------kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()-  -- See Note [Kind checking for type and class decls]-  -- Called only for declarations without a signature (no CUSKs or SAKs here)-kcLTyClDecl (L loc decl)-  = setSrcSpan loc $-    do { tycon <- tcLookupTcTyCon tc_name-       ; traceTc "kcTyClDecl {" (ppr tc_name)-       ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]-         addErrCtxt (tcMkDeclCtxt decl) $-         kcTyClDecl decl tycon-       ; traceTc "kcTyClDecl done }" (ppr tc_name) }-  where-    tc_name = tcdName decl--kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM ()--- This function is used solely for its side effect on kind variables--- NB kind signatures on the type variables and---    result kind signature have already been dealt with---    by inferInitialKind, so we can ignore them here.--kcTyClDecl (DataDecl { tcdLName    = (L _ name)-                     , tcdDataDefn = defn }) tyCon-  | HsDataDefn { dd_cons = cons@((L _ (ConDeclGADT {})) : _)-               , dd_ctxt = (L _ [])-               , dd_ND = new_or_data } <- defn-  = -- See Note [Implementation of UnliftedNewtypes] STEP 2-    kcConDecls new_or_data (tyConResKind tyCon) cons--    -- hs_tvs and dd_kindSig already dealt with in inferInitialKind-    -- This must be a GADT-style decl,-    --        (see invariants of DataDefn declaration)-    -- so (a) we don't need to bring the hs_tvs into scope, because the-    --        ConDecls bind all their own variables-    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it--  | HsDataDefn { dd_ctxt = ctxt-               , dd_cons = cons-               , dd_ND = new_or_data } <- defn-  = bindTyClTyVars name $ \ _ _ _ ->-    do { _ <- tcHsContext ctxt-       ; kcConDecls new_or_data (tyConResKind tyCon) cons-       }--kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon-  = bindTyClTyVars name $ \ _ _ res_kind ->-    discardResult $ tcCheckLHsType rhs (TheKind res_kind)-        -- NB: check against the result kind that we allocated-        -- in inferInitialKinds.--kcTyClDecl (ClassDecl { tcdLName = L _ name-                      , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon-  = bindTyClTyVars name $ \ _ _ _ ->-    do  { _ <- tcHsContext ctxt-        ; mapM_ (wrapLocM_ kc_sig) sigs }-  where-    kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType skol_info nms op_ty-    kc_sig _                          = return ()--    skol_info = TyConSkol ClassFlavour name--kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo   = fd_info })) fam_tc--- closed type families look at their equations, but other families don't--- do anything here-  = case fd_info of-      ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns-      _ -> return ()------------------------- Type check the types of the arguments to a data constructor.--- This includes doing kind unification if the type is a newtype.--- See Note [Implementation of UnliftedNewtypes] for why we need--- the first two arguments.-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-  ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind-                                             tcMult mult)--    -- See Note [Implementation of UnliftedNewtypes], STEP 2-  }--kcConDecls :: NewOrData-           -> Kind             -- The result kind signature-           -> [LConDecl GhcRn] -- The data constructors-           -> TcM ()-kcConDecls new_or_data res_kind cons-  = mapM_ (wrapLocM_ (kcConDecl new_or_data final_res_kind)) cons-  where-    (_, final_res_kind) = splitPiTys res_kind-        -- See Note [kcConDecls result kind]---- Kind check a data constructor. In additional to the data constructor,--- we also need to know about whether or not its corresponding type was--- declared with data or newtype, and we need to know the result kind of--- this type. See Note [Implementation of UnliftedNewtypes] for why--- we need the first two arguments.-kcConDecl :: NewOrData-          -> Kind  -- Result kind of the type constructor-                   -- Usually Type but can be TYPE UnliftedRep-                   -- or even TYPE r, in the case of unlifted newtype-          -> ConDecl GhcRn-          -> TcM ()-kcConDecl new_or_data res_kind (ConDeclH98-  { con_name = name, con_ex_tvs = ex_tvs-  , con_mb_cxt = ex_ctxt, con_args = args })-  = addErrCtxt (dataConCtxtName [name]) $-    discardResult                   $-    bindExplicitTKBndrs_Tv ex_tvs $-    do { _ <- tcHsMbContext ex_ctxt-       ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)-         -- We don't need to check the telescope here,-         -- because that's done in tcConDecl-       }--kcConDecl new_or_data res_kind (ConDeclGADT-    { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt-    , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms })-  = -- Even though the GADT-style data constructor's type is closed,-    -- we must still kind-check the type, because that may influence-    -- the inferred kind of the /type/ constructor.  Example:-    --    data T f a where-    --      MkT :: f a -> T f a-    -- If we don't look at MkT we won't get the correct kind-    -- for the type constructor T-    addErrCtxt (dataConCtxtName names) $-    discardResult $-    bindImplicitTKBndrs_Tv implicit_tkv_nms $-    bindExplicitTKBndrs_Tv explicit_tkv_nms $-        -- Why "_Tv"?  See Note [Kind-checking for GADTs]-    do { _ <- tcHsMbContext cxt-       ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args)-       ; _ <- tcHsOpenType res_ty-       ; return () }--{- Note [kcConDecls result kind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We might have e.g.-    data T a :: Type -> Type where ...-or-    newtype instance N a :: Type -> Type  where ..-in which case, the 'res_kind' passed to kcConDecls will be-   Type->Type--We must look past those arrows, or even foralls, to the Type in the-corner, to pass to kcConDecl c.f. #16828. Hence the splitPiTys here.--I am a bit concerned about tycons with a declaration like-   data T a :: Type -> forall k. k -> Type  where ...--It does not have a CUSK, so kcInferDeclHeader will make a TcTyCon-with tyConResKind of Type -> forall k. k -> Type.  Even that is fine:-the splitPiTys will look past the forall.  But I'm bothered about-what if the type "in the corner" mentions k?  This is incredibly-obscure but something like this could be bad:-   data T a :: Type -> foral k. k -> TYPE (F k) where ...--I bet we are not quite right here, but my brain suffered a buffer-overflow and I thought it best to nail the common cases right now.--Note [Recursion and promoting data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't want to allow promotion in a strongly connected component-when kind checking.--Consider:-  data T f = K (f (K Any))--When kind checking the `data T' declaration the local env contains the-mappings:-  T -> ATcTyCon <some initial kind>-  K -> APromotionErr--APromotionErr is only used for DataCons, and only used during type checking-in tcTyClGroup.--Note [Kind-checking for GADTs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--  data Proxy a where-    MkProxy1 :: forall k (b :: k). Proxy b-    MkProxy2 :: forall j (c :: j). Proxy c--It seems reasonable that this should be accepted. But something very strange-is going on here: when we're kind-checking this declaration, we need to unify-the kind of `a` with k and j -- even though k and j's scopes are local to the type of-MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during-the kind-checking pass. First off, note that it's OK if the kind-checking pass-is too permissive: we'll snag the problems in the type-checking pass later.-(This extra permissiveness might happen with something like--  data SameKind :: k -> k -> Type-  data Bad a where-    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)--which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected-in the second pass, though. Test case: polykinds/TyVarTvKinds3)-Recall that the kind-checking pass exists solely to collect constraints-on the kinds and to power unification.--To achieve the use of TyVarTvs, we must be careful to use specialized functions-that produce TyVarTvs, not ordinary skolems. This is why we need-kcExplicitTKBndrs and kcImplicitTKBndrs in GHC.Tc.Gen.HsType, separate from their-tc... variants.--The drawback of this approach is sometimes it will accept a definition that-a (hypothetical) declarative specification would likely reject. As a general-rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,-the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs-approach allows a limited form of polymorphic recursion *without* a CUSK.--To wit:-  data T a = forall k (b :: k). MkT (T b) Int-  (test case: dependent/should_compile/T14066a)--Note that this is polymorphically recursive, with the recursive occurrence-of T used at a kind other than a's kind. The approach outlined here accepts-this definition, because this kind is still a kind variable (and so the-TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a-way to describe exactly what declarations will be accepted and which will-be rejected (without a CUSK). However, the accepted definitions are indeed-well-kinded and any rejected definitions would be accepted with a CUSK,-and so this wrinkle need not cause anyone to lose sleep.--************************************************************************-*                                                                      *-\subsection{Type checking}-*                                                                      *-************************************************************************--Note [Type checking recursive type and class declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-At this point we have completed *kind-checking* of a mutually-recursive group of type/class decls (done in kcTyClGroup). However,-we discarded the kind-checked types (eg RHSs of data type decls);-note that kcTyClDecl returns ().  There are two reasons:--  * It's convenient, because we don't have to rebuild a-    kinded HsDecl (a fairly elaborate type)--  * It's necessary, because after kind-generalisation, the-    TyCons/Classes may now be kind-polymorphic, and hence need-    to be given kind arguments.--Example:-       data T f a = MkT (f a) (T f a)-During kind-checking, we give T the kind T :: k1 -> k2 -> *-and figure out constraints on k1, k2 etc. Then we generalise-to get   T :: forall k. (k->*) -> k -> *-So now the (T f a) in the RHS must be elaborated to (T k f a).--However, during tcTyClDecl of T (above) we will be in a recursive-"knot". So we aren't allowed to look at the TyCon T itself; we are only-allowed to put it (lazily) in the returned structures.  But when-kind-checking the RHS of T's decl, we *do* need to know T's kind (so-that we can correctly elaboarate (T k f a).  How can we get T's kind-without looking at T?  Delicate answer: during tcTyClDecl, we extend--  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)-  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)--Then:--  * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the-    fully-known, not knot-tied TcTyCon for T.--  * Then, in GHC.Tc.Utils.Zonk.zonkTcTypeToType (and zonkTcTyCon in particular)-    we look in the *global* env to get the TyCon.--This fancy footwork (with two bindings for T) is only necessary for the-TyCons or Classes of this recursive group.  Earlier, finished groups,-live in the global env only.--See also Note [Kind checking recursive type and class declarations]--Note [Kind checking recursive type and class declarations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Before we can type-check the decls, we must kind check them. This-is done by establishing an "initial kind", which is a rather uninformed-guess at a tycon's kind (by counting arguments, mainly) and then-using this initial kind for recursive occurrences.--The initial kind is stored in exactly the same way during-kind-checking as it is during type-checking (Note [Type checking-recursive type and class declarations]): in the *local* environment,-with ATcTyCon. But we still must store *something* in the *global*-environment. Even though we discard the result of kind-checking, we-sometimes need to produce error messages. These error messages will-want to refer to the tycons being checked, except that they don't-exist yet, and it would be Terribly Annoying to get the error messages-to refer back to HsSyn. So we create a TcTyCon and put it in the-global env. This tycon can print out its name and knows its kind, but-any other action taken on it will panic. Note that TcTyCons are *not*-knot-tied, unlike the rather valid but knot-tied ones that occur-during type-checking.--Note [Declarations for wired-in things]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For wired-in things we simply ignore the declaration-and take the wired-in information.  That avoids complications.-e.g. the need to make the data constructor worker name for-     a constraint tuple match the wired-in one--Note [Datatype return kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are several poorly lit corners around datatype/newtype return kinds.-This Note explains these.  We cover data/newtype families and instances-in Note [Data family/instance return kinds].--data    T a :: <kind> where ...   -- See Point DT4-newtype T a :: <kind> where ...   -- See Point DT5--DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations-    can have declared return kinds. This Note does not apply to Haskell98-    syntax.--DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either-     by checkInitialKind (standalone kind signature / CUSK) or-     inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is-     then passed to tcDataDefn.--DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind-    become parameters to the type. That is, when we say--     data T a :: Type -> Type where ...--    we really mean for T to have two parameters. The second parameter-    is produced by processing the return kind in etaExpandAlgTyCon,-    called in tcDataDefn.--    See also Note [TyConBinders for the result kind signatures of a data type]-    in GHC.Tc.Gen.HsType.--DT4 Datatype return kind restriction: A data type return kind must end-    in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By-    "end in", we mean we strip any foralls and function arguments off before-    checking.--    Examples:-      data T1 :: Type                          -- good-      data T2 :: Bool -> Type                  -- good-      data T3 :: Bool -> forall k. Type        -- strange, but still accepted-      data T4 :: forall k. k -> Type           -- good-      data T5 :: Bool                          -- bad-      data T6 :: Type -> Bool                  -- bad--    Exactly the same applies to data instance (but not data family)-    declarations.  Examples-      data instance D1 :: Type                 -- good-      data instance D2 :: Bool -> Type         -- good--    We can "look through" type synonyms-      type Star = Type-      data T7 :: Bool -> Star                  -- good (synonym expansion ok)-      type Arrow = (->)-      data T8 :: Arrow Bool Type               -- good (ditto)--    But we specifically do *not* do type family reduction here.-      type family ARROW where-        ARROW = (->)-      data T9 :: ARROW Bool Type               -- bad--      type family F a where-        F Int  = Bool-        F Bool = Type-      data T10 :: Bool -> F Bool               -- bad--    The /principle/ here is that in the TyCon for a data type or data instance,-    we must be able to lay out all the type-variable binders, one by one, until-    we reach (TYPE xx).  There is no place for a cast here.  We could add one,-    but let's not!--    This check is done in checkDataKindSig. For data declarations, this-    call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl.--DT5 Newtype return kind restriction.-    If -XUnliftedNewtypes is not on, then newtypes are treated just-    like datatypes --- see (4) above.--    If -XUnliftedNewtypes is on, then a newtype return kind must end in-    TYPE xyz, for some xyz (after type synonym expansion). The "xyz"-    may include type families, but the TYPE part must be visible-    /without/ expanding type families (only synonyms).--    This kind is unified with the kind of the representation type (the-    type of the one argument to the one constructor). See also steps-    (2) and (3) of Note [Implementation of UnliftedNewtypes].--    The checks are done in the same places as for datatypes.-    Examples (assume -XUnliftedNewtypes):--      newtype N1 :: Type                       -- good-      newtype N2 :: Bool -> Type               -- good-      newtype N3 :: forall r. Bool -> TYPE r   -- good--      type family F (t :: Type) :: RuntimeRep-      newtype N4 :: forall t -> TYPE (F t)     -- good--      type family STAR where-        STAR = Type-      newtype N5 :: Bool -> STAR               -- bad--Note [Data family/instance return kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Within this note, understand "instance" to mean data or newtype-instance, and understand "family" to mean data family. No type-families or classes here. Some examples:--data family T a :: <kind>          -- See Point DF56--data    instance T [a] :: <kind> where ...   -- See Point DF2-newtype instance T [a] :: <kind> where ...   -- See Point DF2--Here is the Plan for Data Families:--DF0 Where these kinds come from:--    Families: The return kind is either written in a standalone signature-     or extracted from a family declaration in getInitialKind.-     If a family declaration is missing a result kind, it is assumed to be-     Type. This assumption is in getInitialKind for CUSKs or-     get_fam_decl_initial_kind for non-signature & non-CUSK cases.--   Instances: The data family already has a known kind. The return kind-     of an instance is then calculated by applying the data family tycon-     to the patterns provided, as computed by the typeKind lhs_ty in the-     end of tcDataFamInstHeader. In the case of an instance written in GADT-     syntax, there are potentially *two* return kinds: the one computed from-     applying the data family tycon to the patterns, and the one given by-     the user. This second kind is checked by the tc_kind_sig function within-     tcDataFamInstHeader. See also DF3, below.--DF1 In a data/newtype instance, we treat the kind of the /data family/,-    once instantiated, as the "master kind" for the representation-    TyCon.  For example:-        data family T1 :: Type -> Type -> Type-        data instance T1 Int :: F Bool -> Type where ...-    The "master kind" for the representation TyCon R:T1Int comes-    from T1, not from the signature on the data instance.  It is as-    if we declared-        data R:T1Int :: Type -> Type where ...-     See Note [Liberalising data family return kinds] for an alternative-     plan.  But this current plan is simple, and ensures that all instances-     are simple instantiations of the master, without strange casts.--     An example with non-trivial instantiation:-        data family T2 :: forall k. Type -> k-        data instance T2 :: Type -> Type -> Type where ...-     Here 'k' gets instantiated with (Type -> Type), driven by-     the signature on the 'data instance'. (See also DT3 of-     Note [Datatype return kinds] about eta-expansion, which applies here,-     too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.)--     A newtype example:--       data Color = Red | Blue-       type family Interpret (x :: Color) :: RuntimeRep where-         Interpret 'Red = 'IntRep-         Interpret 'Blue = 'WordRep-       data family Foo (x :: Color) :: TYPE (Interpret x)-       newtype instance Foo 'Red :: TYPE IntRep where-         FooRedC :: Int# -> Foo 'Red--    Here we get that Foo 'Red :: TYPE (Interpret Red), and our-    representation newtype looks like-         newtype R:FooRed :: TYPE (Interpret Red) where-            FooRedC :: Int# -> R:FooRed-    Remember: the master kind comes from the /family/ tycon.--DF2 /After/ this instantiation, the return kind of the master kind-    must obey the usual rules for data/newtype return kinds (DT4, DT5)-    of Note [Datatype return kinds].  Examples:-        data family T3 k :: k-        data instance T3 Type where ...          -- OK-        data instance T3 (Type->Type) where ...  -- OK-        data instance T3 (F Int) where ...       -- Not OK--DF3 Any kind signatures on the data/newtype instance are checked for-    equality with the master kind (and hence may guide instantiation)-    but are otherwise ignored. So in the T1 example above, we check-    that (F Int ~ Type) by unification; but otherwise ignore the-    user-supplied signature from the /family/ not the /instance/.--    We must be sure to instantiate any trailing invisible binders-    before doing this unification.  See the call to tcInstInvisibleBinders-    in tcDataFamInstHeader. For example:-       data family D :: forall k. k-       data instance D :: Type               -- forall k. k   <:  Type-       data instance D :: Type -> Type       -- forall k. k   <:  Type -> Type-         -- NB: these do not overlap-    we must instantiate D before unifying with the signature in the-    data instance declaration--DF4 We also (redundantly) check that any user-specified return kind-    signature in the data instance also obeys DT4/DT5.  For example we-    reject-        data family T1 :: Type -> Type -> Type-        data instance T1 Int :: Type -> F Int-    even if (F Int ~ Type).  We could omit this check, because we-    use the master kind; but it seems more uniform to check it, again-    with checkDataKindSig.--DF5 Data /family/ return kind restrictions. Consider-       data family D8 a :: F a-    where F is a type family.  No data/newtype instance can instantiate-    this so that it obeys the rules of DT4 or DT5.  So GHC proactively-    rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5).-    Remember that a data family supports both data and newtype instances.--    More precisely, the return kind of a data family must be either-        * TYPE xyz (for some type xyz) or-        * a kind variable-    Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5).-    This is checked by the call to checkDataKindSig in tcFamDecl1.  Examples:--      data family D1 :: Type              -- good-      data family D2 :: Bool -> Type      -- good-      data family D3 k :: k               -- good-      data family D4 :: forall k -> k     -- good-      data family D5 :: forall k. k -> k  -- good-      data family D6 :: forall r. TYPE r  -- good-      data family D7 :: Bool -> STAR      -- bad (see STAR from point 5)--DF6 Two return kinds for instances: If an instance has two return kinds,-    one from the family declaration and one from the instance declaration-    (see point DF3 above), they are unified. More accurately, we make sure-    that the kind of the applied data family is a subkind of the user-written-    kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but-    that's overkill for our needs here. Instead, we just instantiate any-    invisible binders in the (instantiated) kind of the data family-    (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders-    and then unify the resulting kind with the kind written by the user.-    This unification naturally produces a coercion, which we can drop, as-    the kind annotation on the instance is redundant (except perhaps for-    effects of unification).--    This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes].--Note [Liberalising data family return kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Could we allow this?-   type family F a where { F Int = Type }-   data family T a :: F a-   data instance T Int where-      MkT :: T Int--In the 'data instance', T Int :: F Int, and F Int = Type, so all seems-well.  But there are lots of complications:--* The representation constructor R:TInt presumably has kind Type.-  So the axiom connecting the two would have to look like-       axTInt :: T Int ~ R:TInt |> sym axFInt-  and that doesn't match expectation in DataFamInstTyCon-  in AlgTyConFlav--* The wrapper can't have type-     $WMkT :: Int -> T Int-  because T Int has the wrong kind.  It would have to be-     $WMkT :: Int -> (T Int) |> axFInt--* The code for $WMkT would also be more complicated, needing-  two coherence coercions. Try it!--* Code for pattern matching would be complicated in an-  exactly dual way.--So yes, we could allow this, but we currently do not. That's-why we have DF2 in Note [Data family/instance return kinds].--Note [Implementation of UnliftedNewtypes]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Expected behavior of UnliftedNewtypes:--* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst-* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98--What follows is a high-level overview of the implementation of the-proposal.--STEP 1: Getting the initial kind, as done by inferInitialKind. We have-two sub-cases:--* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind-  the user writes, whatever it may be.--* Without a SAK/CUSK: If there is no kind signature, the tycon is given-  a kind `TYPE r`, for a fresh unification variable `r`. We do this even-  when -XUnliftedNewtypes is not on; see <Error Messages>, below.--STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs.-The key function here is kcConDecl, which looks at an individual constructor-declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes-is enabled; see <Error Messages>, below), we generate a correct ContextKind-for the checking argument types: see getArgExpKind.--Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is-enabled (we use r0 to denote a unification variable):--newtype Foo rep = MkFoo (forall (a :: TYPE rep). a)-+ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0)-  is the kind that inferInitialKind invented for (Foo rep).--data Color = Red | Blue-type family Interpret (x :: Color) :: RuntimeRep where-  Interpret 'Red = 'IntRep-  Interpret 'Blue = 'WordRep-data family Foo (x :: Color) :: TYPE (Interpret x)-newtype instance Foo 'Red = FooRedC Int#-+ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep--Note that, in the GADT case, we might have a kind signature with arrows-(newtype XYZ a b :: Type -> Type where ...). We want only the final-component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon-in kcTyClDecl.--STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function-here is tcConDecl. Once again, we must use getArgExpKind to ensure that the-representation type's kind matches that of the newtype, for two reasons:--  A. It is possible that a GADT has a CUSK. (Note that this is *not*-     possible for H98 types.) Recall that CUSK types don't go through-     kcTyClDecl, so we might not have done this kind check.-  B. We need to produce the coercion to put on the argument type-     if the kinds are different (for both H98 and GADT).--Example of (B):--type family F a where-  F Int = LiftedRep--newtype N :: TYPE (F Int) where-  MkN :: Int -> N--We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where-axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the-newtype kind, which is the principal correctness condition for newtypes.--Wrinkle: Consider (#17021, typecheck/should_fail/T17021)--    type family Id (x :: a) :: a where-      Id x = x--    newtype T :: TYPE (Id LiftedRep) where-      MkT :: Int -> T--  In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T,-  never Int -> (T |> TYPE axId); otherwise, the result type of the-  constructor wouldn't match the datatype. However, type-checking the-  HsType T might reasonably result in (T |> hole). We thus must ensure-  that this cast is dropped, forcing the type-checker to add one to-  the Int instead.--  Why is it always safe to drop the cast? This result type is type-checked by-  tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is-  important that even after dropping the cast, the type's kind has the form-  TYPE r. This is guaranteed by restrictions on the kinds of datatypes.-  For example, a declaration like `newtype T :: Id Type` is rejected: a-  newtype's final kind always has the form TYPE r, just as we want.--Note that this is possible in the H98 case only for a data family, because-the H98 syntax doesn't permit a kind signature on the newtype itself.--There are also some changes for dealing with families:--1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if-   UnliftedNewtypes is on. This allows us to write things like:-     data family Foo :: TYPE 'IntRep--2. In a newtype instance (with -XUnliftedNewtypes), if the user does-   not write a kind signature, we want to allow the possibility that-   the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind.-   This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example:--       data family Bar (a :: RuntimeRep) :: TYPE a-       newtype instance Bar 'IntRep = BarIntC Int#-       newtype instance Bar 'WordRep :: TYPE 'WordRep where-         BarWordC :: Word# -> Bar 'WordRep--   The data instance corresponding to IntRep does not specify a kind signature,-   so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable).-   The data instance corresponding to WordRep does have a kind signature, so-   we use that kind signature.--3. A data family and its newtype instance may be declared with slightly-   different kinds. See point DF6 in Note [Data family/instance return kinds]--There's also a change in the renamer:--* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means-  for a newtype to have a CUSK. This is necessary since UnliftedNewtypes-  means that, for newtypes without kind signatures, we must use the field-  inside the data constructor to determine the result kind.-  See Note [Unlifted Newtypes and CUSKs] for more detail.--For completeness, it was also necessary to make coerce work on-unlifted types, resolving #13595.--<Error Messages>: It's tempting to think that the expected kind for a newtype-constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type.-But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is-an example:--  newtype A = MkA Int#--If we expect the argument to MkA to have kind Type, then we get a kind-mismatch-error. The problem is that there is no way to connect this mismatch error to--XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow-the A to type-check, but then find the problem when doing validity checking (and-where we get make a suitable error message). One potential worry is--  {-# LANGUAGE PolyKinds #-}-  newtype B a = MkB a--This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just-as we would like. Another potential problem comes in a case like--  -- no UnliftedNewtypes--  data family D :: k-  newtype instance D = MkD Any--Here, we want inference to tell us that k should be instantiated to Type in-the instance. With the approach described here (checking for Type only in-the validity checker), that will not happen. But I cannot think of a non-contrived-example that will notice this lack of inference, so it seems better to improve-error messages than be able to infer this instantiation.---}--tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])-tcTyClDecl roles_info (L loc decl)-  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)-  = case thing of -- See Note [Declarations for wired-in things]-      ATyCon tc -> return (tc, wiredInDerivInfo tc decl)-      _ -> pprPanic "tcTyClDecl" (ppr thing)--  | otherwise-  = setSrcSpan loc $ tcAddDeclCtxt decl $-    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)-       ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl-       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)-       ; return (tc, deriv_infos) }--noDerivInfos :: a -> (a, [DerivInfo])-noDerivInfos a = (a, [])--wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]-wiredInDerivInfo tycon decl-  | DataDecl { tcdDataDefn = dataDefn } <- decl-  , HsDataDefn { dd_derivs = derivs } <- dataDefn-  = [ DerivInfo { di_rep_tc = tycon-                , di_scoped_tvs =-                    if isFunTyCon tycon || isPrimTyCon tycon-                       then []  -- no tyConTyVars-                       else mkTyVarNamePairs (tyConTyVars tycon)-                , di_clauses = unLoc derivs-                , di_ctxt = tcMkDeclCtxt decl } ]-wiredInDerivInfo _ _ = []--  -- "type family" declarations-tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])-tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })-  = fmap noDerivInfos $-    tcFamDecl1 parent fd--  -- "type" synonym declaration-tcTyClDecl1 _parent roles_info-            (SynDecl { tcdLName = L _ tc_name-                     , tcdRhs   = rhs })-  = ASSERT( isNothing _parent )-    fmap noDerivInfos $-    tcTySynRhs roles_info tc_name rhs--  -- "data/newtype" declaration-tcTyClDecl1 _parent roles_info-            decl@(DataDecl { tcdLName = L _ tc_name-                           , tcdDataDefn = defn })-  = ASSERT( isNothing _parent )-    tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn--tcTyClDecl1 _parent roles_info-            (ClassDecl { tcdLName = L _ class_name-                       , tcdCtxt = hs_ctxt-                       , tcdMeths = meths-                       , tcdFDs = fundeps-                       , tcdSigs = sigs-                       , tcdATs = ats-                       , tcdATDefs = at_defs })-  = ASSERT( isNothing _parent )-    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt-                              meths fundeps sigs ats at_defs-       ; return (noDerivInfos (classTyCon clas)) }---{- *********************************************************************-*                                                                      *-          Class declarations-*                                                                      *-********************************************************************* -}--tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn-             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]-             -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]-             -> TcM Class-tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs-  = fixM $ \ clas ->-    -- We need the knot because 'clas' is passed into tcClassATs-    bindTyClTyVars class_name $ \ _ binders res_kind ->-    do { checkClassKindSig res_kind-       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)-       ; let tycon_name = class_name        -- We use the same name-             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-               -- skolems bound by the class decl header (#17841)-               do { ctxt <- tcHsContext hs_ctxt-                  ; fds  <- mapM (addLocM tc_fundep) fundeps-                  ; sig_stuff <- tcClassSigs class_name sigs meths-                  ; at_stuff  <- tcClassATs class_name clas ats at_defs-                  ; return (ctxt, fds, sig_stuff, at_stuff) }--       -- The solveEqualities 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-       -- Skolems to tyvars.-       ; ze        <- emptyZonkEnv-       ; ctxt      <- zonkTcTypesToTypesX ze ctxt-       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff-         -- ToDo: do we need to zonk at_stuff?--       -- TODO: Allow us to distinguish between abstract class,-       -- and concrete class with no methods (maybe by-       -- specifying a trailing where or not--       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff-       ; is_boot <- tcIsHsBootOrSig-       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff-                  = Nothing-                  | otherwise-                  = Just (ctxt, at_stuff, sig_stuff, mindef)--       ; clas <- buildClass class_name binders roles fds body-       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$-                                ppr fds)-       ; return clas }-  where-    skol_info = TyConSkol ClassFlavour class_name-    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;-                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;-                                ; return (tvs1', tvs2') }---{- Note [Associated type defaults]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The following is an example of associated type defaults:-             class C a where-               data D a--               type F a b :: *-               type F a b = [a]        -- Default--Note that we can get default definitions only for type families, not data-families.--}--tcClassATs :: Name                    -- The class name (not knot-tied)-           -> Class                   -- The class parent of this associated type-           -> [LFamilyDecl GhcRn]     -- Associated types.-           -> [LTyFamDefltDecl GhcRn] -- Associated type defaults.-           -> TcM [ClassATItem]-tcClassATs class_name cls ats at_defs-  = do {  -- Complain about associated type defaults for non associated-types-         sequence_ [ failWithTc (badATErr class_name n)-                   | n <- map at_def_tycon at_defs-                   , not (n `elemNameSet` at_names) ]-       ; mapM tc_at ats }-  where-    at_def_tycon :: LTyFamDefltDecl GhcRn -> Name-    at_def_tycon = tyFamInstDeclName . unLoc--    at_fam_name :: LFamilyDecl GhcRn -> Name-    at_fam_name = familyDeclName . unLoc--    at_names = mkNameSet (map at_fam_name ats)--    at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]-    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'-    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv-                                          (at_def_tycon at_def) [at_def])-                        emptyNameEnv at_defs--    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at-                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)-                                  `orElse` []-                  ; atd <- tcDefaultAssocDecl fam_tc at_defs-                  ; return (ATI fam_tc atd) }----------------------------tcDefaultAssocDecl ::-     TyCon                                       -- ^ Family TyCon (not knot-tied)-  -> [LTyFamDefltDecl GhcRn]                     -- ^ Defaults-  -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS-tcDefaultAssocDecl _ []-  = return Nothing  -- No default declaration--tcDefaultAssocDecl _ (d1:_:_)-  = failWithTc (text "More than one default declaration for"-                <+> ppr (tyFamInstDeclName (unLoc d1)))--tcDefaultAssocDecl fam_tc-  [L loc (TyFamInstDecl { tfid_eqn =-         HsIB { hsib_ext  = imp_vars-              , hsib_body = FamEqn { feqn_tycon = L _ tc_name-                                   , feqn_bndrs = mb_expl_bndrs-                                   , feqn_pats  = hs_pats-                                   , feqn_rhs   = hs_rhs_ty }}})]-  = -- See Note [Type-checking default assoc decls]-    setSrcSpan loc $-    tcAddFamInstCtxt (text "default type instance") tc_name $-    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)-       ; let fam_tc_name = tyConName fam_tc-             vis_arity = length (tyConVisibleTyVars fam_tc)-             vis_pats  = numVisibleArgs hs_pats--       -- Kind of family check-       ; ASSERT( fam_tc_name == tc_name )-         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)--       -- Arity check-       ; checkTc (vis_pats == vis_arity)-                 (wrongNumberOfParmsErr vis_arity)--       -- Typecheck RHS-       ---       -- You might think we should pass in some AssocInstInfo, as we're looking-       -- at an associated type. But this would be wrong, because an associated-       -- type default LHS can mention *different* type variables than the-       -- enclosing class. So it's treated more as a freestanding beast.-       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated-                                                    imp_vars (mb_expl_bndrs `orElse` [])-                                                    hs_pats hs_rhs_ty--       ; let fam_tvs = tyConTyVars fam_tc-       ; traceTc "tcDefaultAssocDecl 2" (vcat-           [ text "hs_pats"   <+> ppr hs_pats-           , text "hs_rhs_ty" <+> ppr hs_rhs_ty-           , text "fam_tvs" <+> ppr fam_tvs-           , text "qtvs"    <+> ppr qtvs-             -- NB: Do *not* print `pats` or rhs_ty here, as they can mention-             -- knot-tied TyCons. See #18648.-           ])-       ; 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.-     }--{- Note [Type-checking default assoc decls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this default declaration for an associated type--   class C a where-      type F (a :: k) b :: Type-      type F (x :: j) y = Proxy x -> y--Note that the class variable 'a' doesn't scope over the default assoc-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.-Checking for this property proves surprisingly tricky. Three potential places-where GHC could check for this property include:--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-      type F (a :: k) b :: Type-      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. 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, 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)-      type F2 (x :: z) y = SameKind x y-   data SameKind :: k -> k -> Type--All of the arguments in the default equation for `F2` are type variables, so-that passes the first check. However, if we were to build this substitution,-then both `j` and `k` map to `z`! In terms of visible kind application, it's as-if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear-that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is-also rejected.--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.--}--{- *********************************************************************-*                                                                      *-          Type family declarations-*                                                                      *-********************************************************************* -}--tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon-tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info-                              , fdLName = tc_lname@(L _ tc_name)-                              , fdResultSig = L _ sig-                              , fdInjectivityAnn = inj })-  | DataFamily <- fam_info-  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do-  { traceTc "data family:" (ppr tc_name)-  ; checkFamFlag tc_name--  -- Check that the result kind is OK-  -- We allow things like-  --   data family T (a :: Type) :: forall k. k -> Type-  -- We treat T as having arity 1, but result kind forall k. k -> Type-  -- But we want to check that the result kind finishes in-  --   Type or a kind-variable-  -- For the latter, consider-  --   data family D a :: forall k. Type -> k-  -- When UnliftedNewtypes is enabled, we loosen this restriction-  -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1).-  -- See also Note [Datatype return kinds]-  ; checkDataKindSig DataFamilySort res_kind-  ; tc_rep_name <- newTyConRepName tc_name-  ; let inj   = Injective $ replicate (length binders) True-        tycon = mkFamilyTyCon tc_name binders-                              res_kind-                              (resultVariableName sig)-                              (DataFamilyTyCon tc_rep_name)-                              parent inj-  ; return tycon }--  | OpenTypeFamily <- fam_info-  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do-  { traceTc "open type family:" (ppr tc_name)-  ; checkFamFlag tc_name-  ; inj' <- tcInjectivity binders inj-  ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors-  ; let tycon = mkFamilyTyCon tc_name binders res_kind-                               (resultVariableName sig) OpenSynFamilyTyCon-                               parent inj'-  ; return tycon }--  | ClosedTypeFamily mb_eqns <- fam_info-  = -- Closed type families are a little tricky, because they contain the definition-    -- of both the type family and the equations for a CoAxiom.-    do { traceTc "Closed type family:" (ppr tc_name)-         -- the variables in the header scope only over the injectivity-         -- declaration but this is not involved here-       ; (inj', binders, res_kind)-            <- bindTyClTyVars tc_name $ \ _ binders res_kind ->-               do { inj' <- tcInjectivity binders inj-                  ; return (inj', binders, res_kind) }--       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies-       ; checkResultSigFlag tc_name sig--         -- If Nothing, this is an abstract family in a hs-boot file;-         -- but eqns might be empty in the Just case as well-       ; case mb_eqns of-           Nothing   ->-               return $ mkFamilyTyCon tc_name binders res_kind-                                      (resultVariableName sig)-                                      AbstractClosedSynFamilyTyCon parent-                                      inj'-           Just eqns -> do {--         -- Process the equations, creating CoAxBranches-       ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind-                                   noTcTyConScopedTyVars-                                   False {- this doesn't matter here -}-                                   ClosedTypeFamilyFlavour--       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns-         -- Do not attempt to drop equations dominated by earlier-         -- ones here; in the case of mutual recursion with a data-         -- type, we get a knot-tying failure.  Instead we check-         -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom-         -- Example: tc265--         -- Create a CoAxiom, with the correct src location.-       ; co_ax_name <- newFamInstAxiomName tc_lname []--       ; let mb_co_ax-              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list-              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)--             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)-                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'--         -- We check for instance validity later, when doing validity-         -- checking for the tycon. Exception: checking equations-         -- overlap done by dropDominatedAxioms-       ; return fam_tc } }--#if __GLASGOW_HASKELL__ <= 810-  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker-#endif---- | Maybe return a list of Bools that say whether a type family was declared--- injective in the corresponding type arguments. Length of the list is equal to--- the number of arguments (including implicit kind/coercion arguments).--- True on position--- N means that a function is injective in its Nth argument. False means it is--- not.-tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)-              -> TcM Injectivity-tcInjectivity _ Nothing-  = return NotInjective--  -- User provided an injectivity annotation, so for each tyvar argument we-  -- check whether a type family was declared injective in that argument. We-  -- return a list of Bools, where True means that corresponding type variable-  -- was mentioned in lInjNames (type family is injective in that argument) and-  -- False means that it was not mentioned in lInjNames (type family is not-  -- injective in that type variable). We also extend injectivity information to-  -- kind variables, so if a user declares:-  ---  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a-  ---  -- then we mark both `a` and `k1` as injective.-  -- NB: the return kind is considered to be *input* argument to a type family.-  -- Since injectivity allows to infer input arguments from the result in theory-  -- we should always mark the result kind variable (`k3` in this example) as-  -- injective.  The reason is that result type has always an assigned kind and-  -- therefore we can always infer the result kind if we know the result type.-  -- But this does not seem to be useful in any way so we don't do it.  (Another-  -- reason is that the implementation would not be straightforward.)-tcInjectivity tcbs (Just (L loc (InjectivityAnn _ lInjNames)))-  = setSrcSpan loc $-    do { let tvs = binderVars tcbs-       ; dflags <- getDynFlags-       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)-                 (text "Illegal injectivity annotation" $$-                  text "Use TypeFamilyDependencies to allow this")-       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames-       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds-       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars-                        closeOverKinds (mkVarSet inj_tvs)-       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs-       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs-                                       , ppr inj_ktvs, ppr inj_bools ])-       ; return $ Injective inj_bools }--tcTySynRhs :: RolesInfo -> Name-           -> LHsType GhcRn -> TcM TyCon-tcTySynRhs roles_info tc_name hs_ty-  = bindTyClTyVars tc_name $ \ _ binders res_kind ->-    do { env <- getLclEnv-       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))-       ; rhs_ty <- pushTcLevelM_   $-                   solveEqualities $-                   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 }--tcDataDefn :: SDoc -> RolesInfo -> Name-           -> HsDataDefn GhcRn -> TcM (TyCon, [DerivInfo])-  -- NB: not used for newtype/data instances (whether associated or not)-tcDataDefn err_ctxt roles_info tc_name-           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType-                       , dd_ctxt = ctxt-                       , dd_kindSig = mb_ksig  -- Already in tc's kind-                                               -- via inferInitialKinds-                       , dd_cons = cons-                       , dd_derivs = derivs })-  = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind ->-       -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need-       -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'-       ---       -- The TyCon tyvars must scope over-       --    - the stupid theta (dd_ctxt)-       --    - for H98 constructors only, the ConDecl-       -- But it does no harm to bring them into scope-       -- over GADT ConDecls as well; and it's awkward not to-    do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons-         -- see Note [Datatype return kinds]-       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind--       ; tcg_env <- getGblEnv-       ; let hsc_src = tcg_src tcg_env-       ; unless (mk_permissive_kind hsc_src cons) $-         checkDataKindSig (DataDeclSort new_or_data) final_res_kind--       ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt-       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta-       ; kind_signatures <- xoptM LangExt.KindSignatures--             -- Check that we don't use kind signatures without Glasgow extensions-       ; when (isJust mb_ksig) $-         checkTc (kind_signatures) (badSigTyDecl tc_name)--       ; tycon <- fixM $ \ tycon -> do-             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs-                   res_ty      = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))-                   roles       = roles_info tc_name-             ; data_cons <- tcConDecls-                              tycon-                              new_or_data-                              final_bndrs-                              final_res_kind-                              res_ty-                              cons-             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons-             ; tc_rep_nm <- newTyConRepName tc_name-             ; return (mkAlgTyCon tc_name-                                  final_bndrs-                                  final_res_kind-                                  roles-                                  (fmap unLoc cType)-                                  stupid_theta tc_rhs-                                  (VanillaAlgTyCon tc_rep_nm)-                                  gadt_syntax) }-       ; let deriv_info = DerivInfo { di_rep_tc = tycon-                                    , di_scoped_tvs = tcTyConScopedTyVars tctc-                                    , di_clauses = unLoc derivs-                                    , di_ctxt = err_ctxt }-       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)-       ; return (tycon, [deriv_info]) }-  where-    -- 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.-    ---    -- Note that this is only a property that data type declarations possess,-    -- so one could not have, say, a data family instance in an hsig file that-    -- has kind `Bool`. Therefore, this check need only occur in the code that-    -- typechecks data type declarations.-    mk_permissive_kind HsigFile [] = True-    mk_permissive_kind _ _ = False--    -- In hs-boot, a 'data' declaration with no constructors-    -- indicates a nominally distinct abstract data type.-    mk_tc_rhs HsBootFile _ []-      = return AbstractTyCon--    mk_tc_rhs HsigFile _ [] -- ditto-      = return AbstractTyCon--    mk_tc_rhs _ tycon data_cons-      = case new_or_data of-          DataType -> return (mkDataTyConRhs data_cons)-          NewType  -> ASSERT( not (null data_cons) )-                      mkNewTyConRhs tc_name tycon (head data_cons)-----------------------------kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()--- Used for the equations of a closed type family only--- Not used for data/type instances-kcTyFamInstEqn tc_fam_tc-    (L loc (HsIB { hsib_ext = imp_vars-                 , hsib_body = FamEqn { feqn_tycon = L _ eqn_tc_name-                                      , feqn_bndrs = mb_expl_bndrs-                                      , feqn_pats  = hs_pats-                                      , feqn_rhs   = hs_rhs_ty }}))-  = setSrcSpan loc $-    do { traceTc "kcTyFamInstEqn" (vcat-           [ text "tc_name ="    <+> ppr eqn_tc_name-           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)-           , text "hsib_vars ="  <+> ppr imp_vars-           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs-           , text "feqn_pats ="  <+> ppr hs_pats ])-          -- this check reports an arity error instead of a kind error; easier for user-       ; let vis_pats = numVisibleArgs hs_pats--       -- First, check if we're dealing with a closed type family equation, and-       -- if so, ensure that each equation's type constructor is for the right-       -- type family.  E.g. barf on-       --    type family F a where { G Int = Bool }-       ; checkTc (tc_fam_tc_name == eqn_tc_name) $-         wrongTyFamName tc_fam_tc_name eqn_tc_name--       ; checkTc (vis_pats == vis_arity) $-                  wrongNumberOfParmsErr vis_arity--       ; discardResult $-         bindImplicitTKBndrs_Q_Tv imp_vars $-         bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $-         do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats-            ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) }-             -- Why "_Tv" here?  Consider (#14066-             --  type family Bar x y where-             --      Bar (x :: a) (y :: b) = Int-             --      Bar (x :: c) (y :: d) = Bool-             -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately-    }-  where-    vis_arity = length (tyConVisibleTyVars tc_fam_tc)-    tc_fam_tc_name = getName tc_fam_tc-----------------------------tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn-               -> TcM (KnotTied CoAxBranch)--- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families--- (typechecked here) have TyFamInstEqns--tcTyFamInstEqn fam_tc mb_clsinfo-    (L loc (HsIB { hsib_ext = imp_vars-                 , hsib_body = FamEqn { feqn_bndrs  = mb_expl_bndrs-                                      , feqn_pats   = hs_pats-                                      , feqn_rhs    = hs_rhs_ty }}))-  = setSrcSpan loc $-    do { traceTc "tcTyFamInstEqn" $-         vcat [ ppr fam_tc <+> ppr hs_pats-              , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)-              , case mb_clsinfo of-                  NotAssociated {} -> empty-                  InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ]--       -- First, check the arity of visible arguments-       -- If we wait until validity checking, we'll get kind errors-       -- below when an arity error will be much easier to understand.-       -- Note that for closed type families, kcTyFamInstEqn has already-       -- checked the arity previously.-       ; let vis_arity = length (tyConVisibleTyVars fam_tc)-             vis_pats  = numVisibleArgs hs_pats-       ; checkTc (vis_pats == vis_arity) $-         wrongNumberOfParmsErr vis_arity-       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo-                                      imp_vars (mb_expl_bndrs `orElse` [])-                                      hs_pats hs_rhs_ty-       -- Don't print results they may be knot-tied-       -- (tcFamInstEqnGuts zonks to Type)-       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty-                              (map (const Nominal) qtvs)-                              loc) }--{--Kind check type patterns and kind annotate the embedded type variables.-     type instance F [a] = rhs-- * Here we check that a type instance matches its kind signature, but we do-   not check whether there is a pattern for each type index; the latter-   check is only required for type synonym instances.--Note [Instantiating a family tycon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's possible that kind-checking the result of a family tycon applied to-its patterns will instantiate the tycon further. For example, we might-have--  type family F :: k where-    F = Int-    F = Maybe--After checking (F :: forall k. k) (with no visible patterns), we still need-to instantiate the k. With data family instances, this problem can be even-more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See-indexed-types/should_compile/T12369 for an example.--So, the kind-checker must return the new skolems and args (that is, Type-or (Type -> Type) for the equations above) and the instantiated kind.--Note [Generalising in tcTyFamInstEqnGuts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have something like-  type instance forall (a::k) b. F t1 t2 = 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--However, 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.--}-----------------------------tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo-                   -> [Name] -> [LHsTyVarBndr () GhcRn] -- Implicit and explicicit binder-                   -> HsTyPats GhcRn                    -- Patterns-                   -> LHsType GhcRn                     -- RHS-                   -> TcM ([TyVar], [TcType], TcType)   -- (tyvars, pats, rhs)--- Used only for type families, not data families-tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty-  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc)--       -- By now, for type families (but not data families) we should-       -- have checked that the number of patterns matches tyConArity--       -- 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 $-                  do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats-                       -- Ensure that the instance is consistent with its-                       -- parent class (#16008)-                     ; addConsistencyConstraints mb_clsinfo lhs_ty-                     ; 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)-       ; qtvs <- quantifyTyVars dvs--       ; 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-       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty-       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty--       ; let pats = unravelFamInstPats lhs_ty-             -- Note that we do this after solveEqualities-             -- so that any strange coercions inside lhs_ty-             -- have been solved before we attempt to unravel it-       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)-       ; return (qtvs, pats, rhs_ty) }--------------------unravelFamInstPats :: TcType -> [TcType]--- Decompose fam_app to get the argument patterns------ We expect fam_app to look like (F t1 .. tn)--- tcFamTyPats is capable of returning ((F ty1 |> co) ty2),--- but that can't happen here because we already checked the--- arity of F matches the number of pattern-unravelFamInstPats fam_app-  = case splitTyConApp_maybe fam_app of-      Just (_, pats) -> pats-      Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance"-        -- The Nothing case cannot happen for type families, because-        -- we don't call unravelFamInstPats until we've solved the-        -- equalities. For data families, it shouldn't happen either,-        -- we need to fail hard and early if it does. See trac issue #15905-        -- for an example of this happening.--addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()--- In the corresponding positions of the class and type-family,--- ensure the family argument is the same as the class argument---   E.g    class C a b c d where---             F c x y a :: Type--- Here the first  arg of F should be the same as the third of C---  and the fourth arg of F should be the same as the first of C------ We emit /Derived/ constraints (a bit like fundeps) to encourage--- unification to happen, but without actually reporting errors.--- If, despite the efforts, corresponding positions do not match,--- checkConsistentFamInst will complain-addConsistencyConstraints mb_clsinfo fam_app-  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo-  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app-  = do { let eqs = [ (cls_ty, pat)-                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats-                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]-       ; traceTc "addConsistencyConstraints" (ppr eqs)-       ; emitDerivedEqs AssocFamPatOrigin eqs }-    -- Improve inference-    -- Any mis-match is reports by checkConsistentFamInst-  | otherwise-  = return ()--{- Note [Constraints in patterns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This isn't the whole story. See comment in tcFamTyPats.--At first glance, it seems there is a complicated story to tell in tcFamTyPats-around constraint solving. After all, type family patterns can now do-GADT pattern-matching, which is jolly complicated. But, there's a key fact-which makes this all simple: everything is at top level! There cannot-be untouchable type variables. There can't be weird interaction between-case branches. There can't be global skolems.--This means that the semantics of type-level GADT matching is a little-different than term level. If we have--  data G a where-    MkGBool :: G Bool--And then--  type family F (a :: G k) :: k-  type instance F MkGBool = True--we get--  axF : F Bool (MkGBool <Bool>) ~ True--Simple! No casting on the RHS, because we can affect the kind parameter-to F.--If we ever introduce local type families, this all gets a lot more-complicated, and will end up looking awfully like term-level GADT-pattern-matching.---** The new story **--Here is really what we want:--The matcher really can't deal with covars in arbitrary spots in coercions.-But it can deal with covars that are arguments to GADT data constructors.-So we somehow want to allow covars only in precisely those spots, then use-them as givens when checking the RHS. TODO (RAE): Implement plan.--Note [Quantified kind variables of a family pattern]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   type family KindFam (p :: k1) (q :: k1)-           data T :: Maybe k1 -> k2 -> *-           type instance KindFam (a :: Maybe k) b = T a b -> Int-The HsBSig for the family patterns will be ([k], [a])--Then in the family instance we want to-  * Bring into scope [ "k" -> k:*, "a" -> a:k ]-  * Kind-check the RHS-  * Quantify the type instance over k and k', as well as a,b, thus-       type instance [k, k', a:Maybe k, b:k']-                     KindFam (Maybe k) k' a b = T k k' a b -> Int--Notice that in the third step we quantify over all the visibly-mentioned-type variables (a,b), but also over the implicitly mentioned kind variables-(k, k').  In this case one is bound explicitly but often there will be-none. The role of the kind signature (a :: Maybe k) is to add a constraint-that 'a' must have that kind, and to bring 'k' into scope.----************************************************************************-*                                                                      *-               Data types-*                                                                      *-************************************************************************--}--dataDeclChecks :: Name -> NewOrData-               -> LHsContext GhcRn -> [LConDecl GhcRn]-               -> TcM Bool-dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons-  = do {   -- Check that we don't use GADT syntax in H98 world-         gadtSyntax_ok <- xoptM LangExt.GADTSyntax-       ; let gadt_syntax = consUseGadtSyntax cons-       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)--           -- Check that the stupid theta is empty for a GADT-style declaration-       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)--         -- Check that a newtype has exactly one constructor-         -- Do this before checking for empty data decls, so that-         -- we don't suggest -XEmptyDataDecls for newtypes-       ; checkTc (new_or_data == DataType || isSingleton cons)-                (newtypeConError tc_name (length cons))--         -- Check that there's at least one condecl,-         -- or else we're reading an hs-boot file, or -XEmptyDataDecls-       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls-       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?-       ; checkTc (not (null cons) || empty_data_decls || is_boot)-                 (emptyConDeclsErr tc_name)-       ; return gadt_syntax }---------------------------------------consUseGadtSyntax :: [LConDecl GhcRn] -> Bool-consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True-consUseGadtSyntax _                          = False-                 -- All constructors have same shape--------------------------------------tcConDecls :: KnotTied TyCon -> NewOrData-           -> [TyConBinder] -> TcKind   -- binders and result kind of tycon-           -> KnotTied Type -> [LConDecl GhcRn] -> TcM [DataCon]-tcConDecls rep_tycon new_or_data tmpl_bndrs res_kind res_tmpl-  = concatMapM $ addLocM $-    tcConDecl rep_tycon (mkTyConTagMap rep_tycon)-              tmpl_bndrs res_kind res_tmpl new_or_data-    -- It's important that we pay for tag allocation here, once per TyCon,-    -- See Note [Constructor tag allocation], fixes #14657--tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!-          -> NameEnv ConTag-          -> [TyConBinder] -> TcKind   -- tycon binders and result kind-          -> KnotTied Type-                 -- Return type template (T tys), where T is the family TyCon-          -> NewOrData-          -> ConDecl GhcRn-          -> TcM [DataCon]--tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data-          (ConDeclH98 { con_name = name-                      , con_ex_tvs = explicit_tkv_nms-                      , con_mb_cxt = hs_ctxt-                      , con_args = hs_args })-  = addErrCtxt (dataConCtxtName [name]) $-    do { -- NB: the tyvars from the declaration header are in scope--         -- Get hold of the existential type variables-         -- e.g. data T a = forall k (b::k) f. MkT a (f b)-         -- Here tmpl_bndrs = {a}-         --      hs_qvars = HsQTvs { hsq_implicit = {k}-         --                        , hsq_explicit = {f,b} }--       ; 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 $-              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)-                 ; let (arg_tys, stricts) = unzip btys-                 ; return (ctxt, arg_tys, field_lbls, stricts)-                 }--       ; let tmpl_tvs = binderVars tmpl_bndrs--         -- 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.--             -- 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-           -- 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-                            stricts Nothing field_lbls-                            univ_tvs ex_tvs user_tvbs-                            [{- no eq_preds -}] ctxt arg_tys-                            res_tmpl rep_tycon tag_map-                  -- 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]-       }--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.-          (ConDeclGADT { con_g_ext = implicit_tkv_nms-                       , con_names = names-                       , con_qvars = explicit_tkv_nms-                       , con_mb_cxt = cxt, con_args = hs_args-                       , con_res_ty = hs_res_ty })-  = addErrCtxt (dataConCtxtName names) $-    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 $-              do { ctxt <- tcHsMbContext cxt-                 ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty-                         -- See Note [GADT return kinds]--                   -- See Note [Datatype return kinds]-                 ; let exp_kind = getArgExpKind new_or_data res_kind--                 ; btys <- tcConArgs exp_kind hs_args-                 ; let (arg_tys, stricts) = unzip btys-                 ; field_lbls <- lookupConstructorFields name-                 ; 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 tvbndrs =  (mkTyVarBinders InferredSpec tkvs)-                     ++ (mkTyVarBinders SpecifiedSpec imp_tvs)-                     ++ exp_tvbndrs--             -- Zonk to Types-       ; (ze, tvbndrs) <- zonkTyVarBinders       tvbndrs-       ; arg_tys       <- zonkScaledTcTypesToTypesX ze arg_tys-       ; ctxt          <- zonkTcTypesToTypesX ze ctxt-       ; res_ty        <- zonkTcTypeToTypeX   ze res_ty--       ; let (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst)-               = rejigConRes tmpl_bndrs res_tmpl tvbndrs res_ty-             -- See Note [Checking GADT return types]--             ctxt'      = substTys arg_subst ctxt-             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)-       ; let-           buildOneDataCon (L _ name) = do-             { is_infix <- tcConIsInfixGADT name hs_args-             ; rep_nm   <- newTyConRepName name--             ; buildDataCon fam_envs name is_infix-                            rep_nm-                            stricts Nothing field_lbls-                            univ_tvs ex_tvs tvbndrs' eq_preds-                            ctxt' arg_tys' res_ty' rep_tycon tag_map-                  -- 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 names)-       ; mapM buildOneDataCon names-       }--{- Note [GADT return kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   type family Star where Star = Type-   data T :: Type where-      MkT :: Int -> T--If, for some stupid reason, tcInferLHsTypeKind on the return type of-MkT returned (T |> ax, Star), then the return-type check in-checkValidDataCon would reject the decl (although of course there is-nothing wrong with it).  We are implicitly requiring tha-tcInferLHsTypeKind doesn't any gratuitous top-level casts.--}---- | Produce an "expected kind" for the arguments of a data/newtype.--- If the declaration is indeed for a newtype,--- then this expected kind will be the kind provided. Otherwise,--- it is OpenKind for datatypes and liftedTypeKind.--- Why do we not check for -XUnliftedNewtypes? See point <Error Messages>--- in Note [Implementation of UnliftedNewtypes]-getArgExpKind :: NewOrData -> Kind -> ContextKind-getArgExpKind NewType res_ki = TheKind res_ki-getArgExpKind DataType _     = OpenKind--tcConIsInfixH98 :: Name-             -> HsConDetails a b-             -> TcM Bool-tcConIsInfixH98 _   details-  = case details of-           InfixCon {}  -> return True-           _            -> return False--tcConIsInfixGADT :: Name-             -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r-             -> TcM Bool-tcConIsInfixGADT con details-  = case details of-           InfixCon {}  -> return True-           RecCon {}    -> return False-           PrefixCon arg_tys           -- See Note [Infix GADT constructors]-               | isSymOcc (getOccName con)-               , [_ty1,_ty2] <- map hsScaledThing arg_tys-                  -> do { fix_env <- getFixityEnv-                        ; return (con `elemNameEnv` fix_env) }-               | otherwise -> return False--tcConArgs :: ContextKind  -- expected kind of arguments-                          -- always OpenKind for datatypes, but unlifted newtypes-                          -- might have a specific kind-          -> HsConDeclDetails GhcRn-          -> TcM [(Scaled TcType, HsSrcBang)]-tcConArgs exp_kind (PrefixCon btys)-  = mapM (tcConArg exp_kind) btys-tcConArgs exp_kind (InfixCon bty1 bty2)-  = do { bty1' <- tcConArg exp_kind bty1-       ; bty2' <- tcConArg exp_kind bty2-       ; return [bty1', bty2'] }-tcConArgs exp_kind (RecCon fields)-  = mapM (tcConArg exp_kind) btys-  where-    -- We need a one-to-one mapping from field_names to btys-    combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))-                   (unLoc fields)-    explode (ns,ty) = zip ns (repeat ty)-    exploded = concatMap explode combined-    (_,btys) = unzip exploded---tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,-                         -- but might be an unlifted type with UnliftedNewtypes-         -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)-tcConArg exp_kind (HsScaled w bty)-  = do  { traceTc "tcConArg 1" (ppr bty)-        ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind-        ; w' <- tcDataConMult w-        ; traceTc "tcConArg 2" (ppr bty)-        ; return (Scaled w' arg_ty, getBangStrictness bty) }--tcDataConMult :: HsArrow GhcRn -> TcM Mult-tcDataConMult arr@(HsUnrestrictedArrow _) = do-  -- See Note [Function arrows in GADT constructors]-  linearEnabled <- xoptM LangExt.LinearTypes-  if linearEnabled then tcMult arr else return oneDataConTy-tcDataConMult arr = tcMult arr--{--Note [Function arrows in GADT constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the absence of -XLinearTypes, we always interpret function arrows-in GADT constructor types as linear, even if the user wrote an-unrestricted arrow. See the "Without -XLinearTypes" section of the-linear types GHC proposal (#111). We opt to do this in the-typechecker, and not in an earlier pass, to ensure that the AST-matches what the user wrote (#18791).--Note [Infix GADT constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do not currently have syntax to declare an infix constructor in GADT syntax,-but it makes a (small) difference to the Show instance.  So as a slightly-ad-hoc solution, we regard a GADT data constructor as infix if-  a) it is an operator symbol-  b) it has two arguments-  c) there is a fixity declaration for it-For example:-   infix 6 (:--:)-   data T a where-     (:--:) :: t1 -> t2 -> T Int---Note [Checking GADT return types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is a delicacy around checking the return types of a datacon. The-central problem is dealing with a declaration like--  data T a where-    MkT :: T a -> Q a--Note that the return type of MkT is totally bogus. When creating the T-tycon, we also need to create the MkT datacon, which must have a "rejigged"-return type. That is, the MkT datacon's type must be transformed to have-a uniform return type with explicit coercions for GADT-like type parameters.-This rejigging is what rejigConRes does. The problem is, though, that checking-that the return type is appropriate is much easier when done over *Type*,-not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully-defined yet.--So, we want to make rejigConRes lazy and then check the validity of-the return type in checkValidDataCon.  To do this we /always/ return a-6-tuple from rejigConRes (so that we can compute the return type from it, which-checkValidDataCon needs), but the first three fields may be bogus if-the return type isn't valid (the last equation for rejigConRes).--This is better than an earlier solution which reduced the number of-errors reported in one pass.  See #7175, and #10836.--}---- Example---   data instance T (b,c) where---      TI :: forall e. e -> T (e,e)------ The representation tycon looks like this:---   data :R7T b c where---      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1--- In this case orig_res_ty = T (e,e)--rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.-                                  -- data instance T [a] b c ...-                                  --      gives template ([a,b,c], T [a] b c)-            -> [InvisTVBinder]    -- The constructor's type variables (both inferred and user-written)-            -> KnotTied Type      -- res_ty-            -> ([TyVar],          -- Universal-                [TyVar],          -- Existential (distinct OccNames from univs)-                [InvisTVBinder],  -- The constructor's rejigged, user-written-                                  -- type variables-                [EqSpec],         -- Equality predicates-                TCvSubst)         -- Substitution to apply to argument types-        -- We don't check that the TyCon given in the ResTy is-        -- the same as the parent tycon, because checkValidDataCon will do it--- NB: All arguments may potentially be knot-tied-rejigConRes tmpl_bndrs res_tmpl dc_tvbndrs res_ty-        -- E.g.  data T [a] b c where-        --         MkT :: forall x y z. T [(x,y)] z z-        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs-        --     (NB: unlike the H98 case, the dc_tvs are not all existential)-        -- Then we generate-        --      Univ tyvars     Eq-spec-        --          a              a~(x,y)-        --          b              b~z-        --          z-        -- Existentials are the leftover type vars: [x,y]-        -- The user-written type variables are what is listed in the forall:-        --   [x, y, z] (all specified). We must rejig these as well.-        --   See Note [DataCon user type variable binders] in GHC.Core.DataCon.-        -- So we return ( [a,b,z], [x,y]-        --              , [], [x,y,z]-        --              , [a~(x,y),b~z], <arg-subst> )-  | Just subst <- tcMatchTy res_tmpl res_ty-  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst-        raw_ex_tvs = dc_tvs `minusList` univ_tvs-        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs--        -- After rejigging the existential tyvars, the resulting substitution-        -- gives us exactly what we need to rejig the user-written tyvars,-        -- since the dcUserTyVarBinders invariant guarantees that the-        -- substitution has *all* the tyvars in its domain.-        -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.-        subst_user_tvs  = mapVarBndrs (getTyVar "rejigConRes" . substTyVar arg_subst)-        substed_tvbndrs = subst_user_tvs dc_tvbndrs--        substed_eqs = map (substEqSpec arg_subst) raw_eqs-    in-    (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst)--  | otherwise-        -- If the return type of the data constructor doesn't match the parent-        -- type constructor, or the arity is wrong, the tcMatchTy will fail-        --    e.g   data T a b where-        --            T1 :: Maybe a   -- Wrong tycon-        --            T2 :: T [a]     -- Wrong arity-        -- We are detect that later, in checkValidDataCon, but meanwhile-        -- we must do *something*, not just crash.  So we do something simple-        -- albeit bogus, relying on checkValidDataCon to check the-        --  bad-result-type error before seeing that the other fields look odd-        -- See Note [Checking GADT return types]-  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_tvbndrs, [], emptyTCvSubst)-  where-    dc_tvs   = binderVars dc_tvbndrs-    tmpl_tvs = binderVars tmpl_bndrs--{- Note [mkGADTVars]-~~~~~~~~~~~~~~~~~~~~-Running example:--data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where-  MkT :: forall (x1 : *) (y :: x1) (z :: *).-         T x1 * (Proxy (y :: x1), z) z--We need the rejigged type to be--  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).-         forall (y :: x1) (z :: *).-         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)-      => T x1 k2 a b--You might naively expect that z should become a universal tyvar,-not an existential. (After all, x1 becomes a universal tyvar.)-But z has kind * while b has kind k2, so the return type-   T x1 k2 a z-is ill-kinded.  Another way to say it is this: the universal-tyvars must have exactly the same kinds as the tyConTyVars.--So we need an existential tyvar and a heterogeneous equality-constraint. (The b ~ z is a bit redundant with the k2 ~ * that-comes before in that b ~ z implies k2 ~ *. I'm sure we could do-some analysis that could eliminate k2 ~ *. But we don't do this-yet.)--The data con signature has already been fully kind-checked.-The return type--  T x1 * (Proxy (y :: x1), z) z-becomes-  qtkvs    = [x1 :: *, y :: x1, z :: *]-  res_tmpl = T x1 * (Proxy x1 y, z) z--We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We-know this match will succeed because of the validity check (actually done-later, but laziness saves us -- see Note [Checking GADT return types]).-Thus, we get--  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }--Now, we need to figure out what the GADT equalities should be. In this case,-we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a-renaming. The others should be GADT equalities. We also need to make-sure that the universally-quantified variables of the datacon match up-with the tyvars of the tycon, as required for Core context well-formedness.-(This last bit is why we have to rejig at all!)--`choose` walks down the tycon tyvars, figuring out what to do with each one.-It carries two substitutions:-  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables-    mentioned in the datacon signature.-  - r_sub's domain is *result* tyvars, names written by the programmer in-    the datacon signature. The final rejigged type will use these names, but-    the subst is still needed because sometimes the printed name of these variables-    is different. (See choose_tv_name, below.)--Before explaining the details of `choose`, let's just look at its operation-on our example:--  choose [] [] {} {} [k1, k2, a, b]-  -->          -- first branch of `case` statement-  choose-    univs:    [x1 :: *]-    eq_spec:  []-    t_sub:    {k1 |-> x1}-    r_sub:    {x1 |-> x1}-    t_tvs:    [k2, a, b]-  -->          -- second branch of `case` statement-  choose-    univs:    [k2 :: *, x1 :: *]-    eq_spec:  [k2 ~ *]-    t_sub:    {k1 |-> x1, k2 |-> k2}-    r_sub:    {x1 |-> x1}-    t_tvs:    [a, b]-  -->          -- second branch of `case` statement-  choose-    univs:    [a :: k2, k2 :: *, x1 :: *]-    eq_spec:  [ a ~ (Proxy x1 y, z)-              , k2 ~ * ]-    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}-    r_sub:    {x1 |-> x1}-    t_tvs:    [b]-  -->          -- second branch of `case` statement-  choose-    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]-    eq_spec:  [ b ~ z-              , a ~ (Proxy x1 y, z)-              , k2 ~ * ]-    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}-    r_sub:    {x1 |-> x1}-    t_tvs:    []-  -->          -- end of recursion-  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]-  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]-  , {x1 |-> x1} )--`choose` looks up each tycon tyvar in the matching (it *must* be matched!).--* If it finds a bare result tyvar (the first branch of the `case`-  statement), it checks to make sure that the result tyvar isn't yet-  in the list of univ_tvs.  If it is in that list, then we have a-  repeated variable in the return type, and we in fact need a GADT-  equality.--* It then checks to make sure that the kind of the result tyvar-  matches the kind of the template tyvar. This check is what forces-  `z` to be existential, as it should be, explained above.--* Assuming no repeated variables or kind-changing, we wish to use the-  variable name given in the datacon signature (that is, `x1` not-  `k1`), not the tycon signature (which may have been made up by-  GHC). So, we add a mapping from the tycon tyvar to the result tyvar-  to t_sub.--* If we discover that a mapping in `subst` gives us a non-tyvar (the-  second branch of the `case` statement), then we have a GADT equality-  to create.  We create a fresh equality, but we don't extend any-  substitutions. The template variable substitution is meant for use-  in universal tyvar kinds, and these shouldn't be affected by any-  GADT equalities.--This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways-of simplifying it:--1) The first branch of the `case` statement is really an optimization, used-in order to get fewer GADT equalities. It might be possible to make a GADT-equality for *every* univ. tyvar, even if the equality is trivial, and then-either deal with the bigger type or somehow reduce it later.--2) This algorithm strives to use the names for type variables as specified-by the user in the datacon signature. If we always used the tycon tyvar-names, for example, this would be simplified. This change would almost-certainly degrade error messages a bit, though.--}---- ^ From information about a source datacon definition, extract out--- what the universal variables and the GADT equalities should be.--- See Note [mkGADTVars].-mkGADTVars :: [TyVar]    -- ^ The tycon vars-           -> [TyVar]    -- ^ The datacon vars-           -> TCvSubst   -- ^ The matching between the template result type-                         -- and the actual result type-           -> ( [TyVar]-              , [EqSpec]-              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,-                           -- and a subst to apply to the GADT equalities-                           -- and existentials.-mkGADTVars tmpl_tvs dc_tvs subst-  = choose [] [] empty_subst empty_subst tmpl_tvs-  where-    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)-               `unionInScope` getTCvInScope subst-    empty_subst = mkEmptyTCvSubst in_scope--    choose :: [TyVar]           -- accumulator of univ tvs, reversed-           -> [EqSpec]          -- accumulator of GADT equalities, reversed-           -> TCvSubst          -- template substitution-           -> TCvSubst          -- res. substitution-           -> [TyVar]           -- template tvs (the univ tvs passed in)-           -> ( [TyVar]         -- the univ_tvs-              , [EqSpec]        -- GADT equalities-              , TCvSubst )       -- a substitution to fix kinds in ex_tvs--    choose univs eqs _t_sub r_sub []-      = (reverse univs, reverse eqs, r_sub)-    choose univs eqs t_sub r_sub (t_tv:t_tvs)-      | Just r_ty <- lookupTyVar subst t_tv-      = case getTyVar_maybe r_ty of-          Just r_tv-            |  not (r_tv `elem` univs)-            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))-            -> -- simple, well-kinded variable substitution.-               choose (r_tv:univs) eqs-                      (extendTvSubst t_sub t_tv r_ty')-                      (extendTvSubst r_sub r_tv r_ty')-                      t_tvs-            where-              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)-              r_ty'  = mkTyVarTy r_tv1--               -- Not a simple substitution: make an equality predicate-          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)-                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))-                         -- We've updated the kind of t_tv,-                         -- so add it to t_sub (#14162)-                      r_sub t_tvs-            where-              t_tv' = updateTyVarKind (substTy t_sub) t_tv--      | otherwise-      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)--      -- choose an appropriate name for a univ tyvar.-      -- This *must* preserve the Unique of the result tv, so that we-      -- can detect repeated variables. It prefers user-specified names-      -- over system names. A result variable with a system name can-      -- happen with GHC-generated implicit kind variables.-    choose_tv_name :: TyVar -> TyVar -> Name-    choose_tv_name r_tv t_tv-      | isSystemName r_tv_name-      = setNameUnique t_tv_name (getUnique r_tv_name)--      | otherwise-      = r_tv_name--      where-        r_tv_name = getName r_tv-        t_tv_name = getName t_tv--{--Note [Substitution in template variables kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--data G (a :: Maybe k) where-  MkG :: G Nothing--With explicit kind variables--data G k (a :: Maybe k) where-  MkG :: G k1 (Nothing k1)--Note how k1 is distinct from k. So, when we match the template-`G k a` against `G k1 (Nothing k1)`, we get a subst-[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two-mappings, we surely don't want to add (k, k1) to the list of-GADT equalities -- that would be overly complex and would create-more untouchable variables than we need. So, when figuring out-which tyvars are GADT-like and which aren't (the fundamental-job of `choose`), we want to treat `k` as *not* GADT-like.-Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)-instead of (a :: Maybe k). This is the reason for dealing-with a substitution in here.--However, we do not *always* want to substitute. Consider--data H (a :: k) where-  MkH :: H Int--With explicit kind variables:--data H k (a :: k) where-  MkH :: H * Int--Here, we have a kind-indexed GADT. The subst in question is-[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s-kind, because that would give a constructor with the type--MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a--The problem here is that a's kind is wrong -- it needs to be k, not *!-So, if the matching for a variable is anything but another bare variable,-we drop the mapping from the substitution before proceeding. This-was not an issue before kind-indexed GADTs because this case could-never happen.--************************************************************************-*                                                                      *-                Validity checking-*                                                                      *-************************************************************************--Validity checking is done once the mutually-recursive knot has been-tied, so we can look at things freely.--}--checkValidTyCl :: TyCon -> TcM [TyCon]--- The returned list is either a singleton (if valid)--- or a list of "fake tycons" (if not); the fake tycons--- include any implicits, like promoted data constructors--- See Note [Recover from validity error]-checkValidTyCl tc-  = setSrcSpan (getSrcSpan tc) $-    addTyConCtxt tc            $-    recoverM recovery_code     $-    do { traceTc "Starting validity for tycon" (ppr tc)-       ; checkValidTyCon tc-       ; traceTc "Done validity for tycon" (ppr tc)-       ; return [tc] }-  where-    recovery_code -- See Note [Recover from validity error]-      = do { traceTc "Aborted validity for tycon" (ppr tc)-           ; return (concatMap mk_fake_tc $-                     ATyCon tc : implicitTyConThings tc) }--    mk_fake_tc (ATyCon tc)-      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]-      | otherwise       = [makeRecoveryTyCon tc]-    mk_fake_tc (AConLike (RealDataCon dc))-                        = [makeRecoveryTyCon (promoteDataCon dc)]-    mk_fake_tc _        = []--{- Note [Recover from validity error]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We recover from a validity error in a type or class, which allows us-to report multiple validity errors. In the failure case we return a-TyCon of the right kind, but with no interesting behaviour-(makeRecoveryTyCon). Why?  Suppose we have-   type T a = Fun-where Fun is a type family of arity 1.  The RHS is invalid, but we-want to go on checking validity of subsequent type declarations.-So we replace T with an abstract TyCon which will do no harm.-See indexed-types/should_fail/BadSock and #10896--Some notes:--* We must make fakes for promoted DataCons too. Consider (#15215)-      data T a = MkT ...-      data S a = ...T...MkT....-  If there is an error in the definition of 'T' we add a "fake type-  constructor" to the type environment, so that we can continue to-  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'-  and so there was an internal error when we met 'MkT' in the body of-  'S'.--* Painfully, we *don't* want to do this for classes.-  Consider tcfail041:-     class (?x::Int) => C a where ...-     instance C Int-  The class is invalid because of the superclass constraint.  But-  we still want it to look like a /class/, else the instance bleats-  that the instance is mal-formed because it hasn't got a class in-  the head.--  This is really bogus; now we have in scope a Class that is invalid-  in some way, with unknown downstream consequences.  A better-  alternative might be to make a fake class TyCon.  A job for another day.--}------------------------------ For data types declared with record syntax, we require--- that each constructor that has a field 'f'---      (a) has the same result type---      (b) has the same type for 'f'--- module alpha conversion of the quantified type variables--- of the constructor.------ Note that we allow existentials to match because the--- fields can never meet. E.g---      data T where---        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T---        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T--- Here we do not complain about f1,f2 because they are existential--checkValidTyCon :: TyCon -> TcM ()-checkValidTyCon tc-  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim-  = return ()--  | isWiredIn tc     -- validity-checking wired-in tycons is a waste of-                     -- time. More importantly, a wired-in tycon might-                     -- violate assumptions. Example: (~) has a superclass-                     -- mentioning (~#), which is ill-kinded in source Haskell-  = traceTc "Skipping validity check for wired-in" (ppr tc)--  | otherwise-  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))-       ; if | Just cl <- tyConClass_maybe tc-              -> checkValidClass cl--            | Just syn_rhs <- synTyConRhs_maybe tc-              -> do { checkValidType syn_ctxt syn_rhs-                    ; checkTySynRhs syn_ctxt syn_rhs }--            | Just fam_flav <- famTyConFlav_maybe tc-              -> case fam_flav of-               { ClosedSynFamilyTyCon (Just ax)-                   -> tcAddClosedTypeFamilyDeclCtxt tc $-                      checkValidCoAxiom ax-               ; ClosedSynFamilyTyCon Nothing   -> return ()-               ; AbstractClosedSynFamilyTyCon ->-                 do { hsBoot <- tcIsHsBootOrSig-                    ; checkTc hsBoot $-                      text "You may define an abstract closed type family" $$-                      text "only in a .hs-boot file" }-               ; DataFamilyTyCon {}           -> return ()-               ; OpenSynFamilyTyCon           -> return ()-               ; BuiltInSynFamTyCon _         -> return () }--             | otherwise -> do-               { -- Check the context on the data decl-                 traceTc "cvtc1" (ppr tc)-               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)--               ; traceTc "cvtc2" (ppr tc)--               ; dflags          <- getDynFlags-               ; existential_ok  <- xoptM LangExt.ExistentialQuantification-               ; gadt_ok         <- xoptM LangExt.GADTs-               ; let ex_ok = existential_ok || gadt_ok-                     -- Data cons can have existential context-               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons-               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)--                -- Check that fields with the same name share a type-               ; mapM_ check_fields groups }}-  where-    syn_ctxt  = TySynCtxt name-    name      = tyConName tc-    data_cons = tyConDataCons tc--    groups = equivClasses cmp_fld (concatMap get_fields data_cons)-    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2-    get_fields con = dataConFieldLabels con `zip` repeat con-        -- dataConFieldLabels may return the empty list, which is fine--    -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils-    -- We must check (a) that the named field has the same-    --                   type in each constructor-    --               (b) that those constructors have the same result type-    ---    -- However, the constructors may have differently named type variable-    -- and (worse) we don't know how the correspond to each other.  E.g.-    --     C1 :: forall a b. { f :: a, g :: b } -> T a b-    --     C2 :: forall d c. { f :: c, g :: c } -> T c d-    ---    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's-    -- result type against other candidates' types BOTH WAYS ROUND.-    -- If they magically agrees, take the substitution and-    -- apply them to the latter ones, and see if they match perfectly.-    check_fields ((label, con1) :| other_fields)-        -- These fields all have the same name, but are from-        -- different constructors in the data type-        = recoverM (return ()) $ mapM_ checkOne other_fields-                -- Check that all the fields in the group have the same type-                -- NB: this check assumes that all the constructors of a given-                -- data type use the same type variables-        where-        res1 = dataConOrigResTy con1-        fty1 = dataConFieldType con1 lbl-        lbl = flLabel label--        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical-            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2-                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }-            where-                res2 = dataConOrigResTy con2-                fty2 = dataConFieldType con2 lbl--checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()--- Checks the partial record field selector, and warns.--- See Note [Checking partial record field]-checkPartialRecordField all_cons fld-  = setSrcSpan loc $-      warnIfFlag Opt_WarnPartialFields-        (not is_exhaustive && not (startsWithUnderscore occ_name))-        (sep [text "Use of partial record field selector" <> colon,-              nest 2 $ quotes (ppr occ_name)])-  where-    sel_name = flSelector fld-    loc    = getSrcSpan sel_name-    occ_name = getOccName sel_name--    (cons_with_field, cons_without_field) = partition has_field all_cons-    has_field con = fld `elem` (dataConFieldLabels con)-    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field--    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field-    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1-    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)-    inst_tys = substTyVars eq_subst univ_tvs--checkFieldCompat :: FieldLabelString -> DataCon -> DataCon-                 -> Type -> Type -> Type -> Type -> TcM ()-checkFieldCompat fld con1 con2 res1 res2 fty1 fty2-  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)-        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }-  where-    mb_subst1 = tcMatchTy res1 res2-    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2----------------------------------checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()-checkValidDataCon dflags existential_ok tc con-  = setSrcSpan (getSrcSpan con)  $-    addErrCtxt (dataConCtxt con) $-    do  { -- Check that the return type of the data constructor-          -- matches the type constructor; eg reject this:-          --   data T a where { MkT :: Bogus a }-          -- It's important to do this first:-          --  see Note [Checking GADT return types]-          --  and c.f. Note [Check role annotations in a second pass]-          let tc_tvs      = tyConTyVars tc-              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)-              orig_res_ty = dataConOrigResTy con-        ; traceTc "checkValidDataCon" (vcat-              [ ppr con, ppr tc, ppr tc_tvs-              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)-              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])---        ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty))-                  (badDataConTyCon con res_ty_tmpl)-            -- Note that checkTc aborts if it finds an error. This is-            -- critical to avoid panicking when we call dataConDisplayType-            -- on an un-rejiggable datacon!-            -- Also NB that we match the *kind* as well as the *type* (#18357)-            -- However, if the kind is the only thing that doesn't match, the-            -- error message is terrible.  E.g. test T18357b-            --    type family Star where Star = Type-            --    newtype T :: Type where MkT :: Int -> (T :: Star)--        ; traceTc "checkValidDataCon 2" (ppr data_con_display_type)--          -- Check that the result type is a *monotype*-          --  e.g. reject this:   MkT :: T (forall a. a->a)-          -- Reason: it's really the argument of an equality constraint-        ; checkValidMonoType orig_res_ty--          -- If we are dealing with a newtype, we allow levity polymorphism-          -- regardless of whether or not UnliftedNewtypes is enabled. A-          -- later check in checkNewDataCon handles this, producing a-          -- better error message than checkForLevPoly would.-        ; unless (isNewTyCon tc)-            (mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con))--          -- Extra checks for newtype data constructors. Importantly, these-          -- checks /must/ come before the call to checkValidType below. This-          -- is because checkValidType invokes the constraint solver, and-          -- invoking the solver on an ill formed newtype constructor can-          -- confuse GHC to the point of panicking. See #17955 for an example.-        ; when (isNewTyCon tc) (checkNewDataCon con)--          -- Check all argument types for validity-        ; checkValidType ctxt data_con_display_type--          -- Check that existentials are allowed if they are used-        ; checkTc (existential_ok || isVanillaDataCon con)-                  (badExistential con)--          -- Check that UNPACK pragmas and bangs work out-          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"-          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack-        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]--          -- Check the dcUserTyVarBinders invariant-          -- See Note [DataCon user type variable binders] in GHC.Core.DataCon-          -- checked here because we sometimes build invalid DataCons before-          -- erroring above here-        ; when debugIsOn $-          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con-                   user_tvs                       = dataConUserTyVars con-                   user_tvbs_invariant-                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)-                       == Set.fromList user_tvs-             ; MASSERT2( user_tvbs_invariant-                       , vcat ([ ppr con-                               , ppr univs-                               , ppr exs-                               , ppr eq_spec-                               , ppr user_tvs ])) }--        ; traceTc "Done validity of data con" $-          vcat [ ppr con-               , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)-               , text "Datacon rep type:" <+> ppr (dataConRepType con)-               , text "Datacon display type:" <+> ppr data_con_display_type-               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))-               , case tyConFamInst_maybe (dataConTyCon con) of-                   Nothing -> text "not family"-                   Just (f, _) -> ppr (tyConBinders f) ]-    }-  where-    ctxt = ConArgCtxt (dataConName con)--    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()-    check_bang (HsSrcBang _ _ SrcLazy) _ n-      | not (xopt LangExt.StrictData dflags)-      = addErrTc-          (bad_bang n (text "Lazy annotation (~) without StrictData"))-    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n-      | isSrcUnpacked want_unpack, not is_strict-      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))-      | isSrcUnpacked want_unpack-      , case rep_bang of { HsUnpack {} -> False; _ -> True }-      -- If not optimising, we don't unpack (rep_bang is never-      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.-      -- See dataConSrcToImplBang.-      , not (gopt Opt_OmitInterfacePragmas dflags)-      -- When typechecking an indefinite package in Backpack, we-      -- may attempt to UNPACK an abstract type.  The test here will-      -- conclude that this is unusable, but it might become usable-      -- when we actually fill in the abstract type.  As such, don't-      -- warn in this case (it gives users the wrong idea about whether-      -- or not UNPACK on abstract types is supported; it is!)-      , homeUnitIsDefinite dflags-      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))-      where-        is_strict = case strict_mark of-                      NoSrcStrict -> xopt LangExt.StrictData dflags-                      bang        -> isSrcStrict bang--    check_bang _ _ _-      = return ()--    bad_bang n herald-      = hang herald 2 (text "on the" <+> speakNth n-                       <+> text "argument of" <+> quotes (ppr con))--    data_con_display_type = dataConDisplayType dflags con----------------------------------checkNewDataCon :: DataCon -> TcM ()--- Further checks for the data constructor of a newtype-checkNewDataCon con-  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))-              -- One argument--        ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes-        ; let allowedArgType =-                unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True-        ; checkTc allowedArgType $ vcat-          [ text "A newtype cannot have an unlifted argument type"-          , text "Perhaps you intended to use UnliftedNewtypes"-          ]-        ; dflags <- getDynFlags--        ; let check_con what msg =-               checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con))--        ; checkTc (ok_mult (scaledMult arg_ty1)) $-          text "A newtype constructor must be linear"--        ; check_con (null eq_spec) $-          text "A newtype constructor must have a return type of form T a1 ... an"-                -- Return type is (T a b c)--        ; check_con (null theta) $-          text "A newtype constructor cannot have a context in its type"--        ; check_con (null ex_tvs) $-          text "A newtype constructor cannot have existential type variables"-                -- No existentials--        ; checkTc (all ok_bang (dataConSrcBangs con))-                  (newtypeStrictError con)-                -- No strictness annotations-    }-  where-    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)-      = dataConFullSig con--    (arg_ty1 : _) = arg_tys--    ok_bang (HsSrcBang _ _ SrcStrict) = False-    ok_bang (HsSrcBang _ _ SrcLazy)   = False-    ok_bang _                         = True--    ok_mult One = True-    ok_mult _   = False----------------------------------checkValidClass :: Class -> TcM ()-checkValidClass cls-  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods-        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses-        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses-        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies-        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses--        -- Check that the class is unary, unless multiparameter type classes-        -- are enabled; also recognize deprecated nullary type classes-        -- extension (subsumed by multiparameter type classes, #8993)-        ; checkTc (multi_param_type_classes || cls_arity == 1 ||-                    (nullary_type_classes && cls_arity == 0))-                  (classArityErr cls_arity cls)-        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)--        -- Check the super-classes-        ; checkValidTheta (ClassSCCtxt (className cls)) theta--          -- Now check for cyclic superclasses-          -- If there are superclass cycles, checkClassCycleErrs bails.-        ; unless undecidable_super_classes $-          case checkClassCycles cls of-             Just err -> setSrcSpan (getSrcSpan cls) $-                         addErrTc err-             Nothing  -> return ()--        -- Check the class operations.-        -- But only if there have been no earlier errors-        -- See Note [Abort when superclass cycle is detected]-        ; whenNoErrs $-          mapM_ (check_op constrained_class_methods) op_stuff--        -- Check the associated type defaults are well-formed and instantiated-        ; mapM_ check_at at_stuff  }-  where-    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls-    cls_arity = length (tyConVisibleTyVars (classTyCon cls))-       -- Ignore invisible variables-    cls_tv_set = mkVarSet tyvars--    check_op constrained_class_methods (sel_id, dm)-      = setSrcSpan (getSrcSpan sel_id) $-        addErrCtxt (classOpCtxt sel_id op_ty) $ do-        { traceTc "class op type" (ppr op_ty)-        ; checkValidType ctxt op_ty-                -- This implements the ambiguity check, among other things-                -- Example: tc223-                --   class Error e => Game b mv e | b -> mv e where-                --      newBoard :: MonadState b m => m ()-                -- Here, MonadState has a fundep m->b, so newBoard is fine--           -- a method cannot be levity polymorphic, as we have to store the-           -- method in a dictionary-           -- example of what this prevents:-           --   class BoundedX (a :: TYPE r) where minBound :: a-           -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad-        ; checkForLevPoly empty tau1--        ; unless constrained_class_methods $-          mapM_ check_constraint (tail (cls_pred:op_theta))--        ; check_dm ctxt sel_id cls_pred tau2 dm-        }-        where-          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints-          op_name = idName sel_id-          op_ty   = idType sel_id-          (_,cls_pred,tau1) = tcSplitMethodTy op_ty-          -- See Note [Splitting nested sigma types in class type signatures]-          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1--          check_constraint :: TcPredType -> TcM ()-          check_constraint pred -- See Note [Class method constraints]-            = when (not (isEmptyVarSet pred_tvs) &&-                    pred_tvs `subVarSet` cls_tv_set)-                   (addErrTc (badMethPred sel_id pred))-            where-              pred_tvs = tyCoVarsOfType pred--    check_at (ATI fam_tc m_dflt_rhs)-      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)-                     (noClassTyVarErr cls fam_tc)-                        -- Check that the associated type mentions at least-                        -- one of the class type variables-                        -- The check is disabled for nullary type classes,-                        -- since there is no possible ambiguity (#10020)--             -- Check that any default declarations for associated types are valid-           ; 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--    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()-    -- Check validity of the /top-level/ generic-default type-    -- E.g for   class C a where-    --             default op :: forall b. (a~b) => blah-    -- we do not want to do an ambiguity check on a type with-    -- a free TyVar 'a' (#11608).  See TcType-    -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType-    -- Hence the mkDefaultMethodType to close the type.-    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau-             (Just (dm_name, dm_spec@(GenericDM dm_ty)))-      = setSrcSpan (getSrcSpan dm_name) $ do-            -- We have carefully set the SrcSpan on the generic-            -- default-method Name to be that of the generic-            -- default type signature--          -- First, we check that the method's default type signature-          -- aligns with the non-default type signature.-          -- See Note [Default method type signatures must align]-          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls-              -- Note that the second field of this tuple contains the context-              -- of the default type signature, making it apparent that we-              -- ignore method contexts completely when validity-checking-              -- default type signatures. See the end of-              -- Note [Default method type signatures must align]-              -- to learn why this is OK.-              ---              -- See also-              -- Note [Splitting nested sigma types in class type signatures]-              -- for an explanation of why we don't use tcSplitSigmaTy here.-              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty--              -- Given this class definition:-              ---              --  class C a b where-              --    op         :: forall p q. (Ord a, D p q)-              --               => a -> b -> p -> (a, b)-              --    default op :: forall r s. E r-              --               => a -> b -> s -> (a, b)-              ---              -- We want to match up two types of the form:-              ---              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)-              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)-              ---              -- Notice that the two type signatures can be quantified over-              -- different class type variables! Therefore, it's important that-              -- we include the class predicate parts to match up a with aa and-              -- b with bb.-              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau-              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau--          traceTc "check_dm" $ vcat-              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty-              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]--          -- Actually checking that the types align is done with a call to-          -- tcMatchTys. We need to get a match in both directions to rule-          -- out degenerate cases like these:-          ---          --  class Foo a where-          --    foo1         :: a -> b-          --    default foo1 :: a -> Int-          ---          --    foo2         :: a -> Int-          --    default foo2 :: a -> b-          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]-                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $-               hang (text "The default type signature for"-                     <+> ppr sel_id <> colon)-                 2 (ppr dm_ty)-            $$ (text "does not match its corresponding"-                <+> text "non-default type signature")--          -- Now do an ambiguity check on the default type signature.-          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)-    check_dm _ _ _ _ _ = return ()--checkFamFlag :: Name -> TcM ()--- Check that we don't use families without -XTypeFamilies--- The parser won't even parse them, but I suppose a GHC API--- client might have a go!-checkFamFlag tc_name-  = do { idx_tys <- xoptM LangExt.TypeFamilies-       ; checkTc idx_tys err_msg }-  where-    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))-                 2 (text "Enable TypeFamilies to allow indexed type families")--checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()-checkResultSigFlag tc_name (TyVarSig _ tvb)-  = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies-       ; checkTc ty_fam_deps $-         hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))-            2 (text "Enable TypeFamilyDependencies to allow result variable names") }-checkResultSigFlag _ _ = return ()  -- other cases OK--{- Note [Class method constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Haskell 2010 is supposed to reject-  class C a where-    op :: Eq a => a -> a-where the method type constrains only the class variable(s).  (The extension--XConstrainedClassMethods switches off this check.)  But regardless-we should not reject-  class C a where-    op :: (?x::Int) => a -> a-as pointed out in #11793. So the test here rejects the program if-  * -XConstrainedClassMethods is off-  * the tyvars of the constraint are non-empty-  * all the tyvars are class tyvars, none are locally quantified--Note [Abort when superclass cycle is detected]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must avoid doing the ambiguity check for the methods (in-checkValidClass.check_op) when there are already errors accumulated.-This is because one of the errors may be a superclass cycle, and-superclass cycles cause canonicalization to loop. Here is a-representative example:--  class D a => C a where-    meth :: D a => ()-  class C a => D a--This fixes #9415, #9739--Note [Default method type signatures must align]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GHC enforces the invariant that a class method's default type signature-must "align" with that of the method's non-default type signature, as per-GHC #12918. For instance, if you have:--  class Foo a where-    bar :: forall b. Context => a -> b--Then a default type signature for bar must be alpha equivalent to-(forall b. a -> b). That is, the types must be the same modulo differences in-contexts. So the following would be acceptable default type signatures:--    default bar :: forall b. Context1 => a -> b-    default bar :: forall x. Context2 => a -> x--But the following are NOT acceptable default type signatures:--    default bar :: forall b. b -> a-    default bar :: forall x. x-    default bar :: a -> Int--Note that a is bound by the class declaration for Foo itself, so it is-not allowed to differ in the default type signature.--The default type signature (default bar :: a -> Int) deserves special mention,-since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To-write this, you need to declare the default type signature like so:--    default bar :: forall b. (b ~ Int). a -> b--As noted in #12918, there are several reasons to do this:--1. It would make no sense to have a type that was flat-out incompatible with-   the non-default type signature. For instance, if you had:--     class Foo a where-       bar :: a -> Int-       default bar :: a -> Bool--   Then that would always fail in an instance declaration. So this check-   nips such cases in the bud before they have the chance to produce-   confusing error messages.--2. Internally, GHC uses TypeApplications to instantiate the default method in-   an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance.-   Thus, GHC needs to know exactly what the universally quantified type-   variables are, and when instantiated that way, the default method's type-   must match the expected type.--3. Aesthetically, by only allowing the default type signature to differ in its-   context, we are making it more explicit the ways in which the default type-   signature is less polymorphic than the non-default type signature.--You might be wondering: why are the contexts allowed to be different, but not-the rest of the type signature? That's because default implementations often-rely on assumptions that the more general, non-default type signatures do not.-For instance, in the Enum class declaration:--    class Enum a where-      enum :: [a]-      default enum :: (Generic a, GEnum (Rep a)) => [a]-      enum = map to genum--    class GEnum f where-      genum :: [f a]--The default implementation for enum only works for types that are instances of-Generic, and for which their generic Rep type is an instance of GEnum. But-clearly enum doesn't _have_ to use this implementation, so naturally, the-context for enum is allowed to be different to accommodate this. As a result,-when we validity-check default type signatures, we ignore contexts completely.--Note that when checking whether two type signatures match, we must take care to-split as many foralls as it takes to retrieve the tau types we which to check.-See Note [Splitting nested sigma types in class type signatures].--Note [Splitting nested sigma types in class type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this type synonym and class definition:--  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t--  class Each s t a b where-    each         ::                                      Traversal s t a b-    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b--It might seem obvious that the tau types in both type signatures for `each`-are the same, but actually getting GHC to conclude this is surprisingly tricky.-That is because in general, the form of a class method's non-default type-signature is:--  forall a. C a => forall d. D d => E a b--And the general form of a default type signature is:--  forall f. F f => E a f -- The variable `a` comes from the class--So it you want to get the tau types in each type signature, you might find it-reasonable to call tcSplitSigmaTy twice on the non-default type signature, and-call it once on the default type signature. For most classes and methods, this-will work, but Each is a bit of an exceptional case. The way `each` is written,-it doesn't quantify any additional type variables besides those of the Each-class itself, so the non-default type signature for `each` is actually this:--  forall s t a b. Each s t a b => Traversal s t a b--Notice that there _appears_ to only be one forall. But there's actually another-forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy-twice, you'll also go under the forall in Traversal! That is, you'll end up-with:--  (a -> f b) -> s -> f t--A problem arises because you only call tcSplitSigmaTy once on the default type-signature for `each`, which gives you--  Traversal s t a b--Or, equivalently:--  forall f. Applicative f => (a -> f b) -> s -> f t--This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will-say that the tau types for `each` are not equal.--A solution to this problem is to use tcSplitNestedSigmaTys instead of-tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it-sees until it can't go any further, so if you called it on the default type-signature for `each`, it would return (a -> f b) -> s -> f t like we desired.--Note [Checking partial record field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This check checks the partial record field selector, and warns (#7169).--For example:--  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }--The function 'm2' is partial record field, and will fail when it is applied to-'B'. The warning identifies such partial fields. The check is performed at the-declaration of T, not at the call-sites of m2.--The warning can be suppressed by prefixing the field-name with an underscore.-For example:--  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }--************************************************************************-*                                                                      *-                Checking role validity-*                                                                      *-************************************************************************--}--checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()-checkValidRoleAnnots role_annots tc-  | isTypeSynonymTyCon tc = check_no_roles-  | isFamilyTyCon tc      = check_no_roles-  | isAlgTyCon tc         = check_roles-  | otherwise             = return ()-  where-    -- Role annotations are given only on *explicit* variables,-    -- but a tycon stores roles for all variables.-    -- So, we drop the implicit roles (which are all Nominal, anyway).-    name                   = tyConName tc-    roles                  = tyConRoles tc-    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $-                             zip roles (tyConBinders tc)-    role_annot_decl_maybe  = lookupRoleAnnot role_annots name--    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)-    pick_vis (role, tvb)-      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)-      | otherwise                = Nothing--    check_roles-      = whenIsJust role_annot_decl_maybe $-          \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) ->-          addRoleAnnotCtxt name $-          setSrcSpan loc $ do-          { role_annots_ok <- xoptM LangExt.RoleAnnotations-          ; checkTc role_annots_ok $ needXRoleAnnotations tc-          ; checkTc (vis_vars `equalLength` the_role_annots)-                    (wrongNumberOfRoles vis_vars decl)-          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles-          -- Representational or phantom roles for class parameters-          -- quickly lead to incoherence. So, we require-          -- IncoherentInstances to have them. See #8773, #14292-          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances-          ; checkTc (  incoherent_roles_ok-                    || (not $ isClassTyCon tc)-                    || (all (== Nominal) vis_roles))-                    incoherentRoles--          ; lint <- goptM Opt_DoCoreLinting-          ; when lint $ checkValidRoles tc }--    check_no_roles-      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl--checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()-checkRoleAnnot _  (L _ Nothing)   _  = return ()-checkRoleAnnot tv (L _ (Just r1)) r2-  = when (r1 /= r2) $-    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2---- This is a double-check on the role inference algorithm. It is only run when--- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils-checkValidRoles :: TyCon -> TcM ()--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-checkValidRoles tc-  | isAlgTyCon tc-    -- tyConDataCons returns an empty list for data families-  = mapM_ check_dc_roles (tyConDataCons tc)-  | Just rhs <- synTyConRhs_maybe tc-  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs-  | otherwise-  = return ()-  where-    check_dc_roles datacon-      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))-           ; mapM_ (check_ty_roles role_env Representational) $-                    eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) }-                    -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils-      where-        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)-          = dataConFullSig datacon-        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)-              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs-        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)-        role_env   = univ_roles `plusVarEnv` ex_roles--    check_ty_roles env role ty-      | Just ty' <- coreView ty -- #14101-      = check_ty_roles env role ty'--    check_ty_roles env role (TyVarTy tv)-      = case lookupVarEnv env tv of-          Just role' -> unless (role' `ltRole` role || role' == role) $-                        report_error $ text "type variable" <+> quotes (ppr tv) <+>-                                       text "cannot have role" <+> ppr role <+>-                                       text "because it was assigned role" <+> ppr role'-          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>-                                       text "missing in environment"--    check_ty_roles env Representational (TyConApp tc tys)-      = let roles' = tyConRoles tc in-        zipWithM_ (maybe_check_ty_roles env) roles' tys--    check_ty_roles env Nominal (TyConApp _ tys)-      = mapM_ (check_ty_roles env Nominal) tys--    check_ty_roles _   Phantom ty@(TyConApp {})-      = pprPanic "check_ty_roles" (ppr ty)--    check_ty_roles env role (AppTy ty1 ty2)-      =  check_ty_roles env role    ty1-      >> check_ty_roles env Nominal ty2--    check_ty_roles env role (FunTy _ w ty1 ty2)-      =  check_ty_roles env Nominal w-      >> check_ty_roles env role ty1-      >> check_ty_roles env role ty2--    check_ty_roles env role (ForAllTy (Bndr tv _) ty)-      =  check_ty_roles env Nominal (tyVarKind tv)-      >> check_ty_roles (extendVarEnv env tv Nominal) role ty--    check_ty_roles _   _    (LitTy {}) = return ()--    check_ty_roles env role (CastTy t _)-      = check_ty_roles env role t--    check_ty_roles _   role (CoercionTy co)-      = unless (role == Phantom) $-        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role--    maybe_check_ty_roles env role ty-      = when (role == Nominal || role == Representational) $-        check_ty_roles env role ty--    report_error doc-      = addErrTc $ vcat [text "Internal error in role inference:",-                         doc,-                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]--{--************************************************************************-*                                                                      *-                Error messages-*                                                                      *-************************************************************************--}--tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc-tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,-                      text "declaration for", quotes (ppr (tcdName decl))]--addVDQNote :: TcTyCon -> TcM a -> TcM a--- See Note [Inferring visible dependent quantification]--- Only types without a signature (CUSK or SAK) here-addVDQNote tycon thing_inside-  | ASSERT2( isTcTyCon tycon, ppr tycon )-    ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )-    has_vdq-  = addLandmarkErrCtxt vdq_warning thing_inside-  | otherwise-  = thing_inside-  where-      -- Check whether a tycon has visible dependent quantification.-      -- This will *always* be a TcTyCon. Furthermore, it will *always*-      -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader.-      -- Thus, all the TyConBinders will be anonymous. Thus, the-      -- free variables of the tycon's kind will be the same as the free-      -- variables from all the binders.-    has_vdq  = any is_vdq_tcb (tyConBinders tycon)-    tc_kind  = tyConKind tycon-    kind_fvs = tyCoVarsOfType tc_kind--    is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) &&-                     isVisibleTyConBinder tcb--    vdq_warning = vcat-      [ text "NB: Type" <+> quotes (ppr tycon) <+>-        text "was inferred to use visible dependent quantification."-      , text "Most types with visible dependent quantification are"-      , text "polymorphically recursive and need a standalone kind"-      , text "signature. Perhaps supply one, with StandaloneKindSignatures."-      ]--tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a-tcAddDeclCtxt decl thing_inside-  = addErrCtxt (tcMkDeclCtxt decl) thing_inside--tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a-tcAddTyFamInstCtxt decl-  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)--tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc-tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =-                            HsIB { hsib_body = eqn }})-  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")-                    (unLoc (feqn_tycon eqn))--tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a-tcAddDataFamInstCtxt decl-  = addErrCtxt (tcMkDataFamInstCtxt decl)--tcMkFamInstCtxt :: SDoc -> Name -> SDoc-tcMkFamInstCtxt flavour tycon-  = hsep [ text "In the" <+> flavour <+> text "declaration for"-         , quotes (ppr tycon) ]--tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a-tcAddFamInstCtxt flavour tycon thing_inside-  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside--tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a-tcAddClosedTypeFamilyDeclCtxt tc-  = addErrCtxt ctxt-  where-    ctxt = text "In the equations for closed type family" <+>-           quotes (ppr tc)--resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc-resultTypeMisMatch field_name con1 con2-  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,-                text "have a common field" <+> quotes (ppr field_name) <> comma],-          nest 2 $ text "but have different result types"]--fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc-fieldTypeMisMatch field_name con1 con2-  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,-         text "give different types for field", quotes (ppr field_name)]--dataConCtxtName :: [Located Name] -> SDoc-dataConCtxtName [con]-   = text "In the definition of data constructor" <+> quotes (ppr con)-dataConCtxtName con-   = text "In the definition of data constructors" <+> interpp'SP con--dataConCtxt :: Outputable a => a -> SDoc-dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)--classOpCtxt :: Var -> Type -> SDoc-classOpCtxt sel_id tau = sep [text "When checking the class method:",-                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]--classArityErr :: Int -> Class -> SDoc-classArityErr n cls-    | n == 0 = mkErr "No" "no-parameter"-    | otherwise = mkErr "Too many" "multi-parameter"-  where-    mkErr howMany allowWhat =-        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),-              parens (text ("Enable MultiParamTypeClasses to allow "-                                    ++ allowWhat ++ " classes"))]--classFunDepsErr :: Class -> SDoc-classFunDepsErr cls-  = vcat [text "Fundeps in class" <+> quotes (ppr cls),-          parens (text "Enable FunctionalDependencies to allow fundeps")]--badMethPred :: Id -> TcPredType -> SDoc-badMethPred sel_id pred-  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)-                 <+> text "in the type of" <+> quotes (ppr sel_id))-              2 (text "constrains only the class type variables")-         , text "Enable ConstrainedClassMethods to allow it" ]--noClassTyVarErr :: Class -> TyCon -> SDoc-noClassTyVarErr clas fam_tc-  = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))-        , text "mentions none of the type or kind variables of the class" <+>-                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]--badDataConTyCon :: DataCon -> Type -> SDoc-badDataConTyCon data_con res_ty_tmpl-  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>-                text "returns type" <+> quotes (ppr actual_res_ty))-       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))-  where-    actual_res_ty = dataConOrigResTy data_con--badGadtDecl :: Name -> SDoc-badGadtDecl tc_name-  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)-         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]--badExistential :: DataCon -> SDoc-badExistential con-  = sdocWithDynFlags (\dflags ->-      hang (text "Data constructor" <+> quotes (ppr con) <+>-                  text "has existential type variables, a context, or a specialised result type")-         2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType dflags con)-                 , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]))--badStupidTheta :: Name -> SDoc-badStupidTheta tc_name-  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)--newtypeConError :: Name -> Int -> SDoc-newtypeConError tycon n-  = sep [text "A newtype must have exactly one constructor,",-         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]--newtypeStrictError :: DataCon -> SDoc-newtypeStrictError con-  = sep [text "A newtype constructor cannot have a strictness annotation,",-         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]--newtypeFieldErr :: DataCon -> Int -> SDoc-newtypeFieldErr con_name n_flds-  = sep [text "The constructor of a newtype must have exactly one field",-         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]--badSigTyDecl :: Name -> SDoc-badSigTyDecl tc_name-  = vcat [ text "Illegal kind signature" <+>-           quotes (ppr tc_name)-         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]--emptyConDeclsErr :: Name -> SDoc-emptyConDeclsErr tycon-  = sep [quotes (ppr tycon) <+> text "has no constructors",-         nest 2 $ text "(EmptyDataDecls permits this)"]--wrongKindOfFamily :: TyCon -> SDoc-wrongKindOfFamily family-  = text "Wrong category of family instance; declaration was for a"-    <+> kindOfFamily-  where-    kindOfFamily | isTypeFamilyTyCon family = text "type family"-                 | isDataFamilyTyCon family = text "data family"-                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)---- | Produce an error for oversaturated type family equations with too many--- required arguments.--- See Note [Oversaturated type family equations] in "GHC.Tc.Validity".-wrongNumberOfParmsErr :: Arity -> SDoc-wrongNumberOfParmsErr max_args-  = text "Number of parameters must match family declaration; expected"-    <+> ppr max_args--badRoleAnnot :: Name -> Role -> Role -> SDoc-badRoleAnnot var annot inferred-  = hang (text "Role mismatch on variable" <+> ppr var <> colon)-       2 (sep [ text "Annotation says", ppr annot-              , text "but role", ppr inferred-              , text "is required" ])--wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc-wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))-  = hang (text "Wrong number of roles listed in role annotation;" $$-          text "Expected" <+> (ppr $ length tyvars) <> comma <+>-          text "got" <+> (ppr $ length annots) <> colon)-       2 (ppr d)---illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()-illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))-  = setErrCtxt [] $-    setSrcSpan loc $+{-# LANGUAGE LambdaCase #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | Typecheck type and class declarations+module GHC.Tc.TyCl (+        tcTyAndClassDecls,++        -- Functions used by GHC.Tc.TyCl.Instance to check+        -- data/type family instance declarations+        kcConDecls, tcConDecls, DataDeclInfo(..),+        dataDeclChecks, checkValidTyCon,+        tcFamTyPats, tcTyFamInstEqn,+        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,+        unravelFamInstPats, addConsistencyConstraints,+        wrongKindOfFamily+    ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.Session++import GHC.Hs++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.Utils.Unify( unifyType, emitResidualTvConstraint )+import GHC.Tc.Types.Constraint( emptyWC )+import GHC.Tc.Validity+import GHC.Tc.Utils.Zonk+import GHC.Tc.TyCl.Utils+import GHC.Tc.TyCl.Class+import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )+import GHC.Tc.Deriv (DerivInfo(..))+import GHC.Tc.Gen.HsType+import GHC.Tc.Instance.Class( AssocInstInfo(..) )+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.TcType+import GHC.Tc.Instance.Family+import GHC.Tc.Types.Origin++import GHC.Builtin.Types (oneDataConTy,  unitTy, makeRecoveryTyCon )++import GHC.Rename.Env( lookupConstructorFields )++import GHC.Core.Multiplicity+import GHC.Core.FamInstEnv+import GHC.Core.Coercion+import GHC.Core.Type+import GHC.Core.TyCo.Rep   -- for checkValidRoles+import GHC.Core.TyCo.Ppr( pprTyVars )+import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core.Unify++import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.Unique+import GHC.Types.Basic+import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.List.SetOps++import GHC.Unit++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Control.Monad+import Data.Function ( on )+import Data.Functor.Identity+import Data.List (nubBy, partition)+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.Set as Set+import Data.Tuple( swap )++{-+************************************************************************+*                                                                      *+\subsection{Type checking for type and class declarations}+*                                                                      *+************************************************************************++Note [Grouping of type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly+connected component of mutually dependent types and classes. We kind check and+type check each group separately to enhance kind polymorphism. Take the+following example:++  type Id a = a+  data X = X (Id Int)++If we were to kind check the two declarations together, we would give Id the+kind * -> *, since we apply it to an Int in the definition of X. But we can do+better than that, since Id really is kind polymorphic, and should get kind+forall (k::*). k -> k. Since it does not depend on anything else, it can be+kind-checked by itself, hence getting the most general kind. We then kind check+X, which works fine because we then know the polymorphic kind of Id, and simply+instantiate k to *.++Note [Check role annotations in a second pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Role inference potentially depends on the types of all of the datacons declared+in a mutually recursive group. The validity of a role annotation, in turn,+depends on the result of role inference. Because the types of datacons might+be ill-formed (see #7175 and Note [rejigConRes]) we must check+*all* the tycons in a group for validity before checking *any* of the roles.+Thus, we take two passes over the resulting tycons, first checking for general+validity and then checking for valid role annotations.+-}++tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in+                                            -- dependency order+                  -> TcM ( TcGblEnv         -- Input env extended by types and+                                            -- classes+                                            -- and their implicit Ids,DataCons+                         , [InstInfo GhcRn] -- Source-code instance decls info+                         , [DerivInfo]      -- Deriving info+                         )+-- Fails if there are any errors+tcTyAndClassDecls tyclds_s+  -- The code recovers internally, but if anything gave rise to+  -- an error we'd better stop now, to avoid a cascade+  -- Type check each group in dependency order folding the global env+  = checkNoErrs $ fold_env [] [] tyclds_s+  where+    fold_env :: [InstInfo GhcRn]+             -> [DerivInfo]+             -> [TyClGroup GhcRn]+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+    fold_env inst_info deriv_info []+      = do { gbl_env <- getGblEnv+           ; return (gbl_env, inst_info, deriv_info) }+    fold_env inst_info deriv_info (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+           ; setGblEnv tcg_env $+               -- remaining groups are typechecked in the extended global env.+             fold_env (inst_info' ++ inst_info)+                      (deriv_info' ++ deriv_info)+                      tyclds_s }++tcTyClGroup :: TyClGroup GhcRn+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+-- Typecheck one strongly-connected component of type, class, and instance decls+-- See Note [TyClGroups and dependency analysis] in GHC.Hs.Decls+tcTyClGroup (TyClGroup { group_tyclds = tyclds+                       , group_roles  = roles+                       , group_kisigs = kisigs+                       , group_instds = instds })+  = do { let role_annots = mkRoleAnnotEnv roles++           -- Step 1: Typecheck the standalone kind signatures and type/class declarations+       ; traceTc "---- tcTyClGroup ---- {" empty+       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))+       ; (tyclss, data_deriv_info, kindless) <-+           tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]+           do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs+              ; tcTyClDecls tyclds kisig_env role_annots }++           -- Step 1.5: Make sure we don't have any type synonym cycles+       ; traceTc "Starting synonym cycle check" (ppr tyclss)+       ; home_unit <- hsc_home_unit <$> getTopEnv+       ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds+       ; traceTc "Done synonym cycle check" (ppr tyclss)++           -- Step 2: Perform the validity check on those types/classes+           -- We can do this now because we are done with the recursive knot+           -- Do it before Step 3 (adding implicit things) because the latter+           -- expects well-formed TyCons+       ; traceTc "Starting validity check" (ppr tyclss)+       ; tyclss <- concatMapM checkValidTyCl tyclss+       ; traceTc "Done validity check" (ppr tyclss)+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss+           -- See Note [Check role annotations in a second pass]++       ; traceTc "---- end tcTyClGroup ---- }" empty++           -- Step 3: Add the implicit things;+           -- we want them in the environment because+           -- they may be mentioned in interface files+       ; gbl_env <- addTyConsToGblEnv tyclss++           -- Step 4: check instance declarations+       ; (gbl_env', inst_info, datafam_deriv_info) <-+         setGblEnv gbl_env $+         tcInstDecls1 instds++       ; let deriv_info = datafam_deriv_info ++ data_deriv_info+       ; let gbl_env'' = gbl_env'+                { tcg_ksigs = tcg_ksigs gbl_env' `unionNameSet` kindless }+       ; return (gbl_env'', inst_info, deriv_info) }++-- Gives the kind for every TyCon that has a standalone kind signature+type KindSigEnv = NameEnv Kind++tcTyClDecls+  :: [LTyClDecl GhcRn]+  -> KindSigEnv+  -> RoleAnnotEnv+  -> TcM ([TyCon], [DerivInfo], NameSet)+tcTyClDecls tyclds kisig_env role_annots+  = do {    -- Step 1: kind-check this group and returns the final+            -- (possibly-polymorphic) kind of each TyCon and Class+            -- See Note [Kind checking for type and class decls]+         (tc_tycons, kindless) <- kcTyClGroup kisig_env tyclds+       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))++            -- Step 2: type-check all groups together, returning+            -- the final TyCons and Classes+            --+            -- NB: We have to be careful here to NOT eagerly unfold+            -- type synonyms, as we have not tested for type synonym+            -- loops yet and could fall into a black hole.+       ; fixM $ \ ~(rec_tyclss, _, _) -> do+           { tcg_env <- getGblEnv+                 -- Forced so we don't retain a reference to the TcGblEnv+           ; let !src  = tcg_src tcg_env+                 roles = inferRoles src role_annots rec_tyclss++                 -- Populate environment with knot-tied ATyCon for TyCons+                 -- NB: if the decls mention any ill-staged data cons+                 -- (see Note [Recursion and promoting data constructors])+                 -- we will have failed already in kcTyClGroup, so no worries here+           ; (tycons, data_deriv_infos) <-+             tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $++                 -- Also extend the local type envt with bindings giving+                 -- a TcTyCon for each knot-tied TyCon or Class+                 -- See Note [Type checking recursive type and class declarations]+                 -- and Note [Type environment evolution]+             tcExtendKindEnvWithTyCons tc_tycons $++                 -- Kind and type check declarations for this group+               mapAndUnzipM (tcTyClDecl roles) tyclds+           ; return (tycons, concat data_deriv_infos, kindless)+           } }+  where+    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma+                                  , ppr (tyConBinders tc) <> comma+                                  , ppr (tyConResKind tc)+                                  , ppr (isTcTyCon tc) ])++zipRecTyClss :: [TcTyCon]+             -> [TyCon]           -- Knot-tied+             -> [(Name,TyThing)]+-- Build a name-TyThing mapping for the TyCons bound by decls+-- being careful not to look at the knot-tied [TyThing]+-- The TyThings in the result list must have a visible ATyCon,+-- because typechecking types (in, say, tcTyClDecl) looks at+-- this outer constructor+zipRecTyClss tc_tycons rec_tycons+  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]+  where+    rec_tc_env :: NameEnv TyCon+    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons++    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)++    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_one_tc tc env = extendNameEnv env (tyConName tc) tc++    get name = case lookupNameEnv rec_tc_env name of+                 Just tc -> tc+                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)++{-+************************************************************************+*                                                                      *+                Kind checking+*                                                                      *+************************************************************************++Note [Kind checking for type and class decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind checking is done thus:++   1. Make up a kind variable for each parameter of the declarations,+      and extend the kind environment (which is in the TcLclEnv)++   2. Kind check the declarations++We need to kind check all types in the mutually recursive group+before we know the kind of the type variables.  For example:++  class C a where+     op :: D b => a -> b -> b++  class D c where+     bop :: (Monad c) => ...++Here, the kind of the locally-polymorphic type variable "b"+depends on *all the uses of class D*.  For example, the use of+Monad c in bop's type signature means that D must have kind Type->Type.++Note: we don't treat type synonyms specially (we used to, in the past);+in particular, even if we have a type synonym cycle, we still kind check+it normally, and test for cycles later (checkSynCycles).  The reason+we can get away with this is because we have more systematic TYPE r+inference, which means that we can do unification between kinds that+aren't lifted (this historically was not true.)++The downside of not directly reading off the kinds of the RHS of+type synonyms in topological order is that we don't transparently+support making synonyms of types with higher-rank kinds.  But+you can always specify a CUSK directly to make this work out.+See tc269 for an example.++Note [CUSKs and PolyKinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++    data T (a :: *) = MkT (S a)   -- Has CUSK+    data S a = MkS (T Int) (S a)  -- No CUSK++Via inferInitialKinds we get+  T :: * -> *+  S :: kappa -> *++Then we call kcTyClDecl on each decl in the group, to constrain the+kind unification variables.  BUT we /skip/ the RHS of any decl with+a CUSK.  Here we skip the RHS of T, so we eventually get+  S :: forall k. k -> *++This gets us more polymorphism than we would otherwise get, similar+(but implemented strangely differently from) the treatment of type+signatures in value declarations.++However, we only want to do so when we have PolyKinds.+When we have NoPolyKinds, we don't skip those decls, because we have defaulting+(#16609). Skipping won't bring us more polymorphism when we have defaulting.+Consider++  data T1 a = MkT1 T2        -- No CUSK+  data T2 = MkT2 (T1 Maybe)  -- Has CUSK++If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.+With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the+program type-checks.+But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens+in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking+(T1 Maybe) will throw a type error.++Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.++Open type families+~~~~~~~~~~~~~~~~~~+This treatment of type synonyms only applies to Haskell 98-style synonyms.+General type functions can be recursive, and hence, appear in `alg_decls'.++The kind of an open type family is solely determinded by its kind signature;+hence, only kind signatures participate in the construction of the initial+kind environment (as constructed by `inferInitialKind'). In fact, we ignore+instances of families altogether in the following. However, we need to include+the kinds of *associated* families into the construction of the initial kind+environment. (This is handled by `allDecls').++See also Note [Kind checking recursive type and class declarations]++Note [How TcTyCons work]+~~~~~~~~~~~~~~~~~~~~~~~~+TcTyCons are used for two distinct purposes++1.  When recovering from a type error in a type declaration,+    we want to put the erroneous TyCon in the environment in a+    way that won't lead to more errors.  We use a TcTyCon for this;+    see makeRecoveryTyCon.++2.  When checking a type/class declaration (in module GHC.Tc.TyCl), we come+    upon knowledge of the eventual tycon in bits and pieces.++      S1) First, we use inferInitialKinds to look over the user-provided+          kind signature of a tycon (including, for example, the number+          of parameters written to the tycon) to get an initial shape of+          the tycon's kind.  We record that shape in a TcTyCon.++          For CUSK tycons, the TcTyCon has the final, generalised kind.+          For non-CUSK tycons, the TcTyCon has as its tyConBinders only+          the explicit arguments given -- no kind variables, etc.++      S2) Then, using these initial kinds, we kind-check the body of the+          tycon (class methods, data constructors, etc.), filling in the+          metavariables in the tycon's initial kind.++      S3) We then generalize to get the (non-CUSK) tycon's final, fixed+          kind. Finally, once this has happened for all tycons in a+          mutually recursive group, we can desugar the lot.++    For convenience, we store partially-known tycons in TcTyCons, which+    might store meta-variables. These TcTyCons are stored in the local+    environment in GHC.Tc.TyCl, until the real full TyCons can be created+    during desugaring. A desugared program should never have a TcTyCon.++3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).++4.  tyConScopedTyVars.  A challenging piece in all of this is that we+    end up taking three separate passes over every declaration:+      - one in inferInitialKind (this pass look only at the head, not the body)+      - one in kcTyClDecls (to kind-check the body)+      - a final one in tcTyClDecls (to desugar)++    In the latter two passes, we need to connect the user-written type+    variables in an LHsQTyVars with the variables in the tycon's+    inferred kind. Because the tycon might not have a CUSK, this+    matching up is, in general, quite hard to do.  (Look through the+    git history between Dec 2015 and Apr 2016 for+    GHC.Tc.Gen.HsType.splitTelescopeTvs!)++    Instead of trying, we just store the list of type variables to+    bring into scope, in the tyConScopedTyVars field of the TcTyCon.+    These tyvars are brought into scope in GHC.Tc.Gen.HsType.bindTyClTyVars.++    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather+    than just [TcTyVar]?  Consider these mutually-recursive decls+       data T (a :: k1) b = MkT (S a b)+       data S (c :: k2) d = MkS (T c d)+    We start with k1 bound to kappa1, and k2 to kappa2; so initially+    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But+    then kappa1 and kappa2 get unified; so after the zonking in+    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.++See also Note [Type checking recursive type and class declarations].++Note [Swizzling the tyvars before generaliseTcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note only applies when /inferring/ the kind of a TyCon.+If there is a separate kind signature, or a CUSK, we take an entirely+different code path.++For inference, consider+   class C (f :: k) x where+      type T f+      op :: D f => blah+   class D (g :: j) y where+      op :: C g => y -> blah++Here C and D are considered mutually recursive.  Neither has a CUSK.+Just before generalisation we have the (un-quantified) kinds+   C :: k1 -> k2 -> Constraint+   T :: k1 -> Type+   D :: k1 -> Type -> Constraint+Notice that f's kind and g's kind have been unified to 'k1'. We say+that k1 is the "representative" of k in C's decl, and of j in D's decl.++Now when quantifying, we'd like to end up with+   C :: forall {k2}. forall k. k -> k2 -> Constraint+   T :: forall k. k -> Type+   D :: forall j. j -> Type -> Constraint++That is, we want to swizzle the representative to have the Name given+by the user. Partly this is to improve error messages and the output of+:info in GHCi.  But it is /also/ important because the code for a+default method may mention the class variable(s), but at that point+(tcClassDecl2), we only have the final class tyvars available.+(Alternatively, we could record the scoped type variables in the+TyCon, but it's a nuisance to do so.)++Notes:++* On the input to generaliseTyClDecl, the mapping between the+  user-specified Name and the representative TyVar is recorded in the+  tyConScopedTyVars of the TcTyCon.  NB: you first need to zonk to see+  this representative TyVar.++* The swizzling is actually performed by swizzleTcTyConBndrs++* We must do the swizzling across the whole class decl. Consider+     class C f where+       type S (f :: k)+       type T f+  Here f's kind k is a parameter of C, and its identity is shared+  with S and T.  So if we swizzle the representative k at all, we+  must do so consistently for the entire declaration.++  Hence the call to check_duplicate_tc_binders is in generaliseTyClDecl,+  rather than in generaliseTcTyCon.++There are errors to catch here.  Suppose we had+   class E (f :: j) (g :: k) where+     op :: SameKind f g -> blah++Then, just before generalisation we will have the (unquantified)+   E :: k1 -> k1 -> Constraint++That's bad!  Two distinctly-named tyvars (j and k) have ended up with+the same representative k1.  So when swizzling, we check (in+check_duplicate_tc_binders) that two distinct source names map+to the same representative.++Here's an interesting case:+    class C1 f where+      type S (f :: k1)+      type T (f :: k2)+Here k1 and k2 are different Names, but they end up mapped to the+same representative TyVar.  To make the swizzling consistent (remember+we must have a single k across C1, S and T) we reject the program.++Another interesting case+    class C2 f where+      type S (f :: k) (p::Type)+      type T (f :: k) (p::Type->Type)++Here the two k's (and the two p's) get distinct Uniques, because they+are seen by the renamer as locally bound in S and T resp.  But again+the two (distinct) k's end up bound to the same representative TyVar.+You might argue that this should be accepted, but it's definitely+rejected (via an entirely different code path) if you add a kind sig:+    type C2' :: j -> Constraint+    class C2' f where+      type S (f :: k) (p::Type)+We get+    • Expected kind ‘j’, but ‘f’ has kind ‘k’+    • In the associated type family declaration for ‘S’++So we reject C2 too, even without the kind signature.  We have+to do a bit of work to get a good error message, since both k's+look the same to the user.++Another case+    class C3 (f :: k1) where+      type S (f :: k2)++This will be rejected too.+++Note [Type environment evolution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As we typecheck a group of declarations the type environment evolves.+Consider for example:+  data B (a :: Type) = MkB (Proxy 'MkB)++We do the following steps:++  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the+     type env with promotion errors+            B   :-> TyConPE+            MkB :-> DataConPE++  2. kcTyCLGroup+      - Do inferInitialKinds, which will signal a promotion+        error if B is used in any of the kinds needed to initialise+        B's kind (e.g. (a :: Type)) here++      - Extend the type env with these initial kinds (monomorphic for+        decls that lack a CUSK)+            B :-> TcTyCon <initial kind>+        (thereby overriding the B :-> TyConPE binding)+        and do kcLTyClDecl on each decl to get equality constraints on+        all those initial kinds++      - Generalise the initial kind, making a poly-kinded TcTyCon++  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded+     TcTyCons, again overriding the promotion-error bindings.++     But note that the data constructor promotion errors are still in place+     so that (in our example) a use of MkB will still be signalled as+     an error.++  4. Typecheck the decls.++  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons+++Note [Missed opportunity to retain higher-rank kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'kcTyClGroup', there is a missed opportunity to make kind+inference work in a few more cases.  The idea is analogous+to Note [Single function non-recursive binding special-case]:++     * If we have an SCC with a single decl, which is non-recursive,+       instead of creating a unification variable representing the+       kind of the decl and unifying it with the rhs, we can just+       read the type directly of the rhs.++     * Furthermore, we can update our SCC analysis to ignore+       dependencies on declarations which have CUSKs: we don't+       have to kind-check these all at once, since we can use+       the CUSK to initialize the kind environment.++Unfortunately this requires reworking a bit of the code in+'kcLTyClDecl' so I've decided to punt unless someone shouts about it.++Note [Don't process associated types in getInitialKind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously, we processed associated types in the thing_inside in getInitialKind,+but this was wrong -- we want to do ATs sepearately.+The consequence for not doing it this way is #15142:++  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where+    type ListToTuple as :: Type++We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify+kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring+`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't+unified with Type. And then, when we generalize the kind of ListToTuple (which+indeed has a CUSK, according to the rules), we skolemize the free metavariable+kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,+because the solveEqualities in kcInferDeclHeader is at TcLevel 1 and so kappa[1]+will unify with Type.++Bottom line: as associated types should have no effect on a CUSK enclosing class,+we move processing them to a separate action, run after the outer kind has+been generalized.++-}++kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([TcTyCon], NameSet)++-- Kind check this group, kind generalize, and return the resulting local env+-- This binds the TyCons and Classes of the group, but not the DataCons+-- See Note [Kind checking for type and class decls]+-- and Note [Inferring kinds for type declarations]+--+-- The NameSet returned contains kindless tycon names, without CUSK or SAKS.+kcTyClGroup kisig_env decls+  = do  { mod <- getModule+        ; traceTc "---- kcTyClGroup ---- {"+                  (text "module" <+> ppr mod $$ vcat (map ppr decls))++          -- Kind checking;+          --    1. Bind kind variables for decls+          --    2. Kind-check decls+          --    3. Generalise the inferred kinds+          -- See Note [Kind checking for type and class decls]++        ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds+                    -- See Note [CUSKs and PolyKinds]+        ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls+              kindless_names = mkNameSet $ map get_name kindless_decls++              get_name d = tcdName (unLoc d)++              get_kind d+                | Just ki <- lookupNameEnv kisig_env (get_name d)+                = Right (d, SAKS ki)++                | cusks_enabled && hsDeclHasCusk (unLoc d)+                = Right (d, CUSK)++                | otherwise = Left d++        ; 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  $+               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++                  ; traceTc "kcTyClGroup: initial kinds" $+                    ppr_tc_kinds mono_tcs++                    -- Step 2: Set extended envt, kind-check the decls+                    -- NB: the environment extension overrides the tycon+                    --     promotion-errors bindings+                    --     See Note [Type environment evolution]+                  ; checkNoErrs $+                    tcExtendKindEnvWithTyCons mono_tcs $+                    mapM_ kcLTyClDecl kindless_decls++                  ; return mono_tcs }++        -- Step 3: generalisation+        -- Finally, go through each tycon and give it its final kind,+        -- with all the required, specified, and inferred variables+        -- in order.+        ; let inferred_tc_env = mkNameEnv $+                                map (\tc -> (tyConName tc, tc)) inferred_tcs+        ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)+                                        kindless_decls++        ; let poly_tcs = checked_tcs ++ generalized_tcs+        ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)+        ; return (poly_tcs, kindless_names) }+  where+    ppr_tc_kinds tcs = vcat (map pp_tc tcs)+    pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)++type ScopedPairs = [(Name, TcTyVar)]+  -- The ScopedPairs for a TcTyCon are precisely+  --    specified-tvs ++ required-tvs+  -- You can distinguish them because there are tyConArity required-tvs++generaliseTyClDecl :: NameEnv TcTyCon -> LTyClDecl GhcRn -> TcM [TcTyCon]+-- See Note [Swizzling the tyvars before generaliseTcTyCon]+generaliseTyClDecl inferred_tc_env (L _ decl)+  = do { let names_in_this_decl :: [Name]+             names_in_this_decl = tycld_names decl++       -- Extract the specified/required binders and skolemise them+       ; tc_with_tvs  <- mapM skolemise_tc_tycon names_in_this_decl++       -- Zonk, to manifest the side-effects of skolemisation to the swizzler+       -- NB: it's important to skolemise them all before this step. E.g.+       --         class C f where { type T (f :: k) }+       --     We only skolemise k when looking at T's binders,+       --     but k appears in f's kind in C's binders.+       ; tc_infos <- mapM zonk_tc_tycon tc_with_tvs++       -- Swizzle+       ; swizzled_infos <- tcAddDeclCtxt decl (swizzleTcTyConBndrs tc_infos)++       -- And finally generalise+       ; mapAndReportM generaliseTcTyCon swizzled_infos }+  where+    tycld_names :: TyClDecl GhcRn -> [Name]+    tycld_names decl = tcdName decl : at_names decl++    at_names :: TyClDecl GhcRn -> [Name]+    at_names (ClassDecl { tcdATs = ats }) = map (familyDeclName . unLoc) ats+    at_names _ = []  -- Only class decls have associated types++    skolemise_tc_tycon :: Name -> TcM (TcTyCon, ScopedPairs)+    -- Zonk and skolemise the Specified and Required binders+    skolemise_tc_tycon tc_name+      = do { let tc = lookupNameEnv_NF inferred_tc_env tc_name+                      -- This lookup should not fail+           ; scoped_prs <- mapSndM zonkAndSkolemise (tcTyConScopedTyVars tc)+           ; return (tc, scoped_prs) }++    zonk_tc_tycon :: (TcTyCon, ScopedPairs) -> TcM (TcTyCon, ScopedPairs, TcKind)+    zonk_tc_tycon (tc, scoped_prs)+      = do { scoped_prs <- mapSndM zonkTcTyVarToTyVar scoped_prs+                           -- We really have to do this again, even though+                           -- we have just done zonkAndSkolemise+           ; res_kind   <- zonkTcType (tyConResKind tc)+           ; return (tc, scoped_prs, res_kind) }++swizzleTcTyConBndrs :: [(TcTyCon, ScopedPairs, TcKind)]+                -> TcM [(TcTyCon, ScopedPairs, TcKind)]+swizzleTcTyConBndrs tc_infos+  | all no_swizzle swizzle_prs+    -- This fast path happens almost all the time+    -- See Note [Cloning for type variable binders] in GHC.Tc.Gen.HsType+    -- "Almost all the time" means not the case of mutual recursion with+    -- polymorphic kinds.+  = do { traceTc "Skipping swizzleTcTyConBndrs for" (ppr (map fstOf3 tc_infos))+       ; return tc_infos }++  | otherwise+  = do { check_duplicate_tc_binders++       ; traceTc "swizzleTcTyConBndrs" $+         vcat [ text "before" <+> ppr_infos tc_infos+              , text "swizzle_prs" <+> ppr swizzle_prs+              , text "after" <+> ppr_infos swizzled_infos ]++       ; return swizzled_infos }++  where+    swizzled_infos =  [ (tc, mapSnd swizzle_var scoped_prs, swizzle_ty kind)+                      | (tc, scoped_prs, kind) <- tc_infos ]++    swizzle_prs :: [(Name,TyVar)]+    -- Pairs the user-specified Name with its representative TyVar+    -- See Note [Swizzling the tyvars before generaliseTcTyCon]+    swizzle_prs = [ pr | (_, prs, _) <- tc_infos, pr <- prs ]++    no_swizzle :: (Name,TyVar) -> Bool+    no_swizzle (nm, tv) = nm == tyVarName tv++    ppr_infos infos = vcat [ ppr tc <+> pprTyVars (map snd prs)+                           | (tc, prs, _) <- infos ]++    -- Check for duplicates+    -- E.g. data SameKind (a::k) (b::k)+    --      data T (a::k1) (b::k2) = MkT (SameKind a b)+    -- Here k1 and k2 start as TyVarTvs, and get unified with each other+    -- If this happens, things get very confused later, so fail fast+    check_duplicate_tc_binders :: TcM ()+    check_duplicate_tc_binders = unless (null err_prs) $+                                 do { mapM_ report_dup err_prs; failM }++    -------------- Error reporting ------------+    err_prs :: [(Name,Name)]+    err_prs = [ (n1,n2)+              | pr :| prs <- findDupsEq ((==) `on` snd) swizzle_prs+              , (n1,_):(n2,_):_ <- [nubBy ((==) `on` fst) (pr:prs)] ]+              -- This nubBy avoids bogus error reports when we have+              --    [("f", f), ..., ("f",f)....] in swizzle_prs+              -- which happens with  class C f where { type T f }++    report_dup :: (Name,Name) -> TcM ()+    report_dup (n1,n2)+      = setSrcSpan (getSrcSpan n2) $ addErrTc $+        hang (text "Different names for the same type variable:") 2 info+      where+        info | nameOccName n1 /= nameOccName n2+             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)+             | otherwise -- Same OccNames! See C2 in+                         -- Note [Swizzling the tyvars before generaliseTcTyCon]+             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)+                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]++    -------------- The swizzler ------------+    -- This does a deep traverse, simply doing a+    -- Name-to-Name change, governed by swizzle_env+    -- The 'swap' is what gets from the representative TyVar+    -- back to the original user-specified Name+    swizzle_env = mkVarEnv (map swap swizzle_prs)++    swizzleMapper :: TyCoMapper () Identity+    swizzleMapper = TyCoMapper { tcm_tyvar = swizzle_tv+                               , tcm_covar = swizzle_cv+                               , tcm_hole  = swizzle_hole+                               , tcm_tycobinder = swizzle_bndr+                               , tcm_tycon      = swizzle_tycon }+    swizzle_hole  _ hole = pprPanic "swizzle_hole" (ppr hole)+       -- These types are pre-zonked+    swizzle_tycon tc = pprPanic "swizzle_tc" (ppr tc)+       -- TcTyCons can't appear in kinds (yet)+    swizzle_tv _ tv = return (mkTyVarTy (swizzle_var tv))+    swizzle_cv _ cv = return (mkCoVarCo (swizzle_var cv))++    swizzle_bndr _ tcv _+      = return ((), swizzle_var tcv)++    swizzle_var :: Var -> Var+    swizzle_var v+      | Just nm <- lookupVarEnv swizzle_env v+      = updateVarType swizzle_ty (v `setVarName` nm)+      | otherwise+      = updateVarType swizzle_ty v++    (map_type, _, _, _) = mapTyCo swizzleMapper+    swizzle_ty ty = runIdentity (map_type ty)+++generaliseTcTyCon :: (TcTyCon, ScopedPairs, TcKind) -> TcM TcTyCon+generaliseTcTyCon (tc, scoped_prs, tc_res_kind)+  -- See Note [Required, Specified, and Inferred for types]+  = setSrcSpan (getSrcSpan tc) $+    addTyConCtxt tc $+    do { -- Step 1: Separate Specified from Required variables+         -- NB: spec_req_tvs = spec_tvs ++ req_tvs+         --     And req_tvs is 1-1 with tyConTyVars+         --     See Note [Scoped tyvars in a TcTyCon] in GHC.Core.TyCon+       ; let spec_req_tvs        = map snd scoped_prs+             n_spec              = length spec_req_tvs - tyConArity tc+             (spec_tvs, req_tvs) = splitAt n_spec spec_req_tvs+             sorted_spec_tvs     = scopedSort spec_tvs+                 -- NB: We can't do the sort until we've zonked+                 --     Maintain the L-R order of scoped_tvs++       -- Step 2a: find all the Inferred variables we want to quantify over+       ; dvs1 <- candidateQTyVarsOfKinds $+                 (tc_res_kind : map tyVarKind spec_req_tvs)+       ; let dvs2 = dvs1 `delCandidates` spec_req_tvs++       -- Step 2b: quantify, mainly meaning skolemise the free variables+       -- Returned 'inferred' are scope-sorted and skolemised+       ; inferred <- quantifyTyVars dvs2++       ; traceTc "generaliseTcTyCon: pre zonk"+           (vcat [ text "tycon =" <+> ppr tc+                 , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs+                 , text "tc_res_kind =" <+> ppr tc_res_kind+                 , text "dvs1 =" <+> ppr dvs1+                 , text "inferred =" <+> pprTyVars inferred ])++       -- Step 3: Final zonk (following kind generalisation)+       -- See Note [Swizzling the tyvars before generaliseTcTyCon]+       ; ze <- mkEmptyZonkEnv NoFlexi+       ; (ze, inferred)        <- zonkTyBndrsX      ze inferred+       ; (ze, sorted_spec_tvs) <- zonkTyBndrsX      ze sorted_spec_tvs+       ; (ze, req_tvs)         <- zonkTyBndrsX      ze req_tvs+       ; tc_res_kind           <- zonkTcTypeToTypeX ze tc_res_kind++       ; traceTc "generaliseTcTyCon: post zonk" $+         vcat [ text "tycon =" <+> ppr tc+              , text "inferred =" <+> pprTyVars inferred+              , text "spec_req_tvs =" <+> pprTyVars spec_req_tvs+              , text "sorted_spec_tvs =" <+> pprTyVars sorted_spec_tvs+              , text "req_tvs =" <+> ppr req_tvs+              , text "zonk-env =" <+> ppr ze ]++       -- Step 4: Make the TyConBinders.+       ; let dep_fv_set     = candidateKindVars dvs1+             inferred_tcbs  = mkNamedTyConBinders Inferred inferred+             specified_tcbs = mkNamedTyConBinders Specified sorted_spec_tvs+             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs++       -- Step 5: Assemble the final list.+             final_tcbs = concat [ inferred_tcbs+                                 , specified_tcbs+                                 , required_tcbs ]++       -- Step 6: Make the result TcTyCon+             tycon = mkTcTyCon (tyConName tc) final_tcbs tc_res_kind+                            (mkTyVarNamePairs (sorted_spec_tvs ++ req_tvs))+                            True {- it's generalised now -}+                            (tyConFlavour tc)++       ; traceTc "generaliseTcTyCon done" $+         vcat [ text "tycon =" <+> ppr tc+              , text "tc_res_kind =" <+> ppr tc_res_kind+              , text "dep_fv_set =" <+> ppr dep_fv_set+              , text "inferred_tcbs =" <+> ppr inferred_tcbs+              , text "specified_tcbs =" <+> ppr specified_tcbs+              , text "required_tcbs =" <+> ppr required_tcbs+              , text "final_tcbs =" <+> ppr final_tcbs ]++       -- Step 7: Check for validity.+       -- We do this here because we're about to put the tycon into the+       -- the environment, and we don't want anything malformed there+       ; checkTyConTelescope tycon++       ; return tycon }++{- Note [Required, Specified, and Inferred for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each forall'd type variable in a type or kind is one of++  * Required: an argument must be provided at every call site++  * Specified: the argument can be inferred at call sites, but+    may be instantiated with visible type/kind application++  * Inferred: the argument must be inferred at call sites; it+    is unavailable for use with visible type/kind application.++Why have Inferred at all? Because we just can't make user-facing+promises about the ordering of some variables. These might swizzle+around even between minor released. By forbidding visible type+application, we ensure users aren't caught unawares.++Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep.++The question for this Note is this:+   given a TyClDecl, how are its quantified type variables classified?+Much of the debate is memorialized in #15743.++Here is our design choice. When inferring the ordering of variables+for a TyCl declaration (that is, for those variables that the user+has not specified the order with an explicit `forall`), we use the+following order:++ 1. Inferred variables+ 2. Specified variables; in the left-to-right order in which+    the user wrote them, modified by scopedSort (see below)+    to put them in depdendency order.+ 3. Required variables before a top-level ::+ 4. All variables after a top-level ::++If this ordering does not make a valid telescope, we reject the definition.++Example:+  data SameKind :: k -> k -> *+  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)++For Bad:+  - a, c, d, x are Required; they are explicitly listed by the user+    as the positional arguments of Bad+  - b is Specified; it appears explicitly in a kind signature+  - k, the kind of a, is Inferred; it is not mentioned explicitly at all++Putting variables in the order Inferred, Specified, Required+gives us this telescope:+  Inferred:  k+  Specified: b : Proxy a+  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)++But this order is ill-scoped, because b's kind mentions a, which occurs+after b in the telescope. So we reject Bad.++Associated types+~~~~~~~~~~~~~~~~+For associated types everything above is determined by the+associated-type declaration alone, ignoring the class header.+Here is an example (#15592)+  class C (a :: k) b where+    type F (x :: b a)++In the kind of C, 'k' is Specified.  But what about F?+In the kind of F,++ * Should k be Inferred or Specified?  It's Specified for C,+   but not mentioned in F's declaration.++ * In which order should the Specified variables a and b occur?+   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering+   in F's declaration is 'b' then 'a'.++In both cases we make the choice by looking at F's declaration alone,+so it gets the kind+   F :: forall {k}. forall b a. b a -> Type++How it works+~~~~~~~~~~~~+These design choices are implemented by two completely different code+paths for++  * Declarations with a standalone kind signature or a complete user-specified+    kind signature (CUSK). Handled by the kcCheckDeclHeader.++  * Declarations without a kind signature (standalone or CUSK) are handled by+    kcInferDeclHeader; see Note [Inferring kinds for type declarations].++Note that neither code path worries about point (4) above, as this+is nicely handled by not mangling the res_kind. (Mangling res_kinds is done+*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)++We can tell Inferred apart from Specified by looking at the scoped+tyvars; Specified are always included there.++Design alternatives+~~~~~~~~~~~~~~~~~~~+* For associated types we considered putting the class variables+  before the local variables, in a nod to the treatment for class+  methods. But it got too compilicated; see #15592, comment:21ff.++* We rigidly require the ordering above, even though we could be much more+  permissive. Relevant musings are at+  https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623+  The bottom line conclusion is that, if the user wants a different ordering,+  then can specify it themselves, and it is better to be predictable and dumb+  than clever and capricious.++  I (Richard) conjecture we could be fully permissive, allowing all classes+  of variables to intermix. We would have to augment ScopedSort to refuse to+  reorder Required variables (or check that it wouldn't have). But this would+  allow more programs. See #15743 for examples. Interestingly, Idris seems+  to allow this intermixing. The intermixing would be fully specified, in that+  we can be sure that inference wouldn't change between versions. However,+  would users be able to predict it? That I cannot answer.++Test cases (and tickets) relevant to these design decisions+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  T15591*+  T15592*+  T15743*++Note [Inferring kinds for type declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note deals with /inference/ for type declarations+that do not have a CUSK.  Consider+  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)+  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)++We do kind inference as follows:++* Step 1: inferInitialKinds, and in particular kcInferDeclHeader.+  Make a unification variable for each of the Required and Specified+  type variables in the header.++  Record the connection between the Names the user wrote and the+  fresh unification variables in the tcTyConScopedTyVars field+  of the TcTyCon we are making+      [ (a,  aa)+      , (k1, kk1)+      , (k2, kk2)+      , (x,  xx) ]+  (I'm using the convention that double letter like 'aa' or 'kk'+  mean a unification variable.)++  These unification variables+    - Are TyVarTvs: that is, unification variables that can+      unify only with other type variables.+      See Note [TyVarTv] in GHC.Tc.Utils.TcMType++    - Have complete fresh Names; see GHC.Tc.Utils.TcMType+      Note [Unification variables need fresh Names]++  Assign initial monomorphic kinds to S, T+          T :: kk1 -> * -> kk2 -> *+          S :: kk3 -> * -> kk4 -> *++* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and+  T, with these monomorphic kinds.  Now kind-check the declarations,+  and solve the resulting equalities.  The goal here is to discover+  constraints on all these unification variables.++  Here we find that kk1 := kk3, and kk2 := kk4.++  This is why we can't use skolems for kk1 etc; they have to+  unify with each other.++* Step 3: generaliseTcTyCon. Generalise each TyCon in turn.+  We find the free variables of the kind, skolemise them,+  sort them out into Inferred/Required/Specified (see the above+  Note [Required, Specified, and Inferred for types]),+  and perform some validity checks.++  This makes the utterly-final TyConBinders for the TyCon.++  All this is very similar at the level of terms: see GHC.Tc.Gen.Bind+  Note [Quantified variables in partial type signatures]++  But there are some tricky corners: Note [Tricky scoping in generaliseTcTyCon]++* Step 4.  Extend the type environment with a TcTyCon for S and T, now+  with their utterly-final polymorphic kinds (needed for recursive+  occurrences of S, T).  Now typecheck the declarations, and build the+  final AlgTyCon for S and T resp.++The first three steps are in kcTyClGroup; the fourth is in+tcTyClDecls.++There are some wrinkles++* Do not default TyVarTvs.  We always want to kind-generalise over+  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is+  not allowed to unify with a type; it must stand for a type+  variable. Hence the check in GHC.Tc.Solver.defaultTyVarTcS, and+  GHC.Tc.Utils.TcMType.defaultTyVar.  Here's another example (#14555):+     data Exp :: [TYPE rep] -> TYPE rep -> Type where+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)+  We want to kind-generalise over the 'rep' variable.+  #14563 is another example.++* Duplicate type variables. Consider #11203+    data SameKind :: k -> k -> *+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)+  Here we will unify k1 with k2, but this time doing so is an error,+  because k1 and k2 are bound in the same declaration.++  We spot this during validity checking (findDupTyVarTvs),+  in generaliseTcTyCon.++* Required arguments.  Even the Required arguments should be made+  into TyVarTvs, not skolems.  Consider+    data T k (a :: k)+  Here, k is a Required, dependent variable. For uniformity, it is helpful+  to have k be a TyVarTv, in parallel with other dependent variables.++* Duplicate skolemisation is expected.  When generalising in Step 3,+  we may find that one of the variables we want to quantify has+  already been skolemised.  For example, suppose we have already+  generalise S. When we come to T we'll find that kk1 (now the same as+  kk3) has already been skolemised.++  That's fine -- but it means that+    a) when collecting quantification candidates, in+       candidateQTyVarsOfKind, we must collect skolems+    b) quantifyTyVars should be a no-op on such a skolem++Note [Tricky scoping in generaliseTcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider #16342+  class C (a::ka) x where+    cop :: D a x => x -> Proxy a -> Proxy a+    cop _ x = x :: Proxy (a::ka)++  class D (b::kb) y where+    dop :: C b y => y -> Proxy b -> Proxy b+    dop _ x = x :: Proxy (b::kb)++C and D are mutually recursive, by the time we get to+generaliseTcTyCon we'll have unified kka := kkb.++But when typechecking the default declarations for 'cop' and 'dop' in+tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.+But at that point all we have is the utterly-final Class itself.++Conclusion: the classTyVars of a class must have the same Name as+that originally assigned by the user.  In our example, C must have+classTyVars {a, ka, x} while D has classTyVars {a, kb, y}.  Despite+the fact that kka and kkb got unified!++We achieve this sleight of hand in generaliseTcTyCon, using+the specialised function zonkRecTyVarBndrs.  We make the call+   zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx]+where the [ka,a,x] are the Names originally assigned by the user, and+[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars.+zonkRecTyVarBndrs builds a recursive ZonkEnv that binds+   kkb :-> (ka :: <zonked kind of kkb>)+   aa  :-> (a  :: <konked kind of aa>)+   etc+That is, it maps each skolemised TcTyVars to the utterly-final+TyVar to put in the class, with its correct user-specified name.+When generalising D we'll do the same thing, but the ZonkEnv will map+   kkb :-> (kb :: <zonked kind of kkb>)+   bb  :-> (b  :: <konked kind of bb>)+   etc+Note that 'kkb' again appears in the domain of the mapping, but this+time mapped to 'kb'.  That's how C and D end up with differently-named+final TyVars despite the fact that we unified kka:=kkb++zonkRecTyVarBndrs we need to do knot-tying because of the need to+apply this same substitution to the kind of each.++Note [Inferring visible dependent quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data T k :: k -> Type where+    MkT1 :: T Type Int+    MkT2 :: T (Type -> Type) Maybe++This looks like it should work. However, it is polymorphically recursive,+as the uses of T in the constructor types specialize the k in the kind+of T. This trips up our dear users (#17131, #17541), and so we add+a "landmark" context (which cannot be suppressed) whenever we+spot inferred visible dependent quantification (VDQ).++It's hard to know when we've actually been tripped up by polymorphic recursion+specifically, so we just include a note to users whenever we infer VDQ. The+testsuite did not show up a single spurious inclusion of this message.++The context is added in addVDQNote, which looks for a visible TyConBinder+that also appears in the TyCon's kind. (I first looked at the kind for+a visible, dependent quantifier, but Note [No polymorphic recursion] in+GHC.Tc.Gen.HsType defeats that approach.) addVDQNote is used in kcTyClDecl,+which is used only when inferring the kind of a tycon (never with a CUSK or+SAK).++Once upon a time, I (Richard E) thought that the tycon-kind could+not be a forall-type. But this is wrong: data T :: forall k. k -> Type+(with -XNoCUSKs) could end up here. And this is all OK.+++-}++--------------+tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a+tcExtendKindEnvWithTyCons tcs+  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]++--------------+mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv+-- Maps each tycon/datacon to a suitable promotion error+--    tc :-> APromotionErr TyConPE+--    dc :-> APromotionErr RecDataConPE+--    See Note [Recursion and promoting data constructors]++mkPromotionErrorEnv decls+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)+          emptyNameEnv decls++mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })+  = unitNameEnv nm (APromotionErr ClassPE)+    `plusNameEnv`+    mkNameEnv [ (familyDeclName at, APromotionErr TyConPE)+              | L _ at <- ats ]++mk_prom_err_env (DataDecl { tcdLName = L _ name+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })+  = unitNameEnv name (APromotionErr TyConPE)+    `plusNameEnv`+    mkNameEnv [ (con, APromotionErr RecDataConPE)+              | L _ con' <- cons+              , L _ con  <- getConNames con' ]++mk_prom_err_env decl+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)+    -- Works for family declarations too++--------------+inferInitialKinds :: [LTyClDecl GhcRn] -> TcM [TcTyCon]+-- Returns a TcTyCon for each TyCon bound by the decls,+-- each with its initial kind++inferInitialKinds decls+  = do { traceTc "inferInitialKinds {" $ ppr (map (tcdName . unLoc) decls)+       ; tcs <- concatMapM infer_initial_kind decls+       ; traceTc "inferInitialKinds done }" empty+       ; return tcs }+  where+    infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)++-- Check type/class declarations against their standalone kind signatures or+-- CUSKs, producing a generalized TcTyCon for each.+checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [TcTyCon]+checkInitialKinds decls+  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)+       ; tcs <- concatMapM check_initial_kind decls+       ; traceTc "checkInitialKinds done }" empty+       ; return tcs }+  where+    check_initial_kind (ldecl, msig) =+      addLocMA (getInitialKind (InitialKindCheck msig)) ldecl++-- | Get the initial kind of a TyClDecl, either generalized or non-generalized,+-- depending on the 'InitialKindStrategy'.+getInitialKind :: InitialKindStrategy -> TyClDecl GhcRn -> TcM [TcTyCon]++-- Allocate a fresh kind variable for each TyCon and Class+-- For each tycon, return a TcTyCon with kind k+-- where k is the kind of tc, derived from the LHS+--         of the definition (and probably including+--         kind unification variables)+--      Example: data T a b = ...+--      return (T, kv1 -> kv2 -> kv3)+--+-- This pass deals with (ie incorporates into the kind it produces)+--   * The kind signatures on type-variable binders+--   * The result kinds signature on a TyClDecl+--+-- No family instances are passed to checkInitialKinds/inferInitialKinds+getInitialKind strategy+    (ClassDecl { tcdLName = L _ name+               , tcdTyVars = ktvs+               , tcdATs = ats })+  = do { cls <- kcDeclHeader strategy name ClassFlavour ktvs $+                return (TheKind constraintKind)+       ; let parent_tv_prs = tcTyConScopedTyVars cls+            -- See Note [Don't process associated types in getInitialKind]+       ; inner_tcs <-+           tcExtendNameTyVarEnv parent_tv_prs $+           mapM (addLocMA (getAssocFamInitialKind cls)) ats+       ; return (cls : inner_tcs) }+  where+    getAssocFamInitialKind cls =+      case strategy of+        InitialKindInfer -> get_fam_decl_initial_kind (Just cls)+        InitialKindCheck _ -> check_initial_kind_assoc_fam cls++getInitialKind strategy+    (DataDecl { tcdLName = L _ name+              , tcdTyVars = ktvs+              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig+                                         , dd_ND = new_or_data } })+  = do  { let flav = newOrDataToFlavour new_or_data+              ctxt = DataKindCtxt name+        ; tc <- kcDeclHeader strategy name flav ktvs $+                case m_sig of+                  Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+                  Nothing   -> return $ dataDeclDefaultResultKind strategy new_or_data+        ; return [tc] }++getInitialKind InitialKindInfer (FamDecl { tcdFam = decl })+  = do { tc <- get_fam_decl_initial_kind Nothing decl+       ; return [tc] }++getInitialKind (InitialKindCheck msig) (FamDecl { tcdFam =+  FamilyDecl { fdLName     = unLoc -> name+             , fdTyVars    = ktvs+             , fdResultSig = unLoc -> resultSig+             , fdInfo      = info } } )+  = do { let flav = getFamFlav Nothing info+             ctxt = TyFamResKindCtxt name+       ; tc <- kcDeclHeader (InitialKindCheck msig) name flav ktvs $+               case famResultKindSignature resultSig of+                 Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+                 Nothing ->+                   case msig of+                     CUSK -> return (TheKind liftedTypeKind)+                     SAKS _ -> return AnyKind+       ; return [tc] }++getInitialKind strategy+    (SynDecl { tcdLName = L _ name+             , tcdTyVars = ktvs+             , tcdRhs = rhs })+  = do { let ctxt = TySynKindCtxt name+       ; tc <- kcDeclHeader strategy name TypeSynonymFlavour ktvs $+               case hsTyKindSig rhs of+                 Just rhs_sig -> TheKind <$> tcLHsKindSig ctxt rhs_sig+                 Nothing -> return AnyKind+       ; return [tc] }++get_fam_decl_initial_kind+  :: Maybe TcTyCon -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyDecl GhcRn+  -> TcM TcTyCon+get_fam_decl_initial_kind mb_parent_tycon+    FamilyDecl { fdLName     = L _ name+               , fdTyVars    = ktvs+               , fdResultSig = L _ resultSig+               , fdInfo      = info }+  = kcDeclHeader InitialKindInfer name flav ktvs $+    case resultSig of+      KindSig _ ki                            -> TheKind <$> tcLHsKindSig ctxt ki+      TyVarSig _ (L _ (KindedTyVar _ _ _ ki)) -> TheKind <$> tcLHsKindSig ctxt ki+      _ -- open type families have * return kind by default+        | tcFlavourIsOpen flav              -> return (TheKind liftedTypeKind)+               -- closed type families have their return kind inferred+               -- by default+        | otherwise                         -> return AnyKind+  where+    flav = getFamFlav mb_parent_tycon info+    ctxt = TyFamResKindCtxt name++-- See Note [Standalone kind signatures for associated types]+check_initial_kind_assoc_fam+  :: TcTyCon -- parent class+  -> FamilyDecl GhcRn+  -> TcM TcTyCon+check_initial_kind_assoc_fam cls+  FamilyDecl+    { fdLName     = unLoc -> name+    , fdTyVars    = ktvs+    , fdResultSig = unLoc -> resultSig+    , fdInfo      = info }+  = kcDeclHeader (InitialKindCheck CUSK) name flav ktvs $+    case famResultKindSignature resultSig of+      Just ksig -> TheKind <$> tcLHsKindSig ctxt ksig+      Nothing -> return (TheKind liftedTypeKind)+  where+    ctxt = TyFamResKindCtxt name+    flav = getFamFlav (Just cls) info++{- Note [Standalone kind signatures for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If associated types had standalone kind signatures, would they wear them++---------------------------+------------------------------+  like this? (OUT)         |   or like this? (IN)+---------------------------+------------------------------+  type T :: Type -> Type   |   class C a where+  class C a where          |     type T :: Type -> Type+    type T a               |     type T a++The (IN) variant is syntactically ambiguous:++  class C a where+    type T :: a   -- standalone kind signature?+    type T :: a   -- declaration header?++The (OUT) variant does not suffer from this issue, but it might not be the+direction in which we want to take Haskell: we seek to unify type families and+functions, and, by extension, associated types with class methods. And yet we+give class methods their signatures inside the class, not outside. Neither do+we have the counterpart of InstanceSigs for StandaloneKindSignatures.++For now, we dodge the question by using CUSKs for associated types instead of+standalone kind signatures. This is a simple addition to the rule we used to+have before standalone kind signatures:++  old rule:  associated type has a CUSK iff its parent class has a CUSK+  new rule:  associated type has a CUSK iff its parent class has a CUSK or a standalone kind signature++-}++-- See Note [Data declaration default result kind]+dataDeclDefaultResultKind :: InitialKindStrategy ->  NewOrData -> ContextKind+dataDeclDefaultResultKind strategy new_or_data+  | NewType <- new_or_data+  = OpenKind -- See Note [Implementation of UnliftedNewtypes], point <Error Messages>.+  | DataType <- new_or_data+  , InitialKindCheck (SAKS _) <- strategy+  = OpenKind -- See Note [Implementation of UnliftedDatatypes]+  | otherwise+  = TheKind liftedTypeKind++{- Note [Data declaration default result kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user has not written an inline result kind annotation on a data+declaration, we assume it to be 'Type'. That is, the following declarations+D1 and D2 are considered equivalent:++  data D1         where ...+  data D2 :: Type where ...++The consequence of this assumption is that we reject D3 even though we+accept D4:++  data D3 where+    MkD3 :: ... -> D3 param++  data D4 :: Type -> Type where+    MkD4 :: ... -> D4 param++However, there are two twists:++  * For unlifted newtypes, we must relax the assumed result kind to (TYPE r):++      newtype D5 where+        MkD5 :: Int# -> D5++    See Note [Implementation of UnliftedNewtypes], STEP 1 and it's sub-note+    <Error Messages>.++  * For unlifted datatypes, we must relax the assumed result kind to+    (TYPE (BoxedRep l)) in the presence of a SAKS:++      type D6 :: Type -> TYPE (BoxedRep Unlifted)+      data D6 a = MkD6 a++    Otherwise, it would be impossible to declare unlifted data types in H98+    syntax (which doesn't allow specification of a result kind).++-}++---------------------------------+getFamFlav+  :: Maybe TcTyCon    -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyInfo pass+  -> TyConFlavour+getFamFlav mb_parent_tycon info =+  case info of+    DataFamily         -> DataFamilyFlavour mb_parent_tycon+    OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon+    ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon ) -- See Note [Closed type family mb_parent_tycon]+                          ClosedTypeFamilyFlavour++{- Note [Closed type family mb_parent_tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's no way to write a closed type family inside a class declaration:++  class C a where+    type family F a where  -- error: parse error on input ‘where’++In fact, it is not clear what the meaning of such a declaration would be.+Therefore, 'mb_parent_tycon' of any closed type family has to be Nothing.+-}++------------------------------------------------------------------------+kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()+  -- See Note [Kind checking for type and class decls]+  -- Called only for declarations without a signature (no CUSKs or SAKs here)+kcLTyClDecl (L loc decl)+  = setSrcSpanA loc $+    do { tycon <- tcLookupTcTyCon tc_name+       ; traceTc "kcTyClDecl {" (ppr tc_name)+       ; addVDQNote tycon $   -- See Note [Inferring visible dependent quantification]+         addErrCtxt (tcMkDeclCtxt decl) $+         kcTyClDecl decl tycon+       ; traceTc "kcTyClDecl done }" (ppr tc_name) }+  where+    tc_name = tcdName decl++kcTyClDecl :: TyClDecl GhcRn -> TcTyCon -> TcM ()+-- This function is used solely for its side effect on kind variables+-- NB kind signatures on the type variables and+--    result kind signature have already been dealt with+--    by inferInitialKind, so we can ignore them here.++kcTyClDecl (DataDecl { tcdLName    = (L _ name), tcdDataDefn = defn }) tycon+  | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons, dd_ND = new_or_data } <- defn+  = bindTyClTyVars name $ \ _ _ _ ->+       -- NB: binding these tyvars isn't necessary for GADTs, but it does no+       -- harm.  For GADTs, each data con brings its own tyvars into scope,+       -- and the ones from this bindTyClTyVars are either not mentioned or+       -- (conceivably) shadowed.+    do { traceTc "kcTyClDecl" (ppr tycon $$ ppr (tyConTyVars tycon) $$ ppr (tyConResKind tycon))+       ; _ <- tcHsContext ctxt+       ; kcConDecls new_or_data (tyConResKind tycon) cons+       }++kcTyClDecl (SynDecl { tcdLName = L _ name, tcdRhs = rhs }) _tycon+  = bindTyClTyVars name $ \ _ _ res_kind ->+    discardResult $ tcCheckLHsType rhs (TheKind res_kind)+        -- NB: check against the result kind that we allocated+        -- in inferInitialKinds.++kcTyClDecl (ClassDecl { tcdLName = L _ name+                      , tcdCtxt = ctxt, tcdSigs = sigs }) _tycon+  = bindTyClTyVars name $ \ _ _ _ ->+    do  { _ <- tcHsContext ctxt+        ; mapM_ (wrapLocMA_ kc_sig) sigs }+  where+    kc_sig (ClassOpSig _ _ nms op_ty) = kcClassSigType nms op_ty+    kc_sig _                          = return ()++kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo   = fd_info })) fam_tc+-- closed type families look at their equations, but other families don't+-- do anything here+  = case fd_info of+      ClosedTypeFamily (Just eqns) -> mapM_ (kcTyFamInstEqn fam_tc) eqns+      _ -> return ()++-------------------++-- Kind-check the types of the arguments to a data constructor.+-- This includes doing kind unification if the type is a newtype.+-- See Note [Implementation of UnliftedNewtypes] for why we need+-- the first two arguments.+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+  ; forM_ arg_tys (\(HsScaled mult ty) -> do _ <- tcCheckLHsType (getBangType ty) exp_kind+                                             tcMult mult)+    -- See Note [Implementation of UnliftedNewtypes], STEP 2+  }++-- Kind-check the types of arguments to a Haskell98 data constructor.+kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM ()+kcConH98Args new_or_data res_kind con_args = case con_args of+  PrefixCon _ tys   -> kcConArgTys new_or_data res_kind tys+  InfixCon ty1 ty2  -> kcConArgTys new_or_data res_kind [ty1, ty2]+  RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $+                       map (hsLinear . cd_fld_type . unLoc) flds++-- Kind-check the types of arguments to a GADT data constructor.+kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM ()+kcConGADTArgs new_or_data res_kind con_args = case con_args of+  PrefixConGADT tys     -> kcConArgTys new_or_data res_kind tys+  RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $+                           map (hsLinear . cd_fld_type . unLoc) flds++kcConDecls :: NewOrData+           -> Kind             -- The result kind signature+                               --   Used only in H98 case+           -> [LConDecl GhcRn] -- The data constructors+           -> TcM ()+-- See Note [kcConDecls: kind-checking data type decls]+kcConDecls new_or_data tc_res_kind cons+  = mapM_ (wrapLocMA_ (kcConDecl new_or_data tc_res_kind)) cons++-- Kind check a data constructor. In additional to the data constructor,+-- we also need to know about whether or not its corresponding type was+-- declared with data or newtype, and we need to know the result kind of+-- this type. See Note [Implementation of UnliftedNewtypes] for why+-- we need the first two arguments.+kcConDecl :: NewOrData+          -> Kind  -- Result kind of the type constructor+                   -- Usually Type but can be TYPE UnliftedRep+                   -- or even TYPE r, in the case of unlifted newtype+                   -- Used only in H98 case+          -> ConDecl GhcRn+          -> TcM ()+kcConDecl new_or_data tc_res_kind (ConDeclH98+  { con_name = name, con_ex_tvs = ex_tvs+  , con_mb_cxt = ex_ctxt, con_args = args })+  = addErrCtxt (dataConCtxt [name]) $+    discardResult                   $+    bindExplicitTKBndrs_Tv ex_tvs $+    do { _ <- tcHsContext ex_ctxt+       ; kcConH98Args new_or_data tc_res_kind args+         -- We don't need to check the telescope here,+         -- because that's done in tcConDecl+       }++kcConDecl new_or_data+          _tc_res_kind   -- Not used in GADT case (and doesn't make sense)+          (ConDeclGADT+    { con_names = names, con_bndrs = L _ outer_bndrs, con_mb_cxt = cxt+    , con_g_args = args, con_res_ty = res_ty })+  = -- See Note [kcConDecls: kind-checking data type decls]+    addErrCtxt (dataConCtxt names) $+    discardResult                      $+    bindOuterSigTKBndrs_Tv outer_bndrs $+        -- Why "_Tv"?  See Note [Using TyVarTvs for kind-checking GADTs]+    do { _ <- tcHsContext cxt+       ; traceTc "kcConDecl:GADT {" (ppr names $$ ppr res_ty)+       ; con_res_kind <- newOpenTypeKind+       ; _ <- tcCheckLHsType res_ty (TheKind con_res_kind)+       ; kcConGADTArgs new_or_data con_res_kind args+       ; traceTc "kcConDecl:GADT }" (ppr names $$ ppr con_res_kind)+       ; return () }++{- Note [kcConDecls: kind-checking data type decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcConDecls is used when we are inferring the kind of the type+constructor in a data type declaration.  E.g.+    data T f a = MkT (f a)+we want to infer the kind of 'f' and 'a'. The basic plan is described+in Note [Inferring kinds for type declarations]; here we are doing Step 2.++In the GADT case we may have this:+   data T f a where+      MkT :: forall g b. g b -> T g b++Notice that the variables f,a, and g,b are quite distinct.+Nevertheless, the type signature for MkT must still influence the kind+T which is (remember Step 1) something like+  T :: kappa1 -> kappa2 -> Type+Otherwise we'd infer the bogus kind+  T :: forall k1 k2. k1 -> k2 -> Type.++The type signature for MkT influences the kind of T simply by+kind-checking the result type (T g b), which will force 'f' and 'g' to+have the same kinds. This is the call to+    tcCheckLHsType res_ty (TheKind con_res_kind)+Because this is the result type of an arrow, we know the kind must be+of form (TYPE rr), and we get better error messages if we enforce that+here (e.g. test gadt10).++For unlifted newtypes only, we must ensure that the argument kind+and result kind are the same:+* In the H98 case, we need the result kind of the TyCon, to unify with+  the argument kind.++* In GADT syntax, this unification happens via the result kind passed+  to kcConGADTArgs. The tycon's result kind is not used at all in the+  GADT case.++Note [Using TyVarTvs for kind-checking GADTs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data Proxy a where+    MkProxy1 :: forall k (b :: k). Proxy b+    MkProxy2 :: forall j (c :: j). Proxy c++It seems reasonable that this should be accepted. But something very strange+is going on here: when we're kind-checking this declaration, we need to unify+the kind of `a` with k and j -- even though k and j's scopes are local to the type of+MkProxy{1,2}.++In effect, we are simply gathering constraints on the shape of Proxy's+kind, with no skolemisation or implication constraints involved at all.++The best approach we've come up with is to use TyVarTvs during the+kind-checking pass, rather than ordinary skolems. This is why we use+the "_Tv" variant, bindOuterSigTKBndrs_Tv.++Our only goal is to gather constraints on the kind of the type constructor;+we do not certify that the data declaration is well-kinded. For example:++  data SameKind :: k -> k -> Type+  data Bad a where+    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)++which would be accepted by kcConDecl because k1 and k2 are+TyVarTvs. It is correctly rejected in the second pass, tcConDecl.+(Test case: polykinds/TyVarTvKinds3)++One drawback of this approach is sometimes it will accept a definition that+a (hypothetical) declarative specification would likely reject. As a general+rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,+the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs+approach allows a limited form of polymorphic recursion *without* a CUSK.++To wit:+  data T a = forall k (b :: k). MkT (T b) Int+  (test case: dependent/should_compile/T14066a)++Note that this is polymorphically recursive, with the recursive occurrence+of T used at a kind other than a's kind. The approach outlined here accepts+this definition, because this kind is still a kind variable (and so the+TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a+way to describe exactly what declarations will be accepted and which will+be rejected (without a CUSK). However, the accepted definitions are indeed+well-kinded and any rejected definitions would be accepted with a CUSK,+and so this wrinkle need not cause anyone to lose sleep.++Note [Recursion and promoting data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to allow promotion in a strongly connected component+when kind checking.++Consider:+  data T f = K (f (K Any))++When kind checking the `data T' declaration the local env contains the+mappings:+  T -> ATcTyCon <some initial kind>+  K -> APromotionErr++APromotionErr is only used for DataCons, and only used during type checking+in tcTyClGroup.+++************************************************************************+*                                                                      *+\subsection{Type checking}+*                                                                      *+************************************************************************++Note [Type checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this point we have completed *kind-checking* of a mutually+recursive group of type/class decls (done in kcTyClGroup). However,+we discarded the kind-checked types (eg RHSs of data type decls);+note that kcTyClDecl returns ().  There are two reasons:++  * It's convenient, because we don't have to rebuild a+    kinded HsDecl (a fairly elaborate type)++  * It's necessary, because after kind-generalisation, the+    TyCons/Classes may now be kind-polymorphic, and hence need+    to be given kind arguments.++Example:+       data T f a = MkT (f a) (T f a)+During kind-checking, we give T the kind T :: k1 -> k2 -> *+and figure out constraints on k1, k2 etc. Then we generalise+to get   T :: forall k. (k->*) -> k -> *+So now the (T f a) in the RHS must be elaborated to (T k f a).++However, during tcTyClDecl of T (above) we will be in a recursive+"knot". So we aren't allowed to look at the TyCon T itself; we are only+allowed to put it (lazily) in the returned structures.  But when+kind-checking the RHS of T's decl, we *do* need to know T's kind (so+that we can correctly elaboarate (T k f a).  How can we get T's kind+without looking at T?  Delicate answer: during tcTyClDecl, we extend++  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)++Then:++  * During GHC.Tc.Gen.HsType.tcTyVar we look in the *local* env, to get the+    fully-known, not knot-tied TcTyCon for T.++  * Then, in GHC.Tc.Utils.Zonk.zonkTcTypeToType (and zonkTcTyCon in particular)+    we look in the *global* env to get the TyCon.++This fancy footwork (with two bindings for T) is only necessary for the+TyCons or Classes of this recursive group.  Earlier, finished groups,+live in the global env only.++See also Note [Kind checking recursive type and class declarations]++Note [Kind checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before we can type-check the decls, we must kind check them. This+is done by establishing an "initial kind", which is a rather uninformed+guess at a tycon's kind (by counting arguments, mainly) and then+using this initial kind for recursive occurrences.++The initial kind is stored in exactly the same way during+kind-checking as it is during type-checking (Note [Type checking+recursive type and class declarations]): in the *local* environment,+with ATcTyCon. But we still must store *something* in the *global*+environment. Even though we discard the result of kind-checking, we+sometimes need to produce error messages. These error messages will+want to refer to the tycons being checked, except that they don't+exist yet, and it would be Terribly Annoying to get the error messages+to refer back to HsSyn. So we create a TcTyCon and put it in the+global env. This tycon can print out its name and knows its kind, but+any other action taken on it will panic. Note that TcTyCons are *not*+knot-tied, unlike the rather valid but knot-tied ones that occur+during type-checking.++Note [Declarations for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wired-in things we simply ignore the declaration+and take the wired-in information.  That avoids complications.+e.g. the need to make the data constructor worker name for+     a constraint tuple match the wired-in one++Note [Datatype return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several poorly lit corners around datatype/newtype return kinds.+This Note explains these.  We cover data/newtype families and instances+in Note [Data family/instance return kinds].++data    T a :: <kind> where ...   -- See Point DT4+newtype T a :: <kind> where ...   -- See Point DT5++DT1 Where this applies: Only GADT syntax for data/newtype/instance declarations+    can have declared return kinds. This Note does not apply to Haskell98+    syntax.++DT2 Where these kinds come from: The return kind is part of the TyCon kind, gotten either+     by checkInitialKind (standalone kind signature / CUSK) or+     inferInitialKind. It is extracted by bindTyClTyVars in tcTyClDecl1. It is+     then passed to tcDataDefn.++DT3 Eta-expansion: Any forall-bound variables and function arguments in a result kind+    become parameters to the type. That is, when we say++     data T a :: Type -> Type where ...++    we really mean for T to have two parameters. The second parameter+    is produced by processing the return kind in etaExpandAlgTyCon,+    called in tcDataDefn.++    See also Note [TyConBinders for the result kind signatures of a data type]+    in GHC.Tc.Gen.HsType.++DT4 Datatype return kind restriction: A data type return kind must end+    in a type that, after type-synonym expansion, yields `TYPE LiftedRep`. By+    "end in", we mean we strip any foralls and function arguments off before+    checking.++    Examples:+      data T1 :: Type                          -- good+      data T2 :: Bool -> Type                  -- good+      data T3 :: Bool -> forall k. Type        -- strange, but still accepted+      data T4 :: forall k. k -> Type           -- good+      data T5 :: Bool                          -- bad+      data T6 :: Type -> Bool                  -- bad++    Exactly the same applies to data instance (but not data family)+    declarations.  Examples+      data instance D1 :: Type                 -- good+      data instance D2 :: Bool -> Type         -- good++    We can "look through" type synonyms+      type Star = Type+      data T7 :: Bool -> Star                  -- good (synonym expansion ok)+      type Arrow = (->)+      data T8 :: Arrow Bool Type               -- good (ditto)++    But we specifically do *not* do type family reduction here.+      type family ARROW where+        ARROW = (->)+      data T9 :: ARROW Bool Type               -- bad++      type family F a where+        F Int  = Bool+        F Bool = Type+      data T10 :: Bool -> F Bool               -- bad++    The /principle/ here is that in the TyCon for a data type or data instance,+    we must be able to lay out all the type-variable binders, one by one, until+    we reach (TYPE xx).  There is no place for a cast here.  We could add one,+    but let's not!++    This check is done in checkDataKindSig. For data declarations, this+    call is in tcDataDefn; for data instances, this call is in tcDataFamInstDecl.++DT5 Newtype return kind restriction.+    If -XUnliftedNewtypes is not on, then newtypes are treated just+    like datatypes --- see (4) above.++    If -XUnliftedNewtypes is on, then a newtype return kind must end in+    TYPE xyz, for some xyz (after type synonym expansion). The "xyz"+    may include type families, but the TYPE part must be visible+    /without/ expanding type families (only synonyms).++    This kind is unified with the kind of the representation type (the+    type of the one argument to the one constructor). See also steps+    (2) and (3) of Note [Implementation of UnliftedNewtypes].++    The checks are done in the same places as for datatypes.+    Examples (assume -XUnliftedNewtypes):++      newtype N1 :: Type                       -- good+      newtype N2 :: Bool -> Type               -- good+      newtype N3 :: forall r. Bool -> TYPE r   -- good++      type family F (t :: Type) :: RuntimeRep+      newtype N4 :: forall t -> TYPE (F t)     -- good++      type family STAR where+        STAR = Type+      newtype N5 :: Bool -> STAR               -- bad++Note [Data family/instance return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Within this note, understand "instance" to mean data or newtype+instance, and understand "family" to mean data family. No type+families or classes here. Some examples:++data family T a :: <kind>          -- See Point DF56++data    instance T [a] :: <kind> where ...   -- See Point DF2+newtype instance T [a] :: <kind> where ...   -- See Point DF2++Here is the Plan for Data Families:++DF0 Where these kinds come from:++    Families: The return kind is either written in a standalone signature+     or extracted from a family declaration in getInitialKind.+     If a family declaration is missing a result kind, it is assumed to be+     Type. This assumption is in getInitialKind for CUSKs or+     get_fam_decl_initial_kind for non-signature & non-CUSK cases.++   Instances: The data family already has a known kind. The return kind+     of an instance is then calculated by applying the data family tycon+     to the patterns provided, as computed by the typeKind lhs_ty in the+     end of tcDataFamInstHeader. In the case of an instance written in GADT+     syntax, there are potentially *two* return kinds: the one computed from+     applying the data family tycon to the patterns, and the one given by+     the user. This second kind is checked by the tc_kind_sig function within+     tcDataFamInstHeader. See also DF3, below.++DF1 In a data/newtype instance, we treat the kind of the /data family/,+    once instantiated, as the "master kind" for the representation+    TyCon.  For example:+        data family T1 :: Type -> Type -> Type+        data instance T1 Int :: F Bool -> Type where ...+    The "master kind" for the representation TyCon R:T1Int comes+    from T1, not from the signature on the data instance.  It is as+    if we declared+        data R:T1Int :: Type -> Type where ...+     See Note [Liberalising data family return kinds] for an alternative+     plan.  But this current plan is simple, and ensures that all instances+     are simple instantiations of the master, without strange casts.++     An example with non-trivial instantiation:+        data family T2 :: forall k. Type -> k+        data instance T2 :: Type -> Type -> Type where ...+     Here 'k' gets instantiated with (Type -> Type), driven by+     the signature on the 'data instance'. (See also DT3 of+     Note [Datatype return kinds] about eta-expansion, which applies here,+     too; see tcDataFamInstDecl's call of etaExpandAlgTyCon.)++     A newtype example:++       data Color = Red | Blue+       type family Interpret (x :: Color) :: RuntimeRep where+         Interpret 'Red = 'IntRep+         Interpret 'Blue = 'WordRep+       data family Foo (x :: Color) :: TYPE (Interpret x)+       newtype instance Foo 'Red :: TYPE IntRep where+         FooRedC :: Int# -> Foo 'Red++    Here we get that Foo 'Red :: TYPE (Interpret Red), and our+    representation newtype looks like+         newtype R:FooRed :: TYPE (Interpret Red) where+            FooRedC :: Int# -> R:FooRed+    Remember: the master kind comes from the /family/ tycon.++DF2 /After/ this instantiation, the return kind of the master kind+    must obey the usual rules for data/newtype return kinds (DT4, DT5)+    of Note [Datatype return kinds].  Examples:+        data family T3 k :: k+        data instance T3 Type where ...          -- OK+        data instance T3 (Type->Type) where ...  -- OK+        data instance T3 (F Int) where ...       -- Not OK++DF3 Any kind signatures on the data/newtype instance are checked for+    equality with the master kind (and hence may guide instantiation)+    but are otherwise ignored. So in the T1 example above, we check+    that (F Int ~ Type) by unification; but otherwise ignore the+    user-supplied signature from the /family/ not the /instance/.++    We must be sure to instantiate any trailing invisible binders+    before doing this unification.  See the call to tcInstInvisibleBinders+    in tcDataFamInstHeader. For example:+       data family D :: forall k. k+       data instance D :: Type               -- forall k. k   <:  Type+       data instance D :: Type -> Type       -- forall k. k   <:  Type -> Type+         -- NB: these do not overlap+    we must instantiate D before unifying with the signature in the+    data instance declaration++DF4 We also (redundantly) check that any user-specified return kind+    signature in the data instance also obeys DT4/DT5.  For example we+    reject+        data family T1 :: Type -> Type -> Type+        data instance T1 Int :: Type -> F Int+    even if (F Int ~ Type).  We could omit this check, because we+    use the master kind; but it seems more uniform to check it, again+    with checkDataKindSig.++DF5 Data /family/ return kind restrictions. Consider+       data family D8 a :: F a+    where F is a type family.  No data/newtype instance can instantiate+    this so that it obeys the rules of DT4 or DT5.  So GHC proactively+    rejects the data /family/ declaration if it can never satisfy (DT4)/(DT5).+    Remember that a data family supports both data and newtype instances.++    More precisely, the return kind of a data family must be either+        * TYPE xyz (for some type xyz) or+        * a kind variable+    Only in these cases can a data/newtype instance possibly satisfy (DT4)/(DT5).+    This is checked by the call to checkDataKindSig in tcFamDecl1.  Examples:++      data family D1 :: Type              -- good+      data family D2 :: Bool -> Type      -- good+      data family D3 k :: k               -- good+      data family D4 :: forall k -> k     -- good+      data family D5 :: forall k. k -> k  -- good+      data family D6 :: forall r. TYPE r  -- good+      data family D7 :: Bool -> STAR      -- bad (see STAR from point 5)++DF6 Two return kinds for instances: If an instance has two return kinds,+    one from the family declaration and one from the instance declaration+    (see point DF3 above), they are unified. More accurately, we make sure+    that the kind of the applied data family is a subkind of the user-written+    kind. GHC.Tc.Gen.HsType.checkExpectedKind normally does this check for types, but+    that's overkill for our needs here. Instead, we just instantiate any+    invisible binders in the (instantiated) kind of the data family+    (called lhs_kind in tcDataFamInstHeader) with tcInstInvisibleTyBinders+    and then unify the resulting kind with the kind written by the user.+    This unification naturally produces a coercion, which we can drop, as+    the kind annotation on the instance is redundant (except perhaps for+    effects of unification).++    This all is Wrinkle (3) in Note [Implementation of UnliftedNewtypes].++Note [Liberalising data family return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Could we allow this?+   type family F a where { F Int = Type }+   data family T a :: F a+   data instance T Int where+      MkT :: T Int++In the 'data instance', T Int :: F Int, and F Int = Type, so all seems+well.  But there are lots of complications:++* The representation constructor R:TInt presumably has kind Type.+  So the axiom connecting the two would have to look like+       axTInt :: T Int ~ R:TInt |> sym axFInt+  and that doesn't match expectation in DataFamInstTyCon+  in AlgTyConFlav++* The wrapper can't have type+     $WMkT :: Int -> T Int+  because T Int has the wrong kind.  It would have to be+     $WMkT :: Int -> (T Int) |> axFInt++* The code for $WMkT would also be more complicated, needing+  two coherence coercions. Try it!++* Code for pattern matching would be complicated in an+  exactly dual way.++So yes, we could allow this, but we currently do not. That's+why we have DF2 in Note [Data family/instance return kinds].++Note [Implementation of UnliftedNewtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expected behavior of UnliftedNewtypes:++* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0013-unlifted-newtypes.rst+* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/98++What follows is a high-level overview of the implementation of the+proposal.++STEP 1: Getting the initial kind, as done by inferInitialKind. We have+two sub-cases:++* With a SAK/CUSK: no change in kind-checking; the tycon is given the kind+  the user writes, whatever it may be.++* Without a SAK/CUSK: If there is no kind signature, the tycon is given+  a kind `TYPE r`, for a fresh unification variable `r`. We do this even+  when -XUnliftedNewtypes is not on; see <Error Messages>, below.++STEP 2: Kind-checking, as done by kcTyClDecl. This step is skipped for CUSKs.+The key function here is kcConDecl, which looks at an individual constructor+declaration. When we are processing a newtype (but whether or not -XUnliftedNewtypes+is enabled; see <Error Messages>, below), we generate a correct ContextKind+for the checking argument types: see getArgExpKind.++Examples of newtypes affected by STEP 2, assuming -XUnliftedNewtypes is+enabled (we use r0 to denote a unification variable):++newtype Foo rep = MkFoo (forall (a :: TYPE rep). a)++ kcConDecl unifies (TYPE r0) with (TYPE rep), where (TYPE r0)+  is the kind that inferInitialKind invented for (Foo rep).++data Color = Red | Blue+type family Interpret (x :: Color) :: RuntimeRep where+  Interpret 'Red = 'IntRep+  Interpret 'Blue = 'WordRep+data family Foo (x :: Color) :: TYPE (Interpret x)+newtype instance Foo 'Red = FooRedC Int#++ kcConDecl unifies TYPE (Interpret 'Red) with TYPE 'IntRep++Note that, in the GADT case, we might have a kind signature with arrows+(newtype XYZ a b :: Type -> Type where ...). We want only the final+component of the kind for checking in kcConDecl, so we call etaExpandAlgTyCon+in kcTyClDecl.++STEP 3: Type-checking (desugaring), as done by tcTyClDecl. The key function+here is tcConDecl. Once again, we must use getArgExpKind to ensure that the+representation type's kind matches that of the newtype, for two reasons:++  A. It is possible that a GADT has a CUSK. (Note that this is *not*+     possible for H98 types.) Recall that CUSK types don't go through+     kcTyClDecl, so we might not have done this kind check.+  B. We need to produce the coercion to put on the argument type+     if the kinds are different (for both H98 and GADT).++Example of (B):++type family F a where+  F Int = LiftedRep++newtype N :: TYPE (F Int) where+  MkN :: Int -> N++We really need to have the argument to MkN be (Int |> TYPE (sym axF)), where+axF :: F Int ~ LiftedRep. That way, the argument kind is the same as the+newtype kind, which is the principal correctness condition for newtypes.++Wrinkle: Consider (#17021, typecheck/should_fail/T17021)++    type family Id (x :: a) :: a where+      Id x = x++    newtype T :: TYPE (Id LiftedRep) where+      MkT :: Int -> T++  In the type of MkT, we must end with (Int |> TYPE (sym axId)) -> T,+  never Int -> (T |> TYPE axId); otherwise, the result type of the+  constructor wouldn't match the datatype. However, type-checking the+  HsType T might reasonably result in (T |> hole). We thus must ensure+  that this cast is dropped, forcing the type-checker to add one to+  the Int instead.++  Why is it always safe to drop the cast? This result type is type-checked by+  tcHsOpenType, so its kind definitely looks like TYPE r, for some r. It is+  important that even after dropping the cast, the type's kind has the form+  TYPE r. This is guaranteed by restrictions on the kinds of datatypes.+  For example, a declaration like `newtype T :: Id Type` is rejected: a+  newtype's final kind always has the form TYPE r, just as we want.++Note that this is possible in the H98 case only for a data family, because+the H98 syntax doesn't permit a kind signature on the newtype itself.++There are also some changes for dealing with families:++1. In tcFamDecl1, we suppress a tcIsLiftedTypeKind check if+   UnliftedNewtypes is on. This allows us to write things like:+     data family Foo :: TYPE 'IntRep++2. In a newtype instance (with -XUnliftedNewtypes), if the user does+   not write a kind signature, we want to allow the possibility that+   the kind is not Type, so we use newOpenTypeKind instead of liftedTypeKind.+   This is done in tcDataFamInstHeader in GHC.Tc.TyCl.Instance. Example:++       data family Bar (a :: RuntimeRep) :: TYPE a+       newtype instance Bar 'IntRep = BarIntC Int#+       newtype instance Bar 'WordRep :: TYPE 'WordRep where+         BarWordC :: Word# -> Bar 'WordRep++   The data instance corresponding to IntRep does not specify a kind signature,+   so tc_kind_sig just returns `TYPE r0` (where `r0` is a fresh metavariable).+   The data instance corresponding to WordRep does have a kind signature, so+   we use that kind signature.++3. A data family and its newtype instance may be declared with slightly+   different kinds. See point DF6 in Note [Data family/instance return kinds]++There's also a change in the renamer:++* In GHC.RenameSource.rnTyClDecl, enabling UnliftedNewtypes changes what is means+  for a newtype to have a CUSK. This is necessary since UnliftedNewtypes+  means that, for newtypes without kind signatures, we must use the field+  inside the data constructor to determine the result kind.+  See Note [Unlifted Newtypes and CUSKs] for more detail.++For completeness, it was also necessary to make coerce work on+unlifted types, resolving #13595.++<Error Messages>: It's tempting to think that the expected kind for a newtype+constructor argument when -XUnliftedNewtypes is *not* enabled should just be Type.+But this leads to difficulty in suggesting to enable UnliftedNewtypes. Here is+an example:++  newtype A = MkA Int#++If we expect the argument to MkA to have kind Type, then we get a kind-mismatch+error. The problem is that there is no way to connect this mismatch error to+-XUnliftedNewtypes, and suggest enabling the extension. So, instead, we allow+the A to type-check, but then find the problem when doing validity checking (and+where we get make a suitable error message). One potential worry is++  {-# LANGUAGE PolyKinds #-}+  newtype B a = MkB a++This turns out OK, because unconstrained RuntimeReps default to LiftedRep, just+as we would like. Another potential problem comes in a case like++  -- no UnliftedNewtypes++  data family D :: k+  newtype instance D = MkD Any++Here, we want inference to tell us that k should be instantiated to Type in+the instance. With the approach described here (checking for Type only in+the validity checker), that will not happen. But I cannot think of a non-contrived+example that will notice this lack of inference, so it seems better to improve+error messages than be able to infer this instantiation.++Note [Implementation of UnliftedDatatypes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expected behavior of UnliftedDatatypes:++* Proposal: https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0265-unlifted-datatypes.rst+* Discussion: https://github.com/ghc-proposals/ghc-proposals/pull/265++The implementation heavily leans on Note [Implementation of UnliftedNewtypes].++In the frontend, the following tweaks have been made in the typechecker:++* STEP 1: In the inferInitialKinds phase, newExpectedKind gives data type+  constructors a result kind of `TYPE r` with a fresh unification variable+  `r :: RuntimeRep` when there is a SAKS. (Same as for UnliftedNewtypes.)+  Not needed with a CUSK, because it can't specify result kinds.+  If there's a GADTSyntax result kind signature, we keep on using that kind.++  Similarly, for data instances without a kind signature, we use+  `TYPE r` as the result kind, to support the following code:++    data family F a :: UnliftedType+    data instance F Int = TInt++  The ommission of a kind signature for `F` should not mean a result kind+  of `Type` (and thus a kind error) here.++* STEP 2: No change to kcTyClDecl.++* STEP 3: In GHC.Tc.Gen.HsType.checkDataKindSig, we make sure that the result+  kind of the data declaration is actually `Type` or `TYPE (BoxedRep l)`,+  for some `l`. If UnliftedDatatypes is not activated, we emit an error with a+  suggestion in the latter case.++  Why not start out with `TYPE (BoxedRep l)` in the first place? Because then+  we get worse kind error messages in e.g. saks_fail010:++     -     Couldn't match expected kind: TYPE ('GHC.Types.BoxedRep t0)+     -                  with actual kind: * -> *+     +     Expected a type, but found something with kind ‘* -> *’+           In the data type declaration for ‘T’++  It seems `TYPE r` already has appropriate pretty-printing support.++The changes to Core, STG and Cmm are of rather cosmetic nature.+The IRs are already well-equipped to handle unlifted types, and unlifted+datatypes are just a new sub-class thereof.+-}++tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl roles_info (L loc decl)+  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)+  = case thing of -- See Note [Declarations for wired-in things]+      ATyCon tc -> return (tc, wiredInDerivInfo tc decl)+      _ -> pprPanic "tcTyClDecl" (ppr thing)++  | otherwise+  = setSrcSpanA loc $ tcAddDeclCtxt decl $+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)+       ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)+       ; return (tc, deriv_infos) }++noDerivInfos :: a -> (a, [DerivInfo])+noDerivInfos a = (a, [])++wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo]+wiredInDerivInfo tycon decl+  | DataDecl { tcdDataDefn = dataDefn } <- decl+  , HsDataDefn { dd_derivs = derivs } <- dataDefn+  = [ DerivInfo { di_rep_tc = tycon+                , di_scoped_tvs =+                    if isFunTyCon tycon || isPrimTyCon tycon+                       then []  -- no tyConTyVars+                       else mkTyVarNamePairs (tyConTyVars tycon)+                , di_clauses = derivs+                , di_ctxt = tcMkDeclCtxt decl } ]+wiredInDerivInfo _ _ = []++  -- "type family" declarations+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })+  = fmap noDerivInfos $+    tcFamDecl1 parent fd++  -- "type" synonym declaration+tcTyClDecl1 _parent roles_info+            (SynDecl { tcdLName = L _ tc_name+                     , tcdRhs   = rhs })+  = ASSERT( isNothing _parent )+    fmap noDerivInfos $+    tcTySynRhs roles_info tc_name rhs++  -- "data/newtype" declaration+tcTyClDecl1 _parent roles_info+            decl@(DataDecl { tcdLName = L _ tc_name+                           , tcdDataDefn = defn })+  = ASSERT( isNothing _parent )+    tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn++tcTyClDecl1 _parent roles_info+            (ClassDecl { tcdLName = L _ class_name+                       , tcdCtxt = hs_ctxt+                       , tcdMeths = meths+                       , tcdFDs = fundeps+                       , tcdSigs = sigs+                       , tcdATs = ats+                       , tcdATDefs = at_defs })+  = ASSERT( isNothing _parent )+    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt+                              meths fundeps sigs ats at_defs+       ; return (noDerivInfos (classTyCon clas)) }+++{- *********************************************************************+*                                                                      *+          Class declarations+*                                                                      *+********************************************************************* -}++tcClassDecl1 :: RolesInfo -> Name -> Maybe (LHsContext GhcRn)+             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]+             -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]+             -> TcM Class+tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs+  = fixM $ \ clas ->+    -- We need the knot because 'clas' is passed into tcClassATs+    bindTyClTyVars class_name $ \ _ binders res_kind ->+    do { checkClassKindSig res_kind+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)+       ; let tycon_name = class_name        -- We use the same name+             roles = roles_info tycon_name  -- for TyCon and Class++       ; (ctxt, fds, sig_stuff, at_stuff)+            <- 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 (addLocMA tc_fundep) fundeps+                  ; sig_stuff <- tcClassSigs class_name sigs meths+                  ; at_stuff  <- tcClassATs class_name clas ats at_defs+                  ; return (ctxt, fds, sig_stuff, at_stuff) }++       -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType+       -- Example: (typecheck/should_fail/T17562)+       --   type C :: Type -> Type -> Constraint+       --   class (forall a. a b ~ a c) => C b c+       -- The kind of `a` is unconstrained.+       ; dvs <- candidateQTyVarsOfTypes ctxt+       ; let mk_doc tidy_env = do { (tidy_env2, ctxt) <- zonkTidyTcTypes tidy_env ctxt+                                  ; return ( tidy_env2+                                           , sep [ text "the class context:"+                                                 , pprTheta ctxt ] ) }+       ; doNotQuantifyTyVars dvs mk_doc++       -- 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+       -- Skolems to tyvars.+       ; ze        <- mkEmptyZonkEnv NoFlexi+       ; ctxt      <- zonkTcTypesToTypesX ze ctxt+       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff+         -- ToDo: do we need to zonk at_stuff?++       -- TODO: Allow us to distinguish between abstract class,+       -- and concrete class with no methods (maybe by+       -- specifying a trailing where or not++       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff+       ; is_boot <- tcIsHsBootOrSig+       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff+                  = Nothing+                  | otherwise+                  = Just (ctxt, at_stuff, sig_stuff, mindef)++       ; clas <- buildClass class_name binders roles fds body+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$+                                ppr fds)+       ; return clas }+  where+    skol_info = TyConSkol ClassFlavour class_name+    tc_fundep :: GHC.Hs.FunDep GhcRn -> TcM ([Var],[Var])+    tc_fundep (FunDep _ tvs1 tvs2)+                           = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;+                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;+                                ; return (tvs1',tvs2') }+++{- Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The following is an example of associated type defaults:+             class C a where+               data D a++               type F a b :: *+               type F a b = [a]        -- Default++Note that we can get default definitions only for type families, not data+families.+-}++tcClassATs :: Name                    -- The class name (not knot-tied)+           -> Class                   -- The class parent of this associated type+           -> [LFamilyDecl GhcRn]     -- Associated types.+           -> [LTyFamDefltDecl GhcRn] -- Associated type defaults.+           -> TcM [ClassATItem]+tcClassATs class_name cls ats at_defs+  = do {  -- Complain about associated type defaults for non associated-types+         sequence_ [ failWithTc (badATErr class_name n)+                   | n <- map at_def_tycon at_defs+                   , not (n `elemNameSet` at_names) ]+       ; mapM tc_at ats }+  where+    at_def_tycon :: LTyFamDefltDecl GhcRn -> Name+    at_def_tycon = tyFamInstDeclName . unLoc++    at_fam_name :: LFamilyDecl GhcRn -> Name+    at_fam_name = familyDeclName . unLoc++    at_names = mkNameSet (map at_fam_name ats)++    at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv+                                          (at_def_tycon at_def) [at_def])+                        emptyNameEnv at_defs++    tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)+                                  `orElse` []+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs+                  ; return (ATI fam_tc atd) }++-------------------------+tcDefaultAssocDecl ::+     TyCon                                       -- ^ Family TyCon (not knot-tied)+  -> [LTyFamDefltDecl GhcRn]                     -- ^ Defaults+  -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS+tcDefaultAssocDecl _ []+  = return Nothing  -- No default declaration++tcDefaultAssocDecl _ (d1:_:_)+  = failWithTc (text "More than one default declaration for"+                <+> ppr (tyFamInstDeclName (unLoc d1)))++tcDefaultAssocDecl fam_tc+  [L loc (TyFamInstDecl { tfid_eqn =+                            FamEqn { feqn_tycon = L _ tc_name+                                   , feqn_bndrs = outer_bndrs+                                   , feqn_pats  = hs_pats+                                   , feqn_rhs   = hs_rhs_ty }})]+  = -- See Note [Type-checking default assoc decls]+    setSrcSpanA loc $+    tcAddFamInstCtxt (text "default type instance") tc_name $+    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)+       ; let fam_tc_name = tyConName fam_tc+             vis_arity = length (tyConVisibleTyVars fam_tc)+             vis_pats  = numVisibleArgs hs_pats++       -- Kind of family check+       ; ASSERT( fam_tc_name == tc_name )+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)++       -- Arity check+       ; checkTc (vis_pats == vis_arity)+                 (wrongNumberOfParmsErr vis_arity)++       -- Typecheck RHS+       --+       -- You might think we should pass in some AssocInstInfo, as we're looking+       -- at an associated type. But this would be wrong, because an associated+       -- type default LHS can mention *different* type variables than the+       -- enclosing class. So it's treated more as a freestanding beast.+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated+                                      outer_bndrs hs_pats hs_rhs_ty++       ; let fam_tvs = tyConTyVars fam_tc+       ; traceTc "tcDefaultAssocDecl 2" (vcat+           [ text "hs_pats"   <+> ppr hs_pats+           , text "hs_rhs_ty" <+> ppr hs_rhs_ty+           , text "fam_tvs" <+> ppr fam_tvs+           , text "qtvs"    <+> ppr qtvs+             -- NB: Do *not* print `pats` or rhs_ty here, as they can mention+             -- knot-tied TyCons. See #18648.+           ])+       ; 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 (locA loc) pats)+           -- We perform checks for well-formedness and validity later, in+           -- GHC.Tc.Validity.checkValidAssocTyFamDeflt.+     }++{- Note [Type-checking default assoc decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this default declaration for an associated type++   class C a where+      type F (a :: k) b :: Type+      type F (x :: j) y = Proxy x -> y++Note that the class variable 'a' doesn't scope over the default assoc+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.+Checking for this property proves surprisingly tricky. Three potential places+where GHC could check for this property include:++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+      type F (a :: k) b :: Type+      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. 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, 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)+      type F2 (x :: z) y = SameKind x y+   data SameKind :: k -> k -> Type++All of the arguments in the default equation for `F2` are type variables, so+that passes the first check. However, if we were to build this substitution,+then both `j` and `k` map to `z`! In terms of visible kind application, it's as+if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear+that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is+also rejected.++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.+-}++{- *********************************************************************+*                                                                      *+          Type family declarations+*                                                                      *+********************************************************************* -}++tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon+tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info+                              , fdLName = tc_lname@(L _ tc_name)+                              , fdResultSig = L _ sig+                              , fdInjectivityAnn = inj })+  | DataFamily <- fam_info+  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do+  { traceTc "data family:" (ppr tc_name)+  ; checkFamFlag tc_name++  -- Check that the result kind is OK+  -- We allow things like+  --   data family T (a :: Type) :: forall k. k -> Type+  -- We treat T as having arity 1, but result kind forall k. k -> Type+  -- But we want to check that the result kind finishes in+  --   Type or a kind-variable+  -- For the latter, consider+  --   data family D a :: forall k. Type -> k+  -- When UnliftedNewtypes is enabled, we loosen this restriction+  -- on the return kind. See Note [Implementation of UnliftedNewtypes], wrinkle (1).+  -- See also Note [Datatype return kinds]+  ; checkDataKindSig DataFamilySort res_kind+  ; tc_rep_name <- newTyConRepName tc_name+  ; let inj   = Injective $ replicate (length binders) True+        tycon = mkFamilyTyCon tc_name binders+                              res_kind+                              (resultVariableName sig)+                              (DataFamilyTyCon tc_rep_name)+                              parent inj+  ; return tycon }++  | OpenTypeFamily <- fam_info+  = bindTyClTyVars tc_name $ \ _ binders res_kind -> do+  { traceTc "open type family:" (ppr tc_name)+  ; checkFamFlag tc_name+  ; inj' <- tcInjectivity binders inj+  ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors+  ; let tycon = mkFamilyTyCon tc_name binders res_kind+                               (resultVariableName sig) OpenSynFamilyTyCon+                               parent inj'+  ; return tycon }++  | ClosedTypeFamily mb_eqns <- fam_info+  = -- Closed type families are a little tricky, because they contain the definition+    -- of both the type family and the equations for a CoAxiom.+    do { traceTc "Closed type family:" (ppr tc_name)+         -- the variables in the header scope only over the injectivity+         -- declaration but this is not involved here+       ; (inj', binders, res_kind)+            <- bindTyClTyVars tc_name $ \ _ binders res_kind ->+               do { inj' <- tcInjectivity binders inj+                  ; return (inj', binders, res_kind) }++       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies+       ; checkResultSigFlag tc_name sig++         -- If Nothing, this is an abstract family in a hs-boot file;+         -- but eqns might be empty in the Just case as well+       ; case mb_eqns of+           Nothing   ->+               return $ mkFamilyTyCon tc_name binders res_kind+                                      (resultVariableName sig)+                                      AbstractClosedSynFamilyTyCon parent+                                      inj'+           Just eqns -> do {++         -- Process the equations, creating CoAxBranches+       ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind+                                   noTcTyConScopedTyVars+                                   False {- this doesn't matter here -}+                                   ClosedTypeFamilyFlavour++       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns+         -- Do not attempt to drop equations dominated by earlier+         -- ones here; in the case of mutual recursion with a data+         -- type, we get a knot-tying failure.  Instead we check+         -- for this afterwards, in GHC.Tc.Validity.checkValidCoAxiom+         -- Example: tc265++         -- Create a CoAxiom, with the correct src location.+       ; co_ax_name <- newFamInstAxiomName tc_lname []++       ; let mb_co_ax+              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list+              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)++             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)+                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'++         -- We check for instance validity later, when doing validity+         -- checking for the tycon. Exception: checking equations+         -- overlap done by dropDominatedAxioms+       ; return fam_tc } }++#if __GLASGOW_HASKELL__ <= 810+  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker+#endif++-- | Maybe return a list of Bools that say whether a type family was declared+-- injective in the corresponding type arguments. Length of the list is equal to+-- the number of arguments (including implicit kind/coercion arguments).+-- True on position+-- N means that a function is injective in its Nth argument. False means it is+-- not.+tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)+              -> TcM Injectivity+tcInjectivity _ Nothing+  = return NotInjective++  -- User provided an injectivity annotation, so for each tyvar argument we+  -- check whether a type family was declared injective in that argument. We+  -- return a list of Bools, where True means that corresponding type variable+  -- was mentioned in lInjNames (type family is injective in that argument) and+  -- False means that it was not mentioned in lInjNames (type family is not+  -- injective in that type variable). We also extend injectivity information to+  -- kind variables, so if a user declares:+  --+  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a+  --+  -- then we mark both `a` and `k1` as injective.+  -- NB: the return kind is considered to be *input* argument to a type family.+  -- Since injectivity allows to infer input arguments from the result in theory+  -- we should always mark the result kind variable (`k3` in this example) as+  -- injective.  The reason is that result type has always an assigned kind and+  -- therefore we can always infer the result kind if we know the result type.+  -- But this does not seem to be useful in any way so we don't do it.  (Another+  -- reason is that the implementation would not be straightforward.)+tcInjectivity tcbs (Just (L loc (InjectivityAnn _ _ lInjNames)))+  = setSrcSpan loc $+    do { let tvs = binderVars tcbs+       ; dflags <- getDynFlags+       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)+                 (text "Illegal injectivity annotation" $$+                  text "Use TypeFamilyDependencies to allow this")+       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames+       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds+       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars+                        closeOverKinds (mkVarSet inj_tvs)+       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs+       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs+                                       , ppr inj_ktvs, ppr inj_bools ])+       ; return $ Injective inj_bools }++tcTySynRhs :: RolesInfo -> Name+           -> LHsType GhcRn -> TcM TyCon+tcTySynRhs roles_info tc_name hs_ty+  = bindTyClTyVars tc_name $ \ _ binders res_kind ->+    do { env <- getLclEnv+       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))+       ; rhs_ty <- pushLevelAndSolveEqualities skol_info (binderVars binders) $+                   tcCheckLHsType hs_ty (TheKind res_kind)++         -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType+         -- Example: (typecheck/should_fail/T17567)+         --   type T = forall a. Proxy a+         -- The kind of `a` is unconstrained.+       ; dvs <- candidateQTyVarsOfType rhs_ty+       ; let mk_doc tidy_env = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty+                                  ; return ( tidy_env2+                                           , sep [ text "the type synonym right-hand side:"+                                                 , ppr rhs_ty ] ) }+       ; doNotQuantifyTyVars dvs mk_doc++       ; ze <- mkEmptyZonkEnv NoFlexi+       ; rhs_ty <- zonkTcTypeToTypeX ze rhs_ty+       ; let roles = roles_info tc_name+       ; 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])+  -- NB: not used for newtype/data instances (whether associated or not)+tcDataDefn err_ctxt roles_info tc_name+           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                       , dd_ctxt = ctxt+                       , dd_kindSig = mb_ksig  -- Already in tc's kind+                                               -- via inferInitialKinds+                       , dd_cons = cons+                       , dd_derivs = derivs })+  = bindTyClTyVars tc_name $ \ tctc tycon_binders res_kind ->+       -- 'tctc' is a 'TcTyCon' and has the 'tcTyConScopedTyVars' that we need+       -- unlike the finalized 'tycon' defined above which is an 'AlgTyCon'+       --+       -- The TyCon tyvars must scope over+       --    - the stupid theta (dd_ctxt)+       --    - for H98 constructors only, the ConDecl+       -- But it does no harm to bring them into scope+       -- over GADT ConDecls as well; and it's awkward not to+    do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons+         -- see Note [Datatype return kinds]+       ; (extra_bndrs, final_res_kind) <- etaExpandAlgTyCon tycon_binders res_kind++       ; tcg_env <- getGblEnv+       ; let hsc_src = tcg_src tcg_env+       ; unless (mk_permissive_kind hsc_src cons) $+         checkDataKindSig (DataDeclSort new_or_data) final_res_kind++       ; let skol_tvs = binderVars tycon_binders+       ; stupid_tc_theta <- pushLevelAndSolveEqualities skol_info skol_tvs $+                            tcHsContext ctxt++       -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType+       -- Example: (typecheck/should_fail/T17567StupidTheta)+       --   data (forall a. a b ~ a c) => T b c+       -- The kind of 'a' is unconstrained.+       ; dvs <- candidateQTyVarsOfTypes stupid_tc_theta+       ; let mk_doc tidy_env+               = do { (tidy_env2, theta) <- zonkTidyTcTypes tidy_env stupid_tc_theta+                    ; return ( tidy_env2+                             , sep [ text "the datatype context:"+                                   , pprTheta theta ] ) }+       ; doNotQuantifyTyVars dvs mk_doc++       ; ze              <- mkEmptyZonkEnv NoFlexi+       ; stupid_theta    <- zonkTcTypesToTypesX ze stupid_tc_theta++             -- Check that we don't use kind signatures without the extension+       ; kind_signatures <- xoptM LangExt.KindSignatures+       ; when (isJust mb_ksig) $+         checkTc (kind_signatures) (badSigTyDecl tc_name)++       ; tycon <- fixM $ \ rec_tycon -> do+             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs+                   roles       = roles_info tc_name+             ; data_cons <- tcConDecls+                              new_or_data DDataType+                              rec_tycon final_bndrs final_res_kind+                              cons+             ; tc_rhs    <- mk_tc_rhs hsc_src rec_tycon data_cons+             ; tc_rep_nm <- newTyConRepName tc_name+             ; return (mkAlgTyCon tc_name+                                  final_bndrs+                                  final_res_kind+                                  roles+                                  (fmap unLoc cType)+                                  stupid_theta tc_rhs+                                  (VanillaAlgTyCon tc_rep_nm)+                                  gadt_syntax) }+       ; let deriv_info = DerivInfo { di_rep_tc = tycon+                                    , di_scoped_tvs = tcTyConScopedTyVars tctc+                                    , di_clauses = derivs+                                    , di_ctxt = err_ctxt }+       ; 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.+    --+    -- Note that this is only a property that data type declarations possess,+    -- so one could not have, say, a data family instance in an hsig file that+    -- has kind `Bool`. Therefore, this check need only occur in the code that+    -- typechecks data type declarations.+    mk_permissive_kind HsigFile [] = True+    mk_permissive_kind _ _ = False++    -- In hs-boot, a 'data' declaration with no constructors+    -- indicates a nominally distinct abstract data type.+    mk_tc_rhs HsBootFile _ []+      = return AbstractTyCon++    mk_tc_rhs HsigFile _ [] -- ditto+      = return AbstractTyCon++    mk_tc_rhs _ tycon data_cons+      = case new_or_data of+          DataType -> return (mkDataTyConRhs data_cons)+          NewType  -> ASSERT( not (null data_cons) )+                      mkNewTyConRhs tc_name tycon (head data_cons)+++-------------------------+kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()+-- Used for the equations of a closed type family only+-- Not used for data/type instances+kcTyFamInstEqn tc_fam_tc+    (L loc (FamEqn { feqn_tycon = L _ eqn_tc_name+                   , feqn_bndrs = outer_bndrs+                   , feqn_pats  = hs_pats+                   , feqn_rhs   = hs_rhs_ty }))+  = setSrcSpanA loc $+    do { traceTc "kcTyFamInstEqn" (vcat+           [ text "tc_name ="    <+> ppr eqn_tc_name+           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)+           , text "feqn_bndrs =" <+> ppr outer_bndrs+           , text "feqn_pats ="  <+> ppr hs_pats ])++       ; checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats++       ; discardResult $+         bindOuterFamEqnTKBndrs_Q_Tv outer_bndrs $+         do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats+            ; tcCheckLHsType hs_rhs_ty (TheKind res_kind) }+             -- Why "_Tv" here?  Consider (#14066)+             --  type family Bar x y where+             --      Bar (x :: a) (y :: b) = Int+             --      Bar (x :: c) (y :: d) = Bool+             -- During kind-checking, a,b,c,d should be TyVarTvs and unify appropriately+    }++--------------------------+tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn+               -> TcM (KnotTied CoAxBranch)+-- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families+-- (typechecked here) have TyFamInstEqns++tcTyFamInstEqn fam_tc mb_clsinfo+    (L loc (FamEqn { feqn_tycon  = L _ eqn_tc_name+                   , feqn_bndrs  = outer_bndrs+                   , feqn_pats   = hs_pats+                   , feqn_rhs    = hs_rhs_ty }))+  = setSrcSpanA loc $+    do { traceTc "tcTyFamInstEqn" $+         vcat [ ppr loc, ppr fam_tc <+> ppr hs_pats+              , text "fam tc bndrs" <+> pprTyVars (tyConTyVars fam_tc)+              , case mb_clsinfo of+                  NotAssociated {} -> empty+                  InClsInst { ai_class = cls } -> text "class" <+> ppr cls <+> pprTyVars (classTyVars cls) ]++       ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats++       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo+                                      outer_bndrs hs_pats hs_rhs_ty+       -- Don't print results they may be knot-tied+       -- (tcFamInstEqnGuts zonks to Type)+       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty+                              (map (const Nominal) qtvs)+                              (locA loc)) }++checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg tm ty] -> TcM ()+checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats =+  do { -- Ensure that each equation's type constructor is for the right+       -- type family.  E.g. barf on+       --    type family F a where { G Int = Bool }+       let tc_fam_tc_name = getName tc_fam_tc+     ; checkTc (tc_fam_tc_name == eqn_tc_name) $+               wrongTyFamName tc_fam_tc_name eqn_tc_name++       -- Check the arity of visible arguments+       -- If we wait until validity checking, we'll get kind errors+       -- below when an arity error will be much easier to understand.+     ; let vis_arity = length (tyConVisibleTyVars tc_fam_tc)+           vis_pats  = numVisibleArgs hs_pats+     ; checkTc (vis_pats == vis_arity) $+               wrongNumberOfParmsErr vis_arity+     }++{- Note [Instantiating a family tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's possible that kind-checking the result of a family tycon applied to+its patterns will instantiate the tycon further. For example, we might+have++  type family F :: k where+    F = Int+    F = Maybe++After checking (F :: forall k. k) (with no visible patterns), we still need+to instantiate the k. With data family instances, this problem can be even+more intricate, due to Note [Arity of data families] in GHC.Core.FamInstEnv. See+indexed-types/should_compile/T12369 for an example.++So, the kind-checker must return the new skolems and args (that is, Type+or (Type -> Type) for the equations above) and the instantiated kind.++Note [Generalising in tcTyFamInstEqnGuts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have something like+  type instance forall (a::k) b. F (Proxy t1) _ = rhs++Then  imp_vars = [k], exp_bndrs = [a::k, b]++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++The wildcards are particularly awkward: they may need to be quantified+  - before the explicit variables k,a,b+  - after them+  - or even interleaved with them+  c.f. Note [Naughty quantification candidates] in GHC.Tc.Utils.TcMType++So, we use bindOuterFamEqnTKBndrs (which does not create an implication for+the telescope), and generalise over /all/ the variables in the LHS,+without treating the explicitly-quanfitifed ones specially. Wrinkles:++ - When generalising, include the explicit 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++ - We still want to complain about a bad telescope among the user-specified+   variables.  So in checkFamTelescope we emit an implication constraint+   quantifying only over them, purely so that we get a good telescope error.++  - 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.++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+                   -> HsOuterFamEqnTyVarBndrs GhcRn     -- Implicit and explicit binders+                   -> HsTyPats GhcRn                    -- Patterns+                   -> LHsType GhcRn                     -- RHS+                   -> TcM ([TyVar], [TcType], TcType)   -- (tyvars, pats, rhs)+-- Used only for type families, not data families+tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty+  = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc)++       -- By now, for type families (but not data families) we should+       -- have checked that the number of patterns matches tyConArity++       -- This code is closely related to the code+       -- in GHC.Tc.Gen.HsType.kcCheckDeclHeader_cusk+       ; (tclvl, wanted, (outer_tvs, (lhs_ty, rhs_ty)))+               <- pushLevelAndSolveEqualitiesX "tcTyFamInstEqnGuts" $+                  bindOuterFamEqnTKBndrs outer_hs_bndrs             $+                  do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats+                       -- Ensure that the instance is consistent with its+                       -- parent class (#16008)+                     ; addConsistencyConstraints mb_clsinfo lhs_ty+                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty (TheKind rhs_kind)+                     ; return (lhs_ty, rhs_ty) }++       -- 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!++       -- See Note [Generalising in tcTyFamInstEqnGuts]+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys outer_tvs)+       ; qtvs <- quantifyTyVars dvs+       ; reportUnsolvedEqualities FamInstSkol qtvs tclvl wanted+       ; checkFamTelescope tclvl outer_hs_bndrs outer_tvs++       ; traceTc "tcTyFamInstEqnGuts 2" $+         vcat [ ppr fam_tc+              , text "lhs_ty"     <+> ppr lhs_ty+              , text "qtvs"       <+> pprTyVars qtvs ]++       -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType+       -- Example: typecheck/should_fail/T17301+       ; dvs_rhs <- candidateQTyVarsOfType rhs_ty+       ; let mk_doc tidy_env+               = do { (tidy_env2, rhs_ty) <- zonkTidyTcType tidy_env rhs_ty+                    ; return ( tidy_env2+                             , sep [ text "type family equation right-hand side:"+                                   , ppr rhs_ty ] ) }+       ; doNotQuantifyTyVars dvs_rhs mk_doc++       ; ze         <- mkEmptyZonkEnv NoFlexi+       ; (ze, qtvs) <- zonkTyBndrsX      ze qtvs+       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty+       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty++       ; let pats = unravelFamInstPats lhs_ty+             -- Note that we do this after solveEqualities+             -- so that any strange coercions inside lhs_ty+             -- have been solved before we attempt to unravel it+       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)+       ; return (qtvs, pats, rhs_ty) }+++checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn+                  -> [TcTyVar] -> TcM ()+-- Emit a constraint (forall a b c. <empty>), so that+-- we will do telescope-checking on a,b,c+-- See Note [Generalising in tcTyFamInstEqnGuts]+checkFamTelescope tclvl hs_outer_bndrs outer_tvs+  | HsOuterExplicit { hso_bndrs = bndrs } <- hs_outer_bndrs+  , (b_first : _) <- bndrs+  , let b_last    = last bndrs+        skol_info = ForAllSkol (fsep (map ppr bndrs))+  = setSrcSpan (combineSrcSpans (getLocA b_first) (getLocA b_last)) $+    emitResidualTvConstraint skol_info outer_tvs tclvl emptyWC+  | otherwise+  = return ()++-----------------+unravelFamInstPats :: TcType -> [TcType]+-- Decompose fam_app to get the argument patterns+--+-- We expect fam_app to look like (F t1 .. tn)+-- tcFamTyPats is capable of returning ((F ty1 |> co) ty2),+-- but that can't happen here because we already checked the+-- arity of F matches the number of pattern+unravelFamInstPats fam_app+  = case splitTyConApp_maybe fam_app of+      Just (_, pats) -> pats+      Nothing -> panic "unravelFamInstPats: Ill-typed LHS of family instance"+        -- The Nothing case cannot happen for type families, because+        -- we don't call unravelFamInstPats until we've solved the+        -- equalities. For data families, it shouldn't happen either,+        -- we need to fail hard and early if it does. See trac issue #15905+        -- for an example of this happening.++addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()+-- In the corresponding positions of the class and type-family,+-- ensure the family argument is the same as the class argument+--   E.g    class C a b c d where+--             F c x y a :: Type+-- Here the first  arg of F should be the same as the third of C+--  and the fourth arg of F should be the same as the first of C+--+-- We emit /Derived/ constraints (a bit like fundeps) to encourage+-- unification to happen, but without actually reporting errors.+-- If, despite the efforts, corresponding positions do not match,+-- checkConsistentFamInst will complain+addConsistencyConstraints mb_clsinfo fam_app+  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo+  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app+  = do { let eqs = [ (cls_ty, pat)+                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats+                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]+       ; traceTc "addConsistencyConstraints" (ppr eqs)+       ; emitDerivedEqs AssocFamPatOrigin eqs }+    -- Improve inference+    -- Any mis-match is reports by checkConsistentFamInst+  | otherwise+  = return ()++{- Note [Constraints in patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This isn't the whole story. See comment in tcFamTyPats.++At first glance, it seems there is a complicated story to tell in tcFamTyPats+around constraint solving. After all, type family patterns can now do+GADT pattern-matching, which is jolly complicated. But, there's a key fact+which makes this all simple: everything is at top level! There cannot+be untouchable type variables. There can't be weird interaction between+case branches. There can't be global skolems.++This means that the semantics of type-level GADT matching is a little+different than term level. If we have++  data G a where+    MkGBool :: G Bool++And then++  type family F (a :: G k) :: k+  type instance F MkGBool = True++we get++  axF : F Bool (MkGBool <Bool>) ~ True++Simple! No casting on the RHS, because we can affect the kind parameter+to F.++If we ever introduce local type families, this all gets a lot more+complicated, and will end up looking awfully like term-level GADT+pattern-matching.+++** The new story **++Here is really what we want:++The matcher really can't deal with covars in arbitrary spots in coercions.+But it can deal with covars that are arguments to GADT data constructors.+So we somehow want to allow covars only in precisely those spots, then use+them as givens when checking the RHS. TODO (RAE): Implement plan.++Note [Quantified kind variables of a family pattern]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   type family KindFam (p :: k1) (q :: k1)+           data T :: Maybe k1 -> k2 -> *+           type instance KindFam (a :: Maybe k) b = T a b -> Int+The HsBSig for the family patterns will be ([k], [a])++Then in the family instance we want to+  * Bring into scope [ "k" -> k:*, "a" -> a:k ]+  * Kind-check the RHS+  * Quantify the type instance over k and k', as well as a,b, thus+       type instance [k, k', a:Maybe k, b:k']+                     KindFam (Maybe k) k' a b = T k k' a b -> Int++Notice that in the third step we quantify over all the visibly-mentioned+type variables (a,b), but also over the implicitly mentioned kind variables+(k, k').  In this case one is bound explicitly but often there will be+none. The role of the kind signature (a :: Maybe k) is to add a constraint+that 'a' must have that kind, and to bring 'k' into scope.++++************************************************************************+*                                                                      *+               Data types+*                                                                      *+************************************************************************+-}++dataDeclChecks :: Name -> NewOrData+               -> Maybe (LHsContext GhcRn) -> [LConDecl GhcRn]+               -> TcM Bool+dataDeclChecks tc_name new_or_data mctxt cons+  = do { let stupid_theta = fromMaybeContext mctxt+         -- Check that we don't use GADT syntax in H98 world+       ;  gadtSyntax_ok <- xoptM LangExt.GADTSyntax+       ; let gadt_syntax = consUseGadtSyntax cons+       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)++           -- Check that the stupid theta is empty for a GADT-style declaration+       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)++         -- Check that a newtype has exactly one constructor+         -- Do this before checking for empty data decls, so that+         -- we don't suggest -XEmptyDataDecls for newtypes+       ; checkTc (new_or_data == DataType || isSingleton cons)+                (newtypeConError tc_name (length cons))++         -- Check that there's at least one condecl,+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls+       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls+       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?+       ; checkTc (not (null cons) || empty_data_decls || is_boot)+                 (emptyConDeclsErr tc_name)+       ; return gadt_syntax }+++-----------------------------------+consUseGadtSyntax :: [LConDecl GhcRn] -> Bool+consUseGadtSyntax (L _ (ConDeclGADT {}) : _) = True+consUseGadtSyntax _                          = False+                 -- All constructors have same shape++-----------------------------------+data DataDeclInfo+  = DDataType      -- data T a b = T1 a | T2 b+  | DDataInstance  -- data instance D [a] = D1 a | D2+       Type        --   The header D [a]++mkDDHeaderTy :: DataDeclInfo -> TyCon -> [TyConBinder] -> Type+mkDDHeaderTy dd_info rep_tycon tc_bndrs+  = case dd_info of+      DDataType -> mkTyConApp rep_tycon $+                   mkTyVarTys (binderVars tc_bndrs)+      DDataInstance header_ty -> header_ty++tcConDecls :: NewOrData+           -> DataDeclInfo+           -> KnotTied TyCon            -- Representation TyCon+           -> [TyConBinder]             -- Binders of representation TyCon+           -> TcKind                    -- Result kind+           -> [LConDecl GhcRn] -> TcM [DataCon]+tcConDecls new_or_data dd_info rep_tycon tmpl_bndrs res_kind+  = concatMapM $ addLocMA $+    tcConDecl new_or_data dd_info rep_tycon tmpl_bndrs res_kind+              (mkTyConTagMap rep_tycon)+    -- mkTyConTagMap: it's important that we pay for tag allocation here,+    -- once per TyCon. See Note [Constructor tag allocation], fixes #14657++tcConDecl :: NewOrData+          -> DataDeclInfo+          -> KnotTied TyCon   -- Representation tycon. Knot-tied!+          -> [TyConBinder]    -- Binders of representation TyCon+          -> TcKind           -- Result kind+          -> NameEnv ConTag+          -> ConDecl GhcRn+          -> TcM [DataCon]++tcConDecl new_or_data dd_info rep_tycon tc_bndrs res_kind tag_map+          (ConDeclH98 { con_name = lname@(L _ name)+                      , con_ex_tvs = explicit_tkv_nms+                      , con_mb_cxt = hs_ctxt+                      , con_args = hs_args })+  = addErrCtxt (dataConCtxt [lname]) $+    do { -- NB: the tyvars from the declaration header are in scope++         -- Get hold of the existential type variables+         -- e.g. data T a = forall k (b::k) f. MkT a (f b)+         -- Here tc_bndrs = {a}+         --      hs_qvars = HsQTvs { hsq_implicit = {k}+         --                        , hsq_explicit = {f,b} }++       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])++       ; (tclvl, wanted, (exp_tvbndrs, (ctxt, arg_tys, field_lbls, stricts)))+           <- pushLevelAndSolveEqualitiesX "tcConDecl:H98"  $+              tcExplicitTKBndrs explicit_tkv_nms            $+              do { ctxt <- tcHsContext hs_ctxt+                 ; let exp_kind = getArgExpKind new_or_data res_kind+                 ; btys <- tcConH98Args exp_kind hs_args+                 ; field_lbls <- lookupConstructorFields name+                 ; let (arg_tys, stricts) = unzip btys+                 ; return (ctxt, arg_tys, field_lbls, stricts)+                 }+++       ; let tc_tvs   = binderVars tc_bndrs+             fake_ty  = mkSpecForAllTys  tc_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 univ_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_tvbndrs 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 fake_ty++       ; let skol_tvs = tc_tvs ++ kvs ++ binderVars exp_tvbndrs+       ; reportUnsolvedEqualities skol_info skol_tvs tclvl wanted+             -- The skol_info claims that all the variables are bound+             -- by the data constructor decl, whereas actually the+             -- univ_tvs are bound by the data type decl itself.  It+             -- would be better to have a doubly-nested implication.+             -- But that just doesn't seem worth it.+             -- See test dependent/should_fail/T13780a++       -- Zonk to Types+       ; ze                  <- mkEmptyZonkEnv NoFlexi+       ; (ze, qkvs)          <- zonkTyBndrsX              ze kvs+       ; (ze, user_qtvbndrs) <- zonkTyVarBindersX         ze exp_tvbndrs+       ; arg_tys             <- zonkScaledTcTypesToTypesX ze arg_tys+       ; ctxt                <- zonkTcTypesToTypesX       ze ctxt++       -- 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 tc_bndrs+             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+             user_res_ty = mkDDHeaderTy dd_info rep_tycon tc_bndrs++       ; 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+                            tc_tvs ex_tvs user_tvbs+                            [{- no eq_preds -}] ctxt arg_tys+                            user_res_ty rep_tycon tag_map+                  -- 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.++       ; return [dc] }+  where+    skol_info = DataConSkol name++tcConDecl new_or_data dd_info rep_tycon tc_bndrs _res_kind tag_map+  -- NB: don't use res_kind here, as it's ill-scoped. Instead,+  -- we get the res_kind by typechecking the result type.+          (ConDeclGADT { con_names = names+                       , con_bndrs = L _ outer_hs_bndrs+                       , con_mb_cxt = cxt, con_g_args = hs_args+                       , con_res_ty = hs_res_ty })+  = addErrCtxt (dataConCtxt names) $+    do { traceTc "tcConDecl 1 gadt" (ppr names)+       ; let (L _ name : _) = names++       ; (tclvl, wanted, (outer_bndrs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))+           <- pushLevelAndSolveEqualitiesX "tcConDecl:GADT" $+              tcOuterTKBndrs skol_info outer_hs_bndrs       $+              do { ctxt <- tcHsContext cxt+                 ; (res_ty, res_kind) <- tcInferLHsTypeKind hs_res_ty+                         -- See Note [GADT return kinds]++                 -- For data instances (only), ensure that the return type,+                 -- res_ty, is a substitution instance of the header.+                 -- See Note [GADT return types]+                 ; case dd_info of+                      DDataType -> return ()+                      DDataInstance hdr_ty ->+                        do { (subst, _meta_tvs) <- newMetaTyVars (binderVars tc_bndrs)+                           ; let head_shape = substTy subst hdr_ty+                           ; discardResult $+                             popErrCtxt $  -- Drop dataConCtxt+                             addErrCtxt (dataConResCtxt names) $+                             unifyType Nothing res_ty head_shape }++                   -- See Note [Datatype return kinds]+                 ; let exp_kind = getArgExpKind new_or_data res_kind+                 ; btys <- tcConGADTArgs exp_kind hs_args++                 ; let (arg_tys, stricts) = unzip btys+                 ; field_lbls <- lookupConstructorFields name+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)+                 }++       ; outer_tv_bndrs <- scopedSortOuter outer_bndrs++       ; tkvs <- kindGeneralizeAll (mkInvisForAllTys outer_tv_bndrs $+                                    mkPhiTy ctxt $+                                    mkVisFunTys arg_tys $+                                    res_ty)+       ; traceTc "tcConDecl:GADT" (ppr names $$ ppr res_ty $$ ppr tkvs)+       ; reportUnsolvedEqualities skol_info tkvs tclvl wanted++       ; let tvbndrs =  mkTyVarBinders InferredSpec tkvs ++ outer_tv_bndrs++             -- Zonk to Types+       ; ze            <- mkEmptyZonkEnv NoFlexi+       ; (ze, tvbndrs) <- zonkTyVarBindersX         ze tvbndrs+       ; arg_tys       <- zonkScaledTcTypesToTypesX ze arg_tys+       ; ctxt          <- zonkTcTypesToTypesX       ze ctxt+       ; res_ty        <- zonkTcTypeToTypeX         ze res_ty++       ; let res_tmpl = mkDDHeaderTy dd_info rep_tycon tc_bndrs+             (univ_tvs, ex_tvs, tvbndrs', eq_preds, arg_subst)+               = rejigConRes tc_bndrs res_tmpl tvbndrs res_ty+             -- See Note [rejigConRes]++             ctxt'      = substTys arg_subst ctxt+             arg_tys'   = substScaledTys arg_subst arg_tys+             res_ty'    = substTy  arg_subst res_ty++       -- 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+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix+                            rep_nm+                            stricts Nothing field_lbls+                            univ_tvs ex_tvs tvbndrs' eq_preds+                            ctxt' arg_tys' res_ty' rep_tycon tag_map+                  -- 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.+             }+       ; mapM buildOneDataCon names }+  where+    skol_info = DataConSkol (unLoc (head names))++{- Note [GADT return types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data family T :: forall k. k -> Type+  data instance T (a :: Type) where+    MkT :: forall b. T b++What kind does `b` have in the signature for MkT?+Since the return type must be an instance of the type in the header,+we must have (b :: Type), but you can't tell that by looking only at+the type of the data constructor; you have to look at the header too.+If you wrote it out fully, it'd look like+  data instance T @Type (a :: Type) where+    MkT :: forall (b::Type). T @Type b++We could reject the program, and expect the user to add kind+annotations to `MkT` to restrict the signature.  But an easy and+helpful alternative is this: simply instantiate the type from the+header with fresh unification variables, and unify with the return+type of `MkT`. That will force `b` to have kind `Type`.  See #8707+and #14111.++Wrikles+* At first sight it looks as though this would completely subsume the+  return-type check in checkValidDataCon.  But it does not. Suppose we+  have+     data instance T [a] where+        MkT :: T (F (Maybe a))++  where F is a type function.  Then maybe (F (Maybe a)) evaluates to+  [a], so unifyType will succeed.  But we discard the coercion+  returned by unifyType; and we really don't want to accept this+  program.  The check in checkValidDataCon will, however, reject it.+  TL;DR: keep the check in checkValidDataCon.++* Consider a data type, rather than a data instance, declaration+     data S a where { MkS :: b -> S [b]  }+  In tcConDecl, S is knot-tied, so we don't want to unify (S alpha)+  with (S [b]). To put it another way, unifyType should never see a+  TcTycon.  Simple solution: do *not* do the extra unifyType for+  data types (DDataType) only for data instances (DDataInstance); in+  the latter the family constructor is not knot-tied so there is no+  problem.++* Consider this (from an earlier form of GHC itself):++     data Pass = Parsed | ...+     data GhcPass (c :: Pass) where+       GhcPs :: GhcPs+       ...+     type GhcPs   = GhcPass 'Parsed++   Now GhcPs and GhcPass are mutually recursive. If we did unifyType+   for datatypes like GhcPass, we would not be able to expand the type+   synonym (it'd still be a TcTyCon).  So again, we don't do unifyType+   for data types; we leave it to checkValidDataCon.++   We /do/ perform the unifyType for data /instances/, but a data+   instance doesn't declare a new (user-visible) type constructor, so+   there is no mutual recursion with type synonyms to worry about.+   All good.++   TL;DR we do support mutual recursion between type synonyms and+   data type/instance declarations, as above.++Note [GADT return kinds]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type family Star where Star = Type+   data T :: Type where+      MkT :: Int -> T++If, for some stupid reason, tcInferLHsTypeKind on the return type of+MkT returned (T |> ax, Star), then the return-type check in+checkValidDataCon would reject the decl (although of course there is+nothing wrong with it).  We are implicitly requiring tha+tcInferLHsTypeKind doesn't any gratuitous top-level casts.+-}++-- | Produce an "expected kind" for the arguments of a data/newtype.+-- If the declaration is indeed for a newtype,+-- then this expected kind will be the kind provided. Otherwise,+-- it is OpenKind for datatypes and liftedTypeKind.+-- Why do we not check for -XUnliftedNewtypes? See point <Error Messages>+-- in Note [Implementation of UnliftedNewtypes]+getArgExpKind :: NewOrData -> Kind -> ContextKind+getArgExpKind NewType res_ki = TheKind res_ki+getArgExpKind DataType _     = OpenKind++tcConIsInfixH98 :: Name+             -> HsConDeclH98Details GhcRn+             -> TcM Bool+tcConIsInfixH98 _   details+  = case details of+           InfixCon{}  -> return True+           RecCon{}    -> return False+           PrefixCon{} -> return False++tcConIsInfixGADT :: Name+             -> HsConDeclGADTDetails GhcRn+             -> TcM Bool+tcConIsInfixGADT con details+  = case details of+           RecConGADT{} -> return False+           PrefixConGADT arg_tys       -- See Note [Infix GADT constructors]+               | isSymOcc (getOccName con)+               , [_ty1,_ty2] <- map hsScaledThing arg_tys+                  -> do { fix_env <- getFixityEnv+                        ; return (con `elemNameEnv` fix_env) }+               | otherwise -> return False++tcConH98Args :: ContextKind  -- expected kind of arguments+                             -- always OpenKind for datatypes, but unlifted newtypes+                             -- might have a specific kind+             -> HsConDeclH98Details GhcRn+             -> TcM [(Scaled TcType, HsSrcBang)]+tcConH98Args exp_kind (PrefixCon _ btys)+  = mapM (tcConArg exp_kind) btys+tcConH98Args exp_kind (InfixCon bty1 bty2)+  = do { bty1' <- tcConArg exp_kind bty1+       ; bty2' <- tcConArg exp_kind bty2+       ; return [bty1', bty2'] }+tcConH98Args exp_kind (RecCon fields)+  = tcRecConDeclFields exp_kind fields++tcConGADTArgs :: ContextKind  -- expected kind of arguments+                              -- always OpenKind for datatypes, but unlifted newtypes+                              -- might have a specific kind+              -> HsConDeclGADTDetails GhcRn+              -> TcM [(Scaled TcType, HsSrcBang)]+tcConGADTArgs exp_kind (PrefixConGADT btys)+  = mapM (tcConArg exp_kind) btys+tcConGADTArgs exp_kind (RecConGADT fields)+  = tcRecConDeclFields exp_kind fields++tcConArg :: ContextKind  -- expected kind for args; always OpenKind for datatypes,+                         -- but might be an unlifted type with UnliftedNewtypes+         -> HsScaled GhcRn (LHsType GhcRn) -> TcM (Scaled TcType, HsSrcBang)+tcConArg exp_kind (HsScaled w bty)+  = do  { traceTc "tcConArg 1" (ppr bty)+        ; arg_ty <- tcCheckLHsType (getBangType bty) exp_kind+        ; w' <- tcDataConMult w+        ; traceTc "tcConArg 2" (ppr bty)+        ; return (Scaled w' arg_ty, getBangStrictness bty) }++tcRecConDeclFields :: ContextKind+                   -> LocatedL [LConDeclField GhcRn]+                   -> TcM [(Scaled TcType, HsSrcBang)]+tcRecConDeclFields exp_kind fields+  = mapM (tcConArg exp_kind) btys+  where+    -- We need a one-to-one mapping from field_names to btys+    combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f)))+                   (unLoc fields)+    explode (ns,ty) = zip ns (repeat ty)+    exploded = concatMap explode combined+    (_,btys) = unzip exploded++tcDataConMult :: HsArrow GhcRn -> TcM Mult+tcDataConMult arr@(HsUnrestrictedArrow _) = do+  -- See Note [Function arrows in GADT constructors]+  linearEnabled <- xoptM LangExt.LinearTypes+  if linearEnabled then tcMult arr else return oneDataConTy+tcDataConMult arr = tcMult arr++{-+Note [Function arrows in GADT constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the absence of -XLinearTypes, we always interpret function arrows+in GADT constructor types as linear, even if the user wrote an+unrestricted arrow. See the "Without -XLinearTypes" section of the+linear types GHC proposal (#111). We opt to do this in the+typechecker, and not in an earlier pass, to ensure that the AST+matches what the user wrote (#18791).++Note [Infix GADT constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not currently have syntax to declare an infix constructor in GADT syntax,+but it makes a (small) difference to the Show instance.  So as a slightly+ad-hoc solution, we regard a GADT data constructor as infix if+  a) it is an operator symbol+  b) it has two arguments+  c) there is a fixity declaration for it+For example:+   infix 6 (:--:)+   data T a where+     (:--:) :: t1 -> t2 -> T Int+++Note [rejigConRes]+~~~~~~~~~~~~~~~~~~+There is a delicacy around checking the return types of a datacon. The+central problem is dealing with a declaration like++  data T a where+    MkT :: T a -> Q a++Note that the return type of MkT is totally bogus. When creating the T+tycon, we also need to create the MkT datacon, which must have a "rejigged"+return type. That is, the MkT datacon's type must be transformed to have+a uniform return type with explicit coercions for GADT-like type parameters.+This rejigging is what rejigConRes does. The problem is, though, that checking+that the return type is appropriate is much easier when done over *Type*,+not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully+defined yet.++So, we want to make rejigConRes lazy and then check the validity of+the return type in checkValidDataCon.  To do this we /always/ return a+6-tuple from rejigConRes (so that we can compute the return type from it, which+checkValidDataCon needs), but the first three fields may be bogus if+the return type isn't valid (the last equation for rejigConRes).++This is better than an earlier solution which reduced the number of+errors reported in one pass.  See #7175, and #10836.+-}++-- Example+--   data instance T (b,c) where+--      TI :: forall e. e -> T (e,e)+--+-- The representation tycon looks like this:+--   data :R7T b c where+--      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1+-- In this case orig_res_ty = T (e,e)++rejigConRes :: [KnotTied TyConBinder]  -- Template for result type; e.g.+            -> KnotTied Type           -- data instance T [a] b c ...+                                       --      gives template ([a,b,c], T [a] b c)+            -> [InvisTVBinder]    -- The constructor's type variables (both inferred and user-written)+            -> KnotTied Type      -- res_ty+            -> ([TyVar],          -- Universal+                [TyVar],          -- Existential (distinct OccNames from univs)+                [InvisTVBinder],  -- The constructor's rejigged, user-written+                                  -- type variables+                [EqSpec],         -- Equality predicates+                TCvSubst)         -- Substitution to apply to argument types+        -- We don't check that the TyCon given in the ResTy is+        -- the same as the parent tycon, because checkValidDataCon will do it+-- NB: All arguments may potentially be knot-tied+rejigConRes tc_tvbndrs res_tmpl dc_tvbndrs res_ty+        -- E.g.  data T [a] b c where+        --         MkT :: forall x y z. T [(x,y)] z z+        -- The {a,b,c} are the tc_tvs, and the {x,y,z} are the dc_tvs+        --     (NB: unlike the H98 case, the dc_tvs are not all existential)+        -- Then we generate+        --      Univ tyvars     Eq-spec+        --          a              a~(x,y)+        --          b              b~z+        --          z+        -- Existentials are the leftover type vars: [x,y]+        -- The user-written type variables are what is listed in the forall:+        --   [x, y, z] (all specified). We must rejig these as well.+        --   See Note [DataCon user type variable binders] in GHC.Core.DataCon.+        -- So we return ( [a,b,z], [x,y]+        --              , [], [x,y,z]+        --              , [a~(x,y),b~z], <arg-subst> )+  | Just subst <- tcMatchTy res_tmpl res_ty+  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tc_tvs dc_tvs subst+        raw_ex_tvs = dc_tvs `minusList` univ_tvs+        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs++        -- After rejigging the existential tyvars, the resulting substitution+        -- gives us exactly what we need to rejig the user-written tyvars,+        -- since the dcUserTyVarBinders invariant guarantees that the+        -- substitution has *all* the tyvars in its domain.+        -- See Note [DataCon user type variable binders] in GHC.Core.DataCon.+        subst_user_tvs  = mapVarBndrs (getTyVar "rejigConRes" . substTyVar arg_subst)+        substed_tvbndrs = subst_user_tvs dc_tvbndrs++        substed_eqs = map (substEqSpec arg_subst) raw_eqs+    in+    (univ_tvs, substed_ex_tvs, substed_tvbndrs, substed_eqs, arg_subst)++  | otherwise+        -- If the return type of the data constructor doesn't match the parent+        -- type constructor, or the arity is wrong, the tcMatchTy will fail+        --    e.g   data T a b where+        --            T1 :: Maybe a   -- Wrong tycon+        --            T2 :: T [a]     -- Wrong arity+        -- We are detect that later, in checkValidDataCon, but meanwhile+        -- we must do *something*, not just crash.  So we do something simple+        -- albeit bogus, relying on checkValidDataCon to check the+        --  bad-result-type error before seeing that the other fields look odd+        -- See Note [rejigConRes]+  = (tc_tvs, dc_tvs `minusList` tc_tvs, dc_tvbndrs, [], emptyTCvSubst)+  where+    dc_tvs = binderVars dc_tvbndrs+    tc_tvs = binderVars tc_tvbndrs++{- Note [mkGADTVars]+~~~~~~~~~~~~~~~~~~~~+Running example:++data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where+  MkT :: forall (x1 : *) (y :: x1) (z :: *).+         T x1 * (Proxy (y :: x1), z) z++We need the rejigged type to be++  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).+         forall (y :: x1) (z :: *).+         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)+      => T x1 k2 a b++You might naively expect that z should become a universal tyvar,+not an existential. (After all, x1 becomes a universal tyvar.)+But z has kind * while b has kind k2, so the return type+   T x1 k2 a z+is ill-kinded.  Another way to say it is this: the universal+tyvars must have exactly the same kinds as the tyConTyVars.++So we need an existential tyvar and a heterogeneous equality+constraint. (The b ~ z is a bit redundant with the k2 ~ * that+comes before in that b ~ z implies k2 ~ *. I'm sure we could do+some analysis that could eliminate k2 ~ *. But we don't do this+yet.)++The data con signature has already been fully kind-checked.+The return type++  T x1 * (Proxy (y :: x1), z) z+becomes+  qtkvs    = [x1 :: *, y :: x1, z :: *]+  res_tmpl = T x1 * (Proxy x1 y, z) z++We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We+know this match will succeed because of the validity check (actually done+later, but laziness saves us -- see Note [rejigConRes]).+Thus, we get++  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }++Now, we need to figure out what the GADT equalities should be. In this case,+we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a+renaming. The others should be GADT equalities. We also need to make+sure that the universally-quantified variables of the datacon match up+with the tyvars of the tycon, as required for Core context well-formedness.+(This last bit is why we have to rejig at all!)++`choose` walks down the tycon tyvars, figuring out what to do with each one.+It carries two substitutions:+  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables+    mentioned in the datacon signature.+  - r_sub's domain is *result* tyvars, names written by the programmer in+    the datacon signature. The final rejigged type will use these names, but+    the subst is still needed because sometimes the printed name of these variables+    is different. (See choose_tv_name, below.)++Before explaining the details of `choose`, let's just look at its operation+on our example:++  choose [] [] {} {} [k1, k2, a, b]+  -->          -- first branch of `case` statement+  choose+    univs:    [x1 :: *]+    eq_spec:  []+    t_sub:    {k1 |-> x1}+    r_sub:    {x1 |-> x1}+    t_tvs:    [k2, a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [k2 :: *, x1 :: *]+    eq_spec:  [k2 ~ *]+    t_sub:    {k1 |-> x1, k2 |-> k2}+    r_sub:    {x1 |-> x1}+    t_tvs:    [a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}+    r_sub:    {x1 |-> x1}+    t_tvs:    [b]+  -->          -- second branch of `case` statement+  choose+    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ b ~ z+              , a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}+    r_sub:    {x1 |-> x1}+    t_tvs:    []+  -->          -- end of recursion+  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]+  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]+  , {x1 |-> x1} )++`choose` looks up each tycon tyvar in the matching (it *must* be matched!).++* If it finds a bare result tyvar (the first branch of the `case`+  statement), it checks to make sure that the result tyvar isn't yet+  in the list of univ_tvs.  If it is in that list, then we have a+  repeated variable in the return type, and we in fact need a GADT+  equality.++* It then checks to make sure that the kind of the result tyvar+  matches the kind of the template tyvar. This check is what forces+  `z` to be existential, as it should be, explained above.++* Assuming no repeated variables or kind-changing, we wish to use the+  variable name given in the datacon signature (that is, `x1` not+  `k1`), not the tycon signature (which may have been made up by+  GHC). So, we add a mapping from the tycon tyvar to the result tyvar+  to t_sub.++* If we discover that a mapping in `subst` gives us a non-tyvar (the+  second branch of the `case` statement), then we have a GADT equality+  to create.  We create a fresh equality, but we don't extend any+  substitutions. The template variable substitution is meant for use+  in universal tyvar kinds, and these shouldn't be affected by any+  GADT equalities.++This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways+of simplifying it:++1) The first branch of the `case` statement is really an optimization, used+in order to get fewer GADT equalities. It might be possible to make a GADT+equality for *every* univ. tyvar, even if the equality is trivial, and then+either deal with the bigger type or somehow reduce it later.++2) This algorithm strives to use the names for type variables as specified+by the user in the datacon signature. If we always used the tycon tyvar+names, for example, this would be simplified. This change would almost+certainly degrade error messages a bit, though.+-}++-- ^ From information about a source datacon definition, extract out+-- what the universal variables and the GADT equalities should be.+-- See Note [mkGADTVars].+mkGADTVars :: [TyVar]    -- ^ The tycon vars+           -> [TyVar]    -- ^ The datacon vars+           -> TCvSubst   -- ^ The matching between the template result type+                         -- and the actual result type+           -> ( [TyVar]+              , [EqSpec]+              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,+                           -- and a subst to apply to the GADT equalities+                           -- and existentials.+mkGADTVars tmpl_tvs dc_tvs subst+  = choose [] [] empty_subst empty_subst tmpl_tvs+  where+    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)+               `unionInScope` getTCvInScope subst+    empty_subst = mkEmptyTCvSubst in_scope++    choose :: [TyVar]           -- accumulator of univ tvs, reversed+           -> [EqSpec]          -- accumulator of GADT equalities, reversed+           -> TCvSubst          -- template substitution+           -> TCvSubst          -- res. substitution+           -> [TyVar]           -- template tvs (the univ tvs passed in)+           -> ( [TyVar]         -- the univ_tvs+              , [EqSpec]        -- GADT equalities+              , TCvSubst )       -- a substitution to fix kinds in ex_tvs++    choose univs eqs _t_sub r_sub []+      = (reverse univs, reverse eqs, r_sub)+    choose univs eqs t_sub r_sub (t_tv:t_tvs)+      | Just r_ty <- lookupTyVar subst t_tv+      = case getTyVar_maybe r_ty of+          Just r_tv+            |  not (r_tv `elem` univs)+            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))+            -> -- simple, well-kinded variable substitution.+               choose (r_tv:univs) eqs+                      (extendTvSubst t_sub t_tv r_ty')+                      (extendTvSubst r_sub r_tv r_ty')+                      t_tvs+            where+              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)+              r_ty'  = mkTyVarTy r_tv1++               -- Not a simple substitution: make an equality predicate+          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)+                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))+                         -- We've updated the kind of t_tv,+                         -- so add it to t_sub (#14162)+                      r_sub t_tvs+            where+              t_tv' = updateTyVarKind (substTy t_sub) t_tv++      | otherwise+      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)++      -- choose an appropriate name for a univ tyvar.+      -- This *must* preserve the Unique of the result tv, so that we+      -- can detect repeated variables. It prefers user-specified names+      -- over system names. A result variable with a system name can+      -- happen with GHC-generated implicit kind variables.+    choose_tv_name :: TyVar -> TyVar -> Name+    choose_tv_name r_tv t_tv+      | isSystemName r_tv_name+      = setNameUnique t_tv_name (getUnique r_tv_name)++      | otherwise+      = r_tv_name++      where+        r_tv_name = getName r_tv+        t_tv_name = getName t_tv++{-+Note [Substitution in template variables kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data G (a :: Maybe k) where+  MkG :: G Nothing++With explicit kind variables++data G k (a :: Maybe k) where+  MkG :: G k1 (Nothing k1)++Note how k1 is distinct from k. So, when we match the template+`G k a` against `G k1 (Nothing k1)`, we get a subst+[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two+mappings, we surely don't want to add (k, k1) to the list of+GADT equalities -- that would be overly complex and would create+more untouchable variables than we need. So, when figuring out+which tyvars are GADT-like and which aren't (the fundamental+job of `choose`), we want to treat `k` as *not* GADT-like.+Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)+instead of (a :: Maybe k). This is the reason for dealing+with a substitution in here.++However, we do not *always* want to substitute. Consider++data H (a :: k) where+  MkH :: H Int++With explicit kind variables:++data H k (a :: k) where+  MkH :: H * Int++Here, we have a kind-indexed GADT. The subst in question is+[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s+kind, because that would give a constructor with the type++MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a++The problem here is that a's kind is wrong -- it needs to be k, not *!+So, if the matching for a variable is anything but another bare variable,+we drop the mapping from the substitution before proceeding. This+was not an issue before kind-indexed GADTs because this case could+never happen.++************************************************************************+*                                                                      *+                Validity checking+*                                                                      *+************************************************************************++Validity checking is done once the mutually-recursive knot has been+tied, so we can look at things freely.+-}++checkValidTyCl :: TyCon -> TcM [TyCon]+-- The returned list is either a singleton (if valid)+-- or a list of "fake tycons" (if not); the fake tycons+-- include any implicits, like promoted data constructors+-- See Note [Recover from validity error]+checkValidTyCl tc+  = setSrcSpan (getSrcSpan tc) $+    addTyConCtxt tc            $+    recoverM recovery_code     $+    do { traceTc "Starting validity for tycon" (ppr tc)+       ; checkValidTyCon tc+       ; traceTc "Done validity for tycon" (ppr tc)+       ; return [tc] }+  where+    recovery_code -- See Note [Recover from validity error]+      = do { traceTc "Aborted validity for tycon" (ppr tc)+           ; return (map mk_fake_tc $+                     tc : child_tycons tc) }++    mk_fake_tc tc+      | isClassTyCon tc = tc   -- Ugh! Note [Recover from validity error]+      | otherwise       = makeRecoveryTyCon tc++    child_tycons tc = tyConATs tc ++ map promoteDataCon (tyConDataCons tc)++{- Note [Recover from validity error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We recover from a validity error in a type or class, which allows us+to report multiple validity errors. In the failure case we return a+TyCon of the right kind, but with no interesting behaviour+(makeRecoveryTyCon). Why?  Suppose we have+   type T a = Fun+where Fun is a type family of arity 1.  The RHS is invalid, but we+want to go on checking validity of subsequent type declarations.+So we replace T with an abstract TyCon which will do no harm.+See indexed-types/should_fail/BadSock and #10896++Some notes:++* We must make fakes for promoted DataCons too. Consider (#15215)+      data T a = MkT ...+      data S a = ...T...MkT....+  If there is an error in the definition of 'T' we add a "fake type+  constructor" to the type environment, so that we can continue to+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'+  and so there was an internal error when we met 'MkT' in the body of+  'S'.++  Similarly for associated types.++* Painfully, we *don't* want to do this for classes.+  Consider tcfail041:+     class (?x::Int) => C a where ...+     instance C Int+  The class is invalid because of the superclass constraint.  But+  we still want it to look like a /class/, else the instance bleats+  that the instance is mal-formed because it hasn't got a class in+  the head.++  This is really bogus; now we have in scope a Class that is invalid+  in some way, with unknown downstream consequences.  A better+  alternative might be to make a fake class TyCon.  A job for another day.++* Previously, we used implicitTyConThings to snaffle out the parts+  to add to the context. The problem is that this also grabs data con+  wrapper Ids. These could be filtered out. But, painfully, getting+  the wrapper Ids checks the DataConRep, and forcing the DataConRep+  can panic if there is a levity-polymorphic argument. This is #18534.+  We don't need the wrapper Ids here anyway. So the code just takes what+  it needs, via child_tycons.+-}++-------------------------+-- For data types declared with record syntax, we require+-- that each constructor that has a field 'f'+--      (a) has the same result type+--      (b) has the same type for 'f'+-- module alpha conversion of the quantified type variables+-- of the constructor.+--+-- Note that we allow existentials to match because the+-- fields can never meet. E.g+--      data T where+--        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T+--        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T+-- Here we do not complain about f1,f2 because they are existential++checkValidTyCon :: TyCon -> TcM ()+checkValidTyCon tc+  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim+  = return ()++  | isWiredIn tc     -- validity-checking wired-in tycons is a waste of+                     -- time. More importantly, a wired-in tycon might+                     -- violate assumptions. Example: (~) has a superclass+                     -- mentioning (~#), which is ill-kinded in source Haskell+  = traceTc "Skipping validity check for wired-in" (ppr tc)++  | otherwise+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))+       ; if | Just cl <- tyConClass_maybe tc+              -> checkValidClass cl++            | Just syn_rhs <- synTyConRhs_maybe tc+              -> do { checkValidType syn_ctxt syn_rhs+                    ; checkTySynRhs syn_ctxt syn_rhs }++            | Just fam_flav <- famTyConFlav_maybe tc+              -> case fam_flav of+               { ClosedSynFamilyTyCon (Just ax)+                   -> tcAddClosedTypeFamilyDeclCtxt tc $+                      checkValidCoAxiom ax+               ; ClosedSynFamilyTyCon Nothing   -> return ()+               ; AbstractClosedSynFamilyTyCon ->+                 do { hsBoot <- tcIsHsBootOrSig+                    ; checkTc hsBoot $+                      text "You may define an abstract closed type family" $$+                      text "only in a .hs-boot file" }+               ; DataFamilyTyCon {}           -> return ()+               ; OpenSynFamilyTyCon           -> return ()+               ; BuiltInSynFamTyCon _         -> return () }++             | otherwise -> do+               { -- Check the context on the data decl+                 traceTc "cvtc1" (ppr tc)+               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)++               ; traceTc "cvtc2" (ppr tc)++               ; dflags          <- getDynFlags+               ; existential_ok  <- xoptM LangExt.ExistentialQuantification+               ; gadt_ok         <- xoptM LangExt.GADTs+               ; let ex_ok = existential_ok || gadt_ok+                     -- Data cons can have existential context+               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)++                -- Check that fields with the same name share a type+               ; mapM_ check_fields groups }}+  where+    syn_ctxt  = TySynCtxt name+    name      = tyConName tc+    data_cons = tyConDataCons tc++    groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    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++    -- See Note [GADT record selectors] in GHC.Tc.TyCl.Utils+    -- We must check (a) that the named field has the same+    --                   type in each constructor+    --               (b) that those constructors have the same result type+    --+    -- However, the constructors may have differently named type variable+    -- and (worse) we don't know how the correspond to each other.  E.g.+    --     C1 :: forall a b. { f :: a, g :: b } -> T a b+    --     C2 :: forall d c. { f :: c, g :: c } -> T c d+    --+    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's+    -- result type against other candidates' types BOTH WAYS ROUND.+    -- If they magically agrees, take the substitution and+    -- apply them to the latter ones, and see if they match perfectly.+    check_fields ((label, con1) :| other_fields)+        -- These fields all have the same name, but are from+        -- different constructors in the data type+        = recoverM (return ()) $ mapM_ checkOne other_fields+                -- Check that all the fields in the group have the same type+                -- NB: this check assumes that all the constructors of a given+                -- data type use the same type variables+        where+        res1 = dataConOrigResTy con1+        fty1 = dataConFieldType con1 lbl+        lbl = flLabel label++        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical+            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2+                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }+            where+                res2 = dataConOrigResTy con2+                fty2 = dataConFieldType con2 lbl++checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()+-- Checks the partial record field selector, and warns.+-- See Note [Checking partial record field]+checkPartialRecordField all_cons fld+  = setSrcSpan loc $+      warnIfFlag Opt_WarnPartialFields+        (not is_exhaustive && not (startsWithUnderscore occ_name))+        (sep [text "Use of partial record field selector" <> colon,+              nest 2 $ quotes (ppr occ_name)])+  where+    loc = getSrcSpan (flSelector fld)+    occ_name = occName fld++    (cons_with_field, cons_without_field) = partition has_field all_cons+    has_field con = fld `elem` (dataConFieldLabels con)+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field++    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)+    inst_tys = substTyVars eq_subst univ_tvs++checkFieldCompat :: FieldLabelString -> DataCon -> DataCon+                 -> Type -> Type -> Type -> Type -> TcM ()+checkFieldCompat fld con1 con2 res1 res2 fty1 fty2+  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)+        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }+  where+    mb_subst1 = tcMatchTy res1 res2+    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2++-------------------------------+checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()+checkValidDataCon dflags existential_ok tc con+  = setSrcSpan con_loc $+    addErrCtxt (dataConCtxt [L (noAnnSrcSpan con_loc) con_name]) $+    do  { let tc_tvs      = tyConTyVars tc+              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)+              orig_res_ty = dataConOrigResTy con+        ; traceTc "checkValidDataCon" (vcat+              [ ppr con, ppr tc, ppr tc_tvs+              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)+              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])+++        -- Check that the return type of the data constructor+        -- matches the type constructor; eg reject this:+        --   data T a where { MkT :: Bogus a }+        -- It's important to do this first:+        --  see Note [rejigCon+        --  and c.f. Note [Check role annotations in a second pass]++        -- Check that the return type of the data constructor is an instance+        -- of the header of the header of data decl.  This checks for+        --      data T a where { MkT :: S a }+        --      data instance D [a] where { MkD :: D (Maybe b) }+        -- see Note [GADT return types]+        ; checkTc (isJust (tcMatchTyKi res_ty_tmpl orig_res_ty))+                  (badDataConTyCon con res_ty_tmpl)+            -- Note that checkTc aborts if it finds an error. This is+            -- critical to avoid panicking when we call dataConDisplayType+            -- on an un-rejiggable datacon!+            -- Also NB that we match the *kind* as well as the *type* (#18357)+            -- However, if the kind is the only thing that doesn't match, the+            -- error message is terrible.  E.g. test T18357b+            --    type family Star where Star = Type+            --    newtype T :: Type where MkT :: Int -> (T :: Star)++        ; traceTc "checkValidDataCon 2" (ppr data_con_display_type)++          -- Check that the result type is a *monotype*+          --  e.g. reject this:   MkT :: T (forall a. a->a)+          -- Reason: it's really the argument of an equality constraint+        ; checkValidMonoType orig_res_ty++          -- If we are dealing with a newtype, we allow levity polymorphism+          -- regardless of whether or not UnliftedNewtypes is enabled. A+          -- later check in checkNewDataCon handles this, producing a+          -- better error message than checkForLevPoly would.+        ; unless (isNewTyCon tc) $+            checkNoErrs $+            mapM_ (checkForLevPoly empty) (map scaledThing $ dataConOrigArgTys con)+            -- the checkNoErrs is to prevent a panic in isVanillaDataCon+            -- (called a a few lines down), which can fall over if there is a+            -- bang on a levity-polymorphic argument. This is #18534,+            -- typecheck/should_fail/T18534++          -- Extra checks for newtype data constructors. Importantly, these+          -- checks /must/ come before the call to checkValidType below. This+          -- is because checkValidType invokes the constraint solver, and+          -- invoking the solver on an ill formed newtype constructor can+          -- confuse GHC to the point of panicking. See #17955 for an example.+        ; when (isNewTyCon tc) (checkNewDataCon con)++          -- Check all argument types for validity+        ; checkValidType ctxt data_con_display_type++          -- Check that existentials are allowed if they are used+        ; checkTc (existential_ok || isVanillaDataCon con)+                  (badExistential con)++          -- Check that UNPACK pragmas and bangs work out+          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"+          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack+        ; hsc_env <- getTopEnv+        ; let check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()+              check_bang bang rep_bang n+               | HsSrcBang _ _ SrcLazy <- bang+               , not (xopt LangExt.StrictData dflags)+               = addErrTc (bad_bang n (text "Lazy annotation (~) without StrictData"))++               | HsSrcBang _ want_unpack strict_mark <- bang+               , isSrcUnpacked want_unpack, not (is_strict strict_mark)+               = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))++               | HsSrcBang _ want_unpack _ <- bang+               , isSrcUnpacked want_unpack+               , case rep_bang of { HsUnpack {} -> False; _ -> True }+               -- If not optimising, we don't unpack (rep_bang is never+               -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.+               -- See dataConSrcToImplBang.+               , not (gopt Opt_OmitInterfacePragmas dflags)+               -- When typechecking an indefinite package in Backpack, we+               -- may attempt to UNPACK an abstract type.  The test here will+               -- conclude that this is unusable, but it might become usable+               -- when we actually fill in the abstract type.  As such, don't+               -- warn in this case (it gives users the wrong idea about whether+               -- or not UNPACK on abstract types is supported; it is!)+               , isHomeUnitDefinite (hsc_home_unit hsc_env)+               = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))++               | otherwise+               = return ()++        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]++          -- Check the dcUserTyVarBinders invariant+          -- See Note [DataCon user type variable binders] in GHC.Core.DataCon+          -- checked here because we sometimes build invalid DataCons before+          -- erroring above here+        ; when debugIsOn $+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con+                   user_tvs                       = dataConUserTyVars con+                   user_tvbs_invariant+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)+                       == Set.fromList user_tvs+             ; MASSERT2( user_tvbs_invariant+                       , vcat ([ ppr con+                               , ppr univs+                               , ppr exs+                               , ppr eq_spec+                               , ppr user_tvs ])) }++        ; traceTc "Done validity of data con" $+          vcat [ ppr con+               , text "Datacon wrapper type:" <+> ppr (dataConWrapperType con)+               , text "Datacon rep type:" <+> ppr (dataConRepType con)+               , text "Datacon display type:" <+> ppr data_con_display_type+               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))+               , case tyConFamInst_maybe (dataConTyCon con) of+                   Nothing -> text "not family"+                   Just (f, _) -> ppr (tyConBinders f) ]+    }+  where+    con_name = dataConName con+    con_loc  = nameSrcSpan con_name+    ctxt = ConArgCtxt con_name+    is_strict = \case+      NoSrcStrict -> xopt LangExt.StrictData dflags+      bang        -> isSrcStrict bang++    bad_bang n herald+      = hang herald 2 (text "on the" <+> speakNth n+                       <+> text "argument of" <+> quotes (ppr con))++    show_linear_types     = xopt LangExt.LinearTypes dflags+    data_con_display_type = dataConDisplayType show_linear_types con++-------------------------------+checkNewDataCon :: DataCon -> TcM ()+-- Further checks for the data constructor of a newtype+checkNewDataCon con+  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))+              -- One argument++        ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes+        ; let allowedArgType =+                unlifted_newtypes || isLiftedType_maybe (scaledThing arg_ty1) == Just True+        ; checkTc allowedArgType $ vcat+          [ text "A newtype cannot have an unlifted argument type"+          , text "Perhaps you intended to use UnliftedNewtypes"+          ]+        ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags++        ; let check_con what msg =+               checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))++        ; checkTc (ok_mult (scaledMult arg_ty1)) $+          text "A newtype constructor must be linear"++        ; check_con (null eq_spec) $+          text "A newtype constructor must have a return type of form T a1 ... an"+                -- Return type is (T a b c)++        ; check_con (null theta) $+          text "A newtype constructor cannot have a context in its type"++        ; check_con (null ex_tvs) $+          text "A newtype constructor cannot have existential type variables"+                -- No existentials++        ; checkTc (all ok_bang (dataConSrcBangs con))+                  (newtypeStrictError con)+                -- No strictness annotations+    }+  where+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+      = dataConFullSig con++    (arg_ty1 : _) = arg_tys++    ok_bang (HsSrcBang _ _ SrcStrict) = False+    ok_bang (HsSrcBang _ _ SrcLazy)   = False+    ok_bang _                         = True++    ok_mult One = True+    ok_mult _   = False++-------------------------------+checkValidClass :: Class -> TcM ()+checkValidClass cls+  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods+        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses+        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses+        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies+        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses++        -- Check that the class is unary, unless multiparameter type classes+        -- are enabled; also recognize deprecated nullary type classes+        -- extension (subsumed by multiparameter type classes, #8993)+        ; checkTc (multi_param_type_classes || cls_arity == 1 ||+                    (nullary_type_classes && cls_arity == 0))+                  (classArityErr cls_arity cls)+        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)++        -- Check the super-classes+        ; checkValidTheta (ClassSCCtxt (className cls)) theta++          -- Now check for cyclic superclasses+          -- If there are superclass cycles, checkClassCycleErrs bails.+        ; unless undecidable_super_classes $+          case checkClassCycles cls of+             Just err -> setSrcSpan (getSrcSpan cls) $+                         addErrTc err+             Nothing  -> return ()++        -- Check the class operations.+        -- But only if there have been no earlier errors+        -- See Note [Abort when superclass cycle is detected]+        ; whenNoErrs $+          mapM_ (check_op constrained_class_methods) op_stuff++        -- Check the associated type defaults are well-formed and instantiated+        ; mapM_ check_at at_stuff  }+  where+    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls+    cls_arity = length (tyConVisibleTyVars (classTyCon cls))+       -- Ignore invisible variables+    cls_tv_set = mkVarSet tyvars++    check_op constrained_class_methods (sel_id, dm)+      = setSrcSpan (getSrcSpan sel_id) $+        addErrCtxt (classOpCtxt sel_id op_ty) $ do+        { traceTc "class op type" (ppr op_ty)+        ; checkValidType ctxt op_ty+                -- This implements the ambiguity check, among other things+                -- Example: tc223+                --   class Error e => Game b mv e | b -> mv e where+                --      newBoard :: MonadState b m => m ()+                -- Here, MonadState has a fundep m->b, so newBoard is fine++           -- a method cannot be levity polymorphic, as we have to store the+           -- method in a dictionary+           -- example of what this prevents:+           --   class BoundedX (a :: TYPE r) where minBound :: a+           -- See Note [Levity polymorphism checking] in GHC.HsToCore.Monad+        ; checkForLevPoly empty tau1++        ; unless constrained_class_methods $+          mapM_ check_constraint (tail (cls_pred:op_theta))++        ; check_dm ctxt sel_id cls_pred tau2 dm+        }+        where+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints+          op_name = idName sel_id+          op_ty   = idType sel_id+          (_,cls_pred,tau1) = tcSplitMethodTy op_ty+          -- See Note [Splitting nested sigma types in class type signatures]+          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1++          check_constraint :: TcPredType -> TcM ()+          check_constraint pred -- See Note [Class method constraints]+            = when (not (isEmptyVarSet pred_tvs) &&+                    pred_tvs `subVarSet` cls_tv_set)+                   (addErrTc (badMethPred sel_id pred))+            where+              pred_tvs = tyCoVarsOfType pred++    check_at (ATI fam_tc m_dflt_rhs)+      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)+                     (noClassTyVarErr cls fam_tc)+                        -- Check that the associated type mentions at least+                        -- one of the class type variables+                        -- The check is disabled for nullary type classes,+                        -- since there is no possible ambiguity (#10020)++             -- Check that any default declarations for associated types are valid+           ; 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++    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()+    -- Check validity of the /top-level/ generic-default type+    -- E.g for   class C a where+    --             default op :: forall b. (a~b) => blah+    -- we do not want to do an ambiguity check on a type with+    -- a free TyVar 'a' (#11608).  See TcType+    -- Note [TyVars and TcTyVars during type checking] in GHC.Tc.Utils.TcType+    -- Hence the mkDefaultMethodType to close the type.+    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau+             (Just (dm_name, dm_spec@(GenericDM dm_ty)))+      = setSrcSpan (getSrcSpan dm_name) $ do+            -- We have carefully set the SrcSpan on the generic+            -- default-method Name to be that of the generic+            -- default type signature++          -- First, we check that the method's default type signature+          -- aligns with the non-default type signature.+          -- See Note [Default method type signatures must align]+          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls+              -- Note that the second field of this tuple contains the context+              -- of the default type signature, making it apparent that we+              -- ignore method contexts completely when validity-checking+              -- default type signatures. See the end of+              -- Note [Default method type signatures must align]+              -- to learn why this is OK.+              --+              -- See also+              -- Note [Splitting nested sigma types in class type signatures]+              -- for an explanation of why we don't use tcSplitSigmaTy here.+              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty++              -- Given this class definition:+              --+              --  class C a b where+              --    op         :: forall p q. (Ord a, D p q)+              --               => a -> b -> p -> (a, b)+              --    default op :: forall r s. E r+              --               => a -> b -> s -> (a, b)+              --+              -- We want to match up two types of the form:+              --+              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)+              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)+              --+              -- Notice that the two type signatures can be quantified over+              -- different class type variables! Therefore, it's important that+              -- we include the class predicate parts to match up a with aa and+              -- b with bb.+              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau+              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau++          traceTc "check_dm" $ vcat+              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty+              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]++          -- Actually checking that the types align is done with a call to+          -- tcMatchTys. We need to get a match in both directions to rule+          -- out degenerate cases like these:+          --+          --  class Foo a where+          --    foo1         :: a -> b+          --    default foo1 :: a -> Int+          --+          --    foo2         :: a -> Int+          --    default foo2 :: a -> b+          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]+                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $+               hang (text "The default type signature for"+                     <+> ppr sel_id <> colon)+                 2 (ppr dm_ty)+            $$ (text "does not match its corresponding"+                <+> text "non-default type signature")++          -- Now do an ambiguity check on the default type signature.+          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)+    check_dm _ _ _ _ _ = return ()++checkFamFlag :: Name -> TcM ()+-- Check that we don't use families without -XTypeFamilies+-- The parser won't even parse them, but I suppose a GHC API+-- client might have a go!+checkFamFlag tc_name+  = do { idx_tys <- xoptM LangExt.TypeFamilies+       ; checkTc idx_tys err_msg }+  where+    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))+                 2 (text "Enable TypeFamilies to allow indexed type families")++checkResultSigFlag :: Name -> FamilyResultSig GhcRn -> TcM ()+checkResultSigFlag tc_name (TyVarSig _ tvb)+  = do { ty_fam_deps <- xoptM LangExt.TypeFamilyDependencies+       ; checkTc ty_fam_deps $+         hang (text "Illegal result type variable" <+> ppr tvb <+> text "for" <+> quotes (ppr tc_name))+            2 (text "Enable TypeFamilyDependencies to allow result variable names") }+checkResultSigFlag _ _ = return ()  -- other cases OK++{- Note [Class method constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Haskell 2010 is supposed to reject+  class C a where+    op :: Eq a => a -> a+where the method type constrains only the class variable(s).  (The extension+-XConstrainedClassMethods switches off this check.)  But regardless+we should not reject+  class C a where+    op :: (?x::Int) => a -> a+as pointed out in #11793. So the test here rejects the program if+  * -XConstrainedClassMethods is off+  * the tyvars of the constraint are non-empty+  * all the tyvars are class tyvars, none are locally quantified++Note [Abort when superclass cycle is detected]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must avoid doing the ambiguity check for the methods (in+checkValidClass.check_op) when there are already errors accumulated.+This is because one of the errors may be a superclass cycle, and+superclass cycles cause canonicalization to loop. Here is a+representative example:++  class D a => C a where+    meth :: D a => ()+  class C a => D a++This fixes #9415, #9739++Note [Default method type signatures must align]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC enforces the invariant that a class method's default type signature+must "align" with that of the method's non-default type signature, as per+GHC #12918. For instance, if you have:++  class Foo a where+    bar :: forall b. Context => a -> b++Then a default type signature for bar must be alpha equivalent to+(forall b. a -> b). That is, the types must be the same modulo differences in+contexts. So the following would be acceptable default type signatures:++    default bar :: forall b. Context1 => a -> b+    default bar :: forall x. Context2 => a -> x++But the following are NOT acceptable default type signatures:++    default bar :: forall b. b -> a+    default bar :: forall x. x+    default bar :: a -> Int++Note that a is bound by the class declaration for Foo itself, so it is+not allowed to differ in the default type signature.++The default type signature (default bar :: a -> Int) deserves special mention,+since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To+write this, you need to declare the default type signature like so:++    default bar :: forall b. (b ~ Int). a -> b++As noted in #12918, there are several reasons to do this:++1. It would make no sense to have a type that was flat-out incompatible with+   the non-default type signature. For instance, if you had:++     class Foo a where+       bar :: a -> Int+       default bar :: a -> Bool++   Then that would always fail in an instance declaration. So this check+   nips such cases in the bud before they have the chance to produce+   confusing error messages.++2. Internally, GHC uses TypeApplications to instantiate the default method in+   an instance. See Note [Default methods in instances] in GHC.Tc.TyCl.Instance.+   Thus, GHC needs to know exactly what the universally quantified type+   variables are, and when instantiated that way, the default method's type+   must match the expected type.++3. Aesthetically, by only allowing the default type signature to differ in its+   context, we are making it more explicit the ways in which the default type+   signature is less polymorphic than the non-default type signature.++You might be wondering: why are the contexts allowed to be different, but not+the rest of the type signature? That's because default implementations often+rely on assumptions that the more general, non-default type signatures do not.+For instance, in the Enum class declaration:++    class Enum a where+      enum :: [a]+      default enum :: (Generic a, GEnum (Rep a)) => [a]+      enum = map to genum++    class GEnum f where+      genum :: [f a]++The default implementation for enum only works for types that are instances of+Generic, and for which their generic Rep type is an instance of GEnum. But+clearly enum doesn't _have_ to use this implementation, so naturally, the+context for enum is allowed to be different to accommodate this. As a result,+when we validity-check default type signatures, we ignore contexts completely.++Note that when checking whether two type signatures match, we must take care to+split as many foralls as it takes to retrieve the tau types we which to check.+See Note [Splitting nested sigma types in class type signatures].++Note [Splitting nested sigma types in class type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this type synonym and class definition:++  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++  class Each s t a b where+    each         ::                                      Traversal s t a b+    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b++It might seem obvious that the tau types in both type signatures for `each`+are the same, but actually getting GHC to conclude this is surprisingly tricky.+That is because in general, the form of a class method's non-default type+signature is:++  forall a. C a => forall d. D d => E a b++And the general form of a default type signature is:++  forall f. F f => E a f -- The variable `a` comes from the class++So it you want to get the tau types in each type signature, you might find it+reasonable to call tcSplitSigmaTy twice on the non-default type signature, and+call it once on the default type signature. For most classes and methods, this+will work, but Each is a bit of an exceptional case. The way `each` is written,+it doesn't quantify any additional type variables besides those of the Each+class itself, so the non-default type signature for `each` is actually this:++  forall s t a b. Each s t a b => Traversal s t a b++Notice that there _appears_ to only be one forall. But there's actually another+forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy+twice, you'll also go under the forall in Traversal! That is, you'll end up+with:++  (a -> f b) -> s -> f t++A problem arises because you only call tcSplitSigmaTy once on the default type+signature for `each`, which gives you++  Traversal s t a b++Or, equivalently:++  forall f. Applicative f => (a -> f b) -> s -> f t++This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will+say that the tau types for `each` are not equal.++A solution to this problem is to use tcSplitNestedSigmaTys instead of+tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it+sees until it can't go any further, so if you called it on the default type+signature for `each`, it would return (a -> f b) -> s -> f t like we desired.++Note [Checking partial record field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This check checks the partial record field selector, and warns (#7169).++For example:++  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }++The function 'm2' is partial record field, and will fail when it is applied to+'B'. The warning identifies such partial fields. The check is performed at the+declaration of T, not at the call-sites of m2.++The warning can be suppressed by prefixing the field-name with an underscore.+For example:++  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }++************************************************************************+*                                                                      *+                Checking role validity+*                                                                      *+************************************************************************+-}++checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()+checkValidRoleAnnots role_annots tc+  | isTypeSynonymTyCon tc = check_no_roles+  | isFamilyTyCon tc      = check_no_roles+  | isAlgTyCon tc         = check_roles+  | otherwise             = return ()+  where+    -- Role annotations are given only on *explicit* variables,+    -- but a tycon stores roles for all variables.+    -- So, we drop the implicit roles (which are all Nominal, anyway).+    name                   = tyConName tc+    roles                  = tyConRoles tc+    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $+                             zip roles (tyConBinders tc)+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name++    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)+    pick_vis (role, tvb)+      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)+      | otherwise                = Nothing++    check_roles+      = whenIsJust role_annot_decl_maybe $+          \decl@(L loc (RoleAnnotDecl _ _ the_role_annots)) ->+          addRoleAnnotCtxt name $+          setSrcSpanA loc $ do+          { role_annots_ok <- xoptM LangExt.RoleAnnotations+          ; checkTc role_annots_ok $ needXRoleAnnotations tc+          ; checkTc (vis_vars `equalLength` the_role_annots)+                    (wrongNumberOfRoles vis_vars decl)+          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles+          -- Representational or phantom roles for class parameters+          -- quickly lead to incoherence. So, we require+          -- IncoherentInstances to have them. See #8773, #14292+          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances+          ; checkTc (  incoherent_roles_ok+                    || (not $ isClassTyCon tc)+                    || (all (== Nominal) vis_roles))+                    incoherentRoles++          ; lint <- goptM Opt_DoCoreLinting+          ; when lint $ checkValidRoles tc }++    check_no_roles+      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl++checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot _  (L _ Nothing)   _  = return ()+checkRoleAnnot tv (L _ (Just r1)) r2+  = when (r1 /= r2) $+    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2++-- This is a double-check on the role inference algorithm. It is only run when+-- -dcore-lint is enabled. See Note [Role inference] in GHC.Tc.TyCl.Utils+checkValidRoles :: TyCon -> TcM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+checkValidRoles tc+  | isAlgTyCon tc+    -- tyConDataCons returns an empty list for data families+  = mapM_ check_dc_roles (tyConDataCons tc)+  | Just rhs <- synTyConRhs_maybe tc+  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs+  | otherwise+  = return ()+  where+    check_dc_roles datacon+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))+           ; mapM_ (check_ty_roles role_env Representational) $+                    eqSpecPreds eq_spec ++ theta ++ (map scaledThing arg_tys) }+                    -- See Note [Role-checking data constructor arguments] in GHC.Tc.TyCl.Utils+      where+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+          = dataConFullSig datacon+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)+              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs+        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)+        role_env   = univ_roles `plusVarEnv` ex_roles++    check_ty_roles env role ty+      | Just ty' <- coreView ty -- #14101+      = check_ty_roles env role ty'++    check_ty_roles env role (TyVarTy tv)+      = case lookupVarEnv env tv of+          Just role' -> unless (role' `ltRole` role || role' == role) $+                        report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "cannot have role" <+> ppr role <+>+                                       text "because it was assigned role" <+> ppr role'+          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "missing in environment"++    check_ty_roles env Representational (TyConApp tc tys)+      = let roles' = tyConRoles tc in+        zipWithM_ (maybe_check_ty_roles env) roles' tys++    check_ty_roles env Nominal (TyConApp _ tys)+      = mapM_ (check_ty_roles env Nominal) tys++    check_ty_roles _   Phantom ty@(TyConApp {})+      = pprPanic "check_ty_roles" (ppr ty)++    check_ty_roles env role (AppTy ty1 ty2)+      =  check_ty_roles env role    ty1+      >> check_ty_roles env Nominal ty2++    check_ty_roles env role (FunTy _ w ty1 ty2)+      =  check_ty_roles env Nominal w+      >> check_ty_roles env role ty1+      >> check_ty_roles env role ty2++    check_ty_roles env role (ForAllTy (Bndr tv _) ty)+      =  check_ty_roles env Nominal (tyVarKind tv)+      >> check_ty_roles (extendVarEnv env tv Nominal) role ty++    check_ty_roles _   _    (LitTy {}) = return ()++    check_ty_roles env role (CastTy t _)+      = check_ty_roles env role t++    check_ty_roles _   role (CoercionTy co)+      = unless (role == Phantom) $+        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role++    maybe_check_ty_roles env role ty+      = when (role == Nominal || role == Representational) $+        check_ty_roles env role ty++    report_error doc+      = addErrTc $ vcat [text "Internal error in role inference:",+                         doc,+                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]++{-+************************************************************************+*                                                                      *+                Error messages+*                                                                      *+************************************************************************+-}++tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc+tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,+                      text "declaration for", quotes (ppr (tcdName decl))]++addVDQNote :: TcTyCon -> TcM a -> TcM a+-- See Note [Inferring visible dependent quantification]+-- Only types without a signature (CUSK or SAK) here+addVDQNote tycon thing_inside+  | ASSERT2( isTcTyCon tycon, ppr tycon )+    ASSERT2( not (tcTyConIsPoly tycon), ppr tycon $$ ppr tc_kind )+    has_vdq+  = addLandmarkErrCtxt vdq_warning thing_inside+  | otherwise+  = thing_inside+  where+      -- Check whether a tycon has visible dependent quantification.+      -- This will *always* be a TcTyCon. Furthermore, it will *always*+      -- be an ungeneralised TcTyCon, straight out of kcInferDeclHeader.+      -- Thus, all the TyConBinders will be anonymous. Thus, the+      -- free variables of the tycon's kind will be the same as the free+      -- variables from all the binders.+    has_vdq  = any is_vdq_tcb (tyConBinders tycon)+    tc_kind  = tyConKind tycon+    kind_fvs = tyCoVarsOfType tc_kind++    is_vdq_tcb tcb = (binderVar tcb `elemVarSet` kind_fvs) &&+                     isVisibleTyConBinder tcb++    vdq_warning = vcat+      [ text "NB: Type" <+> quotes (ppr tycon) <+>+        text "was inferred to use visible dependent quantification."+      , text "Most types with visible dependent quantification are"+      , text "polymorphically recursive and need a standalone kind"+      , text "signature. Perhaps supply one, with StandaloneKindSignatures."+      ]++tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a+tcAddDeclCtxt decl thing_inside+  = addErrCtxt (tcMkDeclCtxt decl) thing_inside++tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a+tcAddTyFamInstCtxt decl+  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)++tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn = eqn })+  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")+                    (unLoc (feqn_tycon eqn))++tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a+tcAddDataFamInstCtxt decl+  = addErrCtxt (tcMkDataFamInstCtxt decl)++tcMkFamInstCtxt :: SDoc -> Name -> SDoc+tcMkFamInstCtxt flavour tycon+  = hsep [ text "In the" <+> flavour <+> text "declaration for"+         , quotes (ppr tycon) ]++tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a+tcAddFamInstCtxt flavour tycon thing_inside+  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside++tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a+tcAddClosedTypeFamilyDeclCtxt tc+  = addErrCtxt ctxt+  where+    ctxt = text "In the equations for closed type family" <+>+           quotes (ppr tc)++resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+resultTypeMisMatch field_name con1 con2+  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+                text "have a common field" <+> quotes (ppr field_name) <> comma],+          nest 2 $ text "but have different result types"]++fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+fieldTypeMisMatch field_name con1 con2+  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+         text "give different types for field", quotes (ppr field_name)]++dataConCtxt :: [LocatedN Name] -> SDoc+dataConCtxt cons = text "In the definition of data constructor" <> plural cons+                   <+> ppr_cons cons++dataConResCtxt :: [LocatedN Name] -> SDoc+dataConResCtxt cons = text "In the result type of data constructor" <> plural cons+                      <+> ppr_cons cons++ppr_cons :: [LocatedN Name] -> SDoc+ppr_cons [con] = quotes (ppr con)+ppr_cons cons  = interpp'SP cons++classOpCtxt :: Var -> Type -> SDoc+classOpCtxt sel_id tau = sep [text "When checking the class method:",+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]++classArityErr :: Int -> Class -> SDoc+classArityErr n cls+    | n == 0 = mkErr "No" "no-parameter"+    | otherwise = mkErr "Too many" "multi-parameter"+  where+    mkErr howMany allowWhat =+        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),+              parens (text ("Enable MultiParamTypeClasses to allow "+                                    ++ allowWhat ++ " classes"))]++classFunDepsErr :: Class -> SDoc+classFunDepsErr cls+  = vcat [text "Fundeps in class" <+> quotes (ppr cls),+          parens (text "Enable FunctionalDependencies to allow fundeps")]++badMethPred :: Id -> TcPredType -> SDoc+badMethPred sel_id pred+  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)+                 <+> text "in the type of" <+> quotes (ppr sel_id))+              2 (text "constrains only the class type variables")+         , text "Enable ConstrainedClassMethods to allow it" ]++noClassTyVarErr :: Class -> TyCon -> SDoc+noClassTyVarErr clas fam_tc+  = sep [ text "The associated type" <+> quotes (ppr fam_tc <+> hsep (map ppr (tyConTyVars fam_tc)))+        , text "mentions none of the type or kind variables of the class" <+>+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]++badDataConTyCon :: DataCon -> Type -> SDoc+badDataConTyCon data_con res_ty_tmpl+  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>+                text "returns type" <+> quotes (ppr actual_res_ty))+       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))+  where+    actual_res_ty = dataConOrigResTy data_con++badGadtDecl :: Name -> SDoc+badGadtDecl tc_name+  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]++badExistential :: DataCon -> SDoc+badExistential con+  = sdocOption sdocLinearTypes (\show_linear_types ->+      hang (text "Data constructor" <+> quotes (ppr con) <+>+                  text "has existential type variables, a context, or a specialised result type")+         2 (vcat [ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con)+                 , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ]))++badStupidTheta :: Name -> SDoc+badStupidTheta tc_name+  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)++newtypeConError :: Name -> Int -> SDoc+newtypeConError tycon n+  = sep [text "A newtype must have exactly one constructor,",+         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]++newtypeStrictError :: DataCon -> SDoc+newtypeStrictError con+  = sep [text "A newtype constructor cannot have a strictness annotation,",+         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]++newtypeFieldErr :: DataCon -> Int -> SDoc+newtypeFieldErr con_name n_flds+  = sep [text "The constructor of a newtype must have exactly one field",+         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]++badSigTyDecl :: Name -> SDoc+badSigTyDecl tc_name+  = vcat [ text "Illegal kind signature" <+>+           quotes (ppr tc_name)+         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]++emptyConDeclsErr :: Name -> SDoc+emptyConDeclsErr tycon+  = sep [quotes (ppr tycon) <+> text "has no constructors",+         nest 2 $ text "(EmptyDataDecls permits this)"]++wrongKindOfFamily :: TyCon -> SDoc+wrongKindOfFamily family+  = text "Wrong category of family instance; declaration was for a"+    <+> kindOfFamily+  where+    kindOfFamily | isTypeFamilyTyCon family = text "type family"+                 | isDataFamilyTyCon family = text "data family"+                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)++-- | Produce an error for oversaturated type family equations with too many+-- required arguments.+-- See Note [Oversaturated type family equations] in "GHC.Tc.Validity".+wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr max_args+  = text "Number of parameters must match family declaration; expected"+    <+> ppr max_args++badRoleAnnot :: Name -> Role -> Role -> SDoc+badRoleAnnot var annot inferred+  = hang (text "Role mismatch on variable" <+> ppr var <> colon)+       2 (sep [ text "Annotation says", ppr annot+              , text "but role", ppr inferred+              , text "is required" ])++wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc+wrongNumberOfRoles tyvars d@(L _ (RoleAnnotDecl _ _ annots))+  = hang (text "Wrong number of roles listed in role annotation;" $$+          text "Expected" <+> (ppr $ length tyvars) <> comma <+>+          text "got" <+> (ppr $ length annots) <> colon)+       2 (ppr d)+++illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()+illegalRoleAnnotDecl (L loc (RoleAnnotDecl _ tycon _))+  = setErrCtxt [] $+    setSrcSpanA loc $     addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$               text "they are allowed only for datatypes and classes.")

GHC/Tc/TyCl/Build.hs view

@@ -21,8 +21,7 @@  import GHC.Iface.Env import GHC.Core.FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )-import GHC.Builtin.Types( isCTupleTyConName )-import GHC.Builtin.Types.Prim ( voidPrimTy )+import GHC.Builtin.Types( isCTupleTyConName, unboxedUnitTy ) import GHC.Core.DataCon import GHC.Core.PatSyn import GHC.Types.Var@@ -34,7 +33,7 @@ import GHC.Core.Class import GHC.Core.TyCon import GHC.Core.Type-import GHC.Types.Id+import GHC.Types.SourceText import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity @@ -44,6 +43,7 @@ import GHC.Types.Unique.Supply import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic   mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs@@ -170,7 +170,7 @@  ------------------------------------------------------ buildPatSyn :: Name -> Bool-            -> (Id,Bool) -> Maybe (Id, Bool)+            -> PatSynMatcher -> PatSynBuilder             -> ([InvisTVBinder], ThetaType) -- ^ Univ and req             -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov             -> [Type]                       -- ^ Argument types@@ -178,7 +178,7 @@             -> [FieldLabel]                 -- ^ Field labels for                                             --   a record pattern synonym             -> PatSyn-buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder+buildPatSyn src_name declared_infix matcher@(_, matcher_ty,_) builder             (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys             pat_ty field_labels   = -- The assertion checks that the matcher is@@ -201,7 +201,7 @@              arg_tys pat_ty              matcher builder field_labels   where-    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id+    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ matcher_ty     ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau     (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy (scaledThing cont_sigma)     (arg_tys1, _) = (tcSplitFunTys cont_tau)@@ -209,11 +209,11 @@     subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)                        (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs))) -    -- For a nullary pattern synonym we add a single void argument to the+    -- For a nullary pattern synonym we add a single (# #) argument to the     -- matcher to preserve laziness in the case of unlifted types.     -- See #12746     compareArgTys :: [Type] -> [Type] -> Bool-    compareArgTys [] [x] = x `eqType` voidPrimTy+    compareArgTys [] [x] = x `eqType` unboxedUnitTy     compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys

GHC/Tc/TyCl/Class.hs view

@@ -45,7 +45,6 @@ import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad-import GHC.Driver.Phases (HscSource(..)) import GHC.Tc.TyCl.Build( TcMethInfo ) import GHC.Core.Class import GHC.Core.Coercion ( pprCoAxiom )@@ -58,7 +57,9 @@ import GHC.Types.Name.Set import GHC.Types.Var import GHC.Types.Var.Env+import GHC.Types.SourceFile (HscSource(..)) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Core.TyCon import GHC.Data.Maybe@@ -151,30 +152,33 @@        ; traceTc "tcClassSigs 2" (ppr clas)        ; return op_info }   where-    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]-    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]+    vanilla_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp+    vanilla_sigs = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]+    gen_sigs :: [Located ([LocatedN Name], LHsSigType GhcRn)] -- AZ temp+    gen_sigs     = [L (locA loc) (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]     dm_bind_names :: [Name] -- These ones have a value binding in the class decl     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] -    skol_info = TyConSkol ClassFlavour clas--    tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)+    tc_sig :: NameEnv (SrcSpan, Type) -> ([LocatedN Name], LHsSigType GhcRn)            -> TcM [TcMethInfo]     tc_sig gen_dm_env (op_names, op_hs_ty)       = do { traceTc "ClsSig 1" (ppr op_names)-           ; op_ty <- tcClassSigType skol_info op_names op_hs_ty+           ; op_ty <- tcClassSigType op_names op_hs_ty                    -- Class tyvars already in scope -           ; traceTc "ClsSig 2" (ppr op_names)+           ; traceTc "ClsSig 2" (ppr op_names $$ ppr op_ty)            ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }            where              f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)                   | nm `elem` dm_bind_names                 = Just VanillaDM                   | otherwise                               = Nothing +    tc_gen_sig :: ([LocatedN Name], LHsSigType GhcRn)+                      -> IOEnv (Env TcGblEnv TcLclEnv) [(Name, (SrcSpan, Type))] -- AZ temp     tc_gen_sig (op_names, gen_hs_ty)-      = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty-           ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }+      = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty+           ; return [ (op_name, (locA loc, gen_op_ty))+                                                 | L loc op_name <- op_names ] }  {- ************************************************************************@@ -189,9 +193,9 @@  tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,                                 tcdMeths = default_binds}))-  = recoverM (return emptyLHsBinds)     $-    setSrcSpan (getLoc class_name)      $-    do  { clas <- tcLookupLocatedClass class_name+  = recoverM (return emptyLHsBinds) $+    setSrcSpan (getLocA class_name) $+    do  { clas <- tcLookupLocatedClass (n2l class_name)          -- We make a separate binding for each default method.         -- At one time I used a single AbsBinds for all of them, thus@@ -228,7 +232,7 @@  tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)   = do { -- No default method-         mapM_ (addLocM (badDmPrag sel_id))+         mapM_ (addLocMA (badDmPrag sel_id))                (lookupPragEnv prag_fn (idName sel_id))        ; return emptyBag } @@ -273,7 +277,7 @@               local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars) -             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }+             lm_bind     = dm_bind { fun_id = L (la2na bind_loc) local_dm_name }                              -- Substitute the local_meth_name for the binder                              -- NB: the binding is always a FunBind @@ -289,7 +293,7 @@        ; let local_dm_id = mkLocalId local_dm_name Many local_dm_ty              local_dm_sig = CompleteSig { sig_bndr = local_dm_id                                         , sig_ctxt  = ctxt-                                        , sig_loc   = getLoc (hsSigType hs_ty) }+                                        , sig_loc   = getLocA hs_ty }         ; (ev_binds, (tc_bind, _))                <- checkConstraints skol_info tyvars [this_dict] $@@ -338,7 +342,7 @@   where     -- By default require all methods without a default implementation     defMindef :: ClassMinimalDef-    defMindef = mkAnd [ noLoc (mkVar name)+    defMindef = mkAnd [ noLocA (mkVar name)                       | (name, _, Nothing) <- op_info ]  instantiateMethod :: Class -> TcId -> [TcType] -> TcType@@ -369,7 +373,7 @@   where     env = mkHsSigEnv get_classop_sig sigs -    get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)+    get_classop_sig :: LSig GhcRn -> Maybe ([LocatedN Name], LHsSigType GhcRn)     get_classop_sig  (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)     get_classop_sig  _                               = Nothing @@ -388,7 +392,7 @@      f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))       | op_name == sel_name-             = Just (bind, bndr_loc, prags)+             = Just (bind, locA bndr_loc, prags)     f _other = Nothing  ---------------------------@@ -518,7 +522,7 @@              (tv', cv') = partition isTyVar tcv'              tvs'     = scopedSort tv'              cvs'     = scopedSort cv'-       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'+       ; rep_tc_name <- newFamInstTyConName (L (noAnnSrcSpan loc) (tyConName fam_tc)) pat_tys'        ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'                                      fam_tc pat_tys' rhs'            -- NB: no validity check. We check validity of default instances@@ -549,8 +553,10 @@   = do { warn <- woptM Opt_WarnMissingMethods        ; traceTc "warn" (ppr name <+> ppr warn)        ; hsc_src <- fmap tcg_src getGblEnv-       -- Warn only if -Wmissing-methods AND not a signature-       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)+       -- hs-boot and signatures never need to provide complete "definitions"+       -- of any sort, as they aren't really defining anything, but just+       -- constraining items which are defined elsewhere.+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src == HsSrcFile)                 (text "No explicit" <+> text "associated type"                     <+> text "or default declaration for"                     <+> quotes (ppr name)) }

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,9 @@ 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@@ -65,14 +67,19 @@ import GHC.Types.Var.Set import GHC.Data.Bag import GHC.Types.Basic+import GHC.Types.Fixity import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Error+import GHC.Utils.Logger import GHC.Data.FastString import GHC.Types.Id+import GHC.Types.SourceText import GHC.Data.List.SetOps import GHC.Types.Name import GHC.Types.Name.Set import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Utils.Misc import GHC.Data.BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )@@ -477,7 +484,7 @@                                   , cid_sigs = uprags, cid_tyfam_insts = ats                                   , cid_overlap_mode = overlap_mode                                   , cid_datafam_insts = adts }))-  = setSrcSpan loc                      $+  = setSrcSpanA loc                      $     addErrCtxt (instDeclCtxt1 hs_ty)  $     do  { dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty         ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty@@ -490,7 +497,7 @@               -- See Note [Associated data family instances and di_scoped_tvs].               tv_skol_env = mkVarEnv $ map swap tv_skol_prs               n_inferred = countWhile ((== Inferred) . binderArgFlag) $-                           fst $ splitForAllVarBndrs dfun_ty+                           fst $ splitForAllTyCoVarBinders dfun_ty               visible_skol_tvs = drop n_inferred skol_tvs          ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)@@ -508,15 +515,24 @@                        -- Check for missing associated types and build them                       -- from their defaults (if available)-                    ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)-                                        (classATItems clas)-+                    ; is_boot <- tcIsHsBootOrSig+                    ; let atItems = classATItems clas+                    ; tf_insts2 <- mapM (tcATDefault (locA loc) mini_subst defined_ats)+                                        (if is_boot then [] else atItems)+                      -- Don't default type family instances, but rather omit, in hsig/hs-boot.+                      -- Since hsig/hs-boot files are essentially large binders we want omission+                      -- of the definition to result in no restriction, rather than for example+                      -- attempting to "pattern match" with the invisible defaults and generate+                      -- equalities. Without further handling, this would just result in a panic+                      -- anyway.+                      -- See https://github.com/ghc-proposals/ghc-proposals/pull/320 for+                      -- additional discussion.                     ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }           -- Finally, construct the Core representation of the instance.         -- (This no longer includes the associated types.)-        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty))+        ; dfun_name <- newDFunName clas inst_tys (getLocA hs_ty)                 -- Dfun location is that of instance *header*          ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name@@ -535,8 +551,8 @@               all_insts                      = tyfam_insts ++ datafam_insts           -- In hs-boot files there should be no bindings-        ; is_boot <- tcIsHsBootOrSig         ; let no_binds = isEmptyLHsBinds binds && null uprags+        ; is_boot <- tcIsHsBootOrSig         ; failIfTc (is_boot && not no_binds) badBootDeclErr          ; return ( [inst_info], all_insts, deriv_infos ) }@@ -544,7 +560,6 @@     defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)                   `unionNameSet`                   mkNameSet (map (unLoc . feqn_tycon-                                        . hsib_body                                         . dfid_eqn                                         . unLoc) adts) @@ -566,9 +581,9 @@   -- "type instance"   -- See Note [Associated type instances] tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))-  = setSrcSpan loc           $+  = setSrcSpanA loc           $     tcAddTyFamInstCtxt decl  $-    do { let fam_lname = feqn_tycon (hsib_body eqn)+    do { let fam_lname = feqn_tycon eqn        ; fam_tc <- tcLookupLocatedTyCon fam_lname        ; tcFamInstDeclChecks mb_clsinfo fam_tc @@ -577,9 +592,10 @@        ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)           -- (1) do the work of verifying the synonym group+         -- For some reason we don't have a location for the equation+         -- itself, so we make do with the location of family name        ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo-                                        (L (getLoc fam_lname) eqn)-+                                        (L (na2la $ getLoc fam_lname) eqn)           -- (2) check for validity        ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch@@ -650,9 +666,8 @@   -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)   -- "newtype instance" and "data instance" tcDataFamInstDecl mb_clsinfo tv_skol_env-    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars-                                                   , hsib_body =-      FamEqn { feqn_bndrs  = mb_bndrs+    (L loc decl@(DataFamInstDecl { dfid_eqn =+      FamEqn { feqn_bndrs  = outer_bndrs              , feqn_pats   = hs_pats              , feqn_tycon  = lfam_name@(L _ fam_name)              , feqn_fixity = fixity@@ -661,8 +676,8 @@                                         , dd_ctxt    = hs_ctxt                                         , dd_cons    = hs_cons                                         , dd_kindSig = m_ksig-                                        , dd_derivs  = derivs } }}}))-  = setSrcSpan loc             $+                                        , dd_derivs  = derivs } }}))+  = setSrcSpanA loc            $     tcAddDataFamInstCtxt decl  $     do { fam_tc <- tcLookupLocatedTyCon lfam_name @@ -674,9 +689,8 @@           -- Do /not/ check that the number of patterns = tyConArity fam_tc           -- See [Arity of data families] in GHC.Core.FamInstEnv        ; (qtvs, pats, res_kind, stupid_theta)-             <- tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs-                                    fixity hs_ctxt hs_pats m_ksig hs_cons-                                    new_or_data+             <- tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity+                                    hs_ctxt hs_pats m_ksig new_or_data         -- Eta-reduce the axiom if possible        -- Quite tricky: see Note [Implementing eta reduction for data families]@@ -713,7 +727,7 @@        ; traceTc "tcDataFamInstDecl" $          vcat [ text "Fam tycon:" <+> ppr fam_tc               , text "Pats:" <+> ppr pats-              , text "visiblities:" <+> ppr (tcbVisibilities fam_tc pats)+              , text "visibilities:" <+> ppr (tcbVisibilities fam_tc pats)               , text "all_pats:" <+> ppr all_pats               , text "ty_binders" <+> ppr ty_binders               , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)@@ -726,8 +740,9 @@            do { data_cons <- tcExtendTyVarEnv qtvs $                   -- For H98 decls, the tyvars scope                   -- over the data constructors-                  tcConDecls rec_rep_tc new_or_data ty_binders final_res_kind-                             orig_res_ty hs_cons+                  tcConDecls new_or_data (DDataInstance orig_res_ty)+                             rec_rep_tc ty_binders final_res_kind+                             hs_cons                ; rep_tc_name <- newFamInstTyConName lfam_name pats               ; axiom_name  <- newFamInstAxiomName lfam_name [pats]@@ -766,8 +781,8 @@         ; let scoped_tvs = map mk_deriv_info_scoped_tv_pr (tyConTyVars rep_tc)              m_deriv_info = case derivs of-               L _ []    -> Nothing-               L _ preds ->+               []    -> Nothing+               preds ->                  Just $ DerivInfo { di_rep_tc  = rep_tc                                   , di_scoped_tvs = scoped_tvs                                   , di_clauses = preds@@ -841,23 +856,21 @@  ----------------------- tcDataFamInstHeader-    :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr () GhcRn]-    -> LexicalFixity -> LHsContext GhcRn-    -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]+    :: AssocInstInfo -> TyCon -> HsOuterFamEqnTyVarBndrs GhcRn+    -> LexicalFixity -> Maybe (LHsContext GhcRn)+    -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn)     -> NewOrData     -> TcM ([TyVar], [Type], Kind, ThetaType) -- The "header" of a data family instance is the part other than -- the data constructors themselves --    e.g.  data instance D [a] :: * -> * where ... -- Here the "header" is the bit before the "where"-tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity-                    hs_ctxt hs_pats m_ksig hs_cons new_or_data+tcDataFamInstHeader mb_clsinfo fam_tc outer_bndrs fixity+                    hs_ctxt hs_pats m_ksig 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, (scoped_tvs, (stupid_theta, lhs_ty, master_res_kind, instance_res_kind)))+            <- pushLevelAndSolveEqualitiesX "tcDataFamInstHeader" $+               bindOuterFamEqnTKBndrs outer_bndrs                 $                do { stupid_theta <- tcHsContext hs_ctxt                   ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats                   ; (lhs_applied_ty, lhs_applied_kind)@@ -872,14 +885,14 @@                   -- Add constraints from the result signature                   ; res_kind <- tc_kind_sig m_ksig -                  -- Add constraints from the data constructors-                  ; kcConDecls new_or_data res_kind hs_cons+                  -- Do not add constraints from the data constructors+                  -- See Note [Kind inference for data family instances]                    -- Check that the result kind of the TyCon applied to its args                   -- 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 ]@@ -888,20 +901,22 @@                            , 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++       -- See GHC.Tc.TyCl Note [Generalising in tcFamTyPatsGuts]        ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_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-       ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta+       ; ze           <- mkEmptyZonkEnv NoFlexi+       ; (ze, qtvs)   <- zonkTyBndrsX           ze qtvs+       ; 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 @@ -924,21 +939,23 @@   where     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).+    -- See Note [Implementation of UnliftedNewtypes] in GHC.Tc.TyCl, families (2),+    -- and Note [Implementation of UnliftedDatatypes].     tc_kind_sig Nothing-      = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes-           ; if unlifted_newtypes && new_or_data == NewType-               then newOpenTypeKind-               else pure liftedTypeKind+      = do { unlifted_newtypes  <- xoptM LangExt.UnliftedNewtypes+           ; unlifted_datatypes <- xoptM LangExt.UnliftedDatatypes+           ; case new_or_data of+               NewType  | unlifted_newtypes  -> newOpenTypeKind+               DataType | unlifted_datatypes -> newOpenTypeKind+               _                             -> pure liftedTypeKind            }      -- See Note [Result kind signature for a data family instance]     tc_kind_sig (Just hs_kind)       = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind-           ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind            ; lvl <- getTcLevel+           ; let (tvs, inner_kind) = tcSplitForAllInvisTyVars sig_kind            ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs              -- Perhaps surprisingly, we don't need the skolemised tvs themselves            ; return (substTy subst inner_kind) }@@ -1037,6 +1054,86 @@   themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities   does. +Note [Kind inference for data family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GADT-style data type declaration, where I have used+fresh variables in the data constructor's type, to stress that c,d are+quite distinct from a,b.+   data T a b where+     MkT :: forall c d. c d -> T c d++Following Note [Inferring kinds for type declarations] in GHC.Tc.TyCl,+to infer T's kind, we initially give T :: kappa, a monomorpic kind,+gather constraints from the header and data constructors, and conclude+   T :: (kappa1 -> type) -> kappa1 -> Type+Then we generalise, giving+   T :: forall k. (k->Type) -> k -> Type++Now what about a data /instance/ decl+   data family T :: forall k. (k->Type) -> k -> Type++   data instance T p Int where ...++No doubt here! The poly-kinded T is instantiated with k=Type, so the+header really looks like+   data instance T @Type (p :: Type->Type) Int where ...++But what about this?+   data instance T p q where+      MkT :: forall r. r Int -> T r Int++So what kind do 'p' and 'q' have?  No clues from the header, but from+the data constructor we can clearly see that (r :: Type->Type).  Does+that mean that the the /entire data instance/ is instantiated at Type,+like this?+   data instance T @Type (p :: Type->Type) (q :: Type) where+      ...++Not at all! This is a /GADT/-style decl, so the kind argument might+be specialised in this particular data constructor, thus:+   data instance T @k (p :: k->Type) (q :: k) where+     MkT :: forall (r :: Type -> Type).+            r Int -> T @Type r Int+(and perhaps specialised differently in some other data+constructor MkT2).++The key difference in this case and 'data T' at the top of this Note+is that we have no known kind for 'data T'. We thus forbid different+specialisations of T in its constructors, in an attempt to avoid+inferring polymorphic recursion. In data family T, however, there is+no problem with polymorphic recursion: we already /fully know/ T's+kind -- that came from the family declaration, and is not influenced+by the data instances -- and hence we /can/ specialise T's kind+differently in different GADT data constructors.++SHORT SUMMARY: in a data instance decl, it's not clear whether kind+constraints arising from the data constructors should be considered+local to the (GADT) data /constructor/ or should apply to the entire+data instance.++DESIGN CHOICE: in data/newtype family instance declarations, we ignore+the /data constructor/ declarations altogether, looking only at the+data instance /header/.++Observations:+* This choice is simple to describe, as well as simple to implement.+  For a data/newtype instance decl, the instance kinds are influenced+  /only/ by the header.++* We could treat Haskell-98 style data-instance decls differently, by+  taking the data constructors into account, since there are no GADT+  issues.  But we don't, for simplicity, and because it means you can+  understand the data type instance by looking only at the header.++* Newtypes can be declared in GADT syntax, but they can't do GADT-style+  specialisation, so like Haskell-98 definitions we could take the+  data constructors into account.  Again we don't, for the same reason.++So for now at least, we keep the simplest choice. See #18891 and !4419+for more discussion of this issue.++Kind inference for data types (Xie et al) https://arxiv.org/abs/1911.06153+takes a slightly different approach. -}  @@ -1060,9 +1157,9 @@         ; let dm_binds = unionManyBags dm_binds_s            -- (b) instance declarations-        ; let dm_ids = collectHsBindsBinders dm_binds+        ; let dm_ids = collectHsBindsBinders CollNoDictBinders dm_binds               -- Add the default method Ids (again)-              -- (they were arready added in GHC.Tc.TyCl.Utils.tcAddImplicits)+              -- (they were already added in GHC.Tc.TyCl.Utils.tcAddImplicits)               -- See Note [Default methods in the type environment]         ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $                           mapM tcInstDecl2 inst_decls@@ -1140,8 +1237,9 @@        -- Create the result bindings        ; self_dict <- newDict clas inst_tys        ; let class_tc      = classTyCon clas+             loc'          = noAnnSrcSpan loc              [dict_constr] = tyConDataCons class_tc-             dict_bind     = mkVarBind self_dict (L loc con_app_args)+             dict_bind = mkVarBind self_dict (L loc' con_app_args)                       -- We don't produce a binding for the dict_constr; instead we                      -- rely on the simplifier to unfold this saturated application@@ -1160,8 +1258,8 @@              con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids               app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc-             app_to_meth fun meth_id = HsApp noExtField (L loc fun)-                                            (L loc (wrapId arg_wrapper meth_id))+             app_to_meth fun meth_id = HsApp noComments (L loc' fun)+                                            (L loc' (wrapId arg_wrapper meth_id))               inst_tv_tys = mkTyVarTys inst_tyvars              arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys@@ -1188,7 +1286,8 @@                                   , abs_binds = unitBag dict_bind                                   , abs_sig = True } -       ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)+       ; return (unitBag (L loc' main_bind)+                  `unionBags` sc_meth_binds)        }  where    dfun_id = instanceDFunId ispec@@ -1206,7 +1305,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@@ -1227,7 +1326,7 @@    is_newtype  = isNewTyCon clas_tc  wrapId :: HsWrapper -> Id -> HsExpr GhcTc-wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id))+wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLocA id))  {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1339,7 +1438,7 @@                                  , abs_ev_binds = [dfun_ev_binds, local_ev_binds]                                  , abs_binds    = emptyBag                                  , abs_sig      = False }-           ; return (sc_top_id, L loc bind, sc_implic) }+           ; return (sc_top_id, L (noAnnSrcSpan loc) bind, sc_implic) }  ------------------- checkInstConstraints :: TcM result@@ -1558,7 +1657,7 @@           -> [TcTyVar] -> [EvVar]           -> [TcType]           -> TcEvBinds-          -> ([Located TcSpecPrag], TcPragEnv)+          -> ([LTcSpecPrag], TcPragEnv)           -> [ClassOpItem]           -> InstBindings GhcRn           -> TcM ([Id], LHsBinds GhcTc, Bag Implication)@@ -1625,12 +1724,15 @@                              mkLHsWrap lam_wrapper (error_rhs dflags)            ; return (meth_id, meth_bind, Nothing) }       where-        error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags)-        error_fun    = L inst_loc $+        inst_loc' = noAnnSrcSpan inst_loc+        error_rhs dflags = L inst_loc'+                                 $ HsApp noComments error_fun (error_msg dflags)+        error_fun    = L inst_loc' $                        wrapId (mkWpTyApps                                 [ getRuntimeRep meth_tau, meth_tau])                               nO_METHOD_BINDING_ERROR_ID-        error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText+        error_msg dflags = L inst_loc'+                                    (HsLit noComments (HsStringPrim NoSourceText                                               (unsafeMkByteString (error_string dflags))))         meth_tau     = classMethodInstTy sel_id inst_tys         error_string dflags = showSDoc dflags@@ -1742,7 +1844,8 @@                                             mkMethIds clas tyvars dfun_ev_vars                                                       inst_tys sel_id -       ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }+       ; let lm_bind = meth_bind { fun_id = L (noAnnSrcSpan bndr_loc)+                                                        (idName local_meth_id) }                        -- Substitute the local_meth_name for the binder                        -- NB: the binding is always a FunBind @@ -1787,7 +1890,7 @@               -- There is a signature in the instance               -- See Note [Instance method signatures]   = do { (sig_ty, hs_wrap)-             <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $+             <- setSrcSpan (getLocA hs_sig_ty) $                 do { inst_sigs <- xoptM LangExt.InstanceSigs                    ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)                    ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty@@ -1808,7 +1911,7 @@              inner_meth_id  = mkLocalId inner_meth_name Many sig_ty              inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id                                           , sig_ctxt = ctxt-                                          , sig_loc  = getLoc (hsSigType hs_sig_ty) }+                                          , sig_loc  = getLocA hs_sig_ty }          ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind@@ -1862,13 +1965,12 @@         ; return (poly_meth_id, local_meth_id) }   where     sel_name      = idName sel_id-    -- Force so that a thunk doesn't end up in a Name (#19619)-    !sel_occ      = nameOccName sel_name+    sel_occ       = nameOccName sel_name     local_meth_ty = instantiateMethod clas sel_id inst_tys     poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty     theta         = map idType dfun_ev_vars -methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc) methSigCtxt sel_name sig_ty meth_ty env0   = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty        ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty@@ -1964,23 +2066,24 @@ -- visible type application here mkDefMethBind dfun_id clas sel_id dm_name   = do  { dflags <- getDynFlags+        ; logger <- getLogger         ; dm_id <- tcLookupId dm_name         ; let inline_prag = idInlinePragma dm_id               inline_prags | isAnyInlinePragma inline_prag-                           = [noLoc (InlineSig noExtField fn inline_prag)]+                           = [noLocA (InlineSig noAnn fn inline_prag)]                            | otherwise                            = []                  -- Copy the inline pragma (if any) from the default method                  -- to this version. Note [INLINE and default methods] -              fn   = noLoc (idName sel_id)+              fn   = noLocA (idName sel_id)               visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys                                       , tyConBinderArgFlag tcb /= Inferred ]               rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys-              bind = noLoc $ mkTopFunBind Generated fn $+              bind = noLocA $ mkTopFunBind Generated fn $                              [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs] -        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"+        ; liftIO (dumpIfSet_dyn logger dflags Opt_D_dump_deriv "Filling in method body"                    FormatHaskell                    (vcat [ppr clas <+> ppr inst_tys,                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))@@ -1990,8 +2093,8 @@     (_, _, _, inst_tys) = tcSplitDFunTy (idType dfun_id)      mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn-    mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy-                                                $ noLoc $ XHsType $ NHsCoreTy ty))+    mk_vta fun ty = noLocA (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy+                                                $ noLocA $ XHsType ty))        -- NB: use visible type application        -- See Note [Default methods in instances] @@ -2184,9 +2287,9 @@ -}  tcSpecInstPrags :: DFunId -> InstBindings GhcRn-                -> TcM ([Located TcSpecPrag], TcPragEnv)+                -> TcM ([LTcSpecPrag], TcPragEnv) tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })-  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $+  = do { spec_inst_prags <- mapM (wrapLocAM (tcSpecInst dfun_id)) $                             filter isSpecInstLSig uprags              -- The filter removes the pragmas for methods        ; return (spec_inst_prags, mkPragEnv uprags binds) }

GHC/Tc/TyCl/PatSyn.hs view

@@ -1,22 +1,20 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}- {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}+ -- | Typechecking pattern synonym declarations module GHC.Tc.TyCl.PatSyn    ( tcPatSynDecl    , tcPatSynBuilderBind-   , tcPatSynBuilderOcc-   , nonBidirectionalErr+   , patSynBuilderOcc    ) where @@ -26,16 +24,17 @@ import GHC.Tc.Gen.Pat import GHC.Core.Multiplicity import GHC.Core.Type ( tidyTyCoVarBinders, tidyTypes, tidyType )+import GHC.Core.TyCo.Subst( extendTvSubstWithClone ) import GHC.Tc.Utils.Monad-import GHC.Tc.Gen.Sig( emptyPragEnv, completeSigFromId )+import GHC.Tc.Gen.Sig ( TcPragEnv, emptyPragEnv, completeSigFromId, lookupPragEnv, addInlinePrags ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Zonk import GHC.Builtin.Types.Prim import GHC.Types.Name+import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Core.PatSyn-import GHC.Types.Name.Set import GHC.Utils.Panic import GHC.Utils.Outputable import GHC.Data.FastString@@ -58,13 +57,13 @@ import GHC.Tc.TyCl.Utils import GHC.Core.ConLike import GHC.Types.FieldLabel+import GHC.Rename.Env import GHC.Data.Bag import GHC.Utils.Misc-import GHC.Utils.Error-import GHC.Driver.Session ( getDynFlags )+import GHC.Driver.Session ( getDynFlags, xopt_FieldSelectors ) import Data.Maybe( mapMaybe ) import Control.Monad ( zipWithM )-import Data.List( partition )+import Data.List( partition, mapAccumL )  #include "HsVersions.h" @@ -78,12 +77,13 @@  tcPatSynDecl :: PatSynBind GhcRn GhcRn              -> Maybe TcSigInfo+             -> TcPragEnv -- See Note [Pragmas for pattern synonyms]              -> TcM (LHsBinds GhcTc, TcGblEnv)-tcPatSynDecl psb mb_sig+tcPatSynDecl psb mb_sig prag_fn   = recoverM (recoverPSB psb) $     case mb_sig of-      Nothing                 -> tcInferPatSynDecl psb-      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi+      Nothing                 -> tcInferPatSynDecl psb prag_fn+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi prag_fn       _                       -> panic "tcPatSynDecl"  recoverPSB :: PatSynBind GhcRn GhcRn@@ -97,19 +97,18 @@       ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv       ; return (emptyBag, gbl_env) }   where-    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details+    (_arg_names, is_infix) = collectPatSynArgInfo details     mk_placeholder matcher_name       = mkPatSyn name is_infix                         ([mkTyVarBinder SpecifiedSpec alphaTyVar], []) ([], [])                         [] -- Arg tys                         alphaTy-                        (matcher_id, True) Nothing+                        (matcher_name, matcher_ty, True) Nothing                         []  -- Field labels        where          -- The matcher_id is used only by the desugarer, so actually          -- and error-thunk would probably do just as well here.-         matcher_id = mkLocalId matcher_name Many $-                      mkSpecForAllTys [alphaTyVar] alphaTy+         matcher_ty = mkSpecForAllTys [alphaTyVar] alphaTy  {- Note [Pattern synonym error recovery] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -140,13 +139,15 @@ -}  tcInferPatSynDecl :: PatSynBind GhcRn GhcRn+                  -> TcPragEnv                   -> TcM (LHsBinds GhcTc, TcGblEnv) tcInferPatSynDecl (PSB { psb_id = lname@(L _ name), psb_args = details                        , psb_def = lpat, psb_dir = dir })+                  prag_fn   = addPatSynCtxt lname $     do { traceTc "tcInferPatSynDecl {" $ ppr name -       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details+       ; let (arg_names, is_infix) = collectPatSynArgInfo details        ; (tclvl, wanted, ((lpat', args), pat_ty))             <- pushLevelAndCaptureConstraints  $                tcInferPat PatSyn lpat          $@@ -164,8 +165,9 @@                -- ex_tvs in its kind k.                -- See Note [Type variables whose kind is captured] -       ; (univ_tvs, req_dicts, ev_binds, residual, _)-               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted+       ; ((univ_tvs, req_dicts, ev_binds, _), residual)+               <- captureConstraints $+                  simplifyInfer tclvl NoRestrictions [] named_taus wanted        ; top_ev_binds <- checkNoErrs (simplifyTop residual)        ; addTopEvBinds top_ev_binds $ @@ -186,7 +188,8 @@        ; mapM_ dependentArgErr bad_args         ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)-       ; tc_patsyn_finish lname dir is_infix lpat'+       ; rec_fields <- lookupConstructorFields name+       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn                           (mkTyVarBinders InferredSpec univ_tvs                             , req_theta,  ev_binds, req_dicts)                           (mkTyVarBinders InferredSpec ex_tvs@@ -224,7 +227,7 @@ dependentArgErr :: (Id, DTyCoVarSet) -> TcM () -- See Note [Coercions that escape] dependentArgErr (arg, bad_cos)-  = addErrTc $+  = failWithTc $  -- fail here: otherwise we get downstream errors     vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"          , hang (text "Pattern-bound variable")               2 (ppr arg <+> dcolon <+> ppr (idType arg))@@ -344,28 +347,30 @@  tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn                   -> TcPatSynInfo+                  -> TcPragEnv                   -> TcM (LHsBinds GhcTc, TcGblEnv) tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details                          , psb_def = lpat, psb_dir = dir }                   TPSI{ patsig_implicit_bndrs = implicit_bndrs-                      , patsig_univ_bndrs = explicit_univ_bndrs, patsig_prov = prov_theta-                      , patsig_ex_bndrs   = explicit_ex_bndrs,   patsig_req  = req_theta+                      , patsig_univ_bndrs = explicit_univ_bndrs, patsig_req  = req_theta+                      , patsig_ex_bndrs   = explicit_ex_bndrs,   patsig_prov = prov_theta                       , patsig_body_ty    = sig_body_ty }+                  prag_fn   = addPatSynCtxt lname $-    do { let decl_arity = length arg_names-             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details--       ; traceTc "tcCheckPatSynDecl" $+    do { traceTc "tcCheckPatSynDecl" $          vcat [ ppr implicit_bndrs, ppr explicit_univ_bndrs, ppr req_theta               , ppr explicit_ex_bndrs, ppr prov_theta, ppr sig_body_ty ] +       ; let decl_arity = length arg_names+             (arg_names, is_infix) = collectPatSynArgInfo details+        ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of                                  Right stuff  -> return stuff                                  Left missing -> wrongNumberOfParmsErr name decl_arity missing         -- Complain about:  pattern P :: () => forall x. x -> P x        -- The existential 'x' should not appear in the result type-       -- Can't check this until we know P's arity+       -- Can't check this until we know P's arity (decl_arity above)        ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) $ binderVars explicit_ex_bndrs        ; checkTc (null bad_tvs) $          hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma@@ -382,36 +387,55 @@              univ_tvs   = binderVars univ_bndrs              ex_tvs     = binderVars ex_bndrs +         -- Skolemise the quantified type variables. This is necessary+         -- in order to check the actual pattern type against the+         -- expected type. Even though the tyvars in the type are+         -- already skolems, this step changes their TcLevels,+         -- avoiding level-check errors when unifying.+       ; (skol_subst0, skol_univ_bndrs) <- skolemiseTvBndrsX emptyTCvSubst univ_bndrs+       ; (skol_subst, skol_ex_bndrs)    <- skolemiseTvBndrsX skol_subst0   ex_bndrs+       ; let skol_univ_tvs   = binderVars skol_univ_bndrs+             skol_ex_tvs     = binderVars skol_ex_bndrs+             skol_req_theta  = substTheta skol_subst0 req_theta+             skol_prov_theta = substTheta skol_subst  prov_theta+             skol_arg_tys    = substTys   skol_subst  (map scaledThing arg_tys)+             skol_pat_ty     = substTy    skol_subst  pat_ty++             univ_tv_prs     = [ (getName orig_univ_tv, skol_univ_tv)+                               | (orig_univ_tv, skol_univ_tv) <- univ_tvs `zip` skol_univ_tvs ]+        -- Right!  Let's check the pattern against the signature        -- See Note [Checking against a pattern signature]-       ; req_dicts <- newEvVars req_theta+       ; req_dicts <- newEvVars skol_req_theta        ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-            ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )            pushLevelAndCaptureConstraints   $-           tcExtendTyVarEnv univ_tvs        $-           tcCheckPat PatSyn lpat (unrestricted pat_ty)   $-           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)+           tcExtendNameTyVarEnv univ_tv_prs $+           tcCheckPat PatSyn lpat (unrestricted skol_pat_ty)   $+           do { let in_scope    = mkInScopeSet (mkVarSet skol_univ_tvs)                     empty_subst = mkEmptyTCvSubst in_scope-              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs+              ; (inst_subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst skol_ex_tvs                     -- newMetaTyVarX: see the "Existential type variables"                     -- part of Note [Checking against a pattern signature]               ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])               ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])-              ; let prov_theta' = substTheta subst prov_theta+              ; let prov_theta' = substTheta inst_subst skol_prov_theta                   -- Add univ_tvs to the in_scope set to                   -- satisfy the substitution invariant. There's no need to                   -- add 'ex_tvs' as they are already in the domain of the                   -- substitution.                   -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.               ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'-              ; args'      <- zipWithM (tc_arg subst) arg_names (map scaledThing arg_tys)+              ; args'      <- zipWithM (tc_arg inst_subst) arg_names+                                       skol_arg_tys               ; return (ex_tvs', prov_dicts, args') }         ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []                          -- The type here is a bit bogus, but we do not print                          -- the type for PatSynCtxt, so it doesn't matter                          -- See Note [Skolem info for pattern synonyms] in "GHC.Tc.Types.Origin"-       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted+       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_univ_tvs+                                                    req_dicts wanted         -- Solve the constraints now, because we are about to make a PatSyn,        -- which should not contain unification variables and the like (#10997)@@ -422,27 +446,74 @@        -- when that should be impossible         ; traceTc "tcCheckPatSynDecl }" $ ppr name-       ; tc_patsyn_finish lname dir is_infix lpat'-                          (univ_bndrs, req_theta, ev_binds, req_dicts)-                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)-                          (args', (map scaledThing arg_tys))-                          pat_ty rec_fields }++       ; rec_fields <- lookupConstructorFields name+       ; tc_patsyn_finish lname dir is_infix lpat' prag_fn+                          (skol_univ_bndrs, skol_req_theta, ev_binds, req_dicts)+                          (skol_ex_bndrs, mkTyVarTys ex_tvs', skol_prov_theta, prov_dicts)+                          (args', skol_arg_tys)+                          skol_pat_ty rec_fields }   where     tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTc)+     -- Look up the variable actually bound by lpat+     -- and check that it has the expected type     tc_arg subst arg_name arg_ty-      = do {   -- Look up the variable actually bound by lpat-               -- and check that it has the expected type-             arg_id <- tcLookupId arg_name+      = setSrcSpan (nameSrcSpan arg_name) $+           -- Set the SrcSpan to be the binding site of the Id (#18856)+           -- e.g.  pattern P :: Int -> Maybe (Int,Bool)+           --       pattern P x = Just (x,True)+           -- Before unifying x's actual type with its expected type, in tc_arg, set+           -- location to x's binding site in lpat, namely the 'x' in Just (x,True).+           -- Else the error message location is wherever tcCheckPat finished,+           -- namely the right-hand corner of the pattern+        do { arg_id <- tcLookupId arg_name            ; wrap <- tcSubTypeSigma GenSigCtxt                                     (idType arg_id)-                                    (substTyUnchecked subst arg_ty)+                                    (substTy subst arg_ty)                 -- Why do we need tcSubType here?                 -- See Note [Pattern synonyms and higher rank types]            ; return (mkLHsWrap wrap $ nlHsVar arg_id) } -{- [Pattern synonyms and higher rank types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+skolemiseTvBndrsX :: TCvSubst -> [VarBndr TyVar flag]+                  -> TcM (TCvSubst, [VarBndr TcTyVar flag])+-- Make new TcTyVars, all skolems with levels, but do not clone+-- The level is one level deeper than the current level+-- See Note [Skolemising when checking a pattern synonym]+skolemiseTvBndrsX orig_subst tvs+  = do { tc_lvl <- getTcLevel+       ; let pushed_lvl = pushTcLevel tc_lvl+             details    = SkolemTv pushed_lvl False++             mk_skol_tv_x :: TCvSubst -> VarBndr TyVar flag+                          -> (TCvSubst, VarBndr TcTyVar flag)+             mk_skol_tv_x subst (Bndr tv flag)+               = (subst', Bndr new_tv flag)+               where+                 new_kind = substTyUnchecked subst (tyVarKind tv)+                 new_tv   = mkTcTyVar (tyVarName tv) new_kind details+                 subst'   = extendTvSubstWithClone subst tv new_tv++       ; return (mapAccumL mk_skol_tv_x orig_subst tvs) }++{- Note [Skolemising when checking a pattern synonym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider+   pattern P1 :: forall a. a -> Maybe a+   pattern P1 x <- Just x where+      P1 x = Just (x :: a)++The scoped type variable 'a' scopes over the builder RHS, Just (x::a).+But the builder RHS is typechecked much later in tcPatSynBuilderBind,+and gets its scoped type variables from the type of the builder_id.+The easiest way to achieve this is not to clone when skolemising.++Hence a special-purpose skolemiseTvBndrX here, similar to+GHC.Tc.Utils.Instantiate.tcInstSkolTyVarsX except that the latter+does cloning.++[Pattern synonyms and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   data T = MkT (forall a. a->a)    pattern P :: (Int -> Int) -> T@@ -559,26 +630,17 @@   a bad idea. -} -collectPatSynArgInfo :: HsPatSynDetails (Located Name)-                     -> ([Name], [Name], Bool)+collectPatSynArgInfo :: HsPatSynDetails GhcRn+                     -> ([Name], Bool) collectPatSynArgInfo details =   case details of-    PrefixCon names      -> (map unLoc names, [], False)-    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)-    RecCon names         -> (vars, sels, False)-                         where-                            (vars, sels) = unzip (map splitRecordPatSyn names)-  where-    splitRecordPatSyn :: RecordPatSynField (Located Name)-                      -> (Name, Name)-    splitRecordPatSyn (RecordPatSynField-                       { recordPatSynPatVar     = L _ patVar-                       , recordPatSynSelectorId = L _ selId })-      = (patVar, selId)+    PrefixCon _ names    -> (map unLoc names, False)+    InfixCon name1 name2 -> (map unLoc [name1, name2], True)+    RecCon names         -> (map (unLoc . recordPatSynPatVar) names, False) -addPatSynCtxt :: Located Name -> TcM a -> TcM a+addPatSynCtxt :: LocatedN Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside-  = setSrcSpan loc $+  = setSrcSpanA loc $     addErrCtxt (text "In the declaration for pattern synonym"                 <+> quotes (ppr name)) $     thing_inside@@ -592,18 +654,19 @@  ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn-tc_patsyn_finish :: Located Name      -- ^ PatSyn Name+tc_patsyn_finish :: LocatedN Name   -- ^ PatSyn Name                  -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)                  -> Bool              -- ^ Whether infix                  -> LPat GhcTc        -- ^ Pattern of the PatSyn+                 -> TcPragEnv                  -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])                  -> ([LHsExpr GhcTc], [TcType])  -- ^ Pattern arguments and types                  -> TcType            -- ^ Pattern type-                 -> [Name]            -- ^ Selector names+                 -> [FieldLabel]      -- ^ Selector names                  -- ^ Whether fields, empty if not record PatSyn                  -> TcM (LHsBinds GhcTc, TcGblEnv)-tc_patsyn_finish lname dir is_infix lpat'+tc_patsyn_finish lname dir is_infix lpat' prag_fn                  (univ_tvs, req_theta, req_ev_binds, req_dicts)                  (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)                  (args, arg_tys)@@ -611,11 +674,12 @@   = do { -- Zonk everything.  We are about to build a final PatSyn          -- so there had better be no unification variables in there -         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs+       ; ze              <- mkEmptyZonkEnv NoFlexi+       ; (ze, univ_tvs') <- zonkTyVarBindersX   ze univ_tvs        ; req_theta'      <- zonkTcTypesToTypesX ze req_theta-       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs+       ; (ze, ex_tvs')   <- zonkTyVarBindersX   ze ex_tvs        ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta-       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty+       ; pat_ty'         <- zonkTcTypeToTypeX   ze pat_ty        ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys         ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'@@ -634,24 +698,17 @@            ppr pat_ty         -- Make the 'matcher'-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'+       ; (matcher, matcher_bind) <- tcPatSynMatcher lname lpat' prag_fn                                          (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)                                          (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)                                          (args, arg_tys)                                          pat_ty         -- Make the 'builder'-       ; builder_id <- mkPatSynBuilderId dir lname-                                         univ_tvs req_theta-                                         ex_tvs   prov_theta-                                         arg_tys pat_ty--         -- TODO: Make this have the proper information-       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)-                                            , flIsOverloaded = False-                                            , flSelector = name }-             field_labels' = map mkFieldLabel field_labels-+       ; builder <- mkPatSynBuilder dir lname+                                    univ_tvs req_theta+                                    ex_tvs   prov_theta+                                    arg_tys pat_ty         -- Make the PatSyn itself        ; let patSyn = mkPatSyn (unLoc lname) is_infix@@ -659,11 +716,12 @@                         (ex_tvs, prov_theta)                         arg_tys                         pat_ty-                        matcher_id builder_id-                        field_labels'+                        matcher builder+                        field_labels         -- Selectors-       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)+       ; has_sel <- xopt_FieldSelectors <$> getDynFlags+       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn) has_sel              tything = AConLike (PatSynCon patSyn)        ; tcg_env <- tcExtendGlobalEnv [tything] $                     tcRecSelBinds rn_rec_sel_binds@@ -679,32 +737,34 @@ ************************************************************************ -} -tcPatSynMatcher :: Located Name+tcPatSynMatcher :: LocatedN Name                 -> LPat GhcTc+                -> TcPragEnv                 -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])                 -> ([TcTyVar], [TcType], ThetaType, [EvTerm])                 -> ([LHsExpr GhcTc], [TcType])                 -> TcType-                -> TcM ((Id, Bool), LHsBinds GhcTc)+                -> TcM (PatSynMatcher, LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn-tcPatSynMatcher (L loc name) lpat+tcPatSynMatcher (L loc name) lpat prag_fn                 (univ_tvs, req_theta, req_ev_binds, req_dicts)                 (ex_tvs, ex_tys, prov_theta, prov_dicts)                 (args, arg_tys) pat_ty-  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc-       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc+  = do { let loc' = locA loc+       ; rr_name <- newNameAt (mkTyVarOcc "rep") loc'+       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc'        ; let rr_tv  = mkTyVar rr_name runtimeRepTy              rr     = mkTyVarTy rr_tv              res_tv = mkTyVar tv_name (tYPE rr)              res_ty = mkTyVarTy res_tv              is_unlifted = null args && null prov_dicts              (cont_args, cont_arg_tys)-               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])+               | is_unlifted = ([nlHsVar voidPrimId], [unboxedUnitTy])                | otherwise   = (args,                 arg_tys)              cont_ty = mkInfSigmaTy ex_tvs prov_theta $                        mkVisFunTysMany cont_arg_tys res_ty -             fail_ty  = mkVisFunTyMany voidPrimTy res_ty+             fail_ty  = mkVisFunTyMany unboxedUnitTy res_ty         ; matcher_name <- newImplicitBinder name mkMatcherOcc        ; scrutinee    <- newSysLocalId (fsLit "scrut") Many pat_ty@@ -723,7 +783,7 @@              fail' = nlHsApps fail [nlHsVar voidPrimId]               args = map nlVarPat [scrutinee, cont, fail]-             lwpat = noLoc $ WildPat pat_ty+             lwpat = noLocA $ WildPat pat_ty              cases = if isIrrefutableHsPat dflags lpat                      then [mkHsCaseAlt lpat  cont']                      else [mkHsCaseAlt lpat  cont',@@ -731,43 +791,46 @@              body = mkLHsWrap (mkWpLet req_ev_binds) $                     L (getLoc lpat) $                     HsCase noExtField (nlHsVar scrutinee) $-                    MG{ mg_alts = L (getLoc lpat) cases+                    MG{ mg_alts = L (l2l $ getLoc lpat) cases                       , mg_ext = MatchGroupTc [unrestricted pat_ty] res_ty                       , mg_origin = Generated                       }-             body' = noLoc $+             body' = noLocA $                      HsLam noExtField $-                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr-                                                        args body]+                     MG{ mg_alts = noLocA [mkSimpleMatch LambdaExpr+                                                         args body]                        , mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty                        , mg_origin = Generated                        }              match = mkMatch (mkPrefixFunRhs (L loc name)) []                              (mkHsLams (rr_tv:res_tv:univ_tvs)                                        req_dicts body')-                             (noLoc (EmptyLocalBinds noExtField))+                             (EmptyLocalBinds noExtField)              mg :: MatchGroup GhcTc (LHsExpr GhcTc)-             mg = MG{ mg_alts = L (getLoc match) [match]+             mg = MG{ mg_alts = L (l2l $ getLoc match) [match]                     , mg_ext = MatchGroupTc [] res_ty                     , mg_origin = Generated                     }+             prags = lookupPragEnv prag_fn name+             -- See Note [Pragmas for pattern synonyms] -       ; let bind = FunBind{ fun_id = L loc matcher_id+       ; matcher_prag_id <- addInlinePrags matcher_id prags+       ; let bind = FunBind{ fun_id = L loc matcher_prag_id                            , fun_matches = mg                            , fun_ext = idHsWrapper                            , fun_tick = [] }-             matcher_bind = unitBag (noLoc bind)-+             matcher_bind = unitBag (noLocA bind)        ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))        ; traceTc "tcPatSynMatcher" (ppr matcher_bind) -       ; return ((matcher_id, is_unlifted), matcher_bind) }+       ; return ((matcher_name, matcher_sigma, is_unlifted), matcher_bind) }  mkPatSynRecSelBinds :: PatSyn                     -> [FieldLabel]  -- ^ Visible field labels+                    -> FieldSelectors                     -> [(Id, LHsBind GhcRn)]-mkPatSynRecSelBinds ps fields-  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl+mkPatSynRecSelBinds ps fields has_sel+  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl has_sel     | fld_lbl <- fields ]  isUnidirectional :: HsPatSynDir a -> Bool@@ -783,12 +846,12 @@ ************************************************************************ -} -mkPatSynBuilderId :: HsPatSynDir a -> Located Name-                  -> [InvisTVBinder] -> ThetaType-                  -> [InvisTVBinder] -> ThetaType-                  -> [Type] -> Type-                  -> TcM (Maybe (Id, Bool))-mkPatSynBuilderId dir (L _ name)+mkPatSynBuilder :: HsPatSynDir a -> LocatedN Name+                -> [InvisTVBinder] -> ThetaType+                -> [InvisTVBinder] -> ThetaType+                -> [Type] -> Type+                -> TcM PatSynBuilder+mkPatSynBuilder dir (L _ name)                   univ_bndrs req_theta ex_bndrs prov_theta                   arg_tys pat_ty   | isUnidirectional dir@@ -803,42 +866,47 @@                               mkPhiTy theta $                               mkVisFunTysMany arg_tys $                               pat_ty-             builder_id     = mkExportedVanillaId builder_name builder_sigma-              -- See Note [Exported LocalIds] in GHC.Types.Id--             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id--       ; return (Just (builder_id', need_dummy_arg)) }-  where+       ; return (Just (builder_name, builder_sigma, need_dummy_arg)) } -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn+tcPatSynBuilderBind :: TcPragEnv+                    -> PatSynBind GhcRn GhcRn                     -> TcM (LHsBinds GhcTc) -- See Note [Matchers and builders for pattern synonyms] in GHC.Core.PatSyn-tcPatSynBuilderBind (PSB { psb_id = L loc name-                         , psb_def = lpat-                         , psb_dir = dir-                         , psb_args = details })+tcPatSynBuilderBind prag_fn (PSB { psb_id = ps_lname@(L loc ps_name)+                                 , psb_def = lpat+                                 , psb_dir = dir+                                 , psb_args = details })   | isUnidirectional dir   = return emptyBag    | Left why <- mb_match_group       -- Can't invert the pattern-  = setSrcSpan (getLoc lpat) $ failWithTc $+  = setSrcSpan (getLocA lpat) $ failWithTc $     vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"-                 <+> quotes (ppr name) <> colon)+                 <+> quotes (ppr ps_name) <> colon)               2 why          , text "RHS pattern:" <+> ppr lpat ]    | Right match_group <- mb_match_group  -- Bidirectional-  = do { patsyn <- tcLookupPatSyn name+  = do { patsyn <- tcLookupPatSyn ps_name        ; case patSynBuilder patsyn of {            Nothing -> return emptyBag ;              -- This case happens if we found a type error in the              -- pattern synonym, recovered, and put a placeholder              -- with patSynBuilder=Nothing in the environment -           Just (builder_id, need_dummy_arg) ->  -- Normal case+           Just (builder_name, builder_ty, need_dummy_arg) ->  -- Normal case     do { -- Bidirectional, so patSynBuilder returns Just-         let match_group' | need_dummy_arg = add_dummy_arg match_group+         let pat_ty = patSynResultType patsyn+             builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $+                          mkExportedVanillaId builder_name builder_ty+                         -- See Note [Exported LocalIds] in GHC.Types.Id+             prags = lookupPragEnv prag_fn ps_name+             -- See Note [Pragmas for pattern synonyms]+             -- Keyed by the PatSyn Name, not the (internal) builder name++       ; builder_id <- addInlinePrags builder_id prags++       ; let match_group' | need_dummy_arg = add_dummy_arg match_group                           | otherwise      = match_group               bind = FunBind { fun_id      = L loc (idName builder_id)@@ -846,11 +914,13 @@                             , fun_ext     = emptyNameSet                             , fun_tick    = [] } -             sig = completeSigFromId (PatSynCtxt name) builder_id+             sig = completeSigFromId (PatSynCtxt ps_name) builder_id         ; traceTc "tcPatSynBuilderBind {" $-         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)-       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)+         vcat [ ppr patsyn+              , ppr builder_id <+> dcolon <+> ppr (idType builder_id)+              , ppr prags ]+       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLocA bind)        ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds        ; return builder_binds } } } @@ -861,20 +931,20 @@     mb_match_group        = case dir of            ExplicitBidirectional explicit_mg -> Right explicit_mg-           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr ps_name args lpat)            Unidirectional -> panic "tcPatSynBuilderBind"      mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)-    mk_mg body = mkMatchGroup Generated [builder_match]+    mk_mg body = mkMatchGroup Generated (noLocA [builder_match])           where-            builder_args  = [L loc (VarPat noExtField (L loc n))+            builder_args  = [L (na2la loc) (VarPat noExtField (L loc n))                             | L loc n <- args]-            builder_match = mkMatch (mkPrefixFunRhs (L loc name))+            builder_match = mkMatch (mkPrefixFunRhs ps_lname)                                     builder_args body-                                    (noLoc (EmptyLocalBinds noExtField))+                                    (EmptyLocalBinds noExtField)      args = case details of-              PrefixCon args     -> args+              PrefixCon _ args   -> args               InfixCon arg1 arg2 -> [arg1, arg2]               RecCon args        -> map recordPatSynPatVar args @@ -886,32 +956,27 @@     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_ty, 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+    then ( builder_expr   -- still just return builder_expr; the void# arg+                          -- is added by dsConLike in the desugarer          , tcFunResultTy builder_ty )     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-  | need_dummy_arg = mkVisFunTyMany voidPrimTy ty+  | need_dummy_arg = mkVisFunTyMany unboxedUnitTy ty   | otherwise      = ty -tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn-            -> Either MsgDoc (LHsExpr GhcRn)+tcPatToExpr :: Name -> [LocatedN Name] -> LPat GhcRn+            -> Either SDoc (LHsExpr GhcRn) -- Given a /pattern/, return an /expression/ that builds a value -- that matches the pattern.  E.g. if the pattern is (Just [x]), -- the expression is (Just [x]).  They look the same, but the@@ -925,28 +990,32 @@     lhsVars = mkNameSet (map unLoc args)      -- Make a prefix con for prefix and infix patterns for simplicity-    mkPrefixConExpr :: Located Name -> [LPat GhcRn]-                    -> Either MsgDoc (HsExpr GhcRn)+    mkPrefixConExpr :: LocatedN Name -> [LPat GhcRn]+                    -> Either SDoc (HsExpr GhcRn)     mkPrefixConExpr lcon@(L loc _) pats       = do { exprs <- mapM go pats-           ; return (foldl' (\x y -> HsApp noExtField (L loc x) y)-                            (HsVar noExtField lcon) exprs) }+           ; let con = L (l2l loc) (HsVar noExtField lcon)+           ; return (unLoc $ mkHsApps con exprs)+           } -    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)-                    -> Either MsgDoc (HsExpr GhcRn)-    mkRecordConExpr con fields-      = do { exprFields <- mapM go fields-           ; return (RecordCon noExtField con exprFields) }+    mkRecordConExpr :: LocatedN Name -> HsRecFields GhcRn (LPat GhcRn)+                    -> Either SDoc (HsExpr GhcRn)+    mkRecordConExpr con (HsRecFields fields dd)+      = do { exprFields <- mapM go' fields+           ; return (RecordCon noExtField con (HsRecFields exprFields dd)) } -    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)+    go' :: LHsRecField GhcRn (LPat GhcRn) -> Either SDoc (LHsRecField GhcRn (LHsExpr GhcRn))+    go' (L l rf) = L l <$> traverse go rf++    go :: LPat GhcRn -> Either SDoc (LHsExpr GhcRn)     go (L loc p) = L loc <$> go1 p -    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)+    go1 :: Pat GhcRn -> Either SDoc (HsExpr GhcRn)     go1 (ConPat NoExtField con info)       = case info of-          PrefixCon ps  -> mkPrefixConExpr con ps-          InfixCon l r  -> mkPrefixConExpr con [l,r]-          RecCon fields -> mkRecordConExpr con fields+          PrefixCon _ ps -> mkPrefixConExpr con ps+          InfixCon l r   -> mkPrefixConExpr con [l,r]+          RecCon fields  -> mkRecordConExpr con fields      go1 (SigPat _ pat _) = go1 (unLoc pat)         -- See Note [Type signatures and the builder expression]@@ -956,25 +1025,24 @@         = return $ HsVar noExtField (L l var)         | otherwise         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")-    go1 (ParPat _ pat)          = fmap (HsPar noExtField) $ go pat+    go1 (ParPat _ pat)          = fmap (HsPar noAnn) $ go pat     go1 p@(ListPat reb pats)       | Nothing <- reb = do { exprs <- mapM go pats-                            ; return $ ExplicitList noExtField Nothing exprs }+                            ; return $ ExplicitList noExtField exprs }       | otherwise                   = notInvertibleListPat p     go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats                                          ; return $ ExplicitTuple noExtField-                                           (map (noLoc . (Present noExtField)) exprs)-                                                                           box }+                                           (map (Present noAnn) exprs) box }     go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)                                          ; return $ ExplicitSum noExtField alt arity-                                                                   (noLoc expr)+                                                                   (noLocA expr)                                          }-    go1 (LitPat _ lit)              = return $ HsLit noExtField lit+    go1 (LitPat _ lit)              = return $ HsLit noComments lit     go1 (NPat _ (L _ n) mb_neg _)         | Just (SyntaxExprRn neg) <- mb_neg-                                    = return $ unLoc $ foldl' nlHsApp (noLoc neg)-                                                       [noLoc (HsOverLit noExtField n)]-        | otherwise                 = return $ HsOverLit noExtField n+                                    = return $ unLoc $ foldl' nlHsApp (noLocA neg)+                                                       [noLocA (HsOverLit noAnn n)]+        | otherwise                 = return $ HsOverLit noAnn n     go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))                                     = go1 pat     go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"@@ -1084,20 +1152,37 @@ simply discard the signature.  Note [Record PatSyn Desugaring]--------------------------------+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is important that prov_theta comes before req_theta as this ordering is used when desugaring record pattern synonym updates.  Any change to this ordering should make sure to change GHC.HsToCore.Expr if you want to avoid difficult to decipher core lint errors!- -} +Note [Pragmas for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+INLINE and NOINLINE pragmas are supported for pattern synonyms. They affect both+the matcher and the builder.+(See Note [Matchers and builders for pattern synonyms] in PatSyn) -nonBidirectionalErr :: Outputable name => name -> TcM a-nonBidirectionalErr name = failWithTc $-    text "non-bidirectional pattern synonym"-    <+> quotes (ppr name) <+> text "used in an expression"+For example:+    pattern InlinedPattern x = [x]+    {-# INLINE InlinedPattern #-}+    pattern NonInlinedPattern x = [x]+    {-# NOINLINE NonInlinedPattern #-} +For pattern synonyms with explicit builders, only pragma for the entire pattern+synonym is supported. For example:+    pattern HeadC x <- x:xs where+      HeadC x = [x]+      -- This wouldn't compile: {-# INLINE HeadC #-}+    {-# INLINE HeadC #-} -- But this works++When no pragma is provided for a pattern, the inlining decision might change+between different versions of GHC.+ -}++ -- Walk the whole pattern and for all ConPatOuts, collect the -- existentially-bound type variables and evidence binding variables. --@@ -1134,7 +1219,7 @@     go1 _                   = empty      goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])-    goConDetails (PrefixCon ps) = mergeMany . map go $ ps+    goConDetails (PrefixCon _ ps) = mergeMany . map go $ ps     goConDetails (InfixCon p1 p2) = go p1 `merge` go p2     goConDetails (RecCon HsRecFields{ rec_flds = flds })       = mergeMany . map goRecFd $ flds

GHC/Tc/TyCl/PatSyn.hs-boot view

@@ -3,14 +3,15 @@ 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 )+import GHC.Tc.Gen.Sig ( TcPragEnv )  tcPatSynDecl :: PatSynBind GhcRn GhcRn              -> Maybe TcSigInfo+             -> TcPragEnv              -> TcM (LHsBinds GhcTc, TcGblEnv) -tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)+tcPatSynBuilderBind :: TcPragEnv -> PatSynBind GhcRn GhcRn+                    -> TcM (LHsBinds GhcTc) -nonBidirectionalErr :: Outputable name => name -> TcM a

GHC/Tc/TyCl/Utils.hs view

@@ -1,16 +1,15 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1999---}- {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999++-}+ -- | Analysis functions over data types. Specifically, detecting recursive types. -- -- This stuff is only used for source-code decls; it's recorded in interface@@ -35,38 +34,50 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Env import GHC.Tc.Gen.Bind( tcValBinds )+import GHC.Tc.Utils.TcType++import GHC.Builtin.Types( unitTy )+import GHC.Builtin.Uniques ( mkBuiltinUnique )++import GHC.Hs+ import GHC.Core.TyCo.Rep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) ) import GHC.Core.Multiplicity-import GHC.Tc.Utils.TcType import GHC.Core.Predicate-import GHC.Builtin.Types( unitTy ) import GHC.Core.Make( rEC_SEL_ERROR_ID )-import GHC.Hs import GHC.Core.Class import GHC.Core.Type-import GHC.Driver.Types import GHC.Core.TyCon import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Name.Set hiding (unitFV)-import GHC.Types.Name.Reader ( mkVarUnqual )-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Var.Env-import GHC.Types.Var.Set+import GHC.Core.TyCon.Set import GHC.Core.Coercion ( ltRole )-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Types.Unique ( mkBuiltinUnique )+ import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc+import GHC.Utils.FV as FV+ import GHC.Data.Maybe import GHC.Data.Bag import GHC.Data.FastString-import GHC.Utils.FV as FV+ import GHC.Unit.Module++import GHC.Types.Basic+import GHC.Types.FieldLabel+import GHC.Types.SrcLoc+import GHC.Types.SourceFile+import GHC.Types.SourceText+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Name.Reader ( mkVarUnqual )+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.Set+import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt  import Control.Monad@@ -156,7 +167,11 @@     runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }     deriving (Functor) -type SynCycleState = NameSet+-- TODO: TyConSet is implemented as IntMap over uniques.+-- But we could get away with something based on IntSet+-- since we only check membershib, but never extract the+-- elements.+type SynCycleState = TyConSet  instance Applicative SynCycleM where     pure x = SynCycleM $ \state -> Right (x, state)@@ -174,12 +189,12 @@  -- | Test if a 'Name' is acyclic, short-circuiting if we've -- seen it already.-checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()-checkNameIsAcyclic n m = SynCycleM $ \s ->-    if n `elemNameSet` s+checkTyConIsAcyclic :: TyCon -> SynCycleM () -> SynCycleM ()+checkTyConIsAcyclic tc m = SynCycleM $ \s ->+    if tc `elemTyConSet` s         then Right ((), s) -- short circuit         else case runSynCycleM m s of-                Right ((), s') -> Right ((), extendNameSet s' n)+                Right ((), s') -> Right ((), extendTyConSet s' tc)                 Left err -> Left err  -- | Checks if any of the passed in 'TyCon's have cycles.@@ -188,8 +203,8 @@ -- the corresponding @LTyClDecl Name@ for each 'TyCon', so we -- can give better error messages. checkSynCycles :: Unit -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()-checkSynCycles this_uid tcs tyclds = do-    case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of+checkSynCycles this_uid tcs tyclds =+    case runSynCycleM (mapM_ (go emptyTyConSet []) tcs) emptyTyConSet of         Left (loc, err) -> setSrcSpan loc $ failWithTc err         Right _  -> return ()   where@@ -198,15 +213,15 @@      -- Short circuit if we've already seen this Name and concluded     -- it was acyclic.-    go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+    go :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()     go so_far seen_tcs tc =-        checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc+        checkTyConIsAcyclic tc $ go' so_far seen_tcs tc      -- Expand type synonyms, complaining if you find the same     -- type synonym a second time.-    go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+    go' :: TyConSet -> [TyCon] -> TyCon -> SynCycleM ()     go' so_far seen_tcs tc-        | n `elemNameSet` so_far+        | tc `elemTyConSet` so_far             = failSynCycleM (getSrcSpan (head seen_tcs)) $                   sep [ text "Cycle in type synonym declarations:"                       , nest 2 (vcat (map ppr_decl seen_tcs)) ]@@ -221,20 +236,20 @@                isInteractiveModule mod)             = return ()         | Just ty <- synTyConRhs_maybe tc =-            go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty+            go_ty (extendTyConSet so_far tc) (tc:seen_tcs) ty         | otherwise = return ()       where         n = tyConName tc         mod = nameModule n         ppr_decl tc =           case lookupNameEnv lcl_decls n of-            Just (L loc decl) -> ppr loc <> colon <+> ppr decl+            Just (L loc decl) -> ppr (locA loc) <> colon <+> ppr decl             Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n                        <+> text "from external module"          where           n = tyConName tc -    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()+    go_ty :: TyConSet -> [TyCon] -> Type -> SynCycleM ()     go_ty so_far seen_tcs ty =         mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty) @@ -284,11 +299,13 @@ Each step expands superclasses one layer, and clearly does not terminate. -} +type ClassSet = UniqSet Class+ checkClassCycles :: Class -> Maybe SDoc -- Nothing  <=> ok -- Just err <=> possible cycle error checkClassCycles cls-  = do { (definite_cycle, err) <- go (unitNameSet (getName cls))+  = do { (definite_cycle, err) <- go (unitUniqSet cls)                                      cls (mkTyVarTys (classTyVars cls))        ; let herald | definite_cycle = text "Superclass cycle for"                     | otherwise      = text "Potential superclass cycle for"@@ -304,12 +321,12 @@     -- NB: this code duplicates TcType.transSuperClasses, but     --     with more error message generation clobber     -- Make sure the two stay in sync.-    go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+    go :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)     go so_far cls tys = firstJusts $                         map (go_pred so_far) $                         immSuperClasses cls tys -    go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)+    go_pred :: ClassSet -> PredType -> Maybe (Bool, SDoc)        -- Nothing <=> ok        -- Just (True, err)  <=> definite cycle        -- Just (False, err) <=> possible cycle@@ -322,7 +339,7 @@        | otherwise        = Nothing -    go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)+    go_tc :: ClassSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)     go_tc so_far pred tc tys       | isFamilyTyCon tc       = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")@@ -332,18 +349,16 @@       | otherwise   -- Equality predicate, for example       = Nothing -    go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+    go_cls :: ClassSet -> Class -> [Type] -> Maybe (Bool, SDoc)     go_cls so_far cls tys-       | cls_nm `elemNameSet` so_far+       | cls `elementOfUniqSet` so_far        = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))        | isCTupleClass cls        = go so_far cls tys        | otherwise-       = do { (b,err) <- go  (so_far `extendNameSet` cls_nm) cls tys+       = do { (b,err) <- go  (so_far `addOneToUniqSet` cls) cls tys           ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)                        $$ err) }-       where-         cls_nm = getName cls  {- ************************************************************************@@ -762,8 +777,7 @@     do { traceTc "tcAddTyCons" $ vcat             [ text "tycons" <+> ppr tyclss             , text "implicits" <+> ppr implicit_things ]-       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)-       ; return gbl_env }+       ; tcRecSelBinds (mkRecSelBinds tyclss) }  where    implicit_things = concatMap implicitTyConThings tyclss    def_meth_ids    = mkDefaultMethodIds tyclss@@ -838,7 +852,8 @@                                      tcValBinds TopLevel binds sigs getGblEnv        ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }   where-    sigs = [ L loc (IdSig noExtField sel_id) | (sel_id, _) <- sel_bind_prs+    sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id)+                                             | (sel_id, _) <- sel_bind_prs                                              , let loc = getSrcSpan sel_id ]     binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] @@ -853,15 +868,18 @@ mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn) mkRecSelBind (tycon, fl)   = mkOneRecordSelector all_cons (RecSelData tycon) fl+        FieldSelectors  -- See Note [NoFieldSelectors and naughty record selectors]   where     all_cons = map RealDataCon (tyConDataCons tycon) -mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel+mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel -> FieldSelectors                     -> (Id, LHsBind GhcRn)-mkOneRecordSelector all_cons idDetails fl-  = (sel_id, L loc sel_bind)+mkOneRecordSelector all_cons idDetails fl has_sel+  = (sel_id, L (noAnnSrcSpan loc) sel_bind)   where     loc      = getSrcSpan sel_name+    loc'     = noAnnSrcSpan loc+    locn     = noAnnSrcSpan loc     lbl      = flLabel fl     sel_name = flSelector fl @@ -878,6 +896,7 @@                  conLikeUserTyVarBinders con1     data_tv_set= tyCoVarsOfTypes inst_tys     is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)+                    || has_sel == NoFieldSelectors     sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]            | otherwise  = mkForAllTys (tyVarSpecToBinders data_tvbs) $                           mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!@@ -898,18 +917,19 @@                                            [] unit_rhs]              | otherwise =  map mk_match cons_w_field ++ deflt     mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)-                                 [L loc (mk_sel_pat con)]-                                 (L loc (HsVar noExtField (L loc field_var)))-    mk_sel_pat con = ConPat NoExtField (L loc (getName con)) (RecCon rec_fields)+                                 [L loc' (mk_sel_pat con)]+                                 (L loc' (HsVar noExtField (L locn field_var)))+    mk_sel_pat con = ConPat NoExtField (L locn (getName con)) (RecCon rec_fields)     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }-    rec_field  = noLoc (HsRecField-                        { hsRecFieldLbl+    rec_field  = noLocA (HsRecField+                        { hsRecFieldAnn = noAnn+                        , hsRecFieldLbl                            = L loc (FieldOcc sel_name-                                     (L loc $ mkVarUnqual lbl))+                                     (L locn $ mkVarUnqual lbl))                         , hsRecFieldArg-                           = L loc (VarPat noExtField (L loc field_var))+                           = L loc' (VarPat noExtField (L locn field_var))                         , hsRecPun = False })-    sel_lname = L loc sel_name+    sel_lname = L locn sel_name     field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc      -- Add catch-all default case unless the case is exhaustive@@ -917,10 +937,10 @@     -- mentions this particular record selector     deflt | all dealt_with all_cons = []           | otherwise = [mkSimpleMatch CaseAlt-                            [L loc (WildPat noExtField)]-                            (mkHsApp (L loc (HsVar noExtField-                                         (L loc (getName rEC_SEL_ERROR_ID))))-                                     (L loc (HsLit noExtField msg_lit)))]+                            [L loc' (WildPat noExtField)]+                            (mkHsApp (L loc' (HsVar noExtField+                                         (L locn (getName rEC_SEL_ERROR_ID))))+                                     (L loc' (HsLit noComments msg_lit)))]          -- Do not add a default case unless there are unmatched         -- constructors.  We must take account of GADTs, else we@@ -951,7 +971,7 @@     --   scenarios, eq_subst is an empty substitution.     inst_tys = substTyVars eq_subst univ_tvs -    unit_rhs = mkLHsTupleExpr []+    unit_rhs = mkLHsTupleExpr [] noExtField     msg_lit = HsStringPrim NoSourceText (bytesFS lbl)  {-@@ -1020,6 +1040,26 @@ exported.  The function is never called, because the typechecker spots the sel_naughty field. +Note [NoFieldSelectors and naughty record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Under NoFieldSelectors (see Note [NoFieldSelectors] in GHC.Rename.Env), record+selectors will not be in scope in the renamer.  However, for normal datatype+declarations we still generate the underlying selector functions, so they can be+used for constructing the dictionaries for HasField constraints (as described by+Note [HasField instances] in GHC.Tc.Instance.Class).  Hence the call to+mkOneRecordSelector in mkRecSelBind always uses FieldSelectors.++However, record pattern synonyms are not used with HasField, so when+NoFieldSelectors is used we do not need to generate selector functions.  Thus+mkPatSynRecSelBinds passes the current state of the FieldSelectors extension to+mkOneRecordSelector, and in the NoFieldSelectors case it will treat them as+"naughty" fields (see Note [Naughty record selectors]).++Why generate a naughty binding, rather than no binding at all? Because when+type-checking a record update, we need to look up Ids for the fields. In+particular, disambiguateRecordBinds calls lookupParents which needs to look up+the RecSelIds to determine the sel_tycon.+ Note [GADT record selectors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For GADTs, we require that all constructors with a common field 'f' have the same@@ -1093,11 +1133,6 @@ Note that the type of recSelError is `forall r (a :: TYPE r). Addr# -> a`. Therefore, when used in the right-hand side of `unT`, GHC attempts to instantiate `a` with `(forall b. b -> b) -> Int`, which is impredicative.-To make sure that GHC is OK with this, we enable ImpredicativeTypes interally+To make sure that GHC is OK with this, we enable ImpredicativeTypes internally 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. -}

GHC/Tc/Types.hs view

@@ -1,12 +1,14 @@+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE ExistentialQuantification  #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+ {- (c) The University of Glasgow 2006-2012 (c) The GRASP Project, Glasgow University, 1992-2002  -} -{-# LANGUAGE CPP, DeriveFunctor, ExistentialQuantification, GeneralizedNewtypeDeriving,-             ViewPatterns #-}- -- | Various types used during typechecking. -- -- Please see "GHC.Tc.Utils.Monad" as well for operations on these types. You probably@@ -47,18 +49,13 @@         SelfBootInfo(..),         tcTyThingCategory, pprTcTyThingCategory,         peCategory, pprPECategory,-        CompleteMatch(..),--        -- Desugaring types-        DsM, DsLclEnv(..), DsGblEnv(..),-        DsMetaEnv, DsMetaVal(..), CompleteMatchMap,-        mkCompleteMatchMap, extendCompleteMatchMap,+        CompleteMatch, CompleteMatches,          -- Template Haskell         ThStage(..), SpliceType(..), PendingStuff(..),         topStage, topAnnStage, topSpliceStage,         ThLevel, impLevel, outerLevel, thLevel,-        ForeignSrcLang(..),+        ForeignSrcLang(..), THDocs, DocLoc(..),          -- Arrows         ArrowCtxt(..),@@ -92,24 +89,31 @@ import GHC.Prelude import GHC.Platform +import GHC.Driver.Env+import GHC.Driver.Session+import {-# SOURCE #-} GHC.Driver.Hooks+ import GHC.Hs-import GHC.Driver.Types++import GHC.Tc.Utils.TcType+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence+import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )+ import GHC.Core.Type import GHC.Core.TyCon  ( TyCon, tyConKind ) import GHC.Core.PatSyn ( PatSyn ) import GHC.Core.Lint   ( lintAxioms )-import GHC.Types.Id         ( idType, idName )-import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Core.UsageEnv-import GHC.Tc.Utils.TcType-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin-import GHC.Types.Annotations import GHC.Core.InstEnv import GHC.Core.FamInstEnv-import {-# SOURCE #-} GHC.HsToCore.PmCheck.Types (Deltas)-import GHC.Data.IOEnv++import GHC.Types.Id         ( idType, idName )+import GHC.Types.FieldLabel ( FieldLabel )+import GHC.Types.Fixity.Env+import GHC.Types.Annotations+import GHC.Types.CompleteMatch import GHC.Types.Name.Reader import GHC.Types.Name import GHC.Types.Name.Env@@ -117,25 +121,37 @@ import GHC.Types.Avail import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Unit+import GHC.Types.TypeEnv+import GHC.Types.TyThing+import GHC.Types.SourceFile import GHC.Types.SrcLoc import GHC.Types.Var.Set-import GHC.Utils.Error import GHC.Types.Unique.FM import GHC.Types.Basic+import GHC.Types.CostCentre.State+import GHC.Types.HpcInfo++import GHC.Data.IOEnv import GHC.Data.Bag-import GHC.Driver.Session-import GHC.Utils.Outputable import GHC.Data.List.SetOps++import GHC.Unit+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.Imported+import GHC.Unit.Module.ModDetails++import GHC.Utils.Error+import GHC.Utils.Outputable import GHC.Utils.Fingerprint import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Logger+ import GHC.Builtin.Names ( isUnboundName )-import GHC.Types.CostCentre.State  import Control.Monad (ap) import Data.Set      ( Set ) import qualified Data.Set as S- import Data.List ( sort ) import Data.Map ( Map ) import Data.Dynamic  ( Dynamic )@@ -144,8 +160,6 @@ import GHCi.Message import GHCi.RemoteTypes -import {-# SOURCE #-} GHC.Tc.Errors.Hole.FitTypes ( HoleFitPlugin )- import qualified Language.Haskell.TH as TH  -- | A 'NameShape' is a substitution on 'Name's that can be used@@ -192,7 +206,6 @@ type IfM lcl    = TcRnIf IfGblEnv lcl         -- Iface stuff type IfG        = IfM ()                      --    Top level type IfL        = IfM IfLclEnv                --    Nested-type DsM        = TcRnIf DsGblEnv DsLclEnv    -- Desugaring  -- TcRn is the type-checking and renaming monad: the main monad that -- most type-checking takes place in.  The global environment is@@ -227,6 +240,12 @@ instance ContainsDynFlags (Env gbl lcl) where     extractDynFlags env = hsc_dflags (env_top env) +instance ContainsHooks (Env gbl lcl) where+    extractHooks env = hsc_hooks (env_top env)++instance ContainsLogger (Env gbl lcl) where+    extractLogger env = hsc_logger (env_top env)+ instance ContainsModule gbl => ContainsModule (Env gbl lcl) where     extractModule env = extractModule (env_gbl env) @@ -294,58 +313,6 @@ {- ************************************************************************ *                                                                      *-                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:--}--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 :: CompleteMatchMap-           -- Additional complete pattern matches-        , ds_cc_st   :: IORef CostCentreState-           -- Tracking indices for cost centre annotations-        }--instance ContainsModule DsGblEnv where-    extractModule = ds_mod--data DsLclEnv = DsLclEnv {-        dsl_meta    :: DsMetaEnv,        -- Template Haskell bindings-        dsl_loc     :: RealSrcSpan,      -- To put in pattern-matching error msgs--        -- See Note [Note [Type and Term Equality Propagation] in "GHC.HsToCore.PmCheck"-        -- The set of reaching values Deltas is augmented as we walk inwards,-        -- refined through each pattern match in turn-        dsl_deltas  :: Deltas-     }---- 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---{--************************************************************************-*                                                                      *                 Global typechecker environment *                                                                      * ************************************************************************@@ -355,7 +322,7 @@ -- module. Currently one always gets a 'FrontendTypecheck', since running the -- frontend involves typechecking a program. hs-sig merges are not handled here. ----- This data type really should be in GHC.Driver.Types, but it needs+-- This data type really should be in GHC.Driver.Env, but it needs -- to have a TcGblEnv which is only defined here. data FrontendResult         = FrontendTypecheck TcGblEnv@@ -425,7 +392,7 @@          tcg_fix_env   :: FixityEnv,     -- ^ Just for things in this module         tcg_field_env :: RecFieldEnv,   -- ^ Just for things in this module-                                        -- See Note [The interactive package] in "GHC.Driver.Types"+                                        -- See Note [The interactive package] in "GHC.Runtime.Context"          tcg_type_env :: TypeEnv,           -- ^ Global type env for the module we are compiling now.  All@@ -436,7 +403,7 @@           --  move to the global envt during zonking)           --           -- NB: for what "things in this module" means, see-          -- Note [The interactive package] in "GHC.Driver.Types"+          -- Note [The interactive package] in "GHC.Runtime.Context"          tcg_type_env_var :: TcRef TypeEnv,                 -- Used only to initialise the interface-file@@ -517,7 +484,7 @@         -- The binds, rules and foreign-decl fields are collected         -- initially in un-zonked form and are finally zonked in tcRnSrcDecls -        tcg_rn_exports :: Maybe [(Located (IE GhcRn), Avails)],+        tcg_rn_exports :: Maybe [(LIE GhcRn, Avails)],                 -- Nothing <=> no explicit export list                 -- Is always Nothing if we don't want to retain renamed                 -- exports.@@ -555,11 +522,15 @@         tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),         -- ^ Template Haskell state +        tcg_th_docs   :: TcRef THDocs,+        -- ^ Docs added in Template Haskell via @putDoc@.+         tcg_ev_binds  :: Bag EvBind,        -- Top-level evidence bindings          -- Things defined in this module, or (in GHCi)         -- in the declarations for a single GHCi command.-        -- For the latter, see Note [The interactive package] in GHC.Driver.Types+        -- For the latter, see Note [The interactive package] in+        -- GHC.Runtime.Context         tcg_tr_module :: Maybe Id,   -- Id for $trModule :: GHC.Unit.Module                                              -- for which every module has a top-level defn                                              -- except in GHCi in which case we have Nothing@@ -569,6 +540,7 @@         tcg_warns     :: Warnings,           -- ...Warnings and deprecations         tcg_anns      :: [Annotation],       -- ...Annotations         tcg_tcs       :: [TyCon],            -- ...TyCons and Classes+        tcg_ksigs     :: NameSet,            -- ...Top-level TyCon names that *lack* a signature         tcg_insts     :: [ClsInst],          -- ...Instances         tcg_fam_insts :: [FamInst],          -- ...Family instances         tcg_rules     :: [LRuleDecl GhcTc],  -- ...Rules@@ -603,7 +575,7 @@         tcg_static_wc :: TcRef WantedConstraints,           -- ^ Wanted constraints of static forms.         -- See Note [Constraints in static forms].-        tcg_complete_matches :: [CompleteMatch],+        tcg_complete_matches :: !CompleteMatches,          -- ^ Tracking indices for cost centre annotations         tcg_cc_st   :: TcRef CostCentreState@@ -718,6 +690,9 @@           Coercible solver updates tcg_keep's TcRef whenever it           encounters a use of `coerce` that crosses newtype boundaries. +      (e) Record fields that are used to solve HasField constraints+          (see Note [Unused name reporting and HasField] in GHC.Tc.Instance.Class)+       The tcg_keep field is used in two distinct ways:        * Desugar.addExportFlagsAndRules.  Where things like (a-c) are locally@@ -790,7 +765,7 @@                                       -- and for tidying types          tcl_lie  :: TcRef WantedConstraints,    -- Place to accumulate type constraints-        tcl_errs :: TcRef Messages              -- Place to accumulate errors+        tcl_errs :: TcRef (Messages DecoratedSDoc)     -- Place to accumulate errors     }  setLclEnvTcLevel :: TcLclEnv -> TcLevel -> TcLclEnv@@ -805,7 +780,7 @@ getLclEnvLoc :: TcLclEnv -> RealSrcSpan getLclEnvLoc = tcl_loc -type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))+type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, SDoc))         -- Monadic so that we have a chance         -- to deal with bound type variables just before error         -- message construction@@ -1351,8 +1326,8 @@           --      = ModuleEnv [ImportedModsVal],           -- ^ Domain is all directly-imported modules           ---          -- See the documentation on ImportedModsVal in "GHC.Driver.Types" for the-          -- meaning of the fields.+          -- See the documentation on ImportedModsVal in+          -- "GHC.Unit.Module.Imported" for the meaning of the fields.           --           -- We need a full ModuleEnv rather than a ModuleNameEnv here,           -- because we might be importing modules of the same name from@@ -1762,7 +1737,20 @@  -- | Check the 'TcGblEnv' for consistency. Currently, only checks -- axioms, but should check other aspects, too.-lintGblEnv :: DynFlags -> TcGblEnv -> (Bag SDoc, Bag SDoc)-lintGblEnv dflags tcg_env = lintAxioms dflags axioms+lintGblEnv :: Logger -> DynFlags -> TcGblEnv -> TcM ()+lintGblEnv logger dflags tcg_env =+  liftIO $ lintAxioms logger dflags (text "TcGblEnv axioms") axioms   where     axioms = typeEnvCoAxioms (tcg_type_env tcg_env)++-- | This is a mirror of Template Haskell's DocLoc, but the TH names are+-- resolved to GHC names.+data DocLoc = DeclDoc Name+            | ArgDoc Name Int+            | InstDoc Name+            | ModuleDoc+  deriving (Eq, Ord)++-- | The current collection of docs that Template Haskell has built up via+-- putDoc.+type THDocs = Map DocLoc String

GHC/Tc/Types/Constraint.hs view

@@ -1,4 +1,5 @@-{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -9,12 +10,12 @@         QCInst(..), isPendingScInst,          -- Canonical constraints-        Xi, Ct(..), Cts, CtIrredStatus(..), emptyCts, andCts, andManyCts, pprCts,+        Xi, Ct(..), Cts,+        emptyCts, andCts, andManyCts, pprCts,         singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,-        isEmptyCts, isCTyEqCan, isCFunEqCan,+        isEmptyCts,         isPendingScDict, superClassesMightHelp, getPendingWantedScs,-        isCDictCan_Maybe, isCFunEqCan_maybe,-        isCNonCanonical, isWantedCt, isDerivedCt, isGivenCt,+        isWantedCt, isDerivedCt, isGivenCt,         isUserTypeErrorCt, getUserTypeErrorMsg,         ctEvidence, ctLoc, setCtLoc, ctPred, ctFlavour, ctEqRel, ctOrigin,         ctEvId, mkTcEqPredLikeEv,@@ -25,6 +26,17 @@         tyCoVarsOfCt, tyCoVarsOfCts,         tyCoVarsOfCtList, tyCoVarsOfCtsList, +        CtIrredReason(..), HoleSet, isInsolubleReason,++        CheckTyEqResult, CheckTyEqProblem, cteProblem, cterClearOccursCheck,+        cteOK, cteImpredicative, cteTypeFamily, cteHoleBlocker,+        cteInsolubleOccurs, cteSolubleOccurs, cterSetOccursCheckSoluble,+        cterHasNoProblem, cterHasProblem, cterHasOnlyProblem,+        cterRemoveProblem, cterHasOccursCheck, cterFromKind,++        CanEqLHS(..), canEqLHS_maybe, canEqLHSKind, canEqLHSType,+        eqCanEqLHS,+         Hole(..), HoleSort(..), isOutOfScopeHole,          WantedConstraints(..), insolubleWC, emptyWC, isEmptyWC,@@ -35,8 +47,9 @@         isDroppableCt, insolubleImplic,         arisesFromGivens, -        Implication(..), implicationPrototype,+        Implication(..), implicationPrototype, checkTelescopeSkol,         ImplicStatus(..), isInsolubleStatus, isSolvedStatus,+        HasGivenEqs(..),         SubGoalDepth, initialSubGoalDepth, maxSubGoalDepth,         bumpSubGoalDepth, subGoalDepthExceeded,         CtLoc(..), ctLocSpan, ctLocEnv, ctLocLevel, ctLocOrigin,@@ -48,16 +61,15 @@         -- CtEvidence         CtEvidence(..), TcEvDest(..),         mkKindLoc, toKindLoc, mkGivenLoc,-        isWanted, isGiven, isDerived, isGivenOrWDeriv,+        isWanted, isGiven, isDerived,         ctEvRole,          wrapType, -        CtFlavour(..), ShadowInfo(..), ctEvFlavour,+        CtFlavour(..), ShadowInfo(..), ctFlavourContainsDerived, ctEvFlavour,         CtFlavourRole, ctEvFlavourRole, ctFlavourRole,         eqCanRewrite, eqCanRewriteFR, eqMayRewriteFR,         eqCanDischargeFR,-        funEqCanDischarge, funEqCanDischargeF,          -- Pretty printing         pprEvVarTheta,@@ -97,9 +109,17 @@ import GHC.Types.SrcLoc import GHC.Data.Bag import GHC.Utils.Misc+import GHC.Utils.Panic  import Control.Monad ( msum )+import qualified Data.Semigroup ( (<>) ) +-- these are for CheckTyEqResult+import Data.Word  ( Word8 )+import Data.List  ( intersperse )+++ {- ************************************************************************ *                                                                      *@@ -108,28 +128,56 @@ *   These are the constraints the low-level simplifier works with      * *                                                                      * ************************************************************************--} --- The syntax of xi (ξ) types:--- xi ::= a | T xis | xis -> xis | ... | forall a. tau--- Two important notes:---      (i) No type families, unless we are under a ForAll---      (ii) Note that xi types can contain unexpanded type synonyms;---           however, the (transitive) expansions of those type synonyms---           will not contain any type functions, unless we are under a ForAll.--- We enforce the structure of Xi types when we flatten (GHC.Tc.Solver.Canonical)+Note [CEqCan occurs check]+~~~~~~~~~~~~~~~~~~~~~~~~~~+A CEqCan relates a CanEqLHS (a type variable or type family applications) on+its left to an arbitrary type on its right. It is used for rewriting.+Because it is used for rewriting, it would be disastrous if the RHS+were to mention the LHS: this would cause a loop in rewriting. -type Xi = Type       -- In many comments, "xi" ranges over Xi+We thus perform an occurs-check. There is, of course, some subtlety: +* For type variables, the occurs-check looks deeply. This is because+  a CEqCan over a meta-variable is also used to inform unification,+  in GHC.Tc.Solver.Interact.solveByUnification. If the LHS appears+  anywhere, at all, in the RHS, unification will create an infinite+  structure, which is bad.++* For type family applications, the occurs-check is shallow; it looks+  only in places where we might rewrite. (Specifically, it does not+  look in kinds or coercions.) An occurrence of the LHS in, say, an+  RHS coercion is OK, as we do not rewrite in coercions. No loop to+  be found.++  You might also worry about the possibility that a type family+  application LHS doesn't exactly appear in the RHS, but something+  that reduces to the LHS does. Yet that can't happen: the RHS is+  already inert, with all type family redexes reduced. So a simple+  syntactic check is just fine.++The occurs check is performed in GHC.Tc.Utils.Unify.checkTypeEq+and forms condition T3 in Note [Extending the inert equalities]+in GHC.Tc.Solver.Monad.++-}++-- | A 'Xi'-type is one that has been fully rewritten with respect+-- to the inert set; that is, it has been rewritten by the algorithm+-- in GHC.Tc.Solver.Rewrite. (Historical note: 'Xi', for years and years,+-- meant that a type was type-family-free. It does *not* mean this+-- any more.)+type Xi = TcType+ type Cts = Bag Ct  data Ct   -- Atomic canonical constraints-  = CDictCan {  -- e.g.  Num xi+  = CDictCan {  -- e.g.  Num ty       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]        cc_class  :: Class,-      cc_tyargs :: [Xi],   -- cc_tyargs are function-free, hence Xi+      cc_tyargs :: [Xi],   -- cc_tyargs are rewritten w.r.t. inerts, so Xi        cc_pend_sc :: Bool   -- See Note [The superclass story] in GHC.Tc.Solver.Canonical                            -- True <=> (a) cc_class has superclasses@@ -139,12 +187,11 @@    | CIrredCan {  -- These stand for yet-unusable predicates       cc_ev     :: CtEvidence,   -- See Note [Ct/evidence invariant]-      cc_status :: CtIrredStatus+      cc_reason :: CtIrredReason          -- For the might-be-soluble case, the ctev_pred of the evidence is         -- of form   (tv xi1 xi2 ... xin)   with a tyvar at the head-        --      or   (tv1 ~ ty2)   where the CTyEqCan  kind invariant (TyEq:K) fails-        --      or   (F tys ~ ty)  where the CFunEqCan kind invariant fails+        --      or   (lhs1 ~ ty2)  where the CEqCan    kind invariant (TyEq:K) fails         -- See Note [CIrredCan constraints]          -- The definitely-insoluble case is for things like@@ -152,50 +199,32 @@         --    a ~ [a]         occurs check     } -  | CTyEqCan {  -- tv ~ rhs+  | CEqCan {  -- CanEqLHS ~ rhs        -- Invariants:        --   * See Note [inert_eqs: the inert equalities] in GHC.Tc.Solver.Monad-       --   * (TyEq:OC) tv not in deep tvs(rhs)   (occurs check)-       --   * (TyEq:F) If tv is a TauTv, then rhs has no foralls+       --   * Many are checked in checkTypeEq in GHC.Tc.Utils.Unify+       --   * (TyEq:OC) lhs does not occur in rhs (occurs check)+       --               Note [CEqCan occurs check]+       --   * (TyEq:F) rhs has no foralls        --       (this avoids substituting a forall for the tyvar in other types)-       --   * (TyEq:K) tcTypeKind ty `tcEqKind` tcTypeKind tv; Note [Ct kind invariant]-       --   * (TyEq:AFF) rhs (perhaps under the one cast) is *almost function-free*,-       --       See Note [Almost function-free]+       --   * (TyEq:K) tcTypeKind lhs `tcEqKind` tcTypeKind rhs; Note [Ct kind invariant]        --   * (TyEq:N) If the equality is representational, rhs has no top-level newtype-       --     See Note [No top-level newtypes on RHS of representational-       --     equalities] in GHC.Tc.Solver.Canonical-       --   * (TyEq:TV) If rhs (perhaps under the cast) is also a tv, then it is oriented+       --     See Note [No top-level newtypes on RHS of representational equalities]+       --     in GHC.Tc.Solver.Canonical. (Applies only when constructor of newtype is+       --     in scope.)+       --   * (TyEq:TV) If rhs (perhaps under a cast) is also CanEqLHS, then it is oriented        --     to give best chance of        --     unification happening; eg if rhs is touchable then lhs is too-       --     See "GHC.Tc.Solver.Canonical" Note [Canonical orientation for tyvar/tyvar equality constraints]-       --   * (TyEq:H) The RHS has no blocking coercion holes. See "GHC.Tc.Solver.Canonical"+       --     Note [TyVar/TyVar orientation] in GHC.Tc.Utils.Unify+       --   * (TyEq:H) The RHS has no blocking coercion holes. See GHC.Tc.Solver.Canonical        --     Note [Equalities with incompatible kinds], wrinkle (2)       cc_ev     :: CtEvidence, -- See Note [Ct/evidence invariant]-      cc_tyvar  :: TcTyVar,-      cc_rhs    :: TcType,     -- Not necessarily function-free (hence not Xi)-                               -- See invariants above+      cc_lhs    :: CanEqLHS,+      cc_rhs    :: Xi,         -- See invariants above        cc_eq_rel :: EqRel       -- INVARIANT: cc_eq_rel = ctEvEqRel cc_ev     } -  | CFunEqCan {  -- F xis ~ fsk-       -- Invariants:-       --   * isTypeFamilyTyCon cc_fun-       --   * tcTypeKind (F xis) = tyVarKind fsk; Note [Ct kind invariant]-       --   * always Nominal role-      cc_ev     :: CtEvidence,  -- See Note [Ct/evidence invariant]-      cc_fun    :: TyCon,       -- A type function--      cc_tyargs :: [Xi],        -- cc_tyargs are function-free (hence Xi)-        -- Either under-saturated or exactly saturated-        --    *never* over-saturated (because if so-        --    we should have decomposed)--      cc_fsk    :: TcTyVar  -- [G]  always a FlatSkolTv-                            -- [W], [WD], or [D] always a FlatMetaTv-        -- See Note [The flattening story] in GHC.Tc.Solver.Flatten-    }-   | CNonCanonical {        -- See Note [NonCanonical Semantics] in GHC.Tc.Solver.Monad       cc_ev  :: CtEvidence     }@@ -206,6 +235,18 @@       --     auxiliary type  ------------+-- | A 'CanEqLHS' is a type that can appear on the left of a canonical+-- equality: a type variable or exactly-saturated type family application.+data CanEqLHS+  = TyVarLHS TcTyVar+  | TyFamLHS TyCon  -- ^ of the family+             [Xi]   -- ^ exactly saturating the family++instance Outputable CanEqLHS where+  ppr (TyVarLHS tv)              = ppr tv+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)++------------ data QCInst  -- A much simplified version of ClsInst              -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical   = QCI { qci_ev   :: CtEvidence -- Always of type forall tvs. context => ty@@ -233,49 +274,193 @@          , hole_loc  :: CtLoc    -- ^ Where hole was written          }            -- For the hole_loc, we usually only want the TcLclEnv stored within.-           -- Except when we flatten, where we need a whole location. And this+           -- Except when we rewrite, where we need a whole location. And this            -- might get reported to the user if reducing type families in a            -- hole type loops.   -- | Used to indicate which sort of hole we have.-data HoleSort = ExprHole Id+data HoleSort = ExprHole HoleExprRef                  -- ^ Either an out-of-scope variable or a "true" hole in an                  -- expression (TypedHoles).-                 -- The 'Id' is where to store "evidence": this evidence-                 -- will be an erroring expression for -fdefer-type-errors.+                 -- The HoleExprRef says where to write the+                 -- the erroring expression for -fdefer-type-errors.               | TypeHole                  -- ^ A hole in a type (PartialTypeSignatures)+              | ConstraintHole+                 -- ^ A hole in a constraint, like @f :: (_, Eq a) => ...+                 -- Differentiated from TypeHole because a ConstraintHole+                 -- is simplified differently. See+                 -- Note [Do not simplify ConstraintHoles] in GHC.Tc.Solver.  instance Outputable Hole where-  ppr (Hole { hole_sort = ExprHole id+  ppr (Hole { hole_sort = ExprHole ref             , hole_occ  = occ             , hole_ty   = ty })-    = parens $ (braces $ ppr occ <> colon <> ppr id) <+> dcolon <+> ppr ty-  ppr (Hole { hole_sort = TypeHole+    = parens $ (braces $ ppr occ <> colon <> ppr ref) <+> dcolon <+> ppr ty+  ppr (Hole { hole_sort = _other             , hole_occ  = occ             , hole_ty   = ty })     = braces $ ppr occ <> colon <> ppr ty  instance Outputable HoleSort where-  ppr (ExprHole id) = text "ExprHole:" <> ppr id-  ppr TypeHole      = text "TypeHole"+  ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref+  ppr TypeHole       = text "TypeHole"+  ppr ConstraintHole = text "ConstraintHole"  ------------ -- | Used to indicate extra information about why a CIrredCan is irreducible-data CtIrredStatus-  = InsolubleCIS   -- this constraint will never be solved-  | BlockedCIS     -- this constraint is blocked on a coercion hole-                   -- The hole will appear in the ctEvPred of the constraint with this status-                   -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"-                   -- Wrinkle (4a)-  | OtherCIS+data CtIrredReason+  = IrredShapeReason+      -- ^ this constraint has a non-canonical shape (e.g. @c Int@, for a variable @c@) -instance Outputable CtIrredStatus where-  ppr InsolubleCIS = text "(insoluble)"-  ppr BlockedCIS   = text "(blocked)"-  ppr OtherCIS     = text "(soluble)"+  | HoleBlockerReason HoleSet+     -- ^ this constraint is blocked on the coercion hole(s) listed+     -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+     -- Wrinkle (4a). Why store the HoleSet? See Wrinkle (2) of that+     -- same Note.+     -- INVARIANT: A HoleBlockerReason constraint is a homogeneous equality whose+     --   left hand side can fit in a CanEqLHS. +  | NonCanonicalReason CheckTyEqResult+   -- ^ an equality where some invariant other than (TyEq:H) of 'CEqCan' is not satisfied;+   -- the 'CheckTyEqResult' states exactly why+   -- INVARIANT: the 'CheckTyEqResult' has some bit set other than cteHoleBlocker++  | ReprEqReason+    -- ^ an equality that cannot be decomposed because it is representational.+    -- Example: @a b ~R# Int@.+    -- These might still be solved later.+    -- INVARIANT: The constraint is a representational equality constraint++  | ShapeMismatchReason+    -- ^ a nominal equality that relates two wholly different types,+    -- like @Int ~# Bool@ or @a b ~# 3@.+    -- INVARIANT: The constraint is a nominal equality constraint++  | AbstractTyConReason+    -- ^ an equality like @T a b c ~ Q d e@ where either @T@ or @Q@+    -- is an abstract type constructor. See Note [Skolem abstract data]+    -- in GHC.Core.TyCon.+    -- INVARIANT: The constraint is an equality constraint between two TyConApps++instance Outputable CtIrredReason where+  ppr IrredShapeReason          = text "(irred)"+  ppr (HoleBlockerReason holes) = parens (text "blocked on" <+> ppr holes)+  ppr (NonCanonicalReason cter) = ppr cter+  ppr ReprEqReason              = text "(repr)"+  ppr ShapeMismatchReason       = text "(shape)"+  ppr AbstractTyConReason       = text "(abstc)"++-- | Are we sure that more solving will never solve this constraint?+isInsolubleReason :: CtIrredReason -> Bool+isInsolubleReason IrredShapeReason          = False+isInsolubleReason (HoleBlockerReason {})    = False+isInsolubleReason (NonCanonicalReason cter) = cterIsInsoluble cter+isInsolubleReason ReprEqReason              = False+isInsolubleReason ShapeMismatchReason       = True+isInsolubleReason AbstractTyConReason       = True++------------------------------------------------------------------------------+--+-- CheckTyEqResult, defined here because it is stored in a CtIrredReason+--+------------------------------------------------------------------------------++-- | A set of problems in checking the validity of a type equality.+-- See 'checkTypeEq'.+newtype CheckTyEqResult = CTER Word8++-- | No problems in checking the validity of a type equality.+cteOK :: CheckTyEqResult+cteOK = CTER zeroBits++-- | Check whether a 'CheckTyEqResult' is marked successful.+cterHasNoProblem :: CheckTyEqResult -> Bool+cterHasNoProblem (CTER 0) = True+cterHasNoProblem _        = False++-- | An individual problem that might be logged in a 'CheckTyEqResult'+newtype CheckTyEqProblem = CTEP Word8++cteImpredicative, cteTypeFamily, cteHoleBlocker, cteInsolubleOccurs,+  cteSolubleOccurs :: CheckTyEqProblem+cteImpredicative   = CTEP (bit 0)   -- forall or (=>) encountered+cteTypeFamily      = CTEP (bit 1)   -- type family encountered+cteHoleBlocker     = CTEP (bit 2)   -- blocking coercion hole+      -- See Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical+cteInsolubleOccurs = CTEP (bit 3)   -- occurs-check+cteSolubleOccurs   = CTEP (bit 4)   -- occurs-check under a type function or in a coercion+                                    -- must be one bit to the left of cteInsolubleOccurs+-- See also Note [Insoluble occurs check] in GHC.Tc.Errors++cteProblem :: CheckTyEqProblem -> CheckTyEqResult+cteProblem (CTEP mask) = CTER mask++occurs_mask :: Word8+occurs_mask = insoluble_mask .|. soluble_mask+  where+    CTEP insoluble_mask = cteInsolubleOccurs+    CTEP soluble_mask   = cteSolubleOccurs++-- | Check whether a 'CheckTyEqResult' has a 'CheckTyEqProblem'+cterHasProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool+CTER bits `cterHasProblem` CTEP mask = (bits .&. mask) /= 0++-- | Check whether a 'CheckTyEqResult' has one 'CheckTyEqProblem' and no other+cterHasOnlyProblem :: CheckTyEqResult -> CheckTyEqProblem -> Bool+CTER bits `cterHasOnlyProblem` CTEP mask = bits == mask++cterRemoveProblem :: CheckTyEqResult -> CheckTyEqProblem -> CheckTyEqResult+cterRemoveProblem (CTER bits) (CTEP mask) = CTER (bits .&. complement mask)++cterHasOccursCheck :: CheckTyEqResult -> Bool+cterHasOccursCheck (CTER bits) = (bits .&. occurs_mask) /= 0++cterClearOccursCheck :: CheckTyEqResult -> CheckTyEqResult+cterClearOccursCheck (CTER bits) = CTER (bits .&. complement occurs_mask)++-- | Mark a 'CheckTyEqResult' as not having an insoluble occurs-check: any occurs+-- check under a type family or in a representation equality is soluble.+cterSetOccursCheckSoluble :: CheckTyEqResult -> CheckTyEqResult+cterSetOccursCheckSoluble (CTER bits)+  = CTER $ ((bits .&. insoluble_mask) `shift` 1) .|. (bits .&. complement insoluble_mask)+  where+    CTEP insoluble_mask = cteInsolubleOccurs++-- | Retain only information about occurs-check failures, because only that+-- matters after recurring into a kind.+cterFromKind :: CheckTyEqResult -> CheckTyEqResult+cterFromKind (CTER bits)+  = CTER (bits .&. occurs_mask)++cterIsInsoluble :: CheckTyEqResult -> Bool+cterIsInsoluble (CTER bits) = (bits .&. mask) /= 0+  where+    mask = impredicative_mask .|. insoluble_occurs_mask++    CTEP impredicative_mask    = cteImpredicative+    CTEP insoluble_occurs_mask = cteInsolubleOccurs++instance Semigroup CheckTyEqResult where+  CTER bits1 <> CTER bits2 = CTER (bits1 .|. bits2)+instance Monoid CheckTyEqResult where+  mempty = cteOK++instance Outputable CheckTyEqResult where+  ppr cter | cterHasNoProblem cter = text "cteOK"+           | otherwise+           = parens $ fcat $ intersperse vbar $ set_bits+    where+      all_bits = [ (cteImpredicative,   "cteImpredicative")+                 , (cteTypeFamily,      "cteTypeFamily")+                 , (cteHoleBlocker,     "cteHoleBlocker")+                 , (cteInsolubleOccurs, "cteInsolubleOccurs")+                 , (cteSolubleOccurs,   "cteSolubleOccurs") ]+      set_bits = [ text str+                 | (bitmask, str) <- all_bits+                 , cter `cterHasProblem` bitmask ]+ {- Note [CIrredCan constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ CIrredCan constraints are used for constraints that are "stuck"@@ -307,61 +492,11 @@  Note [Ct kind invariant] ~~~~~~~~~~~~~~~~~~~~~~~~-CTyEqCan and CFunEqCan both require that the kind of the lhs matches the kind-of the rhs. This is necessary because both constraints are used for substitutions+CEqCan requires that the kind of the lhs matches the kind+of the rhs. This is necessary because these constraints are used for substitutions during solving. If the kinds differed, then the substitution would take a well-kinded type to an ill-kinded one. -Note [Almost function-free]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-A type is *almost function-free* if it has no type functions (something that-responds True to isTypeFamilyTyCon), except (possibly)- * under a forall, or- * in a coercion (either in a CastTy or a CercionTy)--The RHS of a CTyEqCan must be almost function-free, invariant (TyEq:AFF).-This is for two reasons:--1. There cannot be a top-level function. If there were, the equality should-   really be a CFunEqCan, not a CTyEqCan.--2. Nested functions aren't too bad, on the other hand. However, consider this-   scenario:--     type family F a = r | r -> a--     [D] F ty1 ~ fsk1-     [D] F ty2 ~ fsk2-     [D] fsk1 ~ [G Int]-     [D] fsk2 ~ [G Bool]--     type instance G Int = Char-     type instance G Bool = Char--   If it was the case that fsk1 = fsk2, then we could unifty ty1 and ty2 ---   good! They don't look equal -- but if we aggressively reduce that G Int and-   G Bool they would become equal. The "almost function free" makes sure that-   these redexes are exposed.--   Note that this equality does *not* depend on casts or coercions, and so-   skipping these forms is OK. In addition, the result of a type family cannot-   be a polytype, so skipping foralls is OK, too. We skip foralls because we-   want the output of the flattener to be almost function-free. See Note-   [Flattening under a forall] in GHC.Tc.Solver.Flatten.--   As I (Richard E) write this, it is unclear if the scenario pictured above-   can happen -- I would expect the G Int and G Bool to be reduced. But-   perhaps it can arise somehow, and maintaining almost function-free is cheap.--Historical note: CTyEqCans used to require only condition (1) above: that no-type family was at the top of an RHS. But work on #16512 suggested that the-injectivity checks were not complete, and adding the requirement that functions-do not appear even in a nested fashion was easy (it was already true, but-unenforced).--The almost-function-free property is checked by isAlmostFunctionFree in GHC.Tc.Utils.TcType.-The flattener (in GHC.Tc.Solver.Flatten) produces types that are almost function-free.- Note [Holes] ~~~~~~~~~~~~ This Note explains how GHC tracks *holes*.@@ -376,22 +511,25 @@ When a hole is encountered, a new entry of type Hole is added to the ambient WantedConstraints. The type (hole_ty) of the hole is then simplified during solving (with respect to any Givens in surrounding implications). It is-reported with all the other errors in GHC.Tc.Errors. No type family reduction-is done on hole types; this is purely because we think it will produce-better error messages not to reduce type families. This is why the-GHC.Tc.Solver.Flatten.flattenType function uses FM_SubstOnly.+reported with all the other errors in GHC.Tc.Errors.  For expression holes, the user has the option of deferring errors until runtime with -fdefer-type-errors. In this case, the hole actually has evidence: this evidence is an erroring expression that prints an error and crashes at runtime.-The ExprHole variant of holes stores the Id that will be bound to this evidence;-during constraint generation, this Id was inserted into the expression output-by the type checker.+The ExprHole variant of holes stores an IORef EvTerm that will contain this evidence;+during constraint generation, this IORef was stored in the HsUnboundVar extension+field by the type checker. The desugarer simply dereferences to get the CoreExpr. -You might think that the type of the stored Id is the same as the type of the+Prior to fixing #17812, we used to invent an Id to hold the erroring+expression, and then bind it during type-checking. But this does not support+levity-polymorphic out-of-scope identifiers. See+typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach+described above.++You might think that the type in the HoleExprRef is the same as the type of the hole. However, because the hole type (hole_ty) is rewritten with respect to givens, this might not be the case. That is, the hole_ty is always (~) to the-type of the Id, but they might not be `eqType`. We need the type of the generated+type of the HoleExprRef, but they might not be `eqType`. We need the type of the generated evidence to match what is expected in the context of the hole, and so we must store these types separately. @@ -404,8 +542,8 @@ mkNonCanonicalCt :: Ct -> Ct mkNonCanonicalCt ct = CNonCanonical { cc_ev = cc_ev ct } -mkIrredCt :: CtIrredStatus -> CtEvidence -> Ct-mkIrredCt status ev = CIrredCan { cc_ev = ev, cc_status = status }+mkIrredCt :: CtIrredReason -> CtEvidence -> Ct+mkIrredCt reason ev = CIrredCan { cc_ev = ev, cc_reason = reason }  mkGivens :: CtLoc -> [EvId] -> [Ct] mkGivens loc ev_ids@@ -458,17 +596,50 @@   ppr ct = ppr (ctEvidence ct) <+> parens pp_sort     where       pp_sort = case ct of-         CTyEqCan {}      -> text "CTyEqCan"-         CFunEqCan {}     -> text "CFunEqCan"+         CEqCan {}        -> text "CEqCan"          CNonCanonical {} -> text "CNonCanonical"          CDictCan { cc_pend_sc = pend_sc }             | pend_sc   -> text "CDictCan(psc)"             | otherwise -> text "CDictCan"-         CIrredCan { cc_status = status } -> text "CIrredCan" <> ppr status+         CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason          CQuantCan (QCI { qci_pend_sc = pend_sc })             | pend_sc   -> text "CQuantCan(psc)"             | otherwise -> text "CQuantCan" +-----------------------------------+-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated+-- type family application?+-- Does not look through type synonyms.+canEqLHS_maybe :: Xi -> Maybe CanEqLHS+canEqLHS_maybe xi+  | Just tv <- tcGetTyVar_maybe xi+  = Just $ TyVarLHS tv++  | Just (tc, args) <- tcSplitTyConApp_maybe xi+  , isTypeFamilyTyCon tc+  , args `lengthIs` tyConArity tc+  = Just $ TyFamLHS tc args++  | otherwise+  = Nothing++-- | Convert a 'CanEqLHS' back into a 'Type'+canEqLHSType :: CanEqLHS -> TcType+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args++-- | Retrieve the kind of a 'CanEqLHS'+canEqLHSKind :: CanEqLHS -> TcKind+canEqLHSKind (TyVarLHS tv) = tyVarKind tv+canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args++-- | Are two 'CanEqLHS's equal?+eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool+eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2+eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)+  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2+eqCanEqLHS _ _ = False+ {- ************************************************************************ *                                                                      *@@ -514,19 +685,19 @@ -- | Returns free variables of WantedConstraints as a non-deterministic -- set. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoVarsOfWC :: WantedConstraints -> TyCoVarSet--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoVarsOfWC = fvVarSet . tyCoFVsOfWC  -- | Returns free variables of WantedConstraints as a deterministically -- ordered list. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoVarsOfWCList :: WantedConstraints -> [TyCoVar]--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoVarsOfWCList = fvVarList . tyCoFVsOfWC  -- | Returns free variables of WantedConstraints as a composable FV -- computation. See Note [Deterministic FV] in "GHC.Utils.FV". tyCoFVsOfWC :: WantedConstraints -> FV--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoFVsOfWC (WC { wc_simple = simple, wc_impl = implic, wc_holes = holes })   = tyCoFVsOfCts simple `unionFV`     tyCoFVsOfBag tyCoFVsOfImplic implic `unionFV`@@ -535,7 +706,7 @@ -- | Returns free variables of Implication as a composable FV computation. -- See Note [Deterministic FV] in "GHC.Utils.FV". tyCoFVsOfImplic :: Implication -> FV--- Only called on *zonked* things, hence no need to worry about flatten-skolems+-- Only called on *zonked* things tyCoFVsOfImplic (Implic { ic_skols = skols                         , ic_given = givens                         , ic_wanted = wanted })@@ -601,8 +772,8 @@      keep_deriv       = case ct of-          CIrredCan { cc_status = InsolubleCIS } -> keep_eq True-          _                                      -> keep_eq False+          CIrredCan { cc_reason = reason } | isInsolubleReason reason -> keep_eq True+          _                                                           -> keep_eq False      keep_eq definitely_insoluble        | isGivenOrigin orig    -- Arising only from givens@@ -704,26 +875,6 @@ isDerivedCt :: Ct -> Bool isDerivedCt = isDerived . ctEvidence -isCTyEqCan :: Ct -> Bool-isCTyEqCan (CTyEqCan {})  = True-isCTyEqCan _              = False--isCDictCan_Maybe :: Ct -> Maybe Class-isCDictCan_Maybe (CDictCan {cc_class = cls })  = Just cls-isCDictCan_Maybe _              = Nothing--isCFunEqCan_maybe :: Ct -> Maybe (TyCon, [Type])-isCFunEqCan_maybe (CFunEqCan { cc_fun = tc, cc_tyargs = xis }) = Just (tc, xis)-isCFunEqCan_maybe _ = Nothing--isCFunEqCan :: Ct -> Bool-isCFunEqCan (CFunEqCan {}) = True-isCFunEqCan _ = False--isCNonCanonical :: Ct -> Bool-isCNonCanonical (CNonCanonical {}) = True-isCNonCanonical _ = False- {- Note [Custom type errors in constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -968,18 +1119,24 @@ dropMisleading :: WantedConstraints -> WantedConstraints -- Drop misleading constraints; really just class constraints -- See Note [Constraints and errors] in GHC.Tc.Utils.Monad+--   for why this function is so strange, treating the 'simples'+--   and the implications differently.  Sigh. dropMisleading (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })-  = WC { wc_simple = filterBag keep_ct simples+  = WC { wc_simple = filterBag insolubleCt simples        , wc_impl   = mapBag drop_implic implics        , wc_holes  = filterBag isOutOfScopeHole holes }   where     drop_implic implic-      = implic { ic_wanted = dropMisleading (ic_wanted implic) }-    keep_ct ct-      = case classifyPredType (ctPred ct) of-          ClassPred {} -> False-          _ -> True+      = implic { ic_wanted = drop_wanted (ic_wanted implic) }+    drop_wanted (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })+      = WC { wc_simple = filterBag keep_ct simples+           , wc_impl   = mapBag drop_implic implics+           , wc_holes  = filterBag isOutOfScopeHole holes } +    keep_ct ct = case classifyPredType (ctPred ct) of+                    ClassPred {} -> False+                    _ -> True+ isSolvedStatus :: ImplicStatus -> Bool isSolvedStatus (IC_Solved {}) = True isSolvedStatus _              = False@@ -1023,8 +1180,8 @@ --                   True for  Int ~ F a Int --               but False for  Maybe Int ~ F a Int Int --               (where F is an arity-1 type function)-insolubleEqCt (CIrredCan { cc_status = InsolubleCIS }) = True-insolubleEqCt _                                        = False+insolubleEqCt (CIrredCan { cc_reason = reason }) = isInsolubleReason reason+insolubleEqCt _                                  = False  -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes]@@ -1096,7 +1253,7 @@  data Implication   = Implic {   -- Invariants for a tree of implications:-               -- see TcType Note [TcLevel and untouchable type variables]+               -- see TcType Note [TcLevel invariants]        ic_tclvl :: TcLevel,       -- TcLevel of unification variables                                  -- allocated /inside/ this implication@@ -1109,8 +1266,7 @@                                  --   (order does not matter)                                  -- See Invariant (GivenInv) in GHC.Tc.Utils.TcType -      ic_no_eqs :: Bool,         -- True  <=> ic_givens have no equalities, for sure-                                 -- False <=> ic_givens might have equalities+      ic_given_eqs :: HasGivenEqs,  -- Are there Given equalities here?        ic_warn_inaccessible :: Bool,                                  -- True  <=> -Winaccessible-code is enabled@@ -1157,7 +1313,7 @@             , ic_skols      = []             , ic_given      = []             , ic_wanted     = emptyWC-            , ic_no_eqs     = False+            , ic_given_eqs  = MaybeGivenEqs             , ic_status     = IC_Unsolved             , ic_need_inner = emptyVarSet             , ic_need_outer = emptyVarSet }@@ -1169,14 +1325,65 @@    | IC_Insoluble  -- At least one insoluble constraint in the tree -  | IC_BadTelescope  -- solved, but the skolems in the telescope are out of-                     -- dependency order+  | IC_BadTelescope  -- Solved, but the skolems in the telescope are out of+                     -- dependency order. See Note [Checking telescopes]    | IC_Unsolved   -- Neither of the above; might go either way +data HasGivenEqs -- See Note [HasGivenEqs]+  = NoGivenEqs      -- Definitely no given equalities,+                    --   except by Note [Let-bound skolems] in GHC.Tc.Solver.Monad+  | LocalGivenEqs   -- Might have Given equalities, but only ones that affect only+                    --   local skolems e.g. forall a b. (a ~ F b) => ...+  | MaybeGivenEqs   -- Might have any kind of Given equalities; no floating out+                    --   is possible.+  deriving Eq++{- Note [HasGivenEqs]+~~~~~~~~~~~~~~~~~~~~~+The GivenEqs data type describes the Given constraints of an implication constraint:++* NoGivenEqs: definitely no Given equalities, except perhaps let-bound skolems+  which don't count: see Note [Let-bound skolems] in GHC.Tc.Solver.Monad+  Examples: forall a. Eq a => ...+            forall a. (Show a, Num a) => ...+            forall a. a ~ Either Int Bool => ...  -- Let-bound skolem++* LocalGivenEqs: definitely no Given equalities that would affect principal+  types.  But may have equalities that affect only skolems of this implication+  (and hence do not affect princial types)+  Examples: forall a. F a ~ Int => ...+            forall a b. F a ~ G b => ...++* MaybeGivenEqs: may have Given equalities that would affect principal+  types+  Examples: forall. (a ~ b) => ...+            forall a. F a ~ b => ...+            forall a. c a => ...       -- The 'c' might be instantiated to (b ~)+            forall a. C a b => ....+               where class x~y => C a b+               so there is an equality in the superclass of a Given++The HasGivenEqs classifications affect two things:++* Suppressing redundant givens during error reporting; see GHC.Tc.Errors+  Note [Suppress redundant givens during error reporting]++* Floating in approximateWC.++Specifically, here's how it goes:++                 Stops floating    |   Suppresses Givens in errors+                 in approximateWC  |+                 -----------------------------------------------+ NoGivenEqs         NO             |         YES+ LocalGivenEqs      NO             |         NO+ MaybeGivenEqs      YES            |         NO+-}+ instance Outputable Implication where   ppr (Implic { ic_tclvl = tclvl, ic_skols = skols-              , ic_given = given, ic_no_eqs = no_eqs+              , ic_given = given, ic_given_eqs = given_eqs               , ic_wanted = wanted, ic_status = status               , ic_binds = binds               , ic_need_inner = need_in, ic_need_outer = need_out@@ -1184,7 +1391,7 @@    = hang (text "Implic" <+> lbrace)         2 (sep [ text "TcLevel =" <+> ppr tclvl                , text "Skolems =" <+> pprTyVars skols-               , text "No-eqs =" <+> ppr no_eqs+               , text "Given-eqs =" <+> ppr given_eqs                , text "Status =" <+> ppr status                , hang (text "Given =")  2 (pprEvVars given)                , hang (text "Wanted =") 2 (ppr wanted)@@ -1200,6 +1407,30 @@   ppr (IC_Solved { ics_dead = dead })     = text "Solved" <+> (braces (text "Dead givens =" <+> ppr dead)) +checkTelescopeSkol :: SkolemInfo -> Bool+-- See Note [Checking telescopes]+checkTelescopeSkol (ForAllSkol {}) = True+checkTelescopeSkol _               = False++instance Outputable HasGivenEqs where+  ppr NoGivenEqs    = text "NoGivenEqs"+  ppr LocalGivenEqs = text "LocalGivenEqs"+  ppr MaybeGivenEqs = text "MaybeGivenEqs"++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Semigroup HasGivenEqs where+  NoGivenEqs <> other = other+  other <> NoGivenEqs = other++  MaybeGivenEqs <> _other = MaybeGivenEqs+  _other <> MaybeGivenEqs = MaybeGivenEqs++  LocalGivenEqs <> LocalGivenEqs = LocalGivenEqs++-- Used in GHC.Tc.Solver.Monad.getHasGivenEqs+instance Monoid HasGivenEqs where+  mempty = NoGivenEqs+ {- Note [Checking telescopes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When kind-checking a /user-written/ type, we might have a "bad telescope"@@ -1234,7 +1465,7 @@   that binds existentials, where the type of the data constructor is   known to be valid (it in tcConPat), no need for the check. -  So the check is done if and only if ic_info is ForAllSkol+  So the check is done /if and only if/ ic_info is ForAllSkol.  * If ic_info is (ForAllSkol dt dvs), the dvs::SDoc displays the   original, user-written type variables.@@ -1244,6 +1475,18 @@   constraint solver a chance to make that bad-telescope test!  Hence   the extra guard in emitResidualTvConstraint; see #16247 +* Don't mix up inferred and explicit variables in the same implication+  constraint.  E.g.+      foo :: forall a kx (b :: kx). SameKind a b+  We want an implication+      Implic { ic_skol = [(a::kx), kx, (b::kx)], ... }+  but GHC will attempt to quantify over kx, since it is free in (a::kx),+  and it's hopelessly confusing to report an error about quantified+  variables   kx (a::kx) kx (b::kx).+  Instead, the outer quantification over kx should be in a separate+  implication. TL;DR: an explicit forall should generate an implication+  quantified only over those explicitly quantified variables.+ Note [Needed evidence variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Th ic_need_evs field holds the free vars of ic_binds, and all the@@ -1270,15 +1513,31 @@  Note [Skolems in an implication] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The skolems in an implication are not there to perform a skolem escape-check.  That happens because all the environment variables are in the-untouchables, and therefore cannot be unified with anything at all,-let alone the skolems.+The skolems in an implication are used: -Instead, ic_skols is used only when considering floating a constraint-outside the implication in GHC.Tc.Solver.floatEqualities or-GHC.Tc.Solver.approximateImplications+* When considering floating a constraint outside the implication in+  GHC.Tc.Solver.floatEqualities or GHC.Tc.Solver.approximateImplications+  For this, we can treat ic_skols as a set. +* When checking that a /user-specified/ forall (ic_info = ForAllSkol tvs)+  has its variables in the correct order; see Note [Checking telescopes].+  Only for these implications does ic_skols need to be a list.++Nota bene: Although ic_skols is a list, it is not necessarily+in dependency order:+- In the ic_info=ForAllSkol case, the user might have written them+  in the wrong order+- In the case of a type signature like+      f :: [a] -> [b]+  the renamer gathers the implicit "outer" forall'd variables {a,b}, but+  does not know what order to put them in.  The type checker can sort them+  into dependency order, but only after solving all the kind constraints;+  and to do that it's convenient to create the Implication!++So we accept that ic_skols may be out of order.  Think of it as a set or+(in the case of ic_info=ForAllSkol, a list in user-specified, and possibly+wrong, order.+ Note [Insoluble constraints] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some of the errors that we get during canonicalization are best@@ -1380,7 +1639,7 @@    | HoleDest  CoercionHole  -- ^ fill in this hole with the evidence               -- HoleDest is always used for type-equalities-              -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep"+              -- See Note [Coercion holes] in GHC.Core.TyCo.Rep  data CtEvidence   = CtGiven    -- Truly given, not depending on subgoals@@ -1451,10 +1710,9 @@  instance Outputable CtEvidence where   ppr ev = ppr (ctEvFlavour ev)-           <+> pp_ev-           <+> braces (ppr (ctl_depth (ctEvLoc ev))) <> dcolon-                  -- Show the sub-goal depth too-           <+> ppr (ctEvPred ev)+           <+> pp_ev <+> braces (ppr (ctl_depth (ctEvLoc ev)))+                         -- Show the sub-goal depth too+               <> dcolon <+> ppr (ctEvPred ev)     where       pp_ev = case ev of              CtGiven { ctev_evar = v } -> ppr v@@ -1496,9 +1754,7 @@  * [WD] Wanted WDeriv: a single constraint that represents                       both [W] and [D]-  We keep them paired as one both for efficiency, and because-  when we have a finite map  F tys -> CFunEqCan, it's inconvenient-  to have two CFunEqCans in the range+  We keep them paired as one both for efficiency  The ctev_nosh field of a Wanted distinguishes between [W] and [WD] @@ -1521,17 +1777,18 @@              -- See Note [The improvement story and derived shadows] in GHC.Tc.Solver.Monad   deriving( Eq ) -isGivenOrWDeriv :: CtFlavour -> Bool-isGivenOrWDeriv Given           = True-isGivenOrWDeriv (Wanted WDeriv) = True-isGivenOrWDeriv _               = False- instance Outputable CtFlavour where   ppr Given           = text "[G]"   ppr (Wanted WDeriv) = text "[WD]"   ppr (Wanted WOnly)  = text "[W]"   ppr Derived         = text "[D]" +-- | Does this 'CtFlavour' subsumed 'Derived'? True of @[WD]@ and @[D]@.+ctFlavourContainsDerived :: CtFlavour -> Bool+ctFlavourContainsDerived (Wanted WDeriv) = True+ctFlavourContainsDerived Derived         = True+ctFlavourContainsDerived _               = False+ ctEvFlavour :: CtEvidence -> CtFlavour ctEvFlavour (CtWanted { ctev_nosh = nosh }) = Wanted nosh ctEvFlavour (CtGiven {})                    = Given@@ -1551,17 +1808,15 @@ -- Uses short-cuts to role for special cases ctFlavourRole (CDictCan { cc_ev = ev })   = (ctEvFlavour ev, NomEq)-ctFlavourRole (CTyEqCan { cc_ev = ev, cc_eq_rel = eq_rel })+ctFlavourRole (CEqCan { cc_ev = ev, cc_eq_rel = eq_rel })   = (ctEvFlavour ev, eq_rel)-ctFlavourRole (CFunEqCan { cc_ev = ev })-  = (ctEvFlavour ev, NomEq) ctFlavourRole ct   = ctEvFlavourRole (ctEvidence ct)  {- Note [eqCanRewrite] ~~~~~~~~~~~~~~~~~~~~~~-(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CTyEqCan of form-tv ~ ty) can be used to rewrite ct2.  It must satisfy the properties of+(eqCanRewrite ct1 ct2) holds if the constraint ct1 (a CEqCan of form+lhs ~ ty) can be used to rewrite ct2.  It must satisfy the properties of a can-rewrite relation, see Definition [Can-rewrite relation] in GHC.Tc.Solver.Monad. @@ -1601,6 +1856,59 @@ we can; straight from the Wanteds during improvement. And from a Derived ReprEq we could conceivably get a Derived NomEq improvement (by decomposing a type constructor with Nomninal role), and hence unify.++This restriction that (Derived, NomEq) cannot rewrite (Derived, ReprEq) bites,+in an obscure scenario:++  data T a+  type role T nominal++  type family F a++  g :: forall b a. (F a ~ T a, Coercible (F a) (T b)) => ()+  g = ()++  f :: forall a. (F a ~ T a) => ()+  f = g @a++The problem is in the body of f. We have++  [G]  F a ~N T a+  [WD] F alpha ~N T alpha+  [WD] F alpha ~R T a++The Wanteds aren't of use, so let's just look at Deriveds:++  [G] F a ~N T a+  [D] F alpha ~N T alpha+  [D] F alpha ~R T a++As written, this makes no progress, and GHC errors. But, if we+allowed D/N to rewrite D/R, the first D could rewrite the second:++  [G] F a ~N T a+  [D] F alpha ~N T alpha+  [D] T alpha ~R T a++Now we decompose the second D to get++  [D] alpha ~N a++noting the role annotation on T. This causes (alpha := a), and then+everything else unlocks.++What to do? We could "decompose" nominal equalities into nominal-only+("NO") equalities and representational ones, where a NO equality rewrites+only nominals. That is, when considering whether [D] F alpha ~N T alpha+should rewrite [D] F alpha ~R T a, we could require splitting the first D+into [D] F alpha ~NO T alpha, [D] F alpha ~R T alpha. Then, we use the R+half of the split to rewrite the second D, and off we go. This splitting+would allow the split-off R equality to be rewritten by other equalities,+thus avoiding the problem in Note [Why R2?] in GHC.Tc.Solver.Monad.++This infelicity is #19665 and tested in typecheck/should_compile/T19665+(marked as expect_broken).+ -}  eqCanRewrite :: EqRel -> EqRel -> Bool@@ -1627,47 +1935,11 @@ eqMayRewriteFR (Derived,       NomEq) (Wanted WDeriv, NomEq) = True eqMayRewriteFR fr1 fr2 = eqCanRewriteFR fr1 fr2 -------------------{- Note [funEqCanDischarge]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have two CFunEqCans with the same LHS:-    (x1:F ts ~ f1) `funEqCanDischarge` (x2:F ts ~ f2)-Can we drop x2 in favour of x1, either unifying-f2 (if it's a flatten meta-var) or adding a new Given-(f1 ~ f2), if x2 is a Given?--Answer: yes if funEqCanDischarge is true.--}--funEqCanDischarge-  :: CtEvidence -> CtEvidence-  -> ( SwapFlag   -- NotSwapped => lhs can discharge rhs-                  -- Swapped    => rhs can discharge lhs-     , Bool)      -- True <=> upgrade non-discharded one-                  --          from [W] to [WD]--- See Note [funEqCanDischarge]-funEqCanDischarge ev1 ev2-  = ASSERT2( ctEvEqRel ev1 == NomEq, ppr ev1 )-    ASSERT2( ctEvEqRel ev2 == NomEq, ppr ev2 )-    -- CFunEqCans are all Nominal, hence asserts-    funEqCanDischargeF (ctEvFlavour ev1) (ctEvFlavour ev2)--funEqCanDischargeF :: CtFlavour -> CtFlavour -> (SwapFlag, Bool)-funEqCanDischargeF Given           _               = (NotSwapped, False)-funEqCanDischargeF _               Given           = (IsSwapped,  False)-funEqCanDischargeF (Wanted WDeriv) _               = (NotSwapped, False)-funEqCanDischargeF _               (Wanted WDeriv) = (IsSwapped,  True)-funEqCanDischargeF (Wanted WOnly)  (Wanted WOnly)  = (NotSwapped, False)-funEqCanDischargeF (Wanted WOnly)  Derived         = (NotSwapped, True)-funEqCanDischargeF Derived         (Wanted WOnly)  = (IsSwapped,  True)-funEqCanDischargeF Derived         Derived         = (NotSwapped, False)-- {- Note [eqCanDischarge] ~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have two identical CTyEqCan equality constraints+Suppose we have two identical CEqCan equality constraints (i.e. both LHS and RHS are the same)-      (x1:a~t) `eqCanDischarge` (xs:a~t)+      (x1:lhs~t) `eqCanDischarge` (xs:lhs~t) Can we just drop x2 in favour of x1?  Answer: yes if eqCanDischarge is true.@@ -1797,7 +2069,7 @@ mkKindLoc :: TcType -> TcType   -- original *types* being compared           -> CtLoc -> CtLoc mkKindLoc s1 s2 loc = setCtLocOrigin (toKindLoc loc)-                        (KindEqOrigin s1 (Just s2) (ctLocOrigin loc)+                        (KindEqOrigin s1 s2 (ctLocOrigin loc)                                       (ctLocTypeOrKind_maybe loc))  -- | Take a CtLoc and moves it to the kind level

GHC/Tc/Types/EvTerm.hs view

@@ -6,27 +6,38 @@  import GHC.Prelude -import GHC.Data.FastString+import GHC.Driver.Session++import GHC.Tc.Types.Evidence++import GHC.Unit++import GHC.Builtin.Names+import GHC.Builtin.Types ( liftedRepTy, unitTy )+ import GHC.Core.Type import GHC.Core import GHC.Core.Make-import GHC.Types.Literal ( Literal(..) )-import GHC.Tc.Types.Evidence-import GHC.Driver.Types-import GHC.Driver.Session-import GHC.Types.Name-import GHC.Unit import GHC.Core.Utils-import GHC.Builtin.Names++import GHC.Types.Literal ( Literal(..) ) import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.TyThing +import GHC.Data.FastString+ -- Used with Opt_DeferTypeErrors -- See Note [Deferring coercion errors to runtime] -- in GHC.Tc.Solver evDelayedError :: Type -> FastString -> EvTerm evDelayedError ty msg   = EvExpr $-    Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]+    let fail_expr = Var errorId `mkTyApps` [liftedRepTy, unitTy] `mkApps` [litMsg]+    in mkWildCase fail_expr (unrestricted unitTy) ty []+       -- See Note [Incompleteness and linearity] in GHC.HsToCore.Utils+       -- c.f. mkFailExpr in GHC.HsToCore.Utils+   where     errorId = tYPE_ERROR_ID     litMsg  = Lit (LitString (bytesFS msg))

GHC/Tc/Types/Evidence.hs view

@@ -33,16 +33,20 @@   EvCallStack(..),   EvTypeable(..), +  -- * HoleExprRef+  HoleExprRef(..),+   -- * TcCoercion   TcCoercion, TcCoercionR, TcCoercionN, TcCoercionP, CoercionHole,-  TcMCoercion,+  TcMCoercion, TcMCoercionN, TcMCoercionR,   Role(..), LeftOrRight(..), pickLR,   mkTcReflCo, mkTcNomReflCo, mkTcRepReflCo,   mkTcTyConAppCo, mkTcAppCo, mkTcFunCo,   mkTcAxInstCo, mkTcUnbranchedAxInstCo, mkTcForAllCo, mkTcForAllCos,-  mkTcSymCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSubCo,-  tcDowngradeRole,-  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflLeftCo, mkTcPhantomCo,+  mkTcSymCo, mkTcSymMCo, mkTcTransCo, mkTcNthCo, mkTcLRCo, mkTcSubCo, maybeTcSymCo,+  maybeTcSubCo, tcDowngradeRole,+  mkTcAxiomRuleCo, mkTcGReflRightCo, mkTcGReflRightMCo, mkTcGReflLeftCo, mkTcGReflLeftMCo,+  mkTcPhantomCo,   mkTcCoherenceLeftCo,   mkTcCoherenceRightCo,   mkTcKindCo,@@ -69,23 +73,25 @@ import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.TyCon-import GHC.Core.DataCon( DataCon, dataConWrapId )-import GHC.Core.Class( Class )+import GHC.Core.DataCon ( DataCon, dataConWrapId ) import GHC.Builtin.Names import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Core.Predicate import GHC.Types.Name import GHC.Data.Pair+import GHC.Types.Basic  import GHC.Core-import GHC.Core.Class ( classSCSelId )+import GHC.Core.Class (Class, classSCSelId ) import GHC.Core.FVs   ( exprSomeFreeVars )  import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable+ import GHC.Data.Bag import qualified Data.Data as Data-import GHC.Utils.Outputable import GHC.Types.SrcLoc import Data.IORef( IORef ) import GHC.Types.Unique.Set@@ -110,10 +116,13 @@ type TcCoercionN = CoercionN    -- A Nominal          coercion ~N type TcCoercionR = CoercionR    -- A Representational coercion ~R type TcCoercionP = CoercionP    -- a phantom coercion-type TcMCoercion = MCoercion+type TcMCoercion  = MCoercion+type TcMCoercionN = MCoercionN  -- nominal+type TcMCoercionR = MCoercionR  -- representational  mkTcReflCo             :: Role -> TcType -> TcCoercion mkTcSymCo              :: TcCoercion -> TcCoercion+mkTcSymMCo             :: TcMCoercion -> TcMCoercion mkTcTransCo            :: TcCoercion -> TcCoercion -> TcCoercion mkTcNomReflCo          :: TcType -> TcCoercionN mkTcRepReflCo          :: TcType -> TcCoercionR@@ -128,11 +137,13 @@ mkTcForAllCos          :: [(TyVar, TcCoercionN)] -> TcCoercion -> TcCoercion mkTcNthCo              :: Role -> Int -> TcCoercion -> TcCoercion mkTcLRCo               :: LeftOrRight -> TcCoercion -> TcCoercion-mkTcSubCo              :: TcCoercionN -> TcCoercionR+mkTcSubCo              :: HasDebugCallStack => TcCoercionN -> TcCoercionR tcDowngradeRole        :: Role -> Role -> TcCoercion -> TcCoercion mkTcAxiomRuleCo        :: CoAxiomRule -> [TcCoercion] -> TcCoercionR mkTcGReflRightCo       :: Role -> TcType -> TcCoercionN -> TcCoercion+mkTcGReflRightMCo      :: Role -> TcType -> TcMCoercionN -> TcCoercion mkTcGReflLeftCo        :: Role -> TcType -> TcCoercionN -> TcCoercion+mkTcGReflLeftMCo       :: Role -> TcType -> TcMCoercionN -> TcCoercion mkTcCoherenceLeftCo    :: Role -> TcType -> TcCoercionN                        -> TcCoercion -> TcCoercion mkTcCoherenceRightCo   :: Role -> TcType -> TcCoercionN@@ -152,6 +163,7 @@  mkTcReflCo             = mkReflCo mkTcSymCo              = mkSymCo+mkTcSymMCo             = mkSymMCo mkTcTransCo            = mkTransCo mkTcNomReflCo          = mkNomReflCo mkTcRepReflCo          = mkRepReflCo@@ -168,7 +180,9 @@ tcDowngradeRole        = downgradeRole mkTcAxiomRuleCo        = mkAxiomRuleCo mkTcGReflRightCo       = mkGReflRightCo+mkTcGReflRightMCo      = mkGReflRightMCo mkTcGReflLeftCo        = mkGReflLeftCo+mkTcGReflLeftMCo       = mkGReflLeftMCo mkTcCoherenceLeftCo    = mkCoherenceLeftCo mkTcCoherenceRightCo   = mkCoherenceRightCo mkTcPhantomCo          = mkPhantomCo@@ -183,10 +197,14 @@  -- | If the EqRel is ReprEq, makes a SubCo; otherwise, does nothing. -- Note that the input coercion should always be nominal.-maybeTcSubCo :: EqRel -> TcCoercion -> TcCoercion+maybeTcSubCo :: HasDebugCallStack => EqRel -> TcCoercionN -> TcCoercion maybeTcSubCo NomEq  = id maybeTcSubCo ReprEq = mkTcSubCo +-- | If a 'SwapFlag' is 'IsSwapped', flip the orientation of a coercion+maybeTcSymCo :: SwapFlag -> TcCoercion -> TcCoercion+maybeTcSymCo IsSwapped  co = mkTcSymCo co+maybeTcSymCo NotSwapped co = co  {- %************************************************************************@@ -462,7 +480,7 @@ evidence bindings are allowed.  Notebly ():    - Places in types where we are solving kind constraints (all of which-    are equalities); see solveEqualities, solveLocalEqualities+    are equalities); see solveEqualities    - When unifying forall-types -}@@ -643,6 +661,29 @@   deriving Data.Data  {-+************************************************************************+*                                                                      *+         Evidence for holes+*                                                                      *+************************************************************************+-}++-- | Where to store evidence for expression holes+-- See Note [Holes] in GHC.Tc.Types.Constraint+data HoleExprRef = HER (IORef EvTerm)   -- ^ where to write the erroring expression+                       TcType           -- ^ expected type of that expression+                       Unique           -- ^ for debug output only++instance Outputable HoleExprRef where+  ppr (HER _ _ u) = ppr u++instance Data.Data HoleExprRef where+  -- Placeholder; we can't traverse into HoleExprRef+  toConstr _   = abstractConstr "HoleExprRef"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = Data.mkNoRepType "HoleExprRef"++{- Note [Typeable evidence terms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The EvTypeable data type looks isomorphic to Type, but the EvTerms@@ -764,7 +805,7 @@       EvCsEmpty -   (see GHC.Tc.Solver.simpl_top and GHC.Tc.Solver.defaultCallStacks)+   (see GHC.Tc.Solver.simplifyTopWanteds and GHC.Tc.Solver.defaultCallStacks)  This provides a lightweight mechanism for building up call-stacks explicitly, but is notably limited by the fact that the stack will@@ -1020,7 +1061,7 @@ -- overloaded-label dictionary to expose the underlying value. We -- expect the 'Type' to have the form `IP sym ty` or `IsLabel sym ty`, -- and return a 'Coercion' `co :: IP sym ty ~ ty` or--- `co :: IsLabel sym ty ~ Proxy# sym -> ty`.  See also+-- `co :: IsLabel sym ty ~ ty`.  See also -- Note [Type-checking overloaded labels] in "GHC.Tc.Gen.Expr". unwrapIP :: Type -> CoercionR unwrapIP ty =

GHC/Tc/Types/Origin.hs view

@@ -28,7 +28,6 @@  import GHC.Hs -import GHC.Types.Id import GHC.Core.DataCon import GHC.Core.ConLike import GHC.Core.TyCon@@ -37,13 +36,17 @@ import GHC.Core.Multiplicity ( scaledThing )  import GHC.Unit.Module+import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader-+import GHC.Types.Basic import GHC.Types.SrcLoc+ import GHC.Data.FastString+ import GHC.Utils.Outputable-import GHC.Types.Basic+import GHC.Utils.Panic+import GHC.Driver.Ppr  {- ********************************************************************* *                                                                      *@@ -81,15 +84,12 @@                         --   or  (x::t, y) = e   | RuleSigCtxt Name    -- LHS of a RULE forall                         --    RULE "foo" forall (x :: a -> a). f (Just x) = ...-  | ResSigCtxt          -- Result type sig-                        --      f x :: t = ....   | ForSigCtxt Name     -- Foreign import or export signature   | DefaultDeclCtxt     -- Types in a default declaration   | InstDeclCtxt Bool   -- An instance declaration                         --    True:  stand-alone deriving                         --    False: vanilla instance declaration   | SpecInstCtxt        -- SPECIALISE instance pragma-  | ThBrackCtxt         -- Template Haskell type brackets [t| ... |]   | GenSigCtxt          -- Higher-rank or impredicative situations                         -- e.g. (f e) where f has a higher-rank type                         -- We might want to elaborate this@@ -133,9 +133,7 @@ pprUserTypeCtxt TypeAppCtxt       = text "a type argument" pprUserTypeCtxt (ConArgCtxt c)    = text "the type of the constructor" <+> quotes (ppr c) pprUserTypeCtxt (TySynCtxt c)     = text "the RHS of the type synonym" <+> quotes (ppr c)-pprUserTypeCtxt ThBrackCtxt       = text "a Template Haskell quotation [t|...|]" pprUserTypeCtxt PatSigCtxt        = text "a pattern type signature"-pprUserTypeCtxt ResSigCtxt        = text "a result type signature" pprUserTypeCtxt (ForSigCtxt n)    = text "the foreign declaration for" <+> quotes (ppr n) pprUserTypeCtxt DefaultDeclCtxt   = text "a type in a `default' declaration" pprUserTypeCtxt (InstDeclCtxt False) = text "an instance declaration"@@ -186,7 +184,6 @@                  -- hence, we have less info    | ForAllSkol  -- Bound by a user-written "forall".-       SDoc        -- Shows the entire forall type        SDoc        -- Shows just the binders, used when reporting a bad telescope                    -- See Note [Checking telescopes] in GHC.Tc.Types.Constraint @@ -246,7 +243,7 @@ -- Complete the sentence "is a rigid type variable bound by..." pprSkolInfo (SigSkol cx ty _) = pprSigSkolInfo cx ty pprSkolInfo (SigTypeSkol cx)  = pprUserTypeCtxt cx-pprSkolInfo (ForAllSkol pt _) = quotes pt+pprSkolInfo (ForAllSkol tvs)  = text "an explicit forall" <+> tvs pprSkolInfo (IPSkol ips)      = text "the implicit-parameter binding" <> plural ips <+> text "for"                                  <+> pprWithCommas ppr ips pprSkolInfo (DerivSkol pred)  = text "the deriving clause for" <+> quotes (ppr pred)@@ -260,7 +257,7 @@                                     , text "in" <+> pprMatchContext mc ] pprSkolInfo (InferSkol ids)   = hang (text "the inferred type" <> plural ids <+> text "of")                                    2 (vcat [ ppr name <+> dcolon <+> ppr ty-                                                   | (name,ty) <- ids ])+                                           | (name,ty) <- ids ]) pprSkolInfo (UnifyForAllSkol ty) = text "the type" <+> ppr ty pprSkolInfo (TyConSkol flav name) = text "the" <+> ppr flav <+> text "declaration for" <+> quotes (ppr name) pprSkolInfo (DataConSkol name)= text "the data constructor" <+> quotes (ppr name)@@ -286,10 +283,10 @@  pprPatSkolInfo :: ConLike -> SDoc pprPatSkolInfo (RealDataCon dc)-  = sdocWithDynFlags (\dflags ->+  = sdocOption sdocLinearTypes (\show_linear_types ->       sep [ text "a pattern with constructor:"           , nest 2 $ ppr dc <+> dcolon-            <+> pprType (dataConDisplayType dflags dc) <> comma ])+            <+> pprType (dataConDisplayType show_linear_types dc) <> comma ])             -- pprType prints forall's regardless of -fprint-explicit-foralls             -- which is what we want here, since we might be saying             -- type variable 't' is bound by ...@@ -306,7 +303,7 @@ but the type 'ty' is not very helpful.  The full pattern-synonym type has the provided and required pieces, which it is inconvenient to record and display here. So we simply don't display the type at all,-contenting outselves with just the name of the pattern synonym, which+contenting ourselves with just the name of the pattern synonym, which is fine.  We could do more, but it doesn't seem worth it.  Note [SigSkol SkolemInfo]@@ -364,7 +361,7 @@                  }    | KindEqOrigin-      TcType (Maybe TcType)     -- A kind equality arising from unifying these two types+      TcType TcType             -- A kind equality arising from unifying these two types       CtOrigin                  -- originally arising from this       (Maybe TypeOrKind)        -- the level of the eq this arises from @@ -378,6 +375,7 @@   | AssocFamPatOrigin   -- When matching the patterns of an associated                         -- family instance with that of its parent class   | SectionOrigin+  | HasFieldOrigin FastString   | TupleOrigin         -- (..,..)   | ExprSigOrigin       -- e :: ty   | PatSigOrigin        -- p :: ty@@ -435,7 +433,6 @@   | ExprHoleOrigin OccName   -- from an expression hole   | TypeHoleOrigin OccName   -- from a type hole (partial type signature)   | PatCheckOrigin      -- normalisation of a type during pattern-match checking-  | UnboundOccurrenceOf OccName   | ListOrigin          -- An overloaded list   | BracketOrigin       -- An overloaded quotation bracket   | StaticOrigin        -- A static form@@ -449,6 +446,10 @@   | NonLinearPatternOrigin   | UsageEnvironmentOf Name +  | CycleBreakerOrigin+      CtOrigin   -- origin of the original constraint+      -- See Detail (7) of Note [Type variable cycles] in GHC.Tc.Solver.Canonical+ -- An origin is visible if the place where the constraint arises is manifest -- in user code. Currently, all origins are visible except for invisible -- TypeEqOrigins. This is used when choosing which error of@@ -468,6 +469,7 @@ isGivenOrigin (GivenOrigin {})              = True isGivenOrigin (FunDepOrigin1 _ o1 _ _ o2 _) = isGivenOrigin o1 && isGivenOrigin o2 isGivenOrigin (FunDepOrigin2 _ o1 _ _)      = isGivenOrigin o1+isGivenOrigin (CycleBreakerOrigin o)        = isGivenOrigin o isGivenOrigin _                             = False  instance Outputable CtOrigin where@@ -482,10 +484,12 @@  exprCtOrigin :: HsExpr GhcRn -> CtOrigin exprCtOrigin (HsVar _ (L _ name)) = OccurrenceOf name-exprCtOrigin (HsUnboundVar _ uv)  = UnboundOccurrenceOf uv+exprCtOrigin (HsGetField _ _ (L _ f)) = HasFieldOrigin (unLoc $ hflLabel f)+exprCtOrigin (HsUnboundVar {})    = Shouldn'tHappenOrigin "unbound variable" exprCtOrigin (HsConLikeOut {})    = panic "exprCtOrigin HsConLikeOut" exprCtOrigin (HsRecFld _ f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)-exprCtOrigin (HsOverLabel _ _ l)  = OverLabelOrigin l+exprCtOrigin (HsOverLabel _ l)    = OverLabelOrigin l+exprCtOrigin (ExplicitList {})    = ListOrigin exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"@@ -496,6 +500,7 @@ exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e exprCtOrigin (HsPar _ e)          = lexprCtOrigin e+exprCtOrigin (HsProjection _ _)   = SectionOrigin exprCtOrigin (SectionL _ _ _)     = SectionOrigin exprCtOrigin (SectionR _ _ _)     = SectionOrigin exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"@@ -505,9 +510,8 @@ exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e exprCtOrigin (HsDo {})           = DoOrigin-exprCtOrigin (ExplicitList {})   = Shouldn'tHappenOrigin "list" exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction"-exprCtOrigin (RecordUpd {})      = Shouldn'tHappenOrigin "record update"+exprCtOrigin (RecordUpd {})      = RecordUpdOrigin exprCtOrigin (ExprWithTySig {})  = ExprSigOrigin exprCtOrigin (ArithSeq {})       = Shouldn'tHappenOrigin "arithmetic sequence" exprCtOrigin (HsPragE _ _ e)     = lexprCtOrigin e@@ -563,19 +567,15 @@                , hang (text "instance" <+> quotes (ppr pred2))                     2 (text "at" <+> ppr loc2) ]) -pprCtOrigin (KindEqOrigin t1 (Just t2) _ _)-  = hang (ctoHerald <+> text "a kind equality arising from")-       2 (sep [ppr t1, char '~', ppr t2])- pprCtOrigin AssocFamPatOrigin   = text "when matching a family LHS with its class instance head" -pprCtOrigin (KindEqOrigin t1 Nothing _ _)-  = hang (ctoHerald <+> text "a kind equality when matching")-       2 (ppr t1)+pprCtOrigin (TypeEqOrigin { uo_actual = t1, uo_expected =  t2, uo_visible = vis })+  = text "a type equality" <> brackets (ppr vis) <+> sep [ppr t1, char '~', ppr t2] -pprCtOrigin (UnboundOccurrenceOf name)-  = ctoHerald <+> text "an undeclared identifier" <+> quotes (ppr name)+pprCtOrigin (KindEqOrigin t1 t2 _ _)+  = hang (ctoHerald <+> text "a kind equality arising from")+       2 (sep [ppr t1, char '~', ppr t2])  pprCtOrigin (DerivOriginDC dc n _)   = hang (ctoHerald <+> text "the" <+> speakNth n@@ -617,6 +617,9 @@          , ppr cls_inst          , text "is provided by" <+> quotes (ppr mod)] +pprCtOrigin (CycleBreakerOrigin orig)+  = pprCtOrigin orig+ pprCtOrigin simple_origin   = ctoHerald <+> pprCtO simple_origin @@ -637,6 +640,7 @@ pprCtO (LiteralOrigin lit)   = hsep [text "the literal", quotes (ppr lit)] pprCtO (ArithSeqOrigin seq)  = hsep [text "the arithmetic sequence", quotes (ppr seq)] pprCtO SectionOrigin         = text "an operator section"+pprCtO (HasFieldOrigin f)    = hsep [text "selecting the field", quotes (ppr f)] pprCtO AssocFamPatOrigin     = text "the LHS of a family instance" pprCtO TupleOrigin           = text "a tuple" pprCtO NegateOrigin          = text "a use of syntactic negation"@@ -648,7 +652,6 @@ pprCtO DoOrigin              = text "a do statement" pprCtO MCompOrigin           = text "a statement in a monad comprehension" pprCtO ProcOrigin            = text "a proc expression"-pprCtO (TypeEqOrigin t1 t2 _ _)= text "a type equality" <+> sep [ppr t1, char '~', ppr t2] pprCtO AnnOrigin             = text "an annotation" pprCtO (ExprHoleOrigin occ)  = text "a use of" <+> quotes (ppr occ) pprCtO (TypeHoleOrigin occ)  = text "a use of wildcard" <+> quotes (ppr occ)

GHC/Tc/Utils/Backpack.hs view

@@ -1,15 +1,14 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE CPP                      #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TypeFamilies             #-}  module GHC.Tc.Utils.Backpack (     findExtraSigImports',     findExtraSigImports,     implicitRequirements',     implicitRequirements,+    implicitRequirementsShallow,     checkUnit,     tcRnCheckUnit,     tcRnMergeSignatures,@@ -20,54 +19,71 @@  import GHC.Prelude -import GHC.Types.Basic (defaultFixity, TypeOrKind(..))-import GHC.Unit.State-import GHC.Tc.Gen.Export-import GHC.Driver.Session-import GHC.Hs+import GHC.Driver.Env+import GHC.Driver.Ppr++import GHC.Types.Basic (TypeOrKind(..))+import GHC.Types.Fixity (defaultFixity)+import GHC.Types.Fixity.Env+import GHC.Types.TypeEnv import GHC.Types.Name.Reader-import GHC.Tc.Utils.Monad-import GHC.Tc.TyCl.Utils-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv-import GHC.Tc.Utils.Instantiate-import GHC.IfaceToCore-import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.TcType-import GHC.Tc.Solver-import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin-import GHC.Iface.Load-import GHC.Rename.Names-import GHC.Utils.Error import GHC.Types.Id-import GHC.Unit.Module import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Types.Avail import GHC.Types.SrcLoc-import GHC.Driver.Types-import GHC.Utils.Outputable+import GHC.Types.SourceFile+import GHC.Types.Var+import GHC.Types.Unique.DSet+import GHC.Types.Name.Shape++import GHC.Unit+import GHC.Unit.State+import GHC.Unit.Finder+import GHC.Unit.Module.Warnings+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps++import GHC.Tc.Gen.Export+import GHC.Tc.Solver+import GHC.Tc.TyCl.Utils+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.Instantiate+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.TcType++import GHC.Hs++import GHC.Core.InstEnv+import GHC.Core.FamInstEnv import GHC.Core.Type import GHC.Core.Multiplicity-import GHC.Data.FastString-import GHC.Rename.Fixity ( lookupFixityRn )-import GHC.Data.Maybe-import GHC.Tc.Utils.Env-import GHC.Types.Var++import GHC.IfaceToCore+import GHC.Iface.Load+import GHC.Iface.Rename import GHC.Iface.Syntax-import GHC.Builtin.Names-import qualified Data.Map as Map -import GHC.Driver.Finder-import GHC.Types.Unique.DSet-import GHC.Types.Name.Shape+import GHC.Rename.Names+import GHC.Rename.Fixity ( lookupFixityRn )++import GHC.Tc.Utils.Env import GHC.Tc.Errors import GHC.Tc.Utils.Unify-import GHC.Iface.Rename+ import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Panic +import GHC.Data.FastString+import GHC.Data.Maybe+ import Control.Monad import Data.List (find) @@ -158,7 +174,8 @@       -- The hsig did NOT define this function; that means it must       -- be a reexport.  In this case, make sure the 'Name' of the       -- reexport matches the 'Name exported here.-      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =+      | [gre] <- lookupGlobalRdrEnv gr (nameOccName name) = do+        let name' = greMangledName gre         when (name /= name') $ do             -- See Note [Error reporting bad reexport]             -- TODO: Actually this error swizzle doesn't work@@ -168,7 +185,7 @@                          -- TODO: maybe we can be a little more                          -- precise here and use the Located                          -- info for the *specific* name we matched.-                         -> getLoc e+                         -> getLocA e                        _ -> nameSrcSpan name             addErrAt loc                 (badReexportedBootThing False name name')@@ -206,8 +223,8 @@         skol_info = InstSkol         -- Based off of tcSplitDFunTy         (tvs, theta, pred) =-           case tcSplitForAllTys ty of { (tvs, rho)   ->-           case splitFunTys rho     of { (theta, pred) ->+           case tcSplitForAllInvisTyVars ty of { (tvs, rho)    ->+           case splitFunTys rho             of { (theta, pred) ->            (tvs, theta, pred) }}         origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst     (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize@@ -230,20 +247,6 @@     (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved     reportAllUnsolved (mkImplicWC implic) --- | Return this list of requirement interfaces that need to be merged--- to form @mod_name@, or @[]@ if this is not a requirement.-requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]-requirementMerges pkgstate mod_name =-    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))-    where-      -- update IndefUnitId ppr info as they may have changed since the-      -- time the IndefUnitId was created-      fixupModule (Module iud name) = Module iud' name-         where-            iud' = iud { instUnitInstanceOf = cid' }-            cid  = instUnitInstanceOf iud-            cid' = updateIndefUnitId pkgstate cid- -- | For a module @modname@ of type 'HscSource', determine the list -- of extra "imports" of other requirements which should be considered part of -- the import of the requirement, because it transitively depends on those@@ -251,12 +254,12 @@ -- is something like this: -- --      unit p where---          signature A---          signature B---              import A+--          signature X+--          signature Y+--              import X -- --      unit q where---          dependency p[A=\<A>,B=\<B>]+--          dependency p[X=\<A>,Y=\<B>] --          signature A --          signature B --@@ -275,8 +278,8 @@             $ moduleFreeHolesPrecise (text "findExtraSigImports")                 (mkModule (VirtUnit iuid) mod_name)))   where-    pkgstate = unitState (hsc_dflags hsc_env)-    reqs = requirementMerges pkgstate modname+    unit_state = hsc_units hsc_env+    reqs = requirementMerges unit_state modname  findExtraSigImports' _ _ _ = return emptyUniqDSet @@ -290,7 +293,7 @@            | mod_name <- uniqDSetToList extra_requirements ]  -- A version of 'implicitRequirements'' which is more friendly--- for "GHC.Driver.Make" and "GHC.Tc.Module".+-- for "GHC.Tc.Module". implicitRequirements :: HscEnv                      -> [(Maybe FastString, Located ModuleName)]                      -> IO [(Maybe FastString, Located ModuleName)]@@ -300,7 +303,7 @@  -- Given a list of 'import M' statements in a module, figure out -- any extra implicit requirement imports they may have.  For--- example, if they 'import M' and M resolves to p[A=<B>], then+-- example, if they 'import M' and M resolves to p[A=<B>,C=D], then -- they actually also import the local requirement B. implicitRequirements' :: HscEnv                      -> [(Maybe FastString, Located ModuleName)]@@ -310,11 +313,33 @@     forM normal_imports $ \(mb_pkg, L _ imp) -> do         found <- findImportedModule hsc_env imp mb_pkg         case found of-            Found _ mod | not (isHomeModule dflags mod) ->+            Found _ mod | not (isHomeModule home_unit mod) ->                 return (uniqDSetToList (moduleFreeHoles mod))             _ -> return []-  where dflags = hsc_dflags hsc_env+  where home_unit = hsc_home_unit hsc_env +-- | Like @implicitRequirements'@, but returns either the module name, if it is+-- a free hole, or the instantiated unit the imported module is from, so that+-- that instantiated unit can be processed and via the batch mod graph (rather+-- than a transitive closure done here) all the free holes are still reachable.+implicitRequirementsShallow+  :: HscEnv+  -> [(Maybe FastString, Located ModuleName)]+  -> IO ([ModuleName], [InstantiatedUnit])+implicitRequirementsShallow hsc_env normal_imports = go ([], []) normal_imports+ where+  go acc [] = pure acc+  go (accL, accR) ((mb_pkg, L _ imp):imports) = do+    found <- findImportedModule hsc_env imp mb_pkg+    let acc' = case found of+          Found _ mod | not (isHomeModule (hsc_home_unit hsc_env) mod) ->+              case moduleUnit mod of+                  HoleUnit -> (moduleName mod : accL, accR)+                  RealUnit _ -> (accL, accR)+                  VirtUnit u -> (accL, u:accR)+          _ -> (accL, accR)+    go acc' imports+ -- | Given a 'Unit', make sure it is well typed.  This is because -- unit IDs come from Cabal, which does not know if things are well-typed or -- not; a component may have been filled with implementations for the holes@@ -336,19 +361,20 @@ -- an @hsig@ file.) tcRnCheckUnit ::     HscEnv -> Unit ->-    IO (Messages, Maybe ())+    IO (Messages DecoratedSDoc, Maybe ()) tcRnCheckUnit hsc_env uid =-   withTiming dflags+   withTiming logger dflags               (text "Check unit id" <+> ppr uid)               (const ()) $    initTc hsc_env           HsigFile -- bogus           False-          mAIN -- bogus+          (mainModIs hsc_env)           (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus     $ checkUnit uid   where    dflags = hsc_dflags hsc_env+   logger = hsc_logger hsc_env    loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)  -- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...@@ -356,15 +382,16 @@ -- | Top-level driver for signature merging (run after typechecking -- an @hsig@ file). tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface-                    -> IO (Messages, Maybe TcGblEnv)+                    -> IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =-  withTiming dflags+  withTiming logger dflags              (text "Signature merging" <+> brackets (ppr this_mod))              (const ()) $   initTc hsc_env HsigFile False this_mod real_loc $     mergeSignatures hpm orig_tcg_env iface  where   dflags   = hsc_dflags hsc_env+  logger   = hsc_logger hsc_env   this_mod = mi_module iface   real_loc = tcg_top_loc orig_tcg_env @@ -506,7 +533,6 @@     -- file, which is guaranteed to exist, see     -- Note [Blank hsigs for all requirements]     hsc_env <- getTopEnv-    dflags  <- getDynFlags      -- Copy over some things from the original TcGblEnv that     -- we want to preserve@@ -533,16 +559,17 @@        }) $ do     tcg_env <- getGblEnv -    let outer_mod = tcg_mod tcg_env-        inner_mod = tcg_semantic_mod tcg_env-        mod_name = moduleName (tcg_mod tcg_env)-        pkgstate = unitState dflags+    let outer_mod  = tcg_mod tcg_env+        inner_mod  = tcg_semantic_mod tcg_env+        mod_name   = moduleName (tcg_mod tcg_env)+        unit_state = hsc_units hsc_env+        home_unit  = hsc_home_unit hsc_env      -- STEP 1: Figure out all of the external signature interfaces     -- we are going to merge in.-    let reqs = requirementMerges pkgstate mod_name+    let reqs = requirementMerges unit_state mod_name -    addErrCtxt (merge_msg mod_name reqs) $ do+    addErrCtxt (pprWithUnitState unit_state $ merge_msg mod_name reqs) $ do      -- STEP 2: Read in the RAW forms of all of these interfaces     ireq_ifaces0 <- forM reqs $ \(Module iuid mod_name) ->@@ -569,7 +596,7 @@             let insts = instUnitInsts iuid                 isFromSignaturePackage =                     let inst_uid = instUnitInstanceOf iuid-                        pkg = unsafeLookupUnitId pkgstate (indefUnit inst_uid)+                        pkg = unsafeLookupUnitId unit_state (indefUnit inst_uid)                     in null (unitExposedModules pkg)             -- 3(a). Rename the exports according to how the dependency             -- was instantiated.  The resulting export list will be accurate@@ -584,7 +611,7 @@                       -- a signature package (i.e., does not expose any                       -- modules.)  If so, we can thin it.                       | isFromSignaturePackage-                      -> setSrcSpan loc $ do+                      -> setSrcSpanA loc $ do                         -- Suppress missing errors; they might be used to refer                         -- to entities from other signatures we are merging in.                         -- If an identifier truly doesn't exist in any of the@@ -638,7 +665,7 @@                                             is_mod  = mod_name,                                             is_as   = mod_name,                                             is_qual = False,-                                            is_dloc = loc+                                            is_dloc = locA loc                                           } ImpAll                                 rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)                             setGblEnv tcg_env {@@ -732,11 +759,11 @@     -- STEP 4: Rename the interfaces     ext_ifaces <- forM thinned_ifaces $ \((Module iuid _), ireq_iface) ->         tcRnModIface (instUnitInsts iuid) (Just nsubst) ireq_iface-    lcl_iface <- tcRnModIface (homeUnitInstantiations dflags) (Just nsubst) lcl_iface0+    lcl_iface <- tcRnModIface (homeUnitInstantiations home_unit) (Just nsubst) lcl_iface0     let ifaces = lcl_iface : ext_ifaces      -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env-    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)+    let fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)                             | (occ, f) <- concatMap mi_fixities ifaces                             , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ] @@ -754,7 +781,7 @@     let infos = zip ifaces detailss      -- Test for cycles-    checkSynCycles (homeUnit dflags) (typeEnvTyCons type_env) []+    checkSynCycles (homeUnitAsUnit home_unit) (typeEnvTyCons type_env) []      -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside     -- detailss, and given a Name that doesn't correspond to anything real.  See@@ -828,6 +855,7 @@         -- we hope that we get lucky / the overlapping instances never         -- get used, but it is not a very good situation to be in.         --+        hsc_env <- getTopEnv         let merge_inst (insts, inst_env) inst                 | memberInstEnv inst_env inst -- test DFun Type equality                 = (insts, inst_env)@@ -842,8 +870,9 @@             -- in the listing.  We don't want it because a module is NOT             -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214             iface' = iface { mi_final_exts = (mi_final_exts iface){ mi_orphan = False, mi_finsts = False } }+            home_unit = hsc_home_unit hsc_env             avails = plusImportAvails (tcg_imports tcg_env) $-                        calculateAvails dflags iface' False NotBoot ImportedBySystem+                        calculateAvails home_unit iface' False NotBoot ImportedBySystem         return tcg_env {             tcg_inst_env = inst_env,             tcg_insts    = insts,@@ -885,30 +914,35 @@ -- an @hsig@ file.) tcRnInstantiateSignature ::     HscEnv -> Module -> RealSrcSpan ->-    IO (Messages, Maybe TcGblEnv)+    IO (Messages DecoratedSDoc, Maybe TcGblEnv) tcRnInstantiateSignature hsc_env this_mod real_loc =-   withTiming dflags+   withTiming logger dflags               (text "Signature instantiation"<+>brackets (ppr this_mod))               (const ()) $    initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature   where    dflags = hsc_dflags hsc_env+   logger = hsc_logger hsc_env  exportOccs :: [AvailInfo] -> [OccName] exportOccs = concatMap (map occName . availNames) -impl_msg :: Module -> InstantiatedModule -> SDoc-impl_msg impl_mod (Module req_uid req_mod_name) =-  text "while checking that" <+> ppr impl_mod <+>-  text "implements signature" <+> ppr req_mod_name <+>-  text "in" <+> ppr req_uid+impl_msg :: UnitState -> Module -> InstantiatedModule -> SDoc+impl_msg unit_state impl_mod (Module req_uid req_mod_name)+   = pprWithUnitState unit_state $+      text "while checking that" <+> ppr impl_mod <+>+      text "implements signature" <+> ppr req_mod_name <+>+      text "in" <+> ppr req_uid  -- | Check if module implements a signature.  (The signature is -- always un-hashed, which is why its components are specified -- explicitly.) checkImplements :: Module -> InstantiatedModule -> TcRn TcGblEnv-checkImplements impl_mod req_mod@(Module uid mod_name) =-  addErrCtxt (impl_msg impl_mod req_mod) $ do+checkImplements impl_mod req_mod@(Module uid mod_name) = do+  hsc_env <- getTopEnv+  let unit_state = hsc_units hsc_env+      home_unit  = hsc_home_unit hsc_env+  addErrCtxt (impl_msg unit_state impl_mod req_mod) $ do     let insts = instUnitInsts uid      -- STEP 1: Load the implementing interface, and make a RdrEnv@@ -928,10 +962,9 @@     loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")                          (dep_orphs (mi_deps impl_iface)) -    dflags <- getDynFlags-    let avails = calculateAvails dflags+    let avails = calculateAvails home_unit                     impl_iface False{- safe -} NotBoot ImportedBySystem-        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)+        fix_env = mkNameEnv [ (greMangledName rdr_elt, FixItem occ f)                             | (occ, f) <- mi_fixities impl_iface                             , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]     updGblEnv (\tcg_env -> tcg_env {@@ -966,9 +999,8 @@     forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->         case lookupGlobalRdrEnv impl_gr occ of             [] -> addErr $ quotes (ppr occ)-                    <+> text "is exported by the hsig file, but not"-                    <+> text "exported by the implementing module"-                    <+> quotes (ppr impl_mod)+                    <+> text "is exported by the hsig file, but not exported by the implementing module"+                    <+> quotes (pprWithUnitState unit_state $ ppr impl_mod)             _ -> return ()     failIfErrsM @@ -994,20 +1026,18 @@ -- checking that the implementation matches the signature. instantiateSignature :: TcRn TcGblEnv instantiateSignature = do+    hsc_env <- getTopEnv     tcg_env <- getGblEnv-    dflags <- getDynFlags     let outer_mod = tcg_mod tcg_env         inner_mod = tcg_semantic_mod tcg_env+        home_unit = hsc_home_unit hsc_env     -- TODO: setup the local RdrEnv so the error messages look a little better.     -- But this information isn't stored anywhere. Should we RETYPECHECK     -- the local one just to get the information?  Hmm...-    MASSERT( isHomeModule dflags outer_mod )-    MASSERT( isJust (homeUnitInstanceOfId dflags) )-    let uid  = fromJust (homeUnitInstanceOfId dflags)-        -- we need to fetch the most recent ppr infos from the unit-        -- database because we might have modified it-        uid' = updateIndefUnitId (unitState dflags) uid+    MASSERT( isHomeModule home_unit outer_mod )+    MASSERT( isHomeUnitInstantiating home_unit)+    let uid = Indefinite (homeUnitInstanceOf home_unit)     inner_mod `checkImplements`         Module-            (mkInstantiatedUnit uid' (homeUnitInstantiations dflags))+            (mkInstantiatedUnit uid (homeUnitInstantiations home_unit))             (moduleName outer_mod)

GHC/Tc/Utils/Env.hs view

@@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an                                        -- orphan {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]-                                      -- in module GHC.Hs.Extension+                                      -- in module Language.Haskell.Syntax.Extension {-# LANGUAGE TypeFamilies #-}  module GHC.Tc.Utils.Env(@@ -64,8 +64,8 @@         topIdLvl, isBrackStage,          -- New Ids-        newDFunName, newFamInstTyConName,-        newFamInstAxiomName,+        newDFunName,+        newFamInstTyConName, newFamInstAxiomName,         mkStableIdFromString, mkStableIdFromName,         mkWrapperName   ) where@@ -74,21 +74,27 @@  import GHC.Prelude +import GHC.Driver.Env+import GHC.Driver.Session++import GHC.Builtin.Names+import GHC.Builtin.Types++import GHC.Runtime.Context+ import GHC.Hs+ import GHC.Iface.Env+import GHC.Iface.Load+ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType-import GHC.Core.UsageEnv import GHC.Tc.Types.Evidence (HsWrapper, idHsWrapper) import {-# SOURCE #-} GHC.Tc.Utils.Unify ( tcSubMult ) import GHC.Tc.Types.Origin ( CtOrigin(UsageEnvironmentOf) )-import GHC.Iface.Load-import GHC.Builtin.Names-import GHC.Builtin.Types-import GHC.Types.Id-import GHC.Types.Var-import GHC.Types.Name.Reader++import GHC.Core.UsageEnv import GHC.Core.InstEnv import GHC.Core.DataCon ( DataCon ) import GHC.Core.PatSyn  ( PatSyn )@@ -96,26 +102,35 @@ import GHC.Core.TyCon import GHC.Core.Type import GHC.Core.Coercion.Axiom- import GHC.Core.Class-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Types.Name.Env-import GHC.Types.Var.Env-import GHC.Driver.Types-import GHC.Driver.Session-import GHC.Types.SrcLoc-import GHC.Types.Basic hiding( SuccessFlag(..) )+ import GHC.Unit.Module+import GHC.Unit.Home+import GHC.Unit.External+ import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Encoding+import GHC.Utils.Misc ( HasDebugCallStack )+ import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.List.SetOps-import GHC.Utils.Error import GHC.Data.Maybe( MaybeErr(..), orElse )++import GHC.Types.SrcLoc+import GHC.Types.Basic hiding( SuccessFlag(..) )+import GHC.Types.TypeEnv+import GHC.Types.SourceFile+import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Name.Env+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Name.Reader+import GHC.Types.TyThing import qualified GHC.LanguageExtensions as LangExt-import GHC.Utils.Misc ( HasDebugCallStack )  import Data.IORef import Data.List (intercalate)@@ -138,15 +153,15 @@             Failed msg      -> pprPanic "lookupGlobal" msg         } -lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)+lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) -- This may look up an Id that one has previously looked up. -- If so, we are going to read its interface file, and add its bindings -- to the ExternalPackageTable. lookupGlobal_maybe hsc_env name   = do  {    -- Try local envt           let mod = icInteractiveModule (hsc_IC hsc_env)-              dflags = hsc_dflags hsc_env-              tcg_semantic_mod = canonicalizeModuleIfHome dflags mod+              home_unit = hsc_home_unit hsc_env+              tcg_semantic_mod = homeModuleInstantiation home_unit mod          ; if nameIsLocalOrFrom tcg_semantic_mod name               then (return@@ -157,16 +172,16 @@           lookupImported_maybe hsc_env name         } -lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)+lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) -- Returns (Failed err) if we can't find the interface file for the thing lookupImported_maybe hsc_env name-  = do  { mb_thing <- lookupTypeHscEnv hsc_env name+  = do  { mb_thing <- lookupType hsc_env name         ; case mb_thing of             Just thing -> return (Succeeded thing)             Nothing    -> importDecl_maybe hsc_env name             } -importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)+importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc TyThing) importDecl_maybe hsc_env name   | Just thing <- wiredInNameTyThing_maybe name   = do  { when (needWiredInHomeIface thing)@@ -183,7 +198,7 @@     Succeeded thing -> return thing     Failed msg      -> pprPanic "lookupDataConIO" msg -ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)+ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr SDoc DataCon) ioLookupDataCon_maybe hsc_env name = do     thing <- lookupGlobal hsc_env name     return $ case thing of@@ -214,10 +229,10 @@ -}  -tcLookupLocatedGlobal :: Located Name -> TcM TyThing+tcLookupLocatedGlobal :: LocatedA Name -> TcM TyThing -- c.f. GHC.IfaceToCore.tcIfaceGlobal tcLookupLocatedGlobal name-  = addLocM tcLookupGlobal name+  = addLocMA tcLookupGlobal name  tcLookupGlobal :: Name -> TcM TyThing -- The Name is almost always an ExternalName, but not always@@ -295,14 +310,14 @@         ACoAxiom ax -> return ax         _           -> wrongThingErr "axiom" (AGlobal thing) name -tcLookupLocatedGlobalId :: Located Name -> TcM Id-tcLookupLocatedGlobalId = addLocM tcLookupId+tcLookupLocatedGlobalId :: LocatedA Name -> TcM Id+tcLookupLocatedGlobalId = addLocMA tcLookupId -tcLookupLocatedClass :: Located Name -> TcM Class-tcLookupLocatedClass = addLocM tcLookupClass+tcLookupLocatedClass :: LocatedA Name -> TcM Class+tcLookupLocatedClass = addLocMA tcLookupClass -tcLookupLocatedTyCon :: Located Name -> TcM TyCon-tcLookupLocatedTyCon = addLocM tcLookupTyCon+tcLookupLocatedTyCon :: LocatedN Name -> TcM TyCon+tcLookupLocatedTyCon = addLocMA tcLookupTyCon  -- Find the instance that exactly matches a type class application.  The class arguments must be precisely -- the same as in the instance declaration (modulo renaming & casts).@@ -409,8 +424,8 @@ ************************************************************************ -} -tcLookupLocated :: Located Name -> TcM TcTyThing-tcLookupLocated = addLocM tcLookup+tcLookupLocated :: LocatedA Name -> TcM TcTyThing+tcLookupLocated = addLocMA tcLookup  tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing) tcLookupLcl_maybe name@@ -504,14 +519,15 @@ tcExtendNameTyVarEnv binds thing_inside   -- this should be used only for explicitly mentioned scoped variables.   -- thus, no coercion variables-  = do { tc_extend_local_env NotTopLevel-                    [(name, ATyVar name tv) | (name, tv) <- binds] $-         tcExtendBinderStack tv_binds $-         thing_inside }+  = tc_extend_local_env NotTopLevel names $+        tcExtendBinderStack tv_binds $+        thing_inside   where     tv_binds :: [TcBinder]     tv_binds = [TcTvBndr name tv | (name,tv) <- binds] +    names = [(name, ATyVar name tv) | (name, tv) <- binds]+ isTypeClosedLetBndr :: Id -> Bool -- See Note [Bindings with closed types] in GHC.Tc.Types isTypeClosedLetBndr = noFreeVarsOfType . idType@@ -747,8 +763,8 @@       = concatMap (get_fi_cons . unLoc) fids      get_fi_cons :: DataFamInstDecl GhcRn -> [Name]-    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =-                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})+    get_fi_cons (DataFamInstDecl { dfid_eqn =+                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }})       = map unLoc $ concatMap (getConNames . unLoc) cons  @@ -1040,12 +1056,12 @@         ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)         ; newGlobalBinder mod dfun_occ loc } -newFamInstTyConName :: Located Name -> [Type] -> TcM Name-newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]+newFamInstTyConName :: LocatedN Name -> [Type] -> TcM Name+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id (locA loc) name [tys] -newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name+newFamInstAxiomName :: LocatedN Name -> [[Type]] -> TcM Name newFamInstAxiomName (L loc name) branches-  = mk_fam_inst_name mkInstTyCoOcc loc name branches+  = mk_fam_inst_name mkInstTyCoOcc (locA loc) name branches  mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name mk_fam_inst_name adaptOcc loc tc_name tyss

GHC/Tc/Utils/Instantiate.hs view

@@ -1,85 +1,95 @@+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Tc.Utils.Instantiate (-       topSkolemise,-       topInstantiate, topInstantiateInferred,-       instCall, instDFunType, instStupidTheta, instTyVarsWith,-       newWanted, newWanteds,+     topSkolemise,+     topInstantiate,+     instantiateSigma,+     instCall, instDFunType, instStupidTheta, instTyVarsWith,+     newWanted, newWanteds, -       tcInstType, tcInstTypeBndrs,-       tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,-       tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,+     tcInstType, tcInstTypeBndrs,+     tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,+     tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX, -       freshenTyVarBndrs, freshenCoVarBndrsX,+     freshenTyVarBndrs, freshenCoVarBndrsX, -       tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,+     tcInstInvisibleTyBindersN, tcInstInvisibleTyBinders, tcInstInvisibleTyBinder, -       newOverloadedLit, mkOverLit,+     newOverloadedLit, mkOverLit, -       newClsInst,-       tcGetInsts, tcGetInstEnvs, getOverlapFlag,-       tcExtendLocalInstEnv,-       instCallConstraints, newMethodFromName,-       tcSyntaxName,+     newClsInst,+     tcGetInsts, tcGetInstEnvs, getOverlapFlag,+     tcExtendLocalInstEnv,+     instCallConstraints, newMethodFromName,+     tcSyntaxName, -       -- Simple functions over evidence variables-       tyCoVarsOfWC,-       tyCoVarsOfCt, tyCoVarsOfCts,-    ) where+     -- Simple functions over evidence variables+     tyCoVarsOfWC,+     tyCoVarsOfCt, tyCoVarsOfCts,+  ) where  #include "HsVersions.h"  import GHC.Prelude -import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )-import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType, unifyKind )+import GHC.Driver.Session+import GHC.Driver.Env -import GHC.Types.Basic ( IntegralLit(..), SourceText(..) )+import GHC.Builtin.Types  ( heqDataCon, eqDataCon, integerTyConName )+import GHC.Builtin.Names+ import GHC.Hs++import GHC.Core.InstEnv+import GHC.Core.Predicate+import GHC.Core ( Expr(..), isOrphan ) -- For the Coercion constructor+import GHC.Core.Type+import GHC.Core.Multiplicity+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr ( debugPprType )+import GHC.Core.Class( Class )+import GHC.Core.DataCon++import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcCheckPolyExpr, tcSyntaxOp )+import {-# SOURCE #-}   GHC.Tc.Utils.Unify( unifyType, unifyKind ) import GHC.Tc.Utils.Zonk import GHC.Tc.Utils.Monad import GHC.Tc.Types.Constraint-import GHC.Core.Predicate import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env import GHC.Tc.Types.Evidence-import GHC.Core.InstEnv-import GHC.Builtin.Types  ( heqDataCon, eqDataCon, integerTyConName )-import GHC.Core    ( isOrphan ) import GHC.Tc.Instance.FunDeps import GHC.Tc.Utils.TcMType-import GHC.Core.Type-import GHC.Core.Multiplicity-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr ( debugPprType ) import GHC.Tc.Utils.TcType-import GHC.Driver.Types-import GHC.Core.Class( Class )+ import GHC.Types.Id.Make( mkDictFunId )-import GHC.Core( Expr(..) )  -- For the Coercion constructor+import GHC.Types.Basic ( TypeOrKind(..) )+import GHC.Types.SourceText+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Var.Env+import GHC.Types.Var.Set import GHC.Types.Id import GHC.Types.Name import GHC.Types.Var-import GHC.Core.DataCon-import GHC.Types.Var.Env-import GHC.Builtin.Names-import GHC.Types.SrcLoc as SrcLoc-import GHC.Driver.Session+import qualified GHC.LanguageExtensions as LangExt+ import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Utils.Outputable-import GHC.Types.Basic ( TypeOrKind(..) )-import qualified GHC.LanguageExtensions as LangExt +import GHC.Unit.State+import GHC.Unit.External+ import Data.List ( sortBy, mapAccumL ) import Control.Monad( unless ) import Data.Function ( on )@@ -117,7 +127,7 @@        ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )                  instCall origin ty_args theta -       ; return (mkHsWrap wrap (HsVar noExtField (noLoc id))) }+       ; return (mkHsWrap wrap (HsVar noExtField (noLocA id))) }  {- ************************************************************************@@ -180,73 +190,51 @@       = return (wrap, tv_prs, ev_vars, substTy subst ty)         -- substTy is a quick no-op on an empty substitution --- | Instantiate all outer type variables--- and any context. Never looks through arrows.-topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)--- if    topInstantiate ty = (wrap, rho)--- 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 ::CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+-- Instantiate outer invisible binders (both Inferred and Specified)+-- If    top_instantiate ty = (wrap, inner_ty)+-- then  wrap :: inner_ty "->" ty+-- NB: returns a type with no (=>),+--     and no invisible forall at the top+topInstantiate orig sigma+  | (tvs,   body1) <- tcSplitSomeForAllTyVars isInvisibleArgFlag sigma+  , (theta, body2) <- tcSplitPhiTy body1+  , not (null tvs && null theta)+  = do { (_, wrap1, body3) <- instantiateSigma orig tvs theta body2 -       ; 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, body4) <- topInstantiate orig body3 -       ; (wrap2, rho2) <--           if null leave_bndrs   -- NB: if inst_all is True then leave_bndrs = []+       ; return (wrap2 <.> wrap1, body4) } -         -- account for types like forall a. Num a => forall b. Ord b => ...-           then top_instantiate inst_all orig sigma'+  | otherwise = return (idHsWrapper, sigma) -         -- 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@@ -478,7 +466,7 @@              subst'  = extendTCvInScopeSet subst (tyCoVarsOfType rho)        ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }   where-    (tyvars, rho) = tcSplitForAllTys (idType id)+    (tyvars, rho) = tcSplitForAllInvisTyVars (idType id)     (theta, tau)  = tcSplitPhiTy rho  tcInstTypeBndrs :: Id -> TcM ([(Name, InvisTVBinder)], TcThetaType, TcType)@@ -494,7 +482,7 @@              subst'  = extendTCvInScopeSet subst (tyCoVarsOfType rho)        ; return (tv_prs, substTheta subst' theta, substTy subst' tau) }   where-    (tyvars, rho) = splitForAllTysInvis (idType id)+    (tyvars, rho) = splitForAllInvisTVBinders (idType id)     (theta, tau)  = tcSplitPhiTy rho      inst_invis_bndr :: TCvSubst -> InvisTVBinder@@ -505,7 +493,7 @@  tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType) -- Instantiate a type signature with skolem constants.--- We could give them fresh names, but no need to do so+-- This freshens the names, but no need to do so tcSkolDFunType dfun   = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun        ; return (map snd tv_prs, theta, tau) }@@ -537,13 +525,18 @@  tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables]+-- This version freshens the names and creates "super skolems";+-- see comments around superSkolemTv. tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst  tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- See Note [Skolemising type variables]+-- This version freshens the names and creates "super skolems";+-- see comments around superSkolemTv. tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst -tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]+tcInstSkolTyVarsPushLevel :: Bool  -- True <=> make "super skolem"+                          -> TCvSubst -> [TyVar]                           -> TcM (TCvSubst, [TcTyVar]) -- Skolemise one level deeper, hence pushTcLevel -- See Note [Skolemising type variables]@@ -592,10 +585,7 @@   = do { loc  <- getSrcSpanM        ; uniq <- newUnique        ; let old_name = tyVarName tycovar-             -- Force so we don't retain reference to the old name and id-             -- See (#19619) for more discussion-             !old_occ_name = getOccName old_name-             new_name = mkInternalName uniq old_occ_name loc+             new_name = mkInternalName uniq (getOccName old_name) loc              new_kind = substTyUnchecked subst (tyVarKind tycovar)              new_tcv  = mk_tcv new_name new_kind              subst1   = extendTCvSubstWithClone subst tycovar new_tcv@@ -615,10 +605,22 @@ b) The [TyVar] should be ordered (kind vars first)    See Note [Kind substitution when instantiating] -c) It's a complete freshening operation: the skolems have a fresh-   unique, and a location from the monad+c) Clone the variable to give a fresh unique.  This is essential.+   Consider (tc160)+       type Foo x = forall a. a -> x+   And typecheck the expression+       (e :: Foo (Foo ())+   We will skolemise the signature, but after expanding synonyms it+   looks like+        forall a. a -> forall a. a -> x+   We don't want to make two big-lambdas with the same unique! -d) The resulting skolems are+d) We retain locations. Because the location of the variable is the correct+   location to report in errors (e.g. in the signature). We don't want the+   location to change to the body of the function, which does *not* explicitly+   bind the variable.++e) The resulting skolems are         non-overlappable for tcInstSkolTyVars,    but overlappable for tcInstSuperSkolTyVars    See GHC.Tc.Deriv.Infer Note [Overlap and deriving] for an example@@ -657,34 +659,18 @@ newOverloadedLit :: HsOverLit GhcRn                  -> ExpRhoType                  -> TcM (HsOverLit GhcTc)-newOverloadedLit-  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty-  | not rebindable-  = do { res_ty <- expTypeToType res_ty-       ; dflags <- getDynFlags-       ; let platform = targetPlatform dflags-       ; case shortCutLit platform val res_ty of-        -- Do not generate a LitInst for rebindable syntax.-        -- Reason: If we do, tcSimplify will call lookupInst, which-        --         will call tcSyntaxName, which does unification,-        --         which tcSimplify doesn't like-           Just expr -> return (lit { ol_witness = expr-                                    , ol_ext = OverLitTc False res_ty })-           Nothing   -> newNonTrivialOverloadedLit orig lit-                                                   (mkCheckExpType res_ty) }--  | otherwise-  = newNonTrivialOverloadedLit orig lit res_ty-  where-    orig = LiteralOrigin lit+newOverloadedLit lit res_ty+  = do { mb_lit' <- tcShortCutLit lit res_ty+       ; case mb_lit' of+            Just lit' -> return lit'+            Nothing   -> newNonTrivialOverloadedLit lit res_ty }  -- Does not handle things that 'shortCutLit' can handle. See also -- newOverloadedLit in GHC.Tc.Utils.Unify-newNonTrivialOverloadedLit :: CtOrigin-                           -> HsOverLit GhcRn+newNonTrivialOverloadedLit :: HsOverLit GhcRn                            -> ExpRhoType                            -> TcM (HsOverLit GhcTc)-newNonTrivialOverloadedLit orig+newNonTrivialOverloadedLit   lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)                , ol_ext = rebindable }) res_ty   = do  { hs_lit <- mkOverLit val@@ -696,7 +682,10 @@         ; res_ty <- readExpType res_ty         ; return (lit { ol_witness = witness                       , ol_ext = OverLitTc rebindable res_ty }) }-newNonTrivialOverloadedLit _ lit _+  where+    orig = LiteralOrigin lit++newNonTrivialOverloadedLit lit _   = pprPanic "newNonTrivialOverloadedLit" (ppr lit)  ------------@@ -772,7 +761,7 @@         -- same type as the standard one.         -- Tiresome jiggling because tcCheckSigma takes a located expression      span <- getSrcSpanM-     expr <- tcCheckPolyExpr (L span user_nm_expr) sigma1+     expr <- tcCheckPolyExpr (L (noAnnSrcSpan span) user_nm_expr) sigma1      return (std_nm, unLoc expr)  syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv@@ -853,15 +842,8 @@ tcExtendLocalInstEnv dfuns thing_inside  = do { traceDFuns dfuns       ; env <- getGblEnv-      -- Force the access to the TcgEnv so it isn't retained.-      -- During auditing it is much easier to observe in -hi profiles if-      -- there are a very small number of TcGblEnv. Keeping a TcGblEnv-      -- alive is quite dangerous because it contains reference to many-      -- large data structures.-      ; let !init_inst_env = tcg_inst_env env-            !init_insts = tcg_insts env       ; (inst_env', cls_insts') <- foldlM addLocalInst-                                          (init_inst_env, init_insts)+                                          (tcg_inst_env env, tcg_insts env)                                           dfuns       ; let env' = env { tcg_insts    = cls_insts'                        , tcg_inst_env = inst_env' }@@ -981,9 +963,10 @@                     [ispec, dup_ispec]  addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()-addClsInstsErr herald ispecs-  = setSrcSpan (getSrcSpan (head sorted)) $-    addErr (hang herald 2 (pprInstances sorted))+addClsInstsErr herald ispecs = do+   unit_state <- hsc_units <$> getTopEnv+   setSrcSpan (getSrcSpan (head sorted)) $+      addErr $ pprWithUnitState unit_state $ (hang herald 2 (pprInstances sorted))  where    sorted = sortBy (SrcLoc.leftmost_smallest `on` getSrcSpan) ispecs    -- The sortBy just arranges that instances are displayed in order

GHC/Tc/Utils/Monad.hs view

@@ -1,15 +1,17 @@-{--(c) The University of Glasgow 2006---}+{-# LANGUAGE BangPatterns      #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE ExplicitForAll    #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards   #-} -{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}-{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# LANGUAGE ViewPatterns #-} +{-+(c) The University of Glasgow 2006 +-}+ -- | Functions for working with the typechecker environment (setters, -- getters...). module GHC.Tc.Utils.Monad(@@ -26,7 +28,7 @@   whenDOptM, whenGOptM, whenWOptM,   whenXOptM, unlessXOptM,   getGhcMode,-  withDoDynamicToo,+  withDynamicNow, withoutDynamicNow,   getEpsVar,   getEps,   updateEps, updateEps_,@@ -59,8 +61,9 @@   addDependentFiles,    -- * Error management-  getSrcSpanM, setSrcSpan, addLocM, inGeneratedCode,-  wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,+  getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM, addLocMA, inGeneratedCode,+  wrapLocM, wrapLocAM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,+  wrapLocMA_,wrapLocMA,   getErrsVar, setErrsVar,   addErr,   failWith, failAt,@@ -73,7 +76,7 @@   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,    -- * Shared error message stuff: renamer and typechecker-  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,+  mkLongErrAt, mkDecoratedSDocAt, addLongErrAt, reportErrors, reportError,   reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,   attemptM, tryTc,   askNoErrs, discardErrs, tryTcDiscardingErrs,@@ -109,7 +112,7 @@   getTcLevel, setTcLevel, isTouchableTcM,   getLclTypeEnv, setLclTypeEnv,   traceTcConstraints,-  emitNamedTypeHole, emitAnonTypeHole,+  emitNamedTypeHole, IsExtraConstraint(..), emitAnonTypeHole,    -- * Template Haskell context   recordThUse, recordThSpliceUse,@@ -138,7 +141,7 @@   withException,    -- * Stuff for cost centres.-  ContainsCostCentreState(..), getCCIndexM,+  getCCIndexM, getCCIndexTcM,    -- * Types etc.   module GHC.Tc.Types,@@ -149,44 +152,62 @@  import GHC.Prelude ++import GHC.Builtin.Names+ import GHC.Tc.Types     -- Re-export all-import GHC.Data.IOEnv -- Re-export all import GHC.Tc.Types.Constraint import GHC.Tc.Types.Evidence import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType  import GHC.Hs hiding (LIE)-import GHC.Driver.Types+ import GHC.Unit-import GHC.Types.Name.Reader-import GHC.Types.Name+import GHC.Unit.External+import GHC.Unit.Module.Warnings+import GHC.Unit.Home.ModInfo+ import GHC.Core.UsageEnv import GHC.Core.Multiplicity-import GHC.Core.Type--import GHC.Tc.Utils.TcType import GHC.Core.InstEnv import GHC.Core.FamInstEnv-import GHC.Builtin.Names +import GHC.Driver.Env+import GHC.Driver.Ppr+import GHC.Driver.Session++import GHC.Runtime.Context++import GHC.Data.IOEnv -- Re-export all+import GHC.Data.Bag+import GHC.Data.FastString+import GHC.Data.Maybe++import GHC.Utils.Outputable as Outputable+import GHC.Utils.Error+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Logger++import GHC.Types.Error+import GHC.Types.Fixity.Env+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SafeHaskell import GHC.Types.Id+import GHC.Types.TypeEnv import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Utils.Error import GHC.Types.SrcLoc import GHC.Types.Name.Env import GHC.Types.Name.Set-import GHC.Data.Bag-import GHC.Utils.Outputable as Outputable+import GHC.Types.Name.Ppr import GHC.Types.Unique.Supply-import GHC.Driver.Session-import GHC.Data.FastString-import GHC.Utils.Panic-import GHC.Utils.Misc import GHC.Types.Annotations import GHC.Types.Basic( TopLevelFlag, TypeOrKind(..) )-import GHC.Data.Maybe import GHC.Types.CostCentre.State+import GHC.Types.SourceFile  import qualified GHC.LanguageExtensions as LangExt @@ -212,7 +233,7 @@        -> Module        -> RealSrcSpan        -> TcM r-       -> IO (Messages, Maybe r)+       -> IO (Messages DecoratedSDoc, Maybe r)                 -- Nothing => error thrown by the thing inside                 -- (error messages should have been printed already) @@ -237,8 +258,11 @@         th_coreplugins_var <- newIORef [] ;         th_state_var         <- newIORef Map.empty ;         th_remote_state_var  <- newIORef Nothing ;+        th_docs_var          <- newIORef Map.empty ;         let {-             dflags = hsc_dflags hsc_env ;+             -- bangs to avoid leaking the env (#19356)+             !dflags = hsc_dflags hsc_env ;+             !home_unit = hsc_home_unit hsc_env ;               maybe_rn_syntax :: forall a. a -> Maybe a ;              maybe_rn_syntax empty_val@@ -262,10 +286,10 @@                 tcg_th_coreplugins = th_coreplugins_var,                 tcg_th_state         = th_state_var,                 tcg_th_remote_state  = th_remote_state_var,+                tcg_th_docs          = th_docs_var,                  tcg_mod            = mod,-                tcg_semantic_mod   =-                    canonicalizeModuleIfHome dflags mod,+                tcg_semantic_mod   = homeModuleInstantiation home_unit mod,                 tcg_src            = hsc_src,                 tcg_rdr_env        = emptyGlobalRdrEnv,                 tcg_fix_env        = emptyNameEnv,@@ -298,6 +322,7 @@                 tcg_binds          = emptyLHsBinds,                 tcg_imp_specs      = [],                 tcg_sigs           = emptyNameSet,+                tcg_ksigs          = emptyNameSet,                 tcg_ev_binds       = emptyBag,                 tcg_warns          = NoWarnings,                 tcg_anns           = [],@@ -334,10 +359,10 @@               -> TcGblEnv               -> RealSrcSpan               -> TcM r-              -> IO (Messages, Maybe r)+              -> IO (Messages DecoratedSDoc, Maybe r) initTcWithGbl hsc_env gbl_env loc do_this  = do { lie_var      <- newIORef emptyWC-      ; errs_var     <- newIORef (emptyBag, emptyBag)+      ; errs_var     <- newIORef emptyMessages       ; usage_var    <- newIORef zeroUE       ; let lcl_env = TcLclEnv {                 tcl_errs       = errs_var,@@ -374,14 +399,13 @@         -- Collect any error messages       ; msgs <- readIORef (tcl_errs lcl_env) -      ; let { final_res | errorsFound dflags msgs = Nothing-                        | otherwise               = maybe_res }+      ; let { final_res | errorsFound msgs = Nothing+                        | otherwise        = maybe_res }        ; return (msgs, final_res)       }-  where dflags = hsc_dflags hsc_env -initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)+initTcInteractive :: HscEnv -> TcM a -> IO (Messages DecoratedSDoc, Maybe a) -- Initialise the type checker monad for use in GHCi initTcInteractive hsc_env thing_inside   = initTc hsc_env HsSrcFile False@@ -527,11 +551,16 @@ getGhcMode :: TcRnIf gbl lcl GhcMode getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) } -withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a-withDoDynamicToo =+withDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a+withDynamicNow =   updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->-              top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })+              top { hsc_dflags = setDynamicNow dflags }) +withoutDynamicNow :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a+withoutDynamicNow =+  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->+              top { hsc_dflags = dflags { dynamicNow = False} })+ getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState) getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) } @@ -565,9 +594,9 @@ getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)                   ; return (eps, hsc_HPT env) } --- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing+-- | A convenient wrapper for taking a @MaybeErr SDoc a@ and throwing -- an exception if it is an error.-withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a+withException :: TcRnIf gbl lcl (MaybeErr SDoc a) -> TcRnIf gbl lcl a withException do_this = do     r <- do_this     dflags <- getDynFlags@@ -727,16 +756,16 @@ formatTraceMsg herald doc = hang (text herald) 2 doc  traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()-traceOptTcRn flag doc = do+traceOptTcRn flag doc =   whenDOptM flag $-    dumpTcRn False (dumpOptionsFromFlag flag) "" FormatText doc+    dumpTcRn False flag "" FormatText doc {-# INLINE traceOptTcRn #-} -- see Note [INLINE conditional tracing utilities]  -- | Dump if the given 'DumpFlag' is set. dumpOptTcRn :: DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()-dumpOptTcRn flag title fmt doc = do+dumpOptTcRn flag title fmt doc =   whenDOptM flag $-    dumpTcRn False (dumpOptionsFromFlag flag) title fmt doc+    dumpTcRn False flag title fmt doc {-# INLINE dumpOptTcRn #-} -- see Note [INLINE conditional tracing utilities]  -- | Unconditionally dump some trace output@@ -746,15 +775,16 @@ -- generally we want all other debugging output to use 'PprDump' -- style. We 'PprUser' style if 'useUserStyle' is True. ---dumpTcRn :: Bool -> DumpOptions -> String -> DumpFormat -> SDoc -> TcRn ()-dumpTcRn useUserStyle dumpOpt title fmt doc = do+dumpTcRn :: Bool -> DumpFlag -> String -> DumpFormat -> SDoc -> TcRn ()+dumpTcRn useUserStyle flag title fmt doc = do   dflags <- getDynFlags-  printer <- getPrintUnqualified dflags+  logger <- getLogger+  printer <- getPrintUnqualified   real_doc <- wrapDocLoc doc   let sty = if useUserStyle               then mkUserStyle printer AllTheWay               else mkDumpStyle printer-  liftIO $ dumpAction dflags sty dumpOpt title fmt real_doc+  liftIO $ putDumpMsg logger dflags sty flag title fmt real_doc  -- | Add current location if -dppr-debug -- (otherwise the full location is usually way too much)@@ -768,17 +798,19 @@     else       return doc -getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified-getPrintUnqualified dflags+getPrintUnqualified :: TcRn PrintUnqualified+getPrintUnqualified   = do { rdr_env <- getGlobalRdrEnv-       ; return $ mkPrintUnqualified dflags rdr_env }+       ; hsc_env <- getTopEnv+       ; return $ mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env }  -- | Like logInfoTcRn, but for user consumption printForUserTcRn :: SDoc -> TcRn ()-printForUserTcRn doc-  = do { dflags <- getDynFlags-       ; printer <- getPrintUnqualified dflags-       ; liftIO (printOutputForUser dflags printer doc) }+printForUserTcRn doc = do+    dflags <- getDynFlags+    logger <- getLogger+    printer <- getPrintUnqualified+    liftIO (printOutputForUser logger dflags printer doc)  {- traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is@@ -795,9 +827,10 @@  traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () traceOptIf flag doc-  = whenDOptM flag $    -- No RdrEnv available, so qualify everything-    do { dflags <- getDynFlags-       ; liftIO (putMsg dflags doc) }+  = whenDOptM flag $ do   -- No RdrEnv available, so qualify everything+        dflags <- getDynFlags+        logger <- getLogger+        liftIO (putMsg logger dflags doc) {-# INLINE traceOptIf #-}  -- see Note [INLINE conditional tracing utilities]  {-@@ -868,60 +901,93 @@         -- Avoid clash with Name.getSrcLoc getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env) Nothing) } --- See Note [Rebindable syntax and HsExpansion].+-- See Note [Error contexts in generated code] inGeneratedCode :: TcRn Bool inGeneratedCode = tcl_in_gen_code <$> getLclEnv  setSrcSpan :: SrcSpan -> TcRn a -> TcRn a-setSrcSpan (RealSrcSpan loc _) thing_inside =-  updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })-            thing_inside+-- See Note [Error contexts in generated code]+-- for the tcl_in_gen_code manipulation+setSrcSpan (RealSrcSpan loc _) thing_inside+  = updLclEnv (\env -> env { tcl_loc = loc, tcl_in_gen_code = False })+              thing_inside+ setSrcSpan loc@(UnhelpfulSpan _) thing_inside-  -- See Note [Rebindable syntax and HsExpansion].-  | isGeneratedSrcSpan loc =-      updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside-  | otherwise = thing_inside+  | isGeneratedSrcSpan loc+  = updLclEnv (\env -> env { tcl_in_gen_code = True }) thing_inside +  | otherwise+  = thing_inside++setSrcSpanA :: SrcSpanAnn' ann -> TcRn a -> TcRn a+setSrcSpanA l = setSrcSpan (locA l)+ addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a +addLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcM b+addLocMA fn (L loc a) = setSrcSpanA loc $ fn a+ wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) wrapLocM fn (L loc a) = setSrcSpan loc $ do { b <- fn a                                             ; return (L loc b) } +wrapLocAM :: (a -> TcM b) -> LocatedAn an a -> TcM (Located b)+wrapLocAM fn (L loc a) = setSrcSpanA loc $ do { b <- fn a+                                              ; return (L (locA loc) b) }++wrapLocMA :: (a -> TcM b) -> GenLocated (SrcSpanAnn' ann) a -> TcRn (GenLocated (SrcSpanAnn' ann) b)+wrapLocMA fn (L loc a) = setSrcSpanA loc $ do { b <- fn a+                                              ; return (L loc b) }+ wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) wrapLocFstM fn (L loc a) =   setSrcSpan loc $ do     (b,c) <- fn a     return (L loc b, c) +wrapLocFstMA :: (a -> TcM (b,c)) -> LocatedA a -> TcM (LocatedA b, c)+wrapLocFstMA fn (L loc a) =+  setSrcSpanA loc $ do+    (b,c) <- fn a+    return (L loc b, c)+ wrapLocSndM :: (a -> TcM (b, c)) -> Located a -> TcM (b, Located c) wrapLocSndM fn (L loc a) =   setSrcSpan loc $ do     (b,c) <- fn a     return (b, L loc c) +wrapLocSndMA :: (a -> TcM (b, c)) -> LocatedA a -> TcM (b, LocatedA c)+wrapLocSndMA fn (L loc a) =+  setSrcSpanA loc $ do+    (b,c) <- fn a+    return (b, L loc c)+ wrapLocM_ :: (a -> TcM ()) -> Located a -> TcM () wrapLocM_ fn (L loc a) = setSrcSpan loc (fn a) +wrapLocMA_ :: (a -> TcM ()) -> LocatedA a -> TcM ()+wrapLocMA_ fn (L loc a) = setSrcSpan (locA loc) (fn a)+ -- Reporting errors -getErrsVar :: TcRn (TcRef Messages)+getErrsVar :: TcRn (TcRef (Messages DecoratedSDoc)) getErrsVar = do { env <- getLclEnv; return (tcl_errs env) } -setErrsVar :: TcRef Messages -> TcRn a -> TcRn a+setErrsVar :: TcRef (Messages DecoratedSDoc) -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v }) -addErr :: MsgDoc -> TcRn ()+addErr :: SDoc -> TcRn () addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg } -failWith :: MsgDoc -> TcRn a+failWith :: SDoc -> TcRn a failWith msg = addErr msg >> failM -failAt :: SrcSpan -> MsgDoc -> TcRn a+failAt :: SrcSpan -> SDoc -> TcRn a failAt loc msg = addErrAt loc msg >> failM -addErrAt :: SrcSpan -> MsgDoc -> TcRn ()+addErrAt :: SrcSpan -> SDoc -> TcRn () -- addErrAt is mainly (exclusively?) used by the renamer, where -- tidying is not an issue, but it's all lazy so the extra -- work doesn't matter@@ -930,16 +996,16 @@                       ; err_info <- mkErrInfo tidy_env ctxt                       ; addLongErrAt loc msg err_info } -addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()+addErrs :: [(SrcSpan,SDoc)] -> TcRn () addErrs msgs = mapM_ add msgs              where                add (loc,msg) = addErrAt loc msg -checkErr :: Bool -> MsgDoc -> TcRn ()+checkErr :: Bool -> SDoc -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) -addMessages :: Messages -> TcRn ()+addMessages :: Messages DecoratedSDoc -> TcRn () addMessages msgs1   = do { errs_var <- getErrsVar ;          msgs0 <- readTcRef errs_var ;@@ -950,13 +1016,13 @@ -- used to ignore-unused-variable warnings inside derived code discardWarnings thing_inside   = do  { errs_var <- getErrsVar-        ; (old_warns, _) <- readTcRef errs_var+        ; old_warns <- getWarningMessages <$> readTcRef errs_var          ; result <- thing_inside          -- Revert warnings to old_warns-        ; (_new_warns, new_errs) <- readTcRef errs_var-        ; writeTcRef errs_var (old_warns, new_errs)+        ; new_errs <- getErrorMessages <$> readTcRef errs_var+        ; writeTcRef errs_var $ mkMessages (old_warns `unionBags` new_errs)          ; return result } @@ -968,42 +1034,54 @@ ************************************************************************ -} -mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg+mkLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn (MsgEnvelope DecoratedSDoc) mkLongErrAt loc msg extra-  = do { dflags <- getDynFlags ;-         printer <- getPrintUnqualified dflags ;-         return $ mkLongErrMsg dflags loc printer msg extra }+  = do { printer <- getPrintUnqualified ;+         unit_state <- hsc_units <$> getTopEnv ;+         let msg' = pprWithUnitState unit_state msg in+         return $ mkLongMsgEnvelope loc printer msg' extra } -mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg-mkErrDocAt loc errDoc-  = do { dflags <- getDynFlags ;-         printer <- getPrintUnqualified dflags ;-         return $ mkErrDoc dflags loc printer errDoc }+mkDecoratedSDocAt :: SrcSpan+                  -> SDoc+                  -- ^ The important part of the message+                  -> SDoc+                  -- ^ The context of the message+                  -> SDoc+                  -- ^ Any supplementary information.+                  -> TcRn (MsgEnvelope DecoratedSDoc)+mkDecoratedSDocAt loc important context extra+  = do { printer <- getPrintUnqualified ;+         unit_state <- hsc_units <$> getTopEnv ;+         let f = pprWithUnitState unit_state+             errDoc  = [important, context, extra]+             errDoc' = mkDecorated $ map f errDoc+         in+         return $ mkErr loc printer errDoc' } -addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()+addLongErrAt :: SrcSpan -> SDoc -> SDoc -> TcRn () addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError -reportErrors :: [ErrMsg] -> TcM ()+reportErrors :: [MsgEnvelope DecoratedSDoc] -> TcM () reportErrors = mapM_ reportError -reportError :: ErrMsg -> TcRn ()+reportError :: MsgEnvelope DecoratedSDoc -> TcRn () reportError err-  = do { traceTc "Adding error:" (pprLocErrMsg err) ;+  = do { traceTc "Adding error:" (pprLocMsgEnvelope err) ;          errs_var <- getErrsVar ;-         (warns, errs) <- readTcRef errs_var ;-         writeTcRef errs_var (warns, errs `snocBag` err) }+         msgs     <- readTcRef errs_var ;+         writeTcRef errs_var (err `addMessage` msgs) } -reportWarning :: WarnReason -> ErrMsg -> TcRn ()+reportWarning :: WarnReason -> MsgEnvelope DecoratedSDoc -> TcRn () reportWarning reason err   = do { let warn = makeIntoWarning reason err-                    -- 'err' was built by mkLongErrMsg or something like that,+                    -- 'err' was built by mkLongMsgEnvelope or something like that,                     -- so it's of error severity.  For a warning we downgrade                     -- its severity to SevWarning -       ; traceTc "Adding warning:" (pprLocErrMsg warn)+       ; traceTc "Adding warning:" (pprLocMsgEnvelope warn)        ; errs_var <- getErrsVar-       ; (warns, errs) <- readTcRef errs_var-       ; writeTcRef errs_var (warns `snocBag` warn, errs) }+       ; (warns, errs) <- partitionMessages <$> readTcRef errs_var+       ; writeTcRef errs_var (mkMessages $ (warns `snocBag` warn) `unionBags` errs) }   -----------------------@@ -1030,8 +1108,7 @@ ifErrsM bale_out normal  = do { errs_var <- getErrsVar ;         msgs <- readTcRef errs_var ;-        dflags <- getDynFlags ;-        if errorsFound dflags msgs then+        if errorsFound msgs then            bale_out         else            normal }@@ -1062,8 +1139,21 @@ This reliance on delicate inlining and Called Arity is not good. See #18202 for a more general approach.  But meanwhile, these ininings seem unobjectional, and they solve the immediate-problem. -}+problem. +Note [Error contexts in generated code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* setSrcSpan sets tc_in_gen_code to True if the SrcSpan is GeneratedSrcSpan,+  and back to False when we get a useful SrcSpan++* When tc_in_gen_code is True, addErrCtxt becomes a no-op.++So typically it's better to do setSrcSpan /before/ addErrCtxt.++See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr for+more discussion of this fancy footwork.+-}+ getErrCtxt :: TcM [ErrCtxt] getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) } @@ -1073,45 +1163,46 @@  -- | Add a fixed message to the error context. This message should not -- do any tidying.-addErrCtxt :: MsgDoc -> TcM a -> TcM a+addErrCtxt :: SDoc -> TcM a -> TcM a {-# INLINE addErrCtxt #-}   -- Note [Inlining addErrCtxt] addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))  -- | Add a message to the error context. This message may do tidying.-addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addErrCtxtM #-}  -- Note [Inlining addErrCtxt]-addErrCtxtM ctxt m = updCtxt (push_ctxt (False, ctxt)) m+addErrCtxtM ctxt = pushCtxt (False, ctxt)  -- | Add a fixed landmark message to the error context. A landmark -- message is always sure to be reported, even if there is a lot of -- context. It also doesn't count toward the maximum number of contexts -- reported.-addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a+addLandmarkErrCtxt :: SDoc -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxt #-}  -- Note [Inlining addErrCtxt] addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))  -- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations -- and tidying.-addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, SDoc)) -> TcM a -> TcM a {-# INLINE addLandmarkErrCtxtM #-}  -- Note [Inlining addErrCtxt]-addLandmarkErrCtxtM ctxt m = updCtxt (push_ctxt (True, ctxt)) m+addLandmarkErrCtxtM ctxt = pushCtxt (True, ctxt) -push_ctxt :: (Bool, TidyEnv -> TcM (TidyEnv, MsgDoc))-          -> Bool -> [ErrCtxt] -> [ErrCtxt]-push_ctxt ctxt in_gen ctxts-  | in_gen    = ctxts-  | otherwise = ctxt : ctxts+pushCtxt :: ErrCtxt -> TcM a -> TcM a+{-# INLINE pushCtxt #-} -- Note [Inlining addErrCtxt]+pushCtxt ctxt = updLclEnv (updCtxt ctxt) -updCtxt :: (Bool -> [ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a-{-# INLINE updCtxt #-} -- Note [Inlining addErrCtxt]--- Helper function for the above--- The Bool is true if we are in generated code-updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt-                                         , tcl_in_gen_code = in_gen }) ->-                           env { tcl_ctxt = upd in_gen ctxt })+updCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv+-- Do not update the context if we are in generated code+-- See Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr+updCtxt ctxt env@(TcLclEnv { tcl_ctxt = ctxts, tcl_in_gen_code = in_gen })+  | in_gen    = env+  | otherwise = env { tcl_ctxt = ctxt : ctxts }  popErrCtxt :: TcM a -> TcM a-popErrCtxt = updCtxt (\ _ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })+popErrCtxt = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->+                          env { tcl_ctxt = pop ctxt })+           where+             pop []       = []+             pop (_:msgs) = msgs  getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc getCtLocM origin t_or_k@@ -1164,7 +1255,7 @@        ; lie <- readTcRef lie_var        ; return (res, lie) } -capture_messages :: TcM r -> TcM (r, Messages)+capture_messages :: TcM r -> TcM (r, Messages DecoratedSDoc) -- capture_messages simply captures and returns the --                  errors arnd warnings generated by thing_inside -- Precondition: thing_inside must not throw an exception!@@ -1200,8 +1291,7 @@                           ; failM }             Just res -> do { emitConstraints lie-                          ; dflags <- getDynFlags-                          ; let errs_found = errorsFound dflags msgs+                          ; let errs_found = errorsFound msgs                                           || insolubleWC lie                           ; return (res, not errs_found) } } @@ -1335,7 +1425,7 @@                                 Just acc' -> foldAndRecoverM f acc' xs  }  ------------------------tryTc :: TcRn a -> TcRn (Maybe a, Messages)+tryTc :: TcRn a -> TcRn (Maybe a, Messages DecoratedSDoc) -- (tryTc m) executes m, and returns --      Just r,  if m succeeds (returning r) --      Nothing, if m fails@@ -1363,9 +1453,8 @@   = do { ((mb_res, lie), msgs) <- capture_messages    $                                   capture_constraints $                                   tcTryM thing_inside-        ; dflags <- getDynFlags         ; case mb_res of-            Just res | not (errorsFound dflags msgs)+            Just res | not (errorsFound msgs)                      , not (insolubleWC lie)               -> -- 'main' succeeded with no errors                  do { addMessages msgs  -- msgs might still have warnings@@ -1389,11 +1478,11 @@     tidy up the message; we then use it to tidy the context messages -} -addErrTc :: MsgDoc -> TcM ()+addErrTc :: SDoc -> TcM () addErrTc err_msg = do { env0 <- tcInitTidyEnv                       ; addErrTcM (env0, err_msg) } -addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()+addErrTcM :: (TidyEnv, SDoc) -> TcM () addErrTcM (tidy_env, err_msg)   = do { ctxt <- getErrCtxt ;          loc  <- getSrcSpanM ;@@ -1401,27 +1490,27 @@  -- The failWith functions add an error message and cause failure -failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail+failWithTc :: SDoc -> TcM a               -- Add an error message and fail failWithTc err_msg   = addErrTc err_msg >> failM -failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail+failWithTcM :: (TidyEnv, SDoc) -> TcM a   -- Add an error message and fail failWithTcM local_and_msg   = addErrTcM local_and_msg >> failM -checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true+checkTc :: Bool -> SDoc -> TcM ()         -- Check that the boolean is true checkTc True  _   = return () checkTc False err = failWithTc err -checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()+checkTcM :: Bool -> (TidyEnv, SDoc) -> TcM () checkTcM True  _   = return () checkTcM False err = failWithTcM err -failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false+failIfTc :: Bool -> SDoc -> TcM ()         -- Check that the boolean is false failIfTc False _   = return () failIfTc True  err = failWithTc err -failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()+failIfTcM :: Bool -> (TidyEnv, SDoc) -> TcM ()    -- Check that the boolean is false failIfTcM False _   = return () failIfTcM True  err = failWithTcM err@@ -1431,63 +1520,62 @@  -- | Display a warning if a condition is met, --   and the warning is enabled-warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()+warnIfFlag :: WarningFlag -> Bool -> SDoc -> TcRn () warnIfFlag warn_flag is_bad msg   = do { warn_on <- woptM warn_flag        ; when (warn_on && is_bad) $          addWarn (Reason warn_flag) msg }  -- | Display a warning if a condition is met.-warnIf :: Bool -> MsgDoc -> TcRn ()+warnIf :: Bool -> SDoc -> TcRn () warnIf is_bad msg   = when is_bad (addWarn NoReason msg)  -- | Display a warning if a condition is met.-warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()+warnTc :: WarnReason -> Bool -> SDoc -> TcM () warnTc reason warn_if_true warn_msg   | warn_if_true = addWarnTc reason warn_msg   | otherwise    = return ()  -- | Display a warning if a condition is met.-warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()+warnTcM :: WarnReason -> Bool -> (TidyEnv, SDoc) -> TcM () warnTcM reason warn_if_true warn_msg   | warn_if_true = addWarnTcM reason warn_msg   | otherwise    = return ()  -- | Display a warning in the current context.-addWarnTc :: WarnReason -> MsgDoc -> TcM ()+addWarnTc :: WarnReason -> SDoc -> TcM () addWarnTc reason msg  = do { env0 <- tcInitTidyEnv ;       addWarnTcM reason (env0, msg) }  -- | Display a warning in a given context.-addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()+addWarnTcM :: WarnReason -> (TidyEnv, SDoc) -> TcM () addWarnTcM reason (env0, msg)  = do { ctxt <- getErrCtxt ;         err_info <- mkErrInfo env0 ctxt ;         add_warn reason msg err_info }  -- | Display a warning for the current source location.-addWarn :: WarnReason -> MsgDoc -> TcRn ()+addWarn :: WarnReason -> SDoc -> TcRn () addWarn reason msg = add_warn reason msg Outputable.empty  -- | Display a warning for a given source location.-addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()+addWarnAt :: WarnReason -> SrcSpan -> SDoc -> TcRn () addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty  -- | Display a warning, with an optional flag, for the current source -- location.-add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()+add_warn :: WarnReason -> SDoc -> SDoc -> TcRn () add_warn reason msg extra_info   = do { loc <- getSrcSpanM        ; add_warn_at reason loc msg extra_info }  -- | Display a warning, with an optional flag, for a given location.-add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()+add_warn_at :: WarnReason -> SrcSpan -> SDoc -> SDoc -> TcRn () add_warn_at reason loc msg extra_info-  = do { dflags <- getDynFlags ;-         printer <- getPrintUnqualified dflags ;-         let { warn = mkLongWarnMsg dflags loc printer+  = do { printer <- getPrintUnqualified ;+         let { warn = mkLongWarnMsg loc printer                                     msg extra_info } ;          reportWarning reason warn } @@ -1497,7 +1585,7 @@         Other helper functions -} -add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan+add_err_tcm :: TidyEnv -> SDoc -> SrcSpan             -> [ErrCtxt]             -> TcM () add_err_tcm tidy_env err_msg loc ctxt@@ -1746,16 +1834,26 @@          hang (text (msg ++ ": LIE:")) 2 (ppr lie)        } -emitAnonTypeHole :: TcTyVar -> TcM ()-emitAnonTypeHole tv+data IsExtraConstraint = YesExtraConstraint+                       | NoExtraConstraint++instance Outputable IsExtraConstraint where+  ppr YesExtraConstraint = text "YesExtraConstraint"+  ppr NoExtraConstraint  = text "NoExtraConstraint"++emitAnonTypeHole :: IsExtraConstraint+                 -> TcTyVar -> TcM ()+emitAnonTypeHole extra_constraints tv   = do { ct_loc <- getCtLocM (TypeHoleOrigin occ) Nothing-       ; let hole = Hole { hole_sort = TypeHole+       ; let hole = Hole { hole_sort = sort                          , hole_occ  = occ                          , hole_ty   = mkTyVarTy tv                          , hole_loc  = ct_loc }        ; emitHole hole }   where     occ = mkTyVarOcc "_"+    sort | YesExtraConstraint <- extra_constraints = ConstraintHole+         | otherwise                               = TypeHole  emitNamedTypeHole :: (Name, TcTyVar) -> TcM () emitNamedTypeHole (name, tv)@@ -1805,11 +1903,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.simplifyAndEmitFlatConstraints 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 invariants] 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.@@ -1933,12 +2054,13 @@ initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside   = do  { tcg_env <- getGblEnv-        ; dflags <- getDynFlags+        ; hsc_env <- getTopEnv+          -- bangs to avoid leaking the envs (#19356)         ; let !mod = tcg_semantic_mod tcg_env+              !home_unit = hsc_home_unit hsc_env               -- When we are instantiating a signature, we DEFINITELY               -- do not want to knot tie.-              is_instantiate = homeUnitIsDefinite dflags &&-                               not (null (homeUnitInstantiations dflags))+              is_instantiate = isHomeUnitInstantiating home_unit         ; let { if_env = IfGblEnv {                             if_doc = text "initIfaceTcRn",                             if_rec_types =@@ -1989,56 +2111,58 @@ getIfModule = do { env <- getLclEnv; return (if_mod env) }  ---------------------failIfM :: MsgDoc -> IfL a+failIfM :: SDoc -> IfL a -- The Iface monad doesn't have a place to accumulate errors, so we -- just fall over fast if one happens; it "shouldn't happen". -- We use IfL here so that we can get context info out of the local env-failIfM msg-  = do  { env <- getLclEnv-        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg-        ; dflags <- getDynFlags-        ; liftIO (putLogMsg dflags NoReason SevFatal-                   noSrcSpan $ withPprStyle defaultErrStyle full_msg)-        ; failM }+failIfM msg = do+    env <- getLclEnv+    let full_msg = (if_loc env <> colon) $$ nest 2 msg+    dflags <- getDynFlags+    logger <- getLogger+    liftIO (putLogMsg logger dflags NoReason SevFatal+             noSrcSpan $ withPprStyle defaultErrStyle full_msg)+    failM  ---------------------forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)--- Run thing_inside in an interleaved thread.++-- | Run thing_inside in an interleaved thread. -- It shares everything with the parent thread, so this is DANGEROUS. -- -- It returns Nothing if the computation fails -- -- It's used for lazily type-checking interface--- signatures, which is pretty benign-+-- signatures, which is pretty benign.+--+-- See Note [Masking exceptions in forkM_maybe]+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a) forkM_maybe doc thing_inside- = do { -- see Note [Masking exceptions in forkM_maybe]-      ; unsafeInterleaveM $ uninterruptibleMaskM_ $-        do { traceIf (text "Starting fork {" <+> doc)-           ; mb_res <- tryM $-                       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $-                       thing_inside-           ; case mb_res of-                Right r  -> do  { traceIf (text "} ending fork" <+> doc)-                                ; return (Just r) }-                Left exn -> do {--                    -- Bleat about errors in the forked thread, if -ddump-if-trace is on-                    -- Otherwise we silently discard errors. Errors can legitimately-                    -- happen when compiling interface signatures (see tcInterfaceSigs)-                      whenDOptM Opt_D_dump_if_trace $ do-                          dflags <- getDynFlags-                          let msg = hang (text "forkM failed:" <+> doc)-                                       2 (text (show exn))-                          liftIO $ putLogMsg dflags-                                             NoReason-                                             SevFatal-                                             noSrcSpan-                                             $ withPprStyle defaultErrStyle msg+ = unsafeInterleaveM $ uninterruptibleMaskM_ $+    do { traceIf (text "Starting fork {" <+> doc)+       ; mb_res <- tryM $+                   updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $+                   thing_inside+       ; case mb_res of+            Right r  -> do  { traceIf (text "} ending fork" <+> doc)+                            ; return (Just r) }+            Left exn -> do {+                -- Bleat about errors in the forked thread, if -ddump-if-trace is on+                -- Otherwise we silently discard errors. Errors can legitimately+                -- happen when compiling interface signatures (see tcInterfaceSigs)+                  whenDOptM Opt_D_dump_if_trace $ do+                      dflags <- getDynFlags+                      logger <- getLogger+                      let msg = hang (text "forkM failed:" <+> doc)+                                   2 (text (show exn))+                      liftIO $ putLogMsg logger dflags+                                         NoReason+                                         SevFatal+                                         noSrcSpan+                                         $ withPprStyle defaultErrStyle msg -                    ; traceIf (text "} ending fork (badly)" <+> doc)-                    ; return Nothing }-        }}+                ; traceIf (text "} ending fork (badly)" <+> doc)+                ; return Nothing }+    }  forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside@@ -2070,23 +2194,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

GHC/Tc/Utils/TcMType.hs view

@@ -1,13 +1,14 @@+{-# LANGUAGE CPP             #-}+{-# LANGUAGE MultiWayIf      #-}+{-# LANGUAGE TupleSections   #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP, TupleSections, MultiWayIf, PatternSynonyms #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Monadic type operations -- -- This module contains monadic operations over types that contain mutable type@@ -21,10 +22,11 @@   newNamedFlexiTyVar,   newFlexiTyVarTy,              -- Kind -> TcM TcType   newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]-  newOpenFlexiTyVarTy, newOpenTypeKind,+  newOpenFlexiTyVar, newOpenFlexiTyVarTy, newOpenTypeKind,+  newOpenBoxedTypeKind,   newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,-  cloneMetaTyVar,-  newFmvTyVar, newFskTyVar,+  newAnonMetaTyVar, cloneMetaTyVar,+  newCycleBreakerTyVar,    newMultiplicityVar,   readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,@@ -61,7 +63,6 @@   expTypeToType, scaledExpTypeToType,   checkingExpType_maybe, checkingExpType,   inferResultToType, fillInferResult, promoteTcType,-  promoteTyVar, promoteTyVarSet,    --------------------------------   -- Zonking and tidying@@ -71,20 +72,25 @@   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, promoteMetaTyVarTo, promoteTyVarSet,+  quantifyTyVars, isQuantifiableTv,+  skolemiseUnboundMetaTyVar, zonkAndSkolemise, skolemiseQuantifiedTyVar,+  doNotQuantifyTyVars, +  candidateQTyVarsOfType,  candidateQTyVarsOfKind,+  candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,+  CandidatesQTvs(..), delCandidates,+  candidateKindVars, partitionCandidates,+   ------------------------------   -- Levity polymorphism   ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr@@ -116,22 +122,22 @@ import GHC.Types.Name import GHC.Types.Var.Set import GHC.Builtin.Types-import GHC.Builtin.Types.Prim import GHC.Types.Var.Env import GHC.Types.Name.Env import GHC.Utils.Misc import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.Bag import GHC.Data.Pair import GHC.Types.Unique.Set import GHC.Driver.Session+import GHC.Driver.Ppr import qualified GHC.LanguageExtensions as LangExt import GHC.Types.Basic ( TypeOrKind(..) )  import Control.Monad import GHC.Data.Maybe-import Control.Arrow    ( second ) import qualified Data.Semigroup as Semi  {-@@ -177,7 +183,7 @@ -- Deals with both equality and non-equality predicates newWanted orig t_or_k pty   = do loc <- getCtLocM orig t_or_k-       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole YesBlockSubst pty+       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty                                 else EvVarDest <$> newEvVar pty        return $ CtWanted { ctev_dest = d                          , ctev_pred = pty@@ -193,8 +199,8 @@  cloneWanted :: Ct -> TcM Ct cloneWanted ct-  | ev@(CtWanted { ctev_dest = HoleDest old_hole, ctev_pred = pty }) <- ctEvidence ct-  = do { co_hole <- newCoercionHole (ch_blocker old_hole) pty+  | ev@(CtWanted { ctev_pred = pty }) <- ctEvidence ct+  = do { co_hole <- newCoercionHole pty        ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }   | otherwise   = return ct@@ -244,7 +250,7 @@ -- | Emits a new equality constraint emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion emitWantedEq origin t_or_k role ty1 ty2-  = do { hole <- newCoercionHole YesBlockSubst pty+  = do { hole <- newCoercionHole pty        ; loc <- getCtLocM origin (Just t_or_k)        ; emitSimple $ mkNonCanonical $          CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole@@ -270,16 +276,21 @@ emitWantedEvVars orig = mapM (emitWantedEvVar orig)  -- | Emit a new wanted expression hole-emitNewExprHole :: OccName   -- of the hole-                -> Id        -- of the evidence-                -> Type -> TcM ()-emitNewExprHole occ ev_id ty-  = do { loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel)-       ; let hole = Hole { hole_sort = ExprHole ev_id-                         , hole_occ  = getOccName ev_id+emitNewExprHole :: OccName         -- of the hole+                -> Type -> TcM HoleExprRef+emitNewExprHole occ ty+  = do { u <- newUnique+       ; ref <- newTcRef (pprPanic "unfilled unbound-variable evidence" (ppr u))+       ; let her = HER ref ty u++       ; loc <- getCtLocM (ExprHoleOrigin occ) (Just TypeLevel)++       ; let hole = Hole { hole_sort = ExprHole her+                         , hole_occ  = occ                          , hole_ty   = ty                          , hole_loc  = loc }-       ; emitHole hole }+       ; emitHole hole+       ; return her }  newDict :: Class -> [TcType] -> TcM DictId newDict cls tys@@ -317,16 +328,12 @@ ************************************************************************ -} -newCoercionHole :: BlockSubstFlag  -- should the presence of this hole block substitution?-                                   -- See sub-wrinkle in TcCanonical-                                   -- Note [Equalities with incompatible kinds]-                -> TcPredType -> TcM CoercionHole-newCoercionHole blocker pred_ty+newCoercionHole :: TcPredType -> TcM CoercionHole+newCoercionHole pred_ty   = do { co_var <- newEvVar pred_ty-       ; traceTc "New coercion hole:" (ppr co_var <+> ppr blocker)+       ; traceTc "New coercion hole:" (ppr co_var)        ; ref <- newMutVar Nothing-       ; return $ CoercionHole { ch_co_var = co_var, ch_blocker = blocker-                               , ch_ref = ref } }+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }  -- | Put a value in a coercion hole fillCoercionHole :: CoercionHole -> Coercion -> TcM ()@@ -358,7 +365,7 @@ unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref  -- | Check that a coercion is appropriate for filling a hole. (The hole--- itself is needed only for printing.+-- itself is needed only for printing.) -- Always returns the checked coercion, but this return value is necessary -- so that the input coercion is forced only when the output is forced. checkCoercionHole :: CoVar -> Coercion -> TcM Coercion@@ -463,7 +470,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.@@ -758,23 +765,28 @@  {- 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-function needs to either allow the TyVarTvs to unify with each other or check-that they don't (say, with a call to findDubTyVarTvs).+skolems.  They are used in two places: -Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in-patterns, to make sure these type variables only refer to other type variables,-but this restriction was dropped, and ScopedTypeVariables can now refer to full-types (GHC Proposal 29).+1. In kind signatures, see GHC.Tc.TyCl+      Note [Inferring kinds for type declarations]+   and Note [Kind checking for GADTs] -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]-* In partial type signatures, see Note [Quantified variables in partial type signatures]+2. In partial type signatures.  See GHC.Tc.Types+   Note [Quantified variables in partial type signatures]++Sometimes, they can unify with type variables that the user would+rather keep distinct; see #11203 for an example.  So, any client of+this function needs to either allow the TyVarTvs to unify with each+other or check that they don't. In the case of (1) the check is done+in GHC.Tc.TyCl.swizzleTcTyConBndrs.  In case of (2) it's done by+findDupTyVarTvs in GHC.Tc.Gen.Bind.chooseInferredQuantifiers.++Historical note: Before #15050 this (under the name SigTv) was also+used for ScopedTypeVariables in patterns, to make sure these type+variables only refer to other type variables, but this restriction was+dropped, and ScopedTypeVariables can now refer to full types (GHC+Proposal 29). -}  newMetaTyVarName :: FastString -> TcM Name@@ -800,10 +812,10 @@ 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"+       TyVarTv        -> fsLit "a"+       RuntimeUnkTv   -> fsLit "r"+       CycleBreakerTv -> fsLit "b"  newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar newAnonMetaTyVar mi = newNamedAnonMetaTyVar (metaInfoToTyVarName mi) mi@@ -869,19 +881,13 @@         ; traceTc "cloneAnonMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar))         ; return tyvar } -newFskTyVar :: TcType -> TcM TcTyVar-newFskTyVar fam_ty-  = do { details <- newMetaDetails FlatSkolTv-       ; name <- newMetaTyVarName (fsLit "fsk")-       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }--newFmvTyVar :: TcType -> TcM TcTyVar--- Very like newMetaTyVar, except sets mtv_tclvl to one less--- so that the fmv is untouchable.-newFmvTyVar fam_ty-  = do { details <- newMetaDetails FlatMetaTv-       ; name <- newMetaTyVarName (fsLit "s")-       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }+-- Make a new CycleBreakerTv. See Note [Type variable cycles]+-- in GHC.Tc.Solver.Canonical.+newCycleBreakerTyVar :: TcKind -> TcM TcTyVar+newCycleBreakerTyVar kind+  = do { details <- newMetaDetails CycleBreakerTv+       ; name <- newMetaTyVarName (fsLit "cbv")+       ; return (mkTcTyVar name kind details) }  newMetaDetails :: MetaInfo -> TcM TcTyVarDetails newMetaDetails info@@ -970,12 +976,18 @@        ; writeTcRef ref (Indirect ty) }    -- Everything from here on only happens if DEBUG is on+  -- Need to zonk 'ty' because we may only recently have promoted+  -- its free meta-tyvars (see Solver.Interact.tryToSolveByUnification)   | otherwise   = do { meta_details <- readMutVar ref;        -- Zonk kinds to allow the error check to work        ; zonked_tv_kind <- zonkTcType tv_kind-       ; zonked_ty_kind <- zonkTcType ty_kind-       ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind+       ; zonked_ty      <- zonkTcType ty+       ; let zonked_ty_kind = tcTypeKind zonked_ty+             zonked_ty_lvl  = tcTypeLevel zonked_ty+             level_check_ok  = not (zonked_ty_lvl `strictlyDeeperThan` tv_lvl)+             level_check_msg = ppr zonked_ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty+             kind_check_ok = tcIsConstraintKind zonked_tv_kind                           || tcEqKind zonked_ty_kind zonked_tv_kind              -- Hack alert! tcIsConstraintKind: see GHC.Tc.Gen.HsType              -- Note [Extra-constraint holes in partial type signatures]@@ -991,9 +1003,7 @@        ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )         -- Check for level OK-       -- See Note [Level check when unifying]        ; MASSERT2( level_check_ok, level_check_msg )-       -- another level check problem, see #97         -- Check Kinds ok        ; MASSERT2( kind_check_ok, kind_msg )@@ -1002,58 +1012,14 @@        ; writeMutVar ref (Indirect ty) }   where     tv_kind = tyVarKind tyvar-    ty_kind = tcTypeKind ty      tv_lvl = tcTyVarLevel tyvar-    ty_lvl = tcTypeLevel ty -    level_check_ok  = not (ty_lvl `strictlyDeeperThan` tv_lvl)-    level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty      double_upd_msg details = hang (text "Double update of meta tyvar")                                 2 (ppr tyvar $$ ppr details) -{- Note [Level check when unifying]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When unifying-     alpha:lvl := ty-we expect that the TcLevel of 'ty' will be <= lvl.-However, during unflatting we do-     fuv:l := ty:(l+1)-which is usually wrong; hence the check isFmmvTyVar in level_check_ok.-See Note [TcLevel assignment] in GHC.Tc.Utils.TcType.--}--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)-                 ; 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) }-- {--% Generating fresh variables for pattern match check--}---{- ************************************************************************ *                                                                      *         MetaTvs: TauTvs@@ -1102,9 +1068,20 @@ -- 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 } +newOpenBoxedTypeKind :: TcM TcKind+newOpenBoxedTypeKind+  = do { lev <- newFlexiTyVarTy (mkTyConTy levityTyCon)+       ; let rr = mkTyConApp boxedRepDataConTyCon [lev]+       ; return (tYPE rr) }+ newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar]) -- Instantiate with META type variables -- Note that this works for a sequence of kind, type, and coercion variables@@ -1272,6 +1249,9 @@ generalisation, because at that moment we have a clear picture of what skolems are in scope within the type itself (e.g. that 'forall arg'). +This change is inspired by and described in Section 7.2 of "Kind Inference+for Datatypes", POPL'20.+ Wrinkle:  We must make absolutely sure that alpha indeed is not@@ -1332,7 +1312,30 @@                                              , text "dv_tvs =" <+> ppr tvs                                              , text "dv_cvs =" <+> ppr cvs ]) +isEmptyCandidates :: CandidatesQTvs -> Bool+isEmptyCandidates (DV { dv_kvs = kvs, dv_tvs = tvs })+  = isEmptyDVarSet kvs && isEmptyDVarSet tvs +-- | Extract out the kind vars (in order) and type vars (in order) from+-- a 'CandidatesQTvs'. The lists are guaranteed to be distinct. Keeping+-- the lists separate is important only in the -XNoPolyKinds case.+candidateVars :: CandidatesQTvs -> ([TcTyVar], [TcTyVar])+candidateVars (DV { dv_kvs = dep_kv_set, dv_tvs = nondep_tkv_set })+  = (dep_kvs, nondep_tvs)+  where+    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_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 already zonked+ candidateKindVars :: CandidatesQTvs -> TyVarSet candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs) @@ -1410,7 +1413,7 @@     go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs     -- Uses accumulating-parameter style     go dv (AppTy t1 t2)    = foldlM go dv [t1, t2]-    go dv (TyConApp _ tys) = foldlM go dv tys+    go dv (TyConApp tc tys) = go_tc_args dv (tyConBinders tc) tys     go dv (FunTy _ w arg res) = foldlM go dv [w, arg, res]     go dv (LitTy {})        = return dv     go dv (CastTy ty co)    = do dv1 <- go dv ty@@ -1428,6 +1431,20 @@       = do { dv1 <- collect_cand_qtvs orig_ty True bound dv (tyVarKind tv)            ; collect_cand_qtvs orig_ty is_dep (bound `extendVarSet` tv) dv1 ty } +      -- This makes sure that we default e.g. the alpha in Proxy alpha (Any alpha).+      -- Tested in polykinds/NestedProxies.+      -- We just might get this wrong in AppTy, but I don't think that's possible+      -- with -XNoPolyKinds. And fixing it would be non-performant, as we'd need+      -- to look at kinds.+    go_tc_args dv (tc_bndr:tc_bndrs) (ty:tys)+      = do { dv1 <- collect_cand_qtvs orig_ty (is_dep || isNamedTyConBinder tc_bndr)+                                      bound dv ty+           ; go_tc_args dv1 tc_bndrs tys }+    go_tc_args dv _bndrs tys  -- _bndrs might be non-empty: undersaturation+                              -- tys might be non-empty: oversaturation+                              -- either way, the foldlM is correct+      = foldlM go dv tys+     -----------------     go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv       | tv `elemDVarSet` kvs@@ -1448,7 +1465,7 @@            ; cur_lvl <- getTcLevel            ; if |  tcTyVarLevel tv <= cur_lvl                 -> return dv   -- this variable is from an outer context; skip-                               -- See Note [Use level numbers ofor quantification]+                               -- See Note [Use level numbers for quantification]                  |  intersectsVarSet bound tv_kind_vars                    -- the tyvar must not be from an outer context, but we have@@ -1600,7 +1617,7 @@  It takes these free type/kind variables (partitioned into dependent and non-dependent variables) skolemises metavariables with a TcLevel greater-than the ambient level (see Note [Use level numbers of quantification]).+than the ambient level (see Note [Use level numbers for quantification]).  * This function distinguishes between dependent and non-dependent   variables only to keep correct defaulting behavior with -XNoPolyKinds.@@ -1613,8 +1630,8 @@ Note [Use level numbers for quantification] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The level numbers assigned to metavariables are very useful. Not only-do they track touchability (Note [TcLevel and untouchable type variables]-in GHC.Tc.Utils.TcType), but they also allow us to determine which variables to+do they track touchability (Note [TcLevel invariants] in GHC.Tc.Utils.TcType),+but they also allow us to determine which variables to generalise. The rule is this:    When generalising, quantify only metavariables with a TcLevel greater@@ -1642,11 +1659,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@@ -1666,10 +1683,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.@@ -1677,46 +1693,21 @@ -- 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        -- short-circuit common case-  | isEmptyDVarSet dep_tkvs-  , isEmptyDVarSet nondep_tkvs+  | isEmptyCandidates dvs   = do { traceTc "quantifyTyVars has nothing to quantify" empty        ; return [] }    | otherwise-  = do { traceTc "quantifyTyVars 1" (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--             nondep_tvs  = dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)-                 -- 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+  = do { traceTc "quantifyTyVars {" (ppr dvs) -             -- In the non-PolyKinds case, default the kind variables-             -- to *, and zonk the tyvars as usual.  Notice that this-             -- may make quantifyTyVars return a shorter list-             -- than it was passed, but that's ok-       ; poly_kinds  <- xoptM LangExt.PolyKinds-       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs-       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs-       ; let final_qtvs = dep_kvs' ++ nondep_tvs'-           -- Because of the order, any kind variables-           -- mentioned in the kinds of the nondep_tvs'-           -- now refer to the dep_kvs'+       ; undefaulted <- defaultTyVars dvs+       ; final_qtvs  <- mapMaybeM zonk_quant undefaulted -       ; traceTc "quantifyTyVars 2"-           (vcat [ text "nondep:"     <+> pprTyVars nondep_tvs-                 , text "dep:"        <+> pprTyVars dep_kvs-                 , text "dep_kvs'"    <+> pprTyVars dep_kvs'-                 , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])+       ; traceTc "quantifyTyVars }"+           (vcat [ text "undefaulted:" <+> pprTyVars undefaulted+                 , text "final_qtvs:"  <+> pprTyVars final_qtvs ])         -- We should never quantify over coercion variables; check this        ; let co_vars = filter isCoVar final_qtvs@@ -1726,9 +1717,8 @@   where     -- zonk_quant returns a tyvar if it should be quantified over;     -- otherwise, it returns Nothing. The latter case happens for-    --    * Kind variables, with -XNoPolyKinds: don't quantify over these-    --    * RuntimeRep variables: we never quantify over these-    zonk_quant default_kind tkv+    -- non-meta-tyvars+    zonk_quant tkv       | not (isTyVar tkv)       = return Nothing   -- this can happen for a covar that's associated with                          -- a coercion hole. Test case: typecheck/should_compile/T2494@@ -1738,11 +1728,7 @@                            -- kind signature, we have the class variables in                            -- scope, and they are TyVars not TcTyVars       | otherwise-      = do { deflt_done <- defaultTyVar default_kind tkv-           ; case deflt_done of-               True  -> return Nothing-               False -> do { tv <- skolemiseQuantifiedTyVar tkv-                           ; return (Just tv) } }+      = Just <$> skolemiseQuantifiedTyVar tkv  isQuantifiableTv :: TcLevel   -- Level of the context, outside the quantification                  -> TcTyVar@@ -1804,7 +1790,7 @@    | isTyVarTyVar tv     -- Do not default TyVarTvs. Doing so would violate the invariants-    -- on TyVarTvs; see Note [Signature skolems] in GHC.Tc.Utils.TcType.+    -- on TyVarTvs; see Note [TyVarTv] in GHC.Tc.Utils.TcMType.     -- #13343 is an example; #14555 is another     -- See Note [Inferring kinds for type declarations] in GHC.Tc.TyCl   = return False@@ -1815,6 +1801,10 @@   = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)        ; writeMetaTyVar tv liftedRepTy        ; return True }+  | isLevityVar tv+  = do { traceTc "Defaulting a Levity var to Lifted" (ppr tv)+       ; writeMetaTyVar tv liftedDataConTy+       ; return True }   | isMultiplicityVar tv   = do { traceTc "Defaulting a Multiplicty var to Many" (ppr tv)        ; writeMetaTyVar tv manyDataConTy@@ -1852,6 +1842,24 @@       where         (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv +-- | Default some unconstrained type variables:+--     RuntimeRep tyvars default to LiftedRep+--     Multiplicity tyvars default to Many+--     Type tyvars from dv_kvs default to Type, when -XNoPolyKinds+--     (under -XNoPolyKinds, non-defaulting vars in dv_kvs is an error)+defaultTyVars :: CandidatesQTvs  -- ^ all candidates for quantification+              -> TcM [TcTyVar]   -- ^ those variables not defaulted+defaultTyVars dvs+  = do { poly_kinds <- xoptM LangExt.PolyKinds+       ; defaulted_kvs <- mapM (defaultTyVar (not poly_kinds)) dep_kvs+       ; defaulted_tvs <- mapM (defaultTyVar False)            nondep_tvs+       ; let undefaulted_kvs = [ kv | (kv, False) <- dep_kvs    `zip` defaulted_kvs ]+             undefaulted_tvs = [ tv | (tv, False) <- nondep_tvs `zip` defaulted_tvs ]+       ; return (undefaulted_kvs ++ undefaulted_tvs) }+          -- NB: kvs before tvs because tvs may depend on kvs+  where+    (dep_kvs, nondep_tvs) = candidateVars dvs+ skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar -- We have a Meta tyvar with a ref-cell inside it -- Skolemise it, so that we are totally out of Meta-tyvar-land@@ -1886,6 +1894,134 @@                Indirect ty -> WARN( True, ppr tv $$ ppr ty )                               return () } +{- Note [Error on unconstrained meta-variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  type C :: Type -> Type -> Constraint+  class (forall a. a b ~ a c) => C b c++or++  type T = forall a. Proxy a++or++  data (forall a. a b ~ a c) => T b c++We will infer a :: Type -> kappa... but then we get no further information+on kappa. What to do?++ A. We could choose kappa := Type. But this only works when the kind of kappa+    is Type (true in this example, but not always).+ B. We could default to Any.+ C. We could quantify.+ D. We could error.++We choose (D), as described in #17567. Discussion of alternatives is below.++(One last example: type instance F Int = Proxy Any, where the unconstrained+kind variable is the inferred kind of Any. The four examples here illustrate+all cases in which this Note applies.)++To do this, we must take an extra step before doing the final zonk to create+e.g. a TyCon. (There is no problem in the final term-level zonk. See the+section on alternative (B) below.) This extra step is needed only for+constructs that do not quantify their free meta-variables, such as a class+constraint or right-hand side of a type synonym.++Specifically: before the final zonk, every construct must either call+quantifyTyVars or doNotQuantifyTyVars. The latter issues an error+if it is passed any free variables. (Exception: we still default+RuntimeRep and Multiplicity variables.)++Because no meta-variables remain after quantifying or erroring, we perform+the zonk with NoFlexi, which panics upon seeing a meta-variable.++Alternatives not implemented:++A. As stated above, this works only sometimes. We might have a free+   meta-variable of kind Nat, for example.++B. This is what we used to do, but it caused Any to appear in error+   messages sometimes. See #17567 for several examples. Defaulting to+   Any during the final, whole-program zonk is OK, though, because+   we are completely done type-checking at that point. No chance to+   leak into an error message.++C. Examine the class declaration at the top of this Note again.+   Where should we quantify? We might imagine quantifying and+   putting the kind variable in the forall of the quantified constraint.+   But what if there are nested foralls? Which one should get the+   variable? Other constructs have other problems. (For example,+   the right-hand side of a type family instance equation may not+   be a poly-type.)++   More broadly, the GHC AST defines a set of places where it performs+   implicit lexical generalization. For example, in a type+   signature++     f :: Proxy a -> Bool++   the otherwise-unbound a is lexically quantified, giving us++     f :: forall a. Proxy a -> Bool++   The places that allow lexical quantification are marked in the AST with+   HsImplicitBndrs. HsImplicitBndrs offers a binding site for otherwise-unbound+   variables.++   Later, during type-checking, we discover that a's kind is unconstrained.+   We thus quantify *again*, to++     f :: forall {k} (a :: k). Proxy @k a -> Bool++   It is this second quantification that this Note is really about --+   let's call it *inferred quantification*.+   So there are two sorts of implicit quantification in types:+     1. Lexical quantification: signalled by HsImplicitBndrs, occurs over+        variables mentioned by the user but with no explicit binding site,+        suppressed by a user-written forall (by the forall-or-nothing rule,+        in Note [forall-or-nothing rule] in GHC.Hs.Type).+     2. Inferred quantification: no signal in HsSyn, occurs over unconstrained+        variables invented by the type-checker, possible only with -XPolyKinds,+        unaffected by forall-or-nothing rule+   These two quantifications are performed in different compiler phases, and are+   essentially unrelated. However, it is convenient+   for programmers to remember only one set of implicit quantification+   sites. So, we choose to use the same places (those with HsImplicitBndrs)+   for lexical quantification as for inferred quantification of unconstrained+   meta-variables. Accordingly, there is no quantification in a class+   constraint, or the other constructs that call doNotQuantifyTyVars.+-}++doNotQuantifyTyVars :: CandidatesQTvs+                    -> (TidyEnv -> TcM (TidyEnv, SDoc))+                            -- ^ like "the class context (D a b, E foogle)"+                    -> TcM ()+doNotQuantifyTyVars dvs where_found+  | isEmptyCandidates dvs+  = traceTc "doNotQuantifyTyVars has nothing to error on" empty++  | otherwise+  = do { traceTc "doNotQuantifyTyVars" (ppr dvs)+       ; undefaulted <- defaultTyVars dvs+          -- could have regular TyVars here, in an associated type RHS, or+          -- bound by a type declaration head. So filter looking only for+          -- metavars. e.g. b and c in `class (forall a. a b ~ a c) => C b c`+          -- are OK+       ; let leftover_metas = filter isMetaTyVar undefaulted+       ; unless (null leftover_metas) $+         do { let (tidy_env1, tidied_tvs) = tidyOpenTyCoVars emptyTidyEnv leftover_metas+            ; (tidy_env2, where_doc) <- where_found tidy_env1+            ; let doc = vcat [ text "Uninferrable type variable"+                               <> plural tidied_tvs+                               <+> pprWithCommas pprTyVar tidied_tvs+                               <+> text "in"+                             , where_doc ]+            ; failWithTcM (tidy_env2, pprWithExplicitKindsWhen True doc) }+       ; traceTc "doNotQuantifyTyVars success" empty }+ {- Note [Defaulting with -XNoPolyKinds] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -2041,15 +2177,48 @@  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 *                                                                      *-************************************************************************+********************************************************************* -} --}+promoteMetaTyVarTo :: TcLevel -> TcTyVar -> TcM Bool+-- When we float a constraint out of an implication we must restore+-- invariant (WantedInv) in Note [TcLevel invariants] 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]+promoteMetaTyVarTo tclvl tv+  | ASSERT2( isMetaTyVar tv, ppr tv )+    tcTyVarLevel tv `strictlyDeeperThan` tclvl+  = 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 }+   | otherwise+   = return False +-- Returns whether or not *any* tyvar is defaulted+promoteTyVarSet :: TcTyVarSet -> TcM Bool+promoteTyVarSet tvs+  = do { tclvl <- getTcLevel+       ; bools <- mapM (promoteMetaTyVarTo tclvl)  $+                  filter isPromotableMetaTyVar $+                  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 -- With kind polymorphism it can be essential to zonk *first*@@ -2146,14 +2315,12 @@ zonkHole hole@(Hole { hole_ty = ty })   = do { ty' <- zonkTcType ty        ; return (hole { hole_ty = ty' }) }-  -- No need to zonk the Id in any ExprHole because we never look at it-  -- until after the final zonk and desugaring  {- Note [zonkCt behaviour] ~~~~~~~~~~~~~~~~~~~~~~~~~~ zonkCt tries to maintain the canonical form of a Ct.  For example,   - a CDictCan should stay a CDictCan;-  - a CIrredCan should stay a CIrredCan with its cc_status flag intact+  - a CIrredCan should stay a CIrredCan with its cc_reason flag intact  Why?, for example: - For CDictCan, the @GHC.Tc.Solver.expandSuperClasses@ step, which runs after the@@ -2164,18 +2331,16 @@  - For CIrredCan we want to see if a constraint is insoluble with insolubleWC -On the other hand, we change CTyEqCan to CNonCanonical, because of all of-CTyEqCan's invariants, which can break during zonking. Besides, the constraint+On the other hand, we change CEqCan to CNonCanonical, because of all of+CEqCan's invariants, which can break during zonking. (Example: a ~R alpha, where+we have alpha := N Int, where N is a newtype.) Besides, the constraint will be canonicalised again, so there is little benefit in keeping the-CTyEqCan structure.--NB: we do not expect to see any CFunEqCans, because zonkCt is only-called on unflattened constraints.+CEqCan structure. -NB: Constraints are always re-flattened etc by the canonicaliser in+NB: Constraints are always rewritten etc by the canonicaliser in @GHC.Tc.Solver.Canonical@ even if they come in as CDictCan. Only canonical constraints that are actually in the inert set carry all the guarantees. So it is okay if zonkCt-creates e.g. a CDictCan where the cc_tyars are /not/ function free.+creates e.g. a CDictCan where the cc_tyars are /not/ fully reduced. -}  zonkCt :: Ct -> TcM Ct@@ -2185,18 +2350,15 @@        ; args' <- mapM zonkTcType args        ; return $ ct { cc_ev = ev', cc_tyargs = args' } } -zonkCt (CTyEqCan { cc_ev = ev })+zonkCt (CEqCan { cc_ev = ev })   = mkNonCanonical <$> zonkCtEvidence ev -zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_status flag+zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_reason flag   = do { ev' <- zonkCtEvidence ev        ; return (ct { cc_ev = ev' }) }  zonkCt ct-  = ASSERT( not (isCFunEqCan ct) )-  -- We do not expect to see any CFunEqCans, because zonkCt is only called on-  -- unflattened constraints.-    do { fl' <- zonkCtEvidence (ctEvidence ct)+  = do { fl' <- zonkCtEvidence (ctEvidence ct)        ; return (mkNonCanonical fl') }  zonkCtEvidence :: CtEvidence -> TcM CtEvidence@@ -2365,13 +2527,11 @@        ; (env2, exp') <- zonkTidyTcType env1 exp        ; return ( env2, orig { uo_actual   = act'                              , uo_expected = exp' }) }-zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)-  = do { (env1, ty1')   <- zonkTidyTcType env  ty1-       ; (env2, m_ty2') <- case m_ty2 of-                             Just ty2 -> second Just <$> zonkTidyTcType env1 ty2-                             Nothing  -> return (env1, Nothing)-       ; (env3, orig')  <- zonkTidyOrigin env2 orig-       ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }+zonkTidyOrigin env (KindEqOrigin ty1 ty2 orig t_or_k)+  = do { (env1, ty1')  <- zonkTidyTcType env  ty1+       ; (env2, ty2')  <- zonkTidyTcType env1 ty2+       ; (env3, orig') <- zonkTidyOrigin env2 orig+       ; return (env3, KindEqOrigin ty1' ty2' orig' t_or_k) } zonkTidyOrigin env (FunDepOrigin1 p1 o1 l1 p2 o2 l2)   = do { (env1, p1') <- zonkTidyTcType env  p1        ; (env2, p2') <- zonkTidyTcType env1 p2

GHC/Tc/Utils/TcType.hs view

@@ -1,12 +1,15 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998  -} -{-# LANGUAGE CPP, ScopedTypeVariables, MultiWayIf, FlexibleContexts #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Types used in the typechecker -- -- This module provides the Type interface for front-end parts of the@@ -30,7 +33,7 @@    -- TcLevel   TcLevel(..), topTcLevel, pushTcLevel, isTopTcLevel,-  strictlyDeeperThan, sameDepthAs,+  strictlyDeeperThan, deeperThanOrSame, sameDepthAs,   tcTypeLevel, tcTyVarLevel, maxTcLevel,   promoteSkolem, promoteSkolemX, promoteSkolemsX,   --------------------------------@@ -39,12 +42,10 @@   MetaDetails(Flexi, Indirect), MetaInfo(..),   isImmutableTyVar, isSkolemTyVar, isMetaTyVar,  isMetaTyVarTy, isTyVarTy,   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,-  isFskTyVar, isFmvTyVar, isFlattenTyVar,-  isAmbiguousTyVar, metaTyVarRef, metaTyVarInfo,+  isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,-  isTouchableMetaTyVar,-  isFloatedTouchableMetaTyVar,+  isTouchableMetaTyVar, isPromotableMetaTyVar,   findDupTyVarTvs, mkTyVarNamePairs,    --------------------------------@@ -56,10 +57,10 @@   -- Splitters   -- These are important because they do not look through newtypes   getTyVar,-  tcSplitForAllTy_maybe,-  tcSplitForAllTys,-  tcSplitForAllTysReq, tcSplitForAllTysInvis,-  tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllVarBndrs,+  tcSplitForAllTyVarBinder_maybe,+  tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars,+  tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders,+  tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders,   tcSplitPhiTy, tcSplitPredFunTy_maybe,   tcSplitFunTy_maybe, tcSplitFunTys, tcFunArgTy, tcFunResultTy, tcFunResultTyN,   tcSplitFunTysN,@@ -75,14 +76,15 @@   -- Again, newtypes are opaque   eqType, eqTypes, nonDetCmpType, nonDetCmpTypes, eqTypeX,   pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck, tcEqTypeVis,+  tcEqTyConApps,   isSigmaTy, isRhoTy, isRhoExpTy, isOverloadedTy,   isFloatingTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy,   isIntegerTy, isNaturalTy,   isBoolTy, isUnitTy, isCharTy, isCallStackTy, isCallStackPred,   isTauTy, isTauTyCon, tcIsTyVarTy, tcIsForAllTy,-  isPredTy, isTyVarClassPred, isTyVarHead, isInsolubleOccursCheck,+  isPredTy, isTyVarClassPred,   checkValidClsArgs, hasTyVarHead,-  isRigidTy, isAlmostFunctionFree,+  isRigidTy,    ---------------------------------   -- Misc type manipulators@@ -104,7 +106,7 @@    -- * Finding "exact" (non-dead) type variables   exactTyCoVarsOfType, exactTyCoVarsOfTypes,-  anyRewritableTyVar,+  anyRewritableTyVar, anyRewritableTyFamApp, anyRewritableCanEqLHS,    ---------------------------------   -- Foreign import and export@@ -179,7 +181,7 @@    --------------------------------   pprKind, pprParendKind, pprSigmaType,-  pprType, pprParendType, pprTypeApp, pprTyThingCategory, tyThingCategory,+  pprType, pprParendType, pprTypeApp,   pprTheta, pprParendTheta, pprThetaArrowTy, pprClassPred,   pprTCvBndr, pprTCvBndrs, @@ -226,8 +228,9 @@ import GHC.Data.Maybe import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString-import GHC.Utils.Error( Validity(..), MsgDoc, isValid )+import GHC.Utils.Error( Validity(..), isValid ) import qualified GHC.LanguageExtensions as LangExt  import Data.List  ( mapAccumL )@@ -337,10 +340,6 @@ type TcCoVar = CoVar    -- Used only during type inference type TcType = Type      -- A TcType can have mutable type variables type TcTyCoVar = Var    -- Either a TcTyVar or a CoVar-        -- Invariant on ForAllTy in TcTypes:-        --      forall a. T-        -- a cannot occur inside a MutTyVar in T; that is,-        -- T is "flattened" before quantifying over a  type TcTyVarBinder     = TyVarBinder type TcInvisTVBinder   = InvisTVBinder@@ -458,26 +457,6 @@ It's knot-tied back to "GHC.Types.Var".  There is no reason in principle why "GHC.Types.Var" shouldn't actually have the definition, but it "belongs" here. -Note [Signature skolems]-~~~~~~~~~~~~~~~~~~~~~~~~-A TyVarTv is a specialised variant of TauTv, with the following invariants:--    * A TyVarTv can be unified only with a TyVar,-      not with any other type--    * Its MetaDetails, if filled in, will always be another TyVarTv-      or a SkolemTv--TyVarTvs are only distinguished to improve error messages.-Consider this--  data T (a:k1) = MkT (S a)-  data S (b:k2) = MkS (T b)--When doing kind inference on {S,T} we don't want *skolems* for k1,k2,-because they end up unifying; we want those TyVarTvs again.-- Note [TyVars and TcTyVars during type checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The Var type has constructors TyVar and TcTyVar.  They are used@@ -516,7 +495,7 @@    | MetaTv { mtv_info  :: MetaInfo            , mtv_ref   :: IORef MetaDetails-           , mtv_tclvl :: TcLevel }  -- See Note [TcLevel and untouchable type variables]+           , mtv_tclvl :: TcLevel }  -- See Note [TcLevel invariants]  vanillaSkolemTv, superSkolemTv :: TcTyVarDetails -- See Note [Binding when looking up instances] in GHC.Core.InstEnv@@ -548,27 +527,24 @@     | TyVarTv       -- A variant of TauTv, except that it should not be                    --   unified with a type, only with a type variable-                   -- See Note [Signature skolems]+                   -- See Note [TyVarTv] in GHC.Tc.Utils.TcMType -   | FlatMetaTv    -- A flatten meta-tyvar-                   -- It is a meta-tyvar, but it is always untouchable, with level 0-                   -- See Note [The flattening story] in GHC.Tc.Solver.Flatten+   | RuntimeUnkTv  -- A unification variable used in the GHCi debugger.+                   -- It /is/ allowed to unify with a polytype, unlike TauTv -   | FlatSkolTv    -- A flatten skolem tyvar-                   -- Just like FlatMetaTv, but is completely "owned" by-                   --   its Given CFunEqCan.-                   -- It is filled in /only/ by unflattenGivens-                   -- See Note [The flattening story] in GHC.Tc.Solver.Flatten+   | CycleBreakerTv  -- Used to fix occurs-check problems in Givens+                     -- See Note [Type variable cycles] in+                     -- GHC.Tc.Solver.Canonical  instance Outputable MetaDetails where   ppr Flexi         = text "Flexi"   ppr (Indirect ty) = text "Indirect" <+> ppr ty  instance Outputable MetaInfo where-  ppr TauTv         = text "tau"-  ppr TyVarTv       = text "tyv"-  ppr FlatMetaTv    = text "fmv"-  ppr FlatSkolTv    = text "fsk"+  ppr TauTv          = text "tau"+  ppr TyVarTv        = text "tyv"+  ppr RuntimeUnkTv   = text "rutv"+  ppr CycleBreakerTv = text "cbv"  {- ********************************************************************* *                                                                      *@@ -577,13 +553,14 @@ ********************************************************************* -}  newtype TcLevel = TcLevel Int deriving( Eq, Ord )-  -- See Note [TcLevel and untouchable type variables] for what this Int is+  -- See Note [TcLevel invariants] for what this Int is   -- See also Note [TcLevel assignment]  {--Note [TcLevel and untouchable type variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [TcLevel invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~ * Each unification variable (MetaTv)+  and skolem (SkolemTv)   and each Implication   has a level number (of type TcLevel) @@ -599,16 +576,57 @@     (GivenInv)  The level number of a unification variable appearing                 in the 'ic_given' of an implication I should be                 STRICTLY LESS THAN the ic_tclvl of I+                See Note [GivenInv]      (WantedInv) The level number of a unification variable appearing                 in the 'ic_wanted' of an implication I should be                 LESS THAN OR EQUAL TO the ic_tclvl of I                 See Note [WantedInv] -* A unification variable is *touchable* if its level number-  is EQUAL TO that of its immediate parent implication,-  and it is a TauTv or TyVarTv (but /not/ FlatMetaTv or FlatSkolTv)+The level of a MetaTyVar also governs its untouchability.  See+Note [Unification preconditions] in GHC.Tc.Utils.Unify. +Note [TcLevel assignment]+~~~~~~~~~~~~~~~~~~~~~~~~~+We arrange the TcLevels like this++   0   Top level+   1   First-level implication constraints+   2   Second-level implication constraints+   ...etc...++Note [GivenInv]+~~~~~~~~~~~~~~~+Invariant (GivenInv) is not essential, but it is easy to guarantee, and+it is a useful extra piece of structure.  It ensures that the Givens of+an implication don't change because of unifications /at the same level/+caused by Wanteds.  (Wanteds can also cause unifications at an outer+level, but that will iterate the entire implication; see GHC.Tc.Solver.Monad+Note [The Unification Level Flag].)++Givens can certainly contain meta-tyvars from /outer/ levels.  E.g.+   data T a where+     MkT :: Eq a => a -> MkT a++   f x = case x of MkT y -> y && True++Then we'll infer (x :: T alpha[1]).  The Givens from the implication+arising from the pattern match will look like this:++   forall[2] . Eq alpha[1] => (alpha[1] ~ Bool)++But if we unify alpha (which in this case we will), we'll iterate+the entire implication via Note [The Unification Level Flag] in+GHC.Tc.Solver.Monad.  That isn't true of unifications at the /ambient/+level.++It would be entirely possible to weaken (GivenInv), to LESS THAN OR+EQUAL TO, but we'd need to think carefully about+  - kick-out for Givens+  - GHC.Tc.Solver.Monad.isOuterTyVar+But in fact (GivenInv) is automatically true, so we're adhering to+it for now.  See #18929.+ Note [WantedInv] ~~~~~~~~~~~~~~~~ Why is WantedInv important?  Consider this implication, where@@ -619,48 +637,6 @@  We can unify alpha:=b in the inner implication, because 'alpha' is touchable; but then 'b' has excaped its scope into the outer implication.--Note [Skolem escape prevention]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We only unify touchable unification variables.  Because of-(WantedInv), there can be no occurrences of the variable further out,-so the unification can't cause the skolems to escape. Example:-     data T = forall a. MkT a (a->Int)-     f x (MkT v f) = length [v,x]-We decide (x::alpha), and generate an implication like-      [1]forall a. (a ~ alpha[0])-But we must not unify alpha:=a, because the skolem would escape.--For the cases where we DO want to unify, we rely on floating the-equality.   Example (with same T)-     g x (MkT v f) = x && True-We decide (x::alpha), and generate an implication like-      [1]forall a. (Bool ~ alpha[0])-We do NOT unify directly, bur rather float out (if the constraint-does not mention 'a') to get-      (Bool ~ alpha[0]) /\ [1]forall a.()-and NOW we can unify alpha.--The same idea of only unifying touchables solves another problem.-Suppose we had-   (F Int ~ uf[0])  /\  [1](forall a. C a => F Int ~ beta[1])-In this example, beta is touchable inside the implication. The-first solveSimpleWanteds step leaves 'uf' un-unified. Then we move inside-the implication where a new constraint-       uf  ~  beta-emerges. If we (wrongly) spontaneously solved it to get uf := beta,-the whole implication disappears but when we pop out again we are left with-(F Int ~ uf) which will be unified by our final zonking stage and-uf will get unified *once more* to (F Int).--Note [TcLevel assignment]-~~~~~~~~~~~~~~~~~~~~~~~~~-We arrange the TcLevels like this--   0   Top level-   1   First-level implication constraints-   2   Second-level implication constraints-   ...etc... -}  maxTcLevel :: TcLevel -> TcLevel -> TcLevel@@ -682,13 +658,17 @@ strictlyDeeperThan (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)   = tv_tclvl > ctxt_tclvl +deeperThanOrSame :: TcLevel -> TcLevel -> Bool+deeperThanOrSame (TcLevel tv_tclvl) (TcLevel ctxt_tclvl)+  = tv_tclvl >= ctxt_tclvl+ sameDepthAs :: TcLevel -> TcLevel -> Bool sameDepthAs (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)   = ctxt_tclvl == tv_tclvl   -- NB: invariant ctxt_tclvl >= tv_tclvl                              --     So <= would be equivalent  checkTcLevelInvariant :: TcLevel -> TcLevel -> Bool--- Checks (WantedInv) from Note [TcLevel and untouchable type variables]+-- Checks (WantedInv) from Note [TcLevel invariants] checkTcLevelInvariant (TcLevel ctxt_tclvl) (TcLevel tv_tclvl)   = ctxt_tclvl >= tv_tclvl @@ -846,27 +826,43 @@ -- ^ Check that a type does not contain any type family applications. isTyFamFree = null . tcTyFamInsts -anyRewritableTyVar :: Bool    -- Ignore casts and coercions-                   -> EqRel   -- Ambient role-                   -> (EqRel -> TcTyVar -> Bool)-                   -> TcType -> Bool--- (anyRewritableTyVar ignore_cos pred ty) returns True---    if the 'pred' returns True of any free TyVar in 'ty'+any_rewritable :: Bool    -- Ignore casts and coercions+               -> EqRel   -- Ambient role+               -> (EqRel -> TcTyVar -> Bool)           -- check tyvar+               -> (EqRel -> TyCon -> [TcType] -> Bool) -- check type family+               -> (TyCon -> Bool)                      -- expand type synonym?+               -> TcType -> Bool+-- Checks every tyvar and tyconapp (not including FunTys) within a type,+-- ORing the results of the predicates above together -- Do not look inside casts and coercions if 'ignore_cos' is True -- See Note [anyRewritableTyVar must be role-aware]-anyRewritableTyVar ignore_cos role pred ty-  = go role emptyVarSet ty+--+-- This looks like it should use foldTyCo, but that function is+-- role-agnostic, and this one must be role-aware. We could make+-- foldTyCon role-aware, but that may slow down more common usages.+--+-- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+{-# INLINE any_rewritable #-} -- this allows specialization of predicates+any_rewritable ignore_cos role tv_pred tc_pred should_expand+  = go role emptyVarSet   where-    -- NB: No need to expand synonyms, because we can find-    -- all free variables of a synonym by looking at its-    -- arguments-     go_tv rl bvs tv | tv `elemVarSet` bvs = False-                    | otherwise           = pred rl tv+                    | otherwise           = tv_pred rl tv +    go rl bvs ty@(TyConApp tc tys)+      | isTypeSynonymTyCon tc+      , should_expand tc+      , Just ty' <- tcView ty   -- should always match+      = go rl bvs ty'++      | tc_pred rl tc tys+      = True++      | otherwise+      = go_tc rl bvs tc tys+     go rl bvs (TyVarTy tv)       = go_tv rl bvs tv     go _ _     (LitTy {})        = False-    go rl bvs (TyConApp tc tys)  = go_tc rl bvs tc tys     go rl bvs (AppTy fun arg)    = go rl bvs fun || go NomEq bvs arg     go rl bvs (FunTy _ w arg res)  = go NomEq bvs arg_rep || go NomEq bvs res_rep ||                                      go rl bvs arg || go rl bvs res || go NomEq bvs w@@ -890,6 +886,42 @@       -- We don't have an equivalent of anyRewritableTyVar for coercions       -- (at least not yet) so take the free vars and test them +anyRewritableTyVar :: Bool     -- Ignore casts and coercions+                   -> EqRel    -- Ambient role+                   -> (EqRel -> TcTyVar -> Bool)  -- check tyvar+                   -> TcType -> Bool+-- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+anyRewritableTyVar ignore_cos role pred+  = any_rewritable ignore_cos role pred+      (\ _ _ _ -> False) -- no special check for tyconapps+                         -- (this False is ORed with other results, so it+                         --  really means "do nothing special"; the arguments+                         --   are still inspected)+      (\ _ -> False)     -- don't expand synonyms+    -- NB: No need to expand synonyms, because we can find+    -- all free variables of a synonym by looking at its+    -- arguments++anyRewritableTyFamApp :: EqRel   -- Ambient role+                      -> (EqRel -> TyCon -> [TcType] -> Bool) -- check tyconapp+                          -- should return True only for type family applications+                      -> TcType -> Bool+  -- always ignores casts & coercions+-- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+anyRewritableTyFamApp role check_tyconapp+  = any_rewritable True role (\ _ _ -> False) check_tyconapp (not . isFamFreeTyCon)++-- This version is used by shouldSplitWD. It *does* look in casts+-- and coercions, and it always expands type synonyms whose RHSs mention+-- type families.+-- See Note [Rewritable] in GHC.Tc.Solver.Monad for a specification for this function.+anyRewritableCanEqLHS :: EqRel   -- Ambient role+                      -> (EqRel -> TcTyVar -> Bool)            -- check tyvar+                      -> (EqRel -> TyCon -> [TcType] -> Bool)  -- check type family+                      -> TcType -> Bool+anyRewritableCanEqLHS role check_tyvar check_tyconapp+  = any_rewritable False role check_tyvar check_tyconapp (not . isFamFreeTyCon)+ {- Note [anyRewritableTyVar must be role-aware] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ anyRewritableTyVar is used during kick-out from the inert set,@@ -907,6 +939,7 @@ Moreover, if we were to kick out the inert item the exact same situation would re-occur and we end up with an infinite loop in which each kicks out the other (#14363).+ -}  {- *********************************************************************@@ -957,32 +990,32 @@ -- See Note [TcTyVars and TyVars in the typechecker] tcIsTcTyVar tv = isTyVar tv +isPromotableMetaTyVar :: TcTyVar -> Bool+-- True is this is a meta-tyvar that can be+-- promoted to an outer level+isPromotableMetaTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  , MetaTv { mtv_info = info } <- tcTyVarDetails tv+  = isTouchableInfo info   -- Can't promote cycle breakers+  | otherwise+  = False+ isTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool isTouchableMetaTyVar ctxt_tclvl tv   | isTyVar tv -- See Note [Coercion variables in free variable lists]   , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv-  , not (isFlattenInfo info)+  , isTouchableInfo info   = ASSERT2( checkTcLevelInvariant ctxt_tclvl tv_tclvl,              ppr tv $$ ppr tv_tclvl $$ ppr ctxt_tclvl )     tv_tclvl `sameDepthAs` ctxt_tclvl    | otherwise = False -isFloatedTouchableMetaTyVar :: TcLevel -> TcTyVar -> Bool-isFloatedTouchableMetaTyVar ctxt_tclvl tv-  | isTyVar tv -- See Note [Coercion variables in free variable lists]-  , MetaTv { mtv_tclvl = tv_tclvl, mtv_info = info } <- tcTyVarDetails tv-  , not (isFlattenInfo info)-  = tv_tclvl `strictlyDeeperThan` ctxt_tclvl--  | otherwise = False- isImmutableTyVar :: TyVar -> Bool isImmutableTyVar tv = isSkolemTyVar tv  isTyConableTyVar, isSkolemTyVar, isOverlappableTyVar,-  isMetaTyVar, isAmbiguousTyVar,-  isFmvTyVar, isFskTyVar, isFlattenTyVar :: TcTyVar -> Bool+  isMetaTyVar, isAmbiguousTyVar, isCycleBreakerTyVar :: TcTyVar -> Bool  isTyConableTyVar tv         -- True of a meta-type variable that can be filled in@@ -994,25 +1027,6 @@         _                             -> True   | otherwise = True -isFmvTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )-    case tcTyVarDetails tv of-        MetaTv { mtv_info = FlatMetaTv } -> True-        _                                -> False--isFskTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )-    case tcTyVarDetails tv of-        MetaTv { mtv_info = FlatSkolTv } -> True-        _                                -> False---- | True of both given and wanted flatten-skolems (fmv and fsk)-isFlattenTyVar tv-  = ASSERT2( tcIsTcTyVar tv, ppr tv )-    case tcTyVarDetails tv of-        MetaTv { mtv_info = info } -> isFlattenInfo info-        _                          -> False- isSkolemTyVar tv   = ASSERT2( tcIsTcTyVar tv, ppr tv )     case tcTyVarDetails tv of@@ -1046,6 +1060,14 @@         _             -> False   | otherwise = False +isCycleBreakerTyVar tv+  | isTyVar tv -- See Note [Coercion variables in free variable lists]+  , MetaTv { mtv_info = CycleBreakerTv } <- tcTyVarDetails tv+  = True++  | otherwise+  = False+ isMetaTyVarTy :: TcType -> Bool isMetaTyVarTy (TyVarTy tv) = isMetaTyVar tv isMetaTyVarTy _            = False@@ -1056,10 +1078,10 @@       MetaTv { mtv_info = info } -> info       _ -> pprPanic "metaTyVarInfo" (ppr tv) -isFlattenInfo :: MetaInfo -> Bool-isFlattenInfo FlatMetaTv = True-isFlattenInfo FlatSkolTv = True-isFlattenInfo _          = False+isTouchableInfo :: MetaInfo -> Bool+isTouchableInfo info+  | CycleBreakerTv <- info = False+  | otherwise              = True  metaTyVarTcLevel :: TcTyVar -> TcLevel metaTyVarTcLevel tv@@ -1158,6 +1180,7 @@ getDFunTyLitKey :: TyLit -> OccName getDFunTyLitKey (NumTyLit n) = mkOccName Name.varName (show n) getDFunTyLitKey (StrTyLit n) = mkOccName Name.varName (show n)  -- hm+getDFunTyLitKey (CharTyLit n) = mkOccName Name.varName (show n)  {- ********************************************************************* *                                                                      *@@ -1209,34 +1232,52 @@     isMaybeTyBinder (Just (t,_)) = isTyBinder t     isMaybeTyBinder _            = True -tcSplitForAllTy_maybe :: Type -> Maybe (TyVarBinder, Type)-tcSplitForAllTy_maybe ty | Just ty' <- tcView ty = tcSplitForAllTy_maybe ty'-tcSplitForAllTy_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)-tcSplitForAllTy_maybe _                = Nothing+tcSplitForAllTyVarBinder_maybe :: Type -> Maybe (TyVarBinder, Type)+tcSplitForAllTyVarBinder_maybe ty | Just ty' <- tcView ty = tcSplitForAllTyVarBinder_maybe ty'+tcSplitForAllTyVarBinder_maybe (ForAllTy tv ty) = ASSERT( isTyVarBinder tv ) Just (tv, ty)+tcSplitForAllTyVarBinder_maybe _                = Nothing  -- | Like 'tcSplitPiTys', but splits off only named binders,--- returning just the tycovars.-tcSplitForAllTys :: Type -> ([TyVar], Type)-tcSplitForAllTys ty+-- returning just the tyvars.+tcSplitForAllTyVars :: Type -> ([TyVar], Type)+tcSplitForAllTyVars ty   = ASSERT( all isTyVar (fst sty) ) sty-  where sty = splitForAllTys ty+  where sty = splitForAllTyCoVars ty --- | Like 'tcSplitForAllTys', but only splits 'ForAllTy's with 'Required' type+-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible'+-- type variable binders.+tcSplitForAllInvisTyVars :: Type -> ([TyVar], Type)+tcSplitForAllInvisTyVars ty = tcSplitSomeForAllTyVars isInvisibleArgFlag ty++-- | Like 'tcSplitForAllTyVars', but only splits a 'ForAllTy' if @argf_pred argf@+-- is 'True', where @argf@ is the visibility of the @ForAllTy@'s binder and+-- @argf_pred@ is a predicate over visibilities provided as an argument to this+-- function.+tcSplitSomeForAllTyVars :: (ArgFlag -> Bool) -> Type -> ([TyVar], Type)+tcSplitSomeForAllTyVars argf_pred ty+  = split ty ty []+  where+    split _ (ForAllTy (Bndr tv argf) ty) tvs+      | argf_pred argf                             = split ty ty (tv:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split orig_ty _                            tvs = (reverse tvs, orig_ty)++-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type -- variable binders. All split tyvars are annotated with '()'.-tcSplitForAllTysReq :: Type -> ([TcReqTVBinder], Type)-tcSplitForAllTysReq ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty-  where sty = splitForAllTysReq ty+tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)+tcSplitForAllReqTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty+  where sty = splitForAllReqTVBinders ty --- | Like 'tcSplitForAllTys', but only splits 'ForAllTy's with 'Invisible' type+-- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Invisible' type -- variable binders. All split tyvars are annotated with their 'Specificity'.-tcSplitForAllTysInvis :: Type -> ([TcInvisTVBinder], Type)-tcSplitForAllTysInvis ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty-  where sty = splitForAllTysInvis ty+tcSplitForAllInvisTVBinders :: Type -> ([TcInvisTVBinder], Type)+tcSplitForAllInvisTVBinders ty = ASSERT( all (isTyVar . binderVar) (fst sty) ) sty+  where sty = splitForAllInvisTVBinders ty --- | Like 'tcSplitForAllTys', but splits off only named binders.-tcSplitForAllVarBndrs :: Type -> ([TyVarBinder], Type)-tcSplitForAllVarBndrs ty = ASSERT( all isTyVarBinder (fst sty)) sty-  where sty = splitForAllVarBndrs ty+-- | Like 'tcSplitForAllTyVars', but splits off only named binders.+tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)+tcSplitForAllTyVarBinders ty = ASSERT( all isTyVarBinder (fst sty)) sty+  where sty = splitForAllTyCoVarBinders ty  -- | Is this a ForAllTy with a named binder? tcIsForAllTy :: Type -> Bool@@ -1263,9 +1304,11 @@           Just (pred, ty) -> split ty (pred:ts)           Nothing         -> (reverse ts, ty) --- | Split a sigma type into its parts.+-- | Split a sigma type into its parts. This only splits /invisible/ type+-- variable binders, as these are the only forms of binder that the typechecker+-- will implicitly instantiate. tcSplitSigmaTy :: Type -> ([TyVar], ThetaType, Type)-tcSplitSigmaTy ty = case tcSplitForAllTys ty of+tcSplitSigmaTy ty = case tcSplitForAllInvisTyVars ty of                         (tvs, rho) -> case tcSplitPhiTy rho of                                         (theta, tau) -> (tvs, theta, tau) @@ -1448,9 +1491,9 @@ -- the latter specifically stops at PredTy arguments, -- and we don't want to do that here tcSplitDFunTy ty-  = case tcSplitForAllTys ty   of { (tvs, rho)    ->-    case splitFunTys rho       of { (theta, tau)  ->-    case tcSplitDFunHead tau   of { (clas, tys)   ->+  = case tcSplitForAllInvisTyVars ty of { (tvs, rho)    ->+    case splitFunTys rho             of { (theta, tau)  ->+    case tcSplitDFunHead tau         of { (clas, tys)   ->     (tvs, map scaledThing theta, clas, tys) }}}  tcSplitDFunHead :: Type -> (Class, [Type])@@ -1468,7 +1511,7 @@ -- tcSplitMethodTy just peels off the outer forall and -- that first predicate tcSplitMethodTy ty-  | (sel_tyvars,sel_rho) <- tcSplitForAllTys ty+  | (sel_tyvars,sel_rho) <- tcSplitForAllInvisTyVars ty   , Just (first_pred, local_meth_ty) <- tcSplitPredFunTy_maybe sel_rho   = (sel_tyvars, first_pred, local_meth_ty)   | otherwise@@ -1485,12 +1528,11 @@ tcEqKind = tcEqType  tcEqType :: HasDebugCallStack => TcType -> TcType -> Bool--- tcEqType is a proper implements the same Note [Non-trivial definitional--- equality] (in GHC.Core.TyCo.Rep) as `eqType`, but Type.eqType believes (* ==--- Constraint), and that is NOT what we want in the type checker!+-- ^ tcEqType implements typechecker equality, as described in+-- @Note [Typechecker equality vs definitional equality]@. tcEqType ty1 ty2-  =  tc_eq_type False False ki1 ki2-  && tc_eq_type False False ty1 ty2+  =  tcEqTypeNoSyns ki1 ki2+  && tcEqTypeNoSyns ty1 ty2   where     ki1 = tcTypeKind ty1     ki2 = tcTypeKind ty2@@ -1499,8 +1541,40 @@ -- as long as their non-coercion structure is identical. tcEqTypeNoKindCheck :: TcType -> TcType -> Bool tcEqTypeNoKindCheck ty1 ty2-  = tc_eq_type False False ty1 ty2+  = tcEqTypeNoSyns ty1 ty2 +-- | Check whether two TyConApps are the same; if the number of arguments+-- are different, just checks the common prefix of arguments.+tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool+tcEqTyConApps tc1 args1 tc2 args2+  = tc1 == tc2 &&+    and (zipWith tcEqTypeNoKindCheck args1 args2)+    -- No kind check necessary: if both arguments are well typed, then+    -- any difference in the kinds of later arguments would show up+    -- as differences in earlier (dependent) arguments++{-+Note [Specialising tc_eq_type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type equality predicates in TcType are hit pretty hard during typechecking.+Consequently we take pains to ensure that these paths are compiled to+efficient, minimally-allocating code.++To this end we place an INLINE on tc_eq_type, ensuring that it is inlined into+its publicly-visible interfaces (e.g. tcEqType). In addition to eliminating+some dynamic branches, this allows the simplifier to eliminate the closure+allocations that would otherwise be necessary to capture the two boolean "mode"+flags. This reduces allocations by a good fraction of a percent when compiling+Cabal.++See #19226.+-}++-- | Type equality comparing both visible and invisible arguments and expanding+-- type synonyms.+tcEqTypeNoSyns :: TcType -> TcType -> Bool+tcEqTypeNoSyns ta tb = tc_eq_type False False ta tb+ -- | Like 'tcEqType', but returns True if the /visible/ part of the types -- are equal, even if they are really unequal (in the invisible bits) tcEqTypeVis :: TcType -> TcType -> Bool@@ -1513,8 +1587,6 @@ -- This ignores kinds and coercions, because this is used only for printing. pickyEqType ty1 ty2 = tc_eq_type True False ty1 ty2 -- -- | Real worker for 'tcEqType'. No kind check! tc_eq_type :: Bool          -- ^ True <=> do not expand type synonyms            -> Bool          -- ^ True <=> compare visible args only@@ -1525,6 +1597,11 @@   = go orig_env orig_ty1 orig_ty2   where     go :: RnEnv2 -> Type -> Type -> Bool+    -- See Note [Comparing nullary type synonyms] in GHC.Core.Type.+    go _   (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = True+     go env t1 t2 | not keep_syns, Just t1' <- tcView t1 = go env t1' t2     go env t1 t2 | not keep_syns, Just t2' <- tcView t2 = go env t1 t2' @@ -1536,7 +1613,9 @@      go env (ForAllTy (Bndr tv1 vis1) ty1)            (ForAllTy (Bndr tv2 vis2) ty2)-      =  vis1 == vis2+      =  vis1 `sameVis` vis2+           -- See Note [ForAllTy and typechecker equality] in+           -- GHC.Tc.Solver.Canonical for why we use `sameVis` here       && (vis_only || go env (varType tv1) (varType tv2))       && go (rnBndr2 env tv1 tv2) ty1 ty2 @@ -1585,7 +1664,7 @@     -- sometimes hard to know directly because @ty@ might have some casts     -- obscuring the FunTy. And 'splitAppTy' is difficult because we can't     -- always extract a RuntimeRep (see Note [xyz]) if the kind of the arg or-    -- res is unzonked/unflattened. Thus this function, which handles this+    -- res is unzonked. Thus this function, which handles this     -- corner case.     eqFunTy :: RnEnv2 -> Mult -> Type -> Type -> Type -> Bool                -- Last arg is /not/ FunTy@@ -1600,7 +1679,31 @@           = go env w w' && go env arg arg' && go env res res'         get_args _ _    = False     eqFunTy _ _ _ _ _   = False+{-# INLINE tc_eq_type #-} -- See Note [Specialising tc_eq_type]. +{- Note [Typechecker equality vs definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has two notions of equality over Core types:++* Definitional equality, as implemented by GHC.Core.Type.eqType.+  See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.+* Typechecker equality, as implemented by tcEqType (in GHC.Tc.Utils.TcType).+  GHC.Tc.Solver.Canonical.canEqNC also respects typechecker equality.++Typechecker equality implies definitional equality: if two types are equal+according to typechecker equality, then they are also equal according to+definitional equality. The converse is not always true, as typechecker equality+is more finer-grained than definitional equality in two places:++* Unlike definitional equality, which equates Type and Constraint, typechecker+  treats them as distinct types. See Note [Kind Constraint and kind Type] in+  GHC.Core.Type.+* Unlike definitional equality, which does not care about the ArgFlag of a+  ForAllTy, typechecker equality treats Required type variable binders as+  distinct from Invisible type variable binders.+  See Note [ForAllTy and typechecker equality] in GHC.Tc.Solver.Canonical.+-}+ {- ********************************************************************* *                                                                      *                        Predicate types@@ -1769,7 +1872,7 @@ mkMinimalBySCs get_pred xs = go preds_with_scs []  where    preds_with_scs :: [PredWithSCs a]-   preds_with_scs = [ (pred, pred : transSuperClasses pred, x)+   preds_with_scs = [ (pred, implicants pred, x)                     | x <- xs                     , let pred = get_pred x ] @@ -1787,6 +1890,8 @@                           -- Note [Remove redundant provided dicts]      = go work_list min_preds      | p `in_cloud` work_list || p `in_cloud` min_preds+       -- Why look at work-list too?  Suppose work_item is Eq a,+       -- and work-list contains Ord a      = go work_list min_preds      | otherwise      = go work_list (work_item : min_preds)@@ -1794,6 +1899,20 @@    in_cloud :: PredType -> [PredWithSCs a] -> Bool    in_cloud p ps = or [ p `tcEqType` p' | (_, scs, _) <- ps, p' <- scs ] +   implicants pred+     = pred : eq_extras pred ++ transSuperClasses pred++   -- Combine (a ~ b) and (b ~ a); no need to have both in one context+   -- These can arise when dealing with partial type signatures (e.g. T14715)+   eq_extras pred+     = case classifyPredType pred of+         EqPred r t1 t2               -> [mkPrimEqPredRole (eqRelRole r) t2 t1]+         ClassPred cls [k1,k2,t1,t2]+           | cls `hasKey` heqTyConKey -> [mkClassPred cls [k2, k1, t2, t1]]+         ClassPred cls [k,t1,t2]+           | cls `hasKey` eqTyConKey  -> [mkClassPred cls [k, t2, t1]]+         _ -> []+ transSuperClasses :: PredType -> [PredType] -- (transSuperClasses p) returns (p's superclasses) not including p -- Stop if you encounter the same class again@@ -1829,40 +1948,6 @@       IrredPred {}       -> True -- Might have equalities after reduction?       ForAllPred {}      -> False --- | Is the equality---        a ~r ...a....--- definitely insoluble or not?---      a ~r Maybe a      -- Definitely insoluble---      a ~N ...(F a)...  -- Not definitely insoluble---                        -- Perhaps (F a) reduces to Int---      a ~R ...(N a)...  -- Not definitely insoluble---                        -- Perhaps newtype N a = MkN Int--- See Note [Occurs check error] in--- "GHC.Tc.Solver.Canonical" for the motivation for this function.-isInsolubleOccursCheck :: EqRel -> TcTyVar -> TcType -> Bool-isInsolubleOccursCheck eq_rel tv ty-  = go ty-  where-    go ty | Just ty' <- tcView ty = go ty'-    go (TyVarTy tv') = tv == tv' || go (tyVarKind tv')-    go (LitTy {})    = False-    go (AppTy t1 t2) = case eq_rel of  -- See Note [AppTy and ReprEq]-                         NomEq  -> go t1 || go t2-                         ReprEq -> go t1-    go (FunTy _ w t1 t2) = go w || go t1 || go t2-    go (ForAllTy (Bndr tv' _) inner_ty)-      | tv' == tv = False-      | otherwise = go (varType tv') || go inner_ty-    go (CastTy ty _)  = go ty   -- ToDo: what about the coercion-    go (CoercionTy _) = False   -- ToDo: what about the coercion-    go (TyConApp tc tys)-      | isGenerativeTyCon tc role = any go tys-      | otherwise                 = any go (drop (tyConArity tc) tys)-         -- (a ~ F b a), where F has arity 1,-         -- has an insoluble occurs check--    role = eqRelRole eq_rel- {- Note [Expanding superclasses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we expand superclasses, we use the following algorithm:@@ -2062,31 +2147,6 @@                         Just (tc, _) -> uniq == getUnique tc                         Nothing      -> False --- | Does the given tyvar appear at the head of a chain of applications---     (a t1 ... tn)-isTyVarHead :: TcTyVar -> TcType -> Bool-isTyVarHead tv (TyVarTy tv')   = tv == tv'-isTyVarHead tv (AppTy fun _)   = isTyVarHead tv fun-isTyVarHead tv (CastTy ty _)   = isTyVarHead tv ty-isTyVarHead _ (TyConApp {})    = False-isTyVarHead _  (LitTy {})      = False-isTyVarHead _  (ForAllTy {})   = False-isTyVarHead _  (FunTy {})      = False-isTyVarHead _  (CoercionTy {}) = False---{- Note [AppTy and ReprEq]-~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   a ~R# b a-           a ~R# a b--The former is /not/ a definite error; we might instantiate 'b' with Id-   newtype Id a = MkId a-but the latter /is/ a definite error.--On the other hand, with nominal equality, both are definite errors--}- isRigidTy :: TcType -> Bool isRigidTy ty   | Just (tc,_) <- tcSplitTyConApp_maybe ty = isGenerativeTyCon tc Nominal@@ -2095,24 +2155,6 @@   | otherwise                               = False  --- | Is this type *almost function-free*? See Note [Almost function-free]--- in "GHC.Tc.Types"-isAlmostFunctionFree :: TcType -> Bool-isAlmostFunctionFree ty | Just ty' <- tcView ty = isAlmostFunctionFree ty'-isAlmostFunctionFree (TyVarTy {})    = True-isAlmostFunctionFree (AppTy ty1 ty2) = isAlmostFunctionFree ty1 &&-                                       isAlmostFunctionFree ty2-isAlmostFunctionFree (TyConApp tc args)-  | isTypeFamilyTyCon tc = False-  | otherwise            = all isAlmostFunctionFree args-isAlmostFunctionFree (ForAllTy bndr _) = isAlmostFunctionFree (binderType bndr)-isAlmostFunctionFree (FunTy _ w ty1 ty2) = isAlmostFunctionFree w &&-                                           isAlmostFunctionFree ty1 &&-                                           isAlmostFunctionFree ty2-isAlmostFunctionFree (LitTy {})        = True-isAlmostFunctionFree (CastTy ty _)     = isAlmostFunctionFree ty-isAlmostFunctionFree (CoercionTy {})   = True- {- ************************************************************************ *                                                                      *@@ -2376,7 +2418,7 @@   | otherwise   = NotValid unlifted_only -unlifted_only :: MsgDoc+unlifted_only :: SDoc unlifted_only = text "foreign import prim only accepts simple unlifted types"  validIfUnliftedFFITypes :: DynFlags -> Validity

GHC/Tc/Utils/TcType.hs-boot view

@@ -1,8 +1,12 @@ module GHC.Tc.Utils.TcType where import GHC.Utils.Outputable( SDoc )+import GHC.Prelude ( Bool )+import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )  data MetaDetails  data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc vanillaSkolemTv :: TcTyVarDetails+isMetaTyVar :: TcTyVar -> Bool+isTyConableTyVar :: TcTyVar -> Bool

GHC/Tc/Utils/Unify.hs view

@@ -1,2081 +1,2075 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998---}--{-# LANGUAGE CPP, DeriveFunctor, MultiWayIf, TupleSections,-    ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Type subsumption and unification-module GHC.Tc.Utils.Unify (-  -- Full-blown subsumption-  tcWrapResult, tcWrapResultO, tcWrapResultMono,-  tcSkolemise, tcSkolemiseScoped, tcSkolemiseET,-  tcSubType, tcSubTypeSigma, tcSubTypePat,-  tcSubMult,-  checkConstraints, checkTvConstraints,-  buildImplicationFor, buildTvImplication, emitResidualTvConstraint,--  -- Various unifications-  unifyType, unifyKind,-  uType, promoteTcType,-  swapOverTyVars, canSolveByUnification,--  ---------------------------------  -- Holes-  tcInfer,-  matchExpectedListTy,-  matchExpectedTyConApp,-  matchExpectedAppTy,-  matchExpectedFunTys,-  matchActualFunTysRho, matchActualFunTySigma,-  matchExpectedFunKind,--  metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)--  ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Hs-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Ppr( debugPprType )-import GHC.Tc.Utils.TcMType-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.TcType-import GHC.Tc.Utils.Env-import GHC.Core.Type-import GHC.Core.Coercion-import GHC.Core.Multiplicity-import GHC.Tc.Types.Evidence-import GHC.Tc.Types.Constraint-import GHC.Core.Predicate-import GHC.Tc.Types.Origin-import GHC.Types.Name( isSystemName )-import GHC.Tc.Utils.Instantiate-import GHC.Core.TyCon-import GHC.Builtin.Types-import GHC.Types.Var as Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Utils.Error-import GHC.Driver.Session-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 Control.Monad-import Control.Arrow ( second )--{--************************************************************************-*                                                                      *-             matchExpected functions-*                                                                      *-************************************************************************--Note [Herald for matchExpectedFunTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The 'herald' always looks like:-   "The equation(s) for 'f' have"-   "The abstraction (\x.e) takes"-   "The section (+ x) expects"-   "The function 'f' is applied to"--This is used to construct a message of form--   The abstraction `\Just 1 -> ...' takes two arguments-   but its type `Maybe a -> a' has only one--   The equation(s) for `f' have two arguments-   but its type `Maybe a -> a' has only one--   The section `(f 3)' requires 'f' to take two arguments-   but its type `Int -> Int' has only one--   The function 'f' is applied to two arguments-   but its type `Int -> Int' has only one--When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the-picture, we have a choice in deciding whether to count the type applications as-proper arguments:--   The function 'f' is applied to one visible type argument-     and two value arguments-   but its type `forall a. a -> a` has only one visible type argument-     and one value argument--Or whether to include the type applications as part of the herald itself:--   The expression 'f @Int' is applied to two arguments-   but its type `Int -> Int` has only one--The latter is easier to implement and is arguably easier to understand, so we-choose to implement that option.--Note [matchExpectedFunTys]-~~~~~~~~~~~~~~~~~~~~~~~~~~-matchExpectedFunTys checks that a sigma has the form-of an n-ary function.  It passes the decomposed type to the-thing_inside, and returns a wrapper to coerce between the two types--It's used wherever a language construct must have a functional type,-namely:-        A lambda expression-        A function definition-     An operator section--This function must be written CPS'd because it needs to fill in the-ExpTypes produced for arguments before it can fill in the ExpType-passed in.---}---- Use this one when you have an "expected" type.--- This function skolemises at each polytype.-matchExpectedFunTys :: forall a.-                       SDoc   -- See Note [Herald for matchExpectedFunTys]-                    -> UserTypeCtxt-                    -> Arity-                    -> ExpRhoType      -- Skolemised-                    -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a)-                    -> TcM (HsWrapper, a)--- If    matchExpectedFunTys n ty = (_, wrap)--- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,---   where [t1, ..., tn], ty_r are passed to the thing_inside-matchExpectedFunTys herald ctx arity orig_ty thing_inside-  = case orig_ty of-      Check ty -> go [] arity ty-      _        -> defer [] arity orig_ty-  where-    -- Skolemise any foralls /before/ the zero-arg case-    -- so that we guarantee to return a rho-type-    go acc_arg_tys n ty-      | (tvs, theta, _) <- tcSplitSigmaTy ty-      , not (null tvs && null theta)-      = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' ->-                                               go acc_arg_tys n ty'-           ; return (wrap_gen <.> wrap_res, result) }--    -- No more args; do this /before/ tcView, so-    -- that we do not unnecessarily unwrap synonyms-    go acc_arg_tys 0 rho_ty-      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty)-           ; return (idHsWrapper, result) }--    go acc_arg_tys n ty-      | Just ty' <- tcView ty = go acc_arg_tys n ty'--    go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })-      = ASSERT( af == VisArg )-        do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)-                                      (n-1) res_ty-           ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc-           ; return ( fun_wrap, result ) }-      where-        doc = text "When inferring the argument type of a function with type" <+>-              quotes (ppr orig_ty)--    go acc_arg_tys n ty@(TyVarTy tv)-      | isMetaTyVar tv-      = do { cts <- readMetaTyVar tv-           ; case cts of-               Indirect ty' -> go acc_arg_tys n ty'-               Flexi        -> defer acc_arg_tys n (mkCheckExpType 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 acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $-                          defer acc_arg_tys n (mkCheckExpType ty)--    -------------    defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)-    defer acc_arg_tys n fun_ty-      = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType)-           ; res_ty       <- newInferExpType-           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty-           ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys-           ; res_ty       <- readExpType res_ty-           ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty-           ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty-                         -- Not a good origin at all :-(-           ; return (wrap, result) }--    -------------    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) }-      where-        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-           ; mult <- newFlexiTyVarTy multiplicityTy-           ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty-           ; co <- unifyType mb_thing fun_ty unif_fun_ty-           ; return (mkWpCastN co, Scaled mult 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.--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!--}-------------------------matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)--- Special case for lists-matchExpectedListTy exp_ty- = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty-      ; return (co, elt_ty) }------------------------matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *-                      -> TcRhoType            -- orig_ty-                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty-                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c---- It's used for wired-in tycons, so we call checkWiredInTyCon--- Precondition: never called with FunTyCon--- Precondition: input type :: *--- Postcondition: (T k1 k2 k3 a b c) is well-kinded--matchExpectedTyConApp tc orig_ty-  = ASSERT(not $ isFunTyCon tc) go orig_ty-  where-    go ty-       | Just ty' <- tcView ty-       = go ty'--    go ty@(TyConApp tycon args)-       | tc == tycon  -- Common case-       = return (mkTcNomReflCo ty, args)--    go (TyVarTy tv)-       | isMetaTyVar tv-       = do { cts <- readMetaTyVar tv-            ; case cts of-                Indirect ty -> go ty-                Flexi       -> defer }--    go _ = defer--    -- If the common case does not occur, instantiate a template-    -- T k1 .. kn t1 .. tm, and unify with the original type-    -- Doing it this way ensures that the types we return are-    -- kind-compatible with T.  For example, suppose we have-    --       matchExpectedTyConApp T (f Maybe)-    -- where data T a = MkT a-    -- Then we don't want to instantiate T's data constructors with-    --    (a::*) ~ Maybe-    -- because that'll make types that are utterly ill-kinded.-    -- This happened in #7368-    defer-      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)-           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)-           ; let args = mkTyVarTys arg_tvs-                 tc_template = mkTyConApp tc args-           ; co <- unifyType Nothing tc_template orig_ty-           ; return (co, args) }-------------------------matchExpectedAppTy :: TcRhoType                         -- orig_ty-                   -> TcM (TcCoercion,                   -- m a ~N orig_ty-                           (TcSigmaType, TcSigmaType))  -- Returns m, a--- If the incoming type is a mutable type variable of kind k, then--- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.--matchExpectedAppTy orig_ty-  = go orig_ty-  where-    go ty-      | Just ty' <- tcView ty = go ty'--      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty-      = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))--    go (TyVarTy tv)-      | isMetaTyVar tv-      = do { cts <- readMetaTyVar tv-           ; case cts of-               Indirect ty -> go ty-               Flexi       -> defer }--    go _ = defer--    -- Defer splitting by generating an equality constraint-    defer-      = do { ty1 <- newFlexiTyVarTy kind1-           ; ty2 <- newFlexiTyVarTy kind2-           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty-           ; return (co, (ty1, ty2)) }--    orig_kind = tcTypeKind orig_ty-    kind1 = mkVisFunTyMany liftedTypeKind orig_kind-    kind2 = liftedTypeKind    -- m :: * -> k-                              -- arg type :: *--{--************************************************************************-*                                                                      *-                Subsumption checking-*                                                                      *-************************************************************************--Note [Subsumption checking: tcSubType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-All the tcSubType calls have the form-                tcSubType actual_ty expected_ty-which checks-                actual_ty <= expected_ty--That is, that a value of type actual_ty is acceptable in-a place expecting a value of type expected_ty.  I.e. that--    actual ty   is more polymorphic than   expected_ty--It returns a wrapper function-        co_fn :: actual_ty ~ expected_ty-which takes an HsExpr of type actual_ty into one of type-expected_ty.--}----------------------- tcWrapResult needs both un-type-checked (for origins and error messages)--- and type-checked (for wrapping) expressions-tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType-             -> TcM (HsExpr GhcTc)-tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr--tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType-               -> TcM (HsExpr GhcTc)-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-       ; return (mkHsWrap wrap expr) }--tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc-                 -> TcRhoType   -- Actual -- a rho-type not a sigma-type-                 -> ExpRhoType  -- Expected-                 -> TcM (HsExpr GhcTc)--- A version of tcWrapResult to use when the actual type is a--- rho-type, so nothing to instantiate; just go straight to unify.--- It means we don't need to pass in a CtOrigin-tcWrapResultMono rn_expr expr act_ty res_ty-  = 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-       ; return (mkHsWrapCo co expr) }---------------------------tcSubTypePat :: CtOrigin -> UserTypeCtxt-            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper--- Used in patterns; polarity is backwards compared---   to tcSubType--- If wrap = tc_sub_type_et t1 t2---    => wrap :: t1 ~> t2-tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected-  = tc_sub_type unifyTypeET inst_orig ctxt ty_actual ty_expected--tcSubTypePat _ _ (Infer inf_res) ty_expected-  = do { co <- fillInferResult ty_expected inf_res-               -- In patterns we do not instantatiate--       ; return (mkWpCastN (mkTcSymCo co)) }------------------tcSubType :: CtOrigin -> UserTypeCtxt-          -> TcSigmaType  -- Actual-          -> ExpRhoType   -- Expected-          -> TcM HsWrapper--- Checks that 'actual' is more polymorphic than 'expected'-tcSubType orig ctxt ty_actual ty_expected-  = addSubTypeCtxt ty_actual ty_expected $-    do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])-       ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected }--tcSubTypeNC :: CtOrigin       -- Used when instantiating-            -> UserTypeCtxt   -- Used when skolemising-            -> Maybe (HsExpr GhcRn)   -- The expression that has type 'actual' (if known)-            -> TcSigmaType            -- Actual type-            -> ExpRhoType             -- Expected type-            -> TcM HsWrapper-tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty-  = case res_ty of-      Check ty_expected -> tc_sub_type (unifyType m_thing) inst_orig ctxt-                                       ty_actual ty_expected--      Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual-                                   -- See Note [Instantiation of InferResult]-                          ; co <- fillInferResult rho inf_res-                          ; return (mkWpCastN co <.> wrap) }--{- Note [Instantiation of InferResult]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We now always instantiate before filling in InferResult, so that-the result is a TcRhoType: see #17173 for discussion.--For example:--1. Consider-    f x = (*)-   We want to instantiate the type of (*) before returning, else we-   will infer the type-     f :: forall {a}. a -> forall b. Num b => b -> b -> b-   This is surely confusing for users.--   And worse, the monomorphism restriction won't work properly. The MR is-   dealt with in simplifyInfer, and simplifyInfer has no way of-   instantiating. This could perhaps be worked around, but it may be-   hard to know even when instantiation should happen.--2. Another reason.  Consider-       f :: (?x :: Int) => a -> a-       g y = let ?x = 3::Int in f-   Here want to instantiate f's type so that the ?x::Int constraint-   gets discharged by the enclosing implicit-parameter binding.--3. Suppose one defines plus = (+). If we instantiate lazily, we will-   infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism-   restriction compels us to infer-      plus :: Integer -> Integer -> Integer-   (or similar monotype). Indeed, the only way to know whether to apply-   the monomorphism restriction at all is to instantiate--There is one place where we don't want to instantiate eagerly,-namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type-command. See Note [Implementing :type] in GHC.Tc.Module.--}------------------tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper--- External entry point, but no ExpTypes on either side--- Checks that actual <= expected--- Returns HsWrapper :: actual ~ expected-tcSubTypeSigma ctxt ty_actual ty_expected-  = tc_sub_type (unifyType Nothing) eq_orig ctxt ty_actual ty_expected-  where-    eq_orig = TypeEqOrigin { uo_actual   = ty_actual-                           , uo_expected = ty_expected-                           , uo_thing    = Nothing-                           , uo_visible  = True }------------------tc_sub_type :: (TcType -> TcType -> TcM TcCoercionN)  -- How to unify-            -> CtOrigin       -- Used when instantiating-            -> UserTypeCtxt   -- Used when skolemising-            -> TcSigmaType    -- Actual; a sigma-type-            -> TcSigmaType    -- Expected; also a sigma-type-            -> TcM HsWrapper--- Checks that actual_ty is more polymorphic than expected_ty--- If wrap = tc_sub_type t1 t2---    => wrap :: t1 ~> t2-tc_sub_type unify inst_orig ctxt ty_actual ty_expected-  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]-  , not (possibly_poly ty_actual)-  = do { traceTc "tc_sub_type (drop to equality)" $-         vcat [ text "ty_actual   =" <+> ppr ty_actual-              , text "ty_expected =" <+> ppr ty_expected ]-       ; mkWpCastN <$>-         unify ty_actual ty_expected }--  | otherwise   -- This is the general case-  = do { traceTc "tc_sub_type (general case)" $-         vcat [ text "ty_actual   =" <+> ppr ty_actual-              , text "ty_expected =" <+> ppr ty_expected ]--       ; (sk_wrap, inner_wrap)-           <- tcSkolemise ctxt ty_expected $ \ sk_rho ->-              do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual-                 ; cow           <- unify rho_a sk_rho-                 ; return (mkWpCastN cow <.> wrap) }--       ; 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--    definitely_poly ty-      | (tvs, theta, tau) <- tcSplitSigmaTy ty-      , (tv:_) <- tvs-      , null theta-      , isInsolubleOccursCheck NomEq tv tau-      = True-      | otherwise-      = False---------------------------addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a-addSubTypeCtxt ty_actual ty_expected thing_inside- | isRhoTy ty_actual        -- If there is no polymorphism involved, the- , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)- = thing_inside             -- gives enough context by itself- | otherwise- = addErrCtxtM mk_msg thing_inside-  where-    mk_msg tidy_env-      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual-                   -- might not be filled if we're debugging. ugh.-           ; mb_ty_expected          <- readExpType_maybe ty_expected-           ; (tidy_env, ty_expected) <- case mb_ty_expected of-                                          Just ty -> second mkCheckExpType <$>-                                                     zonkTidyTcType tidy_env ty-                                          Nothing -> return (tidy_env, ty_expected)-           ; ty_expected             <- readExpType ty_expected-           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected-           ; let msg = vcat [ hang (text "When checking that:")-                                 4 (ppr ty_actual)-                            , nest 2 (hang (text "is more polymorphic than:")-                                         2 (ppr ty_expected)) ]-           ; return (tidy_env, msg) }--{- Note [Don't skolemise unnecessarily]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are trying to solve-    (Char->Char) <= (forall a. a->a)-We could skolemise the 'forall a', and then complain-that (Char ~ a) is insoluble; but that's a pretty obscure-error.  It's better to say that-    (Char->Char) ~ (forall a. a->a)-fails.--So roughly:- * if the ty_expected has an outermost forall-      (i.e. skolemisation is the next thing we'd do)- * and the ty_actual has no top-level polymorphism (but looking deeply)-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-- * (Char->Char) <= (forall a. (a~Char) => a -> a)-      ty_expected isn't really polymorphic-- * (Char->Char) <= (forall a. F [a] Char -> Char)-                   where type instance F [x] t = t-     ty_expected isn't really polymorphic--If we prematurely go to equality we'll reject a program we should-accept (e.g. #13752).  So the test (which is only to improve-error message) is very conservative:- * ty_actual is /definitely/ monomorphic- * ty_expected is /definitely/ polymorphic--Note [Settting the argument context]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider we are doing the ambiguity check for the (bogus)-  f :: (forall a b. C b => a -> a) -> Int--We'll call-   tcSubType ((forall a b. C b => a->a) -> Int )-             ((forall a b. C b => a->a) -> Int )--with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing-on the argument type of the (->) -- and at that point we want to switch-to a UserTypeCtxt of GenSigCtxt.  Why?--* Error messages.  If we stick with FunSigCtxt we get errors like-     * Could not deduce: C b-       from the context: C b0-        bound by the type signature for:-            f :: forall a b. C b => a->a-  But of course f does not have that type signature!-  Example tests: T10508, T7220a, Simple14--* Implications. We may decide to build an implication for the whole-  ambiguity check, but we don't need one for each level within it,-  and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt.-  See Note [When to build an implication]--Note [Wrapper returned from tcSubMult]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is no notion of multiplicity coercion in Core, therefore the wrapper-returned by tcSubMult (and derived functions such as tcCheckUsage and-checkManyPattern) is quite unlike any other wrapper: it checks whether the-coercion produced by the constraint solver is trivial, producing a type error-is it is not. This is implemented via the WpMultCoercion wrapper, as desugared-by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check.--This wrapper needs to be placed in the term; otherwise, checking of the-eventual coercion won't be triggered during desugaring. But it can be put-anywhere, since it doesn't affect the desugared code.--Why do we check this in the desugarer? It's a convenient place, since it's-right after all the constraints are solved. We need the constraints to be-solved to check whether they are trivial or not. Plus there is precedent for-type errors during desuraging (such as the levity polymorphism-restriction). An alternative would be to have a kind of constraint which can-only produce trivial evidence, then this check would happen in the constraint-solver.--}--tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper-tcSubMult origin w_actual w_expected-  | Just (w1, w2) <- isMultMul w_actual =-  do { w1 <- tcSubMult origin w1 w_expected-     ; w2 <- tcSubMult origin w2 w_expected-     ; return (w1 <.> w2) }-  -- Currently, we consider p*q and sup p q to be equal.  Therefore, p*q <= r is-  -- equivalent to p <= r and q <= r.  For other cases, we approximate p <= q by p-  -- ~ q.  This is not complete, but it's sound. See also Note [Overapproximating-  -- multiplicities] in Multiplicity.-tcSubMult origin w_actual w_expected =-  case submult w_actual w_expected of-    Submult -> return WpHole-    Unknown -> tcEqMult origin w_actual w_expected--tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper-tcEqMult origin w_actual w_expected = do-  {-  -- Note that here we do not call to `submult`, so we check-  -- for strict equality.-  ; coercion <- uType TypeLevel origin w_actual w_expected-  ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion }---{- *********************************************************************-*                                                                      *-                    Generalisation-*                                                                      *-********************************************************************* -}--{- Note [Skolemisation]-~~~~~~~~~~~~~~~~~~~~~~~-tcSkolemise takes "expected type" and strip off quantifiers to expose the-type underneath, binding the new skolems for the 'thing_inside'-The returned 'HsWrapper' has type (specific_ty -> expected_ty).--Note that for a nested type like-   forall a. Eq a => forall b. Ord b => blah-we still only build one implication constraint-   forall a b. (Eq a, Ord b) => <constraints>-This is just an optimisation, but it's why we use topSkolemise to-build the pieces from all the layers, before making a single call-to checkConstraints.--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 always calls checkConstraints, even if there are no skolem-  variables at all.  Reason: there might be nested deferred errors-  that must not be allowed to float to top level.-  See Note [When to build an implication] below.--}--tcSkolemise, tcSkolemiseScoped-    :: UserTypeCtxt -> TcSigmaType-    -> (TcType -> TcM result)-    -> TcM (HsWrapper, result)-        -- ^ The wrapper has type: spec_ty ~> expected_ty--tcSkolemiseScoped ctxt expected_ty thing_inside-  = do { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty-       ; let skol_tvs  = map snd tv_prs-             skol_info = SigSkol ctxt expected_ty tv_prs--       ; (ev_binds, res)-             <- checkConstraints skol_info skol_tvs given $-                tcExtendNameTyVarEnv tv_prs               $-                thing_inside rho_ty--       ; return (wrap <.> mkWpLet ev_binds, res) }--tcSkolemise ctxt expected_ty thing_inside-  | isRhoTy expected_ty  -- Short cut for common case-  = do { res <- thing_inside expected_ty-       ; return (idHsWrapper, res) }-  | otherwise-  = do  { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty--        ; let skol_tvs  = map snd tv_prs-              skol_info = SigSkol ctxt expected_ty tv_prs--        ; (ev_binds, result)-              <- checkConstraints skol_info skol_tvs given $-                 thing_inside rho_ty--        ; return (wrap <.> mkWpLet ev_binds, result) }-          -- The ev_binds returned by checkConstraints is very-          -- often empty, in which case mkWpLet is a no-op---- | Variant of 'tcSkolemise' that takes an ExpType-tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType-              -> (ExpRhoType -> TcM result)-              -> TcM (HsWrapper, result)-tcSkolemiseET _ et@(Infer {}) thing_inside-  = (idHsWrapper, ) <$> thing_inside et-tcSkolemiseET ctxt (Check ty) thing_inside-  = tcSkolemise ctxt ty $ \rho_ty ->-    thing_inside (mkCheckExpType rho_ty)--checkConstraints :: SkolemInfo-                 -> [TcTyVar]           -- Skolems-                 -> [EvVar]             -- Given-                 -> TcM result-                 -> TcM (TcEvBinds, result)--checkConstraints skol_info skol_tvs given thing_inside-  = do { implication_needed <- implicationNeeded skol_info skol_tvs given--       ; if implication_needed-         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside-                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted-                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)-                 ; emitImplications implics-                 ; return (ev_binds, result) }--         else -- Fast path.  We check every function argument with tcCheckPolyExpr,-              -- which uses tcSkolemise and hence checkConstraints.-              -- So this fast path is well-exercised-              do { res <- thing_inside-                 ; return (emptyTcEvBinds, res) } }--checkTvConstraints :: SkolemInfo-                   -> [TcTyVar]          -- Skolem tyvars-                   -> TcM result-                   -> TcM result--checkTvConstraints skol_info skol_tvs thing_inside-  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside-       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted-       ; return result }--emitResidualTvConstraint :: SkolemInfo -> [TcTyVar]-                         -> TcLevel -> WantedConstraints -> TcM ()-emitResidualTvConstraint skol_info skol_tvs tclvl wanted-  | isEmptyWC wanted-  = return ()--  | otherwise-  = do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted-       ; emitImplication implic }--buildTvImplication :: SkolemInfo -> [TcTyVar]-                   -> TcLevel -> WantedConstraints -> TcM Implication-buildTvImplication skol_info skol_tvs tclvl wanted-  = do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints-                                     -- are solved by filling in coercion holes, not-                                     -- by creating a value-level evidence binding-       ; implic   <- newImplication--       ; return (implic { ic_tclvl     = tclvl-                        , ic_skols     = skol_tvs-                        , ic_no_eqs    = True-                        , ic_wanted    = wanted-                        , ic_binds     = ev_binds-                        , ic_info      = skol_info }) }--implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool--- See Note [When to build an implication]-implicationNeeded skol_info skol_tvs given-  | null skol_tvs-  , null given-  , not (alwaysBuildImplication skol_info)-  = -- Empty skolems and givens-    do { tc_lvl <- getTcLevel-       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are-         then return False             -- already inside an implication-         else-    do { dflags <- getDynFlags       -- If any deferral can happen,-                                     -- we must build an implication-       ; return (gopt Opt_DeferTypeErrors dflags ||-                 gopt Opt_DeferTypedHoles dflags ||-                 gopt Opt_DeferOutOfScopeVariables dflags) } }--  | otherwise     -- Non-empty skolems or givens-  = return True   -- Definitely need an implication--alwaysBuildImplication :: SkolemInfo -> Bool--- See Note [When to build an implication]-alwaysBuildImplication _ = False--{-  Commmented out for now while I figure out about error messages.-    See #14185--alwaysBuildImplication (SigSkol ctxt _ _)-  = case ctxt of-      FunSigCtxt {} -> True  -- RHS of a binding with a signature-      _             -> False-alwaysBuildImplication (RuleSkol {})      = True-alwaysBuildImplication (InstSkol {})      = True-alwaysBuildImplication (FamInstSkol {})   = True-alwaysBuildImplication _                  = False--}--buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]-                   -> [EvVar] -> WantedConstraints-                   -> TcM (Bag Implication, TcEvBinds)-buildImplicationFor tclvl skol_info skol_tvs given wanted-  | isEmptyWC wanted && null given-             -- Optimisation : if there are no wanteds, and no givens-             -- don't generate an implication at all.-             -- Reason for the (null given): we don't want to lose-             -- the "inaccessible alternative" error check-  = return (emptyBag, emptyTcEvBinds)--  | otherwise-  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )-      -- Why allow TyVarTvs? Because implicitly declared kind variables in-      -- non-CUSK type declarations are TyVarTvs, and we need to bring them-      -- into scope as a skolem in an implication. This is OK, though,-      -- because TyVarTvs will always remain tyvars, even after unification.-    do { ev_binds_var <- newTcEvBinds-       ; implic <- newImplication-       ; let implic' = implic { ic_tclvl  = tclvl-                              , ic_skols  = skol_tvs-                              , ic_given  = given-                              , ic_wanted = wanted-                              , ic_binds  = ev_binds_var-                              , ic_info   = skol_info }--       ; return (unitBag implic', TcEvBinds ev_binds_var) }--{- Note [When to build an implication]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have some 'skolems' and some 'givens', and we are-considering whether to wrap the constraints in their scope into an-implication.  We must /always/ so if either 'skolems' or 'givens' are-non-empty.  But what if both are empty?  You might think we could-always drop the implication.  Other things being equal, the fewer-implications the better.  Less clutter and overhead.  But we must-take care:--* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,-  we'll make a /term-level/ evidence binding for 'g = error "blah"'.-  We must have an EvBindsVar those bindings!, otherwise they end up as-  top-level unlifted bindings, which are verboten. This only matters-  at top level, so we check for that-  See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors.-  cf #14149 for an example of what goes wrong.--* If you have-     f :: Int;  f = f_blah-     g :: Bool; g = g_blah-  If we don't build an implication for f or g (no tyvars, no givens),-  the constraints for f_blah and g_blah are solved together.  And that-  can yield /very/ confusing error messages, because we can get-      [W] C Int b1    -- from f_blah-      [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.--}--{--************************************************************************-*                                                                      *-                Boxy unification-*                                                                      *-************************************************************************--The exported functions are all defined as versions of some-non-exported generic functions.--}--unifyType :: Maybe (HsExpr GhcRn)   -- ^ If present, has type 'ty1'-          -> TcTauType -> TcTauType -> TcM TcCoercionN--- Actual and expected types--- Returns a coercion : ty1 ~ ty2-unifyType thing ty1 ty2-  = uType TypeLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty1-                          , uo_expected = ty2-                          , uo_thing    = ppr <$> thing-                          , uo_visible  = True }--unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN--- Like unifyType, but swap expected and actual in error messages--- This is used when typechecking patterns-unifyTypeET ty1 ty2-  = uType TypeLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty2   -- NB swapped-                          , uo_expected = ty1   -- NB swapped-                          , uo_thing    = Nothing-                          , uo_visible  = True }---unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN-unifyKind thing ty1 ty2-  = uType KindLevel origin ty1 ty2-  where-    origin = TypeEqOrigin { uo_actual   = ty1-                          , uo_expected = ty2-                          , uo_thing    = ppr <$> thing-                          , uo_visible  = True }---{--%************************************************************************-%*                                                                      *-                 uType and friends-%*                                                                      *-%************************************************************************--uType is the heart of the unifier.--}--uType, uType_defer-  :: TypeOrKind-  -> CtOrigin-  -> TcType    -- ty1 is the *actual* type-  -> TcType    -- ty2 is the *expected* type-  -> TcM CoercionN------------------- It is always safe to defer unification to the main constraint solver--- See Note [Deferred unification]-uType_defer t_or_k origin ty1 ty2-  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2--       -- Error trace only-       -- NB. do *not* call mkErrInfo unless tracing is on,-       --     because it is hugely expensive (#5631)-       ; whenDOptM Opt_D_dump_tc_trace $ do-            { ctxt <- getErrCtxt-            ; doc <- mkErrInfo emptyTidyEnv ctxt-            ; traceTc "utype_defer" (vcat [ debugPprType ty1-                                          , debugPprType ty2-                                          , pprCtOrigin origin-                                          , doc])-            ; traceTc "utype_defer2" (ppr co)-            }-       ; return co }-----------------uType t_or_k origin orig_ty1 orig_ty2-  = do { tclvl <- getTcLevel-       ; traceTc "u_tys" $ vcat-              [ text "tclvl" <+> ppr tclvl-              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]-              , pprCtOrigin origin]-       ; co <- go orig_ty1 orig_ty2-       ; if isReflCo co-            then traceTc "u_tys yields no coercion" Outputable.empty-            else traceTc "u_tys yields coercion:" (ppr co)-       ; return co }-  where-    go :: TcType -> TcType -> TcM CoercionN-        -- The arguments to 'go' are always semantically identical-        -- to orig_ty{1,2} except for looking through type synonyms--     -- Unwrap casts before looking for variables. This way, we can easily-     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we-     -- didn't do it this way, and then the unification above was deferred.-    go (CastTy t1 co1) t2-      = do { co_tys <- uType t_or_k origin t1 t2-           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }--    go t1 (CastTy t2 co2)-      = do { co_tys <- uType t_or_k origin t1 t2-           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }--        -- Variables; go for uUnfilledVar-        -- Note that we pass in *original* (before synonym expansion),-        -- so that type variables tend to get filled in with-        -- the most informative version of the type-    go (TyVarTy tv1) ty2-      = do { lookup_res <- lookupTcTyVar tv1-           ; case lookup_res of-               Filled ty1   -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)-                                  ; go ty1 ty2 }-               Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }-    go ty1 (TyVarTy tv2)-      = do { lookup_res <- lookupTcTyVar tv2-           ; case lookup_res of-               Filled ty2   -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)-                                  ; go ty1 ty2 }-               Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }--      -- See Note [Expanding synonyms during unification]-    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])-      | tc1 == tc2-      = return $ mkNomReflCo ty1--        -- See Note [Expanding synonyms during unification]-        ---        -- Also NB that we recurse to 'go' so that we don't push a-        -- new item on the origin stack. As a result if we have-        --   type Foo = Int-        -- and we try to unify  Foo ~ Bool-        -- we'll end up saying "can't match Foo with Bool"-        -- rather than "can't match "Int with Bool".  See #4535.-    go ty1 ty2-      | 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-           ; co_w <- uType t_or_k origin w1 w2-           ; return $ mkFunCo Nominal co_w co_l co_r }--        -- Always defer if a type synonym family (type function)-        -- is involved.  (Data families behave rigidly.)-    go ty1@(TyConApp tc1 _) ty2-      | isTypeFamilyTyCon tc1 = defer ty1 ty2-    go ty1 ty2@(TyConApp tc2 _)-      | isTypeFamilyTyCon tc2 = defer ty1 ty2--    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)-      -- See Note [Mismatched type lists and application decomposition]-      | tc1 == tc2, equalLength tys1 tys2-      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )-        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2-           ; return $ mkTyConAppCo Nominal tc1 cos }-      where-        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)-                       (tcTyConVisibilities tc1)--    go (LitTy m) ty@(LitTy n)-      | m == n-      = return $ mkNomReflCo ty--        -- See Note [Care with type applications]-        -- Do not decompose FunTy against App;-        -- it's often a type error, so leave it for the constraint solver-    go (AppTy s1 t1) (AppTy s2 t2)-      = go_app (isNextArgVisible s1) s1 t1 s2 t2--    go (AppTy s1 t1) (TyConApp tc2 ts2)-      | Just (ts2', t2') <- snocView ts2-      = ASSERT( not (mustBeSaturated tc2) )-        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'--    go (TyConApp tc1 ts1) (AppTy s2 t2)-      | Just (ts1', t1') <- snocView ts1-      = ASSERT( not (mustBeSaturated tc1) )-        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2--    go (CoercionTy co1) (CoercionTy co2)-      = do { let ty1 = coercionType co1-                 ty2 = coercionType co2-           ; kco <- uType KindLevel-                          (KindEqOrigin orig_ty1 (Just orig_ty2) origin-                                        (Just t_or_k))-                          ty1 ty2-           ; return $ mkProofIrrelCo Nominal kco co1 co2 }--        -- Anything else fails-        -- E.g. unifying for-all types, which is relative unusual-    go ty1 ty2 = defer ty1 ty2--    -------------------    defer ty1 ty2   -- See Note [Check for equality before deferring]-      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)-      | otherwise          = uType_defer t_or_k origin ty1 ty2--    -------------------    go_app vis s1 t1 s2 t2-      = do { co_s <- uType t_or_k origin s1 s2-           ; let arg_origin-                   | vis       = origin-                   | otherwise = toInvisibleOrigin origin-           ; co_t <- uType t_or_k arg_origin t1 t2-           ; return $ mkAppCo co_s co_t }--{- Note [Check for equality before deferring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Particularly in ambiguity checks we can get equalities like (ty ~ ty).-If ty involves a type function we may defer, which isn't very sensible.-An egregious example of this was in test T9872a, which has a type signature-       Proxy :: Proxy (Solutions Cubes)-Doing the ambiguity check on this signature generates the equality-   Solutions Cubes ~ Solutions Cubes-and currently the constraint solver normalises both sides at vast cost.-This little short-cut in 'defer' helps quite a bit.--Note [Care with type applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Note: type applications need a bit of care!-They can match FunTy and TyConApp, so use splitAppTy_maybe-NB: we've already dealt with type variables and Notes,-so if one type is an App the other one jolly well better be too--Note [Mismatched type lists and application decomposition]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we find two TyConApps, you might think that the argument lists-are guaranteed equal length.  But they aren't. Consider matching-        w (T x) ~ Foo (T x y)-We do match (w ~ Foo) first, but in some circumstances we simply create-a deferred constraint; and then go ahead and match (T x ~ T x y).-This came up in #3950.--So either-   (a) either we must check for identical argument kinds-       when decomposing applications,--   (b) or we must be prepared for ill-kinded unification sub-problems--Currently we adopt (b) since it seems more robust -- no need to maintain-a global invariant.--Note [Expanding synonyms during unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We expand synonyms during unification, but:- * We expand *after* the variable case so that we tend to unify-   variables with un-expanded type synonym. This just makes it-   more likely that the inferred types will mention type synonyms-   understandable to the user-- * Similarly, we expand *after* the CastTy case, just in case the-   CastTy wraps a variable.-- * We expand *before* the TyConApp case.  For example, if we have-      type Phantom a = Int-   and are unifying-      Phantom Int ~ Phantom Char-   it is *wrong* to unify Int and Char.-- * The problem case immediately above can happen only with arguments-   to the tycon. So we check for nullary tycons *before* expanding.-   This is particularly helpful when checking (* ~ *), because * is-   now a type synonym.--Note [Deferred Unification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,-and yet its consistency is undetermined. Previously, there was no way to still-make it consistent. So a mismatch error was issued.--Now these unifications are deferred until constraint simplification, where type-family instances and given equations may (or may not) establish the consistency.-Deferred unifications are of the form-                F ... ~ ...-or              x ~ ...-where F is a type function and x is a type variable.-E.g.-        id :: x ~ y => x -> y-        id e = e--involves the unification x = y. It is deferred until we bring into account the-context x ~ y to establish that it holds.--If available, we defer original types (rather than those where closed type-synonyms have already been expanded via tcCoreView).  This is, as usual, to-improve error messages.---************************************************************************-*                                                                      *-                 uUnfilledVar and friends-*                                                                      *-************************************************************************--@uunfilledVar@ is called when at least one of the types being unified is a-variable.  It does {\em not} assume that the variable is a fixed point-of the substitution; rather, notice that @uVar@ (defined below) nips-back into @uTys@ if it turns out that the variable is already bound.--}-------------uUnfilledVar :: CtOrigin-             -> TypeOrKind-             -> SwapFlag-             -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar-                               --    definitely not a /filled/ meta-tyvar-             -> TcTauType      -- Type 2-             -> TcM Coercion--- "Unfilled" means that the variable is definitely not a filled-in meta tyvar---            It might be a skolem, or untouchable, or meta--uUnfilledVar origin t_or_k swapped tv1 ty2-  = do { ty2 <- zonkTcType ty2-             -- Zonk to expose things to the-             -- occurs check, and so that if ty2-             -- looks like a type variable then it-             -- /is/ a type variable-       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }-------------uUnfilledVar1 :: CtOrigin-              -> TypeOrKind-              -> SwapFlag-              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar-                                --    definitely not a /filled/ meta-tyvar-              -> TcTauType      -- Type 2, zonked-              -> TcM Coercion-uUnfilledVar1 origin t_or_k swapped tv1 ty2-  | Just tv2 <- tcGetTyVar_maybe ty2-  = go tv2--  | otherwise-  = uUnfilledVar2 origin t_or_k swapped tv1 ty2--  where-    -- 'go' handles the case where both are-    -- tyvars so we might want to swap-    -- E.g. maybe tv2 is a meta-tyvar and tv1 is not-    go tv2 | tv1 == tv2  -- Same type variable => no-op-           = return (mkNomReflCo (mkTyVarTy tv1))--           | swapOverTyVars False tv1 tv2   -- Distinct type variables-               -- Swap meta tyvar to the left if poss-           = do { tv1 <- zonkTyCoVarKind tv1-                     -- We must zonk tv1's kind because that might-                     -- not have happened yet, and it's an invariant of-                     -- uUnfilledTyVar2 that ty2 is fully zonked-                     -- Omitting this caused #16902-                ; uUnfilledVar2 origin t_or_k (flipSwap swapped)-                           tv2 (mkTyVarTy tv1) }--           | otherwise-           = uUnfilledVar2 origin t_or_k swapped tv1 ty2-------------uUnfilledVar2 :: CtOrigin-              -> TypeOrKind-              -> SwapFlag-              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar-                                --    definitely not a /filled/ meta-tyvar-              -> TcTauType      -- Type 2, zonked-              -> TcM Coercion-uUnfilledVar2 origin t_or_k swapped tv1 ty2-  = do { dflags  <- getDynFlags-       ; cur_lvl <- getTcLevel-       ; go dflags cur_lvl }-  where-    go dflags cur_lvl-      | canSolveByUnification cur_lvl tv1 ty2-      , MTVU_OK ty2' <- metaTyVarUpdateOK dflags tv1 ty2-      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)-           ; traceTc "uUnfilledVar2 ok" $-             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)-                  , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)-                  , ppr (isTcReflCo co_k), ppr co_k ]--           ; if isTcReflCo co_k-               -- Only proceed if the kinds match-               -- NB: tv1 should still be unfilled, despite the kind unification-               --     because tv1 is not free in ty2 (or, hence, in its kind)-             then do { writeMetaTyVar tv1 ty2'-                     ; return (mkTcNomReflCo ty2') }--             else defer } -- This cannot be solved now.  See GHC.Tc.Solver.Canonical-                          -- Note [Equalities with incompatible kinds]--      | otherwise-      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)-               -- Occurs check or an untouchable: just defer-               -- NB: occurs check isn't necessarily fatal:-               --     eg tv1 occurred in type family parameter-            ; defer }--    ty1 = mkTyVarTy tv1-    kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)--    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2--swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool-swapOverTyVars is_given tv1 tv2-  -- See Note [Unification variables on the left]-  | not is_given, pri1 == 0, pri2 > 0 = True-  | not is_given, pri2 == 0, pri1 > 0 = False--  -- Level comparison: see Note [TyVar/TyVar orientation]-  | lvl1 `strictlyDeeperThan` lvl2 = False-  | lvl2 `strictlyDeeperThan` lvl1 = True--  -- Priority: see Note [TyVar/TyVar orientation]-  | pri1 > pri2 = False-  | pri2 > pri1 = True--  -- Names: see Note [TyVar/TyVar orientation]-  | isSystemName tv2_name, not (isSystemName tv1_name) = True--  | otherwise = False--  where-    lvl1 = tcTyVarLevel tv1-    lvl2 = tcTyVarLevel tv2-    pri1 = lhsPriority tv1-    pri2 = lhsPriority tv2-    tv1_name = Var.varName tv1-    tv2_name = Var.varName tv2---lhsPriority :: TcTyVar -> Int--- Higher => more important to be on the LHS--- See Note [TyVar/TyVar orientation]-lhsPriority tv-  = ASSERT2( isTyVar tv, ppr tv)-    case tcTyVarDetails tv of-      RuntimeUnk  -> 0-      SkolemTv {} -> 0-      MetaTv { mtv_info = info } -> case info of-                                     FlatSkolTv -> 1-                                     TyVarTv    -> 2-                                     TauTv      -> 3-                                     FlatMetaTv -> 4-{- Note [TyVar/TyVar orientation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?-This is a surprisingly tricky question! This is invariant (TyEq:TV).--The question is answered by swapOverTyVars, which is use-  - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1-  - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqTyVarHomo--First note: only swap if you have to!-   See Note [Avoid unnecessary swaps]--So we look for a positive reason to swap, using a three-step test:--* Level comparison. If 'a' has deeper level than 'b',-  put 'a' on the left.  See Note [Deeper level on the left]--* Priority.  If the levels are the same, look at what kind of-  type variable it is, using 'lhsPriority'.--  Generally speaking we always try to put a MetaTv on the left-  in preference to SkolemTv or RuntimeUnkTv:-     a) Because the MetaTv may be touchable and can be unified-     b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities-        looks for meta tyvars on the left--  Tie-breaking rules for MetaTvs:-  - FlatMetaTv = 4: always put on the left.-        See Note [Fmv Orientation Invariant]--        NB: FlatMetaTvs always have the current level, never an-        outer one.  So nothing can be deeper than a FlatMetaTv.--  - TauTv = 3: if we have  tyv_tv ~ tau_tv,-       put tau_tv on the left because there are fewer-       restrictions on updating TauTvs.  Or to say it another-       way, then we won't lose the TyVarTv flag--  - TyVarTv = 2: remember, flat-skols are *only* updated by-       the unflattener, never unified, so TyVarTvs come next--  - FlatSkolTv = 1: put on the left in preference to a SkolemTv.-       See Note [Eliminate flat-skols]--* Names. If the level and priority comparisons are all-  equal, try to eliminate a TyVars with a System Name in-  favour of ones with a Name derived from a user type signature--* Age.  At one point in the past we tried to break any remaining-  ties by eliminating the younger type variable, based on their-  Uniques.  See Note [Eliminate younger unification variables]-  (which also explains why we don't do this any more)--Note [Unification variables on the left]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of-level, so that the unification variable is on the left.--* We /don't/ want this for Givens because if we ave-    [G] a[2] ~ alpha[1]-    [W] Bool ~ a[2]-  we want to rewrite the wanted to Bool ~ alpha[1],-  so we can float the constraint and solve it.--* But for Wanteds putting the unification variable on-  the left means an easier job when floating, and when-  reporting errors -- just fewer cases to consider.--  In particular, we get better skolem-escape messages:-  see #18114--Note [Deeper level on the left]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The most important thing is that we want to put tyvars with-the deepest level on the left.  The reason to do so differs for-Wanteds and Givens, but either way, deepest wins!  Simple.--* Wanteds.  Putting the deepest variable on the left maximise the-  chances that it's a touchable meta-tyvar which can be solved.--* Givens. Suppose we have something like-     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]--  If we orient the Given a[2] on the left, we'll rewrite the Wanted to-  (beta[1] ~ b[1]), and that can float out of the implication.-  Otherwise it can't.  By putting the deepest variable on the left-  we maximise our changes of eliminating skolem capture.--  See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason-  to orient with the deepest skolem on the left.--  IMPORTANT NOTE: this test does a level-number comparison on-  skolems, so it's important that skolems have (accurate) level-  numbers.--See #15009 for an further analysis of why "deepest on the left"-is a good plan.--Note [Fmv Orientation Invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   * We always orient a constraint-        fmv ~ alpha-     with fmv on the left, even if alpha is-     a touchable unification variable--Reason: doing it the other way round would unify alpha:=fmv, but that-really doesn't add any info to alpha.  But a later constraint alpha ~-Int might unlock everything.  Comment:9 of #12526 gives a detailed-example.--WARNING: I've gone to and fro on this one several times.-I'm now pretty sure that unifying alpha:=fmv is a bad idea!-So orienting with fmvs on the left is a good thing.--This example comes from IndTypesPerfMerge. (Others include-T10226, T10009.)-    From the ambiguity check for-      f :: (F a ~ a) => a-    we get:-          [G] F a ~ a-          [WD] F alpha ~ alpha, alpha ~ a--    From Givens we get-          [G] F a ~ fsk, fsk ~ a--    Now if we flatten we get-          [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a--    Now, if we unified alpha := fmv, we'd get-          [WD] F fmv ~ fmv, [WD] fmv ~ a-    And now we are stuck.--So instead the Fmv Orientation Invariant puts the fmv on the-left, giving-      [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a--    Now we get alpha:=a, and everything works out--Note [Eliminate flat-skols]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have  [G] Num (F [a])-then we flatten to-     [G] Num fsk-     [G] F [a] ~ fsk-where fsk is a flatten-skolem (FlatSkolTv). Suppose we have-      type instance F [a] = a-then we'll reduce the second constraint to-     [G] a ~ fsk-and then replace all uses of 'a' with fsk.  That's bad because-in error messages instead of saying 'a' we'll say (F [a]).  In all-places, including those where the programmer wrote 'a' in the first-place.  Very confusing!  See #7862.--Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate-the fsk.--Note [Avoid unnecessary swaps]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we swap without actually improving matters, we can get an infinite loop.-Consider-    work item:  a ~ b-   inert item:  b ~ c-We canonicalise the work-item to (a ~ c).  If we then swap it before-adding to the inert set, we'll add (c ~ a), and therefore kick out the-inert guy, so we get-   new work item:  b ~ c-   inert item:     c ~ a-And now the cycle just repeats--Note [Eliminate younger unification variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given a choice of unifying-     alpha := beta   or   beta := alpha-we try, if possible, to eliminate the "younger" one, as determined-by `ltUnique`.  Reason: the younger one is less likely to appear free in-an existing inert constraint, and hence we are less likely to be forced-into kicking out and rewriting inert constraints.--This is a performance optimisation only.  It turns out to fix-#14723 all by itself, but clearly not reliably so!--It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).-But, to my surprise, it didn't seem to make any significant difference-to the compiler's performance, so I didn't take it any further.  Still-it seemed to too nice to discard altogether, so I'm leaving these-notes.  SLPJ Jan 18.--}---- @trySpontaneousSolve wi@ solves equalities where one side is a--- touchable unification variable.--- Returns True <=> spontaneous solve happened-canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool-canSolveByUnification tclvl tv xi-  | isTouchableMetaTyVar tclvl tv-  = case metaTyVarInfo tv of-      TyVarTv -> is_tyvar xi-      _       -> True--  | otherwise    -- Untouchable-  = False-  where-    is_tyvar xi-      = case tcGetTyVar_maybe xi of-          Nothing -> False-          Just tv -> case tcTyVarDetails tv of-                       MetaTv { mtv_info = info }-                                   -> case info of-                                        TyVarTv -> True-                                        _       -> False-                       SkolemTv {} -> True-                       RuntimeUnk  -> True--{- Note [Prevent unification with type families]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We prevent unification with type families because of an uneasy compromise.-It's perfectly sound to unify with type families, and it even improves the-error messages in the testsuite. It also modestly improves performance, at-least in some cases. But it's disastrous for test case perf/compiler/T3064.-Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.-What do we do? Do we reduce F? Or do we use the given? Hard to know what's-best. GHC reduces. This is a disaster for T3064, where the type's size-spirals out of control during reduction. (We're not helped by the fact that-the flattener re-flattens all the arguments every time around.) If we prevent-unification with type families, then the solver happens to use the equality-before expanding the type family.--It would be lovely in the future to revisit this problem and remove this-extra, unnecessary check. But we retain it for now as it seems to work-better in practice.--Note [Refactoring hazard: checkTauTvUpdate]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-I (Richard E.) have a sad story about refactoring this code, retained here-to prevent others (or a future me!) from falling into the same traps.--It all started with #11407, which was caused by the fact that the TyVarTy-case of defer_me didn't look in the kind. But it seemed reasonable to-simply remove the defer_me check instead.--It referred to two Notes (since removed) that were out of date, and the-fast_check code in occurCheckExpand seemed to do just about the same thing as-defer_me. The one piece that defer_me did that wasn't repeated by-occurCheckExpand was the type-family check. (See Note [Prevent unification-with type families].) So I checked the result of occurCheckExpand for any-type family occurrences and deferred if there were any. This was done-in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .--This approach turned out not to be performant, because the expanded-type was bigger than the original type, and tyConsOfType (needed to-see if there are any type family occurrences) looks through type-synonyms. So it then struck me that we could dispense with the-defer_me check entirely. This simplified the code nicely, and it cut-the allocations in T5030 by half. But, as documented in Note [Prevent-unification with type families], this destroyed performance in-T3064. Regardless, I missed this regression and the change was-committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .--Bottom lines:- * defer_me is back, but now fixed w.r.t. #11407.- * Tread carefully before you start to refactor here. There can be-   lots of hard-to-predict consequences.--Note [Type synonyms and the occur check]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally speaking we try to update a variable with type synonyms not-expanded, which improves later error messages, unless looking-inside a type synonym may help resolve a spurious occurs check-error. Consider:-          type A a = ()--          f :: (A a -> a -> ()) -> ()-          f = \ _ -> ()--          x :: ()-          x = f (\ x p -> p x)--We will eventually get a constraint of the form t ~ A t. The ok function above will-properly expand the type (A t) to just (), which is ok to be unified with t. If we had-unified with the original type A t, we would lead the type checker into an infinite loop.--Hence, if the occurs check fails for a type synonym application, then (and *only* then),-the ok function expands the synonym to detect opportunities for occurs check success using-the underlying definition of the type synonym.--The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact,-function @occ_check_ok@.--Note [Non-TcTyVars in GHC.Tc.Utils.Unify]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because the same code is now shared between unifying types and unifying-kinds, we sometimes will see proper TyVars floating around the unifier.-Example (from test case polykinds/PolyKinds12):--    type family Apply (f :: k1 -> k2) (x :: k1) :: k2-    type instance Apply g y = g y--When checking the instance declaration, we first *kind-check* the LHS-and RHS, discovering that the instance really should be--    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y--During this kind-checking, all the tyvars will be TcTyVars. Then, however,-as a second pass, we desugar the RHS (which is done in functions prefixed-with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper-TyVars, not TcTyVars, get some kind unification must happen.--Thus, we always check if a TyVar is a TcTyVar before asking if it's a-meta-tyvar.--This used to not be necessary for type-checking (that is, before * :: *)-because expressions get desugared via an algorithm separate from-type-checking (with wrappers, etc.). Types get desugared very differently,-causing this wibble in behavior seen here.--}--data LookupTyVarResult  -- The result of a lookupTcTyVar call-  = Unfilled TcTyVarDetails     -- SkolemTv or virgin MetaTv-  | Filled   TcType--lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult-lookupTcTyVar tyvar-  | MetaTv { mtv_ref = ref } <- details-  = do { meta_details <- readMutVar ref-       ; case meta_details of-           Indirect ty -> return (Filled ty)-           Flexi -> do { is_touchable <- isTouchableTcM tyvar-                             -- Note [Unifying untouchables]-                       ; if is_touchable then-                            return (Unfilled details)-                         else-                            return (Unfilled vanillaSkolemTv) } }-  | otherwise-  = return (Unfilled details)-  where-    details = tcTyVarDetails tyvar--{--Note [Unifying untouchables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We treat an untouchable type variable as if it was a skolem.  That-ensures it won't unify with anything.  It's a slight hack, because-we return a made-up TcTyVarDetails, but I think it works smoothly.--}---- | Breaks apart a function kind into its pieces.-matchExpectedFunKind-  :: Outputable fun-  => fun             -- ^ type, only for errors-  -> Arity           -- ^ n: number of desired arrows-  -> TcKind          -- ^ fun_ kind-  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)--matchExpectedFunKind hs_ty n k = go n k-  where-    go 0 k = return (mkNomReflCo k)--    go n k | Just k' <- tcView k = go n k'--    go n k@(TyVarTy kvar)-      | isMetaTyVar kvar-      = do { maybe_kind <- readMetaTyVar kvar-           ; case maybe_kind of-                Indirect fun_kind -> go n fun_kind-                Flexi ->             defer n k }--    go n (FunTy _ w arg res)-      = do { co <- go (n-1) res-           ; return (mkTcFunCo Nominal (mkTcNomReflCo w) (mkTcNomReflCo arg) co) }--    go n other-     = defer n other--    defer n k-      = do { arg_kinds <- newMetaKindVars n-           ; res_kind  <- newMetaKindVar-           ; let new_fun = mkVisFunTysMany arg_kinds res_kind-                 origin  = TypeEqOrigin { uo_actual   = k-                                        , uo_expected = new_fun-                                        , uo_thing    = Just (ppr hs_ty)-                                        , uo_visible  = True-                                        }-           ; uType KindLevel origin k new_fun }--{- *********************************************************************-*                                                                      *-                 Occurrence checking-*                                                                      *-********************************************************************* -}---{-  Note [Occurrence checking: look inside kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we are considering unifying-   (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)-This may be an error (what is that alpha doing inside beta's kind?),-but we must not make the mistake of actually unifying or we'll-build an infinite data structure.  So when looking for occurrences-of alpha in the rhs, we must look in the kinds of type variables-that occur there.--NB: we may be able to remove the problem via expansion; see-    Note [Occurs check expansion].  So we have to try that.--Note [Checking for foralls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unless we have -XImpredicativeTypes (which is a totally unsupported-feature), we do not want to unify-    alpha ~ (forall a. a->a) -> Int-So we look for foralls hidden inside the type, and it's convenient-to do that at the same time as the occurs check (which looks for-occurrences of alpha).--However, it's not just a question of looking for foralls /anywhere/!-Consider-   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)-This is legal; e.g. dependent/should_compile/T11635.--We don't want to reject it because of the forall in beta's kind,-but (see Note [Occurrence checking: look inside kinds]) we do-need to look in beta's kind.  So we carry a flag saying if a 'forall'-is OK, and switch the flag on when stepping inside a kind.--Why is it OK?  Why does it not count as impredicative polymorphism?-The reason foralls are bad is because we reply on "seeing" foralls-when doing implicit instantiation.  But the forall inside the kind is-fine.  We'll generate a kind equality constraint-  (forall k. k->*) ~ (forall k. k->*)-to check that the kinds of lhs and rhs are compatible.  If alpha's-kind had instead been-  (alpha :: kappa)-then this kind equality would rightly complain about unifying kappa-with (forall k. k->*)---}--data MetaTyVarUpdateResult a-  = MTVU_OK a-  | MTVU_Bad          -- Forall, predicate, or type family-  | MTVU_HoleBlocker  -- Blocking coercion hole-        -- See Note [Equalities with incompatible kinds] in "GHC.Tc.Solver.Canonical"-  | MTVU_Occurs-    deriving (Functor)--instance Applicative MetaTyVarUpdateResult where-      pure = MTVU_OK-      (<*>) = ap--instance Monad MetaTyVarUpdateResult where-  MTVU_OK x        >>= k = k x-  MTVU_Bad         >>= _ = MTVU_Bad-  MTVU_HoleBlocker >>= _ = MTVU_HoleBlocker-  MTVU_Occurs      >>= _ = MTVU_Occurs--instance Outputable a => Outputable (MetaTyVarUpdateResult a) where-  ppr (MTVU_OK a)      = text "MTVU_OK" <+> ppr a-  ppr MTVU_Bad         = text "MTVU_Bad"-  ppr MTVU_HoleBlocker = text "MTVU_HoleBlocker"-  ppr MTVU_Occurs      = text "MTVU_Occurs"--occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()--- Just for error-message generation; so we return MetaTyVarUpdateResult--- so the caller can report the right kind of error--- Check whether---   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-      MTVU_OK _        -> MTVU_OK ()-      MTVU_Bad         -> MTVU_Bad-      MTVU_HoleBlocker -> MTVU_HoleBlocker-      MTVU_Occurs      -> case occCheckExpand [tv] ty of-                            Nothing -> MTVU_Occurs-                            Just _  -> MTVU_OK ()-------------------metaTyVarUpdateOK :: DynFlags-                  -> TcTyVar             -- tv :: k1-                  -> 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)---       (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"------ We have two possible outcomes:--- (1) Return the type to update the type variable with,---        [we know the update is ok]--- (2) Return Nothing,---        [the update might be dodgy]------ Note that "Nothing" does not mean "definite error".  For example---   type family F a---   type instance F Int = Int--- consider---   a ~ F a--- This is perfectly reasonable, if we later get a ~ Int.  For now, though,--- we return Nothing, leaving it to the later constraint simplifier to--- sort matters out.------ See Note [Refactoring hazard: checkTauTvUpdate]--metaTyVarUpdateOK dflags tv ty-  = case preCheck dflags False tv ty of-         -- False <=> type families not ok-         -- See Note [Prevent unification with type families]-      MTVU_OK _        -> MTVU_OK ty-      MTVU_Bad         -> MTVU_Bad          -- forall, predicate, type function-      MTVU_HoleBlocker -> MTVU_HoleBlocker  -- coercion hole-      MTVU_Occurs      -> case occCheckExpand [tv] ty of-                            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---   (d) a blocking coercion hole---   (e) an occurrence of the type variable (occurs check)------ For (a), (b), and (c) we check only the top level of the type, NOT--- 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-  = fast_check ty-  where-    details          = tcTyVarDetails tv-    impredicative_ok = canUnifyWithPolyType dflags details--    ok :: MetaTyVarUpdateResult ()-    ok = MTVU_OK ()--    fast_check :: TcType -> MetaTyVarUpdateResult ()-    fast_check (TyVarTy tv')-      | tv == tv' = MTVU_Occurs-      | otherwise = fast_check_occ (tyVarKind tv')-           -- See Note [Occurrence checking: look inside kinds]--    fast_check (TyConApp tc tys)-      | bad_tc tc              = 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-      | 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-       | otherwise = do { fast_check_occ (tyVarKind tv')-                        ; fast_check_occ ty }-       -- Under a forall we look only for occurrences of-       -- the type variable--     -- For kinds, we only do an occurs check; we do not worry-     -- about type families or foralls-     -- See Note [Checking for foralls]-    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs-                     | otherwise                        = ok--     -- no bother about impredicativity in coercions, as they're-     -- inferred-    fast_check_co co | not (gopt Opt_DeferTypeErrors dflags)-                     , badCoercionHoleCo co            = MTVU_HoleBlocker-        -- Wrinkle (4b) in "GHC.Tc.Solver.Canonical" Note [Equalities with incompatible kinds]--                     | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs-                     | otherwise                       = ok--    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+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE BlockArguments      #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | Type subsumption and unification+module GHC.Tc.Utils.Unify (+  -- Full-blown subsumption+  tcWrapResult, tcWrapResultO, tcWrapResultMono,+  tcSkolemise, tcSkolemiseScoped, tcSkolemiseET,+  tcSubType, tcSubTypeSigma, tcSubTypePat,+  tcSubMult,+  checkConstraints, checkTvConstraints,+  buildImplicationFor, buildTvImplication, emitResidualTvConstraint,++  -- Various unifications+  unifyType, unifyKind, unifyExpectedType,+  uType, promoteTcType,+  swapOverTyVars, canSolveByUnification,++  --------------------------------+  -- Holes+  tcInfer,+  matchExpectedListTy,+  matchExpectedTyConApp,+  matchExpectedAppTy,+  matchExpectedFunTys,+  matchExpectedFunKind,+  matchActualFunTySigma, matchActualFunTysRho,++  checkTyVarEq, checkTyFamEq, checkTypeEq++  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Hs+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Ppr( debugPprType )+import GHC.Tc.Utils.TcMType+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcType+import GHC.Tc.Utils.Env+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Multiplicity+import GHC.Tc.Types.Evidence+import GHC.Tc.Types.Constraint+import GHC.Tc.Types.Origin+import GHC.Types.Name( isSystemName )+import GHC.Tc.Utils.Instantiate+import GHC.Core.TyCon+import GHC.Builtin.Types+import GHC.Types.Var as Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Utils.Error+import GHC.Driver.Session+import GHC.Types.Basic+import GHC.Data.Bag+import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic++import GHC.Exts      ( inline )+import Control.Monad+import Control.Arrow ( second )+import qualified Data.Semigroup as S ( (<>) )++{- *********************************************************************+*                                                                      *+              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+           ; mult <- newFlexiTyVarTy multiplicityTy+           ; let unif_fun_ty = mkVisFunTy mult arg_ty res_ty+           ; co <- unifyType mb_thing fun_ty unif_fun_ty+           ; return (mkWpCastN co, Scaled mult arg_ty, res_ty) }++    ------------+    mk_ctxt :: TcType -> TidyEnv -> TcM (TidyEnv, SDoc)+    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 know 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)+++{-+************************************************************************+*                                                                      *+             matchExpected functions+*                                                                      *+************************************************************************++Note [Herald for matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'herald' always looks like:+   "The equation(s) for 'f' have"+   "The abstraction (\x.e) takes"+   "The section (+ x) expects"+   "The function 'f' is applied to"++This is used to construct a message of form++   The abstraction `\Just 1 -> ...' takes two arguments+   but its type `Maybe a -> a' has only one++   The equation(s) for `f' have two arguments+   but its type `Maybe a -> a' has only one++   The section `(f 3)' requires 'f' to take two arguments+   but its type `Int -> Int' has only one++   The function 'f' is applied to two arguments+   but its type `Int -> Int' has only one++When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the+picture, we have a choice in deciding whether to count the type applications as+proper arguments:++   The function 'f' is applied to one visible type argument+     and two value arguments+   but its type `forall a. a -> a` has only one visible type argument+     and one value argument++Or whether to include the type applications as part of the herald itself:++   The expression 'f @Int' is applied to two arguments+   but its type `Int -> Int` has only one++The latter is easier to implement and is arguably easier to understand, so we+choose to implement that option.++Note [matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~+matchExpectedFunTys checks that a sigma has the form+of an n-ary function.  It passes the decomposed type to the+thing_inside, and returns a wrapper to coerce between the two types++It's used wherever a language construct must have a functional type,+namely:+        A lambda expression+        A function definition+     An operator section++This function must be written CPS'd because it needs to fill in the+ExpTypes produced for arguments before it can fill in the ExpType+passed in.++-}++-- Use this one when you have an "expected" type.+-- This function skolemises at each polytype.+matchExpectedFunTys :: forall a.+                       SDoc   -- See Note [Herald for matchExpectedFunTys]+                    -> UserTypeCtxt+                    -> Arity+                    -> ExpRhoType      -- Skolemised+                    -> ([Scaled ExpSigmaType] -> ExpRhoType -> TcM a)+                    -> TcM (HsWrapper, a)+-- If    matchExpectedFunTys n ty = (_, wrap)+-- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,+--   where [t1, ..., tn], ty_r are passed to the thing_inside+matchExpectedFunTys herald ctx arity orig_ty thing_inside+  = case orig_ty of+      Check ty -> go [] arity ty+      _        -> defer [] arity orig_ty+  where+    -- Skolemise any foralls /before/ the zero-arg case+    -- so that we guarantee to return a rho-type+    go acc_arg_tys n ty+      | (tvs, theta, _) <- tcSplitSigmaTy ty+      , not (null tvs && null theta)+      = do { (wrap_gen, (wrap_res, result)) <- tcSkolemise ctx ty $ \ty' ->+                                               go acc_arg_tys n ty'+           ; return (wrap_gen <.> wrap_res, result) }++    -- No more args; do this /before/ tcView, so+    -- that we do not unnecessarily unwrap synonyms+    go acc_arg_tys 0 rho_ty+      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType rho_ty)+           ; return (idHsWrapper, result) }++    go acc_arg_tys n ty+      | Just ty' <- tcView ty = go acc_arg_tys n ty'++    go acc_arg_tys n (FunTy { ft_mult = mult, ft_af = af, ft_arg = arg_ty, ft_res = res_ty })+      = ASSERT( af == VisArg )+        do { (wrap_res, result) <- go ((Scaled mult $ mkCheckExpType arg_ty) : acc_arg_tys)+                                      (n-1) res_ty+           ; let fun_wrap = mkWpFun idHsWrapper wrap_res (Scaled mult arg_ty) res_ty doc+           ; return ( fun_wrap, result ) }+      where+        doc = text "When inferring the argument type of a function with type" <+>+              quotes (ppr orig_ty)++    go acc_arg_tys n ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> go acc_arg_tys n ty'+               Flexi        -> defer acc_arg_tys n (mkCheckExpType 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 acc_arg_tys n ty = addErrCtxtM (mk_ctxt acc_arg_tys ty) $+                          defer acc_arg_tys n (mkCheckExpType ty)++    ------------+    defer :: [Scaled ExpSigmaType] -> Arity -> ExpRhoType -> TcM (HsWrapper, a)+    defer acc_arg_tys n fun_ty+      = do { more_arg_tys <- replicateM n (mkScaled <$> newFlexiTyVarTy multiplicityTy <*> newInferExpType)+           ; res_ty       <- newInferExpType+           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty+           ; more_arg_tys <- mapM (\(Scaled m t) -> Scaled m <$> readExpType t) more_arg_tys+           ; res_ty       <- readExpType res_ty+           ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty+           ; wrap <- tcSubType AppOrigin ctx unif_fun_ty fun_ty+                         -- Not a good origin at all :-(+           ; return (wrap, result) }++    ------------+    mk_ctxt :: [Scaled ExpSigmaType] -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)+    mk_ctxt arg_tys res_ty env+      = mkFunTysMsg env herald arg_tys' res_ty arity+      where+        arg_tys' = map (\(Scaled u v) -> Scaled u (checkingExpType "matchExpectedFunTys" v)) $+                   reverse arg_tys+            -- this is safe b/c we're called from "go"++mkFunTysMsg :: TidyEnv -> SDoc -> [Scaled TcType] -> TcType -> Arity+            -> TcM (TidyEnv, SDoc)+mkFunTysMsg env herald arg_tys res_ty n_val_args_in_call+  = do { (env', fun_rho) <- zonkTidyTcType env $+                            mkVisFunTys arg_tys res_ty++       ; let (all_arg_tys, _) = splitFunTys fun_rho+             n_fun_args = length all_arg_tys++             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])++       ; return (env', msg) }+ where+  full_herald = herald <+> speakNOf n_val_args_in_call (text "value argument")++----------------------+matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)+-- Special case for lists+matchExpectedListTy exp_ty+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty+      ; return (co, elt_ty) }++---------------------+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *+                      -> TcRhoType            -- orig_ty+                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c++-- It's used for wired-in tycons, so we call checkWiredInTyCon+-- Precondition: never called with FunTyCon+-- Precondition: input type :: *+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded++matchExpectedTyConApp tc orig_ty+  = ASSERT(not $ isFunTyCon tc) go orig_ty+  where+    go ty+       | Just ty' <- tcView ty+       = go ty'++    go ty@(TyConApp tycon args)+       | tc == tycon  -- Common case+       = return (mkTcNomReflCo ty, args)++    go (TyVarTy tv)+       | isMetaTyVar tv+       = do { cts <- readMetaTyVar tv+            ; case cts of+                Indirect ty -> go ty+                Flexi       -> defer }++    go _ = defer++    -- If the common case does not occur, instantiate a template+    -- T k1 .. kn t1 .. tm, and unify with the original type+    -- Doing it this way ensures that the types we return are+    -- kind-compatible with T.  For example, suppose we have+    --       matchExpectedTyConApp T (f Maybe)+    -- where data T a = MkT a+    -- Then we don't want to instantiate T's data constructors with+    --    (a::*) ~ Maybe+    -- because that'll make types that are utterly ill-kinded.+    -- This happened in #7368+    defer+      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)+           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)+           ; let args = mkTyVarTys arg_tvs+                 tc_template = mkTyConApp tc args+           ; co <- unifyType Nothing tc_template orig_ty+           ; return (co, args) }++----------------------+matchExpectedAppTy :: TcRhoType                         -- orig_ty+                   -> TcM (TcCoercion,                   -- m a ~N orig_ty+                           (TcSigmaType, TcSigmaType))  -- Returns m, a+-- If the incoming type is a mutable type variable of kind k, then+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.++matchExpectedAppTy orig_ty+  = go orig_ty+  where+    go ty+      | Just ty' <- tcView ty = go ty'++      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty+      = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))++    go (TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty -> go ty+               Flexi       -> defer }++    go _ = defer++    -- Defer splitting by generating an equality constraint+    defer+      = do { ty1 <- newFlexiTyVarTy kind1+           ; ty2 <- newFlexiTyVarTy kind2+           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty+           ; return (co, (ty1, ty2)) }++    orig_kind = tcTypeKind orig_ty+    kind1 = mkVisFunTyMany liftedTypeKind orig_kind+    kind2 = liftedTypeKind    -- m :: * -> k+                              -- arg type :: *++{-+************************************************************************+*                                                                      *+                Subsumption checking+*                                                                      *+************************************************************************++Note [Subsumption checking: tcSubType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All the tcSubType calls have the form+                tcSubType actual_ty expected_ty+which checks+                actual_ty <= expected_ty++That is, that a value of type actual_ty is acceptable in+a place expecting a value of type expected_ty.  I.e. that++    actual ty   is more polymorphic than   expected_ty++It returns a wrapper function+        co_fn :: actual_ty ~ expected_ty+which takes an HsExpr of type actual_ty into one of type+expected_ty.+-}+++-----------------+-- tcWrapResult needs both un-type-checked (for origins and error messages)+-- and type-checked (for wrapping) expressions+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType+             -> TcM (HsExpr GhcTc)+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr++tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTc -> TcSigmaType -> ExpRhoType+               -> TcM (HsExpr GhcTc)+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 (ppr rn_expr)) actual_ty res_ty+       ; return (mkHsWrap wrap expr) }++tcWrapResultMono :: HsExpr GhcRn -> HsExpr GhcTc+                 -> TcRhoType   -- Actual -- a rho-type not a sigma-type+                 -> ExpRhoType  -- Expected+                 -> TcM (HsExpr GhcTc)+-- A version of tcWrapResult to use when the actual type is a+-- rho-type, so nothing to instantiate; just go straight to unify.+-- It means we don't need to pass in a CtOrigin+tcWrapResultMono rn_expr expr act_ty res_ty+  = ASSERT2( isRhoTy act_ty, ppr act_ty $$ ppr rn_expr )+    do { co <- unifyExpectedType rn_expr act_ty res_ty+       ; return (mkHsWrapCo co expr) }++unifyExpectedType :: HsExpr GhcRn+                  -> TcRhoType   -- Actual -- a rho-type not a sigma-type+                  -> ExpRhoType  -- Expected+                  -> TcM TcCoercionN+unifyExpectedType rn_expr act_ty exp_ty+  = case exp_ty of+      Infer inf_res -> fillInferResult act_ty inf_res+      Check exp_ty  -> unifyType (Just (ppr rn_expr)) act_ty exp_ty++------------------------+tcSubTypePat :: CtOrigin -> UserTypeCtxt+            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- Used in patterns; polarity is backwards compared+--   to tcSubType+-- If wrap = tc_sub_type_et t1 t2+--    => wrap :: t1 ~> t2+tcSubTypePat inst_orig ctxt (Check ty_actual) ty_expected+  = do { dflags <- getDynFlags+       ; tc_sub_type dflags unifyTypeET inst_orig ctxt ty_actual ty_expected }++tcSubTypePat _ _ (Infer inf_res) ty_expected+  = do { co <- fillInferResult ty_expected inf_res+               -- In patterns we do not instantatiate++       ; return (mkWpCastN (mkTcSymCo co)) }++---------------+tcSubType :: CtOrigin -> UserTypeCtxt+          -> TcSigmaType  -- Actual+          -> ExpRhoType   -- Expected+          -> TcM HsWrapper+-- Checks that 'actual' is more polymorphic than 'expected'+tcSubType orig ctxt ty_actual ty_expected+  = addSubTypeCtxt ty_actual ty_expected $+    do { traceTc "tcSubType" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])+       ; tcSubTypeNC orig ctxt Nothing ty_actual ty_expected }++tcSubTypeNC :: CtOrigin       -- Used when instantiating+            -> UserTypeCtxt   -- Used when skolemising+            -> Maybe SDoc     -- The expression that has type 'actual' (if known)+            -> TcSigmaType            -- Actual type+            -> ExpRhoType             -- Expected type+            -> TcM HsWrapper+tcSubTypeNC inst_orig ctxt m_thing ty_actual res_ty+  = case res_ty of+      Check ty_expected -> do { dflags <- getDynFlags+                              ; tc_sub_type dflags (unifyType m_thing) inst_orig ctxt+                                            ty_actual ty_expected }++      Infer inf_res -> do { (wrap, rho) <- topInstantiate inst_orig ty_actual+                                   -- See Note [Instantiation of InferResult]+                          ; co <- fillInferResult rho inf_res+                          ; return (mkWpCastN co <.> wrap) }++{- Note [Instantiation of InferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We now always instantiate before filling in InferResult, so that+the result is a TcRhoType: see #17173 for discussion.++For example:++1. Consider+    f x = (*)+   We want to instantiate the type of (*) before returning, else we+   will infer the type+     f :: forall {a}. a -> forall b. Num b => b -> b -> b+   This is surely confusing for users.++   And worse, the monomorphism restriction won't work properly. The MR is+   dealt with in simplifyInfer, and simplifyInfer has no way of+   instantiating. This could perhaps be worked around, but it may be+   hard to know even when instantiation should happen.++2. Another reason.  Consider+       f :: (?x :: Int) => a -> a+       g y = let ?x = 3::Int in f+   Here want to instantiate f's type so that the ?x::Int constraint+   gets discharged by the enclosing implicit-parameter binding.++3. Suppose one defines plus = (+). If we instantiate lazily, we will+   infer plus :: forall a. Num a => a -> a -> a. However, the monomorphism+   restriction compels us to infer+      plus :: Integer -> Integer -> Integer+   (or similar monotype). Indeed, the only way to know whether to apply+   the monomorphism restriction at all is to instantiate++There is one place where we don't want to instantiate eagerly,+namely in GHC.Tc.Module.tcRnExpr, which implements GHCi's :type+command. See Note [Implementing :type] in GHC.Tc.Module.+-}++---------------+tcSubTypeSigma :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- External entry point, but no ExpTypes on either side+-- Checks that actual <= expected+-- Returns HsWrapper :: actual ~ expected+tcSubTypeSigma ctxt ty_actual ty_expected+  = do { dflags <- getDynFlags+       ; tc_sub_type dflags (unifyType Nothing) eq_orig ctxt ty_actual ty_expected }+  where+    eq_orig = TypeEqOrigin { uo_actual   = ty_actual+                           , uo_expected = ty_expected+                           , uo_thing    = Nothing+                           , uo_visible  = True }++---------------+tc_sub_type :: DynFlags+            -> (TcType -> TcType -> TcM TcCoercionN)  -- How to unify+            -> CtOrigin       -- Used when instantiating+            -> UserTypeCtxt   -- Used when skolemising+            -> TcSigmaType    -- Actual; a sigma-type+            -> TcSigmaType    -- Expected; also a sigma-type+            -> TcM HsWrapper+-- Checks that actual_ty is more polymorphic than expected_ty+-- If wrap = tc_sub_type t1 t2+--    => wrap :: t1 ~> t2+tc_sub_type dflags unify inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]+  , not (possibly_poly ty_actual)+  = do { traceTc "tc_sub_type (drop to equality)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; mkWpCastN <$>+         unify ty_actual ty_expected }++  | otherwise   -- This is the general case+  = do { traceTc "tc_sub_type (general case)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]++       ; (sk_wrap, inner_wrap)+           <- tcSkolemise ctxt ty_expected $ \ sk_rho ->+              do { (wrap, rho_a) <- topInstantiate inst_orig ty_actual+                 ; cow           <- unify rho_a sk_rho+                 ; return (mkWpCastN cow <.> wrap) }++       ; return (sk_wrap <.> inner_wrap) }+  where+    possibly_poly ty = not (isRhoTy ty)++    definitely_poly ty+      | (tvs, theta, tau) <- tcSplitSigmaTy ty+      , (tv:_) <- tvs+      , null theta+      , checkTyVarEq dflags tv tau `cterHasProblem` cteInsolubleOccurs+      = True+      | otherwise+      = False++------------------------+addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a+addSubTypeCtxt ty_actual ty_expected thing_inside+ | isRhoTy ty_actual        -- If there is no polymorphism involved, the+ , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)+ = thing_inside             -- gives enough context by itself+ | otherwise+ = addErrCtxtM mk_msg thing_inside+  where+    mk_msg tidy_env+      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual+                   -- might not be filled if we're debugging. ugh.+           ; mb_ty_expected          <- readExpType_maybe ty_expected+           ; (tidy_env, ty_expected) <- case mb_ty_expected of+                                          Just ty -> second mkCheckExpType <$>+                                                     zonkTidyTcType tidy_env ty+                                          Nothing -> return (tidy_env, ty_expected)+           ; ty_expected             <- readExpType ty_expected+           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected+           ; let msg = vcat [ hang (text "When checking that:")+                                 4 (ppr ty_actual)+                            , nest 2 (hang (text "is more polymorphic than:")+                                         2 (ppr ty_expected)) ]+           ; return (tidy_env, msg) }++{- Note [Don't skolemise unnecessarily]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are trying to solve+    (Char->Char) <= (forall a. a->a)+We could skolemise the 'forall a', and then complain+that (Char ~ a) is insoluble; but that's a pretty obscure+error.  It's better to say that+    (Char->Char) ~ (forall a. a->a)+fails.++So roughly:+ * if the ty_expected has an outermost forall+      (i.e. skolemisation is the next thing we'd do)+ * and the ty_actual has no top-level polymorphism (but looking deeply)+then we can revert to simple equality.  But we need to be careful.+These examples are all fine:++ * (Char->Char) <= (forall a. Char -> Char)+      ty_expected isn't really polymorphic++ * (Char->Char) <= (forall a. (a~Char) => a -> a)+      ty_expected isn't really polymorphic++ * (Char->Char) <= (forall a. F [a] Char -> Char)+                   where type instance F [x] t = t+     ty_expected isn't really polymorphic++If we prematurely go to equality we'll reject a program we should+accept (e.g. #13752).  So the test (which is only to improve+error message) is very conservative:+ * ty_actual is /definitely/ monomorphic+ * ty_expected is /definitely/ polymorphic++Note [Settting the argument context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we are doing the ambiguity check for the (bogus)+  f :: (forall a b. C b => a -> a) -> Int++We'll call+   tcSubType ((forall a b. C b => a->a) -> Int )+             ((forall a b. C b => a->a) -> Int )++with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing+on the argument type of the (->) -- and at that point we want to switch+to a UserTypeCtxt of GenSigCtxt.  Why?++* Error messages.  If we stick with FunSigCtxt we get errors like+     * Could not deduce: C b+       from the context: C b0+        bound by the type signature for:+            f :: forall a b. C b => a->a+  But of course f does not have that type signature!+  Example tests: T10508, T7220a, Simple14++* Implications. We may decide to build an implication for the whole+  ambiguity check, but we don't need one for each level within it,+  and GHC.Tc.Utils.Unify.alwaysBuildImplication checks the UserTypeCtxt.+  See Note [When to build an implication]++Note [Wrapper returned from tcSubMult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is no notion of multiplicity coercion in Core, therefore the wrapper+returned by tcSubMult (and derived functions such as tcCheckUsage and+checkManyPattern) is quite unlike any other wrapper: it checks whether the+coercion produced by the constraint solver is trivial, producing a type error+is it is not. This is implemented via the WpMultCoercion wrapper, as desugared+by GHC.HsToCore.Binds.dsHsWrapper, which does the reflexivity check.++This wrapper needs to be placed in the term; otherwise, checking of the+eventual coercion won't be triggered during desugaring. But it can be put+anywhere, since it doesn't affect the desugared code.++Why do we check this in the desugarer? It's a convenient place, since it's+right after all the constraints are solved. We need the constraints to be+solved to check whether they are trivial or not. Plus there is precedent for+type errors during desuraging (such as the levity polymorphism+restriction). An alternative would be to have a kind of constraint which can+only produce trivial evidence, then this check would happen in the constraint+solver.+-}++tcSubMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper+tcSubMult origin w_actual w_expected+  | Just (w1, w2) <- isMultMul w_actual =+  do { w1 <- tcSubMult origin w1 w_expected+     ; w2 <- tcSubMult origin w2 w_expected+     ; return (w1 <.> w2) }+  -- Currently, we consider p*q and sup p q to be equal.  Therefore, p*q <= r is+  -- equivalent to p <= r and q <= r.  For other cases, we approximate p <= q by p+  -- ~ q.  This is not complete, but it's sound. See also Note [Overapproximating+  -- multiplicities] in Multiplicity.+tcSubMult origin w_actual w_expected =+  case submult w_actual w_expected of+    Submult -> return WpHole+    Unknown -> tcEqMult origin w_actual w_expected++tcEqMult :: CtOrigin -> Mult -> Mult -> TcM HsWrapper+tcEqMult origin w_actual w_expected = do+  {+  -- Note that here we do not call to `submult`, so we check+  -- for strict equality.+  ; coercion <- uType TypeLevel origin w_actual w_expected+  ; return $ if isReflCo coercion then WpHole else WpMultCoercion coercion }+++{- *********************************************************************+*                                                                      *+                    Generalisation+*                                                                      *+********************************************************************* -}++{- Note [Skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~+tcSkolemise takes "expected type" and strip off quantifiers to expose the+type underneath, binding the new skolems for the 'thing_inside'+The returned 'HsWrapper' has type (specific_ty -> expected_ty).++Note that for a nested type like+   forall a. Eq a => forall b. Ord b => blah+we still only build one implication constraint+   forall a b. (Eq a, Ord b) => <constraints>+This is just an optimisation, but it's why we use topSkolemise to+build the pieces from all the layers, before making a single call+to checkConstraints.++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 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+  that must not be allowed to float to top level.+  See Note [When to build an implication] below.+-}++tcSkolemise, tcSkolemiseScoped+    :: UserTypeCtxt -> TcSigmaType+    -> (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+       ; let skol_tvs  = map snd tv_prs+             skol_info = SigSkol ctxt expected_ty tv_prs++       ; (ev_binds, res)+             <- checkConstraints skol_info skol_tvs given $+                tcExtendNameTyVarEnv tv_prs               $+                thing_inside rho_ty++       ; return (wrap <.> mkWpLet ev_binds, res) }++tcSkolemise ctxt expected_ty thing_inside+  | isRhoTy expected_ty  -- Short cut for common case+  = do { res <- thing_inside expected_ty+       ; return (idHsWrapper, res) }+  | otherwise+  = do  { (wrap, tv_prs, given, rho_ty) <- topSkolemise expected_ty++        ; let skol_tvs  = map snd tv_prs+              skol_info = SigSkol ctxt expected_ty tv_prs++        ; (ev_binds, result)+              <- checkConstraints skol_info skol_tvs given $+                 thing_inside rho_ty++        ; return (wrap <.> mkWpLet ev_binds, result) }+          -- The ev_binds returned by checkConstraints is very+          -- often empty, in which case mkWpLet is a no-op++-- | Variant of 'tcSkolemise' that takes an ExpType+tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType+              -> (ExpRhoType -> TcM result)+              -> TcM (HsWrapper, result)+tcSkolemiseET _ et@(Infer {}) thing_inside+  = (idHsWrapper, ) <$> thing_inside et+tcSkolemiseET ctxt (Check ty) thing_inside+  = tcSkolemise ctxt ty $ \rho_ty ->+    thing_inside (mkCheckExpType rho_ty)++checkConstraints :: SkolemInfo+                 -> [TcTyVar]           -- Skolems+                 -> [EvVar]             -- Given+                 -> TcM result+                 -> TcM (TcEvBinds, result)++checkConstraints skol_info skol_tvs given thing_inside+  = do { implication_needed <- implicationNeeded skol_info skol_tvs given++       ; if implication_needed+         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted+                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)+                 ; emitImplications implics+                 ; return (ev_binds, result) }++         else -- Fast path.  We check every function argument with tcCheckPolyExpr,+              -- which uses tcSkolemise and hence checkConstraints.+              -- So this fast path is well-exercised+              do { res <- thing_inside+                 ; return (emptyTcEvBinds, res) } }++checkTvConstraints :: SkolemInfo+                   -> [TcTyVar]          -- Skolem tyvars+                   -> TcM result+                   -> TcM result++checkTvConstraints skol_info skol_tvs thing_inside+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+       ; emitResidualTvConstraint skol_info skol_tvs tclvl wanted+       ; return result }++emitResidualTvConstraint :: SkolemInfo -> [TcTyVar]+                         -> TcLevel -> WantedConstraints -> TcM ()+emitResidualTvConstraint skol_info skol_tvs tclvl wanted+  | not (isEmptyWC wanted) ||+    checkTelescopeSkol skol_info+  = -- checkTelescopeSkol: in this case, /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] in+    -- GHC.Tc.Gen.HsType+    do { implic <- buildTvImplication skol_info skol_tvs tclvl wanted+       ; emitImplication implic }++  | otherwise  -- Empty 'wanted', emit nothing+  = return ()++buildTvImplication :: SkolemInfo -> [TcTyVar]+                   -> TcLevel -> WantedConstraints -> TcM Implication+buildTvImplication skol_info skol_tvs tclvl wanted+  = do { ev_binds <- newNoTcEvBinds  -- Used for equalities only, so all the constraints+                                     -- are solved by filling in coercion holes, not+                                     -- by creating a value-level evidence binding+       ; implic   <- newImplication++       ; return (implic { ic_tclvl     = tclvl+                        , ic_skols     = skol_tvs+                        , ic_given_eqs = NoGivenEqs+                        , ic_wanted    = wanted+                        , ic_binds     = ev_binds+                        , ic_info      = skol_info }) }++implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool+-- See Note [When to build an implication]+implicationNeeded skol_info skol_tvs given+  | null skol_tvs+  , null given+  , not (alwaysBuildImplication skol_info)+  = -- Empty skolems and givens+    do { tc_lvl <- getTcLevel+       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are+         then return False             -- already inside an implication+         else+    do { dflags <- getDynFlags       -- If any deferral can happen,+                                     -- we must build an implication+       ; return (gopt Opt_DeferTypeErrors dflags ||+                 gopt Opt_DeferTypedHoles dflags ||+                 gopt Opt_DeferOutOfScopeVariables dflags) } }++  | otherwise     -- Non-empty skolems or givens+  = return True   -- Definitely need an implication++alwaysBuildImplication :: SkolemInfo -> Bool+-- See Note [When to build an implication]+alwaysBuildImplication _ = False++{-  Commmented out for now while I figure out about error messages.+    See #14185++alwaysBuildImplication (SigSkol ctxt _ _)+  = case ctxt of+      FunSigCtxt {} -> True  -- RHS of a binding with a signature+      _             -> False+alwaysBuildImplication (RuleSkol {})      = True+alwaysBuildImplication (InstSkol {})      = True+alwaysBuildImplication (FamInstSkol {})   = True+alwaysBuildImplication _                  = False+-}++buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]+                   -> [EvVar] -> WantedConstraints+                   -> TcM (Bag Implication, TcEvBinds)+buildImplicationFor tclvl skol_info skol_tvs given wanted+  | isEmptyWC wanted && null given+             -- Optimisation : if there are no wanteds, and no givens+             -- don't generate an implication at all.+             -- Reason for the (null given): we don't want to lose+             -- the "inaccessible alternative" error check+  = return (emptyBag, emptyTcEvBinds)++  | otherwise+  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )+      -- Why allow TyVarTvs? Because implicitly declared kind variables in+      -- non-CUSK type declarations are TyVarTvs, and we need to bring them+      -- into scope as a skolem in an implication. This is OK, though,+      -- because TyVarTvs will always remain tyvars, even after unification.+    do { ev_binds_var <- newTcEvBinds+       ; implic <- newImplication+       ; let implic' = implic { ic_tclvl  = tclvl+                              , ic_skols  = skol_tvs+                              , ic_given  = given+                              , ic_wanted = wanted+                              , ic_binds  = ev_binds_var+                              , ic_info   = skol_info }++       ; return (unitBag implic', TcEvBinds ev_binds_var) }++{- Note [When to build an implication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have some 'skolems' and some 'givens', and we are+considering whether to wrap the constraints in their scope into an+implication.  We must /always/ so if either 'skolems' or 'givens' are+non-empty.  But what if both are empty?  You might think we could+always drop the implication.  Other things being equal, the fewer+implications the better.  Less clutter and overhead.  But we must+take care:++* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,+  we'll make a /term-level/ evidence binding for 'g = error "blah"'.+  We must have an EvBindsVar those bindings!, otherwise they end up as+  top-level unlifted bindings, which are verboten. This only matters+  at top level, so we check for that+  See also Note [Deferred errors for coercion holes] in GHC.Tc.Errors.+  cf #14149 for an example of what goes wrong.++* If you have+     f :: Int;  f = f_blah+     g :: Bool; g = g_blah+  If we don't build an implication for f or g (no tyvars, no givens),+  the constraints for f_blah and g_blah are solved together.  And that+  can yield /very/ confusing error messages, because we can get+      [W] C Int b1    -- from f_blah+      [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 separate.+-}++{-+************************************************************************+*                                                                      *+                Boxy unification+*                                                                      *+************************************************************************++The exported functions are all defined as versions of some+non-exported generic functions.+-}++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+  = uType TypeLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual   = ty1+                          , uo_expected = ty2+                          , uo_thing    = ppr <$> thing+                          , uo_visible  = True }++unifyTypeET :: TcTauType -> TcTauType -> TcM CoercionN+-- Like unifyType, but swap expected and actual in error messages+-- This is used when typechecking patterns+unifyTypeET ty1 ty2+  = uType TypeLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual   = ty2   -- NB swapped+                          , uo_expected = ty1   -- NB swapped+                          , uo_thing    = Nothing+                          , uo_visible  = True }+++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    = mb_thing+                          , uo_visible  = True }+++{-+%************************************************************************+%*                                                                      *+                 uType and friends+%*                                                                      *+%************************************************************************++uType is the heart of the unifier.+-}++uType, uType_defer+  :: TypeOrKind+  -> CtOrigin+  -> TcType    -- ty1 is the *actual* type+  -> TcType    -- ty2 is the *expected* type+  -> TcM CoercionN++--------------+-- It is always safe to defer unification to the main constraint solver+-- See Note [Deferred unification]+uType_defer t_or_k origin ty1 ty2+  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2++       -- Error trace only+       -- NB. do *not* call mkErrInfo unless tracing is on,+       --     because it is hugely expensive (#5631)+       ; whenDOptM Opt_D_dump_tc_trace $ do+            { ctxt <- getErrCtxt+            ; doc <- mkErrInfo emptyTidyEnv ctxt+            ; traceTc "utype_defer" (vcat [ debugPprType ty1+                                          , debugPprType ty2+                                          , pprCtOrigin origin+                                          , doc])+            ; traceTc "utype_defer2" (ppr co)+            }+       ; return co }++--------------+uType t_or_k origin orig_ty1 orig_ty2+  = do { tclvl <- getTcLevel+       ; traceTc "u_tys" $ vcat+              [ text "tclvl" <+> ppr tclvl+              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]+              , pprCtOrigin origin]+       ; co <- go orig_ty1 orig_ty2+       ; if isReflCo co+            then traceTc "u_tys yields no coercion" Outputable.empty+            else traceTc "u_tys yields coercion:" (ppr co)+       ; return co }+  where+    go :: TcType -> TcType -> TcM CoercionN+        -- The arguments to 'go' are always semantically identical+        -- to orig_ty{1,2} except for looking through type synonyms++     -- Unwrap casts before looking for variables. This way, we can easily+     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we+     -- didn't do it this way, and then the unification above was deferred.+    go (CastTy t1 co1) t2+      = do { co_tys <- uType t_or_k origin t1 t2+           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }++    go t1 (CastTy t2 co2)+      = do { co_tys <- uType t_or_k origin t1 t2+           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }++        -- Variables; go for uUnfilledVar+        -- Note that we pass in *original* (before synonym expansion),+        -- so that type variables tend to get filled in with+        -- the most informative version of the type+    go (TyVarTy tv1) ty2+      = do { lookup_res <- isFilledMetaTyVar_maybe tv1+           ; case lookup_res of+               Just ty1 -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)+                                ; go ty1 ty2 }+               Nothing  -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }+    go ty1 (TyVarTy tv2)+      = do { lookup_res <- isFilledMetaTyVar_maybe tv2+           ; case lookup_res of+               Just ty2 -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)+                              ; go ty1 ty2 }+               Nothing  -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }++      -- See Note [Expanding synonyms during unification]+    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = return $ mkNomReflCo ty1++        -- See Note [Expanding synonyms during unification]+        --+        -- Also NB that we recurse to 'go' so that we don't push a+        -- new item on the origin stack. As a result if we have+        --   type Foo = Int+        -- and we try to unify  Foo ~ Bool+        -- we'll end up saying "can't match Foo with Bool"+        -- rather than "can't match "Int with Bool".  See #4535.+    go ty1 ty2+      | Just ty1' <- tcView ty1 = go ty1' ty2+      | Just ty2' <- tcView ty2 = go ty1  ty2'++    -- 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 }++        -- Always defer if a type synonym family (type function)+        -- is involved.  (Data families behave rigidly.)+    go ty1@(TyConApp tc1 _) ty2+      | isTypeFamilyTyCon tc1 = defer ty1 ty2+    go ty1 ty2@(TyConApp tc2 _)+      | isTypeFamilyTyCon tc2 = defer ty1 ty2++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      -- See Note [Mismatched type lists and application decomposition]+      | tc1 == tc2, equalLength tys1 tys2+      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )+        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2+           ; return $ mkTyConAppCo Nominal tc1 cos }+      where+        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)+                       (tcTyConVisibilities tc1)++    go (LitTy m) ty@(LitTy n)+      | m == n+      = return $ mkNomReflCo ty++        -- See Note [Care with type applications]+        -- Do not decompose FunTy against App;+        -- it's often a type error, so leave it for the constraint solver+    go (AppTy s1 t1) (AppTy s2 t2)+      = go_app (isNextArgVisible s1) s1 t1 s2 t2++    go (AppTy s1 t1) (TyConApp tc2 ts2)+      | Just (ts2', t2') <- snocView ts2+      = ASSERT( not (mustBeSaturated tc2) )+        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'++    go (TyConApp tc1 ts1) (AppTy s2 t2)+      | Just (ts1', t1') <- snocView ts1+      = ASSERT( not (mustBeSaturated tc1) )+        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2++    go (CoercionTy co1) (CoercionTy co2)+      = do { let ty1 = coercionType co1+                 ty2 = coercionType co2+           ; kco <- uType KindLevel+                          (KindEqOrigin orig_ty1 orig_ty2 origin+                                        (Just t_or_k))+                          ty1 ty2+           ; return $ mkProofIrrelCo Nominal kco co1 co2 }++        -- Anything else fails+        -- E.g. unifying for-all types, which is relative unusual+    go ty1 ty2 = defer ty1 ty2++    ------------------+    defer ty1 ty2   -- See Note [Check for equality before deferring]+      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)+      | otherwise          = uType_defer t_or_k origin ty1 ty2++    ------------------+    go_app vis s1 t1 s2 t2+      = do { co_s <- uType t_or_k origin s1 s2+           ; let arg_origin+                   | vis       = origin+                   | otherwise = toInvisibleOrigin origin+           ; co_t <- uType t_or_k arg_origin t1 t2+           ; return $ mkAppCo co_s co_t }++{- Note [Check for equality before deferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Particularly in ambiguity checks we can get equalities like (ty ~ ty).+If ty involves a type function we may defer, which isn't very sensible.+An egregious example of this was in test T9872a, which has a type signature+       Proxy :: Proxy (Solutions Cubes)+Doing the ambiguity check on this signature generates the equality+   Solutions Cubes ~ Solutions Cubes+and currently the constraint solver normalises both sides at vast cost.+This little short-cut in 'defer' helps quite a bit.++Note [Care with type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note: type applications need a bit of care!+They can match FunTy and TyConApp, so use splitAppTy_maybe+NB: we've already dealt with type variables and Notes,+so if one type is an App the other one jolly well better be too++Note [Mismatched type lists and application decomposition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we find two TyConApps, you might think that the argument lists+are guaranteed equal length.  But they aren't. Consider matching+        w (T x) ~ Foo (T x y)+We do match (w ~ Foo) first, but in some circumstances we simply create+a deferred constraint; and then go ahead and match (T x ~ T x y).+This came up in #3950.++So either+   (a) either we must check for identical argument kinds+       when decomposing applications,++   (b) or we must be prepared for ill-kinded unification sub-problems++Currently we adopt (b) since it seems more robust -- no need to maintain+a global invariant.++Note [Expanding synonyms during unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We expand synonyms during unification, but:+ * We expand *after* the variable case so that we tend to unify+   variables with un-expanded type synonym. This just makes it+   more likely that the inferred types will mention type synonyms+   understandable to the user++ * Similarly, we expand *after* the CastTy case, just in case the+   CastTy wraps a variable.++ * We expand *before* the TyConApp case.  For example, if we have+      type Phantom a = Int+   and are unifying+      Phantom Int ~ Phantom Char+   it is *wrong* to unify Int and Char.++ * The problem case immediately above can happen only with arguments+   to the tycon. So we check for nullary tycons *before* expanding.+   This is particularly helpful when checking (* ~ *), because * is+   now a type synonym.++Note [Deferred unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,+and yet its consistency is undetermined. Previously, there was no way to still+make it consistent. So a mismatch error was issued.++Now these unifications are deferred until constraint simplification, where type+family instances and given equations may (or may not) establish the consistency.+Deferred unifications are of the form+                F ... ~ ...+or              x ~ ...+where F is a type function and x is a type variable.+E.g.+        id :: x ~ y => x -> y+        id e = e++involves the unification x = y. It is deferred until we bring into account the+context x ~ y to establish that it holds.++If available, we defer original types (rather than those where closed type+synonyms have already been expanded via tcCoreView).  This is, as usual, to+improve error messages.+++************************************************************************+*                                                                      *+                 uUnfilledVar and friends+*                                                                      *+************************************************************************++@uunfilledVar@ is called when at least one of the types being unified is a+variable.  It does {\em not} assume that the variable is a fixed point+of the substitution; rather, notice that @uVar@ (defined below) nips+back into @uTys@ if it turns out that the variable is already bound.+-}++----------+uUnfilledVar :: CtOrigin+             -> TypeOrKind+             -> SwapFlag+             -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                               --    definitely not a /filled/ meta-tyvar+             -> TcTauType      -- Type 2+             -> TcM Coercion+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar+--            It might be a skolem, or untouchable, or meta++uUnfilledVar origin t_or_k swapped tv1 ty2+  = do { ty2 <- zonkTcType ty2+             -- Zonk to expose things to the+             -- occurs check, and so that if ty2+             -- looks like a type variable then it+             -- /is/ a type variable+       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }++----------+uUnfilledVar1 :: CtOrigin+              -> TypeOrKind+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                                --    definitely not a /filled/ meta-tyvar+              -> TcTauType      -- Type 2, zonked+              -> TcM Coercion+uUnfilledVar1 origin t_or_k swapped tv1 ty2+  | Just tv2 <- tcGetTyVar_maybe ty2+  = go tv2++  | otherwise+  = uUnfilledVar2 origin t_or_k swapped tv1 ty2++  where+    -- 'go' handles the case where both are+    -- tyvars so we might want to swap+    -- E.g. maybe tv2 is a meta-tyvar and tv1 is not+    go tv2 | tv1 == tv2  -- Same type variable => no-op+           = return (mkNomReflCo (mkTyVarTy tv1))++           | swapOverTyVars False tv1 tv2   -- Distinct type variables+               -- Swap meta tyvar to the left if poss+           = do { tv1 <- zonkTyCoVarKind tv1+                     -- We must zonk tv1's kind because that might+                     -- not have happened yet, and it's an invariant of+                     -- uUnfilledTyVar2 that ty2 is fully zonked+                     -- Omitting this caused #16902+                ; uUnfilledVar2 origin t_or_k (flipSwap swapped)+                           tv2 (mkTyVarTy tv1) }++           | otherwise+           = uUnfilledVar2 origin t_or_k swapped tv1 ty2++----------+uUnfilledVar2 :: CtOrigin+              -> TypeOrKind+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1: not necessarily a meta-tyvar+                                --    definitely not a /filled/ meta-tyvar+              -> TcTauType      -- Type 2, zonked+              -> TcM Coercion+uUnfilledVar2 origin t_or_k swapped tv1 ty2+  = do { dflags  <- getDynFlags+       ; cur_lvl <- getTcLevel+       ; go dflags cur_lvl }+  where+    go dflags cur_lvl+      | isTouchableMetaTyVar cur_lvl tv1+           -- See Note [Unification preconditions], (UNTOUCHABLE) wrinkles+      , canSolveByUnification (metaTyVarInfo tv1) ty2+      , cterHasNoProblem (checkTyVarEq dflags tv1 ty2)+           -- See Note [Prevent unification with type families]+      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2) (tyVarKind tv1)+           ; traceTc "uUnfilledVar2 ok" $+             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)+                  , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)+                  , ppr (isTcReflCo co_k), ppr co_k ]++           ; if isTcReflCo co_k+               -- Only proceed if the kinds match+               -- NB: tv1 should still be unfilled, despite the kind unification+               --     because tv1 is not free in ty2 (or, hence, in its kind)+             then do { writeMetaTyVar tv1 ty2+                     ; return (mkTcNomReflCo ty2) }++             else defer } -- This cannot be solved now.  See GHC.Tc.Solver.Canonical+                          -- Note [Equalities with incompatible kinds]++      | otherwise+      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)+               -- Occurs check or an untouchable: just defer+               -- NB: occurs check isn't necessarily fatal:+               --     eg tv1 occurred in type family parameter+            ; defer }++    ty1 = mkTyVarTy tv1+    kind_origin = KindEqOrigin ty1 ty2 origin (Just t_or_k)++    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2++canSolveByUnification :: MetaInfo -> TcType -> Bool+-- See Note [Unification preconditions, (TYVAR-TV)]+canSolveByUnification info xi+  = case info of+      CycleBreakerTv -> False+      TyVarTv -> case tcGetTyVar_maybe xi of+                   Nothing -> False+                   Just tv -> case tcTyVarDetails tv of+                                 MetaTv { mtv_info = info }+                                            -> case info of+                                                 TyVarTv -> True+                                                 _       -> False+                                 SkolemTv {} -> True+                                 RuntimeUnk  -> True+      _ -> True++swapOverTyVars :: Bool -> TcTyVar -> TcTyVar -> Bool+swapOverTyVars is_given tv1 tv2+  -- See Note [Unification variables on the left]+  | not is_given, pri1 == 0, pri2 > 0 = True+  | not is_given, pri2 == 0, pri1 > 0 = False++  -- Level comparison: see Note [TyVar/TyVar orientation]+  | lvl1 `strictlyDeeperThan` lvl2 = False+  | lvl2 `strictlyDeeperThan` lvl1 = True++  -- Priority: see Note [TyVar/TyVar orientation]+  | pri1 > pri2 = False+  | pri2 > pri1 = True++  -- Names: see Note [TyVar/TyVar orientation]+  | isSystemName tv2_name, not (isSystemName tv1_name) = True++  | otherwise = False++  where+    lvl1 = tcTyVarLevel tv1+    lvl2 = tcTyVarLevel tv2+    pri1 = lhsPriority tv1+    pri2 = lhsPriority tv2+    tv1_name = Var.varName tv1+    tv2_name = Var.varName tv2+++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)+    case tcTyVarDetails tv of+      RuntimeUnk  -> 0+      SkolemTv {} -> 0+      MetaTv { mtv_info = info } -> case info of+                                     CycleBreakerTv -> 0+                                     TyVarTv        -> 1+                                     TauTv          -> 2+                                     RuntimeUnkTv   -> 3++{- Note [Unification preconditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Question: given a homogeneous equality (alpha ~# ty), when is it OK to+unify alpha := ty?++This note only applied to /homogeneous/ equalities, in which both+sides have the same kind.++There are three reasons not to unify:++1. (SKOL-ESC) Skolem-escape+   Consider the constraint+        forall[2] a[2]. alpha[1] ~ Maybe a[2]+   If we unify alpha := Maybe a, the skolem 'a' may escape its scope.+   The level alpha[1] says that alpha may be used outside this constraint,+   where 'a' is not in scope at all.  So we must not unify.++   Bottom line: when looking at a constraint alpha[n] := ty, do not unify+   if any free variable of 'ty' has level deeper (greater) than n++2. (UNTOUCHABLE) Untouchable unification variables+   Consider the constraint+        forall[2] a[2]. b[1] ~ Int => alpha[1] ~ Int+   There is no (SKOL-ESC) problem with unifying alpha := Int, but it might+   not be the principal solution. Perhaps the "right" solution is alpha := b.+   We simply can't tell.  See "OutsideIn(X): modular type inference with local+   assumptions", section 2.2.  We say that alpha[1] is "untouchable" inside+   this implication.++   Bottom line: at amibient level 'l', when looking at a constraint+   alpha[n] ~ ty, do not unify alpha := ty if there are any given equalities+   between levels 'n' and 'l'.++   Exactly what is a "given equality" for the purpose of (UNTOUCHABLE)?+   Answer: see Note [Tracking Given equalities] in GHC.Tc.Solver.Monad++3. (TYVAR-TV) Unifying TyVarTvs and CycleBreakerTvs+   This precondition looks at the MetaInfo of the unification variable:++   * TyVarTv: When considering alpha{tyv} ~ ty, if alpha{tyv} is a+     TyVarTv it can only unify with a type variable, not with a+     structured type.  So if 'ty' is a structured type, such as (Maybe x),+     don't unify.++   * CycleBreakerTv: never unified, except by restoreTyVarCycles.+++Needless to say, all three have wrinkles:++* (SKOL-ESC) Promotion.  Given alpha[n] ~ ty, what if beta[k] is free+  in 'ty', where beta is a unification variable, and k>n?  'beta'+  stands for a monotype, and since it is part of a level-n type+  (equal to alpha[n]), we must /promote/ beta to level n.  Just make+  up a fresh gamma[n], and unify beta[k] := gamma[n].++* (TYVAR-TV) Unification variables.  Suppose alpha[tyv,n] is a level-n+  TyVarTv (see Note [TyVarTv] in GHC.Tc.Types.TcMType)? Now+  consider alpha[tyv,n] ~ Bool.  We don't want to unify because that+  would break the TyVarTv invariant.++  What about alpha[tyv,n] ~ beta[tau,n], where beta is an ordinary+  TauTv?  Again, don't unify, because beta might later be unified+  with, say Bool.  (If levels permit, we reverse the orientation here;+  see Note [TyVar/TyVar orientation].)++* (UNTOUCHABLE) Untouchability.  When considering (alpha[n] ~ ty), how+  do we know whether there are any given equalities between level n+  and the ambient level?  We answer in two ways:++  * In the eager unifier, we only unify if l=n.  If not, alpha may be+    untouchable, and defer to the constraint solver.  This check is+    made in GHC.Tc.Utils.uUnifilledVar2, in the guard+    isTouchableMetaTyVar.++  * In the constraint solver, we track where Given equalities occur+    and use that to guard unification in GHC.Tc.Solver.Canonical.unifyTest+    More details in Note [Tracking Given equalities] in GHC.Tc.Solver.InertSet++    Historical note: in the olden days (pre 2021) the constraint solver+    also used to unify only if l=n.  Equalities were "floated" out of the+    implication in a separate step, so that they would become touchable.+    But the float/don't-float question turned out to be very delicate,+    as you can see if you look at the long series of Notes associated with+    GHC.Tc.Solver.floatEqualities, around Nov 2020.  It's much easier+    to unify in-place, with no floating.++Note [TyVar/TyVar orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (a ~ b), should we orient the CEqCan as (a~b) or (b~a)?+This is a surprisingly tricky question! This is invariant (TyEq:TV).++The question is answered by swapOverTyVars, which is used+  - in the eager unifier, in GHC.Tc.Utils.Unify.uUnfilledVar1+  - in the constraint solver, in GHC.Tc.Solver.Canonical.canEqCanLHS2++First note: only swap if you have to!+   See Note [Avoid unnecessary swaps]++So we look for a positive reason to swap, using a three-step test:++* Level comparison. If 'a' has deeper level than 'b',+  put 'a' on the left.  See Note [Deeper level on the left]++* Priority.  If the levels are the same, look at what kind of+  type variable it is, using 'lhsPriority'.++  Generally speaking we always try to put a MetaTv on the left+  in preference to SkolemTv or RuntimeUnkTv:+     a) Because the MetaTv may be touchable and can be unified+     b) Even if it's not touchable, GHC.Tc.Solver.floatEqualities+        looks for meta tyvars on the left++  Tie-breaking rules for MetaTvs:+  - CycleBreakerTv: This is essentially a stand-in for another type;+       it's untouchable and should have the same priority as a skolem: 0.++  - TyVarTv: These can unify only with another tyvar, but we can't unify+       a TyVarTv with a TauTv, because then the TyVarTv could (transitively)+       get a non-tyvar type. So give these a low priority: 1.++  - TauTv: This is the common case; we want these on the left so that they+       can be written to: 2.++  - RuntimeUnkTv: These aren't really meta-variables used in type inference,+       but just a convenience in the implementation of the GHCi debugger.+       Eagerly write to these: 3. See Note [RuntimeUnkTv] in+       GHC.Runtime.Heap.Inspect.++* Names. If the level and priority comparisons are all+  equal, try to eliminate a TyVar with a System Name in+  favour of ones with a Name derived from a user type signature++* Age.  At one point in the past we tried to break any remaining+  ties by eliminating the younger type variable, based on their+  Uniques.  See Note [Eliminate younger unification variables]+  (which also explains why we don't do this any more)++Note [Unification variables on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wanteds, but not givens, swap (skolem ~ meta-tv) regardless of+level, so that the unification variable is on the left.++* We /don't/ want this for Givens because if we ave+    [G] a[2] ~ alpha[1]+    [W] Bool ~ a[2]+  we want to rewrite the wanted to Bool ~ alpha[1],+  so we can float the constraint and solve it.++* But for Wanteds putting the unification variable on+  the left means an easier job when floating, and when+  reporting errors -- just fewer cases to consider.++  In particular, we get better skolem-escape messages:+  see #18114++Note [Deeper level on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The most important thing is that we want to put tyvars with+the deepest level on the left.  The reason to do so differs for+Wanteds and Givens, but either way, deepest wins!  Simple.++* Wanteds.  Putting the deepest variable on the left maximise the+  chances that it's a touchable meta-tyvar which can be solved.++* Givens. Suppose we have something like+     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]++  If we orient the Given a[2] on the left, we'll rewrite the Wanted to+  (beta[1] ~ b[1]), and that can float out of the implication.+  Otherwise it can't.  By putting the deepest variable on the left+  we maximise our changes of eliminating skolem capture.++  See also GHC.Tc.Solver.Monad Note [Let-bound skolems] for another reason+  to orient with the deepest skolem on the left.++  IMPORTANT NOTE: this test does a level-number comparison on+  skolems, so it's important that skolems have (accurate) level+  numbers.++See #15009 for an further analysis of why "deepest on the left"+is a good plan.++Note [Avoid unnecessary swaps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we swap without actually improving matters, we can get an infinite loop.+Consider+    work item:  a ~ b+   inert item:  b ~ c+We canonicalise the work-item to (a ~ c).  If we then swap it before+adding to the inert set, we'll add (c ~ a), and therefore kick out the+inert guy, so we get+   new work item:  b ~ c+   inert item:     c ~ a+And now the cycle just repeats++Historical Note [Eliminate younger unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a choice of unifying+     alpha := beta   or   beta := alpha+we try, if possible, to eliminate the "younger" one, as determined+by `ltUnique`.  Reason: the younger one is less likely to appear free in+an existing inert constraint, and hence we are less likely to be forced+into kicking out and rewriting inert constraints.++This is a performance optimisation only.  It turns out to fix+#14723 all by itself, but clearly not reliably so!++It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).+But, to my surprise, it didn't seem to make any significant difference+to the compiler's performance, so I didn't take it any further.  Still+it seemed too nice to discard altogether, so I'm leaving these+notes.  SLPJ Jan 18.++Note [Prevent unification with type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prevent unification with type families because of an uneasy compromise.+It's perfectly sound to unify with type families, and it even improves the+error messages in the testsuite. It also modestly improves performance, at+least in some cases. But it's disastrous for test case perf/compiler/T3064.+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.+What do we do? Do we reduce F? Or do we use the given? Hard to know what's+best. GHC reduces. This is a disaster for T3064, where the type's size+spirals out of control during reduction. If we prevent+unification with type families, then the solver happens to use the equality+before expanding the type family.++It would be lovely in the future to revisit this problem and remove this+extra, unnecessary check. But we retain it for now as it seems to work+better in practice.++Revisited in Nov '20, along with removing flattening variables. Problem+is still present, and the solution is still the same.++Note [Refactoring hazard: metaTyVarUpdateOK]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I (Richard E.) have a sad story about refactoring this code, retained here+to prevent others (or a future me!) from falling into the same traps.++It all started with #11407, which was caused by the fact that the TyVarTy+case of defer_me didn't look in the kind. But it seemed reasonable to+simply remove the defer_me check instead.++It referred to two Notes (since removed) that were out of date, and the+fast_check code in occurCheckExpand seemed to do just about the same thing as+defer_me. The one piece that defer_me did that wasn't repeated by+occurCheckExpand was the type-family check. (See Note [Prevent unification+with type families].) So I checked the result of occurCheckExpand for any+type family occurrences and deferred if there were any. This was done+in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .++This approach turned out not to be performant, because the expanded+type was bigger than the original type, and tyConsOfType (needed to+see if there are any type family occurrences) looks through type+synonyms. So it then struck me that we could dispense with the+defer_me check entirely. This simplified the code nicely, and it cut+the allocations in T5030 by half. But, as documented in Note [Prevent+unification with type families], this destroyed performance in+T3064. Regardless, I missed this regression and the change was+committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .++Bottom lines:+ * defer_me is back, but now fixed w.r.t. #11407.+ * Tread carefully before you start to refactor here. There can be+   lots of hard-to-predict consequences.++Note [Type synonyms and the occur check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking we try to update a variable with type synonyms not+expanded, which improves later error messages, unless looking+inside a type synonym may help resolve a spurious occurs check+error. Consider:+          type A a = ()++          f :: (A a -> a -> ()) -> ()+          f = \ _ -> ()++          x :: ()+          x = f (\ x p -> p x)++We will eventually get a constraint of the form t ~ A t. The ok function above will+properly expand the type (A t) to just (), which is ok to be unified with t. If we had+unified with the original type A t, we would lead the type checker into an infinite loop.++Hence, if the occurs check fails for a type synonym application, then (and *only* then),+the ok function expands the synonym to detect opportunities for occurs check success using+the underlying definition of the type synonym.++The same applies later on in the constraint interaction code; see GHC.Tc.Solver.Interact,+function @occ_check_ok@.++Note [Non-TcTyVars in GHC.Tc.Utils.Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because the same code is now shared between unifying types and unifying+kinds, we sometimes will see proper TyVars floating around the unifier.+Example (from test case polykinds/PolyKinds12):++    type family Apply (f :: k1 -> k2) (x :: k1) :: k2+    type instance Apply g y = g y++When checking the instance declaration, we first *kind-check* the LHS+and RHS, discovering that the instance really should be++    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y++During this kind-checking, all the tyvars will be TcTyVars. Then, however,+as a second pass, we desugar the RHS (which is done in functions prefixed+with "tc" in GHC.Tc.TyCl"). By this time, all the kind-vars are proper+TyVars, not TcTyVars, get some kind unification must happen.++Thus, we always check if a TyVar is a TcTyVar before asking if it's a+meta-tyvar.++This used to not be necessary for type-checking (that is, before * :: *)+because expressions get desugared via an algorithm separate from+type-checking (with wrappers, etc.). Types get desugared very differently,+causing this wibble in behavior seen here.+-}++-- | Breaks apart a function kind into its pieces.+matchExpectedFunKind+  :: Outputable fun+  => fun             -- ^ type, only for errors+  -> Arity           -- ^ n: number of desired arrows+  -> TcKind          -- ^ fun_ kind+  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)++matchExpectedFunKind hs_ty n k = go n k+  where+    go 0 k = return (mkNomReflCo k)++    go n k | Just k' <- tcView k = go n k'++    go n k@(TyVarTy kvar)+      | isMetaTyVar kvar+      = do { maybe_kind <- readMetaTyVar kvar+           ; case maybe_kind of+                Indirect fun_kind -> go n fun_kind+                Flexi ->             defer n k }++    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) }++    go n other+     = defer n other++    defer n k+      = do { arg_kinds <- newMetaKindVars n+           ; res_kind  <- newMetaKindVar+           ; let new_fun = mkVisFunTysMany arg_kinds res_kind+                 origin  = TypeEqOrigin { uo_actual   = k+                                        , uo_expected = new_fun+                                        , uo_thing    = Just (ppr hs_ty)+                                        , uo_visible  = True+                                        }+           ; uType KindLevel origin k new_fun }++{- *********************************************************************+*                                                                      *+                 Equality invariant checking+*                                                                      *+********************************************************************* -}+++{-  Note [Checking for foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unless we have -XImpredicativeTypes (which is a totally unsupported+feature), we do not want to unify+    alpha ~ (forall a. a->a) -> Int+So we look for foralls hidden inside the type, and it's convenient+to do that at the same time as the occurs check (which looks for+occurrences of alpha).++However, it's not just a question of looking for foralls /anywhere/!+Consider+   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)+This is legal; e.g. dependent/should_compile/T11635.++We don't want to reject it because of the forall in beta's kind, but+(see Note [Occurrence checking: look inside kinds] in GHC.Core.Type)+we do need to look in beta's kind.  So we carry a flag saying if a+'forall' is OK, and switch the flag on when stepping inside a kind.++Why is it OK?  Why does it not count as impredicative polymorphism?+The reason foralls are bad is because we reply on "seeing" foralls+when doing implicit instantiation.  But the forall inside the kind is+fine.  We'll generate a kind equality constraint+  (forall k. k->*) ~ (forall k. k->*)+to check that the kinds of lhs and rhs are compatible.  If alpha's+kind had instead been+  (alpha :: kappa)+then this kind equality would rightly complain about unifying kappa+with (forall k. k->*)++-}++----------------+{-# NOINLINE checkTyVarEq #-}  -- checkTyVarEq becomes big after the `inline` fires+checkTyVarEq :: DynFlags -> TcTyVar -> TcType -> CheckTyEqResult+checkTyVarEq dflags tv ty+  = inline checkTypeEq dflags (TyVarLHS tv) ty+    -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away++{-# NOINLINE checkTyFamEq #-}  -- checkTyFamEq becomes big after the `inline` fires+checkTyFamEq :: DynFlags+             -> TyCon     -- type function+             -> [TcType]  -- args, exactly saturated+             -> TcType    -- RHS+             -> CheckTyEqResult   -- always drops cteTypeFamily+checkTyFamEq dflags fun_tc fun_args ty+  = inline checkTypeEq dflags (TyFamLHS fun_tc fun_args) ty+    `cterRemoveProblem` cteTypeFamily+    -- inline checkTypeEq so that the `case`s over the CanEqLHS get blasted away++checkTypeEq :: DynFlags -> CanEqLHS -> TcType -> CheckTyEqResult+-- If cteHasNoProblem (checkTypeEq dflags lhs rhs), then lhs ~ rhs+-- is a canonical CEqCan.+--+-- In particular, this looks for:+--   (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 LHS (occurs check)+--+-- Note that an occurs-check does not mean "definite error".  For example+--   type family F a+--   type instance F Int = Int+-- consider+--   b0 ~ F b0+-- This is perfectly reasonable, if we later get b0 ~ Int.  But we+-- certainly can't unify b0 := F b0+--+-- For (a), (b), and (c) we check only the top level of the type, NOT+-- inside the kinds of variables it mentions.  For (d) we look deeply+-- in coercions when the LHS is a tyvar (but skip coercions for type family+-- LHSs), and for (e) see Note [CEqCan occurs check] in GHC.Tc.Types.Constraint.+--+-- checkTypeEq is called from+--    * checkTyFamEq, checkTyVarEq (which inline it to specialise away the+--      case-analysis on 'lhs')+--    * checkEqCanLHSFinish, which does not know the form of 'lhs'+checkTypeEq dflags lhs ty+  = go ty+  where+    impredicative    = cteProblem cteImpredicative+    type_family      = cteProblem cteTypeFamily+    hole_blocker     = cteProblem cteHoleBlocker+    insoluble_occurs = cteProblem cteInsolubleOccurs+    soluble_occurs   = cteProblem cteSolubleOccurs++    -- 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+      | TyVarLHS tv <- lhs+      , MetaTv { mtv_info = RuntimeUnkTv } <- tcTyVarDetails tv+      = True++      | otherwise+      = False++    go :: TcType -> CheckTyEqResult+    go (TyVarTy tv')           = go_tv tv'+    go (TyConApp tc tys)       = go_tc tc tys+    go (LitTy {})              = cteOK+    go (FunTy {ft_af = af, ft_mult = w, ft_arg = a, ft_res = r})+                               = go w S.<> go a S.<> go r S.<>+                                 if not ghci_tv && af == InvisArg+                                   then impredicative+                                   else cteOK+    go (AppTy fun arg) = go fun S.<> go arg+    go (CastTy ty co)  = go ty  S.<> go_co co+    go (CoercionTy co) = go_co co+    go (ForAllTy (Bndr tv' _) ty) = (case lhs of+      TyVarLHS tv | tv == tv' -> go_occ (tyVarKind tv') S.<> cterClearOccursCheck (go ty)+                  | otherwise -> go_occ (tyVarKind tv') S.<> go ty+      _                       -> go ty)+      S.<>+      if ghci_tv then cteOK else impredicative++    go_tv :: TcTyVar -> CheckTyEqResult+      -- this slightly peculiar way of defining this means+      -- we don't have to evaluate this `case` at every variable+      -- occurrence+    go_tv = case lhs of+      TyVarLHS tv -> \ tv' -> go_occ (tyVarKind tv') S.<>+                              if tv == tv' then insoluble_occurs else cteOK+      TyFamLHS {} -> \ _tv' -> cteOK+           -- See Note [Occurrence checking: look inside kinds] in GHC.Core.Type++     -- For kinds, we only do an occurs check; we do not worry+     -- about type families or foralls+     -- See Note [Checking for foralls]+    go_occ k = cterFromKind $ go k++    go_tc :: TyCon -> [TcType] -> CheckTyEqResult+      -- this slightly peculiar way of defining this means+      -- we don't have to evaluate this `case` at every tyconapp+    go_tc = case lhs of+      TyVarLHS {} -> \ tc tys -> check_tc tc S.<> go_tc_args tc tys+      TyFamLHS fam_tc fam_args -> \ tc tys ->+        if tcEqTyConApps fam_tc fam_args tc tys+          then insoluble_occurs+          else check_tc tc S.<> go_tc_args tc tys++      -- just look at arguments, not the tycon itself+    go_tc_args :: TyCon -> [TcType] -> CheckTyEqResult+    go_tc_args tc tys | isGenerativeTyCon tc Nominal = foldMap go tys+                      | otherwise+                      = let (tf_args, non_tf_args) = splitAt (tyConArity tc) tys in+                        cterSetOccursCheckSoluble (foldMap go tf_args) S.<> foldMap go non_tf_args++     -- no bother about impredicativity in coercions, as they're+     -- inferred+    go_co co | TyVarLHS tv <- lhs+             , tv `elemVarSet` tyCoVarsOfCo co+             = soluble_occurs S.<> maybe_hole_blocker++        -- Don't check coercions for type families; see commentary at top of function+             | otherwise+             = maybe_hole_blocker+      where+        -- See GHC.Tc.Solver.Canonical Note [Equalities with incompatible kinds]+        -- Wrinkle (2) about this case in general, Wrinkle (4b) about the check for+        -- deferred type errors+        maybe_hole_blocker | not (gopt Opt_DeferTypeErrors dflags)+                           , hasCoercionHoleCo co+                           = hole_blocker++                           | otherwise+                           = cteOK++    check_tc :: TyCon -> CheckTyEqResult+    check_tc+      | ghci_tv   = \ _tc -> cteOK+      | otherwise = \ tc  -> (if isTauTyCon tc then cteOK else impredicative) S.<>+                             (if isFamFreeTyCon tc then cteOK else type_family)

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

GHC/Tc/Utils/Zonk.hs view

@@ -1,16 +1,15 @@+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+ {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1996-1998  -} -{-# LANGUAGE CPP, TupleSections #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Specialisations of the @HsSyn@ syntax for the typechecker -- -- This module is an extension of @HsSyn@ syntax, for use in the type checker.@@ -21,7 +20,7 @@         -- * Other HsSyn functions         mkHsDictLet, mkHsApp,         mkHsAppTy, mkHsCaseAlt,-        shortCutLit, hsOverLitName,+        tcShortCutLit, shortCutLit, hsOverLitName,         conLikeResTy,          -- * re-exported from TcMonad@@ -33,10 +32,10 @@         zonkTopDecls, zonkTopExpr, zonkTopLExpr,         zonkTopBndrs,         ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,-        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,+        zonkTyVarBindersX, zonkTyVarBinderX,         zonkTyBndrs, zonkTyBndrsX,         zonkTcTypeToType,  zonkTcTypeToTypeX,-        zonkTcTypesToTypes, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,+        zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX,         zonkTyVarOcc,         zonkCoToCo,         zonkEvBinds, zonkTcEvBinds,@@ -48,42 +47,53 @@  import GHC.Prelude +import GHC.Platform++import GHC.Builtin.Types+import GHC.Builtin.Types.Prim+import GHC.Builtin.Names+ import GHC.Hs-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Core.Predicate++import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice) import GHC.Tc.Utils.Monad-import GHC.Builtin.Names import GHC.Tc.TyCl.Build ( TcMethInfo, MethInfo ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.Env   ( tcLookupGlobalOnly ) import GHC.Tc.Types.Evidence+ import GHC.Core.TyCo.Ppr ( pprTyVar )-import GHC.Builtin.Types.Prim import GHC.Core.TyCon-import GHC.Builtin.Types import GHC.Core.Type import GHC.Core.Coercion import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Driver.Types++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Core.Multiplicity+import GHC.Core+import GHC.Core.Predicate+ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Var import GHC.Types.Var.Env-import GHC.Platform+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.TypeEnv+import GHC.Types.SourceText import GHC.Types.Basic-import GHC.Data.Maybe import GHC.Types.SrcLoc-import GHC.Data.Bag-import GHC.Utils.Outputable-import GHC.Utils.Misc import GHC.Types.Unique.FM-import GHC.Core.Multiplicity-import GHC.Core+import GHC.Types.TyThing+import GHC.Driver.Session( getDynFlags, targetPlatform ) -import {-# SOURCE #-} GHC.Tc.Gen.Splice (runTopSplice)+import GHC.Data.Maybe+import GHC.Data.Bag  import Control.Monad import Data.List  ( partition )@@ -142,31 +152,84 @@ hsLitType (HsFloatPrim _ _)  = floatPrimTy hsLitType (HsDoublePrim _ _) = doublePrimTy +{- *********************************************************************+*                                                                      *+         Short-cuts for overloaded numeric literals+*                                                                      *+********************************************************************* -}+ -- Overloaded literals. Here mainly because it uses isIntTy etc +{- Note [Short cut for overloaded literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A literal like "3" means (fromInteger @ty (dNum :: Num ty) (3::Integer)).+But if we have a list like+  [4,2,3,2,4,4,2]::[Int]+we use a lot of compile time and space generating and solving all those Num+constraints, and generating calls to fromInteger etc.  Better just to cut to+the chase, and cough up an Int literal. Large collections of literals like this+sometimes appear in source files, so it's quite a worthwhile fix.++So we try to take advantage of whatever nearby type information we have,+to short-cut the process for built-in types.  We can do this in two places;++* In the typechecker, when we are about to typecheck the literal.+* If that fails, in the desugarer, once we know the final type.+-}++tcShortCutLit :: HsOverLit GhcRn -> ExpRhoType -> TcM (Maybe (HsOverLit GhcTc))+tcShortCutLit lit@(OverLit { ol_val = val, ol_ext = rebindable }) exp_res_ty+  | not rebindable+  , Just res_ty <- checkingExpType_maybe exp_res_ty+  = do { dflags <- getDynFlags+       ; let platform = targetPlatform dflags+       ; case shortCutLit platform val res_ty of+            Just expr -> return $ Just $+                         lit { ol_witness = expr+                             , ol_ext = OverLitTc False res_ty }+            Nothing   -> return Nothing }+  | otherwise+  = return Nothing+ shortCutLit :: Platform -> OverLitVal -> TcType -> Maybe (HsExpr GhcTc)-shortCutLit platform (HsIntegral int@(IL src neg i)) ty-  | isIntTy ty  && platformInIntRange  platform i = Just (HsLit noExtField (HsInt noExtField int))-  | isWordTy ty && platformInWordRange platform i = Just (mkLit wordDataCon (HsWordPrim src i))-  | isIntegerTy ty = Just (HsLit noExtField (HsInteger src i ty))-  | otherwise = shortCutLit platform (HsFractional (integralFractionalLit neg i)) ty+shortCutLit platform val res_ty+  = case val of+      HsIntegral int_lit    -> go_integral int_lit+      HsFractional frac_lit -> go_fractional frac_lit+      HsIsString s src      -> go_string   s src+  where+    go_integral int@(IL src neg i)+      | isIntTy res_ty  && platformInIntRange  platform i+      = Just (HsLit noAnn (HsInt noExtField int))+      | isWordTy res_ty && platformInWordRange platform i+      = Just (mkLit wordDataCon (HsWordPrim src i))+      | isIntegerTy res_ty+      = Just (HsLit noAnn (HsInteger src i res_ty))+      | otherwise+      = go_fractional (integralFractionalLit neg i)         -- The 'otherwise' case is important         -- Consider (3 :: Float).  Syntactically it looks like an IntLit,         -- so we'll call shortCutIntLit, but of course it's a float         -- This can make a big difference for programs with a lot of         -- literals, compiled without -O -shortCutLit _ (HsFractional f) ty-  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))-  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))-  | otherwise     = Nothing+    go_fractional f+      | isFloatTy res_ty && valueInRange  = Just (mkLit floatDataCon  (HsFloatPrim noExtField f))+      | isDoubleTy res_ty && valueInRange = Just (mkLit doubleDataCon (HsDoublePrim noExtField f))+      | otherwise                         = Nothing+      where+        valueInRange =+          case f of+            FL { fl_exp = e } -> (-100) <= e && e <= 100+            -- We limit short-cutting Fractional Literals to when their power of 10+            -- is less than 100, which ensures desugaring isn't slow. -shortCutLit _ (HsIsString src s) ty-  | isStringTy ty = Just (HsLit noExtField (HsString src s))-  | otherwise     = Nothing+    go_string src s+      | isStringTy res_ty = Just (HsLit noAnn (HsString src s))+      | otherwise         = Nothing  mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc-mkLit con lit = HsApp noExtField (nlHsDataCon con) (nlHsLit lit)+mkLit con lit = HsApp noComments (nlHsDataCon con) (nlHsLit lit)  ------------------------------ hsOverLitName :: OverLitVal -> Name@@ -274,6 +337,10 @@   It's a way to have a variable that is not a mutable   unification variable, but doesn't have a binding site   either.++* NoFlexi: See Note [Error on unconstrained meta-variables]+  in GHC.Tc.Utils.TcMType. This mode will panic on unfilled+  meta-variables. -}  data ZonkFlexi   -- See Note [Un-unified unification variables]@@ -281,6 +348,9 @@   | SkolemiseFlexi  -- Skolemise unbound unification variables                     -- See Note [Zonking the LHS of a RULE]   | RuntimeUnkFlexi -- Used in the GHCi debugger+  | NoFlexi         -- Panic on unfilled meta-variables+                    -- See Note [Error on unconstrained meta-variables]+                    -- in GHC.Tc.Utils.TcMType  instance Outputable ZonkEnv where   ppr (ZonkEnv { ze_tv_env = tv_env@@ -342,7 +412,7 @@   -- It's OK to use nonDetEltsUFM here because we forget the ordering   -- immediately by creating a TypeEnv -zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id+zonkLIdOcc :: ZonkEnv -> LocatedN TcId -> LocatedN Id zonkLIdOcc env = mapLoc (zonkIdOcc env)  zonkIdOcc :: ZonkEnv -> TcId -> Id@@ -442,10 +512,6 @@        ; let tv' = mkTyVar (tyVarName tv) ki        ; return (extendTyZonkEnv env tv', tv') } -zonkTyVarBinders ::  [VarBndr TcTyVar vis]-                 -> TcM (ZonkEnv, [VarBndr TyVar vis])-zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs- zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]                              -> TcM (ZonkEnv, [VarBndr TyVar vis]) zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX@@ -503,7 +569,7 @@            ; return (env2, (r,b'):bs') }  zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do-    new_binds <- mapM (wrapLocM zonk_ip_bind) binds+    new_binds <- mapM (wrapLocMA zonk_ip_bind) binds     let         env1 = extendIdZonkEnvRec env                  [ n | (L _ (IPBind _ (Right n) _)) <- new_binds]@@ -519,7 +585,7 @@ zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTc -> TcM (ZonkEnv, LHsBinds GhcTc) zonkRecMonoBinds env binds  = fixM (\ ~(_, new_binds) -> do-        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)+        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders CollNoDictBinders new_binds)         ; binds' <- zonkMonoBinds env1 binds         ; return (env1, binds') }) @@ -528,16 +594,16 @@ zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds  zonk_lbind :: ZonkEnv -> LHsBind GhcTc -> TcM (LHsBind GhcTc)-zonk_lbind env = wrapLocM (zonk_bind env)+zonk_lbind env = wrapLocMA (zonk_bind env)  zonk_bind :: ZonkEnv -> HsBind GhcTc -> TcM (HsBind GhcTc) zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss-                            , pat_ext = NPatBindTc fvs ty})+                            , pat_ext = ty})   = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended         ; new_grhss <- zonkGRHSs env zonkLExpr grhss         ; new_ty    <- zonkTcTypeToTypeX env ty         ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss-                       , pat_ext = NPatBindTc fvs new_ty }) }+                       , pat_ext = new_ty }) }  zonk_bind env (VarBind { var_ext = x                        , var_id = var, var_rhs = expr })@@ -568,7 +634,7 @@        ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds        ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->          do { let env3 = extendIdZonkEnvRec env2 $-                         collectHsBindsBinders new_val_binds+                         collectHsBindsBinders CollNoDictBinders new_val_binds             ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds             ; new_exports   <- mapM (zonk_export env3) exports             ; return (new_val_binds, new_exports) }@@ -616,7 +682,7 @@                                       , psb_dir = dir }))   = do { id' <- zonkIdBndr env id        ; (env1, lpat') <- zonkPat env lpat-       ; let details' = zonkPatSynDetails env1 details+       ; details' <- zonkPatSynDetails env1 details        ; (_env2, dir') <- zonkPatSynDir env1 dir        ; return $ PatSynBind x $                   bind { psb_id = L loc id'@@ -625,15 +691,19 @@                        , psb_dir = dir' } }  zonkPatSynDetails :: ZonkEnv-                  -> HsPatSynDetails (Located TcId)-                  -> HsPatSynDetails (Located Id)-zonkPatSynDetails env (PrefixCon as)-  = PrefixCon (map (zonkLIdOcc env) as)+                  -> HsPatSynDetails GhcTc+                  -> TcM (HsPatSynDetails GhcTc)+zonkPatSynDetails env (PrefixCon _ as)+  = pure $ PrefixCon noTypeArgs (map (zonkLIdOcc env) as) zonkPatSynDetails env (InfixCon a1 a2)-  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)+  = pure $ InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2) zonkPatSynDetails env (RecCon flds)-  = RecCon (map (fmap (zonkLIdOcc env)) flds)+  = RecCon <$> mapM (zonkPatSynField env) flds +zonkPatSynField :: ZonkEnv -> RecordPatSynField GhcTc -> TcM (RecordPatSynField GhcTc)+zonkPatSynField env (RecordPatSynField x y) =+    RecordPatSynField <$> zonkFieldOcc env x <*> pure (zonkLIdOcc env y)+ zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTc               -> TcM (ZonkEnv, HsPatSynDir GhcTc) zonkPatSynDir env Unidirectional        = return (env, Unidirectional)@@ -663,10 +733,11 @@ ************************************************************************ -} -zonkMatchGroup :: ZonkEnv-            -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))-            -> MatchGroup GhcTc (Located (body GhcTc))-            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))+zonkMatchGroup :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+            => ZonkEnv+            -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))+            -> MatchGroup GhcTc (LocatedA (body GhcTc))+            -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc))) zonkMatchGroup env zBody (MG { mg_alts = L l ms                              , mg_ext = MatchGroupTc arg_tys res_ty                              , mg_origin = origin })@@ -677,10 +748,11 @@                      , mg_ext = MatchGroupTc arg_tys' res_ty'                      , mg_origin = origin }) } -zonkMatch :: ZonkEnv-          -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))-          -> LMatch GhcTc (Located (body GhcTc))-          -> TcM (LMatch GhcTc (Located (body GhcTc)))+zonkMatch :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+          => ZonkEnv+          -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))+          -> LMatch GhcTc (LocatedA (body GhcTc))+          -> TcM (LMatch GhcTc (LocatedA (body GhcTc))) zonkMatch env zBody (L loc match@(Match { m_pats = pats                                         , m_grhss = grhss }))   = do  { (env1, new_pats) <- zonkPats env pats@@ -688,12 +760,13 @@         ; return (L loc (match { m_pats = new_pats, m_grhss = new_grhss })) }  --------------------------------------------------------------------------zonkGRHSs :: ZonkEnv-          -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))-          -> GRHSs GhcTc (Located (body GhcTc))-          -> TcM (GRHSs GhcTc (Located (body GhcTc)))+zonkGRHSs :: Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcSpan+          => ZonkEnv+          -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))+          -> GRHSs GhcTc (LocatedA (body GhcTc))+          -> TcM (GRHSs GhcTc (LocatedA (body GhcTc))) -zonkGRHSs env zBody (GRHSs x grhss (L l binds)) = do+zonkGRHSs env zBody (GRHSs x grhss binds) = do     (new_env, new_binds) <- zonkLocalBinds env binds     let         zonk_grhs (GRHS xx guarded rhs)@@ -701,7 +774,7 @@                new_rhs <- zBody env2 rhs                return (GRHS xx new_guarded new_rhs)     new_grhss <- mapM (wrapLocM zonk_grhs) grhss-    return (GRHSs x new_grhss (L l new_binds))+    return (GRHSs x new_grhss new_binds)  {- ************************************************************************@@ -716,12 +789,27 @@ zonkExpr   :: ZonkEnv -> HsExpr GhcTc    -> TcM (HsExpr GhcTc)  zonkLExprs env exprs = mapM (zonkLExpr env) exprs-zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr+zonkLExpr  env expr  = wrapLocMA (zonkExpr env) expr  zonkExpr env (HsVar x (L l id))   = ASSERT2( isNothing (isDataConId_maybe id), ppr id )     return (HsVar x (L l (zonkIdOcc env id))) +zonkExpr env (HsUnboundVar her occ)+  = do her' <- zonk_her her+       return (HsUnboundVar her' occ)+  where+    zonk_her :: HoleExprRef -> TcM HoleExprRef+    zonk_her (HER ref ty u)+      = do updMutVarM ref (zonkEvTerm env)+           ty'  <- zonkTcTypeToTypeX env ty+           return (HER ref ty' u)++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)@@ -809,10 +897,10 @@   = do { new_tup_args <- mapM zonk_tup_arg tup_args        ; return (ExplicitTuple x new_tup_args boxed) }   where-    zonk_tup_arg (L l (Present x e)) = do { e' <- zonkLExpr env e-                                          ; return (L l (Present x e')) }-    zonk_tup_arg (L l (Missing t)) = do { t' <- zonkScaledTcTypeToTypeX env t-                                        ; return (L l (Missing t')) }+    zonk_tup_arg (Present x e) = do { e' <- zonkLExpr env e+                                    ; return (Present x e') }+    zonk_tup_arg (Missing t) = do { t' <- zonkScaledTcTypeToTypeX env t+                                  ; return (Missing t') }   zonkExpr env (ExplicitSum args alt arity expr)@@ -840,45 +928,52 @@                ; expr'          <- zonkLExpr env' expr                ; return $ GRHS x guard' expr' } -zonkExpr env (HsLet x (L l binds) expr)+zonkExpr env (HsLet x binds expr)   = do (new_env, new_binds) <- zonkLocalBinds env binds        new_expr <- zonkLExpr new_env expr-       return (HsLet x (L l new_binds) new_expr)+       return (HsLet x new_binds new_expr)  zonkExpr env (HsDo ty do_or_lc (L l stmts))   = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts        new_ty <- zonkTcTypeToTypeX env ty        return (HsDo new_ty do_or_lc (L l new_stmts)) -zonkExpr env (ExplicitList ty wit exprs)-  = do (env1, new_wit) <- zonkWit env wit-       new_ty <- zonkTcTypeToTypeX env1 ty-       new_exprs <- zonkLExprs env1 exprs-       return (ExplicitList new_ty new_wit new_exprs)-   where zonkWit env Nothing    = return (env, Nothing)-         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln+zonkExpr env (ExplicitList ty exprs)+  = do new_ty <- zonkTcTypeToTypeX env ty+       new_exprs <- zonkLExprs env exprs+       return (ExplicitList new_ty new_exprs) -zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })-  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)+zonkExpr env expr@(RecordCon { rcon_ext = con_expr, rcon_flds = rbinds })+  = do  { new_con_expr <- zonkExpr env con_expr         ; new_rbinds   <- zonkRecFields env rbinds-        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }+        ; return (expr { rcon_ext  = new_con_expr                        , rcon_flds = new_rbinds }) } -zonkExpr env (RecordUpd { rupd_flds = rbinds+-- Record updates via dot syntax are replaced by desugared expressions+-- in the renamer. See Note [Rebindable Syntax and HsExpansion]. This+-- is why we match on 'rupd_flds = Left rbinds' here and panic otherwise.+zonkExpr env (RecordUpd { rupd_flds = Left rbinds                         , rupd_expr = expr-                        , rupd_ext = RecordUpdTc-                            { rupd_cons = cons, rupd_in_tys = in_tys-                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})+                        , rupd_ext = RecordUpdTc {+                                       rupd_cons = cons+                                     , rupd_in_tys = in_tys+                                     , rupd_out_tys = out_tys+                                     , rupd_wrap = req_wrap }})   = do  { new_expr    <- zonkLExpr env expr         ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys         ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys         ; new_rbinds  <- zonkRecUpdFields env rbinds         ; (_, new_recwrap) <- zonkCoFn env req_wrap-        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds-                            , rupd_ext = RecordUpdTc-                                { rupd_cons = cons, rupd_in_tys = new_in_tys-                                , rupd_out_tys = new_out_tys-                                , rupd_wrap = new_recwrap }}) }+        ; return (+            RecordUpd {+                  rupd_expr = new_expr+                , rupd_flds = Left new_rbinds+                , rupd_ext = RecordUpdTc {+                               rupd_cons = cons+                             , rupd_in_tys = new_in_tys+                             , rupd_out_tys = new_out_tys+                             , rupd_wrap = new_recwrap }}) }+zonkExpr _ (RecordUpd {}) = panic "GHC.Tc.Utils.Zonk: zonkExpr: The impossible happened!"  zonkExpr env (ExprWithTySig _ e ty)   = do { e' <- zonkLExpr env e@@ -914,9 +1009,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)  -------------------------------------------------------------------------@@ -959,7 +1051,7 @@ zonkLCmd  :: ZonkEnv -> LHsCmd GhcTc   -> TcM (LHsCmd GhcTc) zonkCmd   :: ZonkEnv -> HsCmd GhcTc    -> TcM (HsCmd GhcTc) -zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd+zonkLCmd  env cmd  = wrapLocMA (zonkCmd env) cmd  zonkCmd env (XCmd (HsWrap w cmd))   = do { (env1, w') <- zonkCoFn env w@@ -1005,10 +1097,10 @@        ; new_cElse <- zonkLCmd env1 cElse        ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) } -zonkCmd env (HsCmdLet x (L l binds) cmd)+zonkCmd env (HsCmdLet x binds cmd)   = do (new_env, new_binds) <- zonkLocalBinds env binds        new_cmd <- zonkLCmd new_env cmd-       return (HsCmdLet x (L l new_binds) new_cmd)+       return (HsCmdLet x new_binds new_cmd)  zonkCmd env (HsCmdDo ty (L l stmts))   = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts@@ -1092,19 +1184,21 @@   --------------------------------------------------------------------------zonkStmts :: ZonkEnv-          -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))-          -> [LStmt GhcTc (Located (body GhcTc))]-          -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])+zonkStmts :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA+          => ZonkEnv+          -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))+          -> [LStmt GhcTc (LocatedA (body GhcTc))]+          -> TcM (ZonkEnv, [LStmt GhcTc (LocatedA (body GhcTc))]) zonkStmts env _ []     = return (env, [])-zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody) s+zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndMA (zonkStmt env zBody) s                                 ; (env2, ss') <- zonkStmts env1 zBody ss                                 ; return (env2, s' : ss') } -zonkStmt :: ZonkEnv-         -> (ZonkEnv -> Located (body GhcTc) -> TcM (Located (body GhcTc)))-         -> Stmt GhcTc (Located (body GhcTc))-         -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))+zonkStmt :: Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA+         => ZonkEnv+         -> (ZonkEnv -> LocatedA (body GhcTc) -> TcM (LocatedA (body GhcTc)))+         -> Stmt GhcTc (LocatedA (body GhcTc))+         -> TcM (ZonkEnv, Stmt GhcTc (LocatedA (body GhcTc))) zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)   = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op        ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty@@ -1124,7 +1218,8 @@             ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)                                                                    new_return) } -zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs+zonkStmt env zBody (RecStmt { recS_stmts = L _ segStmts, recS_later_ids = lvs+                            , recS_rec_ids = rvs                             , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id                             , recS_bind_fn = bind_id                             , recS_ext =@@ -1146,7 +1241,8 @@        ; new_later_rets <- mapM (zonkExpr env5) later_rets        ; new_rec_rets <- mapM (zonkExpr env5) rec_rets        ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed-                 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs+                 RecStmt { recS_stmts = noLocA new_segStmts+                         , recS_later_ids = new_lvs                          , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id                          , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id                          , recS_ext = RecStmtTc@@ -1194,9 +1290,9 @@         newBinder' <- zonkIdBndr env newBinder         return (oldBinder', newBinder') -zonkStmt env _ (LetStmt x (L l binds))+zonkStmt env _ (LetStmt x binds)   = do (env1, new_binds) <- zonkLocalBinds env binds-       return (env1, LetStmt x (L l new_binds))+       return (env1, LetStmt x new_binds)  zonkStmt env zBody (BindStmt xbs pat body)   = do  { (env1, new_bind) <- zonkSyntaxExpr env (xbstc_bindOp xbs)@@ -1309,7 +1405,7 @@ -- Extend the environment as we go, because it's possible for one -- pattern to bind something that is used in another (inside or -- to the right)-zonkPat env pat = wrapLocSndM (zonk_pat env) pat+zonkPat env pat = wrapLocSndMA (zonk_pat env) pat  zonk_pat :: ZonkEnv -> Pat GhcTc -> TcM (ZonkEnv, Pat GhcTc) zonk_pat env (ParPat x p)@@ -1441,7 +1537,7 @@  zonk_pat env (XPat (CoPat co_fn pat ty))   = do { (env', co_fn') <- zonkCoFn env co_fn-       ; (env'', pat') <- zonkPat env' (noLoc pat)+       ; (env'', pat') <- zonkPat env' (noLocA pat)        ; ty' <- zonkTcTypeToTypeX env'' ty        ; return (env'', XPat $ CoPat co_fn' (unLoc pat') ty')        }@@ -1449,13 +1545,11 @@ zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)  ----------------------------zonkConStuff :: ZonkEnv-             -> HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc))-             -> TcM (ZonkEnv,-                    HsConDetails (LPat GhcTc) (HsRecFields id (LPat GhcTc)))-zonkConStuff env (PrefixCon pats)+zonkConStuff :: ZonkEnv -> HsConPatDetails GhcTc+             -> TcM (ZonkEnv, HsConPatDetails GhcTc)+zonkConStuff env (PrefixCon tyargs pats)   = do  { (env', pats') <- zonkPats env pats-        ; return (env', PrefixCon pats') }+        ; return (env', PrefixCon tyargs pats') }  zonkConStuff env (InfixCon p1 p2)   = do  { (env1, p1') <- zonkPat env  p1@@ -1487,7 +1581,7 @@  zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTc]                    -> TcM [LForeignDecl GhcTc]-zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls+zonkForeignExports env ls = mapM (wrapLocMA (zonkForeignExport env)) ls  zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTc -> TcM (ForeignDecl GhcTc) zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co@@ -1499,7 +1593,7 @@   = return for_imp     -- Foreign imports don't need zonking  zonkRules :: ZonkEnv -> [LRuleDecl GhcTc] -> TcM [LRuleDecl GhcTc]-zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs+zonkRules env rs = mapM (wrapLocMA (zonkRule env)) rs  zonkRule :: ZonkEnv -> RuleDecl GhcTc -> TcM (RuleDecl GhcTc) zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}@@ -1589,10 +1683,10 @@          return $ Case scrut' b' ty' alts'  zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt-zonkCoreAlt env (dc, bndrs, rhs)+zonkCoreAlt env (Alt dc bndrs rhs)     = do (env1, bndrs') <- zonkCoreBndrsX env bndrs          rhs' <- zonkCoreExpr env1 rhs-         return $ (dc, bndrs', rhs')+         return $ Alt dc bndrs' rhs'  zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind) zonkCoreBind env (NonRec v e)@@ -1834,6 +1928,9 @@                         -- otherwise-unconstrained unification variables are                         -- turned into RuntimeUnks as they leave the                         -- typechecker's monad++      NoFlexi -> pprPanic "NoFlexi" (ppr tv <+> dcolon <+> ppr zonked_kind)+   where      name = tyVarName tv @@ -1885,9 +1982,6 @@ -- Confused by zonking? See Note [What is zonking?] in GHC.Tc.Utils.TcMType. zonkTcTypeToType :: TcType -> TcM Type zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty--zonkTcTypesToTypes :: [TcType] -> TcM [Type]-zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys  zonkScaledTcTypeToTypeX :: ZonkEnv -> Scaled TcType -> TcM (Scaled TcType) zonkScaledTcTypeToTypeX env (Scaled m ty) = Scaled <$> zonkTcTypeToTypeX env m

GHC/Tc/Validity.hs view

@@ -1,13 +1,13 @@+{-# LANGUAGE CPP           #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- module GHC.Tc.Validity (   Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,   checkValidTheta,@@ -66,7 +66,8 @@ import GHC.Data.List.SetOps import GHC.Types.SrcLoc import GHC.Utils.Outputable as Outputable-import GHC.Types.Unique  ( mkAlphaTyVarUnique )+import GHC.Utils.Panic+import GHC.Builtin.Uniques  ( mkAlphaTyVarUnique ) import GHC.Data.Bag      ( emptyBag ) import qualified GHC.LanguageExtensions as LangExt @@ -253,11 +254,11 @@ checkUserTypeError = check   where   check ty-    | Just msg     <- userTypeError_maybe ty  = fail_with msg-    | Just (_,ts)  <- splitTyConApp_maybe ty  = mapM_ check ts-    | Just (t1,t2) <- splitAppTy_maybe ty     = check t1 >> check t2-    | Just (_,t1)  <- splitForAllTy_maybe ty  = check t1-    | otherwise                               = return ()+    | Just msg     <- userTypeError_maybe ty      = fail_with msg+    | Just (_,ts)  <- splitTyConApp_maybe ty      = mapM_ check ts+    | Just (t1,t2) <- splitAppTy_maybe ty         = check t1 >> check t2+    | Just (_,t1)  <- splitForAllTyCoVar_maybe ty = check t1+    | otherwise                                   = return ()    fail_with msg = do { env0 <- tcInitTidyEnv                      ; let (env1, tidy_msg) = tidyOpenType env0 msg@@ -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,92 @@ 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.+-- 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.+typeLevelUserTypeCtxt :: UserTypeCtxt -> Bool+typeLevelUserTypeCtxt ctxt = case typeOrKindCtxt ctxt of+  OnlyTypeCtxt        -> True+  OnlyKindCtxt        -> False+  BothTypeAndKindCtxt -> True++-- | 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".) 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 = typeLevelUserTypeCtxt  -- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the+-- context for a kind of a type, where all function arrows currently+-- must be unrestricted.+linearityAllowed :: UserTypeCtxt -> Bool+linearityAllowed = typeLevelUserTypeCtxt++-- | 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 +568,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]@@ -708,12 +751,16 @@          ; checkEscapingKind env' tvbs' theta tau }   where-    (tvbs, phi)   = tcSplitForAllVarBndrs ty+    (tvbs, phi)   = tcSplitForAllTyVarBinders ty     (theta, tau)  = tcSplitPhiTy phi     (env', tvbs') = tidyTyCoVarBinders env tvbs -check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ _ arg_ty res_ty)-  = do  { check_type (ve{ve_rank = arg_rank}) arg_ty+check_type (ve@ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt+                          , ve_rank = rank })+           ty@(FunTy _ mult arg_ty res_ty)+  = do  { failIfTcM (not (linearityAllowed ctxt) && not (isManyDataConTy mult))+                     (linearFunKindErr env ty)+        ; check_type (ve{ve_rank = arg_rank}) arg_ty         ; check_type (ve{ve_rank = res_rank}) res_ty }   where     (arg_rank, res_rank) = funArgResRank rank@@ -877,7 +924,7 @@      , vcat [ hang herald 2 (ppr_tidy env ty)             , suggestion ] )   where-    (tvs, _theta, _tau) = tcSplitSigmaTy ty+    (tvs, _rho) = tcSplitForAllTyVars ty     herald | null tvs  = text "Illegal qualified type:"            | otherwise = text "Illegal polymorphic type:"     suggestion = case rank of@@ -961,6 +1008,11 @@        2 (ppr_tidy env ty)   , text "(GHC does not yet support this)" ] ) +-- | Reject uses of linear function arrows in kinds.+linearFunKindErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+linearFunKindErr env ty =+  (env, text "Illegal linear function in a kind:" <+> ppr_tidy env ty)+ {- Note [Liberal type synonyms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1004,7 +1056,7 @@ If the rank-n case came first, then in the process of checking for `forall`s or contexts, we would expand away `B A` to `forall x. x -> x`. This is because the functions that split apart `forall`s/contexts-(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded+(tcSplitForAllTyVarBinders/tcSplitPhiTy) expand type synonyms! If `B A` is expanded away to `forall x. x -> x` before the actually validity checks occur, we will have completely obfuscated the fact that we had an unsaturated application of the `A` type synonym.@@ -1130,7 +1182,7 @@               -- in Note [Lift equality constraints when quantifying] in GHC.Tc.Utils.TcType        ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head-      IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred+      IrredPred {}            -> check_irred_pred under_syn env dflags pred  check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM () check_eq_pred env dflags pred@@ -1172,30 +1224,17 @@     -- This case will not normally be executed because without     -- -XConstraintKinds tuple types are only kind-checked as * -check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()-check_irred_pred under_syn env dflags ctxt pred+check_irred_pred :: Bool -> TidyEnv -> DynFlags -> PredType -> TcM ()+check_irred_pred under_syn env dflags pred     -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint     -- where X is a type function-  = do { -- If it looks like (x t1 t2), require ConstraintKinds+  =      -- If it looks like (x t1 t2), require ConstraintKinds          --   see Note [ConstraintKinds in predicates]          -- But (X t1 t2) is always ok because we just require ConstraintKinds          -- at the definition site (#9838)-        failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)-                                && hasTyVarHead pred)-                  (predIrredErr env pred)--         -- Make sure it is OK to have an irred pred in this context-         -- See Note [Irreducible predicates in superclasses]-       ; failIfTcM (is_superclass ctxt-                    && not (xopt LangExt.UndecidableInstances dflags)-                    && has_tyfun_head pred)-                   (predSuperClassErr env pred) }-  where-    is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }-    has_tyfun_head ty-      = case tcSplitTyConApp_maybe ty of-          Just (tc, _) -> isTypeFamilyTyCon tc-          Nothing      -> False+    failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)+                            && hasTyVarHead pred)+              (predIrredErr env pred)  {- Note [ConstraintKinds in predicates] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1206,19 +1245,7 @@        module B where           import A           f :: C a => a -> a        -- Does *not* need -XConstraintKinds--Note [Irreducible predicates in superclasses]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Allowing type-family calls in class superclasses is somewhat dangerous-because we can write:-- type family Fooish x :: * -> Constraint- type instance Fooish () = Foo- class Fooish () a => Foo a where--This will cause the constraint simplifier to loop because every time we canonicalise a-(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately-solved to add+canonicalise another (Foo a) constraint.  -}+-}  ------------------------- check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt@@ -1242,10 +1269,9 @@      -- Check the arguments of a class constraint     flexible_contexts = xopt LangExt.FlexibleContexts     dflags-    undecidable_ok    = xopt LangExt.UndecidableInstances dflags     arg_tys_ok = case ctxt of         SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine-        InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys+        InstDeclCtxt {} -> checkValidClsArgs flexible_contexts cls tys                                 -- Further checks on head and theta                                 -- in checkInstTermination         _               -> checkValidClsArgs flexible_contexts cls tys@@ -1328,11 +1354,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@@ -1381,7 +1405,7 @@                   , text "While checking" <+> pprUserTypeCtxt ctxt ] )  eqPredTyErr, predTupleErr, predIrredErr,-   predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)+   badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) badQuantHeadErr env pred   = ( env     , hang (text "Quantified predicate must have a class or type variable head:")@@ -1398,11 +1422,6 @@   = ( env     , hang (text "Illegal constraint:" <+> ppr_tidy env pred)          2 (parens constraintKindsMsg) )-predSuperClassErr env pred-  = ( env-    , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)-            <+> text "in a superclass context")-         2 (parens undecidableMsg) )  predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc) predTyVarErr env pred@@ -1845,7 +1864,7 @@   = failWithTc (text "Arity mis-match in instance head")    | otherwise-  = do  { setSrcSpan head_loc $+  = do  { setSrcSpanA head_loc $           checkValidInstHead ctxt clas inst_tys          ; traceTc "checkValidInstance {" (ppr ty)@@ -2186,7 +2205,7 @@ -- checkFamInstRhs :: TyCon -> [Type]         -- LHS                 -> [(TyCon, [Type])]       -- type family calls in RHS-                -> [MsgDoc]+                -> [SDoc] checkFamInstRhs lhs_tc lhs_tys famInsts   = mapMaybe check famInsts   where@@ -2213,12 +2232,6 @@                    -> [TcType]    -- LHS patterns                    -> Type        -- RHS                    -> TcM ()--- We do these binder checks now, in tcFamTyPatsAndGen, rather--- than later, in checkValidFamEqn, for two reasons:---   - We have the implicitly and explicitly---     bound type variables conveniently to hand---   - If implicit variables are out of scope it may---     cause a crash; notably in tcConDecl in tcDataFamInstDecl checkFamPatBinders fam_tc qtvs pats rhs   = do { traceTc "checkFamPatBinders" $          vcat [ debugPprType (mkTyConApp fam_tc pats)@@ -2408,8 +2421,8 @@     -- The /scoped/ type variables from the class-instance header     -- should not be alpha-renamed.  Inferred ones can be.     no_bind_set = mkVarSet inst_tvs-    bind_me tv | tv `elemVarSet` no_bind_set = Skolem-               | otherwise                   = BindMe+    bind_me tv _ty | tv `elemVarSet` no_bind_set = Apart+                   | otherwise                   = BindMe   {- Note [Check type-family instance binders]@@ -2805,7 +2818,7 @@ occurred.  (It /used/ to be possible; see tests T13983 and T7873.  But with the advent of the forall-or-nothing rule for kind variables, those strange cases went away. See Note [forall-or-nothing rule] in-GHC.Rename.HsType.)+GHC.Hs.Type.)  But one might worry about     type v k = *

GHC/ThToHs.hs view

@@ -1,3 +1,16 @@+{-# LANGUAGE BangPatterns            #-}+{-# LANGUAGE DeriveFunctor           #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FunctionalDependencies  #-}+{-# LANGUAGE LambdaCase              #-}+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE ViewPatterns            #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -6,19 +19,6 @@ This module converts Template Haskell syntax into Hs syntax -} -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- module GHC.ThToHs    ( convertToHsExpr    , convertToPat@@ -42,15 +42,17 @@ import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Types.Basic as Hs+import GHC.Types.Fixity as Hs import GHC.Types.ForeignCall import GHC.Types.Unique+import GHC.Types.SourceText import GHC.Utils.Error import GHC.Data.Bag import GHC.Utils.Lexeme import GHC.Utils.Misc import GHC.Data.FastString import GHC.Utils.Outputable as Outputable-import GHC.Parser.Annotation (IsUnicodeSyntax(..))+import GHC.Utils.Panic  import qualified Data.ByteString as BS import Control.Monad( unless, ap )@@ -65,25 +67,25 @@ ------------------------------------------------------------------- --              The external interface -convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]+convertToHsDecls :: Origin -> SrcSpan -> [TH.Dec] -> Either SDoc [LHsDecl GhcPs] convertToHsDecls origin loc ds = initCvt origin loc (fmap catMaybes (mapM cvt_dec ds))   where     cvt_dec d = wrapMsg "declaration" d (cvtDec d) -convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)+convertToHsExpr :: Origin -> SrcSpan -> TH.Exp -> Either SDoc (LHsExpr GhcPs) convertToHsExpr origin loc e   = initCvt origin loc $ wrapMsg "expression" e $ cvtl e -convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)+convertToPat :: Origin -> SrcSpan -> TH.Pat -> Either SDoc (LPat GhcPs) convertToPat origin loc p   = initCvt origin loc $ wrapMsg "pattern" p $ cvtPat p -convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)+convertToHsType :: Origin -> SrcSpan -> TH.Type -> Either SDoc (LHsType GhcPs) convertToHsType origin loc t   = initCvt origin loc $ wrapMsg "type" t $ cvtType t  --------------------------------------------------------------------newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either MsgDoc (SrcSpan, a) }+newtype CvtM a = CvtM { unCvtM :: Origin -> SrcSpan -> Either SDoc (SrcSpan, a) }     deriving (Functor)         -- Push down the Origin (that is configurable by         -- -fenable-th-splice-warnings) and source location;@@ -107,13 +109,13 @@     Left err -> Left err     Right (loc',v) -> unCvtM (k v) origin loc' -initCvt :: Origin -> SrcSpan -> CvtM a -> Either MsgDoc a+initCvt :: Origin -> SrcSpan -> CvtM a -> Either SDoc a initCvt origin loc (CvtM m) = fmap snd (m origin loc)  force :: a -> CvtM () force a = a `seq` return () -failWith :: MsgDoc -> CvtM a+failWith :: SDoc -> CvtM a failWith m = CvtM (\_ _ -> Left m)  getOrigin :: CvtM Origin@@ -128,12 +130,19 @@ returnL :: a -> CvtM (Located a) returnL x = CvtM (\_ loc -> Right (loc, L loc x)) -returnJustL :: a -> CvtM (Maybe (Located a))-returnJustL = fmap Just . returnL+-- returnLA :: a -> CvtM (LocatedA a)+returnLA :: e -> CvtM (GenLocated (SrcSpanAnn' (EpAnn ann)) e)+returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x)) -wrapParL :: (Located a -> a) -> a -> CvtM a-wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))+returnJustLA :: a -> CvtM (Maybe (LocatedA a))+returnJustLA = fmap Just . returnLA +-- wrapParL :: (Located a -> a) -> a -> CvtM a+-- wrapParL add_par x = CvtM (\_ loc -> Right (loc, add_par (L loc x)))++wrapParLA :: (LocatedA a -> a) -> a -> CvtM a+wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))+ wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g  wrapMsg "declaration" dec thing wrapMsg what item (CvtM m)@@ -153,6 +162,16 @@   Left err -> Left err   Right (loc', v) -> Right (loc', L loc v) +wrapLN :: CvtM a -> CvtM (LocatedN a)+wrapLN (CvtM m) = CvtM $ \origin loc -> case m origin loc of+  Left err -> Left err+  Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)++wrapLA :: CvtM a -> CvtM (LocatedA a)+wrapLA (CvtM m) = CvtM $ \origin loc -> case m origin loc of+  Left err -> Left err+  Right (loc', v) -> Right (loc', L (noAnnSrcSpan loc) v)+ ------------------------------------------------------------------- cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs] cvtDecs = fmap catMaybes . mapM cvtDec@@ -160,19 +179,19 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs)) cvtDec (TH.ValD pat body ds)   | TH.VarP s <- pat-  = do  { s' <- vNameL s+  = do  { s' <- vNameN s         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)         ; th_origin <- getOrigin-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }+        ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin s' [cl'] }    | otherwise   = do  { pat' <- cvtPat pat         ; body' <- cvtGuard body         ; ds' <- cvtLocalDecs (text "a where clause") ds-        ; returnJustL $ Hs.ValD noExtField $+        ; returnJustLA $ Hs.ValD noExtField $           PatBind { pat_lhs = pat'-                  , pat_rhs = GRHSs noExtField body' (noLoc ds')-                  , pat_ext = noExtField+                  , pat_rhs = GRHSs emptyComments body' ds'+                  , pat_ext = noAnn                   , pat_ticks = ([],[]) } }  cvtDec (TH.FunD nm cls)@@ -181,30 +200,30 @@                  <+> quotes (text (TH.pprint nm))                  <+> text "has no equations")   | otherwise-  = do  { nm' <- vNameL nm+  = do  { nm' <- vNameN nm         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls         ; th_origin <- getOrigin-        ; returnJustL $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }+        ; returnJustLA $ Hs.ValD noExtField $ mkFunBind th_origin nm' cls' }  cvtDec (TH.SigD nm typ)-  = do  { nm' <- vNameL nm-        ; ty' <- cvtType typ-        ; returnJustL $ Hs.SigD noExtField-                                    (TypeSig noExtField [nm'] (mkLHsSigWcType ty')) }+  = do  { nm' <- vNameN nm+        ; ty' <- cvtSigType typ+        ; returnJustLA $ Hs.SigD noExtField+                                    (TypeSig noAnn [nm'] (mkHsWildCardBndrs ty')) }  cvtDec (TH.KiSigD nm ki)-  = do  { nm' <- tconNameL nm-        ; ki' <- cvtType ki-        ; let sig' = StandaloneKindSig noExtField nm' (mkLHsSigType ki')-        ; returnJustL $ Hs.KindSigD noExtField sig' }+  = do  { nm' <- tconNameN nm+        ; ki' <- cvtSigKind ki+        ; let sig' = StandaloneKindSig noAnn nm' ki'+        ; returnJustLA $ Hs.KindSigD noExtField sig' }  cvtDec (TH.InfixD fx nm)   -- Fixity signatures are allowed for variables, constructors, and types   -- the renamer automatically looks for types during renaming, even when   -- the RdrName says it's a variable or a constructor. So, just assume   -- it's a variable or constructor and proceed.-  = do { nm' <- vcNameL nm-       ; returnJustL (Hs.SigD noExtField (FixSig noExtField+  = do { nm' <- vcNameN nm+       ; returnJustLA (Hs.SigD noExtField (FixSig noAnn                                       (FixitySig noExtField [nm'] (cvtFixity fx)))) }  cvtDec (PragmaD prag)@@ -213,8 +232,8 @@ cvtDec (TySynD tc tvs rhs)   = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs         ; rhs' <- cvtType rhs-        ; returnJustL $ TyClD noExtField $-          SynDecl { tcdSExt = noExtField, tcdLName = tc', tcdTyVars = tvs'+        ; returnJustLA $ TyClD noExtField $+          SynDecl { tcdSExt = noAnn, tcdLName = tc', tcdTyVars = tvs'                   , tcdFixity = Prefix                   , tcdRhs = rhs' } } @@ -236,11 +255,11 @@         ; derivs' <- cvtDerivs derivs         ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = DataType, dd_cType = Nothing-                                , dd_ctxt = ctxt'+                                , dd_ctxt = Just ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = cons', dd_derivs = derivs' }-        ; returnJustL $ TyClD noExtField $-          DataDecl { tcdDExt = noExtField+        ; returnJustLA $ TyClD noExtField $+          DataDecl { tcdDExt = noAnn                    , tcdLName = tc', tcdTyVars = tvs'                    , tcdFixity = Prefix                    , tcdDataDefn = defn } }@@ -252,12 +271,12 @@         ; derivs' <- cvtDerivs derivs         ; let defn = HsDataDefn { dd_ext = noExtField                                 , dd_ND = NewType, dd_cType = Nothing-                                , dd_ctxt = ctxt'+                                , dd_ctxt = Just ctxt'                                 , dd_kindSig = ksig'                                 , dd_cons = [con']                                 , dd_derivs = derivs' }-        ; returnJustL $ TyClD noExtField $-          DataDecl { tcdDExt = noExtField+        ; returnJustLA $ TyClD noExtField $+          DataDecl { tcdDExt = noAnn                    , tcdLName = tc', tcdTyVars = tvs'                    , tcdFixity = Prefix                    , tcdDataDefn = defn } }@@ -270,9 +289,9 @@             (failWith $ (text "Default data instance declarations"                      <+> text "are not allowed:")                    $$ (Outputable.ppr adts'))-        ; returnJustL $ TyClD noExtField $-          ClassDecl { tcdCExt = NoLayoutInfo-                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'+        ; returnJustLA $ TyClD noExtField $+          ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo)+                    , tcdCtxt = Just cxt', tcdLName = tc', tcdTyVars = tvs'                     , tcdFixity = Prefix                     , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'                     , tcdMeths = binds'@@ -286,13 +305,15 @@         ; unless (null fams') (failWith (mkBadDecMsg doc fams'))         ; ctxt' <- cvtContext funPrec ctxt         ; (L loc ty') <- cvtType ty-        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'-        ; returnJustL $ InstD noExtField $ ClsInstD noExtField $-          ClsInstDecl { cid_ext = noExtField, cid_poly_ty = mkLHsSigType inst_ty'+        ; let inst_ty' = L loc $ mkHsImplicitSigType $+                         mkHsQualTy ctxt loc ctxt' $ L loc ty'+        ; returnJustLA $ InstD noExtField $ ClsInstD noExtField $+          ClsInstDecl { cid_ext = (noAnn, NoAnnSortKey), cid_poly_ty = inst_ty'                       , cid_binds = binds'                       , cid_sigs = Hs.mkClassOpSigs sigs'                       , cid_tyfam_insts = ats', cid_datafam_insts = adts'-                      , cid_overlap_mode = fmap (L loc . overlap) o } }+                      , cid_overlap_mode+                                   = fmap (L (l2l loc) . overlap) o } }   where   overlap pragma =     case pragma of@@ -306,13 +327,13 @@  cvtDec (ForeignD ford)   = do { ford' <- cvtForD ford-       ; returnJustL $ ForD noExtField ford' }+       ; returnJustLA $ ForD noExtField ford' }  cvtDec (DataFamilyD tc tvs kind)   = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs        ; result <- cvtMaybeKindToFamilyResultSig kind-       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $-         FamilyDecl noExtField DataFamily tc' tvs' Prefix result Nothing }+       ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noAnn DataFamily TopLevel tc' tvs' Prefix result Nothing }  cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)   = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys@@ -321,14 +342,14 @@        ; derivs' <- cvtDerivs derivs        ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = DataType, dd_cType = Nothing-                               , dd_ctxt = ctxt'+                               , dd_ctxt = Just ctxt'                                , dd_kindSig = ksig'                                , dd_cons = cons', dd_derivs = derivs' } -       ; returnJustL $ InstD noExtField $ DataFamInstD-           { dfid_ext = noExtField-           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $-                           FamEqn { feqn_ext = noExtField+       ; returnJustLA $ InstD noExtField $ DataFamInstD+           { dfid_ext = noAnn+           , dfid_inst = DataFamInstDecl { dfid_eqn =+                           FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'                                   , feqn_bndrs = bndrs'                                   , feqn_pats = typats'@@ -342,13 +363,13 @@        ; derivs' <- cvtDerivs derivs        ; let defn = HsDataDefn { dd_ext = noExtField                                , dd_ND = NewType, dd_cType = Nothing-                               , dd_ctxt = ctxt'+                               , dd_ctxt = Just ctxt'                                , dd_kindSig = ksig'                                , dd_cons = [con'], dd_derivs = derivs' }-       ; returnJustL $ InstD noExtField $ DataFamInstD-           { dfid_ext = noExtField-           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $-                           FamEqn { feqn_ext = noExtField+       ; returnJustLA $ InstD noExtField $ DataFamInstD+           { dfid_ext = noAnn+           , dfid_inst = DataFamInstDecl { dfid_eqn =+                           FamEqn { feqn_ext = noAnn                                   , feqn_tycon = tc'                                   , feqn_bndrs = bndrs'                                   , feqn_pats = typats'@@ -357,71 +378,74 @@  cvtDec (TySynInstD eqn)   = do  { (L _ eqn') <- cvtTySynEqn eqn-        ; returnJustL $ InstD noExtField $ TyFamInstD+        ; returnJustLA $ InstD noExtField $ TyFamInstD             { tfid_ext = noExtField-            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }+            , tfid_inst = TyFamInstDecl { tfid_xtn = noAnn, tfid_eqn = eqn' } }}  cvtDec (OpenTypeFamilyD head)   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head-       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $-         FamilyDecl noExtField OpenTypeFamily tc' tyvars' Prefix result' injectivity'+       ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noAnn OpenTypeFamily TopLevel tc' tyvars' Prefix result' injectivity'        }  cvtDec (ClosedTypeFamilyD head eqns)   = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head        ; eqns' <- mapM cvtTySynEqn eqns-       ; returnJustL $ TyClD noExtField $ FamDecl noExtField $-         FamilyDecl noExtField (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix+       ; returnJustLA $ TyClD noExtField $ FamDecl noExtField $+         FamilyDecl noAnn (ClosedTypeFamily (Just eqns')) TopLevel tc' tyvars' Prefix                            result' injectivity' }  cvtDec (TH.RoleAnnotD tc roles)-  = do { tc' <- tconNameL tc+  = do { tc' <- tconNameN tc        ; let roles' = map (noLoc . cvtRole) roles-       ; returnJustL $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noExtField tc' roles') }+       ; returnJustLA+                   $ Hs.RoleAnnotD noExtField (RoleAnnotDecl noAnn tc' roles') }  cvtDec (TH.StandaloneDerivD ds cxt ty)   = do { cxt' <- cvtContext funPrec cxt        ; ds'  <- traverse cvtDerivStrategy ds        ; (L loc ty') <- cvtType ty-       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'-       ; returnJustL $ DerivD noExtField $-         DerivDecl { deriv_ext =noExtField+       ; let inst_ty' = L loc $ mkHsImplicitSigType $+                        mkHsQualTy cxt loc cxt' $ L loc ty'+       ; returnJustLA $ DerivD noExtField $+         DerivDecl { deriv_ext = noAnn                    , deriv_strategy = ds'-                   , deriv_type = mkLHsSigWcType inst_ty'+                   , deriv_type = mkHsWildCardBndrs inst_ty'                    , deriv_overlap_mode = Nothing } }  cvtDec (TH.DefaultSigD nm typ)-  = do { nm' <- vNameL nm-       ; ty' <- cvtType typ-       ; returnJustL $ Hs.SigD noExtField-                     $ ClassOpSig noExtField True [nm'] (mkLHsSigType ty')}+  = do { nm' <- vNameN nm+       ; ty' <- cvtSigType typ+       ; returnJustLA $ Hs.SigD noExtField+                      $ ClassOpSig noAnn True [nm'] ty'}  cvtDec (TH.PatSynD nm args dir pat)-  = do { nm'   <- cNameL nm+  = do { nm'   <- cNameN nm        ; args' <- cvtArgs args        ; dir'  <- cvtDir nm' dir        ; pat'  <- cvtPat pat-       ; returnJustL $ Hs.ValD noExtField $ PatSynBind noExtField $-           PSB noExtField nm' args' pat' dir' }+       ; returnJustLA $ Hs.ValD noExtField $ PatSynBind noExtField $+           PSB noAnn nm' args' pat' dir' }   where-    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args-    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon noTypeArgs <$> mapM vNameN args+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameN a1 <*> vNameN a2     cvtArgs (TH.RecordPatSyn sels)-      = do { sels' <- mapM vNameL sels-           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels+      = do { sels' <- mapM (fmap (\ (L li i) -> FieldOcc noExtField (L li i)) . vNameN) sels+           ; vars' <- mapM (vNameN . mkNameS . nameBase) sels            ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' } +    -- cvtDir :: LocatedN RdrName -> (PatSynDir -> CvtM (HsPatSynDir RdrName))     cvtDir _ Unidir          = return Unidirectional     cvtDir _ ImplBidir       = return ImplicitBidirectional     cvtDir n (ExplBidir cls) =       do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls          ; th_origin <- getOrigin-         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin ms }+         ; return $ ExplicitBidirectional $ mkMatchGroup th_origin (noLocA ms) }  cvtDec (TH.PatSynSigD nm ty)-  = do { nm' <- cNameL nm+  = do { nm' <- cNameN nm        ; ty' <- cvtPatSynSigTy ty-       ; returnJustL $ Hs.SigD noExtField $ PatSynSig noExtField [nm'] (mkLHsSigType ty')}+       ; returnJustLA $ Hs.SigD noExtField $ PatSynSig noAnn [nm'] ty'}  -- Implicit parameter bindings are handled in cvtLocalDecs and -- cvtImplicitParamBind. They are not allowed in any other scope, so@@ -433,25 +457,26 @@ cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs) cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)   = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs+       ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs mb_bndrs'        ; (head_ty, args) <- split_ty_app lhs        ; case head_ty of-           ConT nm -> do { nm' <- tconNameL nm+           ConT nm -> do { nm' <- tconNameN nm                          ; rhs' <- cvtType rhs                          ; let args' = map wrap_tyarg args-                         ; returnL $ mkHsImplicitBndrs-                            $ FamEqn { feqn_ext    = noExtField+                         ; returnLA+                            $ FamEqn { feqn_ext    = noAnn                                      , feqn_tycon  = nm'-                                     , feqn_bndrs  = mb_bndrs'+                                     , feqn_bndrs  = outer_bndrs                                      , feqn_pats   = args'                                      , feqn_fixity = Prefix                                      , feqn_rhs    = rhs' } }-           InfixT t1 nm t2 -> do { nm' <- tconNameL nm+           InfixT t1 nm t2 -> do { nm' <- tconNameN nm                                  ; args' <- mapM cvtType [t1,t2]                                  ; rhs' <- cvtType rhs-                                 ; returnL $ mkHsImplicitBndrs-                                      $ FamEqn { feqn_ext    = noExtField+                                 ; returnLA+                                      $ FamEqn { feqn_ext    = noAnn                                                , feqn_tycon  = nm'-                                               , feqn_bndrs  = mb_bndrs'+                                               , feqn_bndrs  = outer_bndrs                                                , feqn_pats   =                                                 (map HsValArg args') ++ args                                                , feqn_fixity = Hs.Infix@@ -461,7 +486,7 @@         }  -----------------cvt_ci_decs :: MsgDoc -> [TH.Dec]+cvt_ci_decs :: SDoc -> [TH.Dec]             -> CvtM (LHsBinds GhcPs,                      [LSig GhcPs],                      [LFamilyDecl GhcPs],@@ -482,38 +507,39 @@ ---------------- cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr ()]              -> CvtM ( LHsContext GhcPs-                     , Located RdrName+                     , LocatedN RdrName                      , LHsQTyVars GhcPs) cvt_tycl_hdr cxt tc tvs   = do { cxt' <- cvtContext funPrec cxt-       ; tc'  <- tconNameL tc+       ; tc'  <- tconNameN tc        ; tvs' <- cvtTvs tvs        ; return (cxt', tc', mkHsQTvs tvs')        }  cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr ()] -> TH.Type                -> CvtM ( LHsContext GhcPs-                       , Located RdrName-                       , Maybe [LHsTyVarBndr () GhcPs]+                       , LocatedN RdrName+                       , HsOuterFamEqnTyVarBndrs GhcPs                        , HsTyPats GhcPs) cvt_datainst_hdr cxt bndrs tys   = do { cxt' <- cvtContext funPrec cxt        ; bndrs' <- traverse (mapM cvt_tv) bndrs+       ; let outer_bndrs = mkHsOuterFamEqnTyVarBndrs bndrs'        ; (head_ty, args) <- split_ty_app tys        ; case head_ty of-          ConT nm -> do { nm' <- tconNameL nm+          ConT nm -> do { nm' <- tconNameN nm                         ; let args' = map wrap_tyarg args-                        ; return (cxt', nm', bndrs', args') }-          InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                        ; return (cxt', nm', outer_bndrs, args') }+          InfixT t1 nm t2 -> do { nm' <- tconNameN nm                                 ; args' <- mapM cvtType [t1,t2]-                                ; return (cxt', nm', bndrs',+                                ; return (cxt', nm', outer_bndrs,                                          ((map HsValArg args') ++ args)) }           _ -> failWith $ text "Invalid type instance header:"                           <+> text (show tys) }  ---------------- cvt_tyfam_head :: TypeFamilyHead-               -> CvtM ( Located RdrName+               -> CvtM ( LocatedN RdrName                        , LHsQTyVars GhcPs                        , Hs.LFamilyResultSig GhcPs                        , Maybe (Hs.LInjectivityAnn GhcPs))@@ -557,7 +583,7 @@ is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e) is_ip_bind decl             = Right decl -mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc+mkBadDecMsg :: Outputable a => SDoc -> [a] -> SDoc mkBadDecMsg doc bads   = sep [ text "Illegal declaration(s) in" <+> doc <> colon         , nest 2 (vcat (map Outputable.ppr bads)) ]@@ -569,28 +595,28 @@ cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)  cvtConstr (NormalC c strtys)-  = do  { c'   <- cNameL c+  = do  { c'   <- cNameN c         ; tys' <- mapM cvt_arg strtys-        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon (map hsLinear tys')) }+        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing (PrefixCon noTypeArgs (map hsLinear tys')) }  cvtConstr (RecC c varstrtys)-  = do  { c'    <- cNameL c+  = do  { c'    <- cNameN c         ; args' <- mapM cvt_id_arg varstrtys-        ; returnL $ mkConDeclH98 c' Nothing Nothing-                                   (RecCon (noLoc args')) }+        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing+                                   (RecCon (noLocA args')) }  cvtConstr (InfixC st1 c st2)-  = do  { c'   <- cNameL c+  = do  { c'   <- cNameN c         ; st1' <- cvt_arg st1         ; st2' <- cvt_arg st2-        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon (hsLinear st1')-                                                              (hsLinear st2')) }+        ; returnLA $ mkConDeclH98 noAnn c' Nothing Nothing+                       (InfixCon (hsLinear st1') (hsLinear st2')) }  cvtConstr (ForallC tvs ctxt con)   = do  { tvs'      <- cvtTvs tvs         ; ctxt'     <- cvtContext funPrec ctxt         ; L _ con'  <- cvtConstr con-        ; returnL $ add_forall tvs' ctxt' con' }+        ; returnLA $ add_forall tvs' ctxt' con' }   where     add_cxt lcxt         Nothing           = Just lcxt     add_cxt (L loc cxt1) (Just (L _ cxt2))@@ -598,15 +624,20 @@      add_forall :: [LHsTyVarBndr Hs.Specificity GhcPs] -> LHsContext GhcPs                -> ConDecl GhcPs -> ConDecl GhcPs-    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })-      = con { con_forall = noLoc $ not (null all_tvs)-            , con_qvars  = all_tvs+    add_forall tvs' cxt' con@(ConDeclGADT { con_bndrs = L l outer_bndrs, con_mb_cxt = cxt })+      = con { con_bndrs  = L l outer_bndrs'             , con_mb_cxt = add_cxt cxt' cxt }       where-        all_tvs = tvs' ++ qvars+        outer_bndrs'+          | null all_tvs = mkHsOuterImplicit+          | otherwise    = mkHsOuterExplicit noAnn all_tvs +        all_tvs = tvs' ++ outer_exp_tvs++        outer_exp_tvs = hsOuterExplicitBndrs outer_bndrs+     add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })-      = con { con_forall = noLoc $ not (null all_tvs)+      = con { con_forall = not (null all_tvs)             , con_ex_tvs = all_tvs             , con_mb_cxt = add_cxt cxt' cxt }       where@@ -616,29 +647,28 @@   = failWith (text "GadtC must have at least one constructor name")  cvtConstr (GadtC c strtys ty)-  = do  { c'      <- mapM cNameL c+  = do  { c'      <- mapM cNameN c         ; args    <- mapM cvt_arg strtys         ; ty'     <- cvtType ty-        ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'}+        ; returnLA $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'}  cvtConstr (RecGadtC [] _varstrtys _ty)   = failWith (text "RecGadtC must have at least one constructor name")  cvtConstr (RecGadtC c varstrtys ty)-  = do  { c'       <- mapM cNameL c+  = do  { c'       <- mapM cNameN c         ; ty'      <- cvtType ty         ; rec_flds <- mapM cvt_id_arg varstrtys-        ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' }+        ; returnLA $ mk_gadt_decl c' (RecConGADT $ noLocA rec_flds) ty' } -mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs+mk_gadt_decl :: [LocatedN RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs              -> ConDecl GhcPs mk_gadt_decl names args res_ty-  = ConDeclGADT { con_g_ext  = noExtField+  = ConDeclGADT { con_g_ext  = noAnn                 , con_names  = names-                , con_forall = noLoc False-                , con_qvars  = []+                , con_bndrs  = noLocA mkHsOuterImplicit                 , con_mb_cxt = Nothing-                , con_args   = args+                , con_g_args = args                 , con_res_ty = res_ty                 , con_doc    = Nothing } @@ -658,27 +688,27 @@        ; let ty' = parenthesizeHsType appPrec ty''              su' = cvtSrcUnpackedness su              ss' = cvtSrcStrictness ss-       ; returnL $ HsBangTy noExtField (HsSrcBang NoSourceText su' ss') ty' }+       ; returnLA $ HsBangTy noAnn (HsSrcBang NoSourceText su' ss') ty' }  cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs) cvt_id_arg (i, str, ty)-  = do  { L li i' <- vNameL i+  = do  { L li i' <- vNameN i         ; ty' <- cvt_arg (str,ty)-        ; return $ noLoc (ConDeclField-                          { cd_fld_ext = noExtField+        ; return $ noLocA (ConDeclField+                          { cd_fld_ext = noAnn                           , cd_fld_names-                              = [L li $ FieldOcc noExtField (L li i')]+                              = [L (locA li) $ FieldOcc noExtField (L li i')]                           , cd_fld_type =  ty'                           , cd_fld_doc = Nothing}) }  cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs) cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs-                  ; returnL cs' }+                  ; return cs' } -cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)-cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs-                               ; ys' <- mapM tNameL ys-                               ; returnL (xs', ys') }+cvt_fundep :: TH.FunDep -> CvtM (LHsFunDep GhcPs)+cvt_fundep (TH.FunDep xs ys) = do { xs' <- mapM tNameN xs+                                  ; ys' <- mapM tNameN ys+                                  ; returnLA (Hs.FunDep noAnn xs' ys') }   ------------------------------------------@@ -703,11 +733,11 @@   = failWith $ text (show from) <+> text "is not a valid ccall impent"   where     mk_imp impspec-      = do { nm' <- vNameL nm-           ; ty' <- cvtType ty-           ; return (ForeignImport { fd_i_ext = noExtField+      = do { nm' <- vNameN nm+           ; ty' <- cvtSigType ty+           ; return (ForeignImport { fd_i_ext = noAnn                                    , fd_name = nm'-                                   , fd_sig_ty = mkLHsSigType ty'+                                   , fd_sig_ty = ty'                                    , fd_fi = impspec })            }     safety' = case safety of@@ -716,15 +746,15 @@                      Interruptible -> PlayInterruptible  cvtForD (ExportF callconv as nm ty)-  = do  { nm' <- vNameL nm-        ; ty' <- cvtType ty+  = do  { nm' <- vNameN nm+        ; ty' <- cvtSigType ty         ; let e = CExport (noLoc (CExportStatic (SourceText as)                                                 (mkFastString as)                                                 (cvt_conv callconv)))                                                 (noLoc (SourceText as))-        ; return $ ForeignExport { fd_e_ext = noExtField+        ; return $ ForeignExport { fd_e_ext = noAnn                                  , fd_name = nm'-                                 , fd_sig_ty = mkLHsSigType ty'+                                 , fd_sig_ty = ty'                                  , fd_fe = e } }  cvt_conv :: TH.Callconv -> CCallConv@@ -740,7 +770,7 @@  cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs)) cvtPragmaD (InlineP nm inline rm phases)-  = do { nm' <- vNameL nm+  = do { nm' <- vNameN nm        ; let dflt = dfltActivation inline        ; let src TH.NoInline  = "{-# NOINLINE"              src TH.Inline    = "{-# INLINE"@@ -750,30 +780,30 @@                                  , inl_rule   = cvtRuleMatch rm                                  , inl_act    = cvtPhases phases dflt                                  , inl_sat    = Nothing }-       ; returnJustL $ Hs.SigD noExtField $ InlineSig noExtField nm' ip }+       ; returnJustLA $ Hs.SigD noExtField $ InlineSig noAnn nm' ip }  cvtPragmaD (SpecialiseP nm ty inline phases)-  = do { nm' <- vNameL nm-       ; ty' <- cvtType ty+  = do { nm' <- vNameN nm+       ; ty' <- cvtSigType ty        ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"              src TH.Inline    = "{-# SPECIALISE INLINE"              src TH.Inlinable = "{-# SPECIALISE INLINE"        ; let (inline', dflt,srcText) = case inline of                Just inline1 -> (cvtInline inline1, dfltActivation inline1,                                 src inline1)-               Nothing      -> (NoUserInline,   AlwaysActive,+               Nothing      -> (NoUserInlinePrag,   AlwaysActive,                                 "{-# SPECIALISE")        ; let ip = InlinePragma { inl_src    = SourceText srcText                                , inl_inline = inline'                                , inl_rule   = Hs.FunLike                                , inl_act    = cvtPhases phases dflt                                , inl_sat    = Nothing }-       ; returnJustL $ Hs.SigD noExtField $ SpecSig noExtField nm' [mkLHsSigType ty'] ip }+       ; returnJustLA $ Hs.SigD noExtField $ SpecSig noAnn nm' [ty'] ip }  cvtPragmaD (SpecialiseInstP ty)-  = do { ty' <- cvtType ty-       ; returnJustL $ Hs.SigD noExtField $-         SpecInstSig noExtField (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }+  = do { ty' <- cvtSigType ty+       ; returnJustLA $ Hs.SigD noExtField $+         SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' }  cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)   = do { let nm' = mkFastString nm@@ -782,11 +812,11 @@        ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs        ; lhs'   <- cvtl lhs        ; rhs'   <- cvtl rhs-       ; returnJustL $ Hs.RuleD noExtField-            $ HsRules { rds_ext = noExtField+       ; returnJustLA $ Hs.RuleD noExtField+            $ HsRules { rds_ext = noAnn                       , rds_src = SourceText "{-# RULES"-                      , rds_rules = [noLoc $-                          HsRule { rd_ext  = noExtField+                      , rds_rules = [noLocA $+                          HsRule { rd_ext  = noAnn                                  , rd_name = (noLoc (quotedSourceText nm,nm'))                                  , rd_act  = act                                  , rd_tyvs = ty_bndrs'@@ -802,12 +832,12 @@          ModuleAnnotation  -> return ModuleAnnProvenance          TypeAnnotation n  -> do            n' <- tconName n-           return (TypeAnnProvenance  (noLoc n'))+           return (TypeAnnProvenance  (noLocA n'))          ValueAnnotation n -> do            n' <- vcName n-           return (ValueAnnProvenance (noLoc n'))-       ; returnJustL $ Hs.AnnD noExtField-                     $ HsAnnotation noExtField (SourceText "{-# ANN") target' exp'+           return (ValueAnnProvenance (noLocA n'))+       ; returnJustLA $ Hs.AnnD noExtField+                     $ HsAnnotation noAnn (SourceText "{-# ANN") target' exp'        }  cvtPragmaD (LineP line file)@@ -815,10 +845,10 @@        ; return Nothing        } cvtPragmaD (CompleteP cls mty)-  = do { cls' <- noLoc <$> mapM cNameL cls-       ; mty'  <- traverse tconNameL mty-       ; returnJustL $ Hs.SigD noExtField-                   $ CompleteMatchSig noExtField NoSourceText cls' mty' }+  = do { cls' <- noLoc <$> mapM cNameN cls+       ; mty'  <- traverse tconNameN mty+       ; returnJustLA $ Hs.SigD noExtField+                   $ CompleteMatchSig noAnn NoSourceText cls' mty' }  dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive@@ -840,18 +870,18 @@  cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs) cvtRuleBndr (RuleVar n)-  = do { n' <- vNameL n-       ; return $ noLoc $ Hs.RuleBndr noExtField n' }+  = do { n' <- vNameN n+       ; return $ noLoc $ Hs.RuleBndr noAnn n' } cvtRuleBndr (TypedRuleVar n ty)-  = do { n'  <- vNameL n+  = do { n'  <- vNameN n        ; ty' <- cvtType ty-       ; return $ noLoc $ Hs.RuleBndrSig noExtField n' $ mkHsPatSigType ty' }+       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }  --------------------------------------------------- --              Declarations --------------------------------------------------- -cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)+cvtLocalDecs :: SDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs) cvtLocalDecs doc ds   = case partitionWith is_ip_bind ds of       ([], []) -> return (EmptyLocalBinds noExtField)@@ -860,10 +890,10 @@         let (binds, prob_sigs) = partitionWith is_bind ds'         let (sigs, bads) = partitionWith is_sig prob_sigs         unless (null bads) (failWith (mkBadDecMsg doc bads))-        return (HsValBinds noExtField (ValBinds noExtField (listToBag binds) sigs))+        return (HsValBinds noAnn (ValBinds NoAnnSortKey (listToBag binds) sigs))       (ip_binds, []) -> do         binds <- mapM (uncurry cvtImplicitParamBind) ip_binds-        return (HsIPBinds noExtField (IPBinds noExtField binds))+        return (HsIPBinds noAnn (IPBinds noExtField binds))       ((_:_), (_:_)) ->         failWith (text "Implicit parameters mixed with other bindings") @@ -874,27 +904,27 @@         ; let pps = map (parenthesizePat appPrec) ps'         ; g'  <- cvtGuard body         ; ds' <- cvtLocalDecs (text "a where clause") wheres-        ; returnL $ Hs.Match noExtField ctxt pps (GRHSs noExtField g' (noLoc ds')) }+        ; returnLA $ Hs.Match noAnn ctxt pps (GRHSs emptyComments g' ds') }  cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs) cvtImplicitParamBind n e = do     n' <- wrapL (ipName n)     e' <- cvtl e-    returnL (IPBind noExtField (Left n') e')+    returnLA (IPBind noAnn (Left n') e')  ------------------------------------------------------------------- --              Expressions -------------------------------------------------------------------  cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)-cvtl e = wrapL (cvt e)+cvtl e = wrapLA (cvt e)   where-    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExtField (noLoc s') }-    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExtField (noLoc s') }+    cvt (VarE s)   = do { s' <- vName s; return $ HsVar noExtField (noLocA s') }+    cvt (ConE s)   = do { s' <- cName s; return $ HsVar noExtField (noLocA s') }     cvt (LitE l)-      | overloadedLit l = go cvtOverLit (HsOverLit noExtField)+      | overloadedLit l = go cvtOverLit (HsOverLit noComments)                              (hsOverLitNeedsParens appPrec)-      | otherwise       = go cvtLit (HsLit noExtField)+      | otherwise       = go cvtLit (HsLit noComments)                              (hsLitNeedsParens appPrec)       where         go :: (Lit -> CvtM (l GhcPs))@@ -904,17 +934,17 @@         go cvt_lit mk_expr is_compound_lit = do           l' <- cvt_lit l           let e' = mk_expr l'-          return $ if is_compound_lit l' then HsPar noExtField (noLoc e') else e'+          return $ if is_compound_lit l' then HsPar noAnn (noLocA e') else e'     cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y-                                   ; return $ HsApp noExtField (mkLHsPar x')+                                   ; return $ HsApp noComments (mkLHsPar x')                                                           (mkLHsPar y')}     cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y-                                   ; return $ HsApp noExtField (mkLHsPar x')+                                   ; return $ HsApp noComments (mkLHsPar x')                                                           (mkLHsPar y')}     cvt (AppTypeE e t) = do { e' <- cvtl e                             ; t' <- cvtType t                             ; let tp = parenthesizeHsType appPrec t'-                            ; return $ HsAppType noExtField e'+                            ; return $ HsAppType noSrcSpan e'                                      $ mkHsWildCardBndrs tp }     cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its                                -- own expression to avoid pretty-printing@@ -924,42 +954,42 @@                             ; let pats = map (parenthesizePat appPrec) ps'                             ; th_origin <- getOrigin                             ; return $ HsLam noExtField (mkMatchGroup th_origin-                                             [mkSimpleMatch LambdaExpr-                                             pats e'])}+                                             (noLocA [mkSimpleMatch LambdaExpr+                                             pats e']))}     cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms                             ; th_origin <- getOrigin-                            ; return $ HsLamCase noExtField-                                                   (mkMatchGroup th_origin ms')+                            ; return $ HsLamCase noAnn+                                                   (mkMatchGroup th_origin (noLocA ms'))                             }     cvt (TupE es)        = cvt_tup es Boxed     cvt (UnboxedTupE es) = cvt_tup es Unboxed     cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e                                        ; unboxedSumChecks alt arity-                                       ; return $ ExplicitSum noExtField+                                       ; return $ ExplicitSum noAnn                                                                    alt arity e'}     cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;-                            ; return $ mkHsIf x' y' z' }+                            ; return $ mkHsIf x' y' z' noAnn }     cvt (MultiIfE alts)       | null alts      = failWith (text "Multi-way if-expression with no alternatives")       | otherwise      = do { alts' <- mapM cvtpair alts-                            ; return $ HsMultiIf noExtField alts' }+                            ; return $ HsMultiIf noAnn alts' }     cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds-                            ; e' <- cvtl e; return $ HsLet noExtField (noLoc ds') e'}+                            ; e' <- cvtl e; return $ HsLet noAnn ds' e'}     cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms                             ; th_origin <- getOrigin-                            ; return $ HsCase noExtField e'-                                                 (mkMatchGroup th_origin ms') }+                            ; return $ HsCase noAnn e'+                                                 (mkMatchGroup th_origin (noLocA ms')) }     cvt (DoE m ss)     = cvtHsDo (DoExpr (mk_mod <$> m)) ss     cvt (MDoE m ss)    = cvtHsDo (MDoExpr (mk_mod <$> m)) ss     cvt (CompE ss)     = cvtHsDo ListComp ss     cvt (ArithSeqE dd) = do { dd' <- cvtDD dd-                            ; return $ ArithSeq noExtField Nothing dd' }+                            ; return $ ArithSeq noAnn Nothing dd' }     cvt (ListE xs)       | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)-                                          ; return (HsLit noExtField l') }+                                          ; return (HsLit noComments l') }              -- Note [Converting strings]       | otherwise       = do { xs' <- mapM cvtl xs-                             ; return $ ExplicitList noExtField Nothing xs'+                             ; return $ ExplicitList noAnn xs'                              }      -- Infix expressions@@ -969,25 +999,25 @@          ; y' <- cvtl y          ; let px = parenthesizeHsExpr opPrec x'                py = parenthesizeHsExpr opPrec y'-         ; wrapParL (HsPar noExtField)-           $ OpApp noExtField px s' py }+         ; wrapParLA (HsPar noAnn)+           $ OpApp noAnn px s' py }            -- Parenthesise both arguments and result,            -- to ensure this operator application does            -- does not get re-associated            -- See Note [Operator association]     cvt (InfixE Nothing  s (Just y)) = ensureValidOpExp s $                                        do { s' <- cvtl s; y' <- cvtl y-                                          ; wrapParL (HsPar noExtField) $-                                                          SectionR noExtField s' y' }+                                          ; wrapParLA (HsPar noAnn) $+                                                          SectionR noComments s' y' }                                             -- See Note [Sections in HsSyn] in GHC.Hs.Expr     cvt (InfixE (Just x) s Nothing ) = ensureValidOpExp s $                                        do { x' <- cvtl x; s' <- cvtl s-                                          ; wrapParL (HsPar noExtField) $-                                                          SectionL noExtField x' s' }+                                          ; wrapParLA (HsPar noAnn) $+                                                          SectionL noComments x' s' }      cvt (InfixE Nothing  s Nothing ) = ensureValidOpExp s $                                        do { s' <- cvtl s-                                          ; return $ HsPar noExtField s' }+                                          ; return $ HsPar noAnn s' }                                        -- Can I indicate this is an infix thing?                                        -- Note [Dropping constructors] @@ -998,26 +1028,29 @@                                             _ -> mkLHsPar x'                               ; cvtOpApp x'' s y } --  Note [Converting UInfix] -    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExtField e' }-    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t+    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noAnn e' }+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtSigType t                               ; let pe = parenthesizeHsExpr sigPrec e'-                              ; return $ ExprWithTySig noExtField pe (mkLHsSigWcType t') }-    cvt (RecConE c flds) = do { c' <- cNameL c-                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds-                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }+                              ; return $ ExprWithTySig noAnn pe (mkHsWildCardBndrs t') }+    cvt (RecConE c flds) = do { c' <- cNameN c+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLocA)) flds+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) noAnn }     cvt (RecUpdE e flds) = do { e' <- cvtl e                               ; flds'-                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLocA))                                            flds-                              ; return $ mkRdrRecordUpd e' flds' }-    cvt (StaticE e)      = fmap (HsStatic noExtField) $ cvtl e+                              ; return $ RecordUpd noAnn e' (Left flds') }+    cvt (StaticE e)      = fmap (HsStatic noAnn) $ cvtl e     cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is                               -- important, because UnboundVarE may contain                               -- constructor names - see #14627.                               { s' <- vcName s-                              ; return $ HsVar noExtField (noLoc s') }-    cvt (LabelE s)       = do { return $ HsOverLabel noExtField Nothing (fsLit s) }-    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExtField n' }+                              ; return $ HsVar noExtField (noLocA s') }+    cvt (LabelE s)       = return $ HsOverLabel noComments (fsLit s)+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noComments n' }+    cvt (GetFieldE exp f) = do { e' <- cvtl exp+                               ; return $ HsGetField noComments e' (L noSrcSpan (HsFieldLabel noAnn (L noSrcSpan (fsLit f)))) }+    cvt (ProjectionE xs) = return $ HsProjection noAnn $ fmap (L noSrcSpan . HsFieldLabel noAnn . L noSrcSpan . fsLit) xs  {- | #16895 Ensure an infix expression's operator is a variable/constructor. Consider this example:@@ -1053,12 +1086,13 @@ -}  cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)-       -> CvtM (LHsRecField' t (LHsExpr GhcPs))+       -> CvtM (LHsRecField' GhcPs t (LHsExpr GhcPs)) cvtFld f (v,e)   = do  { v' <- vNameL v; e' <- cvtl e-        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'-                                     , hsRecFieldArg = e'-                                     , hsRecPun      = False}) }+        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn+                                      , hsRecFieldLbl = reLoc $ fmap f v'+                                      , hsRecFieldArg = e'+                                      , hsRecPun      = False}) }  cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs) cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }@@ -1067,12 +1101,12 @@ cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }  cvt_tup :: [Maybe Exp] -> Boxity -> CvtM (HsExpr GhcPs)-cvt_tup es boxity = do { let cvtl_maybe Nothing  = return missingTupArg-                             cvtl_maybe (Just e) = fmap (Present noExtField) (cvtl e)+cvt_tup es boxity = do { let cvtl_maybe Nothing  = return (missingTupArg noAnn)+                             cvtl_maybe (Just e) = fmap (Present noAnn) (cvtl e)                        ; es' <- mapM cvtl_maybe es                        ; return $ ExplicitTuple-                                    noExtField-                                    (map noLoc es')+                                    noAnn+                                    es'                                     boxity }  {- Note [Operator association]@@ -1129,12 +1163,12 @@ -} cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs) cvtOpApp x op1 (UInfixE y op2 z)-  = do { l <- wrapL $ cvtOpApp x op1 y+  = do { l <- wrapLA $ cvtOpApp x op1 y        ; cvtOpApp l op2 z } cvtOpApp x op y   = do { op' <- cvtl op        ; y' <- cvtl y-       ; return (OpApp noExtField x op' y') }+       ; return (OpApp noAnn x op' y') }  ------------------------------------- --      Do notation and statements@@ -1152,7 +1186,7 @@                       -> return (L loc (mkLastStmt body))                     _ -> failWith (bad_last last') -        ; return $ HsDo noExtField do_or_lc (noLoc (stmts'' ++ [last''])) }+        ; return $ HsDo noAnn do_or_lc (noLocA (stmts'' ++ [last''])) }   where     bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon                          , nest 2 $ Outputable.ppr stmt@@ -1162,45 +1196,45 @@ cvtStmts = mapM cvtStmt  cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))-cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }-cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkPsBindStmt p' e' }+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnLA $ mkBodyStmt e' }+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnLA $ mkPsBindStmt noAnn p' e' } cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds-                            ; returnL $ LetStmt noExtField (noLoc ds') }+                            ; returnLA $ LetStmt noAnn ds' } cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss-                            ; returnL $ ParStmt noExtField dss' noExpr noSyntaxExpr }+                            ; returnLA $ ParStmt noExtField dss' noExpr noSyntaxExpr }   where     cvt_one ds = do { ds' <- cvtStmts ds                     ; return (ParStmtBlock noExtField ds' undefined noSyntaxExpr) }-cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnLA (mkRecStmt noAnn (noLocA ss')) }  cvtMatch :: HsMatchContext GhcPs          -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs)) cvtMatch ctxt (TH.Match p body decs)   = do  { p' <- cvtPat p         ; let lp = case p' of-                     (L loc SigPat{}) -> L loc (ParPat noExtField p') -- #14875+                     (L loc SigPat{}) -> L loc (ParPat noAnn p') -- #14875                      _                -> p'         ; g' <- cvtGuard body         ; decs' <- cvtLocalDecs (text "a where clause") decs-        ; returnL $ Hs.Match noExtField ctxt [lp] (GRHSs noExtField g' (noLoc decs')) }+        ; returnLA $ Hs.Match noAnn ctxt [lp] (GRHSs emptyComments g' decs') }  cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)] cvtGuard (GuardedB pairs) = mapM cvtpair pairs cvtGuard (NormalB e)      = do { e' <- cvtl e-                               ; g' <- returnL $ GRHS noExtField [] e'; return [g'] }+                               ; g' <- returnL $ GRHS noAnn [] e'; return [g'] }  cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs)) cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs-                              ; g' <- returnL $ mkBodyStmt ge'-                              ; returnL $ GRHS noExtField [g'] rhs' }+                              ; g' <- returnLA $ mkBodyStmt ge'+                              ; returnL $ GRHS noAnn [g'] rhs' } cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs-                              ; returnL $ GRHS noExtField gs' rhs' }+                              ; returnL $ GRHS noAnn gs' rhs' }  cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs) cvtOverLit (IntegerL i)   = do { force i; return $ mkHsIntegral   (mkIntegralLit i) } cvtOverLit (RationalL r)-  = do { force r; return $ mkHsFractional (mkFractionalLit r) }+  = do { force r; return $ mkHsFractional (mkTHFractionalLit r) } cvtOverLit (StringL s)   = do { let { s' = mkFastString s }        ; force s'@@ -1235,9 +1269,9 @@ cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i } cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w } cvtLit (FloatPrimL f)-  = do { force f; return $ HsFloatPrim noExtField (mkFractionalLit f) }+  = do { force f; return $ HsFloatPrim noExtField (mkTHFractionalLit f) } cvtLit (DoublePrimL f)-  = do { force f; return $ HsDoublePrim noExtField (mkFractionalLit f) }+  = do { force f; return $ HsDoublePrim noExtField (mkTHFractionalLit f) } cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c } cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c } cvtLit (StringL s)     = do { let { s' = mkFastString s }@@ -1262,37 +1296,39 @@ cvtPats pats = mapM cvtPat pats  cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)-cvtPat pat = wrapL (cvtp pat)+cvtPat pat = wrapLA (cvtp pat)  cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs) cvtp (TH.LitP l)   | overloadedLit l    = do { l' <- cvtOverLit l-                            ; return (mkNPat (noLoc l') Nothing) }+                            ; return (mkNPat (noLoc l') Nothing noAnn) }                                   -- Not right for negative patterns;                                   -- need to think about that!   | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExtField l' } cvtp (TH.VarP s)       = do { s' <- vName s-                            ; return $ Hs.VarPat noExtField (noLoc s') }+                            ; return $ Hs.VarPat noExtField (noLocA s') } cvtp (TupP ps)         = do { ps' <- cvtPats ps-                            ; return $ TuplePat noExtField ps' Boxed }+                            ; return $ TuplePat noAnn ps' Boxed } cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps-                            ; return $ TuplePat noExtField ps' Unboxed }+                            ; return $ TuplePat noAnn ps' Unboxed } cvtp (UnboxedSumP p alt arity)                        = do { p' <- cvtPat p                             ; unboxedSumChecks alt arity-                            ; return $ SumPat noExtField p' alt arity }-cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps+                            ; return $ SumPat noAnn p' alt arity }+cvtp (ConP s ts ps)    = do { s' <- cNameN s+                            ; ps' <- cvtPats ps+                            ; ts' <- mapM cvtType ts                             ; let pps = map (parenthesizePat appPrec) ps'                             ; return $ ConPat-                                { pat_con_ext = noExtField+                                { pat_con_ext = noAnn                                 , pat_con = s'-                                , pat_args = PrefixCon pps+                                , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps                                 }                             }-cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2-                            ; wrapParL (ParPat noExtField) $+cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2+                            ; wrapParLA (ParPat noAnn) $                               ConPat-                                { pat_con_ext = NoExtField+                                { pat_con_ext = noAnn                                 , pat_con = s'                                 , pat_args = InfixCon                                     (parenthesizePat opPrec p1')@@ -1304,35 +1340,36 @@ cvtp (ParensP p)       = do { p' <- cvtPat p;                             ; case unLoc p' of  -- may be wrapped ConPatIn                                 ParPat {} -> return $ unLoc p'-                                _         -> return $ ParPat noExtField p' }-cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExtField p' }-cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExtField p' }-cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p-                            ; return $ AsPat noExtField s' p' }+                                _         -> return $ ParPat noAnn p' }+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noAnn p' }+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noAnn p' }+cvtp (TH.AsP s p)      = do { s' <- vNameN s; p' <- cvtPat p+                            ; return $ AsPat noAnn s' p' } cvtp TH.WildP          = return $ WildPat noExtField-cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs+cvtp (RecP c fs)       = do { c' <- cNameN c; fs' <- mapM cvtPatFld fs                             ; return $ ConPat-                                { pat_con_ext = noExtField+                                { pat_con_ext = noAnn                                 , pat_con = c'                                 , pat_args = Hs.RecCon $ HsRecFields fs' Nothing                                 }                             } cvtp (ListP ps)        = do { ps' <- cvtPats ps                             ; return-                                   $ ListPat noExtField ps'}+                                   $ ListPat noAnn ps'} cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t-                            ; return $ SigPat noExtField p' (mkHsPatSigType t') }+                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') } cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p-                            ; return $ ViewPat noExtField e' p'}+                            ; return $ ViewPat noAnn e' p'}  cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs)) cvtPatFld (s,p)-  = do  { L ls s' <- vNameL s+  = do  { L ls s' <- vNameN s         ; p' <- cvtPat p-        ; return (noLoc $ HsRecField { hsRecFieldLbl-                                         = L ls $ mkFieldOcc (L ls s')-                                     , hsRecFieldArg = p'-                                     , hsRecPun      = False}) }+        ; return (noLocA $ HsRecField { hsRecFieldAnn = noAnn+                                      , hsRecFieldLbl+                                         = L (locA ls) $ mkFieldOcc (L ls s')+                                      , hsRecFieldArg = p'+                                      , hsRecPun      = False}) }  {- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix patterns will be left-biased, provided @x@ is.@@ -1341,13 +1378,13 @@ -} cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs) cvtOpAppP x op1 (UInfixP y op2 z)-  = do { l <- wrapL $ cvtOpAppP x op1 y+  = do { l <- wrapLA $ cvtOpAppP x op1 y        ; cvtOpAppP l op2 z } cvtOpAppP x op y-  = do { op' <- cNameL op+  = do { op' <- cNameN op        ; y' <- cvtPat y        ; return $ ConPat-          { pat_con_ext = noExtField+          { pat_con_ext = noAnn           , pat_con = op'           , pat_args = InfixCon x y'           }@@ -1371,14 +1408,14 @@  cvt_tv :: CvtFlag flag flag' => (TH.TyVarBndr flag) -> CvtM (LHsTyVarBndr flag' GhcPs) cvt_tv (TH.PlainTV nm fl)-  = do { nm' <- tNameL nm+  = do { nm' <- tNameN nm        ; let fl' = cvtFlag fl-       ; returnL $ UserTyVar noExtField fl' nm' }+       ; returnLA $ UserTyVar noAnn fl' nm' } cvt_tv (TH.KindedTV nm fl ki)-  = do { nm' <- tNameL nm+  = do { nm' <- tNameN nm        ; let fl' = cvtFlag fl        ; ki' <- cvtKind ki-       ; returnL $ KindedTyVar noExtField fl' nm' ki' }+       ; returnLA $ KindedTyVar noAnn fl' nm' ki' }  cvtRole :: TH.Role -> Maybe Coercion.Role cvtRole TH.NominalR          = Just Coercion.Nominal@@ -1388,29 +1425,54 @@  cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs) cvtContext p tys = do { preds' <- mapM cvtPred tys-                      ; parenthesizeHsContext p <$> returnL preds' }+                      ; parenthesizeHsContext p <$> returnLA preds' }  cvtPred :: TH.Pred -> CvtM (LHsType GhcPs) cvtPred = cvtType +cvtDerivClauseTys :: TH.Cxt -> CvtM (LDerivClauseTys GhcPs)+cvtDerivClauseTys tys+  = do { tys' <- mapM cvtSigType 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 (HsSig { sig_bndrs = HsOuterImplicit{}+                            , sig_body  = L _ (HsTyVar _ NotPromoted _) }))]+                 -> return $ L (l2l l) $ DctSingle noExtField ty'+           _     -> returnLA $ DctMulti noExtField 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 noAnn ds' tys' }  cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)-cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy-cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy-cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy+cvtDerivStrategy TH.StockStrategy    = returnL (Hs.StockStrategy noAnn)+cvtDerivStrategy TH.AnyclassStrategy = returnL (Hs.AnyclassStrategy noAnn)+cvtDerivStrategy TH.NewtypeStrategy  = returnL (Hs.NewtypeStrategy noAnn) cvtDerivStrategy (TH.ViaStrategy ty) = do-  ty' <- cvtType ty-  returnL $ Hs.ViaStrategy (mkLHsSigType ty')+  ty' <- cvtSigType ty+  returnL $ Hs.ViaStrategy (XViaStrategyPs noAnn ty')  cvtType :: TH.Type -> CvtM (LHsType GhcPs) cvtType = cvtTypeKind "type" +cvtSigType :: TH.Type -> CvtM (LHsSigType GhcPs)+cvtSigType = cvtSigTypeKind "type"++-- | Convert a Template Haskell 'Type' to an 'LHsSigType'. To avoid duplicating+-- the logic in 'cvtTypeKind' here, we simply reuse 'cvtTypeKind' and perform+-- surgery on the 'LHsType' it returns to turn it into an 'LHsSigType'.+cvtSigTypeKind :: String -> TH.Type -> CvtM (LHsSigType GhcPs)+cvtSigTypeKind ty_str ty = do+  ty' <- cvtTypeKind ty_str ty+  pure $ hsTypeToHsSigType ty'+ cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs) cvtTypeKind ty_str ty   = do { (head_ty, tys') <- split_ty_app ty@@ -1422,18 +1484,20 @@            TupleT n             | Just normals <- m_normals             , normals `lengthIs` n         -- Saturated-            -> returnL (HsTupleTy noExtField HsBoxedOrConstraintTuple normals)+            -> returnLA (HsTupleTy noAnn HsBoxedOrConstraintTuple normals)             | otherwise             -> mk_apps-               (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))+               (HsTyVar noAnn NotPromoted+                                     (noLocA (getRdrName (tupleTyCon Boxed n))))                tys'            UnboxedTupleT n              | Just normals <- m_normals              , normals `lengthIs` n               -- Saturated-             -> returnL (HsTupleTy noExtField HsUnboxedTuple normals)+             -> returnLA (HsTupleTy noAnn HsUnboxedTuple normals)              | otherwise              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))+                (HsTyVar noAnn NotPromoted+                                   (noLocA (getRdrName (tupleTyCon Unboxed n))))                 tys'            UnboxedSumT n              | n < 2@@ -1443,56 +1507,56 @@                             text "Sums must have an arity of at least 2" ]              | Just normals <- m_normals              , normals `lengthIs` n -- Saturated-             -> returnL (HsSumTy noExtField normals)+             -> returnLA (HsSumTy noAnn normals)              | otherwise              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName (sumTyCon n))))+                (HsTyVar noAnn NotPromoted (noLocA (getRdrName (sumTyCon n))))                 tys'            ArrowT              | Just normals <- m_normals              , [x',y'] <- normals -> do                  x'' <- case unLoc x' of-                          HsFunTy{}    -> returnL (HsParTy noExtField x')-                          HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646-                          HsQualTy{}   -> returnL (HsParTy noExtField x') -- #15324+                          HsFunTy{}    -> returnLA (HsParTy noAnn x')+                          HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646+                          HsQualTy{}   -> returnLA (HsParTy noAnn x') -- #15324                           _            -> return $                                           parenthesizeHsType sigPrec x'                  let y'' = parenthesizeHsType sigPrec y'-                 returnL (HsFunTy noExtField (HsUnrestrictedArrow NormalSyntax) x'' y'')+                 returnLA (HsFunTy noAnn (HsUnrestrictedArrow NormalSyntax) x'' y'')              | otherwise              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName unrestrictedFunTyCon)))+                (HsTyVar noAnn NotPromoted (noLocA (getRdrName unrestrictedFunTyCon)))                 tys'            MulArrowT              | Just normals <- m_normals              , [w',x',y'] <- normals -> do                  x'' <- case unLoc x' of-                          HsFunTy{}    -> returnL (HsParTy noExtField x')-                          HsForAllTy{} -> returnL (HsParTy noExtField x') -- #14646-                          HsQualTy{}   -> returnL (HsParTy noExtField x') -- #15324+                          HsFunTy{}    -> returnLA (HsParTy noAnn x')+                          HsForAllTy{} -> returnLA (HsParTy noAnn x') -- #14646+                          HsQualTy{}   -> returnLA (HsParTy noAnn x') -- #15324                           _            -> return $                                           parenthesizeHsType sigPrec x'                  let y'' = parenthesizeHsType sigPrec y'                      w'' = hsTypeToArrow w'-                 returnL (HsFunTy noExtField w'' x'' y'')+                 returnLA (HsFunTy noAnn w'' x'' y'')              | otherwise              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName funTyCon)))+                (HsTyVar noAnn NotPromoted (noLocA (getRdrName funTyCon)))                 tys'            ListT              | Just normals <- m_normals-             , [x'] <- normals -> do-                returnL (HsListTy noExtField x')+             , [x'] <- normals ->+                returnLA (HsListTy noAnn x')              | otherwise              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName listTyCon)))+                (HsTyVar noAnn NotPromoted (noLocA (getRdrName listTyCon)))                 tys' -           VarT nm -> do { nm' <- tNameL nm-                         ; mk_apps (HsTyVar noExtField NotPromoted nm') tys' }+           VarT nm -> do { nm' <- tNameN nm+                         ; mk_apps (HsTyVar noAnn NotPromoted nm') tys' }            ConT nm -> do { nm' <- tconName nm                          ; let prom = name_promotedness nm'-                         ; mk_apps (HsTyVar noExtField prom (noLoc nm')) tys'}+                         ; mk_apps (HsTyVar noAnn prom (noLocA nm')) tys'}             ForallT tvs cxt ty              | null tys'@@ -1500,9 +1564,10 @@                    ; cxt' <- cvtContext funPrec cxt                    ; ty'  <- cvtType ty                    ; loc <- getL-                   ; let tele   = mkHsForAllInvisTele tvs'-                         hs_ty  = mkHsForAllTy loc tele rho_ty-                         rho_ty = mkHsQualTy cxt loc cxt' ty'+                   ; let loc' = noAnnSrcSpan loc+                   ; let tele   = mkHsForAllInvisTele noAnn tvs'+                         hs_ty  = mkHsForAllTy loc' tele rho_ty+                         rho_ty = mkHsQualTy cxt loc' cxt' ty'                     ; return hs_ty } @@ -1511,13 +1576,14 @@              -> do { tvs' <- cvtTvs tvs                    ; ty'  <- cvtType ty                    ; loc  <- getL-                   ; let tele = mkHsForAllVisTele tvs'-                   ; pure $ mkHsForAllTy loc tele ty' }+                   ; let loc' = noAnnSrcSpan loc+                   ; let tele = mkHsForAllVisTele noAnn tvs'+                   ; pure $ mkHsForAllTy loc' tele ty' }             SigT ty ki              -> do { ty' <- cvtType ty                    ; ki' <- cvtKind ki-                   ; mk_apps (HsKindSig noExtField ty' ki') tys'+                   ; mk_apps (HsKindSig noAnn ty' ki') tys'                    }             LitT lit@@ -1532,7 +1598,7 @@                    ; t2' <- cvtType t2                    ; let prom = name_promotedness s'                    ; mk_apps-                      (HsTyVar noExtField prom (noLoc s'))+                      (HsTyVar noAnn prom (noLocA s'))                       ([HsValArg t1', HsValArg t2'] ++ tys')                    } @@ -1544,45 +1610,48 @@             ParensT t              -> do { t' <- cvtType t-                   ; mk_apps (HsParTy noExtField t') tys'+                   ; mk_apps (HsParTy noAnn t') tys'                    }             PromotedT nm -> do { nm' <- cName nm-                              ; mk_apps (HsTyVar noExtField IsPromoted (noLoc nm'))+                              ; mk_apps (HsTyVar noAnn IsPromoted+                                         (noLocA nm'))                                         tys' }                  -- Promoted data constructor; hence cName             PromotedTupleT n               | Just normals <- m_normals               , normals `lengthIs` n   -- Saturated-              -> returnL (HsExplicitTupleTy noExtField normals)+              -> returnLA (HsExplicitTupleTy noAnn normals)               | otherwise               -> mk_apps-                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))+                 (HsTyVar noAnn IsPromoted+                                   (noLocA (getRdrName (tupleDataCon Boxed n))))                  tys'             PromotedNilT-             -> mk_apps (HsExplicitListTy noExtField IsPromoted []) tys'+             -> mk_apps (HsExplicitListTy noAnn IsPromoted []) tys'             PromotedConsT  -- See Note [Representing concrete syntax in types]                           -- in Language.Haskell.TH.Syntax               | Just normals <- m_normals               , [ty1, L _ (HsExplicitListTy _ ip tys2)] <- normals-              -> do-                  returnL (HsExplicitListTy noExtField ip (ty1:tys2))+              -> returnLA (HsExplicitListTy noAnn ip (ty1:tys2))               | otherwise               -> mk_apps-                 (HsTyVar noExtField IsPromoted (noLoc (getRdrName consDataCon)))+                 (HsTyVar noAnn IsPromoted (noLocA (getRdrName consDataCon)))                  tys'             StarT              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))+                (HsTyVar noAnn NotPromoted+                                      (noLocA (getRdrName liftedTypeKindTyCon)))                 tys'             ConstraintT              -> mk_apps-                (HsTyVar noExtField NotPromoted (noLoc (getRdrName constraintKindTyCon)))+                (HsTyVar noAnn NotPromoted+                                      (noLocA (getRdrName constraintKindTyCon)))                 tys'             EqualityT@@ -1590,18 +1659,18 @@              , [x',y'] <- normals ->                    let px = parenthesizeHsType opPrec x'                        py = parenthesizeHsType opPrec y'-                   in returnL (HsOpTy noExtField px (noLoc eqTyCon_RDR) py)+                   in returnLA (HsOpTy noExtField px (noLocA eqTyCon_RDR) py)                -- The long-term goal is to remove the above case entirely and                -- subsume it under the case for InfixT. See #15815, comment:6,                -- for more details.               | otherwise ->-                   mk_apps (HsTyVar noExtField NotPromoted-                            (noLoc eqTyCon_RDR)) tys'+                   mk_apps (HsTyVar noAnn NotPromoted+                            (noLocA eqTyCon_RDR)) tys'            ImplicitParamT n t              -> do { n' <- wrapL $ ipName n                    ; t' <- cvtType t-                   ; returnL (HsIParamTy noExtField n' t')+                   ; returnLA (HsIParamTy noAnn n' t')                    }             _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))@@ -1610,9 +1679,9 @@ hsTypeToArrow :: LHsType GhcPs -> HsArrow GhcPs hsTypeToArrow w = case unLoc w of                      HsTyVar _ _ (L _ (isExact_maybe -> Just n))-                        | n == oneDataConName -> HsLinearArrow NormalSyntax+                        | n == oneDataConName -> HsLinearArrow NormalSyntax Nothing                         | n == manyDataConName -> HsUnrestrictedArrow NormalSyntax-                     _ -> HsExplicitMult NormalSyntax w+                     _ -> HsExplicitMult NormalSyntax Nothing w  -- ConT/InfixT can contain both data constructor (i.e., promoted) names and -- other (i.e, unpromoted) names, as opposed to PromotedT, which can only@@ -1627,7 +1696,7 @@ -- | Constructs an application of a type to arguments passed in a list. mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs) mk_apps head_ty type_args = do-  head_ty' <- returnL head_ty+  head_ty' <- returnLA head_ty   -- We must parenthesize the function type in case of an explicit   -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there   -- _must_ be parentheses around `Maybe :: Type -> Type`.@@ -1642,13 +1711,13 @@                              mk_apps (HsAppTy noExtField phead_ty p_ty) args           HsTypeArg l ki -> do p_ki <- add_parens ki                                mk_apps (HsAppKindTy l phead_ty p_ki) args-          HsArgPar _   -> mk_apps (HsParTy noExtField phead_ty) args+          HsArgPar _   -> mk_apps (HsParTy noAnn phead_ty) args    go type_args    where     -- See Note [Adding parens for splices]     add_parens lt@(L _ t)-      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExtField lt)+      | hsTypeNeedsParens appPrec t = returnLA (HsParTy noAnn lt)       | otherwise                   = return lt  wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs@@ -1676,7 +1745,7 @@  So scattered through "GHC.ThToHs" are various points where parens are added. -See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289+See (among other closed issues) https://gitlab.haskell.org/ghc/ghc/issues/14289 -} -- --------------------------------------------------------------------- @@ -1692,6 +1761,7 @@ cvtTyLit :: TH.TyLit -> HsTyLit cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)+cvtTyLit (TH.CharTyLit c) = HsCharTy NoSourceText c  {- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. The produced tree of infix types will be right-biased,@@ -1704,13 +1774,16 @@   = do { l <- cvtOpAppT y op1 z        ; cvtOpAppT x op2 l } cvtOpAppT x op y-  = do { op' <- tconNameL op+  = do { op' <- tconNameN op        ; x' <- cvtType x-       ; returnL (mkHsOpTy x' op' y) }+       ; returnLA (mkHsOpTy x' op' y) }  cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs) cvtKind = cvtTypeKind "kind" +cvtSigKind :: TH.Kind -> CvtM (LHsSigType GhcPs)+cvtSigKind = cvtSigTypeKind "kind"+ -- | Convert Maybe Kind to a type family result signature. Used with data -- families where naming of the result is not possible (thus only kind or no -- signature is possible).@@ -1733,34 +1806,34 @@ cvtInjectivityAnnotation :: TH.InjectivityAnn                          -> CvtM (Hs.LInjectivityAnn GhcPs) cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)-  = do { annLHS' <- tNameL annLHS-       ; annRHS' <- mapM tNameL annRHS-       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }+  = do { annLHS' <- tNameN annLHS+       ; annRHS' <- mapM tNameN annRHS+       ; returnL (Hs.InjectivityAnn noAnn annLHS' annRHS') } -cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)+cvtPatSynSigTy :: TH.Type -> CvtM (LHsSigType GhcPs) -- pattern synonym types are of peculiar shapes, which is why we treat -- them separately from regular types; -- see Note [Pattern synonym type signatures and Template Haskell] cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))-  | null exis, null provs = cvtType (ForallT univs reqs ty)-  | null univs, null reqs = do { l   <- getL+  | null exis, null provs = cvtSigType (ForallT univs reqs ty)+  | null univs, null reqs = do { l'  <- getL+                               ; let l = noAnnSrcSpan l'                                ; ty' <- cvtType (ForallT exis provs ty)-                               ; return $ L l (HsQualTy { hst_ctxt = L l []+                               ; return $ L l $ mkHsImplicitSigType+                                        $ L l (HsQualTy { hst_ctxt = Nothing                                                         , hst_xqual = noExtField                                                         , hst_body = ty' }) }-  | null reqs             = do { l      <- getL+  | null reqs             = do { l'      <- getL+                               ; let l'' = noAnnSrcSpan l'                                ; univs' <- cvtTvs univs                                ; ty'    <- cvtType (ForallT exis provs ty)-                               ; let forTy = HsForAllTy-                                              { hst_tele = mkHsForAllInvisTele univs'-                                              , hst_xforall = noExtField-                                              , hst_body = L l cxtTy }-                                     cxtTy = HsQualTy { hst_ctxt = L l []+                               ; let forTy = mkHsExplicitSigType noAnn univs' $ L l'' cxtTy+                                     cxtTy = HsQualTy { hst_ctxt = Nothing                                                       , hst_xqual = noExtField                                                       , hst_body = ty' }-                               ; return $ L l forTy }-  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))-cvtPatSynSigTy ty         = cvtType ty+                               ; return $ L (noAnnSrcSpan l') forTy }+  | otherwise             = cvtSigType (ForallT univs reqs (ForallT exis provs ty))+cvtPatSynSigTy ty         = cvtSigType ty  ----------------------------------------------------------- cvtFixity :: TH.Fixity -> Hs.Fixity@@ -1801,7 +1874,7 @@ -- | If passed an empty list of 'LHsTyVarBndr's, this simply returns the -- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy' -- using the provided 'LHsQTyVars' and 'LHsType'.-mkHsForAllTy :: SrcSpan+mkHsForAllTy :: SrcSpanAnnA              -- ^ The location of the returned 'LHsType' if it needs an              --   explicit forall              -> HsForAllTelescope GhcPs@@ -1829,7 +1902,7 @@ -- they're empty. See #13183. mkHsQualTy :: TH.Cxt            -- ^ The original Template Haskell context-           -> SrcSpan+           -> SrcSpanAnnA            -- ^ The location of the returned 'LHsType' if it needs an            --   explicit context            -> LHsContext GhcPs@@ -1841,35 +1914,40 @@ mkHsQualTy ctxt loc ctxt' ty   | null ctxt = ty   | otherwise = L loc $ HsQualTy { hst_xqual = noExtField-                                 , hst_ctxt  = ctxt'+                                 , hst_ctxt  = Just ctxt'                                  , hst_body  = ty } +mkHsOuterFamEqnTyVarBndrs :: Maybe [LHsTyVarBndr () GhcPs] -> HsOuterFamEqnTyVarBndrs GhcPs+mkHsOuterFamEqnTyVarBndrs = maybe mkHsOuterImplicit (mkHsOuterExplicit noAnn)+ -------------------------------------------------------------------- --      Turning Name back into RdrName --------------------------------------------------------------------  -- variable names-vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)+vNameN, cNameN, vcNameN, tNameN, tconNameN :: TH.Name -> CvtM (LocatedN RdrName)+vNameL                                     :: TH.Name -> CvtM (LocatedA RdrName) vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName  -- Variable names-vNameL n = wrapL (vName n)+vNameN n = wrapLN (vName n)+vNameL n = wrapLA (vName n) vName n = cvtName OccName.varName n  -- Constructor function names; this is Haskell source, hence srcDataName-cNameL n = wrapL (cName n)+cNameN n = wrapLN (cName n) cName n = cvtName OccName.dataName n  -- Variable *or* constructor names; check by looking at the first char-vcNameL n = wrapL (vcName n)+vcNameN n = wrapLN (vcName n) vcName n = if isVarName n then vName n else cName n  -- Type variable names-tNameL n = wrapL (tName n)+tNameN n = wrapLN (tName n) tName n = cvtName OccName.tvName n  -- Type Constructor names-tconNameL n = wrapL (tconName n)+tconNameN n = wrapLN (tconName n) tconName n = cvtName OccName.tcClsName n  ipName :: String -> CvtM HsIPName

GHC/Types/Avail.hs view

@@ -10,22 +10,32 @@     Avails,     AvailInfo(..),     avail,+    availField,+    availTC,     availsToNameSet,     availsToNameSetWithSelectors,     availsToNameEnv,-    availName, availNames, availNonFldNames,+    availExportsDecl,+    availName, availGreName,+    availNames, availNonFldNames,     availNamesWithSelectors,     availFlds,-    availsNamesWithOccs,-    availNamesWithOccs,+    availGreNames,+    availSubordinateGreNames,     stableAvailCmp,     plusAvail,     trimAvail,     filterAvail,     filterAvails,-    nubAvails-+    nubAvails, +    GreName(..),+    greNameMangledName,+    greNamePrintableName,+    greNameSrcSpan,+    greNameFieldLabel,+    partitionGreNames,+    stableGreNameCmp,   ) where  import GHC.Prelude@@ -33,16 +43,19 @@ import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.Name.Set+import GHC.Types.SrcLoc  import GHC.Types.FieldLabel import GHC.Utils.Binary import GHC.Data.List.SetOps import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Utils.Misc  import Data.Data ( Data )+import Data.Either ( partitionEithers ) import Data.List ( find )-import Data.Function+import Data.Maybe  -- ----------------------------------------------------------------------------- -- The AvailInfo type@@ -50,20 +63,19 @@ -- | Records what things are \"available\", i.e. in scope data AvailInfo -  -- | An ordinary identifier in scope-  = Avail Name+  -- | An ordinary identifier in scope, or a field label without a parent type+  -- (see Note [Representing pattern synonym fields in AvailInfo]).+  = Avail GreName    -- | A type or class in scope   --   -- The __AvailTC Invariant__: If the type or class is itself to be in scope,   -- it must be /first/ in this list.  Thus, typically:   ---  -- > AvailTC Eq [Eq, ==, \/=] []+  -- > AvailTC Eq [Eq, ==, \/=]   | AvailTC        Name         -- ^ The name of the type or class-       [Name]       -- ^ The available pieces of type or class,-                    -- excluding field selectors.-       [FieldLabel] -- ^ The record fields of the type+       [GreName]      -- ^ The available pieces of type or class                     -- (see Note [Representing fields in AvailInfo]).     deriving ( Eq    -- ^ Used when deciding if the interface has changed@@ -75,6 +87,8 @@ {- Note [Representing fields in AvailInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [FieldLabel] in GHC.Types.FieldLabel.+ When -XDuplicateRecordFields is disabled (the normal case), a datatype like @@ -82,13 +96,13 @@  gives rise to the AvailInfo -  AvailTC T [T, MkT] [FieldLabel "foo" False foo]+  AvailTC T [T, MkT, FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo]  whereas if -XDuplicateRecordFields is enabled it gives -  AvailTC T [T, MkT] [FieldLabel "foo" True $sel:foo:MkT]+  AvailTC T [T, MkT, FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkT] -since the label does not match the selector name.+where the label foo does not match the selector name $sel:foo:MkT.  The labels in a field list are not necessarily unique: data families allow the same parent (the family tycon) to have@@ -100,41 +114,79 @@  gives rise to -  AvailTC F [ F, MkFInt, MkFBool ]-            [ FieldLabel "foo" True $sel:foo:MkFInt-            , FieldLabel "foo" True $sel:foo:MkFBool ]+  AvailTC F [ F, MkFInt, MkFBool+            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt+            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFBool ] -Moreover, note that the flIsOverloaded flag need not be the same for-all the elements of the list.  In the example above, this occurs if-the two data instances are defined in different modules, one with-`-XDuplicateRecordFields` enabled and one with it disabled.  Thus it-is possible to have+Moreover, note that the flHasDuplicateRecordFields or flFieldSelectors flags+need not be the same for all the elements of the list.  In the example above,+this occurs if the two data instances are defined in different modules, with+different states of the `-XDuplicateRecordFields` or `-XNoFieldSelectors`+extensions.  Thus it is possible to have -  AvailTC F [ F, MkFInt, MkFBool ]-            [ FieldLabel "foo" True $sel:foo:MkFInt-            , FieldLabel "foo" False foo ]+  AvailTC F [ F, MkFInt, MkFBool+            , FieldLabel "foo" DuplicateRecordFields FieldSelectors $sel:foo:MkFInt+            , FieldLabel "foo" NoDuplicateRecordFields FieldSelectors foo ] -If the two data instances are defined in different modules, both-without `-XDuplicateRecordFields`, it will be impossible to export-them from the same module (even with `-XDuplicateRecordfields`-enabled), because they would be represented identically.  The-workaround here is to enable `-XDuplicateRecordFields` on the defining-modules.+If the two data instances are defined in different modules, both without+`-XDuplicateRecordFields` or `-XNoFieldSelectors`, it will be impossible to+export them from the same module (even with `-XDuplicateRecordfields` enabled),+because they would be represented identically.  The workaround here is to enable+`-XDuplicateRecordFields` or `-XNoFieldSelectors` on the defining modules.  See+also #13352.+++Note [Representing pattern synonym fields in AvailInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Record pattern synonym fields cannot be represented using AvailTC like fields of+normal record types (see Note [Representing fields in AvailInfo]), because they+do not always have a parent type constructor.  So we represent them using the+Avail constructor, with a NormalGreName that carries the underlying FieldLabel.++Thus under -XDuplicateRecordFields -XPatternSynoynms, the declaration++  pattern MkFoo{f} = Bar f++gives rise to the AvailInfo++  Avail (NormalGreName MkFoo)+  Avail (FieldGreName (FieldLabel "f" True $sel:f:MkFoo))++However, if `f` is bundled with a type constructor `T` by using `T(MkFoo,f)` in+an export list, then whenever `f` is imported the parent will be `T`,+represented as++  AvailTC T [ NormalGreName T+            , NormalGreName MkFoo+            , FieldGreName (FieldLabel "f" True $sel:f:MkFoo) ]++See also Note [GreNames] in GHC.Types.Name.Reader. -}  -- | Compare lexicographically stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering-stableAvailCmp (Avail n1)       (Avail n2)   = n1 `stableNameCmp` n2-stableAvailCmp (Avail {})         (AvailTC {})   = LT-stableAvailCmp (AvailTC n ns nfs) (AvailTC m ms mfs) =-    (n `stableNameCmp` m) `thenCmp`-    (cmpList stableNameCmp ns ms) `thenCmp`-    (cmpList (stableNameCmp `on` flSelector) nfs mfs)-stableAvailCmp (AvailTC {})       (Avail {})     = GT+stableAvailCmp (Avail c1)     (Avail c2)     = c1 `stableGreNameCmp` c2+stableAvailCmp (Avail {})     (AvailTC {})   = LT+stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`+                                               (cmpList stableGreNameCmp ns ms)+stableAvailCmp (AvailTC {})   (Avail {})     = GT +stableGreNameCmp :: GreName -> GreName -> Ordering+stableGreNameCmp (NormalGreName n1) (NormalGreName n2) = n1 `stableNameCmp` n2+stableGreNameCmp (NormalGreName {}) (FieldGreName  {}) = LT+stableGreNameCmp (FieldGreName  f1) (FieldGreName  f2) = flSelector f1 `stableNameCmp` flSelector f2+stableGreNameCmp (FieldGreName  {}) (NormalGreName {}) = GT+ avail :: Name -> AvailInfo-avail n = Avail n+avail n = Avail (NormalGreName n) +availField :: FieldLabel -> AvailInfo+availField fl = Avail (FieldGreName fl)++availTC :: Name -> [Name] -> [FieldLabel] -> AvailInfo+availTC n ns fls = AvailTC n (map NormalGreName ns ++ map FieldGreName fls)++ -- ----------------------------------------------------------------------------- -- Operations on AvailInfo @@ -151,49 +203,107 @@      where add avail env = extendNameEnvList env                                 (zip (availNames avail) (repeat avail)) +-- | Does this 'AvailInfo' export the parent decl?  This depends on the+-- invariant that the parent is first if it appears at all.+availExportsDecl :: AvailInfo -> Bool+availExportsDecl (AvailTC ty_name names)+  | n : _ <- names = NormalGreName ty_name == n+  | otherwise      = False+availExportsDecl _ = True+ -- | Just the main name made available, i.e. not the available pieces--- of type or class brought into scope by the 'GenAvailInfo'+-- of type or class brought into scope by the 'AvailInfo' availName :: AvailInfo -> Name-availName (Avail n)     = n-availName (AvailTC n _ _) = n+availName (Avail n)     = greNameMangledName n+availName (AvailTC n _) = n +availGreName :: AvailInfo -> GreName+availGreName (Avail c) = c+availGreName (AvailTC n _) = NormalGreName n+ -- | All names made available by the availability information (excluding overloaded selectors) availNames :: AvailInfo -> [Name]-availNames (Avail n)         = [n]-availNames (AvailTC _ ns fs) = ns ++ [ flSelector f | f <- fs, not (flIsOverloaded f) ]+availNames (Avail c) = childNonOverloadedNames c+availNames (AvailTC _ cs) = concatMap childNonOverloadedNames cs +childNonOverloadedNames :: GreName -> [Name]+childNonOverloadedNames (NormalGreName n) = [n]+childNonOverloadedNames (FieldGreName fl) = [ flSelector fl | not (flIsOverloaded fl) ]+ -- | All names made available by the availability information (including overloaded selectors) availNamesWithSelectors :: AvailInfo -> [Name]-availNamesWithSelectors (Avail n)         = [n]-availNamesWithSelectors (AvailTC _ ns fs) = ns ++ map flSelector fs+availNamesWithSelectors (Avail c) = [greNameMangledName c]+availNamesWithSelectors (AvailTC _ cs) = map greNameMangledName cs  -- | Names for non-fields made available by the availability information availNonFldNames :: AvailInfo -> [Name]-availNonFldNames (Avail n)        = [n]-availNonFldNames (AvailTC _ ns _) = ns+availNonFldNames (Avail (NormalGreName n)) = [n]+availNonFldNames (Avail (FieldGreName {})) = []+availNonFldNames (AvailTC _ ns) = mapMaybe f ns+  where+    f (NormalGreName n) = Just n+    f (FieldGreName {}) = Nothing  -- | Fields made available by the availability information availFlds :: AvailInfo -> [FieldLabel]-availFlds (AvailTC _ _ fs) = fs-availFlds _                = []+availFlds (Avail c) = maybeToList (greNameFieldLabel c)+availFlds (AvailTC _ cs) = mapMaybe greNameFieldLabel cs -availsNamesWithOccs :: [AvailInfo] -> [(Name, OccName)]-availsNamesWithOccs = concatMap availNamesWithOccs+-- | Names and fields made available by the availability information.+availGreNames :: AvailInfo -> [GreName]+availGreNames (Avail c)      = [c]+availGreNames (AvailTC _ cs) = cs --- | 'Name's made available by the availability information, paired with--- the 'OccName' used to refer to each one.------ When @DuplicateRecordFields@ is in use, the 'Name' may be the--- mangled name of a record selector (e.g. @$sel:foo:MkT@) while the--- 'OccName' will be the label of the field (e.g. @foo@).------ See Note [Representing fields in AvailInfo].-availNamesWithOccs :: AvailInfo -> [(Name, OccName)]-availNamesWithOccs (Avail n) = [(n, nameOccName n)]-availNamesWithOccs (AvailTC _ ns fs)-  = [ (n, nameOccName n) | n <- ns ] ++-    [ (flSelector fl, mkVarOccFS (flLabel fl)) | fl <- fs ]+-- | Names and fields made available by the availability information, other than+-- the main decl itself.+availSubordinateGreNames :: AvailInfo -> [GreName]+availSubordinateGreNames (Avail {}) = []+availSubordinateGreNames avail@(AvailTC _ ns)+  | availExportsDecl avail = tail ns+  | otherwise              = ns ++-- | Used where we may have an ordinary name or a record field label.+-- See Note [GreNames] in GHC.Types.Name.Reader.+data GreName = NormalGreName Name+             | FieldGreName FieldLabel+    deriving (Data, Eq)++instance Outputable GreName where+  ppr (NormalGreName n) = ppr n+  ppr (FieldGreName fl) = ppr fl++instance HasOccName GreName where+  occName (NormalGreName n) = occName n+  occName (FieldGreName fl) = occName fl++-- | A 'Name' for internal use, but not for output to the user.  For fields, the+-- 'OccName' will be the selector.  See Note [GreNames] in GHC.Types.Name.Reader.+greNameMangledName :: GreName -> Name+greNameMangledName (NormalGreName n) = n+greNameMangledName (FieldGreName fl) = flSelector fl++-- | A 'Name' suitable for output to the user.  For fields, the 'OccName' will+-- be the field label.  See Note [GreNames] in GHC.Types.Name.Reader.+greNamePrintableName :: GreName -> Name+greNamePrintableName (NormalGreName n) = n+greNamePrintableName (FieldGreName fl) = fieldLabelPrintableName fl++greNameSrcSpan :: GreName -> SrcSpan+greNameSrcSpan (NormalGreName n) = nameSrcSpan n+greNameSrcSpan (FieldGreName fl) = nameSrcSpan (flSelector fl)++greNameFieldLabel :: GreName -> Maybe FieldLabel+greNameFieldLabel (NormalGreName {}) = Nothing+greNameFieldLabel (FieldGreName fl)  = Just fl++partitionGreNames :: [GreName] -> ([Name], [FieldLabel])+partitionGreNames = partitionEithers . map to_either+  where+    to_either (NormalGreName n) = Left n+    to_either (FieldGreName fl) = Right fl++ -- ----------------------------------------------------------------------------- -- Utility @@ -202,30 +312,22 @@   | debugIsOn && availName a1 /= availName a2   = pprPanic "GHC.Rename.Env.plusAvail names differ" (hsep [ppr a1,ppr a2]) plusAvail a1@(Avail {})         (Avail {})        = a1-plusAvail (AvailTC _ [] [])     a2@(AvailTC {})   = a2-plusAvail a1@(AvailTC {})       (AvailTC _ [] []) = a1-plusAvail (AvailTC n1 (s1:ss1) fs1) (AvailTC n2 (s2:ss2) fs2)-  = case (n1==s1, n2==s2) of  -- Maintain invariant the parent is first+plusAvail (AvailTC _ [])     a2@(AvailTC {})   = a2+plusAvail a1@(AvailTC {})       (AvailTC _ []) = a1+plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2))+  = case (NormalGreName n1==s1, NormalGreName n2==s2) of  -- Maintain invariant the parent is first        (True,True)   -> AvailTC n1 (s1 : (ss1 `unionLists` ss2))-                                   (fs1 `unionLists` fs2)        (True,False)  -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2)))-                                   (fs1 `unionLists` fs2)        (False,True)  -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2))-                                   (fs1 `unionLists` fs2)        (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2))-                                   (fs1 `unionLists` fs2)-plusAvail (AvailTC n1 ss1 fs1) (AvailTC _ [] fs2)-  = AvailTC n1 ss1 (fs1 `unionLists` fs2)-plusAvail (AvailTC n1 [] fs1)  (AvailTC _ ss2 fs2)-  = AvailTC n1 ss2 (fs1 `unionLists` fs2) plusAvail a1 a2 = pprPanic "GHC.Rename.Env.plusAvail" (hsep [ppr a1,ppr a2])  -- | trims an 'AvailInfo' to keep only a single name trimAvail :: AvailInfo -> Name -> AvailInfo-trimAvail (Avail n)         _ = Avail n-trimAvail (AvailTC n ns fs) m = case find ((== m) . flSelector) fs of-    Just x  -> AvailTC n [] [x]-    Nothing -> ASSERT( m `elem` ns ) AvailTC n [m] []+trimAvail avail@(Avail {})         _ = avail+trimAvail avail@(AvailTC n ns) m = case find ((== m) . greNameMangledName) ns of+    Just c  -> AvailTC n [c]+    Nothing -> pprPanic "trimAvail" (hsep [ppr avail, ppr m])  -- | filters 'AvailInfo's by the given predicate filterAvails  :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo]@@ -235,12 +337,11 @@ filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] filterAvail keep ie rest =   case ie of-    Avail n | keep n    -> ie : rest+    Avail c | keep (greNameMangledName c) -> ie : rest             | otherwise -> rest-    AvailTC tc ns fs ->-        let ns' = filter keep ns-            fs' = filter (keep . flSelector) fs in-        if null ns' && null fs' then rest else AvailTC tc ns' fs' : rest+    AvailTC tc cs ->+        let cs' = filter (keep . greNameMangledName) cs+        in if null cs' then rest else AvailTC tc cs' : rest   -- | Combines 'AvailInfo's from the same family@@ -262,19 +363,17 @@ pprAvail :: AvailInfo -> SDoc pprAvail (Avail n)   = ppr n-pprAvail (AvailTC n ns fs)-  = ppr n <> braces (sep [ fsep (punctuate comma (map ppr ns)) <> semi-                         , fsep (punctuate comma (map (ppr . flLabel) fs))])+pprAvail (AvailTC n ns)+  = ppr n <> braces (fsep (punctuate comma (map ppr ns)))  instance Binary AvailInfo where     put_ bh (Avail aa) = do             putByte bh 0             put_ bh aa-    put_ bh (AvailTC ab ac ad) = do+    put_ bh (AvailTC ab ac) = do             putByte bh 1             put_ bh ab             put_ bh ac-            put_ bh ad     get bh = do             h <- getByte bh             case h of@@ -282,5 +381,19 @@                       return (Avail aa)               _ -> do ab <- get bh                       ac <- get bh-                      ad <- get bh-                      return (AvailTC ab ac ad)+                      return (AvailTC ab ac)++instance Binary GreName where+    put_ bh (NormalGreName aa) = do+            putByte bh 0+            put_ bh aa+    put_ bh (FieldGreName ab) = do+            putByte bh 1+            put_ bh ab+    get bh = do+            h <- getByte bh+            case h of+              0 -> do aa <- get bh+                      return (NormalGreName aa)+              _ -> do ab <- get bh+                      return (FieldGreName ab)

GHC/Types/Basic.hs view

@@ -15,6 +15,9 @@ -}  {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+ {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  module GHC.Types.Basic (@@ -23,21 +26,13 @@          ConTag, ConTagZ, fIRST_TAG, -        Arity, RepArity, JoinArity,+        Arity, RepArity, JoinArity, FullArgCount,          Alignment, mkAlignment, alignmentOf, alignmentBytes,          PromotionFlag(..), isPromoted,         FunctionOrData(..), -        WarningTxt(..), pprWarningTxtForMsg, StringLiteral(..),--        Fixity(..), FixityDirection(..),-        defaultFixity, maxPrecedence, minPrecedence,-        negateFixity, funTyFixity,-        compareFixity,-        LexicalFixity(..),-         RecFlag(..), isRec, isNonRec, boolToRecFlag,         Origin(..), isGenerated, @@ -97,28 +92,24 @@          SuccessFlag(..), succeeded, failed, successIf, -        IntegralLit(..), FractionalLit(..),-        negateIntegralLit, negateFractionalLit,-        mkIntegralLit, mkFractionalLit,-        integralFractionalLit,--        SourceText(..), pprWithSourceText,-         IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, intGtLimit,          SpliceExplicitFlag(..), -        TypeOrKind(..), isTypeLevel, isKindLevel+        TypeOrKind(..), isTypeLevel, isKindLevel,++        ForeignSrcLang (..)    ) where  import GHC.Prelude +import GHC.ForeignSrcLang import GHC.Data.FastString import GHC.Utils.Outputable-import GHC.Types.SrcLoc ( Located,unLoc )-import Data.Data hiding (Fixity, Prefix, Infix)-import Data.Function (on)-import Data.Bits+import GHC.Utils.Panic+import GHC.Utils.Binary+import GHC.Types.SourceText+import Data.Data import qualified Data.Semigroup as Semi  {-@@ -140,6 +131,16 @@   ppr CLeft    = text "Left"   ppr CRight   = text "Right" +instance Binary LeftOrRight where+   put_ bh CLeft  = putByte bh 0+   put_ bh CRight = putByte bh 1++   get bh = do { h <- getByte bh+               ; case h of+                   0 -> return CLeft+                   _ -> return CRight }++ {- ************************************************************************ *                                                                      *@@ -170,6 +171,11 @@ -- are counted. type JoinArity = Int +-- | FullArgCount is the number of type or value arguments in an application,+-- or the number of type or value binders in a lambda.  Note: it includes+-- both type and value arguments!+type FullArgCount = Int+ {- ************************************************************************ *                                                                      *@@ -178,7 +184,7 @@ ************************************************************************ -} --- | Constructor Tag+-- | A *one-index* constructor tag -- -- Type of the tags associated with each constructor possibility or superclass -- selector@@ -233,6 +239,10 @@  instance Outputable Alignment where   ppr (Alignment m) = ppr m++instance OutputableP env Alignment where+  pdoc _ = ppr+ {- ************************************************************************ *                                                                      *@@ -394,6 +404,17 @@   ppr NotPromoted = text "NotPromoted"   ppr IsPromoted  = text "IsPromoted" +instance Binary PromotionFlag where+   put_ bh NotPromoted = putByte bh 0+   put_ bh IsPromoted  = putByte bh 1++   get bh = do+       n <- getByte bh+       case n of+         0 -> return NotPromoted+         1 -> return IsPromoted+         _ -> fail "Binary(IsPromoted): fail)"+ {- ************************************************************************ *                                                                      *@@ -409,62 +430,15 @@     ppr IsFunction = text "(function)"     ppr IsData     = text "(data)" -{--************************************************************************-*                                                                      *-                Deprecations-*                                                                      *-************************************************************************--}---- | A String Literal in the source, including its original raw format for use by--- source to source manipulation tools.-data StringLiteral = StringLiteral-                       { sl_st :: SourceText, -- literal raw source.-                                              -- See not [Literal source text]-                         sl_fs :: FastString  -- literal string value-                       } deriving Data--instance Eq StringLiteral where-  (StringLiteral _ a) == (StringLiteral _ b) = a == b--instance Outputable StringLiteral where-  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)---- | Warning Text------ reason/explanation from a WARNING or DEPRECATED pragma-data WarningTxt = WarningTxt (Located SourceText)-                             [Located StringLiteral]-                | DeprecatedTxt (Located SourceText)-                                [Located StringLiteral]-    deriving (Eq, Data)--instance Outputable WarningTxt where-    ppr (WarningTxt    lsrc ws)-      = case unLoc lsrc of-          NoSourceText   -> pp_ws ws-          SourceText src -> text src <+> pp_ws ws <+> text "#-}"--    ppr (DeprecatedTxt lsrc  ds)-      = case unLoc lsrc of-          NoSourceText   -> pp_ws ds-          SourceText src -> text src <+> pp_ws ds <+> text "#-}"--pp_ws :: [Located StringLiteral] -> SDoc-pp_ws [l] = ppr $ unLoc l-pp_ws ws-  = text "["-    <+> vcat (punctuate comma (map (ppr . unLoc) ws))-    <+> text "]"---pprWarningTxtForMsg :: WarningTxt -> SDoc-pprWarningTxtForMsg (WarningTxt    _ ws)-                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))-pprWarningTxtForMsg (DeprecatedTxt _ ds)-                     = text "Deprecated:" <+>-                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))+instance Binary FunctionOrData where+    put_ bh IsFunction = putByte bh 0+    put_ bh IsData     = putByte bh 1+    get bh = do+        h <- getByte bh+        case h of+          0 -> return IsFunction+          1 -> return IsData+          _ -> panic "Binary FunctionOrData"  {- ************************************************************************@@ -479,83 +453,8 @@ pprRuleName :: RuleName -> SDoc pprRuleName rn = doubleQuotes (ftext rn) -{--************************************************************************-*                                                                      *-\subsection[Fixity]{Fixity info}-*                                                                      *-************************************************************************--} --------------------------data Fixity = Fixity SourceText Int FixityDirection-  -- Note [Pragma source text]-  deriving Data--instance Outputable Fixity where-    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]--instance Eq Fixity where -- Used to determine if two fixities conflict-  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2---------------------------data FixityDirection = InfixL | InfixR | InfixN-                     deriving (Eq, Data)--instance Outputable FixityDirection where-    ppr InfixL = text "infixl"-    ppr InfixR = text "infixr"-    ppr InfixN = text "infix"---------------------------maxPrecedence, minPrecedence :: Int-maxPrecedence = 9-minPrecedence = 0--defaultFixity :: Fixity-defaultFixity = Fixity NoSourceText maxPrecedence InfixL--negateFixity, funTyFixity :: Fixity--- Wired-in fixities-negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate-funTyFixity  = Fixity NoSourceText (-1) InfixR  -- Fixity of '->', see #15235- {--Consider--\begin{verbatim}-        a `op1` b `op2` c-\end{verbatim}-@(compareFixity op1 op2)@ tells which way to arrange application, or-whether there's an error.--}--compareFixity :: Fixity -> Fixity-              -> (Bool,         -- Error please-                  Bool)         -- Associate to the right: a op1 (b op2 c)-compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)-  = case prec1 `compare` prec2 of-        GT -> left-        LT -> right-        EQ -> case (dir1, dir2) of-                        (InfixR, InfixR) -> right-                        (InfixL, InfixL) -> left-                        _                -> error_please-  where-    right        = (False, True)-    left         = (False, False)-    error_please = (True,  False)---- |Captures the fixity of declarations as they are parsed. This is not--- necessarily the same as the fixity declaration, as the normal fixity may be--- overridden using parens or backticks.-data LexicalFixity = Prefix | Infix deriving (Data,Eq)--instance Outputable LexicalFixity where-  ppr Prefix = text "Prefix"-  ppr Infix  = text "Infix"--{- ************************************************************************ *                                                                      * \subsection[Top-level/local]{Top-level/not-top level flag}@@ -566,6 +465,7 @@ data TopLevelFlag   = TopLevel   | NotTopLevel+  deriving Data  isTopLevel, isNotTopLevel :: TopLevelFlag -> Bool @@ -629,6 +529,17 @@   ppr Recursive    = text "Recursive"   ppr NonRecursive = text "NonRecursive" +instance Binary RecFlag where+    put_ bh Recursive =+            putByte bh 0+    put_ bh NonRecursive =+            putByte bh 1+    get bh = do+            h <- getByte bh+            case h of+              0 -> return Recursive+              _ -> return NonRecursive+ {- ************************************************************************ *                                                                      *@@ -668,7 +579,7 @@ --                              @'\{-\# INCOHERENT'@, --      'GHC.Parser.Annotation.AnnClose' @`\#-\}`@, --- For details on above see note [Api annotations] in "GHC.Parser.Annotation"+-- For details on above see note [exact print annotations] in "GHC.Parser.Annotation" data OverlapFlag = OverlapFlag   { overlapMode   :: OverlapMode   , isSafeOverlap :: Bool@@ -767,6 +678,31 @@    ppr (Overlaps     _) = text "[overlap ok]"    ppr (Incoherent   _) = text "[incoherent]" +instance Binary OverlapMode where+    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s+    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s+    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s+    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s+    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+    get bh = do+        h <- getByte bh+        case h of+            0 -> (get bh) >>= \s -> return $ NoOverlap s+            1 -> (get bh) >>= \s -> return $ Overlaps s+            2 -> (get bh) >>= \s -> return $ Incoherent s+            3 -> (get bh) >>= \s -> return $ Overlapping s+            4 -> (get bh) >>= \s -> return $ Overlappable s+            _ -> panic ("get OverlapMode" ++ show h)+++instance Binary OverlapFlag where+    put_ bh flag = do put_ bh (overlapMode flag)+                      put_ bh (isSafeOverlap flag)+    get bh = do+        h <- get bh+        b <- get bh+        return OverlapFlag { overlapMode = h, isSafeOverlap = b }+ pprSafeOverlap :: Bool -> SDoc pprSafeOverlap True  = text "[safe]" pprSafeOverlap False = empty@@ -881,6 +817,18 @@       UnboxedTuple    -> "UnboxedTuple"       ConstraintTuple -> "ConstraintTuple" +instance Binary TupleSort where+    put_ bh BoxedTuple      = putByte bh 0+    put_ bh UnboxedTuple    = putByte bh 1+    put_ bh ConstraintTuple = putByte bh 2+    get bh = do+      h <- getByte bh+      case h of+        0 -> return BoxedTuple+        1 -> return UnboxedTuple+        _ -> return ConstraintTuple++ tupleSortBoxity :: TupleSort -> Boxity tupleSortBoxity BoxedTuple      = Boxed tupleSortBoxity UnboxedTuple    = Unboxed@@ -995,7 +943,7 @@ type BranchCount = Int   -- For OneOcc, the BranchCount says how many syntactic occurrences there are   -- At the moment we really only check for 1 or >1, but in principle-  --   we could pay attention to how *many* occurences there are+  --   we could pay attention to how *many* occurrences there are   --   (notably in postInlineUnconditionally).   -- But meanwhile, Ints are very efficiently represented. @@ -1218,83 +1166,6 @@ {- ************************************************************************ *                                                                      *-\subsection{Source Text}-*                                                                      *-************************************************************************-Keeping Source Text for source to source conversions--Note [Pragma source text]-~~~~~~~~~~~~~~~~~~~~~~~~~-The lexer does a case-insensitive match for pragmas, as well as-accepting both UK and US spelling variants.--So--  {-# SPECIALISE #-}-  {-# SPECIALIZE #-}-  {-# Specialize #-}--will all generate ITspec_prag token for the start of the pragma.--In order to be able to do source to source conversions, the original-source text for the token needs to be preserved, hence the-`SourceText` field.--So the lexer will then generate--  ITspec_prag "{ -# SPECIALISE"-  ITspec_prag "{ -# SPECIALIZE"-  ITspec_prag "{ -# Specialize"--for the cases above.- [without the space between '{' and '-', otherwise this comment won't parse]---Note [Literal source text]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The lexer/parser converts literals from their original source text-versions to an appropriate internal representation. This is a problem-for tools doing source to source conversions, so the original source-text is stored in literals where this can occur.--Motivating examples for HsLit--  HsChar          '\n'       == '\x20`-  HsCharPrim      '\x41`#    == `A`-  HsString        "\x20\x41" == " A"-  HsStringPrim    "\x20"#    == " "#-  HsInt           001        == 1-  HsIntPrim       002#       == 2#-  HsWordPrim      003##      == 3##-  HsInt64Prim     004##      == 4##-  HsWord64Prim    005##      == 5##-  HsInteger       006        == 6--For OverLitVal--  HsIntegral      003      == 0x003-  HsIsString      "\x41nd" == "And"--}-- -- Note [Literal source text],[Pragma source text]-data SourceText = SourceText String-                | NoSourceText -- ^ For when code is generated, e.g. TH,-                               -- deriving. The pretty printer will then make-                               -- its own representation of the item.-                deriving (Data, Show, Eq )--instance Outputable SourceText where-  ppr (SourceText s) = text "SourceText" <+> text s-  ppr NoSourceText   = text "NoSourceText"---- | Special combinator for showing string literals.-pprWithSourceText :: SourceText -> SDoc -> SDoc-pprWithSourceText NoSourceText     d = d-pprWithSourceText (SourceText src) _ = text src--{--************************************************************************-*                                                                      * \subsection{Activation} *                                                                      * ************************************************************************@@ -1459,11 +1330,11 @@  -- | Inline Specification data InlineSpec   -- What the user's INLINE pragma looked like-  = Inline       -- User wrote INLINE-  | Inlinable    -- User wrote INLINABLE-  | NoInline     -- User wrote NOINLINE-  | NoUserInline -- User did not write any of INLINE/INLINABLE/NOINLINE-                 -- e.g. in `defaultInlinePragma` or when created by CSE+  = Inline           -- User wrote INLINE+  | Inlinable        -- User wrote INLINABLE+  | NoInline         -- User wrote NOINLINE+  | NoUserInlinePrag -- User did not write any of INLINE/INLINABLE/NOINLINE+                     -- e.g. in `defaultInlinePragma` or when created by CSE   deriving( Eq, Data, Show )         -- Show needed for GHC.Parser.Lexer @@ -1473,7 +1344,7 @@ the source program.  If you write nothing at all, you get defaultInlinePragma:-   inl_inline = NoUserInline+   inl_inline = NoUserInlinePrag    inl_act    = AlwaysActive    inl_rule   = FunLike @@ -1486,7 +1357,7 @@  Note [inl_inline and inl_act] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* inl_inline says what the user wrote: did she say INLINE, NOINLINE,+* inl_inline says what the user wrote: did they say INLINE, NOINLINE,   INLINABLE, or nothing at all  * inl_act says in what phases the unfolding is active or inactive@@ -1547,15 +1418,15 @@ isFunLike _       = False  noUserInlineSpec :: InlineSpec -> Bool-noUserInlineSpec NoUserInline = True-noUserInlineSpec _            = False+noUserInlineSpec NoUserInlinePrag = True+noUserInlineSpec _                = False  defaultInlinePragma, alwaysInlinePragma, neverInlinePragma, dfunInlinePragma   :: InlinePragma defaultInlinePragma = InlinePragma { inl_src = SourceText "{-# INLINE"                                    , inl_act = AlwaysActive                                    , inl_rule = FunLike-                                   , inl_inline = NoUserInline+                                   , inl_inline = NoUserInlinePrag                                    , inl_sat = Nothing }  alwaysInlinePragma = defaultInlinePragma { inl_inline = Inline }@@ -1616,19 +1487,87 @@    ppr (ActiveAfter  _ n) = brackets (int n)    ppr FinalActive        = text "[final]" +instance Binary Activation where+    put_ bh NeverActive =+            putByte bh 0+    put_ bh FinalActive =+            putByte bh 1+    put_ bh AlwaysActive =+            putByte bh 2+    put_ bh (ActiveBefore src aa) = do+            putByte bh 3+            put_ bh src+            put_ bh aa+    put_ bh (ActiveAfter src ab) = do+            putByte bh 4+            put_ bh src+            put_ bh ab+    get bh = do+            h <- getByte bh+            case h of+              0 -> return NeverActive+              1 -> return FinalActive+              2 -> return AlwaysActive+              3 -> do src <- get bh+                      aa <- get bh+                      return (ActiveBefore src aa)+              _ -> do src <- get bh+                      ab <- get bh+                      return (ActiveAfter src ab)++ instance Outputable RuleMatchInfo where    ppr ConLike = text "CONLIKE"    ppr FunLike = text "FUNLIKE" +instance Binary RuleMatchInfo where+    put_ bh FunLike = putByte bh 0+    put_ bh ConLike = putByte bh 1+    get bh = do+            h <- getByte bh+            if h == 1 then return ConLike+                      else return FunLike+ instance Outputable InlineSpec where-   ppr Inline       = text "INLINE"-   ppr NoInline     = text "NOINLINE"-   ppr Inlinable    = text "INLINABLE"-   ppr NoUserInline = text "NOUSERINLINE" -- what is better?+   ppr Inline           = text "INLINE"+   ppr NoInline         = text "NOINLINE"+   ppr Inlinable        = text "INLINABLE"+   ppr NoUserInlinePrag = empty +instance Binary InlineSpec where+    put_ bh NoUserInlinePrag = putByte bh 0+    put_ bh Inline           = putByte bh 1+    put_ bh Inlinable        = putByte bh 2+    put_ bh NoInline         = putByte bh 3++    get bh = do h <- getByte bh+                case h of+                  0 -> return NoUserInlinePrag+                  1 -> return Inline+                  2 -> return Inlinable+                  _ -> return NoInline++ instance Outputable InlinePragma where   ppr = pprInline +instance Binary InlinePragma where+    put_ bh (InlinePragma s a b c d) = do+            put_ bh s+            put_ bh a+            put_ bh b+            put_ bh c+            put_ bh d++    get bh = do+           s <- get bh+           a <- get bh+           b <- get bh+           c <- get bh+           d <- get bh+           return (InlinePragma s a b c d)++ pprInline :: InlinePragma -> SDoc pprInline = pprInline' True @@ -1654,99 +1593,6 @@               | otherwise      = ppr info  --{- *********************************************************************-*                                                                      *-                 Integer literals-*                                                                      *-********************************************************************* -}---- | Integral Literal------ Used (instead of Integer) to represent negative zegative zero which is--- required for NegativeLiterals extension to correctly parse `-0::Double`--- as negative zero. See also #13211.-data IntegralLit-  = IL { il_text :: SourceText-       , il_neg :: Bool -- See Note [Negative zero]-       , il_value :: Integer-       }-  deriving (Data, Show)--mkIntegralLit :: Integral a => a -> IntegralLit-mkIntegralLit i = IL { il_text = SourceText (show i_integer)-                     , il_neg = i < 0-                     , il_value = i_integer }-  where-    i_integer :: Integer-    i_integer = toInteger i--negateIntegralLit :: IntegralLit -> IntegralLit-negateIntegralLit (IL text neg value)-  = case text of-      SourceText ('-':src) -> IL (SourceText src)       False    (negate value)-      SourceText      src  -> IL (SourceText ('-':src)) True     (negate value)-      NoSourceText         -> IL NoSourceText          (not neg) (negate value)---- | Fractional Literal------ Used (instead of Rational) to represent exactly the floating point literal that we--- encountered in the user's source program. This allows us to pretty-print exactly what--- the user wrote, which is important e.g. for floating point numbers that can't represented--- as Doubles (we used to via Double for pretty-printing). See also #2245.-data FractionalLit-  = FL { fl_text :: SourceText     -- How the value was written in the source-       , fl_neg :: Bool            -- See Note [Negative zero]-       , fl_value :: Rational      -- Numeric value of the literal-       }-  deriving (Data, Show)-  -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on--mkFractionalLit :: Real a => a -> FractionalLit-mkFractionalLit r = FL { fl_text = SourceText (show (realToFrac r::Double))-                           -- Converting to a Double here may technically lose-                           -- precision (see #15502). We could alternatively-                           -- convert to a Rational for the most accuracy, but-                           -- it would cause Floats and Doubles to be displayed-                           -- strangely, so we opt not to do this. (In contrast-                           -- to mkIntegralLit, where we always convert to an-                           -- Integer for the highest accuracy.)-                       , fl_neg = r < 0-                       , fl_value = toRational r }--negateFractionalLit :: FractionalLit -> FractionalLit-negateFractionalLit (FL text neg value)-  = case text of-      SourceText ('-':src) -> FL (SourceText src)     False value-      SourceText      src  -> FL (SourceText ('-':src)) True  value-      NoSourceText         -> FL NoSourceText (not neg) (negate value)--integralFractionalLit :: Bool -> Integer -> FractionalLit-integralFractionalLit neg i = FL { fl_text = SourceText (show i),-                                   fl_neg = neg,-                                   fl_value = fromInteger i }---- Comparison operations are needed when grouping literals--- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)--instance Eq IntegralLit where-  (==) = (==) `on` il_value--instance Ord IntegralLit where-  compare = compare `on` il_value--instance Outputable IntegralLit where-  ppr (IL (SourceText src) _ _) = text src-  ppr (IL NoSourceText _ value) = text (show value)--instance Eq FractionalLit where-  (==) = (==) `on` fl_value--instance Ord FractionalLit where-  compare = compare `on` fl_value--instance Outputable FractionalLit where-  ppr f = pprWithSourceText (fl_text f) (rational (fl_value f))  {- ************************************************************************

+ GHC/Types/CompleteMatch.hs view

@@ -0,0 +1,40 @@+{-# LANGUAGE TypeApplications #-}++-- | COMPLETE signature+module GHC.Types.CompleteMatch where++import GHC.Prelude+import GHC.Core.TyCo.Rep+import GHC.Types.Unique.DSet+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Type ( splitTyConApp_maybe )+import GHC.Utils.Outputable++-- | A list of conlikes which represents a complete pattern match.+-- These arise from @COMPLETE@ signatures.+-- See also Note [Implementation of COMPLETE pragmas].+data CompleteMatch = CompleteMatch+  { cmConLikes :: UniqDSet ConLike -- ^ The set of `ConLike` values+  , cmResultTyCon :: Maybe TyCon   -- ^ The optional, concrete result TyCon the set applies to+  }++vanillaCompleteMatch :: UniqDSet ConLike -> CompleteMatch+vanillaCompleteMatch cls = CompleteMatch { cmConLikes = cls, cmResultTyCon = Nothing }++instance Outputable CompleteMatch where+  ppr (CompleteMatch cls mty) = case mty of+    Nothing -> ppr cls+    Just ty -> ppr cls <> text "@" <> parens (ppr ty)++type CompleteMatches = [CompleteMatch]++completeMatchAppliesAtType :: Type -> CompleteMatch -> Bool+completeMatchAppliesAtType ty cm = all @Maybe ty_matches (cmResultTyCon cm)+  where+    ty_matches sig_tc+      | Just (tc, _arg_tys) <- splitTyConApp_maybe ty+      , tc == sig_tc+      = True+      | otherwise+      = False

GHC/Types/CostCentre.hs view

@@ -30,7 +30,6 @@ import GHC.Utils.Outputable import GHC.Types.SrcLoc import GHC.Data.FastString-import GHC.Utils.Misc import GHC.Types.CostCentre.State  import Data.Data@@ -95,7 +94,11 @@ cmpCostCentre NormalCC {cc_flavour = f1, cc_mod =  m1, cc_name = n1}               NormalCC {cc_flavour = f2, cc_mod =  m2, cc_name = n2}     -- first key is module name, then centre name, then flavour-  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)+  = mconcat+      [ m1 `compare` m2+      , n1 `lexicalCompareFS` n2 -- compare lexically to avoid non-determinism+      , f1 `compare` f2+      ]  cmpCostCentre other_1 other_2   = let@@ -314,7 +317,7 @@ costCentreSrcSpan = cc_loc  instance Binary CCFlavour where-    put_ bh CafCC = do+    put_ bh CafCC =             putByte bh 0     put_ bh (ExprCC i) = do             putByte bh 1@@ -328,10 +331,10 @@     get bh = do             h <- getByte bh             case h of-              0 -> do return CafCC+              0 -> return CafCC               1 -> ExprCC <$> get bh               2 -> DeclCC <$> get bh-              _ -> HpcCC <$> get bh+              _ -> HpcCC  <$> get bh  instance Binary CostCentre where     put_ bh (NormalCC aa ab ac _ad) = do

GHC/Types/Cpr.hs view

@@ -1,62 +1,93 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-}--- | Types for the Constructed Product Result lattice. "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils"+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE PatternSynonyms #-}++-- | Types for the Constructed Product Result lattice.+-- "GHC.Core.Opt.CprAnal" and "GHC.Core.Opt.WorkWrap.Utils" -- are its primary customers via 'GHC.Types.Id.idCprInfo'. module GHC.Types.Cpr (-    CprResult, topCpr, botCpr, conCpr, asConCpr,-    CprType (..), topCprType, botCprType, conCprType,-    lubCprType, applyCprTy, abstractCprTy, ensureCprTyArity, trimCprTy,-    CprSig (..), topCprSig, mkCprSigForArity, mkCprSig, seqCprSig+    Cpr (ConCpr), topCpr, botCpr, flatConCpr, asConCpr,+    CprType (..), topCprType, botCprType, flatConCprType,+    lubCprType, applyCprTy, abstractCprTy, trimCprTy,+    UnpackConFieldsResult (..), unpackConFieldsCpr,+    CprSig (..), topCprSig, isTopCprSig, mkCprSigForArity, mkCprSig, seqCprSig   ) where  import GHC.Prelude +import GHC.Core.DataCon import GHC.Types.Basic-import GHC.Utils.Outputable import GHC.Utils.Binary+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic  ----- * CprResult+-- * Cpr -- --- | The constructed product result lattice.------ @---                    NoCPR---                      |---                 ConCPR ConTag---                      |---                    BotCPR--- @-data CprResult = NoCPR          -- ^ Top of the lattice-               | ConCPR !ConTag -- ^ Returns a constructor from a data type-               | BotCPR         -- ^ Bottom of the lattice-               deriving( Eq, Show )+data Cpr+  = BotCpr+  | ConCpr_ !ConTag ![Cpr]+  -- ^ The number of field Cprs equals 'dataConRepArity'.+  -- If all of them are top, better use 'FlatConCpr', as ensured by the pattern+  -- synonym 'ConCpr'.+  | FlatConCpr !ConTag+  | TopCpr+  deriving Eq -lubCpr :: CprResult -> CprResult -> CprResult-lubCpr (ConCPR t1) (ConCPR t2)-  | t1 == t2               = ConCPR t1-lubCpr BotCPR      cpr     = cpr-lubCpr cpr         BotCPR  = cpr-lubCpr _           _       = NoCPR+pattern ConCpr :: ConTag -> [Cpr] -> Cpr+pattern ConCpr t cs <- ConCpr_ t cs where+  ConCpr t cs+    | all (== TopCpr) cs = FlatConCpr t+    | otherwise          = ConCpr_ t cs+{-# COMPLETE BotCpr, TopCpr, FlatConCpr, ConCpr #-} -topCpr :: CprResult-topCpr = NoCPR+viewConTag :: Cpr -> Maybe ConTag+viewConTag (FlatConCpr t) = Just t+viewConTag (ConCpr t _)   = Just t+viewConTag _              = Nothing+{-# INLINE viewConTag #-} -botCpr :: CprResult-botCpr = BotCPR+lubCpr :: Cpr -> Cpr -> Cpr+lubCpr BotCpr      cpr     = cpr+lubCpr cpr         BotCpr  = cpr+lubCpr (FlatConCpr t1) (viewConTag -> Just t2)+  | t1 == t2 = FlatConCpr t1+lubCpr (viewConTag -> Just t1) (FlatConCpr t2)+  | t1 == t2 = FlatConCpr t2+lubCpr (ConCpr t1 cs1) (ConCpr t2 cs2)+  | t1 == t2 = ConCpr t1 (lubFieldCprs cs1 cs2)+lubCpr _           _       = TopCpr -conCpr :: ConTag -> CprResult-conCpr = ConCPR+lubFieldCprs :: [Cpr] -> [Cpr] -> [Cpr]+lubFieldCprs as bs+  | as `equalLength` bs = zipWith lubCpr as bs+  | otherwise           = [] -trimCpr :: CprResult -> CprResult-trimCpr ConCPR{} = NoCPR-trimCpr cpr      = cpr+topCpr :: Cpr+topCpr = TopCpr -asConCpr :: CprResult -> Maybe ConTag-asConCpr (ConCPR t)  = Just t-asConCpr NoCPR       = Nothing-asConCpr BotCPR      = Nothing+botCpr :: Cpr+botCpr = BotCpr +flatConCpr :: ConTag -> Cpr+flatConCpr t = FlatConCpr t++trimCpr :: Cpr -> Cpr+trimCpr BotCpr = botCpr+trimCpr _      = topCpr++asConCpr :: Cpr -> Maybe (ConTag, [Cpr])+asConCpr (ConCpr t cs)  = Just (t, cs)+asConCpr (FlatConCpr t) = Just (t, [])+asConCpr TopCpr         = Nothing+asConCpr BotCpr         = Nothing++seqCpr :: Cpr -> ()+seqCpr (ConCpr _ cs) = foldr (seq . seqCpr) () cs+seqCpr _             = ()+ -- -- * CprType --@@ -64,10 +95,10 @@ -- | The abstract domain \(A_t\) from the original 'CPR for Haskell' paper. data CprType   = CprType-  { ct_arty :: !Arity     -- ^ Number of value arguments the denoted expression-                          --   eats before returning the 'ct_cpr'-  , ct_cpr  :: !CprResult -- ^ 'CprResult' eventually unleashed when applied to-                          --   'ct_arty' arguments+  { ct_arty :: !Arity -- ^ Number of value arguments the denoted expression+                      --   eats before returning the 'ct_cpr'+  , ct_cpr  :: !Cpr   -- ^ 'Cpr' eventually unleashed when applied to+                      --   'ct_arty' arguments   }  instance Eq CprType where@@ -78,10 +109,10 @@ topCprType = CprType 0 topCpr  botCprType :: CprType-botCprType = CprType 0 botCpr -- TODO: Figure out if arity 0 does what we want... Yes it does: arity zero means we may unleash it under any number of incoming arguments+botCprType = CprType 0 botCpr -conCprType :: ConTag -> CprType-conCprType con_tag = CprType 0 (conCpr con_tag)+flatConCprType :: ConTag -> CprType+flatConCprType con_tag = CprType { ct_arty = 0, ct_cpr = flatConCpr con_tag }  lubCprType :: CprType -> CprType -> CprType lubCprType ty1@(CprType n1 cpr1) ty2@(CprType n2 cpr2)@@ -104,14 +135,31 @@   | res == topCpr = topCprType   | otherwise     = CprType (n+1) res -ensureCprTyArity :: Arity -> CprType -> CprType-ensureCprTyArity n ty@(CprType m _)-  | n == m    = ty-  | otherwise = topCprType- trimCprTy :: CprType -> CprType trimCprTy (CprType arty res) = CprType arty (trimCpr res) +-- | The result of 'unpackConFieldsCpr'.+data UnpackConFieldsResult+  = AllFieldsSame !Cpr+  | ForeachField ![Cpr]++-- | Unpacks a 'ConCpr'-shaped 'Cpr' and returns the field 'Cpr's wrapped in a+-- 'ForeachField'. Otherwise, it returns 'AllFieldsSame' with the appropriate+-- 'Cpr' to assume for each field.+--+-- The use of 'UnpackConFieldsResult' allows O(1) space for the common,+-- non-'ConCpr' case.+unpackConFieldsCpr :: DataCon -> Cpr -> UnpackConFieldsResult+unpackConFieldsCpr dc (ConCpr t cs)+  | t == dataConTag dc, cs `lengthIs` dataConRepArity dc+  = ForeachField cs+unpackConFieldsCpr _  BotCpr = AllFieldsSame BotCpr+unpackConFieldsCpr _  _      = AllFieldsSame TopCpr+{-# INLINE unpackConFieldsCpr #-}++seqCprTy :: CprType -> ()+seqCprTy (CprType _ cpr) = seqCpr cpr+ -- | The arity of the wrapped 'CprType' is the arity at which it is safe -- to unleash. See Note [Understanding DmdType and StrictSig] in "GHC.Types.Demand" newtype CprSig = CprSig { getCprSig :: CprType }@@ -121,21 +169,40 @@ -- unleashable at that arity. See Note [Understanding DmdType and StrictSig] in -- "GHC.Types.Demand" mkCprSigForArity :: Arity -> CprType -> CprSig-mkCprSigForArity arty ty = CprSig (ensureCprTyArity arty ty)+mkCprSigForArity arty ty@(CprType n cpr)+  | arty /= n         = topCprSig+      -- Trim on arity mismatch+  | ConCpr t _ <- cpr = CprSig (CprType n (flatConCpr t))+      -- Flatten nested CPR info, we don't exploit it (yet)+  | otherwise         = CprSig ty  topCprSig :: CprSig topCprSig = CprSig topCprType -mkCprSig :: Arity -> CprResult -> CprSig+isTopCprSig :: CprSig -> Bool+isTopCprSig (CprSig ty) = ct_cpr ty == topCpr++mkCprSig :: Arity -> Cpr -> CprSig mkCprSig arty cpr = CprSig (CprType arty cpr)  seqCprSig :: CprSig -> ()-seqCprSig sig = sig `seq` ()+seqCprSig (CprSig ty) = seqCprTy ty -instance Outputable CprResult where-  ppr NoCPR        = empty-  ppr (ConCPR n)   = char 'm' <> int n-  ppr BotCPR       = char 'b'+-- | BNF:+-- ```+--   cpr ::= ''                               -- TopCpr+--        |  n                                -- FlatConCpr n+--        |  n '(' cpr1 ',' cpr2 ',' ... ')'  -- ConCpr n [cpr1,cpr2,...]+--        |  'b'                              -- BotCpr+-- ```+-- Examples:+--   * `f x = f x` has denotation `b`+--   * `1(1,)` is a valid (nested) 'Cpr' denotation for `(I# 42#, f 42)`.+instance Outputable Cpr where+  ppr TopCpr         = empty+  ppr (FlatConCpr n) = int n+  ppr (ConCpr n cs)  = int n <> parens (pprWithCommas ppr cs)+  ppr BotCpr         = char 'b'  instance Outputable CprType where   ppr (CprType arty res) = ppr arty <> ppr res@@ -144,20 +211,20 @@ instance Outputable CprSig where   ppr (CprSig ty) = ppr (ct_cpr ty) -instance Binary CprResult where-  put_ bh (ConCPR n)   = do { putByte bh 0; put_ bh n }-  put_ bh NoCPR        = putByte bh 1-  put_ bh BotCPR       = putByte bh 2-+instance Binary Cpr where+  put_ bh TopCpr         = putByte bh 0+  put_ bh BotCpr         = putByte bh 1+  put_ bh (FlatConCpr n) = putByte bh 2 *> put_ bh n+  put_ bh (ConCpr n cs)  = putByte bh 3 *> put_ bh n *> put_ bh cs   get  bh = do-          h <- getByte bh-          case h of-            0 -> do { n <- get bh; return (ConCPR n) }-            1 -> return NoCPR-            _ -> return BotCPR+    h <- getByte bh+    case h of+      0 -> return TopCpr+      1 -> return BotCpr+      2 -> FlatConCpr <$> get bh+      3 -> ConCpr <$> get bh <*> get bh+      _ -> pprPanic "Binary Cpr: Invalid tag" (int (fromIntegral h))  instance Binary CprType where-  put_ bh (CprType arty cpr) = do-    put_ bh arty-    put_ bh cpr-  get  bh = CprType <$> get bh <*> get bh+  put_ bh (CprType arty cpr) = put_ bh arty *> put_ bh cpr+  get  bh                    = CprType <$> get bh <*> get bh

GHC/Types/Demand.hs view

@@ -1,2080 +1,1906 @@-{--(c) The University of Glasgow 2006-(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section[Demand]{@Demand@: A decoupled implementation of a demand domain}--}--{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, RecordWildCards #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Types.Demand (-        StrDmd, UseDmd(..), Count,--        Demand, DmdShell, CleanDemand, getStrDmd, getUseDmd,-        mkProdDmd, mkOnceUsedDmd, mkManyUsedDmd, mkHeadStrict, oneifyDmd,-        toCleanDmd,-        absDmd, topDmd, botDmd, seqDmd,-        lubDmd, bothDmd,-        lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd,-        isTopDmd, isAbsDmd, isSeqDmd,-        peelUseCall, cleanUseDmd_maybe, strictenDmd, bothCleanDmd,-        addCaseBndrDmd,--        DmdType(..), dmdTypeDepth, lubDmdType, bothDmdType,-        BothDmdArg, mkBothDmdArg, toBothDmdArg,-        nopDmdType, botDmdType, addDemand,--        DmdEnv, emptyDmdEnv, keepAliveDmdEnv,-        peelFV, findIdDemand,--        Divergence(..), lubDivergence, isDeadEndDiv,-        topDiv, botDiv, exnDiv,-        appIsDeadEnd, isDeadEndSig, pprIfaceStrictSig,-        StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,-        nopSig, botSig,-        isTopSig, hasDemandEnvSig,-        splitStrictSig, strictSigDmdEnv,-        prependArgsStrictSig, etaConvertStrictSig,--        seqDemand, seqDemandList, seqDmdType, seqStrictSig,--        evalDmd, cleanEvalDmd, cleanEvalProdDmd, isStrictDmd,-        splitDmdTy, splitFVs, deferAfterPreciseException,-        postProcessUnsat, postProcessDmdType,--        splitProdDmd_maybe, peelCallDmd, peelManyCalls, mkCallDmd, mkCallDmds,-        mkWorkerDemand, dmdTransformSig, dmdTransformDataConSig,-        dmdTransformDictSelSig, argOneShots, argsOneShots, saturatedByOneShots,-        TypeShape(..), trimToType,--        useCount, isUsedOnce, reuseEnv,-        zapUsageDemand, zapUsageEnvSig,-        zapUsedOnceDemand, zapUsedOnceSig,-        strictifyDictDmd, strictifyDmd--     ) where--#include "HsVersions.h"--import GHC.Prelude--import GHC.Utils.Outputable-import GHC.Types.Var ( Var, Id )-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Unique.FM-import GHC.Utils.Misc-import GHC.Types.Basic-import GHC.Utils.Binary-import GHC.Data.Maybe   ( orElse )--import GHC.Core.Type    ( Type )-import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )-import GHC.Core.DataCon ( splitDataProductType_maybe )-import GHC.Core.Multiplicity    ( scaledThing )--{--************************************************************************-*                                                                      *-        Joint domain for Strictness and Absence-*                                                                      *-************************************************************************--}--data JointDmd s u = JD { sd :: s, ud :: u }-  deriving ( Eq, Show )--getStrDmd :: JointDmd s u -> s-getStrDmd = sd--getUseDmd :: JointDmd s u -> u-getUseDmd = ud---- Pretty-printing-instance (Outputable s, Outputable u) => Outputable (JointDmd s u) where-  ppr (JD {sd = s, ud = u}) = angleBrackets (ppr s <> char ',' <> ppr u)---- Well-formedness preserving constructors for the joint domain-mkJointDmd :: s -> u -> JointDmd s u-mkJointDmd s u = JD { sd = s, ud = u }--mkJointDmds :: [s] -> [u] -> [JointDmd s u]-mkJointDmds ss as = zipWithEqual "mkJointDmds" mkJointDmd ss as---{--************************************************************************-*                                                                      *-            Strictness domain-*                                                                      *-************************************************************************--          Lazy-           |-        HeadStr-        /     \-    SCall      SProd-        \     /-        HyperStr--Note [Exceptions and strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to smart about catching exceptions, but we aren't anymore.-See #14998 for the way it's resolved at the moment.--Here's a historic breakdown:--Apparently, exception handling prim-ops didn't use to have any special-strictness signatures, thus defaulting to nopSig, which assumes they use their-arguments lazily. Joachim was the first to realise that we could provide richer-information. Thus, in 0558911f91c (Dec 13), he added signatures to-primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call-their argument, which is useful information for usage analysis. Still with a-'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.--In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a-'strictApply1Dmd' leads to substantial performance gains. That was at the cost-of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in-28638dfe79e (Dec 15).--Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,-Ben opened #11222. Simon made the demand analyser "understand catch" in-9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call-its argument strictly, but also swallow any thrown exceptions in-'postProcessDivergence'. This was realized by extending the 'Str' constructor of-'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and-adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element-between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,-so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).--This left the other variants like 'catchRetry#' having 'catchArgDmd', which is-where #14998 picked up. Item 1 was concerned with measuring the impact of also-making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that-there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7-(Apr 18). There was a lot of dead code resulting from that change, that we-removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and-removed any code that was dealing with the peculiarities.--Where did the speed-ups vanish to? In #14998, item 3 established that-turning 'catch#' strict in its first argument didn't bring back any of the-alleged performance benefits. Item 2 of that ticket finally found out that it-was entirely due to 'catchException's new (since #11555) definition, which-was simply--    catchException !io handler = catch io handler--While 'catchException' is arguably the saner semantics for 'catch', it is an-internal helper function in "GHC.IO". Its use in-"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:-Remove the bang and you find the regressions we originally wanted to avoid with-'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".--So history keeps telling us that the only possibly correct strictness annotation-for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really-is not strict in its argument: Just try this in GHCi--  :set -XScopedTypeVariables-  import Control.Exception-  catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")--Any analysis that assumes otherwise will be broken in some way or another-(beyond `-fno-pendantic-bottoms`).--But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a-subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is-only used by `raiseIO#` in order to preserve precise exceptions by strictness-analysis, while not impacting the ability to eliminate dead code.-See Note [Precise exceptions and strictness analysis].---}---- | Vanilla strictness domain-data StrDmd-  = HyperStr             -- ^ Hyper-strict (bottom of the lattice).-                         -- See Note [HyperStr and Use demands]--  | SCall StrDmd         -- ^ Call demand-                         -- Used only for values of function type--  | SProd [ArgStr]       -- ^ Product-                         -- Used only for values of product type-                         -- Invariant: not all components are HyperStr (use HyperStr)-                         --            not all components are Lazy     (use HeadStr)--  | HeadStr              -- ^ Head-Strict-                         -- A polymorphic demand: used for values of all types,-                         --                       including a type variable--  deriving ( Eq, Show )---- | Strictness of a function argument.-type ArgStr = Str StrDmd---- | Strictness demand.-data Str s = Lazy  -- ^ Lazy (top of the lattice)-           | Str s -- ^ Strict-  deriving ( Eq, Show )---- Well-formedness preserving constructors for the Strictness domain-strBot, strTop :: ArgStr-strBot = Str HyperStr-strTop = Lazy--mkSCall :: StrDmd -> StrDmd-mkSCall HyperStr = HyperStr-mkSCall s        = SCall s--mkSProd :: [ArgStr] -> StrDmd-mkSProd sx-  | any isHyperStr sx = HyperStr-  | all isLazy     sx = HeadStr-  | otherwise         = SProd sx--isLazy :: ArgStr -> Bool-isLazy Lazy     = True-isLazy (Str {}) = False--isHyperStr :: ArgStr -> Bool-isHyperStr (Str HyperStr) = True-isHyperStr _              = False---- Pretty-printing-instance Outputable StrDmd where-  ppr HyperStr      = char 'B'-  ppr (SCall s)     = char 'C' <> parens (ppr s)-  ppr HeadStr       = char 'S'-  ppr (SProd sx)    = char 'S' <> parens (hcat (map ppr sx))--instance Outputable ArgStr where-  ppr (Str s) = ppr s-  ppr Lazy    = char 'L'--lubArgStr :: ArgStr -> ArgStr -> ArgStr-lubArgStr Lazy     _        = Lazy-lubArgStr _        Lazy     = Lazy-lubArgStr (Str s1) (Str s2) = Str (s1 `lubStr` s2)--lubStr :: StrDmd -> StrDmd -> StrDmd-lubStr HyperStr s              = s-lubStr (SCall s1) HyperStr     = SCall s1-lubStr (SCall _)  HeadStr      = HeadStr-lubStr (SCall s1) (SCall s2)   = SCall (s1 `lubStr` s2)-lubStr (SCall _)  (SProd _)    = HeadStr-lubStr (SProd sx) HyperStr     = SProd sx-lubStr (SProd _)  HeadStr      = HeadStr-lubStr (SProd s1) (SProd s2)-    | s1 `equalLength` s2      = mkSProd (zipWith lubArgStr s1 s2)-    | otherwise                = HeadStr-lubStr (SProd _) (SCall _)     = HeadStr-lubStr HeadStr   _             = HeadStr--bothArgStr :: ArgStr -> ArgStr -> ArgStr-bothArgStr Lazy     s        = s-bothArgStr s        Lazy     = s-bothArgStr (Str s1) (Str s2) = Str (s1 `bothStr` s2)--bothStr :: StrDmd -> StrDmd -> StrDmd-bothStr HyperStr _             = HyperStr-bothStr HeadStr s              = s-bothStr (SCall _)  HyperStr    = HyperStr-bothStr (SCall s1) HeadStr     = SCall s1-bothStr (SCall s1) (SCall s2)  = SCall (s1 `bothStr` s2)-bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird--bothStr (SProd _)  HyperStr    = HyperStr-bothStr (SProd s1) HeadStr     = SProd s1-bothStr (SProd s1) (SProd s2)-    | s1 `equalLength` s2      = mkSProd (zipWith bothArgStr s1 s2)-    | otherwise                = HyperStr  -- Weird-bothStr (SProd _) (SCall _)    = HyperStr---- utility functions to deal with memory leaks-seqStrDmd :: StrDmd -> ()-seqStrDmd (SProd ds)   = seqStrDmdList ds-seqStrDmd (SCall s)    = seqStrDmd s-seqStrDmd _            = ()--seqStrDmdList :: [ArgStr] -> ()-seqStrDmdList [] = ()-seqStrDmdList (d:ds) = seqArgStr d `seq` seqStrDmdList ds--seqArgStr :: ArgStr -> ()-seqArgStr Lazy    = ()-seqArgStr (Str s) = seqStrDmd s---- Splitting polymorphic demands-splitArgStrProdDmd :: Int -> ArgStr -> Maybe [ArgStr]-splitArgStrProdDmd n Lazy    = Just (replicate n Lazy)-splitArgStrProdDmd n (Str s) = splitStrProdDmd n s--splitStrProdDmd :: Int -> StrDmd -> Maybe [ArgStr]-splitStrProdDmd n HyperStr   = Just (replicate n strBot)-splitStrProdDmd n HeadStr    = Just (replicate n strTop)-splitStrProdDmd n (SProd ds) = WARN( not (ds `lengthIs` n),-                                     text "splitStrProdDmd" $$ ppr n $$ ppr ds )-                               Just ds-splitStrProdDmd _ (SCall {}) = Nothing-      -- This can happen when the programmer uses unsafeCoerce,-      -- and we don't then want to crash the compiler (#9208)--{--************************************************************************-*                                                                      *-            Absence domain-*                                                                      *-************************************************************************--         Used-         /   \-     UCall   UProd-         \   /-         UHead-          |-  Count x --        |-       Abs--}---- | Domain for genuine usage-data UseDmd-  = UCall Count UseDmd   -- ^ Call demand for absence.-                         -- Used only for values of function type--  | UProd [ArgUse]       -- ^ Product.-                         -- Used only for values of product type-                         -- See Note [Don't optimise UProd(Used) to Used]-                         ---                         -- Invariant: Not all components are Abs-                         -- (in that case, use UHead)--  | UHead                -- ^ May be used but its sub-components are-                         -- definitely *not* used.  For product types, UHead-                         -- is equivalent to U(AAA); see mkUProd.-                         ---                         -- UHead is needed only to express the demand-                         -- of 'seq' and 'case' which are polymorphic;-                         -- i.e. the scrutinised value is of type 'a'-                         -- rather than a product type. That's why we-                         -- can't use UProd [A,A,A]-                         ---                         -- Since (UCall _ Abs) is ill-typed, UHead doesn't-                         -- make sense for lambdas--  | Used                 -- ^ May be used and its sub-components may be used.-                         -- (top of the lattice)-  deriving ( Eq, Show )---- Extended usage demand for absence and counting-type ArgUse = Use UseDmd--data Use u-  = Abs             -- Definitely unused-                    -- Bottom of the lattice--  | Use Count u     -- May be used with some cardinality-  deriving ( Eq, Show )---- | Abstract counting of usages-data Count = One | Many-  deriving ( Eq, Show )---- Pretty-printing-instance Outputable ArgUse where-  ppr Abs           = char 'A'-  ppr (Use Many a)   = ppr a-  ppr (Use One  a)   = char '1' <> char '*' <> ppr a--instance Outputable UseDmd where-  ppr Used           = char 'U'-  ppr (UCall c a)    = char 'C' <> ppr c <> parens (ppr a)-  ppr UHead          = char 'H'-  ppr (UProd as)     = char 'U' <> parens (hcat (punctuate (char ',') (map ppr as)))--instance Outputable Count where-  ppr One  = char '1'-  ppr Many = text ""--useBot, useTop :: ArgUse-useBot     = Abs-useTop     = Use Many Used--mkUCall :: Count -> UseDmd -> UseDmd---mkUCall c Used = Used c-mkUCall c a  = UCall c a--mkUProd :: [ArgUse] -> UseDmd-mkUProd ux-  | all (== Abs) ux    = UHead-  | otherwise          = UProd ux--lubCount :: Count -> Count -> Count-lubCount _ Many = Many-lubCount Many _ = Many-lubCount x _    = x--lubArgUse :: ArgUse -> ArgUse -> ArgUse-lubArgUse Abs x                   = x-lubArgUse x Abs                   = x-lubArgUse (Use c1 a1) (Use c2 a2) = Use (lubCount c1 c2) (lubUse a1 a2)--lubUse :: UseDmd -> UseDmd -> UseDmd-lubUse UHead       u               = u-lubUse (UCall c u) UHead           = UCall c u-lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)-lubUse (UCall _ _) _               = Used-lubUse (UProd ux) UHead            = UProd ux-lubUse (UProd ux1) (UProd ux2)-     | ux1 `equalLength` ux2       = UProd $ zipWith lubArgUse ux1 ux2-     | otherwise                   = Used-lubUse (UProd {}) (UCall {})       = Used--- lubUse (UProd {}) Used             = Used-lubUse (UProd ux) Used             = UProd (map (`lubArgUse` useTop) ux)-lubUse Used       (UProd ux)       = UProd (map (`lubArgUse` useTop) ux)-lubUse Used _                      = Used  -- Note [Used should win]---- `both` is different from `lub` in its treatment of counting; if--- `both` is computed for two used, the result always has---  cardinality `Many` (except for the inner demands of UCall demand -- [TODO] explain).---  Also,  x `bothUse` x /= x (for anything but Abs).--bothArgUse :: ArgUse -> ArgUse -> ArgUse-bothArgUse Abs x                   = x-bothArgUse x Abs                   = x-bothArgUse (Use _ a1) (Use _ a2)   = Use Many (bothUse a1 a2)---bothUse :: UseDmd -> UseDmd -> UseDmd-bothUse UHead       u               = u-bothUse (UCall c u) UHead           = UCall c u---- Exciting special treatment of inner demand for call demands:---    use `lubUse` instead of `bothUse`!-bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)--bothUse (UCall {}) _                = Used-bothUse (UProd ux) UHead            = UProd ux-bothUse (UProd ux1) (UProd ux2)-      | ux1 `equalLength` ux2       = UProd $ zipWith bothArgUse ux1 ux2-      | otherwise                   = Used-bothUse (UProd {}) (UCall {})       = Used--- bothUse (UProd {}) Used             = Used  -- Note [Used should win]-bothUse Used (UProd ux)             = UProd (map (`bothArgUse` useTop) ux)-bothUse (UProd ux) Used             = UProd (map (`bothArgUse` useTop) ux)-bothUse Used _                      = Used  -- Note [Used should win]--peelUseCall :: UseDmd -> Maybe (Count, UseDmd)-peelUseCall (UCall c u)   = Just (c,u)-peelUseCall _             = Nothing--addCaseBndrDmd :: Demand    -- On the case binder-               -> [Demand]  -- On the components of the constructor-               -> [Demand]  -- Final demands for the components of the constructor--- See Note [Demand on case-alternative binders]-addCaseBndrDmd (JD { sd = ms, ud = mu }) alt_dmds-  = case mu of-     Abs     -> alt_dmds-     Use _ u -> zipWith bothDmd alt_dmds (mkJointDmds ss us)-             where-                Just ss = splitArgStrProdDmd arity ms  -- Guaranteed not to be a call-                Just us = splitUseProdDmd      arity u   -- Ditto-  where-    arity = length alt_dmds--{- Note [Demand on case-alternative binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The demand on a binder in a case alternative comes-  (a) From the demand on the binder itself-  (b) From the demand on the case binder-Forgetting (b) led directly to #10148.--Example. Source code:-  f x@(p,_) = if p then foo x else True--  foo (p,True) = True-  foo (p,q)    = foo (q,p)--After strictness analysis:-  f = \ (x_an1 [Dmd=<S(SL),1*U(U,1*U)>] :: (Bool, Bool)) ->-      case x_an1-      of wild_X7 [Dmd=<L,1*U(1*U,1*U)>]-      { (p_an2 [Dmd=<S,1*U>], ds_dnz [Dmd=<L,A>]) ->-      case p_an2 of _ {-        False -> GHC.Types.True;-        True -> foo wild_X7 }--It's true that ds_dnz is *itself* absent, but the use of wild_X7 means-that it is very much alive and demanded.  See #10148 for how the-consequences play out.--This is needed even for non-product types, in case the case-binder-is used but the components of the case alternative are not.--Note [Don't optimise UProd(Used) to Used]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-These two UseDmds:-   UProd [Used, Used]   and    Used-are semantically equivalent, but we do not turn the former into-the latter, for a regrettable-subtle reason.  Suppose we did.-then-  f (x,y) = (y,x)-would get-  StrDmd = Str  = SProd [Lazy, Lazy]-  UseDmd = Used = UProd [Used, Used]-But with the joint demand of <Str, Used> doesn't convey any clue-that there is a product involved, and so the worthSplittingFun-will not fire.  (We'd need to use the type as well to make it fire.)-Moreover, consider-  g h p@(_,_) = h p-This too would get <Str, Used>, but this time there really isn't any-point in w/w since the components of the pair are not used at all.--So the solution is: don't aggressively collapse UProd [Used,Used] to-Used; instead leave it as-is. In effect we are using the UseDmd to do a-little bit of boxity analysis.  Not very nice.--Note [Used should win]-~~~~~~~~~~~~~~~~~~~~~~-Both in lubUse and bothUse we want (Used `both` UProd us) to be Used.-Why?  Because Used carries the implication the whole thing is used,-box and all, so we don't want to w/w it.  If we use it both boxed and-unboxed, then we are definitely using the box, and so we are quite-likely to pay a reboxing cost.  So we make Used win here.--Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer--Baseline: (A) Not making Used win (UProd wins)-Compare with: (B) making Used win for lub and both--            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%-            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%- Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%--Baseline: (B) Making Used win for both lub and both-Compare with: (C) making Used win for both, but UProd win for lub--            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%-            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%- Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%--}---- If a demand is used multiple times (i.e. reused), than any use-once--- mentioned there, that is not protected by a UCall, can happen many times.-markReusedDmd :: ArgUse -> ArgUse-markReusedDmd Abs         = Abs-markReusedDmd (Use _ a)   = Use Many (markReused a)--markReused :: UseDmd -> UseDmd-markReused (UCall _ u)      = UCall Many u   -- No need to recurse here-markReused (UProd ux)       = UProd (map markReusedDmd ux)-markReused u                = u--isUsedMU :: ArgUse -> Bool--- True <=> markReusedDmd d = d-isUsedMU Abs          = True-isUsedMU (Use One _)  = False-isUsedMU (Use Many u) = isUsedU u--isUsedU :: UseDmd -> Bool--- True <=> markReused d = d-isUsedU Used           = True-isUsedU UHead          = True-isUsedU (UProd us)     = all isUsedMU us-isUsedU (UCall One _)  = False-isUsedU (UCall Many _) = True  -- No need to recurse---- Squashing usage demand demands-seqUseDmd :: UseDmd -> ()-seqUseDmd (UProd ds)   = seqArgUseList ds-seqUseDmd (UCall c d)  = c `seq` seqUseDmd d-seqUseDmd _            = ()--seqArgUseList :: [ArgUse] -> ()-seqArgUseList []     = ()-seqArgUseList (d:ds) = seqArgUse d `seq` seqArgUseList ds--seqArgUse :: ArgUse -> ()-seqArgUse (Use c u)  = c `seq` seqUseDmd u-seqArgUse _          = ()---- Splitting polymorphic Maybe-Used demands-splitUseProdDmd :: Int -> UseDmd -> Maybe [ArgUse]-splitUseProdDmd n Used        = Just (replicate n useTop)-splitUseProdDmd n UHead       = Just (replicate n Abs)-splitUseProdDmd n (UProd ds)  = WARN( not (ds `lengthIs` n),-                                      text "splitUseProdDmd" $$ ppr n-                                                             $$ ppr ds )-                                Just ds-splitUseProdDmd _ (UCall _ _) = Nothing-      -- This can happen when the programmer uses unsafeCoerce,-      -- and we don't then want to crash the compiler (#9208)--useCount :: Use u -> Count-useCount Abs         = One-useCount (Use One _) = One-useCount _           = Many---{--************************************************************************-*                                                                      *-         Clean demand for Strictness and Usage-*                                                                      *-************************************************************************--This domain differst from JointDemand in the sense that pure absence-is taken away, i.e., we deal *only* with non-absent demands.--Note [Strict demands]-~~~~~~~~~~~~~~~~~~~~~-isStrictDmd returns true only of demands that are-   both strict-   and  used-In particular, it is False for <HyperStr, Abs>, which can and does-arise in, say (#7319)-   f x = raise# <some exception>-Then 'x' is not used, so f gets strictness <HyperStr,Abs> -> .-Now the w/w generates-   fx = let x <HyperStr,Abs> = absentError "unused"-        in raise <some exception>-At this point we really don't want to convert to-   fx = case absentError "unused" of x -> raise <some exception>-Since the program is going to diverge, this swaps one error for another,-but it's really a bad idea to *ever* evaluate an absent argument.-In #7319 we get-   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]--Note [Dealing with call demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Call demands are constructed and deconstructed coherently for-strictness and absence. For instance, the strictness signature for the-following function--f :: (Int -> (Int, Int)) -> (Int, Bool)-f g = (snd (g 3), True)--should be: <L,C(U(AU))>m--}--type CleanDemand = JointDmd StrDmd UseDmd-     -- A demand that is at least head-strict--bothCleanDmd :: CleanDemand -> CleanDemand -> CleanDemand-bothCleanDmd (JD { sd = s1, ud = a1}) (JD { sd = s2, ud = a2})-  = JD { sd = s1 `bothStr` s2, ud = a1 `bothUse` a2 }--mkHeadStrict :: CleanDemand -> CleanDemand-mkHeadStrict cd = cd { sd = HeadStr }--mkOnceUsedDmd, mkManyUsedDmd :: CleanDemand -> Demand-mkOnceUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use One a }-mkManyUsedDmd (JD {sd = s,ud = a}) = JD { sd = Str s, ud = Use Many a }--evalDmd :: Demand--- Evaluated strictly, and used arbitrarily deeply-evalDmd = JD { sd = Str HeadStr, ud = useTop }--mkProdDmd :: [Demand] -> CleanDemand-mkProdDmd dx-  = JD { sd = mkSProd $ map getStrDmd dx-       , ud = mkUProd $ map getUseDmd dx }---- | Wraps the 'CleanDemand' with a one-shot call demand: @d@ -> @C1(d)@.-mkCallDmd :: CleanDemand -> CleanDemand-mkCallDmd (JD {sd = d, ud = u})-  = JD { sd = mkSCall d, ud = mkUCall One u }---- | @mkCallDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.-mkCallDmds :: Arity -> CleanDemand -> CleanDemand-mkCallDmds arity cd = iterate mkCallDmd cd !! arity---- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap-mkWorkerDemand :: Int -> Demand-mkWorkerDemand n = JD { sd = Lazy, ud = Use One (go n) }-  where go 0 = Used-        go n = mkUCall One $ go (n-1)--cleanEvalDmd :: CleanDemand-cleanEvalDmd = JD { sd = HeadStr, ud = Used }--cleanEvalProdDmd :: Arity -> CleanDemand-cleanEvalProdDmd n = JD { sd = HeadStr, ud = UProd (replicate n useTop) }---{--************************************************************************-*                                                                      *-           Demand: Combining Strictness and Usage-*                                                                      *-************************************************************************--}--type Demand = JointDmd ArgStr ArgUse--lubDmd :: Demand -> Demand -> Demand-lubDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})- = JD { sd = s1 `lubArgStr` s2-      , ud = a1 `lubArgUse` a2 }--bothDmd :: Demand -> Demand -> Demand-bothDmd (JD {sd = s1, ud = a1}) (JD {sd = s2, ud = a2})- = JD { sd = s1 `bothArgStr` s2-      , ud = a1 `bothArgUse` a2 }--lazyApply1Dmd, lazyApply2Dmd, strictApply1Dmd :: Demand--strictApply1Dmd = JD { sd = Str (SCall HeadStr)-                     , ud = Use Many (UCall One Used) }--lazyApply1Dmd = JD { sd = Lazy-                   , ud = Use One (UCall One Used) }---- Second argument of catch#:---    uses its arg at most once, applies it once---    but is lazy (might not be called at all)-lazyApply2Dmd = JD { sd = Lazy-                   , ud = Use One (UCall One (UCall One Used)) }--absDmd :: Demand-absDmd = JD { sd = Lazy, ud = Abs }--topDmd :: Demand-topDmd = JD { sd = Lazy, ud = useTop }--botDmd :: Demand-botDmd = JD { sd = strBot, ud = useBot }--seqDmd :: Demand-seqDmd = JD { sd = Str HeadStr, ud = Use One UHead }--oneifyDmd :: JointDmd s (Use u) -> JointDmd s (Use u)-oneifyDmd (JD { sd = s, ud = Use _ a }) = JD { sd = s, ud = Use One a }-oneifyDmd jd                            = jd--isTopDmd :: Demand -> Bool--- Used to suppress pretty-printing of an uninformative demand-isTopDmd (JD {sd = Lazy, ud = Use Many Used}) = True-isTopDmd _                                    = False--isAbsDmd :: JointDmd (Str s) (Use u) -> Bool-isAbsDmd (JD {ud = Abs}) = True   -- The strictness part can be HyperStr-isAbsDmd _               = False  -- for a bottom demand--isSeqDmd :: Demand -> Bool-isSeqDmd (JD {sd = Str HeadStr, ud = Use _ UHead}) = True-isSeqDmd _                                                = False--isUsedOnce :: JointDmd (Str s) (Use u) -> Bool-isUsedOnce (JD { ud = a }) = case useCount a of-                               One  -> True-                               Many -> False---- More utility functions for strictness-seqDemand :: Demand -> ()-seqDemand (JD {sd = s, ud = u}) = seqArgStr s `seq` seqArgUse u--seqDemandList :: [Demand] -> ()-seqDemandList [] = ()-seqDemandList (d:ds) = seqDemand d `seq` seqDemandList ds--isStrictDmd :: JointDmd (Str s) (Use u) -> Bool--- See Note [Strict demands]-isStrictDmd (JD {ud = Abs})  = False-isStrictDmd (JD {sd = Lazy}) = False-isStrictDmd _                = True--isWeakDmd :: Demand -> Bool-isWeakDmd (JD {sd = s, ud = a}) = isLazy s && isUsedMU a--cleanUseDmd_maybe :: Demand -> Maybe UseDmd-cleanUseDmd_maybe (JD { ud = Use _ u }) = Just u-cleanUseDmd_maybe _                     = Nothing--splitFVs :: Bool   -- Thunk-         -> DmdEnv -> (DmdEnv, DmdEnv)-splitFVs is_thunk rhs_fvs-  | is_thunk  = strictPairToTuple $-                nonDetStrictFoldUFM_Directly add (emptyVarEnv :*: emptyVarEnv) rhs_fvs-                -- It's OK to use a non-deterministic fold because we-                -- immediately forget the ordering by putting the elements-                -- in the envs again-  | otherwise = partitionVarEnv isWeakDmd rhs_fvs-  where-    add uniq dmd@(JD { sd = s, ud = u }) (lazy_fv :*: sig_fv)-      | Lazy <- s = addToUFM_Directly lazy_fv uniq dmd :*: sig_fv-      | otherwise = addToUFM_Directly lazy_fv uniq (JD { sd = Lazy, ud = u })-                    :*:-                    addToUFM_Directly sig_fv  uniq (JD { sd = s,    ud = Abs })--keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv--- (keepAliveDmdType dt vs) makes sure that the Ids in vs have--- /some/ usage in the returned demand types -- they are not Absent--- See Note [Absence analysis for stable unfoldings and RULES]---     in GHC.Core.Opt.DmdAnal-keepAliveDmdEnv env vs-  = nonDetStrictFoldVarSet add env vs-  where-    add :: Id -> DmdEnv -> DmdEnv-    add v env = extendVarEnv_C add_dmd env v topDmd--    add_dmd :: Demand -> Demand -> Demand-    -- If the existing usage is Absent, make it used-    -- Otherwise leave it alone-    add_dmd dmd _ | isAbsDmd dmd = topDmd-                  | otherwise    = dmd--splitProdDmd_maybe :: Demand -> Maybe [Demand]--- Split a product into its components, iff there is any--- useful information to be extracted thereby--- The demand is not necessarily strict!-splitProdDmd_maybe (JD { sd = s, ud = u })-  = case (s,u) of-      (Str (SProd sx), Use _ u) | Just ux <- splitUseProdDmd (length sx) u-                                -> Just (mkJointDmds sx ux)-      (Str s, Use _ (UProd ux)) | Just sx <- splitStrProdDmd (length ux) s-                                -> Just (mkJointDmds sx ux)-      (Lazy,  Use _ (UProd ux)) -> Just (mkJointDmds (replicate (length ux) Lazy) ux)-      _ -> Nothing--data StrictPair a b = !a :*: !b--strictPairToTuple :: StrictPair a b -> (a, b)-strictPairToTuple (x :*: y) = (x, y)--{- *********************************************************************-*                                                                      *-               TypeShape and demand trimming-*                                                                      *-********************************************************************* -}---data TypeShape -- See Note [Trimming a demand to a type]-               --     in GHC.Core.Opt.DmdAnal-  = TsFun TypeShape-  | TsProd [TypeShape]-  | TsUnk--trimToType :: Demand -> TypeShape -> Demand--- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal-trimToType (JD { sd = ms, ud = mu }) ts-  = JD (go_ms ms ts) (go_mu mu ts)-  where-    go_ms :: ArgStr -> TypeShape -> ArgStr-    go_ms Lazy    _  = Lazy-    go_ms (Str s) ts = Str (go_s s ts)--    go_s :: StrDmd -> TypeShape -> StrDmd-    go_s HyperStr    _            = HyperStr-    go_s (SCall s)   (TsFun ts)   = SCall (go_s s ts)-    go_s (SProd mss) (TsProd tss)-      | equalLength mss tss       = SProd (zipWith go_ms mss tss)-    go_s _           _            = HeadStr--    go_mu :: ArgUse -> TypeShape -> ArgUse-    go_mu Abs _ = Abs-    go_mu (Use c u) ts = Use c (go_u u ts)--    go_u :: UseDmd -> TypeShape -> UseDmd-    go_u UHead       _          = UHead-    go_u (UCall c u) (TsFun ts) = UCall c (go_u u ts)-    go_u (UProd mus) (TsProd tss)-      | equalLength mus tss      = UProd (zipWith go_mu mus tss)-    go_u _           _           = Used--instance Outputable TypeShape where-  ppr TsUnk        = text "TsUnk"-  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)-  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)----{- *********************************************************************-*                                                                      *-                   Termination-*                                                                      *-********************************************************************* -}---- | Divergence lattice. Models a subset lattice of the following exhaustive--- set of divergence results:------ [n] nontermination (e.g. loops)--- [i] throws imprecise exception--- [p] throws precise exception--- [c] converges (reduces to WHNF)------ The different lattice elements correspond to different subsets, indicated by--- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an--- exception, and may or may not reduce to WHNF).------ @---             Dunno (nipc)---                  |---            ExnOrDiv (nip)---                  |---            Diverges (ni)--- @------ As you can see, we don't distinguish __n__ and __i__.--- See Note [Precise exceptions and strictness analysis] for why __p__ is so--- special compared to __i__.-data Divergence-  = Diverges -- ^ Definitely throws an imprecise exception or diverges.-  | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise-             --   exception or diverges. Never converges, hence 'isDeadEndDiv'!-             --   See scenario 1 in Note [Precise exceptions and strictness analysis].-  | Dunno    -- ^ Might diverge, throw any kind of exception or converge.-  deriving( Eq, Show )--lubDivergence :: Divergence -> Divergence -> Divergence-lubDivergence Diverges div      = div-lubDivergence div      Diverges = div-lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv-lubDivergence _        _        = Dunno--- This needs to commute with defaultFvDmd, i.e.--- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2--- (See Note [Default demand on free variables and arguments] for why)--bothDivergence :: Divergence -> Divergence -> Divergence--- See Note [Asymmetry of 'both*'], which concludes that 'bothDivergence' needs--- to be symmetric.--- Strictly speaking, we should have @bothDivergence Dunno Diverges = ExnOrDiv@.--- But that regresses in too many places (every infinite loop, basically) to be--- worth it and is only relevant in higher-order scenarios--- (e.g. Divergence of @f (throwIO blah)@).--- So 'bothDivergence' currently is 'glbDivergence', really.-bothDivergence Dunno    Dunno    = Dunno-bothDivergence Diverges _        = Diverges-bothDivergence _        Diverges = Diverges-bothDivergence _        _        = ExnOrDiv--instance Outputable Divergence where-  ppr Diverges = char 'b' -- for (b)ottom-  ppr ExnOrDiv = char 'x' -- for e(x)ception-  ppr Dunno    = empty--{- Note [Precise vs imprecise exceptions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An exception is considered to be /precise/ when it is thrown by the 'raiseIO#'-primop. It follows that all other primops (such as 'raise#' or-division-by-zero) throw /imprecise/ exceptions. Note that the actual type of-the exception thrown doesn't have any impact!--GHC undertakes some effort not to apply an optimisation that would mask a-/precise/ exception with some other source of nontermination, such as genuine-divergence or an imprecise exception, so that the user can reliably-intercept the precise exception with a catch handler before and after-optimisations.--See also the wiki page on precise exceptions:-https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions-Section 5 of "Tackling the awkward squad" talks about semantic concerns.-Imprecise exceptions are actually more interesting than precise ones (which are-fairly standard) from the perspective of semantics. See the paper "A Semantics-for Imprecise Exceptions" for more details.--Note [Dead ends]-~~~~~~~~~~~~~~~~-We call an expression that either diverges or throws a precise or imprecise-exception a "dead end". We used to call such an expression just "bottoming",-but with the measures we take to preserve precise exception semantics-(see Note [Precise exceptions and strictness analysis]), that is no longer-accurate: 'exnDiv' is no longer the bottom of the Divergence lattice.--Yet externally to demand analysis, we mostly care about being able to drop dead-code etc., which is all due to the property that such an expression never-returns, hence we consider throwing a precise exception to be a dead end.-See also 'isDeadEndDiv'.--Note [Precise exceptions and strictness analysis]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have to take care to preserve precise exception semantics in strictness-analysis (#17676). There are two scenarios that need careful treatment.--The fixes were discussed at-https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions--Recall that raiseIO# raises a *precise* exception, in contrast to raise# which-raises an *imprecise* exception. See Note [Precise vs imprecise exceptions].--Scenario 1: Precise exceptions in case alternatives-----------------------------------------------------Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv.-Here's why. Consider this example from #13380 (similarly #17676):-  f x y | x>0       = raiseIO# Exc-        | y>0       = return 1-        | otherwise = return 2-Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and-loose with the precise exception; after optimisation, (f 42 (error "boom"))-turns from throwing the precise Exc to throwing the imprecise user error-"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be-achieved by giving it divergence exnDiv.-See Note [Default demand on free variables and arguments].--Why don't we just give it topDiv instead of introducing exnDiv?-Because then the simplifier will fail to discard raiseIO#'s continuation in-  case raiseIO# x s of { (# s', r #) -> <BIG> }-which we'd like to optimise to-  case raiseIO# x s of {}-Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and-its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it-behaves exactly as botDiv, so that dead code elimination works as expected.-This is tracked by T13380b.--Scenario 2: Precise exceptions in case scrutinees---------------------------------------------------Consider (more complete examples in #148, #1592, testcase strun003)--  case foo x s of { (# s', r #) -> y }--Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception-(ultimately via raiseIO#), then we must not force 'y', which may fail to-terminate or throw an imprecise exception, until we have performed @foo x s@.--So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to-model the exceptional control flow) when @foo x s@ may throw a precise-exception. Motivated by T13380{d,e,f}.-See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal".--We have to be careful not to discard dead-end Divergence from case-alternatives, though (#18086):--  m = putStrLn "foo" >> error "bar"--'m' should still have 'exnDiv', which is why it is not sufficient to lub with-'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.--Historical Note: This used to be called the "IO hack". But that term is rather-a bad fit because-1. It's easily confused with the "State hack", which also affects IO.-2. Neither "IO" nor "hack" is a good description of what goes on here, which-   is deferring strictness results after possibly throwing a precise exception.-   The "hack" is probably not having to defer when we can prove that the-   expression may not throw a precise exception (increasing precision of the-   analysis), but that's just a favourable guess.--}----------------------------------------------------------------------------- Combined demand result                                             -----------------------------------------------------------------------------topDiv, exnDiv, botDiv :: Divergence-topDiv = Dunno-exnDiv = ExnOrDiv-botDiv = Diverges---- | True if the result indicates that evaluation will not return.--- See Note [Dead ends].-isDeadEndDiv :: Divergence -> Bool-isDeadEndDiv Diverges = True-isDeadEndDiv ExnOrDiv = True-isDeadEndDiv Dunno    = False---- See Notes [Default demand on free variables and arguments]--- and Scenario 1 in [Precise exceptions and strictness analysis]-defaultFvDmd :: Divergence -> Demand-defaultFvDmd Dunno    = absDmd-defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv!-defaultFvDmd Diverges = botDmd -- Diverges--defaultArgDmd :: Divergence -> Demand--- TopRes and BotRes are polymorphic, so that---      BotRes === (Bot -> BotRes) === ...---      TopRes === (Top -> TopRes) === ...--- This function makes that concrete--- Also see Note [Default demand on free variables and arguments]-defaultArgDmd Dunno    = topDmd--- NB: not botDmd! We don't want to mask the precise exception by forcing the--- argument. But it is still absent.-defaultArgDmd ExnOrDiv = absDmd-defaultArgDmd Diverges = botDmd--{- Note [Default demand on free variables and arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Free variables not mentioned in the environment of a 'DmdType'-are demanded according to the demand type's Divergence:-  * In a Diverges (botDiv) context, that demand is botDmd-    (HyperStr and Absent).-  * In all other contexts, the demand is absDmd (Lazy and Absent).-This is recorded in 'defaultFvDmd'.--Similarly, we can eta-expand demand types to get demands on excess arguments-not accounted for in the type, by consulting 'defaultArgDmd':-  * In a Diverges (botDiv) context, that demand is again botDmd.-  * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge-    before evaluating the excess argument, but don't want to eagerly evaluate-    it (cf. Note [Precise exceptions and strictness analysis]).-  * In a Dunno context (topDiv), the demand is topDmd, because-    it's perfectly possible to enter the additional lambda and evaluate it-    in unforeseen ways (so, not Absent).---************************************************************************-*                                                                      *-           Demand environments and types-*                                                                      *-************************************************************************--}--type DmdEnv = VarEnv Demand   -- See Note [Default demand on free variables and arguments]--data DmdType = DmdType-                  DmdEnv        -- Demand on explicitly-mentioned-                                --      free variables-                  [Demand]      -- Demand on arguments-                  Divergence     -- See [Demand type Divergence]--{--Note [Demand type Divergence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand.-This is described in detail in Note [Understanding DmdType and StrictSig].-Here, we'll focus on what that means for a DmdType's Divergence in a higher-order-scenario.--Consider-  err x y = x `seq` y `seq` error (show x)-this has a strictness signature of-  <S><S>b-meaning that we don't know what happens when we call errin weaker contexts than-C(C(S)), like @err `seq` ()@ (S) and @err 1 `seq` ()@ (C(S)). We may not unleash-the botDiv, hence assume topDiv. Of course, in @err 1 2 `seq` ()@ the incoming-demand C(C(S)) is strong enough and we see that the expression diverges.--Now consider a function-  f g = g 1 2-with signature <C(S)>, and the expression-  f err `seq` ()-now f puts a strictness demand of C(C(S)) onto its argument, which is unleashed-on err via the App rule. In contrast to weaker head strictness, this demand is-strong enough to unleash err's signature and hence we see that the whole-expression diverges!--Note [Asymmetry of 'both*']-~~~~~~~~~~~~~~~~~~~~~~~~~~~-'both' for DmdTypes is *asymmetrical*, because there can only one-be one type contributing argument demands!  For example, given (e1 e2), we get-a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do-(dt1 `bothType` dt2). Similarly with-  case e of { p -> rhs }-we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then-compute (dt_rhs `bothType` dt_scrut).--We- 1. combine the information on the free variables,- 2. take the demand on arguments from the first argument- 3. combine the termination results, as in bothDivergence.--Since we don't use argument demands of the second argument anyway, 'both's-second argument is just a 'BothDmdType'.--But note that the argument demand types are not guaranteed to be observed in-left to right order. For example, analysis of a case expression will pass the-demand type for the alts as the left argument and the type for the scrutinee as-the right argument. Also, it is not at all clear if there is such an order;-consider the LetUp case, where the RHS might be forced at any point while-evaluating the let body.-Therefore, it is crucial that 'bothDivergence' is symmetric!--}---- Equality needed for fixpoints in GHC.Core.Opt.DmdAnal-instance Eq DmdType where-  (==) (DmdType fv1 ds1 div1)-       (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2-         -- It's OK to use nonDetUFMToList here because we're testing for-         -- equality and even though the lists will be in some arbitrary-         -- Unique order, it is the same order for both-                              && ds1 == ds2 && div1 == div2---- | Compute the least upper bound of two 'DmdType's elicited /by the same--- incoming demand/!-lubDmdType :: DmdType -> DmdType -> DmdType-lubDmdType d1 d2-  = DmdType lub_fv lub_ds lub_div-  where-    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)-    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1-    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2--    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)-    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2-    lub_div = lubDivergence r1 r2--type BothDmdArg = (DmdEnv, Divergence)--mkBothDmdArg :: DmdEnv -> BothDmdArg-mkBothDmdArg env = (env, topDiv)--toBothDmdArg :: DmdType -> BothDmdArg-toBothDmdArg (DmdType fv _ r) = (fv, r)--bothDmdType :: DmdType -> BothDmdArg -> DmdType-bothDmdType (DmdType fv1 ds1 r1) (fv2, t2)-    -- See Note [Asymmetry of 'both*']-    -- 'both' takes the argument/result info from its *first* arg,-    -- using its second arg just for its free-var info.-  = DmdType (plusVarEnv_CD bothDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))-            ds1-            (r1 `bothDivergence` t2)--instance Outputable DmdType where-  ppr (DmdType fv ds res)-    = hsep [hcat (map ppr ds) <> ppr res,-            if null fv_elts then empty-            else braces (fsep (map pp_elt fv_elts))]-    where-      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd-      fv_elts = nonDetUFMToList fv-        -- It's OK to use nonDetUFMToList here because we only do it for-        -- pretty printing--emptyDmdEnv :: VarEnv Demand-emptyDmdEnv = emptyVarEnv--botDmdType :: DmdType-botDmdType = DmdType emptyDmdEnv [] botDiv---- | The demand type of doing nothing (lazy, absent, no Divergence--- information). Note that it is ''not'' the top of the lattice (which would be--- "may use everything"), so it is (no longer) called topDmdType.--- (SG: I agree, but why is it still 'topDmd' then?)-nopDmdType :: DmdType-nopDmdType = DmdType emptyDmdEnv [] topDiv--isTopDmdType :: DmdType -> Bool-isTopDmdType (DmdType env args div)-  = div == topDiv && null args && isEmptyVarEnv env---- | The demand type of an unspecified expression that is guaranteed to--- throw a (precise or imprecise) exception or diverge.-exnDmdType :: DmdType-exnDmdType = DmdType emptyDmdEnv [] exnDiv--dmdTypeDepth :: DmdType -> Arity-dmdTypeDepth (DmdType _ ds _) = length ds---- | This makes sure we can use the demand type with n arguments after eta--- expansion, where n must not be lower than the demand types depth.--- It appends the argument list with the correct 'defaultArgDmd'.-etaExpandDmdType :: Arity -> DmdType -> DmdType-etaExpandDmdType n d-  | n == depth = d-  | n >  depth = DmdType fv inc_ds div-  | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)-  where depth = dmdTypeDepth d-        DmdType fv ds div = d-        -- Arity increase:-        --  * Demands on FVs are still valid-        --  * Demands on args also valid, plus we can extend with defaultArgDmd-        --    as appropriate for the given Divergence-        --  * Divergence is still valid:-        --    - A dead end after 2 arguments stays a dead end after 3 arguments-        --    - The remaining case is Dunno, which is already topDiv-        inc_ds  = take n (ds ++ repeat (defaultArgDmd div))---- | A conservative approximation for a given 'DmdType' in case of an arity--- decrease. Currently, it's just nopDmdType.-decreaseArityDmdType :: DmdType -> DmdType-decreaseArityDmdType _ = nopDmdType--seqDmdType :: DmdType -> ()-seqDmdType (DmdType env ds res) =-  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()--seqDmdEnv :: DmdEnv -> ()-seqDmdEnv env = seqEltsUFM seqDemandList env--splitDmdTy :: DmdType -> (Demand, DmdType)--- Split off one function argument--- We already have a suitable demand on all--- free vars, so no need to add more!-splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty)-splitDmdTy ty@(DmdType _ [] res_ty)       = (defaultArgDmd res_ty, ty)---- | When e is evaluated after executing an IO action that may throw a precise--- exception, we act as if there is an additional control flow path that is--- taken if e throws a precise exception. The demand type of this control flow--- path---   * is lazy and absent ('topDmd') in all free variables and arguments---   * has 'exnDiv' 'Divergence' result--- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.--- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!--- That means failure to drop dead-ends, see #18086.--- See Note [Precise exceptions and strictness analysis]-deferAfterPreciseException :: DmdType -> DmdType-deferAfterPreciseException = lubDmdType exnDmdType--strictenDmd :: Demand -> Demand-strictenDmd (JD { sd = s, ud = u})-  = JD { sd = poke_s s, ud = poke_u u }-  where-    poke_s Lazy      = Str HeadStr-    poke_s s         = s-    poke_u Abs       = useTop-    poke_u u         = u---- Deferring and peeling--type DmdShell   -- Describes the "outer shell"-                -- of a Demand-   = JointDmd (Str ()) (Use ())--toCleanDmd :: Demand -> (DmdShell, CleanDemand)--- Splits a Demand into its "shell" and the inner "clean demand"-toCleanDmd (JD { sd = s, ud = u })-  = (JD { sd = ss, ud = us }, JD { sd = s', ud = u' })-    -- See Note [Analyzing with lazy demand and lambdas]-    -- See Note [Analysing with absent demand]-  where-    (ss, s') = case s of-                Str s' -> (Str (), s')-                Lazy   -> (Lazy,   HeadStr)--    (us, u') = case u of-                 Use c u' -> (Use c (), u')-                 Abs      -> (Abs,      Used)---- This is used in dmdAnalStar when post-processing--- a function's argument demand. So we only care about what--- does to free variables, and whether it terminates.--- see Note [Asymmetry of 'both*']-postProcessDmdType :: DmdShell -> DmdType -> BothDmdArg-postProcessDmdType du@(JD { sd = ss }) (DmdType fv _ res_ty)-    = (postProcessDmdEnv du fv, postProcessDivergence ss res_ty)--postProcessDivergence :: Str () -> Divergence -> Divergence--- In a Lazy scenario, we might not force the Divergence, in which case we--- converge, hence Dunno.-postProcessDivergence Lazy _ = Dunno-postProcessDivergence _    d = d--postProcessDmdEnv :: DmdShell -> DmdEnv -> DmdEnv-postProcessDmdEnv ds@(JD { sd = ss, ud = us }) env-  | Abs <- us       = emptyDmdEnv-    -- In this case (postProcessDmd ds) == id; avoid a redundant rebuild-    -- of the environment. Be careful, bad things will happen if this doesn't-    -- match postProcessDmd (see #13977).-  | Str _ <- ss-  , Use One _ <- us = env-  | otherwise       = mapVarEnv (postProcessDmd ds) env-  -- For the Absent case just discard all usage information-  -- We only processed the thing at all to analyse the body-  -- See Note [Always analyse in virgin pass]--reuseEnv :: DmdEnv -> DmdEnv-reuseEnv = mapVarEnv (postProcessDmd-                        (JD { sd = Str (), ud = Use Many () }))--postProcessUnsat :: DmdShell -> DmdType -> DmdType-postProcessUnsat ds@(JD { sd = ss }) (DmdType fv args res_ty)-  = DmdType (postProcessDmdEnv ds fv)-            (map (postProcessDmd ds) args)-            (postProcessDivergence ss res_ty)--postProcessDmd :: DmdShell -> Demand -> Demand-postProcessDmd (JD { sd = ss, ud = us }) (JD { sd = s, ud = a})-  = JD { sd = s', ud = a' }-  where-    s' = case ss of-           Lazy  -> Lazy-           Str _ -> s-    a' = case us of-           Abs        -> Abs-           Use Many _ -> markReusedDmd a-           Use One  _ -> a---- Peels one call level from the demand, and also returns--- whether it was unsaturated (separately for strictness and usage)-peelCallDmd :: CleanDemand -> (CleanDemand, DmdShell)--- Exploiting the fact that--- on the strictness side      C(B) = B--- and on the usage side       C(U) = U-peelCallDmd (JD {sd = s, ud = u})-  = (JD { sd = s', ud = u' }, JD { sd = ss, ud = us })-  where-    (s', ss) = case s of-                 SCall s' -> (s',       Str ())-                 HyperStr -> (HyperStr, Str ())-                 _        -> (HeadStr,  Lazy)-    (u', us) = case u of-                 UCall c u' -> (u',   Use c    ())-                 _          -> (Used, Use Many ())-       -- The _ cases for usage includes UHead which seems a bit wrong-       -- because the body isn't used at all!-       -- c.f. the Abs case in toCleanDmd---- Peels that multiple nestings of calls clean demand and also returns--- whether it was unsaturated (separately for strictness and usage--- see Note [Demands from unsaturated function calls]-peelManyCalls :: Int -> CleanDemand -> DmdShell-peelManyCalls n (JD { sd = str, ud = abs })-  = JD { sd = go_str n str, ud = go_abs n abs }-  where-    go_str :: Int -> StrDmd -> Str ()  -- True <=> unsaturated, defer-    go_str 0 _          = Str ()-    go_str _ HyperStr   = Str () -- == go_str (n-1) HyperStr, as HyperStr = Call(HyperStr)-    go_str n (SCall d') = go_str (n-1) d'-    go_str _ _          = Lazy--    go_abs :: Int -> UseDmd -> Use ()      -- Many <=> unsaturated, or at least-    go_abs 0 _              = Use One ()   --          one UCall Many in the demand-    go_abs n (UCall One d') = go_abs (n-1) d'-    go_abs _ _              = Use Many ()--{--Note [Demands from unsaturated function calls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a demand transformer d1 -> d2 -> r for f.-If a sufficiently detailed demand is fed into this transformer,-e.g <C(C(S)), C1(C1(S))> arising from "f x1 x2" in a strict, use-once context,-then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for-the free variable environment) and furthermore the result information r is the-one we want to use.--An anonymous lambda is also an unsaturated function all (needs one argument,-none given), so this applies to that case as well.--But the demand fed into f might be less than <C(C(S)), C1(C1(S))>. There are a few cases:- * Not enough demand on the strictness side:-   - In that case, we need to zap all strictness in the demand on arguments and-     free variables.-   - And finally Divergence information: If r says that f Diverges for sure,-     then this holds when the demand guarantees that two arguments are going to-     be passed. If the demand is lower, we may just as well converge.-     If we were tracking definite convegence, than that would still hold under-     a weaker demand than expected by the demand transformer.- * Not enough demand from the usage side: The missing usage can be expanded-   using UCall Many, therefore this is subsumed by the third case:- * At least one of the uses has a cardinality of Many.-   - Even if f puts a One demand on any of its argument or free variables, if-     we call f multiple times, we may evaluate this argument or free variable-     multiple times. So forget about any occurrence of "One" in the demand.--In dmdTransformSig, we call peelManyCalls to find out if we are in any of these-cases, and then call postProcessUnsat to reduce the demand appropriately.--Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use-peelCallDmd, which peels only one level, but also returns the demand put on the-body of the function.--}--peelFV :: DmdType -> Var -> (DmdType, Demand)-peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)-                               (DmdType fv' ds res, dmd)-  where-  fv' = fv `delVarEnv` id-  -- See Note [Default demand on free variables and arguments]-  dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res--addDemand :: Demand -> DmdType -> DmdType-addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res--findIdDemand :: DmdType -> Var -> Demand-findIdDemand (DmdType fv _ res) id-  = lookupVarEnv fv id `orElse` defaultFvDmd res--{--Note [Always analyse in virgin pass]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Tricky point: make sure that we analyse in the 'virgin' pass. Consider-   rec { f acc x True  = f (...rec { g y = ...g... }...)-         f acc x False = acc }-In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.-That might mean that we analyse the sub-expression containing the-E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*-E, but just returned botType.--Then in the *next* (non-virgin) iteration for 'f', we might analyse E-in a weaker demand, and that will trigger doing a fixpoint iteration-for g.  But *because it's not the virgin pass* we won't start g's-iteration at bottom.  Disaster.  (This happened in $sfibToList' of-nofib/spectral/fibheaps.)--So in the virgin pass we make sure that we do analyse the expression-at least once, to initialise its signatures.--Note [Analyzing with lazy demand and lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The insight for analyzing lambdas follows from the fact that for-strictness S = C(L). This polymorphic expansion is critical for-cardinality analysis of the following example:--{-# NOINLINE build #-}-build g = (g (:) [], g (:) [])--h c z = build (\x ->-                let z1 = z ++ z-                 in if c-                    then \y -> x (y ++ z1)-                    else \y -> x (z1 ++ y))--One can see that `build` assigns to `g` demand <L,C(C1(U))>.-Therefore, when analyzing the lambda `(\x -> ...)`, we-expect each lambda \y -> ... to be annotated as "one-shot"-one. Therefore (\x -> \y -> x (y ++ z)) should be analyzed with a-demand <C(C(..), C(C1(U))>.--This is achieved by, first, converting the lazy demand L into the-strict S by the second clause of the analysis.--Note [Analysing with absent demand]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we analyse an expression with demand <L,A>.  The "A" means-"absent", so this expression will never be needed.  What should happen?-There are several wrinkles:--* We *do* want to analyse the expression regardless.-  Reason: Note [Always analyse in virgin pass]--  But we can post-process the results to ignore all the usage-  demands coming back. This is done by postProcessDmdType.--* In a previous incarnation of GHC we needed to be extra careful in the-  case of an *unlifted type*, because unlifted values are evaluated-  even if they are not used.  Example (see #9254):-     f :: (() -> (# Int#, () #)) -> ()-          -- Strictness signature is-          --    <C(S(LS)), 1*C1(U(A,1*U()))>-          -- I.e. calls k, but discards first component of result-     f k = case k () of (# _, r #) -> r--     g :: Int -> ()-     g y = f (\n -> (# case y of I# y2 -> y2, n #))--  Here f's strictness signature says (correctly) that it calls its-  argument function and ignores the first component of its result.-  This is correct in the sense that it'd be fine to (say) modify the-  function so that always returned 0# in the first component.--  But in function g, we *will* evaluate the 'case y of ...', because-  it has type Int#.  So 'y' will be evaluated.  So we must record this-  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that-  'y' is bound to an aBSENT_ERROR thunk.--  However, the argument of toCleanDmd always satisfies the let/app-  invariant; so if it is unlifted it is also okForSpeculation, and so-  can be evaluated in a short finite time -- and that rules out nasty-  cases like the one above.  (I'm not quite sure why this was a-  problem in an earlier version of GHC, but it isn't now.)--}--{- *********************************************************************-*                                                                      *-                     Demand signatures-*                                                                      *-************************************************************************--In a let-bound Id we record its strictness info.-In principle, this strictness info is a demand transformer, mapping-a demand on the Id into a DmdType, which gives-        a) the free vars of the Id's value-        b) the Id's arguments-        c) an indication of the result of applying-           the Id to its arguments--However, in fact we store in the Id an extremely emascuated demand-transfomer, namely--                a single DmdType-(Nevertheless we dignify StrictSig as a distinct type.)--This DmdType gives the demands unleashed by the Id when it is applied-to as many arguments as are given in by the arg demands in the DmdType.-Also see Note [Demand type Divergence] for the meaning of a Divergence in a-strictness signature.--If an Id is applied to less arguments than its arity, it means that-the demand on the function at a call site is weaker than the vanilla-call demand, used for signature inference. Therefore we place a top-demand on all arguments. Otherwise, the demand is specified by Id's-signature.--For example, the demand transformer described by the demand signature-        StrictSig (DmdType {x -> <S,1*U>} <L,A><L,U(U,U)>m)-says that when the function is applied to two arguments, it-unleashes demand <S,1*U> on the free var x, <L,A> on the first arg,-and <L,U(U,U)> on the second, then returning a constructor.--If this same function is applied to one arg, all we can say is that it-uses x with <L,U>, and its arg with demand <L,U>.--Note [Understanding DmdType and StrictSig]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Demand types are sound approximations of an expression's semantics relative to-the incoming demand we put the expression under. Consider the following-expression:--    \x y -> x `seq` (y, 2*x)--Here is a table with demand types resulting from different incoming demands we-put that expression under. Note the monotonicity; a stronger incoming demand-yields a more precise demand type:--    incoming demand                  |  demand type-    -----------------------------------------------------    <S           ,HU              >  |  <L,U><L,U>{}-    <C(C(S     )),C1(C1(U       ))>  |  <S,U><L,U>{}-    <C(C(S(S,L))),C1(C1(U(1*U,A)))>  |  <S,1*HU><L,A>{}--Note that in the first example, the depth of the demand type was *higher* than-the arity of the incoming call demand due to the anonymous lambda.-The converse is also possible and happens when we unleash demand signatures.-In @f x y@, the incoming call demand on f has arity 2. But if all we have is a-demand signature with depth 1 for @f@ (which we can safely unleash, see below),-the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.--So: Demand types are elicited by putting an expression under an incoming (call)-demand, the arity of which can be lower or higher than the depth of the-resulting demand type.-In contrast, a demand signature summarises a function's semantics *without*-immediately specifying the incoming demand it was produced under. Despite StrSig-being a newtype wrapper around DmdType, it actually encodes two things:--  * The threshold (i.e., minimum arity) to unleash the signature-  * A demand type that is sound to unleash when the minimum arity requirement is-    met.--Here comes the subtle part: The threshold is encoded in the wrapped demand-type's depth! So in mkStrictSigForArity we make sure to trim the list of-argument demands to the given threshold arity. Call sites will make sure that-this corresponds to the arity of the call demand that elicited the wrapped-demand type. See also Note [What are demand signatures?] in GHC.Core.Opt.DmdAnal.--}---- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe--- to unleash. Better construct this through 'mkStrictSigForArity'.--- See Note [Understanding DmdType and StrictSig]-newtype StrictSig = StrictSig DmdType-                  deriving( Eq )--instance Outputable StrictSig where-   ppr (StrictSig ty) = ppr ty---- Used for printing top-level strictness pragmas in interface files-pprIfaceStrictSig :: StrictSig -> SDoc-pprIfaceStrictSig (StrictSig (DmdType _ dmds res))-  = hcat (map ppr dmds) <> ppr res---- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig'--- unleashable at that arity. See Note [Understanding DmdType and StrictSig]-mkStrictSigForArity :: Arity -> DmdType -> StrictSig-mkStrictSigForArity arity dmd_ty@(DmdType fvs args div)-  | arity < dmdTypeDepth dmd_ty = StrictSig (DmdType fvs (take arity args) div)-  | otherwise                   = StrictSig (etaExpandDmdType arity dmd_ty)--mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig-mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res)--splitStrictSig :: StrictSig -> ([Demand], Divergence)-splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)--prependArgsStrictSig :: Int -> StrictSig -> StrictSig--- ^ Add extra ('topDmd') arguments to a strictness signature.--- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument--- demands. This is used by FloatOut.-prependArgsStrictSig new_args sig@(StrictSig dmd_ty@(DmdType env dmds res))-  | new_args == 0       = sig-  | isTopDmdType dmd_ty = sig-  | new_args < 0        = pprPanic "prependArgsStrictSig: negative new_args"-                                   (ppr new_args $$ ppr sig)-  | otherwise           = StrictSig (DmdType env dmds' res)-  where-    dmds' = replicate new_args topDmd ++ dmds--etaConvertStrictSig :: Arity -> StrictSig -> StrictSig--- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to--- the former (when the Simplifier identifies a new join points, for example).--- In contrast to 'prependArgsStrictSig', this /appends/ extra arg demands if--- necessary.--- This works by looking at the 'DmdType' (which was produced under a call--- demand for the old arity) and trying to transfer as many facts as we can to--- the call demand of new arity.--- An arity increase (resulting in a stronger incoming demand) can retain much--- of the info, while an arity decrease (a weakening of the incoming demand)--- must fall back to a conservative default.-etaConvertStrictSig arity (StrictSig dmd_ty)-  | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty-  | otherwise                   = StrictSig $ etaExpandDmdType arity dmd_ty--isTopSig :: StrictSig -> Bool-isTopSig (StrictSig ty) = isTopDmdType ty--hasDemandEnvSig :: StrictSig -> Bool-hasDemandEnvSig (StrictSig (DmdType env _ _)) = not (isEmptyVarEnv env)--strictSigDmdEnv :: StrictSig -> DmdEnv-strictSigDmdEnv (StrictSig (DmdType env _ _)) = env---- | True if the signature diverges or throws an exception in a saturated call.--- See Note [Dead ends].-isDeadEndSig :: StrictSig -> Bool-isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res--botSig :: StrictSig-botSig = StrictSig botDmdType--nopSig :: StrictSig-nopSig = StrictSig nopDmdType--seqStrictSig :: StrictSig -> ()-seqStrictSig (StrictSig ty) = seqDmdType ty--dmdTransformSig :: StrictSig -> CleanDemand -> DmdType--- (dmdTransformSig fun_sig dmd) considers a call to a function whose--- signature is fun_sig, with demand dmd.  We return the demand--- that the function places on its context (eg its args)-dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) cd-  = postProcessUnsat (peelManyCalls (length arg_ds) cd) dmd_ty-    -- see Note [Demands from unsaturated function calls]--dmdTransformDataConSig :: Arity -> CleanDemand -> DmdType--- Same as dmdTransformSig but for a data constructor (worker),--- which has a special kind of demand transformer.--- If the constructor is saturated, we feed the demand on--- the result into the constructor arguments.-dmdTransformDataConSig arity (JD { sd = str, ud = abs })-  | Just str_dmds <- go_str arity str-  , Just abs_dmds <- go_abs arity abs-  = DmdType emptyDmdEnv (mkJointDmds str_dmds abs_dmds) topDiv--  | otherwise   -- Not saturated-  = nopDmdType-  where-    go_str 0 dmd        = splitStrProdDmd arity dmd-    go_str n (SCall s') = go_str (n-1) s'-    go_str n HyperStr   = go_str (n-1) HyperStr-    go_str _ _          = Nothing--    go_abs 0 dmd            = splitUseProdDmd arity dmd-    go_abs n (UCall One u') = go_abs (n-1) u'-    go_abs _ _              = Nothing--dmdTransformDictSelSig :: StrictSig -> CleanDemand -> DmdType--- Like dmdTransformDataConSig, we have a special demand transformer--- for dictionary selectors.  If the selector is saturated (ie has one--- argument: the dictionary), we feed the demand on the result into--- the indicated dictionary component.-dmdTransformDictSelSig (StrictSig (DmdType _ [dict_dmd] _)) cd-   | (cd',defer_use) <- peelCallDmd cd-   , Just jds <- splitProdDmd_maybe dict_dmd-   = postProcessUnsat defer_use $-     DmdType emptyDmdEnv [mkOnceUsedDmd $ mkProdDmd $ map (enhance cd') jds] topDiv-   | otherwise-   = nopDmdType -- See Note [Demand transformer for a dictionary selector]-  where-    enhance cd old | isAbsDmd old = old-                   | otherwise    = mkOnceUsedDmd cd  -- This is the one!--dmdTransformDictSelSig _ _ = panic "dmdTransformDictSelSig: no args"--{--Note [Demand transformer for a dictionary selector]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'-into the appropriate field of the dictionary. What *is* the appropriate field?-We just look at the strictness signature of the class op, which will be-something like: U(AAASAAAAA).  Then replace the 'S' by the demand 'd'.--For single-method classes, which are represented by newtypes the signature-of 'op' won't look like U(...), so the splitProdDmd_maybe will fail.-That's fine: if we are doing strictness analysis we are also doing inlining,-so we'll have inlined 'op' into a cast.  So we can bale out in a conservative-way, returning nopDmdType.--It is (just.. #8329) possible to be running strictness analysis *without*-having inlined class ops from single-method classes.  Suppose you are using-ghc --make; and the first module has a local -O0 flag.  So you may load a class-without interface pragmas, ie (currently) without an unfolding for the class-ops.   Now if a subsequent module in the --make sweep has a local -O flag-you might do strictness analysis, but there is no inlining for the class op.-This is weird, so I'm not worried about whether this optimises brilliantly; but-it should not fall over.--}--argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]--- See Note [Computing one-shot info]-argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args-  | unsaturated_call = []-  | otherwise = go arg_ds-  where-    unsaturated_call = arg_ds `lengthExceeds` n_val_args--    go []               = []-    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds--    -- Avoid list tail like [ [], [], [] ]-    cons [] [] = []-    cons a  as = a:as---- saturatedByOneShots n C1(C1(...)) = True,---   <=>--- there are at least n nested C1(..) calls--- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap-saturatedByOneShots :: Int -> Demand -> Bool-saturatedByOneShots n (JD { ud = usg })-  = case usg of-      Use _ arg_usg -> go n arg_usg-      _             -> False-  where-    go 0 _             = True-    go n (UCall One u) = go (n-1) u-    go _ _             = False--argOneShots :: Demand          -- depending on saturation-            -> [OneShotInfo]-argOneShots (JD { ud = usg })-  = case usg of-      Use _ arg_usg -> go arg_usg-      _             -> []-  where-    go (UCall One  u) = OneShotLam : go u-    go (UCall Many u) = NoOneShotInfo : go u-    go _              = []--{- Note [Computing one-shot info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a call-    f (\pqr. e1) (\xyz. e2) e3-where f has usage signature-    C1(C(C1(U))) C1(U) U-Then argsOneShots returns a [[OneShotInfo]] of-    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]-The occurrence analyser propagates this one-shot infor to the-binders \pqr and \xyz; see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal".--}---- | Returns true if an application to n args would diverge or throw an--- exception. See Note [Unsaturated applications] and Note [Dead ends].-appIsDeadEnd :: StrictSig -> Int -> Bool-appIsDeadEnd (StrictSig (DmdType _ ds res)) n-  = isDeadEndDiv res && not (lengthExceeds ds n)--{--Note [Unsaturated applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a function having bottom as its demand result is applied to a less-number of arguments than its syntactic arity, we cannot say for sure-that it is going to diverge. This is the reason why we use the-function appIsDeadEnd, which, given a strictness signature and a number-of arguments, says conservatively if the function is never going to return.-See Note [Dead ends].--}--zapUsageEnvSig :: StrictSig -> StrictSig--- Remove the usage environment from the demand-zapUsageEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r--zapUsageDemand :: Demand -> Demand--- Remove the usage info, but not the strictness info, from the demand-zapUsageDemand = kill_usage $ KillFlags-    { kf_abs         = True-    , kf_used_once   = True-    , kf_called_once = True-    }---- | Remove all 1* information (but not C1 information) from the demand-zapUsedOnceDemand :: Demand -> Demand-zapUsedOnceDemand = kill_usage $ KillFlags-    { kf_abs         = False-    , kf_used_once   = True-    , kf_called_once = False-    }---- | Remove all 1* information (but not C1 information) from the strictness---   signature-zapUsedOnceSig :: StrictSig -> StrictSig-zapUsedOnceSig (StrictSig (DmdType env ds r))-    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)--data KillFlags = KillFlags-    { kf_abs         :: Bool-    , kf_used_once   :: Bool-    , kf_called_once :: Bool-    }--kill_usage :: KillFlags -> Demand -> Demand-kill_usage kfs (JD {sd = s, ud = u}) = JD {sd = s, ud = zap_musg kfs u}--zap_musg :: KillFlags -> ArgUse -> ArgUse-zap_musg kfs Abs-  | kf_abs kfs = useTop-  | otherwise  = Abs-zap_musg kfs (Use c u)-  | kf_used_once kfs = Use Many (zap_usg kfs u)-  | otherwise        = Use c    (zap_usg kfs u)--zap_usg :: KillFlags -> UseDmd -> UseDmd-zap_usg kfs (UCall c u)-    | kf_called_once kfs = UCall Many (zap_usg kfs u)-    | otherwise          = UCall c    (zap_usg kfs u)-zap_usg kfs (UProd us)   = UProd (map (zap_musg kfs) us)-zap_usg _   u            = u---- If the argument is a used non-newtype dictionary, give it strict--- demand. Also split the product type & demand and recur in order to--- similarly strictify the argument's contained used non-newtype--- superclass dictionaries. We use the demand as our recursive measure--- to guarantee termination.-strictifyDictDmd :: Type -> Demand -> Demand-strictifyDictDmd ty dmd = case getUseDmd dmd of-  Use n _ |-    Just (tycon, _arg_tys, _data_con, inst_con_arg_tys)-      <- splitDataProductType_maybe ty,-    not (isNewTyCon tycon), isClassTyCon tycon -- is a non-newtype dictionary-    -> seqDmd `bothDmd` -- main idea: ensure it's strict-       case splitProdDmd_maybe dmd of-         -- superclass cycles should not be a problem, since the demand we are-         -- consuming would also have to be infinite in order for us to diverge-         Nothing -> dmd -- no components have interesting demand, so stop-                        -- looking for superclass dicts-         Just dmds-           | all (not . isAbsDmd) dmds -> evalDmd-             -- abstract to strict w/ arbitrary component use, since this-             -- smells like reboxing; results in CBV boxed-             ---             -- TODO revisit this if we ever do boxity analysis-           | otherwise -> case mkProdDmd $ zipWith strictifyDictDmd (map scaledThing inst_con_arg_tys) dmds of-               JD {sd = s,ud = a} -> JD (Str s) (Use n a)-             -- TODO could optimize with an aborting variant of zipWith since-             -- the superclass dicts are always a prefix-  _ -> dmd -- unused or not a dictionary--strictifyDmd :: Demand -> Demand-strictifyDmd dmd@(JD { sd = str })-  = dmd { sd = str `bothArgStr` Str HeadStr }--{--Note [HyperStr and Use demands]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The information "HyperStr" needs to be in the strictness signature, and not in-the demand signature, because we still want to know about the demand on things. Consider--    f (x,y) True  = error (show x)-    f (x,y) False = x+1--The signature of f should be <S(SL),1*U(1*U(U),A)><S,1*U>m. If we were not-distinguishing the uses on x and y in the True case, we could either not figure-out how deeply we can unpack x, or that we do not have to pass y.---************************************************************************-*                                                                      *-                     Serialisation-*                                                                      *-************************************************************************--}--instance Binary StrDmd where-  put_ bh HyperStr     = do putByte bh 0-  put_ bh HeadStr      = do putByte bh 1-  put_ bh (SCall s)    = do putByte bh 2-                            put_ bh s-  put_ bh (SProd sx)   = do putByte bh 3-                            put_ bh sx-  get bh = do-         h <- getByte bh-         case h of-           0 -> do return HyperStr-           1 -> do return HeadStr-           2 -> do s  <- get bh-                   return (SCall s)-           _ -> do sx <- get bh-                   return (SProd sx)--instance Binary ArgStr where-    put_ bh Lazy         = do-            putByte bh 0-    put_ bh (Str s)    = do-            putByte bh 1-            put_ bh s--    get  bh = do-            h <- getByte bh-            case h of-              0 -> return Lazy-              _ -> do s  <- get bh-                      return $ Str s--instance Binary Count where-    put_ bh One  = do putByte bh 0-    put_ bh Many = do putByte bh 1--    get  bh = do h <- getByte bh-                 case h of-                   0 -> return One-                   _ -> return Many--instance Binary ArgUse where-    put_ bh Abs          = do-            putByte bh 0-    put_ bh (Use c u)    = do-            putByte bh 1-            put_ bh c-            put_ bh u--    get  bh = do-            h <- getByte bh-            case h of-              0 -> return Abs-              _ -> do c  <- get bh-                      u  <- get bh-                      return $ Use c u--instance Binary UseDmd where-    put_ bh Used         = do-            putByte bh 0-    put_ bh UHead        = do-            putByte bh 1-    put_ bh (UCall c u)    = do-            putByte bh 2-            put_ bh c-            put_ bh u-    put_ bh (UProd ux)   = do-            putByte bh 3-            put_ bh ux--    get  bh = do-            h <- getByte bh-            case h of-              0 -> return $ Used-              1 -> return $ UHead-              2 -> do c <- get bh-                      u <- get bh-                      return (UCall c u)-              _ -> do ux <- get bh-                      return (UProd ux)--instance (Binary s, Binary u) => Binary (JointDmd s u) where-    put_ bh (JD { sd = x, ud = y }) = do put_ bh x; put_ bh y-    get  bh = do-              x <- get bh-              y <- get bh-              return $ JD { sd = x, ud = y }--instance Binary StrictSig where-    put_ bh (StrictSig aa) = do-            put_ bh aa-    get bh = do-          aa <- get bh-          return (StrictSig aa)--instance Binary DmdType where-  -- Ignore DmdEnv when spitting out the DmdType-  put_ bh (DmdType _ ds dr)-       = do put_ bh ds-            put_ bh dr-  get bh-      = do ds <- get bh-           dr <- get bh-           return (DmdType emptyDmdEnv ds dr)--instance Binary Divergence where-  put_ bh Dunno    = putByte bh 0-  put_ bh ExnOrDiv = putByte bh 1-  put_ bh Diverges = putByte bh 2--  get bh = do { h <- getByte bh-              ; case h of-                  0 -> return Dunno-                  1 -> return ExnOrDiv-                  _ -> return Diverges }+{-# LANGUAGE CPP          #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | A language to express the evaluation context of an expression as a+-- 'Demand' and track how an expression evaluates free variables and arguments+-- in turn as a 'DmdType'.+--+-- Lays out the abstract domain for "GHC.Core.Opt.DmdAnal".+module GHC.Types.Demand (+    -- * Demands+    Card(..), Demand(..), SubDemand(Prod), mkProd, viewProd,+    -- ** Algebra+    absDmd, topDmd, botDmd, seqDmd, topSubDmd,+    -- *** Least upper bound+    lubCard, lubDmd, lubSubDmd,+    -- *** Plus+    plusCard, plusDmd, plusSubDmd,+    -- *** Multiply+    multCard, multDmd, multSubDmd,+    -- ** Predicates on @Card@inalities and @Demand@s+    isAbs, isUsedOnce, isStrict,+    isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,+    isTopDmd, isSeqDmd, isWeakDmd,+    -- ** Special demands+    evalDmd,+    -- *** Demands used in PrimOp signatures+    lazyApply1Dmd, lazyApply2Dmd, strictOnceApply1Dmd, strictManyApply1Dmd,+    -- ** Other @Demand@ operations+    oneifyCard, oneifyDmd, strictifyDmd, strictifyDictDmd, mkWorkerDemand,+    peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,+    addCaseBndrDmd,+    -- ** Extracting one-shot information+    argOneShots, argsOneShots, saturatedByOneShots,++    -- * Demand environments+    DmdEnv, emptyDmdEnv,+    keepAliveDmdEnv, reuseEnv,++    -- * Divergence+    Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv,++    -- * Demand types+    DmdType(..), dmdTypeDepth,+    -- ** Algebra+    nopDmdType, botDmdType,+    lubDmdType, plusDmdType, multDmdType,+    -- *** PlusDmdArg+    PlusDmdArg, mkPlusDmdArg, toPlusDmdArg,+    -- ** Other operations+    peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException,+    keepAliveDmdType,++    -- * Demand signatures+    StrictSig(..), mkStrictSigForArity, mkClosedStrictSig,+    splitStrictSig, strictSigDmdEnv, hasDemandEnvSig,+    nopSig, botSig, isTopSig, isDeadEndSig, appIsDeadEnd,+    -- ** Handling arity adjustments+    prependArgsStrictSig, etaConvertStrictSig,++    -- * Demand transformers from demand signatures+    DmdTransformer, dmdTransformSig, dmdTransformDataConSig, dmdTransformDictSelSig,++    -- * Trim to a type shape+    TypeShape(..), trimToType,++    -- * @seq@ing stuff+    seqDemand, seqDemandList, seqDmdType, seqStrictSig,++    -- * Zapping usage information+    zapUsageDemand, zapDmdEnvSig, zapUsedOnceDemand, zapUsedOnceSig+  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Types.Var ( Var, Id )+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Unique.FM+import GHC.Types.Basic+import GHC.Data.Maybe   ( orElse )++import GHC.Core.Type    ( Type )+import GHC.Core.TyCon   ( isNewTyCon, isClassTyCon )+import GHC.Core.DataCon ( splitDataProductType_maybe )+import GHC.Core.Multiplicity    ( scaledThing )++import GHC.Utils.Binary+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++{-+************************************************************************+*                                                                      *+           Card: Combining Strictness and Usage+*                                                                      *+************************************************************************+-}++{- Note [Evaluation cardinalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand analyser uses an /evaluation cardinality/ of type Card,+to specify how many times a term is evaluated.  A cardinality C_lu+represents an /interval/ [l..u], meaning+    C_lu means evaluated /at least/ 'l' times and+                         /at most/  'u' times++* The lower bound corresponds to /strictness/+  Hence 'l' is either 0 (lazy)+                   or 1 (strict)++* The upper bound corresponds to /usage/+  Hence 'u' is either 0 (not used at all),+                   or 1 (used at most once)+                   or n (no information)++Intervals describe sets, so the underlying lattice is the powerset lattice.++Usually l<=u, but we also have C_10, the interval [1,0], the empty interval,+denoting the empty set.   This is the bottom element of the lattice.++See Note [Demand notation] for the notation we use for each of the constructors.+-}+++-- | Describes an interval of /evaluation cardinalities/.+-- See Note [Evaluation cardinalities]+data Card+  = C_00 -- ^ {0}     Absent.+  | C_01 -- ^ {0,1}   Used at most once.+  | C_0N -- ^ {0,1,n} Every possible cardinality; the top element.+  | C_11 -- ^ {1}     Strict and used once.+  | C_1N -- ^ {1,n}   Strict and used (possibly) many times.+  | C_10 -- ^ {}      The empty interval; the bottom element of the lattice.+  deriving Eq++_botCard, topCard :: Card+_botCard = C_10+topCard = C_0N++-- | True <=> lower bound is 1.+isStrict :: Card -> Bool+isStrict C_10 = True+isStrict C_11 = True+isStrict C_1N = True+isStrict _    = False++-- | True <=> upper bound is 0.+isAbs :: Card -> Bool+isAbs C_00 = True+isAbs C_10 = True -- Bottom cardinality is also absent+isAbs _    = False++-- | True <=> upper bound is 1.+isUsedOnce :: Card -> Bool+isUsedOnce C_0N = False+isUsedOnce C_1N = False+isUsedOnce _    = True++-- | Intersect with [0,1].+oneifyCard :: Card -> Card+oneifyCard C_0N = C_01+oneifyCard C_1N = C_11+oneifyCard c    = c++-- | Denotes '∪' on 'Card'.+lubCard :: Card -> Card -> Card+-- Handle C_10 (bot)+lubCard C_10 n    = n    -- bot+lubCard n    C_10 = n    -- bot+-- Handle C_0N (top)+lubCard C_0N _    = C_0N -- top+lubCard _    C_0N = C_0N -- top+-- Handle C_11+lubCard C_00 C_11 = C_01 -- {0} ∪ {1} = {0,1}+lubCard C_11 C_00 = C_01 -- {0} ∪ {1} = {0,1}+lubCard C_11 n    = n    -- {1} is a subset of all other intervals+lubCard n    C_11 = n    -- {1} is a subset of all other intervals+-- Handle C_1N+lubCard C_1N C_1N = C_1N -- reflexivity+lubCard _    C_1N = C_0N -- {0} ∪ {1,n} = top+lubCard C_1N _    = C_0N -- {0} ∪ {1,n} = top+-- Handle C_01+lubCard C_01 _    = C_01 -- {0} ∪ {0,1} = {0,1}+lubCard _    C_01 = C_01 -- {0} ∪ {0,1} = {0,1}+-- Handle C_00+lubCard C_00 C_00 = C_00 -- reflexivity++-- | Denotes '+' on 'Card'.+plusCard :: Card -> Card -> Card+-- Handle C_00+plusCard C_00 n    = n    -- {0}+n = n+plusCard n    C_00 = n    -- {0}+n = n+-- Handle C_10+plusCard C_10 C_01 = C_11 -- These follow by applying + to lower and upper+plusCard C_10 C_0N = C_1N -- bounds individually+plusCard C_10 n    = n+plusCard C_01 C_10 = C_11+plusCard C_0N C_10 = C_1N+plusCard n    C_10 = n+-- Handle the rest (C_01, C_0N, C_11, C_1N)+plusCard C_01 C_01 = C_0N -- The upper bound is at least 1, so upper bound of+plusCard C_01 C_0N = C_0N -- the result must be 1+1 ~= N.+plusCard C_0N C_01 = C_0N -- But for the lower bound we have 4 cases where+plusCard C_0N C_0N = C_0N -- 0+0 ~= 0 (as opposed to 1), so we match on these.+plusCard _    _    = C_1N -- Otherwise we return {1,n}++-- | Denotes '*' on 'Card'.+multCard :: Card -> Card -> Card+-- Handle C_11 (neutral element)+multCard C_11 c    = c+multCard c    C_11 = c+-- Handle C_00 (annihilating element)+multCard C_00 _    = C_00+multCard _    C_00 = C_00+-- Handle C_10+multCard C_10 c    = if isStrict c then C_10 else C_00+multCard c    C_10 = if isStrict c then C_10 else C_00+-- Handle reflexive C_1N, C_01+multCard C_1N C_1N = C_1N+multCard C_01 C_01 = C_01+-- Handle C_0N and the rest (C_01, C_1N):+multCard _    _    = C_0N++{-+************************************************************************+*                                                                      *+           Demand: Evaluation contexts+*                                                                      *+************************************************************************+-}++-- | A demand describes a /scaled evaluation context/, e.g. how many times+-- and how deep the denoted thing is evaluated.+--+-- The "how many" component is represented by a 'Card'inality.+-- The "how deep" component is represented by a 'SubDemand'.+-- Examples (using Note [Demand notation]):+--+--   * 'seq' puts demand @1A@ on its first argument: It evaluates the argument+--     strictly (@1@), but not any deeper (@A@).+--   * 'fst' puts demand @1P(1L,A)@ on its argument: It evaluates the argument+--     pair strictly and the first component strictly, but no nested info+--     beyond that (@L@). Its second argument is not used at all.+--   * '$' puts demand @1C1(L)@ on its first argument: It calls (@C@) the+--     argument function with one argument, exactly once (@1@). No info+--     on how the result of that call is evaluated (@L@).+--   * 'maybe' puts demand @MCM(L)@ on its second argument: It evaluates+--     the argument function at most once ((M)aybe) and calls it once when+--     it is evaluated.+--   * @fst p + fst p@ puts demand @SP(SL,A)@ on @p@: It's @1P(1L,A)@+--     multiplied by two, so we get @S@ (used at least once, possibly multiple+--     times).+--+-- This data type is quite similar to @'Scaled' 'SubDemand'@, but it's scaled+-- by 'Card', which is an /interval/ on 'Multiplicity', the upper bound of+-- which could be used to infer uniqueness types.+data Demand+  = !Card :* !SubDemand+  deriving Eq++-- | A sub-demand describes an /evaluation context/, e.g. how deep the+-- denoted thing is evaluated. See 'Demand' for examples.+--+-- The nested 'SubDemand' @d@ of a 'Call' @Cn(d)@ is /relative/ to a single such call.+-- E.g. The expression @f 1 2 + f 3 4@ puts call demand @SCS(C1(L))@ on @f@:+-- @f@ is called exactly twice (@S@), each time exactly once (@1@) with an+-- additional argument.+--+-- The nested 'Demand's @dn@ of a 'Prod' @P(d1,d2,...)@ apply /absolutely/:+-- If @dn@ is a used once demand (cf. 'isUsedOnce'), then that means that+-- the denoted sub-expression is used once in the entire evaluation context+-- described by the surrounding 'Demand'. E.g., @LP(ML)@ means that the+-- field of the denoted expression is used at most once, although the+-- entire expression might be used many times.+--+-- See Note [Call demands are relative]+-- and Note [Demand notation].+data SubDemand+  = Poly !Card+  -- ^ Polymorphic demand, the denoted thing is evaluated arbitrarily deep,+  -- with the specified cardinality at every level.+  -- Expands to 'Call' via 'viewCall' and to 'Prod' via 'viewProd'.+  --+  -- @Poly n@ is semantically equivalent to @Prod [n :* Poly n, ...]@ or+  -- @Call n (Poly n)@. 'mkCall' and 'mkProd' do these rewrites.+  --+  -- In Note [Demand notation]: @L === P(L,L,...)@ and @L === CL(L)@,+  --                            @1 === P(1,1,...)@ and @1 === C1(1)@, and so on.+  --+  -- We only really use 'Poly' with 'C_10' (B), 'C_00' (A), 'C_0N' (L) and+  -- sometimes 'C_1N' (S), but it's simpler to treat it uniformly than to+  -- have a special constructor for each of the three cases.+  | Call !Card !SubDemand+  -- ^ @Call n sd@ describes the evaluation context of @n@ function+  -- applications, where every individual result is evaluated according to @sd@.+  -- @sd@ is /relative/ to a single call, cf. Note [Call demands are relative].+  -- Used only for values of function type. Use the smart constructor 'mkCall'+  -- whenever possible!+  | Prod ![Demand]+  -- ^ @Prod ds@ describes the evaluation context of a case scrutinisation+  -- on an expression of product type, where the product components are+  -- evaluated according to @ds@.+  deriving Eq++poly00, poly01, poly0N, poly11, poly1N, poly10 :: SubDemand+topSubDmd, botSubDmd, seqSubDmd :: SubDemand+poly00 = Poly C_00+poly01 = Poly C_01+poly0N = Poly C_0N+poly11 = Poly C_11+poly1N = Poly C_1N+poly10 = Poly C_10+topSubDmd = poly0N+botSubDmd = poly10+seqSubDmd = poly00++polyDmd :: Card -> Demand+polyDmd C_00 = C_00 :* poly00+polyDmd C_01 = C_01 :* poly01+polyDmd C_0N = C_0N :* poly0N+polyDmd C_11 = C_11 :* poly11+polyDmd C_1N = C_1N :* poly1N+polyDmd C_10 = C_10 :* poly10++-- | A smart constructor for 'Prod', applying rewrite rules along the semantic+-- equality @Prod [polyDmd n, ...] === polyDmd n@, simplifying to 'Poly'+-- 'SubDemand's when possible. Note that this degrades boxity information! E.g. a+-- polymorphic demand will never unbox.+mkProd :: [Demand] -> SubDemand+mkProd [] = seqSubDmd+mkProd ds@(n:*sd : _)+  | want_to_simplify n, all (== polyDmd n) ds = sd+  | otherwise                                 = Prod ds+  where+    -- We only want to simplify absent and bottom demands and unbox the others.+    -- See also Note [L should win] and Note [Don't optimise LP(L,L,...) to L].+    want_to_simplify C_00 = True+    want_to_simplify C_10 = True+    want_to_simplify _    = False++-- | @viewProd n sd@ interprets @sd@ as a 'Prod' of arity @n@, expanding 'Poly'+-- demands as necessary.+viewProd :: Arity -> SubDemand -> Maybe [Demand]+-- It's quite important that this function is optimised well;+-- it is used by lubSubDmd and plusSubDmd. Note the strict+-- application to 'polyDmd':+viewProd n (Prod ds)   | ds `lengthIs` n = Just ds+-- Note the strict application to replicate: This makes sure we don't allocate+-- a thunk for it, inlines it and lets case-of-case fire at call sites.+viewProd n (Poly card)                   = Just (replicate n $! polyDmd card)+viewProd _ _                             = Nothing+{-# INLINE viewProd #-} -- we want to fuse away the replicate and the allocation+                        -- for Arity. Otherwise, #18304 bites us.++-- | A smart constructor for 'Call', applying rewrite rules along the semantic+-- equality @Call n (Poly n) === Poly n@, simplifying to 'Poly' 'SubDemand's+-- when possible.+mkCall :: Card -> SubDemand -> SubDemand+mkCall n cd@(Poly m) | n == m = cd+mkCall n cd                   = Call n cd++-- | @viewCall sd@ interprets @sd@ as a 'Call', expanding 'Poly' demands as+-- necessary.+viewCall :: SubDemand -> Maybe (Card, SubDemand)+viewCall (Call n sd)    = Just (n, sd)+viewCall sd@(Poly card) = Just (card, sd)+viewCall _              = Nothing++topDmd, absDmd, botDmd, seqDmd :: Demand+topDmd = polyDmd C_0N+absDmd = polyDmd C_00+botDmd = polyDmd C_10+seqDmd = C_11 :* seqSubDmd++-- | Denotes '∪' on 'SubDemand'.+lubSubDmd :: SubDemand -> SubDemand -> SubDemand+-- Handle Prod+lubSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =+  Prod $ zipWith lubDmd ds2 ds1 -- try to fuse with ds2+-- Handle Call+lubSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))+  -- See Note [Call demands are relative]+  | isAbs n1  = mkCall (lubCard n1 n2) (lubSubDmd botSubDmd d2)+  | isAbs n2  = mkCall (lubCard n1 n2) (lubSubDmd d1 botSubDmd)+  | otherwise = mkCall (lubCard n1 n2) (lubSubDmd d1        d2)+-- Handle Poly+lubSubDmd (Poly n1)  (Poly n2) = Poly (lubCard n1 n2)+-- Make use of reflexivity (so we'll match the Prod or Call cases again).+lubSubDmd sd1@Poly{} sd2       = lubSubDmd sd2 sd1+-- Otherwise (Call `lub` Prod) return Top+lubSubDmd _          _         = topSubDmd++-- | Denotes '∪' on 'Demand'.+lubDmd :: Demand -> Demand -> Demand+lubDmd (n1 :* sd1) (n2 :* sd2) = lubCard n1 n2 :* lubSubDmd sd1 sd2++-- | Denotes '+' on 'SubDemand'.+plusSubDmd :: SubDemand -> SubDemand -> SubDemand+-- Handle Prod+plusSubDmd (Prod ds1) (viewProd (length ds1) -> Just ds2) =+  Prod $ zipWith plusDmd ds2 ds1 -- try to fuse with ds2+-- Handle Call+plusSubDmd (Call n1 d1) (viewCall -> Just (n2, d2))+  -- See Note [Call demands are relative]+  | isAbs n1  = mkCall (plusCard n1 n2) (lubSubDmd botSubDmd d2)+  | isAbs n2  = mkCall (plusCard n1 n2) (lubSubDmd d1 botSubDmd)+  | otherwise = mkCall (plusCard n1 n2) (lubSubDmd d1        d2)+-- Handle Poly+plusSubDmd (Poly n1)  (Poly n2) = Poly (plusCard n1 n2)+-- Make use of reflexivity (so we'll match the Prod or Call cases again).+plusSubDmd sd1@Poly{} sd2       = plusSubDmd sd2 sd1+-- Otherwise (Call `lub` Prod) return Top+plusSubDmd _          _         = topSubDmd++-- | Denotes '+' on 'Demand'.+plusDmd :: Demand -> Demand -> Demand+plusDmd (n1 :* sd1) (n2 :* sd2) = plusCard n1 n2 :* plusSubDmd sd1 sd2++-- | The trivial cases of the @mult*@ functions.+-- If @multTrivial n abs a = ma@, we have the following outcomes+-- depending on @n@:+--+--   * 'C_11' => multiply by one, @ma = Just a@+--   * 'C_00', 'C_10' (e.g. @'isAbs' n@) => return the absent thing,+--      @ma = Just abs@+--   * Otherwise ('C_01', 'C_*N') it's not a trivial case, @ma = Nothing@.+multTrivial :: Card -> a -> a -> Maybe a+multTrivial C_11 _   a           = Just a+multTrivial n    abs _ | isAbs n = Just abs+multTrivial _    _   _           = Nothing++multSubDmd :: Card -> SubDemand -> SubDemand+multSubDmd n sd+  | Just sd' <- multTrivial n seqSubDmd sd = sd'+multSubDmd n (Poly n')    = Poly (multCard n n')+multSubDmd n (Call n' sd) = mkCall (multCard n n') sd -- See Note [Call demands are relative]+multSubDmd n (Prod ds)    = Prod (map (multDmd n) ds)++multDmd :: Card -> Demand -> Demand+multDmd n    dmd+  | Just dmd' <- multTrivial n absDmd dmd = dmd'+multDmd n (m :* dmd) = multCard n m :* multSubDmd n dmd++-- | Used to suppress pretty-printing of an uninformative demand+isTopDmd :: Demand -> Bool+isTopDmd dmd = dmd == topDmd++isAbsDmd :: Demand -> Bool+isAbsDmd (n :* _) = isAbs n++-- | Contrast with isStrictUsedDmd. See Note [Strict demands]+isStrictDmd :: Demand -> Bool+isStrictDmd (n :* _) = isStrict n++-- | Not absent and used strictly. See Note [Strict demands]+isStrUsedDmd :: Demand -> Bool+isStrUsedDmd (n :* _) = isStrict n && not (isAbs n)++isSeqDmd :: Demand -> Bool+isSeqDmd (C_11 :* sd) = sd == seqSubDmd+isSeqDmd (C_1N :* sd) = sd == seqSubDmd -- I wonder if we need this case.+isSeqDmd _            = False++-- | Is the value used at most once?+isUsedOnceDmd :: Demand -> Bool+isUsedOnceDmd (n :* _) = isUsedOnce n++-- | We try to avoid tracking weak free variable demands in strictness+-- signatures for analysis performance reasons.+-- See Note [Lazy and unleashable free variables] in "GHC.Core.Opt.DmdAnal".+isWeakDmd :: Demand -> Bool+isWeakDmd dmd@(n :* _) = not (isStrict n) && is_plus_idem_dmd dmd+  where+    -- @is_plus_idem_* thing@ checks whether @thing `plus` thing = thing@,+    -- e.g. if @thing@ is idempotent wrt. to @plus@.+    is_plus_idem_card c = plusCard c c == c+    -- is_plus_idem_dmd dmd = plusDmd dmd dmd == dmd+    is_plus_idem_dmd (n :* sd) = is_plus_idem_card n && is_plus_idem_sub_dmd sd+    -- is_plus_idem_sub_dmd sd = plusSubDmd sd sd == sd+    is_plus_idem_sub_dmd (Poly n)   = is_plus_idem_card n+    is_plus_idem_sub_dmd (Prod ds)  = all is_plus_idem_dmd ds+    is_plus_idem_sub_dmd (Call n _) = is_plus_idem_card n -- See Note [Call demands are relative]++evalDmd :: Demand+evalDmd = C_1N :* topSubDmd++-- | First argument of 'GHC.Exts.maskAsyncExceptions#': @1C1(L)@.+-- Called exactly once.+strictOnceApply1Dmd :: Demand+strictOnceApply1Dmd = C_11 :* mkCall C_11 topSubDmd++-- | First argument of 'GHC.Exts.atomically#': @SCS(L)@.+-- Called at least once, possibly many times.+strictManyApply1Dmd :: Demand+strictManyApply1Dmd = C_1N :* mkCall C_1N topSubDmd++-- | First argument of catch#: @MCM(L)@.+-- Evaluates its arg lazily, but then applies it exactly once to one argument.+lazyApply1Dmd :: Demand+lazyApply1Dmd = C_01 :* mkCall C_01 topSubDmd++-- | Second argument of catch#: @MCM(C1(L))@.+-- Calls its arg lazily, but then applies it exactly once to an additional argument.+lazyApply2Dmd :: Demand+lazyApply2Dmd = C_01 :* mkCall C_01 (mkCall C_11 topSubDmd)++-- | Make a 'Demand' evaluated at-most-once.+oneifyDmd :: Demand -> Demand+oneifyDmd (n :* sd) = oneifyCard n :* sd++-- | Make a 'Demand' evaluated at-least-once (e.g. strict).+strictifyDmd :: Demand -> Demand+strictifyDmd (n :* sd) = plusCard C_10 n :* sd++-- | If the argument is a used non-newtype dictionary, give it strict demand.+-- Also split the product type & demand and recur in order to similarly+-- strictify the argument's contained used non-newtype superclass dictionaries.+-- We use the demand as our recursive measure to guarantee termination.+strictifyDictDmd :: Type -> Demand -> Demand+strictifyDictDmd ty (n :* Prod ds)+  | not (isAbs n)+  , Just field_tys <- as_non_newtype_dict ty+  = C_1N :* -- main idea: ensure it's strict+      if all (not . isAbsDmd) ds+        then topSubDmd -- abstract to strict w/ arbitrary component use,+                         -- since this smells like reboxing; results in CBV+                         -- boxed+                         --+                         -- TODO revisit this if we ever do boxity analysis+        else Prod (zipWith strictifyDictDmd field_tys ds)+  where+    -- | Return a TyCon and a list of field types if the given+    -- type is a non-newtype dictionary type+    as_non_newtype_dict ty+      | Just (tycon, _arg_tys, _data_con, map scaledThing -> inst_con_arg_tys)+          <- splitDataProductType_maybe ty+      , not (isNewTyCon tycon)+      , isClassTyCon tycon+      = Just inst_con_arg_tys+      | otherwise+      = Nothing+strictifyDictDmd _  dmd = dmd++-- | Wraps the 'SubDemand' with a one-shot call demand: @d@ -> @C1(d)@.+mkCalledOnceDmd :: SubDemand -> SubDemand+mkCalledOnceDmd sd = mkCall C_11 sd++-- | @mkCalledOnceDmds n d@ returns @C1(C1...(C1 d))@ where there are @n@ @C1@'s.+mkCalledOnceDmds :: Arity -> SubDemand -> SubDemand+mkCalledOnceDmds arity sd = iterate mkCalledOnceDmd sd !! arity++-- | Peels one call level from the sub-demand, and also returns how many+-- times we entered the lambda body.+peelCallDmd :: SubDemand -> (Card, SubDemand)+peelCallDmd sd = viewCall sd `orElse` (topCard, topSubDmd)++-- Peels multiple nestings of 'Call' sub-demands and also returns+-- whether it was unsaturated in the form of a 'Card'inality, denoting+-- how many times the lambda body was entered.+-- See Note [Demands from unsaturated function calls].+peelManyCalls :: Int -> SubDemand -> Card+peelManyCalls 0 _                          = C_11+-- See Note [Call demands are relative]+peelManyCalls n (viewCall -> Just (m, sd)) = m `multCard` peelManyCalls (n-1) sd+peelManyCalls _ _                          = C_0N++-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap+mkWorkerDemand :: Int -> Demand+mkWorkerDemand n = C_01 :* go n+  where go 0 = topSubDmd+        go n = Call C_01 $ go (n-1)++addCaseBndrDmd :: SubDemand -- On the case binder+               -> [Demand]  -- On the components of the constructor+               -> [Demand]  -- Final demands for the components of the constructor+addCaseBndrDmd (Poly n) alt_dmds+  | isAbs n   = alt_dmds+-- See Note [Demand on case-alternative binders]+addCaseBndrDmd sd       alt_dmds = zipWith plusDmd ds alt_dmds -- fuse ds!+  where+    Just ds = viewProd (length alt_dmds) sd -- Guaranteed not to be a call++argsOneShots :: StrictSig -> Arity -> [[OneShotInfo]]+-- ^ See Note [Computing one-shot info]+argsOneShots (StrictSig (DmdType _ arg_ds _)) n_val_args+  | unsaturated_call = []+  | otherwise = go arg_ds+  where+    unsaturated_call = arg_ds `lengthExceeds` n_val_args++    go []               = []+    go (arg_d : arg_ds) = argOneShots arg_d `cons` go arg_ds++    -- Avoid list tail like [ [], [], [] ]+    cons [] [] = []+    cons a  as = a:as++argOneShots :: Demand          -- ^ depending on saturation+            -> [OneShotInfo]+-- ^ See Note [Computing one-shot info]+argOneShots (_ :* sd) = go sd -- See Note [Call demands are relative]+  where+    go (Call n sd)+      | isUsedOnce n = OneShotLam    : go sd+      | otherwise    = NoOneShotInfo : go sd+    go _    = []++-- |+-- @saturatedByOneShots n CM(CM(...)) = True@+--   <=>+-- There are at least n nested CM(..) calls.+-- See Note [Demand on the worker] in GHC.Core.Opt.WorkWrap+saturatedByOneShots :: Int -> Demand -> Bool+saturatedByOneShots n (_ :* sd) = isUsedOnce (peelManyCalls n sd)++{- Note [Strict demands]+~~~~~~~~~~~~~~~~~~~~~~~~+'isStrUsedDmd' returns true only of demands that are+   both strict+   and  used++In particular, it is False for <B> (i.e. strict and not used,+cardinality C_10), which can and does arise in, say (#7319)+   f x = raise# <some exception>+Then 'x' is not used, so f gets strictness <B> -> .+Now the w/w generates+   fx = let x <B> = absentError "unused"+        in raise <some exception>+At this point we really don't want to convert to+   fx = case absentError "unused" of x -> raise <some exception>+Since the program is going to diverge, this swaps one error for another,+but it's really a bad idea to *ever* evaluate an absent argument.+In #7319 we get+   T7319.exe: Oops!  Entered absent arg w_s1Hd{v} [lid] [base:GHC.Base.String{tc 36u}]++Note [Call demands are relative]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The expression @if b then 0 else f 1 2 + f 3 4@ uses @f@ according to the demand+@LCL(C1(P(L)))@, meaning++  "f is called multiple times or not at all (CL), but each time it+   is called, it's called with *exactly one* (C1) more argument.+   Whenever it is called with two arguments, we have no info on how often+   the field of the product result is used (L)."++So the 'SubDemand' nested in a 'Call' demand is relative to exactly one call.+And that extends to the information we have how its results are used in each+call site. Consider (#18903)++  h :: Int -> Int+  h m =+    let g :: Int -> (Int,Int)+        g 1 = (m, 0)+        g n = (2 * n, 2 `div` n)+        {-# NOINLINE g #-}+    in case m of+      1 -> 0+      2 -> snd (g m)+      _ -> uncurry (+) (g m)++We want to give @g@ the demand @MCM(P(MP(L),1P(L)))@, so we see that in each call+site of @g@, we are strict in the second component of the returned pair.++This relative cardinality leads to an otherwise unexpected call to 'lubSubDmd'+in 'plusSubDmd', but if you do the math it's just the right thing.++There's one more subtlety: Since the nested demand is relative to exactly one+call, in the case where we have *at most zero calls* (e.g. CA(...)), the premise+is hurt and we can assume that the nested demand is 'botSubDmd'. That ensures+that @g@ above actually gets the @1P(L)@ demand on its second pair component,+rather than the lazy @MP(L)@ if we 'lub'bed with an absent demand.++Demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand on a binder in a case alternative comes+  (a) From the demand on the binder itself+  (b) From the demand on the case binder+Forgetting (b) led directly to #10148.++Example. Source code:+  f x@(p,_) = if p then foo x else True++  foo (p,True) = True+  foo (p,q)    = foo (q,p)++After strictness analysis:+  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->+      case x_an1+      of wild_X7 [Dmd=MP(ML,ML)]+      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->+      case p_an2 of _ {+        False -> GHC.Types.True;+        True -> foo wild_X7 }++It's true that ds_dnz is *itself* absent, but the use of wild_X7 means+that it is very much alive and demanded.  See #10148 for how the+consequences play out.++This is needed even for non-product types, in case the case-binder+is used but the components of the case alternative are not.++Note [Don't optimise LP(L,L,...) to L]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These two SubDemands:+   LP(L,L) (@Prod [topDmd, topDmd]@)   and   L (@topSubDmd@)+are semantically equivalent, but we do not turn the former into+the latter, for a regrettable-subtle reason.  Consider+  f p1@(x,y) = (y,x)+  g h p2@(_,_) = h p+We want to unbox @p1@ of @f@, but not @p2@ of @g@, because @g@ only uses+@p2@ boxed and we'd have to rebox. So we give @p1@ demand LP(L,L) and @p2@+demand @L@ to inform 'GHC.Core.Opt.WorkWrap.Utils.wantToUnbox', which will+say "unbox" for @p1@ and "don't unbox" for @p2@.++So the solution is: don't aggressively collapse @Prod [topDmd, topDmd]@ to+@topSubDmd@; instead leave it as-is. In effect we are using the UseDmd to do a+little bit of boxity analysis.  Not very nice.++Note [L should win]+~~~~~~~~~~~~~~~~~~~+Both in 'lubSubDmd' and 'plusSubDmd' we want @L `plusSubDmd` LP(..))@ to be @L@.+Why?  Because U carries the implication the whole thing is used, box and all,+so we don't want to w/w it, cf. Note [Don't optimise LP(L,L,...) to L].+If we use it both boxed and unboxed, then we are definitely using the box,+and so we are quite likely to pay a reboxing cost. So we make U win here.+TODO: Investigate why since 2013, we don't.++Example is in the Buffer argument of GHC.IO.Handle.Internals.writeCharBuffer++Baseline: (A) Not making Used win (LP(..) wins)+Compare with: (B) making Used win for lub and both++            Min          -0.3%     -5.6%    -10.7%    -11.0%    -33.3%+            Max          +0.3%    +45.6%    +11.5%    +11.5%     +6.9%+ Geometric Mean          -0.0%     +0.5%     +0.3%     +0.2%     -0.8%++Baseline: (B) Making L win for both lub and both+Compare with: (C) making L win for plus, but LP(..) win for lub++            Min          -0.1%     -0.3%     -7.9%     -8.0%     -6.5%+            Max          +0.1%     +1.0%    +21.0%    +21.0%     +0.5%+ Geometric Mean          +0.0%     +0.0%     -0.0%     -0.1%     -0.1%++Note [Computing one-shot info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a call+    f (\pqr. e1) (\xyz. e2) e3+where f has usage signature+    <CM(CL(CM(L)))><CM(L)><L>+Then argsOneShots returns a [[OneShotInfo]] of+    [[OneShot,NoOneShotInfo,OneShot],  [OneShot]]+The occurrence analyser propagates this one-shot infor to the+binders \pqr and \xyz;+see Note [Use one-shot information] in "GHC.Core.Opt.OccurAnal".+-}++{- *********************************************************************+*                                                                      *+                 Divergence: Whether evaluation surely diverges+*                                                                      *+********************************************************************* -}++-- | 'Divergence' characterises whether something surely diverges.+-- Models a subset lattice of the following exhaustive set of divergence+-- results:+--+-- [n] nontermination (e.g. loops)+-- [i] throws imprecise exception+-- [p] throws precise exceTtion+-- [c] converges (reduces to WHNF).+--+-- The different lattice elements correspond to different subsets, indicated by+-- juxtaposition of indicators (e.g. __nc__ definitely doesn't throw an+-- exception, and may or may not reduce to WHNF).+--+-- @+--             Dunno (nipc)+--                  |+--            ExnOrDiv (nip)+--                  |+--            Diverges (ni)+-- @+--+-- As you can see, we don't distinguish __n__ and __i__.+-- See Note [Precise exceptions and strictness analysis] for why __p__ is so+-- special compared to __i__.+data Divergence+  = Diverges -- ^ Definitely throws an imprecise exception or diverges.+  | ExnOrDiv -- ^ Definitely throws a *precise* exception, an imprecise+             --   exception or diverges. Never converges, hence 'isDeadEndDiv'!+             --   See scenario 1 in Note [Precise exceptions and strictness analysis].+  | Dunno    -- ^ Might diverge, throw any kind of exception or converge.+  deriving Eq++lubDivergence :: Divergence -> Divergence -> Divergence+lubDivergence Diverges div      = div+lubDivergence div      Diverges = div+lubDivergence ExnOrDiv ExnOrDiv = ExnOrDiv+lubDivergence _        _        = Dunno+-- This needs to commute with defaultFvDmd, i.e.+-- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2+-- (See Note [Default demand on free variables and arguments] for why)++-- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence'+-- needs to be symmetric.+-- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@.+-- But that regresses in too many places (every infinite loop, basically) to be+-- worth it and is only relevant in higher-order scenarios+-- (e.g. Divergence of @f (throwIO blah)@).+-- So 'plusDivergence' currently is 'glbDivergence', really.+plusDivergence :: Divergence -> Divergence -> Divergence+plusDivergence Dunno    Dunno    = Dunno+plusDivergence Diverges _        = Diverges+plusDivergence _        Diverges = Diverges+plusDivergence _        _        = ExnOrDiv++-- | In a non-strict scenario, we might not force the Divergence, in which case+-- we might converge, hence Dunno.+multDivergence :: Card -> Divergence -> Divergence+multDivergence n _ | not (isStrict n) = Dunno+multDivergence _ d                    = d++topDiv, exnDiv, botDiv :: Divergence+topDiv = Dunno+exnDiv = ExnOrDiv+botDiv = Diverges++-- | True if the 'Divergence' indicates that evaluation will not return.+-- See Note [Dead ends].+isDeadEndDiv :: Divergence -> Bool+isDeadEndDiv Diverges = True+isDeadEndDiv ExnOrDiv = True+isDeadEndDiv Dunno    = False++-- See Notes [Default demand on free variables and arguments]+-- and Scenario 1 in [Precise exceptions and strictness analysis]+defaultFvDmd :: Divergence -> Demand+defaultFvDmd Dunno    = absDmd+defaultFvDmd ExnOrDiv = absDmd -- This is the whole point of ExnOrDiv!+defaultFvDmd Diverges = botDmd -- Diverges++defaultArgDmd :: Divergence -> Demand+-- TopRes and BotRes are polymorphic, so that+--      BotRes === (Bot -> BotRes) === ...+--      TopRes === (Top -> TopRes) === ...+-- This function makes that concrete+-- Also see Note [Default demand on free variables and arguments]+defaultArgDmd Dunno    = topDmd+-- NB: not botDmd! We don't want to mask the precise exception by forcing the+-- argument. But it is still absent.+defaultArgDmd ExnOrDiv = absDmd+defaultArgDmd Diverges = botDmd++{- Note [Precise vs imprecise exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An exception is considered to be /precise/ when it is thrown by the 'raiseIO#'+primop. It follows that all other primops (such as 'raise#' or+division-by-zero) throw /imprecise/ exceptions. Note that the actual type of+the exception thrown doesn't have any impact!++GHC undertakes some effort not to apply an optimisation that would mask a+/precise/ exception with some other source of nontermination, such as genuine+divergence or an imprecise exception, so that the user can reliably+intercept the precise exception with a catch handler before and after+optimisations.++See also the wiki page on precise exceptions:+https://gitlab.haskell.org/ghc/ghc/wikis/exceptions/precise-exceptions+Section 5 of "Tackling the awkward squad" talks about semantic concerns.+Imprecise exceptions are actually more interesting than precise ones (which are+fairly standard) from the perspective of semantics. See the paper "A Semantics+for Imprecise Exceptions" for more details.++Note [Dead ends]+~~~~~~~~~~~~~~~~+We call an expression that either diverges or throws a precise or imprecise+exception a "dead end". We used to call such an expression just "bottoming",+but with the measures we take to preserve precise exception semantics+(see Note [Precise exceptions and strictness analysis]), that is no longer+accurate: 'exnDiv' is no longer the bottom of the Divergence lattice.++Yet externally to demand analysis, we mostly care about being able to drop dead+code etc., which is all due to the property that such an expression never+returns, hence we consider throwing a precise exception to be a dead end.+See also 'isDeadEndDiv'.++Note [Precise exceptions and strictness analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have to take care to preserve precise exception semantics in strictness+analysis (#17676). There are two scenarios that need careful treatment.++The fixes were discussed at+https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions++Recall that raiseIO# raises a *precise* exception, in contrast to raise# which+raises an *imprecise* exception. See Note [Precise vs imprecise exceptions].++Scenario 1: Precise exceptions in case alternatives+---------------------------------------------------+Unlike raise# (which returns botDiv), we want raiseIO# to return exnDiv.+Here's why. Consider this example from #13380 (similarly #17676):+  f x y | x>0       = raiseIO# Exc+        | y>0       = return 1+        | otherwise = return 2+Is 'f' strict in 'y'? One might be tempted to say yes! But that plays fast and+loose with the precise exception; after optimisation, (f 42 (error "boom"))+turns from throwing the precise Exc to throwing the imprecise user error+"boom". So, the defaultFvDmd of raiseIO# should be lazy (topDmd), which can be+achieved by giving it divergence exnDiv.+See Note [Default demand on free variables and arguments].++Why don't we just give it topDiv instead of introducing exnDiv?+Because then the simplifier will fail to discard raiseIO#'s continuation in+  case raiseIO# x s of { (# s', r #) -> <BIG> }+which we'd like to optimise to+  case raiseIO# x s of {}+Hence we came up with exnDiv. The default FV demand of exnDiv is lazy (and+its default arg dmd is absent), but otherwise (in terms of 'isDeadEndDiv') it+behaves exactly as botDiv, so that dead code elimination works as expected.+This is tracked by T13380b.++Scenario 2: Precise exceptions in case scrutinees+-------------------------------------------------+Consider (more complete examples in #148, #1592, testcase strun003)++  case foo x s of { (# s', r #) -> y }++Is this strict in 'y'? Often not! If @foo x s@ might throw a precise exception+(ultimately via raiseIO#), then we must not force 'y', which may fail to+terminate or throw an imprecise exception, until we have performed @foo x s@.++So we have to 'deferAfterPreciseException' (which 'lub's with 'exnDmdType' to+model the exceptional control flow) when @foo x s@ may throw a precise+exception. Motivated by T13380{d,e,f}.+See Note [Which scrutinees may throw precise exceptions] in "GHC.Core.Opt.DmdAnal".++We have to be careful not to discard dead-end Divergence from case+alternatives, though (#18086):++  m = putStrLn "foo" >> error "bar"++'m' should still have 'exnDiv', which is why it is not sufficient to lub with+'nopDmdType' (which has 'topDiv') in 'deferAfterPreciseException'.++Historical Note: This used to be called the "IO hack". But that term is rather+a bad fit because+1. It's easily confused with the "State hack", which also affects IO.+2. Neither "IO" nor "hack" is a good description of what goes on here, which+   is deferring strictness results after possibly throwing a precise exception.+   The "hack" is probably not having to defer when we can prove that the+   expression may not throw a precise exception (increasing precision of the+   analysis), but that's just a favourable guess.++Note [Exceptions and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to smart about catching exceptions, but we aren't anymore.+See #14998 for the way it's resolved at the moment.++Here's a historic breakdown:++Apparently, exception handling prim-ops didn't use to have any special+strictness signatures, thus defaulting to nopSig, which assumes they use their+arguments lazily. Joachim was the first to realise that we could provide richer+information. Thus, in 0558911f91c (Dec 13), he added signatures to+primops.txt.pp indicating that functions like `catch#` and `catchRetry#` call+their argument, which is useful information for usage analysis. Still with a+'Lazy' strictness demand (i.e. 'lazyApply1Dmd'), though, and the world was fine.++In 7c0fff4 (July 15), Simon argued that giving `catch#` et al. a+'strictApply1Dmd' leads to substantial performance gains. That was at the cost+of correctness, as #10712 proved. So, back to 'lazyApply1Dmd' in+28638dfe79e (Dec 15).++Motivated to reproduce the gains of 7c0fff4 without the breakage of #10712,+Ben opened #11222. Simon made the demand analyser "understand catch" in+9915b656 (Jan 16) by adding a new 'catchArgDmd', which basically said to call+its argument strictly, but also swallow any thrown exceptions in+'multDivergence'. This was realized by extending the 'Str' constructor of+'ArgStr' with a 'ExnStr' field, indicating that it catches the exception, and+adding a 'ThrowsExn' constructor to the 'Divergence' lattice as an element+between 'Dunno' and 'Diverges'. Then along came #11555 and finally #13330,+so we had to revert to 'lazyApply1Dmd' again in 701256df88c (Mar 17).++This left the other variants like 'catchRetry#' having 'catchArgDmd', which is+where #14998 picked up. Item 1 was concerned with measuring the impact of also+making `catchRetry#` and `catchSTM#` have 'lazyApply1Dmd'. The result was that+there was none. We removed the last usages of 'catchArgDmd' in 00b8ecb7+(Apr 18). There was a lot of dead code resulting from that change, that we+removed in ef6b283 (Jan 19): We got rid of 'ThrowsExn' and 'ExnStr' again and+removed any code that was dealing with the peculiarities.++Where did the speed-ups vanish to? In #14998, item 3 established that+turning 'catch#' strict in its first argument didn't bring back any of the+alleged performance benefits. Item 2 of that ticket finally found out that it+was entirely due to 'catchException's new (since #11555) definition, which+was simply++    catchException !io handler = catch io handler++While 'catchException' is arguably the saner semantics for 'catch', it is an+internal helper function in "GHC.IO". Its use in+"GHC.IO.Handle.Internals.do_operation" made for the huge allocation differences:+Remove the bang and you find the regressions we originally wanted to avoid with+'catchArgDmd'. See also #exceptions_and_strictness# in "GHC.IO".++So history keeps telling us that the only possibly correct strictness annotation+for the first argument of 'catch#' is 'lazyApply1Dmd', because 'catch#' really+is not strict in its argument: Just try this in GHCi++  :set -XScopedTypeVariables+  import Control.Exception+  catch undefined (\(_ :: SomeException) -> putStrLn "you'll see this")++Any analysis that assumes otherwise will be broken in some way or another+(beyond `-fno-pendantic-bottoms`).++But then #13380 and #17676 suggest (in Mar 20) that we need to re-introduce a+subtly different variant of `ThrowsExn` (which we call `ExnOrDiv` now) that is+only used by `raiseIO#` in order to preserve precise exceptions by strictness+analysis, while not impacting the ability to eliminate dead code.+See Note [Precise exceptions and strictness analysis].++Note [Default demand on free variables and arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Free variables not mentioned in the environment of a 'DmdType'+are demanded according to the demand type's Divergence:+  * In a Diverges (botDiv) context, that demand is botDmd+    (strict and absent).+  * In all other contexts, the demand is absDmd (lazy and absent).+This is recorded in 'defaultFvDmd'.++Similarly, we can eta-expand demand types to get demands on excess arguments+not accounted for in the type, by consulting 'defaultArgDmd':+  * In a Diverges (botDiv) context, that demand is again botDmd.+  * In a ExnOrDiv (exnDiv) context, that demand is absDmd: We surely diverge+    before evaluating the excess argument, but don't want to eagerly evaluate+    it (cf. Note [Precise exceptions and strictness analysis]).+  * In a Dunno context (topDiv), the demand is topDmd, because+    it's perfectly possible to enter the additional lambda and evaluate it+    in unforeseen ways (so, not absent).++Note [Bottom CPR iff Dead-Ending Divergence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both CPR analysis and Demand analysis handle recursive functions by doing+fixed-point iteration. To find the *least* (e.g., most informative) fixed-point,+iteration starts with the bottom element of the semantic domain. Diverging+functions generally have the bottom element as their least fixed-point.++One might think that CPR analysis and Demand analysis then agree in when a+function gets a bottom denotation. E.g., whenever it has 'botCpr', it should+also have 'botDiv'. But that is not the case, because strictness analysis has to+be careful around precise exceptions, see Note [Precise vs imprecise exceptions].++So Demand analysis gives some diverging functions 'exnDiv' (which is *not* the+bottom element) when the CPR signature says 'botCpr', and that's OK. Here's an+example (from #18086) where that is the case:++ioTest :: IO ()+ioTest = do+  putStrLn "hi"+  undefined++However, one can loosely say that we give a function 'botCpr' whenever its+'Divergence' is 'exnDiv' or 'botDiv', i.e., dead-ending. But that's just+a consequence of fixed-point iteration, it's not important that they agree.++************************************************************************+*                                                                      *+           Demand environments and types+*                                                                      *+************************************************************************+-}++-- Subject to Note [Default demand on free variables and arguments]+type DmdEnv = VarEnv Demand++emptyDmdEnv :: VarEnv Demand+emptyDmdEnv = emptyVarEnv++multDmdEnv :: Card -> DmdEnv -> DmdEnv+multDmdEnv n env+  | Just env' <- multTrivial n emptyDmdEnv env = env'+  | otherwise                                  = mapVarEnv (multDmd n) env++reuseEnv :: DmdEnv -> DmdEnv+reuseEnv = multDmdEnv C_1N++-- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have+-- /some/ usage in the returned demand types -- they are not Absent.+-- See Note [Absence analysis for stable unfoldings and RULES]+--     in "GHC.Core.Opt.DmdAnal".+keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv+keepAliveDmdEnv env vs+  = nonDetStrictFoldVarSet add env vs+  where+    add :: Id -> DmdEnv -> DmdEnv+    add v env = extendVarEnv_C add_dmd env v topDmd++    add_dmd :: Demand -> Demand -> Demand+    -- If the existing usage is Absent, make it used+    -- Otherwise leave it alone+    add_dmd dmd _ | isAbsDmd dmd = topDmd+                  | otherwise    = dmd++-- | Characterises how an expression+--    * Evaluates its free variables ('dt_env')+--    * Evaluates its arguments ('dt_args')+--    * Diverges on every code path or not ('dt_div')+data DmdType+  = DmdType+  { dt_env  :: DmdEnv     -- ^ Demand on explicitly-mentioned free variables+  , dt_args :: [Demand]   -- ^ Demand on arguments+  , dt_div  :: Divergence -- ^ Whether evaluation diverges.+                          -- See Note [Demand type Divergence]+  }++instance Eq DmdType where+  (==) (DmdType fv1 ds1 div1)+       (DmdType fv2 ds2 div2) = nonDetUFMToList fv1 == nonDetUFMToList fv2+         -- It's OK to use nonDetUFMToList here because we're testing for+         -- equality and even though the lists will be in some arbitrary+         -- Unique order, it is the same order for both+                              && ds1 == ds2 && div1 == div2++-- | Compute the least upper bound of two 'DmdType's elicited /by the same+-- incoming demand/!+lubDmdType :: DmdType -> DmdType -> DmdType+lubDmdType d1 d2+  = DmdType lub_fv lub_ds lub_div+  where+    n = max (dmdTypeDepth d1) (dmdTypeDepth d2)+    (DmdType fv1 ds1 r1) = etaExpandDmdType n d1+    (DmdType fv2 ds2 r2) = etaExpandDmdType n d2++    lub_fv  = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2)+    lub_ds  = zipWithEqual "lubDmdType" lubDmd ds1 ds2+    lub_div = lubDivergence r1 r2++type PlusDmdArg = (DmdEnv, Divergence)++mkPlusDmdArg :: DmdEnv -> PlusDmdArg+mkPlusDmdArg env = (env, topDiv)++toPlusDmdArg :: DmdType -> PlusDmdArg+toPlusDmdArg (DmdType fv _ r) = (fv, r)++plusDmdType :: DmdType -> PlusDmdArg -> DmdType+plusDmdType (DmdType fv1 ds1 r1) (fv2, t2)+    -- See Note [Asymmetry of 'plus*']+    -- 'plus' takes the argument/result info from its *first* arg,+    -- using its second arg just for its free-var info.+  = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2))+            ds1+            (r1 `plusDivergence` t2)++botDmdType :: DmdType+botDmdType = DmdType emptyDmdEnv [] botDiv++-- | The demand type of doing nothing (lazy, absent, no Divergence+-- information). Note that it is ''not'' the top of the lattice (which would be+-- "may use everything"), so it is (no longer) called topDmdType.+nopDmdType :: DmdType+nopDmdType = DmdType emptyDmdEnv [] topDiv++isTopDmdType :: DmdType -> Bool+isTopDmdType (DmdType env args div)+  = div == topDiv && null args && isEmptyVarEnv env++-- | The demand type of an unspecified expression that is guaranteed to+-- throw a (precise or imprecise) exception or diverge.+exnDmdType :: DmdType+exnDmdType = DmdType emptyDmdEnv [] exnDiv++dmdTypeDepth :: DmdType -> Arity+dmdTypeDepth = length . dt_args++-- | This makes sure we can use the demand type with n arguments after eta+-- expansion, where n must not be lower than the demand types depth.+-- It appends the argument list with the correct 'defaultArgDmd'.+etaExpandDmdType :: Arity -> DmdType -> DmdType+etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div}+  | n == depth = d+  | n >  depth = d{dt_args = inc_ds}+  | otherwise  = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d)+  where depth = length ds+        -- Arity increase:+        --  * Demands on FVs are still valid+        --  * Demands on args also valid, plus we can extend with defaultArgDmd+        --    as appropriate for the given Divergence+        --  * Divergence is still valid:+        --    - A dead end after 2 arguments stays a dead end after 3 arguments+        --    - The remaining case is Dunno, which is already topDiv+        inc_ds = take n (ds ++ repeat (defaultArgDmd div))++-- | A conservative approximation for a given 'DmdType' in case of an arity+-- decrease. Currently, it's just nopDmdType.+decreaseArityDmdType :: DmdType -> DmdType+decreaseArityDmdType _ = nopDmdType++splitDmdTy :: DmdType -> (Demand, DmdType)+-- Split off one function argument+-- We already have a suitable demand on all+-- free vars, so no need to add more!+splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args})+splitDmdTy ty@DmdType{dt_div=div}       = (defaultArgDmd div, ty)++multDmdType :: Card -> DmdType -> DmdType+multDmdType n (DmdType fv args res_ty)+  = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $+    DmdType (multDmdEnv n fv)+            (map (multDmd n) args)+            (multDivergence n res_ty)++peelFV :: DmdType -> Var -> (DmdType, Demand)+peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv)+                               (DmdType fv' ds res, dmd)+  where+  fv' = fv `delVarEnv` id+  -- See Note [Default demand on free variables and arguments]+  dmd  = lookupVarEnv fv id `orElse` defaultFvDmd res++addDemand :: Demand -> DmdType -> DmdType+addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res++findIdDemand :: DmdType -> Var -> Demand+findIdDemand (DmdType fv _ res) id+  = lookupVarEnv fv id `orElse` defaultFvDmd res++-- | When e is evaluated after executing an IO action that may throw a precise+-- exception, we act as if there is an additional control flow path that is+-- taken if e throws a precise exception. The demand type of this control flow+-- path+--   * is lazy and absent ('topDmd') in all free variables and arguments+--   * has 'exnDiv' 'Divergence' result+-- So we can simply take a variant of 'nopDmdType', 'exnDmdType'.+-- Why not 'nopDmdType'? Because then the result of 'e' can never be 'exnDiv'!+-- That means failure to drop dead-ends, see #18086.+-- See Note [Precise exceptions and strictness analysis]+deferAfterPreciseException :: DmdType -> DmdType+deferAfterPreciseException = lubDmdType exnDmdType++-- | See 'keepAliveDmdEnv'.+keepAliveDmdType :: DmdType -> VarSet -> DmdType+keepAliveDmdType (DmdType fvs ds res) vars =+  DmdType (fvs `keepAliveDmdEnv` vars) ds res++{-+Note [Demand type Divergence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In contrast to StrictSigs, DmdTypes are elicited under a specific incoming demand.+This is described in detail in Note [Understanding DmdType and StrictSig].+Here, we'll focus on what that means for a DmdType's Divergence in a higher-order+scenario.++Consider+  err x y = x `seq` y `seq` error (show x)+this has a strictness signature of+  <1L><1L>b+meaning that we don't know what happens when we call err in weaker contexts than+C1(C1(L)), like @err `seq` ()@ (1A) and @err 1 `seq` ()@ (CS(A)). We+may not unleash the botDiv, hence assume topDiv. Of course, in+@err 1 2 `seq` ()@ the incoming demand CS(CS(A)) is strong enough and we see+that the expression diverges.++Now consider a function+  f g = g 1 2+with signature <C1(C1(L))>, and the expression+  f err `seq` ()+now f puts a strictness demand of C1(C1(L)) onto its argument, which is unleashed+on err via the App rule. In contrast to weaker head strictness, this demand is+strong enough to unleash err's signature and hence we see that the whole+expression diverges!++Note [Asymmetry of 'plus*']+~~~~~~~~~~~~~~~~~~~~~~~~~~~+'plus' for DmdTypes is *asymmetrical*, because there can only one+be one type contributing argument demands!  For example, given (e1 e2), we get+a DmdType dt1 for e1, use its arg demand to analyse e2 giving dt2, and then do+(dt1 `plusType` dt2). Similarly with+  case e of { p -> rhs }+we get dt_scrut from the scrutinee and dt_rhs from the RHS, and then+compute (dt_rhs `plusType` dt_scrut).++We+ 1. combine the information on the free variables,+ 2. take the demand on arguments from the first argument+ 3. combine the termination results, as in plusDivergence.++Since we don't use argument demands of the second argument anyway, 'plus's+second argument is just a 'PlusDmdType'.++But note that the argument demand types are not guaranteed to be observed in+left to right order. For example, analysis of a case expression will pass the+demand type for the alts as the left argument and the type for the scrutinee as+the right argument. Also, it is not at all clear if there is such an order;+consider the LetUp case, where the RHS might be forced at any point while+evaluating the let body.+Therefore, it is crucial that 'plusDivergence' is symmetric!++Note [Demands from unsaturated function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a demand transformer d1 -> d2 -> r for f.+If a sufficiently detailed demand is fed into this transformer,+e.g <C1(C1(L))> arising from "f x1 x2" in a strict, use-once context,+then d1 and d2 is precisely the demand unleashed onto x1 and x2 (similar for+the free variable environment) and furthermore the result information r is the+one we want to use.++An anonymous lambda is also an unsaturated function all (needs one argument,+none given), so this applies to that case as well.++But the demand fed into f might be less than C1(C1(L)). Then we have to+'multDmdType' the announced demand type. Examples:+ * Not strict enough, e.g. C1(C1(L)):+   - We have to multiply all argument and free variable demands with C_01,+     zapping strictness.+   - We have to multiply divergence with C_01. If r says that f Diverges for sure,+     then this holds when the demand guarantees that two arguments are going to+     be passed. If the demand is lower, we may just as well converge.+     If we were tracking definite convergence, than that would still hold under+     a weaker demand than expected by the demand transformer.+ * Used more than once, e.g. CS(C1(L)):+   - Multiply with C_1N. Even if f puts a used-once demand on any of its argument+     or free variables, if we call f multiple times, we may evaluate this+     argument or free variable multiple times.++In dmdTransformSig, we call peelManyCalls to find out the 'Card'inality with+which we have to multiply and then call multDmdType with that.++Similarly, dmdTransformDictSelSig and dmdAnal, when analyzing a Lambda, use+peelCallDmd, which peels only one level, but also returns the demand put on the+body of the function.+-}+++{-+************************************************************************+*                                                                      *+                     Demand signatures+*                                                                      *+************************************************************************++In a let-bound Id we record its demand signature.+In principle, this demand signature is a demand transformer, mapping+a demand on the Id into a DmdType, which gives+        a) the free vars of the Id's value+        b) the Id's arguments+        c) an indication of the result of applying+           the Id to its arguments++However, in fact we store in the Id an extremely emascuated demand+transfomer, namely++                a single DmdType+(Nevertheless we dignify StrictSig as a distinct type.)++This DmdType gives the demands unleashed by the Id when it is applied+to as many arguments as are given in by the arg demands in the DmdType.+Also see Note [Demand type Divergence] for the meaning of a Divergence in a+strictness signature.++If an Id is applied to less arguments than its arity, it means that+the demand on the function at a call site is weaker than the vanilla+call demand, used for signature inference. Therefore we place a top+demand on all arguments. Otherwise, the demand is specified by Id's+signature.++For example, the demand transformer described by the demand signature+        StrictSig (DmdType {x -> <1L>} <A><1P(L,L)>)+says that when the function is applied to two arguments, it+unleashes demand 1L on the free var x, A on the first arg,+and 1P(L,L) on the second.++If this same function is applied to one arg, all we can say is that it+uses x with 1L, and its arg with demand 1P(L,L).++Note [Understanding DmdType and StrictSig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand types are sound approximations of an expression's semantics relative to+the incoming demand we put the expression under. Consider the following+expression:++    \x y -> x `seq` (y, 2*x)++Here is a table with demand types resulting from different incoming demands we+put that expression under. Note the monotonicity; a stronger incoming demand+yields a more precise demand type:++    incoming demand   |  demand type+    --------------------------------+    1A                  |  <L><L>{}+    C1(C1(L))           |  <1P(L)><L>{}+    C1(C1(1P(1P(L),A))) |  <1P(A)><A>{}++Note that in the first example, the depth of the demand type was *higher* than+the arity of the incoming call demand due to the anonymous lambda.+The converse is also possible and happens when we unleash demand signatures.+In @f x y@, the incoming call demand on f has arity 2. But if all we have is a+demand signature with depth 1 for @f@ (which we can safely unleash, see below),+the demand type of @f@ under a call demand of arity 2 has a *lower* depth of 1.++So: Demand types are elicited by putting an expression under an incoming (call)+demand, the arity of which can be lower or higher than the depth of the+resulting demand type.+In contrast, a demand signature summarises a function's semantics *without*+immediately specifying the incoming demand it was produced under. Despite StrSig+being a newtype wrapper around DmdType, it actually encodes two things:++  * The threshold (i.e., minimum arity) to unleash the signature+  * A demand type that is sound to unleash when the minimum arity requirement is+    met.++Here comes the subtle part: The threshold is encoded in the wrapped demand+type's depth! So in mkStrictSigForArity we make sure to trim the list of+argument demands to the given threshold arity. Call sites will make sure that+this corresponds to the arity of the call demand that elicited the wrapped+demand type. See also Note [What are demand signatures?].+-}++-- | The depth of the wrapped 'DmdType' encodes the arity at which it is safe+-- to unleash. Better construct this through 'mkStrictSigForArity'.+-- See Note [Understanding DmdType and StrictSig]+newtype StrictSig+  = StrictSig DmdType+  deriving Eq++-- | Turns a 'DmdType' computed for the particular 'Arity' into a 'StrictSig'+-- unleashable at that arity. See Note [Understanding DmdType and StrictSig]+mkStrictSigForArity :: Arity -> DmdType -> StrictSig+mkStrictSigForArity arity dmd_ty@(DmdType fvs args div)+  | arity < dmdTypeDepth dmd_ty = StrictSig (DmdType fvs (take arity args) div)+  | otherwise                   = StrictSig (etaExpandDmdType arity dmd_ty)++mkClosedStrictSig :: [Demand] -> Divergence -> StrictSig+mkClosedStrictSig ds res = mkStrictSigForArity (length ds) (DmdType emptyDmdEnv ds res)++splitStrictSig :: StrictSig -> ([Demand], Divergence)+splitStrictSig (StrictSig (DmdType _ dmds res)) = (dmds, res)++strictSigDmdEnv :: StrictSig -> DmdEnv+strictSigDmdEnv (StrictSig (DmdType env _ _)) = env++hasDemandEnvSig :: StrictSig -> Bool+hasDemandEnvSig = not . isEmptyVarEnv . strictSigDmdEnv++botSig :: StrictSig+botSig = StrictSig botDmdType++nopSig :: StrictSig+nopSig = StrictSig nopDmdType++isTopSig :: StrictSig -> Bool+isTopSig (StrictSig ty) = isTopDmdType ty++-- | True if the signature diverges or throws an exception in a saturated call.+-- See Note [Dead ends].+isDeadEndSig :: StrictSig -> Bool+isDeadEndSig (StrictSig (DmdType _ _ res)) = isDeadEndDiv res++-- | Returns true if an application to n args would diverge or throw an+-- exception.+--+-- If a function having 'botDiv' is applied to a less number of arguments than+-- its syntactic arity, we cannot say for sure that it is going to diverge.+-- Hence this function conservatively returns False in that case.+-- See Note [Dead ends].+appIsDeadEnd :: StrictSig -> Int -> Bool+appIsDeadEnd (StrictSig (DmdType _ ds res)) n+  = isDeadEndDiv res && not (lengthExceeds ds n)++prependArgsStrictSig :: Int -> StrictSig -> StrictSig+-- ^ Add extra ('topDmd') arguments to a strictness signature.+-- In contrast to 'etaConvertStrictSig', this /prepends/ additional argument+-- demands. This is used by FloatOut.+prependArgsStrictSig new_args sig@(StrictSig dmd_ty@(DmdType env dmds res))+  | new_args == 0       = sig+  | isTopDmdType dmd_ty = sig+  | new_args < 0        = pprPanic "prependArgsStrictSig: negative new_args"+                                   (ppr new_args $$ ppr sig)+  | otherwise           = StrictSig (DmdType env dmds' res)+  where+    dmds' = replicate new_args topDmd ++ dmds++etaConvertStrictSig :: Arity -> StrictSig -> StrictSig+-- ^ We are expanding (\x y. e) to (\x y z. e z) or reducing from the latter to+-- the former (when the Simplifier identifies a new join points, for example).+-- In contrast to 'prependArgsStrictSig', this /appends/ extra arg demands if+-- necessary.+-- This works by looking at the 'DmdType' (which was produced under a call+-- demand for the old arity) and trying to transfer as many facts as we can to+-- the call demand of new arity.+-- An arity increase (resulting in a stronger incoming demand) can retain much+-- of the info, while an arity decrease (a weakening of the incoming demand)+-- must fall back to a conservative default.+etaConvertStrictSig arity (StrictSig dmd_ty)+  | arity < dmdTypeDepth dmd_ty = StrictSig $ decreaseArityDmdType dmd_ty+  | otherwise                   = StrictSig $ etaExpandDmdType arity dmd_ty++{-+************************************************************************+*                                                                      *+                     Demand transformers+*                                                                      *+************************************************************************+-}++-- | A /demand transformer/ is a monotone function from an incoming evaluation+-- context ('SubDemand') to a 'DmdType', describing how the denoted thing+-- (i.e. expression, function) uses its arguments and free variables, and+-- whether it diverges.+--+-- See Note [Understanding DmdType and StrictSig]+-- and Note [What are demand signatures?].+type DmdTransformer = SubDemand -> DmdType++-- | Extrapolate a demand signature ('StrictSig') into a 'DmdTransformer'.+--+-- Given a function's 'StrictSig' and a 'SubDemand' for the evaluation context,+-- return how the function evaluates its free variables and arguments.+dmdTransformSig :: StrictSig -> DmdTransformer+dmdTransformSig (StrictSig dmd_ty@(DmdType _ arg_ds _)) sd+  = multDmdType (peelManyCalls (length arg_ds) sd) dmd_ty+    -- see Note [Demands from unsaturated function calls]+    -- and Note [What are demand signatures?]++-- | A special 'DmdTransformer' for data constructors that feeds product+-- demands into the constructor arguments.+dmdTransformDataConSig :: Arity -> DmdTransformer+dmdTransformDataConSig arity sd = case go arity sd of+  Just dmds -> DmdType emptyDmdEnv dmds topDiv+  Nothing   -> nopDmdType -- Not saturated+  where+    go 0 sd                            = viewProd arity sd+    go n (viewCall -> Just (C_11, sd)) = go (n-1) sd  -- strict calls only!+    go _ _                             = Nothing++-- | A special 'DmdTransformer' for dictionary selectors that feeds the demand+-- on the result into the indicated dictionary component (if saturated).+dmdTransformDictSelSig :: StrictSig -> DmdTransformer+-- NB: This currently doesn't handle newtype dictionaries and it's unclear how+-- it could without additional parameters.+dmdTransformDictSelSig (StrictSig (DmdType _ [(_ :* sig_sd)] _)) call_sd+   | (n, sd') <- peelCallDmd call_sd+   , Prod sig_ds  <- sig_sd+   = multDmdType n $+     DmdType emptyDmdEnv [C_11 :* Prod (map (enhance sd') sig_ds)] topDiv+   | otherwise+   = nopDmdType -- See Note [Demand transformer for a dictionary selector]+  where+    enhance sd old | isAbsDmd old = old+                   | otherwise    = C_11 :* sd  -- This is the one!++dmdTransformDictSelSig sig sd = pprPanic "dmdTransformDictSelSig: no args" (ppr sig $$ ppr sd)++{-+Note [What are demand signatures?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand analysis interprets expressions in the abstract domain of demand+transformers. Given a (sub-)demand that denotes the evaluation context, the+abstract transformer of an expression gives us back a demand type denoting+how other things (like arguments and free vars) were used when the expression+was evaluated. Here's an example:++  f x y =+    if x + expensive+      then \z -> z + y * ...+      else \z -> z * ...++The abstract transformer (let's call it F_e) of the if expression (let's+call it e) would transform an incoming (undersaturated!) head demand 1A into+a demand type like {x-><1L>,y-><L>}<L>. In pictures:++     Demand ---F_e---> DmdType+     <1A>              {x-><1L>,y-><L>}<L>++Let's assume that the demand transformers we compute for an expression are+correct wrt. to some concrete semantics for Core. How do demand signatures fit+in? They are strange beasts, given that they come with strict rules when to+it's sound to unleash them.++Fortunately, we can formalise the rules with Galois connections. Consider+f's strictness signature, {}<1L><L>. It's a single-point approximation of+the actual abstract transformer of f's RHS for arity 2. So, what happens is that+we abstract *once more* from the abstract domain we already are in, replacing+the incoming Demand by a simple lattice with two elements denoting incoming+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom+element). Here's the diagram:++     A_2 -----f_f----> DmdType+      ^                   |+      | α               γ |+      |                   v+  SubDemand --F_f----> DmdType++With+  α(C1(C1(_))) = >=2+  α(_)         =  <2+  γ(ty)        =  ty+and F_f being the abstract transformer of f's RHS and f_f being the abstracted+abstract transformer computable from our demand signature simply by++  f_f(>=2) = {}<1L><L>+  f_f(<2)  = multDmdType C_0N {}<1L><L>++where multDmdType makes a proper top element out of the given demand type.++In practice, the A_n domain is not just a simple Bool, but a Card, which is+exactly the Card with which we have to multDmdType. The Card for arity n+is computed by calling @peelManyCalls n@, which corresponds to α above.++Note [Demand transformer for a dictionary selector]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we evaluate (op dict-expr) under demand 'd', then we can push the demand 'd'+into the appropriate field of the dictionary. What *is* the appropriate field?+We just look at the strictness signature of the class op, which will be+something like: P(AAA1AAAAA).  Then replace the '1' by the demand 'd'.++For single-method classes, which are represented by newtypes the signature+of 'op' won't look like P(...), so matching on Prod will fail.+That's fine: if we are doing strictness analysis we are also doing inlining,+so we'll have inlined 'op' into a cast.  So we can bale out in a conservative+way, returning nopDmdType.++It is (just.. #8329) possible to be running strictness analysis *without*+having inlined class ops from single-method classes.  Suppose you are using+ghc --make; and the first module has a local -O0 flag.  So you may load a class+without interface pragmas, ie (currently) without an unfolding for the class+ops.   Now if a subsequent module in the --make sweep has a local -O flag+you might do strictness analysis, but there is no inlining for the class op.+This is weird, so I'm not worried about whether this optimises brilliantly; but+it should not fall over.+-}++-- | Remove the demand environment from the signature.+zapDmdEnvSig :: StrictSig -> StrictSig+zapDmdEnvSig (StrictSig (DmdType _ ds r)) = mkClosedStrictSig ds r++zapUsageDemand :: Demand -> Demand+-- Remove the usage info, but not the strictness info, from the demand+zapUsageDemand = kill_usage $ KillFlags+    { kf_abs         = True+    , kf_used_once   = True+    , kf_called_once = True+    }++-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the demand+zapUsedOnceDemand :: Demand -> Demand+zapUsedOnceDemand = kill_usage $ KillFlags+    { kf_abs         = False+    , kf_used_once   = True+    , kf_called_once = False+    }++-- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness+--   signature+zapUsedOnceSig :: StrictSig -> StrictSig+zapUsedOnceSig (StrictSig (DmdType env ds r))+    = StrictSig (DmdType env (map zapUsedOnceDemand ds) r)++data KillFlags = KillFlags+    { kf_abs         :: Bool+    , kf_used_once   :: Bool+    , kf_called_once :: Bool+    }++kill_usage_card :: KillFlags -> Card -> Card+kill_usage_card kfs C_00 | kf_abs kfs       = C_0N+kill_usage_card kfs C_10 | kf_abs kfs       = C_1N+kill_usage_card kfs C_01 | kf_used_once kfs = C_0N+kill_usage_card kfs C_11 | kf_used_once kfs = C_1N+kill_usage_card _   n                       = n++kill_usage :: KillFlags -> Demand -> Demand+kill_usage kfs (n :* sd) = kill_usage_card kfs n :* kill_usage_sd kfs sd++kill_usage_sd :: KillFlags -> SubDemand -> SubDemand+kill_usage_sd kfs (Call n sd)+  | kf_called_once kfs      = mkCall (lubCard C_1N n) (kill_usage_sd kfs sd)+  | otherwise               = mkCall n                (kill_usage_sd kfs sd)+kill_usage_sd kfs (Prod ds) = Prod (map (kill_usage kfs) ds)+kill_usage_sd _   sd        = sd++{- *********************************************************************+*                                                                      *+               TypeShape and demand trimming+*                                                                      *+********************************************************************* -}+++data TypeShape -- See Note [Trimming a demand to a type]+               --     in GHC.Core.Opt.DmdAnal+  = TsFun TypeShape+  | TsProd [TypeShape]+  | TsUnk++trimToType :: Demand -> TypeShape -> Demand+-- See Note [Trimming a demand to a type] in GHC.Core.Opt.DmdAnal+trimToType (n :* sd) ts+  = n :* go sd ts+  where+    go (Prod ds)   (TsProd tss)+      | equalLength ds tss    = Prod (zipWith trimToType ds tss)+    go (Call n sd) (TsFun ts) = mkCall n (go sd ts)+    go sd@Poly{}   _          = sd+    go _           _          = topSubDmd++{-+************************************************************************+*                                                                      *+                     'seq'ing demands+*                                                                      *+************************************************************************+-}++seqDemand :: Demand -> ()+seqDemand (_ :* sd) = seqSubDemand sd++seqSubDemand :: SubDemand -> ()+seqSubDemand (Prod ds)   = seqDemandList ds+seqSubDemand (Call _ sd) = seqSubDemand sd+seqSubDemand (Poly _)    = ()++seqDemandList :: [Demand] -> ()+seqDemandList = foldr (seq . seqDemand) ()++seqDmdType :: DmdType -> ()+seqDmdType (DmdType env ds res) =+  seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` ()++seqDmdEnv :: DmdEnv -> ()+seqDmdEnv env = seqEltsUFM seqDemandList env++seqStrictSig :: StrictSig -> ()+seqStrictSig (StrictSig ty) = seqDmdType ty++{-+************************************************************************+*                                                                      *+                     Outputable and Binary instances+*                                                                      *+************************************************************************+-}++{- Note [Demand notation]+~~~~~~~~~~~~~~~~~~~~~~~~~+This Note should be kept up to date with the documentation of `-fstrictness`+in the user's guide.++For pretty-printing demands, we use quite a compact notation with some+abbreviations. Here's the BNF:++  card ::= B    {}+        |  A    {0}+        |  M    {0,1}+        |  L    {0,1,n}+        |  1    {1}+        |  S    {1,n}++  d    ::= card sd                  The :* constructor, just juxtaposition+        |  card                     abbreviation: Same as "card card",+                                                  in code @polyDmd card@++  sd   ::= card                     @Poly card@+        |  P(d,d,..)                @Prod [d1,d2,..]@+        |  Ccard(sd)                @Call card sd@++So, L can denote a 'Card', polymorphic 'SubDemand' or polymorphic 'Demand',+but it's always clear from context which "overload" is meant. It's like+return-type inference of e.g. 'read'.++Examples are in the haddock for 'Demand'.++This is the syntax for demand signatures:++  div ::= <empty>      topDiv+       |  x            exnDiv+       |  b            botDiv++  sig ::= {x->dx,y->dy,z->dz...}<d1><d2><d3>...<dn>div+                  ^              ^   ^   ^      ^   ^+                  |              |   |   |      |   |+                  |              \---+---+------/   |+                  |                  |              |+             demand on free        demand on      divergence+               variables           arguments      information+           (omitted if empty)                     (omitted if+                                                no information)+++-}++-- | See Note [Demand notation]+-- Current syntax was discussed in #19016.+instance Outputable Card where+  ppr C_00 = char 'A' -- "Absent"+  ppr C_01 = char 'M' -- "Maybe"+  ppr C_0N = char 'L' -- "Lazy"+  ppr C_11 = char '1' -- "exactly 1"+  ppr C_1N = char 'S' -- "Strict"+  ppr C_10 = char 'B' -- "Bottom"++-- | See Note [Demand notation]+instance Outputable Demand where+  ppr dmd@(n :* sd)+    | isAbs n          = ppr n   -- If absent, sd is arbitrary+    | dmd == polyDmd n = ppr n   -- Print UU as just U+    | otherwise        = ppr n <> ppr sd++-- | See Note [Demand notation]+instance Outputable SubDemand where+  ppr (Poly sd)   = ppr sd+  ppr (Call n sd) = char 'C' <> ppr n <> parens (ppr sd)+  ppr (Prod ds)   = char 'P' <> parens (fields ds)+    where+      fields []     = empty+      fields [x]    = ppr x+      fields (x:xs) = ppr x <> char ',' <> fields xs++instance Outputable Divergence where+  ppr Diverges = char 'b' -- for (b)ottom+  ppr ExnOrDiv = char 'x' -- for e(x)ception+  ppr Dunno    = empty++instance Outputable DmdType where+  ppr (DmdType fv ds res)+    = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res,+            if null fv_elts then empty+            else braces (fsep (map pp_elt fv_elts))]+    where+      pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd+      fv_elts = nonDetUFMToList fv+        -- It's OK to use nonDetUFMToList here because we only do it for+        -- pretty printing++instance Outputable StrictSig where+   ppr (StrictSig ty) = ppr ty++instance Outputable TypeShape where+  ppr TsUnk        = text "TsUnk"+  ppr (TsFun ts)   = text "TsFun" <> parens (ppr ts)+  ppr (TsProd tss) = parens (hsep $ punctuate comma $ map ppr tss)++instance Binary Card where+  put_ bh C_00 = putByte bh 0+  put_ bh C_01 = putByte bh 1+  put_ bh C_0N = putByte bh 2+  put_ bh C_11 = putByte bh 3+  put_ bh C_1N = putByte bh 4+  put_ bh C_10 = putByte bh 5+  get bh = do+    h <- getByte bh+    case h of+      0 -> return C_00+      1 -> return C_01+      2 -> return C_0N+      3 -> return C_11+      4 -> return C_1N+      5 -> return C_10+      _ -> pprPanic "Binary:Card" (ppr (fromIntegral h :: Int))++instance Binary Demand where+  put_ bh (n :* sd) = put_ bh n *> put_ bh sd+  get bh = (:*) <$> get bh <*> get bh++instance Binary SubDemand where+  put_ bh (Poly sd)   = putByte bh 0 *> put_ bh sd+  put_ bh (Call n sd) = putByte bh 1 *> put_ bh n *> put_ bh sd+  put_ bh (Prod ds)   = putByte bh 2 *> put_ bh ds+  get bh = do+    h <- getByte bh+    case h of+      0 -> Poly <$> get bh+      1 -> mkCall <$> get bh <*> get bh+      2 -> Prod <$> get bh+      _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int))++instance Binary StrictSig where+  put_ bh (StrictSig aa) = put_ bh aa+  get bh = StrictSig <$> get bh++instance Binary DmdType where+  -- Ignore DmdEnv when spitting out the DmdType+  put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr+  get bh = DmdType emptyDmdEnv <$> get bh <*> get bh++instance Binary Divergence where+  put_ bh Dunno    = putByte bh 0+  put_ bh ExnOrDiv = putByte bh 1+  put_ bh Diverges = putByte bh 2+  get bh = do+    h <- getByte bh+    case h of+      0 -> return Dunno+      1 -> return ExnOrDiv+      2 -> return Diverges+      _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int))

+ GHC/Types/Error.hs view

@@ -0,0 +1,387 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Types.Error+   ( -- * Messages+     Messages+   , WarningMessages+   , ErrorMessages+   , mkMessages+   , emptyMessages+   , isEmptyMessages+   , addMessage+   , unionMessages+   , MsgEnvelope (..)+   , WarnMsg+   , SDoc+   , DecoratedSDoc (unDecorated)+   , Severity (..)+   , RenderableDiagnostic (..)+   , pprMessageBag+   , mkDecorated+   , mkLocMessage+   , mkLocMessageAnn+   , getSeverityColour+   , getCaretDiagnostic+   , makeIntoWarning+   -- * Constructing individual errors+   , mkMsgEnvelope+   , mkPlainMsgEnvelope+   , mkErr+   , mkLongMsgEnvelope+   , mkWarnMsg+   , mkPlainWarnMsg+   , mkLongWarnMsg+   -- * Queries+   , isErrorMessage+   , isWarningMessage+   , getErrorMessages+   , getWarningMessages+   , partitionMessages+   , errorsFound+   )+where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Data.Bag+import GHC.Utils.Outputable as Outputable+import qualified GHC.Utils.Ppr.Colour as Col+import GHC.Types.SrcLoc as SrcLoc+import GHC.Data.FastString (unpackFS)+import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)+import GHC.Utils.Json++import System.IO.Error  ( catchIOError )++{-+Note [Messages]+~~~~~~~~~~~~~~~++We represent the 'Messages' as a single bag of warnings and errors.++The reason behind that is that there is a fluid relationship between errors and warnings and we want to+be able to promote or demote errors and warnings based on certain flags (e.g. -Werror, -fdefer-type-errors+or -XPartialTypeSignatures). For now we rely on the 'Severity' to distinguish between a warning and an+error, although the 'Severity' can be /more/ than just 'SevWarn' and 'SevError', and as such it probably+shouldn't belong to an 'MsgEnvelope' to begin with, as it might potentially lead to the construction of+"impossible states" (e.g. a waning with 'SevInfo', for example).++'WarningMessages' and 'ErrorMessages' are for now simple type aliases to retain backward compatibility, but+in future iterations these can be either parameterised over an 'e' message type (to make type signatures+a bit more declarative) or removed altogether.+-}++-- | A collection of messages emitted by GHC during error reporting. A diagnostic message is typically+-- a warning or an error. See Note [Messages].+newtype Messages e = Messages (Bag (MsgEnvelope e))++instance Functor Messages where+  fmap f (Messages xs) = Messages (mapBag (fmap f) xs)++emptyMessages :: Messages e+emptyMessages = Messages emptyBag++mkMessages :: Bag (MsgEnvelope e) -> Messages e+mkMessages = Messages++isEmptyMessages :: Messages e -> Bool+isEmptyMessages (Messages msgs) = isEmptyBag msgs++addMessage :: MsgEnvelope e -> Messages e -> Messages e+addMessage x (Messages xs) = Messages (x `consBag` xs)++-- | Joins two collections of messages together.+unionMessages :: Messages e -> Messages e -> Messages e+unionMessages (Messages msgs1) (Messages msgs2) = Messages (msgs1 `unionBags` msgs2)++type WarningMessages = Bag (MsgEnvelope DecoratedSDoc)+type ErrorMessages   = Bag (MsgEnvelope DecoratedSDoc)++type WarnMsg         = MsgEnvelope DecoratedSDoc++-- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the invariant that the input '[SDoc]'+-- needs to be rendered /decorated/ into its final form, where the typical case would be adding bullets+-- between each elements of the list.+-- The type of decoration depends on the formatting function used, but in practice GHC uses the+-- 'formatBulleted'.+newtype DecoratedSDoc = Decorated { unDecorated :: [SDoc] }++-- | Creates a new 'DecoratedSDoc' out of a list of 'SDoc'.+mkDecorated :: [SDoc] -> DecoratedSDoc+mkDecorated = Decorated++{-+Note [Rendering Messages]+~~~~~~~~~~~~~~~~~~~~~~~~~++Turning 'Messages' into something that renders nicely for the user is one of the last steps, and it+happens typically at the application boundaries (i.e. from the 'Driver' upwards).++For now (see #18516) this class is very boring as it has only one instance, but the idea is that as+the more domain-specific types are defined, the more instances we would get. For example, given something like:++data TcRnMessage+  = TcRnOutOfScope ..+  | ..++We could then define how a 'TcRnMessage' is displayed to the user. Rather than scattering pieces of+'SDoc' around the codebase, we would write once for all:++instance RenderableDiagnostic TcRnMessage where+  renderDiagnostic = \case+    TcRnOutOfScope .. -> Decorated [text "Out of scope error ..."]+    ...++This way, we can easily write generic rendering functions for errors that all they care about is the+knowledge that a given type 'e' has a 'RenderableDiagnostic' constraint.++-}++-- | A class for types (typically errors and warnings) which can be \"rendered\" into an opaque 'DecoratedSDoc'.+-- For more information, see Note [Rendering Messages].+class RenderableDiagnostic a where+  renderDiagnostic :: a -> DecoratedSDoc++-- | An envelope for GHC's facts about a running program, parameterised over the+-- /domain-specific/ (i.e. parsing, typecheck-renaming, etc) diagnostics.+--+-- To say things differently, GHC emits /diagnostics/ about the running program, each of which is wrapped+-- into a 'MsgEnvelope' that carries specific information like where the error happened, its severity, etc.+-- Finally, multiple 'MsgEnvelope's are aggregated into 'Messages' that are returned to the user.+data MsgEnvelope e = MsgEnvelope+   { errMsgSpan        :: SrcSpan+      -- ^ The SrcSpan is used for sorting errors into line-number order+   , errMsgContext     :: PrintUnqualified+   , errMsgDiagnostic  :: e+   , errMsgSeverity    :: Severity+   , errMsgReason      :: WarnReason+   } deriving Functor++instance RenderableDiagnostic DecoratedSDoc where+  renderDiagnostic = id++data Severity+  = SevOutput+  | SevFatal+  | SevInteractive++  | SevDump+    -- ^ Log message intended for compiler developers+    -- No file\/line\/column stuff++  | SevInfo+    -- ^ Log messages intended for end users.+    -- No file\/line\/column stuff.++  | SevWarning+  | SevError+    -- ^ SevWarning and SevError are used for warnings and errors+    --   o The message has a file\/line\/column heading,+    --     plus "warning:" or "error:",+    --     added by mkLocMessags+    --   o Output is intended for end users+  deriving (Eq, Show)+++instance ToJson Severity where+  json s = JSString (show s)++instance Show (MsgEnvelope DecoratedSDoc) where+    show = showMsgEnvelope++-- | Shows an 'MsgEnvelope'.+showMsgEnvelope :: RenderableDiagnostic a => MsgEnvelope a -> String+showMsgEnvelope err =+  renderWithContext defaultSDocContext (vcat (unDecorated . renderDiagnostic $ errMsgDiagnostic err))++pprMessageBag :: Bag SDoc -> SDoc+pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))++-- | Make an unannotated error message with location info.+mkLocMessage :: Severity -> SrcSpan -> SDoc -> SDoc+mkLocMessage = mkLocMessageAnn Nothing++-- | Make a possibly annotated error message with location info.+mkLocMessageAnn+  :: Maybe String                       -- ^ optional annotation+  -> Severity                           -- ^ severity+  -> SrcSpan                            -- ^ location+  -> SDoc                             -- ^ message+  -> SDoc+  -- Always print the location, even if it is unhelpful.  Error messages+  -- are supposed to be in a standard format, and one without a location+  -- would look strange.  Better to say explicitly "<no location info>".+mkLocMessageAnn ann severity locn msg+    = sdocOption sdocColScheme $ \col_scheme ->+      let locn' = sdocOption sdocErrorSpans $ \case+                     True  -> ppr locn+                     False -> ppr (srcSpanStart locn)++          sevColour = getSeverityColour severity col_scheme++          -- Add optional information+          optAnn = case ann of+            Nothing -> text ""+            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"++          -- Add prefixes, like    Foo.hs:34: warning:+          --                           <the warning message>+          header = locn' <> colon <+>+                   coloured sevColour sevText <> optAnn++      in coloured (Col.sMessage col_scheme)+                  (hang (coloured (Col.sHeader col_scheme) header) 4+                        msg)++  where+    sevText =+      case severity of+        SevWarning -> text "warning:"+        SevError   -> text "error:"+        SevFatal   -> text "fatal:"+        _          -> empty++getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour+getSeverityColour SevWarning = Col.sWarning+getSeverityColour SevError   = Col.sError+getSeverityColour SevFatal   = Col.sFatal+getSeverityColour _          = const mempty++getCaretDiagnostic :: Severity -> SrcSpan -> IO SDoc+getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty+getCaretDiagnostic severity (RealSrcSpan span _) =+  caretDiagnostic <$> getSrcLine (srcSpanFile span) row+  where+    getSrcLine fn i =+      getLine i (unpackFS fn)+        `catchIOError` \_ ->+          pure Nothing++    getLine i fn = do+      -- StringBuffer has advantages over readFile:+      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code+      -- (b) always UTF-8, rather than some system-dependent encoding+      --     (Haskell source code must be UTF-8 anyway)+      content <- hGetStringBuffer fn+      case atLine i content of+        Just at_line -> pure $+          case lines (fix <$> lexemeToString at_line (len at_line)) of+            srcLine : _ -> Just srcLine+            _           -> Nothing+        _ -> pure Nothing++    -- allow user to visibly see that their code is incorrectly encoded+    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)+    fix '\0' = '\xfffd'+    fix c    = c++    row = srcSpanStartLine span+    rowStr = show row+    multiline = row /= srcSpanEndLine span++    caretDiagnostic Nothing = empty+    caretDiagnostic (Just srcLineWithNewline) =+      sdocOption sdocColScheme$ \col_scheme ->+      let sevColour = getSeverityColour severity col_scheme+          marginColour = Col.sMargin col_scheme+      in+      coloured marginColour (text marginSpace) <>+      text ("\n") <>+      coloured marginColour (text marginRow) <>+      text (" " ++ srcLinePre) <>+      coloured sevColour (text srcLineSpan) <>+      text (srcLinePost ++ "\n") <>+      coloured marginColour (text marginSpace) <>+      coloured sevColour (text (" " ++ caretLine))++      where++        -- expand tabs in a device-independent manner #13664+        expandTabs tabWidth i s =+          case s of+            ""        -> ""+            '\t' : cs -> replicate effectiveWidth ' ' +++                         expandTabs tabWidth (i + effectiveWidth) cs+            c    : cs -> c : expandTabs tabWidth (i + 1) cs+          where effectiveWidth = tabWidth - i `mod` tabWidth++        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)++        start = srcSpanStartCol span - 1+        end | multiline = length srcLine+            | otherwise = srcSpanEndCol span - 1+        width = max 1 (end - start)++        marginWidth = length rowStr+        marginSpace = replicate marginWidth ' ' ++ " |"+        marginRow   = rowStr ++ " |"++        (srcLinePre,  srcLineRest) = splitAt start srcLine+        (srcLineSpan, srcLinePost) = splitAt width srcLineRest++        caretEllipsis | multiline = "..."+                      | otherwise = ""+        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis++makeIntoWarning :: WarnReason -> MsgEnvelope e -> MsgEnvelope e+makeIntoWarning reason err = err+    { errMsgSeverity = SevWarning+    , errMsgReason = reason }++--+-- Creating MsgEnvelope(s)+--++mk_err_msg+  :: Severity -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e+mk_err_msg sev locn print_unqual err+ = MsgEnvelope { errMsgSpan = locn+               , errMsgContext = print_unqual+               , errMsgDiagnostic = err+               , errMsgSeverity = sev+               , errMsgReason = NoReason }++mkErr :: SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e+mkErr = mk_err_msg SevError++mkLongMsgEnvelope, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> SDoc -> SDoc -> MsgEnvelope DecoratedSDoc+-- ^ A long (multi-line) error message+mkMsgEnvelope, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> SDoc         -> MsgEnvelope DecoratedSDoc+-- ^ A short (one-line) error message+mkPlainMsgEnvelope, mkPlainWarnMsg :: SrcSpan ->                     SDoc         -> MsgEnvelope DecoratedSDoc+-- ^ Variant that doesn't care about qualified/unqualified names++mkLongMsgEnvelope   locn unqual msg extra = mk_err_msg SevError   locn unqual        (mkDecorated [msg,extra])+mkMsgEnvelope       locn unqual msg       = mk_err_msg SevError   locn unqual        (mkDecorated [msg])+mkPlainMsgEnvelope  locn        msg       = mk_err_msg SevError   locn alwaysQualify (mkDecorated [msg])+mkLongWarnMsg       locn unqual msg extra = mk_err_msg SevWarning locn unqual        (mkDecorated [msg,extra])+mkWarnMsg           locn unqual msg       = mk_err_msg SevWarning locn unqual        (mkDecorated [msg])+mkPlainWarnMsg      locn        msg       = mk_err_msg SevWarning locn alwaysQualify (mkDecorated [msg])++--+-- Queries+--++isErrorMessage :: MsgEnvelope e -> Bool+isErrorMessage = (== SevError) . errMsgSeverity++isWarningMessage :: MsgEnvelope e -> Bool+isWarningMessage = not . isErrorMessage++errorsFound :: Messages e -> Bool+errorsFound (Messages msgs) = any isErrorMessage msgs++getWarningMessages :: Messages e -> Bag (MsgEnvelope e)+getWarningMessages (Messages xs) = fst $ partitionBag isWarningMessage xs++getErrorMessages :: Messages e -> Bag (MsgEnvelope e)+getErrorMessages (Messages xs) = fst $ partitionBag isErrorMessage xs++-- | Partitions the 'Messages' and returns a tuple which first element are the warnings, and the+-- second the errors.+partitionMessages :: Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))+partitionMessages (Messages xs) = partitionBag isWarningMessage xs

GHC/Types/FieldLabel.hs view

@@ -1,30 +1,44 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE UndecidableInstances #-}+ {- % % (c) Adam Gundry 2013-2015 % +Note [FieldLabel]+~~~~~~~~~~~~~~~~~+ This module defines the representation of FieldLabels as stored in TyCons.  As well as a selector name, these have some extra structure-to support the DuplicateRecordFields extension.+to support the DuplicateRecordFields and NoFieldSelectors extensions. -In the normal case (with NoDuplicateRecordFields), a datatype like+In the normal case (with NoDuplicateRecordFields and FieldSelectors),+a datatype like      data T = MkT { foo :: Int }  has -    FieldLabel { flLabel        = "foo"-               , flIsOverloaded = False-               , flSelector     = foo }.+    FieldLabel { flLabel                    = "foo"+               , flHasDuplicateRecordFields = NoDuplicateRecordFields+               , flHasFieldSelector         = FieldSelectors+               , flSelector                 = foo }.  In particular, the Name of the selector has the same string representation as the label.  If DuplicateRecordFields is enabled, however, the same declaration instead gives -    FieldLabel { flLabel        = "foo"-               , flIsOverloaded = True-               , flSelector     = $sel:foo:MkT }.+    FieldLabel { flLabel                    = "foo"+               , flHasDuplicateRecordFields = DuplicateRecordFields+               , flHasFieldSelector         = FieldSelectors+               , flSelector                 = $sel:foo:MkT }. +Similarly, the selector name will be mangled if NoFieldSelectors is used+(whether or not DuplicateRecordFields is enabled).  See Note [NoFieldSelectors]+in GHC.Rename.Env.+ Now the name of the selector ($sel:foo:MkT) does not match the label of the field (foo).  We must be careful not to show the selector name to the user!  The point of mangling the selector name is to allow a@@ -56,31 +70,29 @@  -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE StandaloneDeriving #-}- module GHC.Types.FieldLabel    ( FieldLabelString    , FieldLabelEnv-   , FieldLbl(..)-   , FieldLabel-   , mkFieldLabelOccs+   , FieldLabel(..)+   , fieldSelectorOccName+   , fieldLabelPrintableName+   , DuplicateRecordFields(..)+   , FieldSelectors(..)+   , flIsOverloaded    ) where  import GHC.Prelude -import GHC.Types.Name.Occurrence-import GHC.Types.Name+import {-# SOURCE #-} GHC.Types.Name.Occurrence+import {-# SOURCE #-} GHC.Types.Name  import GHC.Data.FastString import GHC.Data.FastString.Env import GHC.Utils.Outputable import GHC.Utils.Binary +import Data.Bool import Data.Data  -- | Field labels are just represented as strings;@@ -90,43 +102,104 @@ -- | A map from labels to all the auxiliary information type FieldLabelEnv = DFastStringEnv FieldLabel +-- | Fields in an algebraic record type; see Note [FieldLabel].+data FieldLabel = FieldLabel {+      flLabel :: FieldLabelString,+      -- ^ User-visible label of the field+      flHasDuplicateRecordFields :: DuplicateRecordFields,+      -- ^ Was @DuplicateRecordFields@ on in the defining module for this datatype?+      flHasFieldSelector :: FieldSelectors,+      -- ^ Was @FieldSelectors@ enabled in the defining module for this datatype?+      -- See Note [NoFieldSelectors] in GHC.Rename.Env+      flSelector :: Name+      -- ^ Record selector function+    }+  deriving (Data, Eq) -type FieldLabel = FieldLbl Name+instance HasOccName FieldLabel where+  occName = mkVarOccFS . flLabel --- | Fields in an algebraic record type-data FieldLbl a = FieldLabel {-      flLabel        :: FieldLabelString, -- ^ User-visible label of the field-      flIsOverloaded :: Bool,             -- ^ Was DuplicateRecordFields on-                                          --   in the defining module for this datatype?-      flSelector     :: a                 -- ^ Record selector function-    }-  deriving (Eq, Functor, Foldable, Traversable)-deriving instance Data a => Data (FieldLbl a)+instance Outputable FieldLabel where+    ppr fl = ppr (flLabel fl) <> whenPprDebug (braces (ppr (flSelector fl))+                                                <> ppr (flHasDuplicateRecordFields fl)+                                                <> ppr (flHasFieldSelector fl)) -instance Outputable a => Outputable (FieldLbl a) where-    ppr fl = ppr (flLabel fl) <> braces (ppr (flSelector fl))+-- | Flag to indicate whether the DuplicateRecordFields extension is enabled.+data DuplicateRecordFields+    = DuplicateRecordFields   -- ^ Fields may be duplicated in a single module+    | NoDuplicateRecordFields -- ^ Fields must be unique within a module (the default)+  deriving (Show, Eq, Typeable, Data) -instance Binary a => Binary (FieldLbl a) where-    put_ bh (FieldLabel aa ab ac) = do+instance Binary DuplicateRecordFields where+    put_ bh f = put_ bh (f == DuplicateRecordFields)+    get bh = bool NoDuplicateRecordFields DuplicateRecordFields <$> get bh++instance Outputable DuplicateRecordFields where+    ppr DuplicateRecordFields   = text "+dup"+    ppr NoDuplicateRecordFields = text "-dup"+++-- | Flag to indicate whether the FieldSelectors extension is enabled.+data FieldSelectors+    = FieldSelectors   -- ^ Selector functions are available (the default)+    | NoFieldSelectors -- ^ Selector functions are not available+  deriving (Show, Eq, Typeable, Data)++instance Binary FieldSelectors where+    put_ bh f = put_ bh (f == FieldSelectors)+    get bh = bool NoFieldSelectors FieldSelectors <$> get bh++instance Outputable FieldSelectors where+    ppr FieldSelectors   = text "+sel"+    ppr NoFieldSelectors = text "-sel"+++-- | We need the @Binary Name@ constraint here even though there is an instance+-- defined in "GHC.Types.Name", because the we have a SOURCE import, so the+-- instance is not in scope.  And the instance cannot be added to Name.hs-boot+-- because "GHC.Utils.Binary" itself depends on "GHC.Types.Name".+instance Binary Name => Binary FieldLabel where+    put_ bh (FieldLabel aa ab ac ad) = do         put_ bh aa         put_ bh ab         put_ bh ac+        put_ bh ad     get bh = do+        aa <- get bh         ab <- get bh         ac <- get bh         ad <- get bh-        return (FieldLabel ab ac ad)+        return (FieldLabel aa ab ac ad)   -- | Record selector OccNames are built from the underlying field name -- and the name of the first data constructor of the type, to support -- duplicate record field names. -- See Note [Why selector names include data constructors].-mkFieldLabelOccs :: FieldLabelString -> OccName -> Bool -> FieldLbl OccName-mkFieldLabelOccs lbl dc is_overloaded-  = FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded-               , flSelector = sel_occ }+fieldSelectorOccName :: FieldLabelString -> OccName -> DuplicateRecordFields -> FieldSelectors -> OccName+fieldSelectorOccName lbl dc dup_fields_ok has_sel+  | shouldMangleSelectorNames dup_fields_ok has_sel = mkRecFldSelOcc str+  | otherwise     = mkVarOccFS lbl   where     str     = ":" ++ unpackFS lbl ++ ":" ++ occNameString dc-    sel_occ | is_overloaded = mkRecFldSelOcc str-            | otherwise     = mkVarOccFS lbl++-- | Undo the name mangling described in Note [FieldLabel] to produce a Name+-- that has the user-visible OccName (but the selector's unique).  This should+-- be used only when generating output, when we want to show the label, but may+-- need to qualify it with a module prefix.+fieldLabelPrintableName :: FieldLabel -> Name+fieldLabelPrintableName fl+  | flIsOverloaded fl = tidyNameOcc (flSelector fl) (mkVarOccFS (flLabel fl))+  | otherwise         = flSelector fl++-- | Selector name mangling should be used if either DuplicateRecordFields or+-- NoFieldSelectors is enabled, so that the OccName of the field can be used for+-- something else.  See Note [FieldLabel], and Note [NoFieldSelectors] in+-- GHC.Rename.Env.+shouldMangleSelectorNames :: DuplicateRecordFields -> FieldSelectors -> Bool+shouldMangleSelectorNames dup_fields_ok has_sel+    = dup_fields_ok == DuplicateRecordFields || has_sel == NoFieldSelectors++flIsOverloaded :: FieldLabel -> Bool+flIsOverloaded fl =+    shouldMangleSelectorNames (flHasDuplicateRecordFields fl) (flHasFieldSelector fl)

+ GHC/Types/Fixity.hs view

@@ -0,0 +1,119 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Fixity+module GHC.Types.Fixity+   ( Fixity (..)+   , FixityDirection (..)+   , LexicalFixity (..)+   , maxPrecedence+   , minPrecedence+   , defaultFixity+   , negateFixity+   , funTyFixity+   , compareFixity+   )+where++import GHC.Prelude++import GHC.Types.SourceText++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data hiding (Fixity, Prefix, Infix)++data Fixity = Fixity SourceText Int FixityDirection+  -- Note [Pragma source text]+  deriving Data++instance Outputable Fixity where+    ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]++instance Eq Fixity where -- Used to determine if two fixities conflict+  (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2++instance Binary Fixity where+    put_ bh (Fixity src aa ab) = do+            put_ bh src+            put_ bh aa+            put_ bh ab+    get bh = do+          src <- get bh+          aa <- get bh+          ab <- get bh+          return (Fixity src aa ab)++------------------------+data FixityDirection+   = InfixL+   | InfixR+   | InfixN+   deriving (Eq, Data)++instance Outputable FixityDirection where+    ppr InfixL = text "infixl"+    ppr InfixR = text "infixr"+    ppr InfixN = text "infix"++instance Binary FixityDirection where+    put_ bh InfixL =+            putByte bh 0+    put_ bh InfixR =+            putByte bh 1+    put_ bh InfixN =+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> return InfixL+              1 -> return InfixR+              _ -> return InfixN++------------------------+maxPrecedence, minPrecedence :: Int+maxPrecedence = 9+minPrecedence = 0++defaultFixity :: Fixity+defaultFixity = Fixity NoSourceText maxPrecedence InfixL++negateFixity, funTyFixity :: Fixity+-- Wired-in fixities+negateFixity = Fixity NoSourceText 6 InfixL  -- Fixity of unary negate+funTyFixity  = Fixity NoSourceText (-1) InfixR  -- Fixity of '->', see #15235++{-+Consider++\begin{verbatim}+        a `op1` b `op2` c+\end{verbatim}+@(compareFixity op1 op2)@ tells which way to arrange application, or+whether there's an error.+-}++compareFixity :: Fixity -> Fixity+              -> (Bool,         -- Error please+                  Bool)         -- Associate to the right: a op1 (b op2 c)+compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)+  = case prec1 `compare` prec2 of+        GT -> left+        LT -> right+        EQ -> case (dir1, dir2) of+                        (InfixR, InfixR) -> right+                        (InfixL, InfixL) -> left+                        _                -> error_please+  where+    right        = (False, True)+    left         = (False, False)+    error_please = (True,  False)++-- |Captures the fixity of declarations as they are parsed. This is not+-- necessarily the same as the fixity declaration, as the normal fixity may be+-- overridden using parens or backticks.+data LexicalFixity = Prefix | Infix deriving (Data,Eq)++instance Outputable LexicalFixity where+  ppr Prefix = text "Prefix"+  ppr Infix  = text "Infix"

+ GHC/Types/Fixity/Env.hs view

@@ -0,0 +1,46 @@+module GHC.Types.Fixity.Env+   ( FixityEnv+   , FixItem (..)+   , emptyFixityEnv+   , lookupFixity+   , mkIfaceFixCache+   , emptyIfaceFixCache+   )+where++import GHC.Prelude++import GHC.Types.Fixity+import GHC.Types.Name+import GHC.Types.Name.Env++import GHC.Utils.Outputable++-- | Fixity environment mapping names to their fixities+type FixityEnv = NameEnv FixItem++-- | Fixity information for an 'Name'. We keep the OccName in the range+-- so that we can generate an interface from it+data FixItem = FixItem OccName Fixity++instance Outputable FixItem where+  ppr (FixItem occ fix) = ppr fix <+> ppr occ++emptyFixityEnv :: FixityEnv+emptyFixityEnv = emptyNameEnv++lookupFixity :: FixityEnv -> Name -> Fixity+lookupFixity env n = case lookupNameEnv env n of+                        Just (FixItem _ fix) -> fix+                        Nothing         -> defaultFixity++-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'+mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Maybe Fixity+mkIfaceFixCache pairs+  = \n -> lookupOccEnv env n+  where+   env = mkOccEnv pairs++emptyIfaceFixCache :: OccName -> Maybe Fixity+emptyIfaceFixCache _ = Nothing+

GHC/Types/ForeignCall.hs view

@@ -23,8 +23,9 @@ import GHC.Data.FastString import GHC.Utils.Binary import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Unit.Module-import GHC.Types.Basic ( SourceText, pprWithSourceText )+import GHC.Types.SourceText ( SourceText, pprWithSourceText )  import Data.Char import Data.Data@@ -98,7 +99,7 @@ data CExportSpec   = CExportStatic               -- foreign export ccall foo :: ty         SourceText              -- of the CLabelString.-                                -- See note [Pragma source text] in GHC.Types.Basic+                                -- See note [Pragma source text] in GHC.Types.SourceText         CLabelString            -- C Name of exported function         CCallConv   deriving Data@@ -116,7 +117,7 @@   -- An "unboxed" ccall# to named function in a particular package.   = StaticTarget         SourceText                -- of the CLabelString.-                                  -- See note [Pragma source text] in GHC.Types.Basic+                                  -- See note [Pragma source text] in GHC.Types.SourceText         CLabelString                    -- C-land name of label.          (Maybe Unit)                    -- What package the function is in.@@ -227,7 +228,7 @@         = text "__ffi_dyn_ccall" <> gc_suf <+> text "\"\""  -- The filename for a C header file--- Note [Pragma source text] in GHC.Types.Basic+-- Note [Pragma source text] in GHC.Types.SourceText data Header = Header SourceText FastString     deriving (Eq, Data) @@ -240,8 +241,8 @@ --        'GHC.Parser.Annotation.AnnHeader','GHC.Parser.Annotation.AnnVal', --        'GHC.Parser.Annotation.AnnClose' @'\#-}'@, --- For details on above see note [Api annotations] in "GHC.Parser.Annotation"-data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.Basic+-- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"+data CType = CType SourceText -- Note [Pragma source text] in GHC.Types.SourceText                    (Maybe Header) -- header to include for this type                    (SourceText,FastString) -- the type itself     deriving (Eq, Data)@@ -267,18 +268,18 @@     get bh = do aa <- get bh; return (CCall aa)  instance Binary Safety where-    put_ bh PlaySafe = do+    put_ bh PlaySafe =             putByte bh 0-    put_ bh PlayInterruptible = do+    put_ bh PlayInterruptible =             putByte bh 1-    put_ bh PlayRisky = do+    put_ bh PlayRisky =             putByte bh 2     get bh = do             h <- getByte bh             case h of-              0 -> do return PlaySafe-              1 -> do return PlayInterruptible-              _ -> do return PlayRisky+              0 -> return PlaySafe+              1 -> return PlayInterruptible+              _ -> return PlayRisky  instance Binary CExportSpec where     put_ bh (CExportStatic ss aa ab) = do@@ -309,7 +310,7 @@             put_ bh aa             put_ bh ab             put_ bh ac-    put_ bh DynamicTarget = do+    put_ bh DynamicTarget =             putByte bh 1     get bh = do             h <- getByte bh@@ -319,27 +320,27 @@                       ab <- get bh                       ac <- get bh                       return (StaticTarget ss aa ab ac)-              _ -> do return DynamicTarget+              _ -> return DynamicTarget  instance Binary CCallConv where-    put_ bh CCallConv = do+    put_ bh CCallConv =             putByte bh 0-    put_ bh StdCallConv = do+    put_ bh StdCallConv =             putByte bh 1-    put_ bh PrimCallConv = do+    put_ bh PrimCallConv =             putByte bh 2-    put_ bh CApiConv = do+    put_ bh CApiConv =             putByte bh 3-    put_ bh JavaScriptCallConv = do+    put_ bh JavaScriptCallConv =             putByte bh 4     get bh = do             h <- getByte bh             case h of-              0 -> do return CCallConv-              1 -> do return StdCallConv-              2 -> do return PrimCallConv-              3 -> do return CApiConv-              _ -> do return JavaScriptCallConv+              0 -> return CCallConv+              1 -> return StdCallConv+              2 -> return PrimCallConv+              3 -> return CApiConv+              _ -> return JavaScriptCallConv  instance Binary CType where     put_ bh (CType s mh fs) = do put_ bh s

+ GHC/Types/ForeignStubs.hs view

@@ -0,0 +1,46 @@+-- | Foreign export stubs+{-# LANGUAGE DerivingVia #-}+module GHC.Types.ForeignStubs+   ( ForeignStubs (..)+   , CHeader(..)+   , CStub(..)+   , appendStubC+   )+where++import GHC.Utils.Outputable+import Data.Monoid+import Data.Semigroup+import Data.Coerce++newtype CStub = CStub { getCStub :: SDoc }++emptyCStub :: CStub+emptyCStub = CStub empty++instance Monoid CStub where+  mempty = emptyCStub+  mconcat = coerce vcat++instance Semigroup CStub where+  (<>) = coerce ($$)++newtype CHeader = CHeader { getCHeader :: SDoc }+  deriving (Monoid, Semigroup) via CStub++-- | Foreign export stubs+data ForeignStubs+  = NoStubs+      -- ^ We don't have any stubs+  | ForeignStubs CHeader CStub+      -- ^ There are some stubs. Parameters:+      --+      --  1) Header file prototypes for+      --     "foreign exported" functions+      --+      --  2) C stubs to use when calling+      --     "foreign exported" functions++appendStubC :: ForeignStubs -> CStub -> ForeignStubs+appendStubC NoStubs         c_code = ForeignStubs mempty c_code+appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c `mappend` c_code)

+ GHC/Types/HpcInfo.hs view

@@ -0,0 +1,34 @@+-- | Haskell Program Coverage (HPC) support+module GHC.Types.HpcInfo+   ( HpcInfo (..)+   , AnyHpcUsage+   , emptyHpcInfo+   , isHpcUsed+   )+where++import GHC.Prelude++-- | Information about a modules use of Haskell Program Coverage+data HpcInfo+  = HpcInfo+     { hpcInfoTickCount :: Int+     , hpcInfoHash      :: Int+     }+  | NoHpcInfo+     { hpcUsed          :: AnyHpcUsage  -- ^ Is hpc used anywhere on the module \*tree\*?+     }++-- | This is used to signal if one of my imports used HPC instrumentation+-- even if there is no module-local HPC usage+type AnyHpcUsage = Bool++emptyHpcInfo :: AnyHpcUsage -> HpcInfo+emptyHpcInfo = NoHpcInfo++-- | Find out if HPC is used by this module or any of the modules+-- it depends upon+isHpcUsed :: HpcInfo -> AnyHpcUsage+isHpcUsed (HpcInfo {})                   = True+isHpcUsed (NoHpcInfo { hpcUsed = used }) = used+

+ GHC/Types/IPE.hs view

@@ -0,0 +1,36 @@+module GHC.Types.IPE(DCMap, ClosureMap, InfoTableProvMap(..)+                    , emptyInfoTableProvMap) where++import GHC.Prelude++import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Core.DataCon++import GHC.Types.Unique.Map+import GHC.Core.Type+import Data.List.NonEmpty++-- | A map from a 'Name' to the best approximate source position that+-- name arose from.+type ClosureMap = UniqMap Name  -- The binding+                          (Type, Maybe (RealSrcSpan, String))+                          -- The best approximate source position.+                          -- (rendered type, source position, source note+                          -- label)++-- | A map storing all the different uses of a specific data constructor and the+-- approximate source position that usage arose from.+-- The 'Int' is an incrementing identifier which distinguishes each usage+-- of a constructor in a module. It is paired with the source position+-- the constructor was used at, if possible and a string which names+-- the source location. This is the same information as is the payload+-- for the 'GHC.Core.SourceNote' constructor.+type DCMap = UniqMap DataCon (NonEmpty (Int, Maybe (RealSrcSpan, String)))++data InfoTableProvMap = InfoTableProvMap+                          { provDC :: DCMap+                          , provClosure :: ClosureMap }++emptyInfoTableProvMap :: InfoTableProvMap+emptyInfoTableProvMap = InfoTableProvMap emptyUniqMap emptyUniqMap

GHC/Types/Id.hs view

@@ -46,6 +46,7 @@         -- ** Taking an Id apart         idName, idType, idMult, idScaledType, idUnique, idInfo, idDetails,         recordSelectorTyCon,+        recordSelectorTyCon_maybe,          -- ** Modifying an Id         setIdName, setIdUnique, GHC.Types.Id.setIdType, setIdMult,@@ -123,7 +124,6 @@  import GHC.Prelude -import GHC.Driver.Session import GHC.Core ( CoreRule, isStableUnfolding, evaldUnfolding,                  isCompulsoryUnfolding, Unfolding( NoUnfolding ) ) @@ -152,13 +152,19 @@ import GHC.Types.ForeignCall import GHC.Data.Maybe import GHC.Types.SrcLoc-import GHC.Utils.Outputable import GHC.Types.Unique+import GHC.Builtin.Uniques (mkBuiltinUnique) import GHC.Types.Unique.Supply import GHC.Data.FastString-import GHC.Utils.Misc import GHC.Core.Multiplicity +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.GlobalVars++import GHC.Driver.Ppr+ -- infixl so you can say (id `set` a `set` b) infixl  1 `setIdUnfolding`,           `setIdArity`,@@ -433,10 +439,15 @@ -- | If the 'Id' is that for a record selector, extract the 'sel_tycon'. Panic otherwise. recordSelectorTyCon :: Id -> RecSelParent recordSelectorTyCon id-  = case Var.idDetails id of-        RecSelId { sel_tycon = parent } -> parent+  = case recordSelectorTyCon_maybe id of+        Just parent -> parent         _ -> panic "recordSelectorTyCon" +recordSelectorTyCon_maybe :: Id -> Maybe RecSelParent+recordSelectorTyCon_maybe id+  = case Var.idDetails id of+        RecSelId { sel_tycon = parent } -> Just parent+        _ -> Nothing  isRecordSelector        :: Id -> Bool isNaughtyRecordSelector :: Id -> Bool@@ -551,7 +562,7 @@ hasNoBinding id = case Var.idDetails id of                         PrimOpId _       -> True    -- See Note [Eta expanding primops] in GHC.Builtin.PrimOps                         FCallId _        -> True-                        DataConWorkId dc -> isUnboxedTupleCon dc || isUnboxedSumCon dc+                        DataConWorkId dc -> isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc                         _                -> isCompulsoryUnfolding (idUnfolding id)                                             -- See Note [Levity-polymorphic Ids] @@ -689,12 +700,11 @@ -- type, we still want @isStrictId id@ to be @True@. isStrictId :: Id -> Bool isStrictId id-  = ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )-         not (isJoinId id) && (-           (isStrictType (idType id)) ||-           -- Take the best of both strictnesses - old and new-           (isStrictDmd (idDemandInfo id))-         )+  | ASSERT2( isId id, text "isStrictId: not an id: " <+> ppr id )+    isJoinId id = False+  | otherwise   = isStrictType (idType id) ||+                  isStrUsedDmd (idDemandInfo id)+                  -- Take the best of both strictnesses - old and new          ---------------------------------         -- UNFOLDING@@ -838,7 +848,7 @@  isStateHackType :: Type -> Bool isStateHackType ty-  | hasNoStateHack unsafeGlobalDynFlags+  | unsafeHasNoStateHack   = False   | otherwise   = case tyConAppTyCon_maybe ty of

+ GHC/Types/Id.hs-boot view

@@ -0,0 +1,7 @@+module GHC.Types.Id where++import GHC.Prelude ()+import {-# SOURCE #-} GHC.Types.Name+import {-# SOURCE #-} GHC.Types.Var++idName   :: Id -> Name

GHC/Types/Id/Info.hs view

@@ -104,14 +104,15 @@ import GHC.Core.PatSyn import GHC.Core.Type import GHC.Types.ForeignCall-import GHC.Utils.Outputable import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr+ import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.Word-import Data.Bits  import GHC.StgToCmm.Types (LambdaFormInfo (..)) @@ -634,7 +635,7 @@                           -> occ { occ_tail   = NoTailCallInfo }                  _other   -> occ -    is_safe_dmd dmd = not (isStrictDmd dmd)+    is_safe_dmd dmd = not (isStrUsedDmd dmd)  -- | Remove all demand info on the 'IdInfo' zapDemandInfo :: IdInfo -> Maybe IdInfo@@ -648,7 +649,7 @@ zapUsageEnvInfo :: IdInfo -> Maybe IdInfo zapUsageEnvInfo info     | hasDemandEnvSig (strictnessInfo info)-    = Just (info {strictnessInfo = zapUsageEnvSig (strictnessInfo info)})+    = Just (info {strictnessInfo = zapDmdEnvSig (strictnessInfo info)})     | otherwise     = Nothing

GHC/Types/Id/Make.hs view

@@ -32,7 +32,7 @@         nullAddrId, seqId, lazyId, lazyIdKey,         coercionTokenId, magicDictId, coerceId,         proxyHashId, noinlineId, noinlineIdName,-        coerceName,+        coerceName, leftSectionName, rightSectionName,          -- Re-export error Ids         module GHC.Core.Opt.ConstantFold@@ -53,9 +53,11 @@ import GHC.Tc.Utils.TcType as TcType import GHC.Core.Make import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Utils   ( mkCast, mkDefaultCase )-import GHC.Core.Unfold+import GHC.Core.Utils   ( exprType, mkCast, mkDefaultCase )+import GHC.Core.Unfold.Make+import GHC.Core.SimpleOpt import GHC.Types.Literal+import GHC.Types.SourceText import GHC.Core.TyCon import GHC.Core.Class import GHC.Types.Name.Set@@ -67,14 +69,18 @@ import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr+import GHC.Types.TyThing import GHC.Core import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Types.Unique.Supply import GHC.Builtin.Names import GHC.Types.Basic       hiding ( SuccessFlag(..) ) import GHC.Utils.Misc import GHC.Driver.Session+import GHC.Driver.Ppr import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString import GHC.Data.List.SetOps import GHC.Types.Var (VarBndr(Bndr))@@ -115,13 +121,14 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ghcPrimIds -  * Are exported from GHC.Prim+  * Are exported from GHC.Prim (see ghcPrimExports, used in ghcPrimInterface)+    See Note [GHC.Prim] in primops.txt.pp for the remaining items in GHC.Prim.    * Can't be defined in Haskell, and hence no Haskell binding site,     but have perfectly reasonable unfoldings in Core    * Either have a CompulsoryUnfolding (hence always inlined), or-        of an EvaldUnfolding and void representation (e.g. void#)+        of an EvaldUnfolding and void representation (e.g. realWorldPrimId)    * Are (or should be) defined in primops.txt.pp as 'pseudoop'     Reason: that's how we generate documentation for them@@ -138,7 +145,17 @@   * May or may not have a CompulsoryUnfolding.    * But have some special behaviour that can't be done via an-    unfolding from an interface file+    unfolding from an interface file.++  * May have IdInfo that differs from what would be imported from GHC.Magic.hi.+    For example, 'lazy' gets a lazy strictness signature, per Note [lazyId magic].++  The two remaining identifiers in GHC.Magic, runRW# and inline, are not listed+  in magicIds: they have special behavior but they can be known-key and+  not wired-in.+  runRW#: see Note [Simplification of runRW#] in Prep, runRW# code in+  Simplifier, Note [Linting of runRW#].+  inline: see Note [inlineId magic] -}  wiredInIds :: [Id]@@ -159,6 +176,8 @@     , magicDictId     , coerceId     , proxyHashId+    , leftSectionId+    , rightSectionId     ]  {-@@ -472,6 +491,7 @@     info | new_tycon          = base_info `setInlinePragInfo` alwaysInlinePragma                      `setUnfoldingInfo`  mkInlineUnfoldingWithArity 1+                                           defaultSimpleOpts                                            (mkDictSelRhs clas val_index)                    -- See Note [Single-method classes] in GHC.Tc.TyCl.Instance                    -- for why alwaysInlinePragma@@ -497,9 +517,9 @@      strict_sig = mkClosedStrictSig [arg_dmd] topDiv     arg_dmd | new_tycon = evalDmd-            | otherwise = mkManyUsedDmd $-                          mkProdDmd [ if name == sel_name then evalDmd else absDmd-                                    | sel_name <- sel_names ]+            | otherwise = C_1N :*+                          Prod [ if name == sel_name then evalDmd else absDmd+                               | sel_name <- sel_names ]  mkDictSelRhs :: Class              -> Int         -- 0-indexed selector among (superclasses ++ methods)@@ -586,18 +606,18 @@                             isSingleton arg_tys                           , ppr data_con  )                               -- Note [Newtype datacons]-                   mkCompulsoryUnfolding $+                   mkCompulsoryUnfolding defaultSimpleOpts $                    mkLams univ_tvs $ Lam id_arg1 $                    wrapNewTypeBody tycon res_ty_args (Var id_arg1) -dataConCPR :: DataCon -> CprResult+dataConCPR :: DataCon -> Cpr dataConCPR con   | isDataTyCon tycon     -- Real data types only; that is,                           -- not unboxed tuples or newtypes   , null (dataConExTyCoVars con)  -- No existentials   , wkr_arity > 0   , wkr_arity <= mAX_CPR_SIZE-  = conCpr (dataConTag con)+  = flatConCpr (dataConTag con)   | otherwise   = topCpr   where@@ -719,9 +739,9 @@              -- See Note [Inline partially-applied constructor wrappers]              -- Passing Nothing here allows the wrapper to inline when              -- unsaturated.-             wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding wrap_rhs+             wrap_unf | isNewTyCon tycon = mkCompulsoryUnfolding defaultSimpleOpts wrap_rhs                         -- See Note [Compulsory newtype unfolding]-                      | otherwise        = mkInlineUnfolding wrap_rhs+                      | otherwise        = mkInlineUnfolding defaultSimpleOpts wrap_rhs              wrap_rhs = mkLams wrap_tvs $                         mkLams wrap_args $                         wrapFamInstBody tycon res_ty_args $@@ -1399,17 +1419,18 @@ unfoldings in the wired-in GHC.Prim interface file, but we'd have to ensure that they were definitely, definitely inlined, because there is no curried identifier for them.  That's what mkCompulsoryUnfolding-does.  If we had a way to get a compulsory unfolding from an interface-file, we could do that, but we don't right now.+does. Alternatively, we could add the definitions to mi_decls of ghcPrimIface+but it's not clear if this would be simpler. -The type variables we use here are "open" type variables: this means-they can unify with both unlifted and lifted types.  Hence we provide-another gun with which to shoot yourself in the foot.+coercionToken# is not listed in ghcPrimIds, since its type uses (~#)+which is not supposed to be used in expressions (GHC throws an assertion+failure when trying.) -}  nullAddrName, seqName,    realWorldName, voidPrimIdName, coercionTokenName,-   magicDictName, coerceName, proxyName :: Name+   magicDictName, coerceName, proxyName,+   leftSectionName, rightSectionName :: Name nullAddrName      = mkWiredInIdName gHC_PRIM  (fsLit "nullAddr#")      nullAddrIdKey      nullAddrId seqName           = mkWiredInIdName gHC_PRIM  (fsLit "seq")            seqIdKey           seqId realWorldName     = mkWiredInIdName gHC_PRIM  (fsLit "realWorld#")     realWorldPrimIdKey realWorldPrimId@@ -1418,7 +1439,10 @@ magicDictName     = mkWiredInIdName gHC_PRIM  (fsLit "magicDict")      magicDictKey       magicDictId coerceName        = mkWiredInIdName gHC_PRIM  (fsLit "coerce")         coerceKey          coerceId proxyName         = mkWiredInIdName gHC_PRIM  (fsLit "proxy#")         proxyHashKey       proxyHashId+leftSectionName   = mkWiredInIdName gHC_PRIM  (fsLit "leftSection")    leftSectionKey     leftSectionId+rightSectionName  = mkWiredInIdName gHC_PRIM  (fsLit "rightSection")   rightSectionKey    rightSectionId +-- Names listed in magicIds; see Note [magicIds] lazyIdName, oneShotName, noinlineIdName :: Name lazyIdName        = mkWiredInIdName gHC_MAGIC (fsLit "lazy")           lazyIdKey          lazyId oneShotName       = mkWiredInIdName gHC_MAGIC (fsLit "oneShot")        oneShotKey         oneShotId@@ -1448,7 +1472,7 @@ nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                       `setUnfoldingInfo`  mkCompulsoryUnfolding (Lit nullAddrLit)+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts (Lit nullAddrLit)                        `setNeverLevPoly`   addrPrimTy  ------------------------------------------------@@ -1456,7 +1480,7 @@ seqId = pcMiscPrelId seqName ty info   where     info = noCafIdInfo `setInlinePragInfo` inline_prag-                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs      inline_prag          = alwaysInlinePragma `setInlinePragmaActivation` ActiveAfter@@ -1474,7 +1498,7 @@      [x,y] = mkTemplateLocals [alphaTy, openBetaTy]     rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $-          Case (Var x) x openBetaTy [(DEFAULT, [], Var y)]+          Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)]  ------------------------------------------------ lazyId :: Id    -- See Note [lazyId magic]@@ -1493,18 +1517,86 @@ oneShotId = pcMiscPrelId oneShotName ty info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs-    ty  = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar-                          , openAlphaTyVar, openBetaTyVar ]-                          (mkVisFunTyMany fun_ty fun_ty)+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+    ty  = mkInfForAllTys  [ runtimeRep1TyVar, runtimeRep2TyVar ] $+          mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ]      $+          mkVisFunTyMany fun_ty fun_ty     fun_ty = mkVisFunTyMany openAlphaTy openBetaTy     [body, x] = mkTemplateLocals [fun_ty, openAlphaTy]     x' = setOneShotLambda x  -- Here is the magic bit!     rhs = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar                  , openAlphaTyVar, openBetaTyVar                  , body, x'] $-          Var body `App` Var x+          Var body `App` Var x' +----------------------------------------------------------------------+{- Note [Wired-in Ids for rebindable syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The functions leftSectionId, rightSectionId are+wired in here ONLY because they are use in a levity-polymorphic way+by the rebindable syntax mechanism. See GHC.Rename.Expr+Note [Handling overloaded and rebindable constructs].++Alas, we can't currenly give Haskell definitions for+levity-polymorphic functions.++They have Compulsory unfoldings to so that the levity polymorphism+does not linger for long.+-}++-- See Note [Left and right sections] in GHC.Rename.Expr+-- See Note [Wired-in Ids for rebindable syntax]+--   leftSection :: forall r1 r2 n (a:Type r1) (b:TYPE r2).+--                  (a %n-> b) -> a %n-> b+--   leftSection f x = f x+-- Important that it is eta-expanded, so that (leftSection undefined `seq` ())+--   is () and not undefined+-- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList)+leftSectionId :: Id+leftSectionId = pcMiscPrelId leftSectionName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+    ty  = mkInfForAllTys  [runtimeRep1TyVar,runtimeRep2TyVar, multiplicityTyVar1] $+          mkSpecForAllTys [openAlphaTyVar,  openBetaTyVar]    $+          exprType body+    [f,x] = mkTemplateLocals [mkVisFunTy mult openAlphaTy openBetaTy, openAlphaTy]++    mult = mkTyVarTy multiplicityTyVar1 :: Mult+    xmult = setIdMult x mult++    rhs  = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, multiplicityTyVar1+                  , openAlphaTyVar,   openBetaTyVar   ] body+    body = mkLams [f,xmult] $ App (Var f) (Var xmult)++-- See Note [Left and right sections] in GHC.Rename.Expr+-- See Note [Wired-in Ids for rebindable syntax]+--   rightSection :: forall r1 r2 r3 (a:TYPE r1) (b:TYPE r2) (c:TYPE r3).+--                   (a %n1 -> b %n2-> c) -> b %n2-> a %n1-> c+--   rightSection f y x = f x y+-- Again, multiplicity polymorphism is important+rightSectionId :: Id+rightSectionId = pcMiscPrelId rightSectionName ty info+  where+    info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs+    ty  = mkInfForAllTys  [runtimeRep1TyVar,runtimeRep2TyVar,runtimeRep3TyVar+                          , multiplicityTyVar1, multiplicityTyVar2 ] $+          mkSpecForAllTys [openAlphaTyVar,  openBetaTyVar,   openGammaTyVar ]  $+          exprType body+    mult1 = mkTyVarTy multiplicityTyVar1+    mult2 = mkTyVarTy multiplicityTyVar2++    [f,x,y] = mkTemplateLocals [ mkVisFunTys [ Scaled mult1 openAlphaTy+                                             , Scaled mult2 openBetaTy ] openGammaTy+                               , openAlphaTy, openBetaTy ]+    xmult = setIdMult x mult1+    ymult = setIdMult y mult2+    rhs  = mkLams [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar+                  , multiplicityTyVar1, multiplicityTyVar2+                  , openAlphaTyVar,   openBetaTyVar,    openGammaTyVar ] body+    body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult]+ -------------------------------------------------------------------------------- magicDictId :: Id  -- See Note [magicDictId magic] magicDictId = pcMiscPrelId magicDictName ty info@@ -1519,7 +1611,7 @@ coerceId = pcMiscPrelId coerceName ty info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                       `setUnfoldingInfo`  mkCompulsoryUnfolding rhs+                       `setUnfoldingInfo`  mkCompulsoryUnfolding defaultSimpleOpts rhs     eqRTy     = mkTyConApp coercibleTyCon [ tYPE r , a, b ]     eqRPrimTy = mkTyConApp eqReprPrimTyCon [ tYPE r, tYPE r, a, b ]     ty        = mkInvisForAllTys [ Bndr rv InferredSpec@@ -1537,7 +1629,7 @@     [eqR,x,eq] = mkTemplateLocals [eqRTy, a, eqRPrimTy]     rhs = mkLams (bndrs ++ [eqR, x]) $           mkWildCase (Var eqR) (unrestricted eqRTy) b $-          [(DataAlt coercibleDataCon, [eq], Cast (Var x) (mkCoVarCo eq))]+          [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))]  {- Note [seqId magic]@@ -1547,7 +1639,7 @@ a) Its fixity is set in GHC.Iface.Load.ghcPrimIface  b) It has quite a bit of desugaring magic.-   See GHC.HsToCore.Utils Note [Desugaring seq (1)] and (2) and (3)+   See GHC.HsToCore.Utils Note [Desugaring seq] (1) and (2) and (3)  c) There is some special rule handing: Note [User-defined RULES for seq] @@ -1595,7 +1687,7 @@  Note [lazyId magic] ~~~~~~~~~~~~~~~~~~~-lazy :: forall a?. a? -> a?   (i.e. works for unboxed types too)+lazy :: forall a. a -> a  'lazy' is used to make sure that a sub-expression, and its free variables, are truly used call-by-need, with no code motion.  Key examples:@@ -1613,7 +1705,7 @@ Implementing 'lazy' is a bit tricky:  * It must not have a strictness signature: by being a built-in Id,-  all the info about lazyId comes from here, not from GHC.Base.hi.+  all the info about lazyId comes from here, not from GHC.Magic.hi.   This is important, because the strictness analyser will spot it as   strict! @@ -1638,19 +1730,37 @@  Note [noinlineId magic] ~~~~~~~~~~~~~~~~~~~~~~~-noinline :: forall a. a -> a- 'noinline' is used to make sure that a function f is never inlined,-e.g., as in 'noinline f x'.  Ordinarily, the identity function with NOINLINE-could be used to achieve this effect; however, this has the unfortunate-result of leaving a (useless) call to noinline at runtime.  So we have-a little bit of magic to optimize away 'noinline' after we are done-running the simplifier.+e.g., as in 'noinline f x'.  We won't inline f because we never inline+lone variables (see Note [Lone variables] in GHC.Core.Unfold -'noinline' needs to be wired-in because it gets inserted automatically-when we serialize an expression to the interface format. See-Note [Inlining and hs-boot files] in GHC.CoreToIface+You might think that we could implement noinline like this:+   {-# NOINLINE #-}+   noinline :: forall a. a -> a+   noinline x = x +But actually we give 'noinline' a wired-in name for three distinct reasons:++1. We don't want to leave a (useless) call to noinline in the final program,+   to be executed at runtime. So we have a little bit of magic to+   optimize away 'noinline' after we are done running the simplifier.+   This is done in GHC.CoreToStg.Prep.cpeApp.++2. 'noinline' sometimes gets inserted automatically when we serialize an+   expression to the interface format, in GHC.CoreToIface.toIfaceVar.+   See Note [Inlining and hs-boot files] in GHC.CoreToIface++3. Given foo :: Eq a => [a] -> Bool, the expression+     noinline foo x xs+   where x::Int, will naturally desugar to+      noinline @Int (foo @Int dEqInt) x xs+   But now it's entirely possible htat (foo @Int dEqInt) will inline foo,+   since 'foo' is no longer a lone variable -- see #18995++   Solution: in the desugarer, rewrite+      noinline (f x y)  ==>  noinline f x y+   This is done in GHC.HsToCore.Utils.mkCoreAppDs.+ Note that noinline as currently implemented can hide some simplifications since it hides strictness from the demand analyser. Specifically, the demand analyser will treat 'noinline f x' as lazy in 'x', even if the demand signature of 'f'@@ -1731,7 +1841,7 @@   f (x `cast` co a) y  The `co` coercion is the newtype-coercion extracted from the type-class.-The type class is obtain by looking at the type of wrap.+The type class is obtained by looking at the type of wrap.  In the constant folding rule it's very import to make sure to strip all ticks from the expression as if there's an occurence of@@ -1765,14 +1875,21 @@                                   `setNeverLevPoly`  realWorldStatePrimTy)  voidPrimId :: Id     -- Global constant :: Void#-voidPrimId  = pcMiscPrelId voidPrimIdName voidPrimTy-                (noCafIdInfo `setUnfoldingInfo` evaldUnfolding     -- Note [evaldUnfoldings]-                             `setNeverLevPoly`  voidPrimTy)+                     -- The type Void# is now the same as (# #) (ticket #18441),+                     -- this identifier just signifies the (# #) datacon+                     -- and is kept for backwards compatibility.+                     -- We cannot define it in normal Haskell, since it's+                     -- a top-level unlifted value.+voidPrimId  = pcMiscPrelId voidPrimIdName unboxedUnitTy+                (noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding defaultSimpleOpts rhs+                             `setNeverLevPoly`  unboxedUnitTy)+    where rhs = Var (dataConWorkId unboxedUnitDataCon) + voidArgId :: Id       -- Local lambda-bound :: Void#-voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many voidPrimTy+voidArgId = mkSysLocal (fsLit "void") voidArgIdKey Many unboxedUnitTy -coercionTokenId :: Id         -- :: () ~ ()+coercionTokenId :: Id         -- :: () ~# () coercionTokenId -- See Note [Coercion tokens] in "GHC.CoreToStg"   = pcMiscPrelId coercionTokenName                  (mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, unitTy, unitTy])@@ -1781,8 +1898,3 @@ pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info   = mkVanillaGlobalWithInfo name ty info-    -- We lie and say the thing is imported; otherwise, we get into-    -- a mess with dependency analysis; e.g., core2stg may heave in-    -- random calls to GHCbase.unpackPS__.  If GHCbase is the module-    -- being compiled, then it's just a matter of luck if the definition-    -- will be in "the right place" to be in scope.

GHC/Types/Literal.hs view

@@ -2,12 +2,16 @@ (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1998 -\section[Literal]{@Literal@: literals} -}  {-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+ {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- | Core literals module GHC.Types.Literal         (         -- * Main data type@@ -17,6 +21,12 @@         -- ** Creating Literals         , mkLitInt, mkLitIntWrap, mkLitIntWrapC, mkLitIntUnchecked         , mkLitWord, mkLitWordWrap, mkLitWordWrapC+        , mkLitInt8, mkLitInt8Wrap+        , mkLitWord8, mkLitWord8Wrap+        , mkLitInt16, mkLitInt16Wrap+        , mkLitWord16, mkLitWord16Wrap+        , mkLitInt32, mkLitInt32Wrap+        , mkLitWord32, mkLitWord32Wrap         , mkLitInt64, mkLitInt64Wrap         , mkLitWord64, mkLitWord64Wrap         , mkLitFloat, mkLitDouble@@ -30,22 +40,29 @@         , pprLiteral         , litNumIsSigned         , litNumCheckRange+        , litNumWrap+        , litNumCoerce+        , litNumNarrow+        , litNumBitSize+        , isMinBound+        , isMaxBound          -- ** Predicates on Literals and their contents         , litIsDupable, litIsTrivial, litIsLifted         , inCharRange-        , isZeroLit+        , isZeroLit, isOneLit         , litFitsInChar-        , litValue, isLitValue, isLitValue_maybe, mapLitValue+        , litValue, mapLitValue+        , isLitValue_maybe          -- ** Coercions-        , word2IntLit, int2WordLit-        , narrowLit-        , narrow8IntLit, narrow16IntLit, narrow32IntLit-        , narrow8WordLit, narrow16WordLit, narrow32WordLit-        , char2IntLit, int2CharLit-        , float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit-        , nullAddrLit, rubbishLit, float2DoubleLit, double2FloatLit+        , narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit+        , narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit+        , extendIntLit, extendWordLit+        , charToIntLit, intToCharLit+        , floatToIntLit, intToFloatLit, doubleToIntLit, intToDoubleLit+        , nullAddrLit, floatToDoubleLit, doubleToFloatLit+        , rubbishLit, isRubbishLit         ) where  #include "HsVersions.h"@@ -65,14 +82,14 @@ import GHC.Platform import GHC.Types.Unique.FM import GHC.Utils.Misc+import GHC.Utils.Panic  import Data.ByteString (ByteString) import Data.Int import Data.Word import Data.Char-import Data.Maybe ( isJust ) import Data.Data ( Data )-import Data.Proxy+import GHC.Exts import Numeric ( fromRat )  {-@@ -122,11 +139,10 @@                                 -- that can be represented as a Literal. Create                                 -- with 'nullAddrLit' -  | LitRubbish                  -- ^ A nonsense value, used when an unlifted-                                -- binding is absent and has type-                                -- @forall (a :: 'TYPE' 'UnliftedRep'). a@.-                                -- May be lowered by code-gen to any possible-                                -- value. Also see Note [Rubbish literals]+  | LitRubbish Bool             -- ^ A nonsense value; always boxed, but+                                --      True <=> lifted, False <=> unlifted+                                -- Used when a binding is absent.+                                -- See Note [Rubbish literals]    | LitFloat   Rational         -- ^ @Float#@. Create with 'mkLitFloat'   | LitDouble  Rational         -- ^ @Double#@. Create with 'mkLitDouble'@@ -152,8 +168,14 @@   = LitNumInteger -- ^ @Integer@ (see Note [BigNum literals])   | LitNumNatural -- ^ @Natural@ (see Note [BigNum literals])   | LitNumInt     -- ^ @Int#@ - according to target machine+  | LitNumInt8    -- ^ @Int8#@ - exactly 8 bits+  | LitNumInt16   -- ^ @Int16#@ - exactly 16 bits+  | LitNumInt32   -- ^ @Int32#@ - exactly 32 bits   | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits   | LitNumWord    -- ^ @Word#@ - according to target machine+  | LitNumWord8   -- ^ @Word8#@ - exactly 8 bits+  | LitNumWord16  -- ^ @Word16#@ - exactly 16 bits+  | LitNumWord32  -- ^ @Word32#@ - exactly 32 bits   | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits   deriving (Data,Enum,Eq,Ord) @@ -163,10 +185,38 @@   LitNumInteger -> True   LitNumNatural -> False   LitNumInt     -> True+  LitNumInt8    -> True+  LitNumInt16   -> True+  LitNumInt32   -> True   LitNumInt64   -> True   LitNumWord    -> False+  LitNumWord8   -> False+  LitNumWord16  -> False+  LitNumWord32  -> False   LitNumWord64  -> False +-- | Number of bits+litNumBitSize :: Platform -> LitNumType -> Maybe Word+litNumBitSize platform nt = case nt of+  LitNumInteger -> Nothing+  LitNumNatural -> Nothing+  LitNumInt     -> Just (fromIntegral (platformWordSizeInBits platform))+  LitNumInt8    -> Just 8+  LitNumInt16   -> Just 16+  LitNumInt32   -> Just 32+  LitNumInt64   -> Just 64+  LitNumWord    -> Just (fromIntegral (platformWordSizeInBits platform))+  LitNumWord8   -> Just 8+  LitNumWord16  -> Just 16+  LitNumWord32  -> Just 32+  LitNumWord64  -> Just 64++instance Binary LitNumType where+   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))+   get bh = do+      h <- getByte bh+      return (toEnum (fromIntegral h))+ {- Note [BigNum literals] ~~~~~~~~~~~~~~~~~~~~~~@@ -198,16 +248,10 @@  -} -instance Binary LitNumType where-   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))-   get bh = do-      h <- getByte bh-      return (toEnum (fromIntegral h))- instance Binary Literal where     put_ bh (LitChar aa)     = do putByte bh 0; put_ bh aa     put_ bh (LitString ab)   = do putByte bh 1; put_ bh ab-    put_ bh (LitNullAddr)    = do putByte bh 2+    put_ bh (LitNullAddr)    = putByte bh 2     put_ bh (LitFloat ah)    = do putByte bh 3; put_ bh ah     put_ bh (LitDouble ai)   = do putByte bh 4; put_ bh ai     put_ bh (LitLabel aj mb fod)@@ -219,7 +263,7 @@         = do putByte bh 6              put_ bh nt              put_ bh i-    put_ bh (LitRubbish)     = do putByte bh 7+    put_ bh (LitRubbish b) = do putByte bh 7; put_ bh b     get bh = do             h <- getByte bh             case h of@@ -229,8 +273,7 @@               1 -> do                     ab <- get bh                     return (LitString ab)-              2 -> do-                    return (LitNullAddr)+              2 -> return (LitNullAddr)               3 -> do                     ah <- get bh                     return (LitFloat ah)@@ -247,7 +290,8 @@                     i  <- get bh                     return (LitNumber nt i)               _ -> do-                    return (LitRubbish)+                    b <- get bh+                    return (LitRubbish b)  instance Outputable Literal where     ppr = pprLiteral id@@ -283,32 +327,65 @@ Int/Word range. -} --- | Wrap a literal number according to its type-wrapLitNumber :: Platform -> Literal -> Literal-wrapLitNumber platform v@(LitNumber nt i) = case nt of+-- | Make a literal number using wrapping semantics if the value is out of+-- bound.+mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal+mkLitNumberWrap platform nt i = case nt of   LitNumInt -> case platformWordSize platform of-    PW4 -> LitNumber nt (toInteger (fromIntegral i :: Int32))-    PW8 -> LitNumber nt (toInteger (fromIntegral i :: Int64))+    PW4 -> wrap @Int32+    PW8 -> wrap @Int64   LitNumWord -> case platformWordSize platform of-    PW4 -> LitNumber nt (toInteger (fromIntegral i :: Word32))-    PW8 -> LitNumber nt (toInteger (fromIntegral i :: Word64))-  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64))-  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64))-  LitNumInteger -> v-  LitNumNatural -> v-wrapLitNumber _ x = x+    PW4 -> wrap @Word32+    PW8 -> wrap @Word64+  LitNumInt8    -> wrap @Int8+  LitNumInt16   -> wrap @Int16+  LitNumInt32   -> wrap @Int32+  LitNumInt64   -> wrap @Int64+  LitNumWord8   -> wrap @Word8+  LitNumWord16  -> wrap @Word16+  LitNumWord32  -> wrap @Word32+  LitNumWord64  -> wrap @Word64+  LitNumInteger -> LitNumber nt i+  LitNumNatural+    | i < 0     -> panic "mkLitNumberWrap: trying to create a negative Natural"+    | otherwise -> LitNumber nt i+  where+    wrap :: forall a. (Integral a, Num a) => Literal+    wrap = LitNumber nt (toInteger (fromIntegral i :: a)) --- | Create a numeric 'Literal' of the given type-mkLitNumberWrap :: Platform -> LitNumType -> Integer -> Literal-mkLitNumberWrap platform nt i = wrapLitNumber platform (LitNumber nt i)+-- | Wrap a literal number according to its type using wrapping semantics.+litNumWrap :: Platform -> Literal -> Literal+litNumWrap platform (LitNumber nt i) = mkLitNumberWrap platform nt i+litNumWrap _        l                = pprPanic "litNumWrap" (ppr l) +-- | Coerce a literal number into another using wrapping semantics.+litNumCoerce :: LitNumType -> Platform -> Literal -> Literal+litNumCoerce pt platform (LitNumber _nt i) = mkLitNumberWrap platform pt i+litNumCoerce _  _        l                 = pprPanic "litNumWrapCoerce: not a number" (ppr l)++-- | Narrow a literal number by converting it into another number type and then+-- converting it back to its original type.+litNumNarrow :: LitNumType -> Platform -> Literal -> Literal+litNumNarrow pt platform (LitNumber nt i)+   = case mkLitNumberWrap platform pt i of+      LitNumber _ j -> mkLitNumberWrap platform nt j+      l             -> pprPanic "litNumNarrow: got invalid literal" (ppr l)+litNumNarrow _ _ l = pprPanic "litNumNarrow: invalid literal" (ppr l)++ -- | Check that a given number is in the range of a numeric literal litNumCheckRange :: Platform -> LitNumType -> Integer -> Bool litNumCheckRange platform nt i = case nt of      LitNumInt     -> platformInIntRange platform i      LitNumWord    -> platformInWordRange platform i-     LitNumInt64   -> inInt64Range i-     LitNumWord64  -> inWord64Range i+     LitNumInt8    -> inBoundedRange @Int8 i+     LitNumInt16   -> inBoundedRange @Int16 i+     LitNumInt32   -> inBoundedRange @Int32 i+     LitNumInt64   -> inBoundedRange @Int64 i+     LitNumWord8   -> inBoundedRange @Word8 i+     LitNumWord16  -> inBoundedRange @Word16 i+     LitNumWord32  -> inBoundedRange @Word32 i+     LitNumWord64  -> inBoundedRange @Word64 i      LitNumNatural -> i >= 0      LitNumInteger -> True @@ -327,7 +404,7 @@ --   If the argument is out of the (target-dependent) range, it is wrapped. --   See Note [Word/Int underflow/overflow] mkLitIntWrap :: Platform -> Integer -> Literal-mkLitIntWrap platform i = wrapLitNumber platform $ mkLitIntUnchecked i+mkLitIntWrap platform i = mkLitNumberWrap platform LitNumInt i  -- | Creates a 'Literal' of type @Int#@ without checking its range. mkLitIntUnchecked :: Integer -> Literal@@ -351,7 +428,7 @@ --   If the argument is out of the (target-dependent) range, it is wrapped. --   See Note [Word/Int underflow/overflow] mkLitWordWrap :: Platform -> Integer -> Literal-mkLitWordWrap platform i = wrapLitNumber platform $ mkLitWordUnchecked i+mkLitWordWrap platform i = mkLitNumberWrap platform LitNumWord i  -- | Creates a 'Literal' of type @Word#@ without checking its range. mkLitWordUnchecked :: Integer -> Literal@@ -366,14 +443,92 @@   where     n@(LitNumber _ i') = mkLitWordWrap platform i +-- | Creates a 'Literal' of type @Int8#@+mkLitInt8 :: Integer -> Literal+mkLitInt8  x = ASSERT2( inBoundedRange @Int8 x, integer x ) (mkLitInt8Unchecked x)++-- | Creates a 'Literal' of type @Int8#@.+--   If the argument is out of the range, it is wrapped.+mkLitInt8Wrap :: Integer -> Literal+mkLitInt8Wrap i = mkLitInt8Unchecked (toInteger (fromIntegral i :: Int8))++-- | Creates a 'Literal' of type @Int8#@ without checking its range.+mkLitInt8Unchecked :: Integer -> Literal+mkLitInt8Unchecked i = LitNumber LitNumInt8 i++-- | Creates a 'Literal' of type @Word8#@+mkLitWord8 :: Integer -> Literal+mkLitWord8 x = ASSERT2( inBoundedRange @Word8 x, integer x ) (mkLitWord8Unchecked x)++-- | Creates a 'Literal' of type @Word8#@.+--   If the argument is out of the range, it is wrapped.+mkLitWord8Wrap :: Integer -> Literal+mkLitWord8Wrap i = mkLitWord8Unchecked (toInteger (fromIntegral i :: Word8))++-- | Creates a 'Literal' of type @Word8#@ without checking its range.+mkLitWord8Unchecked :: Integer -> Literal+mkLitWord8Unchecked i = LitNumber LitNumWord8 i++-- | Creates a 'Literal' of type @Int16#@+mkLitInt16 :: Integer -> Literal+mkLitInt16  x = ASSERT2( inBoundedRange @Int16 x, integer x ) (mkLitInt16Unchecked x)++-- | Creates a 'Literal' of type @Int16#@.+--   If the argument is out of the range, it is wrapped.+mkLitInt16Wrap :: Integer -> Literal+mkLitInt16Wrap i = mkLitInt16Unchecked (toInteger (fromIntegral i :: Int16))++-- | Creates a 'Literal' of type @Int16#@ without checking its range.+mkLitInt16Unchecked :: Integer -> Literal+mkLitInt16Unchecked i = LitNumber LitNumInt16 i++-- | Creates a 'Literal' of type @Word16#@+mkLitWord16 :: Integer -> Literal+mkLitWord16 x = ASSERT2( inBoundedRange @Word16 x, integer x ) (mkLitWord16Unchecked x)++-- | Creates a 'Literal' of type @Word16#@.+--   If the argument is out of the range, it is wrapped.+mkLitWord16Wrap :: Integer -> Literal+mkLitWord16Wrap i = mkLitWord16Unchecked (toInteger (fromIntegral i :: Word16))++-- | Creates a 'Literal' of type @Word16#@ without checking its range.+mkLitWord16Unchecked :: Integer -> Literal+mkLitWord16Unchecked i = LitNumber LitNumWord16 i++-- | Creates a 'Literal' of type @Int32#@+mkLitInt32 :: Integer -> Literal+mkLitInt32  x = ASSERT2( inBoundedRange @Int32 x, integer x ) (mkLitInt32Unchecked x)++-- | Creates a 'Literal' of type @Int32#@.+--   If the argument is out of the range, it is wrapped.+mkLitInt32Wrap :: Integer -> Literal+mkLitInt32Wrap i = mkLitInt32Unchecked (toInteger (fromIntegral i :: Int32))++-- | Creates a 'Literal' of type @Int32#@ without checking its range.+mkLitInt32Unchecked :: Integer -> Literal+mkLitInt32Unchecked i = LitNumber LitNumInt32 i++-- | Creates a 'Literal' of type @Word32#@+mkLitWord32 :: Integer -> Literal+mkLitWord32 x = ASSERT2( inBoundedRange @Word32 x, integer x ) (mkLitWord32Unchecked x)++-- | Creates a 'Literal' of type @Word32#@.+--   If the argument is out of the range, it is wrapped.+mkLitWord32Wrap :: Integer -> Literal+mkLitWord32Wrap i = mkLitWord32Unchecked (toInteger (fromIntegral i :: Word32))++-- | Creates a 'Literal' of type @Word32#@ without checking its range.+mkLitWord32Unchecked :: Integer -> Literal+mkLitWord32Unchecked i = LitNumber LitNumWord32 i+ -- | Creates a 'Literal' of type @Int64#@ mkLitInt64 :: Integer -> Literal-mkLitInt64  x = ASSERT2( inInt64Range x, integer x ) (mkLitInt64Unchecked x)+mkLitInt64  x = ASSERT2( inBoundedRange @Int64 x, integer x ) (mkLitInt64Unchecked x)  -- | Creates a 'Literal' of type @Int64#@. --   If the argument is out of the range, it is wrapped.-mkLitInt64Wrap :: Platform -> Integer -> Literal-mkLitInt64Wrap platform i = wrapLitNumber platform $ mkLitInt64Unchecked i+mkLitInt64Wrap :: Integer -> Literal+mkLitInt64Wrap i = mkLitInt64Unchecked (toInteger (fromIntegral i :: Int64))  -- | Creates a 'Literal' of type @Int64#@ without checking its range. mkLitInt64Unchecked :: Integer -> Literal@@ -381,12 +536,12 @@  -- | Creates a 'Literal' of type @Word64#@ mkLitWord64 :: Integer -> Literal-mkLitWord64 x = ASSERT2( inWord64Range x, integer x ) (mkLitWord64Unchecked x)+mkLitWord64 x = ASSERT2( inBoundedRange @Word64 x, integer x ) (mkLitWord64Unchecked x)  -- | Creates a 'Literal' of type @Word64#@. --   If the argument is out of the range, it is wrapped.-mkLitWord64Wrap :: Platform -> Integer -> Literal-mkLitWord64Wrap platform i = wrapLitNumber platform $ mkLitWord64Unchecked i+mkLitWord64Wrap :: Integer -> Literal+mkLitWord64Wrap i = mkLitWord64Unchecked (toInteger (fromIntegral i :: Word64))  -- | Creates a 'Literal' of type @Word64#@ without checking its range. mkLitWord64Unchecked :: Integer -> Literal@@ -420,12 +575,44 @@ inNaturalRange :: Integer -> Bool inNaturalRange x = x >= 0 -inInt64Range, inWord64Range :: Integer -> Bool-inInt64Range x  = x >= toInteger (minBound :: Int64) &&-                  x <= toInteger (maxBound :: Int64)-inWord64Range x = x >= toInteger (minBound :: Word64) &&-                  x <= toInteger (maxBound :: Word64)+inBoundedRange :: forall a. (Bounded a, Integral a) => Integer -> Bool+inBoundedRange x  = x >= toInteger (minBound :: a) &&+                    x <= toInteger (maxBound :: a) +isMinBound :: Platform -> Literal -> Bool+isMinBound _        (LitChar c)        = c == minBound+isMinBound platform (LitNumber nt i)   = case nt of+   LitNumInt     -> i == platformMinInt platform+   LitNumInt8    -> i == toInteger (minBound :: Int8)+   LitNumInt16   -> i == toInteger (minBound :: Int16)+   LitNumInt32   -> i == toInteger (minBound :: Int32)+   LitNumInt64   -> i == toInteger (minBound :: Int64)+   LitNumWord    -> i == 0+   LitNumWord8   -> i == 0+   LitNumWord16  -> i == 0+   LitNumWord32  -> i == 0+   LitNumWord64  -> i == 0+   LitNumNatural -> i == 0+   LitNumInteger -> False+isMinBound _        _                  = False++isMaxBound :: Platform -> Literal -> Bool+isMaxBound _        (LitChar c)        = c == maxBound+isMaxBound platform (LitNumber nt i)   = case nt of+   LitNumInt     -> i == platformMaxInt platform+   LitNumInt8    -> i == toInteger (maxBound :: Int8)+   LitNumInt16   -> i == toInteger (maxBound :: Int16)+   LitNumInt32   -> i == toInteger (maxBound :: Int32)+   LitNumInt64   -> i == toInteger (maxBound :: Int64)+   LitNumWord    -> i == platformMaxWord platform+   LitNumWord8   -> i == toInteger (maxBound :: Word8)+   LitNumWord16  -> i == toInteger (maxBound :: Word16)+   LitNumWord32  -> i == toInteger (maxBound :: Word32)+   LitNumWord64  -> i == toInteger (maxBound :: Word64)+   LitNumNatural -> False+   LitNumInteger -> False+isMaxBound _        _                  = False+ inCharRange :: Char -> Bool inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR @@ -436,6 +623,13 @@ isZeroLit (LitDouble 0)   = True isZeroLit _               = False +-- | Tests whether the literal represents a one of whatever type it is+isOneLit :: Literal -> Bool+isOneLit (LitNumber _ 1) = True+isOneLit (LitFloat  1)   = True+isOneLit (LitDouble 1)   = True+isOneLit _               = False+ -- | Returns the 'Integer' contained in the 'Literal', for when that makes -- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'. litValue  :: Literal -> Integer@@ -458,82 +652,75 @@ mapLitValue  :: Platform -> (Integer -> Integer) -> Literal -> Literal mapLitValue _        f (LitChar   c)      = mkLitChar (fchar c)    where fchar = chr . fromInteger . f . toInteger . ord-mapLitValue platform f (LitNumber nt i)   = wrapLitNumber platform (LitNumber nt (f i))+mapLitValue platform f (LitNumber nt i)   = mkLitNumberWrap platform nt (f i) mapLitValue _        _ l                  = pprPanic "mapLitValue" (ppr l) --- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',--- 'Int', 'Word', 'LitInteger' and 'LitNatural'.-isLitValue  :: Literal -> Bool-isLitValue = isJust . isLitValue_maybe- {-         Coercions         ~~~~~~~~~ -} -narrow8IntLit, narrow16IntLit, narrow32IntLit,-  narrow8WordLit, narrow16WordLit, narrow32WordLit,-  char2IntLit, int2CharLit,-  float2IntLit, int2FloatLit, double2IntLit, int2DoubleLit,-  float2DoubleLit, double2FloatLit+charToIntLit, intToCharLit,+  floatToIntLit, intToFloatLit,+  doubleToIntLit, intToDoubleLit,+  floatToDoubleLit, doubleToFloatLit   :: Literal -> Literal -word2IntLit, int2WordLit :: Platform -> Literal -> Literal-word2IntLit platform (LitNumber LitNumWord w)-  -- Map Word range [max_int+1, max_word]-  -- to Int range   [min_int  , -1]-  -- Range [0,max_int] has the same representation with both Int and Word-  | w > platformMaxInt platform = mkLitInt platform (w - platformMaxWord platform - 1)-  | otherwise                   = mkLitInt platform w-word2IntLit _ l = pprPanic "word2IntLit" (ppr l)--int2WordLit platform (LitNumber LitNumInt i)-  -- Map Int range [min_int  , -1]-  -- to Word range [max_int+1, max_word]-  -- Range [0,max_int] has the same representation with both Int and Word-  | i < 0     = mkLitWord platform (1 + platformMaxWord platform + i)-  | otherwise = mkLitWord platform i-int2WordLit _ l = pprPanic "int2WordLit" (ppr l)- -- | Narrow a literal number (unchecked result range)-narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal-narrowLit _ (LitNumber nt i) = LitNumber nt (toInteger (fromInteger i :: a))-narrowLit _ l                = pprPanic "narrowLit" (ppr l)+narrowLit' :: forall a. Integral a => LitNumType -> Literal -> Literal+narrowLit' nt' (LitNumber _ i)  = LitNumber nt' (toInteger (fromInteger i :: a))+narrowLit' _   l                = pprPanic "narrowLit" (ppr l) -narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)-narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)-narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)-narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)-narrow16WordLit = narrowLit (Proxy :: Proxy Word16)-narrow32WordLit = narrowLit (Proxy :: Proxy Word32)+narrowInt8Lit, narrowInt16Lit, narrowInt32Lit, narrowInt64Lit,+  narrowWord8Lit, narrowWord16Lit, narrowWord32Lit, narrowWord64Lit :: Literal -> Literal+narrowInt8Lit   = narrowLit' @Int8   LitNumInt8+narrowInt16Lit  = narrowLit' @Int16  LitNumInt16+narrowInt32Lit  = narrowLit' @Int32  LitNumInt32+narrowInt64Lit  = narrowLit' @Int64  LitNumInt64+narrowWord8Lit  = narrowLit' @Word8  LitNumWord8+narrowWord16Lit = narrowLit' @Word16 LitNumWord16+narrowWord32Lit = narrowLit' @Word32 LitNumWord32+narrowWord64Lit = narrowLit' @Word64 LitNumWord64 -char2IntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))-char2IntLit l                 = pprPanic "char2IntLit" (ppr l)-int2CharLit (LitNumber _ i)   = LitChar (chr (fromInteger i))-int2CharLit l                 = pprPanic "int2CharLit" (ppr l)+-- | Extend a fixed-width literal (e.g. 'Int16#') to a word-sized literal (e.g.+-- 'Int#').+extendWordLit, extendIntLit :: Platform -> Literal -> Literal+extendWordLit platform (LitNumber _nt i)  = mkLitWord platform i+extendWordLit _platform l                 = pprPanic "extendWordLit" (ppr l)+extendIntLit  platform (LitNumber _nt i)  = mkLitInt platform i+extendIntLit  _platform l                 = pprPanic "extendIntLit" (ppr l) -float2IntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)-float2IntLit l                 = pprPanic "float2IntLit" (ppr l)-int2FloatLit (LitNumber _ i)   = LitFloat (fromInteger i)-int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)+charToIntLit (LitChar c)       = mkLitIntUnchecked (toInteger (ord c))+charToIntLit l                 = pprPanic "charToIntLit" (ppr l)+intToCharLit (LitNumber _ i)   = LitChar (chr (fromInteger i))+intToCharLit l                 = pprPanic "intToCharLit" (ppr l) -double2IntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)-double2IntLit l                 = pprPanic "double2IntLit" (ppr l)-int2DoubleLit (LitNumber _ i)   = LitDouble (fromInteger i)-int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)+floatToIntLit (LitFloat f)      = mkLitIntUnchecked (truncate f)+floatToIntLit l                 = pprPanic "floatToIntLit" (ppr l)+intToFloatLit (LitNumber _ i)   = LitFloat (fromInteger i)+intToFloatLit l                 = pprPanic "intToFloatLit" (ppr l) -float2DoubleLit (LitFloat  f) = LitDouble f-float2DoubleLit l             = pprPanic "float2DoubleLit" (ppr l)-double2FloatLit (LitDouble d) = LitFloat  d-double2FloatLit l             = pprPanic "double2FloatLit" (ppr l)+doubleToIntLit (LitDouble f)     = mkLitIntUnchecked (truncate f)+doubleToIntLit l                 = pprPanic "doubleToIntLit" (ppr l)+intToDoubleLit (LitNumber _ i)   = LitDouble (fromInteger i)+intToDoubleLit l                 = pprPanic "intToDoubleLit" (ppr l) +floatToDoubleLit (LitFloat  f) = LitDouble f+floatToDoubleLit l             = pprPanic "floatToDoubleLit" (ppr l)+doubleToFloatLit (LitDouble d) = LitFloat  d+doubleToFloatLit l             = pprPanic "doubleToFloatLit" (ppr l)+ nullAddrLit :: Literal nullAddrLit = LitNullAddr --- | A nonsense literal of type @forall (a :: 'TYPE' 'UnliftedRep'). a@.-rubbishLit :: Literal-rubbishLit = LitRubbish+-- | A rubbish literal; see Note [Rubbish literals]+rubbishLit :: Bool -> Literal+rubbishLit is_lifted = LitRubbish is_lifted +isRubbishLit :: Literal -> Bool+isRubbishLit (LitRubbish {}) = True+isRubbishLit _               = False+ {-         Predicates         ~~~~~~~~~~@@ -579,8 +766,14 @@   LitNumInteger -> False   LitNumNatural -> False   LitNumInt     -> True+  LitNumInt8    -> True+  LitNumInt16   -> True+  LitNumInt32   -> True   LitNumInt64   -> True   LitNumWord    -> True+  LitNumWord8   -> True+  LitNumWord16  -> True+  LitNumWord32  -> True   LitNumWord64  -> True litIsTrivial _                  = True @@ -592,8 +785,14 @@       LitNumInteger -> platformInIntRange platform i       LitNumNatural -> platformInWordRange platform i       LitNumInt     -> True+      LitNumInt8    -> True+      LitNumInt16   -> True+      LitNumInt32   -> True       LitNumInt64   -> True       LitNumWord    -> True+      LitNumWord8   -> True+      LitNumWord16  -> True+      LitNumWord32  -> True       LitNumWord64  -> True    (LitString _) -> False    _             -> True@@ -608,8 +807,14 @@   LitNumInteger -> True   LitNumNatural -> True   LitNumInt     -> False+  LitNumInt8    -> False+  LitNumInt16   -> False+  LitNumInt32   -> False   LitNumInt64   -> False   LitNumWord    -> False+  LitNumWord8   -> False+  LitNumWord16  -> False+  LitNumWord32  -> False   LitNumWord64  -> False litIsLifted _                  = False @@ -630,12 +835,20 @@    LitNumInteger -> integerTy    LitNumNatural -> naturalTy    LitNumInt     -> intPrimTy+   LitNumInt8    -> int8PrimTy+   LitNumInt16   -> int16PrimTy+   LitNumInt32   -> int32PrimTy    LitNumInt64   -> int64PrimTy    LitNumWord    -> wordPrimTy+   LitNumWord8   -> word8PrimTy+   LitNumWord16  -> word16PrimTy+   LitNumWord32  -> word32PrimTy    LitNumWord64  -> word64PrimTy-literalType (LitRubbish)      = mkForAllTy a Inferred (mkTyVarTy a)+literalType (LitRubbish is_lifted) = mkForAllTy a Inferred (mkTyVarTy a)   where-    a = alphaTyVarUnliftedRep+    -- See Note [Rubbish literals]+    a | is_lifted = alphaTyVar+      | otherwise = alphaTyVarUnliftedRep  absentLiteralOf :: TyCon -> Maybe Literal -- Return a literal of the appropriate primitive@@ -645,6 +858,7 @@ --  2. This would need to return a type application to a literal absentLiteralOf tc = lookupUFM absent_lits tc +-- We do not use TyConEnv here to avoid import cycles. absent_lits :: UniqFM TyCon Literal absent_lits = listToUFM_Directly                         -- Explicitly construct the mape from the known@@ -652,8 +866,14 @@                         [ (addrPrimTyConKey,    LitNullAddr)                         , (charPrimTyConKey,    LitChar 'x')                         , (intPrimTyConKey,     mkLitIntUnchecked 0)+                        , (int8PrimTyConKey,    mkLitInt8Unchecked 0)+                        , (int16PrimTyConKey,   mkLitInt16Unchecked 0)+                        , (int32PrimTyConKey,   mkLitInt32Unchecked 0)                         , (int64PrimTyConKey,   mkLitInt64Unchecked 0)                         , (wordPrimTyConKey,    mkLitWordUnchecked 0)+                        , (word8PrimTyConKey,   mkLitWord8Unchecked 0)+                        , (word16PrimTyConKey,  mkLitWord16Unchecked 0)+                        , (word32PrimTyConKey,  mkLitWord32Unchecked 0)                         , (word64PrimTyConKey,  mkLitWord64Unchecked 0)                         , (floatPrimTyConKey,   LitFloat 0)                         , (doublePrimTyConKey,  LitDouble 0)@@ -670,24 +890,13 @@ cmpLit (LitNullAddr)        (LitNullAddr)         = EQ cmpLit (LitFloat     a)     (LitFloat      b)     = a `compare` b cmpLit (LitDouble    a)     (LitDouble     b)     = a `compare` b-cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `compare` b+cmpLit (LitLabel     a _ _) (LitLabel      b _ _) = a `lexicalCompareFS` b cmpLit (LitNumber nt1 a)    (LitNumber nt2  b)-  | nt1 == nt2 = a   `compare` b-  | otherwise  = nt1 `compare` nt2-cmpLit (LitRubbish)         (LitRubbish)          = EQ+  = (nt1 `compare` nt2) `mappend` (a `compare` b)+cmpLit (LitRubbish b1)      (LitRubbish b2)       = b1 `compare` b2 cmpLit lit1 lit2-  | litTag lit1 < litTag lit2 = LT-  | otherwise                 = GT--litTag :: Literal -> Int-litTag (LitChar      _)   = 1-litTag (LitString    _)   = 2-litTag (LitNullAddr)      = 3-litTag (LitFloat     _)   = 4-litTag (LitDouble    _)   = 5-litTag (LitLabel _ _ _)   = 6-litTag (LitNumber  {})    = 7-litTag (LitRubbish)       = 8+  | isTrue# (dataToTag# lit1 <# dataToTag# lit2) = LT+  | otherwise                                    = GT  {-         Printing@@ -706,15 +915,23 @@        LitNumInteger -> pprIntegerVal add_par i        LitNumNatural -> pprIntegerVal add_par i        LitNumInt     -> pprPrimInt i+       LitNumInt8    -> pprPrimInt8 i+       LitNumInt16   -> pprPrimInt16 i+       LitNumInt32   -> pprPrimInt32 i        LitNumInt64   -> pprPrimInt64 i        LitNumWord    -> pprPrimWord i+       LitNumWord8   -> pprPrimWord8 i+       LitNumWord16  -> pprPrimWord16 i+       LitNumWord32  -> pprPrimWord32 i        LitNumWord64  -> pprPrimWord64 i pprLiteral add_par (LitLabel l mb fod) =     add_par (text "__label" <+> b <+> ppr fod)     where b = case mb of               Nothing -> pprHsString l               Just x  -> doubleQuotes (text (unpackFS l ++ '@':show x))-pprLiteral _       (LitRubbish)     = text "__RUBBISH"+pprLiteral _       (LitRubbish is_lifted)+  = text "__RUBBISH"+    <> parens (if is_lifted then text "lifted" else text "unlifted")  pprIntegerVal :: (SDoc -> SDoc) -> Integer -> SDoc -- See Note [Printing of literals in Core].@@ -749,9 +966,9 @@ LitString       "aaa"# LitNullAddr     "__NULL" LitInt          -1#-LitInt64        -1L#+LitIntN         -1#N LitWord          1##-LitWord64        1L##+LitWordN         1##N LitFloat        -1.0# LitDouble       -1.0## LitInteger      -1                 (-1)@@ -779,37 +996,38 @@ * For primitive types like Int# or Word# we can use any random   value of that type. * But what about /unlifted/ but /boxed/ types like MutVar# or-  Array#?   We need a literal value of that type.+  Array#?  Or /lifted/ but /strict/ values, such as a field of+  a strict data constructor.  For these we use LitRubbish.+  See Note [Absent errors] in GHC.Core.Opt.WorkWrap.Utils.hs -That is 'LitRubbish'.  Since we need a rubbish literal for-many boxed, unlifted types, we say that LitRubbish has type-  LitRubbish :: forall (a :: TYPE UnliftedRep). a+The literal (LitRubbish is_lifted)+has type+  LitRubbish :: forall (a :: TYPE LiftedRep). a     if is_lifted+  LitRubbish :: forall (a :: TYPE UnliftedRep). a   otherwise  So we might see a w/w split like-  $wf x z = let y :: Array# Int = LitRubbish @(Array# Int)+  $wf x z = let y :: Array# Int = (LitRubbish False) @(Array# Int)             in e -Recall that (TYPE UnliftedRep) is the kind of boxed, unlifted-heap pointers.--Here are the moving parts:+Here are the moving parts, but see also Note [Absent errors] in+GHC.Core.Opt.WorkWrap.Utils  * We define LitRubbish as a constructor in GHC.Types.Literal.Literal  * It is given its polymorphic type by Literal.literalType  * GHC.Core.Opt.WorkWrap.Utils.mk_absent_let introduces a LitRubbish for absent-  arguments of boxed, unlifted type.+  arguments of boxed, unlifted type; or boxed, lifted arguments of strict data+  constructors. -* In CoreToSTG we convert (RubishLit @t) to just ().  STG is-  untyped, so it doesn't matter that it points to a lifted-  value. The important thing is that it is a heap pointer,-  which the garbage collector can follow if it encounters it.+* In CoreToSTG we convert (RubishLit @t) to just ().  STG is untyped, so this+  will work OK for both lifted and unlifted (but boxed) values. The important+  thing is that it is a heap pointer, which the garbage collector can follow if+  it encounters it. -  We considered maintaining LitRubbish in STG, and lowering-  it in the code generators, but it seems simpler to do it-  once and for all in CoreToSTG.+  We considered maintaining LitRubbish in STG, and lowering it in the code+  generators, but it seems simpler to do it once and for all in CoreToSTG. -  In GHC.ByteCode.Asm we just lower it as a 0 literal, because-  it's all boxed and lifted to the host GC anyway.+  In GHC.ByteCode.Asm we just lower it as a 0 literal, because it's all boxed to+  the host GC anyway. -}

+ GHC/Types/Meta.hs view

@@ -0,0 +1,53 @@+-- | Metaprogramming types+module GHC.Types.Meta+   ( MetaRequest(..)+   , MetaHook+   , MetaResult -- data constructors not exported to ensure correct response type+   , metaRequestE+   , metaRequestP+   , metaRequestT+   , metaRequestD+   , metaRequestAW+   )+where++import GHC.Prelude++import GHC.Serialized   ( Serialized )++import GHC.Hs+++-- | The supported metaprogramming result types+data MetaRequest+  = MetaE  (LHsExpr GhcPs   -> MetaResult)+  | MetaP  (LPat GhcPs      -> MetaResult)+  | MetaT  (LHsType GhcPs   -> MetaResult)+  | MetaD  ([LHsDecl GhcPs] -> MetaResult)+  | MetaAW (Serialized     -> MetaResult)++-- | data constructors not exported to ensure correct result type+data MetaResult+  = MetaResE  { unMetaResE  :: LHsExpr GhcPs   }+  | MetaResP  { unMetaResP  :: LPat GhcPs      }+  | MetaResT  { unMetaResT  :: LHsType GhcPs   }+  | MetaResD  { unMetaResD  :: [LHsDecl GhcPs] }+  | MetaResAW { unMetaResAW :: Serialized      }++type MetaHook f = MetaRequest -> LHsExpr GhcTc -> f MetaResult++metaRequestE :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)+metaRequestE h = fmap unMetaResE . h (MetaE MetaResE)++metaRequestP :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)+metaRequestP h = fmap unMetaResP . h (MetaP MetaResP)++metaRequestT :: Functor f => MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)+metaRequestT h = fmap unMetaResT . h (MetaT MetaResT)++metaRequestD :: Functor f => MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]+metaRequestD h = fmap unMetaResD . h (MetaD MetaResD)++metaRequestAW :: Functor f => MetaHook f -> LHsExpr GhcTc -> f Serialized+metaRequestAW h = fmap unMetaResAW . h (MetaAW MetaResAW)+

GHC/Types/Name.hs view

@@ -1,3 +1,7 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+ {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -5,11 +9,6 @@ \section[Name]{@Name@: to transmit name info from renamer to typechecker} -} -{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PatternSynonyms #-}- -- | -- #name_types# -- GHC uses several kinds of name internally:@@ -82,11 +81,12 @@  import GHC.Prelude -import {-# SOURCE #-} GHC.Core.TyCo.Rep( TyThing )+import {-# SOURCE #-} GHC.Types.TyThing ( TyThing )  import GHC.Platform import GHC.Types.Name.Occurrence import GHC.Unit.Module+import GHC.Unit.Home import GHC.Types.SrcLoc import GHC.Types.Unique import GHC.Utils.Misc@@ -94,6 +94,7 @@ import GHC.Utils.Binary import GHC.Data.FastString import GHC.Utils.Outputable+import GHC.Utils.Panic  import Control.DeepSeq import Data.Data@@ -108,17 +109,27 @@  -- | A unique, unambiguous name for something, containing information about where -- that thing originated.-data Name = Name {-                n_sort :: NameSort,     -- What sort of name it is-                n_occ  :: !OccName,     -- Its occurrence name-                n_uniq :: {-# UNPACK #-} !Unique,-                n_loc  :: !SrcSpan      -- Definition site-            }+data Name = Name+  { n_sort :: NameSort+    -- ^ What sort of name it is --- NOTE: we make the n_loc field strict to eliminate some potential--- (and real!) space leaks, due to the fact that we don't look at--- the SrcLoc in a Name all that often.+  , n_occ  :: OccName+    -- ^ Its occurrence name.+    --+    -- NOTE: kept lazy to allow known names to be known constructor applications+    -- and to inline better. See Note [Fast comparison for built-in Names] +  , n_uniq :: {-# UNPACK #-} !Unique+    -- ^ Its unique.++  , n_loc  :: !SrcSpan+    -- ^ Definition site+    --+    -- NOTE: we make the n_loc field strict to eliminate some potential+    -- (and real!) space leaks, due to the fact that we don't look at+    -- the SrcLoc in a Name all that often.+  }+ -- See Note [About the NameSorts] data NameSort   = External Module@@ -156,6 +167,36 @@ data BuiltInSyntax = BuiltInSyntax | UserSyntax  {-+Note [Fast comparison for built-in Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this wired-in Name in GHC.Builtin.Names:++   int8TyConName = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey++Ultimately this turns into something like:++   int8TyConName = Name gHC_INT (mkOccName ..."Int8") int8TyConKey++So a comparison like `x == int8TyConName` will turn into `getUnique x ==+int8TyConKey`, nice and efficient.  But if the `n_occ` field is strict, that+definition will look like:++   int8TyCOnName = case (mkOccName..."Int8") of occ ->+                   Name gHC_INT occ int8TyConKey++and now the comparison will not optimise.  This matters even more when there are+numerous comparisons (see #19386):++if | tc == int8TyCon  -> ...+   | tc == int16TyCon -> ...+   ...etc...++when we would like to get a single multi-branched case.++TL;DR: we make the `n_occ` field lazy.+-}++{- Note [About the NameSorts]  1.  Initially, top-level Ids (including locally-defined ones) get External names,@@ -307,7 +348,7 @@ -- each give rise to a fresh module (Ghci1, Ghci2, etc), but they all come -- from the magic 'interactive' package; and all the details are kept in the -- TcLclEnv, TcGblEnv, NOT in the HPT or EPT.--- See Note [The interactive package] in "GHC.Driver.Types"+-- See Note [The interactive package] in "GHC.Runtime.Context"  nameIsLocalOrFrom from name   | Just mod <- nameModule_maybe name = from == mod || isInteractiveModule mod@@ -337,10 +378,10 @@  -- | Returns True if the Name comes from some other package: neither this -- package nor the interactive package.-nameIsFromExternalPackage :: Unit -> Name -> Bool-nameIsFromExternalPackage this_unit name+nameIsFromExternalPackage :: HomeUnit -> Name -> Bool+nameIsFromExternalPackage home_unit name   | Just mod <- nameModule_maybe name-  , moduleUnit mod /= this_unit   -- Not the current unit+  , notHomeModule home_unit mod   -- Not the current unit   , not (isInteractiveModule mod) -- Not the 'interactive' package   = True   | otherwise@@ -400,6 +441,7 @@  -- | Create a name which definitely originates in the given module mkExternalName :: Unique -> Module -> OccName -> SrcSpan -> Name+{-# INLINE mkExternalName #-} -- WATCH OUT! External Names should be in the Name Cache -- (see Note [The Name Cache] in GHC.Iface.Env), so don't just call mkExternalName -- with some fresh unique without populating the Name Cache@@ -409,6 +451,7 @@  -- | Create a name which is actually defined by the compiler itself mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax -> Name+{-# INLINE mkWiredInName #-} mkWiredInName mod occ uniq thing built_in   = Name { n_uniq = uniq,            n_sort = WiredIn mod thing built_in,@@ -623,7 +666,7 @@  pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc -- Print the "M." part of a name, based on whether it's in scope or not--- See Note [Printing original names] in GHC.Driver.Types+-- See Note [Printing original names] in GHC.Types.Name.Ppr pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $     case qualName sty mod occ of              -- See Outputable.QualifyName:       NameQual modname -> ppr modname <> dot       -- Name is in scope

GHC/Types/Name.hs-boot view

@@ -1,5 +1,28 @@-module GHC.Types.Name where+module GHC.Types.Name (+    module GHC.Types.Name,+    module GHC.Types.Name.Occurrence+) where -import GHC.Prelude ()+import GHC.Prelude (Eq)+import {-# SOURCE #-} GHC.Types.Name.Occurrence+import GHC.Types.Unique+import GHC.Utils.Outputable+import Data.Data (Data)  data Name++instance Eq Name+instance Data Name+instance Uniquable Name+instance Outputable Name++class NamedThing a where+    getOccName :: a -> OccName+    getName    :: a -> Name++    getOccName n = nameOccName (getName n)++nameUnique :: Name -> Unique+setNameUnique :: Name -> Unique -> Name+nameOccName :: Name -> OccName+tidyNameOcc :: Name -> OccName -> Name

GHC/Types/Name/Cache.hs view

@@ -16,9 +16,11 @@ import GHC.Types.Name import GHC.Types.Unique.Supply import GHC.Builtin.Types+import GHC.Builtin.Names+ import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Builtin.Names+import GHC.Utils.Panic  #include "HsVersions.h"

GHC/Types/Name/Occurrence.hs view

@@ -52,6 +52,7 @@         mkDFunOcc,         setOccNameSpace,         demoteOccName,+        promoteOccName,         HasOccName(..),          -- ** Derived 'OccName's@@ -105,6 +106,7 @@  import GHC.Utils.Misc import GHC.Types.Unique+import GHC.Builtin.Uniques import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Data.FastString@@ -207,13 +209,21 @@  -- demoteNameSpace lowers the NameSpace if possible.  We can not know -- in advance, since a TvName can appear in an HsTyVar.--- See Note [Demotion] in GHC.Rename.Env+-- See Note [Demotion] in GHC.Rename.Env. demoteNameSpace :: NameSpace -> Maybe NameSpace demoteNameSpace VarName = Nothing demoteNameSpace DataName = Nothing demoteNameSpace TvName = Nothing demoteNameSpace TcClsName = Just DataName +-- promoteNameSpace promotes the NameSpace as follows.+-- See Note [Promotion] in GHC.Rename.Env.+promoteNameSpace :: NameSpace -> Maybe NameSpace+promoteNameSpace DataName = Just TcClsName+promoteNameSpace VarName = Just TvName+promoteNameSpace TcClsName = Nothing+promoteNameSpace TvName = Nothing+ {- ************************************************************************ *                                                                      *@@ -238,7 +248,7 @@ instance Ord OccName where         -- Compares lexicographically, *not* by Unique of the string     compare (OccName sp1 s1) (OccName sp2 s2)-        = (s1  `compare` s2) `thenCmp` (sp1 `compare` sp2)+        = (s1  `lexicalCompareFS` s2) `thenCmp` (sp1 `compare` sp2)  instance Data OccName where   -- don't traverse?@@ -335,12 +345,19 @@ mkClsOccFS = mkOccNameFS clsName  -- demoteOccName lowers the Namespace of OccName.--- see Note [Demotion]+-- See Note [Demotion] in GHC.Rename.Env. demoteOccName :: OccName -> Maybe OccName demoteOccName (OccName space name) = do   space' <- demoteNameSpace space   return $ OccName space' name +-- promoteOccName promotes the NameSpace of OccName.+-- See Note [Promotion] in GHC.Rename.Env.+promoteOccName :: OccName -> Maybe OccName+promoteOccName (OccName space name) = do+  space' <- promoteNameSpace space+  return $ OccName space' name+ -- Name spaces are related if there is a chance to mean the one when one writes -- the other, i.e. variables <-> data constructors and type variables <-> type constructors nameSpacesRelated :: NameSpace -> NameSpace -> Bool@@ -629,7 +646,7 @@ mkInstTyCoOcc       = mk_simple_deriv tcName   "D:"   -- Coercion for type functions mkEqPredCoOcc       = mk_simple_deriv tcName   "$co" --- Used in derived instances for the names of auxilary bindings.+-- Used in derived instances for the names of auxiliary bindings. -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate. mkCon2TagOcc        = mk_simple_deriv varName  "$con2tag_" mkTag2ConOcc        = mk_simple_deriv varName  "$tag2con_"@@ -889,21 +906,21 @@ -}  instance Binary NameSpace where-    put_ bh VarName = do+    put_ bh VarName =             putByte bh 0-    put_ bh DataName = do+    put_ bh DataName =             putByte bh 1-    put_ bh TvName = do+    put_ bh TvName =             putByte bh 2-    put_ bh TcClsName = do+    put_ bh TcClsName =             putByte bh 3     get bh = do             h <- getByte bh             case h of-              0 -> do return VarName-              1 -> do return DataName-              2 -> do return TvName-              _ -> do return TcClsName+              0 -> return VarName+              1 -> return DataName+              2 -> return TvName+              _ -> return TcClsName  instance Binary OccName where     put_ bh (OccName aa ab) = do

GHC/Types/Name/Occurrence.hs-boot view

@@ -1,5 +1,13 @@ module GHC.Types.Name.Occurrence where -import GHC.Prelude ()+import GHC.Prelude (String)+import GHC.Data.FastString  data OccName++class HasOccName name where+  occName :: name -> OccName++occNameString :: OccName -> String+mkRecFldSelOcc :: String -> OccName+mkVarOccFS :: FastString -> OccName

+ GHC/Types/Name/Ppr.hs view

@@ -0,0 +1,169 @@+{-# LANGUAGE CPP #-}++module GHC.Types.Name.Ppr+   ( mkPrintUnqualified+   , mkQualModule+   , mkQualPackage+   , pkgQual+   )+where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.State++import GHC.Core.TyCon++import GHC.Types.Name+import GHC.Types.Name.Reader++import GHC.Builtin.Types++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+++{-+Note [Printing original names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deciding how to print names is pretty tricky.  We are given a name+P:M.T, where P is the package name, M is the defining module, and T is+the occurrence name, and we have to decide in which form to display+the name given a GlobalRdrEnv describing the current scope.++Ideally we want to display the name in the form in which it is in+scope.  However, the name might not be in scope at all, and that's+where it gets tricky.  Here are the cases:++ 1. T uniquely maps to  P:M.T      --->  "T"      NameUnqual+ 2. There is an X for which X.T+       uniquely maps to  P:M.T     --->  "X.T"    NameQual X+ 3. There is no binding for "M.T"  --->  "M.T"    NameNotInScope1+ 4. Otherwise                      --->  "P:M.T"  NameNotInScope2++(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at+all. In these cases we still want to refer to the name as "M.T", *but*+"M.T" might mean something else in the current scope (e.g. if there's+an "import X as M"), so to avoid confusion we avoid using "M.T" if+there's already a binding for it.  Instead we write P:M.T.++There's one further subtlety: in case (3), what if there are two+things around, P1:M.T and P2:M.T?  Then we don't want to print both of+them as M.T!  However only one of the modules P1:M and P2:M can be+exposed (say P2), so we use M.T for that, and P1:M.T for the other one.+This is handled by the qual_mod component of PrintUnqualified, inside+the (ppr mod) of case (3), in Name.pprModulePrefix++Note [Printing unit ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the old days, original names were tied to PackageIds, which directly+corresponded to the entities that users wrote in Cabal files, and were perfectly+suitable for printing when we need to disambiguate packages.  However, with+instantiated units, the situation can be different: if the key is instantiated+with some holes, we should try to give the user some more useful information.+-}++-- | Creates some functions that work out the best ways to format+-- names for the user according to a set of heuristics.+mkPrintUnqualified :: UnitEnv -> GlobalRdrEnv -> PrintUnqualified+mkPrintUnqualified unit_env env+ = QueryQualify qual_name+      (mkQualModule unit_state home_unit)+      (mkQualPackage unit_state)+  where+  unit_state = ue_units unit_env+  home_unit  = ue_home_unit unit_env+  qual_name mod occ+        | [gre] <- unqual_gres+        , right_name gre+        = NameUnqual   -- If there's a unique entity that's in scope+                       -- unqualified with 'occ' AND that entity is+                       -- the right one, then we can use the unqualified name++        | [] <- unqual_gres+        , any is_name forceUnqualNames+        , not (isDerivedOccName occ)+        = NameUnqual   -- Don't qualify names that come from modules+                       -- that come with GHC, often appear in error messages,+                       -- but aren't typically in scope. Doing this does not+                       -- cause ambiguity, and it reduces the amount of+                       -- qualification in error messages thus improving+                       -- readability.+                       --+                       -- A motivating example is 'Constraint'. It's often not+                       -- in scope, but printing GHC.Prim.Constraint seems+                       -- overkill.++        | [gre] <- qual_gres+        = NameQual (greQualModName gre)++        | null qual_gres+        = if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)+          then NameNotInScope1+          else NameNotInScope2++        | otherwise+        = NameNotInScope1   -- Can happen if 'f' is bound twice in the module+                            -- Eg  f = True; g = 0; f = False+      where+        is_name :: Name -> Bool+        is_name name = ASSERT2( isExternalName name, ppr name )+                       nameModule name == mod && nameOccName name == occ++        forceUnqualNames :: [Name]+        forceUnqualNames =+          map tyConName [ constraintKindTyCon, heqTyCon, coercibleTyCon ]+          ++ [ eqTyConName ]++        right_name gre = greDefinitionModule gre == Just mod++        unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env+        qual_gres   = filter right_name (lookupGlobalRdrEnv env occ)++    -- we can mention a module P:M without the P: qualifier iff+    -- "import M" would resolve unambiguously to P:M.  (if P is the+    -- current package we can just assume it is unqualified).++-- | Creates a function for formatting modules based on two heuristics:+-- (1) if the module is the current module, don't qualify, and (2) if there+-- is only one exposed package which exports this module, don't qualify.+mkQualModule :: UnitState -> HomeUnit -> QueryQualifyModule+mkQualModule unit_state home_unit mod+     | isHomeModule home_unit mod = False++     | [(_, pkgconfig)] <- lookup,+       mkUnit pkgconfig == moduleUnit mod+        -- this says: we are given a module P:M, is there just one exposed package+        -- that exposes a module M, and is it package P?+     = False++     | otherwise = True+     where lookup = lookupModuleInAllUnits unit_state (moduleName mod)++-- | Creates a function for formatting packages based on two heuristics:+-- (1) don't qualify if the package in question is "main", and (2) only qualify+-- with a unit id if the package ID would be ambiguous.+mkQualPackage :: UnitState -> QueryQualifyPackage+mkQualPackage pkgs uid+     | uid == mainUnit || uid == interactiveUnit+        -- Skip the lookup if it's main, since it won't be in the package+        -- database!+     = False+     | Just pkgid <- mb_pkgid+     , searchPackageId pkgs pkgid `lengthIs` 1+        -- this says: we are given a package pkg-0.1@MMM, are there only one+        -- exposed packages whose package ID is pkg-0.1?+     = False+     | otherwise+     = True+     where mb_pkgid = fmap unitPackageId (lookupUnit pkgs uid)++-- | A function which only qualifies package names if necessary; but+-- qualifies all other identifiers.+pkgQual :: UnitState -> PrintUnqualified+pkgQual pkgs = alwaysQualify { queryQualifyPackage = mkQualPackage pkgs }

GHC/Types/Name/Reader.hs view

@@ -32,7 +32,7 @@         nameRdrName, getRdrName,          -- ** Destruction-        rdrNameOcc, rdrNameSpace, demoteRdrName,+        rdrNameOcc, rdrNameSpace, demoteRdrName, promoteRdrName,         isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual,         isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, @@ -46,7 +46,8 @@         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,         lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,         pprGlobalRdrEnv, globalRdrEnvElts,-        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,+        lookupGRE_RdrName, lookupGRE_RdrName', lookupGRE_Name,+        lookupGRE_GreName, lookupGRE_FieldLabel,         lookupGRE_Name_OccName,         getGRE_NameQualifier_maybes,         transformGREs, pickGREs, pickGREsModExp,@@ -55,17 +56,25 @@         gresFromAvails, gresFromAvail, localGREsFromAvail, availFromGRE,         greRdrNames, greSrcSpan, greQualModName,         gresToAvailInfo,+        greDefinitionModule, greDefinitionSrcSpan,+        greMangledName, grePrintableName,+        greFieldLabel,          -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec'-        GlobalRdrElt(..), isLocalGRE, isRecFldGRE, isOverloadedRecFldGRE, greLabel,+        GlobalRdrElt(..), isLocalGRE, isRecFldGRE,+        isDuplicateRecFldGRE, isNoFieldSelectorGRE, isFieldSelectorGRE,         unQualOK, qualSpecOK, unQualSpecOK,         pprNameProvenance,+        GreName(..), greNameSrcSpan,         Parent(..), greParent_maybe,         ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),         importSpecLoc, importSpecModule, isExplicitItem, bestImport,          -- * Utils for StarIsType-        starInfo+        starInfo,++        -- * Utils+        opIsAt,   ) where  #include "HsVersions.h"@@ -85,6 +94,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set import GHC.Utils.Misc as Utils+import GHC.Utils.Panic import GHC.Types.Name.Env  import Data.Data@@ -117,7 +127,7 @@ --           'GHC.Parser.Annotation.AnnVal' --           'GHC.Parser.Annotation.AnnTilde', --- For details on above see note [Api annotations] in "GHC.Parser.Annotation"+-- For details on above see note [exact print annotations] in "GHC.Parser.Annotation" data RdrName   = Unqual OccName         -- ^ Unqualified  name@@ -178,13 +188,21 @@ rdrNameSpace = occNameSpace . rdrNameOcc  -- demoteRdrName lowers the NameSpace of RdrName.--- see Note [Demotion] in GHC.Types.Name.Occurrence+-- See Note [Demotion] in GHC.Rename.Env demoteRdrName :: RdrName -> Maybe RdrName demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ) demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ) demoteRdrName (Orig _ _) = Nothing demoteRdrName (Exact _) = Nothing +-- promoteRdrName promotes the NameSpace of RdrName.+-- See Note [Promotion] in GHC.Rename.Env.+promoteRdrName :: RdrName -> Maybe RdrName+promoteRdrName (Unqual occ) = fmap Unqual (promoteOccName occ)+promoteRdrName (Qual m occ) = fmap (Qual m) (promoteOccName occ)+promoteRdrName (Orig _ _) = Nothing+promoteRdrName (Exact _)  = Nothing+         -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ@@ -338,13 +356,24 @@ ************************************************************************ -} +{- Note [LocalRdrEnv]+~~~~~~~~~~~~~~~~~~~~~+The LocalRdrEnv is used to store local bindings (let, where, lambda, case).++* It is keyed by OccName, because we never use it for qualified names.++* It maps the OccName to a Name.  That Name is almost always an+  Internal Name, but (hackily) it can be External too for top-level+  pattern bindings.  See Note [bindLocalNames for an External name]+  in GHC.Rename.Pat++* We keep the current mapping (lre_env), *and* the set of all Names in+  scope (lre_in_scope).  Reason: see Note [Splicing Exact names] in+  GHC.Rename.Env.+-}+ -- | Local Reader Environment------ This environment is used to store local bindings--- (@let@, @where@, lambda, @case@).--- It is keyed by OccName, because we never use it for qualified names--- We keep the current mapping, *and* the set of all Names in scope--- Reason: see Note [Splicing Exact names] in "GHC.Rename.Env"+-- See Note [LocalRdrEnv] data LocalRdrEnv = LRE { lre_env      :: OccEnv Name                        , lre_in_scope :: NameSet } @@ -364,16 +393,15 @@                        , lre_in_scope = emptyNameSet }  extendLocalRdrEnv :: LocalRdrEnv -> Name -> LocalRdrEnv--- The Name should be a non-top-level thing+-- See Note [LocalRdrEnv] extendLocalRdrEnv lre@(LRE { lre_env = env, lre_in_scope = ns }) name-  = WARN( isExternalName name, ppr name )-    lre { lre_env      = extendOccEnv env (nameOccName name) name+  = lre { lre_env      = extendOccEnv env (nameOccName name) name         , lre_in_scope = extendNameSet ns name }  extendLocalRdrEnvList :: LocalRdrEnv -> [Name] -> LocalRdrEnv+-- See Note [LocalRdrEnv] extendLocalRdrEnvList lre@(LRE { lre_env = env, lre_in_scope = ns }) names-  = WARN( any isExternalName names, ppr names )-    lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]+  = lre { lre_env = extendOccEnvList env [(nameOccName n, n) | n <- names]         , lre_in_scope = extendNameSetList ns names }  lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name@@ -451,42 +479,35 @@ --                 greOccName gre = occ -- --              NB: greOccName gre is usually the same as---                  nameOccName (gre_name gre), but not always in the---                  case of record selectors; see greOccName+--                  nameOccName (greMangledName gre), but not always in the+--                  case of record selectors; see Note [GreNames]  -- | Global Reader Element -- -- An element of the 'GlobalRdrEnv' data GlobalRdrElt-  = GRE { gre_name :: Name-        , gre_par  :: Parent+  = GRE { gre_name :: GreName      -- ^ See Note [GreNames]+        , gre_par  :: Parent       -- ^ See Note [Parents]         , gre_lcl :: Bool          -- ^ True <=> the thing was defined locally         , gre_imp :: [ImportSpec]  -- ^ In scope through these imports     } deriving (Data, Eq)          -- INVARIANT: either gre_lcl = True or gre_imp is non-empty          -- See Note [GlobalRdrElt provenance] --- | The children of a Name are the things that are abbreviated by the ".."---   notation in export lists.  See Note [Parents]+-- | See Note [Parents] data Parent = NoParent             | ParentIs  { par_is :: Name }-            | FldParent { par_is :: Name, par_lbl :: Maybe FieldLabelString }-              -- ^ See Note [Parents for record fields]             deriving (Eq, Data)  instance Outputable Parent where    ppr NoParent        = empty    ppr (ParentIs n)    = text "parent:" <> ppr n-   ppr (FldParent n f) = text "fldparent:"-                             <> ppr n <> colon <> ppr f  plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _)    p2 = hasParent p1 p2-plusParent p1@(FldParent _ _) p2 = hasParent p1 p2 plusParent p1 p2@(ParentIs _)    = hasParent p2 p1-plusParent p1 p2@(FldParent _ _) = hasParent p2 p1-plusParent _ _                   = NoParent+plusParent NoParent NoParent     = NoParent  hasParent :: Parent -> Parent -> Parent #if defined(DEBUG)@@ -523,10 +544,15 @@  In A.hs, 'T' is locally bound, *and* imported as B.T. + Note [Parents] ~~~~~~~~~~~~~~~~~+The children of a Name are the things that are abbreviated by the ".." notation+in export lists.++~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   Parent           Children-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~   data T           Data constructors                    Record-field ids @@ -536,51 +562,66 @@   class C          Class operations                    Associated type constructors -~~~~~~~~~~~~~~~~~~~~~~~~~- Constructor      Meaning- ~~~~~~~~~~~~~~~~~~~~~~~~-  NoParent        Can not be bundled with a type constructor.-  ParentIs n      Can be bundled with the type constructor corresponding to-                  n.-  FldParent       See Note [Parents for record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Constructor      Meaning+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  NoParent         Not bundled with a type constructor.+  ParentIs n       Bundled with the type constructor corresponding to n. +Pattern synonym constructors (and their record fields, if any) are unusual:+their gre_par is NoParent in the module in which they are defined.  However, a+pattern synonym can be bundled with a type constructor on export, in which case+whenever the pattern synonym is imported the gre_par will be ParentIs. +Thus the gre_name and gre_par fields are independent, because a normal datatype+introduces FieldGreNames using ParentIs, but a record pattern synonym can+introduce FieldGreNames that use NoParent. (In the past we represented fields+using an additional constructor of the Parent type, which could not adequately+represent this situation.) See also+Note [Representing pattern synonym fields in AvailInfo] in GHC.Types.Avail.  -Note [Parents for record fields]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For record fields, in addition to the Name of the type constructor-(stored in par_is), we use FldParent to store the field label.  This-extra information is used for identifying overloaded record fields-during renaming.--In a definition arising from a normal module (without--XDuplicateRecordFields), par_lbl will be Nothing, meaning that the-field's label is the same as the OccName of the selector's Name.  The-GlobalRdrEnv will contain an entry like this:+Note [GreNames]+~~~~~~~~~~~~~~~+A `GlobalRdrElt` has a field `gre_name :: GreName`, which uniquely+identifies what the `GlobalRdrElt` describes.  There are two sorts of+`GreName` (see the data type decl): -    "x" |->  GRE x (FldParent T Nothing) LocalDef+* NormalGreName Name: this is used for most entities; the Name+  uniquely identifies it. It is stored in the GlobalRdrEnv under+  the OccName of the Name. -When -XDuplicateRecordFields is enabled for the module that contains-T, the selector's Name will be mangled (see comments in GHC.Types.FieldLabel).-Thus we store the actual field label in par_lbl, and the GlobalRdrEnv-entry looks like this:+* FieldGreName FieldLabel: is used only for field labels of a+  record. With -XDuplicateRecordFields there may be many field+  labels `x` in scope; e.g.+     data T1 = MkT1 { x :: Int }+     data T2 = MkT2 { x :: Bool }+  Each has a different GlobalRdrElt with a distinct GreName.+  The two fields are uniquely identified by their record selectors,+  which are stored in the FieldLabel, and have mangled names like+  `$sel:x:MkT1`.  See Note [FieldLabel] in GHC.Types.FieldLabel. -    "x" |->  GRE $sel:x:MkT (FldParent T (Just "x")) LocalDef+  These GREs are stored in the GlobalRdrEnv under the OccName of the+  field (i.e. "x" in both cases above), /not/ the OccName of the mangled+  record selector function. -Note that the OccName used when adding a GRE to the environment-(greOccName) now depends on the parent field: for FldParent it is the-field label, if present, rather than the selector name.+A GreName, and hence a GRE, has both a "printable" and a "mangled" Name.  These+are identical for normal names, but for record fields compiled with+-XDuplicateRecordFields they will differ. So we have two pairs of functions: -~~+ * greNameMangledName :: GreName -> Name+   greMangledName :: GlobalRdrElt -> Name+   The "mangled" Name is the actual Name of the selector function,+   e.g. $sel:x:MkT1.  This should not be displayed to the user, but is used to+   uniquely identify the field in the renamer, and later in the backend. -Record pattern synonym selectors are treated differently. Their parent-information is `NoParent` in the module in which they are defined. This is because-a pattern synonym `P` has no parent constructor either.+ * greNamePrintableName :: GreName -> Name+   grePrintableName :: GlobalRdrElt -> Name+   The "printable" Name is the "manged" Name with its OccName replaced with that+   of the field label.  This is how the field should be output to the user. -However, if `f` is bundled with a type constructor `T` then whenever `f` is-imported the parent will use the `Parent` constructor so the parent of `f` is-now `T`.+Since the right Name to use is context-dependent, we do not define a NamedThing+instance for GREName (or GlobalRdrElt), but instead make the choice explicit.   Note [Combining parents]@@ -630,32 +671,52 @@     mk_gre n       = case prov_fn n of  -- Nothing => bound locally                            -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = n, gre_par = mkParent n avail+          Nothing -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail                          , gre_lcl = True, gre_imp = [] }-          Just is -> GRE { gre_name = n, gre_par = mkParent n avail+          Just is -> GRE { gre_name = NormalGreName n, gre_par = mkParent n avail                          , gre_lcl = False, gre_imp = [is] } -    mk_fld_gre (FieldLabel { flLabel = lbl, flIsOverloaded = is_overloaded-                           , flSelector = n })-      = case prov_fn n of  -- Nothing => bound locally+    mk_fld_gre fl+      = case prov_fn (flSelector fl) of  -- Nothing => bound locally                            -- Just is => imported from 'is'-          Nothing -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+          Nothing -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail                          , gre_lcl = True, gre_imp = [] }-          Just is -> GRE { gre_name = n, gre_par = FldParent (availName avail) mb_lbl+          Just is -> GRE { gre_name = FieldGreName fl, gre_par = availParent avail                          , gre_lcl = False, gre_imp = [is] }-      where-        mb_lbl | is_overloaded = Just lbl-               | otherwise     = Nothing +instance HasOccName GlobalRdrElt where+  occName = greOccName +-- | See Note [GreNames]+greOccName :: GlobalRdrElt -> OccName+greOccName = occName . gre_name++-- | A 'Name' for the GRE for internal use.  Careful: the 'OccName' of this+-- 'Name' is not necessarily the same as the 'greOccName' (see Note [GreNames]).+greMangledName :: GlobalRdrElt -> Name+greMangledName = greNameMangledName . gre_name++-- | A 'Name' for the GRE suitable for output to the user.  Its 'OccName' will+-- be the 'greOccName' (see Note [GreNames]).+grePrintableName :: GlobalRdrElt -> Name+grePrintableName = greNamePrintableName . gre_name++-- | The SrcSpan of the name pointed to by the GRE.+greDefinitionSrcSpan :: GlobalRdrElt -> SrcSpan+greDefinitionSrcSpan = nameSrcSpan . greMangledName++-- | The module in which the name pointed to by the GRE is defined.+greDefinitionModule :: GlobalRdrElt -> Maybe Module+greDefinitionModule = nameModule_maybe . greMangledName+ greQualModName :: GlobalRdrElt -> ModuleName -- Get a suitable module qualifier for the GRE -- (used in mkPrintUnqualified)--- Prerecondition: the gre_name is always External-greQualModName gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })- | lcl, Just mod <- nameModule_maybe name = moduleName mod- | (is:_) <- iss                          = is_as (is_decl is)- | otherwise                              = pprPanic "greQualModName" (ppr gre)+-- Prerecondition: the greMangledName is always External+greQualModName gre@(GRE { gre_lcl = lcl, gre_imp = iss })+ | lcl, Just mod <- greDefinitionModule gre = moduleName mod+ | (is:_) <- iss                            = is_as (is_decl is)+ | otherwise                                = pprPanic "greQualModName" (ppr gre)  greRdrNames :: GlobalRdrElt -> [RdrName] greRdrNames gre@GRE{ gre_lcl = lcl, gre_imp = iss }@@ -674,21 +735,25 @@ -- declaration.  We want to sort the export locations in -- exportClashErr by this SrcSpan, we need to extract it: greSrcSpan :: GlobalRdrElt -> SrcSpan-greSrcSpan gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss } )-  | lcl           = nameSrcSpan name+greSrcSpan gre@(GRE { gre_lcl = lcl, gre_imp = iss } )+  | lcl           = greDefinitionSrcSpan gre   | (is:_) <- iss = is_dloc (is_decl is)   | otherwise     = pprPanic "greSrcSpan" (ppr gre)  mkParent :: Name -> AvailInfo -> Parent-mkParent _ (Avail _)           = NoParent-mkParent n (AvailTC m _ _) | n == m    = NoParent+mkParent _ (Avail _)                 = NoParent+mkParent n (AvailTC m _) | n == m    = NoParent                          | otherwise = ParentIs m +availParent :: AvailInfo -> Parent+availParent (AvailTC m _) = ParentIs m+availParent (Avail {})    = NoParent++ greParent_maybe :: GlobalRdrElt -> Maybe Name greParent_maybe gre = case gre_par gre of                         NoParent      -> Nothing                         ParentIs n    -> Just n-                        FldParent n _ -> Just n  -- | Takes a list of distinct GREs and folds them -- into AvailInfos. This is more efficient than mapping each individual@@ -711,46 +776,34 @@       = ( extendNameEnv_Acc comb availFromGRE env key gre         , done `extendNameSet` name )       where-        name = gre_name gre+        name = greMangledName gre         key = case greParent_maybe gre of                  Just parent -> parent-                 Nothing     -> gre_name gre+                 Nothing     -> greMangledName gre          -- We want to insert the child `k` into a list of children but         -- need to maintain the invariant that the parent is first.         --         -- We also use the invariant that `k` is not already in `ns`.-        insertChildIntoChildren :: Name -> [Name] -> Name -> [Name]+        insertChildIntoChildren :: Name -> [GreName] -> GreName -> [GreName]         insertChildIntoChildren _ [] k = [k]         insertChildIntoChildren p (n:ns) k-          | p == k = k:n:ns+          | NormalGreName p == k = k:n:ns           | otherwise = n:k:ns          comb :: GlobalRdrElt -> AvailInfo -> AvailInfo-        comb _ (Avail n) = Avail n -- Duplicated name, should not happen-        comb gre (AvailTC m ns fls)+        comb _   (Avail n) = Avail n -- Duplicated name, should not happen+        comb gre (AvailTC m ns)           = case gre_par gre of-              NoParent    -> AvailTC m (name:ns) fls -- Not sure this ever happens-              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns name) fls-              FldParent _ mb_lbl -> AvailTC m ns (mkFieldLabel name mb_lbl : fls)+              NoParent    -> AvailTC m (gre_name gre:ns) -- Not sure this ever happens+              ParentIs {} -> AvailTC m (insertChildIntoChildren m ns (gre_name gre))  availFromGRE :: GlobalRdrElt -> AvailInfo-availFromGRE (GRE { gre_name = me, gre_par = parent })+availFromGRE (GRE { gre_name = child, gre_par = parent })   = case parent of-      ParentIs p                  -> AvailTC p [me] []-      NoParent   | isTyConName me -> AvailTC me [me] []-                 | otherwise      -> avail   me-      FldParent p mb_lbl -> AvailTC p [] [mkFieldLabel me mb_lbl]--mkFieldLabel :: Name -> Maybe FastString -> FieldLabel-mkFieldLabel me mb_lbl =-          case mb_lbl of-                 Nothing  -> FieldLabel { flLabel = occNameFS (nameOccName me)-                                        , flIsOverloaded = False-                                        , flSelector = me }-                 Just lbl -> FieldLabel { flLabel = lbl-                                        , flIsOverloaded = True-                                        , flSelector = me }+      ParentIs p -> AvailTC p [child]+      NoParent | NormalGreName me <- child, isTyConName me -> AvailTC me [child]+               | otherwise -> Avail child  emptyGlobalRdrEnv :: GlobalRdrEnv emptyGlobalRdrEnv = emptyOccEnv@@ -759,7 +812,7 @@ globalRdrEnvElts env = foldOccEnv (++) [] env  instance Outputable GlobalRdrElt where-  ppr gre = hang (ppr (gre_name gre) <+> ppr (gre_par gre))+  ppr gre = hang (ppr (greMangledName gre) <+> ppr (gre_par gre))                2 (pprNameProvenance gre)  pprGlobalRdrEnv :: Bool -> GlobalRdrEnv -> SDoc@@ -777,19 +830,23 @@                      <> colon)                  2 (vcat (map ppr gres))       where-        occ = nameOccName (gre_name (head gres))+        occ = nameOccName (greMangledName (head gres))  lookupGlobalRdrEnv :: GlobalRdrEnv -> OccName -> [GlobalRdrElt] lookupGlobalRdrEnv env occ_name = case lookupOccEnv env occ_name of                                   Nothing   -> []                                   Just gres -> gres -greOccName :: GlobalRdrElt -> OccName-greOccName (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = mkVarOccFS lbl-greOccName gre                                            = nameOccName (gre_name gre)- lookupGRE_RdrName :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]-lookupGRE_RdrName rdr_name env+-- ^ Look for this 'RdrName' in the global environment.  Omits record fields+-- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env).+lookupGRE_RdrName rdr_name env =+    filter (not . isNoFieldSelectorGRE) (lookupGRE_RdrName' rdr_name env)++lookupGRE_RdrName' :: RdrName -> GlobalRdrEnv -> [GlobalRdrElt]+-- ^ Look for this 'RdrName' in the global environment.  Includes record fields+-- without selector functions (see Note [NoFieldSelectors] in GHC.Rename.Env).+lookupGRE_RdrName' rdr_name env   = case lookupOccEnv env (rdrNameOcc rdr_name) of     Nothing   -> []     Just gres -> pickGREs rdr_name gres@@ -801,20 +858,27 @@ lookupGRE_Name env name   = lookupGRE_Name_OccName env name (nameOccName name) +lookupGRE_GreName :: GlobalRdrEnv -> GreName -> Maybe GlobalRdrElt+-- ^ Look for precisely this 'GreName' in the environment.  This tests+-- whether it is in scope, ignoring anything else that might be in+-- scope with the same 'OccName'.+lookupGRE_GreName env gname+  = lookupGRE_Name_OccName env (greNameMangledName gname) (occName gname)+ lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt -- ^ Look for a particular record field selector in the environment, where the -- selector name and field label may be different: the GlobalRdrEnv is keyed on--- the label.  See Note [Parents for record fields] for why this happens.+-- the label.  See Note [GreNames] for why this happens. lookupGRE_FieldLabel env fl   = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))  lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt -- ^ Look for precisely this 'Name' in the environment, but with an 'OccName' -- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and--- Note [Parents for record fields].+-- Note [GreNames]. lookupGRE_Name_OccName env name occ   = case [ gre | gre <- lookupGlobalRdrEnv env occ-               , gre_name gre == name ] of+               , greMangledName gre == name ] of       []    -> Nothing       [gre] -> Just gre       gres  -> pprPanic "lookupGRE_Name_OccName"@@ -839,21 +903,30 @@ isLocalGRE (GRE {gre_lcl = lcl }) = lcl  isRecFldGRE :: GlobalRdrElt -> Bool-isRecFldGRE (GRE {gre_par = FldParent{}}) = True-isRecFldGRE _                             = False+isRecFldGRE = isJust . greFieldLabel -isOverloadedRecFldGRE :: GlobalRdrElt -> Bool+isDuplicateRecFldGRE :: GlobalRdrElt -> Bool -- ^ Is this a record field defined with DuplicateRecordFields?--- (See Note [Parents for record fields])-isOverloadedRecFldGRE (GRE {gre_par = FldParent{par_lbl = Just _}}) = True-isOverloadedRecFldGRE _                                             = False+-- (See Note [GreNames])+isDuplicateRecFldGRE =+    maybe False ((DuplicateRecordFields ==) . flHasDuplicateRecordFields) . greFieldLabel --- Returns the field label of this GRE, if it has one-greLabel :: GlobalRdrElt -> Maybe FieldLabelString-greLabel (GRE{gre_par = FldParent{par_lbl = Just lbl}}) = Just lbl-greLabel (GRE{gre_name = n, gre_par = FldParent{}})     = Just (occNameFS (nameOccName n))-greLabel _                                              = Nothing+isNoFieldSelectorGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with NoFieldSelectors?+-- (See Note [NoFieldSelectors] in GHC.Rename.Env)+isNoFieldSelectorGRE =+    maybe False ((NoFieldSelectors ==) . flHasFieldSelector) . greFieldLabel +isFieldSelectorGRE :: GlobalRdrElt -> Bool+-- ^ Is this a record field defined with FieldSelectors?+-- (See Note [NoFieldSelectors] in GHC.Rename.Env)+isFieldSelectorGRE =+    maybe False ((FieldSelectors ==) . flHasFieldSelector) . greFieldLabel++greFieldLabel :: GlobalRdrElt -> Maybe FieldLabel+-- ^ Returns the field label of this GRE, if it has one+greFieldLabel = greNameFieldLabel . gre_name+ unQualOK :: GlobalRdrElt -> Bool -- ^ Test if an unqualified version of this thing would be in scope unQualOK (GRE {gre_lcl = lcl, gre_imp = iss })@@ -914,17 +987,17 @@     iss' = filter unQualSpecOK iss  pickQualGRE :: ModuleName -> GlobalRdrElt -> Maybe GlobalRdrElt-pickQualGRE mod gre@(GRE { gre_name = n, gre_lcl = lcl, gre_imp = iss })+pickQualGRE mod gre@(GRE { gre_lcl = lcl, gre_imp = iss })   | not lcl', null iss' = Nothing   | otherwise           = Just (gre { gre_lcl = lcl', gre_imp = iss' })   where     iss' = filter (qualSpecOK mod) iss-    lcl' = lcl && name_is_from mod n+    lcl' = lcl && name_is_from mod -    name_is_from :: ModuleName -> Name -> Bool-    name_is_from mod name = case nameModule_maybe name of-                              Just n_mod -> moduleName n_mod == mod-                              Nothing    -> False+    name_is_from :: ModuleName -> Bool+    name_is_from mod = case greDefinitionModule gre of+                         Just n_mod -> moduleName n_mod == mod+                         Nothing    -> False  pickGREsModExp :: ModuleName -> [GlobalRdrElt] -> [(GlobalRdrElt,GlobalRdrElt)] -- ^ Pick GREs that are in scope *both* qualified *and* unqualified@@ -937,18 +1010,17 @@ --   see 'GHC.Tc.Gen.Export.exports_from_avail' pickGREsModExp mod gres = mapMaybe (pickBothGRE mod) gres +-- | isBuiltInSyntax filter out names for built-in syntax They+-- just clutter up the environment (esp tuples), and the+-- parser will generate Exact RdrNames for them, so the+-- cluttered envt is no use.  Really, it's only useful for+-- GHC.Base and GHC.Tuple. pickBothGRE :: ModuleName -> GlobalRdrElt -> Maybe (GlobalRdrElt, GlobalRdrElt)-pickBothGRE mod gre@(GRE { gre_name = n })-  | isBuiltInSyntax n                = Nothing+pickBothGRE mod gre+  | isBuiltInSyntax (greMangledName gre)   = Nothing   | Just gre1 <- pickQualGRE mod gre   , Just gre2 <- pickUnqualGRE   gre = Just (gre1, gre2)   | otherwise                        = Nothing-  where-        -- isBuiltInSyntax filter out names for built-in syntax They-        -- just clutter up the environment (esp tuples), and the-        -- parser will generate Exact RdrNames for them, so the-        -- cluttered envt is no use.  Really, it's only useful for-        -- GHC.Base and GHC.Tuple.  -- Building GlobalRdrEnvs @@ -996,7 +1068,7 @@   = extendOccEnv_Acc insertGRE Utils.singleton env                      (greOccName gre) gre -shadowNames :: GlobalRdrEnv -> [Name] -> GlobalRdrEnv+shadowNames :: GlobalRdrEnv -> [GreName] -> GlobalRdrEnv shadowNames = foldl' shadowName  {- Note [GlobalRdrEnv shadowing]@@ -1039,7 +1111,7 @@     So when we add `x = True` we must not delete the `M.x` from the     `GlobalRdrEnv`; rather we just want to make it "qualified only";     hence the `mk_fake-imp_spec` in `shadowName`.  See also Note-    [Interactively-bound Ids in GHCi] in GHC.Driver.Types+    [Interactively-bound Ids in GHCi] in GHC.Runtime.Context    - Data types also have External Names, like Ghci4.T; but we still want     'T' to mean the newly-declared 'T', not an old one.@@ -1072,22 +1144,21 @@       At that stage, the class op 'f' will have an Internal name. -} -shadowName :: GlobalRdrEnv -> Name -> GlobalRdrEnv+shadowName :: GlobalRdrEnv -> GreName -> GlobalRdrEnv -- Remove certain old GREs that share the same OccName as this new Name. -- See Note [GlobalRdrEnv shadowing] for details-shadowName env name-  = alterOccEnv (fmap alter_fn) env (nameOccName name)+shadowName env new_name+  = alterOccEnv (fmap (mapMaybe shadow)) env (occName new_name)   where-    alter_fn :: [GlobalRdrElt] -> [GlobalRdrElt]-    alter_fn gres = mapMaybe (shadow_with name) gres+    maybe_new_mod = nameModule_maybe (greNameMangledName new_name) -    shadow_with :: Name -> GlobalRdrElt -> Maybe GlobalRdrElt-    shadow_with new_name-       old_gre@(GRE { gre_name = old_name, gre_lcl = lcl, gre_imp = iss })-       = case nameModule_maybe old_name of+    shadow :: GlobalRdrElt -> Maybe GlobalRdrElt+    shadow+       old_gre@(GRE { gre_lcl = lcl, gre_imp = iss })+       = case greDefinitionModule old_gre of            Nothing -> Just old_gre   -- Old name is Internal; do not shadow            Just old_mod-              | Just new_mod <- nameModule_maybe new_name+              | Just new_mod <- maybe_new_mod               , new_mod == old_mod   -- Old name same as new name; shadow completely               -> Nothing @@ -1098,22 +1169,22 @@               -> Just (old_gre { gre_lcl = False, gre_imp = iss' })                where-                iss' = lcl_imp ++ mapMaybe (shadow_is new_name) iss-                lcl_imp | lcl       = [mk_fake_imp_spec old_name old_mod]+                iss' = lcl_imp ++ mapMaybe shadow_is iss+                lcl_imp | lcl       = [mk_fake_imp_spec old_gre old_mod]                         | otherwise = [] -    mk_fake_imp_spec old_name old_mod    -- Urgh!+    mk_fake_imp_spec old_gre old_mod    -- Urgh!       = ImpSpec id_spec ImpAll       where         old_mod_name = moduleName old_mod         id_spec      = ImpDeclSpec { is_mod = old_mod_name                                    , is_as = old_mod_name                                    , is_qual = True-                                   , is_dloc = nameSrcSpan old_name }+                                   , is_dloc = greDefinitionSrcSpan old_gre } -    shadow_is :: Name -> ImportSpec -> Maybe ImportSpec-    shadow_is new_name is@(ImpSpec { is_decl = id_spec })-       | Just new_mod <- nameModule_maybe new_name+    shadow_is :: ImportSpec -> Maybe ImportSpec+    shadow_is is@(ImpSpec { is_decl = id_spec })+       | Just new_mod <- maybe_new_mod        , is_as id_spec == moduleName new_mod        = Nothing   -- Shadow both qualified and unqualified        | otherwise -- Shadow unqualified only@@ -1276,10 +1347,11 @@ pprNameProvenance :: GlobalRdrElt -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all)-pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })+pprNameProvenance gre@(GRE { gre_lcl = lcl, gre_imp = iss })   = ifPprDebug (vcat pp_provs)                (head pp_provs)   where+    name = greMangledName gre     pp_provs = pp_lcl ++ map pp_is iss     pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]                     else []@@ -1323,7 +1395,7 @@ --   (b) it is always in scope --   (c) it is a synonym for Data.Kind.Type ----- However, the user might not know that he's working on a module with+-- However, the user might not know that they are working on a module with -- NoStarIsType and write code that still assumes (a), (b), and (c), which -- actually do not hold in that module. --@@ -1391,3 +1463,7 @@       = let fs = occNameFS occName         in fs == fsLit "*" || fs == fsLit "★"       | otherwise = False++-- | Indicate if the given name is the "@" operator+opIsAt :: RdrName -> Bool+opIsAt e = e == mkUnqual varName (fsLit "@")

GHC/Types/Name/Shape.hs view

@@ -15,19 +15,23 @@  import GHC.Prelude -import GHC.Utils.Outputable-import GHC.Driver.Types+import GHC.Driver.Env+ import GHC.Unit.Module+ import GHC.Types.Unique.FM import GHC.Types.Avail import GHC.Types.FieldLabel- import GHC.Types.Name import GHC.Types.Name.Env+ import GHC.Tc.Utils.Monad-import GHC.Utils.Misc import GHC.Iface.Env +import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic+ import Control.Monad  -- Note [NameShape]@@ -179,19 +183,24 @@ -- for type constructors, where it is sufficient to substitute the 'availName' -- to induce a substitution on 'availNames'. substNameAvailInfo :: HscEnv -> ShNameSubst -> AvailInfo -> IO AvailInfo-substNameAvailInfo _ env (Avail n) = return (Avail (substName env n))-substNameAvailInfo hsc_env env (AvailTC n ns fs) =+substNameAvailInfo _ env (Avail (NormalGreName n)) = return (Avail (NormalGreName (substName env n)))+substNameAvailInfo _ env (Avail (FieldGreName fl)) =+    return (Avail (FieldGreName fl { flSelector = substName env (flSelector fl) }))+substNameAvailInfo hsc_env env (AvailTC n ns) =     let mb_mod = fmap nameModule (lookupNameEnv env n)-    in AvailTC (substName env n)-        <$> mapM (initIfaceLoad hsc_env . setNameModule mb_mod) ns-        <*> mapM (setNameFieldSelector hsc_env mb_mod) fs+    in AvailTC (substName env n) <$> mapM (setNameGreName hsc_env mb_mod) ns +setNameGreName :: HscEnv -> Maybe Module -> GreName -> IO GreName+setNameGreName hsc_env mb_mod gname = case gname of+    NormalGreName n -> NormalGreName <$> initIfaceLoad hsc_env (setNameModule mb_mod n)+    FieldGreName fl -> FieldGreName  <$> setNameFieldSelector hsc_env mb_mod fl+ -- | Set the 'Module' of a 'FieldSelector' setNameFieldSelector :: HscEnv -> Maybe Module -> FieldLabel -> IO FieldLabel setNameFieldSelector _ Nothing f = return f-setNameFieldSelector hsc_env mb_mod (FieldLabel l b sel) = do+setNameFieldSelector hsc_env mb_mod (FieldLabel l b has_sel sel) = do     sel' <- initIfaceLoad hsc_env $ setNameModule mb_mod sel-    return (FieldLabel l b sel')+    return (FieldLabel l b has_sel sel')  {- ************************************************************************@@ -231,8 +240,8 @@ -- with only name holes from @flexi@ unifiable (all other name holes rigid.) uAvailInfo :: ModuleName -> ShNameSubst -> AvailInfo -> AvailInfo            -> Either SDoc ShNameSubst-uAvailInfo flexi subst (Avail n1) (Avail n2) = uName flexi subst n1 n2-uAvailInfo flexi subst (AvailTC n1 _ _) (AvailTC n2 _ _) = uName flexi subst n1 n2+uAvailInfo flexi subst (Avail (NormalGreName n1)) (Avail (NormalGreName n2)) = uName flexi subst n1 n2+uAvailInfo flexi subst (AvailTC n1 _) (AvailTC n2 _) = uName flexi subst n1 n2 uAvailInfo _ _ a1 a2 = Left $ text "While merging export lists, could not combine"                            <+> ppr a1 <+> text "with" <+> ppr a2                            <+> parens (text "one is a type, the other is a plain identifier")

GHC/Types/RepType.hs view

@@ -27,16 +27,19 @@  import GHC.Types.Basic (Arity, RepArity) import GHC.Core.DataCon-import GHC.Utils.Outputable import GHC.Builtin.Names import GHC.Core.Coercion import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk import GHC.Core.TyCo.Rep import GHC.Core.Type-import GHC.Utils.Misc import GHC.Builtin.Types.Prim import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind ) +import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+ import Data.List (sort) import qualified Data.IntSet as IS @@ -283,10 +286,6 @@ slotPrimRep FloatSlot       = FloatRep  -- | Returns the bigger type if one fits into the other. (commutative)------ Note that lifted and unlifted pointers are *not* in a fits-in relation for--- the reasons described in Note [Don't merge lifted and unlifted slots] in--- GHC.Stg.Unarise. fitsIn :: SlotTy -> SlotTy -> Maybe SlotTy fitsIn ty1 ty2   | ty1 == ty2@@ -362,10 +361,11 @@ data RuntimeRep = VecRep VecCount VecElem   -- ^ a SIMD vector type                 | TupleRep [RuntimeRep]     -- ^ An unboxed tuple of the given reps                 | SumRep [RuntimeRep]       -- ^ An unboxed sum of the given reps-                | LiftedRep       -- ^ lifted; represented by a pointer-                | UnliftedRep     -- ^ unlifted; represented by a pointer+                | BoxedRep Levity -- ^ boxed; represented by a pointer                 | IntRep          -- ^ signed, word-sized value                 ...etc...+data Levity     = Lifted+                | Unlifted  It's all in 1-1 correspondence with PrimRep except for TupleRep and SumRep, which describe unboxed products and sums respectively. RuntimeRep is defined@@ -374,6 +374,13 @@ program, so that every variable has a type that has a PrimRep. For example, unarisation transforms our utup function above, to take two Int arguments instead of one (# Int, Int #) argument.++Also, note that boxed types are represented slightly differently in RuntimeRep+and PrimRep. PrimRep just has the nullary LiftedRep and UnliftedRep data+constructors. RuntimeRep has a BoxedRep data constructor, which accepts a+Levity. The subtle distinction is that since BoxedRep can accept a variable+argument, RuntimeRep can talk about levity polymorphic types. PrimRep, by+contrast, cannot.  See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep].

+ GHC/Types/SafeHaskell.hs view

@@ -0,0 +1,86 @@+-- | This stuff here is related to supporting the Safe Haskell extension,+-- primarily about storing under what trust type a module has been compiled.+module GHC.Types.SafeHaskell+   ( IsSafeImport+   , SafeHaskellMode(..)+   , IfaceTrustInfo+   , getSafeMode+   , setSafeMode+   , noIfaceTrustInfo+   )+where++import GHC.Prelude++import GHC.Utils.Binary+import GHC.Utils.Outputable++import Data.Word+++-- | Is an import a safe import?+type IsSafeImport = Bool++-- | The various Safe Haskell modes+data SafeHaskellMode+   = Sf_None          -- ^ inferred unsafe+   | Sf_Unsafe        -- ^ declared and checked+   | Sf_Trustworthy   -- ^ declared and checked+   | Sf_Safe          -- ^ declared and checked+   | Sf_SafeInferred  -- ^ inferred as safe+   | Sf_Ignore        -- ^ @-fno-safe-haskell@ state+   deriving (Eq)++instance Show SafeHaskellMode where+    show Sf_None         = "None"+    show Sf_Unsafe       = "Unsafe"+    show Sf_Trustworthy  = "Trustworthy"+    show Sf_Safe         = "Safe"+    show Sf_SafeInferred = "Safe-Inferred"+    show Sf_Ignore       = "Ignore"++instance Outputable SafeHaskellMode where+    ppr = text . show++-- | Safe Haskell information for 'ModIface'+-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags+newtype IfaceTrustInfo = TrustInfo SafeHaskellMode++getSafeMode :: IfaceTrustInfo -> SafeHaskellMode+getSafeMode (TrustInfo x) = x++setSafeMode :: SafeHaskellMode -> IfaceTrustInfo+setSafeMode = TrustInfo++noIfaceTrustInfo :: IfaceTrustInfo+noIfaceTrustInfo = setSafeMode Sf_None++trustInfoToNum :: IfaceTrustInfo -> Word8+trustInfoToNum it+  = case getSafeMode it of+            Sf_None         -> 0+            Sf_Unsafe       -> 1+            Sf_Trustworthy  -> 2+            Sf_Safe         -> 3+            Sf_SafeInferred -> 4+            Sf_Ignore       -> 0++numToTrustInfo :: Word8 -> IfaceTrustInfo+numToTrustInfo 0 = setSafeMode Sf_None+numToTrustInfo 1 = setSafeMode Sf_Unsafe+numToTrustInfo 2 = setSafeMode Sf_Trustworthy+numToTrustInfo 3 = setSafeMode Sf_Safe+numToTrustInfo 4 = setSafeMode Sf_SafeInferred+numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"++instance Outputable IfaceTrustInfo where+    ppr (TrustInfo Sf_None)          = text "none"+    ppr (TrustInfo Sf_Ignore)        = text "none"+    ppr (TrustInfo Sf_Unsafe)        = text "unsafe"+    ppr (TrustInfo Sf_Trustworthy)   = text "trustworthy"+    ppr (TrustInfo Sf_Safe)          = text "safe"+    ppr (TrustInfo Sf_SafeInferred)  = text "safe-inferred"++instance Binary IfaceTrustInfo where+    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust+    get bh = getByte bh >>= (return . numToTrustInfo)

+ GHC/Types/SourceError.hs view

@@ -0,0 +1,64 @@+-- | Source errors+module GHC.Types.SourceError+   ( SourceError (..)+   , mkSrcErr+   , srcErrorMessages+   , throwErrors+   , throwOneError+   , handleSourceError+   )+where++import GHC.Prelude+import GHC.Data.Bag+import GHC.Types.Error+import GHC.Utils.Monad+import GHC.Utils.Panic+import GHC.Utils.Exception++import Control.Monad.Catch as MC (MonadCatch, catch)++mkSrcErr :: ErrorMessages -> SourceError+mkSrcErr = SourceError++srcErrorMessages :: SourceError -> ErrorMessages+srcErrorMessages (SourceError msgs) = msgs++throwErrors :: MonadIO io => ErrorMessages -> io a+throwErrors = liftIO . throwIO . mkSrcErr++throwOneError :: MonadIO io => MsgEnvelope DecoratedSDoc -> io a+throwOneError = throwErrors . unitBag++-- | A source error is an error that is caused by one or more errors in the+-- source code.  A 'SourceError' is thrown by many functions in the+-- compilation pipeline.  Inside GHC these errors are merely printed via+-- 'log_action', but API clients may treat them differently, for example,+-- insert them into a list box.  If you want the default behaviour, use the+-- idiom:+--+-- > handleSourceError printExceptionAndWarnings $ do+-- >   ... api calls that may fail ...+--+-- The 'SourceError's error messages can be accessed via 'srcErrorMessages'.+-- This list may be empty if the compiler failed due to @-Werror@+-- ('Opt_WarnIsError').+--+-- See 'printExceptionAndWarnings' for more information on what to take care+-- of when writing a custom error handler.+newtype SourceError = SourceError ErrorMessages++instance Show SourceError where+  show (SourceError msgs) = unlines . map show . bagToList $ msgs++instance Exception SourceError++-- | Perform the given action and call the exception handler if the action+-- throws a 'SourceError'.  See 'SourceError' for more information.+handleSourceError :: (MonadCatch m) =>+                     (SourceError -> m a) -- ^ exception handler+                  -> m a -- ^ action to perform+                  -> m a+handleSourceError handler act =+  MC.catch act (\(e :: SourceError) -> handler e)+

+ GHC/Types/SourceFile.hs view

@@ -0,0 +1,94 @@+module GHC.Types.SourceFile+   ( HscSource(..)+   , SourceModified (..)+   , isHsBootOrSig+   , isHsigFile+   , hscSourceString+   )+where++import GHC.Prelude+import GHC.Utils.Binary++-- Note [HscSource types]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- There are three types of source file for Haskell code:+--+--      * HsSrcFile is an ordinary hs file which contains code,+--+--      * HsBootFile is an hs-boot file, which is used to break+--        recursive module imports (there will always be an+--        HsSrcFile associated with it), and+--+--      * HsigFile is an hsig file, which contains only type+--        signatures and is used to specify signatures for+--        modules.+--+-- Syntactically, hs-boot files and hsig files are quite similar: they+-- only include type signatures and must be associated with an+-- actual HsSrcFile.  isHsBootOrSig allows us to abstract over code+-- which is indifferent to which.  However, there are some important+-- differences, mostly owing to the fact that hsigs are proper+-- modules (you `import Sig` directly) whereas HsBootFiles are+-- temporary placeholders (you `import {-# SOURCE #-} Mod).+-- When we finish compiling the true implementation of an hs-boot,+-- we replace the HomeModInfo with the real HsSrcFile.  An HsigFile, on the+-- other hand, is never replaced (in particular, we *cannot* use the+-- HomeModInfo of the original HsSrcFile backing the signature, since it+-- will export too many symbols.)+--+-- Additionally, while HsSrcFile is the only Haskell file+-- which has *code*, we do generate .o files for HsigFile, because+-- this is how the recompilation checker figures out if a file+-- needs to be recompiled.  These are fake object files which+-- should NOT be linked against.++data HscSource+   = HsSrcFile  -- ^ .hs file+   | HsBootFile -- ^ .hs-boot file+   | HsigFile   -- ^ .hsig file+   deriving (Eq, Ord, Show)++instance Binary HscSource where+    put_ bh HsSrcFile = putByte bh 0+    put_ bh HsBootFile = putByte bh 1+    put_ bh HsigFile = putByte bh 2+    get bh = do+        h <- getByte bh+        case h of+            0 -> return HsSrcFile+            1 -> return HsBootFile+            _ -> return HsigFile++hscSourceString :: HscSource -> String+hscSourceString HsSrcFile   = ""+hscSourceString HsBootFile  = "[boot]"+hscSourceString HsigFile    = "[sig]"++-- See Note [HscSource types]+isHsBootOrSig :: HscSource -> Bool+isHsBootOrSig HsBootFile = True+isHsBootOrSig HsigFile   = True+isHsBootOrSig _          = False++isHsigFile :: HscSource -> Bool+isHsigFile HsigFile = True+isHsigFile _        = False++-- | Indicates whether a given module's source has been modified since it+-- was last compiled.+data SourceModified+  = SourceModified+       -- ^ the source has been modified+  | SourceUnmodified+       -- ^ the source has not been modified.  Compilation may or may+       -- not be necessary, depending on whether any dependencies have+       -- changed since we last compiled.+  | SourceUnmodifiedAndStable+       -- ^ the source has not been modified, and furthermore all of+       -- its (transitive) dependencies are up to date; it definitely+       -- does not need to be recompiled.  This is important for two+       -- reasons: (a) we can omit the version check in checkOldIface,+       -- and (b) if the module used TH splices we don't need to force+       -- recompilation.+

+ GHC/Types/SourceText.hs view

@@ -0,0 +1,324 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Source text+--+-- Keeping Source Text for source to source conversions+--+module GHC.Types.SourceText+   ( SourceText (..)+   , pprWithSourceText++   -- * Literals+   , IntegralLit(..)+   , FractionalLit(..)+   , StringLiteral(..)+   , negateIntegralLit+   , negateFractionalLit+   , mkIntegralLit+   , mkTHFractionalLit, rationalFromFractionalLit+   , integralFractionalLit, mkSourceFractionalLit+   , FractionalExponentBase(..)++   -- Used by the pm checker.+   , fractionalLitFromRational+   , mkFractionalLit++   )+where++import GHC.Prelude++import GHC.Data.FastString++import GHC.Utils.Outputable+import GHC.Utils.Binary+import GHC.Utils.Panic++import Data.Function (on)+import Data.Data+import GHC.Real ( Ratio(..) )+import GHC.Types.SrcLoc++{-+Note [Pragma source text]+~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer does a case-insensitive match for pragmas, as well as+accepting both UK and US spelling variants.++So++  {-# SPECIALISE #-}+  {-# SPECIALIZE #-}+  {-# Specialize #-}++will all generate ITspec_prag token for the start of the pragma.++In order to be able to do source to source conversions, the original+source text for the token needs to be preserved, hence the+`SourceText` field.++So the lexer will then generate++  ITspec_prag "{ -# SPECIALISE"+  ITspec_prag "{ -# SPECIALIZE"+  ITspec_prag "{ -# Specialize"++for the cases above.+ [without the space between '{' and '-', otherwise this comment won't parse]+++Note [Literal source text]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The lexer/parser converts literals from their original source text+versions to an appropriate internal representation. This is a problem+for tools doing source to source conversions, so the original source+text is stored in literals where this can occur.++Motivating examples for HsLit++  HsChar          '\n'       == '\x20`+  HsCharPrim      '\x41`#    == `A`+  HsString        "\x20\x41" == " A"+  HsStringPrim    "\x20"#    == " "#+  HsInt           001        == 1+  HsIntPrim       002#       == 2#+  HsWordPrim      003##      == 3##+  HsInt64Prim     004##      == 4##+  HsWord64Prim    005##      == 5##+  HsInteger       006        == 6++For OverLitVal++  HsIntegral      003      == 0x003+  HsIsString      "\x41nd" == "And"+-}++ -- Note [Literal source text],[Pragma source text]+data SourceText+   = SourceText String+   | NoSourceText+      -- ^ For when code is generated, e.g. TH,+      -- deriving. The pretty printer will then make+      -- its own representation of the item.+   deriving (Data, Show, Eq )++instance Outputable SourceText where+  ppr (SourceText s) = text "SourceText" <+> text s+  ppr NoSourceText   = text "NoSourceText"++instance Binary SourceText where+  put_ bh NoSourceText = putByte bh 0+  put_ bh (SourceText s) = do+        putByte bh 1+        put_ bh s++  get bh = do+    h <- getByte bh+    case h of+      0 -> return NoSourceText+      1 -> do+        s <- get bh+        return (SourceText s)+      _ -> panic $ "Binary SourceText:" ++ show h++-- | Special combinator for showing string literals.+pprWithSourceText :: SourceText -> SDoc -> SDoc+pprWithSourceText NoSourceText     d = d+pprWithSourceText (SourceText src) _ = text src++------------------------------------------------+-- Literals+------------------------------------------------++-- | Integral Literal+--+-- Used (instead of Integer) to represent negative zegative zero which is+-- required for NegativeLiterals extension to correctly parse `-0::Double`+-- as negative zero. See also #13211.+data IntegralLit = IL+   { il_text  :: SourceText+   , il_neg   :: Bool -- See Note [Negative zero] in GHC.Rename.Pat+   , il_value :: Integer+   }+   deriving (Data, Show)++mkIntegralLit :: Integral a => a -> IntegralLit+mkIntegralLit i = IL { il_text = SourceText (show i_integer)+                     , il_neg = i < 0+                     , il_value = i_integer }+  where+    i_integer :: Integer+    i_integer = toInteger i++negateIntegralLit :: IntegralLit -> IntegralLit+negateIntegralLit (IL text neg value)+  = case text of+      SourceText ('-':src) -> IL (SourceText src)       False    (negate value)+      SourceText      src  -> IL (SourceText ('-':src)) True     (negate value)+      NoSourceText         -> IL NoSourceText          (not neg) (negate value)++-- | Fractional Literal+--+-- Used (instead of Rational) to represent exactly the floating point literal that we+-- encountered in the user's source program. This allows us to pretty-print exactly what+-- the user wrote, which is important e.g. for floating point numbers that can't represented+-- as Doubles (we used to via Double for pretty-printing). See also #2245.+-- Note [FractionalLit representation] in GHC.HsToCore.Match.Literal+-- The actual value then is: sign * fl_signi * (fl_exp_base^fl_exp)+--                             where sign = if fl_neg then (-1) else 1+--+-- For example FL { fl_neg = True, fl_signi = 5.3, fl_exp = 4, fl_exp_base = Base10 }+-- denotes  -5300++data FractionalLit = FL+    { fl_text :: SourceText     -- ^ How the value was written in the source+    , fl_neg :: Bool                        -- See Note [Negative zero]+    , fl_signi :: Rational                  -- The significand component of the literal+    , fl_exp :: Integer                     -- The exponent component of the literal+    , fl_exp_base :: FractionalExponentBase -- See Note [Fractional exponent bases]+    }+    deriving (Data, Show)+  -- The Show instance is required for the derived GHC.Parser.Lexer.Token instance when DEBUG is on++-- See Note [FractionalLit representation] in GHC.HsToCore.Match.Literal+data FractionalExponentBase+  = Base2 -- Used in hex fractional literals+  | Base10+  deriving (Eq, Ord, Data, Show)++mkFractionalLit :: SourceText -> Bool -> Rational -> Integer -> FractionalExponentBase+                -> FractionalLit+mkFractionalLit = FL++mkRationalWithExponentBase :: Rational -> Integer -> FractionalExponentBase -> Rational+mkRationalWithExponentBase i e feb = i * (eb ^^ e)+  where eb = case feb of Base2 -> 2 ; Base10 -> 10++fractionalLitFromRational :: Rational -> FractionalLit+fractionalLitFromRational r =  FL { fl_text = NoSourceText+                           , fl_neg = r < 0+                           , fl_signi = r+                           , fl_exp = 0+                           , fl_exp_base = Base10 }++rationalFromFractionalLit :: FractionalLit -> Rational+rationalFromFractionalLit (FL _ _ i e expBase) =+  mkRationalWithExponentBase i e expBase++mkTHFractionalLit :: Rational -> FractionalLit+mkTHFractionalLit r =  FL { fl_text = SourceText (show (realToFrac r::Double))+                             -- Converting to a Double here may technically lose+                             -- precision (see #15502). We could alternatively+                             -- convert to a Rational for the most accuracy, but+                             -- it would cause Floats and Doubles to be displayed+                             -- strangely, so we opt not to do this. (In contrast+                             -- to mkIntegralLit, where we always convert to an+                             -- Integer for the highest accuracy.)+                           , fl_neg = r < 0+                           , fl_signi = r+                           , fl_exp = 0+                           , fl_exp_base = Base10 }++negateFractionalLit :: FractionalLit -> FractionalLit+negateFractionalLit (FL text neg i e eb)+  = case text of+      SourceText ('-':src) -> FL (SourceText src)       False (negate i) e eb+      SourceText      src  -> FL (SourceText ('-':src)) True  (negate i) e eb+      NoSourceText         -> FL NoSourceText (not neg) (negate i) e eb++-- | The integer should already be negated if it's negative.+integralFractionalLit :: Bool -> Integer -> FractionalLit+integralFractionalLit neg i = FL { fl_text = SourceText (show i)+                                 , fl_neg = neg+                                 , fl_signi = i :% 1+                                 , fl_exp = 0+                                 , fl_exp_base = Base10 }++-- | The arguments should already be negated if they are negative.+mkSourceFractionalLit :: String -> Bool -> Integer -> Integer+                      -> FractionalExponentBase+                      -> FractionalLit+mkSourceFractionalLit !str !b !r !i !ff = FL (SourceText str) b (r :% 1) i ff++{- Note [fractional exponent bases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For hexadecimal rationals of+the form 0x0.3p10 the exponent is given on base 2 rather than+base 10. These are the only options, hence the sum type. See also #15646.+-}+++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)++instance Eq IntegralLit where+  (==) = (==) `on` il_value++instance Ord IntegralLit where+  compare = compare `on` il_value++instance Outputable IntegralLit where+  ppr (IL (SourceText src) _ _) = text src+  ppr (IL NoSourceText _ value) = text (show value)+++-- | Compare fractional lits with small exponents for value equality but+--   large values for syntactic equality.+compareFractionalLit :: FractionalLit -> FractionalLit -> Ordering+compareFractionalLit fl1 fl2+  | fl_exp fl1 < 100 && fl_exp fl2 < 100 && fl_exp fl1 >= -100 && fl_exp fl2 >= -100+    = rationalFromFractionalLit fl1 `compare` rationalFromFractionalLit fl2+  | otherwise = (compare `on` (\x -> (fl_signi x, fl_exp x, fl_exp_base x))) fl1 fl2++-- | Be wary of using this instance to compare for equal *values* when exponents are+-- large. The same value expressed in different syntactic form won't compare as equal when+-- any of the exponents is >= 100.+instance Eq FractionalLit where+  (==) fl1 fl2 = case compare fl1 fl2 of+          EQ -> True+          _  -> False++-- | Be wary of using this instance to compare for equal *values* when exponents are+-- large. The same value expressed in different syntactic form won't compare as equal when+-- any of the exponents is >= 100.+instance Ord FractionalLit where+  compare = compareFractionalLit++instance Outputable FractionalLit where+  ppr (fl@(FL {})) =+    pprWithSourceText (fl_text fl) $+      rational $ mkRationalWithExponentBase (fl_signi fl) (fl_exp fl) (fl_exp_base fl)++-- | A String Literal in the source, including its original raw format for use by+-- source to source manipulation tools.+data StringLiteral = StringLiteral+                       { sl_st :: SourceText, -- literal raw source.+                                              -- See not [Literal source text]+                         sl_fs :: FastString, -- literal string value+                         sl_tc :: Maybe RealSrcSpan -- Location of+                                                    -- possible+                                                    -- trailing comma+                       -- AZ: if we could have a LocatedA+                       -- StringLiteral we would not need sl_tc, but+                       -- that would cause import loops.++                       -- AZ:2: sl_tc should be an EpaAnchor, to allow+                       -- editing and reprinting the AST. Need a more+                       -- robust solution.++                       } deriving Data++instance Eq StringLiteral where+  (StringLiteral _ a _) == (StringLiteral _ b _) = a == b++instance Outputable StringLiteral where+  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)++instance Binary StringLiteral where+  put_ bh (StringLiteral st fs _) = do+            put_ bh st+            put_ bh fs+  get bh = do+            st <- get bh+            fs <- get bh+            return (StringLiteral st fs Nothing)

GHC/Types/SrcLoc.hs view

@@ -1,17 +1,11 @@--- (c) The University of Glasgow, 1992-2006- {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveFunctor      #-}-{-# LANGUAGE DeriveFoldable     #-} {-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE FlexibleContexts   #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE RecordWildCards    #-} {-# LANGUAGE TypeFamilies       #-}-{-# LANGUAGE ViewPatterns       #-}-{-# LANGUAGE FlexibleContexts   #-}-{-# LANGUAGE PatternSynonyms    #-} +-- (c) The University of Glasgow, 1992-2006  -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations@@ -55,7 +49,9 @@         realSrcSpanStart, realSrcSpanEnd,         srcSpanFileName_maybe,         pprUserRealSpan, pprUnhelpfulSpanReason,+        pprUserSpan,         unhelpfulSpanFS,+        srcSpanToRealSrcSpan,          -- ** Unsafely deconstructing SrcSpan         -- These are dubious exports, because they crash on some inputs@@ -64,7 +60,7 @@         srcSpanStartCol, srcSpanEndCol,          -- ** Predicates on SrcSpan-        isGoodSrcSpan, isOneLineSpan,+        isGoodSrcSpan, isOneLineSpan, isZeroWidthSpan,         containsSpan,          -- * StringBuffer locations@@ -85,6 +81,7 @@         -- ** Deconstructing Located         getLoc, unLoc,         unRealSrcSpan, getRealSrcSpan,+        pprLocated,          -- ** Modifying Located         mapLoc,@@ -108,6 +105,7 @@         psSpanStart,         psSpanEnd,         mkSrcSpanPs,+        combineRealSrcSpans,          -- * Layout information         LayoutInfo(..),@@ -120,11 +118,11 @@ import GHC.Utils.Misc import GHC.Utils.Json import GHC.Utils.Outputable+import GHC.Utils.Panic import GHC.Data.FastString  import Control.DeepSeq import Control.Applicative (liftA2)-import Data.Bits import Data.Data import Data.List (sortBy, intercalate) import Data.Function (on)@@ -146,7 +144,7 @@ -- -- Represents a single point within a file data RealSrcLoc-  = SrcLoc      FastString              -- A precise location (file name)+  = SrcLoc      LexicalFastString       -- A precise location (file name)                 {-# UNPACK #-} !Int     -- line number, begins at 1                 {-# UNPACK #-} !Int     -- column number, begins at 1   deriving (Eq, Ord)@@ -243,7 +241,7 @@ mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Nothing  mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc-mkRealSrcLoc x line col = SrcLoc x line col+mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col  getBufPos :: SrcLoc -> Maybe BufPos getBufPos (RealSrcLoc _ mbpos) = mbpos@@ -261,7 +259,7 @@  -- | Gives the filename of the 'RealSrcLoc' srcLocFile :: RealSrcLoc -> FastString-srcLocFile (SrcLoc fname _ _) = fname+srcLocFile (SrcLoc (LexicalFastString fname) _ _) = fname  -- | Raises an error when used on a "bad" 'SrcLoc' srcLocLine :: RealSrcLoc -> Int@@ -308,7 +306,7 @@ lookupSrcSpan (UnhelpfulSpan _) = const Nothing  instance Outputable RealSrcLoc where-    ppr (SrcLoc src_path src_line src_col)+    ppr (SrcLoc (LexicalFastString src_path) src_line src_col)       = hcat [ pprFastFilePath src_path <> colon              , int src_line <> colon              , int src_col ]@@ -457,7 +455,7 @@ srcLocSpan (RealSrcLoc l mb) = RealSrcSpan (realSrcLocSpan l) (fmap (\b -> BufSpan b b) mb)  realSrcLocSpan :: RealSrcLoc -> RealSrcSpan-realSrcLocSpan (SrcLoc file line col) = RealSrcSpan' file line col line col+realSrcLocSpan (SrcLoc (LexicalFastString file) line col) = RealSrcSpan' file line col line col  -- | Create a 'SrcSpan' between two points in a file mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan@@ -548,6 +546,14 @@ isOneLineSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s isOneLineSpan (UnhelpfulSpan _) = False +isZeroWidthSpan :: SrcSpan -> Bool+-- ^ True if the span has a width of zero, as returned for "virtual"+-- semicolons in the lexer.+-- For "bad" 'SrcSpan', it returns False+isZeroWidthSpan (RealSrcSpan s _) = srcSpanStartLine s == srcSpanEndLine s+                                 && srcSpanStartCol s == srcSpanEndCol s+isZeroWidthSpan (UnhelpfulSpan _) = False+ -- | Tests whether the first span "contains" the other span, meaning -- that it covers at least as much source code. True where spans are equal. containsSpan :: RealSrcSpan -> RealSrcSpan -> Bool@@ -610,6 +616,10 @@ srcSpanFileName_maybe (RealSrcSpan s _) = Just (srcSpanFile s) srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing +srcSpanToRealSrcSpan :: SrcSpan -> Maybe RealSrcSpan+srcSpanToRealSrcSpan (RealSrcSpan ss _) = Just ss+srcSpanToRealSrcSpan _ = Nothing+ {- ************************************************************************ *                                                                      *@@ -769,11 +779,21 @@    | otherwise = panic "cmpBufSpan: no BufSpan" -instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where-  ppr (L l e) = -- TODO: We can't do this since Located was refactored into-                -- GenLocated:+instance (Outputable e) => Outputable (Located e) where+  ppr (L l e) = -- GenLocated:                 -- Print spans without the file name etc-                -- ifPprDebug (braces (pprUserSpan False l))+                whenPprDebug (braces (pprUserSpan False l))+             $$ ppr e+instance (Outputable e) => Outputable (GenLocated RealSrcSpan e) where+  ppr (L l e) = -- GenLocated:+                -- Print spans without the file name etc+                whenPprDebug (braces (pprUserSpan False (RealSrcSpan l Nothing)))+             $$ ppr e+++pprLocated :: (Outputable l, Outputable e) => GenLocated l e -> SDoc+pprLocated (L l e) =+                -- Print spans without the file name etc                 whenPprDebug (braces (ppr l))              $$ ppr e

+ GHC/Types/Target.hs view

@@ -0,0 +1,67 @@+module GHC.Types.Target+   ( Target(..)+   , TargetId(..)+   , InputFileBuffer+   , pprTarget+   , pprTargetId+   )+where++import GHC.Prelude+import GHC.Driver.Phases ( Phase )+import GHC.Unit+import GHC.Data.StringBuffer ( StringBuffer )+import GHC.Utils.Outputable++import Data.Time++-- | A compilation target.+--+-- A target may be supplied with the actual text of the+-- module.  If so, use this instead of the file contents (this+-- is for use in an IDE where the file hasn't been saved by+-- the user yet).+data Target+  = Target {+      targetId           :: !TargetId, -- ^ module or filename+      targetAllowObjCode :: !Bool,     -- ^ object code allowed?+      targetContents     :: !(Maybe (InputFileBuffer, UTCTime))+      -- ^ Optional in-memory buffer containing the source code GHC should+      -- use for this target instead of reading it from disk.+      --+      -- Since GHC version 8.10 modules which require preprocessors such as+      -- Literate Haskell or CPP to run are also supported.+      --+      -- If a corresponding source file does not exist on disk this will+      -- result in a 'SourceError' exception if @targetId = TargetModule _@+      -- is used. However together with @targetId = TargetFile _@ GHC will+      -- not complain about the file missing.+    }++data TargetId+  = TargetModule !ModuleName+        -- ^ A module name: search for the file+  | TargetFile !FilePath !(Maybe Phase)+        -- ^ A filename: preprocess & parse it to find the module name.+        -- If specified, the Phase indicates how to compile this file+        -- (which phase to start from).  Nothing indicates the starting phase+        -- should be determined from the suffix of the filename.+  deriving Eq++type InputFileBuffer = StringBuffer+++pprTarget :: Target -> SDoc+pprTarget (Target id obj _) =+    (if obj then empty else char '*') <> pprTargetId id++instance Outputable Target where+    ppr = pprTarget++pprTargetId :: TargetId -> SDoc+pprTargetId (TargetModule m) = ppr m+pprTargetId (TargetFile f _) = text f++instance Outputable TargetId where+    ppr = pprTargetId+

+ GHC/Types/Tickish.hs view

@@ -0,0 +1,372 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module GHC.Types.Tickish (+  GenTickish(..),+  CoreTickish, StgTickish, CmmTickish,+  XTickishId,+  tickishCounts,+  TickishScoping(..),+  tickishScoped,+  tickishScopesLike,+  tickishFloatable,+  tickishCanSplit,+  mkNoCount,+  mkNoScope,+  tickishIsCode,+  TickishPlacement(..),+  tickishPlace,+  tickishContains+) where++import GHC.Prelude++import GHC.Core.Type++import GHC.Unit.Module++import GHC.Types.CostCentre+import GHC.Types.SrcLoc ( RealSrcSpan, containsSpan )+import GHC.Types.Var++import GHC.Utils.Panic++import Language.Haskell.Syntax.Extension ( NoExtField )++import Data.Data++{- *********************************************************************+*                                                                      *+              Ticks+*                                                                      *+************************************************************************+-}++-- | Allows attaching extra information to points in expressions++{- | Used as a data type index for the GenTickish annotations.+     See Note [Tickish passes]+ -}+data TickishPass+  = TickishPassCore+  | TickishPassStg+  | TickishPassCmm++{-+   Note [Tickish passes]++   Tickish annotations store different information depending on+   where they are used. Here's a summary of the differences+   between the passes.++   - CoreTickish: Haskell and Core+         The tickish annotations store the free variables of+         breakpoints.++   - StgTickish: Stg+         The GHCi bytecode generator (GHC.StgToByteCode) needs+         to know the type of each breakpoint in addition to its+         free variables. Since we cannot compute the type from+         an STG expression, the tickish annotations store the+         type of breakpoints in addition to the free variables.++   - CmmTickish: Cmm+         Breakpoints are unsupported and no free variables or+         type are stored.+ -}++type family XBreakpoint (pass :: TickishPass)+type instance XBreakpoint 'TickishPassCore = NoExtField+-- | Keep track of the type of breakpoints in STG, for GHCi+type instance XBreakpoint 'TickishPassStg  = Type+type instance XBreakpoint 'TickishPassCmm  = NoExtField++type family XTickishId (pass :: TickishPass)+type instance XTickishId 'TickishPassCore = Id+type instance XTickishId 'TickishPassStg = Id+type instance XTickishId 'TickishPassCmm = NoExtField++type CoreTickish = GenTickish 'TickishPassCore+type StgTickish = GenTickish 'TickishPassStg+-- | Tickish in Cmm context (annotations only)+type CmmTickish = GenTickish 'TickishPassCmm++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data GenTickish pass =+    -- | An @{-# SCC #-}@ profiling annotation, either automatically+    -- added by the desugarer as a result of -auto-all, or added by+    -- the user.+    ProfNote {+      profNoteCC    :: CostCentre, -- ^ the cost centre+      profNoteCount :: !Bool,      -- ^ bump the entry count?+      profNoteScope :: !Bool       -- ^ scopes over the enclosed expression+                                   -- (i.e. not just a tick)+    }++  -- | A "tick" used by HPC to track the execution of each+  -- subexpression in the original source code.+  | HpcTick {+      tickModule :: Module,+      tickId     :: !Int+    }++  -- | A breakpoint for the GHCi debugger.  This behaves like an HPC+  -- tick, but has a list of free variables which will be available+  -- for inspection in GHCi when the program stops at the breakpoint.+  --+  -- NB. we must take account of these Ids when (a) counting free variables,+  -- and (b) substituting (don't substitute for them)+  | Breakpoint+    { breakpointExt    :: XBreakpoint pass+    , breakpointId     :: !Int+    , breakpointFVs    :: [XTickishId pass]+                                -- ^ the order of this list is important:+                                -- it matches the order of the lists in the+                                -- appropriate entry in 'GHC.ByteCode.Types.ModBreaks'.+                                --+                                -- Careful about substitution!  See+                                -- Note [substTickish] in "GHC.Core.Subst".+    }++  -- | A source note.+  --+  -- Source notes are pure annotations: Their presence should neither+  -- influence compilation nor execution. The semantics are given by+  -- causality: The presence of a source note means that a local+  -- change in the referenced source code span will possibly provoke+  -- the generated code to change. On the flip-side, the functionality+  -- of annotated code *must* be invariant against changes to all+  -- source code *except* the spans referenced in the source notes+  -- (see "Causality of optimized Haskell" paper for details).+  --+  -- Therefore extending the scope of any given source note is always+  -- valid. Note that it is still undesirable though, as this reduces+  -- their usefulness for debugging and profiling. Therefore we will+  -- generally try only to make use of this property where it is+  -- necessary to enable optimizations.+  | SourceNote+    { sourceSpan :: RealSrcSpan -- ^ Source covered+    , sourceName :: String      -- ^ Name for source location+                                --   (uses same names as CCs)+    }++deriving instance Eq (GenTickish 'TickishPassCore)+deriving instance Ord (GenTickish 'TickishPassCore)+deriving instance Data (GenTickish 'TickishPassCore)++deriving instance Data (GenTickish 'TickishPassStg)++deriving instance Eq (GenTickish 'TickishPassCmm)+deriving instance Ord (GenTickish 'TickishPassCmm)+deriving instance Data (GenTickish 'TickishPassCmm)+++-- | A "counting tick" (where tickishCounts is True) is one that+-- counts evaluations in some way.  We cannot discard a counting tick,+-- and the compiler should preserve the number of counting ticks as+-- far as possible.+--+-- However, we still allow the simplifier to increase or decrease+-- sharing, so in practice the actual number of ticks may vary, except+-- that we never change the value from zero to non-zero or vice versa.+tickishCounts :: GenTickish pass -> Bool+tickishCounts n@ProfNote{} = profNoteCount n+tickishCounts HpcTick{}    = True+tickishCounts Breakpoint{} = True+tickishCounts _            = False+++-- | Specifies the scoping behaviour of ticks. This governs the+-- behaviour of ticks that care about the covered code and the cost+-- associated with it. Important for ticks relating to profiling.+data TickishScoping =+    -- | No scoping: The tick does not care about what code it+    -- covers. Transformations can freely move code inside as well as+    -- outside without any additional annotation obligations+    NoScope++    -- | Soft scoping: We want all code that is covered to stay+    -- covered.  Note that this scope type does not forbid+    -- transformations from happening, as long as all results of+    -- the transformations are still covered by this tick or a copy of+    -- it. For example+    --+    --   let x = tick<...> (let y = foo in bar) in baz+    --     ===>+    --   let x = tick<...> bar; y = tick<...> foo in baz+    --+    -- Is a valid transformation as far as "bar" and "foo" is+    -- concerned, because both still are scoped over by the tick.+    --+    -- Note though that one might object to the "let" not being+    -- covered by the tick any more. However, we are generally lax+    -- with this - constant costs don't matter too much, and given+    -- that the "let" was effectively merged we can view it as having+    -- lost its identity anyway.+    --+    -- Also note that this scoping behaviour allows floating a tick+    -- "upwards" in pretty much any situation. For example:+    --+    --   case foo of x -> tick<...> bar+    --     ==>+    --   tick<...> case foo of x -> bar+    --+    -- While this is always legal, we want to make a best effort to+    -- only make us of this where it exposes transformation+    -- opportunities.+  | SoftScope++    -- | Cost centre scoping: We don't want any costs to move to other+    -- cost-centre stacks. This means we not only want no code or cost+    -- to get moved out of their cost centres, but we also object to+    -- code getting associated with new cost-centre ticks - or+    -- changing the order in which they get applied.+    --+    -- A rule of thumb is that we don't want any code to gain new+    -- annotations. However, there are notable exceptions, for+    -- example:+    --+    --   let f = \y -> foo in tick<...> ... (f x) ...+    --     ==>+    --   tick<...> ... foo[x/y] ...+    --+    -- In-lining lambdas like this is always legal, because inlining a+    -- function does not change the cost-centre stack when the+    -- function is called.+  | CostCentreScope++  deriving (Eq)++-- | Returns the intended scoping rule for a Tickish+tickishScoped :: GenTickish pass -> TickishScoping+tickishScoped n@ProfNote{}+  | profNoteScope n        = CostCentreScope+  | otherwise              = NoScope+tickishScoped HpcTick{}    = NoScope+tickishScoped Breakpoint{} = CostCentreScope+   -- Breakpoints are scoped: eventually we're going to do call+   -- stacks, but also this helps prevent the simplifier from moving+   -- breakpoints around and changing their result type (see #1531).+tickishScoped SourceNote{} = SoftScope++-- | Returns whether the tick scoping rule is at least as permissive+-- as the given scoping rule.+tickishScopesLike :: GenTickish pass -> TickishScoping -> Bool+tickishScopesLike t scope = tickishScoped t `like` scope+  where NoScope         `like` _               = True+        _               `like` NoScope         = False+        SoftScope       `like` _               = True+        _               `like` SoftScope       = False+        CostCentreScope `like` _               = True++-- | Returns @True@ for ticks that can be floated upwards easily even+-- where it might change execution counts, such as:+--+--   Just (tick<...> foo)+--     ==>+--   tick<...> (Just foo)+--+-- This is a combination of @tickishSoftScope@ and+-- @tickishCounts@. Note that in principle splittable ticks can become+-- floatable using @mkNoTick@ -- even though there's currently no+-- tickish for which that is the case.+tickishFloatable :: GenTickish pass -> Bool+tickishFloatable t = t `tickishScopesLike` SoftScope && not (tickishCounts t)++-- | Returns @True@ for a tick that is both counting /and/ scoping and+-- can be split into its (tick, scope) parts using 'mkNoScope' and+-- 'mkNoTick' respectively.+tickishCanSplit :: GenTickish pass -> Bool+tickishCanSplit ProfNote{profNoteScope = True, profNoteCount = True}+                   = True+tickishCanSplit _  = False++mkNoCount :: GenTickish pass -> GenTickish pass+mkNoCount n | not (tickishCounts n)   = n+            | not (tickishCanSplit n) = panic "mkNoCount: Cannot split!"+mkNoCount n@ProfNote{}                = n {profNoteCount = False}+mkNoCount _                           = panic "mkNoCount: Undefined split!"++mkNoScope :: GenTickish pass -> GenTickish pass+mkNoScope n | tickishScoped n == NoScope  = n+            | not (tickishCanSplit n)     = panic "mkNoScope: Cannot split!"+mkNoScope n@ProfNote{}                    = n {profNoteScope = False}+mkNoScope _                               = panic "mkNoScope: Undefined split!"++-- | Return @True@ if this source annotation compiles to some backend+-- code. Without this flag, the tickish is seen as a simple annotation+-- that does not have any associated evaluation code.+--+-- What this means that we are allowed to disregard the tick if doing+-- so means that we can skip generating any code in the first place. A+-- typical example is top-level bindings:+--+--   foo = tick<...> \y -> ...+--     ==>+--   foo = \y -> tick<...> ...+--+-- Here there is just no operational difference between the first and+-- the second version. Therefore code generation should simply+-- translate the code as if it found the latter.+tickishIsCode :: GenTickish pass -> Bool+tickishIsCode SourceNote{} = False+tickishIsCode _tickish     = True  -- all the rest for now+++-- | Governs the kind of expression that the tick gets placed on when+-- annotating for example using @mkTick@. If we find that we want to+-- put a tickish on an expression ruled out here, we try to float it+-- inwards until we find a suitable expression.+data TickishPlacement =++    -- | Place ticks exactly on run-time expressions. We can still+    -- move the tick through pure compile-time constructs such as+    -- other ticks, casts or type lambdas. This is the most+    -- restrictive placement rule for ticks, as all tickishs have in+    -- common that they want to track runtime processes. The only+    -- legal placement rule for counting ticks.+    PlaceRuntime++    -- | As @PlaceRuntime@, but we float the tick through all+    -- lambdas. This makes sense where there is little difference+    -- between annotating the lambda and annotating the lambda's code.+  | PlaceNonLam++    -- | In addition to floating through lambdas, cost-centre style+    -- tickishs can also be moved from constructors, non-function+    -- variables and literals. For example:+    --+    --   let x = scc<...> C (scc<...> y) (scc<...> 3) in ...+    --+    -- Neither the constructor application, the variable or the+    -- literal are likely to have any cost worth mentioning. And even+    -- if y names a thunk, the call would not care about the+    -- evaluation context. Therefore removing all annotations in the+    -- above example is safe.+  | PlaceCostCentre++  deriving (Eq)++-- | Placement behaviour we want for the ticks+tickishPlace :: GenTickish pass -> TickishPlacement+tickishPlace n@ProfNote{}+  | profNoteCount n        = PlaceRuntime+  | otherwise              = PlaceCostCentre+tickishPlace HpcTick{}     = PlaceRuntime+tickishPlace Breakpoint{}  = PlaceRuntime+tickishPlace SourceNote{}  = PlaceNonLam++-- | Returns whether one tick "contains" the other one, therefore+-- making the second tick redundant.+tickishContains :: Eq (GenTickish pass)+                => GenTickish pass -> GenTickish pass -> Bool+tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)+  = containsSpan sp1 sp2 && n1 == n2+    -- compare the String last+tickishContains t1 t2+  = t1 == t2

+ GHC/Types/TyThing.hs view

@@ -0,0 +1,315 @@+-- | A global typecheckable-thing, essentially anything that has a name.+module GHC.Types.TyThing+   ( TyThing (..)+   , MonadThings (..)+   , mkATyCon+   , mkAnId+   , pprShortTyThing+   , pprTyThingCategory+   , tyThingCategory+   , implicitTyThings+   , implicitConLikeThings+   , implicitClassThings+   , implicitTyConThings+   , implicitCoTyCon+   , isImplicitTyThing+   , tyThingParent_maybe+   , tyThingsTyCoVars+   , tyThingAvailInfo+   , tyThingTyCon+   , tyThingCoAxiom+   , tyThingDataCon+   , tyThingConLike+   , tyThingId+   )+where++import GHC.Prelude++import GHC.Types.Name+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Avail++import GHC.Core.Class+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.PatSyn+import GHC.Core.TyCo.FVs+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import Control.Monad ( liftM )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class++{-+Note [ATyCon for classes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Both classes and type constructors are represented in the type environment+as ATyCon.  You can tell the difference, and get to the class, with+   isClassTyCon :: TyCon -> Bool+   tyConClass_maybe :: TyCon -> Maybe Class+The Class and its associated TyCon have the same Name.+-}++-- | A global typecheckable-thing, essentially anything that has a name.+-- Not to be confused with a 'TcTyThing', which is also a typecheckable+-- thing but in the *local* context.  See "GHC.Tc.Utils.Env" for how to retrieve+-- a 'TyThing' given a 'Name'.+data TyThing+  = AnId     Id+  | AConLike ConLike+  | ATyCon   TyCon       -- TyCons and classes; see Note [ATyCon for classes]+  | ACoAxiom (CoAxiom Branched)++instance Outputable TyThing where+  ppr = pprShortTyThing++instance NamedThing TyThing where       -- Can't put this with the type+  getName (AnId id)     = getName id    -- decl, because the DataCon instance+  getName (ATyCon tc)   = getName tc    -- isn't visible there+  getName (ACoAxiom cc) = getName cc+  getName (AConLike cl) = conLikeName cl++mkATyCon :: TyCon -> TyThing+mkATyCon = ATyCon++mkAnId :: Id -> TyThing+mkAnId = AnId++pprShortTyThing :: TyThing -> SDoc+-- c.f. GHC.Types.TyThing.Ppr.pprTyThing, which prints all the details+pprShortTyThing thing+  = pprTyThingCategory thing <+> quotes (ppr (getName thing))++pprTyThingCategory :: TyThing -> SDoc+pprTyThingCategory = text . capitalise . tyThingCategory++tyThingCategory :: TyThing -> String+tyThingCategory (ATyCon tc)+  | isClassTyCon tc = "class"+  | otherwise       = "type constructor"+tyThingCategory (ACoAxiom _) = "coercion axiom"+tyThingCategory (AnId   _)   = "identifier"+tyThingCategory (AConLike (RealDataCon _)) = "data constructor"+tyThingCategory (AConLike (PatSynCon _))  = "pattern synonym"++++{-+Note [Implicit TyThings]+~~~~~~~~~~~~~~~~~~~~~~~~+  DEFINITION: An "implicit" TyThing is one that does not have its own+  IfaceDecl in an interface file.  Instead, its binding in the type+  environment is created as part of typechecking the IfaceDecl for+  some other thing.++Examples:+  * All DataCons are implicit, because they are generated from the+    IfaceDecl for the data/newtype.  Ditto class methods.++  * Record selectors are *not* implicit, because they get their own+    free-standing IfaceDecl.++  * Associated data/type families are implicit because they are+    included in the IfaceDecl of the parent class.  (NB: the+    IfaceClass decl happens to use IfaceDecl recursively for the+    associated types, but that's irrelevant here.)++  * Dictionary function Ids are not implicit.++  * Axioms for newtypes are implicit (same as above), but axioms+    for data/type family instances are *not* implicit (like DFunIds).+-}++-- | Determine the 'TyThing's brought into scope by another 'TyThing'+-- /other/ than itself. For example, Id's don't have any implicit TyThings+-- as they just bring themselves into scope, but classes bring their+-- dictionary datatype, type constructor and some selector functions into+-- scope, just for a start!++-- N.B. the set of TyThings returned here *must* match the set of+-- names returned by 'GHC.Iface.Load.ifaceDeclImplicitBndrs', in the sense that+-- TyThing.getOccName should define a bijection between the two lists.+-- This invariant is used in 'GHC.IfaceToCore.tc_iface_decl_fingerprint' (see+-- note [Tricky iface loop])+-- The order of the list does not matter.+implicitTyThings :: TyThing -> [TyThing]+implicitTyThings (AnId _)       = []+implicitTyThings (ACoAxiom _cc) = []+implicitTyThings (ATyCon tc)    = implicitTyConThings tc+implicitTyThings (AConLike cl)  = implicitConLikeThings cl++implicitConLikeThings :: ConLike -> [TyThing]+implicitConLikeThings (RealDataCon dc)+  = dataConImplicitTyThings dc++implicitConLikeThings (PatSynCon {})+  = []  -- Pattern synonyms have no implicit Ids; the wrapper and matcher+        -- are not "implicit"; they are simply new top-level bindings,+        -- and they have their own declaration in an interface file+        -- Unless a record pat syn when there are implicit selectors+        -- They are still not included here as `implicitConLikeThings` is+        -- used by `tcTyClsDecls` whilst pattern synonyms are typed checked+        -- by `tcTopValBinds`.++implicitClassThings :: Class -> [TyThing]+implicitClassThings cl+  = -- Does not include default methods, because those Ids may have+    --    their own pragmas, unfoldings etc, not derived from the Class object++    -- associated types+    --    No recursive call for the classATs, because they+    --    are only the family decls; they have no implicit things+    map ATyCon (classATs cl) ++++    -- superclass and operation selectors+    map AnId (classAllSelIds cl)++implicitTyConThings :: TyCon -> [TyThing]+implicitTyConThings tc+  = class_stuff +++      -- fields (names of selectors)++      -- (possibly) implicit newtype axioms+      -- or type family axioms+    implicitCoTyCon tc ++++      -- for each data constructor in order,+      --   the constructor, worker, and (possibly) wrapper+    [ thing | dc    <- tyConDataCons tc+            , thing <- AConLike (RealDataCon dc) : dataConImplicitTyThings dc ]+      -- NB. record selectors are *not* implicit, they have fully-fledged+      -- bindings that pass through the compilation pipeline as normal.+  where+    class_stuff = case tyConClass_maybe tc of+        Nothing -> []+        Just cl -> implicitClassThings cl++-- For newtypes and closed type families (only) add the implicit coercion tycon+implicitCoTyCon :: TyCon -> [TyThing]+implicitCoTyCon tc+  | Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]+  | Just co <- isClosedSynFamilyTyConWithAxiom_maybe tc+                                   = [ACoAxiom co]+  | otherwise                      = []++-- | Returns @True@ if there should be no interface-file declaration+-- for this thing on its own: either it is built-in, or it is part+-- of some other declaration, or it is generated implicitly by some+-- other declaration.+isImplicitTyThing :: TyThing -> Bool+isImplicitTyThing (AConLike cl) = case cl of+                                    RealDataCon {} -> True+                                    PatSynCon {}   -> False+isImplicitTyThing (AnId id)     = isImplicitId id+isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc+isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax++-- | tyThingParent_maybe x returns (Just p)+-- when pprTyThingInContext should print a declaration for p+-- (albeit with some "..." in it) when asked to show x+-- It returns the *immediate* parent.  So a datacon returns its tycon+-- but the tycon could be the associated type of a class, so it in turn+-- might have a parent.+tyThingParent_maybe :: TyThing -> Maybe TyThing+tyThingParent_maybe (AConLike cl) = case cl of+    RealDataCon dc  -> Just (ATyCon (dataConTyCon dc))+    PatSynCon{}     -> Nothing+tyThingParent_maybe (ATyCon tc)   = case tyConAssoc_maybe tc of+                                      Just tc -> Just (ATyCon tc)+                                      Nothing -> Nothing+tyThingParent_maybe (AnId id)     = case idDetails id of+                                      RecSelId { sel_tycon = RecSelData tc } ->+                                          Just (ATyCon tc)+                                      ClassOpId cls               ->+                                          Just (ATyCon (classTyCon cls))+                                      _other                      -> Nothing+tyThingParent_maybe _other = Nothing++tyThingsTyCoVars :: [TyThing] -> TyCoVarSet+tyThingsTyCoVars tts =+    unionVarSets $ map ttToVarSet tts+    where+        ttToVarSet (AnId id)     = tyCoVarsOfType $ idType id+        ttToVarSet (AConLike cl) = case cl of+            RealDataCon dc  -> tyCoVarsOfType $ dataConRepType dc+            PatSynCon{}     -> emptyVarSet+        ttToVarSet (ATyCon tc)+          = case tyConClass_maybe tc of+              Just cls -> (mkVarSet . fst . classTvsFds) cls+              Nothing  -> tyCoVarsOfType $ tyConKind tc+        ttToVarSet (ACoAxiom _)  = emptyVarSet++-- | The Names that a TyThing should bring into scope.  Used to build+-- the GlobalRdrEnv for the InteractiveContext.+tyThingAvailInfo :: TyThing -> [AvailInfo]+tyThingAvailInfo (ATyCon t)+   = case tyConClass_maybe t of+        Just c  -> [availTC n ((n : map getName (classMethods c)+                                 ++ map getName (classATs c))) [] ]+             where n = getName c+        Nothing -> [availTC n (n : map getName dcs) flds]+             where n    = getName t+                   dcs  = tyConDataCons t+                   flds = tyConFieldLabels t+tyThingAvailInfo (AConLike (PatSynCon p))+  = avail (getName p) : map availField (patSynFieldLabels p)+tyThingAvailInfo t+   = [avail (getName t)]++-- | Get the 'TyCon' from a 'TyThing' if it is a type constructor thing. Panics otherwise+tyThingTyCon :: HasDebugCallStack => TyThing -> TyCon+tyThingTyCon (ATyCon tc) = tc+tyThingTyCon other       = pprPanic "tyThingTyCon" (ppr other)++-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise+tyThingCoAxiom :: HasDebugCallStack => TyThing -> CoAxiom Branched+tyThingCoAxiom (ACoAxiom ax) = ax+tyThingCoAxiom other         = pprPanic "tyThingCoAxiom" (ppr other)++-- | Get the 'DataCon' from a 'TyThing' if it is a data constructor thing. Panics otherwise+tyThingDataCon :: HasDebugCallStack => TyThing -> DataCon+tyThingDataCon (AConLike (RealDataCon dc)) = dc+tyThingDataCon other                       = pprPanic "tyThingDataCon" (ppr other)++-- | Get the 'ConLike' from a 'TyThing' if it is a data constructor thing.+-- Panics otherwise+tyThingConLike :: HasDebugCallStack => TyThing -> ConLike+tyThingConLike (AConLike dc) = dc+tyThingConLike other         = pprPanic "tyThingConLike" (ppr other)++-- | Get the 'Id' from a 'TyThing' if it is a id *or* data constructor thing. Panics otherwise+tyThingId :: HasDebugCallStack => TyThing -> Id+tyThingId (AnId id)                   = id+tyThingId (AConLike (RealDataCon dc)) = dataConWrapId dc+tyThingId other                       = pprPanic "tyThingId" (ppr other)++-- | Class that abstracts out the common ability of the monads in GHC+-- to lookup a 'TyThing' in the monadic environment by 'Name'. Provides+-- a number of related convenience functions for accessing particular+-- kinds of 'TyThing'+class Monad m => MonadThings m where+        lookupThing :: Name -> m TyThing++        lookupId :: Name -> m Id+        lookupId = liftM tyThingId . lookupThing++        lookupDataCon :: Name -> m DataCon+        lookupDataCon = liftM tyThingDataCon . lookupThing++        lookupTyCon :: Name -> m TyCon+        lookupTyCon = liftM tyThingTyCon . lookupThing++-- Instance used in GHC.HsToCore.Quote+instance MonadThings m => MonadThings (ReaderT s m) where+  lookupThing = lift . lookupThing++

+ GHC/Types/TyThing.hs-boot view

@@ -0,0 +1,8 @@+module GHC.Types.TyThing where++import {-# SOURCE #-} GHC.Core.TyCon+import {-# SOURCE #-} GHC.Types.Var++data TyThing+mkATyCon :: TyCon -> TyThing+mkAnId   :: Id -> TyThing

+ GHC/Types/TyThing/Ppr.hs view

@@ -0,0 +1,211 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing TyThings+--+-- (c) The GHC Team 2005+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+module GHC.Types.TyThing.Ppr (+        pprTyThing,+        pprTyThingInContext,+        pprTyThingLoc,+        pprTyThingInContextLoc,+        pprTyThingHdr,+        pprTypeForUser,+        pprFamInst+  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Ppr (warnPprTrace)++import GHC.Types.TyThing ( TyThing(..), tyThingParent_maybe )+import GHC.Types.Name+import GHC.Types.Var.Env( emptyTidyEnv )++import GHC.Core.Type    ( Type, ArgFlag(..), mkTyVarBinders, tidyOpenType )+import GHC.Core.Coercion.Axiom ( coAxiomTyCon )+import GHC.Core.FamInstEnv( FamInst(..), FamFlavor(..) )+import GHC.Core.TyCo.Ppr ( pprUserForAll, pprTypeApp, pprSigmaType )++import GHC.Iface.Syntax ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+  , showToHeader, pprIfaceDecl )+import GHC.Iface.Make ( tyThingToIfaceDecl )++import GHC.Utils.Outputable++-- -----------------------------------------------------------------------------+-- Pretty-printing entities that we get from the GHC API++{- Note [Pretty printing via Iface syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our general plan for pretty-printing+  - Types+  - TyCons+  - Classes+  - Pattern synonyms+  ...etc...++is to convert them to Iface syntax, and pretty-print that. For example+  - pprType converts a Type to an IfaceType, and pretty prints that.+  - pprTyThing converts the TyThing to an IfaceDecl,+    and pretty prints that.++So Iface syntax plays a dual role:+  - it's the internal version of an interface files+  - it's used for pretty-printing++Why do this?++* A significant reason is that we need to be able+  to pretty-print Iface syntax (to display Foo.hi), and it was a+  pain to duplicate masses of pretty-printing goop, esp for+  Type and IfaceType.++* When pretty-printing (a type, say), we want to tidy (with+  tidyType) to avoids having (forall a a. blah) where the two+  a's have different uniques.++  Alas, for type constructors, TyCon, tidying does not work well,+  because a TyCon includes DataCons which include Types, which mention+  TyCons. And tidying can't tidy a mutually recursive data structure+  graph, only trees.++* Interface files contains fast-strings, not uniques, so the very same+  tidying must take place when we convert to IfaceDecl. E.g.+  GHC.Iface.Make.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,+  Class etc) to an IfaceDecl.++  Bottom line: IfaceDecls are already 'tidy', so it's straightforward+  to print them.++* An alternative I once explored was to ensure that TyCons get type+  variables with distinct print-names. That's ok for type variables+  but less easy for kind variables. Processing data type declarations+  is already so complicated that I don't think it's sensible to add+  the extra requirement that it generates only "pretty" types and+  kinds.++Consequences:++- Iface syntax (and IfaceType) must contain enough information to+  print nicely.  Hence, for example, the IfaceAppArgs type, which+  allows us to suppress invisible kind arguments in types+  (see Note [Suppressing invisible arguments] in GHC.Iface.Type)++- In a few places we have info that is used only for pretty-printing,+  and is totally ignored when turning Iface syntax back into Core+  (in GHC.IfaceToCore). For example, IfaceClosedSynFamilyTyCon+  stores a [IfaceAxBranch] that is used only for pretty-printing.++- See Note [Free tyvars in IfaceType] in GHC.Iface.Type++See #7730, #8776 for details   -}++--------------------+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.+pprFamInst :: FamInst -> SDoc+--  * For data instances we go via pprTyThing of the representational TyCon,+--    because there is already much cleverness associated with printing+--    data type declarations that I don't want to duplicate+--  * For type instances we print directly here; there is no TyCon+--    to give to pprTyThing+--+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes++pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })+  = pprTyThingInContextLoc (ATyCon rep_tc)++pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })+  = showWithLoc (pprDefinedAt (getName axiom)) $+    hang (text "type instance"+            <+> pprUserForAll (mkTyVarBinders Specified tvs)+                -- See Note [Printing foralls in type family instances]+                -- in GHC.Iface.Type+            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+       2 (equals <+> ppr rhs)++----------------------------+-- | Pretty-prints a 'TyThing' with its defining location.+pprTyThingLoc :: TyThing -> SDoc+pprTyThingLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThing showToHeader tyThing)++-- | Pretty-prints the 'TyThing' header. For functions and data constructors+-- the function is equivalent to 'pprTyThing' but for type constructors+-- and classes it prints only the header part of the declaration.+pprTyThingHdr :: TyThing -> SDoc+pprTyThingHdr = pprTyThing showToHeader++-- | Pretty-prints a 'TyThing' in context: that is, if the entity+-- is a data constructor, record selector, or class method, then+-- the entity's parent declaration is pretty-printed with irrelevant+-- parts omitted.+pprTyThingInContext :: ShowSub -> TyThing -> SDoc+pprTyThingInContext show_sub thing+  = go [] thing+  where+    go ss thing+      = case tyThingParent_maybe thing of+          Just parent ->+            go (getOccName thing : ss) parent+          Nothing ->+            pprTyThing+              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })+              thing++-- | Like 'pprTyThingInContext', but adds the defining location.+pprTyThingInContextLoc :: TyThing -> SDoc+pprTyThingInContextLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThingInContext showToHeader tyThing)++-- | Pretty-prints a 'TyThing'.+pprTyThing :: ShowSub -> TyThing -> SDoc+-- We pretty-print 'TyThing' via 'IfaceDecl'+-- See Note [Pretty-printing TyThings]+pprTyThing ss ty_thing+  = sdocOption sdocLinearTypes $ \show_linear_types ->+      pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)+  where+    ss' = case ss_how_much ss of+      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }+      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }+      _                   -> ss++    ppr' = AltPpr $ ppr_bndr $ getName ty_thing++    ppr_bndr :: Name -> Maybe (OccName -> SDoc)+    ppr_bndr name+      | isBuiltInSyntax name+         = Nothing+      | otherwise+         = case nameModule_maybe name of+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->+               pprModulePrefix sty mod occ <> ppr occ+             Nothing  -> WARN( True, ppr name ) Nothing+             -- Nothing is unexpected here; TyThings have External names++pprTypeForUser :: Type -> SDoc+-- The type is tidied+pprTypeForUser ty+  = pprSigmaType tidy_ty+  where+    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty+     -- Often the types/kinds we print in ghci are fully generalised+     -- and have no free variables, but it turns out that we sometimes+     -- print un-generalised kinds (eg when doing :k T), so it's+     -- better to use tidyOpenType here++showWithLoc :: SDoc -> SDoc -> SDoc+showWithLoc loc doc+    = hang doc 2 (char '\t' <> comment <+> loc)+                -- The tab tries to make them line up a bit+  where+    comment = text "--"

+ GHC/Types/TypeEnv.hs view

@@ -0,0 +1,96 @@+module GHC.Types.TypeEnv+   ( TypeEnv+   , emptyTypeEnv+   , lookupTypeEnv+   , mkTypeEnv+   , typeEnvFromEntities+   , mkTypeEnvWithImplicits+   , extendTypeEnv+   , extendTypeEnvList+   , extendTypeEnvWithIds+   , plusTypeEnv+   , typeEnvElts+   , typeEnvTyCons+   , typeEnvIds+   , typeEnvPatSyns+   , typeEnvDataCons+   , typeEnvCoAxioms+   , typeEnvClasses+   )+where++import GHC.Prelude++import GHC.Core.Class+import GHC.Core.Coercion.Axiom+import GHC.Core.ConLike+import GHC.Core.DataCon+import GHC.Core.FamInstEnv+import GHC.Core.PatSyn+import GHC.Core.TyCon++import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.TyThing++-- | A map from 'Name's to 'TyThing's, constructed by typechecking+-- local declarations or interface files+type TypeEnv = NameEnv TyThing++emptyTypeEnv    :: TypeEnv+typeEnvElts     :: TypeEnv -> [TyThing]+typeEnvTyCons   :: TypeEnv -> [TyCon]+typeEnvCoAxioms :: TypeEnv -> [CoAxiom Branched]+typeEnvIds      :: TypeEnv -> [Id]+typeEnvPatSyns  :: TypeEnv -> [PatSyn]+typeEnvDataCons :: TypeEnv -> [DataCon]+typeEnvClasses  :: TypeEnv -> [Class]+lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing++emptyTypeEnv        = emptyNameEnv+typeEnvElts     env = nameEnvElts env+typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env]+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]+typeEnvIds      env = [id | AnId id     <- typeEnvElts env]+typeEnvPatSyns  env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]+typeEnvDataCons env = [dc | AConLike (RealDataCon dc) <- typeEnvElts env]+typeEnvClasses  env = [cl | tc <- typeEnvTyCons env,+                            Just cl <- [tyConClass_maybe tc]]++mkTypeEnv :: [TyThing] -> TypeEnv+mkTypeEnv things = extendTypeEnvList emptyTypeEnv things++mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv+mkTypeEnvWithImplicits things =+  mkTypeEnv things+    `plusNameEnv`+  mkTypeEnv (concatMap implicitTyThings things)++typeEnvFromEntities :: [Id] -> [TyCon] -> [PatSyn] -> [FamInst] -> TypeEnv+typeEnvFromEntities ids tcs patsyns famInsts =+  mkTypeEnv (   map AnId ids+             ++ map ATyCon all_tcs+             ++ concatMap implicitTyConThings all_tcs+             ++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts+             ++ map (AConLike . PatSynCon) patsyns+            )+ where+  all_tcs = tcs ++ famInstsRepTyCons famInsts++lookupTypeEnv = lookupNameEnv++-- Extend the type environment+extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv+extendTypeEnv env thing = extendNameEnv env (getName thing) thing++extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv+extendTypeEnvList env things = foldl' extendTypeEnv env things++extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv+extendTypeEnvWithIds env ids+  = extendNameEnvList env [(getName id, AnId id) | id <- ids]++plusTypeEnv :: TypeEnv -> TypeEnv -> TypeEnv+plusTypeEnv env1 env2 = plusNameEnv env1 env2+

GHC/Types/Unique.hs view

@@ -33,43 +33,16 @@         getKey,         mkUnique, unpkUnique,         eqUnique, ltUnique,-        incrUnique,+        incrUnique, stepUnique,          newTagUnique,-        initTyVarUnique,-        initExitJoinUnique,         nonDetCmpUnique,         isValidKnownKeyUnique, -        -- ** Making built-in uniques--        -- now all the built-in GHC.Types.Uniques (and functions to make them)-        -- [the Oh-So-Wonderful Haskell module system wins again...]-        mkAlphaTyVarUnique,-        mkPrimOpIdUnique, mkPrimOpWrapperUnique,-        mkPreludeMiscIdUnique, mkPreludeDataConUnique,-        mkPreludeTyConUnique, mkPreludeClassUnique,-        mkCoVarUnique,--        mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,-        mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,-        mkCostCentreUnique,--        mkBuiltinUnique,-        mkPseudoUniqueD,-        mkPseudoUniqueE,-        mkPseudoUniqueH,--        -- ** Deriving uniques-        -- *** From TyCon name uniques-        tyConRepNameUnique,-        -- *** From DataCon name uniques-        dataConWorkerUnique, dataConTyRepNameUnique,-         -- ** Local uniques         -- | These are exposed exclusively for use by 'GHC.Types.Var.Env.uniqAway', which         -- has rather peculiar needs. See Note [Local uniques].-        mkLocalUnique, minLocalUnique, maxLocalUnique+        mkLocalUnique, minLocalUnique, maxLocalUnique,     ) where  #include "HsVersions.h"@@ -77,16 +50,15 @@  import GHC.Prelude -import GHC.Types.Basic import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Misc+import GHC.Utils.Panic  -- just for implementing a fast [0,61) -> Char function import GHC.Exts (indexCharOffAddr#, Char(..), Int(..))  import Data.Char        ( chr, ord )-import Data.Bits  {- ************************************************************************@@ -95,8 +67,20 @@ *                                                                      * ************************************************************************ -The @Chars@ are ``tag letters'' that identify the @UniqueSupply@.-Fast comparison is everything on @Uniques@:+Note [Uniques and masks]+~~~~~~~~~~~~~~~~~~~~~~~~+A `Unique` in GHC is a Word-sized value composed of two pieces:+* A "mask", of width `UNIQUE_TAG_BITS`, in the high order bits+* A number, of width `uNIQUE_BITS`, which fills up the remainder of the Word++The mask is typically an ASCII character.  It is typically used to make it easier+to distinguish uniques constructed by different parts of the compiler.+There is a (potentially incomplete) list of unique masks used given in+GHC.Builtin.Uniques. See Note [Uniques-prelude - Uniques for wired-in Prelude things]++`mkUnique` constructs a `Unique` from its pieces+  mkUnique :: Char -> Int -> Unique+ -}  -- | Unique identifier.@@ -158,8 +142,7 @@ -- and as long as the Char fits in 8 bits, which we assume anyway!  mkUnique :: Char -> Int -> Unique       -- Builds a unique from pieces--- NOT EXPORTED, so that we can see all the Chars that---               are used in this one module+-- EXPORTED and used only in GHC.Builtin.Uniques mkUnique c i   = MkUnique (tag .|. bits)   where@@ -340,109 +323,3 @@     {-# INLINE chooseChar62 #-}     chooseChar62 (I# n) = C# (indexCharOffAddr# chars62 n)     chars62 = "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"#--{--************************************************************************-*                                                                      *-\subsection[Uniques-prelude]{@Uniques@ for wired-in Prelude things}-*                                                                      *-************************************************************************--Allocation of unique supply characters:-        v,t,u : for renumbering value-, type- and usage- vars.-        B:   builtin-        C-E: pseudo uniques     (used in native-code generator)-        X:   uniques from mkLocalUnique-        _:   unifiable tyvars   (above)-        0-9: prelude things below-             (no numbers left any more..)-        ::   (prelude) parallel array data constructors--        other a-z: lower case chars for unique supplies.  Used so far:--        d       desugarer-        f       AbsC flattener-        g       SimplStg-        k       constraint tuple tycons-        m       constraint tuple datacons-        n       Native codegen-        r       Hsc name cache-        s       simplifier-        z       anonymous sums--}--mkAlphaTyVarUnique     :: Int -> Unique-mkPreludeClassUnique   :: Int -> Unique-mkPreludeTyConUnique   :: Int -> Unique-mkPreludeDataConUnique :: Arity -> Unique-mkPrimOpIdUnique       :: Int -> Unique--- See Note [Primop wrappers] in GHC.Builtin.PrimOps.-mkPrimOpWrapperUnique  :: Int -> Unique-mkPreludeMiscIdUnique  :: Int -> Unique-mkCoVarUnique          :: Int -> Unique--mkAlphaTyVarUnique   i = mkUnique '1' i-mkCoVarUnique        i = mkUnique 'g' i-mkPreludeClassUnique i = mkUnique '2' i------------------------------------------------------- Wired-in type constructor keys occupy *two* slots:---    * u: the TyCon itself---    * u+1: the TyConRepName of the TyCon-mkPreludeTyConUnique i                = mkUnique '3' (2*i)--tyConRepNameUnique :: Unique -> Unique-tyConRepNameUnique  u = incrUnique u------------------------------------------------------- Wired-in data constructor keys occupy *three* slots:---    * u: the DataCon itself---    * u+1: its worker Id---    * u+2: the TyConRepName of the promoted TyCon--- Prelude data constructors are too simple to need wrappers.--mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic-----------------------------------------------------dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique-dataConWorkerUnique  u = incrUnique u-dataConTyRepNameUnique u = stepUnique u 2-----------------------------------------------------mkPrimOpIdUnique op         = mkUnique '9' (2*op)-mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)-mkPreludeMiscIdUnique  i    = mkUnique '0' i---- The "tyvar uniques" print specially nicely: a, b, c, etc.--- See pprUnique for details--initTyVarUnique :: Unique-initTyVarUnique = mkUnique 't' 0--mkPseudoUniqueD, mkPseudoUniqueE, mkPseudoUniqueH,-   mkBuiltinUnique :: Int -> Unique--mkBuiltinUnique i = mkUnique 'B' i-mkPseudoUniqueD i = mkUnique 'D' i -- used in NCG for getUnique on RealRegs-mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs-mkPseudoUniqueH i = mkUnique 'H' i -- used in NCG spiller to create spill VirtualRegs--mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique-mkRegSingleUnique = mkUnique 'R'-mkRegSubUnique    = mkUnique 'S'-mkRegPairUnique   = mkUnique 'P'-mkRegClassUnique  = mkUnique 'L'--mkCostCentreUnique :: Int -> Unique-mkCostCentreUnique = mkUnique 'C'--mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique--- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence-mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)-mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)-mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)-mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)--initExitJoinUnique :: Unique-initExitJoinUnique = mkUnique 's' 0-

GHC/Types/Unique/DFM.hs view

@@ -15,8 +15,10 @@ -}  {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} @@ -38,6 +40,7 @@         adjustUDFM_Directly,         alterUDFM,         mapUDFM,+        mapMaybeUDFM,         plusUDFM,         plusUDFM_C,         lookupUDFM, lookupUDFM_Directly,@@ -121,7 +124,7 @@   TaggedVal     val     {-# UNPACK #-} !Int -- ^ insertion time-  deriving (Data, Functor)+  deriving stock (Data, Functor, Foldable, Traversable)  taggedFst :: TaggedVal val -> val taggedFst (TaggedVal v _) = v@@ -398,6 +401,10 @@ -- | Map a function over every value in a UniqDFM mapUDFM :: (elt1 -> elt2) -> UniqDFM key elt1 -> UniqDFM key elt2 mapUDFM f (UDFM m i) = UDFM (M.map (fmap f) m) i++mapMaybeUDFM :: forall elt1 elt2 key.+                (elt1 -> Maybe elt2) -> UniqDFM key elt1 -> UniqDFM key elt2+mapMaybeUDFM f (UDFM m i) = UDFM (M.mapMaybe (traverse f) m) i  anyUDFM :: (elt -> Bool) -> UniqDFM key elt -> Bool anyUDFM p (UDFM m _i) = M.foldr ((||) . p . taggedFst) False m

GHC/Types/Unique/FM.hs view

@@ -23,6 +23,7 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-}  module GHC.Types.Unique.FM (@@ -34,6 +35,7 @@         emptyUFM,         unitUFM,         unitDirectlyUFM,+        zipToUFM,         listToUFM,         listToUFM_Directly,         listToUFM_C,@@ -52,8 +54,8 @@         plusUFM_C,         plusUFM_CD,         plusUFM_CD2,-        mergeUFM,         plusMaybeUFM_C,+        mergeUFM,         plusUFMList,         minusUFM,         intersectUFM,@@ -77,12 +79,16 @@         pprUniqFM, pprUFM, pprUFMWithKeys, pluralUFM     ) where +#include "HsVersions.h"+ import GHC.Prelude  import GHC.Types.Unique ( Uniquable(..), Unique, getKey ) import GHC.Utils.Outputable-+import GHC.Utils.Panic (assertPanic)+import GHC.Utils.Misc (debugIsOn) import qualified Data.IntMap as M+import qualified Data.IntMap.Strict as MS import qualified Data.IntSet as S import Data.Data import qualified Data.Semigroup as Semi@@ -116,6 +122,19 @@ unitDirectlyUFM :: Unique -> elt -> UniqFM key elt unitDirectlyUFM u v = UFM (M.singleton (getKey u) v) +-- zipToUFM ks vs = listToUFM (zip ks vs)+-- This function exists because it's a common case (#18535), and+-- it's inefficient to first build a list of pairs, and then immediately+-- take it apart. Astonishingly, fusing this one list away reduces total+-- compiler allocation by more than 10% (in T12545, see !3935)+-- Note that listToUFM (zip ks vs) performs similarly, but+-- the explicit recursion avoids relying too much on fusion.+zipToUFM :: Uniquable key => [key] -> [elt] -> UniqFM key elt+zipToUFM ks vs = ASSERT( length ks == length vs ) innerZip emptyUFM ks vs+  where+    innerZip ufm (k:kList) (v:vList) = innerZip (addToUFM ufm k v) kList vList+    innerZip ufm _ _ = ufm+ listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM @@ -261,7 +280,7 @@   -> UniqFM key eltb   -> UniqFM key eltc mergeUFM f g h (UFM xm) (UFM ym)-  = UFM $ M.mergeWithKey+  = UFM $ MS.mergeWithKey       (\_ x y -> (x `f` y))       (coerce g)       (coerce h)

+ GHC/Types/Unique/Map.hs view

@@ -0,0 +1,206 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -Wall #-}++-- Like 'UniqFM', these are maps for keys which are Uniquable.+-- Unlike 'UniqFM', these maps also remember their keys, which+-- makes them a much better drop in replacement for 'Data.Map.Map'.+--+-- Key preservation is right-biased.+module GHC.Types.Unique.Map (+    UniqMap(..),+    emptyUniqMap,+    isNullUniqMap,+    unitUniqMap,+    listToUniqMap,+    listToUniqMap_C,+    addToUniqMap,+    addListToUniqMap,+    addToUniqMap_C,+    addToUniqMap_Acc,+    alterUniqMap,+    addListToUniqMap_C,+    adjustUniqMap,+    delFromUniqMap,+    delListFromUniqMap,+    plusUniqMap,+    plusUniqMap_C,+    plusMaybeUniqMap_C,+    plusUniqMapList,+    minusUniqMap,+    intersectUniqMap,+    disjointUniqMap,+    mapUniqMap,+    filterUniqMap,+    partitionUniqMap,+    sizeUniqMap,+    elemUniqMap,+    lookupUniqMap,+    lookupWithDefaultUniqMap,+    anyUniqMap,+    allUniqMap,+    -- Non-deterministic functions omitted+) where++import GHC.Prelude++import GHC.Types.Unique.FM++import GHC.Types.Unique+import GHC.Utils.Outputable++import Data.Semigroup as Semi ( Semigroup(..) )+import Data.Coerce+import Data.Maybe+import Data.Data++-- | Maps indexed by 'Uniquable' keys+newtype UniqMap k a = UniqMap (UniqFM k (k, a))+    deriving (Data, Eq, Functor)+type role UniqMap nominal representational++instance Semigroup (UniqMap k a) where+  (<>) = plusUniqMap++instance Monoid (UniqMap k a) where+    mempty = emptyUniqMap+    mappend = (Semi.<>)++instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where+    ppr (UniqMap m) =+        brackets $ fsep $ punctuate comma $+        [ ppr k <+> text "->" <+> ppr v+        | (k, v) <- eltsUFM m ]++liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)+liftC f (_, v) (k', v') = (k', f v v')++emptyUniqMap :: UniqMap k a+emptyUniqMap = UniqMap emptyUFM++isNullUniqMap :: UniqMap k a -> Bool+isNullUniqMap (UniqMap m) = isNullUFM m++unitUniqMap :: Uniquable k => k -> a -> UniqMap k a+unitUniqMap k v = UniqMap (unitUFM k (k, v))++listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a+listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])++listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a+listToUniqMap_C f kvs = UniqMap $+    listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]++addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a+addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)++addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a+addListToUniqMap (UniqMap m) kvs = UniqMap $+    addListToUFM m [(k,(k,v)) | (k,v) <- kvs]++addToUniqMap_C :: Uniquable k+               => (a -> a -> a)+               -> UniqMap k a+               -> k+               -> a+               -> UniqMap k a+addToUniqMap_C f (UniqMap m) k v = UniqMap $+    addToUFM_C (liftC f) m k (k, v)++addToUniqMap_Acc :: Uniquable k+                 => (b -> a -> a)+                 -> (b -> a)+                 -> UniqMap k a+                 -> k+                 -> b+                 -> UniqMap k a+addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $+    addToUFM_Acc (\b (k, v) -> (k, exi b v))+                 (\b -> (k0, new b))+                 m k0 v0++alterUniqMap :: Uniquable k+             => (Maybe a -> Maybe a)+             -> UniqMap k a+             -> k+             -> UniqMap k a+alterUniqMap f (UniqMap m) k = UniqMap $+    alterUFM (fmap (k,) . f . fmap snd) m k++addListToUniqMap_C+    :: Uniquable k+    => (a -> a -> a)+    -> UniqMap k a+    -> [(k, a)]+    -> UniqMap k a+addListToUniqMap_C f (UniqMap m) kvs = UniqMap $+    addListToUFM_C (liftC f) m+        [(k,(k,v)) | (k,v) <- kvs]++adjustUniqMap+    :: Uniquable k+    => (a -> a)+    -> UniqMap k a+    -> k+    -> UniqMap k a+adjustUniqMap f (UniqMap m) k = UniqMap $+    adjustUFM (\(_,v) -> (k,f v)) m k++delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a+delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k++delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a+delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks++plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a+plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2++plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a+plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $+    plusUFM_C (liftC f) m1 m2++plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a+plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $+    plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2++plusUniqMapList :: [UniqMap k a] -> UniqMap k a+plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)++minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a+minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2++intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a+intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2++disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool+disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2++mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b+mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance++filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a+filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m++partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)+partitionUniqMap f (UniqMap m) =+    coerce $ partitionUFM (f . snd) m++sizeUniqMap :: UniqMap k a -> Int+sizeUniqMap (UniqMap m) = sizeUFM m++elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool+elemUniqMap k (UniqMap m) = elemUFM k m++lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a+lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)++lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a+lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))++anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool+anyUniqMap f (UniqMap m) = anyUFM (f . snd) m++allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool+allUniqMap f (UniqMap m) = allUFM (f . snd) m

+ 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', _)    , (y', Nothing))     -> (Nothing, set_indirect y' x')+    ((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

GHC/Types/Unique/Supply.hs view

@@ -3,18 +3,12 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# OPTIONS_GHC -fno-state-hack #-}-    -- This -fno-state-hack is important-    -- See Note [Optimising the unique supply]- {-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE BangPatterns #-}--#if !defined(GHC_LOADED_INTO_GHCI) {-# LANGUAGE UnboxedTuples #-}-#endif  module GHC.Types.Unique.Supply (         -- * Main data type@@ -40,17 +34,24 @@ import GHC.Prelude  import GHC.Types.Unique-import GHC.Utils.Panic.Plain (panic)+import GHC.Utils.Panic.Plain  import GHC.IO  import GHC.Utils.Monad import Control.Monad-import Data.Bits import Data.Char-import GHC.Exts( inline )+import GHC.Exts( Ptr(..), noDuplicate#, oneShot )+#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0)+import GHC.Exts( Int(..), word2Int#, fetchAddWordAddr#, plusWord#, readWordOffAddr# )+#if defined(DEBUG)+import GHC.Utils.Misc+#endif+#endif+import Foreign.Storable  #include "Unique.h"+#include "HsVersions.h"  {- ************************************************************************@@ -81,111 +82,103 @@      * The fresh node      * A thunk for each sub-tree -Note [Optimising the unique supply]+Note [How unique supplies are used] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The inner loop of mkSplitUniqSupply is a function closure--     mk_supply :: IO UniqSupply-     mk_supply = unsafeInterleaveIO $-                 genSym      >>= \ u ->-                 mk_supply   >>= \ s1 ->-                 mk_supply   >>= \ s2 ->-                 return (MkSplitUniqSupply (mask .|. u) s1 s2)+The general design (used throughout GHC) is to: -It's a classic example of an IO action that is captured-and the called repeatedly (see #18238 for some discussion).-It turns out that we can get something like+* For creating new uniques either a UniqSupply is used and threaded through+  or for monadic code a MonadUnique instance might conjure up uniques using+  `uniqFromMask`.+* Different parts of the compiler will use a UniqSupply or MonadUnique instance+  with a specific mask. This way the different parts of the compiler will+  generate uniques with different masks. -  $wmkSplitUniqSupply c# s-    = letrec-        mk_supply-          = \s -> unsafeDupableInterleaveIO1-                    (\s2 -> case noDuplicate# s2 of s3 ->-                            ...-                            case mk_supply s4 of (# s5, t1 #) ->-                            ...-                            (# s6, MkSplitUniqSupply ... #)-      in mk_supply s+If different code shares the same mask then care has to be taken that all uniques+still get distinct numbers. Usually this is done by relying on genSym which+has *one* counter per GHC invocation that is relied on by all calls to it.+But using something like the address for pinned objects works as well and in fact is done+for fast strings. -This is bad becuase we allocate that inner (\s2...) every time.-Why doesn't full laziness float out the (\s2...)?  Because of-the state hack (#18238).+This is important for example in the simplifier. Most passes of the simplifier use+the same mask 's'. However in some places we create a unique supply using `mkSplitUniqSupply`+and thread it through the code, while in GHC.Core.Opt.Simplify.Monad  we use the+`instance MonadUnique SimplM`, which uses `mkSplitUniqSupply` in getUniqueSupplyM+and `uniqFromMask` in getUniqeM. -So for this module we switch the state hack off -- it's an example-of when it makes things worse rather than better.  And we use-multiShotIO (see Note [multiShotIO]) thus:+Ultimately all these boil down to each new unique consisting of the mask and the result from+a call to `genSym`. The later producing a distinct number for each invocation ensuring+uniques are distinct. -     mk_supply = multiShotIO $-                 unsafeInterleaveIO $-                 genSym      >>= \ u ->-                 ...+Note [Optimising the unique supply]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The inner loop of mkSplitUniqSupply is a function closure -Now full laziness can float that lambda out, and we get+     mk_supply s0 =+        case noDuplicate# s0 of { s1 ->+        case unIO genSym s1 of { (# s2, u #) ->+        case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->+        case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->+        (# s4, MkSplitUniqSupply (mask .|. u) x y #)+        }}}} -  $wmkSplitUniqSupply c# s-    = letrec-        lvl = \s2 -> case noDuplicate# s2 of s3 ->-                     ...-                     case unsafeDupableInterleaveIO-                              lvl s4 of (# s5, t1 #) ->-                     ...-                     (# s6, MkSplitUniqSupply ... #)-      in unsafeDupableInterleaveIO1 lvl s+It's a classic example of an IO action that is captured and then called+repeatedly (see #18238 for some discussion). It mustn't allocate!  The test+perf/should_run/UniqLoop keeps track of this loop.  Watch it carefully. -This is all terribly delicate.  It just so happened that before I-fixed #18078, and even with the state-hack still enabled, we were-getting this:+We used to write it as: -  $wmkSplitUniqSupply c# s-    = letrec-        mk_supply = \s2 -> case noDuplicate# s2 of s3 ->-                           ...-                           case mks_help s3 of (# s5,t1 #) ->-                           ...-                           (# s6, MkSplitUniqSupply ... #)-        mks_help = unsafeDupableInterleaveIO mk_supply-           -- mks_help marked as loop breaker-      in mks_help s+     mk_supply :: IO UniqSupply+     mk_supply = unsafeInterleaveIO $+                 genSym      >>= \ u ->+                 mk_supply   >>= \ s1 ->+                 mk_supply   >>= \ s2 ->+                 return (MkSplitUniqSupply (mask .|. u) s1 s2) -The fact that we didn't need full laziness was somewhat fortuitious.-We got the right number of allocations. But the partial application of-the arity-2 unsafeDupableInterleaveIO in mks_help makes it quite a-bit slower.  (Test perf/should_run/UniqLoop had a 20% perf change.)+and to rely on -fno-state-hack, full laziness and inlining to get the same+result. It was very brittle and required enabling -fno-state-hack globally. So+it has been rewritten using lower level constructs to explicitly state what we+want. -Sigh.  The test perf/should_run/UniqLoop keeps track of this loop.-Watch it carefully.+Note [Optimising use of unique supplies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When it comes to having a way to generate new Uniques+there are generally three ways to deal with this: -Note [multiShotIO]-~~~~~~~~~~~~~~~~~~-The function multiShotIO :: IO a -> IO a-says that the argument IO action may be invoked repeatedly (is-multi-shot), and so there should be a multi-shot lambda around it.-It's quite easy to define, in any module with `-fno-state-hack`:-    multiShotIO :: IO a -> IO a-    {-# INLINE multiShotIO #-}-    multiShotIO (IO m) = IO (\s -> inline m s)+For pure code the only good approach is to take an UniqSupply+as argument. Then  thread it through the code splitting it+for sub-passes or when creating uniques.+The code for this is about as optimized as it gets, but we can't+get around the need to allocate one `UniqSupply` for each Unique+we need. -Because of -fno-state-hack, that '\s' will be multi-shot. Now,-ignoring the casts from IO:-    multiShotIO (\ss{one-shot}. blah)-    ==> let m = \ss{one-shot}. blah-        in \s. inline m s-    ==> \s. (\ss{one-shot}.blah) s-    ==> \s. blah[s/ss]+For code in IO we can improve on this by threading only the *mask*+we are going to use for Uniques. Using `uniqFromMask` to+generate uniques as needed. This gets rid of the overhead of+allocating a new UniqSupply for each unique generated. It also avoids+frequent state updates when the Unique/Mask is part of the state in a+state monad. -The magic `inline` function does two things-* It prevents eta reduction.  If we wrote just-      multiShotIO (IO m) = IO (\s -> m s)-  the lamda would eta-reduce to 'm' and all would be lost.+For monadic code in IO which always uses the same mask we can go further+and hardcode the mask into the MonadUnique instance. On top of all the+benefits of threading the mask this *also* has the benefit of avoiding+the mask getting captured in thunks, or being passed around at runtime.+It does however come at the cost of having to use a fixed Mask for all+code run in this Monad. But rememeber, the Mask is purely cosmetic:+See Note [Uniques and masks]. -* It helps ensure that 'm' really does inline.+NB: It's *not* an optimization to pass around the UniqSupply inside an+IORef instead of the mask. While this would avoid frequent state updates+it still requires allocating one UniqSupply per Unique. On top of some+overhead for reading/writing to/from the IORef. -Note that 'inline' evaporates in phase 0.  See Note [inlineIdMagic]-in GHC.Core.Opt.ConstantFold.match_inline.+All of this hinges on the assumption that UniqSupply and+uniqFromMask use the same source of distinct numbers (`genSym`) which+allows both to be used at the same time, with the same mask, while still+ensuring distinct uniques.+One might consider this fact to be an "accident". But GHC worked like this+as far back as source control history goes. It also allows the later two+optimizations to be used. So it seems safe to depend on this fact. -The INLINE pragma on multiShotIO is very important, else the-'inline' call will evaporate when compiling the module that-defines 'multiShotIO', before it is ever exported. -}  @@ -201,36 +194,73 @@                                 -- when split => these two supplies  mkSplitUniqSupply :: Char -> IO UniqSupply--- ^ Create a unique supply out of thin air. The character given must--- be distinct from those of all calls to this function in the compiler--- for the values generated to be truly unique.+-- ^ Create a unique supply out of thin air.+-- The "mask" (Char) supplied is purely cosmetic, making it easier+-- to figure out where a Unique was born. See+-- Note [Uniques and masks].+--+-- The payload part of the Uniques allocated from this UniqSupply are+-- guaranteed distinct wrt all other supplies, regardless of their "mask".+-- This is achieved by allocating the payload part from+-- a single source of Uniques, namely `genSym`, shared across+-- all UniqSupply's.  -- See Note [How the unique supply works] -- See Note [Optimising the unique supply] mkSplitUniqSupply c-  = mk_supply+  = unsafeDupableInterleaveIO (IO mk_supply)+   where-     !mask = ord c `shiftL` uNIQUE_BITS+     !mask = ord c `unsafeShiftL` uNIQUE_BITS          -- Here comes THE MAGIC: see Note [How the unique supply works]         -- This is one of the most hammered bits in the whole compiler         -- See Note [Optimising the unique supply]-        -- NB: Use unsafeInterleaveIO for thread-safety.-     mk_supply = multiShotIO $-                 unsafeInterleaveIO $-                 genSym      >>= \ u ->-                 mk_supply   >>= \ s1 ->-                 mk_supply   >>= \ s2 ->-                 return (MkSplitUniqSupply (mask .|. u) s1 s2)--multiShotIO :: IO a -> IO a-{-# INLINE multiShotIO #-}--- See Note [multiShotIO]-multiShotIO (IO m) = IO (\s -> inline m s)+        -- NB: Use noDuplicate# for thread-safety.+     mk_supply s0 =+        case noDuplicate# s0 of { s1 ->+        case unIO genSym s1 of { (# s2, u #) ->+        -- deferred IO computations+        case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s2 of { (# s3, x #) ->+        case unIO (unsafeDupableInterleaveIO (IO mk_supply)) s3 of { (# s4, y #) ->+        (# s4, MkSplitUniqSupply (mask .|. u) x y #)+        }}}} +#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) foreign import ccall unsafe "genSym" genSym :: IO Int-foreign import ccall unsafe "initGenSym" initUniqSupply :: Int -> Int -> IO ()+#else+genSym :: IO Int+genSym = do+    let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1+    let !(Ptr counter) = ghc_unique_counter+    let !(Ptr inc_ptr) = ghc_unique_inc+    u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of+        (# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of+            (# s2, val #) ->+                let !u = I# (word2Int# (val `plusWord#` inc)) .&. mask+                in (# s2, u #)+#if defined(DEBUG)+    -- Uh oh! We will overflow next time a unique is requested.+    -- (Note that if the increment isn't 1 we may miss this check)+    MASSERT(u /= mask)+#endif+    return u+#endif +foreign import ccall unsafe "&ghc_unique_counter" ghc_unique_counter :: Ptr Word+foreign import ccall unsafe "&ghc_unique_inc"     ghc_unique_inc     :: Ptr Int++initUniqSupply :: Word -> Int -> IO ()+initUniqSupply counter inc = do+    poke ghc_unique_counter counter+    poke ghc_unique_inc     inc++uniqFromMask :: Char -> IO Unique+uniqFromMask !mask+  = do { uqNum <- genSym+       ; return $! mkUnique mask uqNum }++ splitUniqSupply :: UniqSupply -> (UniqSupply, UniqSupply) -- ^ Build two 'UniqSupply' from a single one, each of which -- can supply its own 'Unique'.@@ -250,12 +280,6 @@ uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily n : uniqsFromSupply s2 takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily n, s1) -uniqFromMask :: Char -> IO Unique-uniqFromMask mask-  = do { uqNum <- genSym-       ; return $! mkUnique mask uqNum }-- {- ************************************************************************ *                                                                      *@@ -264,33 +288,34 @@ ************************************************************************ -} --- Avoids using unboxed tuples when loading into GHCi-#if !defined(GHC_LOADED_INTO_GHCI)- type UniqResult result = (# result, UniqSupply #)  pattern UniqResult :: a -> b -> (# a, b #) pattern UniqResult x y = (# x, y #) {-# COMPLETE UniqResult #-} -#else--data UniqResult result = UniqResult !result {-# UNPACK #-} !UniqSupply-  deriving (Functor)--#endif- -- | A monad which just gives the ability to obtain 'Unique's newtype UniqSM result = USM { unUSM :: UniqSupply -> UniqResult result }-    deriving (Functor) +-- See Note [The one-shot state monad trick] for why we don't derive this.+instance Functor UniqSM where+  fmap f (USM m) = mkUniqSM $ \us ->+      case m us of+        (# r, us' #) -> UniqResult (f r) us'++-- | Smart constructor for 'UniqSM', as described in Note [The one-shot state+-- monad trick].+mkUniqSM :: (UniqSupply -> UniqResult a) -> UniqSM a+mkUniqSM f = USM (oneShot f)+{-# INLINE mkUniqSM #-}+ instance Monad UniqSM where   (>>=) = thenUs   (>>)  = (*>)  instance Applicative UniqSM where     pure = returnUs-    (USM f) <*> (USM x) = USM $ \us0 -> case f us0 of+    (USM f) <*> (USM x) = mkUniqSM $ \us0 -> case f us0 of                             UniqResult ff us1 -> case x us1 of                               UniqResult xx us2 -> UniqResult (ff xx) us2     (*>) = thenUs_@@ -317,22 +342,22 @@ liftUSM (USM m) us0 = case m us0 of UniqResult a us1 -> (a, us1)  instance MonadFix UniqSM where-    mfix m = USM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)+    mfix m = mkUniqSM (\us0 -> let (r,us1) = liftUSM (m r) us0 in UniqResult r us1)  thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b thenUs (USM expr) cont-  = USM (\us0 -> case (expr us0) of+  = mkUniqSM (\us0 -> case (expr us0) of                    UniqResult result us1 -> unUSM (cont result) us1)  thenUs_ :: UniqSM a -> UniqSM b -> UniqSM b thenUs_ (USM expr) (USM cont)-  = USM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })+  = mkUniqSM (\us0 -> case (expr us0) of { UniqResult _ us1 -> cont us1 })  returnUs :: a -> UniqSM a-returnUs result = USM (\us -> UniqResult result us)+returnUs result = mkUniqSM (\us -> UniqResult result us)  getUs :: UniqSM UniqSupply-getUs = USM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)+getUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of (us1,us2) -> UniqResult us1 us2)  -- | A monad for generating unique identifiers class Monad m => MonadUnique m where@@ -356,9 +381,9 @@     getUniquesM = getUniquesUs  getUniqueUs :: UniqSM Unique-getUniqueUs = USM (\us0 -> case takeUniqFromSupply us0 of+getUniqueUs = mkUniqSM (\us0 -> case takeUniqFromSupply us0 of                            (u,us1) -> UniqResult u us1)  getUniquesUs :: UniqSM [Unique]-getUniquesUs = USM (\us0 -> case splitUniqSupply us0 of+getUniquesUs = mkUniqSM (\us0 -> case splitUniqSupply us0 of                             (us1,us2) -> UniqResult (uniqsFromSupply us1) us2)

GHC/Types/Var.hs view

@@ -68,15 +68,17 @@          -- * ArgFlags         ArgFlag(Invisible,Required,Specified,Inferred),-        isVisibleArgFlag, isInvisibleArgFlag, sameVis,         AnonArgFlag(..), Specificity(..),+        isVisibleArgFlag, isInvisibleArgFlag, isInferredArgFlag,+        sameVis,          -- * TyVar's         VarBndr(..), TyCoVarBinder, TyVarBinder, InvisTVBinder, ReqTVBinder,         binderVar, binderVars, binderArgFlag, binderType,         mkTyCoVarBinder, mkTyCoVarBinders,         mkTyVarBinder, mkTyVarBinders,-        isTyVarBinder, tyVarSpecToBinder, tyVarSpecToBinders,+        isTyVarBinder,+        tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,         mapVarBndr, mapVarBndrs, lookupVarBndr,          -- ** Constructing TyVar's@@ -103,12 +105,13 @@ import {-# SOURCE #-}   GHC.Types.Id.Info( IdDetails, IdInfo, coVarDetails, isCoVarDetails,                                            vanillaIdInfo, pprIdDetails ) import {-# SOURCE #-}   GHC.Builtin.Types ( manyDataConTy )-import GHC.Types.Name hiding (varName)+import {-# SOURCE #-}   GHC.Types.Name import GHC.Types.Unique ( Uniquable, Unique, getKey, getUnique                         , mkUniqueGrimily, nonDetCmpUnique ) import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.Data @@ -466,13 +469,18 @@  -- | Does this 'ArgFlag' classify an argument that is written in Haskell? isVisibleArgFlag :: ArgFlag -> Bool-isVisibleArgFlag Required = True-isVisibleArgFlag _        = False+isVisibleArgFlag af = not (isInvisibleArgFlag af)  -- | Does this 'ArgFlag' classify an argument that is not written in Haskell? isInvisibleArgFlag :: ArgFlag -> Bool-isInvisibleArgFlag = not . isVisibleArgFlag+isInvisibleArgFlag (Invisible {}) = True+isInvisibleArgFlag Required       = False +isInferredArgFlag :: ArgFlag -> Bool+-- More restrictive than isInvisibleArgFlag+isInferredArgFlag (Invisible InferredSpec) = True+isInferredArgFlag _                        = False+ -- | Do these denote the same level of visibility? 'Required' -- arguments are visible, others are not. So this function -- equates 'Specified' and 'Inferred'. Used for printing.@@ -595,20 +603,40 @@ *                                                                      * ********************************************************************* -} --- Variable Binder------ VarBndr is polymorphic in both var and visibility fields.--- Currently there are nine different uses of 'VarBndr':---   * Var.TyVarBinder               = VarBndr TyVar ArgFlag---   * Var.TyCoVarBinder             = VarBndr TyCoVar ArgFlag---   * Var.InvisTVBinder             = VarBndr TyVar Specificity---   * Var.ReqTVBinder               = VarBndr TyVar ()---   * TyCon.TyConBinder             = VarBndr TyVar TyConBndrVis---   * TyCon.TyConTyCoBinder         = VarBndr TyCoVar TyConBndrVis---   * IfaceType.IfaceForAllBndr     = VarBndr IfaceBndr ArgFlag---   * IfaceType.IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis---   * IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity+{- Note [The VarBndr type and its uses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+VarBndr is polymorphic in both var and visibility fields.+Currently there are nine different uses of 'VarBndr':++* Var.TyCoVarBinder = VarBndr TyCoVar ArgFlag+  Binder of a forall-type; see ForAllTy in GHC.Core.TyCo.Rep++* Var.TyVarBinder = VarBndr TyVar ArgFlag+  Subset of TyCoVarBinder when we are sure the binder is a TyVar++* Var.InvisTVBinder = VarBndr TyVar Specificity+  Specialised form of TyVarBinder, when ArgFlag = Invisible s+  See GHC.Core.Type.splitForAllInvisTVBinders++* Var.ReqTVBinder = VarBndr TyVar ()+  Specialised form of TyVarBinder, when ArgFlag = Required+  See GHC.Core.Type.splitForAllReqTVBinders+  This one is barely used++* TyCon.TyConBinder = VarBndr TyVar TyConBndrVis+  Binders of a TyCon; see TyCon in GHC.Core.TyCon++* TyCon.TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis+  Binders of a PromotedDataCon+  See Note [Promoted GADT data construtors] in GHC.Core.TyCon++* IfaceType.IfaceForAllBndr     = VarBndr IfaceBndr ArgFlag+* IfaceType.IfaceForAllSpecBndr = VarBndr IfaceBndr Specificity+* IfaceType.IfaceTyConBinder    = VarBndr IfaceBndr TyConBndrVis+-}+ data VarBndr var argf = Bndr var argf+  -- See Note [The VarBndr type and its uses]   deriving( Data )  -- | Variable Binder@@ -626,9 +654,15 @@ tyVarSpecToBinders :: [VarBndr a Specificity] -> [VarBndr a ArgFlag] tyVarSpecToBinders = map tyVarSpecToBinder -tyVarSpecToBinder :: (VarBndr a Specificity) -> (VarBndr a ArgFlag)+tyVarSpecToBinder :: VarBndr a Specificity -> VarBndr a ArgFlag tyVarSpecToBinder (Bndr tv vis) = Bndr tv (Invisible vis) +tyVarReqToBinders :: [VarBndr a ()] -> [VarBndr a ArgFlag]+tyVarReqToBinders = map tyVarReqToBinder++tyVarReqToBinder :: VarBndr a () -> VarBndr a ArgFlag+tyVarReqToBinder (Bndr tv _) = Bndr tv Required+ binderVar :: VarBndr tv argf -> tv binderVar (Bndr v _) = v @@ -642,12 +676,12 @@ binderType (Bndr tv _) = varType tv  -- | Make a named binder-mkTyCoVarBinder :: vis -> TyCoVar -> (VarBndr TyCoVar vis)+mkTyCoVarBinder :: vis -> TyCoVar -> VarBndr TyCoVar vis mkTyCoVarBinder vis var = Bndr var vis  -- | Make a named binder -- 'var' should be a type variable-mkTyVarBinder :: vis -> TyVar -> (VarBndr TyVar vis)+mkTyVarBinder :: vis -> TyVar -> VarBndr TyVar vis mkTyVarBinder vis var   = ASSERT( isTyVar var )     Bndr var vis

GHC/Types/Var.hs-boot view

@@ -1,6 +1,7 @@ module GHC.Types.Var where  import GHC.Prelude ()+import {-# SOURCE #-} GHC.Types.Name   -- We compile this GHC with -XNoImplicitPrelude, so if there are no imports   -- it does not seem to depend on anything. But it does! We must, for   -- example, compile GHC.Types in the ghc-prim library first. So this@@ -10,4 +11,11 @@ data ArgFlag data AnonArgFlag data Var+instance NamedThing Var+data VarBndr var argf+data Specificity type TyVar = Var+type Id    = Var+type TyCoVar = Id+type TcTyVar = Var+type InvisTVBinder = VarBndr TyVar Specificity

GHC/Types/Var/Env.hs view

@@ -86,6 +86,7 @@ import GHC.Types.Unique.DFM import GHC.Types.Unique import GHC.Utils.Misc+import GHC.Utils.Panic import GHC.Data.Maybe import GHC.Utils.Outputable

GHC/Unit.hs view

@@ -1,6 +1,4 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE DeriveFunctor #-}  -- | Units are library components from Cabal packages compiled and installed in -- a database@@ -10,14 +8,17 @@    , module GHC.Unit.Parser    , module GHC.Unit.State    , module GHC.Unit.Module+   , module GHC.Unit.Home    ) where  import GHC.Unit.Types import GHC.Unit.Info import GHC.Unit.Parser-import GHC.Unit.State import GHC.Unit.Module+import GHC.Unit.Home+-- source import to avoid DynFlags import loops+import {-# SOURCE #-} GHC.Unit.State  {- @@ -270,39 +271,58 @@ TODO: We should probably have `instanceOf :: Maybe IndefUnitId` instead.  -Pretty-printing UnitId-----------------------+Note [Pretty-printing UnitId]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -GHC mostly deals with UnitIds which are some opaque strings. We could display-them when we pretty-print a module origin, a name, etc. But it wouldn't be-very friendly to the user because of the hash they usually contain. E.g.+When we pretty-print a UnitId for the user, we try to map it back to its origin+package name, version and component to print "package-version:component" instead+of some hash. How to retrieve these information from a UnitId? -   foo-4.18.1:thelib-XYZsomeUglyHashABC+Solution 0: ask for a UnitState to be passed each time we want to pretty-print a+SDoc so that the Outputable instance for UnitId could retrieve the information+from it. That what we used in the past: a DynFlags was passed and the UnitState+was retrieved from it. This is wrong for several reasons: -Instead when we want to pretty-print a 'UnitId' we query the database to-get the 'UnitInfo' and print something nicer to the user:+    1. The UnitState is accessed when the message is printed, not when it is+       generated. So we could imagine that the UnitState could have changed+       in-between. Especially if we want to allow unit unloading. -   foo-4.18.1:thelib+    2. We want GHC to support several independent sessions at once, hence+       several UnitState. This approach supposes there is a unique UnitState+       (the one given at printing-time), moreover a UnitId doesn't indicate+       which UnitState it comes from (think about statically defined UnitId for+       wired-in units). -We do the same for wired-in units.+Solution 1: an obvious approach would be to store the required information in+the UnitId itself. However it doesn't work because some UnitId are defined+statically for wired-in units and the same UnitId can map to different units in+different contexts. This solution would make wired-in units harder to deal with. -Currently (2020-04-06), we don't thread the database into every function that-pretty-prints a Name/Module/Unit. Instead querying the database is delayed-until the `SDoc` is transformed into a `Doc` using the database that is-active at this point in time. This is an issue because we want to be able to-unload units from the database and we also want to support several-independent databases loaded at the same time (see #14335). The alternatives-we have are:+Solution 2: another approach would be to thread the UnitState to all places+where a UnitId is pretty-printed and to retrieve the information from the+UnitState only when needed. It would mean that UnitId couldn't have an+Outputable instance as it would need an additional UnitState parameter to be+printed. It means that many other types couldn't have an Outputable instance+either: Unit, Module, Name, InstEnv, etc. Too many to make this solution+feasible. -   * threading the database into every function that pretty-prints a UnitId-   for the user (directly or indirectly).+Solution 3: the approach we use is a compromise between solutions 0 and 2: the+appropriate UnitState has to be threaded close enough to the function generating+the SDoc so that the latter can use `pprWithUnitState` to set the UnitState to+fetch information from. However the UnitState doesn't have to be threaded+explicitly all the way down to the point where the UnitId itself is printed:+instead the Outputable instance of UnitId fetches the "sdocUnitIdForUser"+field in the SDocContext to pretty-print. -   * storing enough info to correctly display a UnitId into the UnitId-   datatype itself. This is done in the IndefUnitId wrapper (see-   'UnitPprInfo' datatype) but not for every 'UnitId'. Statically defined-   'UnitId' for wired-in units would have empty UnitPprInfo so we need to-   find some places to update them if we want to display wired-in UnitId-   correctly. This leads to a solution similar to the first one above.+   1. We can still have Outputable instances for common types (Module, Unit,+      Name, etc.)++   2. End-users don't have to pass a UnitState (via a DynFlags) to print a SDoc.++   3. By default "sdocUnitIdForUser" prints the UnitId hash. In case of a bug+      (i.e. GHC doesn't correctly call `pprWithUnitState` before pretty-printing a+      UnitId), that's what will be shown to the user so it's no big deal.+  Note [VirtUnit to RealUnit improvement] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+ GHC/Unit/Env.hs view

@@ -0,0 +1,61 @@+module GHC.Unit.Env+    ( UnitEnv (..)+    , preloadUnitsInfo+    , preloadUnitsInfo'+    )+where++import GHC.Prelude++import GHC.Unit.State+import GHC.Unit.Home+import GHC.Unit.Types++import GHC.Platform+import GHC.Settings+import GHC.Data.Maybe++data UnitEnv = UnitEnv+    { ue_units     :: !UnitState      -- ^ Units+    , ue_home_unit :: !HomeUnit       -- ^ Home unit+    , ue_platform  :: !Platform       -- ^ Platform+    , ue_namever   :: !GhcNameVersion -- ^ GHC name/version (used for dynamic library suffix)+    }++-- -----------------------------------------------------------------------------+-- Extracting information from the packages in scope++-- Many of these functions take a list of packages: in those cases,+-- the list is expected to contain the "dependent packages",+-- i.e. those packages that were found to be depended on by the+-- current module/program.  These can be auto or non-auto packages, it+-- doesn't really matter.  The list is always combined with the list+-- of preload (command-line) packages to determine which packages to+-- use.++-- | Lookup 'UnitInfo' for every preload unit from the UnitState, for every unit+-- used to instantiate the home unit, and for every unit explicitly passed in+-- the given list of UnitId.+preloadUnitsInfo' :: UnitEnv -> [UnitId] -> MaybeErr UnitErr [UnitInfo]+preloadUnitsInfo' unit_env ids0 = all_infos+  where+    home_unit  = ue_home_unit unit_env+    unit_state = ue_units     unit_env+    ids      = ids0 ++ inst_ids+    inst_ids+       -- An indefinite package will have insts to HOLE,+       -- which is not a real package. Don't look it up.+       -- Fixes #14525+       | isHomeUnitIndefinite home_unit = []+       | otherwise = map (toUnitId . moduleUnit . snd) (homeUnitInstantiations home_unit)+    pkg_map = unitInfoMap unit_state+    preload = preloadUnits unit_state++    all_pkgs  = closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing)+    all_infos = map (unsafeLookupUnitId unit_state) <$> all_pkgs+++-- | Lookup 'UnitInfo' for every preload unit from the UnitState and for every+-- unit used to instantiate the home unit.+preloadUnitsInfo :: UnitEnv -> MaybeErr UnitErr [UnitInfo]+preloadUnitsInfo unit_env = preloadUnitsInfo' unit_env []

+ GHC/Unit/External.hs view

@@ -0,0 +1,131 @@+module GHC.Unit.External+   ( ExternalPackageState (..)+   , EpsStats(..)+   , addEpsInStats+   , PackageTypeEnv+   , PackageIfaceTable+   , PackageInstEnv+   , PackageFamInstEnv+   , PackageRuleBase+   , PackageCompleteMatches+   , emptyPackageIfaceTable+   )+where++import GHC.Prelude++import GHC.Unit+import GHC.Unit.Module.ModIface++import GHC.Core         ( RuleBase )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( InstEnv )++import GHC.Types.Annotations ( AnnEnv )+import GHC.Types.CompleteMatch+import GHC.Types.TypeEnv+import GHC.Types.Unique.DSet+++type PackageTypeEnv          = TypeEnv+type PackageRuleBase         = RuleBase+type PackageInstEnv          = InstEnv+type PackageFamInstEnv       = FamInstEnv+type PackageAnnEnv           = AnnEnv+type PackageCompleteMatches = CompleteMatches++-- | Helps us find information about modules in the imported packages+type PackageIfaceTable = ModuleEnv ModIface+        -- Domain = modules in the imported packages++-- | Constructs an empty PackageIfaceTable+emptyPackageIfaceTable :: PackageIfaceTable+emptyPackageIfaceTable = emptyModuleEnv+++-- | Information about other packages that we have slurped in by reading+-- their interface files+data ExternalPackageState+  = EPS {+        eps_is_boot :: !(ModuleNameEnv ModuleNameWithIsBoot),+                -- ^ In OneShot mode (only), home-package modules+                -- accumulate in the external package state, and are+                -- sucked in lazily.  For these home-pkg modules+                -- (only) we need to record which are boot modules.+                -- We set this field after loading all the+                -- explicitly-imported interfaces, but before doing+                -- anything else+                --+                -- The 'ModuleName' part is not necessary, but it's useful for+                -- debug prints, and it's convenient because this field comes+                -- direct from 'GHC.Tc.Utils.imp_dep_mods'++        eps_PIT :: !PackageIfaceTable,+                -- ^ The 'ModIface's for modules in external packages+                -- whose interfaces we have opened.+                -- The declarations in these interface files are held in the+                -- 'eps_decls', 'eps_inst_env', 'eps_fam_inst_env' and 'eps_rules'+                -- fields of this record, not in the 'mi_decls' fields of the+                -- interface we have sucked in.+                --+                -- What /is/ in the PIT is:+                --+                -- * The Module+                --+                -- * Fingerprint info+                --+                -- * Its exports+                --+                -- * Fixities+                --+                -- * Deprecations and warnings++        eps_free_holes :: InstalledModuleEnv (UniqDSet ModuleName),+                -- ^ Cache for 'mi_free_holes'.  Ordinarily, we can rely on+                -- the 'eps_PIT' for this information, EXCEPT that when+                -- we do dependency analysis, we need to look at the+                -- 'Dependencies' of our imports to determine what their+                -- precise free holes are ('moduleFreeHolesPrecise').  We+                -- don't want to repeatedly reread in the interface+                -- for every import, so cache it here.  When the PIT+                -- gets filled in we can drop these entries.++        eps_PTE :: !PackageTypeEnv,+                -- ^ Result of typechecking all the external package+                -- interface files we have sucked in. The domain of+                -- the mapping is external-package modules++        eps_inst_env     :: !PackageInstEnv,   -- ^ The total 'InstEnv' accumulated+                                               -- from all the external-package modules+        eps_fam_inst_env :: !PackageFamInstEnv,-- ^ The total 'FamInstEnv' accumulated+                                               -- from all the external-package modules+        eps_rule_base    :: !PackageRuleBase,  -- ^ The total 'RuleEnv' accumulated+                                               -- from all the external-package modules+        eps_ann_env      :: !PackageAnnEnv,    -- ^ The total 'AnnEnv' accumulated+                                               -- from all the external-package modules+        eps_complete_matches :: !PackageCompleteMatches,+                                  -- ^ The total 'CompleteMatches' accumulated+                                  -- from all the external-package modules++        eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- ^ The family instances accumulated from external+                                                         -- packages, keyed off the module that declared them++        eps_stats :: !EpsStats                 -- ^ Stastics about what was loaded from external packages+  }++-- | Accumulated statistics about what we are putting into the 'ExternalPackageState'.+-- \"In\" means stuff that is just /read/ from interface files,+-- \"Out\" means actually sucked in and type-checked+data EpsStats = EpsStats { n_ifaces_in+                         , n_decls_in, n_decls_out+                         , n_rules_in, n_rules_out+                         , n_insts_in, n_insts_out :: !Int }++addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats+-- ^ Add stats for one newly-read interface+addEpsInStats stats n_decls n_insts n_rules+  = stats { n_ifaces_in = n_ifaces_in stats + 1+          , n_decls_in  = n_decls_in stats + n_decls+          , n_insts_in  = n_insts_in stats + n_insts+          , n_rules_in  = n_rules_in stats + n_rules }+

+ GHC/Unit/Finder.hs view

@@ -0,0 +1,612 @@+{-+(c) The University of Glasgow, 2000-2006++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Module finder+module GHC.Unit.Finder (+    FindResult(..),+    InstalledFindResult(..),+    FinderCache,+    flushFinderCaches,+    findImportedModule,+    findPluginModule,+    findExactModule,+    findHomeModule,+    findExposedPackageModule,+    mkHomeModLocation,+    mkHomeModLocation2,+    mkHiOnlyModLocation,+    mkHiPath,+    mkObjPath,+    addHomeModuleToFinder,+    uncacheModule,+    mkStubPaths,++    findObjectLinkableMaybe,+    findObjectLinkable,++  ) where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.Session++import GHC.Platform.Ways++import GHC.Builtin.Names ( gHC_PRIM )++import GHC.Unit.Types+import GHC.Unit.Module+import GHC.Unit.Home+import GHC.Unit.State+import GHC.Unit.Finder.Types++import GHC.Data.FastString+import GHC.Data.Maybe    ( expectJust )+import qualified GHC.Data.ShortText as ST++import GHC.Utils.Misc+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic++import GHC.Linker.Types++import Data.IORef       ( IORef, readIORef, atomicModifyIORef' )+import System.Directory+import System.FilePath+import Control.Monad+import Data.Time+++type FileExt = String   -- Filename extension+type BaseName = String  -- Basename of file++-- -----------------------------------------------------------------------------+-- The Finder++-- The Finder provides a thin filesystem abstraction to the rest of+-- the compiler.  For a given module, it can tell you where the+-- source, interface, and object files for that module live.++-- It does *not* know which particular package a module lives in.  Use+-- Packages.lookupModuleInAllUnits for that.++-- -----------------------------------------------------------------------------+-- The finder's cache++-- remove all the home modules from the cache; package modules are+-- assumed to not move around during a session.+flushFinderCaches :: HscEnv -> IO ()+flushFinderCaches hsc_env =+  atomicModifyIORef' fc_ref $ \fm -> (filterInstalledModuleEnv is_ext fm, ())+ where+        fc_ref       = hsc_FC hsc_env+        home_unit    = hsc_home_unit hsc_env+        is_ext mod _ = not (isHomeInstalledModule home_unit mod)++addToFinderCache :: IORef FinderCache -> InstalledModule -> InstalledFindResult -> IO ()+addToFinderCache ref key val =+  atomicModifyIORef' ref $ \c -> (extendInstalledModuleEnv c key val, ())++removeFromFinderCache :: IORef FinderCache -> InstalledModule -> IO ()+removeFromFinderCache ref key =+  atomicModifyIORef' ref $ \c -> (delInstalledModuleEnv c key, ())++lookupFinderCache :: IORef FinderCache -> InstalledModule -> IO (Maybe InstalledFindResult)+lookupFinderCache ref key = do+   c <- readIORef ref+   return $! lookupInstalledModuleEnv c key++-- -----------------------------------------------------------------------------+-- The three external entry points++-- | Locate a module that was imported by the user.  We have the+-- module's name, and possibly a package name.  Without a package+-- name, this function will use the search path and the known exposed+-- packages to find the module, if a package is specified then only+-- that package is searched for the module.++findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult+findImportedModule hsc_env mod_name mb_pkg =+  case mb_pkg of+        Nothing                        -> unqual_import+        Just pkg | pkg == fsLit "this" -> home_import -- "this" is special+                 | otherwise           -> pkg_import+  where+    home_import   = findHomeModule hsc_env mod_name++    pkg_import    = findExposedPackageModule hsc_env mod_name mb_pkg++    unqual_import = home_import+                    `orIfNotFound`+                    findExposedPackageModule hsc_env mod_name Nothing++-- | Locate a plugin module requested by the user, for a compiler+-- plugin.  This consults the same set of exposed packages as+-- 'findImportedModule', unless @-hide-all-plugin-packages@ or+-- @-plugin-package@ are specified.+findPluginModule :: HscEnv -> ModuleName -> IO FindResult+findPluginModule hsc_env mod_name =+  findHomeModule hsc_env mod_name+  `orIfNotFound`+  findExposedPluginPackageModule hsc_env mod_name++-- | Locate a specific 'Module'.  The purpose of this function is to+-- create a 'ModLocation' for a given 'Module', that is to find out+-- where the files associated with this module live.  It is used when+-- reading the interface for a module mentioned by another interface,+-- for example (a "system import").++findExactModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findExactModule hsc_env mod =+    let home_unit = hsc_home_unit hsc_env+    in if isHomeInstalledModule home_unit mod+       then findInstalledHomeModule hsc_env (moduleName mod)+       else findPackageModule hsc_env mod++-- -----------------------------------------------------------------------------+-- Helpers++-- | Given a monadic actions @this@ and @or_this@, first execute+-- @this@.  If the returned 'FindResult' is successful, return+-- it; otherwise, execute @or_this@.  If both failed, this function+-- also combines their failure messages in a reasonable way.+orIfNotFound :: Monad m => m FindResult -> m FindResult -> m FindResult+orIfNotFound this or_this = do+  res <- this+  case res of+    NotFound { fr_paths = paths1, fr_mods_hidden = mh1+             , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 }+     -> do res2 <- or_this+           case res2 of+             NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2+                      , fr_pkgs_hidden = ph2, fr_unusables = u2+                      , fr_suggestions = s2 }+              -> return (NotFound { fr_paths = paths1 ++ paths2+                                  , fr_pkg = mb_pkg2 -- snd arg is the package search+                                  , fr_mods_hidden = mh1 ++ mh2+                                  , fr_pkgs_hidden = ph1 ++ ph2+                                  , fr_unusables = u1 ++ u2+                                  , fr_suggestions = s1  ++ s2 })+             _other -> return res2+    _other -> return res++-- | Helper function for 'findHomeModule': this function wraps an IO action+-- which would look up @mod_name@ in the file system (the home package),+-- and first consults the 'hsc_FC' cache to see if the lookup has already+-- been done.  Otherwise, do the lookup (with the IO action) and save+-- the result in the finder cache and the module location cache (if it+-- was successful.)+homeSearchCache :: HscEnv -> ModuleName -> IO InstalledFindResult -> IO InstalledFindResult+homeSearchCache hsc_env mod_name do_this = do+  let home_unit = hsc_home_unit hsc_env+      mod = mkHomeInstalledModule home_unit mod_name+  modLocationCache hsc_env mod do_this++findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString+                         -> IO FindResult+findExposedPackageModule hsc_env mod_name mb_pkg+  = findLookupResult hsc_env+  $ lookupModuleWithSuggestions+        (hsc_units hsc_env) mod_name mb_pkg++findExposedPluginPackageModule :: HscEnv -> ModuleName+                               -> IO FindResult+findExposedPluginPackageModule hsc_env mod_name+  = findLookupResult hsc_env+  $ lookupPluginModuleWithSuggestions+        (hsc_units hsc_env) mod_name Nothing++findLookupResult :: HscEnv -> LookupResult -> IO FindResult+findLookupResult hsc_env r = case r of+     LookupFound m pkg_conf -> do+       let im = fst (getModuleInstantiation m)+       r' <- findPackageModule_ hsc_env im (fst pkg_conf)+       case r' of+        -- TODO: ghc -M is unlikely to do the right thing+        -- with just the location of the thing that was+        -- instantiated; you probably also need all of the+        -- implicit locations from the instances+        InstalledFound loc   _ -> return (Found loc m)+        InstalledNoPackage   _ -> return (NoPackage (moduleUnit m))+        InstalledNotFound fp _ -> return (NotFound{ fr_paths = fp, fr_pkg = Just (moduleUnit m)+                                         , fr_pkgs_hidden = []+                                         , fr_mods_hidden = []+                                         , fr_unusables = []+                                         , fr_suggestions = []})+     LookupMultiple rs ->+       return (FoundMultiple rs)+     LookupHidden pkg_hiddens mod_hiddens ->+       return (NotFound{ fr_paths = [], fr_pkg = Nothing+                       , fr_pkgs_hidden = map (moduleUnit.fst) pkg_hiddens+                       , fr_mods_hidden = map (moduleUnit.fst) mod_hiddens+                       , fr_unusables = []+                       , fr_suggestions = [] })+     LookupUnusable unusable ->+       let unusables' = map get_unusable unusable+           get_unusable (m, ModUnusable r) = (moduleUnit m, r)+           get_unusable (_, r)             =+             pprPanic "findLookupResult: unexpected origin" (ppr r)+       in return (NotFound{ fr_paths = [], fr_pkg = Nothing+                          , fr_pkgs_hidden = []+                          , fr_mods_hidden = []+                          , fr_unusables = unusables'+                          , fr_suggestions = [] })+     LookupNotFound suggest -> do+       let suggest'+             | gopt Opt_HelpfulErrors (hsc_dflags hsc_env) = suggest+             | otherwise = []+       return (NotFound{ fr_paths = [], fr_pkg = Nothing+                       , fr_pkgs_hidden = []+                       , fr_mods_hidden = []+                       , fr_unusables = []+                       , fr_suggestions = suggest' })++modLocationCache :: HscEnv -> InstalledModule -> IO InstalledFindResult -> IO InstalledFindResult+modLocationCache hsc_env mod do_this = do+  m <- lookupFinderCache (hsc_FC hsc_env) mod+  case m of+    Just result -> return result+    Nothing     -> do+        result <- do_this+        addToFinderCache (hsc_FC hsc_env) mod result+        return result++-- This returns a module because it's more convenient for users+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module+addHomeModuleToFinder hsc_env mod_name loc = do+  let home_unit = hsc_home_unit hsc_env+      mod = mkHomeInstalledModule home_unit mod_name+  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)+  return (mkHomeModule home_unit mod_name)++uncacheModule :: HscEnv -> ModuleName -> IO ()+uncacheModule hsc_env mod_name = do+  let home_unit = hsc_home_unit hsc_env+      mod = mkHomeInstalledModule home_unit mod_name+  removeFromFinderCache (hsc_FC hsc_env) mod++-- -----------------------------------------------------------------------------+--      The internal workers++findHomeModule :: HscEnv -> ModuleName -> IO FindResult+findHomeModule hsc_env mod_name = do+  r <- findInstalledHomeModule hsc_env mod_name+  return $ case r of+    InstalledFound loc _ -> Found loc (mkHomeModule home_unit mod_name)+    InstalledNoPackage _ -> NoPackage uid -- impossible+    InstalledNotFound fps _ -> NotFound {+        fr_paths = fps,+        fr_pkg = Just uid,+        fr_mods_hidden = [],+        fr_pkgs_hidden = [],+        fr_unusables = [],+        fr_suggestions = []+      }+ where+  home_unit = hsc_home_unit hsc_env+  uid       = homeUnitAsUnit home_unit++-- | Implements the search for a module name in the home package only.  Calling+-- this function directly is usually *not* what you want; currently, it's used+-- as a building block for the following operations:+--+--  1. When you do a normal package lookup, we first check if the module+--  is available in the home module, before looking it up in the package+--  database.+--+--  2. When you have a package qualified import with package name "this",+--  we shortcut to the home module.+--+--  3. When we look up an exact 'Module', if the unit id associated with+--  the module is the current home module do a look up in the home module.+--+--  4. Some special-case code in GHCi (ToDo: Figure out why that needs to+--  call this.)+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule hsc_env mod_name =+   homeSearchCache hsc_env mod_name $+   let+     dflags = hsc_dflags hsc_env+     home_unit = hsc_home_unit hsc_env+     home_path = importPaths dflags+     hisuf = hiSuf dflags+     mod = mkHomeInstalledModule home_unit mod_name++     source_exts =+      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")+      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")+      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")+      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")+      ]++     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that+     -- when hiDir field is set in dflags, we know to look there (see #16500)+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)+               ]++        -- In compilation manager modes, we look for source files in the home+        -- package because we can compile these automatically.  In one-shot+        -- compilation mode we look for .hi and .hi-boot files only.+     exts | isOneShot (ghcMode dflags) = hi_exts+          | otherwise                  = source_exts+   in++  -- special case for GHC.Prim; we won't find it in the filesystem.+  -- This is important only when compiling the base package (where GHC.Prim+  -- is a home module).+  if mod `installedModuleEq` gHC_PRIM+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)+        else searchPathExts home_path mod exts+++-- | Search for a module in external packages only.+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findPackageModule hsc_env mod = do+  let pkg_id = moduleUnit mod+  case lookupUnitId (hsc_units hsc_env) pkg_id of+     Nothing -> return (InstalledNoPackage pkg_id)+     Just u  -> findPackageModule_ hsc_env mod u++-- | Look up the interface file associated with module @mod@.  This function+-- requires a few invariants to be upheld: (1) the 'Module' in question must+-- be the module identifier of the *original* implementation of a module,+-- not a reexport (this invariant is upheld by "GHC.Unit.State") and (2)+-- the 'UnitInfo' must be consistent with the unit id in the 'Module'.+-- The redundancy is to avoid an extra lookup in the package state+-- for the appropriate config.+findPackageModule_ :: HscEnv -> InstalledModule -> UnitInfo -> IO InstalledFindResult+findPackageModule_ hsc_env mod pkg_conf =+  ASSERT2( moduleUnit mod == unitId pkg_conf, ppr (moduleUnit mod) <+> ppr (unitId pkg_conf) )+  modLocationCache hsc_env mod $++  -- special case for GHC.Prim; we won't find it in the filesystem.+  if mod `installedModuleEq` gHC_PRIM+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)+        else++  let+     dflags = hsc_dflags hsc_env+     tag = waysBuildTag (ways dflags)++           -- hi-suffix for packages depends on the build tag.+     package_hisuf | null tag  = "hi"+                   | otherwise = tag ++ "_hi"++     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf++     import_dirs = map ST.unpack $ unitImportDirs pkg_conf+      -- we never look for a .hi-boot file in an external package;+      -- .hi-boot files only make sense for the home package.+  in+  case import_dirs of+    [one] | MkDepend <- ghcMode dflags -> do+          -- there's only one place that this .hi file can be, so+          -- don't bother looking for it.+          let basename = moduleNameSlashes (moduleName mod)+          loc <- mk_hi_loc one basename+          return (InstalledFound loc mod)+    _otherwise ->+          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]++-- -----------------------------------------------------------------------------+-- General path searching++searchPathExts :: [FilePath]      -- paths to search+               -> InstalledModule -- module name+               -> [ (+                     FileExt,                                -- suffix+                     FilePath -> BaseName -> IO ModLocation  -- action+                    )+                  ]+               -> IO InstalledFindResult++searchPathExts paths mod exts = search to_search+  where+    basename = moduleNameSlashes (moduleName mod)++    to_search :: [(FilePath, IO ModLocation)]+    to_search = [ (file, fn path basename)+                | path <- paths,+                  (ext,fn) <- exts,+                  let base | path == "." = basename+                           | otherwise   = path </> basename+                      file = base <.> ext+                ]++    search [] = return (InstalledNotFound (map fst to_search) (Just (moduleUnit mod)))++    search ((file, mk_result) : rest) = do+      b <- doesFileExist file+      if b+        then do { loc <- mk_result; return (InstalledFound loc mod) }+        else search rest++mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt+                          -> FilePath -> BaseName -> IO ModLocation+mkHomeModLocationSearched dflags mod suff path basename =+  mkHomeModLocation2 dflags mod (path </> basename) suff++-- -----------------------------------------------------------------------------+-- Constructing a home module location++-- This is where we construct the ModLocation for a module in the home+-- package, for which we have a source file.  It is called from three+-- places:+--+--  (a) Here in the finder, when we are searching for a module to import,+--      using the search path (-i option).+--+--  (b) The compilation manager, when constructing the ModLocation for+--      a "root" module (a source file named explicitly on the command line+--      or in a :load command in GHCi).+--+--  (c) The driver in one-shot mode, when we need to construct a+--      ModLocation for a source file named on the command-line.+--+-- Parameters are:+--+-- mod+--      The name of the module+--+-- path+--      (a): The search path component where the source file was found.+--      (b) and (c): "."+--+-- src_basename+--      (a): (moduleNameSlashes mod)+--      (b) and (c): The filename of the source file, minus its extension+--+-- ext+--      The filename extension of the source file (usually "hs" or "lhs").++mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation+mkHomeModLocation dflags mod src_filename = do+   let (basename,extension) = splitExtension src_filename+   mkHomeModLocation2 dflags mod basename extension++mkHomeModLocation2 :: DynFlags+                   -> ModuleName+                   -> FilePath  -- Of source module, without suffix+                   -> String    -- Suffix+                   -> IO ModLocation+mkHomeModLocation2 dflags mod src_basename ext = do+   let mod_basename = moduleNameSlashes mod++       obj_fn = mkObjPath  dflags src_basename mod_basename+       hi_fn  = mkHiPath   dflags src_basename mod_basename+       hie_fn = mkHiePath  dflags src_basename mod_basename++   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),+                        ml_hi_file   = hi_fn,+                        ml_obj_file  = obj_fn,+                        ml_hie_file  = hie_fn })++mkHomeModHiOnlyLocation :: DynFlags+                        -> ModuleName+                        -> FilePath+                        -> BaseName+                        -> IO ModLocation+mkHomeModHiOnlyLocation dflags mod path basename = do+   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""+   return loc { ml_hs_file = Nothing }++mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String+                    -> IO ModLocation+mkHiOnlyModLocation dflags hisuf path basename+ = do let full_basename = path </> basename+          obj_fn = mkObjPath  dflags full_basename basename+          hie_fn = mkHiePath  dflags full_basename basename+      return ModLocation{    ml_hs_file   = Nothing,+                             ml_hi_file   = full_basename <.> hisuf,+                                -- Remove the .hi-boot suffix from+                                -- hi_file, if it had one.  We always+                                -- want the name of the real .hi file+                                -- in the ml_hi_file field.+                             ml_obj_file  = obj_fn,+                             ml_hie_file  = hie_fn+                  }++-- | Constructs the filename of a .o file for a given source file.+-- Does /not/ check whether the .o file exists+mkObjPath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkObjPath dflags basename mod_basename = obj_basename <.> osuf+  where+                odir = objectDir dflags+                osuf = objectSuf dflags++                obj_basename | Just dir <- odir = dir </> mod_basename+                             | otherwise        = basename+++-- | Constructs the filename of a .hi file for a given source file.+-- Does /not/ check whether the .hi file exists+mkHiPath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkHiPath dflags basename mod_basename = hi_basename <.> hisuf+ where+                hidir = hiDir dflags+                hisuf = hiSuf dflags++                hi_basename | Just dir <- hidir = dir </> mod_basename+                            | otherwise         = basename++-- | Constructs the filename of a .hie file for a given source file.+-- Does /not/ check whether the .hie file exists+mkHiePath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf+ where+                hiedir = hieDir dflags+                hiesuf = hieSuf dflags++                hie_basename | Just dir <- hiedir = dir </> mod_basename+                             | otherwise          = basename++++-- -----------------------------------------------------------------------------+-- Filenames of the stub files++-- We don't have to store these in ModLocations, because they can be derived+-- from other available information, and they're only rarely needed.++mkStubPaths+  :: DynFlags+  -> ModuleName+  -> ModLocation+  -> FilePath++mkStubPaths dflags mod location+  = let+        stubdir = stubDir dflags++        mod_basename = moduleNameSlashes mod+        src_basename = dropExtension $ expectJust "mkStubPaths"+                                                  (ml_hs_file location)++        stub_basename0+            | Just dir <- stubdir = dir </> mod_basename+            | otherwise           = src_basename++        stub_basename = stub_basename0 ++ "_stub"+     in+        stub_basename <.> "h"++-- -----------------------------------------------------------------------------+-- findLinkable isn't related to the other stuff in here,+-- but there's no other obvious place for it++findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)+findObjectLinkableMaybe mod locn+   = do let obj_fn = ml_obj_file locn+        maybe_obj_time <- modificationTimeIfExists obj_fn+        case maybe_obj_time of+          Nothing -> return Nothing+          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)++-- Make an object linkable when we know the object file exists, and we know+-- its modification time.+findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])+  -- We used to look for _stub.o files here, but that was a bug (#706)+  -- Now GHC merges the stub.o into the main .o (#3687)+

+ GHC/Unit/Finder/Types.hs view

@@ -0,0 +1,56 @@+module GHC.Unit.Finder.Types+   ( FinderCache+   , FindResult (..)+   , InstalledFindResult (..)+   )+where++import GHC.Prelude+import GHC.Unit+import GHC.Unit.State++-- | The 'FinderCache' maps modules to the result of+-- searching for that module. It records the results of searching for+-- modules along the search path. On @:load@, we flush the entire+-- contents of this cache.+--+type FinderCache = InstalledModuleEnv InstalledFindResult++data InstalledFindResult+  = InstalledFound ModLocation InstalledModule+  | InstalledNoPackage UnitId+  | InstalledNotFound [FilePath] (Maybe UnitId)++-- | The result of searching for an imported module.+--+-- NB: FindResult manages both user source-import lookups+-- (which can result in 'Module') as well as direct imports+-- for interfaces (which always result in 'InstalledModule').+data FindResult+  = Found ModLocation Module+        -- ^ The module was found+  | NoPackage Unit+        -- ^ The requested unit was not found+  | FoundMultiple [(Module, ModuleOrigin)]+        -- ^ _Error_: both in multiple packages++        -- | Not found+  | NotFound+      { fr_paths       :: [FilePath]       -- ^ Places where I looked++      , fr_pkg         :: Maybe Unit       -- ^ Just p => module is in this unit's+                                           --   manifest, but couldn't find the+                                           --   .hi file++      , fr_mods_hidden :: [Unit]           -- ^ Module is in these units,+                                           --   but the *module* is hidden++      , fr_pkgs_hidden :: [Unit]           -- ^ Module is in these units,+                                           --   but the *unit* is hidden++        -- | Module is in these units, but it is unusable+      , fr_unusables   :: [(Unit, UnusableUnitReason)]++      , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules+      }+

+ GHC/Unit/Home.hs view

@@ -0,0 +1,211 @@+-- | The home unit is the unit (i.e. compiled package) that contains the module+-- we are compiling/typechecking.+module GHC.Unit.Home+   ( GenHomeUnit (..)+   , HomeUnit+   , homeUnitId+   , homeUnitInstantiations+   , homeUnitInstanceOf+   , homeUnitInstanceOfMaybe+   , homeUnitAsUnit+   , homeUnitMap+   -- * Predicates+   , isHomeUnitIndefinite+   , isHomeUnitDefinite+   , isHomeUnitInstantiating+   , isHomeUnit+   , isHomeUnitId+   , isHomeUnitInstanceOf+   , isHomeModule+   , isHomeInstalledModule+   , notHomeModule+   , notHomeModuleMaybe+   , notHomeInstalledModule+   , notHomeInstalledModuleMaybe+   -- * Helpers+   , mkHomeModule+   , mkHomeInstalledModule+   , homeModuleInstantiation+   , homeModuleNameInstantiation+   )+where++import GHC.Prelude+import GHC.Unit.Types+import GHC.Unit.Module.Name+import Data.Maybe++-- | Information about the home unit (i.e., the until that will contain the+-- modules we are compiling)+--+-- The unit identifier of the instantiating units is left open to allow+-- switching from UnitKey (what is provided by the user) to UnitId (internal+-- unit identifier) with `homeUnitMap`.+--+-- TODO: this isn't implemented yet. UnitKeys are still converted too early into+-- UnitIds in GHC.Unit.State.readUnitDataBase+data GenHomeUnit u+   = DefiniteHomeUnit UnitId (Maybe (u, GenInstantiations u))+      -- ^ Definite home unit (i.e. that we can compile).+      --+      -- Nothing:        not an instantiated unit+      -- Just (i,insts): made definite by instantiating "i" with "insts"++   | IndefiniteHomeUnit UnitId (GenInstantiations u)+      -- ^ Indefinite home unit (i.e. that we can only typecheck)+      --+      -- All the holes are instantiated with fake modules from the Hole unit.+      -- See Note [Representation of module/name variables] in "GHC.Unit"++type HomeUnit = GenHomeUnit UnitId++-- | Return home unit id+homeUnitId :: GenHomeUnit u -> UnitId+homeUnitId (DefiniteHomeUnit u _)   = u+homeUnitId (IndefiniteHomeUnit u _) = u++-- | Return home unit instantiations+homeUnitInstantiations :: GenHomeUnit u -> GenInstantiations u+homeUnitInstantiations (DefiniteHomeUnit   _ Nothing)       = []+homeUnitInstantiations (DefiniteHomeUnit   _ (Just (_,is))) = is+homeUnitInstantiations (IndefiniteHomeUnit _ is)            = is++-- | Return the unit id of the unit that is instantiated by the home unit.+--+-- E.g. if home unit = q[A=p:B,...] we return q.+--+-- If the home unit is not an instance of another unit, we return its own unit+-- id (it is an instance of itself if you will).+homeUnitInstanceOf :: HomeUnit -> UnitId+homeUnitInstanceOf h = fromMaybe (homeUnitId h) (homeUnitInstanceOfMaybe h)++-- | Return the unit id of the unit that is instantiated by the home unit.+--+-- E.g. if home unit = q[A=p:B,...] we return (Just q).+--+-- If the home unit is not an instance of another unit, we return Nothing.+homeUnitInstanceOfMaybe :: GenHomeUnit u -> Maybe u+homeUnitInstanceOfMaybe (DefiniteHomeUnit   _ (Just (u,_))) = Just u+homeUnitInstanceOfMaybe _                                   = Nothing++-- | Return the home unit as a normal unit.+--+-- We infer from the home unit itself the kind of unit we create:+--    1. If the home unit is definite, we must be compiling so we return a real+--    unit. The definite home unit may be the result of a unit instantiation,+--    say `p = q[A=r:X]`. In this case we could have returned a virtual unit+--    `q[A=r:X]` but it's not what the clients of this function expect,+--    especially because `p` is lost when we do this. The unit id of a virtual+--    unit is made up internally so `unitId(q[A=r:X])` is not equal to `p`.+--+--    2. If the home unit is indefinite we can only create a virtual unit from+--    it. It's ok because we must be only typechecking the home unit so we won't+--    produce any code object that rely on the unit id of this virtual unit.+homeUnitAsUnit :: HomeUnit -> Unit+homeUnitAsUnit (DefiniteHomeUnit u _)    = RealUnit (Definite u)+homeUnitAsUnit (IndefiniteHomeUnit u is) = mkVirtUnit (Indefinite u) is++-- | Map over the unit identifier for instantiating units+homeUnitMap :: IsUnitId v => (u -> v) -> GenHomeUnit u -> GenHomeUnit v+homeUnitMap _ (DefiniteHomeUnit u Nothing)       = DefiniteHomeUnit u Nothing+homeUnitMap f (DefiniteHomeUnit u (Just (i,is))) = DefiniteHomeUnit u (Just (f i, mapInstantiations f is))+homeUnitMap f (IndefiniteHomeUnit u is)          = IndefiniteHomeUnit u (mapInstantiations f is)++----------------------------+-- Predicates+----------------------------++-- | Test if we are type-checking an indefinite unit+--+-- (if it is not, we should never use on-the-fly renaming)+isHomeUnitIndefinite :: GenHomeUnit u -> Bool+isHomeUnitIndefinite (DefiniteHomeUnit {})   = False+isHomeUnitIndefinite (IndefiniteHomeUnit {}) = True++-- | Test if we are compiling a definite unit+--+-- (if it is, we should never use on-the-fly renaming)+isHomeUnitDefinite :: GenHomeUnit u -> Bool+isHomeUnitDefinite (DefiniteHomeUnit {})   = True+isHomeUnitDefinite (IndefiniteHomeUnit {}) = False++-- | Test if we are compiling by instantiating a definite unit+isHomeUnitInstantiating :: GenHomeUnit u -> Bool+isHomeUnitInstantiating u =+   isHomeUnitDefinite u && not (null (homeUnitInstantiations u))++-- | Test if the unit is the home unit+isHomeUnit :: HomeUnit -> Unit -> Bool+isHomeUnit hu u = u == homeUnitAsUnit hu++-- | Test if the unit-id is the home unit-id+isHomeUnitId :: GenHomeUnit u -> UnitId -> Bool+isHomeUnitId hu uid = uid == homeUnitId hu++-- | Test if the home unit is an instance of the given unit-id+isHomeUnitInstanceOf :: HomeUnit -> UnitId -> Bool+isHomeUnitInstanceOf hu u = homeUnitInstanceOf hu == u++-- | Test if the module comes from the home unit+isHomeModule :: HomeUnit -> Module -> Bool+isHomeModule hu m = isHomeUnit hu (moduleUnit m)++-- | Test if the module comes from the home unit+isHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool+isHomeInstalledModule hu m = isHomeUnitId hu (moduleUnit m)+++-- | Test if a module doesn't come from the given home unit+notHomeInstalledModule :: GenHomeUnit u -> InstalledModule -> Bool+notHomeInstalledModule hu m = not (isHomeInstalledModule hu m)++-- | Test if a module doesn't come from the given home unit+notHomeInstalledModuleMaybe :: Maybe (GenHomeUnit u) -> InstalledModule -> Bool+notHomeInstalledModuleMaybe mh m = fromMaybe True $ fmap (`notHomeInstalledModule` m) mh+++-- | Test if a module doesn't come from the given home unit+notHomeModule :: HomeUnit -> Module -> Bool+notHomeModule hu m = not (isHomeModule hu m)++-- | Test if a module doesn't come from the given home unit+notHomeModuleMaybe :: Maybe HomeUnit -> Module -> Bool+notHomeModuleMaybe mh m = fromMaybe True $ fmap (`notHomeModule` m) mh++----------------------------+-- helpers+----------------------------++-- | Make a module in home unit+mkHomeModule :: HomeUnit -> ModuleName -> Module+mkHomeModule hu = mkModule (homeUnitAsUnit hu)++-- | Make a module in home unit+mkHomeInstalledModule :: GenHomeUnit u -> ModuleName -> InstalledModule+mkHomeInstalledModule hu = mkModule (homeUnitId hu)++-- | Return the module that is used to instantiate the given home module name.+-- If the ModuleName doesn't refer to a signature, return the actual home+-- module.+--+-- E.g., the instantiating module of @A@ in @p[A=q[]:B]@ is @q[]:B@.+--       the instantiating module of @A@ in @p@ is @p:A@.+homeModuleNameInstantiation :: HomeUnit -> ModuleName -> Module+homeModuleNameInstantiation hu mod_name =+    case lookup mod_name (homeUnitInstantiations hu) of+        Nothing  -> mkHomeModule hu mod_name+        Just mod -> mod++-- | Return the module that is used to instantiate the given home module.+--+-- If the given module isn't a module hole, return the actual home module.+--+-- E.g., the instantiating module of @p:A@ in @p[A=q[]:B]@ is @q[]:B@.+--       the instantiating module of @r:A@ in @p[A=q[]:B]@ is @r:A@.+--       the instantiating module of @p:A@ in @p@ is @p:A@.+--       the instantiating module of @r:A@ in @p@ is @r:A@.+homeModuleInstantiation :: HomeUnit -> Module -> Module+homeModuleInstantiation hu mod+   | isHomeModule hu mod = homeModuleNameInstantiation hu (moduleName mod)+   | otherwise           = mod+

+ GHC/Unit/Home/ModInfo.hs view

@@ -0,0 +1,121 @@+-- | Info about modules in the "home" unit+module GHC.Unit.Home.ModInfo+   ( HomeModInfo (..)+   , HomePackageTable+   , emptyHomePackageTable+   , lookupHpt+   , eltsHpt+   , filterHpt+   , allHpt+   , anyHpt+   , mapHpt+   , delFromHpt+   , addToHpt+   , addListToHpt+   , lookupHptDirectly+   , lookupHptByModule+   , listToHpt+   , pprHPT+   )+where++import GHC.Prelude++import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module++import GHC.Linker.Types ( Linkable(..) )++import GHC.Types.Unique+import GHC.Types.Unique.DFM++import GHC.Utils.Outputable++-- | Information about modules in the package being compiled+data HomeModInfo = HomeModInfo+   { hm_iface    :: !ModIface+        -- ^ The basic loaded interface file: every loaded module has one of+        -- these, even if it is imported from another package++   , hm_details  :: !ModDetails+        -- ^ Extra information that has been created from the 'ModIface' for+        -- the module, typically during typechecking++   , hm_linkable :: !(Maybe Linkable)+        -- ^ The actual artifact we would like to link to access things in+        -- this module.+        --+        -- 'hm_linkable' might be Nothing:+        --+        --   1. If this is an .hs-boot module+        --+        --   2. Temporarily during compilation if we pruned away+        --      the old linkable because it was out of date.+        --+        -- After a complete compilation ('GHC.load'), all 'hm_linkable' fields+        -- in the 'HomePackageTable' will be @Just@.+        --+        -- When re-linking a module ('GHC.Driver.Main.HscNoRecomp'), we construct the+        -- 'HomeModInfo' by building a new 'ModDetails' from the old+        -- 'ModIface' (only).+   }++-- | Helps us find information about modules in the home package+type HomePackageTable = DModuleNameEnv HomeModInfo+   -- Domain = modules in the home unit that have been fully compiled+   -- "home" unit id cached (implicit) here for convenience++-- | Constructs an empty HomePackageTable+emptyHomePackageTable :: HomePackageTable+emptyHomePackageTable  = emptyUDFM++lookupHpt :: HomePackageTable -> ModuleName -> Maybe HomeModInfo+lookupHpt = lookupUDFM++lookupHptDirectly :: HomePackageTable -> Unique -> Maybe HomeModInfo+lookupHptDirectly = lookupUDFM_Directly++eltsHpt :: HomePackageTable -> [HomeModInfo]+eltsHpt = eltsUDFM++filterHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> HomePackageTable+filterHpt = filterUDFM++allHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+allHpt = allUDFM++anyHpt :: (HomeModInfo -> Bool) -> HomePackageTable -> Bool+anyHpt = anyUDFM++mapHpt :: (HomeModInfo -> HomeModInfo) -> HomePackageTable -> HomePackageTable+mapHpt = mapUDFM++delFromHpt :: HomePackageTable -> ModuleName -> HomePackageTable+delFromHpt = delFromUDFM++addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable+addToHpt = addToUDFM++addListToHpt+  :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable+addListToHpt = addListToUDFM++listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable+listToHpt = listToUDFM++lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo+-- The HPT is indexed by ModuleName, not Module,+-- we must check for a hit on the right Module+lookupHptByModule hpt mod+  = case lookupHpt hpt (moduleName mod) of+      Just hm | mi_module (hm_iface hm) == mod -> Just hm+      _otherwise                               -> Nothing++pprHPT :: HomePackageTable -> SDoc+-- A bit arbitrary for now+pprHPT hpt = pprUDFM hpt $ \hms ->+    vcat [ hang (ppr (mi_module (hm_iface hm)))+              2 (ppr (md_types (hm_details hm)))+         | hm <- hms ]+

GHC/Unit/Info.hs view

@@ -19,23 +19,42 @@    , unitPackageNameString    , unitPackageIdString    , pprUnitInfo++   , collectIncludeDirs+   , collectExtraCcOpts+   , collectLibraryDirs+   , collectFrameworks+   , collectFrameworksDirs+   , unitHsLibs    ) where  #include "HsVersions.h"  import GHC.Prelude+import GHC.Platform.Ways -import GHC.Unit.Database-import Data.Version-import Data.Bifunctor+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic +import GHC.Types.Unique+ import GHC.Data.FastString-import GHC.Utils.Outputable+import qualified GHC.Data.ShortText as ST+ import GHC.Unit.Module as Module-import GHC.Types.Unique import GHC.Unit.Ppr+import GHC.Unit.Database +import GHC.Settings++import Data.Version+import Data.Bifunctor+import Data.List (isPrefixOf, stripPrefix)+import qualified Data.Set as Set++ -- | Information about an installed unit -- -- We parameterize on the unit identifier:@@ -46,12 +65,6 @@ -- Units] in "GHC.Unit" type GenUnitInfo unit = GenericUnitInfo (Indefinite unit) PackageId PackageName unit ModuleName (GenModule (GenUnit unit)) --- | A unit key in the database-newtype UnitKey = UnitKey FastString--unitKeyFS :: UnitKey -> FastString-unitKeyFS (UnitKey fs) = fs- -- | Information about an installed unit (units are identified by their database -- UnitKey) type UnitKeyInfo = GenUnitInfo UnitKey@@ -74,33 +87,29 @@      mkPackageName'       = PackageName    . mkFastStringByteString      mkUnitKey'           = UnitKey        . mkFastStringByteString      mkModuleName'        = mkModuleNameFS . mkFastStringByteString-     mkIndefUnitKey' cid  = Indefinite (mkUnitKey' cid) Nothing+     mkIndefUnitKey' cid  = Indefinite (mkUnitKey' cid)      mkVirtUnitKey' i = case i of-      DbInstUnitId cid insts -> mkGenVirtUnit unitKeyFS (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)+      DbInstUnitId cid insts -> mkVirtUnit (mkIndefUnitKey' cid) (fmap (bimap mkModuleName' mkModule') insts)       DbUnitId uid           -> RealUnit (Definite (mkUnitKey' uid))      mkModule' m = case m of        DbModule uid n -> mkModule (mkVirtUnitKey' uid) (mkModuleName' n)        DbModuleVar  n -> mkHoleModule (mkModuleName' n)  -- | Map over the unit parameter-mapUnitInfo :: (u -> v) -> (v -> FastString) -> GenUnitInfo u -> GenUnitInfo v-mapUnitInfo f gunitFS = mapGenericUnitInfo+mapUnitInfo :: IsUnitId v => (u -> v) -> GenUnitInfo u -> GenUnitInfo v+mapUnitInfo f = mapGenericUnitInfo    f         -- unit identifier    (fmap f)  -- indefinite unit identifier    id        -- package identifier    id        -- package name    id        -- module name-   (fmap (mapGenUnit f gunitFS)) -- instantiating modules---- TODO: there's no need for these to be FastString, as we don't need the uniq---       feature, but ghc doesn't currently have convenient support for any---       other compact string types, e.g. plain ByteString or Text.+   (fmap (mapGenUnit f)) -- instantiating modules -newtype PackageId   = PackageId    FastString deriving (Eq, Ord)+newtype PackageId   = PackageId    FastString deriving (Eq) newtype PackageName = PackageName    { unPackageName :: FastString    }-   deriving (Eq, Ord)+   deriving (Eq)  instance Uniquable PackageId where   getUnique (PackageId n) = getUnique n@@ -134,21 +143,21 @@       field "exposed-modules"      (ppr unitExposedModules),       field "hidden-modules"       (fsep (map ppr unitHiddenModules)),       field "trusted"              (ppr unitIsTrusted),-      field "import-dirs"          (fsep (map text unitImportDirs)),-      field "library-dirs"         (fsep (map text unitLibraryDirs)),-      field "dynamic-library-dirs" (fsep (map text unitLibraryDynDirs)),-      field "hs-libraries"         (fsep (map text unitLibraries)),-      field "extra-libraries"      (fsep (map text unitExtDepLibsSys)),-      field "extra-ghci-libraries" (fsep (map text unitExtDepLibsGhc)),-      field "include-dirs"         (fsep (map text unitIncludeDirs)),-      field "includes"             (fsep (map text unitIncludes)),+      field "import-dirs"          (fsep (map (text . ST.unpack) unitImportDirs)),+      field "library-dirs"         (fsep (map (text . ST.unpack) unitLibraryDirs)),+      field "dynamic-library-dirs" (fsep (map (text . ST.unpack) unitLibraryDynDirs)),+      field "hs-libraries"         (fsep (map (text . ST.unpack) unitLibraries)),+      field "extra-libraries"      (fsep (map (text . ST.unpack) unitExtDepLibsSys)),+      field "extra-ghci-libraries" (fsep (map (text . ST.unpack) unitExtDepLibsGhc)),+      field "include-dirs"         (fsep (map (text . ST.unpack) unitIncludeDirs)),+      field "includes"             (fsep (map (text . ST.unpack) unitIncludes)),       field "depends"              (fsep (map ppr  unitDepends)),-      field "cc-options"           (fsep (map text unitCcOptions)),-      field "ld-options"           (fsep (map text unitLinkerOptions)),-      field "framework-dirs"       (fsep (map text unitExtDepFrameworkDirs)),-      field "frameworks"           (fsep (map text unitExtDepFrameworks)),-      field "haddock-interfaces"   (fsep (map text unitHaddockInterfaces)),-      field "haddock-html"         (fsep (map text unitHaddockHTMLs))+      field "cc-options"           (fsep (map (text . ST.unpack) unitCcOptions)),+      field "ld-options"           (fsep (map (text . ST.unpack) unitLinkerOptions)),+      field "framework-dirs"       (fsep (map (text . ST.unpack) unitExtDepFrameworkDirs)),+      field "frameworks"           (fsep (map (text . ST.unpack) unitExtDepFrameworks)),+      field "haddock-interfaces"   (fsep (map (text . ST.unpack) unitHaddockInterfaces)),+      field "haddock-html"         (fsep (map (text . ST.unpack) unitHaddockHTMLs))     ]   where     field name body = text name <> colon <+> nest 4 body@@ -168,8 +177,80 @@    | otherwise          = RealUnit (Definite (unitId p))  -- | Create a UnitPprInfo from a UnitInfo-mkUnitPprInfo :: GenUnitInfo u -> UnitPprInfo-mkUnitPprInfo i = UnitPprInfo+mkUnitPprInfo :: (u -> FastString) -> GenUnitInfo u -> UnitPprInfo+mkUnitPprInfo ufs i = UnitPprInfo+   (ufs (unitId i))    (unitPackageNameString i)    (unitPackageVersion i)    ((unpackFS . unPackageName) <$> unitComponentName i)++-- | Find all the include directories in the given units+collectIncludeDirs :: [UnitInfo] -> [FilePath]+collectIncludeDirs ps = map ST.unpack $ ordNub (filter (not . ST.null) (concatMap unitIncludeDirs ps))++-- | Find all the C-compiler options in the given units+collectExtraCcOpts :: [UnitInfo] -> [String]+collectExtraCcOpts ps = map ST.unpack (concatMap unitCcOptions ps)++-- | Find all the library directories in the given units for the given ways+collectLibraryDirs :: Ways -> [UnitInfo] -> [FilePath]+collectLibraryDirs ws = ordNub . filter notNull . concatMap (libraryDirsForWay ws)++-- | Find all the frameworks in the given units+collectFrameworks :: [UnitInfo] -> [String]+collectFrameworks ps = map ST.unpack (concatMap unitExtDepFrameworks ps)++-- | Find all the package framework paths in these and the preload packages+collectFrameworksDirs :: [UnitInfo] -> [String]+collectFrameworksDirs ps = map ST.unpack (ordNub (filter (not . ST.null) (concatMap unitExtDepFrameworkDirs ps)))++-- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.+libraryDirsForWay :: Ways -> UnitInfo -> [String]+libraryDirsForWay ws+  | WayDyn `elem` ws = map ST.unpack . unitLibraryDynDirs+  | otherwise        = map ST.unpack . unitLibraryDirs++unitHsLibs :: GhcNameVersion -> Ways -> UnitInfo -> [String]+unitHsLibs namever ways0 p = map (mkDynName . addSuffix . ST.unpack) (unitLibraries p)+  where+        ways1 = Set.filter (/= WayDyn) ways0+        -- the name of a shared library is libHSfoo-ghc<version>.so+        -- we leave out the _dyn, because it is superfluous++        -- debug and profiled RTSs include support for -eventlog+        ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1+              = Set.filter (/= WayTracing) ways1+              | otherwise+              = ways1++        tag     = waysTag (fullWays ways2)+        rts_tag = waysTag ways2++        mkDynName x+         | not (ways0 `hasWay` WayDyn) = x+         | "HS" `isPrefixOf` x         = x ++ dynLibSuffix namever+           -- For non-Haskell libraries, we use the name "Cfoo". The .a+           -- file is libCfoo.a, and the .so is libfoo.so. That way the+           -- linker knows what we mean for the vanilla (-lCfoo) and dyn+           -- (-lfoo) ways. We therefore need to strip the 'C' off here.+         | Just x' <- stripPrefix "C" x = x'+         | otherwise+            = panic ("Don't understand library name " ++ x)++        -- Add _thr and other rts suffixes to packages named+        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts+        -- package is called `rts` only.  However the tooling+        -- usually expects a package name to have a version.+        -- As such we will gradually move towards the `rts-1.0`+        -- package name, at which point the `rts` package name+        -- will eventually be unused.+        --+        -- This change elevates the need to add custom hooks+        -- and handling specifically for the `rts` package for+        -- example in ghc-cabal.+        addSuffix rts@"HSrts"       = rts       ++ (expandTag rts_tag)+        addSuffix rts@"HSrts-1.0.2" = rts       ++ (expandTag rts_tag)+        addSuffix other_lib         = other_lib ++ (expandTag tag)++        expandTag t | null t = ""+                    | otherwise = '_':t

GHC/Unit/Module.hs view

@@ -1,3 +1,8 @@+{-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+ {- (c) The University of Glasgow, 2004-2006 @@ -9,14 +14,6 @@ the keys. -} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE ExplicitNamespaces #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeSynonymInstances #-}- module GHC.Unit.Module     ( module GHC.Unit.Types @@ -43,7 +40,6 @@     , moduleIsDefinite     , HasModule(..)     , ContainsModule(..)-    , unitIdEq     , installedModuleEq     ) where @@ -89,10 +85,6 @@ installedModuleEq imod mod =     fst (getModuleInstantiation mod) == imod --- | Test if a 'Unit' corresponds to a given 'UnitId',--- modulo instantiation.-unitIdEq :: UnitId -> Unit -> Bool-unitIdEq iuid uid = toUnitId uid == iuid  {- ************************************************************************

+ GHC/Unit/Module/Deps.hs view

@@ -0,0 +1,195 @@+-- | Dependencies and Usage of a module+module GHC.Unit.Module.Deps+   ( Dependencies (..)+   , Usage (..)+   , noDependencies+   )+where++import GHC.Prelude++import GHC.Types.SafeHaskell+import GHC.Types.Name+import GHC.Unit.Module.Name+import GHC.Unit.Module++import GHC.Utils.Fingerprint+import GHC.Utils.Binary++-- | Dependency information about ALL modules and packages below this one+-- in the import hierarchy.+--+-- Invariant: the dependencies of a module @M@ never includes @M@.+--+-- Invariant: none of the lists contain duplicates.+data Dependencies = Deps+   { dep_mods   :: [ModuleNameWithIsBoot]+      -- ^ All home-package modules transitively below this one+      -- I.e. modules that this one imports, or that are in the+      --      dep_mods of those directly-imported modules++   , dep_pkgs   :: [(UnitId, Bool)]+      -- ^ All packages transitively below this module+      -- I.e. packages to which this module's direct imports belong,+      --      or that are in the dep_pkgs of those modules+      -- The bool indicates if the package is required to be+      -- trusted when the module is imported as a safe import+      -- (Safe Haskell). See Note [Tracking Trust Transitively] in GHC.Rename.Names++   , dep_orphs  :: [Module]+      -- ^ Transitive closure of orphan modules (whether+      -- home or external pkg).+      --+      -- (Possible optimization: don't include family+      -- instance orphans as they are anyway included in+      -- 'dep_finsts'.  But then be careful about code+      -- which relies on dep_orphs having the complete list!)+      -- This does NOT include us, unlike 'imp_orphs'.++   , dep_finsts :: [Module]+      -- ^ Transitive closure of depended upon modules which+      -- contain family instances (whether home or external).+      -- This is used by 'checkFamInstConsistency'.  This+      -- does NOT include us, unlike 'imp_finsts'. See Note+      -- [The type family instance consistency story].++   , dep_plgins :: [ModuleName]+      -- ^ All the plugins used while compiling this module.+   }+   deriving( Eq )+        -- Equality used only for old/new comparison in GHC.Iface.Recomp.addFingerprints+        -- See 'GHC.Tc.Utils.ImportAvails' for details on dependencies.++instance Binary Dependencies where+    put_ bh deps = do put_ bh (dep_mods deps)+                      put_ bh (dep_pkgs deps)+                      put_ bh (dep_orphs deps)+                      put_ bh (dep_finsts deps)+                      put_ bh (dep_plgins deps)++    get bh = do ms <- get bh+                ps <- get bh+                os <- get bh+                fis <- get bh+                pl <- get bh+                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,+                               dep_finsts = fis, dep_plgins = pl })++noDependencies :: Dependencies+noDependencies = Deps [] [] [] [] []++-- | Records modules for which changes may force recompilation of this module+-- See wiki: https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance+--+-- This differs from Dependencies.  A module X may be in the dep_mods of this+-- module (via an import chain) but if we don't use anything from X it won't+-- appear in our Usage+data Usage+  -- | Module from another package+  = UsagePackageModule {+        usg_mod      :: Module,+           -- ^ External package module depended on+        usg_mod_hash :: Fingerprint,+            -- ^ Cached module fingerprint+        usg_safe :: IsSafeImport+            -- ^ Was this module imported as a safe import+    }+  -- | Module from the current package+  | UsageHomeModule {+        usg_mod_name :: ModuleName,+            -- ^ Name of the module+        usg_mod_hash :: Fingerprint,+            -- ^ Cached module fingerprint+        usg_entities :: [(OccName,Fingerprint)],+            -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.+            -- NB: usages are for parent names only, e.g. type constructors+            -- but not the associated data constructors.+        usg_exports  :: Maybe Fingerprint,+            -- ^ Fingerprint for the export list of this module,+            -- if we directly imported it (and hence we depend on its export list)+        usg_safe :: IsSafeImport+            -- ^ Was this module imported as a safe import+    }                                           -- ^ Module from the current package+  -- | A file upon which the module depends, e.g. a CPP #include, or using TH's+  -- 'addDependentFile'+  | UsageFile {+        usg_file_path  :: FilePath,+        -- ^ External file dependency. From a CPP #include or TH+        -- addDependentFile. Should be absolute.+        usg_file_hash  :: Fingerprint+        -- ^ 'Fingerprint' of the file contents.++        -- Note: We don't consider things like modification timestamps+        -- here, because there's no reason to recompile if the actual+        -- contents don't change.  This previously lead to odd+        -- recompilation behaviors; see #8114+  }+  -- | A requirement which was merged into this one.+  | UsageMergedRequirement {+        usg_mod :: Module,+        usg_mod_hash :: Fingerprint+  }+    deriving( Eq )+        -- The export list field is (Just v) if we depend on the export list:+        --      i.e. we imported the module directly, whether or not we+        --           enumerated the things we imported, or just imported+        --           everything+        -- We need to recompile if M's exports change, because+        -- if the import was    import M,       we might now have a name clash+        --                                      in the importing module.+        -- if the import was    import M(x)     M might no longer export x+        -- The only way we don't depend on the export list is if we have+        --                      import M()+        -- And of course, for modules that aren't imported directly we don't+        -- depend on their export lists++instance Binary Usage where+    put_ bh usg@UsagePackageModule{} = do+        putByte bh 0+        put_ bh (usg_mod usg)+        put_ bh (usg_mod_hash usg)+        put_ bh (usg_safe     usg)++    put_ bh usg@UsageHomeModule{} = do+        putByte bh 1+        put_ bh (usg_mod_name usg)+        put_ bh (usg_mod_hash usg)+        put_ bh (usg_exports  usg)+        put_ bh (usg_entities usg)+        put_ bh (usg_safe     usg)++    put_ bh usg@UsageFile{} = do+        putByte bh 2+        put_ bh (usg_file_path usg)+        put_ bh (usg_file_hash usg)++    put_ bh usg@UsageMergedRequirement{} = do+        putByte bh 3+        put_ bh (usg_mod      usg)+        put_ bh (usg_mod_hash usg)++    get bh = do+        h <- getByte bh+        case h of+          0 -> do+            nm    <- get bh+            mod   <- get bh+            safe  <- get bh+            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }+          1 -> do+            nm    <- get bh+            mod   <- get bh+            exps  <- get bh+            ents  <- get bh+            safe  <- get bh+            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,+                     usg_exports = exps, usg_entities = ents, usg_safe = safe }+          2 -> do+            fp   <- get bh+            hash <- get bh+            return UsageFile { usg_file_path = fp, usg_file_hash = hash }+          3 -> do+            mod <- get bh+            hash <- get bh+            return UsageMergedRequirement { usg_mod = mod, usg_mod_hash = hash }+          i -> error ("Binary.get(Usage): " ++ show i)

+ GHC/Unit/Module/Graph.hs view

@@ -0,0 +1,208 @@+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}++module GHC.Unit.Module.Graph+   ( ModuleGraph+   , ModuleGraphNode(..)+   , emptyMG+   , mkModuleGraph+   , mkModuleGraph'+   , extendMG+   , extendMGInst+   , extendMG'+   , filterToposortToModules+   , mapMG+   , mgModSummaries+   , mgModSummaries'+   , mgExtendedModSummaries+   , mgElemModule+   , mgLookupModule+   , mgBootModules+   , needsTemplateHaskellOrQQ+   , isTemplateHaskellOrQQNonBoot+   , showModMsg+   )+where++import GHC.Prelude++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.Maybe+import GHC.Data.Graph.Directed ( SCC(..) )++import GHC.Driver.Backend+import GHC.Driver.Ppr+import GHC.Driver.Session++import GHC.Types.SourceFile ( hscSourceString )++import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Env+import GHC.Unit.Types+import GHC.Utils.Outputable++import System.FilePath++-- | A '@ModuleGraphNode@' is a node in the '@ModuleGraph@'.+-- Edges between nodes mark dependencies arising from module imports+-- and dependencies arising from backpack instantiations.+data ModuleGraphNode+  -- | Instantiation nodes track the instantiation of other units+  -- (backpack dependencies) with the holes (signatures) of the current package.+  = InstantiationNode InstantiatedUnit+  -- | There is a module summary node for each module, signature, and boot module being built.+  | ModuleNode ExtendedModSummary++instance Outputable ModuleGraphNode where+  ppr = \case+    InstantiationNode iuid -> ppr iuid+    ModuleNode ems -> ppr ems++-- | A '@ModuleGraph@' contains all the nodes from the home package (only). See+-- '@ModuleGraphNode@' for information about the nodes.+--+-- Modules need to be compiled. hs-boots need to be typechecked before+-- the associated "real" module so modules with {-# SOURCE #-} imports can be+-- built. Instantiations also need to be typechecked to ensure that the module+-- fits the signature. Substantiation typechecking is roughly comparable to the+-- check that the module and its hs-boot agree.+--+-- The graph is not necessarily stored in topologically-sorted order.  Use+-- 'GHC.topSortModuleGraph' and 'GHC.Data.Graph.Directed.flattenSCC' to achieve this.+data ModuleGraph = ModuleGraph+  { mg_mss :: [ModuleGraphNode]+  , mg_non_boot :: ModuleEnv ModSummary+    -- a map of all non-boot ModSummaries keyed by Modules+  , mg_boot :: ModuleSet+    -- a set of boot Modules+  , mg_needs_th_or_qq :: !Bool+    -- does any of the modules in mg_mss require TemplateHaskell or+    -- QuasiQuotes?+  }++-- | Determines whether a set of modules requires Template Haskell or+-- Quasi Quotes+--+-- Note that if the session's 'DynFlags' enabled Template Haskell when+-- 'depanal' was called, then each module in the returned module graph will+-- have Template Haskell enabled whether it is actually needed or not.+needsTemplateHaskellOrQQ :: ModuleGraph -> Bool+needsTemplateHaskellOrQQ mg = mg_needs_th_or_qq mg++-- | Map a function 'f' over all the 'ModSummaries'.+-- To preserve invariants 'f' can't change the isBoot status.+mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph+mapMG f mg@ModuleGraph{..} = mg+  { mg_mss = flip fmap mg_mss $ \case+      InstantiationNode iuid -> InstantiationNode iuid+      ModuleNode (ExtendedModSummary ms bds) -> ModuleNode (ExtendedModSummary (f ms) bds)+  , mg_non_boot = mapModuleEnv f mg_non_boot+  }++mgBootModules :: ModuleGraph -> ModuleSet+mgBootModules ModuleGraph{..} = mg_boot++mgModSummaries :: ModuleGraph -> [ModSummary]+mgModSummaries mg = [ m | ModuleNode (ExtendedModSummary m _) <- mgModSummaries' mg ]++mgExtendedModSummaries :: ModuleGraph -> [ExtendedModSummary]+mgExtendedModSummaries mg = [ ems | ModuleNode ems <- mgModSummaries' mg ]++mgModSummaries' :: ModuleGraph -> [ModuleGraphNode]+mgModSummaries' = mg_mss++mgElemModule :: ModuleGraph -> Module -> Bool+mgElemModule ModuleGraph{..} m = elemModuleEnv m mg_non_boot++-- | Look up a ModSummary in the ModuleGraph+mgLookupModule :: ModuleGraph -> Module -> Maybe ModSummary+mgLookupModule ModuleGraph{..} m = lookupModuleEnv mg_non_boot m++emptyMG :: ModuleGraph+emptyMG = ModuleGraph [] emptyModuleEnv emptyModuleSet False++isTemplateHaskellOrQQNonBoot :: ModSummary -> Bool+isTemplateHaskellOrQQNonBoot ms =+  (xopt LangExt.TemplateHaskell (ms_hspp_opts ms)+    || xopt LangExt.QuasiQuotes (ms_hspp_opts ms)) &&+  (isBootSummary ms == NotBoot)++-- | Add an ExtendedModSummary to ModuleGraph. Assumes that the new ModSummary is+-- not an element of the ModuleGraph.+extendMG :: ModuleGraph -> ExtendedModSummary -> ModuleGraph+extendMG ModuleGraph{..} ems@(ExtendedModSummary ms _) = ModuleGraph+  { mg_mss = ModuleNode ems : mg_mss+  , mg_non_boot = case isBootSummary ms of+      IsBoot -> mg_non_boot+      NotBoot -> extendModuleEnv mg_non_boot (ms_mod ms) ms+  , mg_boot = case isBootSummary ms of+      NotBoot -> mg_boot+      IsBoot -> extendModuleSet mg_boot (ms_mod ms)+  , mg_needs_th_or_qq = mg_needs_th_or_qq || isTemplateHaskellOrQQNonBoot ms+  }++extendMGInst :: ModuleGraph -> InstantiatedUnit -> ModuleGraph+extendMGInst mg depUnitId = mg+  { mg_mss = InstantiationNode depUnitId : mg_mss mg+  }++extendMG' :: ModuleGraph -> ModuleGraphNode -> ModuleGraph+extendMG' mg = \case+  InstantiationNode depUnitId -> extendMGInst mg depUnitId+  ModuleNode ems -> extendMG mg ems++mkModuleGraph :: [ExtendedModSummary] -> ModuleGraph+mkModuleGraph = foldr (flip extendMG) emptyMG++mkModuleGraph' :: [ModuleGraphNode] -> ModuleGraph+mkModuleGraph' = foldr (flip extendMG') emptyMG++-- | This function filters out all the instantiation nodes from each SCC of a+-- topological sort. Use this with care, as the resulting "strongly connected components"+-- may not really be strongly connected in a direct way, as instantiations have been+-- removed. It would probably be best to eliminate uses of this function where possible.+filterToposortToModules+  :: [SCC ModuleGraphNode] -> [SCC ModSummary]+filterToposortToModules = mapMaybe $ mapMaybeSCC $ \case+  InstantiationNode _ -> Nothing+  ModuleNode (ExtendedModSummary node _) -> Just node+  where+    -- This higher order function is somewhat bogus,+    -- as the definition of "strongly connected component"+    -- is not necessarily respected.+    mapMaybeSCC :: (a -> Maybe b) -> SCC a -> Maybe (SCC b)+    mapMaybeSCC f = \case+      AcyclicSCC a -> AcyclicSCC <$> f a+      CyclicSCC as -> case mapMaybe f as of+        [] -> Nothing+        [a] -> Just $ AcyclicSCC a+        as -> Just $ CyclicSCC as++showModMsg :: DynFlags -> Bool -> ModuleGraphNode -> SDoc+showModMsg _ _ (InstantiationNode indef_unit) =+  ppr $ instUnitInstanceOf indef_unit+showModMsg dflags recomp (ModuleNode (ExtendedModSummary mod_summary _)) =+  if gopt Opt_HideSourcePaths dflags+      then text mod_str+      else hsep $+         [ text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' ')+         , char '('+         , text (op $ msHsFilePath mod_summary) <> char ','+         ] +++         if gopt Opt_BuildDynamicToo dflags+            then [ text obj_file <> char ','+                 , text dyn_file+                 , char ')'+                 ]+            else [ text obj_file, char ')' ]+  where+    op       = normalise+    mod      = moduleName (ms_mod mod_summary)+    mod_str  = showPpr dflags mod ++ hscSourceString (ms_hsc_src mod_summary)+    dyn_file = op $ msDynObjFilePath mod_summary dflags+    obj_file = case backend dflags of+                Interpreter | recomp -> "interpreted"+                NoBackend            -> "nothing"+                _                    -> (op $ msObjFilePath mod_summary)+

+ GHC/Unit/Module/Imported.hs view

@@ -0,0 +1,54 @@+module GHC.Unit.Module.Imported+   ( ImportedMods+   , ImportedBy (..)+   , ImportedModsVal (..)+   , importedByUser+   )+where++import GHC.Prelude++import GHC.Unit.Module++import GHC.Types.Name.Reader+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc++-- | Records the modules directly imported by a module for extracting e.g.+-- usage information, and also to give better error message+type ImportedMods = ModuleEnv [ImportedBy]++-- | If a module was "imported" by the user, we associate it with+-- more detailed usage information 'ImportedModsVal'; a module+-- imported by the system only gets used for usage information.+data ImportedBy+    = ImportedByUser ImportedModsVal+    | ImportedBySystem++importedByUser :: [ImportedBy] -> [ImportedModsVal]+importedByUser (ImportedByUser imv : bys) = imv : importedByUser bys+importedByUser (ImportedBySystem   : bys) =       importedByUser bys+importedByUser [] = []++data ImportedModsVal = ImportedModsVal+   { imv_name        :: ModuleName+      -- ^ The name the module is imported with++   , imv_span        :: SrcSpan+      -- ^ the source span of the whole import++   , imv_is_safe     :: IsSafeImport+      -- ^ whether this is a safe import++   , imv_is_hiding   :: Bool+      -- ^ whether this is an "hiding" import++   , imv_all_exports :: !GlobalRdrEnv+      -- ^ all the things the module could provide.+      --+      -- NB. BangPattern here: otherwise this leaks. (#15111)++   , imv_qualified   :: Bool+      -- ^ whether this is a qualified import+   }+

+ GHC/Unit/Module/ModDetails.hs view

@@ -0,0 +1,51 @@+module GHC.Unit.Module.ModDetails+   ( ModDetails (..)+   , emptyModDetails+   )+where++import GHC.Core         ( CoreRule )+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv ( ClsInst )++import GHC.Types.Avail+import GHC.Types.CompleteMatch+import GHC.Types.TypeEnv+import GHC.Types.Annotations ( Annotation )++-- | The 'ModDetails' is essentially a cache for information in the 'ModIface'+-- for home modules only. Information relating to packages will be loaded into+-- global environments in 'ExternalPackageState'.+data ModDetails = ModDetails+   { -- The next two fields are created by the typechecker+     md_exports   :: [AvailInfo]+   , md_types     :: !TypeEnv+      -- ^ Local type environment for this particular module+      -- Includes Ids, TyCons, PatSyns++   , md_insts     :: ![ClsInst]+      -- ^ 'DFunId's for the instances in this module++   , md_fam_insts :: ![FamInst]+   , md_rules     :: ![CoreRule]+      -- ^ Domain may include 'Id's from other modules++   , md_anns      :: ![Annotation]+      -- ^ Annotations present in this module: currently+      -- they only annotate things also declared in this module++   , md_complete_matches :: [CompleteMatch]+      -- ^ Complete match pragmas for this module+   }++-- | Constructs an empty ModDetails+emptyModDetails :: ModDetails+emptyModDetails = ModDetails+   { md_types            = emptyTypeEnv+   , md_exports          = []+   , md_insts            = []+   , md_rules            = []+   , md_fam_insts        = []+   , md_anns             = []+   , md_complete_matches = []+   }

+ GHC/Unit/Module/ModGuts.hs view

@@ -0,0 +1,140 @@+module GHC.Unit.Module.ModGuts+   ( ModGuts (..)+   , CgGuts (..)+   )+where++import GHC.Prelude++import GHC.ByteCode.Types+import GHC.ForeignSrcLang++import GHC.Hs++import GHC.Unit+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Warnings++import GHC.Core.InstEnv ( InstEnv, ClsInst )+import GHC.Core.FamInstEnv+import GHC.Core         ( CoreProgram, CoreRule )+import GHC.Core.TyCon+import GHC.Core.PatSyn++import GHC.Linker.Types ( SptEntry(..) )++import GHC.Types.Annotations ( Annotation )+import GHC.Types.Avail+import GHC.Types.CompleteMatch+import GHC.Types.Fixity.Env+import GHC.Types.ForeignStubs+import GHC.Types.HpcInfo+import GHC.Types.Name.Reader+import GHC.Types.SafeHaskell+import GHC.Types.SourceFile ( HscSource(..) )+import GHC.Types.SrcLoc+++-- | A ModGuts is carried through the compiler, accumulating stuff as it goes+-- There is only one ModGuts at any time, the one for the module+-- being compiled right now.  Once it is compiled, a 'ModIface' and+-- 'ModDetails' are extracted and the ModGuts is discarded.+data ModGuts+  = ModGuts {+        mg_module    :: !Module,         -- ^ Module being compiled+        mg_hsc_src   :: HscSource,       -- ^ Whether it's an hs-boot module+        mg_loc       :: SrcSpan,         -- ^ For error messages from inner passes+        mg_exports   :: ![AvailInfo],    -- ^ What it exports+        mg_deps      :: !Dependencies,   -- ^ What it depends on, directly or+                                         -- otherwise+        mg_usages    :: ![Usage],        -- ^ What was used?  Used for interfaces.++        mg_used_th   :: !Bool,           -- ^ Did we run a TH splice?+        mg_rdr_env   :: !GlobalRdrEnv,   -- ^ Top-level lexical environment++        -- These fields all describe the things **declared in this module**+        mg_fix_env   :: !FixityEnv,      -- ^ Fixities declared in this module.+                                         -- Used for creating interface files.+        mg_tcs       :: ![TyCon],        -- ^ TyCons declared in this module+                                         -- (includes TyCons for classes)+        mg_insts     :: ![ClsInst],      -- ^ Class instances declared in this module+        mg_fam_insts :: ![FamInst],+                                         -- ^ Family instances declared in this module+        mg_patsyns   :: ![PatSyn],       -- ^ Pattern synonyms declared in this module+        mg_rules     :: ![CoreRule],     -- ^ Before the core pipeline starts, contains+                                         -- See Note [Overall plumbing for rules] in "GHC.Core.Rules"+        mg_binds     :: !CoreProgram,    -- ^ Bindings for this module+        mg_foreign   :: !ForeignStubs,   -- ^ Foreign exports declared in this module+        mg_foreign_files :: ![(ForeignSrcLang, FilePath)],+        -- ^ Files to be compiled with the C compiler+        mg_warns     :: !Warnings,       -- ^ Warnings declared in the module+        mg_anns      :: [Annotation],    -- ^ Annotations declared in this module+        mg_complete_matches :: [CompleteMatch], -- ^ Complete Matches+        mg_hpc_info  :: !HpcInfo,        -- ^ Coverage tick boxes in the module+        mg_modBreaks :: !(Maybe ModBreaks), -- ^ Breakpoints for the module++                        -- The next two fields are unusual, because they give instance+                        -- environments for *all* modules in the home package, including+                        -- this module, rather than for *just* this module.+                        -- Reason: when looking up an instance we don't want to have to+                        --         look at each module in the home package in turn+        mg_inst_env     :: InstEnv,             -- ^ Class instance environment for+                                                -- /home-package/ modules (including this+                                                -- one); c.f. 'tcg_inst_env'+        mg_fam_inst_env :: FamInstEnv,          -- ^ Type-family instance environment for+                                                -- /home-package/ modules (including this+                                                -- one); c.f. 'tcg_fam_inst_env'++        mg_safe_haskell :: SafeHaskellMode,     -- ^ Safe Haskell mode+        mg_trust_pkg    :: Bool,                -- ^ Do we need to trust our+                                                -- own package for Safe Haskell?+                                                -- See Note [Trust Own Package]+                                                -- in "GHC.Rename.Names"++        mg_doc_hdr       :: !(Maybe HsDocString), -- ^ Module header.+        mg_decl_docs     :: !DeclDocMap,     -- ^ Docs on declarations.+        mg_arg_docs      :: !ArgDocMap       -- ^ Docs on arguments.+    }++-- The ModGuts takes on several slightly different forms:+--+-- After simplification, the following fields change slightly:+--      mg_rules        Orphan rules only (local ones now attached to binds)+--      mg_binds        With rules attached++---------------------------------------------------------+-- The Tidy pass forks the information about this module:+--      * one lot goes to interface file generation (ModIface)+--        and later compilations (ModDetails)+--      * the other lot goes to code generation (CgGuts)++-- | A restricted form of 'ModGuts' for code generation purposes+data CgGuts+  = CgGuts {+        cg_module    :: !Module,+                -- ^ Module being compiled++        cg_tycons    :: [TyCon],+                -- ^ Algebraic data types (including ones that started+                -- life as classes); generate constructors and info+                -- tables. Includes newtypes, just for the benefit of+                -- External Core++        cg_binds     :: CoreProgram,+                -- ^ The tidied main bindings, including+                -- previously-implicit bindings for record and class+                -- selectors, and data constructor wrappers.  But *not*+                -- data constructor workers; reason: we regard them+                -- as part of the code-gen of tycons++        cg_foreign   :: !ForeignStubs,   -- ^ Foreign export stubs+        cg_foreign_files :: ![(ForeignSrcLang, FilePath)],+        cg_dep_pkgs  :: ![UnitId], -- ^ Dependent packages, used to+                                            -- generate #includes for C code gen+        cg_hpc_info  :: !HpcInfo,           -- ^ Program coverage tick box information+        cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints+        cg_spt_entries :: [SptEntry]+                -- ^ Static pointer table entries for static forms defined in+                -- the module.+                -- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable"+    }

+ GHC/Unit/Module/ModIface.hs view

@@ -0,0 +1,535 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}++module GHC.Unit.Module.ModIface+   ( ModIface+   , ModIface_ (..)+   , PartialModIface+   , ModIfaceBackend (..)+   , IfaceDeclExts+   , IfaceBackendExts+   , IfaceExport+   , WhetherHasOrphans+   , WhetherHasFamInst+   , mi_boot+   , mi_fix+   , mi_semantic_module+   , mi_free_holes+   , renameFreeHoles+   , emptyPartialModIface+   , emptyFullModIface+   , mkIfaceHashCache+   , emptyIfaceHashCache+   )+where++import GHC.Prelude++import GHC.Hs++import GHC.Iface.Syntax+import GHC.Iface.Ext.Fields++import GHC.Unit+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Warnings++import GHC.Types.Avail+import GHC.Types.Fixity+import GHC.Types.Fixity.Env+import GHC.Types.HpcInfo+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.SafeHaskell+import GHC.Types.SourceFile+import GHC.Types.Unique.DSet+import GHC.Types.Unique.FM++import GHC.Data.Maybe++import GHC.Utils.Fingerprint+import GHC.Utils.Binary++import Control.DeepSeq++{- Note [Interface file stages]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Interface files have two possible stages.++* A partial stage built from the result of the core pipeline.+* A fully instantiated form. Which also includes fingerprints and+  potentially information provided by backends.++We can build a full interface file two ways:+* Directly from a partial one:+  Then we omit backend information and mostly compute fingerprints.+* From a partial one + information produced by a backend.+  Then we store the provided information and fingerprint both.+-}++type PartialModIface = ModIface_ 'ModIfaceCore+type ModIface = ModIface_ 'ModIfaceFinal++-- | Extends a PartialModIface with information which is either:+-- * Computed after codegen+-- * Or computed just before writing the iface to disk. (Hashes)+-- In order to fully instantiate it.+data ModIfaceBackend = ModIfaceBackend+  { mi_iface_hash :: !Fingerprint+    -- ^ Hash of the whole interface+  , mi_mod_hash :: !Fingerprint+    -- ^ Hash of the ABI only+  , mi_flag_hash :: !Fingerprint+    -- ^ Hash of the important flags used when compiling the module, excluding+    -- optimisation flags+  , mi_opt_hash :: !Fingerprint+    -- ^ Hash of optimisation flags+  , mi_hpc_hash :: !Fingerprint+    -- ^ Hash of hpc flags+  , mi_plugin_hash :: !Fingerprint+    -- ^ Hash of plugins+  , mi_orphan :: !WhetherHasOrphans+    -- ^ Whether this module has orphans+  , mi_finsts :: !WhetherHasFamInst+    -- ^ Whether this module has family instances. See Note [The type family+    -- instance consistency story].+  , mi_exp_hash :: !Fingerprint+    -- ^ Hash of export list+  , mi_orphan_hash :: !Fingerprint+    -- ^ Hash for orphan rules, class and family instances combined++    -- Cached environments for easy lookup. These are computed (lazily) from+    -- other fields and are not put into the interface file.+    -- Not really produced by the backend but there is no need to create them+    -- any earlier.+  , mi_warn_fn :: !(OccName -> Maybe WarningTxt)+    -- ^ Cached lookup for 'mi_warns'+  , mi_fix_fn :: !(OccName -> Maybe Fixity)+    -- ^ Cached lookup for 'mi_fixities'+  , mi_hash_fn :: !(OccName -> Maybe (OccName, Fingerprint))+    -- ^ Cached lookup for 'mi_decls'. The @Nothing@ in 'mi_hash_fn' means that+    -- the thing isn't in decls. It's useful to know that when seeing if we are+    -- up to date wrt. the old interface. The 'OccName' is the parent of the+    -- name, if it has one.+  }++data ModIfacePhase+  = ModIfaceCore+  -- ^ Partial interface built based on output of core pipeline.+  | ModIfaceFinal++-- | Selects a IfaceDecl representation.+-- For fully instantiated interfaces we also maintain+-- a fingerprint, which is used for recompilation checks.+type family IfaceDeclExts (phase :: ModIfacePhase) where+  IfaceDeclExts 'ModIfaceCore = IfaceDecl+  IfaceDeclExts 'ModIfaceFinal = (Fingerprint, IfaceDecl)++type family IfaceBackendExts (phase :: ModIfacePhase) where+  IfaceBackendExts 'ModIfaceCore = ()+  IfaceBackendExts 'ModIfaceFinal = ModIfaceBackend++++-- | A 'ModIface' plus a 'ModDetails' summarises everything we know+-- about a compiled module.  The 'ModIface' is the stuff *before* linking,+-- and can be written out to an interface file. The 'ModDetails is after+-- linking and can be completely recovered from just the 'ModIface'.+--+-- When we read an interface file, we also construct a 'ModIface' from it,+-- except that we explicitly make the 'mi_decls' and a few other fields empty;+-- as when reading we consolidate the declarations etc. into a number of indexed+-- maps and environments in the 'ExternalPackageState'.+data ModIface_ (phase :: ModIfacePhase)+  = ModIface {+        mi_module     :: !Module,             -- ^ Name of the module we are for+        mi_sig_of     :: !(Maybe Module),     -- ^ Are we a sig of another mod?++        mi_hsc_src    :: !HscSource,          -- ^ Boot? Signature?++        mi_deps     :: Dependencies,+                -- ^ The dependencies of the module.  This is+                -- consulted for directly-imported modules, but not+                -- for anything else (hence lazy)++        mi_usages   :: [Usage],+                -- ^ Usages; kept sorted so that it's easy to decide+                -- whether to write a new iface file (changing usages+                -- doesn't affect the hash of this module)+                -- NOT STRICT!  we read this field lazily from the interface file+                -- It is *only* consulted by the recompilation checker++        mi_exports  :: ![IfaceExport],+                -- ^ Exports+                -- Kept sorted by (mod,occ), to make version comparisons easier+                -- Records the modules that are the declaration points for things+                -- exported by this module, and the 'OccName's of those things+++        mi_used_th  :: !Bool,+                -- ^ Module required TH splices when it was compiled.+                -- This disables recompilation avoidance (see #481).++        mi_fixities :: [(OccName,Fixity)],+                -- ^ Fixities+                -- NOT STRICT!  we read this field lazily from the interface file++        mi_warns    :: Warnings,+                -- ^ Warnings+                -- NOT STRICT!  we read this field lazily from the interface file++        mi_anns     :: [IfaceAnnotation],+                -- ^ Annotations+                -- NOT STRICT!  we read this field lazily from the interface file+++        mi_decls    :: [IfaceDeclExts phase],+                -- ^ Type, class and variable declarations+                -- The hash of an Id changes if its fixity or deprecations change+                --      (as well as its type of course)+                -- Ditto data constructors, class operations, except that+                -- the hash of the parent class/tycon changes++        mi_globals  :: !(Maybe GlobalRdrEnv),+                -- ^ Binds all the things defined at the top level in+                -- the /original source/ code for this module. which+                -- is NOT the same as mi_exports, nor mi_decls (which+                -- may contains declarations for things not actually+                -- defined by the user).  Used for GHCi and for inspecting+                -- the contents of modules via the GHC API only.+                --+                -- (We need the source file to figure out the+                -- top-level environment, if we didn't compile this module+                -- from source then this field contains @Nothing@).+                --+                -- Strictly speaking this field should live in the+                -- 'HomeModInfo', but that leads to more plumbing.++                -- Instance declarations and rules+        mi_insts       :: [IfaceClsInst],     -- ^ Sorted class instance+        mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances+        mi_rules       :: [IfaceRule],     -- ^ Sorted rules++        mi_hpc       :: !AnyHpcUsage,+                -- ^ True if this program uses Hpc at any point in the program.++        mi_trust     :: !IfaceTrustInfo,+                -- ^ Safe Haskell Trust information for this module.++        mi_trust_pkg :: !Bool,+                -- ^ Do we require the package this module resides in be trusted+                -- to trust this module? This is used for the situation where a+                -- module is Safe (so doesn't require the package be trusted+                -- itself) but imports some trustworthy modules from its own+                -- package (which does require its own package be trusted).+                -- See Note [Trust Own Package] in GHC.Rename.Names+        mi_complete_matches :: [IfaceCompleteMatch],++        mi_doc_hdr :: Maybe HsDocString,+                -- ^ Module header.++        mi_decl_docs :: DeclDocMap,+                -- ^ Docs on declarations.++        mi_arg_docs :: ArgDocMap,+                -- ^ Docs on arguments.++        mi_final_exts :: !(IfaceBackendExts phase),+                -- ^ Either `()` or `ModIfaceBackend` for+                -- a fully instantiated interface.++        mi_ext_fields :: ExtensibleFields+                -- ^ Additional optional fields, where the Map key represents+                -- the field name, resulting in a (size, serialized data) pair.+                -- Because the data is intended to be serialized through the+                -- internal `Binary` class (increasing compatibility with types+                -- using `Name` and `FastString`, such as HIE), this format is+                -- chosen over `ByteString`s.+     }++-- | Old-style accessor for whether or not the ModIface came from an hs-boot+-- file.+mi_boot :: ModIface -> IsBootInterface+mi_boot iface = if mi_hsc_src iface == HsBootFile+    then IsBoot+    else NotBoot++-- | Lookups up a (possibly cached) fixity from a 'ModIface'. If one cannot be+-- found, 'defaultFixity' is returned instead.+mi_fix :: ModIface -> OccName -> Fixity+mi_fix iface name = mi_fix_fn (mi_final_exts iface) name `orElse` defaultFixity++-- | The semantic module for this interface; e.g., if it's a interface+-- for a signature, if 'mi_module' is @p[A=<A>]:A@, 'mi_semantic_module'+-- will be @<A>@.+mi_semantic_module :: ModIface_ a -> Module+mi_semantic_module iface = case mi_sig_of iface of+                            Nothing -> mi_module iface+                            Just mod -> mod++-- | The "precise" free holes, e.g., the signatures that this+-- 'ModIface' depends on.+mi_free_holes :: ModIface -> UniqDSet ModuleName+mi_free_holes iface =+  case getModuleInstantiation (mi_module iface) of+    (_, Just indef)+        -- A mini-hack: we rely on the fact that 'renameFreeHoles'+        -- drops things that aren't holes.+        -> renameFreeHoles (mkUniqDSet cands) (instUnitInsts (moduleUnit indef))+    _   -> emptyUniqDSet+  where+    cands = map gwib_mod $ dep_mods $ mi_deps iface++-- | Given a set of free holes, and a unit identifier, rename+-- the free holes according to the instantiation of the unit+-- identifier.  For example, if we have A and B free, and+-- our unit identity is @p[A=<C>,B=impl:B]@, the renamed free+-- holes are just C.+renameFreeHoles :: UniqDSet ModuleName -> [(ModuleName, Module)] -> UniqDSet ModuleName+renameFreeHoles fhs insts =+    unionManyUniqDSets (map lookup_impl (uniqDSetToList fhs))+  where+    hmap = listToUFM insts+    lookup_impl mod_name+        | Just mod <- lookupUFM hmap mod_name = moduleFreeHoles mod+        -- It wasn't actually a hole+        | otherwise                           = emptyUniqDSet+++instance Binary ModIface where+   put_ bh (ModIface {+                 mi_module    = mod,+                 mi_sig_of    = sig_of,+                 mi_hsc_src   = hsc_src,+                 mi_deps      = deps,+                 mi_usages    = usages,+                 mi_exports   = exports,+                 mi_used_th   = used_th,+                 mi_fixities  = fixities,+                 mi_warns     = warns,+                 mi_anns      = anns,+                 mi_decls     = decls,+                 mi_insts     = insts,+                 mi_fam_insts = fam_insts,+                 mi_rules     = rules,+                 mi_hpc       = hpc_info,+                 mi_trust     = trust,+                 mi_trust_pkg = trust_pkg,+                 mi_complete_matches = complete_matches,+                 mi_doc_hdr   = doc_hdr,+                 mi_decl_docs = decl_docs,+                 mi_arg_docs  = arg_docs,+                 mi_ext_fields = _ext_fields, -- Don't `put_` this in the instance so we+                                              -- can deal with it's pointer in the header+                                              -- when we write the actual file+                 mi_final_exts = ModIfaceBackend {+                   mi_iface_hash = iface_hash,+                   mi_mod_hash = mod_hash,+                   mi_flag_hash = flag_hash,+                   mi_opt_hash = opt_hash,+                   mi_hpc_hash = hpc_hash,+                   mi_plugin_hash = plugin_hash,+                   mi_orphan = orphan,+                   mi_finsts = hasFamInsts,+                   mi_exp_hash = exp_hash,+                   mi_orphan_hash = orphan_hash+                 }}) = do+        put_ bh mod+        put_ bh sig_of+        put_ bh hsc_src+        put_ bh iface_hash+        put_ bh mod_hash+        put_ bh flag_hash+        put_ bh opt_hash+        put_ bh hpc_hash+        put_ bh plugin_hash+        put_ bh orphan+        put_ bh hasFamInsts+        lazyPut bh deps+        lazyPut bh usages+        put_ bh exports+        put_ bh exp_hash+        put_ bh used_th+        put_ bh fixities+        lazyPut bh warns+        lazyPut bh anns+        put_ bh decls+        put_ bh insts+        put_ bh fam_insts+        lazyPut bh rules+        put_ bh orphan_hash+        put_ bh hpc_info+        put_ bh trust+        put_ bh trust_pkg+        put_ bh complete_matches+        lazyPut bh doc_hdr+        lazyPut bh decl_docs+        lazyPut bh arg_docs++   get bh = do+        mod         <- get bh+        sig_of      <- get bh+        hsc_src     <- get bh+        iface_hash  <- get bh+        mod_hash    <- get bh+        flag_hash   <- get bh+        opt_hash    <- get bh+        hpc_hash    <- get bh+        plugin_hash <- get bh+        orphan      <- get bh+        hasFamInsts <- get bh+        deps        <- lazyGet bh+        usages      <- {-# SCC "bin_usages" #-} lazyGet bh+        exports     <- {-# SCC "bin_exports" #-} get bh+        exp_hash    <- get bh+        used_th     <- get bh+        fixities    <- {-# SCC "bin_fixities" #-} get bh+        warns       <- {-# SCC "bin_warns" #-} lazyGet bh+        anns        <- {-# SCC "bin_anns" #-} lazyGet bh+        decls       <- {-# SCC "bin_tycldecls" #-} get bh+        insts       <- {-# SCC "bin_insts" #-} get bh+        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh+        rules       <- {-# SCC "bin_rules" #-} lazyGet bh+        orphan_hash <- get bh+        hpc_info    <- get bh+        trust       <- get bh+        trust_pkg   <- get bh+        complete_matches <- get bh+        doc_hdr     <- lazyGet bh+        decl_docs   <- lazyGet bh+        arg_docs    <- lazyGet bh+        return (ModIface {+                 mi_module      = mod,+                 mi_sig_of      = sig_of,+                 mi_hsc_src     = hsc_src,+                 mi_deps        = deps,+                 mi_usages      = usages,+                 mi_exports     = exports,+                 mi_used_th     = used_th,+                 mi_anns        = anns,+                 mi_fixities    = fixities,+                 mi_warns       = warns,+                 mi_decls       = decls,+                 mi_globals     = Nothing,+                 mi_insts       = insts,+                 mi_fam_insts   = fam_insts,+                 mi_rules       = rules,+                 mi_hpc         = hpc_info,+                 mi_trust       = trust,+                 mi_trust_pkg   = trust_pkg,+                        -- And build the cached values+                 mi_complete_matches = complete_matches,+                 mi_doc_hdr     = doc_hdr,+                 mi_decl_docs   = decl_docs,+                 mi_arg_docs    = arg_docs,+                 mi_ext_fields  = emptyExtensibleFields, -- placeholder because this is dealt+                                                         -- with specially when the file is read+                 mi_final_exts = ModIfaceBackend {+                   mi_iface_hash = iface_hash,+                   mi_mod_hash = mod_hash,+                   mi_flag_hash = flag_hash,+                   mi_opt_hash = opt_hash,+                   mi_hpc_hash = hpc_hash,+                   mi_plugin_hash = plugin_hash,+                   mi_orphan = orphan,+                   mi_finsts = hasFamInsts,+                   mi_exp_hash = exp_hash,+                   mi_orphan_hash = orphan_hash,+                   mi_warn_fn = mkIfaceWarnCache warns,+                   mi_fix_fn = mkIfaceFixCache fixities,+                   mi_hash_fn = mkIfaceHashCache decls+                 }})++-- | The original names declared of a certain module that are exported+type IfaceExport = AvailInfo++emptyPartialModIface :: Module -> PartialModIface+emptyPartialModIface mod+  = ModIface { mi_module      = mod,+               mi_sig_of      = Nothing,+               mi_hsc_src     = HsSrcFile,+               mi_deps        = noDependencies,+               mi_usages      = [],+               mi_exports     = [],+               mi_used_th     = False,+               mi_fixities    = [],+               mi_warns       = NoWarnings,+               mi_anns        = [],+               mi_insts       = [],+               mi_fam_insts   = [],+               mi_rules       = [],+               mi_decls       = [],+               mi_globals     = Nothing,+               mi_hpc         = False,+               mi_trust       = noIfaceTrustInfo,+               mi_trust_pkg   = False,+               mi_complete_matches = [],+               mi_doc_hdr     = Nothing,+               mi_decl_docs   = emptyDeclDocMap,+               mi_arg_docs    = emptyArgDocMap,+               mi_final_exts  = (),+               mi_ext_fields  = emptyExtensibleFields+             }++emptyFullModIface :: Module -> ModIface+emptyFullModIface mod =+    (emptyPartialModIface mod)+      { mi_decls = []+      , mi_final_exts = ModIfaceBackend+        { mi_iface_hash = fingerprint0,+          mi_mod_hash = fingerprint0,+          mi_flag_hash = fingerprint0,+          mi_opt_hash = fingerprint0,+          mi_hpc_hash = fingerprint0,+          mi_plugin_hash = fingerprint0,+          mi_orphan = False,+          mi_finsts = False,+          mi_exp_hash = fingerprint0,+          mi_orphan_hash = fingerprint0,+          mi_warn_fn = emptyIfaceWarnCache,+          mi_fix_fn = emptyIfaceFixCache,+          mi_hash_fn = emptyIfaceHashCache } }++-- | Constructs cache for the 'mi_hash_fn' field of a 'ModIface'+mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]+                 -> (OccName -> Maybe (OccName, Fingerprint))+mkIfaceHashCache pairs+  = \occ -> lookupOccEnv env occ+  where+    env = foldl' add_decl emptyOccEnv pairs+    add_decl env0 (v,d) = foldl' add env0 (ifaceDeclFingerprints v d)+      where+        add env0 (occ,hash) = extendOccEnv env0 occ (occ,hash)++emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)+emptyIfaceHashCache _occ = Nothing++-- Take care, this instance only forces to the degree necessary to+-- avoid major space leaks.+instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where+  rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12+                f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =+    rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`+    f9 `seq` rnf f10 `seq` rnf f11 `seq` f12 `seq` rnf f13 `seq` rnf f14 `seq` rnf f15 `seq`+    rnf f16 `seq` f17 `seq` rnf f18 `seq` rnf f19 `seq` f20 `seq` f21 `seq` f22 `seq` rnf f23+    `seq` rnf f24++-- | Records whether a module has orphans. An \"orphan\" is one of:+--+-- * An instance declaration in a module other than the definition+--   module for one of the type constructors or classes in the instance head+--+-- * A rewrite rule in a module other than the one defining+--   the function in the head of the rule+--+type WhetherHasOrphans   = Bool++-- | Does this module define family instances?+type WhetherHasFamInst = Bool+++

+ GHC/Unit/Module/ModSummary.hs view

@@ -0,0 +1,183 @@+{-# LANGUAGE LambdaCase #-}++-- | A ModSummary is a node in the compilation manager's dependency graph+-- (ModuleGraph)+module GHC.Unit.Module.ModSummary+   ( ExtendedModSummary (..)+   , extendModSummaryNoDeps+   , ModSummary (..)+   , ms_installed_mod+   , ms_mod_name+   , ms_imps+   , ms_home_allimps+   , ms_home_srcimps+   , ms_home_imps+   , msHiFilePath+   , msHsFilePath+   , msObjFilePath+   , msDynObjFilePath+   , isBootSummary+   , findTarget+   )+where++import GHC.Prelude++import GHC.Hs++import GHC.Driver.Session++import GHC.Unit.Types+import GHC.Unit.Module++import GHC.Types.SourceFile ( HscSource(..), hscSourceString )+import GHC.Types.SrcLoc+import GHC.Types.Target++import GHC.Data.Maybe+import GHC.Data.FastString+import GHC.Data.StringBuffer ( StringBuffer )++import GHC.Utils.Outputable++import Data.Time++-- | Enrichment of 'ModSummary' with backpack dependencies+data ExtendedModSummary = ExtendedModSummary+  { emsModSummary :: {-# UNPACK #-} !ModSummary+  , emsInstantiatedUnits :: [InstantiatedUnit]+  -- ^ Extra backpack deps+  -- NB: This is sometimes left empty in situations where the instantiated units+  -- would not be used. See call sites of 'extendModSummaryNoDeps'.+  }++instance Outputable ExtendedModSummary where+  ppr = \case+    ExtendedModSummary ms bds -> ppr ms <+> ppr bds++extendModSummaryNoDeps :: ModSummary -> ExtendedModSummary+extendModSummaryNoDeps ms = ExtendedModSummary ms []++-- | Data for a module node in a 'ModuleGraph'. Module nodes of the module graph+-- are one of:+--+-- * A regular Haskell source module+-- * A hi-boot source module+--+data ModSummary+   = ModSummary {+        ms_mod          :: Module,+          -- ^ Identity of the module+        ms_hsc_src      :: HscSource,+          -- ^ The module source either plain Haskell, hs-boot, or hsig+        ms_location     :: ModLocation,+          -- ^ Location of the various files belonging to the module+        ms_hs_date      :: UTCTime,+          -- ^ Timestamp of source file+        ms_obj_date     :: Maybe UTCTime,+          -- ^ Timestamp of object, if we have one+        ms_iface_date   :: Maybe UTCTime,+          -- ^ Timestamp of hi file, if we *only* are typechecking (it is+          -- 'Nothing' otherwise.+          -- See Note [Recompilation checking in -fno-code mode] and #9243+        ms_hie_date   :: Maybe UTCTime,+          -- ^ Timestamp of hie file, if we have one+        ms_srcimps      :: [(Maybe FastString, Located ModuleName)],+          -- ^ Source imports of the module+        ms_textual_imps :: [(Maybe FastString, Located ModuleName)],+          -- ^ Non-source imports of the module from the module *text*+        ms_parsed_mod   :: Maybe HsParsedModule,+          -- ^ The parsed, nonrenamed source, if we have it.  This is also+          -- used to support "inline module syntax" in Backpack files.+        ms_hspp_file    :: FilePath,+          -- ^ Filename of preprocessed source file+        ms_hspp_opts    :: DynFlags,+          -- ^ Cached flags from @OPTIONS@, @INCLUDE@ and @LANGUAGE@+          -- pragmas in the modules source code+        ms_hspp_buf     :: Maybe StringBuffer+          -- ^ The actual preprocessed source, if we have it+     }++ms_installed_mod :: ModSummary -> InstalledModule+ms_installed_mod = fst . getModuleInstantiation . ms_mod++ms_mod_name :: ModSummary -> ModuleName+ms_mod_name = moduleName . ms_mod++ms_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]+ms_imps ms =+  ms_textual_imps ms +++  map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))+  where+    mk_additional_import mod_nm = (Nothing, noLoc mod_nm)++home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]+home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,+                                  isLocal mb_pkg ]+  where isLocal Nothing = True+        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special+        isLocal _ = False++ms_home_allimps :: ModSummary -> [ModuleName]+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)++-- | Like 'ms_home_imps', but for SOURCE imports.+ms_home_srcimps :: ModSummary -> [Located ModuleName]+ms_home_srcimps = home_imps . ms_srcimps++-- | All of the (possibly) home module imports from a+-- 'ModSummary'; that is to say, each of these module names+-- could be a home import if an appropriately named file+-- existed.  (This is in contrast to package qualified+-- imports, which are guaranteed not to be home imports.)+ms_home_imps :: ModSummary -> [Located ModuleName]+ms_home_imps = home_imps . ms_imps++-- The ModLocation contains both the original source filename and the+-- filename of the cleaned-up source file after all preprocessing has been+-- done.  The point is that the summariser will have to cpp/unlit/whatever+-- all files anyway, and there's no point in doing this twice -- just+-- park the result in a temp file, put the name of it in the location,+-- and let @compile@ read from that file on the way back up.++-- The ModLocation is stable over successive up-sweeps in GHCi, wheres+-- the ms_hs_date and imports can, of course, change++msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath+msHsFilePath  ms = expectJust "msHsFilePath" (ml_hs_file  (ms_location ms))+msHiFilePath  ms = ml_hi_file  (ms_location ms)+msObjFilePath ms = ml_obj_file (ms_location ms)++msDynObjFilePath :: ModSummary -> DynFlags -> FilePath+msDynObjFilePath ms dflags = dynamicOutputFile dflags (msObjFilePath ms)++-- | Did this 'ModSummary' originate from a hs-boot file?+isBootSummary :: ModSummary -> IsBootInterface+isBootSummary ms = if ms_hsc_src ms == HsBootFile then IsBoot else NotBoot++instance Outputable ModSummary where+   ppr ms+      = sep [text "ModSummary {",+             nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),+                          text "ms_mod =" <+> ppr (ms_mod ms)+                                <> text (hscSourceString (ms_hsc_src ms)) <> comma,+                          text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),+                          text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),+             char '}'+            ]++findTarget :: ModSummary -> [Target] -> Maybe Target+findTarget ms ts =+  case filter (matches ms) ts of+        []    -> Nothing+        (t:_) -> Just t+  where+    summary `matches` Target (TargetModule m) _ _+        = ms_mod_name summary == m+    summary `matches` Target (TargetFile f _) _ _+        | Just f' <- ml_hs_file (ms_location summary)+        = f == f'+    _ `matches` _+        = False++

GHC/Unit/Module/Name.hs view

@@ -30,7 +30,7 @@ import Data.Char (isAlphaNum)  -- | A ModuleName is essentially a simple string, e.g. @Data.List@.-newtype ModuleName = ModuleName FastString+newtype ModuleName = ModuleName FastString deriving Show  instance Uniquable ModuleName where   getUnique (ModuleName nm) = getUnique nm@@ -59,7 +59,7 @@  stableModuleNameCmp :: ModuleName -> ModuleName -> Ordering -- ^ Compares module names lexically, rather than by their 'Unique's-stableModuleNameCmp n1 n2 = moduleNameFS n1 `compare` moduleNameFS n2+stableModuleNameCmp n1 n2 = moduleNameFS n1 `lexicalCompareFS` moduleNameFS n2  pprModuleName :: ModuleName -> SDoc pprModuleName (ModuleName nm) =

+ GHC/Unit/Module/Status.hs view

@@ -0,0 +1,39 @@+module GHC.Unit.Module.Status+   ( HscStatus (..)+   )+where++import GHC.Prelude++import GHC.Unit+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModDetails++import GHC.Utils.Fingerprint++-- | Status of a module compilation to machine code+data HscStatus+    -- | Nothing to do.+    = HscNotGeneratingCode ModIface ModDetails+    -- | Nothing to do because code already exists.+    | HscUpToDate ModIface ModDetails+    -- | Update boot file result.+    | HscUpdateBoot ModIface ModDetails+    -- | Generate signature file (backpack)+    | HscUpdateSig ModIface ModDetails+    -- | Recompile this module.+    | HscRecomp+        { hscs_guts           :: CgGuts+          -- ^ Information for the code generator.+        , hscs_mod_location   :: !ModLocation+          -- ^ Module info+        , hscs_mod_details    :: !ModDetails+        , hscs_partial_iface  :: !PartialModIface+          -- ^ Partial interface+        , hscs_old_iface_hash :: !(Maybe Fingerprint)+          -- ^ Old interface hash for this compilation, if an old interface file+          -- exists. Pass to `hscMaybeWriteIface` when writing the interface to+          -- avoid updating the existing interface when the interface isn't+          -- changed.+        }

+ GHC/Unit/Module/Warnings.hs view

@@ -0,0 +1,146 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- | Warnings for a module+module GHC.Unit.Module.Warnings+   ( Warnings (..)+   , WarningTxt (..)+   , pprWarningTxtForMsg+   , mkIfaceWarnCache+   , emptyIfaceWarnCache+   , plusWarns+   )+where++import GHC.Prelude++import GHC.Types.SourceText+import GHC.Types.Name.Occurrence+import GHC.Types.SrcLoc++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data++-- | Warning Text+--+-- reason/explanation from a WARNING or DEPRECATED pragma+data WarningTxt+   = WarningTxt+      (Located SourceText)+      [Located StringLiteral]+   | DeprecatedTxt+      (Located SourceText)+      [Located StringLiteral]+   deriving (Eq, Data)++instance Outputable WarningTxt where+    ppr (WarningTxt    lsrc ws)+      = case unLoc lsrc of+          NoSourceText   -> pp_ws ws+          SourceText src -> text src <+> pp_ws ws <+> text "#-}"++    ppr (DeprecatedTxt lsrc  ds)+      = case unLoc lsrc of+          NoSourceText   -> pp_ws ds+          SourceText src -> text src <+> pp_ws ds <+> text "#-}"++instance Binary WarningTxt where+    put_ bh (WarningTxt s w) = do+            putByte bh 0+            put_ bh s+            put_ bh w+    put_ bh (DeprecatedTxt s d) = do+            putByte bh 1+            put_ bh s+            put_ bh d++    get bh = do+            h <- getByte bh+            case h of+              0 -> do s <- get bh+                      w <- get bh+                      return (WarningTxt s w)+              _ -> do s <- get bh+                      d <- get bh+                      return (DeprecatedTxt s d)+++pp_ws :: [Located StringLiteral] -> SDoc+pp_ws [l] = ppr $ unLoc l+pp_ws ws+  = text "["+    <+> vcat (punctuate comma (map (ppr . unLoc) ws))+    <+> text "]"+++pprWarningTxtForMsg :: WarningTxt -> SDoc+pprWarningTxtForMsg (WarningTxt    _ ws)+                     = doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ws))+pprWarningTxtForMsg (DeprecatedTxt _ ds)+                     = text "Deprecated:" <+>+                       doubleQuotes (vcat (map (ftext . sl_fs . unLoc) ds))+++-- | Warning information for a module+data Warnings+  = NoWarnings                          -- ^ Nothing deprecated+  | WarnAll WarningTxt                  -- ^ Whole module deprecated+  | WarnSome [(OccName,WarningTxt)]     -- ^ Some specific things deprecated++     -- Only an OccName is needed because+     --    (1) a deprecation always applies to a binding+     --        defined in the module in which the deprecation appears.+     --    (2) deprecations are only reported outside the defining module.+     --        this is important because, otherwise, if we saw something like+     --+     --        {-# DEPRECATED f "" #-}+     --        f = ...+     --        h = f+     --        g = let f = undefined in f+     --+     --        we'd need more information than an OccName to know to say something+     --        about the use of f in h but not the use of the locally bound f in g+     --+     --        however, because we only report about deprecations from the outside,+     --        and a module can only export one value called f,+     --        an OccName suffices.+     --+     --        this is in contrast with fixity declarations, where we need to map+     --        a Name to its fixity declaration.+  deriving( Eq )++instance Binary Warnings where+    put_ bh NoWarnings     = putByte bh 0+    put_ bh (WarnAll t) = do+            putByte bh 1+            put_ bh t+    put_ bh (WarnSome ts) = do+            putByte bh 2+            put_ bh ts++    get bh = do+            h <- getByte bh+            case h of+              0 -> return NoWarnings+              1 -> do aa <- get bh+                      return (WarnAll aa)+              _ -> do aa <- get bh+                      return (WarnSome aa)++-- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'+mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt+mkIfaceWarnCache NoWarnings  = \_ -> Nothing+mkIfaceWarnCache (WarnAll t) = \_ -> Just t+mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)++emptyIfaceWarnCache :: OccName -> Maybe WarningTxt+emptyIfaceWarnCache _ = Nothing++plusWarns :: Warnings -> Warnings -> Warnings+plusWarns d NoWarnings = d+plusWarns NoWarnings d = d+plusWarns _ (WarnAll t) = WarnAll t+plusWarns (WarnAll t) _ = WarnAll t+plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)+

GHC/Unit/Parser.hs view

@@ -36,7 +36,7 @@ parseIndefUnitId :: ReadP IndefUnitId parseIndefUnitId = do    uid <- parseUnitId-   return (Indefinite uid Nothing)+   return (Indefinite uid)  parseHoleyModule :: ReadP Module parseHoleyModule = parseModuleVar <++ parseModule

GHC/Unit/Ppr.hs view

@@ -5,6 +5,7 @@ where  import GHC.Prelude+import GHC.Data.FastString import GHC.Utils.Outputable import Data.Version @@ -14,18 +15,22 @@ --    package-version:componentname -- data UnitPprInfo = UnitPprInfo-   { unitPprPackageName    :: String       -- ^ Source package name+   { unitPprId             :: FastString   -- ^ Identifier+   , unitPprPackageName    :: String       -- ^ Source package name    , unitPprPackageVersion :: Version      -- ^ Source package version    , unitPprComponentName  :: Maybe String -- ^ Component name    }  instance Outputable UnitPprInfo where-  ppr pprinfo = text $ mconcat-      [ unitPprPackageName pprinfo-      , case unitPprPackageVersion pprinfo of-         Version [] [] -> ""-         version       -> "-" ++ showVersion version-      , case unitPprComponentName pprinfo of-         Nothing    -> ""-         Just cname -> ":" ++ cname-      ]+  ppr pprinfo = getPprDebug $ \debug ->+    if debug+       then ftext (unitPprId pprinfo)+       else text $ mconcat+         [ unitPprPackageName pprinfo+         , case unitPprPackageVersion pprinfo of+            Version [] [] -> ""+            version       -> "-" ++ showVersion version+         , case unitPprComponentName pprinfo of+            Nothing    -> ""+            Just cname -> ":" ++ cname+         ]

GHC/Unit/State.hs view

@@ -2,6 +2,7 @@  {-# LANGUAGE CPP, ScopedTypeVariables, BangPatterns, FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}  -- | Unit manipulation module GHC.Unit.State (@@ -9,7 +10,9 @@          -- * Reading the package config, and processing cmdline args         UnitState(..),+        PreloadUnitClosure,         UnitDatabase (..),+        UnitErr (..),         emptyUnitState,         initUnits,         readUnitDatabases,@@ -19,6 +22,7 @@         listUnitInfo,          -- * Querying the package config+        UnitInfoMap,         lookupUnit,         lookupUnit',         unsafeLookupUnit,@@ -29,30 +33,21 @@         lookupPackageName,         improveUnit,         searchPackageId,-        displayUnitId,         listVisibleModuleNames,         lookupModuleInAllUnits,         lookupModuleWithSuggestions,         lookupModulePackage,         lookupPluginModuleWithSuggestions,+        requirementMerges,         LookupResult(..),         ModuleSuggestion(..),         ModuleOrigin(..),         UnusableUnitReason(..),         pprReason, -        -- * Inspecting the set of packages in scope-        getUnitIncludePath,-        getUnitLibraryPath,-        getUnitLinkOpts,-        getUnitExtraCcOpts,-        getUnitFrameworkPath,-        getUnitFrameworks,-        getPreloadUnitsAnd,--        collectArchives,-        collectIncludeDirs, collectLibraryPaths, collectLinkOpts,-        packageHsLibs, getLibs,+        closeUnitDeps,+        closeUnitDeps',+        mayThrowUnitErr,          -- * Module hole substitution         ShHoleSubst,@@ -63,16 +58,17 @@         instUnitToUnit,         instModuleToModule, -        -- * Utils-        mkIndefUnitId,-        updateIndefUnitId,-        unwireUnit,+        -- * Pretty-printing         pprFlag,         pprUnits,         pprUnitsSimple,+        pprUnitIdForUser,+        pprUnitInfoForUser,         pprModuleMap,-        homeUnitIsIndefinite,-        homeUnitIsDefinite,+        pprWithUnitState,++        -- * Utils+        unwireUnit     ) where @@ -80,17 +76,23 @@  import GHC.Prelude +import GHC.Driver.Session+ import GHC.Platform+import GHC.Platform.Ways+ import GHC.Unit.Database import GHC.Unit.Info+import GHC.Unit.Ppr import GHC.Unit.Types import GHC.Unit.Module-import GHC.Driver.Session-import GHC.Driver.Ways+import GHC.Unit.Home+ import GHC.Types.Unique.FM import GHC.Types.Unique.DFM import GHC.Types.Unique.Set import GHC.Types.Unique.DSet+ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Outputable as Outputable@@ -98,8 +100,9 @@  import System.Environment ( getEnv ) import GHC.Data.FastString-import GHC.Utils.Error  ( debugTraceMsg, MsgDoc, dumpIfSet_dyn,-                          withTiming, DumpFormat (..) )+import qualified GHC.Data.ShortText as ST+import GHC.Utils.Logger+import GHC.Utils.Error import GHC.Utils.Exception  import System.Directory@@ -107,7 +110,7 @@ import Control.Monad import Data.Graph (stronglyConnComp, SCC(..)) import Data.Char ( toUpper )-import Data.List as List+import Data.List ( intersperse, partition, sortBy, isSuffixOf ) import Data.Map (Map) import Data.Set (Set) import Data.Monoid (First(..))@@ -119,11 +122,7 @@ -- --------------------------------------------------------------------------- -- The Unit state --- | Unit state is all stored in 'DynFlags', including the details of--- all units, which units are exposed, and which modules they--- provide.------ The unit state is computed by 'initUnits', and kept in DynFlags.+-- The unit state is computed by 'initUnits', and kept in HscEnv. -- It is influenced by various command-line flags: -- --   * @-package \<pkg>@ and @-package-id \<pkg>@ cause @\<pkg>@ to become exposed.@@ -228,14 +227,16 @@ fromFlag = ModOrigin Nothing [] [] True  instance Semigroup ModuleOrigin where-    ModOrigin e res rhs f <> ModOrigin e' res' rhs' f' =+    x@(ModOrigin e res rhs f) <> y@(ModOrigin e' res' rhs' f') =         ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f')       where g (Just b) (Just b')                 | b == b'   = Just b-                | otherwise = panic "ModOrigin: package both exposed/hidden"+                | otherwise = pprPanic "ModOrigin: package both exposed/hidden" $+                    text "x: " <> ppr x $$ text "y: " <> ppr y             g Nothing x = x             g x Nothing = x-    _x <> _y = panic "ModOrigin: hidden module redefined"+    x <> y = pprPanic "ModOrigin: hidden module redefined" $+                 text "x: " <> ppr x $$ text "y: " <> ppr y  instance Monoid ModuleOrigin where     mempty = ModOrigin Nothing [] [] False@@ -312,8 +313,14 @@  -- | Unit configuration data UnitConfig = UnitConfig-   { unitConfigPlatformArchOs :: !PlatformMini  -- ^ Platform-   , unitConfigWays           :: !(Set Way)     -- ^ Ways to use+   { unitConfigPlatformArchOS :: !ArchOS        -- ^ Platform arch and OS+   , unitConfigWays           :: !Ways          -- ^ Ways to use++   , unitConfigAllowVirtual   :: !Bool          -- ^ Allow virtual units+      -- ^ Do we allow the use of virtual units instantiated on-the-fly (see Note+      -- [About units] in GHC.Unit). This should only be true when we are+      -- type-checking an indefinite unit (not producing any code).+    , unitConfigProgramName    :: !String       -- ^ Name of the compiler (e.g. "GHC", "GHCJS"). Used to fetch environment       -- variables such as "GHC[JS]_PACKAGE_PATH".@@ -327,11 +334,6 @@    , unitConfigHideAll        :: !Bool     -- ^ Hide all units by default    , unitConfigHideAllPlugins :: !Bool     -- ^ Hide all plugins units by default -   , unitConfigAllowVirtualUnits :: !Bool-      -- ^ Allow the use of virtual units instantiated on-the-fly (see Note-      -- [About units] in GHC.Unit). This should only be used when we are-      -- type-checking an indefinite unit (not producing any code).-    , unitConfigDBCache      :: Maybe [UnitDatabase UnitId]       -- ^ Cache of databases to use, in the order they were specified on the       -- command line (later databases shadow earlier ones).@@ -345,18 +347,30 @@    , unitConfigFlagsPlugins :: [PackageFlag]       -- ^ Plugins exposed units    } -initUnitConfig :: DynFlags -> UnitConfig-initUnitConfig dflags =-   let autoLink+initUnitConfig :: DynFlags -> Maybe [UnitDatabase UnitId] -> UnitConfig+initUnitConfig dflags cached_dbs =+   let !hu_id             = homeUnitId_ dflags+       !hu_instanceof     = homeUnitInstanceOf_ dflags+       !hu_instantiations = homeUnitInstantiations_ dflags++       autoLink          | not (gopt Opt_AutoLinkPackages dflags) = []          -- By default we add base & rts to the preload units (when they are          -- found in the unit database) except when we are building them-         | otherwise = filter (/= homeUnitId dflags) [baseUnitId, rtsUnitId]+         | otherwise = filter (hu_id /=) [baseUnitId, rtsUnitId] +       -- if the home unit is indefinite, it means we are type-checking it only+       -- (not producing any code). Hence we can use virtual units instantiated+       -- on-the-fly. See Note [About units] in GHC.Unit+       allow_virtual_units = case (hu_instanceof, hu_instantiations) of+            (Just u, is) -> u == hu_id && any (isHoleModule . snd) is+            _            -> False+    in UnitConfig-      { unitConfigPlatformArchOs = platformMini (targetPlatform dflags)+      { unitConfigPlatformArchOS = platformArchOS (targetPlatform dflags)       , unitConfigProgramName    = programName dflags       , unitConfigWays           = ways dflags+      , unitConfigAllowVirtual   = allow_virtual_units        , unitConfigGlobalDB       = globalPackageDatabasePath dflags       , unitConfigGHCDir         = topDir dflags@@ -367,12 +381,7 @@       , unitConfigHideAll        = gopt Opt_HideAllPackages dflags       , unitConfigHideAllPlugins = gopt Opt_HideAllPluginPackages dflags -        -- when the home unit is indefinite, it means we are type-checking it-        -- only (not producing any code). Hence we can use virtual units-        -- instantiated on-the-fly (see Note [About units] in GHC.Unit)-      , unitConfigAllowVirtualUnits = homeUnitIsIndefinite dflags--      , unitConfigDBCache      = unitDatabases dflags+      , unitConfigDBCache      = cached_dbs       , unitConfigFlagsDB      = packageDBFlags dflags       , unitConfigFlagsExposed = packageFlags dflags       , unitConfigFlagsIgnored = ignorePackageFlags dflags@@ -406,7 +415,7 @@    -- | A mapping of 'PackageName' to 'IndefUnitId'.  This is used when   -- users refer to packages in Backpack includes.-  packageNameMap            :: Map PackageName IndefUnitId,+  packageNameMap            :: UniqFM PackageName IndefUnitId,    -- | A mapping from database unit keys to wired in unit ids.   wireMap :: Map UnitId UnitId,@@ -451,7 +460,7 @@ emptyUnitState = UnitState {     unitInfoMap = Map.empty,     preloadClosure = emptyUniqSet,-    packageNameMap = Map.empty,+    packageNameMap = emptyUFM,     wireMap   = Map.empty,     unwireMap = Map.empty,     preloadUnits = [],@@ -524,7 +533,7 @@ -- | Find the unit we know about with the given package name (e.g. @foo@), if any -- (NB: there might be a locally defined unit name which overrides this) lookupPackageName :: UnitState -> PackageName -> Maybe IndefUnitId-lookupPackageName pkgstate n = Map.lookup n (packageNameMap pkgstate)+lookupPackageName pkgstate n = lookupUFM (packageNameMap pkgstate) n  -- | Search for units with a given package ID (e.g. \"foo-0.1\") searchPackageId :: UnitState -> PackageId -> [UnitInfo]@@ -569,28 +578,73 @@ -- 'initUnits' can be called again subsequently after updating the -- 'packageFlags' field of the 'DynFlags', and it will update the -- 'unitState' in 'DynFlags'.-initUnits :: DynFlags -> IO DynFlags-initUnits dflags = do+initUnits :: Logger -> DynFlags -> Maybe [UnitDatabase UnitId] -> IO ([UnitDatabase UnitId], UnitState, HomeUnit, Maybe PlatformConstants)+initUnits logger dflags cached_dbs = do    let forceUnitInfoMap (state, _) = unitInfoMap state `seq` ()   let ctx     = initSDocContext dflags defaultUserStyle -- SDocContext used to render exception messages-  let printer = debugTraceMsg dflags                    -- printer for trace messages+  let printer = debugTraceMsg logger dflags             -- printer for trace messages -  (state,dbs) <- withTiming dflags (text "initializing unit database")+  (unit_state,dbs) <- withTiming logger dflags (text "initializing unit database")                    forceUnitInfoMap-                   (mkUnitState ctx printer (initUnitConfig dflags))+                 $ mkUnitState ctx printer (initUnitConfig dflags cached_dbs) -  dumpIfSet_dyn (dflags { pprCols = 200 }) Opt_D_dump_mod_map "Module Map"-    FormatText (pprModuleMap (moduleNameProvidersMap state))+  dumpIfSet_dyn logger dflags Opt_D_dump_mod_map "Module Map"+    FormatText (updSDocContext (\ctx -> ctx {sdocLineLength = 200})+                $ pprModuleMap (moduleNameProvidersMap unit_state)) -  let dflags'  = dflags-                  { unitDatabases = Just dbs -- databases are cached and never read again-                  , unitState     = state-                  }-      dflags'' = upd_wired_in_home_instantiations dflags'+  let home_unit = mkHomeUnit unit_state+                             (homeUnitId_ dflags)+                             (homeUnitInstanceOf_ dflags)+                             (homeUnitInstantiations_ dflags) -  return dflags''+  -- Try to find platform constants+  --+  -- See Note [Platform constants] in GHC.Platform+  mconstants <- if homeUnitId_ dflags == rtsUnitId+    then do+      -- we're building the RTS! Lookup DerivedConstants.h in the include paths+      lookupPlatformConstants (includePathsGlobal (includePaths dflags))+    else+      -- lookup the DerivedConstants.h header bundled with the RTS unit. We+      -- don't fail if we can't find the RTS unit as it can be a valid (but+      -- uncommon) case, e.g. building a C utility program (not depending on the+      -- RTS) before building the RTS. In any case, we will fail later on if we+      -- really need to use the platform constants but they have not been loaded.+      case lookupUnitId unit_state rtsUnitId of+        Nothing   -> return Nothing+        Just info -> lookupPlatformConstants (fmap ST.unpack (unitIncludeDirs info)) +  return (dbs,unit_state,home_unit,mconstants)++mkHomeUnit+    :: UnitState+    -> UnitId                 -- ^ Home unit id+    -> Maybe UnitId           -- ^ Home unit instance of+    -> [(ModuleName, Module)] -- ^ Home unit instantiations+    -> HomeUnit+mkHomeUnit unit_state hu_id hu_instanceof hu_instantiations_ =+    let+        -- Some wired units can be used to instantiate the home unit. We need to+        -- replace their unit keys with their wired unit ids.+        wmap              = wireMap unit_state+        hu_instantiations = map (fmap (upd_wired_in_mod wmap)) hu_instantiations_+    in case (hu_instanceof, hu_instantiations) of+      (Nothing,[]) -> DefiniteHomeUnit hu_id Nothing+      (Nothing, _) -> throwGhcException $ CmdLineError ("Use of -instantiated-with requires -this-component-id")+      (Just _, []) -> throwGhcException $ CmdLineError ("Use of -this-component-id requires -instantiated-with")+      (Just u, is)+         -- detect fully indefinite units: all their instantiations are hole+         -- modules and the home unit id is the same as the instantiating unit+         -- id (see Note [About units] in GHC.Unit)+         | all (isHoleModule . snd) is && u == hu_id+         -> IndefiniteHomeUnit u is+         -- otherwise it must be that we (fully) instantiate an indefinite unit+         -- to make it definite.+         -- TODO: error when the unit is partially instantiated??+         | otherwise+         -> DefiniteHomeUnit hu_id (Just (u, is))+ -- ----------------------------------------------------------------------------- -- Reading the unit database(s) @@ -644,7 +698,7 @@ resolveUnitDatabase :: UnitConfig -> PkgDbRef -> IO (Maybe FilePath) resolveUnitDatabase cfg GlobalPkgDb = return $ Just (unitConfigGlobalDB cfg) resolveUnitDatabase cfg UserPkgDb = runMaybeT $ do-  dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOs cfg)+  dir <- versionedAppDir (unitConfigProgramName cfg) (unitConfigPlatformArchOS cfg)   let pkgconf = dir </> unitConfigDBName cfg   exist <- tryMaybeT $ doesDirectoryExist pkgconf   if exist then return pkgconf else mzero@@ -677,7 +731,7 @@       conf_file' = dropTrailingPathSeparator conf_file       top_dir = unitConfigGHCDir cfg       pkgroot = takeDirectory conf_file'-      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) unitIdFS . mkUnitKeyInfo)+      pkg_configs1 = map (mungeUnitInfo top_dir pkgroot . mapUnitInfo (\(UnitKey x) -> UnitId x) . mkUnitKeyInfo)                          proto_pkg_configs   --   return $ UnitDatabase conf_file' pkg_configs1@@ -705,7 +759,7 @@                           <+> text conf_dir <> text ", treating"                           <+> text "package database as empty"               return []-            else do+            else               throwGhcExceptionIO $ InstallationError $                 "there is no package.cache in " ++ conf_dir ++                 " even though package database is not empty"@@ -740,7 +794,7 @@                    -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot =     mungeDynLibFields-  . mungeUnitInfoPaths top_dir pkgroot+  . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)  mungeDynLibFields :: UnitInfo -> UnitInfo mungeDynLibFields pkg =@@ -755,40 +809,28 @@ -- -trust and -distrust.  applyTrustFlag-   :: SDocContext-   -> UnitPrecedenceMap+   :: UnitPrecedenceMap    -> UnusableUnits    -> [UnitInfo]    -> TrustFlag-   -> IO [UnitInfo]-applyTrustFlag ctx prec_map unusable pkgs flag =+   -> MaybeErr UnitErr [UnitInfo]+applyTrustFlag prec_map unusable pkgs flag =   case flag of     -- we trust all matching packages. Maybe should only trust first one?     -- and leave others the same or set them untrusted     TrustPackage str ->        case selectPackages prec_map (PackageArg str) pkgs unusable of-         Left ps       -> trustFlagErr ctx flag ps-         Right (ps,qs) -> return (map trust ps ++ qs)+         Left ps       -> Failed (TrustFlagErr flag ps)+         Right (ps,qs) -> Succeeded (map trust ps ++ qs)           where trust p = p {unitIsTrusted=True}      DistrustPackage str ->        case selectPackages prec_map (PackageArg str) pkgs unusable of-         Left ps       -> trustFlagErr ctx flag ps-         Right (ps,qs) -> return (distrustAllUnits ps ++ qs)---- | A little utility to tell if the home unit is indefinite--- (if it is not, we should never use on-the-fly renaming.)-homeUnitIsIndefinite :: DynFlags -> Bool-homeUnitIsIndefinite dflags = not (homeUnitIsDefinite dflags)---- | A little utility to tell if the home unit is definite--- (if it is, we should never use on-the-fly renaming.)-homeUnitIsDefinite :: DynFlags -> Bool-homeUnitIsDefinite dflags = unitIsDefinite (homeUnit dflags)+         Left ps       -> Failed (TrustFlagErr flag ps)+         Right (ps,qs) -> Succeeded (distrustAllUnits ps ++ qs)  applyPackageFlag-   :: SDocContext-   -> UnitPrecedenceMap+   :: UnitPrecedenceMap    -> UnitInfoMap    -> PreloadUnitClosure    -> UnusableUnits@@ -796,15 +838,15 @@            -- any previously exposed packages with the same name    -> [UnitInfo]    -> VisibilityMap           -- Initially exposed-   -> PackageFlag               -- flag to apply-   -> IO VisibilityMap        -- Now exposed+   -> PackageFlag             -- flag to apply+   -> MaybeErr UnitErr VisibilityMap -- Now exposed -applyPackageFlag ctx prec_map pkg_map closure unusable no_hide_others pkgs vm flag =+applyPackageFlag prec_map pkg_map closure unusable no_hide_others pkgs vm flag =   case flag of     ExposePackage _ arg (ModRenaming b rns) ->        case findPackages prec_map pkg_map closure arg pkgs unusable of-         Left ps         -> packageFlagErr ctx flag ps-         Right (p:_) -> return vm'+         Left ps     -> Failed (PackageFlagErr flag ps)+         Right (p:_) -> Succeeded vm'           where            n = fsPackageName p @@ -867,9 +909,8 @@      HidePackage str ->        case findPackages prec_map pkg_map closure (PackageArg str) pkgs unusable of-         Left ps  -> packageFlagErr ctx flag ps-         Right ps -> return vm'-          where vm' = foldl' (flip Map.delete) vm (map mkUnit ps)+         Left ps  -> Failed (PackageFlagErr flag ps)+         Right ps -> Succeeded $ foldl' (flip Map.delete) vm (map mkUnit ps)  -- | Like 'selectPackages', but doesn't return a list of unmatched -- packages.  Furthermore, any packages it returns are *renamed*@@ -889,7 +930,7 @@         else Right (sortByPreference prec_map ps)   where     finder (PackageArg str) p-      = if str == unitPackageIdString p || str == unitPackageNameString p+      = if matchingStr str p           then Just p           else Nothing     finder (UnitIdArg uid) p@@ -976,34 +1017,6 @@ comparing :: Ord a => (t -> a) -> t -> t -> Ordering comparing f a b = f a `compare` f b -packageFlagErr :: SDocContext-               -> PackageFlag-               -> [(UnitInfo, UnusableUnitReason)]-               -> IO a-packageFlagErr ctx flag reasons-  = packageFlagErr' ctx (pprFlag flag) reasons--trustFlagErr :: SDocContext-             -> TrustFlag-             -> [(UnitInfo, UnusableUnitReason)]-             -> IO a-trustFlagErr ctx flag reasons-  = packageFlagErr' ctx (pprTrustFlag flag) reasons--packageFlagErr' :: SDocContext-               -> SDoc-               -> [(UnitInfo, UnusableUnitReason)]-               -> IO a-packageFlagErr' ctx flag_doc reasons-  = throwGhcExceptionIO (CmdLineError (renderWithStyle ctx $ err))-  where err = text "cannot satisfy " <> flag_doc <>-                (if null reasons then Outputable.empty else text ": ") $$-              nest 4 (ppr_reasons $$-                      text "(use -v for more information)")-        ppr_reasons = vcat (map ppr_reason reasons)-        ppr_reason (p, reason) =-            pprReason (ppr (unitId p) <+> text "is") reason- pprFlag :: PackageFlag -> SDoc pprFlag flag = case flag of     HidePackage p   -> text "-hide-package " <> text p@@ -1123,17 +1136,6 @@ -- For instance, base-4.9.0.0 will be rewritten to just base, to match -- what appears in GHC.Builtin.Names. --- | Some wired units can be used to instantiate the home unit. We need to--- replace their unit keys with their wired unit ids.-upd_wired_in_home_instantiations :: DynFlags -> DynFlags-upd_wired_in_home_instantiations dflags = dflags { homeUnitInstantiations = wiredInsts }-   where-      state        = unitState dflags-      wiringMap    = wireMap state-      unwiredInsts = homeUnitInstantiations dflags-      wiredInsts   = map (fmap (upd_wired_in_mod wiringMap)) unwiredInsts-- upd_wired_in_mod :: WiringMap -> Module -> Module upd_wired_in_mod wiredInMap (Module uid m) = Module (upd_wired_in_uid wiredInMap uid) m @@ -1488,7 +1490,8 @@    -- Apply trust flags (these flags apply regardless of whether   -- or not packages are visible or not)-  pkgs1 <- foldM (applyTrustFlag ctx prec_map unusable)+  pkgs1 <- mayThrowUnitErr+            $ foldM (applyTrustFlag prec_map unusable)                  (Map.elems pkg_map2) (reverse (unitConfigFlagsTrusted cfg))   let prelim_pkg_db = mkUnitInfoMap pkgs1 @@ -1546,7 +1549,8 @@   -- -hide-package).  This needs to know about the unusable packages, since if a   -- user tries to enable an unusable package, we should let them know.   ---  vis_map2 <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable+  vis_map2 <- mayThrowUnitErr+                $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable                         (unitConfigHideAll cfg) pkgs1)                             vis_map1 other_flags @@ -1574,7 +1578,8 @@                         -- won't work.                         | otherwise = vis_map2                 plugin_vis_map2-                    <- foldM (applyPackageFlag ctx prec_map prelim_pkg_db emptyUniqSet unusable+                    <- mayThrowUnitErr+                        $ foldM (applyPackageFlag prec_map prelim_pkg_db emptyUniqSet unusable                                 hide_plugin_pkgs pkgs1)                              plugin_vis_map1                              (reverse (unitConfigFlagsPlugins cfg))@@ -1588,10 +1593,9 @@                 -- likely to actually happen.                 return (updateVisibilityMap wired_map plugin_vis_map2) -  let pkgname_map = foldl' add Map.empty pkgs2-        where add pn_map p-                = Map.insert (unitPackageName p) (unitInstanceOf p) pn_map-+  let pkgname_map = listToUFM [ (unitPackageName p, unitInstanceOf p)+                              | p <- pkgs2+                              ]   -- The explicitUnits accurately reflects the set of units we have turned   -- on; as such, it also is the only way one can come up with requirements.   -- The requirement context is directly based off of this: we simply@@ -1621,8 +1625,9 @@       preload3 = ordNub $ (basicLinkedUnits ++ preload1)    -- Close the preload packages with their dependencies-  let dep_preload_err = closeUnitDeps pkg_db (zip (map toUnitId preload3) (repeat Nothing))-  dep_preload <- throwErr ctx dep_preload_err+  dep_preload <- mayThrowUnitErr+                    $ closeUnitDeps pkg_db+                    $ zip (map toUnitId preload3) (repeat Nothing)    let mod_map1 = mkModuleNameProvidersMap ctx cfg pkg_db emptyUniqSet vis_map       mod_map2 = mkUnusableModuleNameProvidersMap unusable@@ -1640,14 +1645,13 @@          , wireMap                      = wired_map          , unwireMap                    = Map.fromList [ (v,k) | (k,v) <- Map.toList wired_map ]          , requirementContext           = req_ctx-         , allowVirtualUnits            = unitConfigAllowVirtualUnits cfg+         , allowVirtualUnits            = unitConfigAllowVirtual cfg          }-   return (state, raw_dbs)  -- | Given a wired-in 'Unit', "unwire" it into the 'Unit' -- that it was recorded as in the package database.-unwireUnit :: UnitState -> Unit-> Unit+unwireUnit :: UnitState -> Unit -> Unit unwireUnit state uid@(RealUnit (Definite def_uid)) =     maybe uid (RealUnit . Definite) (Map.lookup def_uid (unwireMap state)) unwireUnit _ uid = uid@@ -1717,7 +1721,7 @@     rnBinding (orig, new) = (new, setOrigins origEntry fromFlag)      where origEntry = case lookupUFM esmap orig of             Just r -> r-            Nothing -> throwGhcException (CmdLineError (renderWithStyle ctx+            Nothing -> throwGhcException (CmdLineError (renderWithContext ctx                         (text "package flag: could not find module name" <+>                             ppr orig <+> text "in package" <+> ppr pk))) @@ -1738,7 +1742,7 @@     hiddens = [(m, mkModMap pk m ModHidden) | m <- hidden_mods]      pk = mkUnit pkg-    unit_lookup uid = lookupUnit' (unitConfigAllowVirtualUnits cfg) pkg_map closure uid+    unit_lookup uid = lookupUnit' (unitConfigAllowVirtual cfg) pkg_map closure uid                         `orElse` pprPanic "unit_lookup" (ppr uid)      exposed_mods = unitExposedModules pkg@@ -1781,135 +1785,7 @@ mkModMap :: Unit -> ModuleName -> ModuleOrigin -> Map Module ModuleOrigin mkModMap pkg mod = Map.singleton (mkModule pkg mod) --- -------------------------------------------------------------------------------- Extracting information from the packages in scope --- Many of these functions take a list of packages: in those cases,--- the list is expected to contain the "dependent packages",--- i.e. those packages that were found to be depended on by the--- current module/program.  These can be auto or non-auto packages, it--- doesn't really matter.  The list is always combined with the list--- of preload (command-line) packages to determine which packages to--- use.---- | Find all the include directories in these and the preload packages-getUnitIncludePath :: DynFlags -> [UnitId] -> IO [String]-getUnitIncludePath dflags pkgs =-  collectIncludeDirs `fmap` getPreloadUnitsAnd dflags pkgs--collectIncludeDirs :: [UnitInfo] -> [FilePath]-collectIncludeDirs ps = ordNub (filter notNull (concatMap unitIncludeDirs ps))---- | Find all the library paths in these and the preload packages-getUnitLibraryPath :: DynFlags -> [UnitId] -> IO [String]-getUnitLibraryPath dflags pkgs =-  collectLibraryPaths dflags `fmap` getPreloadUnitsAnd dflags pkgs--collectLibraryPaths :: DynFlags -> [UnitInfo] -> [FilePath]-collectLibraryPaths dflags = ordNub . filter notNull-                           . concatMap (libraryDirsForWay dflags)---- | Find all the link options in these and the preload packages,--- returning (package hs lib options, extra library options, other flags)-getUnitLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])-getUnitLinkOpts dflags pkgs =-  collectLinkOpts dflags `fmap` getPreloadUnitsAnd dflags pkgs--collectLinkOpts :: DynFlags -> [UnitInfo] -> ([String], [String], [String])-collectLinkOpts dflags ps =-    (-        concatMap (map ("-l" ++) . packageHsLibs dflags) ps,-        concatMap (map ("-l" ++) . unitExtDepLibsSys) ps,-        concatMap unitLinkerOptions ps-    )-collectArchives :: DynFlags -> UnitInfo -> IO [FilePath]-collectArchives dflags pc =-  filterM doesFileExist [ searchPath </> ("lib" ++ lib ++ ".a")-                        | searchPath <- searchPaths-                        , lib <- libs ]-  where searchPaths = ordNub . filter notNull . libraryDirsForWay dflags $ pc-        libs        = packageHsLibs dflags pc ++ unitExtDepLibsSys pc--getLibs :: DynFlags -> [UnitId] -> IO [(String,String)]-getLibs dflags pkgs = do-  ps <- getPreloadUnitsAnd dflags pkgs-  fmap concat . forM ps $ \p -> do-    let candidates = [ (l </> f, f) | l <- collectLibraryPaths dflags [p]-                                    , f <- (\n -> "lib" ++ n ++ ".a") <$> packageHsLibs dflags p ]-    filterM (doesFileExist . fst) candidates--packageHsLibs :: DynFlags -> UnitInfo -> [String]-packageHsLibs dflags p = map (mkDynName . addSuffix) (unitLibraries p)-  where-        ways0 = ways dflags--        ways1 = Set.filter (/= WayDyn) ways0-        -- the name of a shared library is libHSfoo-ghc<version>.so-        -- we leave out the _dyn, because it is superfluous--        -- debug and profiled RTSs include support for -eventlog-        ways2 | WayDebug `Set.member` ways1 || WayProf `Set.member` ways1-              = Set.filter (/= WayEventLog) ways1-              | otherwise-              = ways1--        tag     = waysTag (Set.filter (not . wayRTSOnly) ways2)-        rts_tag = waysTag ways2--        mkDynName x-         | WayDyn `Set.notMember` ways dflags = x-         | "HS" `isPrefixOf` x                =-              x ++ '-':programName dflags ++ projectVersion dflags-           -- For non-Haskell libraries, we use the name "Cfoo". The .a-           -- file is libCfoo.a, and the .so is libfoo.so. That way the-           -- linker knows what we mean for the vanilla (-lCfoo) and dyn-           -- (-lfoo) ways. We therefore need to strip the 'C' off here.-         | Just x' <- stripPrefix "C" x = x'-         | otherwise-            = panic ("Don't understand library name " ++ x)--        -- Add _thr and other rts suffixes to packages named-        -- `rts` or `rts-1.0`. Why both?  Traditionally the rts-        -- package is called `rts` only.  However the tooling-        -- usually expects a package name to have a version.-        -- As such we will gradually move towards the `rts-1.0`-        -- package name, at which point the `rts` package name-        -- will eventually be unused.-        ---        -- This change elevates the need to add custom hooks-        -- and handling specifically for the `rts` package for-        -- example in ghc-cabal.-        addSuffix rts@"HSrts"      = rts       ++ (expandTag rts_tag)-        addSuffix rts@"HSrts-1.0.2"= rts       ++ (expandTag rts_tag)-        addSuffix other_lib        = other_lib ++ (expandTag tag)--        expandTag t | null t = ""-                    | otherwise = '_':t---- | Either the 'unitLibraryDirs' or 'unitLibraryDynDirs' as appropriate for the way.-libraryDirsForWay :: DynFlags -> UnitInfo -> [String]-libraryDirsForWay dflags-  | WayDyn `elem` ways dflags = unitLibraryDynDirs-  | otherwise                 = unitLibraryDirs---- | Find all the C-compiler options in these and the preload packages-getUnitExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]-getUnitExtraCcOpts dflags pkgs = do-  ps <- getPreloadUnitsAnd dflags pkgs-  return (concatMap unitCcOptions ps)---- | Find all the package framework paths in these and the preload packages-getUnitFrameworkPath  :: DynFlags -> [UnitId] -> IO [String]-getUnitFrameworkPath dflags pkgs = do-  ps <- getPreloadUnitsAnd dflags pkgs-  return (ordNub (filter notNull (concatMap unitExtDepFrameworkDirs ps)))---- | Find all the package frameworks in these and the preload packages-getUnitFrameworks  :: DynFlags -> [UnitId] -> IO [String]-getUnitFrameworks dflags pkgs = do-  ps <- getPreloadUnitsAnd dflags pkgs-  return (concatMap unitExtDepFrameworks ps)- -- ----------------------------------------------------------------------------- -- Package Utils @@ -2053,42 +1929,15 @@     map fst (filter visible (Map.toList (moduleNameProvidersMap state)))   where visible (_, ms) = any originVisible (Map.elems ms) --- | Lookup 'UnitInfo' for every preload unit, for every unit used to--- instantiate the current unit, and for every unit explicitly passed in the--- given list of UnitId.-getPreloadUnitsAnd :: DynFlags -> [UnitId] -> IO [UnitInfo]-getPreloadUnitsAnd dflags ids0 =-  let-      ids  = ids0 ++-              -- An indefinite package will have insts to HOLE,-              -- which is not a real package. Don't look it up.-              -- Fixes #14525-              if homeUnitIsIndefinite dflags-                then []-                else map (toUnitId . moduleUnit . snd)-                         (homeUnitInstantiations dflags)-      state   = unitState dflags-      pkg_map = unitInfoMap state-      preload = preloadUnits state-      ctx     = initSDocContext dflags defaultUserStyle-  in do-  all_pkgs <- throwErr ctx (closeUnitDeps' pkg_map preload (ids `zip` repeat Nothing))-  return (map (unsafeLookupUnitId state) all_pkgs)--throwErr :: SDocContext -> MaybeErr MsgDoc a -> IO a-throwErr ctx m = case m of-   Failed e    -> throwGhcExceptionIO (CmdLineError (renderWithStyle ctx e))-   Succeeded r -> return r- -- | Takes a list of UnitIds (and their "parent" dependency, used for error -- messages), and returns the list with dependencies included, in reverse -- dependency order (a units appears before those it depends on).-closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]+closeUnitDeps :: UnitInfoMap -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps pkg_map ps = closeUnitDeps' pkg_map [] ps  -- | Similar to closeUnitDeps but takes a list of already loaded units as an -- additional argument.-closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr MsgDoc [UnitId]+closeUnitDeps' :: UnitInfoMap -> [UnitId] -> [(UnitId,Maybe UnitId)] -> MaybeErr UnitErr [UnitId] closeUnitDeps' pkg_map current_ids ps = foldM (add_unit pkg_map) current_ids ps  -- | Add a UnitId and those it depends on (recursively) to the given list of@@ -2101,16 +1950,11 @@ add_unit :: UnitInfoMap             -> [UnitId]             -> (UnitId,Maybe UnitId)-            -> MaybeErr MsgDoc [UnitId]+            -> MaybeErr UnitErr [UnitId] add_unit pkg_map ps (p, mb_parent)   | p `elem` ps = return ps     -- Check if we've already added this unit   | otherwise   = case lookupUnitId' pkg_map p of-      Nothing -> Failed $-                   (ftext (fsLit "unknown package:") <+> ppr p)-                   <> case mb_parent of-                         Nothing     -> Outputable.empty-                         Just parent -> space <> parens (text "dependency of"-                                                  <+> ftext (unitIdFS parent))+      Nothing   -> Failed (CloseUnitErr p mb_parent)       Just info -> do          -- Add the unit's dependents also          ps' <- foldM add_unit_key ps (unitDepends info)@@ -2119,8 +1963,61 @@           add_unit_key ps key             = add_unit pkg_map ps (key, Just p) +data UnitErr+  = CloseUnitErr !UnitId !(Maybe UnitId)+  | PackageFlagErr !PackageFlag ![(UnitInfo,UnusableUnitReason)]+  | TrustFlagErr   !TrustFlag   ![(UnitInfo,UnusableUnitReason)]++mayThrowUnitErr :: MaybeErr UnitErr a -> IO a+mayThrowUnitErr = \case+    Failed e    -> throwGhcExceptionIO+                    $ CmdLineError+                    $ renderWithContext defaultSDocContext+                    $ withPprStyle defaultUserStyle+                    $ ppr e+    Succeeded a -> return a++instance Outputable UnitErr where+    ppr = \case+        CloseUnitErr p mb_parent+            -> (ftext (fsLit "unknown unit:") <+> ppr p)+               <> case mb_parent of+                     Nothing     -> Outputable.empty+                     Just parent -> space <> parens (text "dependency of"+                                              <+> ftext (unitIdFS parent))+        PackageFlagErr flag reasons+            -> flag_err (pprFlag flag) reasons++        TrustFlagErr flag reasons+            -> flag_err (pprTrustFlag flag) reasons+      where+        flag_err flag_doc reasons =+            text "cannot satisfy "+            <> flag_doc+            <> (if null reasons then Outputable.empty else text ": ")+            $$ nest 4 (vcat (map ppr_reason reasons) $$+                      text "(use -v for more information)")++        ppr_reason (p, reason) =+            pprReason (ppr (unitId p) <+> text "is") reason++-- | Return this list of requirement interfaces that need to be merged+-- to form @mod_name@, or @[]@ if this is not a requirement.+requirementMerges :: UnitState -> ModuleName -> [InstantiatedModule]+requirementMerges pkgstate mod_name =+    fmap fixupModule $ fromMaybe [] (Map.lookup mod_name (requirementContext pkgstate))+    where+      -- update IndefUnitId ppr info as they may have changed since the+      -- time the IndefUnitId was created+      fixupModule (Module iud name) = Module iud' name+         where+            iud' = iud { instUnitInstanceOf = cid' }+            cid' = instUnitInstanceOf iud+ -- ----------------------------------------------------------------------------- +-- | Pretty-print a UnitId for the user.+-- -- Cabal packages may contain several components (programs, libraries, etc.). -- As far as GHC is concerned, installed package components ("units") are -- identified by an opaque IndefUnitId string provided by Cabal. As the string@@ -2132,25 +2029,18 @@ -- -- Component name is only displayed if it isn't the default library ----- To do this we need to query the database (cached in DynFlags). We cache--- these details in the IndefUnitId itself because we don't want to query--- DynFlags each time we pretty-print the IndefUnitId----mkIndefUnitId :: UnitState -> FastString -> IndefUnitId-mkIndefUnitId pkgstate raw =-    let uid = UnitId raw-    in case lookupUnitId pkgstate uid of-         Nothing -> Indefinite uid Nothing -- we didn't find the unit at all-         Just c  -> Indefinite uid $ Just $ mkUnitPprInfo c---- | Update component ID details from the database-updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId-updateIndefUnitId pkgstate uid = mkIndefUnitId pkgstate (unitIdFS (indefUnit uid))+-- To do this we need to query a unit database.+pprUnitIdForUser :: UnitState -> UnitId -> SDoc+pprUnitIdForUser state uid@(UnitId fs) =+   case lookupUnitPprInfo state uid of+      Nothing -> ftext fs -- we didn't find the unit at all+      Just i  -> ppr i +pprUnitInfoForUser :: UnitInfo -> SDoc+pprUnitInfoForUser info = ppr (mkUnitPprInfo unitIdFS info) -displayUnitId :: UnitState -> UnitId -> Maybe String-displayUnitId pkgstate uid =-    fmap unitPackageIdString (lookupUnitId pkgstate uid)+lookupUnitPprInfo :: UnitState -> UnitId -> Maybe UnitPprInfo+lookupUnitPprInfo state uid = fmap (mkUnitPprInfo unitIdFS) (lookupUnitId state uid)  -- ----------------------------------------------------------------------------- -- Displaying packages@@ -2284,4 +2174,10 @@ instModuleToModule :: UnitState -> InstantiatedModule -> Module instModuleToModule pkgstate (Module iuid mod_name) =     mkModule (instUnitToUnit pkgstate iuid) mod_name++-- | Print unit-ids with UnitInfo found in the given UnitState+pprWithUnitState :: UnitState -> SDoc -> SDoc+pprWithUnitState state = updSDocContext (\ctx -> ctx+   { sdocUnitIdForUser = \fs -> pprUnitIdForUser state (UnitId fs)+   })

GHC/Unit/State.hs-boot view

@@ -1,13 +1,12 @@ module GHC.Unit.State where -import GHC.Prelude-import GHC.Data.FastString-import {-# SOURCE #-} GHC.Unit.Types (IndefUnitId, UnitId)+import {-# SOURCE #-} GHC.Utils.Outputable+import {-# SOURCE #-} GHC.Unit.Types (UnitId,Unit)  data UnitState data UnitDatabase unit  emptyUnitState :: UnitState-mkIndefUnitId :: UnitState -> FastString -> IndefUnitId-displayUnitId :: UnitState -> UnitId -> Maybe String-updateIndefUnitId :: UnitState -> IndefUnitId -> IndefUnitId+pprUnitIdForUser :: UnitState -> UnitId -> SDoc+pprWithUnitState :: UnitState -> SDoc -> SDoc+unwireUnit :: UnitState -> Unit-> Unit

GHC/Unit/Types.hs view

@@ -1,8 +1,9 @@-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  -- | Unit & Module types --@@ -20,21 +21,22 @@    , moduleFreeHoles       -- * Units+   , IsUnitId    , GenUnit (..)    , Unit    , UnitId (..)+   , UnitKey (..)    , GenInstantiatedUnit (..)    , InstantiatedUnit    , IndefUnitId    , DefUnitId    , Instantiations    , GenInstantiations-   , mkGenInstantiatedUnit    , mkInstantiatedUnit    , mkInstantiatedUnitHash-   , mkGenVirtUnit    , mkVirtUnit    , mapGenUnit+   , mapInstantiations    , unitFreeModuleHoles    , fsToUnit    , unitFS@@ -44,6 +46,7 @@    , stringToUnit    , stableUnitCmp    , unitIsDefinite+   , isHoleUnit       -- * Unit Ids    , unitIdString@@ -86,7 +89,6 @@ import GHC.Prelude import GHC.Types.Unique import GHC.Types.Unique.DSet-import GHC.Unit.Ppr import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Utils.Outputable@@ -103,9 +105,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 -import {-# SOURCE #-} GHC.Unit.State (UnitState,displayUnitId)-import {-# SOURCE #-} GHC.Driver.Session (unitState)- --------------------------------------------------------------------- -- MODULES ---------------------------------------------------------------------@@ -166,7 +165,25 @@       cid   = instUnitInstanceOf uid       insts = instUnitInsts uid +-- | Class for types that are used as unit identifiers (UnitKey, UnitId, Unit)+--+-- We need this class because we create new unit ids for virtual units (see+-- VirtUnit) and they have to to be made from units with different kinds of+-- identifiers.+class IsUnitId u where+   unitFS :: u -> FastString +instance IsUnitId UnitKey where+   unitFS (UnitKey fs) = fs++instance IsUnitId UnitId where+   unitFS (UnitId fs) = fs++instance IsUnitId u => IsUnitId (GenUnit u) where+   unitFS (VirtUnit x)            = instUnitFS x+   unitFS (RealUnit (Definite x)) = unitFS x+   unitFS HoleUnit                = holeFS+ pprModule :: Module -> SDoc pprModule mod@(Module p n)  = getPprStyle doc  where@@ -192,6 +209,9 @@ -- UNITS --------------------------------------------------------------------- +-- | A unit key in the database+newtype UnitKey = UnitKey FastString+ -- | A unit identifier identifies a (possibly partially) instantiated library. -- It is primarily used as part of 'Module', which in turn is used in 'Name', -- which is used to give names to entities when typechecking.@@ -261,12 +281,16 @@ holeFS :: FastString holeFS = fsLit "<hole>" +isHoleUnit :: GenUnit u -> Bool+isHoleUnit HoleUnit = True+isHoleUnit _        = False + instance Eq (GenInstantiatedUnit unit) where   u1 == u2 = instUnitKey u1 == instUnitKey u2  instance Ord (GenInstantiatedUnit unit) where-  u1 `compare` u2 = instUnitFS u1 `compare` instUnitFS u2+  u1 `compare` u2 = instUnitFS u1 `uniqCompareFS` instUnitFS u2  instance Binary InstantiatedUnit where   put_ bh indef = do@@ -284,10 +308,10 @@             instUnitKey = getUnique fs            } -instance Eq Unit where+instance IsUnitId u => Eq (GenUnit u) where   uid1 == uid2 = unitUnique uid1 == unitUnique uid2 -instance Uniquable Unit where+instance IsUnitId u => Uniquable (GenUnit u) where   getUnique = unitUnique  instance Ord Unit where@@ -304,7 +328,7 @@  -- | Compares unit ids lexically, rather than by their 'Unique's stableUnitCmp :: Unit -> Unit -> Ordering-stableUnitCmp p1 p2 = unitFS p1 `compare` unitFS p2+stableUnitCmp p1 p2 = unitFS p1 `lexicalCompareFS` unitFS p2  instance Outputable Unit where    ppr pk = pprUnit pk@@ -325,7 +349,7 @@   put_ bh (VirtUnit indef_uid) = do     putByte bh 1     put_ bh indef_uid-  put_ bh HoleUnit = do+  put_ bh HoleUnit =     putByte bh 2   get bh = do b <- getByte bh               case b of@@ -333,12 +357,6 @@                 1 -> fmap VirtUnit (get bh)                 _ -> pure HoleUnit -instance Binary unit => Binary (Indefinite unit) where-  put_ bh (Indefinite fs _) = put_ bh fs-  get bh = do { fs <- get bh; return (Indefinite fs Nothing) }--- -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName unitFreeModuleHoles (VirtUnit x) = instUnitHoles x@@ -357,8 +375,8 @@   -- | Create a new 'GenInstantiatedUnit' given an explicit module substitution.-mkGenInstantiatedUnit :: (unit -> FastString) -> Indefinite unit -> GenInstantiations unit -> GenInstantiatedUnit unit-mkGenInstantiatedUnit gunitFS cid insts =+mkInstantiatedUnit :: IsUnitId u => Indefinite u -> GenInstantiations u -> GenInstantiatedUnit u+mkInstantiatedUnit cid insts =     InstantiatedUnit {         instUnitInstanceOf = cid,         instUnitInsts = sorted_insts,@@ -367,22 +385,14 @@         instUnitKey = getUnique fs     }   where-     fs = mkGenInstantiatedUnitHash gunitFS cid sorted_insts+     fs           = mkInstantiatedUnitHash cid sorted_insts      sorted_insts = sortBy (stableModuleNameCmp `on` fst) insts --- | Create a new 'InstantiatedUnit' given an explicit module substitution.-mkInstantiatedUnit :: IndefUnitId -> Instantiations -> InstantiatedUnit-mkInstantiatedUnit = mkGenInstantiatedUnit unitIdFS - -- | Smart constructor for instantiated GenUnit-mkGenVirtUnit :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> GenUnit unit-mkGenVirtUnit _gunitFS uid []    = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole?-mkGenVirtUnit gunitFS  uid insts = VirtUnit $ mkGenInstantiatedUnit gunitFS uid insts---- | Smart constructor for VirtUnit-mkVirtUnit :: IndefUnitId -> Instantiations -> Unit-mkVirtUnit = mkGenVirtUnit unitIdFS+mkVirtUnit :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> GenUnit u+mkVirtUnit uid []    = RealUnit $ Definite (indefUnit uid) -- huh? indefinite unit without any instantiation/hole?+mkVirtUnit uid insts = VirtUnit $ mkInstantiatedUnit uid insts  -- | Generate a uniquely identifying hash (internal unit-id) for an instantiated -- unit.@@ -392,24 +402,21 @@ -- This hash is completely internal to GHC and is not used for symbol names or -- file paths. It is different from the hash Cabal would produce for the same -- instantiated unit.-mkGenInstantiatedUnitHash :: (unit -> FastString) -> Indefinite unit -> [(ModuleName, GenModule (GenUnit unit))] -> FastString-mkGenInstantiatedUnitHash gunitFS cid sorted_holes =+mkInstantiatedUnitHash :: IsUnitId u => Indefinite u -> [(ModuleName, GenModule (GenUnit u))] -> FastString+mkInstantiatedUnitHash cid sorted_holes =     mkFastStringByteString-  . fingerprintUnitId (bytesFS (gunitFS (indefUnit cid)))-  $ hashInstantiations gunitFS sorted_holes--mkInstantiatedUnitHash :: IndefUnitId -> Instantiations -> FastString-mkInstantiatedUnitHash = mkGenInstantiatedUnitHash unitIdFS+  . fingerprintUnitId (bytesFS (unitFS cid))+  $ hashInstantiations sorted_holes  -- | Generate a hash for a sorted module instantiation.-hashInstantiations :: (unit -> FastString) -> [(ModuleName, GenModule (GenUnit unit))] -> Fingerprint-hashInstantiations gunitFS sorted_holes =+hashInstantiations :: IsUnitId u => [(ModuleName, GenModule (GenUnit u))] -> Fingerprint+hashInstantiations sorted_holes =     fingerprintByteString   . BS.concat $ do         (m, b) <- sorted_holes-        [ bytesFS (moduleNameFS m),                   BS.Char8.singleton ' ',-          bytesFS (genUnitFS gunitFS (moduleUnit b)), BS.Char8.singleton ':',-          bytesFS (moduleNameFS (moduleName b)),      BS.Char8.singleton '\n']+        [ bytesFS (moduleNameFS m),              BS.Char8.singleton ' ',+          bytesFS (unitFS (moduleUnit b)),       BS.Char8.singleton ':',+          bytesFS (moduleNameFS (moduleName b)), BS.Char8.singleton '\n']  fingerprintUnitId :: BS.ByteString -> Fingerprint -> BS.ByteString fingerprintUnitId prefix (Fingerprint a b)@@ -419,42 +426,37 @@       , BS.Char8.pack (toBase62Padded a)       , BS.Char8.pack (toBase62Padded b) ] -unitUnique :: Unit -> Unique+unitUnique :: IsUnitId u => GenUnit u -> Unique unitUnique (VirtUnit x)            = instUnitKey x-unitUnique (RealUnit (Definite x)) = getUnique x+unitUnique (RealUnit (Definite x)) = getUnique (unitFS x) unitUnique HoleUnit                = holeUnique -unitFS :: Unit -> FastString-unitFS = genUnitFS unitIdFS--genUnitFS :: (unit -> FastString) -> GenUnit unit -> FastString-genUnitFS _gunitFS (VirtUnit x)            = instUnitFS x-genUnitFS gunitFS  (RealUnit (Definite x)) = gunitFS x-genUnitFS _gunitFS HoleUnit                = holeFS- -- | Create a new simple unit identifier from a 'FastString'.  Internally, -- this is primarily used to specify wired-in unit identifiers. fsToUnit :: FastString -> Unit fsToUnit = RealUnit . Definite . UnitId -unitString :: Unit -> String+unitString :: IsUnitId u => u  -> String unitString = unpackFS . unitFS  stringToUnit :: String -> Unit stringToUnit = fsToUnit . mkFastString  -- | Map over the unit type of a 'GenUnit'-mapGenUnit :: (u -> v) -> (v -> FastString) -> GenUnit u -> GenUnit v-mapGenUnit f gunitFS = go+mapGenUnit :: IsUnitId v => (u -> v) -> GenUnit u -> GenUnit v+mapGenUnit f = go    where       go gu = case gu of                HoleUnit   -> HoleUnit                RealUnit d -> RealUnit (fmap f d)                VirtUnit i ->-                  VirtUnit $ mkGenInstantiatedUnit gunitFS+                  VirtUnit $ mkInstantiatedUnit                      (fmap f (instUnitInstanceOf i))                      (fmap (second (fmap go)) (instUnitInsts i)) +-- | Map over the unit identifier of unit instantiations.+mapInstantiations :: IsUnitId v => (u -> v) -> GenInstantiations u -> GenInstantiations v+mapInstantiations f = map (second (fmap (mapGenUnit f)))  -- | Return the UnitId of the Unit. For on-the-fly instantiated units, return -- the UnitId of the indefinite unit this unit is an instance of.@@ -502,25 +504,16 @@     uid1 == uid2 = getUnique uid1 == getUnique uid2  instance Ord UnitId where-    u1 `compare` u2 = unitIdFS u1 `compare` unitIdFS u2+    -- we compare lexically to avoid non-deterministic output when sets of+    -- unit-ids are printed (dependencies, etc.)+    u1 `compare` u2 = unitIdFS u1 `lexicalCompareFS` unitIdFS u2  instance Uniquable UnitId where     getUnique = getUnique . unitIdFS  instance Outputable UnitId where-    ppr uid = sdocWithDynFlags $ \dflags -> pprUnitId (unitState dflags) uid---- | Pretty-print a UnitId------ In non-debug mode, query the given database to try to print--- "package-version:component" instead of the raw UnitId-pprUnitId :: UnitState -> UnitId -> SDoc-pprUnitId state uid@(UnitId fs) = getPprDebug $ \debug ->-   if debug-      then ftext fs-      else case displayUnitId state uid of-            Just str -> text str-            _        -> ftext fs+    ppr (UnitId fs) = sdocOption sdocUnitIdForUser ($ fs) -- see Note [Pretty-printing UnitId]+                                                          -- in "GHC.Unit"  -- | A 'DefUnitId' is an 'UnitId' with the invariant that -- it only refers to a definite library; i.e., one we have generated@@ -539,44 +532,16 @@  -- | A definite unit (i.e. without any free module hole) newtype Definite unit = Definite { unDefinite :: unit }-    deriving (Eq, Ord, Functor)--instance Outputable unit => Outputable (Definite unit) where-    ppr (Definite uid) = ppr uid--instance Binary unit => Binary (Definite unit) where-    put_ bh (Definite uid) = put_ bh uid-    get bh = do uid <- get bh; return (Definite uid)-+   deriving (Functor)+   deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)  -- | An 'IndefUnitId' is an 'UnitId' with the invariant that it only -- refers to an indefinite library; i.e., one that can be instantiated. type IndefUnitId = Indefinite UnitId -data Indefinite unit = Indefinite-   { indefUnit        :: !unit             -- ^ Unit identifier-   , indefUnitPprInfo :: Maybe UnitPprInfo -- ^ Cache for some unit info retrieved from the DB-   }+newtype Indefinite unit = Indefinite { indefUnit :: unit }    deriving (Functor)--instance Eq unit => Eq (Indefinite unit) where-   a == b = indefUnit a == indefUnit b--instance Ord unit => Ord (Indefinite unit) where-   compare a b = compare (indefUnit a) (indefUnit b)---instance Uniquable unit => Uniquable (Indefinite unit) where-  getUnique (Indefinite n _) = getUnique n--instance Outputable unit => Outputable (Indefinite unit) where-  ppr (Indefinite uid Nothing)        = ppr uid-  ppr (Indefinite uid (Just pprinfo)) =-    getPprDebug $ \debug ->-      if debug-         then ppr uid-         else ppr pprinfo-+   deriving newtype (Eq, Ord, Outputable, Binary, Uniquable, IsUnitId)  --------------------------------------------------------------------- -- WIRED-IN UNITS@@ -711,5 +676,5 @@  instance Outputable a => Outputable (GenWithIsBoot a) where   ppr (GWIB  { gwib_mod, gwib_isBoot }) = hsep $ ppr gwib_mod : case gwib_isBoot of-    IsBoot -> []-    NotBoot -> [text "{-# SOURCE #-}"]+    IsBoot -> [ text "{-# SOURCE #-}" ]+    NotBoot -> []

GHC/Utils/Binary.hs view

@@ -3,11 +3,15 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UnboxedTuples #-}  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+#if MIN_VERSION_base(4,16,0)+#define HAS_TYPELITCHAR+#endif -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -76,11 +80,10 @@ import GHC.Types.Unique.FM import GHC.Data.FastMutInt import GHC.Utils.Fingerprint-import GHC.Types.Basic import GHC.Types.SrcLoc  import Control.DeepSeq-import Foreign+import Foreign hiding (shiftL, shiftR) import Data.Array import Data.ByteString (ByteString) import qualified Data.ByteString.Internal as BS@@ -89,16 +92,11 @@ import Data.Char                ( ord, chr ) import Data.Time import Data.List (unfoldr)-import Type.Reflection-import Type.Reflection.Unsafe-import Data.Kind (Type)-import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..)) import Control.Monad            ( when, (<$!>), unless ) import System.IO as IO import System.IO.Unsafe         ( unsafeInterleaveIO ) import System.IO.Error          ( mkIOError, eofErrorType ) import GHC.Real                 ( Ratio(..) )-import GHC.Serialized #if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr           ( unsafeWithForeignPtr ) #endif@@ -136,10 +134,8 @@  dataHandle :: BinData -> IO BinHandle dataHandle (BinData size bin) = do-  ixr <- newFastMutInt-  szr <- newFastMutInt-  writeFastMutInt ixr 0-  writeFastMutInt szr size+  ixr <- newFastMutInt 0+  szr <- newFastMutInt size   binr <- newIORef bin   return (BinMem noUserData ixr szr binr) @@ -217,10 +213,8 @@  | otherwise = do    arr <- mallocForeignPtrBytes size    arr_r <- newIORef arr-   ix_r <- newFastMutInt-   writeFastMutInt ix_r 0-   sz_r <- newFastMutInt-   writeFastMutInt sz_r size+   ix_r <- newFastMutInt 0+   sz_r <- newFastMutInt size    return (BinMem noUserData ix_r sz_r arr_r)  tellBin :: BinHandle -> IO (Bin a)@@ -253,10 +247,8 @@        error ("Binary.readBinMem: only read " ++ show count ++ " bytes")   hClose h   arr_r <- newIORef arr-  ix_r <- newFastMutInt-  writeFastMutInt ix_r 0-  sz_r <- newFastMutInt-  writeFastMutInt sz_r filesize+  ix_r <- newFastMutInt 0+  sz_r <- newFastMutInt filesize   return (BinMem noUserData ix_r sz_r arr_r)  -- expand the size of the array to include a specified offset@@ -877,185 +869,7 @@   put_ bh (BinPtr i) = putWord32 bh (fromIntegral i :: Word32)   get bh = do i <- getWord32 bh; return (BinPtr (fromIntegral (i :: Word32))) --- -------------------------------------------------------------------------------- Instances for Data.Typeable stuff -instance Binary TyCon where-    put_ bh tc = do-        put_ bh (tyConPackage tc)-        put_ bh (tyConModule tc)-        put_ bh (tyConName tc)-        put_ bh (tyConKindArgs tc)-        put_ bh (tyConKindRep tc)-    get bh =-        mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh--instance Binary VecCount where-    put_ bh = putByte bh . fromIntegral . fromEnum-    get bh = toEnum . fromIntegral <$> getByte bh--instance Binary VecElem where-    put_ bh = putByte bh . fromIntegral . fromEnum-    get bh = toEnum . fromIntegral <$> getByte bh--instance Binary RuntimeRep where-    put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b-    put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps-    put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps-    put_ bh LiftedRep       = putByte bh 3-    put_ bh UnliftedRep     = putByte bh 4-    put_ bh IntRep          = putByte bh 5-    put_ bh WordRep         = putByte bh 6-    put_ bh Int64Rep        = putByte bh 7-    put_ bh Word64Rep       = putByte bh 8-    put_ bh AddrRep         = putByte bh 9-    put_ bh FloatRep        = putByte bh 10-    put_ bh DoubleRep       = putByte bh 11-    put_ bh Int8Rep         = putByte bh 12-    put_ bh Word8Rep        = putByte bh 13-    put_ bh Int16Rep        = putByte bh 14-    put_ bh Word16Rep       = putByte bh 15-#if __GLASGOW_HASKELL__ >= 809-    put_ bh Int32Rep        = putByte bh 16-    put_ bh Word32Rep       = putByte bh 17-#endif--    get bh = do-        tag <- getByte bh-        case tag of-          0  -> VecRep <$> get bh <*> get bh-          1  -> TupleRep <$> get bh-          2  -> SumRep <$> get bh-          3  -> pure LiftedRep-          4  -> pure UnliftedRep-          5  -> pure IntRep-          6  -> pure WordRep-          7  -> pure Int64Rep-          8  -> pure Word64Rep-          9  -> pure AddrRep-          10 -> pure FloatRep-          11 -> pure DoubleRep-          12 -> pure Int8Rep-          13 -> pure Word8Rep-          14 -> pure Int16Rep-          15 -> pure Word16Rep-#if __GLASGOW_HASKELL__ >= 809-          16 -> pure Int32Rep-          17 -> pure Word32Rep-#endif-          _  -> fail "Binary.putRuntimeRep: invalid tag"--instance Binary KindRep where-    put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k-    put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr-    put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b-    put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b-    put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r-    put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r--    get bh = do-        tag <- getByte bh-        case tag of-          0 -> KindRepTyConApp <$> get bh <*> get bh-          1 -> KindRepVar <$> get bh-          2 -> KindRepApp <$> get bh <*> get bh-          3 -> KindRepFun <$> get bh <*> get bh-          4 -> KindRepTYPE <$> get bh-          5 -> KindRepTypeLit <$> get bh <*> get bh-          _ -> fail "Binary.putKindRep: invalid tag"--instance Binary TypeLitSort where-    put_ bh TypeLitSymbol = putByte bh 0-    put_ bh TypeLitNat = putByte bh 1-    get bh = do-        tag <- getByte bh-        case tag of-          0 -> pure TypeLitSymbol-          1 -> pure TypeLitNat-          _ -> fail "Binary.putTypeLitSort: invalid tag"--putTypeRep :: BinHandle -> TypeRep a -> IO ()--- Special handling for TYPE, (->), and RuntimeRep due to recursive kind--- relations.--- See Note [Mutually recursive representations of primitive types]-putTypeRep bh rep-  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)-  = put_ bh (0 :: Word8)-putTypeRep bh (Con' con ks) = do-    put_ bh (1 :: Word8)-    put_ bh con-    put_ bh ks-putTypeRep bh (App f x) = do-    put_ bh (2 :: Word8)-    putTypeRep bh f-    putTypeRep bh x-putTypeRep bh (Fun arg res) = do-    put_ bh (3 :: Word8)-    putTypeRep bh arg-    putTypeRep bh res--getSomeTypeRep :: BinHandle -> IO SomeTypeRep-getSomeTypeRep bh = do-    tag <- get bh :: IO Word8-    case tag of-        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)-        1 -> do con <- get bh :: IO TyCon-                ks <- get bh :: IO [SomeTypeRep]-                return $ SomeTypeRep $ mkTrCon con ks--        2 -> do SomeTypeRep f <- getSomeTypeRep bh-                SomeTypeRep x <- getSomeTypeRep bh-                case typeRepKind f of-                  Fun arg res ->-                      case arg `eqTypeRep` typeRepKind x of-                        Just HRefl ->-                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of-                              Just HRefl -> return $ SomeTypeRep $ mkTrApp f x-                              _ -> failure "Kind mismatch in type application" []-                        _ -> failure "Kind mismatch in type application"-                             [ "    Found argument of kind: " ++ show (typeRepKind x)-                             , "    Where the constructor:  " ++ show f-                             , "    Expects kind:           " ++ show arg-                             ]-                  _ -> failure "Applied non-arrow"-                       [ "    Applied type: " ++ show f-                       , "    To argument:  " ++ show x-                       ]-        3 -> do SomeTypeRep arg <- getSomeTypeRep bh-                SomeTypeRep res <- getSomeTypeRep bh-                if-                  | App argkcon _ <- typeRepKind arg-                  , App reskcon _ <- typeRepKind res-                  , Just HRefl <- argkcon `eqTypeRep` tYPErep-                  , Just HRefl <- reskcon `eqTypeRep` tYPErep-                  -> return $ SomeTypeRep $ Fun arg res-                  | otherwise -> failure "Kind mismatch" []-        _ -> failure "Invalid SomeTypeRep" []-  where-    tYPErep :: TypeRep TYPE-    tYPErep = typeRep--    failure description info =-        fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]-                      ++ map ("    "++) info--instance Typeable a => Binary (TypeRep (a :: k)) where-    put_ = putTypeRep-    get bh = do-        SomeTypeRep rep <- getSomeTypeRep bh-        case rep `eqTypeRep` expected of-            Just HRefl -> pure rep-            Nothing    -> fail $ unlines-                               [ "Binary: Type mismatch"-                               , "    Deserialized type: " ++ show rep-                               , "    Expected type:     " ++ show expected-                               ]-     where expected = typeRep :: TypeRep a--instance Binary SomeTypeRep where-    put_ bh (SomeTypeRep rep) = putTypeRep bh rep-    get = getSomeTypeRep- -- ----------------------------------------------------------------------------- -- Lazy reading/writing @@ -1076,7 +890,7 @@     a <- unsafeInterleaveIO $ do         -- NB: Use a fresh off_r variable in the child thread, for thread         -- safety.-        off_r <- newFastMutInt+        off_r <- newFastMutInt 0         getAt bh { _off_r = off_r } p_a     seekBin bh p -- skip over the object for now     return a@@ -1216,206 +1030,188 @@     case getUserData bh of         UserData { ud_get_fs = get_fs } -> get_fs bh --- Here to avoid loop-instance Binary LeftOrRight where-   put_ bh CLeft  = putByte bh 0-   put_ bh CRight = putByte bh 1--   get bh = do { h <- getByte bh-               ; case h of-                   0 -> return CLeft-                   _ -> return CRight }--instance Binary PromotionFlag where-   put_ bh NotPromoted = putByte bh 0-   put_ bh IsPromoted  = putByte bh 1--   get bh = do-       n <- getByte bh-       case n of-         0 -> return NotPromoted-         1 -> return IsPromoted-         _ -> fail "Binary(IsPromoted): fail)"+deriving instance Binary NonDetFastString+deriving instance Binary LexicalFastString  instance Binary Fingerprint where   put_ h (Fingerprint w1 w2) = do put_ h w1; put_ h w2   get  h = do w1 <- get h; w2 <- get h; return (Fingerprint w1 w2) -instance Binary FunctionOrData where-    put_ bh IsFunction = putByte bh 0-    put_ bh IsData     = putByte bh 1-    get bh = do-        h <- getByte bh-        case h of-          0 -> return IsFunction-          1 -> return IsData-          _ -> panic "Binary FunctionOrData"+-- instance Binary FunctionOrData where+--     put_ bh IsFunction = putByte bh 0+--     put_ bh IsData     = putByte bh 1+--     get bh = do+--         h <- getByte bh+--         case h of+--           0 -> return IsFunction+--           1 -> return IsData+--           _ -> panic "Binary FunctionOrData" -instance Binary TupleSort where-    put_ bh BoxedTuple      = putByte bh 0-    put_ bh UnboxedTuple    = putByte bh 1-    put_ bh ConstraintTuple = putByte bh 2-    get bh = do-      h <- getByte bh-      case h of-        0 -> do return BoxedTuple-        1 -> do return UnboxedTuple-        _ -> do return ConstraintTuple+-- instance Binary TupleSort where+--     put_ bh BoxedTuple      = putByte bh 0+--     put_ bh UnboxedTuple    = putByte bh 1+--     put_ bh ConstraintTuple = putByte bh 2+--     get bh = do+--       h <- getByte bh+--       case h of+--         0 -> do return BoxedTuple+--         1 -> do return UnboxedTuple+--         _ -> do return ConstraintTuple -instance Binary Activation where-    put_ bh NeverActive = do-            putByte bh 0-    put_ bh FinalActive = do-            putByte bh 1-    put_ bh AlwaysActive = do-            putByte bh 2-    put_ bh (ActiveBefore src aa) = do-            putByte bh 3-            put_ bh src-            put_ bh aa-    put_ bh (ActiveAfter src ab) = do-            putByte bh 4-            put_ bh src-            put_ bh ab-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return NeverActive-              1 -> do return FinalActive-              2 -> do return AlwaysActive-              3 -> do src <- get bh-                      aa <- get bh-                      return (ActiveBefore src aa)-              _ -> do src <- get bh-                      ab <- get bh-                      return (ActiveAfter src ab)+-- instance Binary Activation where+--     put_ bh NeverActive = do+--             putByte bh 0+--     put_ bh FinalActive = do+--             putByte bh 1+--     put_ bh AlwaysActive = do+--             putByte bh 2+--     put_ bh (ActiveBefore src aa) = do+--             putByte bh 3+--             put_ bh src+--             put_ bh aa+--     put_ bh (ActiveAfter src ab) = do+--             putByte bh 4+--             put_ bh src+--             put_ bh ab+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do return NeverActive+--               1 -> do return FinalActive+--               2 -> do return AlwaysActive+--               3 -> do src <- get bh+--                       aa <- get bh+--                       return (ActiveBefore src aa)+--               _ -> do src <- get bh+--                       ab <- get bh+--                       return (ActiveAfter src ab) -instance Binary InlinePragma where-    put_ bh (InlinePragma s a b c d) = do-            put_ bh s-            put_ bh a-            put_ bh b-            put_ bh c-            put_ bh d+-- instance Binary InlinePragma where+--     put_ bh (InlinePragma s a b c d) = do+--             put_ bh s+--             put_ bh a+--             put_ bh b+--             put_ bh c+--             put_ bh d -    get bh = do-           s <- get bh-           a <- get bh-           b <- get bh-           c <- get bh-           d <- get bh-           return (InlinePragma s a b c d)+--     get bh = do+--            s <- get bh+--            a <- get bh+--            b <- get bh+--            c <- get bh+--            d <- get bh+--            return (InlinePragma s a b c d) -instance Binary RuleMatchInfo where-    put_ bh FunLike = putByte bh 0-    put_ bh ConLike = putByte bh 1-    get bh = do-            h <- getByte bh-            if h == 1 then return ConLike-                      else return FunLike+-- instance Binary RuleMatchInfo where+--     put_ bh FunLike = putByte bh 0+--     put_ bh ConLike = putByte bh 1+--     get bh = do+--             h <- getByte bh+--             if h == 1 then return ConLike+--                       else return FunLike -instance Binary InlineSpec where-    put_ bh NoUserInline    = putByte bh 0-    put_ bh Inline          = putByte bh 1-    put_ bh Inlinable       = putByte bh 2-    put_ bh NoInline        = putByte bh 3+-- instance Binary InlineSpec where+--     put_ bh NoUserInlinePrag = putByte bh 0+--     put_ bh Inline           = putByte bh 1+--     put_ bh Inlinable        = putByte bh 2+--     put_ bh NoInline         = putByte bh 3 -    get bh = do h <- getByte bh-                case h of-                  0 -> return NoUserInline-                  1 -> return Inline-                  2 -> return Inlinable-                  _ -> return NoInline+--     get bh = do h <- getByte bh+--                 case h of+--                   0 -> return NoUserInlinePrag+--                   1 -> return Inline+--                   2 -> return Inlinable+--                   _ -> return NoInline -instance Binary RecFlag where-    put_ bh Recursive = do-            putByte bh 0-    put_ bh NonRecursive = do-            putByte bh 1-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return Recursive-              _ -> do return NonRecursive+-- instance Binary RecFlag where+--     put_ bh Recursive = do+--             putByte bh 0+--     put_ bh NonRecursive = do+--             putByte bh 1+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do return Recursive+--               _ -> do return NonRecursive -instance Binary OverlapMode where-    put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s-    put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s-    put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s-    put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s-    put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s-    get bh = do-        h <- getByte bh-        case h of-            0 -> (get bh) >>= \s -> return $ NoOverlap s-            1 -> (get bh) >>= \s -> return $ Overlaps s-            2 -> (get bh) >>= \s -> return $ Incoherent s-            3 -> (get bh) >>= \s -> return $ Overlapping s-            4 -> (get bh) >>= \s -> return $ Overlappable s-            _ -> panic ("get OverlapMode" ++ show h)+-- instance Binary OverlapMode where+--     put_ bh (NoOverlap    s) = putByte bh 0 >> put_ bh s+--     put_ bh (Overlaps     s) = putByte bh 1 >> put_ bh s+--     put_ bh (Incoherent   s) = putByte bh 2 >> put_ bh s+--     put_ bh (Overlapping  s) = putByte bh 3 >> put_ bh s+--     put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s+--     get bh = do+--         h <- getByte bh+--         case h of+--             0 -> (get bh) >>= \s -> return $ NoOverlap s+--             1 -> (get bh) >>= \s -> return $ Overlaps s+--             2 -> (get bh) >>= \s -> return $ Incoherent s+--             3 -> (get bh) >>= \s -> return $ Overlapping s+--             4 -> (get bh) >>= \s -> return $ Overlappable s+--             _ -> panic ("get OverlapMode" ++ show h)  -instance Binary OverlapFlag where-    put_ bh flag = do put_ bh (overlapMode flag)-                      put_ bh (isSafeOverlap flag)-    get bh = do-        h <- get bh-        b <- get bh-        return OverlapFlag { overlapMode = h, isSafeOverlap = b }+-- instance Binary OverlapFlag where+--     put_ bh flag = do put_ bh (overlapMode flag)+--                       put_ bh (isSafeOverlap flag)+--     get bh = do+--         h <- get bh+--         b <- get bh+--         return OverlapFlag { overlapMode = h, isSafeOverlap = b } -instance Binary FixityDirection where-    put_ bh InfixL = do-            putByte bh 0-    put_ bh InfixR = do-            putByte bh 1-    put_ bh InfixN = do-            putByte bh 2-    get bh = do-            h <- getByte bh-            case h of-              0 -> do return InfixL-              1 -> do return InfixR-              _ -> do return InfixN+-- instance Binary FixityDirection where+--     put_ bh InfixL = do+--             putByte bh 0+--     put_ bh InfixR = do+--             putByte bh 1+--     put_ bh InfixN = do+--             putByte bh 2+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do return InfixL+--               1 -> do return InfixR+--               _ -> do return InfixN -instance Binary Fixity where-    put_ bh (Fixity src aa ab) = do-            put_ bh src-            put_ bh aa-            put_ bh ab-    get bh = do-          src <- get bh-          aa <- get bh-          ab <- get bh-          return (Fixity src aa ab)+-- instance Binary Fixity where+--     put_ bh (Fixity src aa ab) = do+--             put_ bh src+--             put_ bh aa+--             put_ bh ab+--     get bh = do+--           src <- get bh+--           aa <- get bh+--           ab <- get bh+--           return (Fixity src aa ab) -instance Binary WarningTxt where-    put_ bh (WarningTxt s w) = do-            putByte bh 0-            put_ bh s-            put_ bh w-    put_ bh (DeprecatedTxt s d) = do-            putByte bh 1-            put_ bh s-            put_ bh d+-- instance Binary WarningTxt where+--     put_ bh (WarningTxt s w) = do+--             putByte bh 0+--             put_ bh s+--             put_ bh w+--     put_ bh (DeprecatedTxt s d) = do+--             putByte bh 1+--             put_ bh s+--             put_ bh d -    get bh = do-            h <- getByte bh-            case h of-              0 -> do s <- get bh-                      w <- get bh-                      return (WarningTxt s w)-              _ -> do s <- get bh-                      d <- get bh-                      return (DeprecatedTxt s d)+--     get bh = do+--             h <- getByte bh+--             case h of+--               0 -> do s <- get bh+--                       w <- get bh+--                       return (WarningTxt s w)+--               _ -> do s <- get bh+--                       d <- get bh+--                       return (DeprecatedTxt s d) -instance Binary StringLiteral where-  put_ bh (StringLiteral st fs) = do-            put_ bh st-            put_ bh fs-  get bh = do-            st <- get bh-            fs <- get bh-            return (StringLiteral st fs)+-- instance Binary StringLiteral where+--   put_ bh (StringLiteral st fs _) = do+--             put_ bh st+--             put_ bh fs+--   get bh = do+--             st <- get bh+--             fs <- get bh+--             return (StringLiteral st fs Nothing)  instance Binary a => Binary (Located a) where     put_ bh (L l x) = do@@ -1492,27 +1288,3 @@                     return (RealSrcSpan ss sb)             _ -> do s <- get bh                     return (UnhelpfulSpan s)--instance Binary Serialized where-    put_ bh (Serialized the_type bytes) = do-        put_ bh the_type-        put_ bh bytes-    get bh = do-        the_type <- get bh-        bytes <- get bh-        return (Serialized the_type bytes)--instance Binary SourceText where-  put_ bh NoSourceText = putByte bh 0-  put_ bh (SourceText s) = do-        putByte bh 1-        put_ bh s--  get bh = do-    h <- getByte bh-    case h of-      0 -> return NoSourceText-      1 -> do-        s <- get bh-        return (SourceText s)-      _ -> panic $ "Binary SourceText:" ++ show h

+ GHC/Utils/Binary/Typeable.hs view

@@ -0,0 +1,232 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE GADTs #-}++{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}+{-# OPTIONS_GHC -Wno-orphans #-}+#if MIN_VERSION_base(4,16,0)+#define HAS_TYPELITCHAR+#endif++-- | Orphan Binary instances for Data.Typeable stuff+module GHC.Utils.Binary.Typeable+   ( getSomeTypeRep+   )+where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Utils.Binary++import GHC.Exts (TYPE, RuntimeRep(..), VecCount(..), VecElem(..))+#if __GLASGOW_HASKELL__ >= 901+import GHC.Exts (Levity(Lifted, Unlifted))+#endif+import GHC.Serialized++import Foreign+import Type.Reflection+import Type.Reflection.Unsafe+import Data.Kind (Type)+++instance Binary TyCon where+    put_ bh tc = do+        put_ bh (tyConPackage tc)+        put_ bh (tyConModule tc)+        put_ bh (tyConName tc)+        put_ bh (tyConKindArgs tc)+        put_ bh (tyConKindRep tc)+    get bh =+        mkTyCon <$> get bh <*> get bh <*> get bh <*> get bh <*> get bh++getSomeTypeRep :: BinHandle -> IO SomeTypeRep+getSomeTypeRep bh = do+    tag <- get bh :: IO Word8+    case tag of+        0 -> return $ SomeTypeRep (typeRep :: TypeRep Type)+        1 -> do con <- get bh :: IO TyCon+                ks <- get bh :: IO [SomeTypeRep]+                return $ SomeTypeRep $ mkTrCon con ks++        2 -> do SomeTypeRep f <- getSomeTypeRep bh+                SomeTypeRep x <- getSomeTypeRep bh+                case typeRepKind f of+                  Fun arg res ->+                      case arg `eqTypeRep` typeRepKind x of+                        Just HRefl ->+                            case typeRepKind res `eqTypeRep` (typeRep :: TypeRep Type) of+                              Just HRefl -> return $ SomeTypeRep $ mkTrApp f x+                              _ -> failure "Kind mismatch in type application" []+                        _ -> failure "Kind mismatch in type application"+                             [ "    Found argument of kind: " ++ show (typeRepKind x)+                             , "    Where the constructor:  " ++ show f+                             , "    Expects kind:           " ++ show arg+                             ]+                  _ -> failure "Applied non-arrow"+                       [ "    Applied type: " ++ show f+                       , "    To argument:  " ++ show x+                       ]+        3 -> do SomeTypeRep arg <- getSomeTypeRep bh+                SomeTypeRep res <- getSomeTypeRep bh+                if+                  | App argkcon _ <- typeRepKind arg+                  , App reskcon _ <- typeRepKind res+                  , Just HRefl <- argkcon `eqTypeRep` tYPErep+                  , Just HRefl <- reskcon `eqTypeRep` tYPErep+                  -> return $ SomeTypeRep $ Fun arg res+                  | otherwise -> failure "Kind mismatch" []+        _ -> failure "Invalid SomeTypeRep" []+  where+    tYPErep :: TypeRep TYPE+    tYPErep = typeRep++    failure description info =+        fail $ unlines $ [ "Binary.getSomeTypeRep: "++description ]+                      ++ map ("    "++) info++instance Binary SomeTypeRep where+    put_ bh (SomeTypeRep rep) = putTypeRep bh rep+    get = getSomeTypeRep++instance Typeable a => Binary (TypeRep (a :: k)) where+    put_ = putTypeRep+    get bh = do+        SomeTypeRep rep <- getSomeTypeRep bh+        case rep `eqTypeRep` expected of+            Just HRefl -> pure rep+            Nothing    -> fail $ unlines+                               [ "Binary: Type mismatch"+                               , "    Deserialized type: " ++ show rep+                               , "    Expected type:     " ++ show expected+                               ]+     where expected = typeRep :: TypeRep a+++instance Binary VecCount where+    put_ bh = putByte bh . fromIntegral . fromEnum+    get bh = toEnum . fromIntegral <$> getByte bh++instance Binary VecElem where+    put_ bh = putByte bh . fromIntegral . fromEnum+    get bh = toEnum . fromIntegral <$> getByte bh++instance Binary RuntimeRep where+    put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b+    put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps+    put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps+#if __GLASGOW_HASKELL__ >= 901+    put_ bh (BoxedRep Lifted)   = putByte bh 3+    put_ bh (BoxedRep Unlifted) = putByte bh 4+#else+    put_ bh LiftedRep       = putByte bh 3+    put_ bh UnliftedRep     = putByte bh 4+#endif+    put_ bh IntRep          = putByte bh 5+    put_ bh WordRep         = putByte bh 6+    put_ bh Int64Rep        = putByte bh 7+    put_ bh Word64Rep       = putByte bh 8+    put_ bh AddrRep         = putByte bh 9+    put_ bh FloatRep        = putByte bh 10+    put_ bh DoubleRep       = putByte bh 11+    put_ bh Int8Rep         = putByte bh 12+    put_ bh Word8Rep        = putByte bh 13+    put_ bh Int16Rep        = putByte bh 14+    put_ bh Word16Rep       = putByte bh 15+    put_ bh Int32Rep        = putByte bh 16+    put_ bh Word32Rep       = putByte bh 17++    get bh = do+        tag <- getByte bh+        case tag of+          0  -> VecRep <$> get bh <*> get bh+          1  -> TupleRep <$> get bh+          2  -> SumRep <$> get bh+#if __GLASGOW_HASKELL__ >= 901+          3  -> pure (BoxedRep Lifted)+          4  -> pure (BoxedRep Unlifted)+#else+          3  -> pure LiftedRep+          4  -> pure UnliftedRep+#endif+          5  -> pure IntRep+          6  -> pure WordRep+          7  -> pure Int64Rep+          8  -> pure Word64Rep+          9  -> pure AddrRep+          10 -> pure FloatRep+          11 -> pure DoubleRep+          12 -> pure Int8Rep+          13 -> pure Word8Rep+          14 -> pure Int16Rep+          15 -> pure Word16Rep+          16 -> pure Int32Rep+          17 -> pure Word32Rep+          _  -> fail "Binary.putRuntimeRep: invalid tag"++instance Binary KindRep where+    put_ bh (KindRepTyConApp tc k) = putByte bh 0 >> put_ bh tc >> put_ bh k+    put_ bh (KindRepVar bndr) = putByte bh 1 >> put_ bh bndr+    put_ bh (KindRepApp a b) = putByte bh 2 >> put_ bh a >> put_ bh b+    put_ bh (KindRepFun a b) = putByte bh 3 >> put_ bh a >> put_ bh b+    put_ bh (KindRepTYPE r) = putByte bh 4 >> put_ bh r+    put_ bh (KindRepTypeLit sort r) = putByte bh 5 >> put_ bh sort >> put_ bh r++    get bh = do+        tag <- getByte bh+        case tag of+          0 -> KindRepTyConApp <$> get bh <*> get bh+          1 -> KindRepVar <$> get bh+          2 -> KindRepApp <$> get bh <*> get bh+          3 -> KindRepFun <$> get bh <*> get bh+          4 -> KindRepTYPE <$> get bh+          5 -> KindRepTypeLit <$> get bh <*> get bh+          _ -> fail "Binary.putKindRep: invalid tag"++instance Binary TypeLitSort where+    put_ bh TypeLitSymbol = putByte bh 0+    put_ bh TypeLitNat = putByte bh 1+#if defined(HAS_TYPELITCHAR)+    put_ bh TypeLitChar = putByte bh 2+#endif+    get bh = do+        tag <- getByte bh+        case tag of+          0 -> pure TypeLitSymbol+          1 -> pure TypeLitNat+#if defined(HAS_TYPELITCHAR)+          2 -> pure TypeLitChar+#endif+          _ -> fail "Binary.putTypeLitSort: invalid tag"++putTypeRep :: BinHandle -> TypeRep a -> IO ()+-- Special handling for TYPE, (->), and RuntimeRep due to recursive kind+-- relations.+-- See Note [Mutually recursive representations of primitive types]+putTypeRep bh rep+  | Just HRefl <- rep `eqTypeRep` (typeRep :: TypeRep Type)+  = put_ bh (0 :: Word8)+putTypeRep bh (Con' con ks) = do+    put_ bh (1 :: Word8)+    put_ bh con+    put_ bh ks+putTypeRep bh (App f x) = do+    put_ bh (2 :: Word8)+    putTypeRep bh f+    putTypeRep bh x+putTypeRep bh (Fun arg res) = do+    put_ bh (3 :: Word8)+    putTypeRep bh arg+    putTypeRep bh res++instance Binary Serialized where+    put_ bh (Serialized the_type bytes) = do+        put_ bh the_type+        put_ bh bytes+    get bh = do+        the_type <- get bh+        bytes <- get bh+        return (Serialized the_type bytes)

GHC/Utils/BufHandle.hs view

@@ -46,8 +46,7 @@ newBufHandle :: Handle -> IO BufHandle newBufHandle hdl = do   ptr <- mallocBytes buf_size-  r <- newFastMutInt-  writeFastMutInt r 0+  r <- newFastMutInt 0   return (BufHandle ptr r hdl)  buf_size :: Int

− GHC/Utils/Encoding.hs

@@ -1,501 +0,0 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}-{-# OPTIONS_GHC -O2 #-}--- We always optimise this, otherwise performance of a non-optimised--- compiler is severely affected---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 1997-2006------ Character encodings------ -------------------------------------------------------------------------------module GHC.Utils.Encoding (-        -- * UTF-8-        utf8DecodeCharAddr#,-        utf8PrevChar,-        utf8CharStart,-        utf8DecodeChar,-        utf8DecodeByteString,-        utf8UnconsByteString,-        utf8DecodeShortByteString,-        utf8DecodeStringLazy,-        utf8EncodeChar,-        utf8EncodeString,-        utf8EncodeShortByteString,-        utf8EncodedLength,-        countUTF8Chars,--        -- * Z-encoding-        zEncodeString,-        zDecodeString,--        -- * Base62-encoding-        toBase62,-        toBase62Padded-  ) where--import GHC.Prelude--import Foreign-import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)-import Data.Char-import qualified Data.Char as Char-import Numeric-import GHC.IO-import GHC.ST--import Data.ByteString (ByteString)-import qualified Data.ByteString.Internal as BS-import Data.ByteString.Short.Internal (ShortByteString(..))--import GHC.Exts---- -------------------------------------------------------------------------------- UTF-8---- We can't write the decoder as efficiently as we'd like without--- resorting to unboxed extensions, unfortunately.  I tried to write--- an IO version of this function, but GHC can't eliminate boxed--- results from an IO-returning function.------ We assume we can ignore overflow when parsing a multibyte character here.--- To make this safe, we add extra sentinel bytes to unparsed UTF-8 sequences--- before decoding them (see "GHC.Data.StringBuffer").--{-# INLINE utf8DecodeChar# #-}-utf8DecodeChar# :: (Int# -> Word#) -> (# Char#, Int# #)-utf8DecodeChar# indexWord8# =-  let !ch0 = word2Int# (indexWord8# 0#) in-  case () of-    _ | isTrue# (ch0 <=# 0x7F#) -> (# chr# ch0, 1# #)--      | isTrue# ((ch0 >=# 0xC0#) `andI#` (ch0 <=# 0xDF#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        (# chr# (((ch0 -# 0xC0#) `uncheckedIShiftL#` 6#) +#-                  (ch1 -# 0x80#)),-           2# #)--      | isTrue# ((ch0 >=# 0xE0#) `andI#` (ch0 <=# 0xEF#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        let !ch2 = word2Int# (indexWord8# 2#) in-        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else-        (# chr# (((ch0 -# 0xE0#) `uncheckedIShiftL#` 12#) +#-                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 6#)  +#-                  (ch2 -# 0x80#)),-           3# #)--     | isTrue# ((ch0 >=# 0xF0#) `andI#` (ch0 <=# 0xF8#)) ->-        let !ch1 = word2Int# (indexWord8# 1#) in-        if isTrue# ((ch1 <# 0x80#) `orI#` (ch1 >=# 0xC0#)) then fail 1# else-        let !ch2 = word2Int# (indexWord8# 2#) in-        if isTrue# ((ch2 <# 0x80#) `orI#` (ch2 >=# 0xC0#)) then fail 2# else-        let !ch3 = word2Int# (indexWord8# 3#) in-        if isTrue# ((ch3 <# 0x80#) `orI#` (ch3 >=# 0xC0#)) then fail 3# else-        (# chr# (((ch0 -# 0xF0#) `uncheckedIShiftL#` 18#) +#-                 ((ch1 -# 0x80#) `uncheckedIShiftL#` 12#) +#-                 ((ch2 -# 0x80#) `uncheckedIShiftL#` 6#)  +#-                  (ch3 -# 0x80#)),-           4# #)--      | otherwise -> fail 1#-  where-        -- all invalid sequences end up here:-        fail :: Int# -> (# Char#, Int# #)-        fail nBytes# = (# '\0'#, nBytes# #)-        -- '\xFFFD' would be the usual replacement character, but-        -- that's a valid symbol in Haskell, so will result in a-        -- confusing parse error later on.  Instead we use '\0' which-        -- will signal a lexer error immediately.--utf8DecodeCharAddr# :: Addr# -> Int# -> (# Char#, Int# #)-utf8DecodeCharAddr# a# off# =-    utf8DecodeChar# (\i# -> indexWord8OffAddr# a# (i# +# off#))--utf8DecodeCharByteArray# :: ByteArray# -> Int# -> (# Char#, Int# #)-utf8DecodeCharByteArray# ba# off# =-    utf8DecodeChar# (\i# -> indexWord8Array# ba# (i# +# off#))--utf8DecodeChar :: Ptr Word8 -> (Char, Int)-utf8DecodeChar !(Ptr a#) =-  case utf8DecodeCharAddr# a# 0# of-    (# c#, nBytes# #) -> ( C# c#, I# nBytes# )---- UTF-8 is cleverly designed so that we can always figure out where--- the start of the current character is, given any position in a--- stream.  This function finds the start of the previous character,--- assuming there *is* a previous character.-utf8PrevChar :: Ptr Word8 -> IO (Ptr Word8)-utf8PrevChar p = utf8CharStart (p `plusPtr` (-1))--utf8CharStart :: Ptr Word8 -> IO (Ptr Word8)-utf8CharStart p = go p- where go p = do w <- peek p-                 if w >= 0x80 && w < 0xC0-                        then go (p `plusPtr` (-1))-                        else return p--{-# INLINE utf8DecodeLazy# #-}-utf8DecodeLazy# :: (IO ()) -> (Int# -> (# Char#, Int# #)) -> Int# -> IO [Char]-utf8DecodeLazy# retain decodeChar# len#-  = unpack 0#-  where-    unpack i#-        | isTrue# (i# >=# len#) = retain >> return []-        | otherwise =-            case decodeChar# i# of-              (# c#, nBytes# #) -> do-                rest <- unsafeDupableInterleaveIO $ unpack (i# +# nBytes#)-                return (C# c# : rest)--utf8DecodeByteString :: ByteString -> [Char]-utf8DecodeByteString (BS.PS fptr offset len)-  = utf8DecodeStringLazy fptr offset len--utf8UnconsByteString :: ByteString -> Maybe (Char, ByteString)-utf8UnconsByteString (BS.PS _ _ 0) = Nothing-utf8UnconsByteString (BS.PS fptr offset len)-  = unsafeDupablePerformIO $-      withForeignPtr fptr $ \ptr -> do-        let (c,n) = utf8DecodeChar (ptr `plusPtr` offset)-        return $ Just (c, BS.PS fptr (offset + n) (len - n))--utf8DecodeStringLazy :: ForeignPtr Word8 -> Int -> Int -> [Char]-utf8DecodeStringLazy fp offset (I# len#)-  = unsafeDupablePerformIO $ do-      let !(Ptr a#) = unsafeForeignPtrToPtr fp `plusPtr` offset-      utf8DecodeLazy# (touchForeignPtr fp) (utf8DecodeCharAddr# a#) len#--- Note that since utf8DecodeLazy# returns a thunk the lifetime of the--- ForeignPtr actually needs to be longer than the lexical lifetime--- withForeignPtr would provide here. That's why we use touchForeignPtr to--- keep the fp alive until the last character has actually been decoded.--utf8DecodeShortByteString :: ShortByteString -> [Char]-utf8DecodeShortByteString (SBS ba#)-  = unsafeDupablePerformIO $-      let len# = sizeofByteArray# ba# in-      utf8DecodeLazy# (return ()) (utf8DecodeCharByteArray# ba#) len#--countUTF8Chars :: ShortByteString -> IO Int-countUTF8Chars (SBS ba) = go 0# 0#-  where-    len# = sizeofByteArray# ba-    go i# n#-      | isTrue# (i# >=# len#) =-          return (I# n#)-      | otherwise = do-          case utf8DecodeCharByteArray# ba i# of-            (# _, nBytes# #) -> go (i# +# nBytes#) (n# +# 1#)--{-# INLINE utf8EncodeChar #-}-utf8EncodeChar :: (Int# -> Word# -> State# s -> State# s)-               -> Char -> ST s Int-utf8EncodeChar write# c =-  let x = ord c in-  case () of-    _ | x > 0 && x <= 0x007f -> do-          write 0 x-          return 1-        -- NB. '\0' is encoded as '\xC0\x80', not '\0'.  This is so that we-        -- can have 0-terminated UTF-8 strings (see GHC.Base.unpackCStringUtf8).-      | x <= 0x07ff -> do-          write 0 (0xC0 .|. ((x `shiftR` 6) .&. 0x1F))-          write 1 (0x80 .|. (x .&. 0x3F))-          return 2-      | x <= 0xffff -> do-          write 0 (0xE0 .|. (x `shiftR` 12) .&. 0x0F)-          write 1 (0x80 .|. (x `shiftR` 6) .&. 0x3F)-          write 2 (0x80 .|. (x .&. 0x3F))-          return 3-      | otherwise -> do-          write 0 (0xF0 .|. (x `shiftR` 18))-          write 1 (0x80 .|. ((x `shiftR` 12) .&. 0x3F))-          write 2 (0x80 .|. ((x `shiftR` 6) .&. 0x3F))-          write 3 (0x80 .|. (x .&. 0x3F))-          return 4-  where-    {-# INLINE write #-}-    write (I# off#) (I# c#) = ST $ \s ->-      case write# off# (int2Word# c#) s of-        s -> (# s, () #)--utf8EncodeString :: Ptr Word8 -> String -> IO ()-utf8EncodeString (Ptr a#) str = go a# str-  where go !_   []   = return ()-        go a# (c:cs) = do-          I# off# <- stToIO $ utf8EncodeChar (writeWord8OffAddr# a#) c-          go (a# `plusAddr#` off#) cs--utf8EncodeShortByteString :: String -> IO ShortByteString-utf8EncodeShortByteString str = IO $ \s ->-  case utf8EncodedLength str         of { I# len# ->-  case newByteArray# len# s          of { (# s, mba# #) ->-  case go mba# 0# str                of { ST f_go ->-  case f_go s                        of { (# s, () #) ->-  case unsafeFreezeByteArray# mba# s of { (# s, ba# #) ->-  (# s, SBS ba# #) }}}}}-  where-    go _ _ [] = return ()-    go mba# i# (c:cs) = do-      I# off# <- utf8EncodeChar (\j# -> writeWord8Array# mba# (i# +# j#)) c-      go mba# (i# +# off#) cs--utf8EncodedLength :: String -> Int-utf8EncodedLength str = go 0 str-  where go !n [] = n-        go n (c:cs)-          | ord c > 0 && ord c <= 0x007f = go (n+1) cs-          | ord c <= 0x07ff = go (n+2) cs-          | ord c <= 0xffff = go (n+3) cs-          | otherwise       = go (n+4) cs---- -------------------------------------------------------------------------------- The Z-encoding--{--This is the main name-encoding and decoding function.  It encodes any-string into a string that is acceptable as a C name.  This is done-right before we emit a symbol name into the compiled C or asm code.-Z-encoding of strings is cached in the FastString interface, so we-never encode the same string more than once.--The basic encoding scheme is this.--* Tuples (,,,) are coded as Z3T--* Alphabetic characters (upper and lower) and digits-        all translate to themselves;-        except 'Z', which translates to 'ZZ'-        and    'z', which translates to 'zz'-  We need both so that we can preserve the variable/tycon distinction--* Most other printable characters translate to 'zx' or 'Zx' for some-        alphabetic character x--* The others translate as 'znnnU' where 'nnn' is the decimal number-        of the character--        Before          After-        ---------------------------        Trak            Trak-        foo_wib         foozuwib-        >               zg-        >1              zg1-        foo#            foozh-        foo##           foozhzh-        foo##1          foozhzh1-        fooZ            fooZZ-        :+              ZCzp-        ()              Z0T     0-tuple-        (,,,,)          Z5T     5-tuple-        (# #)           Z1H     unboxed 1-tuple (note the space)-        (#,,,,#)        Z5H     unboxed 5-tuple-                (NB: There is no Z1T nor Z0H.)--}--type UserString = String        -- As the user typed it-type EncodedString = String     -- Encoded form---zEncodeString :: UserString -> EncodedString-zEncodeString cs = case maybe_tuple cs of-                Just n  -> n            -- Tuples go to Z2T etc-                Nothing -> go cs-          where-                go []     = []-                go (c:cs) = encode_digit_ch c ++ go' cs-                go' []     = []-                go' (c:cs) = encode_ch c ++ go' cs--unencodedChar :: Char -> Bool   -- True for chars that don't need encoding-unencodedChar 'Z' = False-unencodedChar 'z' = False-unencodedChar c   =  c >= 'a' && c <= 'z'-                  || c >= 'A' && c <= 'Z'-                  || c >= '0' && c <= '9'---- If a digit is at the start of a symbol then we need to encode it.--- Otherwise package names like 9pH-0.1 give linker errors.-encode_digit_ch :: Char -> EncodedString-encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c-encode_digit_ch c | otherwise            = encode_ch c--encode_ch :: Char -> EncodedString-encode_ch c | unencodedChar c = [c]     -- Common case first---- Constructors-encode_ch '('  = "ZL"   -- Needed for things like (,), and (->)-encode_ch ')'  = "ZR"   -- For symmetry with (-encode_ch '['  = "ZM"-encode_ch ']'  = "ZN"-encode_ch ':'  = "ZC"-encode_ch 'Z'  = "ZZ"---- Variables-encode_ch 'z'  = "zz"-encode_ch '&'  = "za"-encode_ch '|'  = "zb"-encode_ch '^'  = "zc"-encode_ch '$'  = "zd"-encode_ch '='  = "ze"-encode_ch '>'  = "zg"-encode_ch '#'  = "zh"-encode_ch '.'  = "zi"-encode_ch '<'  = "zl"-encode_ch '-'  = "zm"-encode_ch '!'  = "zn"-encode_ch '+'  = "zp"-encode_ch '\'' = "zq"-encode_ch '\\' = "zr"-encode_ch '/'  = "zs"-encode_ch '*'  = "zt"-encode_ch '_'  = "zu"-encode_ch '%'  = "zv"-encode_ch c    = encode_as_unicode_char c--encode_as_unicode_char :: Char -> EncodedString-encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str-                                                           else '0':hex_str-  where hex_str = showHex (ord c) "U"-  -- ToDo: we could improve the encoding here in various ways.-  -- eg. strings of unicode characters come out as 'z1234Uz5678U', we-  -- could remove the 'U' in the middle (the 'z' works as a separator).--zDecodeString :: EncodedString -> UserString-zDecodeString [] = []-zDecodeString ('Z' : d : rest)-  | isDigit d = decode_tuple   d rest-  | otherwise = decode_upper   d : zDecodeString rest-zDecodeString ('z' : d : rest)-  | isDigit d = decode_num_esc d rest-  | otherwise = decode_lower   d : zDecodeString rest-zDecodeString (c   : rest) = c : zDecodeString rest--decode_upper, decode_lower :: Char -> Char--decode_upper 'L' = '('-decode_upper 'R' = ')'-decode_upper 'M' = '['-decode_upper 'N' = ']'-decode_upper 'C' = ':'-decode_upper 'Z' = 'Z'-decode_upper ch  = {-pprTrace "decode_upper" (char ch)-} ch--decode_lower 'z' = 'z'-decode_lower 'a' = '&'-decode_lower 'b' = '|'-decode_lower 'c' = '^'-decode_lower 'd' = '$'-decode_lower 'e' = '='-decode_lower 'g' = '>'-decode_lower 'h' = '#'-decode_lower 'i' = '.'-decode_lower 'l' = '<'-decode_lower 'm' = '-'-decode_lower 'n' = '!'-decode_lower 'p' = '+'-decode_lower 'q' = '\''-decode_lower 'r' = '\\'-decode_lower 's' = '/'-decode_lower 't' = '*'-decode_lower 'u' = '_'-decode_lower 'v' = '%'-decode_lower ch  = {-pprTrace "decode_lower" (char ch)-} ch---- Characters not having a specific code are coded as z224U (in hex)-decode_num_esc :: Char -> EncodedString -> UserString-decode_num_esc d rest-  = go (digitToInt d) rest-  where-    go n (c : rest) | isHexDigit c = go (16*n + digitToInt c) rest-    go n ('U' : rest)           = chr n : zDecodeString rest-    go n other = error ("decode_num_esc: " ++ show n ++  ' ':other)--decode_tuple :: Char -> EncodedString -> UserString-decode_tuple d rest-  = go (digitToInt d) rest-  where-        -- NB. recurse back to zDecodeString after decoding the tuple, because-        -- the tuple might be embedded in a longer name.-    go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest-    go 0 ('T':rest)     = "()" ++ zDecodeString rest-    go n ('T':rest)     = '(' : replicate (n-1) ',' ++ ")" ++ zDecodeString rest-    go 1 ('H':rest)     = "(# #)" ++ zDecodeString rest-    go n ('H':rest)     = '(' : '#' : replicate (n-1) ',' ++ "#)" ++ zDecodeString rest-    go n other = error ("decode_tuple: " ++ show n ++ ' ':other)--{--Tuples are encoded as-        Z3T or Z3H-for 3-tuples or unboxed 3-tuples respectively.  No other encoding starts-        Z<digit>--* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)-  There are no unboxed 0-tuples.--* "()" is the tycon for a boxed 0-tuple.-  There are no boxed 1-tuples.--}--maybe_tuple :: UserString -> Maybe EncodedString--maybe_tuple "(# #)" = Just("Z1H")-maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of-                                 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")-                                 _                  -> Nothing-maybe_tuple "()" = Just("Z0T")-maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of-                                 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")-                                 _            -> Nothing-maybe_tuple _                = Nothing--count_commas :: Int -> String -> (Int, String)-count_commas n (',' : cs) = count_commas (n+1) cs-count_commas n cs         = (n,cs)---{--************************************************************************-*                                                                      *-                        Base 62-*                                                                      *-************************************************************************--Note [Base 62 encoding 128-bit integers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Instead of base-62 encoding a single 128-bit integer-(ceil(21.49) characters), we'll base-62 a pair of 64-bit integers-(2 * ceil(10.75) characters).  Luckily for us, it's the same number of-characters!--}------------------------------------------------------------------------------- Base 62---- The base-62 code is based off of 'locators'--- ((c) Operational Dynamics Consulting, BSD3 licensed)---- | Size of a 64-bit word when written as a base-62 string-word64Base62Len :: Int-word64Base62Len = 11---- | Converts a 64-bit word into a base-62 string-toBase62Padded :: Word64 -> String-toBase62Padded w = pad ++ str-  where-    pad = replicate len '0'-    len = word64Base62Len - length str -- 11 == ceil(64 / lg 62)-    str = toBase62 w--toBase62 :: Word64 -> String-toBase62 w = showIntAtBase 62 represent w ""-  where-    represent :: Int -> Char-    represent x-        | x < 10 = Char.chr (48 + x)-        | x < 36 = Char.chr (65 + x - 10)-        | x < 62 = Char.chr (97 + x - 36)-        | otherwise = error "represent (base 62): impossible!"

GHC/Utils/Error.hs view

@@ -1,39 +1,36 @@+{-# LANGUAGE BangPatterns    #-}+{-# LANGUAGE CPP             #-}+{-# LANGUAGE RankNTypes      #-}+{-# LANGUAGE ViewPatterns    #-}+ {- (c) The AQUA Project, Glasgow University, 1994-1998  \section[ErrsUtils]{Utilities for error reporting} -} -{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE LambdaCase #-}- module GHC.Utils.Error (         -- * Basic types         Validity(..), andValid, allValid, isValid, getInvalids, orValid,         Severity(..),          -- * Messages-        ErrMsg, errMsgDoc, errMsgSeverity, errMsgReason,-        ErrDoc, errDoc, errDocImportant, errDocContext, errDocSupplementary,-        WarnMsg, MsgDoc,+        WarnMsg,+        MsgEnvelope(..),+        SDoc,+        DecoratedSDoc(unDecorated),         Messages, ErrorMessages, WarningMessages,         unionMessages,-        errMsgSpan, errMsgContext,         errorsFound, isEmptyMessages,-        isWarnMsgFatal,-        warningsToMessages,          -- ** Formatting-        pprMessageBag, pprErrMsgBagWithLoc,-        pprLocErrMsg, printBagOfErrors,-        formatErrDoc,+        pprMessageBag, pprMsgEnvelopeBagWithLoc,+        pprLocMsgEnvelope,+        formatBulleted,          -- ** Construction-        emptyMessages, mkLocMessage, mkLocMessageAnn, makeIntoWarning,-        mkErrMsg, mkPlainErrMsg, mkErrDoc, mkLongErrMsg, mkWarnMsg,+        emptyMessages, mkDecorated, mkLocMessage, mkLocMessageAnn, makeIntoWarning,+        mkMsgEnvelope, mkPlainMsgEnvelope, mkErr, mkLongMsgEnvelope, mkWarnMsg,         mkPlainWarnMsg,         mkLongWarnMsg, @@ -41,13 +38,6 @@         doIfSet, doIfSet_dyn,         getCaretDiagnostic, -        -- * Dump files-        dumpIfSet, dumpIfSet_dyn, dumpIfSet_dyn_printer,-        dumpOptionsFromFlag, DumpOptions (..),-        DumpFormat (..), DumpAction, dumpAction, defaultDumpAction,-        TraceAction, traceAction, defaultTraceAction,-        touchDumpFile,-         -- * Issuing messages during compilation         putMsg, printInfoForUser, printOutputForUser,         logInfo, logOutput,@@ -55,53 +45,45 @@         fatalErrorMsg, fatalErrorMsg'',         compilationProgressMsg,         showPass,-        withTiming, withTimingSilent, withTimingD, withTimingSilentD,+        withTiming, withTimingSilent,         debugTraceMsg,         ghcExit,         prettyPrintGhcErrors,-        traceCmd+        traceCmd,++        sortMsgBag     ) where  #include "HsVersions.h"  import GHC.Prelude +import GHC.Driver.Session+import GHC.Driver.Ppr+ import GHC.Data.Bag import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import qualified GHC.Utils.Ppr.Colour as Col+import GHC.Utils.Logger+import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc-import GHC.Driver.Session-import GHC.Data.FastString (unpackFS)-import GHC.Data.StringBuffer (atLine, hGetStringBuffer, len, lexemeToString)-import GHC.Utils.Json -import System.Directory import System.Exit      ( ExitCode(..), exitWith )-import System.FilePath  ( takeDirectory, (</>) )-import Data.List-import qualified Data.Set as Set-import Data.IORef+import Data.List        ( sortBy ) import Data.Maybe       ( fromMaybe ) import Data.Function-import Data.Time import Debug.Trace import Control.Monad import Control.Monad.IO.Class import Control.Monad.Catch as MC (handle)-import System.IO-import System.IO.Error  ( catchIOError ) import GHC.Conc         ( getAllocationCounter ) import System.CPUTime  --------------------------type MsgDoc  = SDoc--------------------------- data Validity   = IsValid            -- ^ Everything is fine-  | NotValid MsgDoc    -- ^ A problem, and some indication of why+  | NotValid SDoc    -- ^ A problem, and some indication of why  isValid :: Validity -> Bool isValid IsValid       = True@@ -116,7 +98,7 @@ allValid []       = IsValid allValid (v : vs) = v `andValid` allValid vs -getInvalids :: [Validity] -> [MsgDoc]+getInvalids :: [Validity] -> [SDoc] getInvalids vs = [d | NotValid d <- vs]  orValid :: Validity -> Validity -> Validity@@ -124,292 +106,32 @@ orValid _       v = v  -- -------------------------------------------------------------------------------- Basic error messages: just render a message with a source location.--type Messages        = (WarningMessages, ErrorMessages)-type WarningMessages = Bag WarnMsg-type ErrorMessages   = Bag ErrMsg--unionMessages :: Messages -> Messages -> Messages-unionMessages (warns1, errs1) (warns2, errs2) =-  (warns1 `unionBags` warns2, errs1 `unionBags` errs2)--data ErrMsg = ErrMsg {-        errMsgSpan        :: SrcSpan,-        errMsgContext     :: PrintUnqualified,-        errMsgDoc         :: ErrDoc,-        -- | This has the same text as errDocImportant . errMsgDoc.-        errMsgShortString :: String,-        errMsgSeverity    :: Severity,-        errMsgReason      :: WarnReason-        }-        -- The SrcSpan is used for sorting errors into line-number order----- | Categorise error msgs by their importance.  This is so each section can--- be rendered visually distinct.  See Note [Error report] for where these come--- from.-data ErrDoc = ErrDoc {-        -- | Primary error msg.-        errDocImportant     :: [MsgDoc],-        -- | Context e.g. \"In the second argument of ...\".-        errDocContext       :: [MsgDoc],-        -- | Supplementary information, e.g. \"Relevant bindings include ...\".-        errDocSupplementary :: [MsgDoc]-        }--errDoc :: [MsgDoc] -> [MsgDoc] -> [MsgDoc] -> ErrDoc-errDoc = ErrDoc--type WarnMsg = ErrMsg--data Severity-  = SevOutput-  | SevFatal-  | SevInteractive--  | SevDump-    -- ^ Log message intended for compiler developers-    -- No file\/line\/column stuff--  | SevInfo-    -- ^ Log messages intended for end users.-    -- No file\/line\/column stuff.--  | SevWarning-  | SevError-    -- ^ SevWarning and SevError are used for warnings and errors-    --   o The message has a file\/line\/column heading,-    --     plus "warning:" or "error:",-    --     added by mkLocMessags-    --   o Output is intended for end users-  deriving Show---instance ToJson Severity where-  json s = JSString (show s)---instance Show ErrMsg where-    show em = errMsgShortString em--pprMessageBag :: Bag MsgDoc -> SDoc-pprMessageBag msgs = vcat (punctuate blankLine (bagToList msgs))---- | Make an unannotated error message with location info.-mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc-mkLocMessage = mkLocMessageAnn Nothing---- | Make a possibly annotated error message with location info.-mkLocMessageAnn-  :: Maybe String                       -- ^ optional annotation-  -> Severity                           -- ^ severity-  -> SrcSpan                            -- ^ location-  -> MsgDoc                             -- ^ message-  -> MsgDoc-  -- Always print the location, even if it is unhelpful.  Error messages-  -- are supposed to be in a standard format, and one without a location-  -- would look strange.  Better to say explicitly "<no location info>".-mkLocMessageAnn ann severity locn msg-    = sdocOption sdocColScheme $ \col_scheme ->-      let locn' = sdocOption sdocErrorSpans $ \case-                     True  -> ppr locn-                     False -> ppr (srcSpanStart locn)--          sevColour = getSeverityColour severity col_scheme--          -- Add optional information-          optAnn = case ann of-            Nothing -> text ""-            Just i  -> text " [" <> coloured sevColour (text i) <> text "]"--          -- Add prefixes, like    Foo.hs:34: warning:-          --                           <the warning message>-          header = locn' <> colon <+>-                   coloured sevColour sevText <> optAnn--      in coloured (Col.sMessage col_scheme)-                  (hang (coloured (Col.sHeader col_scheme) header) 4-                        msg)--  where-    sevText =-      case severity of-        SevWarning -> text "warning:"-        SevError   -> text "error:"-        SevFatal   -> text "fatal:"-        _          -> empty--getSeverityColour :: Severity -> Col.Scheme -> Col.PprColour-getSeverityColour SevWarning = Col.sWarning-getSeverityColour SevError   = Col.sError-getSeverityColour SevFatal   = Col.sFatal-getSeverityColour _          = const mempty--getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc-getCaretDiagnostic _ (UnhelpfulSpan _) = pure empty-getCaretDiagnostic severity (RealSrcSpan span _) = do-  caretDiagnostic <$> getSrcLine (srcSpanFile span) row--  where-    getSrcLine fn i =-      getLine i (unpackFS fn)-        `catchIOError` \_ ->-          pure Nothing--    getLine i fn = do-      -- StringBuffer has advantages over readFile:-      -- (a) no lazy IO, otherwise IO exceptions may occur in pure code-      -- (b) always UTF-8, rather than some system-dependent encoding-      --     (Haskell source code must be UTF-8 anyway)-      content <- hGetStringBuffer fn-      case atLine i content of-        Just at_line -> pure $-          case lines (fix <$> lexemeToString at_line (len at_line)) of-            srcLine : _ -> Just srcLine-            _           -> Nothing-        _ -> pure Nothing--    -- allow user to visibly see that their code is incorrectly encoded-    -- (StringBuffer.nextChar uses \0 to represent undecodable characters)-    fix '\0' = '\xfffd'-    fix c    = c--    row = srcSpanStartLine span-    rowStr = show row-    multiline = row /= srcSpanEndLine span--    caretDiagnostic Nothing = empty-    caretDiagnostic (Just srcLineWithNewline) =-      sdocOption sdocColScheme$ \col_scheme ->-      let sevColour = getSeverityColour severity col_scheme-          marginColour = Col.sMargin col_scheme-      in-      coloured marginColour (text marginSpace) <>-      text ("\n") <>-      coloured marginColour (text marginRow) <>-      text (" " ++ srcLinePre) <>-      coloured sevColour (text srcLineSpan) <>-      text (srcLinePost ++ "\n") <>-      coloured marginColour (text marginSpace) <>-      coloured sevColour (text (" " ++ caretLine))--      where--        -- expand tabs in a device-independent manner #13664-        expandTabs tabWidth i s =-          case s of-            ""        -> ""-            '\t' : cs -> replicate effectiveWidth ' ' ++-                         expandTabs tabWidth (i + effectiveWidth) cs-            c    : cs -> c : expandTabs tabWidth (i + 1) cs-          where effectiveWidth = tabWidth - i `mod` tabWidth--        srcLine = filter (/= '\n') (expandTabs 8 0 srcLineWithNewline)--        start = srcSpanStartCol span - 1-        end | multiline = length srcLine-            | otherwise = srcSpanEndCol span - 1-        width = max 1 (end - start)--        marginWidth = length rowStr-        marginSpace = replicate marginWidth ' ' ++ " |"-        marginRow   = rowStr ++ " |"--        (srcLinePre,  srcLineRest) = splitAt start srcLine-        (srcLineSpan, srcLinePost) = splitAt width srcLineRest--        caretEllipsis | multiline = "..."-                      | otherwise = ""-        caretLine = replicate start ' ' ++ replicate width '^' ++ caretEllipsis--makeIntoWarning :: WarnReason -> ErrMsg -> ErrMsg-makeIntoWarning reason err = err-    { errMsgSeverity = SevWarning-    , errMsgReason = reason }---- ----------------------------------------------------------------------------- -- Collecting up messages for later ordering and printing. -mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg-mk_err_msg dflags sev locn print_unqual doc- = ErrMsg { errMsgSpan = locn-          , errMsgContext = print_unqual-          , errMsgDoc = doc-          , errMsgShortString = showSDoc dflags (vcat (errDocImportant doc))-          , errMsgSeverity = sev-          , errMsgReason = NoReason }--mkErrDoc :: DynFlags -> SrcSpan -> PrintUnqualified -> ErrDoc -> ErrMsg-mkErrDoc dflags = mk_err_msg dflags SevError--mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg--- ^ A long (multi-line) error message-mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg--- ^ A short (one-line) error message-mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg--- ^ Variant that doesn't care about qualified/unqualified names--mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [extra])-mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        (ErrDoc [msg] [] [])-mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify (ErrDoc [msg] [] [])-mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [extra])-mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        (ErrDoc [msg] [] [])-mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify (ErrDoc [msg] [] [])- -----------------emptyMessages :: Messages-emptyMessages = (emptyBag, emptyBag)--isEmptyMessages :: Messages -> Bool-isEmptyMessages (warns, errs) = isEmptyBag warns && isEmptyBag errs--errorsFound :: DynFlags -> Messages -> Bool-errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)--warningsToMessages :: DynFlags -> WarningMessages -> Messages-warningsToMessages dflags =-  partitionBagWith $ \warn ->-    case isWarnMsgFatal dflags warn of-      Nothing -> Left warn-      Just err_reason ->-        Right warn{ errMsgSeverity = SevError-                  , errMsgReason = ErrReason err_reason }--printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()-printBagOfErrors dflags bag_of_errors-  = sequence_ [ let style = mkErrStyle unqual-                    ctx   = initSDocContext dflags style-                in putLogMsg dflags reason sev s $ withPprStyle style (formatErrDoc ctx doc)-              | ErrMsg { errMsgSpan      = s,-                         errMsgDoc       = doc,-                         errMsgSeverity  = sev,-                         errMsgReason    = reason,-                         errMsgContext   = unqual } <- sortMsgBag (Just dflags)-                                                                  bag_of_errors ]--formatErrDoc :: SDocContext -> ErrDoc -> SDoc-formatErrDoc ctx (ErrDoc important context supplementary)+-- | Formats the input list of structured document, where each element of the list gets a bullet.+formatBulleted :: SDocContext -> DecoratedSDoc -> SDoc+formatBulleted ctx (unDecorated -> docs)   = case msgs of-        [msg] -> vcat msg-        _ -> vcat $ map starred msgs+        []    -> Outputable.empty+        [msg] -> msg+        _     -> vcat $ map starred msgs     where-    msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx))-        [important, context, supplementary]-    starred = (bullet<+>) . vcat+    msgs    = filter (not . Outputable.isEmpty ctx) docs+    starred = (bullet<+>) -pprErrMsgBagWithLoc :: Bag ErrMsg -> [SDoc]-pprErrMsgBagWithLoc bag = [ pprLocErrMsg item | item <- sortMsgBag Nothing bag ]+pprMsgEnvelopeBagWithLoc :: Bag (MsgEnvelope DecoratedSDoc) -> [SDoc]+pprMsgEnvelopeBagWithLoc bag = [ pprLocMsgEnvelope item | item <- sortMsgBag Nothing bag ] -pprLocErrMsg :: ErrMsg -> SDoc-pprLocErrMsg (ErrMsg { errMsgSpan      = s-                     , errMsgDoc       = doc-                     , errMsgSeverity  = sev-                     , errMsgContext   = unqual })+pprLocMsgEnvelope :: RenderableDiagnostic e => MsgEnvelope e -> SDoc+pprLocMsgEnvelope (MsgEnvelope { errMsgSpan      = s+                               , errMsgDiagnostic = e+                               , errMsgSeverity  = sev+                               , errMsgContext   = unqual })   = sdocWithContext $ \ctx ->-    withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)+    withErrStyle unqual $ mkLocMessage sev s (formatBulleted ctx $ renderDiagnostic e) -sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]+sortMsgBag :: Maybe DynFlags -> Bag (MsgEnvelope e) -> [MsgEnvelope e] sortMsgBag dflags = maybeLimit . sortBy (cmp `on` errMsgSpan) . bagToList   where cmp           | fromMaybe False (fmap reverseErrors dflags) = SrcLoc.rightmost_smallest@@ -418,10 +140,10 @@           Nothing        -> id           Just err_limit -> take err_limit -ghcExit :: DynFlags -> Int -> IO ()-ghcExit dflags val+ghcExit :: Logger -> DynFlags -> Int -> IO ()+ghcExit logger dflags val   | val == 0  = exitWith ExitSuccess-  | otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")+  | otherwise = do errorMsg logger dflags (text "\nCompilation had errors\n\n")                    exitWith (ExitFailure val)  doIfSet :: Bool -> IO () -> IO ()@@ -433,179 +155,6 @@                                | otherwise        = return ()  -- -------------------------------------------------------------------------------- Dumping--dumpIfSet :: DynFlags -> Bool -> String -> SDoc -> IO ()-dumpIfSet dflags flag hdr doc-  | not flag   = return ()-  | otherwise  = doDump dflags hdr doc-{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]---- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated--- despite the fact that 'dumpIfSet' has an @INLINE@.-doDump :: DynFlags -> String -> SDoc -> IO ()-doDump dflags hdr doc =-  putLogMsg dflags-            NoReason-            SevDump-            noSrcSpan-            (withPprStyle defaultDumpStyle-              (mkDumpDoc hdr doc))---- | A wrapper around 'dumpAction'.--- First check whether the dump flag is set--- Do nothing if it is unset-dumpIfSet_dyn :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()-dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify-{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]---- | A wrapper around 'dumpAction'.--- First check whether the dump flag is set--- Do nothing if it is unset------ Unlike 'dumpIfSet_dyn', has a printer argument-dumpIfSet_dyn_printer :: PrintUnqualified -> DynFlags -> DumpFlag -> String-                         -> DumpFormat -> SDoc -> IO ()-dumpIfSet_dyn_printer printer dflags flag hdr fmt doc-  = when (dopt flag dflags) $ do-      let sty = mkDumpStyle printer-      dumpAction dflags sty (dumpOptionsFromFlag flag) hdr fmt doc-{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]--mkDumpDoc :: String -> SDoc -> SDoc-mkDumpDoc hdr doc-   = vcat [blankLine,-           line <+> text hdr <+> line,-           doc,-           blankLine]-     where-        line = text (replicate 20 '=')----- | Ensure that a dump file is created even if it stays empty-touchDumpFile :: DynFlags -> DumpOptions -> IO ()-touchDumpFile dflags dumpOpt = withDumpFileHandle dflags dumpOpt (const (return ()))---- | Run an action with the handle of a 'DumpFlag' if we are outputting to a--- file, otherwise 'Nothing'.-withDumpFileHandle :: DynFlags -> DumpOptions -> (Maybe Handle -> IO ()) -> IO ()-withDumpFileHandle dflags dumpOpt action = do-    let mFile = chooseDumpFile dflags dumpOpt-    case mFile of-      Just fileName -> do-        let gdref = generatedDumps dflags-        gd <- readIORef gdref-        let append = Set.member fileName gd-            mode = if append then AppendMode else WriteMode-        unless append $-            writeIORef gdref (Set.insert fileName gd)-        createDirectoryIfMissing True (takeDirectory fileName)-        withFile fileName mode $ \handle -> do-            -- We do not want the dump file to be affected by-            -- environment variables, but instead to always use-            -- UTF8. See:-            -- https://gitlab.haskell.org/ghc/ghc/issues/10762-            hSetEncoding handle utf8--            action (Just handle)-      Nothing -> action Nothing----- | Write out a dump.--- If --dump-to-file is set then this goes to a file.--- otherwise emit to stdout.------ When @hdr@ is empty, we print in a more compact format (no separators and--- blank lines)-dumpSDocWithStyle :: PprStyle -> DynFlags -> DumpOptions -> String -> SDoc -> IO ()-dumpSDocWithStyle sty dflags dumpOpt hdr doc =-    withDumpFileHandle dflags dumpOpt writeDump-  where-    -- write dump to file-    writeDump (Just handle) = do-        doc' <- if null hdr-                then return doc-                else do t <- getCurrentTime-                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)-                                          then empty-                                          else text (show t)-                        let d = timeStamp-                                $$ blankLine-                                $$ doc-                        return $ mkDumpDoc hdr d-        defaultLogActionHPrintDoc dflags handle (withPprStyle sty doc')--    -- write the dump to stdout-    writeDump Nothing = do-        let (doc', severity)-              | null hdr  = (doc, SevOutput)-              | otherwise = (mkDumpDoc hdr doc, SevDump)-        putLogMsg dflags NoReason severity noSrcSpan (withPprStyle sty doc')----- | Choose where to put a dump file based on DynFlags----chooseDumpFile :: DynFlags -> DumpOptions -> Maybe FilePath-chooseDumpFile dflags dumpOpt--        | gopt Opt_DumpToFile dflags || dumpForcedToFile dumpOpt-        , Just prefix <- getPrefix-        = Just $ setDir (prefix ++ dumpSuffix dumpOpt)--        | otherwise-        = Nothing--        where getPrefix-                 -- dump file location is being forced-                 --      by the --ddump-file-prefix flag.-               | Just prefix <- dumpPrefixForce dflags-                  = Just prefix-                 -- dump file location chosen by GHC.Driver.Pipeline.runPipeline-               | Just prefix <- dumpPrefix dflags-                  = Just prefix-                 -- we haven't got a place to put a dump file.-               | otherwise-                  = Nothing-              setDir f = case dumpDir dflags of-                         Just d  -> d </> f-                         Nothing ->       f---- | Dump options------ Dumps are printed on stdout by default except when the `dumpForcedToFile`--- field is set to True.------ When `dumpForcedToFile` is True or when `-ddump-to-file` is set, dumps are--- written into a file whose suffix is given in the `dumpSuffix` field.----data DumpOptions = DumpOptions-   { dumpForcedToFile :: Bool   -- ^ Must be dumped into a file, even if-                                --   -ddump-to-file isn't set-   , dumpSuffix       :: String -- ^ Filename suffix used when dumped into-                                --   a file-   }---- | Create dump options from a 'DumpFlag'-dumpOptionsFromFlag :: DumpFlag -> DumpOptions-dumpOptionsFromFlag Opt_D_th_dec_file =-   DumpOptions                        -- -dth-dec-file dumps expansions of TH-      { dumpForcedToFile = True       -- splices into MODULE.th.hs even when-      , dumpSuffix       = "th.hs"    -- -ddump-to-file isn't set-      }-dumpOptionsFromFlag flag =-   DumpOptions-      { dumpForcedToFile = False-      , dumpSuffix       = suffix -- build a suffix from the flag name-      }                           -- e.g. -ddump-asm => ".dump-asm"-   where-      str  = show flag-      suff = case stripPrefix "Opt_D_" str of-             Just x  -> x-             Nothing -> panic ("Bad flag name: " ++ str)-      suffix = map (\c -> if c == '_' then '-' else c) suff----- ----------------------------------------------------------------------------- -- Outputting messages from the compiler  -- We want all messages to go through one place, so that we can@@ -619,31 +168,32 @@   | otherwise               = return () {-# INLINE ifVerbose #-}  -- see Note [INLINE conditional tracing utilities] -errorMsg :: DynFlags -> MsgDoc -> IO ()-errorMsg dflags msg-   = putLogMsg dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg+errorMsg :: Logger -> DynFlags -> SDoc -> IO ()+errorMsg logger dflags msg+   = putLogMsg logger dflags NoReason SevError noSrcSpan $ withPprStyle defaultErrStyle msg -warningMsg :: DynFlags -> MsgDoc -> IO ()-warningMsg dflags msg-   = putLogMsg dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg+warningMsg :: Logger -> DynFlags -> SDoc -> IO ()+warningMsg logger dflags msg+   = putLogMsg logger dflags NoReason SevWarning noSrcSpan $ withPprStyle defaultErrStyle msg -fatalErrorMsg :: DynFlags -> MsgDoc -> IO ()-fatalErrorMsg dflags msg =-    putLogMsg dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg+fatalErrorMsg :: Logger -> DynFlags -> SDoc -> IO ()+fatalErrorMsg logger dflags msg =+    putLogMsg logger dflags NoReason SevFatal noSrcSpan $ withPprStyle defaultErrStyle msg  fatalErrorMsg'' :: FatalMessager -> String -> IO () fatalErrorMsg'' fm msg = fm msg -compilationProgressMsg :: DynFlags -> String -> IO ()-compilationProgressMsg dflags msg = do-    traceEventIO $ "GHC progress: " ++ msg+compilationProgressMsg :: Logger -> DynFlags -> SDoc -> IO ()+compilationProgressMsg logger dflags msg = do+    let str = showSDoc dflags msg+    traceEventIO $ "GHC progress: " ++ str     ifVerbose dflags 1 $-        logOutput dflags $ withPprStyle defaultUserStyle (text msg)+        logOutput logger dflags $ withPprStyle defaultUserStyle msg -showPass :: DynFlags -> String -> IO ()-showPass dflags what+showPass :: Logger -> DynFlags -> String -> IO ()+showPass logger dflags what   = ifVerbose dflags 2 $-    logInfo dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)+    logInfo logger dflags $ withPprStyle defaultUserStyle (text "***" <+> text what <> colon)  data PrintTimings = PrintTimings | DontPrintTimings   deriving (Eq, Show)@@ -673,26 +223,15 @@ -- -- See Note [withTiming] for more. withTiming :: MonadIO m-           => DynFlags     -- ^ DynFlags+           => Logger+           -> DynFlags     -- ^ DynFlags            -> SDoc         -- ^ The name of the phase            -> (a -> ())    -- ^ A function to force the result                            -- (often either @const ()@ or 'rnf')            -> m a          -- ^ The body of the phase to be timed            -> m a-withTiming dflags what force action =-  withTiming' dflags what force PrintTimings action---- | Like withTiming but get DynFlags from the Monad.-withTimingD :: (MonadIO m, HasDynFlags m)-           => SDoc         -- ^ The name of the phase-           -> (a -> ())    -- ^ A function to force the result-                           -- (often either @const ()@ or 'rnf')-           -> m a          -- ^ The body of the phase to be timed-           -> m a-withTimingD what force action = do-  dflags <- getDynFlags-  withTiming' dflags what force PrintTimings action-+withTiming logger dflags what force action =+  withTiming' logger dflags what force PrintTimings action  -- | Same as 'withTiming', but doesn't print timings in the --   console (when given @-vN@, @N >= 2@ or @-ddump-timings@).@@ -700,145 +239,130 @@ --   See Note [withTiming] for more. withTimingSilent   :: MonadIO m-  => DynFlags   -- ^ DynFlags+  => Logger+  -> DynFlags   -- ^ DynFlags   -> SDoc       -- ^ The name of the phase   -> (a -> ())  -- ^ A function to force the result                 -- (often either @const ()@ or 'rnf')   -> m a        -- ^ The body of the phase to be timed   -> m a-withTimingSilent dflags what force action =-  withTiming' dflags what force DontPrintTimings action---- | Same as 'withTiming', but doesn't print timings in the---   console (when given @-vN@, @N >= 2@ or @-ddump-timings@)---   and gets the DynFlags from the given Monad.------   See Note [withTiming] for more.-withTimingSilentD-  :: (MonadIO m, HasDynFlags m)-  => SDoc       -- ^ The name of the phase-  -> (a -> ())  -- ^ A function to force the result-                -- (often either @const ()@ or 'rnf')-  -> m a        -- ^ The body of the phase to be timed-  -> m a-withTimingSilentD what force action = do-  dflags <- getDynFlags-  withTiming' dflags what force DontPrintTimings action+withTimingSilent logger dflags what force action =+  withTiming' logger dflags what force DontPrintTimings action  -- | Worker for 'withTiming' and 'withTimingSilent'. withTiming' :: MonadIO m-            => DynFlags   -- ^ A means of getting a 'DynFlags' (often-                            -- 'getDynFlags' will work here)+            => Logger+            -> DynFlags   -- ^ 'DynFlags'             -> SDoc         -- ^ The name of the phase             -> (a -> ())    -- ^ A function to force the result                             -- (often either @const ()@ or 'rnf')             -> PrintTimings -- ^ Whether to print the timings             -> m a          -- ^ The body of the phase to be timed             -> m a-withTiming' dflags what force_result prtimings action-  = do if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags-          then do whenPrintTimings $-                    logInfo dflags $ withPprStyle defaultUserStyle $-                      text "***" <+> what <> colon-                  let ctx = initDefaultSDocContext dflags-                  eventBegins ctx what-                  alloc0 <- liftIO getAllocationCounter-                  start <- liftIO getCPUTime-                  !r <- action-                  () <- pure $ force_result r-                  eventEnds ctx what-                  end <- liftIO getCPUTime-                  alloc1 <- liftIO getAllocationCounter-                  -- recall that allocation counter counts down-                  let alloc = alloc0 - alloc1-                      time = realToFrac (end - start) * 1e-9+withTiming' logger dflags what force_result prtimings action+  = if verbosity dflags >= 2 || dopt Opt_D_dump_timings dflags+    then do whenPrintTimings $+              logInfo logger dflags $ withPprStyle defaultUserStyle $+                text "***" <+> what <> colon+            let ctx = initDefaultSDocContext dflags+            alloc0 <- liftIO getAllocationCounter+            start <- liftIO getCPUTime+            eventBegins ctx what+            recordAllocs alloc0+            !r <- action+            () <- pure $ force_result r+            eventEnds ctx what+            end <- liftIO getCPUTime+            alloc1 <- liftIO getAllocationCounter+            recordAllocs alloc1+            -- recall that allocation counter counts down+            let alloc = alloc0 - alloc1+                time = realToFrac (end - start) * 1e-9 -                  when (verbosity dflags >= 2 && prtimings == PrintTimings)-                      $ liftIO $ logInfo dflags $ withPprStyle defaultUserStyle-                          (text "!!!" <+> what <> colon <+> text "finished in"-                           <+> doublePrec 2 time-                           <+> text "milliseconds"-                           <> comma-                           <+> text "allocated"-                           <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)-                           <+> text "megabytes")+            when (verbosity dflags >= 2 && prtimings == PrintTimings)+                $ liftIO $ logInfo logger dflags $ withPprStyle defaultUserStyle+                    (text "!!!" <+> what <> colon <+> text "finished in"+                     <+> doublePrec 2 time+                     <+> text "milliseconds"+                     <> comma+                     <+> text "allocated"+                     <+> doublePrec 3 (realToFrac alloc / 1024 / 1024)+                     <+> text "megabytes") -                  whenPrintTimings $-                      dumpIfSet_dyn dflags Opt_D_dump_timings "" FormatText-                          $ text $ showSDocOneLine ctx-                          $ hsep [ what <> colon-                                 , text "alloc=" <> ppr alloc-                                 , text "time=" <> doublePrec 3 time-                                 ]-                  pure r-           else action+            whenPrintTimings $+                dumpIfSet_dyn logger dflags Opt_D_dump_timings "" FormatText+                    $ text $ showSDocOneLine ctx+                    $ hsep [ what <> colon+                           , text "alloc=" <> ppr alloc+                           , text "time=" <> doublePrec 3 time+                           ]+            pure r+     else action      where whenPrintTimings = liftIO . when (prtimings == PrintTimings)++          recordAllocs alloc =+            liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc+           eventBegins ctx w = do-            whenPrintTimings $ traceMarkerIO (eventBeginsDoc ctx w)-            liftIO $ traceEventIO (eventBeginsDoc ctx w)+            let doc = eventBeginsDoc ctx w+            whenPrintTimings $ traceMarkerIO doc+            liftIO $ traceEventIO doc+           eventEnds ctx w = do-            whenPrintTimings $ traceMarkerIO (eventEndsDoc ctx w)-            liftIO $ traceEventIO (eventEndsDoc ctx w)+            let doc = eventEndsDoc ctx w+            whenPrintTimings $ traceMarkerIO doc+            liftIO $ traceEventIO doc            eventBeginsDoc ctx w = showSDocOneLine ctx $ text "GHC:started:" <+> w           eventEndsDoc   ctx w = showSDocOneLine ctx $ text "GHC:finished:" <+> w -debugTraceMsg :: DynFlags -> Int -> MsgDoc -> IO ()-debugTraceMsg dflags val msg =+debugTraceMsg :: Logger -> DynFlags -> Int -> SDoc -> IO ()+debugTraceMsg logger dflags val msg =    ifVerbose dflags val $-      logInfo dflags (withPprStyle defaultDumpStyle msg)+      logInfo logger dflags (withPprStyle defaultDumpStyle msg) {-# INLINE debugTraceMsg #-}  -- see Note [INLINE conditional tracing utilities] -putMsg :: DynFlags -> MsgDoc -> IO ()-putMsg dflags msg = logInfo dflags (withPprStyle defaultUserStyle msg)+putMsg :: Logger -> DynFlags -> SDoc -> IO ()+putMsg logger dflags msg = logInfo logger dflags (withPprStyle defaultUserStyle msg) -printInfoForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()-printInfoForUser dflags print_unqual msg-  = logInfo dflags (withUserStyle print_unqual AllTheWay msg)+printInfoForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()+printInfoForUser logger dflags print_unqual msg+  = logInfo logger dflags (withUserStyle print_unqual AllTheWay msg) -printOutputForUser :: DynFlags -> PrintUnqualified -> MsgDoc -> IO ()-printOutputForUser dflags print_unqual msg-  = logOutput dflags (withUserStyle print_unqual AllTheWay msg)+printOutputForUser :: Logger -> DynFlags -> PrintUnqualified -> SDoc -> IO ()+printOutputForUser logger dflags print_unqual msg+  = logOutput logger dflags (withUserStyle print_unqual AllTheWay msg) -logInfo :: DynFlags -> MsgDoc -> IO ()-logInfo dflags msg-  = putLogMsg dflags NoReason SevInfo noSrcSpan msg+logInfo :: Logger -> DynFlags -> SDoc -> IO ()+logInfo logger dflags msg+  = putLogMsg logger dflags NoReason SevInfo noSrcSpan msg  -- | Like 'logInfo' but with 'SevOutput' rather then 'SevInfo'-logOutput :: DynFlags -> MsgDoc -> IO ()-logOutput dflags msg-  = putLogMsg dflags NoReason SevOutput noSrcSpan msg+logOutput :: Logger -> DynFlags -> SDoc -> IO ()+logOutput logger dflags msg+  = putLogMsg logger dflags NoReason SevOutput noSrcSpan msg  prettyPrintGhcErrors :: ExceptionMonad m => DynFlags -> m a -> m a prettyPrintGhcErrors dflags     = MC.handle $ \e -> case e of                       PprPanic str doc ->-                          pprDebugAndThen dflags panic (text str) doc+                          pprDebugAndThen ctx panic (text str) doc                       PprSorry str doc ->-                          pprDebugAndThen dflags sorry (text str) doc+                          pprDebugAndThen ctx sorry (text str) doc                       PprProgramError str doc ->-                          pprDebugAndThen dflags pgmError (text str) doc+                          pprDebugAndThen ctx pgmError (text str) doc                       _ ->                           liftIO $ throwIO e---- | Checks if given 'WarnMsg' is a fatal warning.-isWarnMsgFatal :: DynFlags -> WarnMsg -> Maybe (Maybe WarningFlag)-isWarnMsgFatal dflags ErrMsg{errMsgReason = Reason wflag}-  = if wopt_fatal wflag dflags-      then Just (Just wflag)-      else Nothing-isWarnMsgFatal dflags _-  = if gopt Opt_WarnIsError dflags-      then Just Nothing-      else Nothing+      where+         ctx = initSDocContext dflags defaultUserStyle -traceCmd :: DynFlags -> String -> String -> IO a -> IO a+traceCmd :: Logger -> DynFlags -> String -> String -> IO a -> IO a -- trace the command (at two levels of verbosity)-traceCmd dflags phase_name cmd_line action+traceCmd logger dflags phase_name cmd_line action  = do   { let verb = verbosity dflags-        ; showPass dflags phase_name-        ; debugTraceMsg dflags 3 (text cmd_line)+        ; showPass logger dflags phase_name+        ; debugTraceMsg logger dflags 3 (text cmd_line)         ; case flushErr dflags of               FlushErr io -> io @@ -846,8 +370,8 @@         ; action `catchIO` handle_exn verb         }   where-    handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n')-                              ; debugTraceMsg dflags 2+    handle_exn _verb exn = do { debugTraceMsg logger dflags 2 (char '\n')+                              ; debugTraceMsg logger dflags 2                                 (text "Failed:"                                  <+> text cmd_line                                  <+> text (show exn))@@ -950,41 +474,3 @@ -}  --- | Format of a dump------ Dump formats are loosely defined: dumps may contain various additional--- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint--- (e.g. for syntax highlighters).-data DumpFormat-   = FormatHaskell   -- ^ Haskell-   | FormatCore      -- ^ Core-   | FormatSTG       -- ^ STG-   | FormatByteCode  -- ^ ByteCode-   | FormatCMM       -- ^ Cmm-   | FormatASM       -- ^ Assembly code-   | FormatC         -- ^ C code/header-   | FormatLLVM      -- ^ LLVM bytecode-   | FormatText      -- ^ Unstructured dump-   deriving (Show,Eq)--type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String-                  -> DumpFormat -> SDoc -> IO ()--type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a---- | Default action for 'dumpAction' hook-defaultDumpAction :: DumpAction-defaultDumpAction dflags sty dumpOpt title _fmt doc = do-   dumpSDocWithStyle sty dflags dumpOpt title doc---- | Default action for 'traceAction' hook-defaultTraceAction :: TraceAction-defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc---- | Helper for `dump_action`-dumpAction :: DumpAction-dumpAction dflags = dump_action dflags dflags---- | Helper for `trace_action`-traceAction :: TraceAction-traceAction dflags = trace_action dflags dflags

− GHC/Utils/Error.hs-boot

@@ -1,50 +0,0 @@-{-# LANGUAGE RankNTypes #-}--module GHC.Utils.Error where--import GHC.Prelude-import GHC.Utils.Outputable (SDoc, PprStyle )-import GHC.Types.SrcLoc (SrcSpan)-import GHC.Utils.Json-import {-# SOURCE #-} GHC.Driver.Session ( DynFlags )--type DumpAction = DynFlags -> PprStyle -> DumpOptions -> String-                  -> DumpFormat -> SDoc -> IO ()--type TraceAction = forall a. DynFlags -> String -> SDoc -> a -> a--data DumpOptions = DumpOptions-   { dumpForcedToFile :: Bool-   , dumpSuffix       :: String-   }--data DumpFormat-  = FormatHaskell-  | FormatCore-  | FormatSTG-  | FormatByteCode-  | FormatCMM-  | FormatASM-  | FormatC-  | FormatLLVM-  | FormatText--data Severity-  = SevOutput-  | SevFatal-  | SevInteractive-  | SevDump-  | SevInfo-  | SevWarning-  | SevError---type MsgDoc = SDoc--mkLocMessage :: Severity -> SrcSpan -> MsgDoc -> MsgDoc-mkLocMessageAnn :: Maybe String -> Severity -> SrcSpan -> MsgDoc -> MsgDoc-getCaretDiagnostic :: Severity -> SrcSpan -> IO MsgDoc-defaultDumpAction :: DumpAction-defaultTraceAction :: TraceAction--instance ToJson Severity

GHC/Utils/Exception.hs view

@@ -3,14 +3,13 @@  module GHC.Utils.Exception     (-    module Control.Exception,+    module CE,     module GHC.Utils.Exception     )     where  import GHC.Prelude -import Control.Exception import Control.Exception as CE import Control.Monad.IO.Class import Control.Monad.Catch

+ GHC/Utils/GlobalVars.hs view

@@ -0,0 +1,112 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++module GHC.Utils.GlobalVars+   ( v_unsafeHasPprDebug+   , v_unsafeHasNoDebugOutput+   , v_unsafeHasNoStateHack+   , unsafeHasPprDebug+   , unsafeHasNoDebugOutput+   , unsafeHasNoStateHack++   , global+   , consIORef+   , globalM+   , sharedGlobal+   , sharedGlobalM+   )+where++#include "HsVersions.h"++import GHC.Prelude++import GHC.Conc.Sync ( sharedCAF )++import System.IO.Unsafe+import Data.IORef+import Foreign (Ptr)+++--------------------------------------------------------------------------+-- Do not use global variables!+--+-- Global variables are a hack. Do not use them if you can help it.++#if GHC_STAGE < 2++GLOBAL_VAR(v_unsafeHasPprDebug,      False, Bool)+GLOBAL_VAR(v_unsafeHasNoDebugOutput, False, Bool)+GLOBAL_VAR(v_unsafeHasNoStateHack,   False, Bool)++#else+SHARED_GLOBAL_VAR( v_unsafeHasPprDebug+                 , getOrSetLibHSghcGlobalHasPprDebug+                 , "getOrSetLibHSghcGlobalHasPprDebug"+                 , False+                 , Bool )+SHARED_GLOBAL_VAR( v_unsafeHasNoDebugOutput+                 , getOrSetLibHSghcGlobalHasNoDebugOutput+                 , "getOrSetLibHSghcGlobalHasNoDebugOutput"+                 , False+                 , Bool )+SHARED_GLOBAL_VAR( v_unsafeHasNoStateHack+                 , getOrSetLibHSghcGlobalHasNoStateHack+                 , "getOrSetLibHSghcGlobalHasNoStateHack"+                 , False+                 , Bool )+#endif++unsafeHasPprDebug :: Bool+unsafeHasPprDebug = unsafePerformIO $ readIORef v_unsafeHasPprDebug++unsafeHasNoDebugOutput :: Bool+unsafeHasNoDebugOutput = unsafePerformIO $ readIORef v_unsafeHasNoDebugOutput++unsafeHasNoStateHack :: Bool+unsafeHasNoStateHack = unsafePerformIO $ readIORef v_unsafeHasNoStateHack++{-+************************************************************************+*                                                                      *+                        Globals and the RTS+*                                                                      *+************************************************************************++When a plugin is loaded, it currently gets linked against a *newly+loaded* copy of the GHC package. This would not be a problem, except+that the new copy has its own mutable state that is not shared with+that state that has already been initialized by the original GHC+package.++(Note that if the GHC executable was dynamically linked this+wouldn't be a problem, because we could share the GHC library it+links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.)++The solution is to make use of @sharedCAF@ through @sharedGlobal@+for globals that are shared between multiple copies of ghc packages.+-}++-- Global variables:++global :: a -> IORef a+global a = unsafePerformIO (newIORef a)++consIORef :: IORef [a] -> a -> IO ()+consIORef var x =+  atomicModifyIORef' var (\xs -> (x:xs,()))++globalM :: IO a -> IORef a+globalM ma = unsafePerformIO (ma >>= newIORef)++-- Shared global variables:++sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a+sharedGlobal a get_or_set = unsafePerformIO $+  newIORef a >>= flip sharedCAF get_or_set++sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a+sharedGlobalM ma get_or_set = unsafePerformIO $+  ma >>= newIORef >>= flip sharedCAF get_or_set

+ GHC/Utils/Logger.hs view

@@ -0,0 +1,473 @@+{-# LANGUAGE RankNTypes #-}++-- | Logger+module GHC.Utils.Logger+    ( Logger+    , initLogger+    , HasLogger (..)+    , ContainsLogger (..)+    , LogAction+    , DumpAction+    , TraceAction+    , DumpFormat (..)+    , putLogMsg+    , putDumpMsg+    , putTraceMsg++    -- * Hooks+    , popLogHook+    , pushLogHook+    , popDumpHook+    , pushDumpHook+    , popTraceHook+    , pushTraceHook+    , makeThreadSafe++    -- * Logging+    , jsonLogAction+    , defaultLogAction+    , defaultLogActionHPrintDoc+    , defaultLogActionHPutStrDoc++    -- * Dumping+    , defaultDumpAction+    , withDumpFileHandle+    , touchDumpFile+    , dumpIfSet+    , dumpIfSet_dyn+    , dumpIfSet_dyn_printer++    -- * Tracing+    , defaultTraceAction+    )+where++import GHC.Prelude+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Types.Error+import GHC.Types.SrcLoc++import qualified GHC.Utils.Ppr as Pretty+import GHC.Utils.Outputable+import GHC.Utils.Json+import GHC.Utils.Panic++import Data.IORef+import System.Directory+import System.FilePath  ( takeDirectory, (</>) )+import qualified Data.Set as Set+import Data.Set (Set)+import Data.List (intercalate, stripPrefix)+import Data.Time+import System.IO+import Control.Monad+import Control.Concurrent.MVar+import System.IO.Unsafe++type LogAction = DynFlags+              -> WarnReason+              -> Severity+              -> SrcSpan+              -> SDoc+              -> IO ()++type DumpAction = DynFlags+               -> PprStyle+               -> DumpFlag+               -> String+               -> DumpFormat+               -> SDoc+               -> IO ()++type TraceAction a = DynFlags -> String -> SDoc -> a -> a++-- | Format of a dump+--+-- Dump formats are loosely defined: dumps may contain various additional+-- headers and annotations and they may be partial. 'DumpFormat' is mainly a hint+-- (e.g. for syntax highlighters).+data DumpFormat+   = FormatHaskell   -- ^ Haskell+   | FormatCore      -- ^ Core+   | FormatSTG       -- ^ STG+   | FormatByteCode  -- ^ ByteCode+   | FormatCMM       -- ^ Cmm+   | FormatASM       -- ^ Assembly code+   | FormatC         -- ^ C code/header+   | FormatLLVM      -- ^ LLVM bytecode+   | FormatText      -- ^ Unstructured dump+   deriving (Show,Eq)++type DumpCache = IORef (Set FilePath)++data Logger = Logger+    { log_hook   :: [LogAction -> LogAction]+        -- ^ Log hooks stack++    , dump_hook  :: [DumpAction -> DumpAction]+        -- ^ Dump hooks stack++    , trace_hook :: forall a. [TraceAction a -> TraceAction a]+        -- ^ Trace hooks stack++    , generated_dumps :: DumpCache+        -- ^ Already dumped files (to append instead of overwriting them)+    }++initLogger :: IO Logger+initLogger = do+    dumps <- newIORef Set.empty+    return $ Logger+        { log_hook        = []+        , dump_hook       = []+        , trace_hook      = []+        , generated_dumps = dumps+        }++-- | Log something+putLogMsg :: Logger -> LogAction+putLogMsg logger = foldr ($) defaultLogAction (log_hook logger)++-- | Dump something+putDumpMsg :: Logger -> DumpAction+putDumpMsg logger =+    let+        fallback = putLogMsg logger+        dumps    = generated_dumps logger+        deflt    = defaultDumpAction dumps fallback+    in foldr ($) deflt (dump_hook logger)++-- | Trace something+putTraceMsg :: Logger -> TraceAction a+putTraceMsg logger = foldr ($) defaultTraceAction (trace_hook logger)+++-- | Push a log hook+pushLogHook :: (LogAction -> LogAction) -> Logger -> Logger+pushLogHook h logger = logger { log_hook = h:log_hook logger }++-- | Pop a log hook+popLogHook :: Logger -> Logger+popLogHook logger = case log_hook logger of+    []   -> panic "popLogHook: empty hook stack"+    _:hs -> logger { log_hook = hs }++-- | Push a dump hook+pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger+pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }++-- | Pop a dump hook+popDumpHook :: Logger -> Logger+popDumpHook logger = case dump_hook logger of+    []   -> panic "popDumpHook: empty hook stack"+    _:hs -> logger { dump_hook = hs }++-- | Push a trace hook+pushTraceHook :: (forall a. TraceAction a -> TraceAction a) -> Logger -> Logger+pushTraceHook h logger = logger { trace_hook = h:trace_hook logger }++-- | Pop a trace hook+popTraceHook :: Logger -> Logger+popTraceHook logger = case trace_hook logger of+    [] -> panic "popTraceHook: empty hook stack"+    _  -> logger { trace_hook = tail (trace_hook logger) }++-- | Make the logger thread-safe+makeThreadSafe :: Logger -> IO Logger+makeThreadSafe logger = do+    lock <- newMVar ()+    let+        with_lock :: forall a. IO a -> IO a+        with_lock act = withMVar lock (const act)++        log action dflags reason sev loc doc =+            with_lock (action dflags reason sev loc doc)++        dmp action dflags sty opts str fmt doc =+            with_lock (action dflags sty opts str fmt doc)++        trc :: forall a. TraceAction a -> TraceAction a+        trc action dflags str doc v =+            unsafePerformIO (with_lock (return $! action dflags str doc v))++    return $ pushLogHook log+           $ pushDumpHook dmp+           $ pushTraceHook trc+           $ logger++-- See Note [JSON Error Messages]+--+jsonLogAction :: LogAction+jsonLogAction dflags reason severity srcSpan msg+  =+    defaultLogActionHPutStrDoc dflags True stdout+      (withPprStyle (PprCode CStyle) (doc $$ text ""))+    where+      str = renderWithContext (initSDocContext dflags defaultUserStyle) msg+      doc = renderJSON $+              JSObject [ ( "span", json srcSpan )+                       , ( "doc" , JSString str )+                       , ( "severity", json severity )+                       , ( "reason" ,   json reason )+                       ]+++defaultLogAction :: LogAction+defaultLogAction dflags reason severity srcSpan msg+  | dopt Opt_D_dump_json dflags = jsonLogAction dflags reason severity srcSpan msg+  | otherwise = case severity of+      SevOutput      -> printOut msg+      SevDump        -> printOut (msg $$ blankLine)+      SevInteractive -> putStrSDoc msg+      SevInfo        -> printErrs msg+      SevFatal       -> printErrs msg+      SevWarning     -> printWarns+      SevError       -> printWarns+    where+      printOut   = defaultLogActionHPrintDoc  dflags False stdout+      printErrs  = defaultLogActionHPrintDoc  dflags False stderr+      putStrSDoc = defaultLogActionHPutStrDoc dflags False stdout+      -- Pretty print the warning flag, if any (#10752)+      message = mkLocMessageAnn flagMsg severity srcSpan msg++      printWarns = do+        hPutChar stderr '\n'+        caretDiagnostic <-+            if gopt Opt_DiagnosticsShowCaret dflags+            then getCaretDiagnostic severity srcSpan+            else pure empty+        printErrs $ getPprStyle $ \style ->+          withPprStyle (setStyleColoured True style)+            (message $+$ caretDiagnostic)+        -- careful (#2302): printErrs prints in UTF-8,+        -- whereas converting to string first and using+        -- hPutStr would just emit the low 8 bits of+        -- each unicode char.++      flagMsg =+        case reason of+          NoReason -> Nothing+          Reason wflag -> do+            spec <- flagSpecOf wflag+            return ("-W" ++ flagSpecName spec ++ warnFlagGrp wflag)+          ErrReason Nothing ->+            return "-Werror"+          ErrReason (Just wflag) -> do+            spec <- flagSpecOf wflag+            return $+              "-W" ++ flagSpecName spec ++ warnFlagGrp wflag +++              ", -Werror=" ++ flagSpecName spec++      warnFlagGrp flag+          | gopt Opt_ShowWarnGroups dflags =+                case smallestGroups flag of+                    [] -> ""+                    groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")"+          | otherwise = ""++-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline.+defaultLogActionHPrintDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPrintDoc dflags asciiSpace h d+ = defaultLogActionHPutStrDoc dflags asciiSpace h (d $$ text "")++-- | The boolean arguments let's the pretty printer know if it can optimize indent+-- by writing ascii ' ' characters without going through decoding.+defaultLogActionHPutStrDoc :: DynFlags -> Bool -> Handle -> SDoc -> IO ()+defaultLogActionHPutStrDoc dflags asciiSpace h d+  -- Don't add a newline at the end, so that successive+  -- calls to this log-action can output all on the same line+  = printSDoc ctx (Pretty.PageMode asciiSpace) h d+    where+      ctx = initSDocContext dflags defaultUserStyle++--+-- Note [JSON Error Messages]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- When the user requests the compiler output to be dumped as json+-- we used to collect them all in an IORef and then print them at the end.+-- This doesn't work very well with GHCi. (See #14078) So instead we now+-- use the simpler method of just outputting a JSON document inplace to+-- stdout.+--+-- Before the compiler calls log_action, it has already turned the `ErrMsg`+-- into a formatted message. This means that we lose some possible+-- information to provide to the user but refactoring log_action is quite+-- invasive as it is called in many places. So, for now I left it alone+-- and we can refine its behaviour as users request different output.++-- | Default action for 'dumpAction' hook+defaultDumpAction :: DumpCache -> LogAction -> DumpAction+defaultDumpAction dumps log_action dflags sty flag title _fmt doc =+  dumpSDocWithStyle dumps log_action sty dflags flag title doc++-- | Write out a dump.+--+-- If --dump-to-file is set then this goes to a file.+-- otherwise emit to stdout (via the the LogAction parameter).+--+-- When @hdr@ is empty, we print in a more compact format (no separators and+-- blank lines)+dumpSDocWithStyle :: DumpCache -> LogAction -> PprStyle -> DynFlags -> DumpFlag -> String -> SDoc -> IO ()+dumpSDocWithStyle dumps log_action sty dflags flag hdr doc =+    withDumpFileHandle dumps dflags flag writeDump+  where+    -- write dump to file+    writeDump (Just handle) = do+        doc' <- if null hdr+                then return doc+                else do t <- getCurrentTime+                        let timeStamp = if (gopt Opt_SuppressTimestamps dflags)+                                          then empty+                                          else text (show t)+                        let d = timeStamp+                                $$ blankLine+                                $$ doc+                        return $ mkDumpDoc hdr d+        -- When we dump to files we use UTF8. Which allows ascii spaces.+        defaultLogActionHPrintDoc dflags True handle (withPprStyle sty doc')++    -- write the dump to stdout+    writeDump Nothing = do+        let (doc', severity)+              | null hdr  = (doc, SevOutput)+              | otherwise = (mkDumpDoc hdr doc, SevDump)+        log_action dflags NoReason severity noSrcSpan (withPprStyle sty doc')+++-- | Run an action with the handle of a 'DumpFlag' if we are outputting to a+-- file, otherwise 'Nothing'.+withDumpFileHandle :: DumpCache -> DynFlags -> DumpFlag -> (Maybe Handle -> IO ()) -> IO ()+withDumpFileHandle dumps dflags flag action = do+    let mFile = chooseDumpFile dflags flag+    case mFile of+      Just fileName -> do+        gd <- readIORef dumps+        let append = Set.member fileName gd+            mode = if append then AppendMode else WriteMode+        unless append $+            writeIORef dumps (Set.insert fileName gd)+        createDirectoryIfMissing True (takeDirectory fileName)+        withFile fileName mode $ \handle -> do+            -- We do not want the dump file to be affected by+            -- environment variables, but instead to always use+            -- UTF8. See:+            -- https://gitlab.haskell.org/ghc/ghc/issues/10762+            hSetEncoding handle utf8++            action (Just handle)+      Nothing -> action Nothing++-- | Choose where to put a dump file based on DynFlags and DumpFlag+chooseDumpFile :: DynFlags -> DumpFlag -> Maybe FilePath+chooseDumpFile dflags flag+    | gopt Opt_DumpToFile dflags || forced_to_file+    , Just prefix <- getPrefix+    = Just $ setDir (prefix ++ dump_suffix)++    | otherwise+    = Nothing+  where+    (forced_to_file, dump_suffix) = case flag of+        -- -dth-dec-file dumps expansions of TH+        -- splices into MODULE.th.hs even when+        -- -ddump-to-file isn't set+        Opt_D_th_dec_file -> (True, "th.hs")+        _                 -> (False, default_suffix)++    -- build a suffix from the flag name+    -- e.g. -ddump-asm => ".dump-asm"+    default_suffix = map (\c -> if c == '_' then '-' else c) $+      let str = show flag+      in case stripPrefix "Opt_D_" str of+        Just x  -> x+        Nothing -> panic ("chooseDumpFile: bad flag name: " ++ str)++    getPrefix+         -- dump file location is being forced+         --      by the --ddump-file-prefix flag.+       | Just prefix <- dumpPrefixForce dflags+          = Just prefix+         -- dump file location chosen by GHC.Driver.Pipeline.runPipeline+       | Just prefix <- dumpPrefix dflags+          = Just prefix+         -- we haven't got a place to put a dump file.+       | otherwise+          = Nothing+    setDir f = case dumpDir dflags of+                 Just d  -> d </> f+                 Nothing ->       f++-- | This is a helper for 'dumpIfSet' to ensure that it's not duplicated+-- despite the fact that 'dumpIfSet' has an @INLINE@.+doDump :: Logger -> DynFlags -> String -> SDoc -> IO ()+doDump logger dflags hdr doc =+  putLogMsg logger dflags+            NoReason+            SevDump+            noSrcSpan+            (withPprStyle defaultDumpStyle+              (mkDumpDoc hdr doc))++mkDumpDoc :: String -> SDoc -> SDoc+mkDumpDoc hdr doc+   = vcat [blankLine,+           line <+> text hdr <+> line,+           doc,+           blankLine]+     where+        line = text "===================="+++dumpIfSet :: Logger -> DynFlags -> Bool -> String -> SDoc -> IO ()+dumpIfSet logger dflags flag hdr doc+  | not flag   = return ()+  | otherwise  = doDump logger dflags hdr doc+{-# INLINE dumpIfSet #-}  -- see Note [INLINE conditional tracing utilities]++-- | A wrapper around 'dumpAction'.+-- First check whether the dump flag is set+-- Do nothing if it is unset+dumpIfSet_dyn :: Logger -> DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()+dumpIfSet_dyn = dumpIfSet_dyn_printer alwaysQualify+{-# INLINE dumpIfSet_dyn #-}  -- see Note [INLINE conditional tracing utilities]++-- | A wrapper around 'putDumpMsg'.+-- First check whether the dump flag is set+-- Do nothing if it is unset+--+-- Unlike 'dumpIfSet_dyn', has a printer argument+dumpIfSet_dyn_printer+    :: PrintUnqualified+    -> Logger+    -> DynFlags+    -> DumpFlag+    -> String+    -> DumpFormat+    -> SDoc+    -> IO ()+dumpIfSet_dyn_printer printer logger dflags flag hdr fmt doc+  = when (dopt flag dflags) $ do+      let sty = mkDumpStyle printer+      putDumpMsg logger dflags sty flag hdr fmt doc+{-# INLINE dumpIfSet_dyn_printer #-}  -- see Note [INLINE conditional tracing utilities]++-- | Ensure that a dump file is created even if it stays empty+touchDumpFile :: Logger -> DynFlags -> DumpFlag -> IO ()+touchDumpFile logger dflags flag =+    withDumpFileHandle (generated_dumps logger) dflags flag (const (return ()))+++-- | Default action for 'traceAction' hook+defaultTraceAction :: TraceAction a+defaultTraceAction dflags title doc = pprTraceWithFlags dflags title doc++++class HasLogger m where+    getLogger :: m Logger++class ContainsLogger t where+    extractLogger :: t -> Logger+

GHC/Utils/Misc.hs view

@@ -6,6 +6,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MagicHash #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -35,7 +36,7 @@          dropWhileEndLE, spanEnd, last2, lastMaybe, -        foldl1', foldl2, count, countWhile, all2,+        List.foldl1', foldl2, count, countWhile, all2,          lengthExceeds, lengthIs, lengthIsNot,         lengthAtLeast, lengthAtMost, lengthLessThan,@@ -98,7 +99,9 @@          -- * Floating point         readRational,+        readSignificandExponentPair,         readHexRational,+        readHexSignificandExponentPair,          -- * IO-ish utilities         doesDirNameExist,@@ -106,9 +109,6 @@         modificationTimeIfExists,         withAtomicRename, -        global, consIORef, globalM,-        sharedGlobal, sharedGlobalM,-         -- * Filenames and paths         Suffix,         splitLongestPrefix,@@ -142,9 +142,7 @@ import GHC.Utils.Panic.Plain  import Data.Data-import Data.IORef       ( IORef, newIORef, atomicModifyIORef' )-import System.IO.Unsafe ( unsafePerformIO )-import Data.List        hiding (group)+import qualified Data.List as List import Data.List.NonEmpty  ( NonEmpty(..) )  import GHC.Exts@@ -153,7 +151,6 @@ import Control.Applicative ( liftA2 ) import Control.Monad    ( liftM, guard ) import Control.Monad.IO.Class ( MonadIO, liftIO )-import GHC.Conc.Sync ( sharedCAF ) import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, getModificationTime, renameFile ) import System.FilePath@@ -163,7 +160,6 @@ import Data.Int import Data.Ratio       ( (%) ) import Data.Ord         ( comparing )-import Data.Bits import Data.Word import qualified Data.IntMap as IM import qualified Data.Set as Set@@ -171,7 +167,8 @@ import Data.Time  #if defined(DEBUG)-import {-# SOURCE #-} GHC.Utils.Outputable ( warnPprTrace, text )+import {-# SOURCE #-} GHC.Utils.Outputable ( text )+import {-# SOURCE #-} GHC.Driver.Ppr ( warnPprTrace ) #endif  infixr 9 `thenCmp`@@ -234,7 +231,7 @@ applyWhen True f x = f x applyWhen _    _ x = x --- | A for loop: Compose a function with itself n times.  (nth rather than twice)+-- | Apply a function @n@ times to a given value. nTimes :: Int -> (a -> a) -> (a -> a) nTimes 0 _ = id nTimes 1 f = f@@ -318,7 +315,7 @@ zipEqual      _ = zip zipWithEqual  _ = zipWith zipWith3Equal _ = zipWith3-zipWith4Equal _ = zipWith4+zipWith4Equal _ = List.zipWith4 #else zipEqual _   []     []     = [] zipEqual msg (a:as) (b:bs) = (a,b) : zipEqual msg as bs@@ -554,9 +551,8 @@ isSingleton [_] = True isSingleton _   = False -notNull :: [a] -> Bool-notNull [] = False-notNull _  = True+notNull :: Foldable f => f a -> Bool+notNull = not . null  only :: [a] -> a #if defined(DEBUG)@@ -774,17 +770,23 @@ dropList (_:xs) (_:ys) = dropList xs ys  +-- | Given two lists xs and ys, return `splitAt (length xs) ys`. splitAtList :: [b] -> [a] -> ([a], [a])-splitAtList [] xs     = ([], xs)-splitAtList _ xs@[]   = (xs, xs)-splitAtList (_:xs) (y:ys) = (y:ys', ys'')-    where-      (ys', ys'') = splitAtList xs ys+splitAtList xs ys = go 0# xs ys+   where+      -- we are careful to avoid allocating when there are no leftover+      -- arguments: in this case we can return "ys" directly (cf #18535)+      --+      -- We make `xs` strict because in the general case `ys` isn't `[]` so we+      -- will have to evaluate `xs` anyway.+      go _  !_     []     = (ys, [])             -- length ys <= length xs+      go n  []     bs     = (take (I# n) ys, bs) -- = splitAt n ys+      go n  (_:as) (_:bs) = go (n +# 1#) as bs  -- drop from the end of a list dropTail :: Int -> [a] -> [a] -- Specification: dropTail n = reverse . drop n . reverse--- Better implemention due to Joachim Breitner+-- Better implementation due to Joachim Breitner -- http://www.joachim-breitner.de/blog/archives/600-On-taking-the-last-n-elements-of-a-list.html dropTail n xs   = go (drop n xs) xs@@ -818,7 +820,7 @@ -- | Get the last two elements in a list. Partial! {-# INLINE last2 #-} last2 :: [a] -> (a,a)-last2 = foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError)+last2 = List.foldl' (\(_,x2) x -> (x2,x)) (partialError,partialError)   where     partialError = panic "last2 - list length less than two" @@ -947,7 +949,7 @@ restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2   | [] <- str1 = n   | otherwise  = extractAnswer $-                 foldl' (restrictedDamerauLevenshteinDistanceWorker+                 List.foldl' (restrictedDamerauLevenshteinDistanceWorker                              (matchVectors str1) top_bit_mask vector_mask)                         (0, 0, m_ones, 0, m) str2   where@@ -986,7 +988,7 @@ sizedComplement vector_mask vect = vector_mask `xor` vect  matchVectors :: (Bits bv, Num bv) => String -> IM.IntMap bv-matchVectors = snd . foldl' go (0 :: Int, IM.empty)+matchVectors = snd . List.foldl' go (0 :: Int, IM.empty)   where     go (ix, im) char = let ix' = ix + 1                            im' = IM.insertWith (.|.) (ord char) (2 ^ ix) im@@ -1019,7 +1021,7 @@ -- returning a small number of ranked results fuzzyLookup :: String -> [(String,a)] -> [a] fuzzyLookup user_entered possibilites-  = map fst $ take mAX_RESULTS $ sortBy (comparing snd)+  = map fst $ take mAX_RESULTS $ List.sortBy (comparing snd)     [ (poss_val, distance) | (poss_str, poss_val) <- possibilites                        , let distance = restrictedDamerauLevenshteinDistance                                             poss_str user_entered@@ -1063,49 +1065,7 @@   in     x' : xs' -{--************************************************************************-*                                                                      *-                        Globals and the RTS-*                                                                      *-************************************************************************ -When a plugin is loaded, it currently gets linked against a *newly-loaded* copy of the GHC package. This would not be a problem, except-that the new copy has its own mutable state that is not shared with-that state that has already been initialized by the original GHC-package.--(Note that if the GHC executable was dynamically linked this-wouldn't be a problem, because we could share the GHC library it-links to; this is only a problem if DYNAMIC_GHC_PROGRAMS=NO.)--The solution is to make use of @sharedCAF@ through @sharedGlobal@-for globals that are shared between multiple copies of ghc packages.--}---- Global variables:--global :: a -> IORef a-global a = unsafePerformIO (newIORef a)--consIORef :: IORef [a] -> a -> IO ()-consIORef var x = do-  atomicModifyIORef' var (\xs -> (x:xs,()))--globalM :: IO a -> IORef a-globalM ma = unsafePerformIO (ma >>= newIORef)---- Shared global variables:--sharedGlobal :: a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a-sharedGlobal a get_or_set = unsafePerformIO $-  newIORef a >>= flip sharedCAF get_or_set--sharedGlobalM :: IO a -> (Ptr (IORef a) -> IO (Ptr (IORef a))) -> IORef a-sharedGlobalM ma get_or_set = unsafePerformIO $-  ma >>= newIORef >>= flip sharedCAF get_or_set- -- Module names:  looksLikeModuleName :: String -> Bool@@ -1202,9 +1162,28 @@  readRational__ :: ReadS Rational -- NB: doesn't handle leading "-" readRational__ r = do+      ((i, e), t) <- readSignificandExponentPair__ r+      return ((i%1)*10^^e, t)++readRational :: String -> Rational -- NB: *does* handle a leading "-"+readRational top_s+  = case top_s of+      '-' : xs -> - (read_me xs)+      xs       -> read_me xs+  where+    read_me s+      = case (do { (x,"") <- readRational__ s ; return x }) of+          [x] -> x+          []  -> error ("readRational: no parse:"        ++ top_s)+          _   -> error ("readRational: ambiguous parse:" ++ top_s)+++readSignificandExponentPair__ :: ReadS (Integer, Integer) -- NB: doesn't handle leading "-"+readSignificandExponentPair__ r = do      (n,d,s) <- readFix r      (k,t)   <- readExp s-     return ((n%1)*10^^(k-d), t)+     let pair = (n, toInteger (k - d))+     return (pair, t)  where      readFix r = do         (ds,s)  <- lexDecDigits r@@ -1238,17 +1217,25 @@                | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)                | otherwise =  ([],xs) -readRational :: String -> Rational -- NB: *does* handle a leading "-"-readRational top_s+-- | Parse a string into a significand and exponent.+-- A trivial example might be:+--   ghci> readSignificandExponentPair "1E2"+--   (1,2)+-- In a more complex case we might return a exponent different than that+-- which the user wrote. This is needed in order to use a Integer significand.+--   ghci> readSignificandExponentPair "-1.11E5"+--   (-111,3)+readSignificandExponentPair :: String -> (Integer, Integer) -- NB: *does* handle a leading "-"+readSignificandExponentPair top_s   = case top_s of-      '-' : xs -> - (read_me xs)+      '-' : xs -> let (i, e) = read_me xs in (-i, e)       xs       -> read_me xs   where     read_me s-      = case (do { (x,"") <- readRational__ s ; return x }) of+      = case (do { (x,"") <- readSignificandExponentPair__ s ; return x }) of           [x] -> x-          []  -> error ("readRational: no parse:"        ++ top_s)-          _   -> error ("readRational: ambiguous parse:" ++ top_s)+          []  -> error ("readSignificandExponentPair: no parse:"        ++ top_s)+          _   -> error ("readSignificandExponentPair: ambiguous parse:" ++ top_s)   readHexRational :: String -> Rational@@ -1295,7 +1282,7 @@              (ds,"") | not (null ds) -> Just (steps 10 0 ds)              _ -> Nothing -  steps base n ds = foldl' (step base) n ds+  steps base n ds = List.foldl' (step base) n ds   step  base n d  = base * n + fromIntegral (digitToInt d)    span' _ xs@[]         =  (xs, xs)@@ -1306,6 +1293,73 @@  readHexRational__ _ = Nothing +-- | Parse a string into a significand and exponent according to+-- the "Hexadecimal Floats in Haskell" proposal.+-- A trivial example might be:+--   ghci> readHexSignificandExponentPair "0x1p+1"+--   (1,1)+-- Behaves similar to readSignificandExponentPair but the base is 16+-- and numbers are given in hexadecimal:+--   ghci> readHexSignificandExponentPair "0xAp-4"+--   (10,-4)+--   ghci> readHexSignificandExponentPair "0x1.2p3"+--   (18,-1)+readHexSignificandExponentPair :: String -> (Integer, Integer)+readHexSignificandExponentPair str =+  case str of+    '-' : xs -> let (i, e) = readMe xs in (-i, e)+    xs       -> readMe xs+  where+  readMe as =+    case readHexSignificandExponentPair__ as of+      Just n -> n+      _      -> error ("readHexSignificandExponentPair: no parse:" ++ str)+++readHexSignificandExponentPair__ :: String -> Maybe (Integer, Integer)+readHexSignificandExponentPair__ ('0' : x : rest)+  | x == 'X' || x == 'x' =+  do let (front,rest2) = span' isHexDigit rest+     guard (not (null front))+     let frontNum = steps 16 0 front+     case rest2 of+       '.' : rest3 ->+          do let (back,rest4) = span' isHexDigit rest3+             guard (not (null back))+             let backNum = steps 16 frontNum back+                 exp1    = -4 * length back+             case rest4 of+               p : ps | isExp p -> fmap (mk backNum . (+ exp1)) (getExp ps)+               _ -> return (mk backNum exp1)+       p : ps | isExp p -> fmap (mk frontNum) (getExp ps)+       _ -> Nothing++  where+  isExp p = p == 'p' || p == 'P'++  getExp ('+' : ds) = dec ds+  getExp ('-' : ds) = fmap negate (dec ds)+  getExp ds         = dec ds++  mk :: Integer -> Int -> (Integer, Integer)+  mk n e = (n, fromIntegral e)++  dec cs = case span' isDigit cs of+             (ds,"") | not (null ds) -> Just (steps 10 0 ds)+             _ -> Nothing++  steps base n ds = foldl' (step base) n ds+  step  base n d  = base * n + fromIntegral (digitToInt d)++  span' _ xs@[]         =  (xs, xs)+  span' p xs@(x:xs')+            | x == '_'  = span' p xs'   -- skip "_"  (#14473)+            | p x       =  let (ys,zs) = span' p xs' in (x:ys,zs)+            | otherwise =  ([],xs)++readHexSignificandExponentPair__ _ = Nothing++ ----------------------------------------------------------------------------- -- Verify that the 'dirname' portion of a FilePath exists. --@@ -1322,7 +1376,7 @@ -- check existence & modification time at the same time  modificationTimeIfExists :: FilePath -> IO (Maybe UTCTime)-modificationTimeIfExists f = do+modificationTimeIfExists f =   (do t <- getModificationUTCTime f; return (Just t))         `catchIO` \e -> if isDoesNotExistError e                         then return Nothing

GHC/Utils/Monad.hs view

@@ -11,6 +11,7 @@         , zipWith3M, zipWith3M_, zipWith4M, zipWithAndUnzipM         , mapAndUnzipM, mapAndUnzip3M, mapAndUnzip4M, mapAndUnzip5M         , mapAccumLM+        , liftFstM, liftSndM         , mapSndM         , concatMapM         , mapMaybeM@@ -87,9 +88,7 @@  zipWithAndUnzipM :: Monad m                  => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d])-{-# INLINABLE zipWithAndUnzipM #-}--- See Note [flatten_args performance] in GHC.Tc.Solver.Flatten for why this--- pragma is essential.+{-# INLINABLE zipWithAndUnzipM #-}  -- this allows specialization to a given monad zipWithAndUnzipM f (x:xs) (y:ys)   = do { (c, d) <- f x y        ; (cs, ds) <- zipWithAndUnzipM f xs ys@@ -164,6 +163,12 @@     go []         = return []     go ((a,b):xs) = do { c <- f b; rs <- go xs; return ((a,c):rs) } +liftFstM :: Monad m => (a -> b) -> m (a, r) -> m (b, r)+liftFstM f thing = do { (a,r) <- thing; return (f a, r) }++liftSndM :: Monad m => (a -> b) -> m (r, a) -> m (r, b)+liftSndM f thing = do { (r,a) <- thing; return (r, f a) }+ -- | Monadic version of concatMap concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] concatMapM f xs = liftM concat (mapM f xs)@@ -226,3 +231,186 @@ filterOutM :: (Applicative m) => (a -> m Bool) -> [a] -> m [a] filterOutM p =   foldr (\ x -> liftA2 (\ flg -> if flg then id else (x:)) (p x)) (pure [])++{- Note [The one-shot state monad trick]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Summary: many places in GHC use a state monad, and we really want those+functions to be eta-expanded (#18202).++The problem+~~~~~~~~~~~+Consider+    newtype M a = MkM (State -> (State, a))++    instance Monad M where+       mf >>= k = MkM (\s -> case mf  of MkM f  ->+                             case f s of (s',r) ->+                             case k r of MkM g  ->+                             g s')++    fooM :: Int -> M Int+    fooM x = g y >>= \r -> h r+      where+        y = expensive x++Now suppose you say (repeat 20 (fooM 4)), where+  repeat :: Int -> M Int -> M Int+performs its argument n times.  You would expect (expensive 4) to be+evaluated only once, not 20 times.  So foo should have arity 1 (not 2);+it should look like this (modulo casts)++  fooM x = let y = expensive x in+           \s -> case g y of ...++But creating and then repeating, a monadic computation is rare.  If you+/aren't/ re-using (M a) value, it's /much/ more efficient to make+foo have arity 2, thus:++  fooM x s = case g (expensive x) of ...++Why more efficient?  Because now foo takes its argument both at once,+rather than one at a time, creating a heap-allocated function closure. See+https://www.joachim-breitner.de/blog/763-Faster_Winter_5__Eta-Expanding_ReaderT+for a very good explanation of the issue which led to these optimisations+into GHC.++The trick+~~~~~~~~~+With state monads like M the general case is that we *aren't* reusing+(M a) values so it is much more efficient to avoid allocating a+function closure for them. So the state monad trick is a way to keep+the monadic syntax but to make GHC eta-expand functions like `fooM`.+To do that we use the "oneShot" magic function.++Here is the trick:+  * Define a "smart constructor"+       mkM :: (State -> (State,a)) -> M a+       mkM f = MkM (oneShot m)++  * Never call MkM directly, as a constructor.  Instead, always call mkM.++And that's it!  The magic 'oneShot' function does this transformation:+   oneShot (\s. e)  ==>   \s{os}. e+which pins a one-shot flag {os} onto the binder 's'.  That tells GHC+that it can assume the lambda is called only once, and thus can freely+float computations in and out of the lambda.++To be concrete, let's see what happens to fooM:++ fooM = \x. g (expensive x) >>= \r -> h r+      = \x. let mf = g (expensive x)+                k  = \r -> h r+            in MkM (oneShot (\s -> case mf  of MkM' f  ->+                                   case f s of (s',r) ->+                                   case k r of MkM' g  ->+                                   g s'))+      -- The MkM' are just newtype casts nt_co+      = \x. let mf = g (expensive x)+                k  = \r -> h r+            in (\s{os}. case (mf |> nt_co) s of (s',r) ->+                        (k r) |> nt_co s')+               |> sym nt_co++      -- Crucial step: float let-bindings into that \s{os}+      = \x. (\s{os}. case (g (expensive x) |> nt_co) s of (s',r) ->+                     h r |> nt_co s')+            |> sym nt_co++and voila! fooM has arity 2.++The trick is very similar to the built-in "state hack"+(see Note [The state-transformer hack] in "GHC.Core.Opt.Arity") but is+applicable on a monad-by-monad basis under programmer control.++Using pattern synonyms+~~~~~~~~~~~~~~~~~~~~~~+Using a smart constructor is fine, but there is no way to check that we+have found *all* uses, especially if the uses escape a single module.+A neat (but more sophisticated) alternative is to use pattern synonyms:++   -- We rename the existing constructor.+   newtype M a = MkM' (State -> (State, a))++   -- The pattern has the old constructor name.+   pattern MkM f <- MkM' f+      where+        MkM f = MkM' (oneShot f)++Now we can simply grep to check that there are no uses of MkM'+/anywhere/, to guarantee that we have not missed any.  (Using the+smart constructor alone we still need the data constructor in+patterns.)  That's the advantage of the pattern-synonym approach, but+it is more elaborate.++The pattern synonym approach is due to Sebastian Graaf (#18238)++Do note that for monads for multiple arguments more than one oneShot+function might be required. For example in FCode we use:++    newtype FCode a = FCode' { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }++    pattern FCode :: (CgInfoDownwards -> CgState -> (a, CgState))+                  -> FCode a+    pattern FCode m <- FCode' m+      where+        FCode m = FCode' $ oneShot (\cgInfoDown -> oneShot (\state ->m cgInfoDown state))++Derived instances+~~~~~~~~~~~~~~~~~+One caveat of both approaches is that derived instances don't use the smart+constructor /or/ the pattern synonym. So they won't benefit from the automatic+insertion of "oneShot".++   data M a = MkM' (State -> (State,a))+            deriving (Functor) <-- Functor implementation will use MkM'!++Conclusion: don't use 'derviving' in these cases.++Multi-shot actions (cf #18238)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Sometimes we really *do* want computations to be shared! Remember our+example (repeat 20 (fooM 4)). See Note [multiShotIO] in GHC.Types.Unique.Supply++We can force fooM to have arity 1 using multiShot:++    fooM :: Int -> M Int+    fooM x = multiShotM (g y >>= \r -> h r)+      where+        y = expensive x++    multiShotM :: M a -> M a+    {-# INLINE multiShotM #-}+    multiShotM (MkM m) = MkM (\s -> inline m s)+         -- Really uses the data constructor,+         -- not the smart constructor!++Now we can see how fooM optimises (ignoring casts)++   multiShotM (g y >>= \r -> h r)+   ==> {inline (>>=)}+       multiShotM (\s{os}. case g y s of ...)+   ==> {inline multiShotM}+       let m = \s{os}. case g y s of ...+       in \s. inline m s+   ==> {inline m}+       \s. (\s{os}. case g y s of ...) s+   ==> \s. case g y s of ...++and voila! the one-shot flag has gone.  It's possible that y has been+replaced by (expensive x), but full laziness should pull it back out.+(This part seems less robust.)++The magic `inline` function does two things+* It prevents eta reduction.  If we wrote just+      multiShotIO (IO m) = IO (\s -> m s)+  the lamda would eta-reduce to 'm' and all would be lost.++* It helps ensure that 'm' really does inline.++Note that 'inline' evaporates in phase 0.  See Note [inlineIdMagic]+in GHC.Core.Opt.ConstantFold.match_inline.++The INLINE pragma on multiShotM is very important, else the+'inline' call will evaporate when compiling the module that+defines 'multiShotM', before it is ever exported.+-}

GHC/Utils/Outputable.hs view

@@ -1,4 +1,10 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}  {- (c) The University of Glasgow 2006-2012@@ -13,12 +19,12 @@ -- and works over the 'SDoc' type. module GHC.Utils.Outputable (         -- * Type classes-        Outputable(..), OutputableBndr(..),+        Outputable(..), OutputableBndr(..), OutputableP(..),          -- * Pretty printing combinators-        SDoc, runSDoc, initSDocContext,+        SDoc, runSDoc, PDoc(..),         docToSDoc,-        interppSP, interpp'SP,+        interppSP, interpp'SP, interpp'SP',         pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor,         pprWithBars,         empty, isEmpty, nest,@@ -29,6 +35,7 @@         doubleQuotes, angleBrackets,         semi, comma, colon, dcolon, space, equals, dot, vbar,         arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,+        lambda,         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow,         blankLine, forAllLit, bullet,         (<>), (<+>), hcat, hsep,@@ -43,37 +50,45 @@         coloured, keyword,          -- * Converting 'SDoc' into strings and outputting it-        printSDoc, printSDocLn, printForUser,-        printForC, bufLeftRenderSDoc,-        pprCode, mkCodeStyle,-        showSDoc, showSDocUnsafe, showSDocOneLine,-        showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,-        showSDocUnqual, showPpr,-        renderWithStyle,+        printSDoc, printSDocLn,+        bufLeftRenderSDoc,+        pprCode,+        showSDocUnsafe,+        showPprUnsafe,+        showSDocOneLine,+        renderWithContext,          pprInfixVar, pprPrefixVar,         pprHsChar, pprHsString, pprHsBytes, -        primFloatSuffix, primCharSuffix, primWordSuffix, primDoubleSuffix,-        primInt64Suffix, primWord64Suffix, primIntSuffix,+        primFloatSuffix, primCharSuffix, primDoubleSuffix,+        primInt8Suffix, primWord8Suffix,+        primInt16Suffix, primWord16Suffix,+        primInt32Suffix, primWord32Suffix,+        primInt64Suffix, primWord64Suffix,+        primIntSuffix, primWordSuffix, -        pprPrimChar, pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64,+        pprPrimChar, pprPrimInt, pprPrimWord,+        pprPrimInt8, pprPrimWord8,+        pprPrimInt16, pprPrimWord16,+        pprPrimInt32, pprPrimWord32,+        pprPrimInt64, pprPrimWord64,          pprFastFilePath, pprFilePathString,          -- * Controlling the style in which output is printed         BindingSite(..), -        PprStyle(..), CodeStyle(..), PrintUnqualified(..),+        PprStyle(..), LabelStyle(..), PrintUnqualified(..),         QueryQualifyName, QueryQualifyModule, QueryQualifyPackage,         reallyAlwaysQualify, reallyAlwaysQualifyNames,         alwaysQualify, alwaysQualifyNames, alwaysQualifyModules,         neverQualify, neverQualifyNames, neverQualifyModules,         alwaysQualifyPackages, neverQualifyPackages,         QualifyName(..), queryQual,-        sdocWithDynFlags, sdocOption,+        sdocOption,         updSDocContext,-        SDocContext (..), sdocWithContext,+        SDocContext (..), sdocWithContext, defaultSDocContext,         getPprStyle, withPprStyle, setStyleColoured,         pprDeeper, pprDeeperList, pprSetDepth,         codeStyle, userStyle, dumpStyle, asmStyle,@@ -84,20 +99,10 @@          ifPprDebug, whenPprDebug, getPprDebug, -        -- * Error handling and debugging utilities-        pprPanic, pprSorry, assertPprPanic, pprPgmError,-        pprTrace, pprTraceDebug, pprTraceWith, pprTraceIt, warnPprTrace,-        pprSTrace, pprTraceException, pprTraceM, pprTraceWithFlags,-        trace, pgmError, panic, sorry, assertPanic,-        pprDebugAndThen, callStackDoc,     ) where  import GHC.Prelude -import {-# SOURCE #-}   GHC.Driver.Session-                           ( DynFlags, hasPprDebug, hasNoDebugOutput-                           , unsafeGlobalDynFlags, initSDocContext-                           ) import {-# SOURCE #-}   GHC.Unit.Types ( Unit, Module, moduleName ) import {-# SOURCE #-}   GHC.Unit.Module.Name( ModuleName ) import {-# SOURCE #-}   GHC.Types.Name.Occurrence( OccName )@@ -105,10 +110,8 @@ import GHC.Utils.BufHandle (BufHandle) import GHC.Data.FastString import qualified GHC.Utils.Ppr as Pretty-import GHC.Utils.Misc import qualified GHC.Utils.Ppr.Colour as Col import GHC.Utils.Ppr       ( Doc, Mode(..) )-import GHC.Utils.Panic import GHC.Serialized import GHC.LanguageExtensions (Extension) @@ -120,6 +123,7 @@ import qualified Data.IntMap as IM import Data.Set (Set) import qualified Data.Set as Set+import qualified Data.IntSet as IntSet import Data.String import Data.Word import System.IO        ( Handle )@@ -133,9 +137,8 @@  import GHC.Fingerprint import GHC.Show         ( showMultiLineString )-import GHC.Stack        ( callStack, prettyCallStack )-import Control.Monad.IO.Class import GHC.Utils.Exception+import GHC.Exts (oneShot)  {- ************************************************************************@@ -158,11 +161,20 @@                 -- Does not assume tidied code: non-external names                 -- are printed with uniques. -  | PprCode CodeStyle-                -- Print code; either C or assembler+  | PprCode LabelStyle -- ^ Print code; either C or assembler -data CodeStyle = CStyle         -- The format of labels differs for C and assembler-               | AsmStyle+-- | Style of label pretty-printing.+--+-- When we produce C sources or headers, we have to take into account that C+-- compilers transform C labels when they convert them into symbols. For+-- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for+-- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style+-- or Asm style.+--+data LabelStyle+   = CStyle   -- ^ C label style (used by C and LLVM backends)+   | AsmStyle -- ^ Asm label style (used by NCG backend)+   deriving (Eq,Ord,Show)  data Depth    = AllTheWay@@ -198,7 +210,7 @@ -- the component id to disambiguate it. type QueryQualifyPackage = Unit -> Bool --- See Note [Printing original names] in GHC.Driver.Types+-- See Note [Printing original names] in GHC.Types.Name.Ppr data QualifyName   -- Given P:M.T   = NameUnqual           -- It's in scope unqualified as "T"                          -- OR nothing called "T" is in scope@@ -317,10 +329,20 @@ -- | Represents a pretty-printable document. -- -- To display an 'SDoc', use 'printSDoc', 'printSDocLn', 'bufLeftRenderSDoc',--- or 'renderWithStyle'.  Avoid calling 'runSDoc' directly as it breaks the+-- or 'renderWithContext'.  Avoid calling 'runSDoc' directly as it breaks the -- abstraction layer.-newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }+newtype SDoc = SDoc' (SDocContext -> Doc) +-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+{-# COMPLETE SDoc #-}+pattern SDoc :: (SDocContext -> Doc) -> SDoc+pattern SDoc m <- SDoc' m+  where+    SDoc m = SDoc' (oneShot m)++runSDoc :: SDoc -> (SDocContext -> Doc)+runSDoc (SDoc m) = m+ data SDocContext = SDC   { sdocStyle                       :: !PprStyle   , sdocColScheme                   :: !Col.Scheme@@ -360,7 +382,19 @@   , sdocLinearTypes                 :: !Bool   , sdocImpredicativeTypes          :: !Bool   , sdocPrintTypeAbbreviations      :: !Bool-  , sdocDynFlags                    :: DynFlags -- TODO: remove+  , sdocUnitIdForUser               :: !(FastString -> SDoc)+      -- ^ Used to map UnitIds to more friendly "package-version:component"+      -- strings while pretty-printing.+      --+      -- Use `GHC.Unit.State.pprWithUnitState` to set it. Users should never+      -- have to set it to pretty-print SDocs emitted by GHC, otherwise it's a+      -- bug. It's an internal field used to thread the UnitState so that the+      -- Outputable instance of UnitId can use it.+      --+      -- See Note [Pretty-printing UnitId] in "GHC.Unit" for more details.+      --+      -- Note that we use `FastString` instead of `UnitId` to avoid boring+      -- module inter-dependency issues.   }  instance IsString SDoc where@@ -370,6 +404,45 @@ instance Outputable SDoc where   ppr = id +-- | Default pretty-printing options+defaultSDocContext :: SDocContext+defaultSDocContext = SDC+  { sdocStyle                       = defaultDumpStyle+  , sdocColScheme                   = Col.defaultScheme+  , sdocLastColour                  = Col.colReset+  , sdocShouldUseColor              = False+  , sdocDefaultDepth                = 5+  , sdocLineLength                  = 100+  , sdocCanUseUnicode               = False+  , sdocHexWordLiterals             = False+  , sdocPprDebug                    = False+  , sdocPrintUnicodeSyntax          = False+  , sdocPrintCaseAsLet              = False+  , sdocPrintTypecheckerElaboration = False+  , sdocPrintAxiomIncomps           = False+  , sdocPrintExplicitKinds          = False+  , sdocPrintExplicitCoercions      = False+  , sdocPrintExplicitRuntimeReps    = False+  , sdocPrintExplicitForalls        = False+  , sdocPrintPotentialInstances     = False+  , sdocPrintEqualityRelations      = False+  , sdocSuppressTicks               = False+  , sdocSuppressTypeSignatures      = False+  , sdocSuppressTypeApplications    = False+  , sdocSuppressIdInfo              = False+  , sdocSuppressCoercions           = False+  , sdocSuppressUnfoldings          = False+  , sdocSuppressVarKinds            = False+  , sdocSuppressUniques             = False+  , sdocSuppressModulePrefixes      = False+  , sdocSuppressStgExts             = False+  , sdocErrorSpans                  = False+  , sdocStarIsType                  = False+  , sdocImpredicativeTypes          = False+  , sdocLinearTypes                 = False+  , sdocPrintTypeAbbreviations      = True+  , sdocUnitIdForUser               = ftext+  }  withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}@@ -416,9 +489,6 @@ getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx -sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc-sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx- sdocWithContext :: (SDocContext -> SDoc) -> SDoc sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx @@ -494,66 +564,18 @@ printSDocLn ctx mode handle doc =   printSDoc ctx mode handle (doc $$ text "") -printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()-printForUser dflags handle unqual depth doc-  = printSDocLn ctx PageMode handle doc-    where ctx = initSDocContext dflags (mkUserStyle unqual depth)---- | Like 'printSDocLn' but specialized with 'LeftMode' and--- @'PprCode' 'CStyle'@.  This is typically used to output C-- code.-printForC :: DynFlags -> Handle -> SDoc -> IO ()-printForC dflags handle doc =-  printSDocLn ctx LeftMode handle doc-  where ctx = initSDocContext dflags (PprCode CStyle)- -- | An efficient variant of 'printSDoc' specialized for 'LeftMode' that -- outputs to a 'BufHandle'. bufLeftRenderSDoc :: SDocContext -> BufHandle -> SDoc -> IO () bufLeftRenderSDoc ctx bufHandle doc =   Pretty.bufLeftRender bufHandle (runSDoc doc ctx) -pprCode :: CodeStyle -> SDoc -> SDoc+pprCode :: LabelStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d -mkCodeStyle :: CodeStyle -> PprStyle-mkCodeStyle = PprCode---- Can't make SDoc an instance of Show because SDoc is just a function type--- However, Doc *is* an instance of Show--- showSDoc just blasts it out as a string-showSDoc :: DynFlags -> SDoc -> String-showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags defaultUserStyle) sdoc---- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be--- initialised yet.-showSDocUnsafe :: SDoc -> String-showSDocUnsafe sdoc = showSDoc unsafeGlobalDynFlags sdoc--showPpr :: Outputable a => DynFlags -> a -> String-showPpr dflags thing = showSDoc dflags (ppr thing)--showSDocUnqual :: DynFlags -> SDoc -> String--- Only used by Haddock-showSDocUnqual dflags sdoc = showSDoc dflags sdoc--showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String--- Allows caller to specify the PrintUnqualified to use-showSDocForUser dflags unqual doc- = renderWithStyle (initSDocContext dflags (mkUserStyle unqual AllTheWay)) doc--showSDocDump :: DynFlags -> SDoc -> String-showSDocDump dflags d = renderWithStyle (initSDocContext dflags defaultDumpStyle) d--showSDocDebug :: DynFlags -> SDoc -> String-showSDocDebug dflags d = renderWithStyle ctx d-   where-      ctx = (initSDocContext dflags defaultDumpStyle)-               { sdocPprDebug = True-               }--renderWithStyle :: SDocContext -> SDoc -> String-renderWithStyle ctx sdoc-  = let s = Pretty.style{ Pretty.mode       = PageMode,+renderWithContext :: SDocContext -> SDoc -> String+renderWithContext ctx sdoc+  = let s = Pretty.style{ Pretty.mode       = PageMode False,                           Pretty.lineLength = sdocLineLength ctx }     in Pretty.renderStyle s $ runSDoc sdoc ctx @@ -567,17 +589,13 @@    Pretty.renderStyle s $       runSDoc d ctx -showSDocDumpOneLine :: DynFlags -> SDoc -> String-showSDocDumpOneLine dflags d- = let s = Pretty.style{ Pretty.mode = OneLineMode,-                         Pretty.lineLength = irrelevantNCols } in-   Pretty.renderStyle s $-      runSDoc d (initSDocContext dflags defaultDumpStyle)+showSDocUnsafe :: SDoc -> String+showSDocUnsafe sdoc = renderWithContext defaultSDocContext sdoc -irrelevantNCols :: Int--- Used for OneLineMode and LeftMode when number of cols isn't used-irrelevantNCols = 1+showPprUnsafe :: Outputable a => a -> String+showPprUnsafe a = renderWithContext defaultSDocContext (ppr a) + isEmpty :: SDocContext -> SDoc -> Bool isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) @@ -642,13 +660,14 @@    False -> SDoc $ \sty ->       let pp_d = runSDoc d sty           str  = show pp_d-      in case (str, lastMaybe str) of-        (_, Just '\'') -> pp_d-        ('\'' : _, _)       -> pp_d-        _other              -> Pretty.quotes pp_d+      in case str of+         []                   -> Pretty.quotes pp_d+         '\'' : _             -> pp_d+         _ | '\'' <- last str -> pp_d+           | otherwise        -> Pretty.quotes pp_d  semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc-arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc+arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, lambda :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc  blankLine  = docToSDoc $ Pretty.text ""@@ -661,6 +680,7 @@ larrowt    = unicodeSyntax (char '⤙') (docToSDoc $ Pretty.text "-<") arrowtt    = unicodeSyntax (char '⤜') (docToSDoc $ Pretty.text ">>-") larrowtt   = unicodeSyntax (char '⤛') (docToSDoc $ Pretty.text "-<<")+lambda     = unicodeSyntax (char 'λ') (char '\\') semi       = docToSDoc $ Pretty.semi comma      = docToSDoc $ Pretty.comma colon      = docToSDoc $ Pretty.colon@@ -797,24 +817,13 @@ keyword :: SDoc -> SDoc keyword = coloured Col.colBold -{--************************************************************************-*                                                                      *-\subsection[Outputable-class]{The @Outputable@ class}-*                                                                      *-************************************************************************--}+-----------------------------------------------------------------------+-- The @Outputable@ class+-----------------------------------------------------------------------  -- | Class designating that some type has an 'SDoc' representation class Outputable a where-        ppr :: a -> SDoc-        pprPrec :: Rational -> a -> SDoc-                -- 0 binds least tightly-                -- We use Rational because there is always a-                -- Rational between any other two Rationals--        ppr = pprPrec 0-        pprPrec _ = ppr+    ppr :: a -> SDoc  instance Outputable Char where     ppr c = text [c]@@ -870,6 +879,9 @@ instance (Outputable a) => Outputable (Set a) where     ppr s = braces (fsep (punctuate comma (map ppr (Set.toList s)))) +instance Outputable IntSet.IntSet where+    ppr s = braces (fsep (punctuate comma (map ppr (IntSet.toList s))))+ instance (Outputable a, Outputable b) => Outputable (a, b) where     ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) @@ -930,8 +942,12 @@     ppr fs = ftext fs           -- Prints an unadorned string,                                 -- no double quotes or anything +deriving newtype instance Outputable NonDetFastString+deriving newtype instance Outputable LexicalFastString+ instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where     ppr m = ppr (M.toList m)+ instance (Outputable elt) => Outputable (IM.IntMap elt) where     ppr m = ppr (IM.toList m) @@ -948,6 +964,144 @@ instance Outputable Extension where     ppr = text . show +-----------------------------------------------------------------------+-- The @OutputableP@ class+-----------------------------------------------------------------------++-- Note [The OutputableP class]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- SDoc has become the common type to+--    * display messages in the terminal+--    * dump outputs (Cmm, Asm, C, etc.)+--    * return messages to ghc-api clients+--+-- SDoc is a kind of state Monad: SDoc ~ State SDocContext Doc+-- I.e. to render a SDoc, a SDocContext must be provided.+--+-- SDocContext contains legit rendering options (e.g., line length, color and+-- unicode settings). Sadly SDocContext ended up also being used to thread+-- values that were considered bothersome to thread otherwise:+--    * current HomeModule: to decide if module names must be printed qualified+--    * current UnitState: to print unit-ids as "packagename-version:component"+--    * target platform: to render labels, instructions, etc.+--    * selected backend: to display CLabel as C labels or Asm labels+--+-- In fact the whole compiler session state that is DynFlags was passed in+-- SDocContext and these values were retrieved from it.+--+-- The Outputable class makes SDoc creation easy for many values by providing+-- the ppr method:+--+--    class Outputable a where+--       ppr :: a -> SDoc+--+-- Almost every type is Outputable in the compiler and it seems great because it+-- is similar to the Show class. But it's a fallacious simplicity because `SDoc`+-- needs a `SDocContext` to be transformed into a renderable `Doc`: who is going+-- to provide the SDocContext with the correct values in it?+--+--    E.g. if a SDoc is returned in an exception, how could we know the home+--    module at the time it was thrown?+--+-- A workaround is to pass dummy values (no home module, empty UnitState) at SDoc+-- rendering time and to hope that the code that produced the SDoc has updated+-- the SDocContext with meaningful values (e.g. using withPprStyle or+-- pprWithUnitState). If the context isn't correctly updated, a dummy value is+-- used and the printed result isn't what we expected. Note that the compiler+-- doesn't help us finding spots where we need to update the SDocContext.+--+-- In some cases we can't pass a dummy value because we can't create one. For+-- example, how can we create a dummy Platform value? In the old days, GHC only+-- supported a single Platform set when it was built, so we could use it without+-- any risk of mistake. But now GHC starts supporting several Platform in the+-- same session so it becomes an issue. We could be tempted to use the+-- workaround described above by using "undefined" as a dummy Platform value.+-- However in this case, if we forget to update it we will get a runtime+-- error/crash. We could use "Maybe Platform" and die with a better error+-- message at places where we really really need to know if we are on Windows or+-- not, or if we use 32- or 64-bit. Still the compiler would not help us in+-- finding spots where to update the context with a valid Platform.+--+-- So finally here comes the OutputableP class:+--+--    class OutputableP env a where+--       pdoc :: env -> a -> SDoc+--+-- OutputableP forces us to thread an environment necessary to print a value.+-- For now we only use it to thread a Platform environment, so we have several+-- "Outputable Platform XYZ" instances. In the future we could imagine using a+-- Has class to retrieve a value from a generic environment to make the code+-- more composable. E.g.:+--+--    instance Has Platform env => OutputableP env XYZ where+--       pdoc env a = ... (getter env :: Platform)+--+-- A drawback of this approach over Outputable is that we have to thread an+-- environment explicitly to use "pdoc" and it's more cumbersome. But it's the+-- price to pay to have some help from the compiler to ensure that we... thread+-- an environment down to the places where we need it, i.e. where SDoc are+-- created (not rendered). On the other hand, it makes life easier for SDoc+-- renderers as they only have to deal with pretty-printing related options in+-- SDocContext.+--+-- TODO:+--+-- 1) we could use OutputableP to thread a UnitState and replace the Outputable+-- instance of UnitId with:+--+--       instance OutputableP UnitState UnitId where ...+--+--    This would allow the removal of the `sdocUnitIdForUser` field.+--+--    Be warned: I've tried to do it, but there are A LOT of other Outputable+--    instances depending on UnitId's one. In particular:+--       UnitId <- Unit <- Module <- Name <- Var <- Core.{Type,Expr} <- ...+--+-- 2) Use it to pass the HomeModule (but I fear it will be as difficult as for+-- UnitId).+--+--++-- | Outputable class with an additional environment value+--+-- See Note [The OutputableP class]+class OutputableP env a where+   pdoc :: env -> a -> SDoc++-- | Wrapper for types having a Outputable instance when an OutputableP instance+-- is required.+newtype PDoc a = PDoc a++instance Outputable a => OutputableP env (PDoc a) where+   pdoc _ (PDoc a) = ppr a++instance OutputableP env a => OutputableP env [a] where+   pdoc env xs = ppr (fmap (pdoc env) xs)++instance OutputableP env a => OutputableP env (Maybe a) where+   pdoc env xs = ppr (fmap (pdoc env) xs)++instance (OutputableP env a, OutputableP env b) => OutputableP env (a, b) where+    pdoc env (a,b) = ppr (pdoc env a, pdoc env b)++instance (OutputableP env a, OutputableP env b, OutputableP env c) => OutputableP env (a, b, c) where+    pdoc env (a,b,c) = ppr (pdoc env a, pdoc env b, pdoc env c)+++instance (OutputableP env key, OutputableP env elt) => OutputableP env (M.Map key elt) where+    pdoc env m = ppr $ fmap (\(x,y) -> (pdoc env x, pdoc env y)) $ M.toList m++instance OutputableP env a => OutputableP env (SCC a) where+   pdoc env scc = ppr (fmap (pdoc env) scc)++instance OutputableP env SDoc where+   pdoc _ x = x++instance (OutputableP env a) => OutputableP env (Set a) where+    pdoc env s = braces (fsep (punctuate comma (map (pdoc env) (Set.toList s))))++ {- ************************************************************************ *                                                                      *@@ -1015,23 +1169,45 @@  -- Postfix modifiers for unboxed literals. -- See Note [Printing of literals in Core] in "GHC.Types.Literal".-primCharSuffix, primFloatSuffix, primIntSuffix :: SDoc-primDoubleSuffix, primWordSuffix, primInt64Suffix, primWord64Suffix :: SDoc+primCharSuffix, primFloatSuffix, primDoubleSuffix,+  primIntSuffix, primWordSuffix,+  primInt8Suffix, primWord8Suffix,+  primInt16Suffix, primWord16Suffix,+  primInt32Suffix, primWord32Suffix,+  primInt64Suffix, primWord64Suffix+  :: SDoc primCharSuffix   = char '#' primFloatSuffix  = char '#' primIntSuffix    = char '#' primDoubleSuffix = text "##" primWordSuffix   = text "##"-primInt64Suffix  = text "L#"-primWord64Suffix = text "L##"+primInt8Suffix   = text "#8"+primWord8Suffix  = text "##8"+primInt16Suffix  = text "#16"+primWord16Suffix = text "##16"+primInt32Suffix  = text "#32"+primWord32Suffix = text "##32"+primInt64Suffix  = text "#64"+primWord64Suffix = text "##64"  -- | Special combinator for showing unboxed literals. pprPrimChar :: Char -> SDoc-pprPrimInt, pprPrimWord, pprPrimInt64, pprPrimWord64 :: Integer -> SDoc+pprPrimInt, pprPrimWord,+  pprPrimInt8, pprPrimWord8,+  pprPrimInt16, pprPrimWord16,+  pprPrimInt32, pprPrimWord32,+  pprPrimInt64, pprPrimWord64+  :: Integer -> SDoc pprPrimChar c   = pprHsChar c <> primCharSuffix pprPrimInt i    = integer i   <> primIntSuffix pprPrimWord w   = word    w   <> primWordSuffix+pprPrimInt8 i   = integer i   <> primInt8Suffix+pprPrimInt16 i  = integer i   <> primInt16Suffix+pprPrimInt32 i  = integer i   <> primInt32Suffix pprPrimInt64 i  = integer i   <> primInt64Suffix+pprPrimWord8 w  = word    w   <> primWord8Suffix+pprPrimWord16 w = word    w   <> primWord16Suffix+pprPrimWord32 w = word    w   <> primWord32Suffix pprPrimWord64 w = word    w   <> primWord64Suffix  ---------------------@@ -1087,8 +1263,11 @@  -- | Returns the comma-separated concatenation of the pretty printed things. interpp'SP :: Outputable a => [a] -> SDoc-interpp'SP xs = sep (punctuate comma (map ppr xs))+interpp'SP xs = interpp'SP' ppr xs +interpp'SP' :: (a -> SDoc) -> [a] -> SDoc+interpp'SP' f xs = sep (punctuate comma (map f xs))+ -- | Returns the comma-separated concatenation of the quoted pretty printed things. -- -- > [x,y,z]  ==>  `x', `y', `z'@@ -1156,8 +1335,8 @@ -- > speakN 5 = text "five" -- > speakN 10 = text "10" speakN :: Int -> SDoc-speakN 0 = text "none"  -- E.g.  "he has none"-speakN 1 = text "one"   -- E.g.  "he has one"+speakN 0 = text "none"  -- E.g.  "they have none"+speakN 1 = text "one"   -- E.g.  "they have one" speakN 2 = text "two" speakN 3 = text "three" speakN 4 = text "four"@@ -1211,96 +1390,3 @@ itsOrTheir :: [a] -> SDoc itsOrTheir [_] = text "its" itsOrTheir _   = text "their"--{--************************************************************************-*                                                                      *-\subsection{Error handling}-*                                                                      *-************************************************************************--}--callStackDoc :: HasCallStack => SDoc-callStackDoc =-    hang (text "Call stack:")-       4 (vcat $ map text $ lines (prettyCallStack callStack))--pprPanic :: HasCallStack => String -> SDoc -> a--- ^ Throw an exception saying "bug in GHC"-pprPanic s doc = panicDoc s (doc $$ callStackDoc)--pprSorry :: String -> SDoc -> a--- ^ Throw an exception saying "this isn't finished yet"-pprSorry    = sorryDoc---pprPgmError :: String -> SDoc -> a--- ^ Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)-pprPgmError = pgmErrorDoc--pprTraceDebug :: String -> SDoc -> a -> a-pprTraceDebug str doc x-   | debugIsOn && hasPprDebug unsafeGlobalDynFlags = pprTrace str doc x-   | otherwise                                     = x---- | If debug output is on, show some 'SDoc' on the screen-pprTrace :: String -> SDoc -> a -> a-pprTrace str doc x = pprTraceWithFlags unsafeGlobalDynFlags str doc x---- | If debug output is on, show some 'SDoc' on the screen-pprTraceWithFlags :: DynFlags -> String -> SDoc -> a -> a-pprTraceWithFlags dflags str doc x-  | hasNoDebugOutput dflags = x-  | otherwise               = pprDebugAndThen dflags trace (text str) doc x--pprTraceM :: Applicative f => String -> SDoc -> f ()-pprTraceM str doc = pprTrace str doc (pure ())---- | @pprTraceWith desc f x@ is equivalent to @pprTrace desc (f x) x@.--- This allows you to print details from the returned value as well as from--- ambient variables.-pprTraceWith :: String -> (a -> SDoc) -> a -> a-pprTraceWith desc f x = pprTrace desc (f x) x---- | @pprTraceIt desc x@ is equivalent to @pprTrace desc (ppr x) x@-pprTraceIt :: Outputable a => String -> a -> a-pprTraceIt desc x = pprTraceWith desc ppr x---- | @pprTraceException desc x action@ runs action, printing a message--- if it throws an exception.-pprTraceException :: ExceptionMonad m => String -> SDoc -> m a -> m a-pprTraceException heading doc =-    handleGhcException $ \exc -> liftIO $ do-        putStrLn $ showSDocDump unsafeGlobalDynFlags (sep [text heading, nest 2 doc])-        throwGhcExceptionIO exc---- | If debug output is on, show some 'SDoc' on the screen along--- with a call stack when available.-pprSTrace :: HasCallStack => SDoc -> a -> a-pprSTrace doc = pprTrace "" (doc $$ callStackDoc)--warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a--- ^ Just warn about an assertion failure, recording the given file and line number.--- Should typically be accessed with the WARN macros-warnPprTrace _     _     _     _    x | not debugIsOn     = x-warnPprTrace _     _file _line _msg x-   | hasNoDebugOutput unsafeGlobalDynFlags = x-warnPprTrace False _file _line _msg x = x-warnPprTrace True   file  line  msg x-  = pprDebugAndThen unsafeGlobalDynFlags trace heading-                    (msg $$ callStackDoc )-                    x-  where-    heading = hsep [text "WARNING: file", text file <> comma, text "line", int line]---- | Panic with an assertion failure, recording the given file and--- line number. Should typically be accessed with the ASSERT family of macros-assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a-assertPprPanic _file _line msg-  = pprPanic "ASSERT failed!" msg--pprDebugAndThen :: DynFlags -> (String -> a) -> SDoc -> SDoc -> a-pprDebugAndThen dflags cont heading pretty_msg- = cont (showSDocDump dflags doc)- where-     doc = sep [heading, nest 2 pretty_msg]

GHC/Utils/Outputable.hs-boot view

@@ -1,14 +1,9 @@ module GHC.Utils.Outputable where  import GHC.Prelude-import GHC.Stack( HasCallStack )  data SDoc data PprStyle data SDocContext--showSDocUnsafe :: SDoc -> String--warnPprTrace :: HasCallStack => Bool -> String -> Int -> SDoc -> a -> a  text :: String -> SDoc

GHC/Utils/Panic.hs view

@@ -10,27 +10,43 @@ -- -- It's hard to put these functions anywhere else without causing -- some unnecessary loops in the module dependency graph.-module GHC.Utils.Panic (-     GhcException(..), showGhcException,-     throwGhcException, throwGhcExceptionIO,-     handleGhcException,-     GHC.Utils.Panic.Plain.progName,-     pgmError,--     panic, sorry, assertPanic, trace,-     panicDoc, sorryDoc, pgmErrorDoc,--     cmdLineError, cmdLineErrorIO,+module GHC.Utils.Panic+   ( GhcException(..)+   , showGhcException+   , showGhcExceptionUnsafe+   , throwGhcException+   , throwGhcExceptionIO+   , handleGhcException -     Exception.Exception(..), showException, safeShowException,-     try, tryMost, throwTo,+   , GHC.Utils.Panic.Plain.progName+   , pgmError+   , panic+   , pprPanic+   , assertPanic+   , assertPprPanic+   , sorry+   , trace+   , panicDoc+   , sorryDoc+   , pgmErrorDoc+   , cmdLineError+   , cmdLineErrorIO+   , callStackDoc -     withSignalHandlers,-) where+   , Exception.Exception(..)+   , showException+   , safeShowException+   , try+   , tryMost+   , throwTo+   , withSignalHandlers+   )+where  import GHC.Prelude+import GHC.Stack -import {-# SOURCE #-} GHC.Utils.Outputable (SDoc, showSDocUnsafe)+import GHC.Utils.Outputable import GHC.Utils.Panic.Plain  import GHC.Utils.Exception as Exception@@ -105,9 +121,9 @@     | otherwise = Nothing  instance Show GhcException where-  showsPrec _ e@(ProgramError _) = showGhcException e-  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcException e-  showsPrec _ e = showString progName . showString ": " . showGhcException e+  showsPrec _ e@(ProgramError _) = showGhcExceptionUnsafe e+  showsPrec _ e@(CmdLineError _) = showString "<command line>: " . showGhcExceptionUnsafe e+  showsPrec _ e = showString progName . showString ": " . showGhcExceptionUnsafe e  -- | Show an exception as a string. showException :: Exception e => e -> String@@ -128,12 +144,14 @@  -- | Append a description of the given exception to this string. ----- Note that this uses 'GHC.Driver.Session.unsafeGlobalDynFlags', which may have some--- uninitialized fields if invoked before 'GHC.initGhcMonad' has been called.--- If the error message to be printed includes a pretty-printer document--- which forces one of these fields this call may bottom.-showGhcException :: GhcException -> ShowS-showGhcException = showPlainGhcException . \case+-- Note that this uses 'defaultSDocContext', which doesn't use the options+-- set by the user via DynFlags.+showGhcExceptionUnsafe :: GhcException -> ShowS+showGhcExceptionUnsafe = showGhcException defaultSDocContext++-- | Append a description of the given exception to this string.+showGhcException :: SDocContext -> GhcException -> ShowS+showGhcException ctx = showPlainGhcException . \case   Signal n -> PlainSignal n   UsageError str -> PlainUsageError str   CmdLineError str -> PlainCmdLineError str@@ -143,11 +161,11 @@   ProgramError str -> PlainProgramError str    PprPanic str sdoc -> PlainPanic $-      concat [str, "\n\n", showSDocUnsafe sdoc]+      concat [str, "\n\n", renderWithContext ctx sdoc]   PprSorry str sdoc -> PlainProgramError $-      concat [str, "\n\n", showSDocUnsafe sdoc]+      concat [str, "\n\n", renderWithContext ctx sdoc]   PprProgramError str sdoc -> PlainProgramError $-      concat [str, "\n\n", showSDocUnsafe sdoc]+      concat [str, "\n\n", renderWithContext ctx sdoc]  throwGhcException :: GhcException -> a throwGhcException = Exception.throw@@ -158,9 +176,20 @@ handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a handleGhcException = MC.handle -panicDoc, sorryDoc, pgmErrorDoc :: String -> SDoc -> a-panicDoc    x doc = throwGhcException (PprPanic        x doc)-sorryDoc    x doc = throwGhcException (PprSorry        x doc)+-- | Throw an exception saying "bug in GHC" with a callstack+pprPanic :: HasCallStack => String -> SDoc -> a+pprPanic s doc = panicDoc s (doc $$ callStackDoc)++-- | Throw an exception saying "bug in GHC"+panicDoc :: String -> SDoc -> a+panicDoc x doc = throwGhcException (PprPanic x doc)++-- | Throw an exception saying "this isn't finished yet"+sorryDoc :: String -> SDoc -> a+sorryDoc x doc = throwGhcException (PprSorry x doc)++-- | Throw an exception saying "bug in pgm being compiled" (used for unusual program errors)+pgmErrorDoc :: String -> SDoc -> a pgmErrorDoc x doc = throwGhcException (PprProgramError x doc)  -- | Like try, but pass through UserInterrupt and Panic exceptions.@@ -258,3 +287,14 @@    mayInstallHandlers   act `MC.finally` mayUninstallHandlers++callStackDoc :: HasCallStack => SDoc+callStackDoc =+    hang (text "Call stack:")+       4 (vcat $ map text $ lines (prettyCallStack callStack))++-- | Panic with an assertion failure, recording the given file and+-- line number. Should typically be accessed with the ASSERT family of macros+assertPprPanic :: HasCallStack => String -> Int -> SDoc -> a+assertPprPanic _file _line msg+  = pprPanic "ASSERT failed!" msg

GHC/Utils/Ppr.hs view

@@ -917,16 +917,26 @@           , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length           } --- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).+-- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@). style :: Style-style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }+style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode False }  -- | Rendering mode.-data Mode = PageMode     -- ^ Normal+data Mode = PageMode { asciiSpace :: Bool }    -- ^ Normal           | ZigZagMode   -- ^ With zig-zag cuts           | LeftMode     -- ^ No indentation, infinitely long lines           | OneLineMode  -- ^ All on one line +-- | Can we output an ascii space character for spaces?+--   Mostly true, but not for e.g. UTF16+--   See Note [putSpaces optimizations] for why we bother+--   to track this.+hasAsciiSpace :: Mode -> Bool+hasAsciiSpace mode =+  case mode of+    PageMode asciiSpace -> asciiSpace+    _ -> False+ -- | Render the @Doc@ to a String using the given @Style@. renderStyle :: Style -> Doc -> String renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)@@ -1034,6 +1044,20 @@ -- printDoc adds a newline to the end printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "") +{- Note [putSpaces optimizations]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When using dump flags a lot of what we are dumping ends up being whitespace.+This is especially true for Core/Stg dumps. Enough so that it's worth optimizing.++Especially in the common case of writing to an UTF8 or similarly encoded file+where space is equal to ascii space we use hPutBuf to write a preallocated+buffer to the file. This avoids a fair bit of allocation.++For other cases we fall back to the old and slow path for simplicity.++-}+ printDoc_ :: Mode -> Int -> Handle -> Doc -> IO () -- printDoc_ does not add a newline at the end, so that -- successive calls can output stuff on the same line@@ -1051,9 +1075,27 @@                           -- the I/O library's encoding layer. (#3398)     put (ZStr s)   next = hPutFZS  hdl s >> next     put (LStr s)   next = hPutPtrString hdl s >> next-    put (RStr n c) next = hPutStr hdl (replicate n c) >> next+    put (RStr n c) next+      | c == ' '+      = putSpaces n >> next+      | otherwise+      = hPutStr hdl (replicate n c) >> next+    putSpaces n+      -- If we use ascii spaces we are allowed to use hPutBuf+      -- See Note [putSpaces optimizations]+      | hasAsciiSpace mode+      , n <= 100+      = hPutBuf hdl (Ptr spaces') n+      | hasAsciiSpace mode+      , n > 100+      = hPutBuf hdl (Ptr spaces') 100 >> putSpaces (n-100) +      | otherwise = hPutStr hdl (replicate n ' ')+     done = return () -- hPutChar hdl '\n'+    -- 100 spaces, so we avoid the allocation of replicate n ' '+    spaces' = "                                                                                                    "#+    -- some versions of hPutBuf will barf if the length is zero hPutPtrString :: Handle -> PtrString -> IO ()

+ GHC/Utils/TmpFs.hs view

@@ -0,0 +1,409 @@+{-# LANGUAGE CPP #-}++-- | Temporary file-system management+module GHC.Utils.TmpFs+    ( TmpFs+    , initTmpFs+    , forkTmpFsFrom+    , mergeTmpFsInto+    , FilesToClean(..)+    , emptyFilesToClean+    , TempFileLifetime(..)+    , cleanTempDirs+    , cleanTempFiles+    , cleanCurrentModuleTempFiles+    , addFilesToClean+    , changeTempFilesLifetime+    , newTempName+    , newTempLibName+    , newTempDir+    , withSystemTempDirectory+    , withTempDirectory+    )+where++import GHC.Prelude++import GHC.Driver.Session+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Logger+import GHC.Utils.Misc+import GHC.Utils.Exception as Exception+import GHC.Driver.Phases++import Control.Monad+import Data.List (partition)+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import Data.Map (Map)+import Data.IORef+import System.Directory+import System.FilePath+import System.IO.Error++#if !defined(mingw32_HOST_OS)+import qualified System.Posix.Internals+#endif++-- | Temporary file-system+data TmpFs = TmpFs+  { tmp_dirs_to_clean :: IORef (Map FilePath FilePath)+      -- ^ Maps system temporary directory (passed via settings or DynFlags) to+      -- an actual temporary directory for this process.+      --+      -- It's a Map probably to support changing the system temporary directory+      -- over time.+      --+      -- Shared with forked TmpFs.++  , tmp_next_suffix :: IORef Int+      -- ^ The next available suffix to uniquely name a temp file, updated+      -- atomically.+      --+      -- Shared with forked TmpFs.++  , tmp_files_to_clean :: IORef FilesToClean+      -- ^ Files to clean (per session or per module)+      --+      -- Not shared with forked TmpFs.+  }++-- | A collection of files that must be deleted before ghc exits.+data FilesToClean = FilesToClean+    { ftcGhcSession :: !(Set FilePath)+        -- ^ Files that will be deleted at the end of runGhc(T)++    , ftcCurrentModule :: !(Set FilePath)+        -- ^ Files that will be deleted the next time+        -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of+        -- the session.+    }++-- | Used when a temp file is created. This determines which component Set of+-- FilesToClean will get the temp file+data TempFileLifetime+  = TFL_CurrentModule+  -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the+  -- end of upweep_mod+  | TFL_GhcSession+  -- ^ A file with lifetime TFL_GhcSession will be cleaned up at the end of+  -- runGhc(T)+  deriving (Show)+++-- | An empty FilesToClean+emptyFilesToClean :: FilesToClean+emptyFilesToClean = FilesToClean Set.empty Set.empty++-- | Merge two FilesToClean+mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean+mergeFilesToClean x y = FilesToClean+    { ftcGhcSession    = Set.union (ftcGhcSession x) (ftcGhcSession y)+    , ftcCurrentModule = Set.union (ftcCurrentModule x) (ftcCurrentModule y)+    }++-- | Initialise an empty TmpFs+initTmpFs :: IO TmpFs+initTmpFs = do+    files <- newIORef emptyFilesToClean+    dirs  <- newIORef Map.empty+    next  <- newIORef 0+    return $ TmpFs+        { tmp_files_to_clean = files+        , tmp_dirs_to_clean  = dirs+        , tmp_next_suffix    = next+        }++-- | Initialise an empty TmpFs sharing unique numbers and per-process temporary+-- directories with the given TmpFs+forkTmpFsFrom :: TmpFs -> IO TmpFs+forkTmpFsFrom old = do+    files <- newIORef emptyFilesToClean+    return $ TmpFs+        { tmp_files_to_clean = files+        , tmp_dirs_to_clean  = tmp_dirs_to_clean old+        , tmp_next_suffix    = tmp_next_suffix old+        }++-- | Merge the first TmpFs into the second.+--+-- The first TmpFs is returned emptied.+mergeTmpFsInto :: TmpFs -> TmpFs -> IO ()+mergeTmpFsInto src dst = do+    src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyFilesToClean, s))+    atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergeFilesToClean src_files s, ()))++cleanTempDirs :: Logger -> TmpFs -> DynFlags -> IO ()+cleanTempDirs logger tmpfs dflags+   = unless (gopt Opt_KeepTmpFiles dflags)+   $ mask_+   $ do let ref = tmp_dirs_to_clean tmpfs+        ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds)+        removeTmpDirs logger dflags (Map.elems ds)++-- | Delete all files in @tmp_files_to_clean@.+cleanTempFiles :: Logger -> TmpFs -> DynFlags -> IO ()+cleanTempFiles logger tmpfs dflags+   = unless (gopt Opt_KeepTmpFiles dflags)+   $ mask_+   $ do let ref = tmp_files_to_clean tmpfs+        to_delete <- atomicModifyIORef' ref $+            \FilesToClean+                { ftcCurrentModule = cm_files+                , ftcGhcSession = gs_files+                } -> ( emptyFilesToClean+                     , Set.toList cm_files ++ Set.toList gs_files)+        removeTmpFiles logger dflags to_delete++-- | Delete all files in @tmp_files_to_clean@. That have lifetime+-- TFL_CurrentModule.+-- If a file must be cleaned eventually, but must survive a+-- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession.+cleanCurrentModuleTempFiles :: Logger -> TmpFs -> DynFlags -> IO ()+cleanCurrentModuleTempFiles logger tmpfs dflags+   = unless (gopt Opt_KeepTmpFiles dflags)+   $ mask_+   $ do let ref = tmp_files_to_clean tmpfs+        to_delete <- atomicModifyIORef' ref $+            \ftc@FilesToClean{ftcCurrentModule = cm_files} ->+                (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files)+        removeTmpFiles logger dflags to_delete++-- | Ensure that new_files are cleaned on the next call of+-- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime.+-- If any of new_files are already tracked, they will have their lifetime+-- updated.+addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()+addFilesToClean tmpfs lifetime new_files = modifyIORef' (tmp_files_to_clean tmpfs) $+  \FilesToClean+    { ftcCurrentModule = cm_files+    , ftcGhcSession = gs_files+    } -> case lifetime of+      TFL_CurrentModule -> FilesToClean+        { ftcCurrentModule = cm_files `Set.union` new_files_set+        , ftcGhcSession = gs_files `Set.difference` new_files_set+        }+      TFL_GhcSession -> FilesToClean+        { ftcCurrentModule = cm_files `Set.difference` new_files_set+        , ftcGhcSession = gs_files `Set.union` new_files_set+        }+  where+    new_files_set = Set.fromList new_files++-- | Update the lifetime of files already being tracked. If any files are+-- not being tracked they will be discarded.+changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO ()+changeTempFilesLifetime tmpfs lifetime files = do+  FilesToClean+    { ftcCurrentModule = cm_files+    , ftcGhcSession = gs_files+    } <- readIORef (tmp_files_to_clean tmpfs)+  let old_set = case lifetime of+        TFL_CurrentModule -> gs_files+        TFL_GhcSession -> cm_files+      existing_files = [f | f <- files, f `Set.member` old_set]+  addFilesToClean tmpfs lifetime existing_files++-- Return a unique numeric temp file suffix+newTempSuffix :: TmpFs -> IO Int+newTempSuffix tmpfs =+  atomicModifyIORef' (tmp_next_suffix tmpfs) $ \n -> (n+1,n)++-- Find a temporary name that doesn't already exist.+newTempName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix -> IO FilePath+newTempName logger tmpfs dflags lifetime extn+  = do d <- getTempDir logger tmpfs dflags+       findTempName (d </> "ghc_") -- See Note [Deterministic base name]+  where+    findTempName :: FilePath -> IO FilePath+    findTempName prefix+      = do n <- newTempSuffix tmpfs+           let filename = prefix ++ show n <.> extn+           b <- doesFileExist filename+           if b then findTempName prefix+                else do -- clean it up later+                        addFilesToClean tmpfs lifetime [filename]+                        return filename++newTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath+newTempDir logger tmpfs dflags+  = do d <- getTempDir logger tmpfs dflags+       findTempDir (d </> "ghc_")+  where+    findTempDir :: FilePath -> IO FilePath+    findTempDir prefix+      = do n <- newTempSuffix tmpfs+           let filename = prefix ++ show n+           b <- doesDirectoryExist filename+           if b then findTempDir prefix+                else do createDirectory filename+                        -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename+                        return filename++newTempLibName :: Logger -> TmpFs -> DynFlags -> TempFileLifetime -> Suffix+  -> IO (FilePath, FilePath, String)+newTempLibName logger tmpfs dflags lifetime extn+  = do d <- getTempDir logger tmpfs dflags+       findTempName d ("ghc_")+  where+    findTempName :: FilePath -> String -> IO (FilePath, FilePath, String)+    findTempName dir prefix+      = do n <- newTempSuffix tmpfs -- See Note [Deterministic base name]+           let libname = prefix ++ show n+               filename = dir </> "lib" ++ libname <.> extn+           b <- doesFileExist filename+           if b then findTempName dir prefix+                else do -- clean it up later+                        addFilesToClean tmpfs lifetime [filename]+                        return (filename, dir, libname)+++-- Return our temporary directory within tmp_dir, creating one if we+-- don't have one yet.+getTempDir :: Logger -> TmpFs -> DynFlags -> IO FilePath+getTempDir logger tmpfs dflags = do+    mapping <- readIORef dir_ref+    case Map.lookup tmp_dir mapping of+        Nothing -> do+            pid <- getProcessID+            let prefix = tmp_dir </> "ghc" ++ show pid ++ "_"+            mask_ $ mkTempDir prefix+        Just dir -> return dir+  where+    tmp_dir = tmpDir dflags+    dir_ref = tmp_dirs_to_clean tmpfs++    mkTempDir :: FilePath -> IO FilePath+    mkTempDir prefix = do+        n <- newTempSuffix tmpfs+        let our_dir = prefix ++ show n++        -- 1. Speculatively create our new directory.+        createDirectory our_dir++        -- 2. Update the tmp_dirs_to_clean mapping unless an entry already exists+        -- (i.e. unless another thread beat us to it).+        their_dir <- atomicModifyIORef' dir_ref $ \mapping ->+            case Map.lookup tmp_dir mapping of+                Just dir -> (mapping, Just dir)+                Nothing  -> (Map.insert tmp_dir our_dir mapping, Nothing)++        -- 3. If there was an existing entry, return it and delete the+        -- directory we created.  Otherwise return the directory we created.+        case their_dir of+            Nothing  -> do+                debugTraceMsg logger dflags 2 $+                    text "Created temporary directory:" <+> text our_dir+                return our_dir+            Just dir -> do+                removeDirectory our_dir+                return dir+      `catchIO` \e -> if isAlreadyExistsError e+                      then mkTempDir prefix else ioError e++{- Note [Deterministic base name]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The filename of temporary files, especially the basename of C files, can end+up in the output in some form, e.g. as part of linker debug information. In the+interest of bit-wise exactly reproducible compilation (#4012), the basename of+the temporary file no longer contains random information (it used to contain+the process id).++This is ok, as the temporary directory used contains the pid (see getTempDir).+-}+removeTmpDirs :: Logger -> DynFlags -> [FilePath] -> IO ()+removeTmpDirs logger dflags ds+  = traceCmd logger dflags "Deleting temp dirs"+             ("Deleting: " ++ unwords ds)+             (mapM_ (removeWith logger dflags removeDirectory) ds)++removeTmpFiles :: Logger -> DynFlags -> [FilePath] -> IO ()+removeTmpFiles logger dflags fs+  = warnNon $+    traceCmd logger dflags "Deleting temp files"+             ("Deleting: " ++ unwords deletees)+             (mapM_ (removeWith logger dflags removeFile) deletees)+  where+     -- Flat out refuse to delete files that are likely to be source input+     -- files (is there a worse bug than having a compiler delete your source+     -- files?)+     --+     -- Deleting source files is a sign of a bug elsewhere, so prominently flag+     -- the condition.+    warnNon act+     | null non_deletees = act+     | otherwise         = do+        putMsg logger dflags (text "WARNING - NOT deleting source files:"+                       <+> hsep (map text non_deletees))+        act++    (non_deletees, deletees) = partition isHaskellUserSrcFilename fs++removeWith :: Logger -> DynFlags -> (FilePath -> IO ()) -> FilePath -> IO ()+removeWith logger dflags remover f = remover f `catchIO`+  (\e ->+   let msg = if isDoesNotExistError e+             then text "Warning: deleting non-existent" <+> text f+             else text "Warning: exception raised when deleting"+                                            <+> text f <> colon+               $$ text (show e)+   in debugTraceMsg logger dflags 2 msg+  )++#if defined(mingw32_HOST_OS)+-- relies on Int == Int32 on Windows+foreign import ccall unsafe "_getpid" getProcessID :: IO Int+#else+getProcessID :: IO Int+getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral+#endif++-- The following three functions are from the `temporary` package.++-- | Create and use a temporary directory in the system standard temporary+-- directory.+--+-- Behaves exactly the same as 'withTempDirectory', except that the parent+-- temporary directory will be that returned by 'getTemporaryDirectory'.+withSystemTempDirectory :: String   -- ^ Directory name template. See 'openTempFile'.+                        -> (FilePath -> IO a) -- ^ Callback that can use the directory+                        -> IO a+withSystemTempDirectory template action =+  getTemporaryDirectory >>= \tmpDir -> withTempDirectory tmpDir template action+++-- | Create and use a temporary directory.+--+-- Creates a new temporary directory inside the given directory, making use+-- of the template. The temp directory is deleted after use. For example:+--+-- > withTempDirectory "src" "sdist." $ \tmpDir -> do ...+--+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.+-- @src/sdist.342@.+withTempDirectory :: FilePath -- ^ Temp directory to create the directory in+                  -> String   -- ^ Directory name template. See 'openTempFile'.+                  -> (FilePath -> IO a) -- ^ Callback that can use the directory+                  -> IO a+withTempDirectory targetDir template =+  Exception.bracket+    (createTempDirectory targetDir template)+    (ignoringIOErrors . removeDirectoryRecursive)++ignoringIOErrors :: IO () -> IO ()+ignoringIOErrors ioe = ioe `catchIO` const (return ())+++createTempDirectory :: FilePath -> String -> IO FilePath+createTempDirectory dir template = do+  pid <- getProcessID+  findTempName pid+  where findTempName x = do+            let path = dir </> template ++ show x+            createDirectory path+            return path+          `catchIO` \e -> if isAlreadyExistsError e+                          then findTempName (x+1) else ioError e

HsVersions.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));

+ Language/Haskell/Syntax.hs view

@@ -0,0 +1,62 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{Haskell abstract syntax definition}++This module glues together the pieces of the Haskell abstract syntax,+which is declared in the various \tr{Hs*} modules.  This module,+therefore, is almost nothing but re-exporting.+-}++{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax (+        module Language.Haskell.Syntax.Binds,+        module Language.Haskell.Syntax.Decls,+        module Language.Haskell.Syntax.Expr,+        module Language.Haskell.Syntax.Lit,+        module Language.Haskell.Syntax.Pat,+        module Language.Haskell.Syntax.Type,+        module Language.Haskell.Syntax.Extension,+) where++import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Binds+import Language.Haskell.Syntax.Expr+import Language.Haskell.Syntax.Lit+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Pat+import Language.Haskell.Syntax.Type++{-+Note [Language.Haskell.Syntax.* Hierarchy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Why are these modules not 'GHC.Hs.*', or some other 'GHC.*'? The answer+is that they are to be separated from GHC and put into another package,+in accordance with the final goals of Trees that Grow. (See Note [Trees+that grow] in 'Language.Haskell.Syntax.Extension'.) In short, the+'Language.Haskell.Syntax.*' tree should be entirely GHC-independent.+GHC-specific stuff related to source-language syntax should be in+'GHC.Hs.*'.++We cannot move them to the separate package yet, but by giving them+names like so, we hope to remind others that the goal is to factor them+out, and therefore dependencies on the rest of GHC should never be+added, only removed.++For more details, see+https://gitlab.haskell.org/ghc/ghc/-/wikis/implementing-trees-that-grow+-}+++-- TODO Add TTG parameter to 'HsModule' and move here.

+ Language/Haskell/Syntax/Binds.hs view

@@ -0,0 +1,944 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE ViewPatterns #-}+++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[HsBinds]{Abstract syntax: top-level bindings and signatures}++Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.+-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax.Binds where++import GHC.Prelude++import {-# SOURCE #-} Language.Haskell.Syntax.Expr+  ( LHsExpr+  , MatchGroup+  , GRHSs )+import {-# SOURCE #-} Language.Haskell.Syntax.Pat+  ( LPat )++import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Type+import GHC.Tc.Types.Evidence+import GHC.Core.Type+import GHC.Types.Basic+import GHC.Types.SourceText+import GHC.Types.SrcLoc as SrcLoc+import GHC.Types.Tickish+import GHC.Types.Var+import GHC.Types.Fixity+import GHC.Data.Bag+import GHC.Data.BooleanFormula (LBooleanFormula)++import GHC.Utils.Outputable++import Data.Data hiding ( Fixity )+import Data.Void++{-+************************************************************************+*                                                                      *+\subsection{Bindings: @BindGroup@}+*                                                                      *+************************************************************************++Global bindings (where clauses)+-}++-- During renaming, we need bindings where the left-hand sides+-- have been renamed but the right-hand sides have not.+-- Other than during renaming, these will be the same.++-- | Haskell Local Bindings+type HsLocalBinds id = HsLocalBindsLR id id++-- | Located Haskell local bindings+type LHsLocalBinds id = XRec id (HsLocalBinds id)++-- | Haskell Local Bindings with separate Left and Right identifier types+--+-- Bindings in a 'let' expression+-- or a 'where' clause+data HsLocalBindsLR idL idR+  = HsValBinds+        (XHsValBinds idL idR)+        (HsValBindsLR idL idR)+      -- ^ Haskell Value Bindings++         -- There should be no pattern synonyms in the HsValBindsLR+         -- These are *local* (not top level) bindings+         -- The parser accepts them, however, leaving the+         -- renamer to report them++  | HsIPBinds+        (XHsIPBinds idL idR)+        (HsIPBinds idR)+      -- ^ Haskell Implicit Parameter Bindings++  | EmptyLocalBinds (XEmptyLocalBinds idL idR)+      -- ^ Empty Local Bindings++  | XHsLocalBindsLR+        !(XXHsLocalBindsLR idL idR)++type LHsLocalBindsLR idL idR = XRec idL (HsLocalBindsLR idL idR)+++-- | Haskell Value Bindings+type HsValBinds id = HsValBindsLR id id++-- | Haskell Value bindings with separate Left and Right identifier types+-- (not implicit parameters)+-- Used for both top level and nested bindings+-- May contain pattern synonym bindings+data HsValBindsLR idL idR+  = -- | Value Bindings In+    --+    -- Before renaming RHS; idR is always RdrName+    -- Not dependency analysed+    -- Recursive by default+    ValBinds+        (XValBinds idL idR)+        (LHsBindsLR idL idR) [LSig idR]++    -- | Value Bindings Out+    --+    -- After renaming RHS; idR can be Name or Id Dependency analysed,+    -- later bindings in the list may depend on earlier ones.+  | XValBindsLR+      !(XXValBindsLR idL idR)++-- ---------------------------------------------------------------------++-- | Located Haskell Binding+type LHsBind  id = LHsBindLR  id id++-- | Located Haskell Bindings+type LHsBinds id = LHsBindsLR id id++-- | Haskell Binding+type HsBind   id = HsBindLR   id id++-- | Located Haskell Bindings with separate Left and Right identifier types+type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)++-- | Located Haskell Binding with separate Left and Right identifier types+type LHsBindLR  idL idR = XRec idL (HsBindLR idL idR)++{- Note [FunBind vs PatBind]+   ~~~~~~~~~~~~~~~~~~~~~~~~~+The distinction between FunBind and PatBind is a bit subtle. FunBind covers+patterns which resemble function bindings and simple variable bindings.++    f x = e+    f !x = e+    f = e+    !x = e          -- FunRhs has SrcStrict+    x `f` y = e     -- FunRhs has Infix++The actual patterns and RHSs of a FunBind are encoding in fun_matches.+The m_ctxt field of each Match in fun_matches will be FunRhs and carries+two bits of information about the match,++  * The mc_fixity field on each Match describes the fixity of the+    function binder in that match.  E.g. this is legal:+         f True False  = e1+         True `f` True = e2++  * The mc_strictness field is used /only/ for nullary FunBinds: ones+    with one Match, which has no pats. For these, it describes whether+    the match is decorated with a bang (e.g. `!x = e`).++By contrast, PatBind represents data constructor patterns, as well as a few+other interesting cases. Namely,++    Just x = e+    (x) = e+    x :: Ty = e+-}++-- | Haskell Binding with separate Left and Right id's+data HsBindLR idL idR+  = -- | Function-like Binding+    --+    -- FunBind is used for both functions     @f x = e@+    -- and variables                          @f = \x -> e@+    -- and strict variables                   @!x = x + 1@+    --+    -- Reason 1: Special case for type inference: see 'GHC.Tc.Gen.Bind.tcMonoBinds'.+    --+    -- Reason 2: Instance decls can only have FunBinds, which is convenient.+    --           If you change this, you'll need to change e.g. rnMethodBinds+    --+    -- But note that the form                 @f :: a->a = ...@+    -- parses as a pattern binding, just like+    --                                        @(f :: a -> a) = ... @+    --+    -- Strict bindings have their strictness recorded in the 'SrcStrictness' of their+    -- 'MatchContext'. See Note [FunBind vs PatBind] for+    -- details about the relationship between FunBind and PatBind.+    --+    --  'GHC.Parser.Annotation.AnnKeywordId's+    --+    --  - 'GHC.Parser.Annotation.AnnFunId', attached to each element of fun_matches+    --+    --  - 'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',+    --    'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    FunBind {++        fun_ext :: XFunBind idL idR,++          -- ^ After the renamer (but before the type-checker), this contains the+          -- locally-bound free variables of this defn. See Note [Bind free vars]+          --+          -- After the type-checker, this contains a coercion from the type of+          -- the MatchGroup to the type of the Id. Example:+          --+          -- @+          --      f :: Int -> forall a. a -> a+          --      f x y = y+          -- @+          --+          -- Then the MatchGroup will have type (Int -> a' -> a')+          -- (with a free type variable a').  The coercion will take+          -- a CoreExpr of this type and convert it to a CoreExpr of+          -- type         Int -> forall a'. a' -> a'+          -- Notice that the coercion captures the free a'.++        fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr++        fun_matches :: MatchGroup idR (LHsExpr idR),  -- ^ The payload++        fun_tick :: [CoreTickish] -- ^ Ticks to put on the rhs, if any+    }++  -- | Pattern Binding+  --+  -- The pattern is never a simple variable;+  -- That case is done by FunBind.+  -- See Note [FunBind vs PatBind] for details about the+  -- relationship between FunBind and PatBind.++  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang',+  --       'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',+  --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | PatBind {+        pat_ext    :: XPatBind idL idR, -- ^ See Note [Bind free vars]+        pat_lhs    :: LPat idL,+        pat_rhs    :: GRHSs idR (LHsExpr idR),+        pat_ticks  :: ([CoreTickish], [[CoreTickish]])+               -- ^ Ticks to put on the rhs, if any, and ticks to put on+               -- the bound variables.+    }++  -- | Variable Binding+  --+  -- Dictionary binding and suchlike.+  -- All VarBinds are introduced by the type checker+  | VarBind {+        var_ext    :: XVarBind idL idR,+        var_id     :: IdP idL,+        var_rhs    :: LHsExpr idR    -- ^ Located only for consistency+    }++  -- | Abstraction Bindings+  | AbsBinds {                      -- Binds abstraction; TRANSLATION+        abs_ext     :: XAbsBinds idL idR,+        abs_tvs     :: [TyVar],+        abs_ev_vars :: [EvVar],  -- ^ Includes equality constraints++       -- | AbsBinds only gets used when idL = idR after renaming,+       -- but these need to be idL's for the collect... code in HsUtil+       -- to have the right type+        abs_exports :: [ABExport idL],++        -- | Evidence bindings+        -- Why a list? See "GHC.Tc.TyCl.Instance"+        -- Note [Typechecking plan for instance declarations]+        abs_ev_binds :: [TcEvBinds],++        -- | Typechecked user bindings+        abs_binds    :: LHsBinds idL,++        abs_sig :: Bool  -- See Note [The abs_sig field of AbsBinds]+    }++  -- | Patterns Synonym Binding+  | PatSynBind+        (XPatSynBind idL idR)+        (PatSynBind idL idR)+        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',+        --          'GHC.Parser.Annotation.AnnLarrow','GHC.Parser.Annotation.AnnEqual',+        --          'GHC.Parser.Annotation.AnnWhere'+        --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | XHsBindsLR !(XXHsBindsLR idL idR)+++        -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]+        --+        -- Creates bindings for (polymorphic, overloaded) poly_f+        -- in terms of monomorphic, non-overloaded mono_f+        --+        -- Invariants:+        --      1. 'binds' binds mono_f+        --      2. ftvs is a subset of tvs+        --      3. ftvs includes all tyvars free in ds+        --+        -- See Note [AbsBinds]++-- | Abstraction Bindings Export+data ABExport p+  = ABE { abe_ext       :: XABE p+        , abe_poly      :: IdP p -- ^ Any INLINE pragma is attached to this Id+        , abe_mono      :: IdP p+        , abe_wrap      :: HsWrapper    -- ^ See Note [ABExport wrapper]+             -- Shape: (forall abs_tvs. abs_ev_vars => abe_mono) ~ abe_poly+        , abe_prags     :: TcSpecPrags  -- ^ SPECIALISE pragmas+        }+   | XABExport !(XXABExport p)+++-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',+--             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnLarrow',+--             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen' @'{'@,+--             'GHC.Parser.Annotation.AnnClose' @'}'@,++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Pattern Synonym binding+data PatSynBind idL idR+  = PSB { psb_ext  :: XPSB idL idR,            -- ^ Post renaming, FVs.+                                               -- See Note [Bind free vars]+          psb_id   :: LIdP idL,                -- ^ Name of the pattern synonym+          psb_args :: HsPatSynDetails idR,     -- ^ Formal parameter names+          psb_def  :: LPat idR,                -- ^ Right-hand side+          psb_dir  :: HsPatSynDir idR          -- ^ Directionality+     }+   | XPatSynBind !(XXPatSynBind idL idR)++{-+Note [AbsBinds]+~~~~~~~~~~~~~~~+The AbsBinds constructor is used in the output of the type checker, to+record *typechecked* and *generalised* bindings.  Specifically++         AbsBinds { abs_tvs      = tvs+                  , abs_ev_vars  = [d1,d2]+                  , abs_exports  = [ABE { abe_poly = fp, abe_mono = fm+                                        , abe_wrap = fwrap }+                                    ABE { slly for g } ]+                  , abs_ev_binds = DBINDS+                  , abs_binds    = BIND[fm,gm] }++where 'BIND' binds the monomorphic Ids 'fm' and 'gm', means++        fp = fwrap [/\ tvs. \d1 d2. letrec { DBINDS        ]+                   [                       ; BIND[fm,gm] } ]+                   [                 in fm                 ]++        gp = ...same again, with gm instead of fm++The 'fwrap' is an impedance-matcher that typically does nothing; see+Note [ABExport wrapper].++This is a pretty bad translation, because it duplicates all the bindings.+So the desugarer tries to do a better job:++        fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of+                                        (fm,gm) -> fm+        ..ditto for gp..++        tp = /\ [a,b] -> \ [d1,d2] -> letrec { DBINDS; BIND }+                                      in (fm,gm)++In general:++  * abs_tvs are the type variables over which the binding group is+    generalised+  * abs_ev_var are the evidence variables (usually dictionaries)+    over which the binding group is generalised+  * abs_binds are the monomorphic bindings+  * abs_ex_binds are the evidence bindings that wrap the abs_binds+  * abs_exports connects the monomorphic Ids bound by abs_binds+    with the polymorphic Ids bound by the AbsBinds itself.++For example, consider a module M, with this top-level binding, where+there is no type signature for M.reverse,+    M.reverse []     = []+    M.reverse (x:xs) = M.reverse xs ++ [x]++In Hindley-Milner, a recursive binding is typechecked with the+*recursive* uses being *monomorphic*.  So after typechecking *and*+desugaring we will get something like this++    M.reverse :: forall a. [a] -> [a]+      = /\a. letrec+                reverse :: [a] -> [a] = \xs -> case xs of+                                                []     -> []+                                                (x:xs) -> reverse xs ++ [x]+             in reverse++Notice that 'M.reverse' is polymorphic as expected, but there is a local+definition for plain 'reverse' which is *monomorphic*.  The type variable+'a' scopes over the entire letrec.++That's after desugaring.  What about after type checking but before+desugaring?  That's where AbsBinds comes in.  It looks like this:++   AbsBinds { abs_tvs     = [a]+            , abs_ev_vars = []+            , abs_exports = [ABE { abe_poly = M.reverse :: forall a. [a] -> [a],+                                 , abe_mono = reverse :: [a] -> [a]}]+            , abs_ev_binds = {}+            , abs_binds = { reverse :: [a] -> [a]+                               = \xs -> case xs of+                                            []     -> []+                                            (x:xs) -> reverse xs ++ [x] } }++Here,++  * abs_tvs says what type variables are abstracted over the binding+    group, just 'a' in this case.+  * abs_binds is the *monomorphic* bindings of the group+  * abs_exports describes how to get the polymorphic Id 'M.reverse'+    from the monomorphic one 'reverse'++Notice that the *original* function (the polymorphic one you thought+you were defining) appears in the abe_poly field of the+abs_exports. The bindings in abs_binds are for fresh, local, Ids with+a *monomorphic* Id.++If there is a group of mutually recursive (see Note [Polymorphic+recursion]) functions without type signatures, we get one AbsBinds+with the monomorphic versions of the bindings in abs_binds, and one+element of abe_exports for each variable bound in the mutually+recursive group.  This is true even for pattern bindings.  Example:+        (f,g) = (\x -> x, f)+After type checking we get+   AbsBinds { abs_tvs     = [a]+            , abs_exports = [ ABE { abe_poly = M.f :: forall a. a -> a+                                  , abe_mono = f :: a -> a }+                            , ABE { abe_poly = M.g :: forall a. a -> a+                                  , abe_mono = g :: a -> a }]+            , abs_binds = { (f,g) = (\x -> x, f) }++Note [Polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   Rec { f x = ...(g ef)...++       ; g :: forall a. [a] -> [a]+       ; g y = ...(f eg)...  }++These bindings /are/ mutually recursive (f calls g, and g calls f).+But we can use the type signature for g to break the recursion,+like this:++  1. Add g :: forall a. [a] -> [a] to the type environment++  2. Typecheck the definition of f, all by itself,+     including generalising it to find its most general+     type, say f :: forall b. b -> b -> [b]++  3. Extend the type environment with that type for f++  4. Typecheck the definition of g, all by itself,+     checking that it has the type claimed by its signature++Steps 2 and 4 each generate a separate AbsBinds, so we end+up with+   Rec { AbsBinds { ...for f ... }+       ; AbsBinds { ...for g ... } }++This approach allows both f and to call each other+polymorphically, even though only g has a signature.++We get an AbsBinds that encompasses multiple source-program+bindings only when+ * Each binding in the group has at least one binder that+   lacks a user type signature+ * The group forms a strongly connected component+++Note [The abs_sig field of AbsBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The abs_sig field supports a couple of special cases for bindings.+Consider++  x :: Num a => (# a, a #)+  x = (# 3, 4 #)++The general desugaring for AbsBinds would give++  x = /\a. \ ($dNum :: Num a) ->+      letrec xm = (# fromInteger $dNum 3, fromInteger $dNum 4 #) in+      xm++But that has an illegal let-binding for an unboxed tuple.  In this+case we'd prefer to generate the (more direct)++  x = /\ a. \ ($dNum :: Num a) ->+     (# fromInteger $dNum 3, fromInteger $dNum 4 #)++A similar thing happens with representation-polymorphic defns+(#11405):++  undef :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a+  undef = error "undef"++Again, the vanilla desugaring gives a local let-binding for a+representation-polymorphic (undefm :: a), which is illegal.  But+again we can desugar without a let:++  undef = /\ a. \ (d:HasCallStack) -> error a d "undef"++The abs_sig field supports this direct desugaring, with no local+let-binding.  When abs_sig = True++ * the abs_binds is single FunBind++ * the abs_exports is a singleton++ * we have a complete type sig for binder+   and hence the abs_binds is non-recursive+   (it binds the mono_id but refers to the poly_id++These properties are exploited in GHC.HsToCore.Binds.dsAbsBinds to+generate code without a let-binding.++Note [ABExport wrapper]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   (f,g) = (\x.x, \y.y)+This ultimately desugars to something like this:+   tup :: forall a b. (a->a, b->b)+   tup = /\a b. (\x:a.x, \y:b.y)+   f :: forall a. a -> a+   f = /\a. case tup a Any of+               (fm::a->a,gm:Any->Any) -> fm+   ...similarly for g...++The abe_wrap field deals with impedance-matching between+    (/\a b. case tup a b of { (f,g) -> f })+and the thing we really want, which may have fewer type+variables.  The action happens in GHC.Tc.Gen.Bind.mkExport.++Note [Bind free vars]+~~~~~~~~~~~~~~~~~~~~~+The bind_fvs field of FunBind and PatBind records the free variables+of the definition.  It is used for the following purposes++a) Dependency analysis prior to type checking+    (see GHC.Tc.Gen.Bind.tc_group)++b) Deciding whether we can do generalisation of the binding+    (see GHC.Tc.Gen.Bind.decideGeneralisationPlan)++c) Deciding whether the binding can be used in static forms+    (see GHC.Tc.Gen.Expr.checkClosedInStaticForm for the HsStatic case and+     GHC.Tc.Gen.Bind.isClosedBndrGroup).++Specifically,++  * bind_fvs includes all free vars that are defined in this module+    (including top-level things and lexically scoped type variables)++  * bind_fvs excludes imported vars; this is just to keep the set smaller++  * Before renaming, and after typechecking, the field is unused;+    it's just an error thunk+-}+++{-+************************************************************************+*                                                                      *+                Implicit parameter bindings+*                                                                      *+************************************************************************+-}++-- | Haskell Implicit Parameter Bindings+data HsIPBinds id+  = IPBinds+        (XIPBinds id)+        [LIPBind id]+        -- TcEvBinds       -- Only in typechecker output; binds+        --                 -- uses of the implicit parameters+  | XHsIPBinds !(XXHsIPBinds id)+++-- | Located Implicit Parameter Binding+type LIPBind id = XRec id (IPBind id)+-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a+--   list++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Implicit parameter bindings.+--+-- These bindings start off as (Left "x") in the parser and stay+-- that way until after type-checking when they are replaced with+-- (Right d), where "d" is the name of the dictionary holding the+-- evidence for the implicit parameter.+--+-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation+data IPBind id+  = IPBind+        (XCIPBind id)+        (Either (XRec id HsIPName) (IdP id))+        (LHsExpr id)+  | XIPBind !(XXIPBind id)++{-+************************************************************************+*                                                                      *+\subsection{@Sig@: type signatures and value-modifying user pragmas}+*                                                                      *+************************************************************************++It is convenient to lump ``value-modifying'' user-pragmas (e.g.,+``specialise this function to these four types...'') in with type+signatures.  Then all the machinery to move them into place, etc.,+serves for both.+-}++-- | Located Signature+type LSig pass = XRec pass (Sig pass)++-- | Signatures and pragmas+data Sig pass+  =   -- | An ordinary type signature+      --+      -- > f :: Num a => a -> a+      --+      -- After renaming, this list of Names contains the named+      -- wildcards brought into scope by this signature. For a signature+      -- @_ -> _a -> Bool@, the renamer will leave the unnamed wildcard @_@+      -- untouched, and the named wildcard @_a@ is then replaced with+      -- fresh meta vars in the type. Their names are stored in the type+      -- signature that brought them into scope, in this third field to be+      -- more specific.+      --+      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon',+      --          'GHC.Parser.Annotation.AnnComma'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    TypeSig+       (XTypeSig pass)+       [LIdP pass]           -- LHS of the signature; e.g.  f,g,h :: blah+       (LHsSigWcType pass)   -- RHS of the signature; can have wildcards++      -- | A pattern synonym type signature+      --+      -- > pattern Single :: () => (Show a) => a -> [a]+      --+      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnPattern',+      --           'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnForall'+      --           'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | PatSynSig (XPatSynSig pass) [LIdP pass] (LHsSigType pass)+      -- P :: forall a b. Req => Prov => ty++      -- | A signature for a class method+      --   False: ordinary class-method signature+      --   True:  generic-default class method signature+      -- e.g.   class C a where+      --          op :: a -> a                   -- Ordinary+      --          default op :: Eq a => a -> a   -- Generic default+      -- No wildcards allowed here+      --+      --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDefault',+      --           'GHC.Parser.Annotation.AnnDcolon'+  | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass)++        -- | A type signature in generated code, notably the code+        -- generated for record selectors.  We simply record+        -- the desired Id itself, replete with its name, type+        -- and IdDetails.  Otherwise it's just like a type+        -- signature: there should be an accompanying binding+  | IdSig (XIdSig pass) Id++        -- | An ordinary fixity declaration+        --+        -- >     infixl 8 ***+        --+        --+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInfix',+        --           'GHC.Parser.Annotation.AnnVal'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | FixSig (XFixSig pass) (FixitySig pass)++        -- | An inline pragma+        --+        -- > {#- INLINE f #-}+        --+        --  - 'GHC.Parser.Annotation.AnnKeywordId' :+        --       'GHC.Parser.Annotation.AnnOpen' @'{-\# INLINE'@ and @'['@,+        --       'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnOpen',+        --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnTilde',+        --       'GHC.Parser.Annotation.AnnClose'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | InlineSig   (XInlineSig pass)+                (LIdP pass)        -- Function name+                InlinePragma       -- Never defaultInlinePragma++        -- | A specialisation pragma+        --+        -- > {-# SPECIALISE f :: Int -> Int #-}+        --+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+        --      'GHC.Parser.Annotation.AnnOpen' @'{-\# SPECIALISE'@ and @'['@,+        --      'GHC.Parser.Annotation.AnnTilde',+        --      'GHC.Parser.Annotation.AnnVal',+        --      'GHC.Parser.Annotation.AnnClose' @']'@ and @'\#-}'@,+        --      'GHC.Parser.Annotation.AnnDcolon'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | SpecSig     (XSpecSig pass)+                (LIdP pass)        -- Specialise a function or datatype  ...+                [LHsSigType pass]  -- ... to these types+                InlinePragma       -- The pragma on SPECIALISE_INLINE form.+                                   -- If it's just defaultInlinePragma, then we said+                                   --    SPECIALISE, not SPECIALISE_INLINE++        -- | A specialisation pragma for instance declarations only+        --+        -- > {-# SPECIALISE instance Eq [Int] #-}+        --+        -- (Class tys); should be a specialisation of the+        -- current instance declaration+        --+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+        --      'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass)+                  -- Note [Pragma source text] in GHC.Types.SourceText++        -- | A minimal complete definition pragma+        --+        -- > {-# MINIMAL a | (b, c | (d | e)) #-}+        --+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+        --      'GHC.Parser.Annotation.AnnVbar','GHC.Parser.Annotation.AnnComma',+        --      'GHC.Parser.Annotation.AnnClose'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | MinimalSig (XMinimalSig pass)+               SourceText (LBooleanFormula (LIdP pass))+               -- Note [Pragma source text] in GHC.Types.SourceText++        -- | A "set cost centre" pragma for declarations+        --+        -- > {-# SCC funName #-}+        --+        -- or+        --+        -- > {-# SCC funName "cost_centre_name" #-}++  | SCCFunSig  (XSCCFunSig pass)+               SourceText     -- Note [Pragma source text] in GHC.Types.SourceText+               (LIdP pass)    -- Function name+               (Maybe (XRec pass StringLiteral))+       -- | A complete match pragma+       --+       -- > {-# COMPLETE C, D [:: T] #-}+       --+       -- Used to inform the pattern match checker about additional+       -- complete matchings which, for example, arise from pattern+       -- synonym definitions.+  | CompleteMatchSig (XCompleteMatchSig pass)+                     SourceText+                     (XRec pass [LIdP pass])+                     (Maybe (LIdP pass))+  | XSig !(XXSig pass)++-- | Located Fixity Signature+type LFixitySig pass = XRec pass (FixitySig pass)++-- | Fixity Signature+data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity+                    | XFixitySig !(XXFixitySig pass)++-- | Type checker Specialisation Pragmas+--+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer+data TcSpecPrags+  = IsDefaultMethod     -- ^ Super-specialised: a default method should+                        -- be macro-expanded at every call site+  | SpecPrags [LTcSpecPrag]+  deriving Data++-- | Located Type checker Specification Pragmas+type LTcSpecPrag = Located TcSpecPrag++-- | Type checker Specification Pragma+data TcSpecPrag+  = SpecPrag+        Id+        HsWrapper+        InlinePragma+  -- ^ The Id to be specialised, a wrapper that specialises the+  -- polymorphic function, and inlining spec for the specialised function+  deriving Data++noSpecPrags :: TcSpecPrags+noSpecPrags = SpecPrags []++hasSpecPrags :: TcSpecPrags -> Bool+hasSpecPrags (SpecPrags ps) = not (null ps)+hasSpecPrags IsDefaultMethod = False++isDefaultMethod :: TcSpecPrags -> Bool+isDefaultMethod IsDefaultMethod = True+isDefaultMethod (SpecPrags {})  = False++isFixityLSig :: forall p. UnXRec p => LSig p -> Bool+isFixityLSig (unXRec @p -> FixSig {}) = True+isFixityLSig _                 = False++isTypeLSig :: forall p. UnXRec p => LSig p -> Bool  -- Type signatures+isTypeLSig (unXRec @p -> TypeSig {})    = True+isTypeLSig (unXRec @p -> ClassOpSig {}) = True+isTypeLSig (unXRec @p -> IdSig {})      = True+isTypeLSig _                    = False++isSpecLSig :: forall p. UnXRec p => LSig p -> Bool+isSpecLSig (unXRec @p -> SpecSig {}) = True+isSpecLSig _                 = False++isSpecInstLSig :: forall p. UnXRec p => LSig p -> Bool+isSpecInstLSig (unXRec @p -> SpecInstSig {}) = True+isSpecInstLSig _                      = False++isPragLSig :: forall p. UnXRec p => LSig p -> Bool+-- Identifies pragmas+isPragLSig (unXRec @p -> SpecSig {})   = True+isPragLSig (unXRec @p -> InlineSig {}) = True+isPragLSig (unXRec @p -> SCCFunSig {}) = True+isPragLSig (unXRec @p -> CompleteMatchSig {}) = True+isPragLSig _                    = False++isInlineLSig :: forall p. UnXRec p => LSig p -> Bool+-- Identifies inline pragmas+isInlineLSig (unXRec @p -> InlineSig {}) = True+isInlineLSig _                    = False++isMinimalLSig :: forall p. UnXRec p => LSig p -> Bool+isMinimalLSig (unXRec @p -> MinimalSig {}) = True+isMinimalLSig _                               = False++isSCCFunSig :: forall p. UnXRec p => LSig p -> Bool+isSCCFunSig (unXRec @p -> SCCFunSig {}) = True+isSCCFunSig _                    = False++isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool+isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True+isCompleteMatchSig _                            = False++hsSigDoc :: Sig name -> SDoc+hsSigDoc (TypeSig {})           = text "type signature"+hsSigDoc (PatSynSig {})         = text "pattern synonym signature"+hsSigDoc (ClassOpSig _ is_deflt _ _)+ | is_deflt                     = text "default type signature"+ | otherwise                    = text "class method signature"+hsSigDoc (IdSig {})             = text "id signature"+hsSigDoc (SpecSig _ _ _ inl)+                                = ppr inl <+> text "pragma"+hsSigDoc (InlineSig _ _ prag)   = ppr (inlinePragmaSpec prag) <+> text "pragma"+hsSigDoc (SpecInstSig _ src _)+                                = pprWithSourceText src empty <+> text "instance pragma"+hsSigDoc (FixSig {})            = text "fixity declaration"+hsSigDoc (MinimalSig {})        = text "MINIMAL pragma"+hsSigDoc (SCCFunSig {})         = text "SCC pragma"+hsSigDoc (CompleteMatchSig {})  = text "COMPLETE pragma"+hsSigDoc (XSig {})              = text "XSIG TTG extension"++{-+************************************************************************+*                                                                      *+\subsection[PatSynBind]{A pattern synonym definition}+*                                                                      *+************************************************************************+-}++-- | Haskell Pattern Synonym Details+type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass]++-- See Note [Record PatSyn Fields]+-- | Record Pattern Synonym Field+data RecordPatSynField pass+  = RecordPatSynField+      { recordPatSynField :: FieldOcc pass+      -- ^ Field label visible in rest of the file+      , recordPatSynPatVar :: LIdP pass+      -- ^ Filled in by renamer, the name used internally by the pattern+      }+++{-+Note [Record PatSyn Fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider the following two pattern synonyms.++  pattern P x y = ([x,True], [y,'v'])+  pattern Q{ x, y } =([x,True], [y,'v'])++In P, we just have two local binders, x and y.++In Q, we have local binders but also top-level record selectors+  x :: ([Bool], [Char]) -> Bool+  y :: ([Bool], [Char]) -> Char++Both are recorded in the `RecordPatSynField`s for `x` and `y`:+* recordPatSynField: the top-level record selector+* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym.++It would make sense to support record-like syntax++  pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v'])++when we have a different name for the local and top-level binder,+making the distinction between the two names clear.++-}+instance Outputable (RecordPatSynField a) where+    ppr (RecordPatSynField { recordPatSynField = v }) = ppr v+++-- | Haskell Pattern Synonym Direction+data HsPatSynDir id+  = Unidirectional+  | ImplicitBidirectional+  | ExplicitBidirectional (MatchGroup id (LHsExpr id))

+ Language/Haskell/Syntax/Decls.hs view

@@ -0,0 +1,1818 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE ViewPatterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*++-- | Abstract syntax of global declarations.+--+-- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,+-- @InstDecl@, @DefaultDecl@ and @ForeignDecl@.+module Language.Haskell.Syntax.Decls (+  -- * Toplevel declarations+  HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep, FunDep(..),+  HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,+  NewOrData(..), newOrDataToFlavour,+  StandaloneKindSig(..), LStandaloneKindSig,++  -- ** Class or type declarations+  TyClDecl(..), LTyClDecl, DataDeclRn(..),+  TyClGroup(..),+  tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,+  tyClGroupKindSigs,+  isClassDecl, isDataDecl, isSynDecl,+  isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,+  isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,+  countTyClDecls,+  tyClDeclTyVars,+  FamilyDecl(..), LFamilyDecl,++  -- ** Instance declarations+  InstDecl(..), LInstDecl, FamilyInfo(..), pprFlavour,+  TyFamInstDecl(..), LTyFamInstDecl,+  TyFamDefltDecl, LTyFamDefltDecl,+  DataFamInstDecl(..), LDataFamInstDecl,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  LClsInstDecl, ClsInstDecl(..),++  -- ** Standalone deriving declarations+  DerivDecl(..), LDerivDecl,+  -- ** Deriving strategies+  DerivStrategy(..), LDerivStrategy,+  derivStrategyName,+  -- ** @RULE@ declarations+  LRuleDecls,RuleDecls(..),RuleDecl(..),LRuleDecl,HsRuleRn(..),+  RuleBndr(..),LRuleBndr,+  collectRuleBndrSigTys,+  pprFullRuleName,+  -- ** @default@ declarations+  DefaultDecl(..), LDefaultDecl,+  -- ** Template haskell declaration splice+  SpliceExplicitFlag(..),+  SpliceDecl(..), LSpliceDecl,+  -- ** Foreign function interface declarations+  ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),+  CImportSpec(..),+  -- ** Data-constructor declarations+  ConDecl(..), LConDecl,+  HsConDeclH98Details, HsConDeclGADTDetails(..),+  -- ** Document comments+  DocDecl(..), LDocDecl, docDeclDoc,+  -- ** Deprecations+  WarnDecl(..),  LWarnDecl,+  WarnDecls(..), LWarnDecls,+  -- ** Annotations+  AnnDecl(..), LAnnDecl,+  AnnProvenance(..), annProvenanceName_maybe,+  -- ** Role annotations+  RoleAnnotDecl(..), LRoleAnnotDecl,+  -- ** Injective type families+  FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,++  -- * Grouping+  HsGroup(..), hsGroupInstDecls,+    ) where++-- friends:+import GHC.Prelude++import {-# SOURCE #-} Language.Haskell.Syntax.Expr+  ( HsExpr, HsSplice )+        -- Because Expr imports Decls via HsBracket++import Language.Haskell.Syntax.Binds+import Language.Haskell.Syntax.Type+import GHC.Hs.Doc+import GHC.Core.TyCon+import GHC.Types.Basic+import GHC.Types.ForeignCall+import Language.Haskell.Syntax.Extension+import GHC.Types.Name.Set+import GHC.Types.Fixity++-- others:+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Types.SrcLoc+import GHC.Types.SourceText+import GHC.Core.Type+import GHC.Unit.Module.Warnings++import GHC.Data.Maybe+import Data.Data        hiding (TyCon,Fixity, Infix)+import Data.Void++{-+************************************************************************+*                                                                      *+\subsection[HsDecl]{Declarations}+*                                                                      *+************************************************************************+-}++type LHsDecl p = XRec p (HsDecl p)+        -- ^ When in a list this may have+        --+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'+        --++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | A Haskell Declaration+data HsDecl p+  = TyClD      (XTyClD p)      (TyClDecl p)      -- ^ Type or Class Declaration+  | InstD      (XInstD p)      (InstDecl  p)     -- ^ Instance declaration+  | DerivD     (XDerivD p)     (DerivDecl p)     -- ^ Deriving declaration+  | ValD       (XValD p)       (HsBind p)        -- ^ Value declaration+  | SigD       (XSigD p)       (Sig p)           -- ^ Signature declaration+  | KindSigD   (XKindSigD p)   (StandaloneKindSig p) -- ^ Standalone kind signature+  | DefD       (XDefD p)       (DefaultDecl p)   -- ^ 'default' declaration+  | ForD       (XForD p)       (ForeignDecl p)   -- ^ Foreign declaration+  | WarningD   (XWarningD p)   (WarnDecls p)     -- ^ Warning declaration+  | AnnD       (XAnnD p)       (AnnDecl p)       -- ^ Annotation declaration+  | RuleD      (XRuleD p)      (RuleDecls p)     -- ^ Rule declaration+  | SpliceD    (XSpliceD p)    (SpliceDecl p)    -- ^ Splice declaration+                                                 -- (Includes quasi-quotes)+  | DocD       (XDocD p)       (DocDecl)  -- ^ Documentation comment declaration+  | RoleAnnotD (XRoleAnnotD p) (RoleAnnotDecl p) -- ^Role annotation declaration+  | XHsDecl    !(XXHsDecl p)++{-+Note [Top-level fixity signatures in an HsGroup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An `HsGroup p` stores every top-level fixity declarations in one of two places:++1. hs_fixds :: [LFixitySig p]++   This stores fixity signatures for top-level declarations (e.g., functions,+   data constructors, classes, type families, etc.) as well as fixity+   signatures for class methods written outside of the class, as in this+   example:++     infixl 4 `m1`+     class C1 a where+       m1 :: a -> a -> a++2. hs_tyclds :: [TyClGroup p]++   Each type class can be found in a TyClDecl inside a TyClGroup, and that+   TyClDecl stores the fixity signatures for its methods written inside of the+   class, as in this example:++     class C2 a where+       infixl 4 `m2`+       m2 :: a -> a -> a++The story for fixity signatures for class methods is made slightly complicated+by the fact that they can appear both inside and outside of the class itself,+and both forms of fixity signatures are considered top-level. This matters+in `GHC.Rename.Module.rnSrcDecls`, which must create a fixity environment out+of all top-level fixity signatures before doing anything else. Therefore,+`rnSrcDecls` must be aware of both (1) and (2) above. The+`hsGroupTopLevelFixitySigs` function is responsible for collecting this+information from an `HsGroup`.++One might wonder why we even bother separating top-level fixity signatures+into two places at all. That is, why not just take the fixity signatures+from `hs_tyclds` and put them into `hs_fixds` so that they are all in one+location? This ends up causing problems for `GHC.HsToCore.Quote.repTopDs`,+which translates each fixity signature in `hs_fixds` and `hs_tyclds` into a+Template Haskell `Dec`. If there are any duplicate signatures between the two+fields, this will result in an error (#17608).+-}++-- | Haskell Group+--+-- A 'HsDecl' is categorised into a 'HsGroup' before being+-- fed to the renamer.+data HsGroup p+  = HsGroup {+        hs_ext    :: XCHsGroup p,+        hs_valds  :: HsValBinds p,+        hs_splcds :: [LSpliceDecl p],++        hs_tyclds :: [TyClGroup p],+                -- A list of mutually-recursive groups;+                -- This includes `InstDecl`s as well;+                -- Parser generates a singleton list;+                -- renamer does dependency analysis++        hs_derivds :: [LDerivDecl p],++        hs_fixds  :: [LFixitySig p],+                -- A list of fixity signatures defined for top-level+                -- declarations and class methods (defined outside of the class+                -- itself).+                -- See Note [Top-level fixity signatures in an HsGroup]++        hs_defds  :: [LDefaultDecl p],+        hs_fords  :: [LForeignDecl p],+        hs_warnds :: [LWarnDecls p],+        hs_annds  :: [LAnnDecl p],+        hs_ruleds :: [LRuleDecls p],++        hs_docs   :: [LDocDecl p]+    }+  | XHsGroup !(XXHsGroup p)+++hsGroupInstDecls :: HsGroup id -> [LInstDecl id]+hsGroupInstDecls = (=<<) group_instds . hs_tyclds++-- | Located Splice Declaration+type LSpliceDecl pass = XRec pass (SpliceDecl pass)++-- | Splice Declaration+data SpliceDecl p+  = SpliceDecl                  -- Top level splice+        (XSpliceDecl p)+        (XRec p (HsSplice p))+        SpliceExplicitFlag+  | XSpliceDecl !(XXSpliceDecl p)++{-+************************************************************************+*                                                                      *+            Type and class declarations+*                                                                      *+************************************************************************++Note [The Naming story]+~~~~~~~~~~~~~~~~~~~~~~~+Here is the story about the implicit names that go with type, class,+and instance decls.  It's a bit tricky, so pay attention!++"Implicit" (or "system") binders+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  Each data type decl defines+        a worker name for each constructor+        to-T and from-T convertors+  Each class decl defines+        a tycon for the class+        a data constructor for that tycon+        the worker for that constructor+        a selector for each superclass++All have occurrence names that are derived uniquely from their parent+declaration.++None of these get separate definitions in an interface file; they are+fully defined by the data or class decl.  But they may *occur* in+interface files, of course.  Any such occurrence must haul in the+relevant type or class decl.++Plan of attack:+ - Ensure they "point to" the parent data/class decl+   when loading that decl from an interface file+   (See RnHiFiles.getSysBinders)++ - When typechecking the decl, we build the implicit TyCons and Ids.+   When doing so we look them up in the name cache (GHC.Rename.Env.lookupSysName),+   to ensure correct module and provenance is set++These are the two places that we have to conjure up the magic derived+names.  (The actual magic is in GHC.Types.Name.Occurrence.mkWorkerOcc, etc.)++Default methods+~~~~~~~~~~~~~~~+ - Occurrence name is derived uniquely from the method name+   E.g. $dmmax++ - If there is a default method name at all, it's recorded in+   the ClassOpSig (in GHC.Hs.Binds), in the DefMethInfo field.+   (DefMethInfo is defined in GHC.Core.Class)++Source-code class decls and interface-code class decls are treated subtly+differently, which has given me a great deal of confusion over the years.+Here's the deal.  (We distinguish the two cases because source-code decls+have (Just binds) in the tcdMeths field, whereas interface decls have Nothing.++In *source-code* class declarations:++ - When parsing, every ClassOpSig gets a DefMeth with a suitable RdrName+   This is done by GHC.Parser.PostProcess.mkClassOpSigDM++ - The renamer renames it to a Name++ - During typechecking, we generate a binding for each $dm for+   which there's a programmer-supplied default method:+        class Foo a where+          op1 :: <type>+          op2 :: <type>+          op1 = ...+   We generate a binding for $dmop1 but not for $dmop2.+   The Class for Foo has a Nothing for op2 and+                         a Just ($dm_op1, VanillaDM) for op1.+   The Name for $dmop2 is simply discarded.++In *interface-file* class declarations:+  - When parsing, we see if there's an explicit programmer-supplied default method+    because there's an '=' sign to indicate it:+        class Foo a where+          op1 = :: <type>       -- NB the '='+          op2   :: <type>+    We use this info to generate a DefMeth with a suitable RdrName for op1,+    and a NoDefMeth for op2+  - The interface file has a separate definition for $dmop1, with unfolding etc.+  - The renamer renames it to a Name.+  - The renamer treats $dmop1 as a free variable of the declaration, so that+    the binding for $dmop1 will be sucked in.  (See RnHsSyn.tyClDeclFVs)+    This doesn't happen for source code class decls, because they *bind* the default method.++Dictionary functions+~~~~~~~~~~~~~~~~~~~~+Each instance declaration gives rise to one dictionary function binding.++The type checker makes up new source-code instance declarations+(e.g. from 'deriving' or generic default methods --- see+GHC.Tc.TyCl.Instance.tcInstDecls1).  So we can't generate the names for+dictionary functions in advance (we don't know how many we need).++On the other hand for interface-file instance declarations, the decl+specifies the name of the dictionary function, and it has a binding elsewhere+in the interface file:+        instance {Eq Int} = dEqInt+        dEqInt :: {Eq Int} <pragma info>++So again we treat source code and interface file code slightly differently.++Source code:+  - Source code instance decls have a Nothing in the (Maybe name) field+    (see data InstDecl below)++  - The typechecker makes up a Local name for the dict fun for any source-code+    instance decl, whether it comes from a source-code instance decl, or whether+    the instance decl is derived from some other construct (e.g. 'deriving').++  - The occurrence name it chooses is derived from the instance decl (just for+    documentation really) --- e.g. dNumInt.  Two dict funs may share a common+    occurrence name, but will have different uniques.  E.g.+        instance Foo [Int]  where ...+        instance Foo [Bool] where ...+    These might both be dFooList++  - The CoreTidy phase externalises the name, and ensures the occurrence name is+    unique (this isn't special to dict funs).  So we'd get dFooList and dFooList1.++  - We can take this relaxed approach (changing the occurrence name later)+    because dict fun Ids are not captured in a TyCon or Class (unlike default+    methods, say).  Instead, they are kept separately in the InstEnv.  This+    makes it easy to adjust them after compiling a module.  (Once we've finished+    compiling that module, they don't change any more.)+++Interface file code:+  - The instance decl gives the dict fun name, so the InstDecl has a (Just name)+    in the (Maybe name) field.++  - RnHsSyn.instDeclFVs treats the dict fun name as free in the decl, so that we+    suck in the dfun binding+-}++-- | Located Declaration of a Type or Class+type LTyClDecl pass = XRec pass (TyClDecl pass)++-- | A type or class declaration.+data TyClDecl pass+  = -- | @type/data family T :: *->*@+    --+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',+    --             'GHC.Parser.Annotation.AnnData',+    --             'GHC.Parser.Annotation.AnnFamily','GHC.Parser.Annotation.AnnDcolon',+    --             'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpenP',+    --             'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnCloseP',+    --             'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnRarrow',+    --             'GHC.Parser.Annotation.AnnVbar'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    FamDecl { tcdFExt :: XFamDecl pass, tcdFam :: FamilyDecl pass }++  | -- | @type@ declaration+    --+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',+    --             'GHC.Parser.Annotation.AnnEqual',++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    SynDecl { tcdSExt   :: XSynDecl pass          -- ^ Post renameer, FVs+            , tcdLName  :: LIdP pass              -- ^ Type constructor+            , tcdTyVars :: LHsQTyVars pass        -- ^ Type variables; for an+                                                  -- associated type these+                                                  -- include outer binders+            , tcdFixity :: LexicalFixity          -- ^ Fixity used in the declaration+            , tcdRhs    :: LHsType pass }         -- ^ RHS of type declaration++  | -- | @data@ declaration+    --+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',+    --              'GHC.Parser.Annotation.AnnFamily',+    --              'GHC.Parser.Annotation.AnnNewType',+    --              'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnDcolon'+    --              'GHC.Parser.Annotation.AnnWhere',++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+    DataDecl { tcdDExt     :: XDataDecl pass       -- ^ Post renamer, CUSK flag, FVs+             , tcdLName    :: LIdP pass             -- ^ Type constructor+             , tcdTyVars   :: LHsQTyVars pass      -- ^ Type variables+                              -- See Note [TyVar binders for associated declarations]+             , tcdFixity   :: LexicalFixity        -- ^ Fixity used in the declaration+             , tcdDataDefn :: HsDataDefn pass }++  | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs+                tcdCtxt    :: Maybe (LHsContext pass), -- ^ Context...+                tcdLName   :: LIdP pass,               -- ^ Name of the class+                tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables+                tcdFixity  :: LexicalFixity, -- ^ Fixity used in the declaration+                tcdFDs     :: [LHsFunDep pass],         -- ^ Functional deps+                tcdSigs    :: [LSig pass],              -- ^ Methods' signatures+                tcdMeths   :: LHsBinds pass,            -- ^ Default methods+                tcdATs     :: [LFamilyDecl pass],       -- ^ Associated types;+                tcdATDefs  :: [LTyFamDefltDecl pass],   -- ^ Associated type defaults+                tcdDocs    :: [LDocDecl pass]           -- ^ Haddock docs+    }+        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnClass',+        --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',+        --           'GHC.Parser.Annotation.AnnClose'+        --   - The tcdFDs will have 'GHC.Parser.Annotation.AnnVbar',+        --                          'GHC.Parser.Annotation.AnnComma'+        --                          'GHC.Parser.Annotation.AnnRarrow'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XTyClDecl !(XXTyClDecl pass)++data FunDep pass+  = FunDep (XCFunDep pass)+           [LIdP pass]+           [LIdP pass]+  | XFunDep !(XXFunDep pass)++type LHsFunDep pass = XRec pass (FunDep pass)++data DataDeclRn = DataDeclRn+             { tcdDataCusk :: Bool    -- ^ does this have a CUSK?+                 -- See Note [CUSKs: complete user-supplied kind signatures]+             , tcdFVs      :: NameSet }+  deriving Data++{- Note [TyVar binders for associated decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For an /associated/ data, newtype, or type-family decl, the LHsQTyVars+/includes/ outer binders.  For example+    class T a where+       data D a c+       type F a b :: *+       type F a b = a -> a+Here the data decl for 'D', and type-family decl for 'F', both include 'a'+in their LHsQTyVars (tcdTyVars and fdTyVars resp).++Ditto any implicit binders in the hsq_implicit field of the LHSQTyVars.++The idea is that the associated type is really a top-level decl in its+own right.  However we are careful to use the same name 'a', so that+we can match things up.++c.f. Note [Associated type tyvar names] in GHC.Core.Class+     Note [Family instance declaration binders]+-}++{- Note [Class LayoutInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The LayoutInfo is used to associate Haddock comments with parts of the declaration.+Compare the following examples:++    class C a where+      f :: a -> Int+      -- ^ comment on f++    class C a where+      f :: a -> Int+    -- ^ comment on C++Notice how "comment on f" and "comment on C" differ only by indentation level.+Thus we have to record the indentation level of the class declarations.++See also Note [Adding Haddock comments to the syntax tree] in GHC.Parser.PostProcess.Haddock+-}++-- Simple classifiers for TyClDecl+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- | @True@ <=> argument is a @data@\/@newtype@+-- declaration.+isDataDecl :: TyClDecl pass -> Bool+isDataDecl (DataDecl {}) = True+isDataDecl _other        = False++-- | type or type instance declaration+isSynDecl :: TyClDecl pass -> Bool+isSynDecl (SynDecl {})   = True+isSynDecl _other        = False++-- | type class+isClassDecl :: TyClDecl pass -> Bool+isClassDecl (ClassDecl {}) = True+isClassDecl _              = False++-- | type/data family declaration+isFamilyDecl :: TyClDecl pass -> Bool+isFamilyDecl (FamDecl {})  = True+isFamilyDecl _other        = False++-- | type family declaration+isTypeFamilyDecl :: TyClDecl pass -> Bool+isTypeFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = info })) = case info of+  OpenTypeFamily      -> True+  ClosedTypeFamily {} -> True+  _                   -> False+isTypeFamilyDecl _ = False++-- | open type family info+isOpenTypeFamilyInfo :: FamilyInfo pass -> Bool+isOpenTypeFamilyInfo OpenTypeFamily = True+isOpenTypeFamilyInfo _              = False++-- | closed type family info+isClosedTypeFamilyInfo :: FamilyInfo pass -> Bool+isClosedTypeFamilyInfo (ClosedTypeFamily {}) = True+isClosedTypeFamilyInfo _                     = False++-- | data family declaration+isDataFamilyDecl :: TyClDecl pass -> Bool+isDataFamilyDecl (FamDecl _ (FamilyDecl { fdInfo = DataFamily })) = True+isDataFamilyDecl _other      = False++-- Dealing with names++tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs+tyClDeclTyVars d = tcdTyVars d++countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)+        -- class, synonym decls, data, newtype, family decls+countTyClDecls decls+ = (count isClassDecl    decls,+    count isSynDecl      decls,  -- excluding...+    count isDataTy       decls,  -- ...family...+    count isNewTy        decls,  -- ...instances+    count isFamilyDecl   decls)+ where+   isDataTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = DataType } } = True+   isDataTy _                                                       = False++   isNewTy DataDecl{ tcdDataDefn = HsDataDefn { dd_ND = NewType } } = True+   isNewTy _                                                      = False+++{- Note [CUSKs: complete user-supplied kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We kind-check declarations differently if they have a complete, user-supplied+kind signature (CUSK). This is because we can safely generalise a CUSKed+declaration before checking all of the others, supporting polymorphic recursion.+See https://gitlab.haskell.org/ghc/ghc/wikis/ghc-kinds/kind-inference#proposed-new-strategy+and #9200 for lots of discussion of how we got here.++The detection of CUSKs is enabled by the -XCUSKs extension, switched on by default.+Under -XNoCUSKs, all declarations are treated as if they have no CUSK.+See https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0036-kind-signatures.rst++PRINCIPLE:+  a type declaration has a CUSK iff we could produce a separate kind signature+  for it, just like a type signature for a function,+  looking only at the header of the declaration.++Examples:+  * data T1 (a :: *->*) (b :: *) = ....+    -- Has CUSK; equivalant to   T1 :: (*->*) -> * -> *++ * data T2 a b = ...+   -- No CUSK; we do not want to guess T2 :: * -> * -> *+   -- because the full decl might be   data T a b = MkT (a b)++  * data T3 (a :: k -> *) (b :: *) = ...+    -- CUSK; equivalent to   T3 :: (k -> *) -> * -> *+    -- We lexically generalise over k to get+    --    T3 :: forall k. (k -> *) -> * -> *+    -- The generalisation is here is purely lexical, just like+    --    f3 :: a -> a+    -- means+    --    f3 :: forall a. a -> a++  * data T4 (a :: j k) = ...+     -- CUSK; equivalent to   T4 :: j k -> *+     -- which we lexically generalise to  T4 :: forall j k. j k -> *+     -- and then, if PolyKinds is on, we further generalise to+     --   T4 :: forall kk (j :: kk -> *) (k :: kk). j k -> *+     -- Again this is exactly like what happens as the term level+     -- when you write+     --    f4 :: forall a b. a b -> Int++NOTE THAT+  * A CUSK does /not/ mean that everything about the kind signature is+    fully specified by the user.  Look at T4 and f4: we had to do kind+    inference to figure out the kind-quantification.  But in both cases+    (T4 and f4) that inference is done looking /only/ at the header of T4+    (or signature for f4), not at the definition thereof.++  * The CUSK completely fixes the kind of the type constructor, forever.++  * The precise rules, for each declaration form, for whether a declaration+    has a CUSK are given in the user manual section "Complete user-supplied+    kind signatures and polymorphic recursion".  But they simply implement+    PRINCIPLE above.++  * Open type families are interesting:+      type family T5 a b :: *+    There simply /is/ no accompanying declaration, so that info is all+    we'll ever get.  So we it has a CUSK by definition, and we default+    any un-fixed kind variables to *.++  * Associated types are a bit tricker:+      class C6 a where+         type family T6 a b :: *+         op :: a Int -> Int+    Here C6 does not have a CUSK (in fact we ultimately discover that+    a :: * -> *).  And hence neither does T6, the associated family,+    because we can't fix its kind until we have settled C6.  Another+    way to say it: unlike a top-level, we /may/ discover more about+    a's kind from C6's definition.++  * A data definition with a top-level :: must explicitly bind all+    kind variables to the right of the ::. See test+    dependent/should_compile/KindLevels, which requires this+    case. (Naturally, any kind variable mentioned before the :: should+    not be bound after it.)++    This last point is much more debatable than the others; see+    #15142 comment:22++    Because this is fiddly to check, there is a field in the DataDeclRn+    structure (included in a DataDecl after the renamer) that stores whether+    or not the declaration has a CUSK.+-}+++{- *********************************************************************+*                                                                      *+                         TyClGroup+        Strongly connected components of+      type, class, instance, and role declarations+*                                                                      *+********************************************************************* -}++{- Note [TyClGroups and dependency analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A TyClGroup represents a strongly connected components of type/class/instance+decls, together with the role annotations for the type/class declarations.++The hs_tyclds :: [TyClGroup] field of a HsGroup is a dependency-order+sequence of strongly-connected components.++Invariants+ * The type and class declarations, group_tyclds, may depend on each+   other, or earlier TyClGroups, but not on later ones++ * The role annotations, group_roles, are role-annotations for some or+   all of the types and classes in group_tyclds (only).++ * The instance declarations, group_instds, may (and usually will)+   depend on group_tyclds, or on earlier TyClGroups, but not on later+   ones.++See Note [Dependency analysis of type, class, and instance decls]+in GHC.Rename.Module for more info.+-}++-- | Type or Class Group+data TyClGroup pass  -- See Note [TyClGroups and dependency analysis]+  = TyClGroup { group_ext    :: XCTyClGroup pass+              , group_tyclds :: [LTyClDecl pass]+              , group_roles  :: [LRoleAnnotDecl pass]+              , group_kisigs :: [LStandaloneKindSig pass]+              , group_instds :: [LInstDecl pass] }+  | XTyClGroup !(XXTyClGroup pass)+++tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]+tyClGroupTyClDecls = concatMap group_tyclds++tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]+tyClGroupInstDecls = concatMap group_instds++tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]+tyClGroupRoleDecls = concatMap group_roles++tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]+tyClGroupKindSigs = concatMap group_kisigs+++{- *********************************************************************+*                                                                      *+               Data and type family declarations+*                                                                      *+********************************************************************* -}++{- Note [FamilyResultSig]+~~~~~~~~~~~~~~~~~~~~~~~~~++This data type represents the return signature of a type family.  Possible+values are:++ * NoSig - the user supplied no return signature:+      type family Id a where ...++ * KindSig - the user supplied the return kind:+      type family Id a :: * where ...++ * TyVarSig - user named the result with a type variable and possibly+   provided a kind signature for that variable:+      type family Id a = r where ...+      type family Id a = (r :: *) where ...++   Naming result of a type family is required if we want to provide+   injectivity annotation for a type family:+      type family Id a = r | r -> a where ...++See also: Note [Injectivity annotation]++Note [Injectivity annotation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A user can declare a type family to be injective:++   type family Id a = r | r -> a where ...++ * The part after the "|" is called "injectivity annotation".+ * "r -> a" part is called "injectivity condition"; at the moment terms+   "injectivity annotation" and "injectivity condition" are synonymous+   because we only allow a single injectivity condition.+ * "r" is the "LHS of injectivity condition". LHS can only contain the+   variable naming the result of a type family.++ * "a" is the "RHS of injectivity condition". RHS contains space-separated+   type and kind variables representing the arguments of a type+   family. Variables can be omitted if a type family is not injective in+   these arguments. Example:+         type family Foo a b c = d | d -> a c where ...++Note that:+ (a) naming of type family result is required to provide injectivity+     annotation+ (b) for associated types if the result was named then injectivity annotation+     is mandatory. Otherwise result type variable is indistinguishable from+     associated type default.++It is possible that in the future this syntax will be extended to support+more complicated injectivity annotations. For example we could declare that+if we know the result of Plus and one of its arguments we can determine the+other argument:++   type family Plus a b = (r :: Nat) | r a -> b, r b -> a where ...++Here injectivity annotation would consist of two comma-separated injectivity+conditions.++See also Note [Injective type families] in GHC.Core.TyCon+-}++-- | Located type Family Result Signature+type LFamilyResultSig pass = XRec pass (FamilyResultSig pass)++-- | type Family Result Signature+data FamilyResultSig pass = -- see Note [FamilyResultSig]+    NoSig (XNoSig pass)+  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | KindSig  (XCKindSig pass) (LHsKind pass)+  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :+  --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',+  --             'GHC.Parser.Annotation.AnnCloseP'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | TyVarSig (XTyVarSig pass) (LHsTyVarBndr () pass)+  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :+  --             'GHC.Parser.Annotation.AnnOpenP','GHC.Parser.Annotation.AnnDcolon',+  --             'GHC.Parser.Annotation.AnnCloseP', 'GHC.Parser.Annotation.AnnEqual'+  | XFamilyResultSig !(XXFamilyResultSig pass)++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+++-- | Located type Family Declaration+type LFamilyDecl pass = XRec pass (FamilyDecl pass)++-- | type Family Declaration+data FamilyDecl pass = FamilyDecl+  { fdExt            :: XCFamilyDecl pass+  , fdInfo           :: FamilyInfo pass              -- type/data, closed/open+  , fdTopLevel       :: TopLevelFlag                 -- used for printing only+  , fdLName          :: LIdP pass                    -- type constructor+  , fdTyVars         :: LHsQTyVars pass              -- type variables+                       -- See Note [TyVar binders for associated declarations]+  , fdFixity         :: LexicalFixity                -- Fixity used in the declaration+  , fdResultSig      :: LFamilyResultSig pass        -- result signature+  , fdInjectivityAnn :: Maybe (LInjectivityAnn pass) -- optional injectivity ann+  }+  | XFamilyDecl !(XXFamilyDecl pass)+  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',+  --             'GHC.Parser.Annotation.AnnData', 'GHC.Parser.Annotation.AnnFamily',+  --             'GHC.Parser.Annotation.AnnWhere', 'GHC.Parser.Annotation.AnnOpenP',+  --             'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnCloseP',+  --             'GHC.Parser.Annotation.AnnEqual', 'GHC.Parser.Annotation.AnnRarrow',+  --             'GHC.Parser.Annotation.AnnVbar'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+++-- | Located Injectivity Annotation+type LInjectivityAnn pass = XRec pass (InjectivityAnn pass)++-- | If the user supplied an injectivity annotation it is represented using+-- InjectivityAnn. At the moment this is a single injectivity condition - see+-- Note [Injectivity annotation]. `Located name` stores the LHS of injectivity+-- condition. `[Located name]` stores the RHS of injectivity condition. Example:+--+--   type family Foo a b c = r | r -> a c where ...+--+-- This will be represented as "InjectivityAnn `r` [`a`, `c`]"+data InjectivityAnn pass+  = InjectivityAnn (XCInjectivityAnn pass)+                   (LIdP pass) [LIdP pass]+  -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :+  --             'GHC.Parser.Annotation.AnnRarrow', 'GHC.Parser.Annotation.AnnVbar'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XInjectivityAnn !(XXInjectivityAnn pass)++data FamilyInfo pass+  = DataFamily+  | OpenTypeFamily+     -- | 'Nothing' if we're in an hs-boot file and the user+     -- said "type family Foo x where .."+  | ClosedTypeFamily (Maybe [LTyFamInstEqn pass])+++------------- Pretty printing FamilyDecls -----------++pprFlavour :: FamilyInfo pass -> SDoc+pprFlavour DataFamily            = text "data"+pprFlavour OpenTypeFamily        = text "type"+pprFlavour (ClosedTypeFamily {}) = text "type"++instance Outputable (FamilyInfo pass) where+  ppr info = pprFlavour info <+> text "family"++++{- *********************************************************************+*                                                                      *+               Data types and data constructors+*                                                                      *+********************************************************************* -}++-- | Haskell Data type Definition+data HsDataDefn pass   -- The payload of a data type defn+                       -- Used *both* for vanilla data declarations,+                       --       *and* for data family instances+  = -- | Declares a data type or newtype, giving its constructors+    -- @+    --  data/newtype T a = <constrs>+    --  data/newtype instance T [a] = <constrs>+    -- @+    HsDataDefn { dd_ext    :: XCHsDataDefn pass,+                 dd_ND     :: NewOrData,+                 dd_ctxt   :: Maybe (LHsContext pass), -- ^ Context+                 dd_cType  :: Maybe (XRec pass CType),+                 dd_kindSig:: Maybe (LHsKind pass),+                     -- ^ Optional kind signature.+                     --+                     -- @(Just k)@ for a GADT-style @data@,+                     -- or @data instance@ decl, with explicit kind sig+                     --+                     -- Always @Nothing@ for H98-syntax decls++                 dd_cons   :: [LConDecl pass],+                     -- ^ Data constructors+                     --+                     -- For @data T a = T1 | T2 a@+                     --   the 'LConDecl's all have 'ConDeclH98'.+                     -- For @data T a where { T1 :: T a }@+                     --   the 'LConDecls' all have 'ConDeclGADT'.++                 dd_derivs :: HsDeriving pass  -- ^ Optional 'deriving' clause++             -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+   }+  | XHsDataDefn !(XXHsDataDefn pass)++-- | Haskell Deriving clause+type HsDeriving pass = [LHsDerivingClause pass]+  -- ^ The optional @deriving@ clauses of a data declaration. "Clauses" is+  -- plural because one can specify multiple deriving clauses using the+  -- @-XDerivingStrategies@ language extension.+  --+  -- The list of 'LHsDerivingClause's corresponds to exactly what the user+  -- requested to derive, in order. If no deriving clauses were specified,+  -- the list is empty.++type LHsDerivingClause pass = XRec pass (HsDerivingClause pass)++-- | A single @deriving@ clause of a data declaration.+--+--  - 'GHC.Parser.Annotation.AnnKeywordId' :+--       'GHC.Parser.Annotation.AnnDeriving', 'GHC.Parser.Annotation.AnnStock',+--       'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype',+--       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'+data HsDerivingClause pass+  -- See Note [Deriving strategies] in GHC.Tc.Deriv+  = HsDerivingClause+    { deriv_clause_ext :: XCHsDerivingClause pass+    , deriv_clause_strategy :: Maybe (LDerivStrategy pass)+      -- ^ The user-specified strategy (if any) to use when deriving+      -- 'deriv_clause_tys'.+    , deriv_clause_tys :: LDerivClauseTys pass+      -- ^ The types to derive.+    }+  | XHsDerivingClause !(XXHsDerivingClause pass)++type LDerivClauseTys pass = XRec pass (DerivClauseTys pass)++-- | The types mentioned in a single @deriving@ clause. This can come in two+-- forms, 'DctSingle' or 'DctMulti', depending on whether the types are+-- surrounded by enclosing parentheses or not. These parentheses are+-- semantically different than 'HsParTy'. For example, @deriving ()@ means+-- \"derive zero classes\" rather than \"derive an instance of the 0-tuple\".+--+-- 'DerivClauseTys' use 'LHsSigType' because @deriving@ clauses can mention+-- type variables that aren't bound by the datatype, e.g.+--+-- > data T b = ... deriving (C [a])+--+-- should produce a derived instance for @C [a] (T b)@.+data DerivClauseTys pass+  = -- | A @deriving@ clause with a single type. Moreover, that type can only+    -- be a type constructor without any arguments.+    --+    -- Example: @deriving Eq@+    DctSingle (XDctSingle pass) (LHsSigType pass)++    -- | A @deriving@ clause with a comma-separated list of types, surrounded+    -- by enclosing parentheses.+    --+    -- Example: @deriving (Eq, C a)@+  | DctMulti (XDctMulti pass) [LHsSigType pass]++  | XDerivClauseTys !(XXDerivClauseTys pass)++-- | Located Standalone Kind Signature+type LStandaloneKindSig pass = XRec pass (StandaloneKindSig pass)++data StandaloneKindSig pass+  = StandaloneKindSig (XStandaloneKindSig pass)+      (LIdP pass)           -- Why a single binder? See #16754+      (LHsSigType pass)     -- Why not LHsSigWcType? See Note [Wildcards in standalone kind signatures]+  | XStandaloneKindSig !(XXStandaloneKindSig pass)++{- Note [Wildcards in standalone kind signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Standalone kind signatures enable polymorphic recursion, and it is unclear how+to reconcile this with partial type signatures, so we disallow wildcards in+them.++We reject wildcards in 'rnStandaloneKindSignature' by returning False for+'StandaloneKindSigCtx' in 'wildCardsAllowed'.++The alternative design is to have special treatment for partial standalone kind+signatures, much like we have special treatment for partial type signatures in+terms. However, partial standalone kind signatures are not a proper replacement+for CUSKs, so this would be a separate feature.+-}++data NewOrData+  = NewType                     -- ^ @newtype Blah ...@+  | DataType                    -- ^ @data Blah ...@+  deriving( Eq, Data )                -- Needed because Demand derives Eq++-- | Convert a 'NewOrData' to a 'TyConFlavour'+newOrDataToFlavour :: NewOrData -> TyConFlavour+newOrDataToFlavour NewType  = NewtypeFlavour+newOrDataToFlavour DataType = DataTypeFlavour+++-- | Located data Constructor Declaration+type LConDecl pass = XRec pass (ConDecl pass)+      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when+      --   in a GADT constructor list++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- |+--+-- @+-- data T b = forall a. Eq a => MkT a b+--   MkT :: forall b a. Eq a => MkT a b+--+-- data T b where+--      MkT1 :: Int -> T Int+--+-- data T = Int `MkT` Int+--        | MkT2+--+-- data T a where+--      Int `MkT` Int :: T Int+-- @+--+-- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',+--            'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnCLose',+--            'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnVbar',+--            'GHC.Parser.Annotation.AnnDarrow','GHC.Parser.Annotation.AnnDarrow',+--            'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot'++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | data Constructor Declaration+data ConDecl pass+  = ConDeclGADT+      { con_g_ext   :: XConDeclGADT pass+      , con_names   :: [LIdP pass]++      -- The following fields describe the type after the '::'+      -- See Note [GADT abstract syntax]+      , con_bndrs   :: XRec pass (HsOuterSigTyVarBndrs pass)+        -- ^ The outermost type variable binders, be they explicit or+        --   implicit.  The 'XRec' is used to anchor exact print+        --   annotations, AnnForall and AnnDot.+      , con_mb_cxt  :: Maybe (LHsContext pass)   -- ^ User-written context (if any)+      , con_g_args  :: HsConDeclGADTDetails pass -- ^ Arguments; never infix+      , con_res_ty  :: LHsType pass              -- ^ Result type++      , con_doc     :: Maybe LHsDocString+          -- ^ A possible Haddock comment.+      }++  | ConDeclH98+      { con_ext     :: XConDeclH98 pass+      , con_name    :: LIdP pass++      , con_forall  :: Bool+                              -- ^ True <=> explicit user-written forall+                              --     e.g. data T a = forall b. MkT b (b->a)+                              --     con_ex_tvs = {b}+                              -- False => con_ex_tvs is empty+      , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only+      , con_mb_cxt :: Maybe (LHsContext pass)         -- ^ User-written context (if any)+      , con_args   :: HsConDeclH98Details pass        -- ^ Arguments; can be infix++      , con_doc       :: Maybe LHsDocString+          -- ^ A possible Haddock comment.+      }+  | XConDecl !(XXConDecl pass)++{- Note [GADT abstract syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The types of both forms of GADT constructors are very structured, as they+must consist of the quantified type variables (if provided), followed by the+context (if provided), followed by the argument types (if provided), followed+by the result type. (See "Wrinkle: No nested foralls or contexts" below for+more discussion on the restrictions imposed here.) As a result, instead of+storing the type of a GADT constructor as a single LHsType, we split it up+into its constituent components for easier access.++There are two broad ways to classify GADT constructors:++* Record-syntax constructors. For example:++    data T a where+      K :: forall a. Ord a => { x :: [a], ... } -> T a++* Prefix constructors, which do not use record syntax. For example:++    data T a where+      K :: forall a. Ord a => [a] -> ... -> T a++This distinction is recorded in the `con_args :: HsConDetails pass`, which+tracks if we're dealing with a RecCon or PrefixCon. It is easy to distinguish+the two in the AST since record GADT constructors use HsRecTy. This distinction+is made in GHC.Parser.PostProcess.mkGadtDecl.++It is worth elaborating a bit more on the process of splitting the argument+types of a GADT constructor, since there are some non-obvious details involved.+While splitting the argument types of a record GADT constructor is easy (they+are stored in an HsRecTy), splitting the arguments of a prefix GADT constructor+is trickier. The basic idea is that we must split along the outermost function+arrows ((->) and (%1 ->)) in the type, which GHC.Hs.Type.splitHsFunType+accomplishes. But what about type operators? Consider:++  C :: a :*: b -> a :*: b -> a :+: b++This could parse in many different ways depending on the precedences of each+type operator. In particular, if (:*:) were to have lower precedence than (->),+then it could very well parse like this:++  a :*: ((b -> a) :*: ((b -> a) :+: b)))++This would give the false impression that the whole type is part of one large+return type, with no arguments. Note that we do not fully resolve the exact+precedences of each user-defined type operator until the renamer, so this a+more difficult task for the parser.++Fortunately, there is no risk of the above happening. GHC's parser gives+special treatment to function arrows, and as a result, they are always parsed+with a lower precedence than any other type operator. As a result, the type+above is actually parsed like this:++  (a :*: b) -> ((a :*: b) -> (a :+: b))++While we won't know the exact precedences of (:*:) and (:+:) until the renamer,+all we are concerned about in the parser is identifying the overall shape of+the argument and result types, which we can accomplish by piggybacking on the+special treatment given to function arrows. In a future where function arrows+aren't given special status in the parser, we will likely have to modify+GHC.Parser.PostProcess.mkHsOpTyPV to preserve this trick.++-----+-- Wrinkle: No nested foralls or contexts+-----++GADT constructors provide some freedom to change the order of foralls in their+types (see Note [DataCon user type variable binders] in GHC.Core.DataCon), but+this freedom is still limited. GADTs still require that all quantification+occurs "prenex". That is, any explicitly quantified type variables must occur+at the front of the GADT type, followed by any contexts, followed by the body of+the GADT type, in precisely that order. For instance:++  data T where+    MkT1 :: forall a b. (Eq a, Eq b) => a -> b -> T+      -- OK+    MkT2 :: forall a. Eq a => forall b. a -> b -> T+      -- Rejected, `forall b` is nested+    MkT3 :: forall a b. Eq a => Eq b => a -> b -> T+      -- Rejected, `Eq b` is nested+    MkT4 :: Int -> forall a. a -> T+      -- Rejected, `forall a` is nested+    MkT5 :: forall a. Int -> Eq a => a -> T+      -- Rejected, `Eq a` is nested+    MkT6 :: (forall a. a -> T)+      -- Rejected, `forall a` is nested due to the surrounding parentheses+    MkT7 :: (Eq a => a -> t)+      -- Rejected, `Eq a` is nested due to the surrounding parentheses++For the full details, see the "Formal syntax for GADTs" section of the GHC+User's Guide. GHC enforces that GADT constructors do not have nested `forall`s+or contexts in two parts:++1. GHC, in the process of splitting apart a GADT's type,+   extracts out the leading `forall` and context (if they are provided). To+   accomplish this splitting, the renamer uses the+   GHC.Hs.Type.splitLHsGADTPrefixTy function, which is careful not to remove+   parentheses surrounding the leading `forall` or context (as these+   parentheses can be syntactically significant). If the third result returned+   by splitLHsGADTPrefixTy contains any `forall`s or contexts, then they must+   be nested, so they will be rejected.++   Note that this step applies to both prefix and record GADTs alike, as they+   both have syntax which permits `forall`s and contexts. The difference is+   where this step happens:++   * For prefix GADTs, this happens in the renamer (in rnConDecl), as we cannot+     split until after the type operator fixities have been resolved.+   * For record GADTs, this happens in the parser (in mkGadtDecl).+2. If the GADT type is prefix, the renamer (in the ConDeclGADTPrefixPs case of+   rnConDecl) will then check for nested `forall`s/contexts in the body of a+   prefix GADT type, after it has determined what all of the argument types are.+   This step is necessary to catch examples like MkT4 above, where the nested+   quantification occurs after a visible argument type.+-}++-- | The arguments in a Haskell98-style data constructor.+type HsConDeclH98Details pass+   = HsConDetails Void (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass])+-- The Void argument to HsConDetails here is a reflection of the fact that+-- type applications are not allowed in data constructor declarations.++-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors,+-- GADT constructors cannot be declared with infix syntax. As a result, we do+-- not use 'HsConDetails' here, as 'InfixCon' would be an unrepresentable+-- state. (There is a notion of infix GADT constructors for the purposes of+-- derived Show instances—see Note [Infix GADT constructors] in+-- GHC.Tc.TyCl—but that is an orthogonal concern.)+data HsConDeclGADTDetails pass+   = PrefixConGADT [HsScaled pass (LBangType pass)]+   | RecConGADT (XRec pass [LConDeclField pass])++instance Outputable NewOrData where+  ppr NewType  = text "newtype"+  ppr DataType = text "data"++{-+************************************************************************+*                                                                      *+                Instance declarations+*                                                                      *+************************************************************************++Note [Type family instance declarations in HsSyn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The data type FamEqn represents one equation of a type family instance.+Aside from the pass, it is also parameterised over another field, feqn_rhs.+feqn_rhs is either an HsDataDefn (for data family instances) or an LHsType+(for type family instances).++Type family instances also include associated type family default equations.+That is because a default for a type family looks like this:++  class C a where+    type family F a b :: Type+    type F c d = (c,d)   -- Default instance++The default declaration is really just a `type instance` declaration, but one+with particularly simple patterns: they must all be distinct type variables.+That's because we will instantiate it (in an instance declaration for `C`) if+we don't give an explicit instance for `F`. Note that the names of the+variables don't need to match those of the class: it really is like a+free-standing `type instance` declaration.+-}++----------------- Type synonym family instances -------------++-- | Located Type Family Instance Equation+type LTyFamInstEqn pass = XRec pass (TyFamInstEqn pass)+  -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'+  --   when in a list++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Haskell Type Patterns+type HsTyPats pass = [LHsTypeArg pass]++{- Note [Family instance declaration binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The feqn_pats field of FamEqn (family instance equation) stores the LHS type+(and kind) patterns. Any type (and kind) variables contained+in these type patterns are bound in the feqn_bndrs field.+Note that in particular:++* The feqn_bndrs *include* any anonymous wildcards.  For example+     type instance F a _ = a+  The feqn_bndrs will be HsOuterImplicit {a, _}.  Remember that each separate+  wildcard '_' gets its own unique.  In this context wildcards behave just like+  an ordinary type variable, only anonymous.++* The feqn_bndrs *include* type variables that are already in scope++   Eg   class C s t where+          type F t p :: *+        instance C w (a,b) where+          type F (a,b) x = x->a+   The feqn_bndrs of the F decl is HsOuterImplicit {a,b,x}, even though the+   F decl is nested inside the 'instance' decl.++   However after the renamer, the uniques will match up:+        instance C w7 (a8,b9) where+          type F (a8,b9) x10 = x10->a8+   so that we can compare the type pattern in the 'instance' decl and+   in the associated 'type' decl++c.f. Note [TyVar binders for associated decls]+-}++-- | Type Family Instance Equation+type TyFamInstEqn pass = FamEqn pass (LHsType pass)+            -- Here, the @pats@ are type patterns (with kind and type bndrs).+            -- See Note [Family instance declaration binders]++-- | Type family default declarations.+-- A convenient synonym for 'TyFamInstDecl'.+-- See @Note [Type family instance declarations in HsSyn]@.+type TyFamDefltDecl = TyFamInstDecl++-- | Located type family default declarations.+type LTyFamDefltDecl pass = XRec pass (TyFamDefltDecl pass)++-- | Located Type Family Instance Declaration+type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)++-- | Type Family Instance Declaration+data TyFamInstDecl pass+  = TyFamInstDecl { tfid_xtn :: XCTyFamInstDecl pass+                  , tfid_eqn :: TyFamInstEqn pass }+    -- ^+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',+    --           'GHC.Parser.Annotation.AnnInstance',++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XTyFamInstDecl !(XXTyFamInstDecl pass)++----------------- Data family instances -------------++-- | Located Data Family Instance Declaration+type LDataFamInstDecl pass = XRec pass (DataFamInstDecl pass)++-- | Data Family Instance Declaration+newtype DataFamInstDecl pass+  = DataFamInstDecl { dfid_eqn :: FamEqn pass (HsDataDefn pass) }+    -- ^+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnData',+    --           'GHC.Parser.Annotation.AnnNewType','GHC.Parser.Annotation.AnnInstance',+    --           'GHC.Parser.Annotation.AnnDcolon'+    --           'GHC.Parser.Annotation.AnnWhere','GHC.Parser.Annotation.AnnOpen',+    --           'GHC.Parser.Annotation.AnnClose'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++----------------- Family instances (common types) -------------++-- | Family Equation+--+-- One equation in a type family instance declaration, data family instance+-- declaration, or type family default.+-- See Note [Type family instance declarations in HsSyn]+-- See Note [Family instance declaration binders]+data FamEqn pass rhs+  = FamEqn+       { feqn_ext    :: XCFamEqn pass rhs+       , feqn_tycon  :: LIdP pass+       , feqn_bndrs  :: HsOuterFamEqnTyVarBndrs pass -- ^ Optional quantified type vars+       , feqn_pats   :: HsTyPats pass+       , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration+       , feqn_rhs    :: rhs+       }+    -- ^+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual'+  | XFamEqn !(XXFamEqn pass rhs)++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++----------------- Class instances -------------++-- | Located Class Instance Declaration+type LClsInstDecl pass = XRec pass (ClsInstDecl pass)++-- | Class Instance Declaration+data ClsInstDecl pass+  = ClsInstDecl+      { cid_ext     :: XCClsInstDecl pass+      , cid_poly_ty :: LHsSigType pass    -- Context => Class Instance-type+                                          -- Using a polytype means that the renamer conveniently+                                          -- figures out the quantified type variables for us.+      , cid_binds         :: LHsBinds pass       -- Class methods+      , cid_sigs          :: [LSig pass]         -- User-supplied pragmatic info+      , cid_tyfam_insts   :: [LTyFamInstDecl pass]   -- Type family instances+      , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances+      , cid_overlap_mode  :: Maybe (XRec pass OverlapMode)+         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+         --                                    'GHC.Parser.Annotation.AnnClose',++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+      }+    -- ^+    --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnInstance',+    --           'GHC.Parser.Annotation.AnnWhere',+    --           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XClsInstDecl !(XXClsInstDecl pass)++----------------- Instances of all kinds -------------++-- | Located Instance Declaration+type LInstDecl pass = XRec pass (InstDecl pass)++-- | Instance Declaration+data InstDecl pass  -- Both class and family instances+  = ClsInstD+      { cid_d_ext :: XClsInstD pass+      , cid_inst  :: ClsInstDecl pass }+  | DataFamInstD              -- data family instance+      { dfid_ext  :: XDataFamInstD pass+      , dfid_inst :: DataFamInstDecl pass }+  | TyFamInstD              -- type family instance+      { tfid_ext  :: XTyFamInstD pass+      , tfid_inst :: TyFamInstDecl pass }+  | XInstDecl !(XXInstDecl pass)++{-+************************************************************************+*                                                                      *+\subsection[DerivDecl]{A stand-alone instance deriving declaration}+*                                                                      *+************************************************************************+-}++-- | Located stand-alone 'deriving instance' declaration+type LDerivDecl pass = XRec pass (DerivDecl pass)++-- | Stand-alone 'deriving instance' declaration+data DerivDecl pass = DerivDecl+        { deriv_ext          :: XCDerivDecl pass+        , deriv_type         :: LHsSigWcType pass+          -- ^ The instance type to derive.+          --+          -- It uses an 'LHsSigWcType' because the context is allowed to be a+          -- single wildcard:+          --+          -- > deriving instance _ => Eq (Foo a)+          --+          -- Which signifies that the context should be inferred.++          -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer.++        , deriv_strategy     :: Maybe (LDerivStrategy pass)+        , deriv_overlap_mode :: Maybe (XRec pass OverlapMode)+         -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDeriving',+         --        'GHC.Parser.Annotation.AnnInstance', 'GHC.Parser.Annotation.AnnStock',+         --        'GHC.Parser.Annotation.AnnAnyClass', 'GHC.Parser.Annotation.AnnNewtype',+         --        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+        }+  | XDerivDecl !(XXDerivDecl pass)++{-+************************************************************************+*                                                                      *+                Deriving strategies+*                                                                      *+************************************************************************+-}++-- | A 'Located' 'DerivStrategy'.+type LDerivStrategy pass = XRec pass (DerivStrategy pass)++-- | Which technique the user explicitly requested when deriving an instance.+data DerivStrategy pass+  -- See Note [Deriving strategies] in GHC.Tc.Deriv+  = StockStrategy (XStockStrategy pass)+                     -- ^ GHC's \"standard\" strategy, which is to implement a+                     --   custom instance for the data type. This only works+                     --   for certain types that GHC knows about (e.g., 'Eq',+                     --   'Show', 'Functor' when @-XDeriveFunctor@ is enabled,+                     --   etc.)+  | AnyclassStrategy (XAnyClassStrategy pass) -- ^ @-XDeriveAnyClass@+  | NewtypeStrategy  (XNewtypeStrategy pass)  -- ^ @-XGeneralizedNewtypeDeriving@+  | ViaStrategy (XViaStrategy pass)+                     -- ^ @-XDerivingVia@++-- | A short description of a @DerivStrategy'@.+derivStrategyName :: DerivStrategy a -> SDoc+derivStrategyName = text . go+  where+    go StockStrategy    {} = "stock"+    go AnyclassStrategy {} = "anyclass"+    go NewtypeStrategy  {} = "newtype"+    go ViaStrategy      {} = "via"++{-+************************************************************************+*                                                                      *+\subsection[DefaultDecl]{A @default@ declaration}+*                                                                      *+************************************************************************++There can only be one default declaration per module, but it is hard+for the parser to check that; we pass them all through in the abstract+syntax, and that restriction must be checked in the front end.+-}++-- | Located Default Declaration+type LDefaultDecl pass = XRec pass (DefaultDecl pass)++-- | Default Declaration+data DefaultDecl pass+  = DefaultDecl (XCDefaultDecl pass) [LHsType pass]+        -- ^ - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnDefault',+        --          'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XDefaultDecl !(XXDefaultDecl pass)++{-+************************************************************************+*                                                                      *+\subsection{Foreign function interface declaration}+*                                                                      *+************************************************************************+-}++-- foreign declarations are distinguished as to whether they define or use a+-- Haskell name+--+--  * the Boolean value indicates whether the pre-standard deprecated syntax+--   has been used++-- | Located Foreign Declaration+type LForeignDecl pass = XRec pass (ForeignDecl pass)++-- | Foreign Declaration+data ForeignDecl pass+  = ForeignImport+      { fd_i_ext  :: XForeignImport pass   -- Post typechecker, rep_ty ~ sig_ty+      , fd_name   :: LIdP pass             -- defines this name+      , fd_sig_ty :: LHsSigType pass       -- sig_ty+      , fd_fi     :: ForeignImport }++  | ForeignExport+      { fd_e_ext  :: XForeignExport pass   -- Post typechecker, rep_ty ~ sig_ty+      , fd_name   :: LIdP pass             -- uses this name+      , fd_sig_ty :: LHsSigType pass       -- sig_ty+      , fd_fe     :: ForeignExport }+        -- ^+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForeign',+        --           'GHC.Parser.Annotation.AnnImport','GHC.Parser.Annotation.AnnExport',+        --           'GHC.Parser.Annotation.AnnDcolon'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XForeignDecl !(XXForeignDecl pass)++{-+    In both ForeignImport and ForeignExport:+        sig_ty is the type given in the Haskell code+        rep_ty is the representation for this type, i.e. with newtypes+               coerced away and type functions evaluated.+    Thus if the declaration is valid, then rep_ty will only use types+    such as Int and IO that we know how to make foreign calls with.+-}++-- Specification Of an imported external entity in dependence on the calling+-- convention+--+data ForeignImport = -- import of a C entity+                     --+                     --  * the two strings specifying a header file or library+                     --   may be empty, which indicates the absence of a+                     --   header or object specification (both are not used+                     --   in the case of `CWrapper' and when `CFunction'+                     --   has a dynamic target)+                     --+                     --  * the calling convention is irrelevant for code+                     --   generation in the case of `CLabel', but is needed+                     --   for pretty printing+                     --+                     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'+                     --+                     CImport  (Located CCallConv) -- ccall or stdcall+                              (Located Safety)  -- interruptible, safe or unsafe+                              (Maybe Header)       -- name of C header+                              CImportSpec          -- details of the C entity+                              (Located SourceText) -- original source text for+                                                   -- the C entity+  deriving Data++-- details of an external C entity+--+data CImportSpec = CLabel    CLabelString     -- import address of a C label+                 | CFunction CCallTarget      -- static or dynamic function+                 | CWrapper                   -- wrapper to expose closures+                                              -- (former f.e.d.)+  deriving Data++-- specification of an externally exported entity in dependence on the calling+-- convention+--+data ForeignExport = CExport  (Located CExportSpec) -- contains the calling+                                                    -- convention+                              (Located SourceText)  -- original source text for+                                                    -- the C entity+  deriving Data++-- pretty printing of foreign declarations+--++instance Outputable ForeignImport where+  ppr (CImport  cconv safety mHeader spec (L _ srcText)) =+    ppr cconv <+> ppr safety+      <+> pprWithSourceText srcText (pprCEntity spec "")+    where+      pp_hdr = case mHeader of+               Nothing -> empty+               Just (Header _ header) -> ftext header++      pprCEntity (CLabel lbl) _ =+        doubleQuotes $ text "static" <+> pp_hdr <+> char '&' <> ppr lbl+      pprCEntity (CFunction (StaticTarget st _lbl _ isFun)) src =+        if dqNeeded then doubleQuotes ce else empty+          where+            dqNeeded = (take 6 src == "static")+                    || isJust mHeader+                    || not isFun+                    || st /= NoSourceText+            ce =+                  -- We may need to drop leading spaces first+                  (if take 6 src == "static" then text "static" else empty)+              <+> pp_hdr+              <+> (if isFun then empty else text "value")+              <+> (pprWithSourceText st empty)+      pprCEntity (CFunction DynamicTarget) _ =+        doubleQuotes $ text "dynamic"+      pprCEntity CWrapper _ = doubleQuotes $ text "wrapper"++instance Outputable ForeignExport where+  ppr (CExport  (L _ (CExportStatic _ lbl cconv)) _) =+    ppr cconv <+> char '"' <> ppr lbl <> char '"'++{-+************************************************************************+*                                                                      *+\subsection{Rewrite rules}+*                                                                      *+************************************************************************+-}++-- | Located Rule Declarations+type LRuleDecls pass = XRec pass (RuleDecls pass)++  -- Note [Pragma source text] in GHC.Types.SourceText+-- | Rule Declarations+data RuleDecls pass = HsRules { rds_ext   :: XCRuleDecls pass+                              , rds_src   :: SourceText+                              , rds_rules :: [LRuleDecl pass] }+  | XRuleDecls !(XXRuleDecls pass)++-- | Located Rule Declaration+type LRuleDecl pass = XRec pass (RuleDecl pass)++-- | Rule Declaration+data RuleDecl pass+  = HsRule -- Source rule+       { rd_ext  :: XHsRule pass+           -- ^ After renamer, free-vars from the LHS and RHS+       , rd_name :: XRec pass (SourceText,RuleName)+           -- ^ Note [Pragma source text] in "GHC.Types.Basic"+       , rd_act  :: Activation+       , rd_tyvs :: Maybe [LHsTyVarBndr () (NoGhcTc pass)]+           -- ^ Forall'd type vars+       , rd_tmvs :: [LRuleBndr pass]+           -- ^ Forall'd term vars, before typechecking; after typechecking+           --    this includes all forall'd vars+       , rd_lhs  :: XRec pass (HsExpr pass)+       , rd_rhs  :: XRec pass (HsExpr pass)+       }+    -- ^+    --  - 'GHC.Parser.Annotation.AnnKeywordId' :+    --           'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnTilde',+    --           'GHC.Parser.Annotation.AnnVal',+    --           'GHC.Parser.Annotation.AnnClose',+    --           'GHC.Parser.Annotation.AnnForall','GHC.Parser.Annotation.AnnDot',+    --           'GHC.Parser.Annotation.AnnEqual',+  | XRuleDecl !(XXRuleDecl pass)++data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS+  deriving Data++-- | Located Rule Binder+type LRuleBndr pass = XRec pass (RuleBndr pass)++-- | Rule Binder+data RuleBndr pass+  = RuleBndr (XCRuleBndr pass)  (LIdP pass)+  | RuleBndrSig (XRuleBndrSig pass) (LIdP pass) (HsPatSigType pass)+  | XRuleBndr !(XXRuleBndr pass)+        -- ^+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+        --     'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++collectRuleBndrSigTys :: [RuleBndr pass] -> [HsPatSigType pass]+collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ _ ty <- bndrs]++pprFullRuleName :: Located (SourceText, RuleName) -> SDoc+pprFullRuleName (L _ (st, n)) = pprWithSourceText st (doubleQuotes $ ftext n)++{-+************************************************************************+*                                                                      *+\subsection[DocDecl]{Document comments}+*                                                                      *+************************************************************************+-}++-- | Located Documentation comment Declaration+type LDocDecl pass = XRec pass (DocDecl)++-- | Documentation comment Declaration+data DocDecl+  = DocCommentNext HsDocString+  | DocCommentPrev HsDocString+  | DocCommentNamed String HsDocString+  | DocGroup Int HsDocString+  deriving Data++-- Okay, I need to reconstruct the document comments, but for now:+instance Outputable DocDecl where+  ppr _ = text "<document comment>"++docDeclDoc :: DocDecl -> HsDocString+docDeclDoc (DocCommentNext d) = d+docDeclDoc (DocCommentPrev d) = d+docDeclDoc (DocCommentNamed _ d) = d+docDeclDoc (DocGroup _ d) = d++{-+************************************************************************+*                                                                      *+\subsection[DeprecDecl]{Deprecations}+*                                                                      *+************************************************************************++We use exported entities for things to deprecate.+-}++-- | Located Warning Declarations+type LWarnDecls pass = XRec pass (WarnDecls pass)++ -- Note [Pragma source text] in GHC.Types.SourceText+-- | Warning pragma Declarations+data WarnDecls pass = Warnings { wd_ext      :: XWarnings pass+                               , wd_src      :: SourceText+                               , wd_warnings :: [LWarnDecl pass]+                               }+  | XWarnDecls !(XXWarnDecls pass)++-- | Located Warning pragma Declaration+type LWarnDecl pass = XRec pass (WarnDecl pass)++-- | Warning pragma Declaration+data WarnDecl pass = Warning (XWarning pass) [LIdP pass] WarningTxt+                   | XWarnDecl !(XXWarnDecl pass)++{-+************************************************************************+*                                                                      *+\subsection[AnnDecl]{Annotations}+*                                                                      *+************************************************************************+-}++-- | Located Annotation Declaration+type LAnnDecl pass = XRec pass (AnnDecl pass)++-- | Annotation Declaration+data AnnDecl pass = HsAnnotation+                      (XHsAnnotation pass)+                      SourceText -- Note [Pragma source text] in GHC.Types.SourceText+                      (AnnProvenance pass) (XRec pass (HsExpr pass))+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+      --           'GHC.Parser.Annotation.AnnType'+      --           'GHC.Parser.Annotation.AnnModule'+      --           'GHC.Parser.Annotation.AnnClose'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XAnnDecl !(XXAnnDecl pass)++-- | Annotation Provenance+data AnnProvenance pass = ValueAnnProvenance (LIdP pass)+                        | TypeAnnProvenance (LIdP pass)+                        | ModuleAnnProvenance+-- deriving instance Functor     AnnProvenance+-- deriving instance Foldable    AnnProvenance+-- deriving instance Traversable AnnProvenance+-- deriving instance (Data pass) => Data (AnnProvenance pass)++annProvenanceName_maybe :: forall p. UnXRec p => AnnProvenance p -> Maybe (IdP p)+annProvenanceName_maybe (ValueAnnProvenance (unXRec @p -> name)) = Just name+annProvenanceName_maybe (TypeAnnProvenance (unXRec @p -> name))  = Just name+annProvenanceName_maybe ModuleAnnProvenance                      = Nothing++{-+************************************************************************+*                                                                      *+\subsection[RoleAnnot]{Role annotations}+*                                                                      *+************************************************************************+-}++-- | Located Role Annotation Declaration+type LRoleAnnotDecl pass = XRec pass (RoleAnnotDecl pass)++-- See #8185 for more info about why role annotations are+-- top-level declarations+-- | Role Annotation Declaration+data RoleAnnotDecl pass+  = RoleAnnotDecl (XCRoleAnnotDecl pass)+                  (LIdP pass)              -- type constructor+                  [XRec pass (Maybe Role)] -- optional annotations+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnType',+      --           'GHC.Parser.Annotation.AnnRole'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XRoleAnnotDecl !(XXRoleAnnotDecl pass)

+ Language/Haskell/Syntax/Expr.hs view

@@ -0,0 +1,1800 @@+{-# LANGUAGE CPP                       #-}+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE DeriveDataTypeable        #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE LambdaCase                #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE StandaloneDeriving        #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilyDependencies    #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*++-- | Abstract Haskell syntax for expressions.+module Language.Haskell.Syntax.Expr where++#include "HsVersions.h"++-- friends:+import GHC.Prelude++import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Pat+import Language.Haskell.Syntax.Lit+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Type+import Language.Haskell.Syntax.Binds++-- others:+import GHC.Tc.Types.Evidence+import GHC.Core.DataCon (FieldLabelString)+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Core.ConLike+import GHC.Unit.Module (ModuleName)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Core.Type++-- libraries:+import Data.Data hiding (Fixity(..))+import qualified Data.Data as Data (Fixity(..))++import Data.List.NonEmpty ( NonEmpty )++import GHCi.RemoteTypes ( ForeignRef )+import qualified Language.Haskell.TH as TH (Q)++{- Note [RecordDotSyntax field updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The extensions @OverloadedRecordDot@ @OverloadedRecordUpdate@ together+enable record updates like @a{foo.bar.baz = 1}@. Introducing this+syntax slightly complicates parsing. This note explains how it's done.++In the event a record is being constructed or updated, it's this+production that's in play:+@+aexp1 -> aexp1 '{' fbinds '}' {+  ...+  mkHsRecordPV ... $1 (snd $3)+}+@+@fbinds@ is a list of field bindings. @mkHsRecordPV@ is a function of+the @DisambECP b@ typeclass, see Note [Ambiguous syntactic+categories].++The "normal" rules for an @fbind@ are:+@+fbind+        : qvar '=' texp+        | qvar+@+These rules compute values of @LHsRecField GhcPs (Located b)@. They+apply in the context of record construction, record updates, record+patterns and record expressions. That is, @b@ ranges over @HsExpr+GhcPs@, @HsPat GhcPs@ and @HsCmd GhcPs@.++When @OverloadedRecordDot@ and @OverloadedRecordUpdate@ are both+enabled, two additional @fbind@ rules are admitted:+@+        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp+        | field TIGHT_INFIX_PROJ fieldToUpdate+@++These rules only make sense when parsing record update expressions+(that is, patterns and commands cannot be parsed by these rules and+neither record constructions).++The results of these new rules cannot be represented by @LHsRecField+GhcPs (LHsExpr GhcPs)@ values as the type is defined today. We+minimize modifying existing code by having these new rules calculate+@LHsRecProj GhcPs (Located b)@ ("record projection") values instead:+@+newtype FieldLabelStrings = FieldLabelStrings [Located FieldLabelString]+type RecProj arg = HsRecField' FieldLabelStrings arg+type LHsRecProj p arg = Located (RecProj arg)+@++The @fbind@ rule is then given the type @fbind :: { forall b.+DisambECP b => PV (Fbind b) }@ accomodating both alternatives:+@+type Fbind b = Either+                  (LHsRecField GhcPs (Located b))+                  ( LHsRecProj GhcPs (Located b))+@++In @data HsExpr p@, the @RecordUpd@ constuctor indicates regular+updates vs. projection updates by means of the @rupd_flds@ member+type, an @Either@ instance:+@+  | RecordUpd+      { rupd_ext  :: XRecordUpd p+      , rupd_expr :: LHsExpr p+      , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p]+      }+@+Here,+@+type RecUpdProj p = RecProj (LHsExpr p)+type LHsRecUpdProj p = Located (RecUpdProj p)+@+and @Left@ values indicating regular record update, @Right@ values+updates desugared to @setField@s.++If @OverloadedRecordUpdate@ is enabled, any updates parsed as+@LHsRecField GhcPs@ values are converted to @LHsRecUpdProj GhcPs@+values (see function @mkRdrRecordUpd@ in 'GHC.Parser.PostProcess').+-}++-- | RecordDotSyntax field updates++newtype FieldLabelStrings p =+  FieldLabelStrings [Located (HsFieldLabel p)]++instance Outputable (FieldLabelStrings p) where+  ppr (FieldLabelStrings flds) =+    hcat (punctuate dot (map (ppr . unLoc) flds))++instance OutputableBndr (FieldLabelStrings p) where+  pprInfixOcc = pprFieldLabelStrings+  pprPrefixOcc = pprFieldLabelStrings++pprFieldLabelStrings :: FieldLabelStrings p -> SDoc+pprFieldLabelStrings (FieldLabelStrings flds) =+    hcat (punctuate dot (map (ppr . unLoc) flds))++instance Outputable (HsFieldLabel p) where+  ppr (HsFieldLabel _ s) = ppr s+  ppr XHsFieldLabel{} = text "XHsFieldLabel"++-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note+-- [RecordDotSyntax field updates].+type RecProj p arg = HsRecField' (FieldLabelStrings p) arg++-- The phantom type parameter @p@ is for symmetry with @LHsRecField p+-- arg@ in the definition of @data Fbind@ (see GHC.Parser.Process).+type LHsRecProj p arg = XRec p (RecProj p arg)++-- These two synonyms are used in the definition of syntax @RecordUpd@+-- below.+type RecUpdProj p = RecProj p (LHsExpr p)+type LHsRecUpdProj p = XRec p (RecUpdProj p)++{-+************************************************************************+*                                                                      *+\subsection{Expressions proper}+*                                                                      *+************************************************************************+-}++-- * Expressions proper++-- | Located Haskell Expression+type LHsExpr p = XRec p (HsExpr p)+  -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when+  --   in a list++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-------------------------+{- Note [NoSyntaxExpr]+~~~~~~~~~~~~~~~~~~~~~~+Syntax expressions can be missing (NoSyntaxExprRn or NoSyntaxExprTc)+for several reasons:++ 1. As described in Note [Rebindable if]++ 2. In order to suppress "not in scope: xyz" messages when a bit of+    rebindable syntax does not apply. For example, when using an irrefutable+    pattern in a BindStmt, we don't need a `fail` operator.++ 3. Rebindable syntax might just not make sense. For example, a BodyStmt+    contains the syntax for `guard`, but that's used only in monad comprehensions.+    If we had more of a whiz-bang type system, we might be able to rule this+    case out statically.+-}++-- | Syntax Expression+--+-- SyntaxExpr is represents the function used in interpreting rebindable+-- syntax. In the parser, we have no information to supply; in the renamer,+-- we have the name of the function (but see+-- Note [Monad fail : Rebindable syntax, overloaded strings] for a wrinkle)+-- and in the type-checker we have a more elaborate structure 'SyntaxExprTc'.+--+-- In some contexts, rebindable syntax is not implemented, and so we have+-- constructors to represent that possibility in both the renamer and+-- typechecker instantiations.+--+-- E.g. @(>>=)@ is filled in before the renamer by the appropriate 'Name' for+--      @(>>=)@, and then instantiated by the type checker with its type args+--      etc+type family SyntaxExpr p++-- | Command Syntax Table (for Arrow syntax)+type CmdSyntaxTable p = [(Name, HsExpr p)]+-- See Note [CmdSyntaxTable]++{-+Note [CmdSyntaxTable]+~~~~~~~~~~~~~~~~~~~~~+Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps+track of the methods needed for a Cmd.++* Before the renamer, this list is an empty list++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@+  For example, for the 'arr' method+   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)+   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)+             where @arr_22@ is whatever 'arr' is in scope++* After the type checker, it takes the form [(std_name, <expression>)]+  where <expression> is the evidence for the method.  This evidence is+  instantiated with the class, but is still polymorphic in everything+  else.  For example, in the case of 'arr', the evidence has type+         forall b c. (b->c) -> a b c+  where 'a' is the ambient type of the arrow.  This polymorphism is+  important because the desugarer uses the same evidence at multiple+  different types.++This is Less Cool than what we normally do for rebindable syntax, which is to+make fully-instantiated piece of evidence at every use site.  The Cmd way+is Less Cool because+  * The renamer has to predict which methods are needed.+    See the tedious GHC.Rename.Expr.methodNamesCmd.++  * The desugarer has to know the polymorphic type of the instantiated+    method. This is checked by Inst.tcSyntaxName, but is less flexible+    than the rest of rebindable syntax, where the type is less+    pre-ordained.  (And this flexibility is useful; for example we can+    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)+-}++-- | A Haskell expression.+data HsExpr p+  = HsVar     (XVar p)+              (LIdP p) -- ^ Variable+                       -- See Note [Located RdrNames]++  | HsUnboundVar (XUnboundVar p)+                 OccName     -- ^ Unbound variable; also used for "holes"+                             --   (_ or _x).+                             -- Turned from HsVar to HsUnboundVar by the+                             --   renamer, when it finds an out-of-scope+                             --   variable or hole.+                             -- The (XUnboundVar p) field becomes an HoleExprRef+                             --   after typechecking; this is where the+                             --   erroring expression will be written after+                             --   solving. See Note [Holes] in GHC.Tc.Types.Constraint.++  | HsConLikeOut (XConLikeOut p)+                 ConLike     -- ^ After typechecker only; must be different+                             -- HsVar for pretty printing++  | HsRecFld  (XRecFld p)+              (AmbiguousFieldOcc p) -- ^ Variable pointing to record selector+              -- The parser produces HsVars+              -- The renamer renames record-field selectors to HsRecFld+              -- The typechecker preserves HsRecFld++  | HsOverLabel (XOverLabel p) FastString+     -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)++  | HsIPVar   (XIPVar p)+              HsIPName   -- ^ Implicit parameter (not in use after typechecking)+  | HsOverLit (XOverLitE p)+              (HsOverLit p)  -- ^ Overloaded literals++  | HsLit     (XLitE p)+              (HsLit p)      -- ^ Simple (non-overloaded) literals++  | HsLam     (XLam p)+              (MatchGroup p (LHsExpr p))+                       -- ^ Lambda abstraction. Currently always a single match+       --+       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+       --       'GHC.Parser.Annotation.AnnRarrow',++       -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsLamCase (XLamCase p) (MatchGroup p (LHsExpr p)) -- ^ Lambda-case+       --+       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+       --           'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',+       --           'GHC.Parser.Annotation.AnnClose'++       -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application++  | HsAppType (XAppTypeE p) -- After typechecking: the type argument+              (LHsExpr p)+              (LHsWcType (NoGhcTc p))  -- ^ Visible type application+       --+       -- Explicit type argument; e.g  f @Int x y+       -- NB: Has wildcards, but no implicit quantification+       --+       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt',++  -- | Operator applications:+  -- NB Bracketed ops such as (+) come out as Vars.++  -- NB Sadly, we need an expr for the operator in an OpApp/Section since+  -- the renamer may turn a HsVar into HsRecFld or HsUnboundVar++  | OpApp       (XOpApp p)+                (LHsExpr p)       -- left operand+                (LHsExpr p)       -- operator+                (LHsExpr p)       -- right operand++  -- | Negation operator. Contains the negated expression and the name+  -- of 'negate'+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnMinus'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | NegApp      (XNegApp p)+                (LHsExpr p)+                (SyntaxExpr p)++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,+  --             'GHC.Parser.Annotation.AnnClose' @')'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsPar       (XPar p)+                (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]++  | SectionL    (XSectionL p)+                (LHsExpr p)    -- operand; see Note [Sections in HsSyn]+                (LHsExpr p)    -- operator+  | SectionR    (XSectionR p)+                (LHsExpr p)    -- operator; see Note [Sections in HsSyn]+                (LHsExpr p)    -- operand++  -- | Used for explicit tuples and sections thereof+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+  --         'GHC.Parser.Annotation.AnnClose'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- Note [ExplicitTuple]+  | ExplicitTuple+        (XExplicitTuple p)+        [HsTupArg p]+        Boxity++  -- | Used for unboxed sum types+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,+  --          'GHC.Parser.Annotation.AnnVbar', 'GHC.Parser.Annotation.AnnClose' @'#)'@,+  --+  --  There will be multiple 'GHC.Parser.Annotation.AnnVbar', (1 - alternative) before+  --  the expression, (arity - alternative) after it+  | ExplicitSum+          (XExplicitSum p)+          ConTag --  Alternative (one-based)+          Arity  --  Sum arity+          (LHsExpr p)++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',+  --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,+  --       'GHC.Parser.Annotation.AnnClose' @'}'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsCase      (XCase p)+                (LHsExpr p)+                (MatchGroup p (LHsExpr p))++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',+  --       'GHC.Parser.Annotation.AnnSemi',+  --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',+  --       'GHC.Parser.Annotation.AnnElse',++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsIf        (XIf p)        -- GhcPs: this is a Bool; False <=> do not use+                               --  rebindable syntax+                (LHsExpr p)    --  predicate+                (LHsExpr p)    --  then part+                (LHsExpr p)    --  else part++  -- | Multi-way if+  --+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf'+  --       'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsMultiIf   (XMultiIf p) [LGRHS p (LHsExpr p)]++  -- | let(rec)+  --+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',+  --       'GHC.Parser.Annotation.AnnOpen' @'{'@,+  --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsLet       (XLet p)+                (HsLocalBinds p)+                (LHsExpr  p)++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',+  --             'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',+  --             'GHC.Parser.Annotation.AnnVbar',+  --             'GHC.Parser.Annotation.AnnClose'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsDo        (XDo p)                  -- Type of the whole expression+                (HsStmtContext (HsDoRn p))+                -- The parameterisation of the above is unimportant+                -- because in this context we never use+                -- the PatGuard or ParStmt variant+                (XRec p [ExprLStmt p])   -- "do":one or more stmts++  -- | Syntactic list: [a,b,c,...]+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,+  --              'GHC.Parser.Annotation.AnnClose' @']'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  -- See Note [Empty lists]+  | ExplicitList+                (XExplicitList p)  -- Gives type of components of list+                [LHsExpr p]++  -- | Record construction+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,+  --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | RecordCon+      { rcon_ext  :: XRecordCon p+      , rcon_con  :: XRec p (ConLikeP p)  -- The constructor+      , rcon_flds :: HsRecordBinds p }    -- The fields++  -- | Record update+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,+  --         'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose' @'}'@+  --         'GHC.Parser.Annotation.AnnComma, 'GHC.Parser.Annotation.AnnDot',+  --         'GHC.Parser.Annotation.AnnClose' @'}'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | RecordUpd+      { rupd_ext  :: XRecordUpd p+      , rupd_expr :: LHsExpr p+      , rupd_flds :: Either [LHsRecUpdField p] [LHsRecUpdProj p]+      }+  -- For a type family, the arg types are of the *instance* tycon,+  -- not the family tycon++  -- | Record field selection e.g @z.x@.+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDot'+  --+  -- This case only arises when the OverloadedRecordDot langauge+  -- extension is enabled.++  | HsGetField {+        gf_ext :: XGetField p+      , gf_expr :: LHsExpr p+      , gf_field :: Located (HsFieldLabel p)+      }++  -- | Record field selector. e.g. @(.x)@ or @(.x.y)@+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenP'+  --         'GHC.Parser.Annotation.AnnDot', 'GHC.Parser.Annotation.AnnCloseP'+  --+  -- This case only arises when the OverloadedRecordDot langauge+  -- extensions is enabled.++  | HsProjection {+        proj_ext :: XProjection p+      , proj_flds :: NonEmpty (Located (HsFieldLabel p))+      }++  -- | Expression with an explicit type signature. @e :: type@+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | ExprWithTySig+                (XExprWithTySig p)++                (LHsExpr p)+                (LHsSigWcType (NoGhcTc p))++  -- | Arithmetic sequence+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,+  --              'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnDotdot',+  --              'GHC.Parser.Annotation.AnnClose' @']'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | ArithSeq+                (XArithSeq p)+                (Maybe (SyntaxExpr p))+                                  -- For OverloadedLists, the fromList witness+                (ArithSeqInfo p)++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  -----------------------------------------------------------+  -- MetaHaskell Extensions++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+  --         'GHC.Parser.Annotation.AnnOpenE','GHC.Parser.Annotation.AnnOpenEQ',+  --         'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnCloseQ'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsBracket    (XBracket p) (HsBracket p)++    -- See Note [Pending Splices]+  | HsRnBracketOut+      (XRnBracketOut p)+      (HsBracket (HsBracketRn p)) -- Output of the renamer is the *original* renamed+                                  -- expression, plus+      [PendingRnSplice' p] -- _renamed_ splices to be type checked++  | HsTcBracketOut+      (XTcBracketOut p)+      (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument+                           -- to the quote.+      (HsBracket (HsBracketRn p)) -- Output of the type checker is the *original*+                                 -- renamed expression, plus+      [PendingTcSplice' p] -- _typechecked_ splices to be+                           -- pasted back in by the desugarer++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+  --         'GHC.Parser.Annotation.AnnClose'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsSpliceE  (XSpliceE p) (HsSplice p)++  -----------------------------------------------------------+  -- Arrow notation extension++  -- | @proc@ notation for Arrows+  --+  --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnProc',+  --          'GHC.Parser.Annotation.AnnRarrow'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsProc      (XProc p)+                (LPat p)               -- arrow abstraction, proc+                (LHsCmdTop p)          -- body of the abstraction+                                       -- always has an empty stack++  ---------------------------------------+  -- static pointers extension+  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnStatic',++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsStatic (XStatic p) -- Free variables of the body+             (LHsExpr p)        -- Body++  ---------------------------------------+  -- Haskell program coverage (Hpc) Support++  | HsTick+     (XTick p)+     CoreTickish+     (LHsExpr p)                       -- sub-expression++  | HsBinTick+     (XBinTick p)+     Int                                -- module-local tick number for True+     Int                                -- module-local tick number for False+     (LHsExpr p)                        -- sub-expression++  ---------------------------------------+  -- Expressions annotated with pragmas, written as {-# ... #-}+  | HsPragE (XPragE p) (HsPragE p) (LHsExpr p)++  | XExpr       !(XXExpr p)+  -- Note [Trees that Grow] extension constructor for the+  -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr+  -- for an example of how we use it.++-- | The AST used to hard-refer to GhcPass, which was a layer violation. For now,+-- we paper it over with this new extension point.+type family HsDoRn p+type family HsBracketRn p+type family PendingRnSplice' p+type family PendingTcSplice' p++-- ---------------------------------------------------------------------++data HsFieldLabel p+  = HsFieldLabel+    { hflExt   :: XCHsFieldLabel p+    , hflLabel :: Located FieldLabelString+    }+  | XHsFieldLabel !(XXHsFieldLabel p)++-- ---------------------------------------------------------------------++-- | A pragma, written as {-# ... #-}, that may appear within an expression.+data HsPragE p+  = HsPragSCC   (XSCC p)+                SourceText            -- Note [Pragma source text] in GHC.Types.SourceText+                StringLiteral         -- "set cost centre" SCC pragma++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+  --       'GHC.Parser.Annotation.AnnOpen' @'{-\# GENERATED'@,+  --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnVal',+  --       'GHC.Parser.Annotation.AnnColon','GHC.Parser.Annotation.AnnVal',+  --       'GHC.Parser.Annotation.AnnMinus',+  --       'GHC.Parser.Annotation.AnnVal','GHC.Parser.Annotation.AnnColon',+  --       'GHC.Parser.Annotation.AnnVal',+  --       'GHC.Parser.Annotation.AnnClose' @'\#-}'@++  | XHsPragE !(XXPragE p)++-- | Located Haskell Tuple Argument+--+-- 'HsTupArg' is used for tuple sections+-- @(,a,)@ is represented by+-- @ExplicitTuple [Missing ty1, Present a, Missing ty3]@+-- Which in turn stands for @(\x:ty1 \y:ty2. (x,a,y))@+type LHsTupArg id = XRec id (HsTupArg id)+-- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Haskell Tuple Argument+data HsTupArg id+  = Present (XPresent id) (LHsExpr id)     -- ^ The argument+  | Missing (XMissing id)    -- ^ The argument is missing, but this is its type+  | XTupArg !(XXTupArg id)   -- ^ Note [Trees that Grow] extension point++{-+Note [Parens in HsSyn]+~~~~~~~~~~~~~~~~~~~~~~+HsPar (and ParPat in patterns, HsParTy in types) is used as follows++  * HsPar is required; the pretty printer does not add parens.++  * HsPars are respected when rearranging operator fixities.+    So   a * (b + c)  means what it says (where the parens are an HsPar)++  * For ParPat and HsParTy the pretty printer does add parens but this should be+    a no-op for ParsedSource, based on the pretty printer round trip feature+    introduced in+    https://phabricator.haskell.org/rGHC499e43824bda967546ebf95ee33ec1f84a114a7c++  * ParPat and HsParTy are pretty printed as '( .. )' regardless of whether or+    not they are strictly necessary. This should be addressed when #13238 is+    completed, to be treated the same as HsPar.+++Note [Sections in HsSyn]+~~~~~~~~~~~~~~~~~~~~~~~~+Sections should always appear wrapped in an HsPar, thus+         HsPar (SectionR ...)+The parser parses sections in a wider variety of situations+(See Note [Parsing sections]), but the renamer checks for those+parens.  This invariant makes pretty-printing easier; we don't need+a special case for adding the parens round sections.++Note [Rebindable if]+~~~~~~~~~~~~~~~~~~~~+The rebindable syntax for 'if' is a bit special, because when+rebindable syntax is *off* we do not want to treat+   (if c then t else e)+as if it was an application (ifThenElse c t e).  Why not?+Because we allow an 'if' to return *unboxed* results, thus+  if blah then 3# else 4#+whereas that would not be possible using a all to a polymorphic function+(because you can't call a polymorphic function at an unboxed type).++So we use NoSyntaxExpr to mean "use the old built-in typing rule".++A further complication is that, in the `deriving` code, we never want+to use rebindable syntax. So, even in GhcPs, we want to denote whether+to use rebindable syntax or not. This is done via the type instance+for XIf GhcPs.++Note [Record Update HsWrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a wrapper in RecordUpd which is used for the *required*+constraints for pattern synonyms. This wrapper is created in the+typechecking and is then directly used in the desugaring without+modification.++For example, if we have the record pattern synonym P,+  pattern P :: (Show a) => a -> Maybe a+  pattern P{x} = Just x++  foo = (Just True) { x = False }+then `foo` desugars to something like+  foo = case Just True of+          P x -> P False+hence we need to provide the correct dictionaries to P's matcher on+the RHS so that we can build the expression.++Note [Located RdrNames]+~~~~~~~~~~~~~~~~~~~~~~~+A number of syntax elements have seemingly redundant locations+attached to them.  This is deliberate, to allow transformations making+use of the exact print annotations to easily correlate a Located Name+in the RenamedSource with a Located RdrName in the ParsedSource.++There are unfortunately enough differences between the ParsedSource+and the RenamedSource that the exact print annotations cannot be used+directly with RenamedSource, so this allows a simple mapping to be+used based on the location.++Note [ExplicitTuple]+~~~~~~~~~~~~~~~~~~~~+An ExplicitTuple is never just a data constructor like (,,,).+That is, the `[LHsTupArg p]` argument of `ExplicitTuple` has at least+one `Present` member (and is thus never empty).++A tuple data constructor like () or (,,,) is parsed as an `HsVar`, not an+`ExplicitTuple`, and stays that way. This is important for two reasons:++  1. We don't need -XTupleSections for (,,,)+  2. The type variables in (,,,) can be instantiated with visible type application.+     That is,++       (,,)     :: forall a b c. a -> b -> c -> (a,b,c)+       (True,,) :: forall {b} {c}. b -> c -> (Bool,b,c)++     Note that the tuple section has *inferred* arguments, while the data+     constructor has *specified* ones.+     (See Note [Required, Specified, and Inferred for types] in GHC.Tc.TyCl+     for background.)++Sadly, the grammar for this is actually ambiguous, and it's only thanks to the+preference of a shift in a shift/reduce conflict that the parser works as this+Note details. Search for a reference to this Note in GHC.Parser for further+explanation.++Note [Empty lists]+~~~~~~~~~~~~~~~~~~+An empty list could be considered either a data constructor (stored with+HsVar) or an ExplicitList. This Note describes how empty lists flow through the+various phases and why.++Parsing+-------+An empty list is parsed by the sysdcon nonterminal. It thus comes to life via+HsVar nilDataCon (defined in GHC.Builtin.Types). A freshly-parsed (HsExpr GhcPs) empty list+is never a ExplicitList.++Renaming+--------+If -XOverloadedLists is enabled, we must type-check the empty list as if it+were a call to fromListN. (This is true regardless of the setting of+-XRebindableSyntax.) This is very easy if the empty list is an ExplicitList,+but an annoying special case if it's an HsVar. So the renamer changes a+HsVar nilDataCon to an ExplicitList [], but only if -XOverloadedLists is on.+(Why not always? Read on, dear friend.) This happens in the HsVar case of rnExpr.++Type-checking+-------------+We want to accept an expression like [] @Int. To do this, we must infer that+[] :: forall a. [a]. This is easy if [] is a HsVar with the right DataCon inside.+However, the type-checking for explicit lists works differently: [x,y,z] is never+polymorphic. Instead, we unify the types of x, y, and z together, and use the+unified type as the argument to the cons and nil constructors. Thus, treating+[] as an empty ExplicitList in the type-checker would prevent [] @Int from working.++However, if -XOverloadedLists is on, then [] @Int really shouldn't be allowed:+it's just like fromListN 0 [] @Int. Since+  fromListN :: forall list. IsList list => Int -> [Item list] -> list+that expression really should be rejected. Thus, the renamer's behaviour is+exactly what we want: treat [] as a datacon when -XNoOverloadedLists, and as+an empty ExplicitList when -XOverloadedLists.++See also #13680, which requested [] @Int to work.+-}+++-----------------------+pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc+pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))+  = ppr (src,(n1,n2),(n3,n4))++{-+HsSyn records exactly where the user put parens, with HsPar.+So generally speaking we print without adding any parens.+However, some code is internally generated, and in some places+parens are absolutely required; so for these places we use+pprParendLExpr (but don't print double parens of course).++For operator applications we don't add parens, because the operator+fixities should do the job, except in debug mode (-dppr-debug) so we+can see the structure of the parse tree.+-}++{-+************************************************************************+*                                                                      *+\subsection{Commands (in arrow abstractions)}+*                                                                      *+************************************************************************++We re-use HsExpr to represent these.+-}++-- | Located Haskell Command (for arrow syntax)+type LHsCmd id = XRec id (HsCmd id)++-- | Haskell Command (e.g. a "statement" in an Arrow proc block)+data HsCmd id+  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.Annlarrowtail',+  --          'GHC.Parser.Annotation.Annrarrowtail','GHC.Parser.Annotation.AnnLarrowtail',+  --          'GHC.Parser.Annotation.AnnRarrowtail'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  = HsCmdArrApp          -- Arrow tail, or arrow application (f -< arg)+        (XCmdArrApp id)  -- type of the arrow expressions f,+                         -- of the form a t t', where arg :: t+        (LHsExpr id)     -- arrow expression, f+        (LHsExpr id)     -- input expression, arg+        HsArrAppType     -- higher-order (-<<) or first-order (-<)+        Bool             -- True => right-to-left (f -< arg)+                         -- False => left-to-right (arg >- f)++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpenB' @'(|'@,+  --         'GHC.Parser.Annotation.AnnCloseB' @'|)'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | HsCmdArrForm         -- Command formation,  (| e cmd1 .. cmdn |)+        (XCmdArrForm id)+        (LHsExpr id)     -- The operator.+                         -- After type-checking, a type abstraction to be+                         -- applied to the type of the local environment tuple+        LexicalFixity    -- Whether the operator appeared prefix or infix when+                         -- parsed.+        (Maybe Fixity)   -- fixity (filled in by the renamer), for forms that+                         -- were converted from OpApp's by the renamer+        [LHsCmdTop id]   -- argument commands++  | HsCmdApp    (XCmdApp id)+                (LHsCmd id)+                (LHsExpr id)++  | HsCmdLam    (XCmdLam id)+                (MatchGroup id (LHsCmd id))     -- kappa+       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+       --       'GHC.Parser.Annotation.AnnRarrow',++       -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsCmdPar    (XCmdPar id)+                (LHsCmd id)                     -- parenthesised command+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,+    --             'GHC.Parser.Annotation.AnnClose' @')'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsCmdCase   (XCmdCase id)+                (LHsExpr id)+                (MatchGroup id (LHsCmd id))     -- bodies are HsCmd's+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase',+    --       'GHC.Parser.Annotation.AnnOf','GHC.Parser.Annotation.AnnOpen' @'{'@,+    --       'GHC.Parser.Annotation.AnnClose' @'}'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsCmdLamCase (XCmdLamCase id)+                 (MatchGroup id (LHsCmd id))    -- bodies are HsCmd's+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+    --       'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,+    --       'GHC.Parser.Annotation.AnnClose' @'}'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsCmdIf     (XCmdIf id)+                (SyntaxExpr id)         -- cond function+                (LHsExpr id)            -- predicate+                (LHsCmd id)             -- then part+                (LHsCmd id)             -- else part+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnIf',+    --       'GHC.Parser.Annotation.AnnSemi',+    --       'GHC.Parser.Annotation.AnnThen','GHC.Parser.Annotation.AnnSemi',+    --       'GHC.Parser.Annotation.AnnElse',++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsCmdLet    (XCmdLet id)+                (HsLocalBinds id)      -- let(rec)+                (LHsCmd  id)+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',+    --       'GHC.Parser.Annotation.AnnOpen' @'{'@,+    --       'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsCmdDo     (XCmdDo id)                     -- Type of the whole expression+                (XRec id [CmdLStmt id])+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',+    --             'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnSemi',+    --             'GHC.Parser.Annotation.AnnVbar',+    --             'GHC.Parser.Annotation.AnnClose'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | XCmd        !(XXCmd id)     -- Note [Trees that Grow] extension point+++-- | Haskell Array Application Type+data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp+  deriving Data+++{- | Top-level command, introducing a new arrow.+This may occur inside a proc (where the stack is empty) or as an+argument of a command-forming operator.+-}++-- | Located Haskell Top-level Command+type LHsCmdTop p = XRec p (HsCmdTop p)++-- | Haskell Top-level Command+data HsCmdTop p+  = HsCmdTop (XCmdTop p)+             (LHsCmd p)+  | XCmdTop !(XXCmdTop p)        -- Note [Trees that Grow] extension point++-----------------------++{-+************************************************************************+*                                                                      *+\subsection{Record binds}+*                                                                      *+************************************************************************+-}++-- | Haskell Record Bindings+type HsRecordBinds p = HsRecFields p (LHsExpr p)++{-+************************************************************************+*                                                                      *+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}+*                                                                      *+************************************************************************++@Match@es are sets of pattern bindings and right hand sides for+functions, patterns or case branches. For example, if a function @g@+is defined as:+\begin{verbatim}+g (x,y) = y+g ((x:ys),y) = y+1,+\end{verbatim}+then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.++It is always the case that each element of an @[Match]@ list has the+same number of @pats@s inside it.  This corresponds to saying that+a function defined by pattern matching must have the same number of+patterns in each equation.+-}++data MatchGroup p body+  = MG { mg_ext     :: XMG p body -- Post-typechecker, types of args and result+       , mg_alts    :: XRec p [LMatch p body]  -- The alternatives+       , mg_origin  :: Origin }+     -- The type is the type of the entire group+     --      t1 -> ... -> tn -> tr+     -- where there are n patterns+  | XMatchGroup !(XXMatchGroup p body)++data MatchGroupTc+  = MatchGroupTc+       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn+       , mg_res_ty  :: Type    -- Type of the result, tr+       } deriving Data++-- | Located Match+type LMatch id body = XRec id (Match id body)+-- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi' when in a+--   list++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation+data Match p body+  = Match {+        m_ext :: XCMatch p body,+        m_ctxt :: HsMatchContext (NoGhcTc p),+          -- See note [m_ctxt in Match]+        m_pats :: [LPat p], -- The patterns+        m_grhss :: (GRHSs p body)+  }+  | XMatch !(XXMatch p body)++{-+Note [m_ctxt in Match]+~~~~~~~~~~~~~~~~~~~~~~++A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and+so on.++In order to simplify tooling processing and pretty print output, the provenance+is captured in an HsMatchContext.++This is particularly important for the exact print annotations for a+multi-equation FunBind.++The parser initially creates a FunBind with a single Match in it for+every function definition it sees.++These are then grouped together by getMonoBind into a single FunBind,+where all the Matches are combined.++In the process, all the original FunBind fun_id's bar one are+discarded, including the locations.++This causes a problem for source to source conversions via exact print+annotations, so the original fun_ids and infix flags are preserved in+the Match, when it originates from a FunBind.++Example infix function definition requiring individual exact print+annotations++    (&&&  ) [] [] =  []+    xs    &&&   [] =  xs+    (  &&&  ) [] ys =  ys++++-}+++isInfixMatch :: Match id body -> Bool+isInfixMatch match = case m_ctxt match of+  FunRhs {mc_fixity = Infix} -> True+  _                          -> False++-- | Guarded Right-Hand Sides+--+-- GRHSs are used both for pattern bindings and for Matches+--+--  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',+--        'GHC.Parser.Annotation.AnnEqual','GHC.Parser.Annotation.AnnWhere',+--        'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose'+--        'GHC.Parser.Annotation.AnnRarrow','GHC.Parser.Annotation.AnnSemi'++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation+data GRHSs p body+  = GRHSs {+      grhssExt :: XCGRHSs p body,+      grhssGRHSs :: [LGRHS p body],     -- ^ Guarded RHSs+      grhssLocalBinds :: HsLocalBinds p -- ^ The where clause+    }+  | XGRHSs !(XXGRHSs p body)++-- | Located Guarded Right-Hand Side+type LGRHS id body = XRec id (GRHS id body)++-- | Guarded Right Hand Side.+data GRHS p body = GRHS (XCGRHS p body)+                        [GuardLStmt p] -- Guards+                        body           -- Right hand side+                  | XGRHS !(XXGRHS p body)++-- We know the list must have at least one @Match@ in it.++{-+************************************************************************+*                                                                      *+\subsection{Do stmts and list comprehensions}+*                                                                      *+************************************************************************+-}++-- | Located @do@ block Statement+type LStmt id body = XRec id (StmtLR id id body)++-- | Located Statement with separate Left and Right id's+type LStmtLR idL idR body = XRec idL (StmtLR idL idR body)++-- | @do@ block Statement+type Stmt id body = StmtLR id id body++-- | Command Located Statement+type CmdLStmt   id = LStmt id (LHsCmd  id)++-- | Command Statement+type CmdStmt    id = Stmt  id (LHsCmd  id)++-- | Expression Located Statement+type ExprLStmt  id = LStmt id (LHsExpr id)++-- | Expression Statement+type ExprStmt   id = Stmt  id (LHsExpr id)++-- | Guard Located Statement+type GuardLStmt id = LStmt id (LHsExpr id)++-- | Guard Statement+type GuardStmt  id = Stmt  id (LHsExpr id)++-- | Ghci Located Statement+type GhciLStmt  id = LStmt id (LHsExpr id)++-- | Ghci Statement+type GhciStmt   id = Stmt  id (LHsExpr id)++-- The SyntaxExprs in here are used *only* for do-notation and monad+-- comprehensions, which have rebindable syntax. Otherwise they are unused.+-- | Exact print annotations when in qualifier lists or guards+--  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVbar',+--         'GHC.Parser.Annotation.AnnComma','GHC.Parser.Annotation.AnnThen',+--         'GHC.Parser.Annotation.AnnBy','GHC.Parser.Annotation.AnnBy',+--         'GHC.Parser.Annotation.AnnGroup','GHC.Parser.Annotation.AnnUsing'++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation+data StmtLR idL idR body -- body should always be (LHs**** idR)+  = LastStmt  -- Always the last Stmt in ListComp, MonadComp,+              -- and (after the renamer, see GHC.Rename.Expr.checkLastStmt) DoExpr, MDoExpr+              -- Not used for GhciStmtCtxt, PatGuard, which scope over other stuff+          (XLastStmt idL idR body)+          body+          (Maybe Bool)  -- Whether return was stripped+            -- Just True <=> return with a dollar was stripped by ApplicativeDo+            -- Just False <=> return without a dollar was stripped by ApplicativeDo+            -- Nothing <=> Nothing was stripped+          (SyntaxExpr idR)   -- The return operator+            -- The return operator is used only for MonadComp+            -- For ListComp we use the baked-in 'return'+            -- For DoExpr, MDoExpr, we don't apply a 'return' at all+            -- See Note [Monad Comprehensions]+            -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLarrow'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | BindStmt (XBindStmt idL idR body)+             -- ^ Post renaming has optional fail and bind / (>>=) operator.+             -- Post typechecking, also has multiplicity of the argument+             -- and the result type of the function passed to bind;+             -- that is, (P, S) in (>>=) :: Q -> (R # P -> S) -> T+             -- See Note [The type of bind in Stmts]+             (LPat idL)+             body++  -- | 'ApplicativeStmt' represents an applicative expression built with+  -- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the+  -- appropriate applicative expression by the desugarer, but it is intended+  -- to be invisible in error messages.+  --+  -- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"+  --+  | ApplicativeStmt+             (XApplicativeStmt idL idR body) -- Post typecheck, Type of the body+             [ ( SyntaxExpr idR+               , ApplicativeArg idL) ]+                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]+             (Maybe (SyntaxExpr idR))  -- 'join', if necessary++  | BodyStmt (XBodyStmt idL idR body) -- Post typecheck, element type+                                      -- of the RHS (used for arrows)+             body              -- See Note [BodyStmt]+             (SyntaxExpr idR)  -- The (>>) operator+             (SyntaxExpr idR)  -- The `guard` operator; used only in MonadComp+                               -- See notes [Monad Comprehensions]++  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet'+  --          'GHC.Parser.Annotation.AnnOpen' @'{'@,'GHC.Parser.Annotation.AnnClose' @'}'@,++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | LetStmt  (XLetStmt idL idR body) (HsLocalBindsLR idL idR)++  -- ParStmts only occur in a list/monad comprehension+  | ParStmt  (XParStmt idL idR body)    -- Post typecheck,+                                        -- S in (>>=) :: Q -> (R -> S) -> T+             [ParStmtBlock idL idR]+             (HsExpr idR)               -- Polymorphic `mzip` for monad comprehensions+             (SyntaxExpr idR)           -- The `>>=` operator+                                        -- See notes [Monad Comprehensions]+            -- After renaming, the ids are the binders+            -- bound by the stmts and used after themp++  | TransStmt {+      trS_ext   :: XTransStmt idL idR body, -- Post typecheck,+                                            -- R in (>>=) :: Q -> (R -> S) -> T+      trS_form  :: TransForm,+      trS_stmts :: [ExprLStmt idL],   -- Stmts to the *left* of the 'group'+                                      -- which generates the tuples to be grouped++      trS_bndrs :: [(IdP idR, IdP idR)], -- See Note [TransStmt binder map]++      trS_using :: LHsExpr idR,+      trS_by :: Maybe (LHsExpr idR),  -- "by e" (optional)+        -- Invariant: if trS_form = GroupBy, then grp_by = Just e++      trS_ret :: SyntaxExpr idR,      -- The monomorphic 'return' function for+                                      -- the inner monad comprehensions+      trS_bind :: SyntaxExpr idR,     -- The '(>>=)' operator+      trS_fmap :: HsExpr idR          -- The polymorphic 'fmap' function for desugaring+                                      -- Only for 'group' forms+                                      -- Just a simple HsExpr, because it's+                                      -- too polymorphic for tcSyntaxOp+    }                                 -- See Note [Monad Comprehensions]++  -- Recursive statement (see Note [How RecStmt works] below)+  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRec'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | RecStmt+     { recS_ext :: XRecStmt idL idR body+     , recS_stmts :: XRec idR [LStmtLR idL idR body]+     -- Assume XRec is the same for idL and idR, pick one arbitrarily++        -- The next two fields are only valid after renaming+     , recS_later_ids :: [IdP idR]+                         -- The ids are a subset of the variables bound by the+                         -- stmts that are used in stmts that follow the RecStmt++     , recS_rec_ids :: [IdP idR]+                         -- Ditto, but these variables are the "recursive" ones,+                         -- that are used before they are bound in the stmts of+                         -- the RecStmt.+        -- An Id can be in both groups+        -- Both sets of Ids are (now) treated monomorphically+        -- See Note [How RecStmt works] for why they are separate++        -- Rebindable syntax+     , recS_bind_fn :: SyntaxExpr idR -- The bind function+     , recS_ret_fn  :: SyntaxExpr idR -- The return function+     , recS_mfix_fn :: SyntaxExpr idR -- The mfix function+      }+  | XStmtLR !(XXStmtLR idL idR body)++data TransForm   -- The 'f' below is the 'using' function, 'e' is the by function+  = ThenForm     -- then f               or    then f by e             (depending on trS_by)+  | GroupForm    -- then group using f   or    then group by e using f (depending on trS_by)+  deriving Data++-- | Parenthesised Statement Block+data ParStmtBlock idL idR+  = ParStmtBlock+        (XParStmtBlock idL idR)+        [ExprLStmt idL]+        [IdP idR]          -- The variables to be returned+        (SyntaxExpr idR)   -- The return operator+  | XParStmtBlock !(XXParStmtBlock idL idR)++-- | The fail operator+--+-- This is used for `.. <-` "bind statements" in do notation, including+-- non-monadic "binds" in applicative.+--+-- The fail operator is 'Just expr' if it potentially fail monadically. if the+-- pattern match cannot fail, or shouldn't fail monadically (regular incomplete+-- pattern exception), it is 'Nothing'.+--+-- See Note [Monad fail : Rebindable syntax, overloaded strings] for the type of+-- expression in the 'Just' case, and why it is so.+--+-- See Note [Failing pattern matches in Stmts] for which contexts for+-- '@BindStmt@'s should use the monadic fail and which shouldn't.+type FailOperator id = Maybe (SyntaxExpr id)++-- | Applicative Argument+data ApplicativeArg idL+  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)+    { xarg_app_arg_one  :: XApplicativeArgOne idL+      -- ^ The fail operator, after renaming+      --+      -- The fail operator is needed if this is a BindStmt+      -- where the pattern can fail. E.g.:+      -- (Just a) <- stmt+      -- The fail operator will be invoked if the pattern+      -- match fails.+      -- It is also used for guards in MonadComprehensions.+      -- The fail operator is Nothing+      -- if the pattern match can't fail+    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)+    , arg_expr          :: LHsExpr idL+    , is_body_stmt      :: Bool+      -- ^ True <=> was a BodyStmt,+      -- False <=> was a BindStmt.+      -- See Note [Applicative BodyStmt]+    }+  | ApplicativeArgMany     -- do { stmts; return vars }+    { xarg_app_arg_many :: XApplicativeArgMany idL+    , app_stmts         :: [ExprLStmt idL] -- stmts+    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)+    , bv_pattern        :: LPat idL      -- (v1,...,vn)+    , stmt_context      :: HsStmtContext (ApplicativeArgStmCtxPass idL)+      -- ^ context of the do expression, used in pprArg+    }+  | XApplicativeArg !(XXApplicativeArg idL)++type family ApplicativeArgStmCtxPass idL++{-+Note [The type of bind in Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some Stmts, notably BindStmt, keep the (>>=) bind operator.+We do NOT assume that it has type+    (>>=) :: m a -> (a -> m b) -> m b+In some cases (see #303, #1537) it might have a more+exotic type, such as+    (>>=) :: m i j a -> (a -> m j k b) -> m i k b+So we must be careful not to make assumptions about the type.+In particular, the monad may not be uniform throughout.++Note [TransStmt binder map]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The [(idR,idR)] in a TransStmt behaves as follows:++  * Before renaming: []++  * After renaming:+          [ (x27,x27), ..., (z35,z35) ]+    These are the variables+       bound by the stmts to the left of the 'group'+       and used either in the 'by' clause,+                or     in the stmts following the 'group'+    Each item is a pair of identical variables.++  * After typechecking:+          [ (x27:Int, x27:[Int]), ..., (z35:Bool, z35:[Bool]) ]+    Each pair has the same unique, but different *types*.++Note [BodyStmt]+~~~~~~~~~~~~~~~+BodyStmts are a bit tricky, because what they mean+depends on the context.  Consider the following contexts:++        A do expression of type (m res_ty)+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E any_ty:   do { ....; E; ... }+                E :: m any_ty+          Translation: E >> ...++        A list comprehensions of type [elt_ty]+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E Bool:   [ .. | .... E ]+                        [ .. | ..., E, ... ]+                        [ .. | .... | ..., E | ... ]+                E :: Bool+          Translation: if E then fail else ...++        A guard list, guarding a RHS of type rhs_ty+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E BooParStmtBlockl:   f x | ..., E, ... = ...rhs...+                E :: Bool+          Translation: if E then fail else ...++        A monad comprehension of type (m res_ty)+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        * BodyStmt E Bool:   [ .. | .... E ]+                E :: Bool+          Translation: guard E >> ...++Array comprehensions are handled like list comprehensions.++Note [How RecStmt works]+~~~~~~~~~~~~~~~~~~~~~~~~+Example:+   HsDo [ BindStmt x ex++        , RecStmt { recS_rec_ids   = [a, c]+                  , recS_stmts     = [ BindStmt b (return (a,c))+                                     , LetStmt a = ...b...+                                     , BindStmt c ec ]+                  , recS_later_ids = [a, b]++        , return (a b) ]++Here, the RecStmt binds a,b,c; but+  - Only a,b are used in the stmts *following* the RecStmt,+  - Only a,c are used in the stmts *inside* the RecStmt+        *before* their bindings++Why do we need *both* rec_ids and later_ids?  For monads they could be+combined into a single set of variables, but not for arrows.  That+follows from the types of the respective feedback operators:++        mfix :: MonadFix m => (a -> m a) -> m a+        loop :: ArrowLoop a => a (b,d) (c,d) -> a b c++* For mfix, the 'a' covers the union of the later_ids and the rec_ids+* For 'loop', 'c' is the later_ids and 'd' is the rec_ids++Note [Typing a RecStmt]+~~~~~~~~~~~~~~~~~~~~~~~+A (RecStmt stmts) types as if you had written++  (v1,..,vn, _, ..., _) <- mfix (\~(_, ..., _, r1, ..., rm) ->+                                 do { stmts+                                    ; return (v1,..vn, r1, ..., rm) })++where v1..vn are the later_ids+      r1..rm are the rec_ids++Note [Monad Comprehensions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Monad comprehensions require separate functions like 'return' and+'>>=' for desugaring. These functions are stored in the statements+used in monad comprehensions. For example, the 'return' of the 'LastStmt'+expression is used to lift the body of the monad comprehension:++  [ body | stmts ]+   =>+  stmts >>= \bndrs -> return body++In transform and grouping statements ('then ..' and 'then group ..') the+'return' function is required for nested monad comprehensions, for example:++  [ body | stmts, then f, rest ]+   =>+  f [ env | stmts ] >>= \bndrs -> [ body | rest ]++BodyStmts require the 'Control.Monad.guard' function for boolean+expressions:++  [ body | exp, stmts ]+   =>+  guard exp >> [ body | stmts ]++Parallel statements require the 'Control.Monad.Zip.mzip' function:++  [ body | stmts1 | stmts2 | .. ]+   =>+  mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body++In any other context than 'MonadComp', the fields for most of these+'SyntaxExpr's stay bottom.+++Note [Applicative BodyStmt]++(#12143) For the purposes of ApplicativeDo, we treat any BodyStmt+as if it was a BindStmt with a wildcard pattern.  For example,++  do+    x <- A+    B+    return x++is transformed as if it were++  do+    x <- A+    _ <- B+    return x++so it transforms to++  (\(x,_) -> x) <$> A <*> B++But we have to remember when we treat a BodyStmt like a BindStmt,+because in error messages we want to emit the original syntax the user+wrote, not our internal representation.  So ApplicativeArgOne has a+Bool flag that is True when the original statement was a BodyStmt, so+that we can pretty-print it correctly.+-}+++{-+************************************************************************+*                                                                      *+                Template Haskell quotation brackets+*                                                                      *+************************************************************************+-}++-- | Haskell Splice+data HsSplice id+   = HsTypedSplice       --  $$z  or $$(f 4)+        (XTypedSplice id)+        SpliceDecoration -- Whether $$( ) variant found, for pretty printing+        (IdP id)         -- A unique name to identify this splice point+        (LHsExpr id)     -- See Note [Pending Splices]++   | HsUntypedSplice     --  $z  or $(f 4)+        (XUntypedSplice id)+        SpliceDecoration -- Whether $( ) variant found, for pretty printing+        (IdP id)         -- A unique name to identify this splice point+        (LHsExpr id)     -- See Note [Pending Splices]++   | HsQuasiQuote        -- See Note [Quasi-quote overview] in GHC.Tc.Gen.Splice+        (XQuasiQuote id)+        (IdP id)         -- Splice point+        (IdP id)         -- Quoter+        SrcSpan          -- The span of the enclosed string+        FastString       -- The enclosed string++   -- AZ:TODO: use XSplice instead of HsSpliced+   | HsSpliced  -- See Note [Delaying modFinalizers in untyped splices] in+                -- GHC.Rename.Splice.+                -- This is the result of splicing a splice. It is produced by+                -- the renamer and consumed by the typechecker. It lives only+                -- between the two.+        (XSpliced id)+        ThModFinalizers     -- TH finalizers produced by the splice.+        (HsSplicedThing id) -- The result of splicing+   | XSplice !(XXSplice id) -- Note [Trees that Grow] extension point++-- | A splice can appear with various decorations wrapped around it. This data+-- type captures explicitly how it was originally written, for use in the pretty+-- printer.+data SpliceDecoration+  = DollarSplice  -- ^ $splice or $$splice+  | BareSplice    -- ^ bare splice+  deriving (Data, Eq, Show)++instance Outputable SpliceDecoration where+  ppr x = text $ show x+++isTypedSplice :: HsSplice id -> Bool+isTypedSplice (HsTypedSplice {}) = True+isTypedSplice _                  = False   -- Quasi-quotes are untyped splices++-- | Finalizers produced by a splice with+-- 'Language.Haskell.TH.Syntax.addModFinalizer'+--+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how+-- this is used.+--+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]++-- A Data instance which ignores the argument of 'ThModFinalizers'.+instance Data ThModFinalizers where+  gunfold _ z _ = z $ ThModFinalizers []+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]++-- | Haskell Spliced Thing+--+-- Values that can result from running a splice.+data HsSplicedThing id+    = HsSplicedExpr (HsExpr id) -- ^ Haskell Spliced Expression+    | HsSplicedTy   (HsType id) -- ^ Haskell Spliced Type+    | HsSplicedPat  (Pat id)    -- ^ Haskell Spliced Pattern+++-- See Note [Pending Splices]+type SplicePointName = Name++data UntypedSpliceFlavour+  = UntypedExpSplice+  | UntypedPatSplice+  | UntypedTypeSplice+  | UntypedDeclSplice+  deriving Data++-- | Haskell Bracket+data HsBracket p+  = ExpBr  (XExpBr p)   (LHsExpr p)    -- [|  expr  |]+  | PatBr  (XPatBr p)   (LPat p)      -- [p| pat   |]+  | DecBrL (XDecBrL p)  [LHsDecl p]   -- [d| decls |]; result of parser+  | DecBrG (XDecBrG p)  (HsGroup p)   -- [d| decls |]; result of renamer+  | TypBr  (XTypBr p)   (LHsType p)   -- [t| type  |]+  | VarBr  (XVarBr p)   Bool (LIdP p)+                                -- True: 'x, False: ''T+                                -- (The Bool flag is used only in pprHsBracket)+  | TExpBr (XTExpBr p) (LHsExpr p)    -- [||  expr  ||]+  | XBracket !(XXBracket p)           -- Note [Trees that Grow] extension point++isTypedBracket :: HsBracket id -> Bool+isTypedBracket (TExpBr {}) = True+isTypedBracket _           = False++{-+************************************************************************+*                                                                      *+\subsection{Enumerations and list comprehensions}+*                                                                      *+************************************************************************+-}++-- | Arithmetic Sequence Information+data ArithSeqInfo id+  = From            (LHsExpr id)+  | FromThen        (LHsExpr id)+                    (LHsExpr id)+  | FromTo          (LHsExpr id)+                    (LHsExpr id)+  | FromThenTo      (LHsExpr id)+                    (LHsExpr id)+                    (LHsExpr id)+-- AZ: Should ArithSeqInfo have a TTG extension?++{-+************************************************************************+*                                                                      *+\subsection{HsMatchCtxt}+*                                                                      *+************************************************************************+-}++-- | Haskell Match Context+--+-- Context of a pattern match. This is more subtle than it would seem. See Note+-- [Varieties of pattern matches].+data HsMatchContext p+  = FunRhs { mc_fun        :: LIdP p    -- ^ function binder of @f@+           , mc_fixity     :: LexicalFixity -- ^ fixing of @f@+           , mc_strictness :: SrcStrictness -- ^ was @f@ banged?+                                            -- See Note [FunBind vs PatBind]+           }+                                -- ^A pattern matching on an argument of a+                                -- function binding+  | LambdaExpr                  -- ^Patterns of a lambda+  | CaseAlt                     -- ^Patterns and guards on a case alternative+  | IfAlt                       -- ^Guards of a multi-way if alternative+  | ArrowMatchCtxt              -- ^A pattern match inside arrow notation+      HsArrowMatchContext+  | PatBindRhs                  -- ^A pattern binding  eg [y] <- e = e+  | PatBindGuards               -- ^Guards of pattern bindings, e.g.,+                                --    (Just b) | Just _ <- x = e+                                --             | otherwise   = e'++  | RecUpd                      -- ^Record update [used only in GHC.HsToCore.Expr to+                                --    tell matchWrapper what sort of+                                --    runtime error message to generate]++  | StmtCtxt (HsStmtContext p)  -- ^Pattern of a do-stmt, list comprehension,+                                -- pattern guard, etc++  | ThPatSplice            -- ^A Template Haskell pattern splice+  | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]+  | PatSyn                 -- ^A pattern synonym declaration++isPatSynCtxt :: HsMatchContext p -> Bool+isPatSynCtxt ctxt =+  case ctxt of+    PatSyn -> True+    _      -> False++-- | Haskell Statement Context.+data HsStmtContext p+  = ListComp+  | MonadComp++  | DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }+  | MDoExpr (Maybe ModuleName)       -- ^[ModuleName.]mdo { ... }  ie recursive do-expression+  | ArrowExpr                        -- ^do-notation in an arrow-command context++  | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs+  | PatGuard (HsMatchContext p)      -- ^Pattern guard for specified thing+  | ParStmtCtxt (HsStmtContext p)    -- ^A branch of a parallel stmt+  | TransStmtCtxt (HsStmtContext p)  -- ^A branch of a transform stmt++-- | Haskell arrow match context.+data HsArrowMatchContext+  = ProcExpr     -- ^ A proc expression+  | ArrowCaseAlt -- ^ A case alternative inside arrow notation+  | KappaExpr    -- ^ An arrow kappa abstraction++qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName+qualifiedDoModuleName_maybe ctxt = case ctxt of+  DoExpr m -> m+  MDoExpr m -> m+  _ -> Nothing++isComprehensionContext :: HsStmtContext id -> Bool+-- Uses comprehension syntax [ e | quals ]+isComprehensionContext ListComp          = True+isComprehensionContext MonadComp         = True+isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c+isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c+isComprehensionContext _ = False++-- | Is this a monadic context?+isMonadStmtContext :: HsStmtContext id -> Bool+isMonadStmtContext MonadComp            = True+isMonadStmtContext DoExpr{}             = True+isMonadStmtContext MDoExpr{}            = True+isMonadStmtContext GhciStmtCtxt         = True+isMonadStmtContext (ParStmtCtxt ctxt)   = isMonadStmtContext ctxt+isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt+isMonadStmtContext _ = False -- ListComp, PatGuard, ArrowExpr++isMonadCompContext :: HsStmtContext id -> Bool+isMonadCompContext MonadComp = True+isMonadCompContext _         = False++matchSeparator :: HsMatchContext p -> SDoc+matchSeparator (FunRhs {})   = text "="+matchSeparator CaseAlt       = text "->"+matchSeparator IfAlt         = text "->"+matchSeparator LambdaExpr    = text "->"+matchSeparator (ArrowMatchCtxt{})= text "->"+matchSeparator PatBindRhs    = text "="+matchSeparator PatBindGuards = text "="+matchSeparator (StmtCtxt _)  = text "<-"+matchSeparator RecUpd        = text "=" -- This can be printed by the pattern+                                       -- match checker trace+matchSeparator ThPatSplice  = panic "unused"+matchSeparator ThPatQuote   = panic "unused"+matchSeparator PatSyn       = panic "unused"++pprMatchContext :: (Outputable (IdP p), UnXRec p)+                => HsMatchContext p -> SDoc+pprMatchContext ctxt+  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt+  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt+  where+    want_an (FunRhs {})                = True  -- Use "an" in front+    want_an (ArrowMatchCtxt ProcExpr)  = True+    want_an (ArrowMatchCtxt KappaExpr) = True+    want_an _                          = False++pprMatchContextNoun :: forall p. (Outputable (IdP p), UnXRec p)+                    => HsMatchContext p -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=fun})+                                    = text "equation for"+                                      <+> quotes (ppr (unXRec @p fun))+pprMatchContextNoun CaseAlt         = text "case alternative"+pprMatchContextNoun IfAlt           = text "multi-way if alternative"+pprMatchContextNoun RecUpd          = text "record-update construct"+pprMatchContextNoun ThPatSplice     = text "Template Haskell pattern splice"+pprMatchContextNoun ThPatQuote      = text "Template Haskell pattern quotation"+pprMatchContextNoun PatBindRhs      = text "pattern binding"+pprMatchContextNoun PatBindGuards   = text "pattern binding guards"+pprMatchContextNoun LambdaExpr      = text "lambda abstraction"+pprMatchContextNoun (ArrowMatchCtxt c)= pprArrowMatchContextNoun c+pprMatchContextNoun (StmtCtxt ctxt) = text "pattern binding in"+                                      $$ pprAStmtContext ctxt+pprMatchContextNoun PatSyn          = text "pattern synonym declaration"++pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNoun ProcExpr     = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt = text "case alternative within arrow notation"+pprArrowMatchContextNoun KappaExpr    = text "arrow kappa abstraction"++-----------------+pprAStmtContext, pprStmtContext :: (Outputable (IdP p), UnXRec p)+                                => HsStmtContext p -> SDoc+pprAStmtContext ctxt = article <+> pprStmtContext ctxt+  where+    pp_an = text "an"+    pp_a  = text "a"+    article = case ctxt of+                  MDoExpr Nothing -> pp_an+                  GhciStmtCtxt  -> pp_an+                  _             -> pp_a+++-----------------+pprStmtContext GhciStmtCtxt    = text "interactive GHCi command"+pprStmtContext (DoExpr m)      = prependQualified m (text "'do' block")+pprStmtContext (MDoExpr m)     = prependQualified m (text "'mdo' block")+pprStmtContext ArrowExpr       = text "'do' block in an arrow command"+pprStmtContext ListComp        = text "list comprehension"+pprStmtContext MonadComp       = text "monad comprehension"+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt++-- Drop the inner contexts when reporting errors, else we get+--     Unexpected transform statement+--     in a transformed branch of+--          transformed branch of+--          transformed branch of monad comprehension+pprStmtContext (ParStmtCtxt c) =+  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])+             (pprStmtContext c)+pprStmtContext (TransStmtCtxt c) =+  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])+             (pprStmtContext c)++prependQualified :: Maybe ModuleName -> SDoc -> SDoc+prependQualified Nothing  t = t+prependQualified (Just _) t = text "qualified" <+> t

+ Language/Haskell/Syntax/Expr.hs-boot view

@@ -0,0 +1,22 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax.Expr where++import Language.Haskell.Syntax.Extension ( XRec )+import Data.Kind  ( Type )++type role HsExpr nominal+type role MatchGroup nominal nominal+type role GRHSs nominal nominal+type role HsSplice nominal+data HsExpr (i :: Type)+data HsSplice (i :: Type)+data MatchGroup (a :: Type) (body :: Type)+data GRHSs (a :: Type) (body :: Type)+type family SyntaxExpr (i :: Type)++type LHsExpr a = XRec a (HsExpr a)

+ Language/Haskell/Syntax/Extension.hs view

@@ -0,0 +1,696 @@+{-# LANGUAGE AllowAmbiguousTypes     #-} -- for unXRec, etc.+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DeriveDataTypeable      #-}+{-# LANGUAGE EmptyCase               #-}+{-# LANGUAGE EmptyDataDeriving       #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE RankNTypes              #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeFamilyDependencies  #-}+{-# LANGUAGE UndecidableInstances    #-} -- Wrinkle in Note [Trees That Grow]+                                         -- in module Language.Haskell.Syntax.Extension++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax.Extension where++-- This module captures the type families to precisely identify the extension+-- points for GHC.Hs syntax++import GHC.Prelude++import Data.Data hiding ( Fixity )+import Data.Kind (Type)+import GHC.Utils.Outputable++{-+Note [Trees that grow]+~~~~~~~~~~~~~~~~~~~~~~++See https://gitlab.haskell.org/ghc/ghc/wikis/implementing-trees-that-grow++The hsSyn AST is reused across multiple compiler passes. We also have the+Template Haskell AST, and the haskell-src-exts one (outside of GHC)++Supporting multiple passes means the AST has various warts on it to cope with+the specifics for the phases, such as the 'ValBindsOut', 'ConPatOut',+'SigPatOut' etc.++The growable AST will allow each of these variants to be captured explicitly,+such that they only exist in the given compiler pass AST, as selected by the+type parameter to the AST.++In addition it will allow tool writers to define their own extensions to capture+additional information for the tool, in a natural way.++A further goal is to provide a means to harmonise the Template Haskell and+haskell-src-exts ASTs as well.++Wrinkle: In order to print out the AST, we need to know it is Outputable.+We also sometimes need to branch on the particular pass that we're in+(e.g. to print out type information once we know it). In order to allow+both of these actions, we define OutputableBndrId, which gathers the necessary+OutputableBndr and IsPass constraints. The use of this constraint in instances+generally requires UndecidableInstances.++See also Note [IsPass] and Note [NoGhcTc] in GHC.Hs.Extension.++-}++-- | A placeholder type for TTG extension points that are not currently+-- unused to represent any particular value.+--+-- This should not be confused with 'NoExtCon', which are found in unused+-- extension /constructors/ and therefore should never be inhabited. In+-- contrast, 'NoExtField' is used in extension /points/ (e.g., as the field of+-- some constructor), so it must have an inhabitant to construct AST passes+-- that manipulate fields with that extension point as their type.+data NoExtField = NoExtField+  deriving (Data,Eq,Ord)++instance Outputable NoExtField where+  ppr _ = text "NoExtField"++-- | Used when constructing a term with an unused extension point.+noExtField :: NoExtField+noExtField = NoExtField++-- | Used in TTG extension constructors that have yet to be extended with+-- anything. If an extension constructor has 'NoExtCon' as its field, it is+-- not intended to ever be constructed anywhere, and any function that consumes+-- the extension constructor can eliminate it by way of 'noExtCon'.+--+-- This should not be confused with 'NoExtField', which are found in unused+-- extension /points/ (not /constructors/) and therefore can be inhabited.++-- See also [NoExtCon and strict fields].+data NoExtCon+  deriving (Data,Eq,Ord)++instance Outputable NoExtCon where+  ppr = noExtCon++-- | Eliminate a 'NoExtCon'. Much like 'Data.Void.absurd'.+noExtCon :: NoExtCon -> a+noExtCon x = case x of {}++-- | GHC's L prefixed variants wrap their vanilla variant in this type family,+-- to add 'SrcLoc' info via 'Located'. Other passes than 'GhcPass' not+-- interested in location information can define this as+-- @type instance XRec NoLocated a = a@.+-- See Note [XRec and SrcSpans in the AST]+type family XRec p a = r | r -> a++type family Anno a = b -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation++{-+Note [XRec and SrcSpans in the AST]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+XRec is meant to replace most of the uses of `Located` in the AST. It is another+extension point meant to make it easier for non-GHC applications to reuse the+AST for their own purposes, and not have to deal the hassle of (perhaps) useless+SrcSpans everywhere.++instead of `Located (HsExpr p)` or similar types, we will now have `XRec p+(HsExpr p)`++XRec allows annotating certain points in the AST with extra+information. This maybe be source spans (for GHC), nothing (for TH),+types (for HIE files), exact print annotations (for exactprint) or+anything else.++This should hopefully bring us one step closer to sharing the AST between GHC+and TH.++We use the `UnXRec`, `MapXRec` and `WrapXRec` type classes to aid us in writing+pass-polymorphic code that deals with `XRec`s+-}++-- | We can strip off the XRec to access the underlying data.+-- See Note [XRec and SrcSpans in the AST]+class UnXRec p where+  unXRec :: XRec p a -> a++-- | We can map over the underlying type contained in an @XRec@ while preserving+-- the annotation as is.+class MapXRec p where+  mapXRec :: (Anno a ~ Anno b) => (a -> b) -> XRec p a -> XRec p b+-- See Note [XRec and SrcSpans in the AST]+-- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation+-- AZ: Is there a way to not have Anno in this file, but still have MapXRec?+--     Perhaps define XRec with an additional b parameter, only used in Hs as (Anno b)?++-- | The trivial wrapper that carries no additional information+-- See Note [XRec and SrcSpans in the AST]+class WrapXRec p a where+  wrapXRec :: a -> XRec p a++-- | Maps the "normal" id type for a given pass+type family IdP p++type LIdP p = XRec p (IdP p)++-- =====================================================================+-- Type families for the HsBinds extension points++-- HsLocalBindsLR type families+type family XHsValBinds      x x'+type family XHsIPBinds       x x'+type family XEmptyLocalBinds x x'+type family XXHsLocalBindsLR x x'++-- HsValBindsLR type families+type family XValBinds    x x'+type family XXValBindsLR x x'++-- HsBindLR type families+type family XFunBind    x x'+type family XPatBind    x x'+type family XVarBind    x x'+type family XAbsBinds   x x'+type family XPatSynBind x x'+type family XXHsBindsLR x x'++-- ABExport type families+type family XABE x+type family XXABExport x++-- PatSynBind type families+type family XPSB x x'+type family XXPatSynBind x x'++-- HsIPBinds type families+type family XIPBinds    x+type family XXHsIPBinds x++-- IPBind type families+type family XCIPBind x+type family XXIPBind x++-- Sig type families+type family XTypeSig          x+type family XPatSynSig        x+type family XClassOpSig       x+type family XIdSig            x+type family XFixSig           x+type family XInlineSig        x+type family XSpecSig          x+type family XSpecInstSig      x+type family XMinimalSig       x+type family XSCCFunSig        x+type family XCompleteMatchSig x+type family XXSig             x++-- FixitySig type families+type family XFixitySig          x+type family XXFixitySig         x++-- StandaloneKindSig type families+type family XStandaloneKindSig  x+type family XXStandaloneKindSig x++-- =====================================================================+-- Type families for the HsDecls extension points++-- HsDecl type families+type family XTyClD       x+type family XInstD       x+type family XDerivD      x+type family XValD        x+type family XSigD        x+type family XKindSigD    x+type family XDefD        x+type family XForD        x+type family XWarningD    x+type family XAnnD        x+type family XRuleD       x+type family XSpliceD     x+type family XDocD        x+type family XRoleAnnotD  x+type family XXHsDecl     x++-- -------------------------------------+-- HsGroup type families+type family XCHsGroup      x+type family XXHsGroup      x++-- -------------------------------------+-- SpliceDecl type families+type family XSpliceDecl       x+type family XXSpliceDecl      x++-- -------------------------------------+-- TyClDecl type families+type family XFamDecl       x+type family XSynDecl       x+type family XDataDecl      x+type family XClassDecl     x+type family XXTyClDecl     x++-- -------------------------------------+-- FunDep type families+type family XCFunDep      x+type family XXFunDep      x++-- -------------------------------------+-- TyClGroup type families+type family XCTyClGroup      x+type family XXTyClGroup      x++-- -------------------------------------+-- FamilyResultSig type families+type family XNoSig            x+type family XCKindSig         x -- Clashes with XKindSig above+type family XTyVarSig         x+type family XXFamilyResultSig x++-- -------------------------------------+-- FamilyDecl type families+type family XCFamilyDecl      x+type family XXFamilyDecl      x++-- -------------------------------------+-- HsDataDefn type families+type family XCHsDataDefn      x+type family XXHsDataDefn      x++-- -------------------------------------+-- HsDerivingClause type families+type family XCHsDerivingClause      x+type family XXHsDerivingClause      x++-- -------------------------------------+-- DerivClauseTys type families+type family XDctSingle       x+type family XDctMulti        x+type family XXDerivClauseTys x++-- -------------------------------------+-- ConDecl type families+type family XConDeclGADT   x+type family XConDeclH98    x+type family XXConDecl      x++-- -------------------------------------+-- FamEqn type families+type family XCFamEqn      x r+type family XXFamEqn      x r++-- -------------------------------------+-- TyFamInstDecl type families+type family XCTyFamInstDecl x+type family XXTyFamInstDecl x++-- -------------------------------------+-- ClsInstDecl type families+type family XCClsInstDecl      x+type family XXClsInstDecl      x++-- -------------------------------------+-- InstDecl type families+type family XClsInstD      x+type family XDataFamInstD  x+type family XTyFamInstD    x+type family XXInstDecl     x++-- -------------------------------------+-- DerivDecl type families+type family XCDerivDecl      x+type family XXDerivDecl      x++-- -------------------------------------+-- DerivStrategy type family+type family XStockStrategy    x+type family XAnyClassStrategy x+type family XNewtypeStrategy  x+type family XViaStrategy      x++-- -------------------------------------+-- DefaultDecl type families+type family XCDefaultDecl      x+type family XXDefaultDecl      x++-- -------------------------------------+-- ForeignDecl type families+type family XForeignImport     x+type family XForeignExport     x+type family XXForeignDecl      x++-- -------------------------------------+-- RuleDecls type families+type family XCRuleDecls      x+type family XXRuleDecls      x++-- -------------------------------------+-- RuleDecl type families+type family XHsRule          x+type family XXRuleDecl       x++-- -------------------------------------+-- RuleBndr type families+type family XCRuleBndr      x+type family XRuleBndrSig    x+type family XXRuleBndr      x++-- -------------------------------------+-- WarnDecls type families+type family XWarnings        x+type family XXWarnDecls      x++-- -------------------------------------+-- WarnDecl type families+type family XWarning        x+type family XXWarnDecl      x++-- -------------------------------------+-- AnnDecl type families+type family XHsAnnotation  x+type family XXAnnDecl      x++-- -------------------------------------+-- RoleAnnotDecl type families+type family XCRoleAnnotDecl  x+type family XXRoleAnnotDecl  x++-- -------------------------------------+-- InjectivityAnn type families+type family XCInjectivityAnn  x+type family XXInjectivityAnn  x++-- =====================================================================+-- Type families for the HsExpr extension points++type family XVar            x+type family XUnboundVar     x+type family XConLikeOut     x+type family XRecFld         x+type family XOverLabel      x+type family XIPVar          x+type family XOverLitE       x+type family XLitE           x+type family XLam            x+type family XLamCase        x+type family XApp            x+type family XAppTypeE       x+type family XOpApp          x+type family XNegApp         x+type family XPar            x+type family XSectionL       x+type family XSectionR       x+type family XExplicitTuple  x+type family XExplicitSum    x+type family XCase           x+type family XIf             x+type family XMultiIf        x+type family XLet            x+type family XDo             x+type family XExplicitList   x+type family XRecordCon      x+type family XRecordUpd      x+type family XGetField       x+type family XProjection     x+type family XExprWithTySig  x+type family XArithSeq       x+type family XBracket        x+type family XRnBracketOut   x+type family XTcBracketOut   x+type family XSpliceE        x+type family XProc           x+type family XStatic         x+type family XTick           x+type family XBinTick        x+type family XPragE          x+type family XXExpr          x++-- -------------------------------------+-- FieldLabel type families+type family XCHsFieldLabel  x+type family XXHsFieldLabel  x++-- -------------------------------------+-- HsPragE type families+type family XSCC            x+type family XXPragE         x+++-- -------------------------------------+-- AmbiguousFieldOcc type families+type family XUnambiguous        x+type family XAmbiguous          x+type family XXAmbiguousFieldOcc x++-- -------------------------------------+-- HsTupArg type families+type family XPresent  x+type family XMissing  x+type family XXTupArg  x++-- -------------------------------------+-- HsSplice type families+type family XTypedSplice   x+type family XUntypedSplice x+type family XQuasiQuote    x+type family XSpliced       x+type family XXSplice       x++-- -------------------------------------+-- HsBracket type families+type family XExpBr      x+type family XPatBr      x+type family XDecBrL     x+type family XDecBrG     x+type family XTypBr      x+type family XVarBr      x+type family XTExpBr     x+type family XXBracket   x++-- -------------------------------------+-- HsCmdTop type families+type family XCmdTop  x+type family XXCmdTop x++-- -------------------------------------+-- MatchGroup type families+type family XMG           x b+type family XXMatchGroup  x b++-- -------------------------------------+-- Match type families+type family XCMatch  x b+type family XXMatch  x b++-- -------------------------------------+-- GRHSs type families+type family XCGRHSs  x b+type family XXGRHSs  x b++-- -------------------------------------+-- GRHS type families+type family XCGRHS  x b+type family XXGRHS  x b++-- -------------------------------------+-- StmtLR type families+type family XLastStmt        x x' b+type family XBindStmt        x x' b+type family XApplicativeStmt x x' b+type family XBodyStmt        x x' b+type family XLetStmt         x x' b+type family XParStmt         x x' b+type family XTransStmt       x x' b+type family XRecStmt         x x' b+type family XXStmtLR         x x' b++-- -------------------------------------+-- HsCmd type families+type family XCmdArrApp  x+type family XCmdArrForm x+type family XCmdApp     x+type family XCmdLam     x+type family XCmdPar     x+type family XCmdCase    x+type family XCmdLamCase x+type family XCmdIf      x+type family XCmdLet     x+type family XCmdDo      x+type family XCmdWrap    x+type family XXCmd       x++-- -------------------------------------+-- ParStmtBlock type families+type family XParStmtBlock  x x'+type family XXParStmtBlock x x'++-- -------------------------------------+-- ApplicativeArg type families+type family XApplicativeArgOne   x+type family XApplicativeArgMany  x+type family XXApplicativeArg     x++-- =====================================================================+-- Type families for the HsImpExp extension points++-- TODO++-- =====================================================================+-- Type families for the HsLit extension points++-- We define a type family for each extension point. This is based on prepending+-- 'X' to the constructor name, for ease of reference.+type family XHsChar x+type family XHsCharPrim x+type family XHsString x+type family XHsStringPrim x+type family XHsInt x+type family XHsIntPrim x+type family XHsWordPrim x+type family XHsInt64Prim x+type family XHsWord64Prim x+type family XHsInteger x+type family XHsRat x+type family XHsFloatPrim x+type family XHsDoublePrim x+type family XXLit x++-- -------------------------------------+-- HsOverLit type families+type family XOverLit  x+type family XXOverLit x++-- =====================================================================+-- Type families for the HsPat extension points++type family XWildPat    x+type family XVarPat     x+type family XLazyPat    x+type family XAsPat      x+type family XParPat     x+type family XBangPat    x+type family XListPat    x+type family XTuplePat   x+type family XSumPat     x+type family XConPat     x+type family XViewPat    x+type family XSplicePat  x+type family XLitPat     x+type family XNPat       x+type family XNPlusKPat  x+type family XSigPat     x+type family XCoPat      x+type family XXPat       x+type family XHsRecField x++-- =====================================================================+-- Type families for the HsTypes type families+++-- -------------------------------------+-- LHsQTyVars type families+type family XHsQTvs       x+type family XXLHsQTyVars  x++-- -------------------------------------+-- HsOuterTyVarBndrs type families+type family XHsOuterImplicit    x+type family XHsOuterExplicit    x flag+type family XXHsOuterTyVarBndrs x++-- -------------------------------------+-- HsSigType type families+type family XHsSig      x+type family XXHsSigType x++-- -------------------------------------+-- HsWildCardBndrs type families+type family XHsWC              x b+type family XXHsWildCardBndrs  x b++-- -------------------------------------+-- HsPatSigType type families+type family XHsPS x+type family XXHsPatSigType x++-- -------------------------------------+-- HsType type families+type family XForAllTy        x+type family XQualTy          x+type family XTyVar           x+type family XAppTy           x+type family XAppKindTy       x+type family XFunTy           x+type family XListTy          x+type family XTupleTy         x+type family XSumTy           x+type family XOpTy            x+type family XParTy           x+type family XIParamTy        x+type family XStarTy          x+type family XKindSig         x+type family XSpliceTy        x+type family XDocTy           x+type family XBangTy          x+type family XRecTy           x+type family XExplicitListTy  x+type family XExplicitTupleTy x+type family XTyLit           x+type family XWildCardTy      x+type family XXType           x++-- ---------------------------------------------------------------------+-- HsForAllTelescope type families+type family XHsForAllVis        x+type family XHsForAllInvis      x+type family XXHsForAllTelescope x++-- ---------------------------------------------------------------------+-- HsTyVarBndr type families+type family XUserTyVar   x+type family XKindedTyVar x+type family XXTyVarBndr  x++-- ---------------------------------------------------------------------+-- ConDeclField type families+type family XConDeclField  x+type family XXConDeclField x++-- ---------------------------------------------------------------------+-- FieldOcc type families+type family XCFieldOcc x+type family XXFieldOcc x++-- =====================================================================+-- Type families for the HsImpExp type families++-- -------------------------------------+-- ImportDecl type families+type family XCImportDecl       x+type family XXImportDecl       x++-- -------------------------------------+-- IE type families+type family XIEVar             x+type family XIEThingAbs        x+type family XIEThingAll        x+type family XIEThingWith       x+type family XIEModuleContents  x+type family XIEGroup           x+type family XIEDoc             x+type family XIEDocNamed        x+type family XXIE               x++-- -------------------------------------++-- =====================================================================+-- Misc++-- | See Note [NoGhcTc] in GHC.Hs.Extension. It has to be in this+-- module because it is used like an extension point (in the data definitions+-- of types that should be parameter-agnostic.+type family NoGhcTc (p :: Type)++-- =====================================================================+-- End of Type family definitions+-- =====================================================================

+ Language/Haskell/Syntax/Lit.hs view

@@ -0,0 +1,204 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*++-- | Source-language literals+module Language.Haskell.Syntax.Lit where++#include "HsVersions.h"++import GHC.Prelude++import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsExpr )+import GHC.Types.Basic (PprPrec(..), topPrec )+import GHC.Types.SourceText+import GHC.Core.Type+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import Language.Haskell.Syntax.Extension++import Data.ByteString (ByteString)+import Data.Data hiding ( Fixity )++{-+************************************************************************+*                                                                      *+\subsection[HsLit]{Literals}+*                                                                      *+************************************************************************+-}++-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in+-- the following+-- Note [Trees that grow] in Language.Haskell.Syntax.Extension for the Xxxxx fields in the following+-- | Haskell Literal+data HsLit x+  = HsChar (XHsChar x) {- SourceText -} Char+      -- ^ Character+  | HsCharPrim (XHsCharPrim x) {- SourceText -} Char+      -- ^ Unboxed character+  | HsString (XHsString x) {- SourceText -} FastString+      -- ^ String+  | HsStringPrim (XHsStringPrim x) {- SourceText -} !ByteString+      -- ^ Packed bytes+  | HsInt (XHsInt x)  IntegralLit+      -- ^ Genuinely an Int; arises from+      -- "GHC.Tc.Deriv.Generate", and from TRANSLATION+  | HsIntPrim (XHsIntPrim x) {- SourceText -} Integer+      -- ^ literal @Int#@+  | HsWordPrim (XHsWordPrim x) {- SourceText -} Integer+      -- ^ literal @Word#@+  | HsInt64Prim (XHsInt64Prim x) {- SourceText -} Integer+      -- ^ literal @Int64#@+  | HsWord64Prim (XHsWord64Prim x) {- SourceText -} Integer+      -- ^ literal @Word64#@+  | HsInteger (XHsInteger x) {- SourceText -} Integer Type+      -- ^ Genuinely an integer; arises only+      -- from TRANSLATION (overloaded+      -- literals are done with HsOverLit)+  | HsRat (XHsRat x)  FractionalLit Type+      -- ^ Genuinely a rational; arises only from+      -- TRANSLATION (overloaded literals are+      -- done with HsOverLit)+  | HsFloatPrim (XHsFloatPrim x)   FractionalLit+      -- ^ Unboxed Float+  | HsDoublePrim (XHsDoublePrim x) FractionalLit+      -- ^ Unboxed Double++  | XLit !(XXLit x)++instance Eq (HsLit x) where+  (HsChar _ x1)       == (HsChar _ x2)       = x1==x2+  (HsCharPrim _ x1)   == (HsCharPrim _ x2)   = x1==x2+  (HsString _ x1)     == (HsString _ x2)     = x1==x2+  (HsStringPrim _ x1) == (HsStringPrim _ x2) = x1==x2+  (HsInt _ x1)        == (HsInt _ x2)        = x1==x2+  (HsIntPrim _ x1)    == (HsIntPrim _ x2)    = x1==x2+  (HsWordPrim _ x1)   == (HsWordPrim _ x2)   = x1==x2+  (HsInt64Prim _ x1)  == (HsInt64Prim _ x2)  = x1==x2+  (HsWord64Prim _ x1) == (HsWord64Prim _ x2) = x1==x2+  (HsInteger _ x1 _)  == (HsInteger _ x2 _)  = x1==x2+  (HsRat _ x1 _)      == (HsRat _ x2 _)      = x1==x2+  (HsFloatPrim _ x1)  == (HsFloatPrim _ x2)  = x1==x2+  (HsDoublePrim _ x1) == (HsDoublePrim _ x2) = x1==x2+  _                   == _                   = False++-- | Haskell Overloaded Literal+data HsOverLit p+  = OverLit {+      ol_ext :: (XOverLit p),+      ol_val :: OverLitVal,+      ol_witness :: HsExpr p}         -- Note [Overloaded literal witnesses]++  | XOverLit+      !(XXOverLit p)++-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in+-- the following+-- | Overloaded Literal Value+data OverLitVal+  = HsIntegral   !IntegralLit            -- ^ Integer-looking literals;+  | HsFractional !FractionalLit          -- ^ Frac-looking literals+  | HsIsString   !SourceText !FastString -- ^ String-looking literals+  deriving Data++negateOverLitVal :: OverLitVal -> OverLitVal+negateOverLitVal (HsIntegral i) = HsIntegral (negateIntegralLit i)+negateOverLitVal (HsFractional f) = HsFractional (negateFractionalLit f)+negateOverLitVal _ = panic "negateOverLitVal: argument is not a number"++{-+Note [Overloaded literal witnesses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Before* type checking, the HsExpr in an HsOverLit is the+name of the coercion function, 'fromInteger' or 'fromRational'.+*After* type checking, it is a witness for the literal, such as+        (fromInteger 3) or lit_78+This witness should replace the literal.++This dual role is unusual, because we're replacing 'fromInteger' with+a call to fromInteger.  Reason: it allows commoning up of the fromInteger+calls, which wouldn't be possible if the desugarer made the application.++The PostTcType in each branch records the type the overload literal is+found to have.+-}++-- Comparison operations are needed when grouping literals+-- for compiling pattern-matching (module GHC.HsToCore.Match.Literal)+instance (Eq (XXOverLit p)) => Eq (HsOverLit p) where+  (OverLit _ val1 _) == (OverLit _ val2 _) = val1 == val2+  (XOverLit  val1)   == (XOverLit  val2)   = val1 == val2+  _ == _ = panic "Eq HsOverLit"++instance Eq OverLitVal where+  (HsIntegral   i1)   == (HsIntegral   i2)   = i1 == i2+  (HsFractional f1)   == (HsFractional f2)   = f1 == f2+  (HsIsString _ s1)   == (HsIsString _ s2)   = s1 == s2+  _                   == _                   = False++instance (Ord (XXOverLit p)) => Ord (HsOverLit p) where+  compare (OverLit _ val1 _) (OverLit _ val2 _) = val1 `compare` val2+  compare (XOverLit  val1)   (XOverLit  val2)   = val1 `compare` val2+  compare _ _ = panic "Ord HsOverLit"++instance Ord OverLitVal where+  compare (HsIntegral i1)     (HsIntegral i2)     = i1 `compare` i2+  compare (HsIntegral _)      (HsFractional _)    = LT+  compare (HsIntegral _)      (HsIsString _ _)    = LT+  compare (HsFractional f1)   (HsFractional f2)   = f1 `compare` f2+  compare (HsFractional _)    (HsIntegral   _)    = GT+  compare (HsFractional _)    (HsIsString _ _)    = LT+  compare (HsIsString _ s1)   (HsIsString _ s2)   = s1 `uniqCompareFS` s2+  compare (HsIsString _ _)    (HsIntegral   _)    = GT+  compare (HsIsString _ _)    (HsFractional _)    = GT++instance Outputable OverLitVal where+  ppr (HsIntegral i)     = pprWithSourceText (il_text i) (integer (il_value i))+  ppr (HsFractional f)   = ppr f+  ppr (HsIsString st s)  = pprWithSourceText st (pprHsString s)++-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs+-- to be parenthesized under precedence @p@.+hsLitNeedsParens :: PprPrec -> HsLit x -> Bool+hsLitNeedsParens p = go+  where+    go (HsChar {})        = False+    go (HsCharPrim {})    = False+    go (HsString {})      = False+    go (HsStringPrim {})  = False+    go (HsInt _ x)        = p > topPrec && il_neg x+    go (HsIntPrim _ x)    = p > topPrec && x < 0+    go (HsWordPrim {})    = False+    go (HsInt64Prim _ x)  = p > topPrec && x < 0+    go (HsWord64Prim {})  = False+    go (HsInteger _ x _)  = p > topPrec && x < 0+    go (HsRat _ x _)      = p > topPrec && fl_neg x+    go (HsFloatPrim _ x)  = p > topPrec && fl_neg x+    go (HsDoublePrim _ x) = p > topPrec && fl_neg x+    go (XLit _)           = False++-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal+-- @ol@ needs to be parenthesized under precedence @p@.+hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool+hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv+  where+    go :: OverLitVal -> Bool+    go (HsIntegral x)   = p > topPrec && il_neg x+    go (HsFractional x) = p > topPrec && fl_neg x+    go (HsIsString {})  = False+hsOverLitNeedsParens _ (XOverLit { }) = False

+ Language/Haskell/Syntax/Pat.hs view

@@ -0,0 +1,375 @@++{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE DeriveTraversable    #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE LambdaCase           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-# LANGUAGE ViewPatterns         #-}+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[PatSyntax]{Abstract Haskell syntax---patterns}+-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax.Pat (+        Pat(..), LPat,+        ConLikeP,++        HsConPatDetails, hsConPatArgs,+        HsRecFields(..), HsRecField'(..), LHsRecField',+        HsRecField, LHsRecField,+        HsRecUpdField, LHsRecUpdField,+        hsRecFields, hsRecFieldSel, hsRecFieldsArgs,+    ) where++import GHC.Prelude++import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsSplice)++-- friends:+import Language.Haskell.Syntax.Lit+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Type+import GHC.Types.Basic+-- others:+import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} )+import GHC.Utils.Outputable+import GHC.Types.SrcLoc+-- libraries:++type LPat p = XRec p (Pat p)++-- | Pattern+--+-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'++-- For details on above see note [exact print annotations] in GHC.Parser.Annotation+data Pat p+  =     ------------ Simple patterns ---------------+    WildPat     (XWildPat p)        -- ^ Wildcard Pattern+        -- The sole reason for a type on a WildPat is to+        -- support hsPatType :: Pat Id -> Type++       -- AZ:TODO above comment needs to be updated+  | VarPat      (XVarPat p)+                (LIdP p)     -- ^ Variable Pattern++                             -- See Note [Located RdrNames] in GHC.Hs.Expr+  | LazyPat     (XLazyPat p)+                (LPat p)                -- ^ Lazy Pattern+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnTilde'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | AsPat       (XAsPat p)+                (LIdP p) (LPat p)    -- ^ As pattern+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | ParPat      (XParPat p)+                (LPat p)                -- ^ Parenthesised pattern+                                        -- See Note [Parens in HsSyn] in GHC.Hs.Expr+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,+    --                                    'GHC.Parser.Annotation.AnnClose' @')'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | BangPat     (XBangPat p)+                (LPat p)                -- ^ Bang pattern+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnBang'++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++        ------------ Lists, tuples, arrays ---------------+  | ListPat     (XListPat p)+                [LPat p]+                   -- For OverloadedLists a Just (ty,fn) gives+                   -- overall type of the pattern, and the toList+-- function to convert the scrutinee to a list value++    -- ^ Syntactic List+    --+    -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,+    --                                    'GHC.Parser.Annotation.AnnClose' @']'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | TuplePat    (XTuplePat p)+                  -- after typechecking, holds the types of the tuple components+                [LPat p]         -- Tuple sub-patterns+                Boxity           -- UnitPat is TuplePat []+        -- You might think that the post typechecking Type was redundant,+        -- because we can get the pattern type by getting the types of the+        -- sub-patterns.+        -- But it's essential+        --      data T a where+        --        T1 :: Int -> T Int+        --      f :: (T a, a) -> Int+        --      f (T1 x, z) = z+        -- When desugaring, we must generate+        --      f = /\a. \v::a.  case v of (t::T a, w::a) ->+        --                       case t of (T1 (x::Int)) ->+        -- Note the (w::a), NOT (w::Int), because we have not yet+        -- refined 'a' to Int.  So we must know that the second component+        -- of the tuple is of type 'a' not Int.  See selectMatchVar+        -- (June 14: I'm not sure this comment is right; the sub-patterns+        --           will be wrapped in CoPats, no?)+    -- ^ Tuple sub-patterns+    --+    -- - 'GHC.Parser.Annotation.AnnKeywordId' :+    --            'GHC.Parser.Annotation.AnnOpen' @'('@ or @'(#'@,+    --            'GHC.Parser.Annotation.AnnClose' @')'@ or  @'#)'@++  | SumPat      (XSumPat p)        -- after typechecker, types of the alternative+                (LPat p)           -- Sum sub-pattern+                ConTag             -- Alternative (one-based)+                Arity              -- Arity (INVARIANT: ≥ 2)+    -- ^ Anonymous sum pattern+    --+    -- - 'GHC.Parser.Annotation.AnnKeywordId' :+    --            'GHC.Parser.Annotation.AnnOpen' @'(#'@,+    --            'GHC.Parser.Annotation.AnnClose' @'#)'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++        ------------ Constructor patterns ---------------+  | ConPat {+        pat_con_ext :: XConPat p,+        pat_con     :: XRec p (ConLikeP p),+        pat_args    :: HsConPatDetails p+    }+    -- ^ Constructor Pattern++        ------------ View patterns ---------------+  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | ViewPat       (XViewPat p)     -- The overall type of the pattern+                                   -- (= the argument type of the view function)+                                   -- for hsPatType.+                  (LHsExpr p)+                  (LPat p)+    -- ^ View Pattern++        ------------ Pattern splices ---------------+  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@+  --        'GHC.Parser.Annotation.AnnClose' @')'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | SplicePat       (XSplicePat p)+                    (HsSplice p)    -- ^ Splice Pattern (Includes quasi-quotes)++        ------------ Literal and n+k patterns ---------------+  | LitPat          (XLitPat p)+                    (HsLit p)           -- ^ Literal Pattern+                                        -- Used for *non-overloaded* literal patterns:+                                        -- Int#, Char#, Int, Char, String, etc.++  | NPat                -- Natural Pattern+                        -- Used for all overloaded literals,+                        -- including overloaded strings with -XOverloadedStrings+                    (XNPat p)            -- Overall type of pattern. Might be+                                         -- different than the literal's type+                                         -- if (==) or negate changes the type+                    (XRec p (HsOverLit p))     -- ALWAYS positive+                    (Maybe (SyntaxExpr p)) -- Just (Name of 'negate') for+                                           -- negative patterns, Nothing+                                           -- otherwise+                    (SyntaxExpr p)       -- Equality checker, of type t->t->Bool++  -- ^ Natural Pattern+  --+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnVal' @'+'@++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | NPlusKPat       (XNPlusKPat p)           -- Type of overall pattern+                    (LIdP p)                 -- n+k pattern+                    (XRec p (HsOverLit p))   -- It'll always be an HsIntegral+                    (HsOverLit p)            -- See Note [NPlusK patterns] in GHC.Tc.Gen.Pat+                     -- NB: This could be (PostTc ...), but that induced a+                     -- a new hs-boot file. Not worth it.++                    (SyntaxExpr p)   -- (>=) function, of type t1->t2->Bool+                    (SyntaxExpr p)   -- Name of '-' (see GHC.Rename.Env.lookupSyntax)+  -- ^ n+k pattern++        ------------ Pattern type signatures ---------------+  -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'++  -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | SigPat          (XSigPat p)             -- After typechecker: Type+                    (LPat p)                -- Pattern with a type signature+                    (HsPatSigType (NoGhcTc p)) --  Signature can bind both+                                               --  kind and type vars++    -- ^ Pattern with a type signature++  -- | Trees that Grow extension point for new constructors+  | XPat+      !(XXPat p)++type family ConLikeP x+++-- ---------------------------------------------------------------------+++-- | Haskell Constructor Pattern Details+type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))++hsConPatArgs :: forall p . (UnXRec p) => HsConPatDetails p -> [LPat p]+hsConPatArgs (PrefixCon _ ps) = ps+hsConPatArgs (RecCon fs)      = map (hsRecFieldArg . unXRec @p) (rec_flds fs)+hsConPatArgs (InfixCon p1 p2) = [p1,p2]++-- | Haskell Record Fields+--+-- HsRecFields is used only for patterns and expressions (not data type+-- declarations)+data HsRecFields p arg         -- A bunch of record fields+                                --      { x = 3, y = True }+        -- Used for both expressions and patterns+  = HsRecFields { rec_flds   :: [LHsRecField p arg],+                  rec_dotdot :: Maybe (Located Int) }  -- Note [DotDot fields]+  -- AZ:The XRec for LHsRecField makes the derivings fail.+  -- deriving (Functor, Foldable, Traversable)+++-- Note [DotDot fields]+-- ~~~~~~~~~~~~~~~~~~~~+-- The rec_dotdot field means this:+--   Nothing => the normal case+--   Just n  => the group uses ".." notation,+--+-- In the latter case:+--+--   *before* renamer: rec_flds are exactly the n user-written fields+--+--   *after* renamer:  rec_flds includes *all* fields, with+--                     the first 'n' being the user-written ones+--                     and the remainder being 'filled in' implicitly++-- | Located Haskell Record Field+type LHsRecField' p id arg = XRec p (HsRecField' id arg)++-- | Located Haskell Record Field+type LHsRecField  p arg = XRec p (HsRecField  p arg)++-- | Located Haskell Record Update Field+type LHsRecUpdField p   = XRec p (HsRecUpdField p)++-- | Haskell Record Field+type HsRecField    p arg = HsRecField' (FieldOcc p) arg++-- | Haskell Record Update Field+type HsRecUpdField p     = HsRecField' (AmbiguousFieldOcc p) (LHsExpr p)++-- | Haskell Record Field+--+-- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnEqual',+--+-- For details on above see note [exact print annotations] in GHC.Parser.Annotation+data HsRecField' id arg = HsRecField {+        hsRecFieldAnn :: XHsRecField id,+        hsRecFieldLbl :: Located id,+        hsRecFieldArg :: arg,           -- ^ Filled in by renamer when punning+        hsRecPun      :: Bool           -- ^ Note [Punning]+  } deriving (Functor, Foldable, Traversable)+++-- Note [Punning]+-- ~~~~~~~~~~~~~~+-- If you write T { x, y = v+1 }, the HsRecFields will be+--      HsRecField x x True ...+--      HsRecField y (v+1) False ...+-- That is, for "punned" field x is expanded (in the renamer)+-- to x=x; but with a punning flag so we can detect it later+-- (e.g. when pretty printing)+--+-- If the original field was qualified, we un-qualify it, thus+--    T { A.x } means T { A.x = x }+++-- Note [HsRecField and HsRecUpdField]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- A HsRecField (used for record construction and pattern matching)+-- contains an unambiguous occurrence of a field (i.e. a FieldOcc).+-- We can't just store the Name, because thanks to+-- DuplicateRecordFields this may not correspond to the label the user+-- wrote.+--+-- A HsRecUpdField (used for record update) contains a potentially+-- ambiguous occurrence of a field (an AmbiguousFieldOcc).  The+-- renamer will fill in the selector function if it can, but if the+-- selector is ambiguous the renamer will defer to the typechecker.+-- After the typechecker, a unique selector will have been determined.+--+-- The renamer produces an Unambiguous result if it can, rather than+-- just doing the lookup in the typechecker, so that completely+-- unambiguous updates can be represented by 'GHC.HsToCore.Quote.repUpdFields'.+--+-- For example, suppose we have:+--+--     data S = MkS { x :: Int }+--     data T = MkT { x :: Int }+--+--     f z = (z { x = 3 }) :: S+--+-- The parsed HsRecUpdField corresponding to the record update will have:+--+--     hsRecFieldLbl = Unambiguous "x" noExtField :: AmbiguousFieldOcc RdrName+--+-- After the renamer, this will become:+--+--     hsRecFieldLbl = Ambiguous   "x" noExtField :: AmbiguousFieldOcc Name+--+-- (note that the Unambiguous constructor is not type-correct here).+-- The typechecker will determine the particular selector:+--+--     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id+--+-- See also Note [Disambiguating record fields] in GHC.Tc.Gen.Head.++hsRecFields :: forall p arg. UnXRec p => HsRecFields p arg -> [XCFieldOcc p]+hsRecFields rbinds = map (unLoc . hsRecFieldSel . unXRec @p) (rec_flds rbinds)++-- Probably won't typecheck at once, things have changed :/+hsRecFieldsArgs :: forall p arg. UnXRec p => HsRecFields p arg -> [arg]+hsRecFieldsArgs rbinds = map (hsRecFieldArg . unXRec @p) (rec_flds rbinds)++hsRecFieldSel :: HsRecField pass arg -> Located (XCFieldOcc pass)+hsRecFieldSel = fmap extFieldOcc . hsRecFieldLbl+++{-+************************************************************************+*                                                                      *+*              Printing patterns+*                                                                      *+************************************************************************+-}++instance (Outputable arg, Outputable (XRec p (HsRecField p arg)))+      => Outputable (HsRecFields p arg) where+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })+        = braces (fsep (punctuate comma (map ppr flds)))+  ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) })+        = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot])))+        where+          dotdot = text ".." <+> whenPprDebug (ppr (drop n flds))++instance (Outputable p, OutputableBndr p, Outputable arg)+      => Outputable (HsRecField' p arg) where+  ppr (HsRecField { hsRecFieldLbl = L _ f, hsRecFieldArg = arg,+                    hsRecPun = pun })+    = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg)

+ Language/Haskell/Syntax/Pat.hs-boot view

@@ -0,0 +1,13 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TypeFamilies #-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax.Pat where++import Language.Haskell.Syntax.Extension ( XRec )+import Data.Kind++type role Pat nominal+data Pat (i :: Type)+type LPat i = XRec i (Pat i)

+ Language/Haskell/Syntax/Type.hs view

@@ -0,0 +1,1313 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DeriveDataTypeable   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE ViewPatterns         #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                      -- in module Language.Haskell.Syntax.Extension+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++GHC.Hs.Type: Abstract syntax: user-defined types+-}++-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*+module Language.Haskell.Syntax.Type (+        Mult, HsScaled(..),+        hsMult, hsScaledThing,+        HsArrow(..),+        hsLinear, hsUnrestricted,++        HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,+        HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,+        LHsQTyVars(..),+        HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,+        HsWildCardBndrs(..),+        HsPatSigType(..), HsPSRn(..),+        HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,+        HsTupleSort(..),+        HsContext, LHsContext,+        HsTyLit(..),+        HsIPName(..), hsIPNameFS,+        HsArg(..), numVisibleArgs,+        LHsTypeArg,++        LBangType, BangType,+        HsSrcBang(..), HsImplBang(..),+        SrcStrictness(..), SrcUnpackedness(..),++        ConDeclField(..), LConDeclField,++        HsConDetails(..), noTypeArgs,++        FieldOcc(..), LFieldOcc,+        AmbiguousFieldOcc(..),++        mapHsOuterImplicit,+        hsQTvExplicit,+        isHsKindedTyVar,+        hsPatSigType,+    ) where++#include "HsVersions.h"++import GHC.Prelude++import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsSplice )++import Language.Haskell.Syntax.Extension++import GHC.Types.SourceText+import GHC.Types.Name( Name )+import GHC.Types.Name.Reader ( RdrName )+import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),+                         SrcStrictness(..), SrcUnpackedness(..) )+import GHC.Core.Type+import GHC.Hs.Doc+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Utils.Misc ( count )+import GHC.Parser.Annotation++import Data.Data hiding ( Fixity, Prefix, Infix )+import Data.Void++{-+************************************************************************+*                                                                      *+\subsection{Bang annotations}+*                                                                      *+************************************************************************+-}++-- | Located Bang Type+type LBangType pass = XRec pass (BangType pass)++-- | Bang Type+--+-- In the parser, strictness and packedness annotations bind more tightly+-- than docstrings. This means that when consuming a 'BangType' (and looking+-- for 'HsBangTy') we must be ready to peer behind a potential layer of+-- 'HsDocTy'. See #15206 for motivation and 'getBangType' for an example.+type BangType pass  = HsType pass       -- Bangs are in the HsType data type++{-+************************************************************************+*                                                                      *+\subsection{Data types}+*                                                                      *+************************************************************************++This is the syntax for types as seen in type signatures.++Note [HsBSig binder lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a binder (or pattern) decorated with a type or kind,+   \ (x :: a -> a). blah+   forall (a :: k -> *) (b :: k). blah+Then we use a LHsBndrSig on the binder, so that the+renamer can decorate it with the variables bound+by the pattern ('a' in the first example, 'k' in the second),+assuming that neither of them is in scope already+See also Note [Kind and type-variable binders] in GHC.Rename.HsType++Note [HsType binders]+~~~~~~~~~~~~~~~~~~~~~+The system for recording type and kind-variable binders in HsTypes+is a bit complicated.  Here's how it works.++* In a HsType,+     HsForAllTy   represents an /explicit, user-written/ 'forall' that+                  is nested within another HsType+                   e.g.   forall a b.   {...} or+                          forall a b -> {...}++                  Note that top-level 'forall's are represented with a+                  different AST form. See the description of HsOuterTyVarBndrs+                  below.+     HsQualTy     represents an /explicit, user-written/ context+                   e.g.   (Eq a, Show a) => ...+                  The context can be empty if that's what the user wrote+  These constructors represent what the user wrote, no more+  and no less.++* The ForAllTelescope field of HsForAllTy represents whether a forall is+  invisible (e.g., forall a b. {...}, with a dot) or visible+  (e.g., forall a b -> {...}, with an arrow).++* HsTyVarBndr describes a quantified type variable written by the+  user.  For example+     f :: forall a (b :: *).  blah+  here 'a' and '(b::*)' are each a HsTyVarBndr.  A HsForAllTy has+  a list of LHsTyVarBndrs.++* HsOuterTyVarBndrs is used to represent the outermost quantified type+  variables in a type that obeys the forall-or-nothing rule. An+  HsOuterTyVarBndrs can be one of the following:++    HsOuterImplicit (implicit quantification, added by renamer)+          f :: a -> a     -- Desugars to f :: forall {a}. a -> a+    HsOuterExplicit (explicit user quantifiation):+          f :: forall a. a -> a++  See Note [forall-or-nothing rule].++* An HsSigType is an LHsType with an accompanying HsOuterTyVarBndrs that+  represents the presence (or absence) of its outermost 'forall'.+  See Note [Representing type signatures].++* HsWildCardBndrs is a wrapper that binds the wildcard variables+  of the wrapped thing.  It is filled in by the renamer+     f :: _a -> _+  The enclosing HsWildCardBndrs binds the wildcards _a and _.++* HsSigPatType describes types that appear in pattern signatures and+  the signatures of term-level binders in RULES. Like+  HsWildCardBndrs/HsOuterTyVarBndrs, they track the names of wildcard+  variables and implicitly bound type variables. Unlike+  HsOuterTyVarBndrs, however, HsSigPatTypes do not obey the+  forall-or-nothing rule. See Note [Pattern signature binders and scoping].++* The explicit presence of these wrappers specifies, in the HsSyn,+  exactly where implicit quantification is allowed, and where+  wildcards are allowed.++* LHsQTyVars is used in data/class declarations, where the user gives+  explicit *type* variable bindings, but we need to implicitly bind+  *kind* variables.  For example+      class C (a :: k -> *) where ...+  The 'k' is implicitly bound in the hsq_tvs field of LHsQTyVars++Note [The wildcard story for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Types can have wildcards in them, to support partial type signatures,+like       f :: Int -> (_ , _a) -> _a++A wildcard in a type can be++  * An anonymous wildcard,+        written '_'+    In HsType this is represented by HsWildCardTy.+    The renamer leaves it untouched, and it is later given a fresh+    meta tyvar in the typechecker.++  * A named wildcard,+        written '_a', '_foo', etc+    In HsType this is represented by (HsTyVar "_a")+    i.e. a perfectly ordinary type variable that happens+         to start with an underscore++Note carefully:++* When NamedWildCards is off, type variables that start with an+  underscore really /are/ ordinary type variables.  And indeed, even+  when NamedWildCards is on you can bind _a explicitly as an ordinary+  type variable:+        data T _a _b = MkT _b _a+  Or even:+        f :: forall _a. _a -> _b+  Here _a is an ordinary forall'd binder, but (With NamedWildCards)+  _b is a named wildcard.  (See the comments in #10982)++* Named wildcards are bound by the HsWildCardBndrs (for types that obey the+  forall-or-nothing rule) and HsPatSigType (for type signatures in patterns+  and term-level binders in RULES), which wrap types that are allowed to have+  wildcards. Unnamed wildcards, however are left unchanged until typechecking,+  where we give them fresh wild tyvars and determine whether or not to emit+  hole constraints on each wildcard (we don't if it's a visible type/kind+  argument or a type family pattern). See related notes+  Note [Wildcards in visible kind application] and+  Note [Wildcards in visible type application] in GHC.Tc.Gen.HsType.++* After type checking is done, we report what types the wildcards+  got unified with.++Note [Ordering of implicit variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the advent of -XTypeApplications, GHC makes promises about the ordering+of implicit variable quantification. Specifically, we offer that implicitly+quantified variables (such as those in const :: a -> b -> a, without a `forall`)+will occur in left-to-right order of first occurrence. Here are a few examples:++  const :: a -> b -> a       -- forall a b. ...+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included++  type a <-< b = b -> a+  g :: a <-< b               -- forall a b. ...  type synonyms matter++  class Functor f where+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...+    -- The f is quantified by the class, so only a and b are considered in fmap++This simple story is complicated by the possibility of dependency: all variables+must come after any variables mentioned in their kinds.++  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...++The k comes first because a depends on k, even though the k appears later than+the a in the code. Thus, GHC does a *stable topological sort* on the variables.+By "stable", we mean that any two variables who do not depend on each other+preserve their existing left-to-right ordering.++Implicitly bound variables are collected by the extract- family of functions+(extractHsTysRdrTyVars, extractHsTyVarBndrsKVs, etc.) in GHC.Rename.HsType.+These functions thus promise to keep left-to-right ordering.+Look for pointers to this note to see the places where the action happens.++Note that we also maintain this ordering in kind signatures. Even though+there's no visible kind application (yet), having implicit variables be+quantified in left-to-right order in kind signatures is nice since:++* It's consistent with the treatment for type signatures.+* It can affect how types are displayed with -fprint-explicit-kinds (see+  #15568 for an example), which is a situation where knowing the order in+  which implicit variables are quantified can be useful.+* In the event that visible kind application is implemented, the order in+  which we would expect implicit variables to be ordered in kinds will have+  already been established.+-}++-- | Located Haskell Context+type LHsContext pass = XRec pass (HsContext pass)+      -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnUnit'+      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Haskell Context+type HsContext pass = [LHsType pass]++-- | Located Haskell Type+type LHsType pass = XRec pass (HsType pass)+      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when+      --   in a list++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Haskell Kind+type HsKind pass = HsType pass++-- | Located Haskell Kind+type LHsKind pass = XRec pass (HsKind pass)+      -- ^ 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++--------------------------------------------------+--             LHsQTyVars+--  The explicitly-quantified binders in a data/type declaration++-- | The type variable binders in an 'HsForAllTy'.+-- See also @Note [Variable Specificity and Forall Visibility]@ in+-- "GHC.Tc.Gen.HsType".+data HsForAllTelescope pass+  = HsForAllVis -- ^ A visible @forall@ (e.g., @forall a -> {...}@).+                --   These do not have any notion of specificity, so we use+                --   '()' as a placeholder value.+    { hsf_xvis      :: XHsForAllVis pass+    , hsf_vis_bndrs :: [LHsTyVarBndr () pass]+    }+  | HsForAllInvis -- ^ An invisible @forall@ (e.g., @forall a {b} c. {...}@),+                  --   where each binder has a 'Specificity'.+    { hsf_xinvis       :: XHsForAllInvis pass+    , hsf_invis_bndrs  :: [LHsTyVarBndr Specificity pass]+    }+  | XHsForAllTelescope !(XXHsForAllTelescope pass)++-- | Located Haskell Type Variable Binder+type LHsTyVarBndr flag pass = XRec pass (HsTyVarBndr flag pass)+                         -- See Note [HsType binders]++-- | Located Haskell Quantified Type Variables+data LHsQTyVars pass   -- See Note [HsType binders]+  = HsQTvs { hsq_ext :: XHsQTvs pass++           , hsq_explicit :: [LHsTyVarBndr () pass]+                -- Explicit variables, written by the user+    }+  | XLHsQTyVars !(XXLHsQTyVars pass)++hsQTvExplicit :: LHsQTyVars pass -> [LHsTyVarBndr () pass]+hsQTvExplicit = hsq_explicit++------------------------------------------------+--            HsOuterTyVarBndrs+-- Used to quantify the outermost type variable binders of a type that obeys+-- the forall-or-nothing rule. These are used to represent the outermost+-- quantification in:+--    * Type signatures (LHsSigType/LHsSigWcType)+--    * Patterns in a type/data family instance (HsTyPats)+--+-- We support two forms:+--   HsOuterImplicit (implicit quantification, added by renamer)+--         f :: a -> a     -- Desugars to f :: forall {a}. a -> a+--         type instance F (a,b) = a->b+--   HsOuterExplicit (explicit user quantifiation):+--         f :: forall a. a -> a+--         type instance forall a b. F (a,b) = a->b+--+-- In constrast, when the user writes /visible/ quanitification+--         T :: forall k -> k -> Type+-- we use use HsOuterImplicit, wrapped around a HsForAllTy+-- for the visible quantification+--+-- See Note [forall-or-nothing rule]++-- | The outermost type variables in a type that obeys the @forall@-or-nothing+-- rule. See @Note [forall-or-nothing rule]@.+data HsOuterTyVarBndrs flag pass+  = HsOuterImplicit -- ^ Implicit forall, e.g.,+                    --    @f :: a -> b -> b@+    { hso_ximplicit :: XHsOuterImplicit pass+    }+  | HsOuterExplicit -- ^ Explicit forall, e.g.,+                    --    @f :: forall a b. a -> b -> b@+    { hso_xexplicit :: XHsOuterExplicit pass flag+    , hso_bndrs     :: [LHsTyVarBndr flag (NoGhcTc pass)]+    }+  | XHsOuterTyVarBndrs !(XXHsOuterTyVarBndrs pass)++-- | Used for signatures, e.g.,+--+-- @+-- f :: forall a {b}. blah+-- @+--+-- We use 'Specificity' for the 'HsOuterTyVarBndrs' @flag@ to allow+-- distinguishing between specified and inferred type variables.+type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity++-- | Used for type-family instance equations, e.g.,+--+-- @+-- type instance forall a. F [a] = Tree a+-- @+--+-- The notion of specificity is irrelevant in type family equations, so we use+-- @()@ for the 'HsOuterTyVarBndrs' @flag@.+type HsOuterFamEqnTyVarBndrs = HsOuterTyVarBndrs ()++-- | Haskell Wildcard Binders+data HsWildCardBndrs pass thing+    -- See Note [HsType binders]+    -- See Note [The wildcard story for types]+  = HsWC { hswc_ext :: XHsWC pass thing+                -- after the renamer+                -- Wild cards, only named+                -- See Note [Wildcards in visible kind application]++         , hswc_body :: thing+                -- Main payload (type or list of types)+                -- If there is an extra-constraints wildcard,+                -- it's still there in the hsc_body.+    }+  | XHsWildCardBndrs !(XXHsWildCardBndrs pass thing)++-- | Types that can appear in pattern signatures, as well as the signatures for+-- term-level binders in RULES.+-- See @Note [Pattern signature binders and scoping]@.+--+-- This is very similar to 'HsSigWcType', but with+-- slightly different semantics: see @Note [HsType binders]@.+-- See also @Note [The wildcard story for types]@.+data HsPatSigType pass+  = HsPS { hsps_ext  :: XHsPS pass   -- ^ After renamer: 'HsPSRn'+         , hsps_body :: LHsType pass -- ^ Main payload (the type itself)+    }+  | XHsPatSigType !(XXHsPatSigType pass)++-- | The extension field for 'HsPatSigType', which is only used in the+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.+data HsPSRn = HsPSRn+  { hsps_nwcs    :: [Name] -- ^ Wildcard names+  , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  }+  deriving Data++-- | Located Haskell Signature Type+type LHsSigType   pass = XRec pass (HsSigType pass)               -- Implicit only++-- | Located Haskell Wildcard Type+type LHsWcType    pass = HsWildCardBndrs pass (LHsType pass)    -- Wildcard only++-- | Located Haskell Signature Wildcard Type+type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both++-- | A type signature that obeys the @forall@-or-nothing rule. In other+-- words, an 'LHsType' that uses an 'HsOuterSigTyVarBndrs' to represent its+-- outermost type variable quantification.+-- See @Note [Representing type signatures]@.+data HsSigType pass+  = HsSig { sig_ext   :: XHsSig pass+          , sig_bndrs :: HsOuterSigTyVarBndrs pass+          , sig_body  :: LHsType pass+          }+  | XHsSigType !(XXHsSigType pass)++hsPatSigType :: HsPatSigType pass -> LHsType pass+hsPatSigType = hsps_body++{-+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. This is referred+to as the forall-or-nothing rule.++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.++For a complete list of all places where the forall-or-nothing rule applies, see+"The `forall`-or-nothing rule" section of the GHC User's Guide.++Any type that obeys the forall-or-nothing rule is represented in the AST with+an HsOuterTyVarBndrs:++* If the type has an outermost, invisible 'forall', it uses HsOuterExplicit,+  which contains a list of the explicitly quantified type variable binders in+  `hso_bndrs`. After typechecking, HsOuterExplicit also stores a list of the+  explicitly quantified `InvisTVBinder`s in+  `hso_xexplicit :: XHsOuterExplicit GhcTc`.++* Otherwise, it uses HsOuterImplicit. HsOuterImplicit is used for different+  things depending on the phase:++  * After parsing, it does not store anything in particular.+  * After renaming, it stores the implicitly bound type variable `Name`s in+    `hso_ximplicit :: XHsOuterImplicit GhcRn`.+  * After typechecking, it stores the implicitly bound `TyVar`s in+    `hso_ximplicit :: XHsOuterImplicit GhcTc`.++  NB: this implicit quantification is purely lexical: we bind any+      type or kind variables that are not in scope. The type checker+      may subsequently quantify over further kind variables.+      See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig.++HsOuterTyVarBndrs GhcTc is used in the typechecker as an intermediate data type+for storing the outermost TyVars/InvisTVBinders in a type.+See GHC.Tc.Gen.HsType.bindOuterTKBndrsX for an example of this.++Note [Representing type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsSigType is used to represent an explicit user type signature. These are+used in a variety of places. Some examples include:++* Type signatures (e.g., f :: a -> a)+* Standalone kind signatures (e.g., type G :: a -> a)+* GADT constructor types (e.g., data T where MkT :: a -> T)++A HsSigType is the combination of an HsOuterSigTyVarBndrs and an LHsType:++* The HsOuterSigTyVarBndrs binds the /explicitly/ quantified type variables+  when the type signature has an outermost, user-written 'forall' (i.e,+  the HsOuterExplicit constructor is used). If there is no outermost 'forall',+  then it binds the /implicitly/ quantified type variables instead (i.e.,+  the HsOuterImplicit constructor is used).+* The LHsType represents the rest of the type.++E.g. For a signature like+   f :: forall k (a::k). blah+we get+   HsSig { sig_bndrs = HsOuterExplicit { hso_bndrs = [k, (a :: k)] }+         , sig_body  = blah }++Note [Pattern signature binders and scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the pattern signatures like those on `t` and `g` in:++   f = let h = \(t :: (b, b) ->+               \(g :: forall a. a -> b) ->+               ...(t :: (Int,Int))...+       in woggle++* The `b` in t's pattern signature is implicitly bound and scopes over+  the signature and the body of the lambda.  It stands for a type (any type);+  indeed we subsequently discover that b=Int.+  (See Note [TyVarTv] in GHC.Tc.Utils.TcMType for more on this point.)+* The `b` in g's pattern signature is an /occurrence/ of the `b` bound by+  t's pattern signature.+* The `a` in `forall a` scopes only over the type `a -> b`, not over the body+  of the lambda.+* There is no forall-or-nothing rule for pattern signatures, which is why the+  type `forall a. a -> b` is permitted in `g`'s pattern signature, even though+  `b` is not explicitly bound. See Note [forall-or-nothing rule].++Similar scoping rules apply to term variable binders in RULES, like in the+following example:++   {-# RULES "h" forall (t :: (b, b)) (g :: forall a. a -> b). h t g = ... #-}++Just like in pattern signatures, the `b` in t's signature is implicitly bound+and scopes over the remainder of the RULE. As a result, the `b` in g's+signature is an occurrence. Moreover, the `a` in `forall a` scopes only over+the type `a -> b`, and the forall-or-nothing rule does not apply.++While quite similar, RULE term binder signatures behave slightly differently+from pattern signatures in two ways:++1. Unlike in pattern signatures, where type variables can stand for any type,+   type variables in RULE term binder signatures are skolems.+   See Note [Typechecking pattern signature binders] in GHC.Tc.Gen.HsType for+   more on this point.++   In this sense, type variables in pattern signatures are quite similar to+   named wildcards, as both can refer to arbitrary types. The main difference+   lies in error reporting: if a named wildcard `_a` in a pattern signature+   stands for Int, then by default GHC will emit a warning stating as much.+   Changing `_a` to `a`, on the other hand, will cause it not to be reported.+2. In the `h` RULE above, only term variables are explicitly bound, so any free+   type variables in the term variables' signatures are implicitly bound.+   This is just like how the free type variables in pattern signatures are+   implicitly bound. If a RULE explicitly binds both term and type variables,+   however, then free type variables in term signatures are /not/ implicitly+   bound. For example, this RULE would be ill scoped:++     {-# RULES "h2" forall b. forall (t :: (b, c)) (g :: forall a. a -> b).+                    h2 t g = ... #-}++   This is because `b` and `c` occur free in the signature for `t`, but only+   `b` was explicitly bound, leaving `c` out of scope. If the RULE had started+   with `forall b c.`, then it would have been accepted.++The types in pattern signatures and RULE term binder signatures are represented+in the AST by HsSigPatType. From the renamer onward, the hsps_ext field (of+type HsPSRn) tracks the names of named wildcards and implicitly bound type+variables so that they can be brought into scope during renaming and+typechecking.++Note [Lexically scoped type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ScopedTypeVariables extension does two things:++* It allows the use of type signatures in patterns+  (e.g., `f (x :: a -> a) = ...`). See+  Note [Pattern signature binders and scoping] for more on this point.+* It brings lexically scoped type variables into scope for certain type+  signatures with outermost invisible 'forall's.++This Note concerns the latter bullet point. Per the+"Lexically scoped type variables" section of the GHC User's Guide, the+following forms of type signatures can have lexically scoped type variables:++* In declarations with type signatures, e.g.,++    f :: forall a. a -> a+    f x = e @a++  Here, the 'forall a' brings 'a' into scope over the body of 'f'.++  Note that ScopedTypeVariables does /not/ interact with standalone kind+  signatures, only type signatures.++* In explicit type annotations in expressions, e.g.,++    id @a :: forall a. a -> a++* In instance declarations, e.g.,++    instance forall a. C [a] where+      m = e @a++  Note that unlike the examples above, the use of an outermost 'forall' isn't+  required to bring 'a' into scope. That is, the following would also work:++    instance forall a. C [a] where+      m = e @a++Note that all of the types above obey the forall-or-nothing rule. As a result,+the places in the AST that can have lexically scoped type variables are a+subset of the places that use HsOuterTyVarBndrs+(See Note [forall-or-nothing rule].)++Some other observations about lexically scoped type variables:++* Only type variables bound by an /invisible/ forall can be lexically scoped.+  See Note [hsScopedTvs and visible foralls].+* The lexically scoped type variables may be a strict subset of the type+  variables brought into scope by a type signature.+  See Note [Binding scoped type variables] in GHC.Tc.Gen.Sig.+-}++mapHsOuterImplicit :: (XHsOuterImplicit pass -> XHsOuterImplicit pass)+                   -> HsOuterTyVarBndrs flag pass+                   -> HsOuterTyVarBndrs flag pass+mapHsOuterImplicit f (HsOuterImplicit{hso_ximplicit = imp}) =+  HsOuterImplicit{hso_ximplicit = f imp}+mapHsOuterImplicit _ hso@(HsOuterExplicit{})    = hso+mapHsOuterImplicit _ hso@(XHsOuterTyVarBndrs{}) = hso+++--------------------------------------------------+-- | These names are used early on to store the names of implicit+-- parameters.  They completely disappear after type-checking.+newtype HsIPName = HsIPName FastString+  deriving( Eq, Data )++hsIPNameFS :: HsIPName -> FastString+hsIPNameFS (HsIPName n) = n++instance Outputable HsIPName where+    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters++instance OutputableBndr HsIPName where+    pprBndr _ n   = ppr n         -- Simple for now+    pprInfixOcc  n = ppr n+    pprPrefixOcc n = ppr n++--------------------------------------------------++-- | Haskell Type Variable Binder+-- The flag annotates the binder. It is 'Specificity' in places where+-- explicit specificity is allowed (e.g. x :: forall {a} b. ...) or+-- '()' in other places.+data HsTyVarBndr flag pass+  = UserTyVar        -- no explicit kinding+         (XUserTyVar pass)+         flag+         (LIdP pass)+        -- See Note [Located RdrNames] in GHC.Hs.Expr++  | KindedTyVar+         (XKindedTyVar pass)+         flag+         (LIdP pass)+         (LHsKind pass)  -- The user-supplied kind signature+        -- ^+        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',+        --          'GHC.Parser.Annotation.AnnDcolon', 'GHC.Parser.Annotation.AnnClose'++        -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | XTyVarBndr+      !(XXTyVarBndr pass)++-- | Does this 'HsTyVarBndr' come with an explicit kind annotation?+isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool+isHsKindedTyVar (UserTyVar {})   = False+isHsKindedTyVar (KindedTyVar {}) = True+isHsKindedTyVar (XTyVarBndr {})  = False++-- | Haskell Type+data HsType pass+  = HsForAllTy   -- See Note [HsType binders]+      { hst_xforall :: XForAllTy pass+      , hst_tele    :: HsForAllTelescope pass+                                     -- Explicit, user-supplied 'forall a {b} c'+      , hst_body    :: LHsType pass  -- body type+      }+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnForall',+      --         'GHC.Parser.Annotation.AnnDot','GHC.Parser.Annotation.AnnDarrow'+      -- For details on above see note [exact print annotations] in "GHC.Parser.Annotation"++  | HsQualTy   -- See Note [HsType binders]+      { hst_xqual :: XQualTy pass+      , hst_ctxt  :: Maybe (LHsContext pass)  -- Context C => blah+      , hst_body  :: LHsType pass }++  | HsTyVar  (XTyVar pass)+              PromotionFlag    -- Whether explicitly promoted,+                               -- for the pretty printer+             (LIdP pass)+                  -- Type variable, type constructor, or data constructor+                  -- see Note [Promotions (HsTyVar)]+                  -- See Note [Located RdrNames] in GHC.Hs.Expr+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsAppTy             (XAppTy pass)+                        (LHsType pass)+                        (LHsType pass)+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsAppKindTy         (XAppKindTy pass) -- type level type app+                        (LHsType pass)+                        (LHsKind pass)++  | HsFunTy             (XFunTy pass)+                        (HsArrow pass)+                        (LHsType pass)   -- function type+                        (LHsType pass)+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow',++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsListTy            (XListTy pass)+                        (LHsType pass)  -- Element type+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'['@,+      --         'GHC.Parser.Annotation.AnnClose' @']'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsTupleTy           (XTupleTy pass)+                        HsTupleSort+                        [LHsType pass]  -- Element types (length gives arity)+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(' or '(#'@,+    --         'GHC.Parser.Annotation.AnnClose' @')' or '#)'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsSumTy             (XSumTy pass)+                        [LHsType pass]  -- Element types (length gives arity)+    -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'(#'@,+    --         'GHC.Parser.Annotation.AnnClose' '#)'@++    -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsOpTy              (XOpTy pass)+                        (LHsType pass) (LIdP pass) (LHsType pass)+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsParTy             (XParTy pass)+                        (LHsType pass)   -- See Note [Parens in HsSyn] in GHC.Hs.Expr+        -- Parenthesis preserved for the precedence re-arrangement in+        -- GHC.Rename.HsType+        -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,+      --         'GHC.Parser.Annotation.AnnClose' @')'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsIParamTy          (XIParamTy pass)+                        (XRec pass HsIPName) -- (?x :: ty)+                        (LHsType pass)   -- Implicit parameters as they occur in+                                         -- contexts+      -- ^+      -- > (?x :: ty)+      --+      -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsStarTy            (XStarTy pass)+                        Bool             -- Is this the Unicode variant?+                                         -- Note [HsStarTy]+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++  | HsKindSig           (XKindSig pass)+                        (LHsType pass)  -- (ty :: kind)+                        (LHsKind pass)  -- A type with a kind signature+      -- ^+      -- > (ty :: kind)+      --+      -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,+      --         'GHC.Parser.Annotation.AnnDcolon','GHC.Parser.Annotation.AnnClose' @')'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsSpliceTy          (XSpliceTy pass)+                        (HsSplice pass)   -- Includes quasi-quotes+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'$('@,+      --         'GHC.Parser.Annotation.AnnClose' @')'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsDocTy             (XDocTy pass)+                        (LHsType pass) LHsDocString -- A documented type+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsBangTy    (XBangTy pass)+                HsSrcBang (LHsType pass)   -- Bang-style type annotations+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' :+      --         'GHC.Parser.Annotation.AnnOpen' @'{-\# UNPACK' or '{-\# NOUNPACK'@,+      --         'GHC.Parser.Annotation.AnnClose' @'#-}'@+      --         'GHC.Parser.Annotation.AnnBang' @\'!\'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsRecTy     (XRecTy pass)+                [LConDeclField pass]    -- Only in data type declarations+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'{'@,+      --         'GHC.Parser.Annotation.AnnClose' @'}'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsExplicitListTy       -- A promoted explicit list+        (XExplicitListTy pass)+        PromotionFlag      -- whether explicitly promoted, for pretty printer+        [LHsType pass]+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'["@,+      --         'GHC.Parser.Annotation.AnnClose' @']'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsExplicitTupleTy      -- A promoted explicit tuple+        (XExplicitTupleTy pass)+        [LHsType pass]+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @"'("@,+      --         'GHC.Parser.Annotation.AnnClose' @')'@++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsTyLit (XTyLit pass) HsTyLit      -- A promoted numeric literal.+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  | HsWildCardTy (XWildCardTy pass)  -- A type wildcard+      -- See Note [The wildcard story for types]+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : None++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++  -- For adding new constructors via Trees that Grow+  | XHsType+      !(XXType pass)++-- An escape hatch for tunnelling a Core 'Type' through 'HsType'.+-- For more details on how this works, see:+--+-- * @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"+--+-- * @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"+type HsCoreTy = Type+++-- Note [Literal source text] in GHC.Types.Basic for SourceText fields in+-- the following+-- | Haskell Type Literal+data HsTyLit+  = HsNumTy SourceText Integer+  | HsStrTy SourceText FastString+  | HsCharTy SourceText Char+    deriving Data++-- | Denotes the type of arrows in the surface language+data HsArrow pass+  = HsUnrestrictedArrow IsUnicodeSyntax+    -- ^ a -> b or a → b+  | HsLinearArrow IsUnicodeSyntax (Maybe AddEpAnn)+    -- ^ a %1 -> b or a %1 → b, or a ⊸ b+  | HsExplicitMult IsUnicodeSyntax (Maybe AddEpAnn) (LHsType pass)+    -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!+    -- This is how the programmer wrote it). It is stored as an+    -- `HsType` so as to preserve the syntax as written in the+    -- program.++-- | This is used in the syntax. In constructor declaration. It must keep the+-- arrow representation.+data HsScaled pass a = HsScaled (HsArrow pass) a++hsMult :: HsScaled pass a -> HsArrow pass+hsMult (HsScaled m _) = m++hsScaledThing :: HsScaled pass a -> a+hsScaledThing (HsScaled _ t) = t++-- | When creating syntax we use the shorthands. It's better for printing, also,+-- the shorthands work trivially at each pass.+hsUnrestricted, hsLinear :: a -> HsScaled pass a+hsUnrestricted = HsScaled (HsUnrestrictedArrow NormalSyntax)+hsLinear = HsScaled (HsLinearArrow NormalSyntax Nothing)++instance Outputable a => Outputable (HsScaled pass a) where+   ppr (HsScaled _cnt t) = -- ppr cnt <> ppr t+                            ppr t++{-+Note [Unit tuples]+~~~~~~~~~~~~~~~~~~+Consider the type+    type instance F Int = ()+We want to parse that "()"+    as HsTupleTy HsBoxedOrConstraintTuple [],+NOT as HsTyVar unitTyCon++Why? Because F might have kind (* -> Constraint), so we when parsing we+don't know if that tuple is going to be a constraint tuple or an ordinary+unit tuple.  The HsTupleSort flag is specifically designed to deal with+that, but it has to work for unit tuples too.++Note [Promotions (HsTyVar)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsTyVar: A name in a type or kind.+  Here are the allowed namespaces for the name.+    In a type:+      Var: not allowed+      Data: promoted data constructor+      Tv: type variable+      TcCls before renamer: type constructor, class constructor, or promoted data constructor+      TcCls after renamer: type constructor or class constructor+    In a kind:+      Var, Data: not allowed+      Tv: kind variable+      TcCls: kind constructor or promoted type constructor++  The 'Promoted' field in an HsTyVar captures whether the type was promoted in+  the source code by prefixing an apostrophe.++Note [HsStarTy]+~~~~~~~~~~~~~~~+When the StarIsType extension is enabled, we want to treat '*' and its Unicode+variant identically to 'Data.Kind.Type'. Unfortunately, doing so in the parser+would mean that when we pretty-print it back, we don't know whether the user+wrote '*' or 'Type', and lose the parse/ppr roundtrip property.++As a workaround, we parse '*' as HsStarTy (if it stands for 'Data.Kind.Type')+and then desugar it to 'Data.Kind.Type' in the typechecker (see tc_hs_type).+When '*' is a regular type operator (StarIsType is disabled), HsStarTy is not+involved.+++Note [Promoted lists and tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice the difference between+   HsListTy    HsExplicitListTy+   HsTupleTy   HsExplicitListTupleTy++E.g.    f :: [Int]                      HsListTy++        g3  :: T '[]                   All these use+        g2  :: T '[True]                  HsExplicitListTy+        g1  :: T '[True,False]+        g1a :: T [True,False]             (can omit ' where unambiguous)++  kind of T :: [Bool] -> *        This kind uses HsListTy!++E.g.    h :: (Int,Bool)                 HsTupleTy; f is a pair+        k :: S '(True,False)            HsExplicitTypleTy; S is indexed by+                                           a type-level pair of booleans+        kind of S :: (Bool,Bool) -> *   This kind uses HsExplicitTupleTy++Note [Distinguishing tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Apart from promotion, tuples can have one of three different kinds:++        x :: (Int, Bool)                -- Regular boxed tuples+        f :: Int# -> (# Int#, Int# #)   -- Unboxed tuples+        g :: (Eq a, Ord a) => a         -- Constraint tuples++For convenience, internally we use a single constructor for all of these,+namely HsTupleTy, but keep track of the tuple kind (in the first argument to+HsTupleTy, a HsTupleSort). We can tell if a tuple is unboxed while parsing,+because of the #. However, with -XConstraintKinds we can only distinguish+between constraint and boxed tuples during type checking, in general. Hence the+two constructors of HsTupleSort:++        HsUnboxedTuple                  -> Produced by the parser+        HsBoxedOrConstraintTuple        -> Could be a boxed or a constraint+                                        tuple. Produced by the parser only,+                                        disappears after type checking++After typechecking, we use TupleSort (which clearly distinguishes between+constraint tuples and boxed tuples) rather than HsTupleSort.+-}++-- | Haskell Tuple Sort+data HsTupleSort = HsUnboxedTuple+                 | HsBoxedOrConstraintTuple+                 deriving Data++-- | Located Constructor Declaration Field+type LConDeclField pass = XRec pass (ConDeclField pass)+      -- ^ May have 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma' when+      --   in a list++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation++-- | Constructor Declaration Field+data ConDeclField pass  -- Record fields have Haddock docs on them+  = ConDeclField { cd_fld_ext  :: XConDeclField pass,+                   cd_fld_names :: [LFieldOcc pass],+                                   -- ^ See Note [ConDeclField passs]+                   cd_fld_type :: LBangType pass,+                   cd_fld_doc  :: Maybe LHsDocString }+      -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDcolon'++      -- For details on above see note [exact print annotations] in GHC.Parser.Annotation+  | XConDeclField !(XXConDeclField pass)++-- | Describes the arguments to a data constructor. This is a common+-- representation for several constructor-related concepts, including:+--+-- * The arguments in a Haskell98-style constructor declaration+--   (see 'HsConDeclH98Details' in "GHC.Hs.Decls").+--+-- * The arguments in constructor patterns in @case@/function definitions+--   (see 'HsConPatDetails' in "GHC.Hs.Pat").+--+-- * The left-hand side arguments in a pattern synonym binding+--   (see 'HsPatSynDetails' in "GHC.Hs.Binds").+--+-- One notable exception is the arguments in a GADT constructor, which uses+-- a separate data type entirely (see 'HsConDeclGADTDetails' in+-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with+-- infix syntax, unlike the concepts above (#18844).+data HsConDetails tyarg arg rec+  = PrefixCon [tyarg] [arg]     -- C @t1 @t2 p1 p2 p3+  | RecCon    rec               -- C { x = p1, y = p2 }+  | InfixCon  arg arg           -- p1 `C` p2+  deriving Data++-- | An empty list that can be used to indicate that there are no+-- type arguments allowed in cases where HsConDetails is applied to Void.+noTypeArgs :: [Void]+noTypeArgs = []++instance (Outputable tyarg, Outputable arg, Outputable rec)+         => Outputable (HsConDetails tyarg arg rec) where+  ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args+  ppr (RecCon rec)            = text "RecCon:" <+> ppr rec+  ppr (InfixCon l r)          = text "InfixCon:" <+> ppr [l, r]++{-+Note [ConDeclField passs]+~~~~~~~~~~~~~~~~~~~~~~~~~++A ConDeclField contains a list of field occurrences: these always+include the field label as the user wrote it.  After the renamer, it+will additionally contain the identity of the selector function in the+second component.++Due to DuplicateRecordFields, the OccName of the selector function+may have been mangled, which is why we keep the original field label+separately.  For example, when DuplicateRecordFields is enabled++    data T = MkT { x :: Int }++gives++    ConDeclField { cd_fld_names = [L _ (FieldOcc "x" $sel:x:MkT)], ... }.+-}++-----------------------+-- A valid type must have a for-all at the top of the type, or of the fn arg+-- types++---------------------++{- Note [Scoping of named wildcards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: _a -> _a+  f x = let g :: _a -> _a+            g = ...+        in ...++Currently, for better or worse, the "_a" variables are all the same. So+although there is no explicit forall, the "_a" scopes over the definition.+I don't know if this is a good idea, but there it is.+-}++{- Note [hsScopedTvs and visible foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-XScopedTypeVariables can be defined in terms of a desugaring to+-XTypeAbstractions (GHC Proposal #50):++    fn :: forall a b c. tau(a,b,c)            fn :: forall a b c. tau(a,b,c)+    fn = defn(a,b,c)                   ==>    fn @x @y @z = defn(x,y,z)++That is, for every type variable of the leading 'forall' in the type signature,+we add an invisible binder at term level.++This model does not extend to visible forall, as discussed here:++* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412+* https://github.com/ghc-proposals/ghc-proposals/pull/238++The conclusion of these discussions can be summarized as follows:++  > Assuming support for visible 'forall' in terms, consider this example:+  >+  >     vfn :: forall x y -> tau(x,y)+  >     vfn = \a b -> ...+  >+  > The user has written their own binders 'a' and 'b' to stand for 'x' and+  > 'y', and we definitely should not desugar this into:+  >+  >     vfn :: forall x y -> tau(x,y)+  >     vfn x y = \a b -> ...         -- bad!++This design choice is reflected in the design of HsOuterSigTyVarBndrs, which are+used in every place that ScopedTypeVariables takes effect:++  data HsOuterTyVarBndrs flag pass+    = HsOuterImplicit { ... }+    | HsOuterExplicit { ..., hso_bndrs :: [LHsTyVarBndr flag pass] }+    | ...+  type HsOuterSigTyVarBndrs = HsOuterTyVarBndrs Specificity++The HsOuterExplicit constructor is only used in type signatures with outermost,+/invisible/ 'forall's. Any other type—including those with outermost,+/visible/ 'forall's—will use HsOuterImplicit. Therefore, when we determine+which type variables to bring into scope over the body of a function+(in hsScopedTvs), we /only/ bring the type variables bound by the hso_bndrs in+an HsOuterExplicit into scope. If we have an HsOuterImplicit instead, then we+do not bring any type variables into scope over the body of a function at all.++At the moment, GHC does not support visible 'forall' in terms. Nevertheless,+it is still possible to write erroneous programs that use visible 'forall's in+terms, such as this example:++    x :: forall a -> a -> a+    x = x++Previous versions of GHC would bring `a` into scope over the body of `x` in the+hopes that the typechecker would error out later+(see `GHC.Tc.Validity.vdqAllowed`). However, this can wreak havoc in the+renamer before GHC gets to that point (see #17687 for an example of this).+Bottom line: nip problems in the bud by refraining from bringing any type+variables in an HsOuterImplicit into scope over the body of a function, even+if they correspond to a visible 'forall'.+-}++{-+************************************************************************+*                                                                      *+                Decomposing HsTypes+*                                                                      *+************************************************************************+-}++-- Arguments in an expression/type after splitting+data HsArg tm ty+  = HsValArg tm   -- Argument is an ordinary expression     (f arg)+  | HsTypeArg SrcSpan ty -- Argument is a visible type application (f @ty)+                         -- SrcSpan is location of the `@`+  | HsArgPar SrcSpan -- See Note [HsArgPar]++numVisibleArgs :: [HsArg tm ty] -> Arity+numVisibleArgs = count is_vis+  where is_vis (HsValArg _) = True+        is_vis _            = False++-- type level equivalent+type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)++instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where+  ppr (HsValArg tm)    = ppr tm+  ppr (HsTypeArg _ ty) = char '@' <> ppr ty+  ppr (HsArgPar sp)    = text "HsArgPar"  <+> ppr sp+{-+Note [HsArgPar]+A HsArgPar indicates that everything to the left of this in the argument list is+enclosed in parentheses together with the function itself. It is necessary so+that we can recreate the parenthesis structure in the original source after+typechecking the arguments.++The SrcSpan is the span of the original HsPar++((f arg1) arg2 arg3) results in an input argument list of+[HsValArg arg1, HsArgPar span1, HsValArg arg2, HsValArg arg3, HsArgPar span2]++-}++--------------------------------+++{-+************************************************************************+*                                                                      *+                FieldOcc+*                                                                      *+************************************************************************+-}++-- | Located Field Occurrence+type LFieldOcc pass = XRec pass (FieldOcc pass)++-- | Field Occurrence+--+-- Represents an *occurrence* of an unambiguous field.  This may or may not be a+-- binding occurrence (e.g. this type is used in 'ConDeclField' and+-- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for+-- record construction and patterns, which do not).+--+-- We store both the 'RdrName' the user originally wrote, and after the renamer,+-- the selector function.+data FieldOcc pass = FieldOcc { extFieldOcc     :: XCFieldOcc pass+                              , rdrNameFieldOcc :: LocatedN RdrName+                                 -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr"+                              }++  | XFieldOcc+      !(XXFieldOcc pass)++deriving instance (Eq (XCFieldOcc pass), Eq (XXFieldOcc pass)) => Eq (FieldOcc pass)++instance Outputable (FieldOcc pass) where+  ppr = ppr . rdrNameFieldOcc++instance OutputableBndr (FieldOcc pass) where+  pprInfixOcc  = pprInfixOcc . unLoc . rdrNameFieldOcc+  pprPrefixOcc = pprPrefixOcc . unLoc . rdrNameFieldOcc++instance OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where+  pprInfixOcc  = pprInfixOcc . unLoc+  pprPrefixOcc = pprPrefixOcc . unLoc++-- | Ambiguous Field Occurrence+--+-- Represents an *occurrence* of a field that is potentially+-- ambiguous after the renamer, with the ambiguity resolved by the+-- typechecker.  We always store the 'RdrName' that the user+-- originally wrote, and store the selector function after the renamer+-- (for unambiguous occurrences) or the typechecker (for ambiguous+-- occurrences).+--+-- See Note [HsRecField and HsRecUpdField] in "GHC.Hs.Pat" and+-- Note [Disambiguating record fields] in "GHC.Tc.Gen.Head".+-- See Note [Located RdrNames] in "GHC.Hs.Expr"+data AmbiguousFieldOcc pass+  = Unambiguous (XUnambiguous pass) (LocatedN RdrName)+  | Ambiguous   (XAmbiguous pass)   (LocatedN RdrName)+  | XAmbiguousFieldOcc !(XXAmbiguousFieldOcc pass)+++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++instance Outputable HsTyLit where+    ppr = ppr_tylit+--------------------------+ppr_tylit :: HsTyLit -> SDoc+ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)+ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))+ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))

cbits/genSym.c view

@@ -2,39 +2,17 @@ #include <assert.h> #include "Unique.h" -static HsInt GenSymCounter = 0;-static HsInt GenSymInc = 1;+HsInt ghc_unique_counter = 0;+HsInt ghc_unique_inc     = 1;  #define UNIQUE_BITS (sizeof (HsInt) * 8 - UNIQUE_TAG_BITS) #define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1) -STATIC_INLINE void checkUniqueRange(HsInt u STG_UNUSED) {+HsInt genSym(void) {+    HsInt u = atomic_inc((StgWord *)&ghc_unique_counter, ghc_unique_inc) & UNIQUE_MASK; #if DEBUG     // Uh oh! We will overflow next time a unique is requested.     assert(u != UNIQUE_MASK); #endif-}--HsInt genSym(void) {-#if defined(THREADED_RTS)-    if (n_capabilities == 1) {-        GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;-        checkUniqueRange(GenSymCounter);-        return GenSymCounter;-    } else {-        HsInt n = atomic_inc((StgWord *)&GenSymCounter, GenSymInc)-          & UNIQUE_MASK;-        checkUniqueRange(n);-        return n;-    }-#else-    GenSymCounter = (GenSymCounter + GenSymInc) & UNIQUE_MASK;-    checkUniqueRange(GenSymCounter);-    return GenSymCounter;-#endif-}--void initGenSym(HsInt NewGenSymCounter, HsInt NewGenSymInc) {-  GenSymCounter = NewGenSymCounter;-  GenSymInc = NewGenSymInc;+    return u; }

ghc.cabal view

@@ -1,8 +1,9 @@ -- WARNING: ghc.cabal is automatically generated from ghc.cabal.in by -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal. +Cabal-Version: >=1.22 Name: ghc-Version: 9.0.2+Version: 9.2.1 License: BSD3 License-File: LICENSE Author: The GHC Team@@ -21,10 +22,9 @@     for more information. Category: Development Build-Type: Simple-Cabal-Version: 2.0 -Flag ghci-    Description: Build GHCi support.+Flag internal-interpreter+    Description: Build with internal interpreter support.     Default: False     Manual: True @@ -51,30 +51,31 @@ Flag dynamic-system-linker     Description: The system can load dynamic code. This is not the case for musl.     Default: True-    Manual: False+    Manual: True  Library     Default-Language: Haskell2010     Exposed: False -    Build-Depends: base       >= 4.11 && < 4.16,+    Build-Depends: base       >= 4.11 && < 4.17,                    deepseq    >= 1.4 && < 1.5,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,-                   bytestring >= 0.9 && < 0.11,+                   bytestring >= 0.9 && < 0.12,                    binary     == 0.8.*,-                   time       >= 1.4 && < 1.10,+                   time       >= 1.4 && < 1.12,                    containers >= 0.6.2.1 && < 0.7,                    array      >= 0.1 && < 0.6,                    filepath   >= 1   && < 1.5,-                   template-haskell == 2.17.*,+                   template-haskell == 2.18.*,                    hpc        == 0.6.*,                    transformers == 0.5.*,                    exceptions == 0.10.*,-                   ghc-boot   == 9.0.2,-                   ghc-boot-th == 9.0.2,-                   ghc-heap   == 9.0.2,-                   ghci == 9.0.2+                   parsec,+                   ghc-boot   == 9.2.1,+                   ghc-heap   == 9.2.1,+                   ghci == 9.2.1,+                   unbuildable < 0      if os(windows)         Build-Depends: Win32  >= 2.3 && < 2.13@@ -88,9 +89,8 @@                  -Wnoncanonical-monad-instances                  -Wnoncanonical-monoid-instances -    if flag(ghci)+    if flag(internal-interpreter)         CPP-Options: -DHAVE_INTERNAL_INTERPRETER-        -- Include-Dirs: ../rts/dist/build       -- if no dynamic system linker is available, don't try DLLs.     if flag(dynamic-system-linker)@@ -129,15 +129,6 @@     -- as it's magic.     GHC-Options: -this-unit-id ghc -    -- if flag(stage1)-    --     Include-Dirs: stage1-    -- else-    --     if flag(stage2)-    --         Include-Dirs: stage2-    --     else-    --         if flag(stage3)-    --             Include-Dirs: stage2-     Install-Includes: HsVersions.h      c-sources:@@ -153,497 +144,590 @@         NoImplicitPrelude        ,BangPatterns        ,ScopedTypeVariables+       ,MonoLocalBinds      Exposed-Modules:-        GHC.Iface.Ext.Types-        GHC.Iface.Ext.Debug-        GHC.Iface.Ext.Binary-        GHC.Iface.Ext.Utils-        GHC.Iface.Ext.Ast-        GHC.SysTools.Ar-        GHC.SysTools.FileCleanup-        GHC.Driver.Backend-        GHC.Driver.Backpack-        GHC.Driver.Backpack.Syntax-        GHC.Types.Name.Shape-        GHC.Iface.Rename-        GHC.Types.Avail-        GHC.Utils.Asm-        GHC.Types.Basic-        GHC.Core.ConLike-        GHC.Core.DataCon-        GHC.Core.PatSyn-        GHC.Types.Demand-        GHC.Types.Cpr-        GHC.Cmm.DebugBlock-        GHC.Utils.Exception-        GHC.Types.FieldLabel-        GHC.Driver.Monad-        GHC.Driver.Hooks-        GHC.Driver.Flags-        GHC.Driver.Ways-        GHC.Types.Id-        GHC.Types.Id.Info-        GHC.Core.Predicate-        GHC.Utils.Lexeme-        GHC.Types.Literal-        GHC.Llvm-        GHC.Llvm.Syntax-        GHC.Llvm.MetaData-        GHC.Llvm.Ppr-        GHC.Llvm.Types-        GHC.CmmToLlvm-        GHC.CmmToLlvm.Base-        GHC.CmmToLlvm.CodeGen-        GHC.CmmToLlvm.Data-        GHC.CmmToLlvm.Ppr-        GHC.CmmToLlvm.Regs-        GHC.CmmToLlvm.Mangler-        GHC.Types.Id.Make-        GHC.Unit-        GHC.Unit.Parser-        GHC.Unit.Ppr-        GHC.Unit.Types-        GHC.Unit.Module-        GHC.Unit.Module.Name-        GHC.Unit.Module.Location-        GHC.Unit.Module.Env-        GHC.Types.Name-        GHC.Types.Name.Env-        GHC.Types.Name.Set-        GHC.Types.Name.Occurrence-        GHC.Types.Name.Reader-        GHC.Types.Name.Cache-        GHC.Types.SrcLoc-        GHC.Types.Unique.Supply-        GHC.Types.Unique-        GHC.Types.Var-        GHC.Types.Var.Env-        GHC.Types.Var.Set-        GHC.Data.Graph.UnVar-        GHC.Cmm.BlockId-        GHC.Cmm.CLabel+        GHC+        GHC.Builtin.Names+        GHC.Builtin.Names.TH+        GHC.Builtin.PrimOps+        GHC.Builtin.Types+        GHC.Builtin.Types.Literals+        GHC.Builtin.Types.Prim+        GHC.Builtin.Uniques+        GHC.Builtin.Utils+        GHC.ByteCode.Asm+        GHC.ByteCode.InfoTable+        GHC.ByteCode.Instr+        GHC.ByteCode.Linker+        GHC.ByteCode.Types         GHC.Cmm-        GHC.Cmm.Info.Build-        GHC.Cmm.Pipeline+        GHC.Cmm.BlockId         GHC.Cmm.CallConv+        GHC.Cmm.CLabel         GHC.Cmm.CommonBlockElim-        GHC.Cmm.Switch.Implement         GHC.Cmm.ContFlowOpt+        GHC.Cmm.Dataflow+        GHC.Cmm.Dataflow.Block+        GHC.Cmm.Dataflow.Collections+        GHC.Cmm.Dataflow.Graph+        GHC.Cmm.Dataflow.Label+        GHC.Cmm.DebugBlock         GHC.Cmm.Expr+        GHC.Cmm.Graph         GHC.Cmm.Info+        GHC.Cmm.Info.Build+        GHC.Cmm.LayoutStack         GHC.Cmm.Lexer         GHC.Cmm.Lint         GHC.Cmm.Liveness         GHC.Cmm.MachOp-        GHC.Cmm.Monad-        GHC.Cmm.Switch         GHC.Cmm.Node         GHC.Cmm.Opt         GHC.Cmm.Parser+        GHC.Cmm.Parser.Monad+        GHC.Cmm.Pipeline+        GHC.Cmm.Ppr+        GHC.Cmm.Ppr.Decl+        GHC.Cmm.Ppr.Expr         GHC.Cmm.ProcPoint         GHC.Cmm.Sink-        GHC.Cmm.Type-        GHC.Cmm.Utils-        GHC.Cmm.LayoutStack-        GHC.Utils.CliOption-        GHC.Data.EnumSet-        GHC.Cmm.Graph-        GHC.CmmToAsm.Ppr+        GHC.Cmm.Switch+        GHC.Cmm.Switch.Implement+        GHC.CmmToAsm+        GHC.Cmm.LRegSet+        GHC.CmmToAsm.AArch64+        GHC.CmmToAsm.AArch64.CodeGen+        GHC.CmmToAsm.AArch64.Cond+        GHC.CmmToAsm.AArch64.Instr+        GHC.CmmToAsm.AArch64.Ppr+        GHC.CmmToAsm.AArch64.RegInfo+        GHC.CmmToAsm.AArch64.Regs+        GHC.CmmToAsm.BlockLayout+        GHC.CmmToAsm.CFG+        GHC.CmmToAsm.CFG.Dominators+        GHC.CmmToAsm.CFG.Weight         GHC.CmmToAsm.Config+        GHC.CmmToAsm.CPrim+        GHC.CmmToAsm.Dwarf+        GHC.CmmToAsm.Dwarf.Constants+        GHC.CmmToAsm.Dwarf.Types+        GHC.CmmToAsm.Format+        GHC.CmmToAsm.Instr+        GHC.CmmToAsm.Monad+        GHC.CmmToAsm.PIC+        GHC.CmmToAsm.PPC+        GHC.CmmToAsm.PPC.CodeGen+        GHC.CmmToAsm.PPC.Cond+        GHC.CmmToAsm.PPC.Instr+        GHC.CmmToAsm.PPC.Ppr+        GHC.CmmToAsm.PPC.RegInfo+        GHC.CmmToAsm.PPC.Regs+        GHC.CmmToAsm.Ppr+        GHC.CmmToAsm.Reg.Graph+        GHC.CmmToAsm.Reg.Graph.Base+        GHC.CmmToAsm.Reg.Graph.Coalesce+        GHC.CmmToAsm.Reg.Graph.Spill+        GHC.CmmToAsm.Reg.Graph.SpillClean+        GHC.CmmToAsm.Reg.Graph.SpillCost+        GHC.CmmToAsm.Reg.Graph.Stats+        GHC.CmmToAsm.Reg.Graph.TrivColorable+        GHC.CmmToAsm.Reg.Graph.X86+        GHC.CmmToAsm.Reg.Linear+        GHC.CmmToAsm.Reg.Linear.AArch64+        GHC.CmmToAsm.Reg.Linear.Base+        GHC.CmmToAsm.Reg.Linear.FreeRegs+        GHC.CmmToAsm.Reg.Linear.JoinToTargets+        GHC.CmmToAsm.Reg.Linear.PPC+        GHC.CmmToAsm.Reg.Linear.SPARC+        GHC.CmmToAsm.Reg.Linear.StackMap+        GHC.CmmToAsm.Reg.Linear.State+        GHC.CmmToAsm.Reg.Linear.Stats+        GHC.CmmToAsm.Reg.Linear.X86+        GHC.CmmToAsm.Reg.Linear.X86_64+        GHC.CmmToAsm.Reg.Liveness+        GHC.CmmToAsm.Reg.Target+        GHC.CmmToAsm.Reg.Utils+        GHC.CmmToAsm.SPARC+        GHC.CmmToAsm.SPARC.AddrMode+        GHC.CmmToAsm.SPARC.Base+        GHC.CmmToAsm.SPARC.CodeGen+        GHC.CmmToAsm.SPARC.CodeGen.Amode+        GHC.CmmToAsm.SPARC.CodeGen.Base+        GHC.CmmToAsm.SPARC.CodeGen.CondCode+        GHC.CmmToAsm.SPARC.CodeGen.Expand+        GHC.CmmToAsm.SPARC.CodeGen.Gen32+        GHC.CmmToAsm.SPARC.CodeGen.Gen64+        GHC.CmmToAsm.SPARC.CodeGen.Sanity+        GHC.CmmToAsm.SPARC.Cond+        GHC.CmmToAsm.SPARC.Imm+        GHC.CmmToAsm.SPARC.Instr+        GHC.CmmToAsm.SPARC.Ppr+        GHC.CmmToAsm.SPARC.Regs+        GHC.CmmToAsm.SPARC.ShortcutJump+        GHC.CmmToAsm.SPARC.Stack+        GHC.CmmToAsm.Types+        GHC.CmmToAsm.Utils+        GHC.CmmToAsm.X86+        GHC.CmmToAsm.X86.CodeGen+        GHC.CmmToAsm.X86.Cond+        GHC.CmmToAsm.X86.Instr+        GHC.CmmToAsm.X86.Ppr+        GHC.CmmToAsm.X86.RegInfo+        GHC.CmmToAsm.X86.Regs         GHC.CmmToC-        GHC.Cmm.Ppr-        GHC.Cmm.Ppr.Decl-        GHC.Cmm.Ppr.Expr-        GHC.Data.Bitmap-        GHC.Platform.Regs-        GHC.Platform.ARM-        GHC.Platform.AArch64-        GHC.Platform.NoRegs-        GHC.Platform.PPC-        GHC.Platform.S390X-        GHC.Platform.SPARC-        GHC.Platform.X86-        GHC.Platform.X86_64-        GHC.StgToCmm.CgUtils-        GHC.StgToCmm-        GHC.StgToCmm.Bind-        GHC.StgToCmm.Closure-        GHC.StgToCmm.DataCon-        GHC.StgToCmm.Env-        GHC.StgToCmm.Expr-        GHC.StgToCmm.Foreign-        GHC.StgToCmm.Heap-        GHC.StgToCmm.Hpc-        GHC.StgToCmm.ArgRep-        GHC.StgToCmm.Layout-        GHC.StgToCmm.Monad-        GHC.StgToCmm.Prim-        GHC.StgToCmm.Prof-        GHC.StgToCmm.Ticky-        GHC.StgToCmm.Utils-        GHC.StgToCmm.ExtCode-        GHC.StgToCmm.Types-        GHC.Runtime.Heap.Layout-        GHC.Core.Opt.Arity+        GHC.CmmToLlvm+        GHC.CmmToLlvm.Base+        GHC.CmmToLlvm.CodeGen+        GHC.CmmToLlvm.Data+        GHC.CmmToLlvm.Mangler+        GHC.CmmToLlvm.Ppr+        GHC.CmmToLlvm.Regs+        GHC.Cmm.Type+        GHC.Cmm.Utils+        GHC.Core+        GHC.Core.Class+        GHC.Core.Coercion+        GHC.Core.Coercion.Axiom+        GHC.Core.Coercion.Opt+        GHC.Core.ConLike+        GHC.Core.DataCon+        GHC.Core.FamInstEnv         GHC.Core.FVs+        GHC.Core.InstEnv         GHC.Core.Lint-        GHC.Core.Subst+        GHC.Core.Make+        GHC.Core.Map.Expr+        GHC.Core.Map.Type+        GHC.Core.Multiplicity+        GHC.Core.Opt.Arity+        GHC.Core.Opt.CallArity+        GHC.Core.Opt.CallerCC+        GHC.Core.Opt.ConstantFold+        GHC.Core.Opt.CprAnal+        GHC.Core.Opt.CSE+        GHC.Core.Opt.DmdAnal+        GHC.Core.Opt.Exitify+        GHC.Core.Opt.FloatIn+        GHC.Core.Opt.FloatOut+        GHC.Core.Opt.LiberateCase+        GHC.Core.Opt.Monad+        GHC.Core.Opt.OccurAnal+        GHC.Core.Opt.Pipeline+        GHC.Core.Opt.SetLevels+        GHC.Core.Opt.Simplify+        GHC.Core.Opt.Simplify.Env+        GHC.Core.Opt.Simplify.Monad+        GHC.Core.Opt.Simplify.Utils+        GHC.Core.Opt.SpecConstr+        GHC.Core.Opt.Specialise+        GHC.Core.Opt.StaticArgs+        GHC.Core.Opt.WorkWrap+        GHC.Core.Opt.WorkWrap.Utils+        GHC.Core.PatSyn+        GHC.Core.Ppr+        GHC.Types.TyThing.Ppr+        GHC.Core.Predicate+        GHC.Core.Rules+        GHC.Core.Seq         GHC.Core.SimpleOpt-        GHC.Core-        GHC.Data.TrieMap+        GHC.Core.Stats+        GHC.Core.Subst         GHC.Core.Tidy+        GHC.CoreToIface+        GHC.CoreToStg+        GHC.CoreToStg.Prep+        GHC.Core.TyCo.FVs+        GHC.Core.TyCon+        GHC.Core.TyCon.Env+        GHC.Core.TyCon.RecWalk+        GHC.Core.TyCon.Set+        GHC.Core.TyCo.Ppr+        GHC.Core.TyCo.Rep+        GHC.Core.TyCo.Subst+        GHC.Core.TyCo.Tidy+        GHC.Core.Type         GHC.Core.Unfold+        GHC.Core.Unfold.Make+        GHC.Core.Unify+        GHC.Core.UsageEnv         GHC.Core.Utils-        GHC.Core.Map-        GHC.Core.Seq-        GHC.Core.Stats-        GHC.Core.Make-        GHC.Core.Ppr-        GHC.HsToCore.PmCheck.Oracle-        GHC.HsToCore.PmCheck.Ppr-        GHC.HsToCore.PmCheck.Types-        GHC.HsToCore.PmCheck-        GHC.HsToCore.Coverage+        GHC.Data.Bag+        GHC.Data.Bitmap+        GHC.Data.BooleanFormula+        GHC.Data.EnumSet+        GHC.Data.FastMutInt+        GHC.Data.FastString+        GHC.Data.FastString.Env+        GHC.Data.FiniteMap+        GHC.Data.Graph.Base+        GHC.Data.Graph.Color+        GHC.Data.Graph.Directed+        GHC.Data.Graph.Ops+        GHC.Data.Graph.Ppr+        GHC.Data.Graph.UnVar+        GHC.Data.IOEnv+        GHC.Data.List.SetOps+        GHC.Data.Maybe+        GHC.Data.OrdList+        GHC.Data.Pair+        GHC.Data.Stream+        GHC.Data.StringBuffer+        GHC.Data.TrieMap         GHC.Data.UnionFind+        GHC.Driver.Backend+        GHC.Driver.Backpack+        GHC.Driver.Backpack.Syntax+        GHC.Driver.CmdLine+        GHC.Driver.CodeOutput+        GHC.Driver.Config+        GHC.Driver.Env+        GHC.Driver.Env.Types+        GHC.Driver.Errors+        GHC.Driver.Flags+        GHC.Driver.Hooks+        GHC.Driver.Main+        GHC.Driver.Make+        GHC.Driver.MakeFile+        GHC.Driver.Monad+        GHC.Driver.Phases+        GHC.Driver.Pipeline+        GHC.Driver.Pipeline.Monad+        GHC.Driver.Plugins+        GHC.Driver.Ppr+        GHC.Driver.Session+        GHC.Hs+        GHC.Hs.Binds+        GHC.Hs.Decls+        GHC.Hs.Doc+        GHC.Hs.Dump+        GHC.Hs.Expr+        GHC.Hs.Extension+        GHC.Hs.ImpExp+        GHC.Hs.Instances+        GHC.Hs.Lit+        GHC.Hs.Pat+        GHC.Hs.Stats         GHC.HsToCore         GHC.HsToCore.Arrows         GHC.HsToCore.Binds-        GHC.HsToCore.Foreign.Call+        GHC.HsToCore.Coverage+        GHC.HsToCore.Docs         GHC.HsToCore.Expr+        GHC.HsToCore.Foreign.Call         GHC.HsToCore.Foreign.Decl         GHC.HsToCore.GuardedRHSs         GHC.HsToCore.ListComp-        GHC.HsToCore.Monad-        GHC.HsToCore.Usage-        GHC.HsToCore.Utils-        GHC.HsToCore.Docs         GHC.HsToCore.Match         GHC.HsToCore.Match.Constructor         GHC.HsToCore.Match.Literal-        GHC.Hs-        GHC.Hs.Binds-        GHC.Hs.Decls-        GHC.Hs.Doc-        GHC.Hs.Expr-        GHC.Hs.ImpExp-        GHC.Hs.Lit-        GHC.Hs.Extension-        GHC.Hs.Instances-        GHC.Hs.Pat+        GHC.HsToCore.Monad+        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.Hs.Type         GHC.Hs.Utils-        GHC.Hs.Dump         GHC.Iface.Binary-        GHC.Iface.Recomp.Binary-        GHC.Tc.TyCl.Build         GHC.Iface.Env-        GHC.Iface.Syntax-        GHC.Iface.Type-        GHC.CoreToIface+        GHC.Iface.Ext.Ast+        GHC.Iface.Ext.Binary+        GHC.Iface.Ext.Debug+        GHC.Iface.Ext.Fields+        GHC.Iface.Ext.Types+        GHC.Iface.Ext.Utils         GHC.Iface.Load         GHC.Iface.Make         GHC.Iface.Recomp-        GHC.IfaceToCore+        GHC.Iface.Recomp.Binary         GHC.Iface.Recomp.Flags-        GHC.Types.Annotations-        GHC.Driver.CmdLine-        GHC.Driver.CodeOutput-        GHC.Settings.Constants-        GHC.Driver.MakeFile-        GHC.Driver.Phases-        GHC.Driver.Pipeline.Monad-        GHC.Driver.Pipeline-        GHC.Driver.Session-        GHC.Utils.Error-        GHC.Driver.Finder-        GHC-        GHC.Driver.Make-        GHC.Plugins-        GHC.Prelude-        GHC.Parser.Header-        GHC.Driver.Main-        GHC.Hs.Stats-        GHC.Driver.Types-        GHC.Runtime.Eval-        GHC.Runtime.Eval.Types-        GHC.Runtime.Loader-        GHC.Unit.Info-        GHC.Unit.State-        GHC.Driver.Plugins-        GHC.Tc.Plugin-        GHC.Core.Ppr.TyThing-        GHC.Settings-        GHC.Iface.Tidy.StaticPtrTable-        GHC.SysTools-        GHC.SysTools.BaseDir-        GHC.SysTools.Terminal-        GHC.SysTools.ExtraObj-        GHC.SysTools.Info-        GHC.SysTools.Process-        GHC.SysTools.Tasks-        GHC.Settings.IO-        GHC.SysTools.Elf+        GHC.Iface.Rename+        GHC.Iface.Syntax         GHC.Iface.Tidy+        GHC.Iface.Tidy.StaticPtrTable+        GHC.IfaceToCore+        GHC.Iface.Type+        GHC.Iface.UpdateIdInfos+        GHC.Linker+        GHC.Linker.Dynamic+        GHC.Linker.ExtraObj+        GHC.Linker.Loader+        GHC.Linker.MacOS+        GHC.Linker.Static+        GHC.Linker.Types+        GHC.Linker.Unit+        GHC.Linker.Windows+        GHC.Llvm+        GHC.Llvm.MetaData+        GHC.Llvm.Ppr+        GHC.Llvm.Syntax+        GHC.Llvm.Types+        GHC.Parser+        GHC.Parser.Annotation         GHC.Parser.CharClass+        GHC.Parser.Errors+        GHC.Parser.Errors.Ppr+        GHC.Parser.Header         GHC.Parser.Lexer-        GHC.Core.Coercion.Opt-        GHC.Parser         GHC.Parser.PostProcess         GHC.Parser.PostProcess.Haddock-        GHC.Parser.Annotation-        GHC.Types.ForeignCall-        GHC.Builtin.Uniques-        GHC.Builtin.Utils-        GHC.Builtin.Names-        GHC.Core.Opt.ConstantFold-        GHC.Builtin.PrimOps-        GHC.Builtin.RebindableNames-        GHC.Builtin.Types.Prim-        GHC.Builtin.Types-        GHC.Types.CostCentre-        GHC.Types.CostCentre.State+        GHC.Parser.Types+        GHC.Parser.Utils+        GHC.Platform+        GHC.Platform.ARM+        GHC.Platform.AArch64+        GHC.Platform.Constants+        GHC.Platform.NoRegs+        GHC.Platform.PPC+        GHC.Platform.Profile+        GHC.Platform.Reg+        GHC.Platform.Reg.Class+        GHC.Platform.Regs+        GHC.Platform.RISCV64+        GHC.Platform.S390X+        GHC.Platform.SPARC+        GHC.Platform.Ways+        GHC.Platform.X86+        GHC.Platform.X86_64+        GHC.Plugins+        GHC.Prelude         GHC.Rename.Bind         GHC.Rename.Env         GHC.Rename.Expr-        GHC.Rename.Doc+        GHC.Rename.Fixity+        GHC.Rename.HsType+        GHC.Rename.Module         GHC.Rename.Names         GHC.Rename.Pat-        GHC.Rename.Module         GHC.Rename.Splice-        GHC.Rename.HsType-        GHC.Rename.Fixity-        GHC.Rename.Utils         GHC.Rename.Unbound-        GHC.Core.Opt.Monad-        GHC.Core.Opt.CSE-        GHC.Core.Opt.FloatIn-        GHC.Core.Opt.FloatOut-        GHC.Core.Opt.LiberateCase-        GHC.Core.Opt.OccurAnal-        GHC.Core.Opt.StaticArgs-        GHC.Core.Opt.SetLevels-        GHC.Core.Opt.Pipeline-        GHC.Core.Opt.Simplify.Env-        GHC.Core.Opt.Simplify.Monad-        GHC.Core.Opt.Simplify.Utils-        GHC.Core.Opt.Simplify-        GHC.Stg.Pipeline-        GHC.Stg.Stats+        GHC.Rename.Utils+        GHC.Runtime.Context+        GHC.Runtime.Debugger+        GHC.Runtime.Eval+        GHC.Runtime.Eval.Types+        GHC.Runtime.Heap.Inspect+        GHC.Runtime.Heap.Layout+        GHC.Runtime.Interpreter+        GHC.Runtime.Interpreter.Types+        GHC.Runtime.Loader+        GHC.Settings+        GHC.Settings.Config+        GHC.Settings.Constants+        GHC.Settings.IO         GHC.Stg.CSE+        GHC.Stg.Debug+        GHC.Stg.DepAnal+        GHC.Stg.FVs         GHC.Stg.Lift         GHC.Stg.Lift.Analysis         GHC.Stg.Lift.Monad-        GHC.Stg.Subst-        GHC.Stg.Unarise         GHC.Stg.Lint+        GHC.Stg.Pipeline+        GHC.Stg.Stats+        GHC.Stg.Subst         GHC.Stg.Syntax-        GHC.Stg.FVs-        GHC.Stg.DepAnal-        GHC.CoreToStg-        GHC.CoreToStg.Prep-        GHC.Types.RepType-        GHC.Core.Rules-        GHC.Core.Opt.SpecConstr-        GHC.Core.Opt.Specialise-        GHC.Core.Opt.CallArity-        GHC.Core.Opt.DmdAnal-        GHC.Core.Opt.CprAnal-        GHC.Core.Opt.Exitify-        GHC.Core.Opt.WorkWrap-        GHC.Core.Opt.WorkWrap.Utils-        GHC.Tc.Instance.Family-        GHC.Tc.Instance.Class-        GHC.Tc.Utils.Instantiate+        GHC.StgToByteCode+        GHC.StgToCmm+        GHC.StgToCmm.ArgRep+        GHC.StgToCmm.Bind+        GHC.StgToCmm.CgUtils+        GHC.StgToCmm.Closure+        GHC.StgToCmm.DataCon+        GHC.StgToCmm.Env+        GHC.StgToCmm.Expr+        GHC.StgToCmm.ExtCode+        GHC.StgToCmm.Foreign+        GHC.StgToCmm.Heap+        GHC.StgToCmm.Hpc+        GHC.StgToCmm.Layout+        GHC.StgToCmm.Monad+        GHC.StgToCmm.Prim+        GHC.StgToCmm.Prof+        GHC.StgToCmm.Ticky+        GHC.StgToCmm.Types+        GHC.StgToCmm.Utils+        GHC.Stg.Unarise+        GHC.SysTools+        GHC.SysTools.Ar+        GHC.SysTools.BaseDir+        GHC.SysTools.Elf+        GHC.SysTools.Info+        GHC.SysTools.Process+        GHC.SysTools.Tasks+        GHC.SysTools.Terminal+        GHC.Tc.Deriv+        GHC.Tc.Deriv.Functor+        GHC.Tc.Deriv.Generate+        GHC.Tc.Deriv.Generics+        GHC.Tc.Deriv.Infer+        GHC.Tc.Deriv.Utils+        GHC.Tc.Errors+        GHC.Tc.Errors.Hole+        GHC.Tc.Errors.Hole.FitTypes         GHC.Tc.Gen.Annotation+        GHC.Tc.Gen.App         GHC.Tc.Gen.Arrow         GHC.Tc.Gen.Bind-        GHC.Tc.Gen.Sig-        GHC.Tc.TyCl.Class         GHC.Tc.Gen.Default-        GHC.Tc.Deriv-        GHC.Tc.Deriv.Infer-        GHC.Tc.Deriv.Utils-        GHC.Tc.Utils.Env+        GHC.Tc.Gen.Export         GHC.Tc.Gen.Expr         GHC.Tc.Gen.Foreign-        GHC.Tc.Deriv.Generate-        GHC.Tc.Deriv.Functor-        GHC.Tc.Deriv.Generics-        GHC.Tc.Utils.Zonk-        GHC.Tc.Utils.TcType-        GHC.Tc.TyCl.Instance-        GHC.Tc.Utils.TcMType-        GHC.Tc.Validity+        GHC.Tc.Gen.Head+        GHC.Tc.Gen.HsType         GHC.Tc.Gen.Match         GHC.Tc.Gen.Pat-        GHC.Tc.TyCl.PatSyn-        GHC.Tc.Module-        GHC.Tc.Utils.Backpack-        GHC.Tc.Gen.Export-        GHC.Tc.Utils.Monad-        GHC.Tc.Types-        GHC.Tc.Types.Constraint-        GHC.Tc.Types.Origin         GHC.Tc.Gen.Rule-        GHC.Tc.Errors.Hole-        GHC.Tc.Errors.Hole.FitTypes-        GHC.Tc.Errors+        GHC.Tc.Gen.Sig+        GHC.Tc.Gen.Splice+        GHC.Tc.Instance.Class+        GHC.Tc.Instance.Family+        GHC.Tc.Instance.FunDeps+        GHC.Tc.Instance.Typeable+        GHC.Tc.Module+        GHC.Tc.Plugin+        GHC.Tc.Solver+        GHC.Tc.Solver.Canonical+        GHC.Tc.Solver.Rewrite+        GHC.Tc.Solver.Interact+        GHC.Tc.Solver.Monad         GHC.Tc.TyCl+        GHC.Tc.TyCl.Build+        GHC.Tc.TyCl.Class+        GHC.Tc.TyCl.Instance+        GHC.Tc.TyCl.PatSyn         GHC.Tc.TyCl.Utils-        GHC.Tc.Instance.Typeable-        GHC.Tc.Gen.HsType+        GHC.Tc.Types+        GHC.Tc.Types.Constraint         GHC.Tc.Types.Evidence         GHC.Tc.Types.EvTerm+        GHC.Tc.Types.Origin+        GHC.Tc.Utils.Backpack+        GHC.Tc.Utils.Env+        GHC.Tc.Utils.Instantiate+        GHC.Tc.Utils.Monad+        GHC.Tc.Utils.TcMType+        GHC.Tc.Utils.TcType         GHC.Tc.Utils.Unify-        GHC.Tc.Solver-        GHC.Tc.Solver.Interact-        GHC.Tc.Solver.Canonical-        GHC.Tc.Solver.Flatten-        GHC.Tc.Solver.Monad-        GHC.Builtin.Types.Literals-        GHC.Tc.Gen.Splice-        GHC.Core.Class-        GHC.Core.Coercion-        GHC.HsToCore.Quote-        GHC.Builtin.Names.TH-        GHC.Core.FamInstEnv-        GHC.Tc.Instance.FunDeps-        GHC.Core.InstEnv-        GHC.Core.Multiplicity-        GHC.Core.UsageEnv-        GHC.Core.TyCon-        GHC.Core.Coercion.Axiom-        GHC.Core.Type-        GHC.Core.TyCo.Rep-        GHC.Core.TyCo.FVs-        GHC.Core.TyCo.Subst-        GHC.Core.TyCo.Ppr-        GHC.Core.TyCo.Tidy-        GHC.Core.Unify-        GHC.Data.Bag+        GHC.Tc.Utils.Zonk+        GHC.Tc.Validity+        GHC.ThToHs+        GHC.Types.Annotations+        GHC.Types.Avail+        GHC.Types.Basic+        GHC.Types.CompleteMatch+        GHC.Types.CostCentre+        GHC.Types.CostCentre.State+        GHC.Types.Cpr+        GHC.Types.Demand+        GHC.Types.Error+        GHC.Types.FieldLabel+        GHC.Types.Fixity+        GHC.Types.Fixity.Env+        GHC.Types.ForeignCall+        GHC.Types.ForeignStubs+        GHC.Types.HpcInfo+        GHC.Types.Id+        GHC.Types.IPE+        GHC.Types.Id.Info+        GHC.Types.Id.Make+        GHC.Types.Literal+        GHC.Types.Meta+        GHC.Types.Name+        GHC.Types.Name.Cache+        GHC.Types.Name.Env+        GHC.Types.Name.Occurrence+        GHC.Types.Name.Reader+        GHC.Types.Name.Set+        GHC.Types.Name.Shape+        GHC.Types.Name.Ppr+        GHC.Types.RepType+        GHC.Types.SafeHaskell+        GHC.Types.SourceError+        GHC.Types.SourceFile+        GHC.Types.SourceText+        GHC.Types.SrcLoc+        GHC.Types.Target+        GHC.Types.Tickish+        GHC.Types.TypeEnv+        GHC.Types.TyThing+        GHC.Types.Unique+        GHC.Types.Unique.DFM+        GHC.Types.Unique.DSet+        GHC.Types.Unique.FM+        GHC.Types.Unique.Map+        GHC.Types.Unique.SDFM+        GHC.Types.Unique.Set+        GHC.Types.Unique.Supply+        GHC.Types.Var+        GHC.Types.Var.Env+        GHC.Types.Var.Set+        GHC.Unit+        GHC.Unit.Env+        GHC.Unit.External+        GHC.Unit.Finder+        GHC.Unit.Finder.Types+        GHC.Unit.Home+        GHC.Unit.Home.ModInfo+        GHC.Unit.Info+        GHC.Unit.Module+        GHC.Unit.Module.Deps+        GHC.Unit.Module.Env+        GHC.Unit.Module.Graph+        GHC.Unit.Module.Imported+        GHC.Unit.Module.Location+        GHC.Unit.Module.ModDetails+        GHC.Unit.Module.ModGuts+        GHC.Unit.Module.ModIface+        GHC.Unit.Module.ModSummary+        GHC.Unit.Module.Name+        GHC.Unit.Module.Status+        GHC.Unit.Module.Warnings+        GHC.Unit.Parser+        GHC.Unit.Ppr+        GHC.Unit.State+        GHC.Unit.Types+        GHC.Utils.Asm         GHC.Utils.Binary-        GHC.Data.BooleanFormula+        GHC.Utils.Binary.Typeable         GHC.Utils.BufHandle-        GHC.Data.Graph.Directed-        GHC.Utils.Encoding-        GHC.Utils.IO.Unsafe-        GHC.Data.FastMutInt-        GHC.Data.FastString-        GHC.Data.FastString.Env+        GHC.Utils.CliOption+        GHC.Utils.Error+        GHC.Utils.Exception         GHC.Utils.Fingerprint-        GHC.Data.FiniteMap         GHC.Utils.FV-        GHC.Data.Graph.Base-        GHC.Data.Graph.Color-        GHC.Data.Graph.Ops-        GHC.Data.Graph.Ppr-        GHC.Data.IOEnv+        GHC.Utils.GlobalVars+        GHC.Utils.IO.Unsafe         GHC.Utils.Json-        GHC.Data.List.SetOps-        GHC.Data.Maybe+        GHC.Utils.Lexeme+        GHC.Utils.Logger+        GHC.Utils.Misc         GHC.Utils.Monad-        GHC.Data.OrdList+        GHC.Utils.Monad.State         GHC.Utils.Outputable-        GHC.Data.Pair         GHC.Utils.Panic         GHC.Utils.Panic.Plain-        GHC.Utils.Ppr.Colour         GHC.Utils.Ppr-        GHC.Utils.Monad.State-        GHC.Data.Stream-        GHC.Data.StringBuffer-        GHC.Types.Unique.DFM-        GHC.Types.Unique.DSet-        GHC.Types.Unique.FM-        GHC.Types.Unique.Set-        GHC.Utils.Misc-        GHC.Cmm.Dataflow-        GHC.Cmm.Dataflow.Block-        GHC.Cmm.Dataflow.Collections-        GHC.Cmm.Dataflow.Graph-        GHC.Cmm.Dataflow.Label-        GHC.Settings.Config+        GHC.Utils.Ppr.Colour+        GHC.Utils.TmpFs -    autogen-modules: GHC.Settings.Config+        Language.Haskell.Syntax+        Language.Haskell.Syntax.Binds+        Language.Haskell.Syntax.Decls+        Language.Haskell.Syntax.Expr+        Language.Haskell.Syntax.Extension+        Language.Haskell.Syntax.Lit+        Language.Haskell.Syntax.Pat+        Language.Haskell.Syntax.Type -    Exposed-Modules:-            GHC.CmmToAsm-            GHC.CmmToAsm.Reg.Target-            GHC.CmmToAsm.Monad-            GHC.CmmToAsm.Instr-            GHC.CmmToAsm.BlockLayout-            GHC.CmmToAsm.CFG-            GHC.CmmToAsm.CFG.Dominators-            GHC.CmmToAsm.Format-            GHC.Platform.Reg-            GHC.Platform.Reg.Class-            GHC.CmmToAsm.PIC-            GHC.CmmToAsm.CPrim-            GHC.CmmToAsm.X86.Regs-            GHC.CmmToAsm.X86.RegInfo-            GHC.CmmToAsm.X86.Instr-            GHC.CmmToAsm.X86.Cond-            GHC.CmmToAsm.X86.Ppr-            GHC.CmmToAsm.X86.CodeGen-            GHC.CmmToAsm.PPC.Regs-            GHC.CmmToAsm.PPC.RegInfo-            GHC.CmmToAsm.PPC.Instr-            GHC.CmmToAsm.PPC.Cond-            GHC.CmmToAsm.PPC.Ppr-            GHC.CmmToAsm.PPC.CodeGen-            GHC.CmmToAsm.SPARC.Base-            GHC.CmmToAsm.SPARC.Regs-            GHC.CmmToAsm.SPARC.Imm-            GHC.CmmToAsm.SPARC.AddrMode-            GHC.CmmToAsm.SPARC.Cond-            GHC.CmmToAsm.SPARC.Instr-            GHC.CmmToAsm.SPARC.Stack-            GHC.CmmToAsm.SPARC.ShortcutJump-            GHC.CmmToAsm.SPARC.Ppr-            GHC.CmmToAsm.SPARC.CodeGen-            GHC.CmmToAsm.SPARC.CodeGen.Amode-            GHC.CmmToAsm.SPARC.CodeGen.Base-            GHC.CmmToAsm.SPARC.CodeGen.CondCode-            GHC.CmmToAsm.SPARC.CodeGen.Gen32-            GHC.CmmToAsm.SPARC.CodeGen.Gen64-            GHC.CmmToAsm.SPARC.CodeGen.Sanity-            GHC.CmmToAsm.SPARC.CodeGen.Expand-            GHC.CmmToAsm.Reg.Liveness-            GHC.CmmToAsm.Reg.Graph-            GHC.CmmToAsm.Reg.Graph.Stats-            GHC.CmmToAsm.Reg.Graph.Base-            GHC.CmmToAsm.Reg.Graph.X86-            GHC.CmmToAsm.Reg.Graph.Coalesce-            GHC.CmmToAsm.Reg.Graph.Spill-            GHC.CmmToAsm.Reg.Graph.SpillClean-            GHC.CmmToAsm.Reg.Graph.SpillCost-            GHC.CmmToAsm.Reg.Graph.TrivColorable-            GHC.CmmToAsm.Reg.Linear-            GHC.CmmToAsm.Reg.Linear.JoinToTargets-            GHC.CmmToAsm.Reg.Linear.State-            GHC.CmmToAsm.Reg.Linear.Stats-            GHC.CmmToAsm.Reg.Linear.FreeRegs-            GHC.CmmToAsm.Reg.Linear.StackMap-            GHC.CmmToAsm.Reg.Linear.Base-            GHC.CmmToAsm.Reg.Linear.X86-            GHC.CmmToAsm.Reg.Linear.X86_64-            GHC.CmmToAsm.Reg.Linear.PPC-            GHC.CmmToAsm.Reg.Linear.SPARC-            GHC.CmmToAsm.Reg.Utils-            GHC.CmmToAsm.Dwarf-            GHC.CmmToAsm.Dwarf.Types-            GHC.CmmToAsm.Dwarf.Constants-            GHC.ThToHs-            GHC.ByteCode.Types-            GHC.ByteCode.Asm-            GHC.ByteCode.Instr-            GHC.ByteCode.InfoTable-            GHC.ByteCode.Linker-            GHC.CoreToByteCode-            GHC.Runtime.Debugger-            GHC.Runtime.Linker.Types-            GHC.Runtime.Linker-            GHC.Runtime.Heap.Inspect-            GHC.Runtime.Interpreter-            GHC.Runtime.Interpreter.Types+    reexported-modules:+          GHC.Platform.ArchOS+        , GHC.Platform.Host